betza wip 3

;;;; Betza Notation

;;; ========
;;; Classes
;;; ========

;; Range
;; ======
;; Range moves are moves that repeat themselves. For instance

(defclass range ()
  ((base-vector :initarg :destination
        :initform '(0 . 0)
        :reader base-vector)
   (length :initarg :max-steps
       :initform :infinite
       :reader max-steps)))

(defmethod print-object ((object range) stream)
  (print-unreadable-object (object stream :type t)
    (with-slots (base-vector length) object
      (flet ((multiplier (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 --|~a"
        (multiplier (car base-vector))
        (multiplier (cdr base-vector))
        length)))))

(defgeneric range= (range-1 range-2)
  (:documentation "Checks if two ranges are equal."))

(defmethod range= ((range-1 range) (range-2 range))
  (with-slots ((base-vector-1 base-vector) (length-1 length)) range-1
    (with-slots ((base-vector-2 base-vector) (length-2 length)) range-2
      (and (equal base-vector-1 base-vector-2)
       (= length-1 length-2)))))

(defgeneric range-include (range-or-single-square range-2)
  (:documentation "Checks if one range completely eclipses another, or if a single-square is included in a range"))

(defmethod range-include ((range-or-single-square range) (range-2 range))
  "Checks if the two ranges overlap each other, return T if it does.
   Additionally, returns :second-eclipse-first if the second one wholly contains the first one,
   :first-eclipse-second if the first one wholly contains the second one,
   and :identity if both of them are the same thing (equivalent to a T from range=)."
  ;; for range (an, bn --> f) and (pn, qn --> g)
  ;; if this is true:
  ;;   a = p, b = q, f < g
  ;; then (an, bn --> f) is in (pn, qn --> g)
  (let ((a (car (base-vector range-or-single-square)))
    (b (cdr (base-vector range-or-single-square)))
    (f (max-steps range-or-single-square))
    (p (car (base-vector range-2)))
    (q (cdr (base-vector range-2)))
    (g (max-steps range-2)))
    (if (and (= a p) (= b q))
    (cond
      ((or (and (not (eql f :infinite)) (eql g :infinite)) (< f g)) (values T :second-eclipse-first))
      ((or (and (not (eql g :infinite)) (eql f :infinite)) (> f g)) (values T :first-eclipse-second))
      (t (values T :identity))))))
)
  ;; for cell (a, b) in range (pn, qn)
  ;; (a, b) is in (pn, qn)1  ;; 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

(defgeneric get-nth-in-range (range nth)
  (:documentation "Gets the nth square of a range."))

(defmethod get-nth-in-range ((range range) (nth number))
  (with-slots (base-vector length) range
    (if (and (not (eql length :infinite)) (< length nth))
    (restart-case (error (format nil "Range is not long enough to get to cell number ~d" nth))
      (use-value (value) value)
      (clamp-to-max ()
        :report "Return the furthest permissible destination."
        (get-nth-in-range range length))
      (return-nil ()
        :report "Return NIL."
        nil)
      (return-zero ()
        :report "Return the destination of a Zero."
        (dest 0 0)))
    (dest (* nth (car base-vector)) (* nth (cdr base-vector))))))


;;;------

(defun dest (x y)
  (if (and (numberp x)
       (numberp y))
      (cons x y)
      (error "Destination must be a number")))

;;;------

(defun zero () (dest 0 0))
;; Orthogonally-jumping pieces
;; =====

;; Generic orthogonal
(defun orthogonal-jump (&key (directions '(:f :b :r :l)) (jump-distance 1))
  (let ((vectors (list :r (dest (+ jump-distance) 0)
               :l (dest (- jump-distance) 0)
               :f (dest 0 (+ jump-distance))
               :b (dest 0 (- jump-distance)))))
    (mapcar #'(lambda (x) (getf vectors x)) directions)))

;; Specialized orthogonal
(defmacro def-orthogonal-jump (name dist)
  `(defun ,name (&key (directions '(:f :b :r :l)))
     (orthogonal-jump :directions directions :jump-distance ,dist)))
(def-orthogonal-jump wazir       1)
(def-orthogonal-jump dabbabah    2)
(def-orthogonal-jump threeleaper 3)

;; Generic rider orthogonal
(defun orthogonal-ride (&key (distance :infinite) (directions '(:f :b :r :l)) (jump-distance 1))
  (let ((used-vectors (orthogonal-jump :directions directions :jump-distance jump-distance)))
    (if (eql distance 1)
    used-vectors
    (mapcar #'(lambda (x) (make-instance 'range :max-steps distance :destination x)) used-vectors))))

;; Specialized rider orthogonal
(defmacro def-orthogonal-range (name dist)
  `(defun ,name (&key (distance :infinite) (directions '(:f :b :r :l)))
     (orthogonal-ride :distance distance :directions directions :jump-distance ,dist)))
(def-orthogonal-range rook              1)
(def-orthogonal-range dabbabah-rider    2)
(def-orthogonal-range threeleaper-rider 3)

;; Diagonally-jumping pieces
;; =====

;; Generic diagonal
(defun diagonal-jump (&key (directions '(:f :b :r :l)) (jump-distance 1))
  (flet ((expand-diagonals (dir) ;keyword shorthand expansion
       (loop
          for i in dir
          append (case i
               (:f  (list :fl :fr))
               (:b  (list :bl :br))
               (:l  (list :fl :bl))
               (:r  (list :fr :br))
               (:fl (list :fl))
               (:bl (list :bl))
               (:br (list :br))
               (:fr (list :fr))))))
    (let ((vectors (list :fr (dest (+ jump-distance) (+ jump-distance))
             :fl (dest (- jump-distance) (+ jump-distance))
             :br (dest (+ jump-distance) (- jump-distance))
             :bl (dest (- jump-distance) (- jump-distance)))))
      (remove-duplicates (mapcar #'(lambda (x) (getf vectors x)) (expand-diagonals directions))))))

;; Specialized diagonal
(defmacro def-diagonal-jump (name dist)
  `(defun ,name (&key (directions '(:f :b :r :l)))
     (diagonal-jump :directions directions :jump-distance ,dist)))
(def-diagonal-jump ferz    1)
(def-diagonal-jump alfil   2)
(def-diagonal-jump tripper 3)

;; Generic rider diagonal
(defun diagonal-ride (&key (distance :infinite) (directions '(:f :b :r :l)) (jump-distance 1))
  (let ((used-vectors (diagonal-jump :directions directions :jump-distance jump-distance)))
    (if (eql distance 1)
    used-vectors
    (mapcar #'(lambda (x) (make-instance 'range :max-steps distance :destination x)) used-vectors))))

;; Specialized rider orthogonal
(defmacro def-diagonal-range (name dist)
  `(defun ,name (&key (distance :infinite) (directions '(:f :b :r :l)))
     (diagonal-ride :distance distance :directions directions :jump-distance ,dist)))
(def-diagonal-range bishop        1)
(def-diagonal-range alfil-rider   2)
(def-diagonal-range tripper-rider 3)

;; Hippogonal pieces
;; =====

;; Generic hippogonal
(defun hippo (long-side short-side &key (directions '(:f :b :r :l)))
  (cond
    ;; degenerate cases
    ((< long-side short-side) (hippo short-side long-side :directions directions))
    ((= long-side short-side) (diagonal-jump :directions directions :jump-distance long-side))
    ((zerop short-side)     (orthogonal-jump :directions directions :jump-distance long-side))
    ;; the real thing
    (t (flet ((expand-hippogonals (dir) ;keyword shorthand expansion
        (loop for i in dir
           append (case i
                (:f   (list :ffr :ffl :fsr :fsl))
                (:b   (list :bbr :bbl :bsr :bsl))
                (:r   (list :ffr :fsr :bsr :bbr))
                (:l   (list :ffl :fsl :bsl :bbl))
                (:fr  (list :ffr :fsr))
                (:fl  (list :ffl :fsl))
                (:br  (list :bbr :bsr))
                (:bl  (list :bbl :bsl))
                (:ff  (list :ffr :ffl))
                (:fs  (list :fsr :fsl))
                (:bb  (list :bbr :bbl))
                (:bs  (list :bsr :bsl))
                (:ll  (list :bsl :fsl))
                (:lv  (list :bbl :ffl))
                (:rr  (list :bsr :fsr))
                (:rv  (list :bbr :ffr))
                (:fb  (list :ffl :ffr :bbl :bbr))
                (:rl  (list :fsl :fsr :bsl :bsr))
                (:ffr (list :ffr))
                (:fsr (list :fsr))
                (:bsr (list :bsr))
                (:bbr (list :bbr))
                (:bbl (list :bll))
                (:bsl (list :bsl))
                (:fsl (list :fsl))
                (:ffl (list :ffl))))))
     (let ((vectors (list :ffr (dest (+ short-side) (+ long-side) )
                  :fsr (dest (+ long-side)  (+ short-side))
                  :bsr (dest (+ long-side)  (- short-side))
                  :bbr (dest (+ short-side) (- long-side) )
                  :bbl (dest (- short-side) (- long-side) )
                  :bsl (dest (- long-side)  (- short-side))
                  :fsl (dest (- long-side)  (+ short-side))
                  :ffl (dest (- short-side) (+ long-side)))))
       (remove-duplicates (mapcar #'(lambda (x) (getf vectors x)) (expand-hippogonals directions))))))))


;; Specialized hippogonal
(defmacro defhippo (name long short)
  `(defun ,name (&key (directions '(:f :b :r :l)))
     (hippo ,long ,short :directions directions)))
(defhippo knight   2 1)
(defhippo camel    3 1)
(defhippo zebra    3 2)
(defhippo giraffe  4 1)
(defhippo antelope 4 3)

;; Generalized hippogonal ride
(defun hippogonal-ride (long-side short-side &key (distance :infinite) (directions '(:f :b :r :l)))
  (let ((used-vectors (hippo long-side short-side :directions directions)))
    (if (eql distance 1)
    used-vectors
    (mapcar #'(lambda (x) (make-instance 'range :max-steps distance :destination x)) used-vectors))))

;; Specialized rider orthogonal
(defmacro def-hippogonal-range (name long short)
  `(defun ,name (&key (distance :infinite) (directions '(:f :b :r :l)))
     (hippogonal-ride ,long ,short :distance distance :directions directions)))
(def-hippogonal-range nightrider 2 1)
(def-hippogonal-range camelrider 3 1)
(def-hippogonal-range zebrarider 3 2)