betza wip 4

;;;; Betza Notation

(defpackage :info.isoraqathedh.betza
  (:use :common-lisp))

(in-package :info.isoraqathedh.betza)

;;;------

(define-condition range-not-long-enough (error)
  ((requested-range :initarg :requested-range
            :reader  range-not-long-enough-requested)
   (requested-distance :initarg :requested-distance
               :reader  range-not-long-enough-distance))
  (:report (lambda (condition stream)
             (format stream "Range ~a is not long enough to get to cell number ~d."
             (range-not-long-enough-requested condition)
                     (range-not-long-enough-distance condition)))))

;;;------

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

;;; ======
;;; Range functor (do not use directly)
;;; ======

(defun append-range (move distance)
  (append move (list :range (list :distance distance))))

;;; ======
;;; Combinators and attributes
;;; ======

;; Attributes
;; =====

(defun component-combine (func dests) "Basic combine moves with a free slot to indicate the combining function. Helper function."
  (loop for dest in dests append (mapcar func dest)))
(defun combine (&rest dests)
  (component-combine #'identity dests)) ; For consistency, this function uses the rather silly identity function.
(defun capture (&rest dests)
  (component-combine #'(lambda (p) (append p (list :capture t))) dests))
(defun move (&rest dests)
  (component-combine #'(lambda (p) (append p (list :move t))) dests))
(defun igui (&rest dests)
  (component-combine #'(lambda (p) (append p (list :igui t))) dests))
(defun lame (&rest dests) ; use (then '(:complete t)) (NYI) for finer control over lame moves.
  (component-combine #'(lambda (p) (append p (list :lame t))) dests))
(defun jump (optlist &rest dests) ; Jumping makes sense only on range moves, or when exactly one of the options are false.
                    ; Single destinations are jumps by default.
  (destructuring-bind (&key (jump-friendly-p t) (jump-enemy-p t)) optlist
                    ; The destructuring-bind above catches settings that are not included with the attribute
    (component-combine #'(lambda (p) (append p (list :jump (list :jump-friendly-p jump-friendly-p
                                 :jump-enemy-p    jump-enemy-p)))) dests)))
(defun cylindrical (optlist &rest dests)
  (destructuring-bind (&key (wrap-left-right T)
                (wrap-front-back NIL)) optlist
    (component-combine #'(lambda (p) (append p (list :cylindrical (list :wrap-left-right wrap-left-right
                                    :wrap-front-back wrap-front-back)))) dests)))
(defun cannon (optlist &rest dests)
  (destructuring-bind (&key (steps-before :any)
                (jump-enemy-p T)
                (jump-friendly-p T)
                (capture-screen-p nil)
                (screen-count 1)
                (steps-after :any)) optlist
      (component-combine #'(lambda (p) (append p (list :cannon (list :steps-before     steps-before
                                     :jump-enemy-p     jump-enemy-p
                                     :jump-friendly-p  jump-friendly-p
                                     :capture-screen-p capture-screen-p
                                     :screen-count     screen-count
                                     :steps-after      steps-after)))) dests)))


;; Multimoves
;; =====

;(loop for i in set-1
;       nconc (loop for j in set-2 collect (list i j))))

(defun combo (obligate-complete-p repeatp outwards-only-p steps)
  (let ((initial-list (reduce #'(lambda (first-step second-step)
                  (loop for i in first-step
                     append (loop for j in second-step
                           collect (if (keywordp (car i))
                               (concatenate 'list i (list j))
                               (list :then (list :obligate-complete-p obligate-complete-p
                                         :repeatp             repeatp)
                                 i j)))))
                  steps)))
    (if outwards-only-p
    (remove-if #'(lambda (p) (apply #'< (loop for (x y . nil) in (cddr p)
                           for aggr-x = x then (+ aggr-x x)
                           for aggr-y = y then (+ aggr-y y)
                           collect (+ (expt aggr-x 2) (expt aggr-y 2))))) initial-list)
    initial-list)))

(defun then      (&rest steps) (combo nil nil t   steps))
(defun must-go   (&rest steps) (combo t   nil t   steps))
(defun alternate (&rest steps) (combo nil t   nil steps))

;;; ======
;;; Pieces
;;; ======

(defun zero () (list (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 define-orthogonal-jump (name dist)
  `(defun ,name (&key (directions '(:f :b :r :l)))
     (orthogonal-jump :directions directions :jump-distance ,dist)))
(define-orthogonal-jump wazir       1)
(define-orthogonal-jump dabbabah    2)
(define-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) (append-range x distance)) used-vectors))))

;; Specialized rider orthogonal
(defmacro define-orthogonal-range (name dist)
  `(defun ,name (&key (distance :infinite) (directions '(:f :b :r :l)))
     (orthogonal-ride :distance distance :directions directions :jump-distance ,dist)))
(define-orthogonal-range rook              1)
(define-orthogonal-range dabbabah-rider    2)
(define-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  '(:fl :fr))
               (:b  '(:bl :br))
               (:l  '(:fl :bl))
               (:r  '(:fr :br))
               (:fl '(:fl))
               (:bl '(:bl))
               (:br '(:br))
               (:fr '(: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 define-diagonal-jump (name dist)
  `(defun ,name (&key (directions '(:f :b :r :l)))
     (diagonal-jump :directions directions :jump-distance ,dist)))
(define-diagonal-jump ferz    1)
(define-diagonal-jump alfil   2)
(define-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) (append-range x distance)) used-vectors))))

;; Specialized rider orthogonal
(defmacro define-diagonal-range (name dist)
  `(defun ,name (&key (distance :infinite) (directions '(:f :b :r :l)))
     (diagonal-ride :distance distance :directions directions :jump-distance ,dist)))
(define-diagonal-range bishop        1)
(define-diagonal-range alfil-rider   2)
(define-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   '(:ffr :ffl :fsr :fsl))
                (:b   '(:bbr :bbl :bsr :bsl))
                (:r   '(:ffr :fsr :bsr :bbr))
                (:l   '(:ffl :fsl :bsl :bbl))
                (:fr  '(:ffr :fsr))
                (:fl  '(:ffl :fsl))
                (:br  '(:bbr :bsr))
                (:bl  '(:bbl :bsl))
                (:ff  '(:ffr :ffl))
                (:fs  '(:fsr :fsl))
                (:bb  '(:bbr :bbl))
                (:bs  '(:bsr :bsl))
                (:ll  '(:bsl :fsl))
                (:lv  '(:bbl :ffl))
                (:rr  '(:bsr :fsr))
                (:rv  '(:bbr :ffr))
                (:fb  '(:ffl :ffr :bbl :bbr))
                (:rl  '(:fsl :fsr :bsl :bsr))
                (:ffr '(:ffr))
                (:fsr '(:fsr))
                (:bsr '(:bsr))
                (:bbr '(:bbr))
                (:bbl '(:bll))
                (:bsl '(:bsl))
                (:fsl '(:fsl))
                (:ffl '(: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 define-hippo (name long short)
  `(defun ,name (&key (directions '(:f :b :r :l)))
     (hippo ,long ,short :directions directions)))
(define-hippo knight   2 1)
(define-hippo camel    3 1)
(define-hippo zebra    3 2)
(define-hippo giraffe  4 1)
(define-hippo 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) (append-range x distance)) used-vectors))))

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

;; Commonly-used pieces
;; =====
(defvar *wazir* (wazir))
(defvar *dabbabah* (dabbabah))

(defvar *ferz* (ferz))
(defvar *alfil* (alfil))

(defvar *rook* (rook))
(defvar *remarkable-short-rook* (rook :distance 4))

(defvar *bishop* (bishop))

(defvar *knight*   (knight))
(defvar *camel*    (camel))
(defvar *zebra*    (zebra))
(defvar *giraffe*  (giraffe))
(defvar *antelope* (antelope))

;; FIDE
(defvar *king* (combine (wazir) (ferz)) "The King from FIDE Chess.")
(defvar *queen* (combine (rook) (bishop)) "The Queen from Fide Chess.")
(defvar *rook* (rook) "The Rook from FIDE Chess.")
(defvar *bishop* (bishop) "The Bishop from FIDE Chess.")
(defvar *knight* (knight) "The Knight from FIDE Chess.")
(defvar *pawn* (combine (capture (ferz :directions '(:f))) (move (wazir :directions '(:f)))) "The Pawn from FIDE chess, less the initial kerfluffle.")

;; Shogi
(defvar *incense-chariot* (rook :directions '(:f))
  "The Incense Chariot from Shogi, also called 'lance', 'fragrant chariot' or 'wing'.")
(defvar *honourable-horse* (knight :directions '(:ff))
  "The Honorable Horse from Shogi, also called 'horse', 'laureled horse' or 'helm'.")
(defvar *silver-general* (combine (ferz) (wazir :directions '(:f))) "The Silver General from Shogi. Also the elephant from Makruk.")
(defvar *gold-general* (combine (wazir) (ferz :directions '(:f))) "The Gold General from Shogi.")
(defvar *dragon-king* (combine (rook) (ferz)) "The Dragon King from Shogi. Also called 'chatelaine'.")
(defvar *dragon-horse* (combine (bishop) (wazir)) "The Dragon Horse from Shogi. Also called 'primate'.")
(defvar *foot-soldier* (wazir :directions '(:f)) "The Foot Soldier from Shogi. Also called 'fuhyo' or 'point'.")

;; Xiangqi
(defvar *horse* (must-go (move (wazir)) (ferz)) "The Horse from Xiangqi. Like a knight but lame.")
(defvar *chinese-elephant* (lame (alfil)) "The elephant from Xiangqi.  Like an Alfil but lame.")
(defvar *cannon* (combine (move (rook)) (capture (cannon nil (rook)))) "The Cannon from Xiangqi.")

;; ======
;; Writer
;; ======

(defun write-in-diagram-array (diagram destination-descr &optional force-char)
  (destructuring-bind (y x &rest args) destination-descr ; again, reversed x-ys in arrays
    (let ((centre-of-array-x (floor (/ (first (array-dimensions diagram)) 2)))
      (centre-of-array-y (floor (/ (second (array-dimensions diagram)) 2))))
      (labels ((write-functor (x y char centre-of-array-x centre-of-array-y)
         (setf (aref diagram (- (first (array-dimensions diagram)) (+ x centre-of-array-x 1)) (+ y centre-of-array-y)) char))
           (select-character (args default force-char)
         (if force-char force-char (cond
                         ((getf args :igui) "!")
                         ((and (getf args :move)
                           (not (getf args :capture))) "m")
                         ((and (getf args :capture)
                           (not (getf args :move))) "c")
                         (t default)))))
    (handler-case
        (cond ((and (getf args :range)
            (numberp (getf (getf args :range) :distance)))
           (let ((total-distance (getf (getf args :range) :distance)))
             (loop for i from 1 to total-distance
            do (write-functor (* i x) (* i y) (select-character args "x" force-char) centre-of-array-x centre-of-array-y))))
          ((and (getf args :range)
            (eql (getf (getf args :range) :distance) :infinite))
           (let ((max-distance-x (- (first (array-dimensions diagram)) centre-of-array-x 1))
             (max-distance-y (- (second (array-dimensions diagram)) centre-of-array-y 1)))
             (loop for i from 1 to (max max-distance-x max-distance-y)
            do (write-functor (* i x) (* i y)
                      (select-character args (cond ((= x y) "/")
                                       ((= x (- y)) "\\")
                                       ((= x 0) "-")
                                       ((= y 0) "|")
                                       (t "~")) force-char)
                      centre-of-array-x centre-of-array-y))))
          (t (write-functor x y (select-character args "x" force-char) centre-of-array-x centre-of-array-y)))
      (SB-INT:INVALID-ARRAY-INDEX-ERROR () nil))
    diagram))))

(defun write-all-in-diagram-array (diagram piece)
  (loop for dest-descr in piece
     do
       ; (format t "~&~a" dest-descr)
       (write-in-diagram-array diagram dest-descr)
     finally (return diagram)))

(defun make-diagram-array (piece &optional (spaciousp t) (squarep t))
  (flet ((max-coords-needed (piece squarep)
       (loop for dest in piece
          maximize (cond ((keywordp (first dest)) (reduce #'+ (subseq dest 2) :key #'first))
                 ((and (getf (nthcdr 2 dest) :range)
                   (numberp (getf (getf (nthcdr 2 dest) :range) :distance)))
                  (* (getf (getf (nthcdr 2 dest) :range) :distance) (first dest)))
                 (t (first dest))) into max-x
          maximize (cond ((keywordp (first dest)) (reduce #'+ (subseq dest 2) :key #'second))
                 ((and (getf (nthcdr 2 dest) :range)
                   (numberp (getf (getf (nthcdr 2 dest) :range) :distance)))
                  (* (getf (getf (nthcdr 2 dest) :range) :distance) (second dest)))
                 (t (second dest))) into max-y
          finally
           (return
         (let ((max-all (max max-x max-y)))
           (list (if squarep max-all max-x)
             (if squarep max-all max-y)))))))
    (let ((true-size (reverse ; The array x-y is reversed compared to the conventional x-y.
               (mapcar #'(lambda (p) (+ (if spaciousp 3 1) (* 2 p)))
                   (max-coords-needed piece squarep)))))
      (write-all-in-diagram-array
       (write-in-diagram-array (make-array true-size :initial-element ".") '(0 0) "O")
       piece))))

(defun print-diagram (stream diagram &optional returnp)
  (when (or (< (first (array-dimensions diagram)) 10)
        (< (first (array-dimensions diagram)) 10)
        (eql stream t)
        (y-or-n-p "Holy crap, this diagram is going to be huge. Continue?"))
    (loop with 2d = diagram
       with (rows cols) = (array-dimensions 2d)
       for row below rows
       do (format stream "~&")
     (loop for col below cols
        do (format stream "~a " (aref 2d row col))))
    (if returnp diagram)))

(defun make-and-print-diagram (stream piece &optional returnp)
  (print-diagram stream (make-diagram-array piece) returnp))