;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Connect-n - By Shaul Markovitch
;;;
;;;  This file contains an implementation of the game connect-n (the
;;;  most known instance of it is the game connect-4).
;;;  In the standard connect four game, there are six rows, seven
;;;  columns.  Each player drops a piece into one of the columns.  The
;;;  one who first manages to get-t consecutive pieces in any direction
;;;  wins the game.
;;;  For efficiency, boards are represented by a pair of bit vectors.
;;;  The first vector represent the squares occupied by white pieces.
;;;  The second vector represent the squares occupied by white pieces.
;;;  The binary vector represents the board in
;;;  column major order.  Thus, for the standard connect-4 game,
;;;  starting from the less significant
;;;  bit, bit 0 through bit 5 represent the first column, bits 6
;;;  through bit 11 the second column etc.  An occupied square is
;;;  marked by 1.  An empty square by 0.
;;;  The game can be played with any number of columns, number of rows
;;;  and number of pieces that should be connected.
;;;
;;;  This file contains the functions specific to connect-n.  To play
;;;  the game the user should first load the file "general-game", then
;;;  load this file.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
(defconstant *columns* 7)		;The number of columns in a board
(defconstant *rows* 6)			;The number of rows in a board
(defconstant *board-size* (* *rows* *columns*))
(defconstant *connect-n* 4)		;The number of pieces in a row
					;for winning

(deftype color-vector ()`(simple-bit-vector ,*board-size*))

(defun make-color-vector ()
  (the color-vector
       (make-array (list *board-size*) :initial-element 0
			  :element-type 'bit)))

(defun copy-color-vector (old-vector)
  (declare (type color-vector old-vector))
  (let ((new-vector (the color-vector
			 (make-array (list *board-size*)
     :element-type 'bit :initial-contents old-vector))))
    new-vector))
    
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; connect-initial-board
;;;   Creates a new initial board of the game.  This function is
;;;   called by the "play-game" function in "general-game"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun connect-initial-board ()
  (list (make-color-vector)(make-color-vector))
	)	;No white pieces, no black pieces

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; loc-index
;;;  A utility function - gets the location of a square in double
;;;  index notation and returns the location in a single index notation.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun loc-index (col row) (declare (type fixnum col row))
				    (+ (* col *rows*) row))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  whites blacks
;;;   Access functions.  Whites returns the white components of a board
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun whites (board)(first board))
(defun blacks (board)(second board))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; get-hash-key
;;;   A function for creating hash key for a board.  In the current
;;;   representation, the board itself can be used as a hash key
;;;   together with "equal".  If one wishes to create a more efficient
;;;   hash key, this function need a replacement.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun get-hash-key (board) board)

(defun copy-color (color-vec)
  (declare (type color-vector color-vec))
  (let ((c (make-color-vector)))
    (declare (type color-vector c))
    (bit-ior c color-vec t)
    c))

(defvar *temp-vector* (the color-vector (make-color-vector))) ;Temporary vector to avoid
					   ;garbage collection
(declaim (type color-vector *temp-vector*))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Connect-expand
;;;
;;;  The main function of this file.  gets a board and a color and
;;;  generates all the legal successors for the given color.  The
;;;  color should be either :black or :white (need not be quoted).
;;;  Note - The function makes copy only of the part of the board that
;;;  is modified.  The other board is pointed to without copying to
;;;  save some time (and memory).  The function returns a multiple
;;;  value list.  The first value is the list of the boards.  The
;;;  second value is the list of the move numbers.  This second list
;;;  is typically used by various tracing and printing functions.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun connect-expand
  (board color)					
  (let* ((whites (whites board))
	 (blacks (blacks board))
	 (all *temp-vector*)
	 boards moves)
    (declare (type color-vector whites blacks all))
    (declare (optimize (speed 3)(safety 0)))
    (bit-ior blacks whites all)		;A vector that contains both
					;white and black bits.
  (loop for col fixnum below *columns*	;Each column is a potential move
	for start fixnum = (loc-index col 0) ;The column top square
	;;  The following condition tests whether there is any empty
	;;  square in this column.
	when (zerop (sbit all start))
	do
	;; We copy only the vector that is modified.
	(let ((new-board
		  (if (eq color :white)
		      (list (copy-color whites) blacks)
		    (list whites (copy-color blacks)))
		      ))
	  ;;The following loop tests for the first unoccupied square
	  ;;in the current column starting from the bottom.
	  (loop for i fixnum downfrom (+ start *rows* -1) to start 
		until (zerop (sbit all i))
		finally
		(progn
		  (setf 
		   (sbit
		    (if (eq color :white)
			(the color-vector (whites new-board))
		      (the color-vector (blacks new-board)))
		    i) 1)
		  (push new-board boards)
		  (push col moves)))))
  (values boards moves)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Masking functions
;;;
;;;  The masking function are called only once when the file is
;;;  loaded.  Their only purpose is to save time for the evaluation
;;;  function.  They create all the possible combinations of sections
;;;  of size 4 (*connect-n* in general).  There are four possible
;;;  directions for such sections: horizontal, vertical, and two
;;;  diagonals. The mask list is a list of masks.  Each mask is a list
;;;  of indices.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun create-col-masks ()
  (loop for col below *columns* append
	(loop for r1 from 0 to (- *rows* *connect-n*)
	      collect
	      (loop for r from r1 below (+ r1 *connect-n*)
		    collect (loc-index col r)))))
(defun create-row-masks ()
  (loop for row below *rows* append
	(loop for c1 from 0 to (- *columns* *connect-n*)
	      collect
	      (loop for c from c1 below (+ c1 *connect-n*)
		      collect (loc-index c row)))))

(defun create-lr-masks ()
  (loop for col below *columns*
	append
	(loop for r-start from (1- *connect-n*) below *rows*
	      for c-start = col 
	      for c-end = (1- (+ *connect-n* c-start))
	      for r-end = (1+ (- r-start *connect-n*))
	      when (and (< c-end *columns*)
		       (>= r-end 0))
		    collect
		    (loop for c from c-start to c-end
			  for r from r-start downto r-end
			  collect (loc-index c r)))))
			  
		    
(defun create-rl-masks ()
  (loop for col below *columns*
	append
	(loop for r-start from (1- *connect-n*) below *rows*
	      for c-start = col 
	      for c-end = (1+ (- c-start *connect-n*))
	      for r-end = (1+ (- r-start *connect-n*))
	      when (and (>= c-end 0)
		       (>= r-end 0))
		    collect
		    (loop for c from c-start downto c-end
			  for r from r-start downto r-end
			  collect (loc-index c r)))))
  

(defun create-masks()
  (append (create-col-masks)(create-row-masks)
	  (create-rl-masks)(create-lr-masks)))

(defparameter *masks* (create-masks))

(defun create-diff-list (masks)
  (let* ((new-masks (list (pop masks)))
	 (last-mask (first new-masks))
	(diff-list nil))
    (loop while masks
	do
	(loop with min-diff = (make-list (1+ *connect-n*))
	      with min-mask
	      for m in masks
	      for diff = (set-difference m last-mask)
	      when (< (length diff) (length min-diff))
	      do (setf min-diff diff min-mask m)
	      finally
	      (progn (push min-diff diff-list)
		     (push min-mask new-masks)
		     (setf masks (remove min-mask masks))
		     (setf last-mask min-mask))))
    (list (reverse new-masks) (reverse diff-list))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The following two vectors are containers for the white and black
;;; features evaluated by the evaluation functions.  Their only
;;; purpose is to save garbage collection time by using global
;;; variables.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *white-features* (make-array (list (1+ *connect-n*))
                                           :element-type 'fixnum
					   :initial-element 0))
(defparameter *black-features* (make-array (list (1+ *connect-n*))
                                           :element-type 'fixnum
					   :initial-element 0))
(deftype feature-array ()`(simple-array fixnum (,(1+ *connect-n*))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; clear-features
;;;  Initializes all the features to be zero
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun clear-features (arr)
  (declare (type feature-array arr))
  (loop for i fixnum from 0 to *connect-n*
	do (setf (aref arr i) 0)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  compute-features
;;;
;;;  The main function for evaluating a board.  Each possible section
;;;  of *connect-n* squares is tested.  If it contains only pieces of
;;;  one color, the number of pieces determine the feature.  Thus, the
;;;  function returns the number of single white pieces in a section,
;;;  the number of pairs, or triples etc.  Same goes for blacks.
;;;  Instead of returning new vectors of features the values are
;;;  returned in the feature vectors that are given as argument.  This
;;;  was done to save garbage collection.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun compute-features
  (board white-features black-features)
  (declare (type feature-array white-features)
	   (type feature-array black-features))
  (let ((whites (whites board))
	(blacks (blacks board)))
    (declare (type color-vector whites)
	     (type color-vector blacks))
    (declare (optimize (speed 3)(safety 0)))
    (clear-features white-features)
    (clear-features black-features)
    ;; Recall that each mask is a list of *connect-n* indices that
    ;; indicate a section of four squares in one of the four
    ;; directions. 
  (loop for mask in *masks*
	for white-count fixnum = (loop for m fixnum in mask
				       sum (sbit whites m) fixnum)
	for black-count fixnum = (loop for m fixnum in mask
				       sum (sbit blacks m) fixnum)
	when (> (+ white-count black-count) 0)
	do
	(cond ((zerop black-count)
	       (incf (aref white-features white-count) 1))
	      ((zerop white-count)
	       (incf (aref black-features black-count) 1))))
  ))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The coefficient vector determines how the features should be
;;; combined. The default behavior induce lexicographical order on the
;;; set of features.  Thus, for the case of connect-4, the number of
;;; triples will be the dominant feature, then the number of pairs etc.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *connect-base* 20)

(defparameter *coefficients*
  (make-array (list (1+ *connect-n*))
              :element-type 'fixnum
	      :initial-contents
	      (loop for i from 0 to *connect-n*
		    collect (expt *connect-base* i))))
(declaim (type feature-array *coefficients*))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; connect-eval
;;;
;;; The evaluation function for the connect-n game.  computes the
;;; features and computes the polynomial to get the value of a board.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun connect-eval
  (board color)
  (let ((white-features *white-features*)
	(black-features *black-features*)
	(mult (if (eq color :white) 1 -1)))
    (declare (type feature-array white-features)
	     (type feature-array black-features))
     (compute-features board white-features black-features)
    (cond ((> (aref white-features *connect-n*) 0)
	   (* mult *infinity*))
	  ((> (aref black-features *connect-n*) 0)
	   (* mult (- *infinity*)))
	  (t (* mult
		(loop for i fixnum from 1 to *connect-n*
		   for w fixnum = (aref white-features i)
		   for b fixnum = (aref black-features i)
		   sum (* (aref *coefficients* i)(- w b))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; connect-win-predicate
;;;
;;; Gets a board and returns one of the values: :white, :black, :draw
;;; or nil.  Works similarly to "compute-features", but does less
;;; work.  As soon as a *connect-n* section of one color is detected,
;;; it returns the appropriate symbol.  If none was found, the
;;; function tests for draw condition - when the whole board is
;;; occupied.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
					
(defun connect-win-predicate (board &optional color)
  (declare (ignore color))
  (let ((whites (whites board))
	(blacks (blacks board))
	(black-count 0)( white-count 0)
	)
    (declare (type fixnum white-count black-count))
    (declare (type color-vector whites blacks))
    (loop for mask in *masks* do
	  (setq white-count (loop for m fixnum
				  in mask sum (bit whites m)))
	  (cond ((= white-count *connect-n*)
		 (return-from connect-win-predicate :white))
		((= white-count 0)
		 (setq black-count (loop for m fixnum
					 in mask sum (bit blacks
								m)))
		 (when (= black-count *connect-n*)
			 (return-from connect-win-predicate :black)))))
    (let ((all *temp-vector*))
      (declare (type color-vector all))
      (bit-ior whites blacks all)
      (when (loop for col fixnum below *columns*
		  for index fixnum = (loc-index col 0)
		  always (= (bit all index) 1))
	    (return-from connect-win-predicate :draw)))))
		 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; random-board
;;;
;;; A utility function used for debugging.  Generates a random board
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
       
(defun random-board (&optional (seq-length (random *board-size*)))
  (let ((b (connect-initial-board))
	(color :white))
    (loop repeat seq-length
	  for new-boards = (connect-expand b color)
	  do
	  (when (null new-boards)(return-from random-board b))
	  (setf b (elt new-boards (random (length new-boards))))
	  (setf color (opponent color)))
    b))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Printing functions
;;;
;;; The following functions allow simple ASCII printing of boards or
;;; full games.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *white-char* "w")
(defparameter *black-char* "b")
(defparameter *empty-char* "-")
(defparameter *wall-char* "#")
(defparameter *insertion-char* "v")

(defun col-changed (b1 b2)
  (loop for i below *board-size*
    when (or (not (= (aref (whites b1) i)
                     (aref (whites b2) i)))
             (not (= (aref (blacks b1) i)
                     (aref (blacks b2) i))))
    return (floor (/ i *rows*))))

(defun create-board-print-array
  (board &optional (old-board nil))
  (let ((char-array (make-array (list (+ 2 *rows*)(+ 2 *columns*))
				:initial-element *empty-char*))
        (move (when old-board (col-changed board old-board)))
        )
  (loop for col below (+ 2 *columns*)
	do (setf (aref char-array 0 col) " ")
	(setf (aref char-array (1+ *rows*) col) *wall-char*))
  (loop for row from 1 to (1+ *rows*) do
	(setf (aref char-array row 0) *wall-char*)
	(setf (aref char-array row (1+ *columns*)) *wall-char*))
  (when move (setf (aref char-array 0 (1+ move)) *insertion-char*))
  (loop for row below *rows* do
	(loop for col below *columns*
	      for index = (loc-index col row)
	      do
	      (setf (aref char-array (1+ row)(1+ col))
		    (cond ((= (bit (whites board) index)1) *white-char*)
			  ((= (bit (blacks board) index) 1)
			   *black-char*)
			  (t *empty-char*)
			  )))
	)
  char-array))

(defun connect-draw-board
  (board &optional (move nil)(offset 0))
  (let ((arr (create-board-print-array board move)))
    (loop for row below (+ 2 *rows*) do
	  (format t "~%~VT" offset)
	  (loop for col below (+ 2 *columns*) do
		(format t "~a" (aref arr row col))))
    (format t "~%")))

(defparameter *chars-in-row* 80)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Draw-boards
;;;  The main printing function.  Gets a list of boards and prints
;;;  them several boards in each row.
;;;  It can also gets an optional list of moves.  A move is a number
;;;  between 0 and the number of columns minus 1.  The list of moves
;;;  should have the same length as the list of boards.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun connect-draw-boards
  (boards &key (moves (make-list (length boards)))
	  (stream t))
  (let ((boards-in-row (truncate *chars-in-row* (+ 3 *columns*))))
    (loop with row-boards
	  for i from 1
	  for b in boards
	  for m in moves
	  do
	  (push (create-board-print-array b m) row-boards)
	  (when (or (zerop (mod i boards-in-row))
		    (= i (length boards)))
		(loop for row from 0 below (+ 2 *rows*)
		      do
		      (format stream "~%")
		      (loop for arr in (reverse row-boards)
			    do
			    (loop for col below (+ 2 *columns*)
				  do (format stream "~a"
					     (aref arr row col)))
			    (format stream " ")))
		(format stream "~%")
		(setf row-boards nil)))))




(defun interactive-play (board depth color expand-fn win-predicate
			       eval-fn)
   (declare (ignore depth)(ignore eval-fn)(ignore win-predicate))
   (multiple-value-bind (boards moves)
       (funcall expand-fn board color)
       (let (move)
	 (format t "Please enter a move (a number between 1 to ~d): "
		 *columns*)
	 (setq move (read))
	 (loop  until (and (fixnump move)(> move 0)(<= move *columns*))
	       do
	       (format t
		   "Error!!! Please enter a move (a number between 1 to ~d: "
		 *columns*)
	       (setq move (read)))
	 (loop for b in boards for m in moves when
	       (= (- move 1) m) do (return-from interactive-play
					  (values b m))))))


(defparameter *interactive-player*
  (make-player :search-fn 'interactive-play))
		   
    
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *game*
  (make-game
   :win-predicate 'connect-win-predicate 
   :expand-fn 'connect-expand
   :init-board-fn  'connect-initial-board
   :print-board-fn 'connect-draw-board
   :print-board-list-fn 'connect-draw-board
   :judge-fn nil
   ))