;;; -*- Mode: Scheme -*-

;;; Playing TIC TAC TOE (tlp@mit.edu)

(define *VERBOSITY* 1)			; how much to print
(define *MAX-DEPTH* 3.)			; default search depth
(define *NUMBER-OF-STATIC-EVALUATIONS* 0)
(define *TEST-FOR-CUTOFF* #t)		; in alpha-beta
(define *+INF* 9e10)
(define *-INF* -9e10)
(define *WIN* 100)

(define *BOARD-WIDTH* 3)
(define *BOARD-SIZE* (* *board-width* *board-width*))
(define (ALL-BOARD-INDICES)
  (do ((i 0 (+ i 1))
       (l '()))
      ((= i *BOARD-SIZE*) l)
    (set! l (cons i l))))

;;; Make sure that these are defined.
(define FIRST car)
(define SECOND cadr)
(define REST cdr)

;;; Basic data structures for Tic-Tac-Toe (TTT) or Checkers.  A
;;; POSITION is composed of (next-player board).  The player is either
;;; X or O indicating the NEXT player to go.  The BOARD is a vector
;;; with X's and O's indicating "piece" positions. A MOVE is
;;; (move-coordinates resulting-position), where move is a board
;;; index.

(define (MAKE-POSITION next-player board)
  (list next-player board))
(define (POSITION-NEXT-PLAYER position)
  (first position))
(define (POSITION-BOARD position)
  (second position))
(define (POSITION-PLAYER position)	; the opposite of the next player
  (if (eq? (position-next-player position) 'X)
      'O
      'X))

(define (MAKE-BOARD)
  (make-vector *BOARD-SIZE* #f))
(define (BOARD-ENTRY BOARD i)
  (vector-ref board i))
(define (SET-BOARD-ENTRY board i player)
  (vector-set! board i player))

(define (MAKE-MOVE coordinates result-position)
  (list coordinates result-position))
(define (MOVE-COORDINATES move)
  (and move (first move)))
(define (MOVE-POSITION move)
  (and move (second move)))

;;; Interactive TIC-TAC-TOE game playing program.
;;; The user goes first and gets to be O, the machine plays X.

;;; This is a general function for playing a game between two arbitray
;;; functions, one of which could be read-user-move.  Player-functions
;;; is of the form ((o <fn>) (x <fn>)) where the functions take a
;;; position and return a move.

(define (PLAY-GAME position player-functions)
  (let* ((player-function 
	  (next-player-function position player-functions))
	 (move (player-function position))
	 (new-position (position-after-move move position)))
    (if (>= *verbosity* 1)
	(print-move move new-position))
    (if (>= *verbosity* 2)
	(print-position new-position))
    (cond ((winning-position? new-position)
	   (print-position new-position)
  	   (print-winner new-position)
	   (position-player new-position))
	  ((game-done? new-position)
	   (print-position new-position)
	   (begin (newline)
		  (display " Looks like a tie ...")
		  (newline))
	   'tie)
	  (else
	   (play-game new-position player-functions)))))

(define (NEXT-PLAYER-FUNCTION position player-functions)
  (second (assoc (position-next-player position) player-functions)))

;;; Given a position this computes the coordinates of the best move by
;;; calling ALPHA-BETA.  The optinal argument specifies the depth of
;;; lookahed in the search tree.

(define (BEST-MOVE position . max-depth)
  (set! *number-of-static-evaluations* 0)
  (if (game-done? position) 
      #f
      ;; loop over moves and pick best one
      (do ((moves (legal-moves position) (cdr moves))
	   (best-val *-inf*)
	   (best-mov #f))
	  ((null? moves) 
	   ;; got to the end, return best-mov, but first print.
	   (if (>= *verbosity* 3)
	       (print-best-move position best-val best-mov)) 
	   (if (>= *verbosity* 2)
	       (print-static-evals))
	   (move-coordinates best-mov))
	(let* ((depth
		(if (null? max-depth)
		    *max-depth* ; default
		    (car max-depth)))
	       (value
		(- (alpha-beta (move-position (car moves))
			       *-inf* *+inf* 
			       (- depth 1)
			       ))))
	  (cond ((> *verbosity* 1))
		(print-position (move-position (car moves)))
		(newline)
		(display " Has value = ") (display value))
	  (cond ((> value best-val)
		 (set! best-val value)
		 (set! best-mov (car moves))))))
      ))

;;; Alpha Beta Procedure, coded using NegaMax for compactness.
;;; Computes the best value and does some printing.

(define (ALPHA-BETA position alpha beta depth)
  ;; Loop over the legal moves from this position
  (define (alpha-beta-loop moves)
    (if (null? moves) alpha
	(let ((value (- (alpha-beta (move-position (car moves))
				    (- beta)
				    (- alpha)
				    (- depth 1)))))
	  (if (> value alpha)		; found a better one
	      (set! alpha value))
	  (if (and *test-for-cutoff* (>= alpha beta))
	      ;; skip the rest of the moves, they can't be better
	      alpha
	      ;; keep looking
	      (alpha-beta-loop (cdr moves))))))
  (if (>= *verbosity* 3)
      (print-ab-state position alpha beta depth #f))
  (let ((value
	 (cond ((winning-position-for? position (position-next-player position)) *win*)
	       ((winning-position-for? position (position-player position)) (- *win*))
	       ((= depth 0)
		(static-evaluation position))
	       (else
		(let ((moves (legal-moves position)))
		  (if (null? moves)	; end of game
		      (static-evaluation position)
		      (alpha-beta-loop moves)
		      ))))))
    (if (>= *verbosity* 3)
	(print-ab-state position alpha beta depth value))
    value
    ))

;;; The static evaluation function estimates how good the position is

(define (STATIC-EVALUATION position)
  (let ((value (static-evaluation-fn-aux position))) ; use the game specific function
    (if (>= *verbosity* 3)
	(begin (newline) (display " Static evaluation is ") (display value)))
    (set! *number-of-static-evaluations* (+ 1 *number-of-static-evaluations*))
    value))

(define (STATIC-EVALUATION-FN-TRIVIAL position) ; say nothing...
  0)

(define STATIC-EVALUATION-FN-AUX STATIC-EVALUATION-FN-TRIVIAL) ; default

;;; Some utilities ...
      
(define (PRINT-POSITION position)
  (newline)
  (display " The NEXT player to move is ")
  (display (position-next-player position))
  (do ((i 0 (+ i 1)))
      ((= i *BOARD-WIDTH*))
    (newline) (display "  ")
    (do ((j 0 (+ j 1)))
	((= j *BOARD-WIDTH*))
      (let ((index (board-index i j)))
	(display (or (board-entry (position-board position) (board-index i j))
		     (+ index 1)	; 1 based i/o
		     '_)))
      (display "  "))))

(define (PRINT-BEST-MOVE position value move)
  (cond (move
	 (newline)
	 (display " The best move from this position:")
	 (print-position position)
	 (newline)
	 (display " is to this position:")
	 (print-position (move-position move))
	 (newline)
	 (display " The backed-up value is = ")
	 (display value)
	 )
	(else
	 (newline)
	 (display " Could not find a move."))))

(define (PRINT-MOVE move position)
  (newline)
  (display " move is: ") 
  (display (position-player position))
  (display " -> ")
  (display (+ move 1))			; 1-based i/o
  (newline))

(define (PRINT-AB-STATE position alpha beta depth value)
  (newline)
  (display " Evaluating at depth= ") (display depth)
  (display " alpha=  ") (display alpha) 
  (display " beta= ") (display beta)
  (display " value= ") (display value)
  (print-position position))

(define (PRINT-STATIC-EVALS)
  (newline) (display *number-of-static-evaluations*)
  (display "  static evaluations were needed"))

(define (PRINT-WINNER position)
  (newline)
  (display " Win for player ")
  (display (position-player position))
  (newline))

;;; Simulate a move and create the resulting position.
(define (POSITION-AFTER-MOVE move position)
  (and move
       (let* ((new-board (copy-board (position-board position)))
	      (new-position (make-position (position-player position)
					   new-board)))
	 (set-board-entry new-board move
			  (position-next-player position))
	 new-position)))

(define (VALID-INDEX? i)
  (and (number? i) (< i *board-size*) (>= i 0)))

(define (COPY-BOARD board)
  (let ((new-board (make-board)))
    (do ((i 0 (+ 1 i)))
	((= i *board-size*))
      (set-board-entry new-board i (board-entry board i)))
    new-board))

(define (every fn l)
  (cond ((null? l) #t)
	((fn (car l)) (every fn (cdr l)))
	(else #f)))

(define (user-vs-machine) 
  (play-game (initial-position) `((o ,read-user-move) (x ,best-move))))

(define (machine-vs-user) 
  (play-game (initial-position) `((o ,best-move) (x ,read-user-move))))

;;; Play the machine against itself in a tournament, specify the
;;; search-depth for o and x.  Also specify the static evaluation function.

(define (machine-vs-machine d1 f1 d2 f2) 
  (tournament				; game specific
   `((o ,(lambda (p) 
	   (fluid-let
	       ((STATIC-EVALUATION-FN-AUX f1))
	     (best-move p d1))))
     
     (x ,(lambda (p) 
	   (fluid-let
	       ((STATIC-EVALUATION-FN-AUX f2))
	     (best-move p d2)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TTT-specific functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; in TTT all i,j positions are valid
(define (BOARD-INDEX i j) (+ (* *BOARD-WIDTH* i) j))

(define (INITIAL-POSITION)
  (make-position 'O (make-board)))

;;; Legal move function for TIC TAC TOE, returns a list of all the
;;; legal MOVE's.  This is very wasteful in that it computes the whole 
;;; board for each move (you would not want to do this for chess...).

(define (LEGAL-MOVES position)
  (let ((next-player (position-next-player position))
	(player (position-player position))
	(board (position-board position))
	(legal-moves '()))
    (do ((i 0 (+ 1 i)))
	((= i *board-width*))
      (do ((j 0 (+ 1 j)))
	  ((= j *board-width*))
	(let ((index (board-index i j)))
	  (if (not (board-entry board index))
	      (let ((new-board (copy-board board)))
		(set-board-entry new-board index next-player)
		(set! legal-moves
		      (cons (make-move index
				       ;; the position encodes NEXT player
				       (make-position player
						      new-board))
			    legal-moves)))))))
    legal-moves))

;;; This returns a score that depends of the number of rows, columns,
;;; and diagonals in which only members of players can be found.  This
;;; is useful for detecting winners as well as in computing static
;;; evaluations.  So when PLAYERS=(X), this would count how many ways
;;; the X player has won already.  When PLAYERS=(X #f), this would
;;; count (weighted) how many ways the X player might win eventually,
;;; that is, how many rows, columns and diagonals do not have an O in
;;; them.

(define *ROWS* 
  (list '(0 1 2) '(3 4 5) '(6 7 8)))

(define *COLUMNS*
  (list '(0 3 6) '(1 4 7) '(2 5 8)))

(define *DIAGONALS*
  (list '(0 4 8) '(2 4 6)))

;;; Given a board and a list of players or #f, returns a number which
;;; is the sum of a score for each row, column and diagonal.  If the
;;; row has players not listed in values, then the score is 0.  If the
;;; values include #f, then if the column, row, or diag has 1 mark,
;;; return w1, if it has two marks, return w2, if it has 3 return
;;; w2*w2.

(define (TTT-WEIGHT-WINNERS board values w1 w2)
  (let ((value1 (car values))
	(value2 (if (null? (cdr values)) 'none (cadr values))))
    
    (define (value indeces)
      (define (value-aux indeces i1 i2 i3)
	(cond ((null? indeces)
	       (cond ((> i3 0) 0)	; oponent present
		     ((= i1 1) w1)
		     ((= i1 2) w2)	; 2 in a row
		     ((= i1 3) (* w2 w2))
		     (else 0)))
	      (else
	       (let ((val (board-entry board (car indeces))))
		 (cond ((eq? val value1)
			(value-aux (cdr indeces) (+ i1 1) i2 i3))
		       ((eq? val value2)
			(value-aux (cdr indeces) i1 (+ i2 1) i3))
		       (else
			(value-aux (cdr indeces) i1 i2 (+ i3 1))))))))
      (value-aux indeces 0 0 0))

    (if (not value1)			; make sure value1 is not #f
	(let ((v value2))
	  (set! value2 value1)
	  (set! value1 v)))
    (+ (apply + (map value *rows*))
       (apply + (map value *columns*))
       (apply + (map value *diagonals*)))))

(define (TTT-STATIC-EVALUATION-FN position)
  (- (ttt-weight-winners
      (position-board position)
      ;; we're evaluating this for the next-player - whose turn this is.
      (list (position-next-player position) #f)
      1 10)
     (ttt-weight-winners
      (position-board position)
      ;; position-player produced this board, so he is the oponent.
      (list (position-player position) #f)
      1 10)))

(define (WINNING-POSITION? position)
  (> (ttt-weight-winners (position-board position)
			 (list (position-player position))
			 1 1)
     0))

(define (WINNING-POSITION-FOR? position player)
  (> (ttt-weight-winners (position-board position) (list player) 1 1)
     0))

(define (GAME-DONE? position)
  (every (lambda (x) (board-entry (position-board position) x))
	 (all-board-indices)))

(define (READ-USER-MOVE position)
  (print-position position)
  (cond ((null? (legal-moves position)) #f)
	(else
	 (newline)
	 (display "Please enter a move as an integer: ")
	 (newline)
	 (let ((user-move (read)))
	   (if (and (number? user-move)
		    (valid-index? (- user-move 1))
		    (not (board-entry (position-board position) (- user-move 1))))
	       (- user-move 1)		; 1-based i/o
	       (begin
		 (newline)
		 (display "That's not a valid move; try again ... ")
		 (read-user-move position))))
	 )))

;;; This plays games with each player starting at each possible
;;; starting position, so it plays 18 games.

(define (TOURNAMENT player-functions)
  (map (lambda (position)
	 (if (> *verbosity* 0)
	     (display "====================================="))
	 (play-game position player-functions))
       (apply append
	      (map (lambda (x-o)
		     (map (lambda (move)
			    (position-after-move 
			     move (make-position x-o (make-board)))
			    )
			  (all-board-indices))
		     )
		   '(x o)))))