;;
;;  octi-notation.lisp
;;
;;   Contains tools for reading and writing standard Octi notation.
;;
;;  Here is an almost-BNF for Octi notation:
;;
;;    move ::= jump-list | add-prong | add-pod | move-prong
;;    jump-list ::= jump (',' jump)*
;;    jump ::= piece ('-' square ['x'])+
;;    add-prong ::= piece '+' direction
;;    move-prong ::= piece '-' direction '+' direction
;;    piece ::= square [ prongs ]
;;    square ::= (11..19, 21..29, ..., 91..99)
;;    prongs ::= [a-h]+ (but each letter may appear at most once)
;;    direction ::= [a-h]
;;
;;  Main functions:
;;
;;   READ-OCTI-MOVE stream player board   [function]
;;     Constructs an Octi move structure based on a move read from STREAM.
;;     PLAYER and BOARD are needed to allow context-sensitive reference
;;     to pieces.
;;
;;   WRITE-OCTI-MOVE move board stream   [function]
;;     Writes the Octi move structure MOVE to STREAM in standard Octi notation.
;;
;;   ADD-OCTI-PIECE board player stream   [function]
;;     Adds a new piece to a board that specified using a standard Octi piece
;;     specification [i.e., the piece production above].  Useful for creating
;;     board scenarios for puzzles and debugging
;;
;;----------------------------------------------
;;   This software is licensed; see the file
;;   LICENSE for details.
;;----------------------------------------------


;; TODO: read-jump-move-list does not handle whitespace after comma

(in-package "CL-USER")

(defun add-octi-piece (board player stream)
  "Adds a new piece to a board that specified using a standard Octi piece
   specification.  Useful for creating board scenarios for puzzles and debugging."
  (let ((square (read-square stream))
        (dirs (read-directions stream)))
    (unless (or (square-empty board square)
                (square-occupied board square player))
      (error "Square ~a occupied by a player who's not ~a" 
        square (player-name player)))
    (let ((piece (make-piece :player (player-name player))))
      (dolist (dir dirs)
        (piece-add-prong piece dir))
      (stack-add-piece 
       (bref board square)
       piece))))

(defun write-octi-move (move board stream)
  (cond
   ((add-prong-move-p move) (write-add-prong-move move board stream))
   ((reposition-prong-move-p move) (write-reposition-prong-move move board stream))
   ((add-pod-move-p move) (write-add-pod-move move stream))
   ((listp move) (write-jump-list move board stream))))

(defun write-add-prong-move (move board stream)
  (write-piece (add-prong-move-piece-loc move) board stream)
  (write-char #\+ stream)
  (write-char (direction-char (add-prong-move-dir move))
              stream))

(defun write-reposition-prong-move (move board stream)
  (write-piece (reposition-prong-move-piece-loc move) board stream)
  (write-char #\- stream)
  (write-char (direction-char (reposition-prong-move-from-dir move))
              stream)
  (write-char #\+ stream)
  (write-char (direction-char (reposition-prong-move-to-dir move))
              stream))

(defun write-add-pod-move (move stream)
  (princ (add-pod-move-square move) stream))

(defun write-jump-list (jlist board stream)
  (write-jump (first jlist) board stream)
  (dolist (jump (rest jlist))
    (write-char #\, stream)
    (write-jump jump board stream)))

(defun write-jump (jump board stream)
  (write-piece (jump-move-piece-loc jump) board stream)
  (do*
       ((prev (jump-move-from-square jump) this)
        (this-list (jump-move-to-squares jump) (cdr this-list))
        (this (car this-list) (car this-list)))
       ((null this-list))
    (write-char #\- stream)
    (princ this stream)
    (let ((jumped-square (square-jumped prev this)))
      (when (member jumped-square (jump-move-capture-squares jump))
        (write-char #\x stream)))))
       
(defun write-piece (piece-loc board stream)
  (princ (piece-loc-square piece-loc) stream)
  (let ((piece (lookup-piece-location board piece-loc)))
    (do-directions (dir)
       (when (piece-has-prong-p piece dir)
         (write-char (direction-char dir) stream)))))

(defun read-octi-move ( stream board player )
  "Reads a move in standard octi notation from the string STREAM,
   given the state of the board in BOARD."
  (let ((square (read-square stream))
        (peeked-ch (peek-char nil stream nil #\Space)))
    (if (whitespacep peeked-ch)
        (read-add-pod-move square board player)
      (let ((piece-loc (determine-piece-loc stream square board))
            (ch (read-char stream)))
        (unless piece-loc
          (error "Invalid piece specified."))
        (cond
         ((eql ch #\+) (read-add-prong stream piece-loc))
         ((eql ch #\-)
          (if (digit-char-p (peek-char nil stream))
              (read-jump-list stream piece-loc board)
            (read-move-prong stream piece-loc)))
         (t (error "Invalid move: Just read ~s" piece-loc)))))))

(defun read-square (stream)
  (let ((square (read-integer stream)))
    (if (squarep square)
        square
      (error "Error: Invalid square ~a" square))))

(defun determine-piece-loc ( stream square board)
  "Reads a specification of an Octi piece from STREAM.  BOARD is needed
   for more context-sensitive reference to pieces."
  (find-piece-contextually 
   board
   (read-directions stream)
   square))

(defun read-directions ( stream )
  "Reads a list of prong directions from STREAM.  Assumes that
   STREAM is containing a list of prong-direction characters
   like 'abh'."
    (do
        ((char (peek-char nil stream nil #\Space)
               (peek-char nil stream nil #\Space))
         (directions nil))
        ((not (direction-char-p char))
         directions)
      (read-char stream)
      (push (direction-char-number char) directions)))

(defun find-piece-contextually (board directions square)
  (if (and (null directions)
           (= (stack-num-pieces (bref board square))
              1))
      (make-piece-loc square 0)
    (find-piece-loc board directions square)))

(defun read-add-pod-move (square board player)
  (let ((move (make-add-pod-move :square square :captured? t)))
    (if (valid-move-p move player board)
        move
      (make-add-pod-move :square square :captured? nil))))

(defun read-add-prong (stream piece-loc)
  "Returns a move structure denoting an add-prong move onto piece.
   Assumes that the piece designation and the plus sign have been
   eaten from the stream."
  (let* ((ch (read-char stream))
         (dir (direction-char-p ch)))
    (unless dir (error "Invalid direction ~a" ch))
    (make-add-prong-move :piece-loc piece-loc :dir dir)))
    
(defun read-move-prong (stream piece-loc)
  "Returns a move structure denoting a move-prong move.  Assumes
   that the piece designation and the initial minus sign has already been read from STREAM
   and that a list (SQUARE NUM) denoting the piece is in PIECE-LOC."
  (let* ((from-char (read-char stream))
         (from-dir (direction-char-number from-char))
         (plus (read-char stream))
         (to-char (read-char stream))
         (to-dir (direction-char-number to-char)))
    (unless from-dir
      (error "Invalid move-prong move: expected a-h, got ~a" from-char))
    (unless (eql plus #\+)
      (error "Invalid move-prong move: expected +, got ~a" plus))
    (unless to-dir
      (error "Inavlid move-prong move: expected a-h, got ~a" to-char))
    (make-reposition-prong-move 
     :piece-loc piece-loc
     :from-dir from-dir
     :to-dir to-dir)))

(defun read-jump-list ( stream piece-loc board)
  "Returns a move structure corresponding to a jump
   list based on a move in Octi notation read from
   STREAM.  Assumes that the piece designation and
   first minus sign have already been read.  PIECE-LOC
   should be a piece-locating list corresponding
   to the first piece to be moved.  Will handle
   all jumps for a stack (if each individual jump
   is separated by ',')"
  (loop
    for comma = #\, then (read-char stream nil nil)
    while (eql comma #\,)
    for square = nil then (read-square stream)
    for pl = piece-loc then (determine-piece-loc stream square board)
    for dash = #\- then (read-char stream) ;; Remove dash
    do (unless (eql dash #\-)
         (error "Invalid jump; expected -, got ~a" dash))
    collect (read-jump-move stream pl)))

(defun read-jump-move ( stream piece-loc )
  "Returns a move structure corresponding to the
   jump of one piece, based on a move in Octi
   notation read from STREAM.  Assumes that
   the piece designator and initial dash have
   already been read.  PIECE-LOC should be
   the piece designator list."
  (loop
    with to-list = nil
    with cap-list = nil
    for last-square = (piece-loc-square piece-loc) then square
    for square = (read-integer stream)
    for next = (read-char stream nil nil)
    for dash = (when (eql next #\x)
                 (read-char stream nil nil))
    do
    (progn
      (push square to-list)
      (when (eql next #\x)
        (push (square-jumped last-square square)
              cap-list)))
    while
    (or
     (eql next #\-)
     (and (eql next #\x)
          (eql dash #\-)))
    finally
    (if (eql next #\x)
        (when dash (unread-char dash stream))
      (when next (unread-char next stream)))
    (return (make-jump-move :from-square (piece-loc-square piece-loc)
                    :piece-loc piece-loc
                    :to-squares (nreverse to-list) 
                    :capture-squares (nreverse cap-list)))))
      
(defun direction-char-p ( ch )
  (direction-char-number ch))

(defparameter *octi-directions-alist*
    `((#\a . ,n)
      (#\b . ,ne)
      (#\c . ,e)
      (#\d . ,se)
      (#\e . ,s)
      (#\f . ,sw)
      (#\g . ,w)
      (#\h . ,nw)
      (#\A . ,n)
      (#\B . ,ne)
      (#\C . ,e)
      (#\D . ,se)
      (#\E . ,s)
      (#\F . ,sw)
      (#\G . ,w)
      (#\H . ,nw)))

(defun direction-char-number ( ch )
  (cdr (assoc ch *octi-directions-alist*)))

(defun direction-char ( dir )
  (car (rassoc dir *octi-directions-alist*)))

(defun whitespacep ( ch )
  (member ch '(#\Space #\Tab #\Return #\Newline)))

(defun read-integer ( stream &optional (radix 10))
  (do*
      ((i 0)
       (ch (read-char stream)
           (read-char stream nil #\Space)))
      ((not (digit-char-p ch radix))
       (unread-char ch stream)
       i)
    (setq i
          (+ (* i radix)
             (digit-char-p ch radix)))))