;;(declaim (optimize (speed 3)(compilation-speed 0)(safety 0) (debug 0)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Checkers game: written by Shaul Markovitch                       ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Version: 7.02                                                      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Last time modified: 5/12/99
;;;
;;; Change Log:
;;;
;;; 5/12/99 - Corrected bug in the printing function. [Forgot that
;;;           case does not evaluate the various cases].



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 
;;;  A checkers board is represented by a one-dimensional array of size 32 .
;;;  A board element is accessed via the functions get-piece and put-piece.
;;;  The predicates king-p and pawn-p are used for checking the identity of a piece
;;;  The function color returns the color of a piece
;;;  The function checkers-expand-board is the main function - it returns a list of
;;;  boards that are a result of legal moves by a given color.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defconstant *board-size*  8 "Defines the size of the board")
(defconstant *king-val* 3  "this is the right king values for computing material advantage")
(defconstant *pawn-val* 2)
(defconstant *total-squares* 32)
(deftype piece () `(integer ,(- *king-val*) ,*king-val*))
(deftype board-array () `(simple-array piece
                                       (,*total-squares*)))

(setq *random-state* (make-random-state t))  ; Initalize random seed using the clock

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The following arrays save us computation in run-time.  We store for each square
;;; its next location with regard to the four possible directions (lf stand for
;;; left-forward, rf right-forward, lb left-back, rb right back)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *moves* (list 
   (list 'lf (make-array (list *total-squares*)
                         :element-type 'fixnum
                       :initial-contents
                       '(-1 4 5 6 8 9 10 11 -1 12 13 14 16 17 18 19 -1 20 
                       21 22 24 25 26 27 -1 28 29 30 -1 -1 -1 -1)))

   (list 'rf (make-array (list *total-squares*) :element-type 'fixnum
                       :initial-contents
                       '(4 5 6 7 9 10 11 -1 12 13 14 15 17 18 19 -1 20 21 
                       22 23 25 26 27 -1 28 29 30 31 -1 -1 -1 -1)))

   (list 'lb (make-array (list *total-squares*) :element-type 'fixnum
                       :initial-contents
                       '(-1 -1 -1 -1 0 1 2 3 -1 4 5 6 8 9 10 11 -1 12 13 
                       14 16 17 18 19 -1 20 21 22 24 25 26 27)))
   (list 'rb (make-array (list *total-squares*) :element-type 'fixnum
                       :initial-contents
                       '(-1 -1 -1 -1 1 2 3 -1 4 5 6 7 9 10 11 -1 12 13 14 
                       15 17 18 19 -1 20 21 22 23 25 26 27 -1)))))


(defparameter *king-moves* '(lf rf lb rb))
(defparameter *black-moves* '(lb rb))
(defparameter *white-moves* '(lf rf))

(defun get-moves (color king-p)
   (cond (king-p *king-moves*)
         ((eql color :white) *white-moves*)
         (t *black-moves*)))

(declaim (inline legal-loc apply-move))
(defun legal-loc (loc) (/= loc -1))

(defun apply-move (move index)
   (let ((new-loc (aref (second (assoc move *moves*)) index)))
     (if (legal-loc new-loc) new-loc nil)))
                         

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Internally, we represent an empty square by 0, a black pawn by -2,
;;;  a black king by -3, a white pawn by 2 and a white king by 3.
;;;  This allows a compact array for representing board (with 3 bits
;;;  per cell) and an easy computation of material difference
;;; (traditionally a king in checkers in considered as 3/2 pawns
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(declaim (inline color color-sign opposite-color king-p pawn-p
                 empty-location-p opponents-p put-piece get-piece))

(defun color  (piece)
  (cond ((< piece 0) :black)
	((> piece 0) :white)
	(t nil)))

(defun color-sign (color) (if (eql color :white) 1 -1))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun opposite-color  (color)
  (if (eql color :white) :black :white))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun king-p (piece) (= *king-val* (abs piece))) ;returns t if a piece is a king

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun pawn-p (piece) (= *pawn-val* (abs piece))) ;returns t if a piece is a pawn

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun empty-location-p			;returns t if a location is empty
  ( board location)
  (= (get-piece board location) 0))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun opponents-p			;returns t if the two given
					;locations contain different
					;color pieces
  (board loc-a loc-b)
  (> 0 (* (get-piece board loc-a)(get-piece board loc-b))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun put-piece
  
   ;; Access function to a board. Places the piece in the given location
   ;; of the board DESTRUCTIVELY.
  
  (board location piece)
  (setf (aref board location) piece))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-piece
  (board location)

  ;;  Access function to a board.  returns the piece in the given
  ;; location.
  
  (aref board location))


(defun get-piece-by-row-col (board row col)
  (let ((index (compute-index row col)))
    (when index (get-piece board index))))

(defun compute-index (row col)
  (when (or (and (oddp row)(oddp col))
	    (and (evenp row)(evenp col)))
	(1- (+ (* row 4)(ceiling (/ (1+ col) 2))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; mixup
;;;
;;; randomly re-shuffles a list
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun mixup (list)
  (let ((copy-list (copy-list list)))
    (loop for i below (length list)
          for index = (random (- (length list) i))
          for el = (elt copy-list index)
          do
            (cond ((zerop index)(setq copy-list (cdr copy-list)))
                  (t (let ((loc (nthcdr (1- index) copy-list)))
                       (rplacd loc (cddr loc)))))
            collect el)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; E X P A N D - B O A R D 
;;; Main playing function.  Receives a board and a color and returns
;;; a list of all legal moves of the given color.  The elements of
;;; the list returned are of type move-record, i.e., they contain in
;;; addition to the new board after the move, the old and new
;;; location of the piece that moved.
;;;   Rules of checkers that were used:
;;;    1.  A pawn can move and jump only forward.
;;;    2.  A king can move and jump both forward and backward.
;;;    3.  A king can move only one square at a time (this is
;;;        American checkers).
;;;    4.  A pawn that arrives at the starting line of the opponent
;;;        changed to become a king.
;;;    5.  If a pawn can jump over opponent's piece, a jump must be
;;;        done.  It is  necessary to perform double jump
;;;        when such a jump is possible.  So the rule is:  a piece
;;;       can not perform a non-jump move if there is at least one jump
;;;       move available.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun checkers-expand
  (board color)
  #- HPPA (declare (type board-array board))
      
    (mixup
     (or (loop for index fixnum below *total-squares*
                      for piece = (aref board index)
		      when (eql (color piece) color)
		      append (generate-jumps board index
					    color (king-p piece)))
	
         (loop for index fixnum below *total-squares*
                     for piece = (aref board index)
                     when (eql (color piece) color)
                     append (generate-simple-moves board
						   index color
						   (king-p piece))))))
						  


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; checkers-win-predicate
;;
;; A function for testing whether the current state is a final
;;position.  A final position in checkers is defined as a position
;;where the current player can not move.  We could use much shorter
;;code that utilizes expand and tests whether the returned list is
;;null.  However, since the function is called in every node of the
;;search tree it is extremely important to make it very efficient.
;;  1.  As soon as one move is found it can stop.
;;  2.  It does not need to compute the resulting board of the new
;;      move - only that such a move exists
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun checkers-win-predicate (board &optional color)
    #- HPPA (declare (type board-array board))
    (if (loop for index fixnum below *total-squares*
          for piece = (aref board index)
          with skip-move
          never
          (and (eql (color piece) color)
          (loop  for move in
            (get-moves color (king-p piece))
            for new-loc = (apply-move move index)
            thereis
            (and new-loc
                 (or (empty-location-p board new-loc)
                     (and (opponents-p board index new-loc)
                          (setf skip-move (apply-move move new-loc))
                          (empty-location-p board skip-move)))))))
        (opposite-color color) nil))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun generate-simple-moves
  (board location color king-p)
  #- HPPA (declare (type board-array board))
  ;;  Simple-moves are non-jump moves.  They are pretty easy to
  ;;  generate.  The only test need to be done is whether the new
  ;;  location is within the board and is not occupied by another piece
  
  (loop  for move in (get-moves color king-p)
	 for new-loc = (apply-move move location)
         when (and new-loc (empty-location-p board new-loc))
         collect (move-piece board location new-loc)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun generate-jumps
   (board location color &optional (king-p (king-p (get-piece board location))))
  #- HPPA (declare (type board-array board))
  ;;  This function is a bit trickier than the simple-moves generator.
  ;;  The new location is computed by applying a move twice.  there is
  ;;  a need to check whether there is a piece of the opposite color in
  ;;  the middle square.  Also there is a need to check for a double
  ;;  and triple jumps - this is done by calling this function recursively
  ;; with the given new location.
  
  (loop for move in (get-moves color king-p)
	for over-loc = (apply-move move location)
	for new-loc = (and over-loc (apply-move move over-loc))
	when (and new-loc
		  (empty-location-p board new-loc)
		  (opponents-p board location over-loc))
	append (let ((new-board (move-piece board location new-loc))
		     new-boards)
		 (put-piece new-board over-loc 0)
		 (setq new-boards (generate-jumps new-board new-loc color ))
		 (or new-boards (list new-board)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun move-piece
  (board old-loc new-loc)
  #- HPPA (declare (type board-array board))
  ;;  This functions actually modifies the board ( a copy of it)
  ;;  to move a piece from a location to another one
  
  (let ((new-board (duplicate-board board)))
    (declare (type board-array new-board))
    (rotatef (aref new-board old-loc)(aref new-board new-loc))
    (check-for-new-king new-board new-loc)
    new-board))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun check-for-new-king
  (board location)
  #- HPPA (declare (type board-array board))
  ;;  A pawn that reaches the opponent's base line is becoming a king.
  
  (let ((piece (get-piece board location)))
    (when (and (not (king-p piece))
	       (king-location-p location (color piece)))
      (put-piece board location (get-king (color piece))))))

(defun get-king (color)(if (eql color :white) *king-val* (- *king-val*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun king-location-p
  ;; base line of the opponent
   (index color)
   (declare (type fixnum index))
   (or (and (< index 4)(eql color :black))
      (and (> index 27)(eql color :white))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun duplicate-board
  (board)
  #- HPPA (declare (type board-array board))
   (declare (optimize (speed 3)(compilation-speed 0)(safety 0) (debug 0)))
  ;; a copying function - used to enable destructive operations of
  ;;boards. [The number 32 should be replaced by a constant but
  ;;meanwhile the compiled code is much faster with the hard coded number.
  (let ((new-board (make-array '(32) :element-type 'piece)))
    #- HPPA (declare (type board-array new-board))
    (loop for i fixnum below *total-squares* do
      (setf (aref new-board i)(aref board i)))
    new-board))
  ;(copy-seq board))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;
;;; initial board [for a different board-size rewrite this function]
;;;
(defun checkers-create-initial-board
  ()
  (make-array '(32)  :element-type 'piece :initial-contents
              (append (loop for i from 1 to 12 collect *pawn-val*)
                      (loop for i from 1 to 8 collect 0)
                      (loop for i from 1 to 12 collect (- *pawn-val*)))))
            
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun checkers-material (board color)
  #- HPPA (declare (type board-array board))
  (declare (optimize (speed 3)(compilation-speed 0)(safety 0) (debug 0)))
  (* (color-sign color)
     (loop for i across board sum i fixnum)))
     ;(reduce #'+ board)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *checkers-judge-difference* 8)
(defun checkers-judge (board)
  (let ((m (checkers-material board :white)))
    (cond ((> m *checkers-judge-difference*) :white)
          ((< m (- *checkers-judge-difference*)) :black)
          (t :draw))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;        P  R  I  N  T  I  N  G      F  A  C  I  L  I  T  I  E  S            ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Below is a collection of function that is used for tracing and printing   ;;;
;;;  games.  There is no need to look into the details of these function.      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun checkers-print-board (board-to-print &optional old-board)
  
  ;; This function gets either a board or a move-record and prints it nicely
  ;; on the standard output.  For printing on file use PRINT-BOARD-LIST
  
  (let ()
      (format t "*******************~%")
      
      (dotimes (row *board-size*)
	     (format t "*")
	     (format t (create-row-string board-to-print row old-board))
	     (format t "*~%"))
    (format t "*******************~%")))


(defun create-square-string
  (board row col &aux (piece (get-piece-by-row-col board row col)))
  (cond ((null piece) #\-)
        ((= piece (- *king-val*)) #\B)
        ((= piece (- *pawn-val*)) #\b)
        ((= piece 0) #\-)
        ((= piece *pawn-val*) #\w)
        ((= piece *king-val*) #\W)
        (T #\ )))

 
(defun create-row-string
  (board row &optional prev-board)
  (let ((str (make-string (1+ (* 2 *board-size*)) :initial-element #\ ))
	)
    (dotimes (col *board-size*)
       (setf (elt str (1+ (* 2 col))) (create-square-string board row col)))
    (when prev-board
      (loop for col below *board-size*
          when (not (eql (get-piece-by-row-col board row col)
                         (get-piece-by-row-col  prev-board row col)))
          do
          (setf (elt str (* 2 col)) #\{)
          (setf (elt str (+ 2 (* 2 col))) #\})))
          
    
    str))

(defvar *board-lines-per-page* 6)

(defun checkers-print-board-list
    (board-list &key (out-stream t) (num-columns 4)(previous-board nil))
  (let* ((n (min (length board-list) num-columns))
	 (old-n n)
	 (board-rows 0) last-board )
    (loop while board-list
      do
      (loop repeat old-n do (format out-stream "******************")
        finally (format out-stream "*~%"))
      (loop for i below n do (format out-stream "|     ~4d        "
                                (+ (* board-rows num-columns) i))
        finally (format out-stream "|~%"))
      (loop repeat n do (format out-stream "******************") finally
        (format out-stream "*~%"))
      (loop for row below *board-size* do
          (loop for i below n
            for old-board = last-board then board
            for board in board-list
            do
            (format out-stream "|")
            (format out-stream (create-row-string board row
                                                  (or  previous-board old-board))))
          (format out-stream "|~%"))
      (setq last-board (elt board-list (1- n)))
      (setq board-list (nthcdr n board-list))
      (setq old-n n)
      (incf board-rows)
      (setq n (min (length board-list) num-columns))
      (loop repeat old-n do (format out-stream "******************")
        finally  (format out-stream "*~%"))
      (when (and board-list (= (rem board-rows *board-lines-per-page*) 0))
        (format out-stream "~|")
        (dotimes (i old-n) (format out-stream "******************"))
        (format out-stream "*~%")))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Interactive checkers player
;;
;; To play human against machine perform:
;; (play-game
;;     *interactive-checkers-player*
;;     (make-alpha-beta-player :depth 6 :eval-fn 'checkers-material))
;;
;; The program will display your current options with attached
;;numbers.  You enter your move by typing the number of the selected
;;move.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun interactive-checkers-player (board color)
  (let ((options (checkers-expand board color)))
    (setf *trace* t)
    (checkers-print-board-list options :previous-board board)
    (loop for response =
      (progn (format t "~%Please enter a number between 0 and ~d :"
                     (1- (length options)))
             (read))
      until (and (>= response 0)(< response (length options)))
      finally (return (elt options response)))))

(defparameter *interactive-checkers-player*
  (make-player :search-fn 'interactive-checkers-player))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *game*
  (make-game
   :win-predicate 'checkers-win-predicate 
   :expand-fn 'checkers-expand
   :init-board-fn  'checkers-create-initial-board
   :print-board-fn 'checkers-print-board
   :print-board-list-fn 'checkers-print-board-list
   :judge-fn 'checkers-judge
   ))