;;; ----------------------------------------------------------------------
;;;
;;; TTTHPLAYE: Human player
;;;
;;; ----------------------------------------------------------------------
;;;
;;; 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
;;; ----------------------------------------------------------------------
;;;

(defglobal .data-dir #f"${ILT_DIR}/talk/contrib/ttt/data")
(defglobal .dialog-file (merge-filenames .data-dir #f"ttt" ".ilv"))

(defglobal .dialog-players
  ;; Map from dialogs to players.
  (make-hash-table))

(defun make-human-player (rest: keywords)
  (let* ((d (the-IlvDisplay))
	 (dialog (IlvDialog d "Tic Tac Toe" "Tic Tac Toe"
			    (string .dialog-file)))
	 (player (apply #'.make-hplayer
			dialog: dialog
			keywords)))
    (setf (htref .dialog-players dialog) player)
    (->setLabel (->getObject dialog "your-name")
		(.player-name player))
    (->setDestroyCallback dialog #'.quit player)
    (->registerCallback dialog "Game/Start" #'.game-start)
    (->registerCallback dialog "Game/Quit" #'.game-quit)
    (->deSelect (->getObject dialog "board"))
    (let ((menu (->getSubMenu (->getObject dialog "menubar") 0)))
      (->setClientData (->getItem menu 0) player)
      (->setClientData (->getItem menu 2) player)
      )
    (->show dialog)
    player
    ))

(defun start-human-player (player)
  (fprintf (stderr) "Trying to start %A...\n" player)
  (if (not (eq (.hplayer-state player) 'free))
      (warn 'start-human-player #!.player-not-free player)
    (progn
      (setf (.hplayer-state player) 'waiting)
      (submit-ttt-player player
			 (.hplayer-host player)
			 (.hplayer-port player))
      (let ((dialog (.hplayer-dialog player)))
	(->setLabel (->getObject dialog "opponents-name") "")
	(->setLabel (->getObject dialog "opponent-plays") "")
	(->setLabel (->getObject dialog "you-play") "")
	(->setLabel (->getObject dialog "your-turn") "Waiting for game")
	(->setLabel (->getObject dialog "opponents-turn")
		    "Waiting for game")
	(->reDraw dialog))
      player)))

(defmethod .tell-start-game ((player .<hplayer>) other-name which)
  (setf (.hplayer-state player) 'playing)
  (let* ((dialog (.hplayer-dialog player))
	 (opponents-name (->getObject dialog "opponents-name"))
	 (you-play (->getObject dialog "you-play"))
	 (opponent-plays (->getObject dialog "opponent-plays"))
	 (board (->getObject dialog "board"))
	 )
    (setf (htref .board-player board) player)
    (setf (.hplayer-opponent-name player) other-name)
    (setf (.hplayer-side player) (if (char= which #\x) "X" "O"))
    (setf (.hplayer-other-side player) (if (char= which #\x) "O" "X"))
    (->setLabel opponents-name other-name)
    (->setLabel you-play
		(make-string 1 (if (char= which #\x) #\X #\O)))
    (->setLabel opponent-plays
		(make-string 1 (if (char= which #\x) #\O #\X)))
    (->setLabel (->getObject dialog "your-turn") "")
    (->setLabel (->getObject dialog "opponents-turn") "Opponent's turn")
    (->setExclusive board t)
    (let ((item-color (->getColor (the-IlvDisplay) "lightSkyBlue")))
      (for ((i from: 0 to: 8))
	(let ((mitem (.get-item board i)))
	  (->setLabel mitem "")
	  (->setBackground mitem item-color)
	  (->setItemCallback board
			     (.move-column i) (.move-row i)
			     #'.board-item-callback)
	  (->setItemData board (.move-column i) (.move-row i) ())
	  ))
      (->reDraw dialog)
      )))

(defcallback .quit IlvDestroyCallback (top data)
  (let ((player (proxy-ptr data)))
    (.pprintf player "Quitting from control.\n")
    (delete top)
    (signal (.make-exit-condition))
    ))

(defcallback .game-quit IlvGraphicCallback (graphic data)
  (ignore graphic)
  (let ((player (proxy-ptr data)))
    (assert (.playerp player))
    (.pprintf player "Quitting from menu.\n")
    (delete (.hplayer-dialog player))
    (signal (.make-exit-condition))
    ))

(defcallback .game-start IlvGraphicCallback (graphic data)
  (ignore graphic)
  (let ((player (proxy-ptr data)))
    (assert (.playerp player))
    (if (eq (.hplayer-state player) 'free)
	(progn (.pprintf player "Asking server to start a game with me.\n")
	       (start-human-player player))
      (.pprintf player
		"Player not free.  Please finish current game first.\n"))))

(defdynamic .*asking-for-move-p* ())
(defdynamic .*selected* ())
(defglobal .board-player (make-hash-table))

(defcallback .board-item-callback IlvMatrixItemCallback (board col row data)
  (let ((player (htref .board-player board)))
    (assert player)
    (let ((dialog (.hplayer-dialog player)))
      (cond ((null (dynamic .*asking-for-move-p*))
	     (.pprintf player "not your turn: c=%d, r=%d\n" col row)
	     (->deSelect board)
	     (->reDrawObj dialog board))
	    ((null data)
	     (.pprintf player "illegal move: c=%d, r=%d\n" col row)
	     (->deSelect board)
	     (->reDrawObj dialog board))
	    (t (let ((move (.col-row-move col row)))
		 (.pprintf player "moved to c=%d, r=%d, move=%d\n"
			   col row move)
		 (setf (dynamic .*selected*) move)))))))

(defun .get-item (board i)
  ;; This better work...
  (cast IlvFilledLabelMatrixItem* (->getItem board i)))

(defmethod .tell-move ((player .<hplayer>) other-name move new-state)
  (ignore new-state other-name)
  (let* ((mstring (.hplayer-other-side player))
	 (dialog (.hplayer-dialog player))
	 (board (->getObject dialog "board"))
	 (item (.get-item board move)))
    (->setLabel item mstring)
    (->setItemData board (.move-column move) (.move-row move) ())
    (->reDraw dialog)))

(defmethod .tell-winner ((player .<hplayer>) winner-name positions)
  (let* ((i-won-p (and winner-name
		       (string= winner-name (.player-name player))))
	 (my-string (cond ((null winner-name) "Tie game")
			  (i-won-p "You won")
			  (t "You lost")))
	 (other-string (if (null winner-name)
			   "Tie game"
			 (sprintf () (if i-won-p "%s lost" "%s won")
				  (.hplayer-opponent-name player))))
	 (dialog (.hplayer-dialog player)))
    (->setLabel (->getObject dialog "your-turn") my-string)
    (->setLabel (->getObject dialog "opponents-turn") other-string)
    (when winner-name
      (let ((board (->getObject dialog "board"))
	    (win-color (->getColor (the-IlvDisplay) "red")))
	(for ((pos in: positions))
	  (let ((item (.get-item board pos)))
	    (->setBackground item win-color)))))
    (->reDraw dialog)
    (setf (.hplayer-state player) 'free)
    ))

(defmethod .ask-move ((player .<hplayer>) state legal-moves)
  (ignore state)
  (.pprintf player "need a move from %A\n" legal-moves)
  (let* ((dialog (.hplayer-dialog player))
	 (board (->getObject dialog "board"))
	 (your-turn (->getObject dialog "your-turn"))
	 (opponents-turn (->getObject dialog "opponents-turn")))
    (->setLabel opponents-turn "")
    (->setLabel your-turn "Your turn")
    (->reDraw dialog)
    (for ((move in: legal-moves))
      (->setItemData board (.move-column move) (.move-row move) t))
    (let ((move ()))
      (unwind-protect
	  (block get-move
	    (dynamic-let ((.*selected* ())
			  (.*asking-for-move-p* t))
	      (while t
		(select)
		(when (dynamic .*selected*)
		  (setq move (dynamic .*selected*))
		  (debug-assert (member move legal-moves))
		  (return-from get-move move)))))
	(progn
	  (for ((move in: legal-moves))
	    (->setItemData board (.move-column move) (.move-row move) ()))
	  (->setLabel (.get-item board move) (.hplayer-side player))
	  (->setLabel opponents-turn "Opponent's turn")
	  (->setLabel your-turn "")
	  (->deSelect board)
	  (->reDraw dialog))))))

(defmethod .tell-game-error ((player .<hplayer>) msg rest: args)
  (->get (IlvIQuestionDialog (the-IlvDisplay)
			     (sprintf () "%s: %s"
				      (.player-name player)
				      (apply #'sprintf () msg args))))
  (setf (.hplayer-state player) 'free)
  )

;;; Utility functions

(defun .col-row-move (c r) (i+ (i* r 3) c))
(defun .move-row (move) (i/ move 3))
(defun .move-column (move) (i% move 3))

(defmethod prin-object ((p .<hplayer>) stream)
  (let ((s (sprintf () "#<human player %s (%A) [host: %s, port: %s] #p%08lp>"
		    (.player-name p)
		    (.hplayer-state p)
		    (.hplayer-host p)
		    (.hplayer-port p)
		    p)))
    (prin-string s stream)
    (free-row s)))
  
;;; Messages

(defmessage .player-not-free
  english: "player not free"
  french: "joueur n'est pas libre")
