;;; ----------------------------------------------------------------------
;;;
;;; TTTLPLAYE: Learning player implementation
;;;
;;; ----------------------------------------------------------------------
;;;
;;; 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
;;; ----------------------------------------------------------------------
;;;

(defmethod .tell-start-game ((player .<lplayer>) other-name which)
  (setf (.lplayer-which player) which)
  (setf (.lplayer-moves player) ())
  (setf (.lplayer-other-moves player) ())
  (call-next-method))

(defmethod .tell-move ((player .<lplayer>) other-name move state)
  ;; Store the other player's moves too, to learn twice as fast.
  (ignore other-name)
  (let ((nstate (copy state)))
    (setf (sref nstate move) #\.)
    (pushf (.lplayer-other-moves player)
      (vector nstate
	      (if (char= (.lplayer-which player) #\x) #\o #\x)
	      move))))

(defmethod .ask-move ((player .<lplayer>) state legal-moves)
  ;; Choose the best memorized move, or, if none are winning, choose a
  ;; random move.
  (let ((chosen (.find-best-move player (copy state) legal-moves)))
    (destructuring-let (((bscore bentry bmove) chosen))
      (pushf (.lplayer-moves player) bentry)
      (.pprintf player "Moving to %d with score %d.\n" bmove bscore)
      (cond ((i> bscore 0)
	     (.pprintf player "++ Looks like a good move.\n"))
	    ((i< bscore 0)
	     (.pprintf player "-- Looks like a rotten move.\n")))
      bmove)))

(defun .find-best-move (player state legal-moves)
  (let* ((which (.lplayer-which player))
	 (memory (.lplayer-memory player))
	 (best-score (smallest-int))
	 (best-moves ()))
    (for ((move in: legal-moves))
      (block find-permutation
	(for ((permutation in: .permutations))
	  ;; Find the canonicalized version of this state, if any.
	  (let* ((pstate (.permuted-state state permutation))
		 (pmove (.permuted-move move permutation))
		 (entry (vector pstate which pmove))
		 (score (ptref memory entry)))
	    (when score
	      (cond ((i> score best-score)
		     (setf best-score score)
		     (pushf best-moves (list best-score entry move)))
		    ((i= score best-score)
		     (pushf best-moves (list best-score entry move))))
	      (return-from find-permutation))))
	;; nothing was found; suppose this move is worth 0.
	(cond ((i= best-score 0)
	       (pushf best-moves (list 0 (vector state which move) move)))
	      ((i< best-score 0)
	       (setf best-score 0)
	       (pushf best-moves (list 0 (vector state which move) move)))
	      ((i> best-score 0) ()))))
    (lref best-moves (rand 0 (i1- (llen best-moves))))))

(defglobal .permutations
  ;; Each entry is a vector of index increments.
  '(#( 0  0  0  0  0  0  0  0  0)	; identity
    #( 0  2  4 -2  0  2 -4 -2  0)	; diag flip up right -> low left
    #( 2  0 -2  2  0 -2  2  0 -2)	; horizontal flip
    #( 2  4  6 -2  0 -4 -6 -4 -2)	; counter-clockwise rotation
    #( 6  2 -2  4  0 -4  2 -2 -6)	; clockwise rotation
    #( 6  6  6  0  0  0 -6 -6 -6)	; vertical flip
    #( 8  4  0  4  0 -4  0 -4 -8)	; diag flip up left -> low right
    #( 8  6  4  2  0 -2 -4 -6 -8)	; 2 flips
    ))

(defun .permuted-state (state permutation)
  ;; Given a board state, produce a new state modified according to
  ;; the permutation.
  (let ((result (make-string 9 #\$)))
    (for (((i inc) in-vector: permutation)
	  (char in-string: state))
      (setf (sref result (i+ i inc)) char))
    result))

(defun .permuted-move (move permutation)
  (i+ move (vref permutation move)))

(defmethod .tell-winner ((player .<lplayer>) winner-name positions)
  (ignore positions)
  (if winner-name
      (.pprintf player "%s won; updating memory.\n" winner-name)
    (.pprintf player "Tie game.\n"))
  (when winner-name
    ;; if tie, scores not updated
    (let ((inc (if (string= winner-name (.player-name player)) 1 -1))
	  (memory (.lplayer-memory player)))
      (for ((move in: (.lplayer-moves player)))
	(let ((old-score (ptref memory move 0)))
	  (setf (ptref memory move) (i+ old-score inc))))
      (for ((move in: (.lplayer-other-moves player)))
	(let ((old-score (ptref memory move 0)))
	  (setf (ptref memory move) (i- old-score inc)))))))

;;; To see what he's got up his sleeve...

(defun .print-memory (player)
  (let* ((memory (.lplayer-memory player))
	 (items
	  (collecting
	    (for (((key value) in-pattern-table: memory))
	      (collect (cons value key))))))
    (setf items
      (nlsort items (lambda (e1 e2) (i> (car e1) (car e2)))))
    (for ((item in: items))
      (destructuring-let (((score . entry) item))
	(printf "Playing %c, from %A go to %d with %d certainty.\n"
		(vref entry 1)
		(vref entry 0)
		(vref entry 2)
		score)))))

(defun .save-memory (player file)
  (assert (not (access file)))
  (with-posix-streams ((os (fopen file 'w)))
    (fprintf os "(\n")
    (for (((key value) in-pattern-table: (.lplayer-memory player)))
      (fprintf os "(%A %A)\n" key value))
    (fprintf os ")\n")))

(defun .read-memory (player file)
  (assert (access file))
  (with-posix-streams ((is (fopen file 'r)))
    (let ((entries (read is))
	  (memory (.lplayer-memory player)))
      (ptclear memory)
      (for ((entry in: entries))
	(setf (ptref memory (car entry)) (cadr entry))))))
