;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  General game written by Shaul Markovitch http://www.cs.technion.ac.il/~shaulm
;;;
;;;  The functions in this file are for running two-player board
;;;  games.
;;;  The main two functions are play-game for running a single game
;;;  and play-tour for running a sequence of games.
;;;  To test the package you can run
;;;  (play-tour *random-player* *random-player*)
;;;  With the checkers package, for example, load first
;;;  "general-game", then "checkers".  If you also load "alpha-beta"
;;;  you can run a tournament between two alpha-beta searchers by:
;;;  (play-tour (make-alpha-beta-player :depth 4 :eval-fn
;;'                 checkers-material)
;;;             (make-alpha-beta-player :depth 4 :eval-fn
;;'                 checkers-material))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Version: 7.53                                                 ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Last time modified: 16/5/01
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Change log
;;;  16/5/01 - Corrected a bug in determining exceeding of game time limit.
;;;            For move time limit we assumed an overhead factor in the form of 1.2
;;;            for allowing 20% overhead.  For game limit we assumed the form 0.2
;;;            to specify the same.  We now use the second form (0.2) and we
;;;            changed the line checking move time limit to reflect this.
;;;       
;;;  15/1/01 - Corrected a bug in move-remaining-time
;;;  2/12/99 - Corrected several bugs with game time control.
;;;  8/12/99 - Added access functions for remaining moves.
;;; 13/12/99 - The compiler decided that the two instances of the list
;;;            ((:white 0)(:black 0)) assigned to *remaining-moves*
;;             and *game-timer* are the same object.  This caused
;;;            problems with timing.  A change was made to avoid this.
;;; 28/12/00 - Changes has been done to allow move-oriented programming.
;;;            The game structure has been extended, and minor changes 
;;;            were done to the play-game function.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; game
;;;
;;; The main data structure used to defined a new game.  For defining
;;; a new game, the programmer must define all the necessary functions
;;; and set the global *game* variable to a new instance of game with 
;;; appropriate slots.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct game
  expand-fn
					;A function that takes a board and a color
					;and returns a list of boards, 
					;successors of the given board. An alternative 
					;approach is to use the move oriented functions below.
  
  win-predicate
					;A function that looks at a board and determines if it is a final
					;position
  (judge-fn #'(lambda (board)(declare (ignore board)) :draw))
					;A function that looks at a non-terminal board and decides who wins
  init-board-fn
					;A function that returns an initial position of the game
  print-board-fn
					;A function for printing a board
  print-board-list-fn
					;A function for printing a list of boards
  (eq-board-fn #'equalp)
					;A function for comparing two boards
  copy-board-fn
					;A function returning a copy of a board
  init-move-fn
					;A function for performing initialization before
					;searching for a move
  
  ;;;The following four fields are needed only for  move oriented alpha-beta
  moves-fn				;returns a list of moves
  legal-move-fn
					;A predicate that decides whether a move is legal.  
  apply-move-fn				;A function that destructively applies a move
  undo-move-fn				;A function that destructively undos a move
  
  )

(defvar *game* nil "Holds the functions defining the currrent game")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A structure holding information that determines a playing strategy
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct player
  (search-fn 'random-search)
  ;; A function which gets two parameters: a board and a color (either 
  ;; :black or :white) and must return a board which is a legal
  ;; successor of the given board.
  (name (gensym "Player"))       ;; A name for tournament tracing
  (authors nil)
  (init #'(lambda (color)(declare (ignore color)) nil))
     ;; A function that will be called at a beginning of each game for 
     ;;initializations particular to the specific player.  The default 
     ;;does nothing.
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; A structure holding information about the result of a game
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct result
  winner
      ;;Either :white or :black or :draw
  (reason :simple-win)
      ;;The reason for the winning - either :simple-win or :judge (if
      ;;the result was determined by a judge) or :move-limit (if the
      ;;number of moves exceeded the allowed number) or
      ;;:time-limit-per-move-exceeded or :time-limit-per-game-exceeded 
      ;;or :illegal move.
  (moves 0)
      ;; The number of moves of the game
  (time 0)
      ;; A list of the form ((:white xxx)(:black yyy)) where xxx is
      ;;the total time consumed by :white during the game and yyy is
      ;;the total time consumed by :black.
  )

(defvar *tournament-length* 100 "The default tournament length")
(defvar  *move-limit* 100 "A limit on the length of the game")
(defvar *use-judge* nil
  "If T a judging function will be called when move limit reached")
(defvar *time-control-per-move* nil
  "A flag which determines whether time control per move should be employed")
(defvar *time-control-per-game* nil
  "A flag which determines whether time control per game should be employed")
(defparameter *max-seconds-per-move* 3
  "The number of seconds allowed per move")
(defparameter *max-seconds-per-game* 30
  "The number of seconds allowed per game")
(defvar *trace* nil "When T prints the game states during the game")




(setq *random-state* (make-random-state t))

(defun opponent (color)(if (eq color :white) :black :white))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This is a user callable function that returns the number of
;;; remaining moves for a particular color.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *remaining-moves* (list (list :white 0)(list :black 0)))
(defun reset-move-counter ()
  (setf (second (first *remaining-moves*))(ceiling (/ *move-limit* 2))
        (second (second *remaining-moves*))(floor (/ *move-limit*
                                                     2))))
(defun decrement-move-counter (color)
  (decf (second (assoc color *remaining-moves*))))

(defun remaining-moves (color) (second (assoc color *remaining-moves*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Time Control Functions

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; start-timer: a macro that gets a variable and set it to the
;;; current time (in internal time units
;;; read-timer: returns the current value of the timer in seconds.
;;; example:
;;;  (let (timer)
;;;    (start-timer timer)
;;;    (loop .....)
;;;    (format t "%Running time was ~f seconds." (read-timer timer)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



(defmacro start-timer (timer)
  `(setf ,timer (get-internal-run-time)))

(defmacro read-timer (timer)
  `(float (/ (- (get-internal-run-time) ,timer)
	      internal-time-units-per-second)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *move-timer* nil)
(defvar *game-timer* (list (list :white 0)(list :black 0)))
(defun reset-game-timer ()(setf (second (first *game-timer*)) 0
                                (second (second *game-timer*)) 0))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; move-remaining-time
;;; Main user function for time control on moves.  Returns the 
;;; numbers of seconds remaining for the current move.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun move-remaining-time ()(- *max-seconds-per-move* (read-timer *move-timer*)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; game-remaining-time
;;; Main user function for time control on games.  Returns the 
;;; numbers of seconds remaining for the current game.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun game-remaining-time (color)
  (- *max-seconds-per-game* (second (assoc color *game-timer*))))
(defun increase-game-timer (color time)
  (incf (second (assoc color *game-timer*)) time)) 

(defparameter *overhead-factor* 0.2)
(defparameter *initial-randomization* nil)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; play-game
;;;
;;; One of the main user functions.  Gets two player objects as
;;; parameters and performs a game between them.  The start-color
;;; optional parameter determines which color starts [should be 
;;; either :white or :black (unquoted).  Returns a result object
;;; which lists the winner, the number of moves, the time per
;;; player.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun play-game (white-player black-player &key (start-color :white))

  (let ((board (funcall (game-init-board-fn *game*)))
	(color start-color) winner
	)
    (when *initial-randomization* (setf board (randomize-board board color)))
      
    (reset-game-timer)
    (reset-move-counter)
    (loop for counter from 1
      for player = (if (eql color :white)
                       white-player
                     black-player)
	  do
	  (setf winner (funcall (game-win-predicate *game*) board
                                color))
          ;;A final position
	  (when winner (return (make-result :winner winner :moves
                                            counter :time (copy-tree *game-timer*))))
	  (when (> counter *move-limit*) ;number of moves exceeded limit
            (return (make-result :winner (if *use-judge*
                                             (funcall (game-judge-fn
                                                       *game*) board)
                                            :draw)
                                 :reason (if *use-judge* :judge 
                                                  :move-limit)
                                 :moves counter
                                 :time (copy-tree *game-timer*))))
 	  (when *trace* (format t "~%~d] Player:  ~A~%" counter color))
          (start-timer *move-timer*)
          (when (<= counter 2)(funcall (player-init player) color))
	  (let* ((new-board             ;The actual move computation
                  (funcall (player-search-fn player)
                           board color))
                 (move-time (read-timer *move-timer*))
                 legal-moves)
            (when (and *time-control-per-move*
                       (> move-time (* (+ 1 *overhead-factor*)
                                       *max-seconds-per-move*)))
              ;; Too much time per move
              (return-from play-game
                (make-result :winner (opponent color)
                             :reason :time-limit-per-move-exceeded
                             :moves counter :time (copy-tree *game-timer*))))
           
            (increase-game-timer color move-time)
            (decrement-move-counter color)
            (when (and *time-control-per-game*
                       (< (game-remaining-time color)
                          (- (* *overhead-factor*
                             *max-seconds-per-game*))))
              ;; Too much time per game.
              (return-from play-game
                (make-result :winner (opponent  color)
                             :reason :time-limit-per-game-exceeded
                             :moves counter :time (copy-tree *game-timer*))))
            (when *trace* (funcall (game-print-board-fn *game*) new-board board))
	    
	    (when (illegal-move board new-board color)
		   ;; Ilegal move
		   (return-from play-game 
                           (make-result :winner (opponent color)
                                        :reason :illegal-move
                                        :moves counter :time (copy-tree *game-timer*))))
            (setq board new-board)
            (setq color (opponent color))))))
   
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; illegal-move
;;; Tests whether a move is legal.  Uses the expand function if exists,
;;; otherwise assumes move-based implementation.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun illegal-move (board new-board color)
  (if (game-expand-fn *game*)
      (not (member new-board  (funcall (game-expand-fn *game*) board color)
		   :test (game-eq-board-fn *game*)))
    (loop for move in (funcall (game-moves-fn *game*) board color)
	never (let ((board-found nil))
		(when (funcall (game-legal-move-fn *game*)
			       move board color)
		  (funcall (game-apply-move-fn *game*) move board color)
		  (setf board-found (funcall (game-eq-board-fn *game*)
					     board new-board))
		  (funcall (game-undo-move-fn *game*) move board color))
		board-found))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  To avoid repeating the same game, we have the option of starting
;;;  the game by a sequence of random moves.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defparameter *randomization-length* 1)

(defun randomize-board (board color)
  (loop repeat *randomization-length*
      do
	(setf board (random-search board color))
	(setf board (random-search board (opponent color))))
  board)
		 
	       
      
	   
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Random search
;;; 
;;; Not a very smart player function.  returns a random successor of
;;the given board.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun random-search (board  color)
   ;;  This is the most simple playing function - just picks a random
   ;;  move out of the set of legal moves.  Just for testing.
  (cond ((game-expand-fn *game*)
	 (let ((boards (funcall (game-expand-fn *game*) board color)))
	   (elt boards (random (length boards)))))
	(t (let* ((legal-moves (loop for move in (funcall (game-moves-fn *game*) board color)
			 when (funcall (game-legal-move-fn *game*) move board color)
				   collect move))
		  (selected-move (elt legal-moves (random (length legal-moves))))
		  (new-board (funcall (game-copy-board-fn *game*) board)))
	     (funcall (game-apply-move-fn *game*) selected-move new-board color)
	     new-board))))
	     

(defparameter *random-player*
   (make-player :search-fn #'random-search))

(defun play-random-game ()
  ;;  Call (play-random-game) to see a game 
   (play-game *random-player* *random-player* ))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Tournament playing
;;;
;;;  The function gets two players and performs a tournament between
;;;  them.  It returns two values:  The first value is a list of three
;;;  numbers indicating the number of wins for :white, the number of
;;;  draws and the number of wins for :black.  The second value is the 
;;;  list of the result records.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun play-tour (player1 player2 &key
			  (n *tournament-length*)
			 )
  (loop with results-summary = (list 0 0 0)
	for i from 1 to n
	for start-color = :white then (opponent start-color)
	for outcome = (play-game player1 player2
				 :start-color start-color
				)
	do
	(case (result-winner outcome)
            (:white (incf (first results-summary)))
            (:draw (incf (second results-summary)))
            (:black (incf (third results-summary))))
	(format t "~% ~3d: ~6a ~3d [~6,2F~6,2F] [~3d,~3d,~3d] ~A " i
                (result-winner outcome)(result-moves outcome)
                (second (assoc :white (result-time outcome)))
                (second (assoc :black (result-time outcome)))
                (first results-summary)(second results-summary)(third results-summary)
                (if (equal (result-reason outcome) :SIMPLE-WIN)
                    " " (result-reason outcome)))
        collect outcome into outcomes
	finally
	(return-from play-tour (values results-summary outcomes))))


(defun tour-score (res)
  (/ (+ (first res)(* 0.5 (second res)))
     (apply #'+ res)))