; Stream stuff

(define the-empty-stream '())
(define empty-stream? null?)
(define cons-stream cons)
(define head car)
(define tail cdr)
(define singleton list)

; Tic-tac-toe player

(define (try-it)
  (tic-tac-toe human-player machine-player))

(define (tic-tac-toe player-1 player-2)
  (let loop ((board initial-board) 
	     (current-player player-1)
	     (other-player player-2))
    (print-board board)
    (cond ((loss? board)
	   (other-player 'win) 
	   (newline))
	  ((no-moves-possible? board)
	   (display "A draw, ho hum.")
	   (newline))
	  (else (loop ((current-player 'move) board)
		      other-player 
		      current-player)))))
		  
(define machine-player
  (lambda (message)
    (case message
      ((move) best-move)
      ((win) (display "Ha ha, I won")))))
	  
(define human-player
  (lambda (message)
    (case message
      ((move) 
       (lambda (board)
	 (display "Your move? ")
	 (parse-move (read) board)))
      ((win) (display "You won, congrats!")))))
	  
; Finding the best move

; In general, best-move and value will work for a finite 2-person game
; in which turns alternate, it's a draw if neither player can move,
; and a player must move to win (i.e., if a win occurs, it goes to the
; last player to move).
; Whose turn it is to move is implicit in the board state.

(define impossibly-high-score 2)

; Pre: (not (empty-stream? (moves board)))
(define (best-move board)
  (let loop ((best-board 'ignore) 
	     (score impossibly-high-score)
	     (rest (moves board)))
    (if (empty-stream? rest)
	best-board
	(let ((new-score (value (head rest))))
	  (if (< new-score score)
	      (loop (head rest) new-score (tail rest))
	      (loop best-board score (tail rest)))))))

; value to player with move; +1 = win, 0 = draw, -1 = loss
(define (value board)
  (lookup-board board
    (lambda (val) val)
    (lambda ()
      (let ((val
	     (if (loss? board)
		 -1
		 (let ((possible-moves (moves board)))
		   (if (empty-stream? possible-moves)
		       0
		       (let loop ((best -1) (boards possible-moves))
			 (if (empty-stream? boards)
			     best
			     (let ((new-score (- (value (head boards)))))
			       (if (= new-score 1)
				   new-score
				   (loop (max new-score best) 
					 (tail boards)))))))))))
	(note-board-value! board val)
	val))))

; Table of board values

(define table (make-vector 103 '()))
; (define table (call-with-input-file "ttt.dat" read))

(define table-size (vector-length table))

(define (note-board-value! board value)
  (let ((bucket (hash-board board table-size)))
    (vector-set! table bucket 
		 (cons (cons board value)
		       (vector-ref table bucket)))))

(define (lookup-board board succeed fail)
  (let ((bucket (vector-ref table (hash-board board table-size))))
    (define (lookup board fail)
      (let ((entry (assoc board bucket)))
	(if entry
	    (succeed (cdr entry))
	    (fail))))
    (let loop ((boards (equivalents board)))
      (if (empty-stream? boards)
	  (fail)
	  (lookup (head boards)
		  (lambda () (loop (tail boards))))))))

; Symmetry group of tic-tac-toe boards
; Represented as a stream of boards equivalent under the symmetries.

(define (equivalents board)
  (define (make-board board i1 i2 i3 i4 i5 i6 i7 i8 i9)
    (define (sq i) (vector-ref board i))
    (vector (vector-ref board 0) 
	    (sq i1) (sq i2) (sq i3) 
	    (sq i4) (sq i5) (sq i6) 
	    (sq i7) (sq i8) (sq i9)))
  (define (rotate board)
    (make-board board 3 6 9
		      2 5 8
		      1 4 7))
  (define (flip board)
    (make-board board 3 2 1
		      6 5 4
		      9 8 7))
  (define (perform op rest-proc)
    (lambda (board)
      (cons-stream board (rest-proc (op board)))))
  ((perform rotate
     (perform rotate
       (perform rotate
	 (perform flip
	   (perform rotate
	     (perform rotate
	       (perform rotate
		 singleton)))))))
   board))

; Board representation

(define (loss? board)
  (let ((marker (not (vector-ref board 0))))
    (define (match? i1 i2 i3)
      (and (eqv? (vector-ref board i1) marker)
	   (eqv? (vector-ref board i2) marker)
	   (eqv? (vector-ref board i3) marker)))
    (or (match? 1 2 3)
	(match? 4 5 6)
	(match? 7 8 9)
	(match? 1 4 7)
	(match? 2 5 8)
	(match? 3 6 9)
	(match? 1 5 9)
	(match? 3 5 7))))
  
(define (moves board)
  (let loop ((i 1))
    (if (> i 9)
	the-empty-stream
	(if (eq? (vector-ref board i) '-)
	    (cons-stream (make-move board i)
			 (loop (+ i 1)))
	    (loop (+ i 1))))))

(define (no-moves-possible? board)
  (empty-stream? (moves board)))
  
(define initial-board 
  '#(#t  -  -  - 
	 -  -  - 
	 -  -  -))

(define (square->symbol square-value)
  (case square-value
    ((#t) 'X)
    ((#f) 'O)
    ((-)  '-)))
	
(define (make-move board i)
  (let ((copy (copy-vector board)))
    (vector-set! copy i (vector-ref copy 0))
    (vector-set! copy 0 (not (vector-ref copy 0)))
    copy))

(define (parse-move move-spec board)
  (make-move board move-spec))

(define (print-board board)
  (do ((row 0 (+ row 1)))
      ((= row 3) (newline))
    (do ((col 0 (+ col 1)))
	((= col 3) (newline))
      (display (square->symbol (vector-ref board (+ (* row 3) col 1))))
      (display " "))))

(define (hash-board board limit)
  (define (square i)
    (case (vector-ref board i)
      ((-) 0)
      ((#t) 1)
      ((#f) 2)))
  (remainder
   (+ (* 9 (+ (square 1) (square 3) (square 7) (square 9)))
      (* 3 (+ (square 2) (square 4) (square 6) (square 8)))
      (square 5))
   limit))

; Help functions

(define (compose f g)
  (lambda (x) (f (g x))))

(define (copy-vector v)
  (let ((u (make-vector (vector-length v))))
    (do ((i 0 (+ i 1)))
	((= i (vector-length v))
	 u)
      (vector-set! u i (vector-ref v i)))))

(define (accumulate-left f id stream)
  (if (empty-stream? stream)
      id
      (accumulate-left f (f id (head stream)) (tail stream))))

(try-it)