betza wip 2

(defclass infinite-range ()
  ((x-increment
    :initarg :x-increment
    :initform 0)
   (y-increment
    :initarg :y-increment
    :initform 0)
   (x-start
    :initarg :x-start
    :initform 0)
   (y-start
    :initarg :y-start
    :initform 0)))

(defmethod print-object ((object infinite-range) stream)
  (print-unreadable-object (object stream :type t)
    (with-slots (x-increment y-increment) object
      (flet ((multiples (number)
           (cond
         ((= number -1) (format nil "-n"))
         ((= number  0) (format nil "0"))
         ((= number  1) (format nil "n"))
         (t             (format nil "~dn" number)))))
    (format stream "~a, ~a" (multiples x-increment) (multiples y-increment))))))

(defgeneric infinite-range= (range-1 range-2)
  (:documentation "Checks if two infinite ranges are congruent, or if a cell is included in a destination"))

(defmethod infinite-range= ((range-1 infinite-range) (range-2 infinite-range))
  (and (= (slot-value range-1 'x-increment) (slot-value range-2 'x-increment))
       (= (slot-value range-1 'y-increment) (slot-value range-2 'y-increment))))

(defmethod infinite-range= ((range-1 cons) (range-2 infinite-range))
  (with-slots (x-increment y-increment) range-2
    ; for cell (a, b) in range (pn, qn)
    ; (a, b) is in (pn, qn)
    ; if any of these are true:
    ;   a = b = p = q = 0
    ;   a = p = 0 and b mod q = 0 and b/q > 0
    ;   b = q = 0 and a mod p = 0 and a/p > 0
    ;   None of a, b, p or q = 0 and a mod p = 0 and b mod q = 0 and a/p = b/q and a/p > 0 and b/q > 0
    (let ((p x-increment)
      (q y-increment)
      (a (car range-1))
      (b (cdr range-1)))
      (or
       (= a b p q 0)
       (and (= a p 0) (zerop (mod b q)) (plusp (/ b q)))
       (and (= b q 0) (zerop (mod a p)) (plusp (/ a p)))
       (and (not (zerop a))
        (not (zerop b))
        (not (zerop p))
        (not (zerop q))
        (zerop (mod a p))
        (zerop (mod b q))
        (plusp (/ a p))
        (plusp (/ b q))
        (= (/ a p) (/ b q)))))))

(defmethod infinite-range= ((range-1 infinite-range) (range-2 cons))
  ; same as above function, just with the arguments swapped.
  (infinite-range= range-2 range-1))

(defmethod infinite-range= ((range-1 cons) (range-2 cons))
  (equal range-1 range-2))


(defgeneric retrieve-rider-squares (number infinite-range)
  (:documentation "Retrieves the first <number> of squares in the square visit sequence of <object infinite-range>."))

;---

(defun rook (&key (length :infinity) (directions '(:forward :backward :left :right)))
  "Lists all possible destinations of a Rook.
   Represents infinite-range moves as :n and :-n.
   Betza equivalent /f?r?l?b?R[0-9]*/"
  (if (eql length :infinity)
      ;; Infinite-length items use the infinite-range class
      (loop
     for dir     in '(:forward :backward :left     :right)
     for vectors in '((0 . 1)  (0 . -1)  (-1 . 0)  (1 . 0))
     if (member dir directions)
     collect (make-instance 'infinite-range :x-increment (car vectors) :y-increment (cdr vectors)))
      ;; Otherwise list them all.
      (loop for dir in directions
     for horizontal =     (member dir '(:forward :backward))
     for relative   = (if (member dir '(:left :backward))    -1 1)
     append (loop for i from 1 to length
            collect (if horizontal
                (cons 0 (* i relative))
                (cons (* i relative) 0))))))

(defun bishop (&key (length :infinity) (directions '(:forward :backward :left :right)))
  "Lists all possible destinations of a Bishop.
   Represents infinite-range moves as :n and :-n.
   Betza equivalent /\[[fb]?[rl]?\]B[0-9]*/"
  (flet ((diagonal-directions (dirs)
       (remove-duplicates
        (loop
           for dir in dirs
           appending (cond
               ((eql dir :forward ) (list :ne :nw))
               ((eql dir :backward) (list :se :sw))
               ((eql dir :left)     (list :nw :sw))
               ((eql dir :right)    (list :ne :se))
               ((member dir (list :ne :se :sw :nw)) (list dir))
               (t nil))))))
    (if (eql length :infinity)
    (loop
       for dir     in '(:ne :se :sw :nw)
       for vectors in '((1 . 1) (1 . -1) (-1 . -1) (-1 . 1))
       if (member dir (diagonal-directions directions))
       collect (make-instance 'infinite-range :x-increment (car vectors) :y-increment (cdr vectors)))
    (loop
          with calculated-dirs = (diagonal-directions directions)
          for dirs in (list :ne :se :sw :nw)
          for mult-x = (if (member dirs '(:nw :sw)) -1 1)
          for mult-y = (if (member dirs '(:se :sw)) -1 1)
          append (when (member dirs calculated-dirs)
               (loop for i from 1 to length collect (cons (* mult-x i) (* mult-y i))))))))

(defun hippo (long-side short-side &key (length 1) (directions '(:forward :backward)))
  (flet ((permute (a b)
       (let ((large (max a b))
         (small (min a b)))
           (list (list :ffr (+ small) (+ large))
             (list :fsr (+ large) (+ small))
             (list :bsr (+ large) (- small))
             (list :bbr (+ small) (- large))
             (list :bbl (- small) (- large))
             (list :bsl (- large) (- small))
             (list :fsl (- large) (+ small))
             (list :ffl (- small) (+ large)))))
     (decode-hippogonals (dirs)
       (remove-duplicates
        (loop
           for dir in dirs
           appending (cond
               ((eql :forward  dir) (list :ffl :ffr :fsl :fsr))
               ((eql :backward dir) (list :bbl :bbr :bsl :bsr))
               ((eql :left     dir) (list :ffl :fsl :bsl :bbl))
               ((eql :right    dir) (list :ffr :fsr :bsr :bbr))
               ((eql :fb dir)       (list :ffl :ffr :bbl :bbr))
               ((eql :rl dir)       (list :fsl :bsl :fsr :bsr))
               ((eql :ff dir)       (list :ffl :ffr))
               ((eql :fs dir)       (list :fsl :fsr))
               ((eql :bs dir)       (list :bsl :bsr))
               ((eql :bb dir)       (list :bbl :bbr))
               ((eql :rr dir)       (list :fsr :bsr))
               ((eql :rv dir)       (list :ffr :bbr))
               ((eql :ll dir)       (list :fsl :bsl))
               ((eql :lv dir)       (list :ffl :bbl))
               ((member dir '(:ffl :fsl :bsl :bbl :bbr :bsr :fsr :ffr)) (list dir))
               (t nil))))))
    (remove-duplicates
     (if (eql length :infinity)
     (loop
        with selected-directions = (decode-hippogonals directions)
        for every-direction in (permute long-side short-side)
        if (member (first every-direction) selected-directions)
        collect (make-instance 'infinite-range
                   :x-increment (second every-direction)
                   :y-increment (third every-direction)))
     (loop
        with selected-directions = (decode-hippogonals directions)
        for every-direction in (permute long-side short-side)
        if (member (first every-direction) selected-directions)
        append (loop for i from 1 to length
              collecting (cons (* i (second every-direction))
                       (* i (third  every-direction))))))
     :test #'infinite-range=)))

; a handful of utility functions that just help with defining chess pieces
(defun queen (&key (length :infinity) (directions '(:forward :backward :left :right)))
  (combine (rook :length length :directions directions) (bishop :length length :directions directions)))

(defmacro defleaper (name long-side short-side)
  `(defun ,name (&key (directions '(:forward :backward :left :right)) (length 1))
     (hippo ,long-side ,short-side :length length :directions directions)))

(defun king     (&key (directions '(:forward :backward :left :right))) (queen  :length 1 :directions directions))
(defun wazir    (&key (directions '(:forward :backward :left :right))) (rook   :length 1 :directions directions))
(defun ferz     (&key (directions '(:forward :backward :left :right))) (bishop :length 1 :directions directions))
(defleaper knight   2 1)
(defleaper camel    3 1)
(defleaper zebra    3 2)
(defleaper dabbabah 2 0)
(defleaper HLeaper  3 0)
(defleaper alfil    2 2)
(defleaper GLeaper  3 3)

; Combine two movesets with these
(defun combine (&rest destination-squares)
  (remove-duplicates
   (arrange-destinations (apply #'append destination-squares))
   :test #'infinite-range=))

(defun arrange-destinations (destination-squares)
  (flet ((min-coords (p q)
       (if (= (car p) (car q))
           (< (cdr p) (cdr q))
           (< (car p) (car q)))))
    (concatenate 'list
         (sort (remove-if-not #'(lambda (x) (eql (type-of x) 'cons)) destination-squares) #'min-coords)
         (sort (remove-if-not #'(lambda (x) (eql (type-of x) 'infinite-range)) destination-squares)
               #'(lambda (m n) (min-coords (cons (slot-value m 'x-increment) (slot-value m 'y-increment))
                           (cons (slot-value n 'x-increment) (slot-value n 'y-increment))))))))