;;; ----------------------------------------------------------------------
;;;
;;; TTTMGRE: Tic Tac Toe Manager
;;;
;;; ----------------------------------------------------------------------
;;;
;;; This file is part of ILOG Talk.
;;; Inquiries to ILOG S.A.
;;;              9 rue de Verdun, BP 85,
;;;              94253 Gentilly Cedex, France.
;;;
;;; Copyright (c) 1994-1996 by ILOG
;;; ----------------------------------------------------------------------
;;;

;;; This module implements the game of Tic-tac-toe between two
;;; players.  Three objects are involved in each game:  Two players,
;;; which are instances of a subclass of ttt.<player>, and one game
;;; object, an instance of ttt.<game>.  A game can be started between
;;; two players with the function .start-game, or see the module
;;; tttserve for a way to play across the network.

;;; Each player must respond to a protocol of generic functions to
;;; implement its strategy (if automatic) and/or interface (if
;;; interfacing to a human player).  See the README file for a
;;; description of this protocol.

(defun .start-game (x-player o-player)
  ;; Start and play a new Tic-Tac-Toe game.
  (let ((game (.make-game
	       x-player: x-player
	       o-player: o-player)))
    (.tell-start-game x-player (.ask-player-name o-player) #\x)
    (.tell-start-game o-player (.ask-player-name x-player) #\o)
    (while (not (.game-winner game))
      (.do-game-turn game))))

(defun .do-game-turn (game)
  ;; Do one turn in the game GAME.
  (let* ((x-player (.game-x-player game))
	 (o-player (.game-o-player game))
	 (current-player (.game-current-player game))
	 (other-player (.game-other-player game)))
    (when (null current-player)
      (.message 'mgr "Setting up game between %A and %A\n" x-player o-player)
      (setf (.game-current-player game) x-player)
      (setf (.game-other-player game) o-player)
      (setq current-player x-player)
      (setq other-player o-player))
    (block turn
      (let ((end (.find-winner game)))
	(when end
	  (let ((winner (car end))
		(positions (cdr end)))
	  (.store-results winner x-player o-player)
	  (if (eq winner t)
	      (.message 'mgr "Game %A ended in a tie.\n" game)
	    (.message 'mgr "Winner of %A is %A at %A\n" game winner positions))
	  (setf (.game-winner game) winner)
	  (let ((winner-name (if (eq winner t)
				 ()
			       (.ask-player-name winner))))
	    (.tell-winner x-player winner-name positions)
	    (.tell-winner o-player winner-name positions)
	    (return-from turn winner)))))
      (let ((move (.get-move game current-player)))
	(.message 'mgr "%A moved to %d\n" current-player move)
	(setf (sref (.game-state game) move)
	  (if (eq current-player x-player) #\x #\o))
	(.tell-move other-player
		    (.ask-player-name current-player) move (.game-state game)))
      (if (eq current-player x-player)
	  (progn
	    (setf (.game-current-player game) o-player)
	    (setf (.game-other-player game) x-player))
	(progn
	  (setf (.game-current-player game) x-player)
	  (setf (.game-other-player game) o-player)))
      ()
      )))

(defun .get-move (game current-player)
  ;; Ask the current player what move to make.  To make things easy,
  ;; give him the legal moves to choose from.
  (let* ((legal-moves (.find-legal-moves game))
	 (move
	  (.ask-move current-player (.game-state game) legal-moves)))
    ;; A move is simply an index from 0 to 8.
    (assert (.legal-move-p move legal-moves)
      (.game-error game #!.illegal-move (.ask-player-name current-player)))
    move))

(defun .find-winner (game)
  ;; Find out if the game has a winner.  Possible return values are
  ;; #\x, #\o, t (tie), and () (continue).
  (let ((winner (.find-state-winner (.game-state game))))
    (cond ((null winner) ())
	  ((charp winner) '(t))
	  (t (let ((win-char (car winner))
		   (win-pos (cdr winner)))
	       (cons (case win-char
		       (#\x (.game-x-player game)) ; x wins
		       (#\o (.game-o-player game))) ; o wins
		     win-pos))))))

;;; Persistent result management

(defglobal .result-file
  ;; Contents is an a-list:
  ;;  ((name wins losses ties) ...)
  #f"${HOME}/tmp/ttt-results")

(defglobal .ttt-results
  ;; Local cache for the contents of .result-file.
  ())

(defun .store-results (winner x-player o-player)
  (.store-results-in-file
   winner x-player o-player
   (if (access .result-file) (.read-results) ())))

(defun .store-results-in-file (winner x-player o-player results)
  (cond ((eq winner t)
	 (setf results (.inc-result-entry results x-player 0 0 1))
	 (setf results (.inc-result-entry results o-player 0 0 1)))
	((eq winner x-player)
	 (setf results (.inc-result-entry results x-player 1 0 0))
	 (setf results (.inc-result-entry results o-player 0 1 0)))
	((eq winner o-player)
	 (setf results (.inc-result-entry results x-player 0 1 0))
	 (setf results (.inc-result-entry results o-player 1 0 0)))
	(t (error '.store-results-in-file #!erroob
		  winner x-player o-player)))
  (setf .ttt-results results)
  (with-posix-streams ((os (fopen .result-file 'w)))
    (pprin results os t)
    (newline os)))

(defun .inc-result-entry (results player wins losses ties)
  (let* ((name (.ask-player-name player))
	 (entry (assoc name results #'string=)))
    (if (null entry)
	(cons (list name wins losses ties) results)
      (progn
	(setf (cdr entry)
	  `(,(i+ wins (cadr entry))
	    ,(i+ losses (caddr entry))
	    ,(i+ ties (car (cdddr entry)))))
	results))))

(defun .read-results ()
  (with-posix-streams ((is (fopen .result-file)))
    (read is)))


(defglobal .winners
  ;; The winning combinations...
  #((0 1 2)
    (1 4 7)
    (2 4 6)
    (3 4 5)
    (4 0 8)
    (5 2 8)
    (6 3 0)
    (7 6 8)
    ))

(defun .find-state-winner (state)
  (block winner
    ;; See if there's a winner.
    (for ((combo in-vector: .winners))
      (let ((winner (.matching-state-p combo state)))
	(when winner
	  (return-from winner
	    (cons winner combo)))))
    ;; Now see if there's not a tie
    (for ((val in-string: state))
      (when (char= val #\.)
	(return-from winner ())))
    ;; There's a tie.
    #\.))

(defun .matching-state-p (combo state)
  (let ((type (sref state (popf combo))))
    (and (not (char= type #\.))
	 (char= (sref state (popf combo)) type)
	 (char= (sref state (car combo)) type))))

(defun .find-legal-moves (game)
  (collecting
    (for (((i val) in-string: (.game-state game)))
      (when (char= val #\.)
	(collect i)))))

(defun .legal-move-p (move legal-moves)
  (debug-assert (proper-list-p legal-moves))
  (and (intp move) (member move legal-moves)))

;;; Etc.

(defun .game-error (game msg rest: args)
  (apply #'efprintf (stderr) msg args)
  (apply #'.tell-game-error (.game-x-player game) msg args)
  (apply #'.tell-game-error (.game-o-player game) msg args))

(defmethod prin-object ((g .<game>) stream)
  (let* ((x-player (.game-x-player g))
	 (o-player (.game-o-player g))
	 (winner (.game-winner g))
	 (string (sprintf () "#<Game %s%s (x) vs. %s%s (o) #p%08lp>"
			  (if (eq x-player winner) "*" "")
			  (.ask-player-name x-player)
			  (if (eq o-player winner) "*" "")
			  (.ask-player-name o-player)
			  g)))
    (prin-string string stream)))

;;; Messages

(defmessage .illegal-move
  english: "%s made an illegal move"
  french: "%s a fait un mouvement illégal")
