;;; TIC-TAC-N Written by Shaul Markovitch, http://www.cs.technion.ac.il/~shaulm 
;;;  
;;; This file contains the functions for implementing the TIC-TAC-N game. 
;;; The functions in this file should be used with the general functions in 
;;; general-game.lisp.  TIC-TAC-N is played exactly like TIC-TAC-TOE.  There 
;;; are two differences.  While in TIC-TAC-TOE the board size is 3X3, in TIC-TAC-N 
;;; the board can be of size NXN for any N.  While in TIC-TAC-TOE the goal 
;;; is to create a file of 3 pieces in a line, in TIC-TAC-N the goal is to 
;;; create a file of K pieces where K is any number equal of less than N. 
;;; 
;;; 
;;; Because the branching factor is quite large (NXN) and because each 
;;; move changes only one location on the board, I decided to use a move 
;;; based approach rather than expand-based approach.  That means that 
;;; in each search node, the search algorithm will apply the moves one 
;;; after another.  Each move will destructively change the board but 
;;; after returning from the search it will undo the change.  That means 
;;; that the search consumes very little memory (there is only one board 
;;; in memory at each stage). An alpha-beta search procedure implementing 
;;; this approach is available at alpha-beta-m.lisp. 
;;; 
;;;  A TIC-TAC-N board is represented by an NXN array where each element is 
;;;  a symbol: either :black, :white, or :empty. 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
(declaim (optimize (speed 3)(compilation-speed 0)(safety 0) (debug 0))) 
 
(defconstant *board-size* 6  "The size of the board (assumed to be a square)") 
(defconstant *tic-n* 4 "The length of group sufficient for victory") 
 
(deftype tic-tac-board () `(simple-array symbol (,*board-size* ,*board-size*))) 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;; tic-tac-initial-board 
;;; 
;;; Creates an empty tic-tac-n board
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun tic-tac-initial-board () 
  (the tic-tac-board (make-array (list *board-size* *board-size*) 
				 :initial-element :empty :element-type 'symbol))) 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;; tic-tac-copy
;;; 
;;; Creates a copy opf a board
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 

(defun tic-tac-copy (board) 
  (declare (type tic-tac-board board)) 
  (let ((new-board (make-array (list *board-size* *board-size*) 
			       :initial-element :empty :element-type 'symbol))) 
    (declare (type tic-tac-board new-board)) 
    (loop for r below *board-size* do  
	  (loop for c below *board-size* do (setf (aref new-board r c)(aref board r c)))) 
    new-board)) 


(defparameter *moves* (loop for row below *board-size* append 
			    (loop for col below *board-size* collect 
				  (list row col)))
  "The list of possible moves.  A move is represented by a pair (row col)") 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;; tic-tac-moves
;;; 
;;; Returns the list of possible moves
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun tic-tac-moves (board color) 
  *moves*) 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;; tic-tac-legal
;;; 
;;; Tests whether a move is legal (the square is empty).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun tic-tac-legal (move board color) 
  (declare (type tic-tac-board board)) 
  (eq :empty (aref board (first move)(second move)))) 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;; tic-tac-apply-move
;;; 
;;; Applies a move destructively on a board.  In addition it updates the 
;;; counters of potential "lines"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun tic-tac-apply-move (move board color) 
  (declare (type tic-tac-board board)) 
  (setf (aref board (first move)(second move)) color) 
  (update-count-from-move move color ) 
  ) 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;; tic-tac-undo-move
;;; 
;;; Undo a move destructively .  In addition it updates (undoes) the 
;;; counters of potential "lines"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun tic-tac-undo-move (move board color) 
  (declare (type tic-tac-board board)) 
  (update-count-from-move move color -1 ) 
  (setf (aref board (first move)(second move)) :empty)) 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;; tic-tac-win-predicate
;;; 
;;; Tests whether the given position is a winning position.
;;; Most of the times it will be called from the search procedure.  There
;;; the potentials counters are updated and the test is relatively easy.
;;; It just looks for a potential file filled with the same color.  Since
;;; when called during the search the last move is give, it can check
;;; inly the potential lines that contain the last move. 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
(defun tic-tac-win-predicate (board color &key (last-move nil)) 
  (declare (type tic-tac-board board)) 
  
  (cond ((null last-move) 
	 (update-count-from-board board) 
	 (loop for i below *n-potential* 
	     for count = (aref *group-count* i) 
			 do (cond ((= (first count) *tic-n*)  
				   (return-from tic-tac-win-predicate :white)) 
				  ((= (second count) *tic-n*)  
				   (return-from tic-tac-win-predicate :black))))) 
	(t (loop for i in (aref *square-index* (first last-move)(second last-move)) 
	     for count = (aref *group-count* i) 
			 do (cond ((= (first count) *tic-n*)  
				   (return-from tic-tac-win-predicate :white)) 
				  ((= (second count) *tic-n*)  
				   (return-from tic-tac-win-predicate :black))))))
  (when (loop for r below *board-size* always 
	      (loop for c below *board-size* always 
		    (not (eq (aref board r c) :empty)))) 
    (return-from tic-tac-win-predicate :draw)) )
   
   
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;;  Potential groups
;;;  
;;; This implementation maintains a data structure of all the potential groups.
;;; It is used for testing the win condition, but it can also be used for the 
;;; evaluation function.  A potential group is a sequence of *tic-n* squares
;;; in one of the 4 possible directions.  When loading we generate the list
;;; (which is a function of *board-size* and *tic-n*).  The number of potential
;;; groups is calculated.  We create an array with an entry for each potential
;;; group.  Each entry contains the list of squares belonging to the group.
;;; We also maintain a data structure which is a two-dimensional array with
;;; the same size as the board.  For each square we hold a list of all the potential
;;; groups where it is a member.  Lastly, we hold a one dimensional array
;;; of the same size as the potential groups.  Each entry is a list
;;; of two counters: the first for the white pieces and the second for the black ones.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 
 
(defconstant *n-potential*  
    (let ((k (1+ (- *board-size* *tic-n*)))) 
      (+ (* k *board-size* 2) 
	 (* (- (* (loop for i from 1 to k sum i) 2) k) 2)))
  "The number of possible groups in the 4 directions"
  ) 

(defparameter *potential-groups* 
    (make-array *n-potential*) "Contains the array of potential groups") 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;;  initialize-potential-group
;;; 
;;;  Initializes the array of the potential groups. 
;;;  This is needed mainly for the second stage which involves creating he 
;;;  square index.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 

(defun initialize-potential-groups () 
  (let ((index 0)) 
    (loop for r below *board-size* do 
	  (loop for c1 from 0 to (- *board-size* *tic-n*) do 
		(setf (aref *potential-groups* index) 
		  (loop for c from c1 below (+ c1 *tic-n*) collect (list r c))) 
		(incf index))) 
    (loop for c below *board-size* do 
	  (loop for r1 from 0 to (- *board-size* *tic-n*) do 
		(setf (aref *potential-groups* index) 
		  (loop for r from r1 below (+ r1 *tic-n*) collect (list r c))) 
		(incf index))) 
    (loop for col below *board-size* do 
	(loop for r-start from (1- *tic-n*) below *board-size* 
	      for c-start = col  
	      for c-end = (1- (+ *tic-n* c-start)) 
	      for r-end = (1+ (- r-start *tic-n*)) 
	      when (and (< c-end *board-size*)(>= r-end 0)) 
	    do  
	      (setf (aref *potential-groups* index) 
		(loop for c from c-start to c-end 
		    for r from r-start downto r-end 
		    collect (list c r))) 
	      (incf index) 
	      )) 
    (loop for col below *board-size* do 
	(loop for r-start from (1- *tic-n*) below *board-size* 
	      for c-start = col  
	      for c-end = (1+ (- c-start *tic-n*)) 
	      for r-end = (1+ (- r-start *tic-n*)) 
	      when (and (>= c-end 0)(>= r-end 0)) 
	    do  
	      (setf (aref *potential-groups* index) 
		(loop for c from c-start downto c-end 
		    for r from r-start downto r-end 
		    collect (list c r))) 
	       (incf index) 
	      )))) 
(initialize-potential-groups) 
 
(deftype square-index-array () `(simple-array list (,*board-size* ,*board-size*))) 
(defparameter *square-index* (make-array (list *board-size* *board-size*))
  "This array holds for each square the list of groups where it is a member in") 
(declaim (type square-index-array *square-index*)) 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;; initialize-square-index
;;;
;;; Initializes the square index based on the potential group array.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 

(defun initialize-square-index () 
  (loop for r below *board-size* do 
	(loop for c below *board-size*  
	    for loc = (list r c) 
	    do 
	      (setf (aref *square-index* r c) 
		(loop for i below *n-potential* when 
		      (member loc (aref *potential-groups* i) :test #'equal)  
		    collect i))))) 
 
(initialize-square-index) 
 
(deftype group-array () `(simple-array list ,*n-potential*)) 
(defparameter *group-count* (make-array *n-potential* :initial-contents 
					(loop repeat *n-potential* collect (list 0 0)))
  "Holds two counters for each potential group: the number of white pieces
   and the number of black pieces within the group") 
(declaim (type group-array *group-count*)) 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;; update-count-from-board
;;;
;;; This procedure takes a board and updates all the group counters.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 

(defun update-count-from-board (board) 
  (loop for index below *n-potential* do  
	(setf (first (aref *group-count* index)) 0) 
	(setf (second (aref *group-count* index)) 0)) 
  (loop for r below *board-size* do 
	(loop for c below *board-size* 
	    for sq = (aref board r c) 
	    when (not (eq sq :empty)) 
	    do (let ((ind (if (eq sq :white) 0 1))) 
		 (loop for group-index in (aref *square-index* r c) do 
		       (incf (elt (aref *group-count* group-index) ind))))))) 
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;; update-count-from-move
;;;
;;; The procedure updates the counters based on the last move.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 

(defun update-count-from-move (move color &optional (inc 1)) 
   
  (let ((ind (if (eq color :white) 0 1))) 
    (loop for group-index fixnum in (aref *square-index* (first move)(second move)) do 
	  (incf (elt (aref *group-count* group-index) ind) inc))))	 
 
 
(defun tic-tac-draw-board (board &optional (last-board nil)) 
  (terpri) 
  (loop for row below *board-size* do 
	(loop for col below *board-size*  
	    for sq = (aref board row col) 
		 do (format t " ~a "  
			    (case sq  
			       (:empty ".") 
			       (:black "b") 
			       (:white "w")))) 
	(terpri))) 
 
(defparameter *game* 
  (make-game 
   :win-predicate 'tic-tac-win-predicate  
   :expand-fn nil 
   :init-board-fn  'tic-tac-initial-board 
   :print-board-fn 'tic-tac-draw-board 
   :print-board-list-fn 'tic-tac-draw-board 
   :judge-fn nil 
   :copy-board-fn 'tic-tac-copy 
   :moves-fn 'tic-tac-moves 
   :legal-move-fn 'tic-tac-legal 
   :apply-move-fn 'tic-tac-apply-move 
   :undo-move-fn 'tic-tac-undo-move 
   :init-move-fn 'update-count-from-board 
   ))