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

;;; Some basic game functions for simple checkers and tic-tac-toe.
;;; For use in 6.034 at MIT EECS (by 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* 1000)			; value of a win

(define *DISPLAY-SIZE* 300)		; virtual display coordinates

;;; Make sure that these are defined.
(define FIRST car)
(define SECOND cadr)
(define THIRD caddr)
(define REST cdr)
(define (1+ x) (+ x 1))
(define (1- x) (- x 1))

;;; Basic data structures for Checkers (or Tic Tac Toe).  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-spec
;;; resulting-position), where move is a board index.  A MOVE-SPEC
;;; specifies from square, to square and any captures.

;;; POSITION = (NEXT-PLAYER BOARD)
(define (MAKE-POSITION next-player board)
  (list next-player board))
(define POSITION-NEXT-PLAYER first)
(define POSITION-BOARD second)
(define (POSITION-PLAYER position)	; the opposite of the next player
  (other-player (position-next-player position)))

;;; BOARD = vector from {x, o, #f}
(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))

;;; MOVE = (MOVE-SPEC POSITION)
(define (MAKE-MOVE spec result-position)
  (list spec result-position))
(define MOVE-SPEC first)
(define MOVE-POSITION second)

;;; MOVE-SPEC = (FROM TO CAPTURES)
(define (MAKE-MOVE-SPEC from to captures)
  (list from to captures))
(define MOVE-SPEC-FROM first)
(define MOVE-SPEC-TO second)
(define MOVE-SPEC-CAPTURES third)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; TOP-LEVEL FUNCTIONS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Interactive (Checkers, Tic Tac Toe) game playing program.  The
;;; user goes first and gets to be O, the machine plays X.

(define (USER-VS-MACHINE) 
  (or *WINDOW* (if *DISPLAY-SIZE* (open-window *DISPLAY-SIZE*)))
  (play-game (initial-position 'o) `((o ,read-user-move) (x ,best-move))))

;;; Flip the roles
(define (MACHINE-VS-USER) 
  (or *WINDOW* (if *DISPLAY-SIZE* (open-window *DISPLAY-SIZE*)))
  (play-game (initial-position 'o) `((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) 
  (or *WINDOW* (if *DISPLAY-SIZE* (open-window *DISPLAY-SIZE*)))
  (play-game
   (initial-position 'o)
   `((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)))))))

;;; 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)
  (set! *number-of-static-evaluations* 0) ; keep track of how much work we do
  (let* ((player-function		; function to get move
	  (next-player-function position player-functions))
	 (move				; the move
	  (player-function position))
	 (new-position			; position after move
	  (move-position move)))
    (if (>= *verbosity* 1)
	(print-move move))
    (if (>= *verbosity* 2)
	(print-position new-position))
    (if *WINDOW* (display-position&moves new-position (list move)))
    (cond ((winning-position-for? new-position (position-player new-position))
	   ;; The position is a WIN
	   (print-position new-position)
	   (print-static-evals)
  	   (display-nl* " Win for player " (position-player new-position))
	   ;; return winning player
	   (position-player new-position))
	  ((game-done? new-position)
	   ;; No more moves, game over without a pre-emptive win.
	   (print-position new-position)
	   (print-static-evals)
	   (let ((o-score (final-score (position-board new-position) 'o))
		 (x-score (final-score (position-board new-position) 'x)))
	   (cond ((> o-score x-score)
		  (display-nl* " Win (on points) for player " 'o)
		  'o)
		 ((> x-score o-score)
		  (display-nl* " Win (on points) for player " 'x)
		  'x)
		 (else
		  (display-nl* " Looks like a tie ...")
		  'tie))
	   ))
	  (else
	   ;; keep going to next move
	   (play-game new-position player-functions)))))

(define (NEXT-PLAYER-FUNCTION position player-functions)
  ;; look up function for the next player associated with this position
  (second (assoc (position-next-player position) player-functions)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; BASIC ALPHA-BETA ENGINE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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

(define (BEST-MOVE position . max-depth)
  ;; loop over the legal moves and pick best one
  (let ((best-val *-inf*)
	(best-mov #f)
	(depth				; if no depth specified use default
	 (if (null? max-depth)
	     *max-depth*		; default
	     (car max-depth))))
    (for-each
     (lambda (move)
       (if (>= *verbosity* 3)
	   (begin (display "Evaluating ") (print-move move)))
       (let* ((value			
	       ;; negative of AB result, since we are one level up in the game tree.
	       (- (alpha-beta (move-position move)
			      *-inf* *+inf* 
			      (- depth 1)
			      ))))
	 (cond ((> *verbosity* 1))
	       (print-position (move-position move))
	       (display* " Has value = " value))
	 ;; We are maximizing the score here.
	 (cond ((> value best-val)	; found a better value, remember it.
		(set! best-val value)
		(set! best-mov move)))))
     (legal-moves position))
    ;; got to the end of moves, return best-mov, but first print.
    (if (>= *verbosity* 3)
	(print-best-move position best-val best-mov)) 
    (if (>= *verbosity* 2)
	(print-static-evals))
    ;; return the spec of the move
    best-mov
    ))

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

(define (ALPHA-BETA position alpha beta depth)
  ;; Auxiliary function to loop over the legal moves from this
  ;; position.
  (define (alpha-beta-loop moves)
    (if (and (not (null? moves)) (>= *verbosity* 3))
	(begin (display " Considering ") (print-move (car moves))))
    (if (null? moves) alpha		; return
	(let ((value			; note negation of lower level result
	       (- (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 (and (> depth 0) (>= *verbosity* 3)) ; the state before we recurse
      (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)
		;; at the leaves of the tree, use static evaluation
		(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)		; the state after we recurse
	(print-ab-state position alpha beta depth value))
    value
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; STATIC EVALUATION STUB
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; The static evaluation function estimates how good the position is
;;; (for next-player).  Mostly just calls STATIC-EVALUATION-FN-AUX,
;;; which is game specific and increments count.

(define (STATIC-EVALUATION position)
  (set! *number-of-static-evaluations* (1+ *number-of-static-evaluations*))
  (static-evaluation-fn-aux position)	; use the game specific function
  )

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

;;; This needs to be set by the game specific code to something better...
(define STATIC-EVALUATION-FN-AUX STATIC-EVALUATION-FN-TRIVIAL)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SOME UTILITIES ...
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (GAME-DONE? position)
  ;; no legal moves -> done
  (null? (legal-moves position)))

;;; Simulate a move and create the resulting position.
(define (POSITION-AFTER-MOVE mspec position player)
  (and mspec
       (let* ((new-board (copy-board (position-board position)))
	      (new-position 
	       (make-position (other-player player) ; switch turns
			      new-board)))
	 ;; the new position
	 (set-board-entry new-board (move-spec-to mspec) player)
	 ;; optionally remove previous position
	 (if (move-spec-from mspec)
	     (set-board-entry new-board (move-spec-from mspec) #f))
	 ;; eliminate the entries in the captured positions, may be null
	 (for-each (lambda (capture)
		     (set-board-entry new-board capture #f))
		   (move-spec-captures mspec))
	 new-position)))

;;; Make a new copy of board
(define (COPY-BOARD board)
  (let ((new-board (make-board)))
    (scan-squares
     (lambda (i) 
       (set-board-entry new-board i (board-entry board i))))
    new-board))

(define (OTHER-PLAYER p) (if (eq? p 'x) 'o 'x))

;;; Count how many times a player appears on board
(define (COUNT-PLAYER board player)
  (let ((count 0))
    (scan-squares
     (lambda (i)
       (if (eq? (board-entry board i) player) (set! count (1+ count)))))
    count))

;;; Given a list of indices (1-based) for O and X positions, create board.
;;; This is useful for debugging only...
(define (FILL-BOARD o-indices x-indices)
  (let ((board (make-board)))
    (for-each (lambda (o-index)
		(set-board-entry board (1- o-index) 'o)) 
	      o-indices)
    (for-each (lambda (x-index)
		(set-board-entry board (1- x-index) 'x)) 
	      x-indices)
    board))

(define (SCAN-SQUARES function)
  (define (loop i)
    (cond ((< i *BOARD-SIZE*)
	   (function i)
	   (loop (+ i 1)))))
  (loop 0))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; read A (LEGAL) MOVE
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (READ-USER-MOVE position)
  (print-position position)		; let us know state of game
  (let* ((legal (sort (legal-moves position) move-spec-<)))	; legal moves
    (display-nl* "Pick from among the following moves (shown as index:move):")
    (let ((i 1))			; index of move
      (for-each
       (lambda (ms)
	 (if (= (modulo i 8) 0) (newline)) ; don't put them all on one line
	 (display* i ":") (print-move-spec-short ms)
	 (set! i (1+ i)))
       (map move-spec legal)))
    (cond ((null? legal) #f)
	  (else
	   (newline)
	   (display-nl* "Please enter the index of the legal move:")
	   (let* ((user-move (read)))
	     (cond ((and (number? user-move) ; check validity of input
			 (> user-move 0)
			 (<= user-move (length legal)))
		    (list-ref legal (1- user-move)))
		   (else
		    (newline)
		    (display "That's not a valid index; try again ... ")
		    (read-user-move position)))
	     )))))

;;; Function to sort the move specs in a consistent numerical order
;;; (first by to index and then by from index.
(define (MOVE-SPEC-< move1 move2)
  (let ((ms1 (move-spec move1))
	(ms2 (move-spec move2)))
    (cond ((< (move-spec-to ms1) (move-spec-to ms2)) #t)
	  ((= (move-spec-to ms1) (move-spec-to ms2))
	   (or (not (move-spec-from ms1))
	       (not (move-spec-from ms2))
	       (< (move-spec-from ms1) (move-spec-from ms2))))
	  (else #f))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; PRINTING
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (PRINT-POSITION position)
  (display* " The NEXT player to move is " (position-next-player position)
	    ", static value is " (static-evaluation position))
  (do ((i (- *board-width* 1) (1- i)))
      ((< i 0))
    (newline) (display "  ")
    (do ((j 0 (1+ j)))
	((= j *BOARD-WIDTH*))
      (let* ((index
	      (board-index i j))
	     (entry
	      (and index (board-entry (position-board position) index))))
	(if index (set! index (1+ index))) ; 1-based i/o
	(cond ((and index entry)
	       (if (< index 10) (display " "))
	       (display* index ":"
			 (if (eq? entry 'o) "O" "X")))
	      (index
	       (display*
		(if (< index 10) " " "")  index ": "))
	      (else
	       (display "    ")
	       )))
      (display "  ")))
  (newline))

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

(define (PRINT-MOVE move)
  (display* " move: " (position-player (move-position move)))
  (print-move-spec (move-spec move))
  (newline))

(define (PRINT-MOVE-SPEC mspec)  
  (cond ((move-spec-from mspec)
	 (display* " from " (1+ (move-spec-from mspec))
		   " to "  (1+ (move-spec-to mspec)))
	 (cond ((not (null? (move-spec-captures mspec)))
		(display* " captures: "
			  (map 1+ (move-spec-captures mspec))))))
	(else
	 (display* " -> " (1+ (move-spec-to mspec))))))

(define (PRINT-MOVE-SPEC-SHORT mspec)  
  (cond ((move-spec-from mspec)
	 (display* "(" (1+ (move-spec-from mspec)) " -> " (1+ (move-spec-to mspec)) ") "))
	(else
	 (display* (1+ (move-spec-to mspec)) " "))))

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

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

(define (DISPLAY* . vals)
  (for-each display vals))

(define (DISPLAY-NL* . vals)
  (for-each display vals)
  (newline))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; GRAPHICAL DISPLAY
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (DISPLAY-POSITION&MOVES position moves)
  (clear-window)			; a new canvas...
  (let ((spacing (/ *display-size* *BOARD-WIDTH*)))
    (define (trans c) 
      (list (* (+ (second c) 0.5) spacing) (* (+ (first c) 0.5) spacing)))
    (define (draw-grid i)
      (cond ((<= i *BOARD-WIDTH*)
	     (graphics-draw-line *window* (* i spacing) 0 (* i spacing) *display-size*)
	     (graphics-draw-line *window* 0 (* i spacing) *display-size* (* i spacing))
	     (draw-grid (+ i 1)))))
    ;; Draw grid
    (draw-grid 0)
    ;; Draw state of board
    (scan-squares
     (lambda (index)
       (let* ((coords (board-coordinates index))
	      (i (first coords))
	      (j (second coords))
	      (entry (board-entry (position-board position) index)))
	 (set! index (1+ index))	; output is 1-based
	 (cond ((and index entry)
		;; occupied legal board space
		(graphics-set-color *window* (if (eq? entry 'x) '(255 0 0) '(0 0 0)))
		(display-filled-circle
		 (* (+ j 0.5) spacing) (* (+ i 0.5) spacing) (* 0.4 spacing))
		(graphics-draw-text *window*
				    (* j spacing) (* (+ i 0.75) spacing) (number->string index))
		(graphics-set-color *window* (if (eq? entry 'x) '(0 0 0) '(255 0 0)))
		(graphics-draw-text *window*
				    (* (+ j 0.475) spacing) (* (+ i 0.475) spacing) 
				    (string-upcase (symbol->string entry)))
		)
	       (index
		;; empty legal board space
		(graphics-set-color *window* '(0 255 0))
		(graphics-draw-text *window*
				    (* j spacing) (* (+ i 0.75) spacing) (number->string index))
		)))))
    ;; Moves, draw arrows to show them.
    (for-each 
     (lambda (mspec)
       (cond ((move-spec-from mspec)
	      (graphics-set-color *window* '(0 0 255))
	      (display-arrow (trans (board-coordinates (move-spec-from mspec)))
			     (trans (board-coordinates (move-spec-to mspec)))
			     (* 0.25 spacing)))))
     (map move-spec moves))
    ))