;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                        
;; NAME: gamesman.scm
;; 
;; DESCRIPTION: GAMESMAN (Scheme)
;; 
;; AUTHOR: Dan Garcia - University of California at Berkeley
;;
;;         Initial Scheme port by David Schultz and Greg Krimer (2001).
;;         Support for loopy games and other features added by Alex 
;;             Kozlowski, Alan Sheinberg and Greg Krimer (2002). 
;;         GUI added by Alex Kozlowski (2002).
;;
;;         Copyright (C) Dan Garcia, 2001. All rights reserved.
;; 
;; UPDATE HISTORY:
;; 
;;    2001-11-05: (v2.0s) Release for Fall 2001 CS3
;;    2002-09-15: (v2.?b) Using built-in STk hash tables 
;;    2002-10-29: (v3.0s) Release for Fall 2002 CS3
;;    2002-11-15: (v3.1s) Added GUI features!
;;    2003-02-09: (v3.2s) Updated comments
;;    2003-03-03: (v3.3s) Fixed "accumulate bug"
;;    2003-04-03: (v3.4)  Updated GUI & move gifs/ppms to 'images' directory
;;    2003-04-05: (v4.0b1) Fix for 'modules' and 'trees' directory
;;    2003-04-07: (v4.0)  Release for Spring 2003 CS3
;;    2003-05-11: (v4.1) Gui fix for Undo/Value Moves to handle go-agains
;;    2003-05-26: (v4.2) Gui fix for delays and comp/comp infinite play
;;    2003-10-29: (v5.0) Play without solving humans/computers
;;    2003-11-01: (v5.1) Added automatic tree reading/writing
;;    2003-11-03: (v5.2) Added mtttt.scm (from mtttt2.scm)
;;    2003-11-03: (v5.2.1) Removed cs3-gamesman from file
;;    2003-11-03: (v5.2.2) Improved randomization 2^17 (from 2^8)
;;    2003-11-03: (v5.2.3) Gui game/move delay only when Comp vs. Comp
;;    2003-11-03: (v5.2.4) Gui value move graphic only appears for solved games
;;    2003-11-03: (v5.2.5) Updated toggle-preds to explicitly set predictions
;;                         to false if the game is not being solved.
;;    2003-11-03: (v5.2.6) Added mkonane.scm to the list of game modules
;;                         and changed date on 'welcome'
;;    2003-11-03: (v5.2.7) Changed 'up to 2 minutes' to 'up to 20 minutes'
;;    2003-11-04: (v5.2.8) Fixed 'New Game' bug
;;    2003-11-04: (v5.2.9) Changed "Welcome to gamesman" to include 5.2.9
;;                                                           
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 

;;             real-gamesman
;;              
;;               load-menu
;;
;;         game-specific-options
;;
;;             play-options
;;
;;               play-game


;; GLOBAL VARIABLES

;; all the games that Gamesman knows about and can load from the (load-menu)
(define *game-modules* '(("m1210.scm" "1,2,...,10") 
                         ("msurround.scm" "Surround") 
			 ("mnorthcotts.scm" "Northcott's Game")
			 ("mknights.scm" "Knight's Dance")
			 ("mkonane.scm" "Konane")
			 ("mtttt.scm" "Tomorrow's Tic-Tac-Toe")
    ))


;; all of these must be defined in every game module
(define *required-variables* 
  '(generate-moves do-move print-help primitive-position whose-move
		   print-position draw-position *game-name* *group-members* init-canvas))

;; this is the subset of *required-variables* that are procedures
(define *required-procs*
  '(generate-moves do-move print-position print-help primitive-position whose-move
		   draw-position init-canvas))

;; the place where we will expect to find game modules
(define *gamesman-path* #f)

;; added for human vs human play without solving.
;; disables certain options and like predictions and game trees.
(define *play-without-solving* #f)

;; the table of game positions and their values
(define *database* #f) 

;; This keeps track of whether or not the game needs to be resolved because 
;; the game-specific options have been changed. 
(define *game-specific-options-changed* #t) 

;; the table of game specific options (modified by SET-RULE! and GET-RULE)
(define *game-specific-options* (list 'GAME-SPECIFIC-OPTIONS-TABLE)) 

;; the table of play options
(define *play-options* (list 'PLAY-OPTIONS-TABLE)) 

;; a list of all positions visited in current game (used for undo)
(define *game-so-far* #f)

;; a list of moves made in current game (used in GUI)
(define *moves-so-far* #f)

;; call/cc needed to allow global escape with (quit)
(define (gamesman) 
  (call-with-current-continuation real-gamesman)) 

(define (real-gamesman c)
  (set! quit c)
  (display "==============================================================================\n")
  (display "Welcome to CS3 Gamesman, version 5.2.9 (2003-11-04), written by Dan Garcia &\n") 
  (display "ported to Scheme by the following ace CS3 developers:\n")
  (display "  2001Fa v2 Greg Krimer & David Schultz\n")
  (display "  2002Fa v3 Alex Kozlowski, Greg Krimer & Alan Sheinberg\n")
  (display "  2003Sp v4 Alex Kozlowski, Greg Krimer, Nishant Prasad & Alan Sheinberg\n")
  (display "  2003Fa v5 Jennifer Tsang, Hesam Samimi, Michael McGehee\n")
  (display "            (with help from Alex Kozlowski & Greg Krimer)\n")
  (display "Send questions to ucb.class.cs3\n")
  (display "Send bug reports to ucb.class.cs3 but put BUG in the subject\n")
  (unless *gamesman-path* (set-gamesman-path))
  (load-menu))

;; Sets *gamesman-path* to the current directory and prepends it to all of the
;; game modules so that they may be loaded automatically.
;; 
;; Note: On a PC, the current directory will be "C:\\Program Files\\STk\\MS-Win32"
;;   unless changed explicitly with (chdir).
(define (set-gamesman-path)
  (set! *gamesman-path* (string-append (getcwd) "/"))
  (for-each (lambda (module)
	      (set-car! module (string-append *gamesman-path* "modules/" (car module))))
	    *game-modules*))
	
;; Returns #t iff all symbols in LST are defined in global environment. For each
;; symbol that is not defined, a warning message is printed. 
(define (all-defined? lst)
  (null? 
   (filter (lambda (name)
	     (if (symbol-bound? name)
		 #f
		 (begin
		   (oops name " is not bound. Please check your source file.")
		   #t)))
	   lst)))

;; Prints non-fatal error messages.
(define (oops . stuff)
  (display "\n[Oops!] ")
  (for-each display stuff)
  (display "\n"))

;; Removes all symbols in LST from global environment.
(define (undefine-all lst)
  (for-each (lambda (name)
	      (if (symbol-bound? name)
		  (eval `(set! ,name (make-unbound)))))
	    lst))

;; Registers the names of the two game pieces with Gamesman. That is, if 
;; you are doing Tic Tac Toe, then you should call this function like this:
;;
;;  (name-game-pieces "X" "0")
;;
;; This procedure then puts entries into the *play-options* table that are
;; named as the pieces. For example, the call above will produce entries
;; such as X-opponent, O-player, O-name and just plain X and O, among others.
(define (name-game-pieces left right)
  
  (define (is-computer? piece)
    (eq? (get-option piece *play-options*)
	 get-computer-move))
  
  ;; returns procedure to display if player is a human or computer
  (define (display-player player)
    (lambda ()
      (format #t "Change ~A player from ~A"
	      player
	      (if (is-computer? player)
		  "[COMPUTER] to human"
		  "[HUMAN] to computer"))))

  ;; returns procedure to change player from human to computer or 
  ;; the other way around
  (define (change-player player)
    (lambda () 
      (set-option! player
		   (if (is-computer? player)
		       get-human-move
		       get-computer-move)
		   *play-options*)
      (let ((old-name (get-option (word 'old- player '-name) *play-options*)))
	(set-option! (word 'old- player '-name) 
		     (get-option (word player '-name) *play-options*) 
		     *play-options*)
	(set-option! (word player '-name) old-name *play-options*))))
  
  ;; returns procedure to display player's name
  (define (display-name player)
    (lambda ()
      (format #t "Change ~A name from (currently) ~A" 
	      player
	      (get-option (word player '-name) *play-options*))))

  ;; returns procedure to change player's name
  (define (change-name player)
    (lambda ()
      (if (eq? (get-option player *play-options*)
	       get-computer-move)
	  (begin (display ">>> We're sorry, you can't change the computer's name.\n")
		 (press-enter-to-continue))
	  (begin (display ">>> Enter a new name (in double quotes): ")
		 (set-option! (word player '-name) (read) *play-options*)))))

  (set-option! 'pieces `(name-game-pieces ,left ,right) *play-options*)
  
  (if *play-without-solving*
     (begin
       ;; left set to human
       (set-option! left get-human-move *play-options*)
       ;; right set to human
       (set-option! right get-human-move *play-options*) 
       ;; their opponents; needed to figure out who won/lost
       (set-option! (word left '-opponent) right *play-options*)
       (set-option! (word right '-opponent) left *play-options*)
       ;; give each player a default name, as well as keep track of the old name
       (set-option! (word left '-name) "CS3 Student 1" *play-options*)
       (set-option! (word right '-name) "CS3 Student 2" *play-options*)  
       (set-option! (word 'old- left '-name) "HAL 9000" *play-options*)
       (set-option! (word 'old- right '-name) "Deep Blue" *play-options*) 
       ;; empty the play options menu 
       (set! *play-options-menu* (list (car *play-options-menu*)))
       (add-to-menu! "L" (display-player left) (change-player left) *play-options-menu*)
       (add-to-menu! "R" (display-player right) (change-player right) *play-options-menu*)
       (add-to-menu! "M" (display-name left) (change-name left) *play-options-menu*) 
       (add-to-menu! "N" (display-name right) (change-name right) *play-options-menu*)  
     ) 
     (begin
       ;; left assumed to be human; can be changed with (change-player)
       (set-option! left get-human-move *play-options*)
       ;; right assumed to be computer; can be changed with (change-player)
       (set-option! right get-computer-move *play-options*)
       ;; their opponents; needed to figure out who won/lost
       (set-option! (word left '-opponent) right *play-options*)
       (set-option! (word right '-opponent) left *play-options*)
       ;; give each player a default name, as well as keep track of the old name
       (set-option! (word left '-name) "CS3 Student 1" *play-options*)
       (set-option! (word right '-name) "Deep Blue" *play-options*)
       (set-option! (word 'old- left '-name) "HAL 9000" *play-options*)
       (set-option! (word 'old- right '-name) "CS3 Student 2" *play-options*)
       ;; empty the play options menu 
       (set! *play-options-menu* (list (car *play-options-menu*)))
       ;; reset it appropriately
       (add-to-menu! "L" (display-player left) (change-player left) *play-options-menu*)
       (add-to-menu! "R" (display-player right) (change-player right) *play-options-menu*)
       (add-to-menu! "M" (display-name left) (change-name left) *play-options-menu*) 
       (add-to-menu! "N" (display-name right) (change-name right) *play-options-menu*)  
     )  )  )

   

;; Encapsulates each of the *required-procs* in an error-safe version that
;; quits Gamesman immediately on error instead of waiting for things to
;; break down later on. All procedures in Gamesman then use the safe versions
;; of the module functions: safe-generate-moves instead of generate-moves, etc.
;; 
;; Kludge: It seems that STk does not store the last error message encountered
;;   (you'd think it'd be in *last-error-message*, but this is not the case at 
;;   least on a PC). To reproduce it, the offending procedure is called again. This 
;;   means that any side-effects it has will occur twice. Seeing as it's CS3, this 
;;   should not be an issue except maybe with (print-position).
(define (make-module-procs-safe)
  (for-each 
   (lambda (name)
     ;; eval occurs in global environment by default unless optional second arg
     ;; like (current-environment) is supplied; environments are first-class in STk
     (eval `(define ,(word 'safe- name)  
	      (let ((real-proc ,name)   
		    (proc-name ',name)  ;; (quote (unquote name))  
		    (result #f))        
		(lambda args        
		  (if (catch (set! result (apply real-proc args)))
		      (begin 
			(format #t 
				"\n\n>>> ~A has triggered the following error:\n\n" 
				,(string-upper (symbol->string name)))
			;; dynamic-wind prevents errors from ditching the
			;; current continuation, thus ensuring that (quit) gets
			;; called and "The offending ... " message gets printed
			(dynamic-wind                           
			    (lambda () 'dummy)    ;; need a third thunk                
			    (lambda () (apply real-proc args))  
			    (lambda ()                          
			      (format #t                        
				      "\n\n>>> The offending expression was: ~A\n" 
				      (cons proc-name args)) 
			      (quit "Fix the bug and come back soon!"))))
		      result))))))
   *required-procs*))
	    
;; Returns the subset of *game-modules* that are in the *gamesman-path*.
;;
;; Note: File-exists? does not expand file-names. Hence it won't recognize
;;   relative path names like "~/foo", "./foo" or "../foo", so we must be
;;   sure to call set-gamesman-path to prepend the expanded *gamesman-path* 
;;   to all *game-modules* prior to calling this.
(define (available-modules)
  (filter (lambda (module)
	    (file-exists? (car module)))
	  *game-modules*))

;; Prompts user for a file name and appends the *gamesman-path* to it.
(define (get-file-name)
  (format #t "\n>>> Looking for files in ~A\n" *gamesman-path*)
  (display ">>> Type the name of the file here: ")
  (let ((file-name (read)))
    (string-append *gamesman-path*
		   (if (symbol? file-name)
		       (symbol->string file-name)
		       file-name))))

;; Loads file or returns #f  
(define (load-succesful? file-name)
  (or (try-load file-name)
      (begin (format #t "\n[Oops!] Could not open file: ~A\n" file-name) 
	     #f)))

;; Checks if its agument, an STk hash table, is initialized.
(define (initialized? x)
  (and x
       (hash-table? x)
       (not (null? (hash-table->list x)))))

;; Presents user with menu for easily loading game modules from the
;; *gamesman-path* directory.
(define (load-menu)
  
  ;; prints all games (a list of strings) in a pretty way
  (define (generate-load-menu games counter)
    (if (null? games)
	'done
	(begin (format #t "(~A) ~A\n" counter (cadr (car games)))
	       (generate-load-menu (cdr games) (+ counter 1)))))
  
  (let ((modules (available-modules)))
    (define (loop)
      (display "\nLoad Game Menu\n")
      (display "------------------------------------------------------------------------\n")
      (format #t ">>> Looking for game modules in ~A\n" (expand-file-name 
                                                 (string-append *gamesman-path* "modules/")))
      (display "------------------------------------------------------------------------\n")
      (generate-load-menu modules 1)
      (display "------------------------------------------------------------------------\n")
      (if (initialized? *database*) (display "(C) Continue with currently loaded module\n"))
      (display "(O) Other (manually enter file name)\n")
      (display "(Q) Quit Gamesman\n")
      (display "Type your selection and press ENTER: ")
      (let ((choice (read)))
	(cond
	 ;; bye bye
	 ((equal? choice 'q) 
	  (quit "Thanks for using Gamesman!"))
	 ;; continue with currently loaded module
	 ((equal? choice 'c)
	  (if (initialized? *database*)
	      (game-specific-options)
	      (begin (display "\n[Oops!] No module loaded. Please try again.\n")
		     (press-enter-to-continue)
		     (loop))))
	 
	 ;; load file manually (choic 'o) 
	 ;; or enter a number for automatic loading 
	 ((or (and (equal? choice 'o)
		   (initialize)
		   (gui-make-functions-clean)
		   (load-succesful? (get-file-name))
		   (all-defined? *required-variables*))
	      (and (member choice (enumerate-interval 1 (length modules)))
		   (initialize)
		   (gui-make-functions-clean)
		   (load-succesful? (car (list-ref modules (- choice 1))))
		   (all-defined? *required-variables*)))
	  (make-module-procs-safe)
	  (format #t "\n>>> Let's play the game called ~A by ~A.\n" *game-name* *group-members*)
	  (game-specific-options))
	 ;; boo boo
	 (else 
	  (format #t "\n[Oops!] Invalid choice: ~A\n" choice)
	  (loop)))))
    
    ;; make sure to kill Gamesman GUI window on exit
    (if tk:initialized? (wm 'withdraw *root*))
    (loop)))


(define (game-specific-options)
  (if tk:initialized? (wm 'withdraw *root*))
  (newline)
  (format #t "~A Options\n" *game-name*) 
  (display "------------------------------------------------------------------------\n")
  (format #t 
	  ">>> ~A set to go first given the initial position.\n" 
	  (whose-move (get-rule 'initial-position)))
   
      (format #t
	  ">>> Game~Asolved.\n"
	  (if (not *game-specific-options-changed*) " " " not "))

  (display "------------------------------------------------------------------------\n")
  (print-menu (cdr *game-specific-options-menu*) 1)
  (display "------------------------------------------------------------------------\n")
  
  (let ((solved-tree (or (curr-tree? "std") (curr-tree? "mis") 
                         (curr-tree? "cmp") (curr-tree? "usr") (curr-tree? "1"))))
    
    (format #t "(P) Play ~A without solving.\n" *game-name*)
    (if solved-tree
        (begin 
          (display "(S) Play using solved tree with current game settings\n") 
          (display "(A) Re-solve game\n"))
        (if *game-specific-options-changed*
            (format #t "(S) Solve and play ~A\n" *game-name*)
            (format #t "(S) Play ~A with solved game features.\n" *game-name*)))
    (display "(H) Print Help\n")
    (display "(R) Read game tree from file\n")
    (display "(L) Return to Load Menu\n")
    (show "(Q) Quit Gamesman")
    (display "Type your selection and press ENTER: ")
    (let ((choice (read))) 
      (cond ((and solved-tree (equal? choice 't)) (load-tree solved-tree) (solve-game))
            ((equal? choice 'a) (begin (set! *game-specific-options-changed* #t)
                                       (solve-game)))
            ((equal? choice 'r) (read-game-tree))
            ((equal? choice 'l) (load-menu))
            ((equal? choice 'h) (print-help) (game-specific-options))
            ((equal? choice 's) 
             (let ((left (cadr (get-option 'pieces *play-options*)) )
                   (right (caddr (get-option 'pieces *play-options*)) ))
               (set! *play-without-solving* #f)
               (name-game-pieces left right)
               (if (not (get-option 'predictions *play-options*)) (toggle-preds))
               (solve-game) )) 
            ((equal? choice 'p) 
             (let ((left (cadr (get-option 'pieces *play-options*)) )
                   (right (caddr (get-option 'pieces *play-options*)) ))
	       (if (get-option 'predictions *play-options*) (toggle-preds))
	       ;; predictions will not work unless you solve the game
               (set! *play-without-solving* #t)
	       (name-game-pieces left right)
               (play-options)) )
            ((equal? choice 'q) (quit "Thanks for using Gamesman!"))
            ((and (integer? choice) 
                  (> choice 0) (<= choice (length (cdr *game-specific-options-menu*))))
             (newline) 
             ((caddr (list-ref (cdr *game-specific-options-menu*) (- choice 1))))
             (game-specific-options))
            (else 
             (format #t "\n[Oops] Invalid choice: ~A\n" choice)
             (game-specific-options))))))


(define (curr-tree? t)
  (let ((file-name (expand-file-name (string-append *gamesman-path* "trees/" *game-name* "_" t ".tree"))))
    (if (file-exists? file-name)
        (let ((in (open-input-file file-name)))
          (read in) ;;game-name
          (read in) ;;group-members
          (let ((game-options (read in)))
            (if (equal? *game-specific-options* game-options)
                t
                (let ((n (substring t 0 1)))
                  (if (number? n)
                      (curr-tree? (number->string (+ n 1)))
                      #f)))))
        '#f)))

;; Solves the game using DETERMINE-VALUE iff *GAME-SPECIFIC-OPTIONS- 
;; CHANGED* is true. Calls PLAY-OPTIONS. 
(define (solve-game) 
  (if *game-specific-options-changed* 
      (begin (format #t "\n>>> Solving ~A now. This may take up to twenty minutes.\n" 
		     *game-name*)
             (initialize-database)
	     (set! *determine-value:called* 0)
             (determine-value (get-rule 'initial-position) #t)
	     (print-progress-report)
	     (resolve-loopy-queue)
             (newline) 
             (set! *game-specific-options-changed* #f))) 
  (play-options))


(define (play-options)
  ;;GUI STUFF
  (define (gui-loop)
     (let ((input (read)))
        (if (equal? input 'q)
           (begin 
              (if (symbol-bound? '.gamesmanGUI)
                 (gui-quit))
                 (play-options))
           (gui-loop))))
  (newline)
  (display "Play Options\n") 
  (display "------------------------------------------------------------------------\n")
  (format #t 
	  ">>> ~A set to go first given the initial position.\n" 
	  (whose-move (get-rule 'initial-position)))
  (if (not *play-without-solving*)
      (print-prediction (get-rule 'initial-position)))
      
  (display "------------------------------------------------------------------------\n")
  (print-menu (cdr *play-options-menu*) 1)
  (display "------------------------------------------------------------------------\n")
        
  (if(gui-graphics-on?)
     (format #t "(P) Launch GUI for ~A\n" *game-name*)
     (format #t "(P) Play ~A\n" *game-name*))
  (display "(H) Print Help\n")
  (format #t "(S) Set Random Seed (Currently ~A)\n" (random-generator 'get-seed 'dummy))
  (if (not *play-without-solving*)
      (display "(W) Write Game Tree to File\n") )
  (if tk:initialized? 
      (format #t "(D) Graphics: [~A]\n"
	      (get-option 'graphics *play-options*)))
  (if (not *play-without-solving*)       
      (begin
          (format #t "(T) Predictions: [~A]\n"
	  (if (get-option 'predictions *play-options*) "ON" "OFF"))))
  (display "(G) Return to Game-Specific Options menu\n")
  (display "(L) Return to Load Menu\n")
  (display "(Q) Quit Gamesman\n")
  (display "Type your selection and press ENTER: ") 
  (let ((choice (read)))
    (cond ((equal? choice 's) (set-random-seed))
          ((and (not *play-without-solving*) (equal? choice 'w))
           (write-game-tree))
	  ((equal? choice 'h) 
           (safe-print-help) 
           (play-options))
          ((equal? choice 'g) (game-specific-options))
	  ((and tk:initialized? (equal? choice 'd)) (inc-graphics))
	  ((and (not *play-without-solving*) (equal? choice 't))
	   (set-option! 'predictions (not (get-option 'predictions *play-options*)) *play-options*)
	   (play-options))
	  ((equal? choice 'l) (load-menu))
	  ((equal? choice 'q) 
           (if tk:initialized? (wm 'withdraw *root*)) 
           (quit "Thanks for using Gamesman!"))
	  ((equal? choice 'p)
           (if (gui-graphics-on?)
              (begin (unless (symbol-bound? '.drawwindow)
                        (begin (load (string-append *gamesman-path* "gdraw.scm"))
                           (init-graphics)))
                           (clear-graphics!)
                           (wm 'deiconify *root*)
                           (gui-initialize)
                           (display "Please type \"q\" and ENTER to return to Gamesman:\n")
                           (gui-loop))
              (begin 
                 (set! *game-so-far* (list (get-rule 'initial-position)))
                 (if (equal? (get-option 'graphics *play-options*) "SIMPLE")
                    (begin (unless (symbol-bound? '.drawwindow)
                              (begin (load (string-append *gamesman-path* "gdraw.scm"))
                                 (init-graphics)))
                                 (if tk:initialized? (wm 'deiconify *root*))
                                 (safe-init-canvas (get-rule 'initial-position))))
                                 (play-game))))
       	  ((and (integer? choice) 
		(> choice 0) (<= choice (length (cdr *play-options-menu*))))
	   (newline) 
	   ((caddr (list-ref (cdr *play-options-menu*) (- choice 1))))
	   (play-options))
	  (else 
	   (format #t "\n[Oops!] Invalid choice: ~A\n" choice)
	   (play-options)))))

(define (gui-graphics-on?)
   (equal? (get-option 'graphics *play-options*) "GUI"))
   
(define (simple-graphics-on?)
   (equal? (get-option 'graphics *play-options*) "SIMPLE"))

(define (inc-graphics)
  (set-option!
   'graphics
   (let ((gra (get-option 'graphics *play-options*)))
     (cond ((equal? gra "NONE") "SIMPLE")
	   ((equal? gra "SIMPLE") "GUI")
	   ((equal? gra "GUI") (begin (if tk:initialized? (wm 'withdraw *root*)) "NONE"))
	   (else
	    (gamesman:fatal "INC-GRAPHICS\n"
			    "Graphics value neither NONE, SIMPLE, or GUI: " gra))))
   *play-options*)
  (play-options))
   
(define (print-menu menu n)
  (if (null? menu) 
      'done
      (begin (format #t "(~A) " n)
	     ((cadar menu))
	     (newline)
	     (print-menu (cdr menu) (+ n 1)))))

;; The actual game is played through the procedures (play-game) 
;; and (get-move-and-continue), which are mutually recurssive. This
;; procedure checks that the game is not over, and calls 
;; get-move-and-continue with the procedure that will supply the
;; moves on the next turn (either get-human-move or get-computer-move).
(define (play-game)
  (let ((primitive (safe-primitive-position (car *game-so-far*)))
	(position (car *game-so-far*)))
    (if primitive
	(game-over position primitive)
	(begin
	  (if (get-option 'predictions *play-options*)
	      (begin (newline) (print-prediction position)))
	  (get-move-and-continue (get-option (safe-whose-move position) *play-options*))))))

;; Gets a move from (get-move), which is either get-human-move or 
;; get-computer-move and calls (play-game) to continue.
(define (get-move-and-continue get-move)
  (let ((position (car *game-so-far*)))
    (let ((move (get-move position (name-of-player position))))
      (if (equal? move 'undo)
	  (undo)
	  (begin
	    (format #t "\n>>> ~A's move: ~A\n" (name-of-player position) move)
	    (set! *game-so-far* (cons (safe-do-move position move) *game-so-far*))
	    (play-game))))))

;; Undoes the previous move.
(define (undo)
  (let ((undo-once (cdr *game-so-far*)))
    (cond ((null? undo-once)
	   (display "\n[Oops!] Can't undo initial position.\n")
	   (press-enter-to-continue))
	  ((null? (cdr undo-once))
	   (set! *game-so-far* undo-once))
	  ((player-is-computer? (car undo-once))
	   (set! *game-so-far* (cdr undo-once)))
	  (else
	   (set! *game-so-far* undo-once)))
    (play-game)))
	  

(define (name-of-player position)
  (get-option (word (safe-whose-move position) '-name) *play-options*))

(define (name-of-opponent position)
  (let ((o (get-option (word (safe-whose-move position) '-opponent) *play-options*)))
    (get-option (word o '-name) *play-options*)))

(define (player-is-computer? position)
  (eq? (get-option (safe-whose-move position) *play-options*)
       get-computer-move))

(define (opponent-is-computer? position)
  (let ((o (get-option (word (safe-whose-move position) '-opponent) *play-options*)))
    (eq? (get-option o *play-options*)
	 get-computer-move)))

(define (print-prediction position)
  (if (get-option 'predictions *play-options* )
  (let* ((value&remote (lookup-position position)))
    (cond ((draw? (value value&remote)) (predict-draw position))
	  ((win? (value value&remote)) (predict-win position (remoteness value&remote)))
	  ((lose? (value value&remote)) (predict-loss position (remoteness value&remote)))
	  ((tie? (value value&remote)) (predict-tie position (remoteness value&remote)))
	  (else
	   (gamesman:fatal "PRINT-PREDICTION\n"
			   "Position neither draw, win, lose or tie: " position))))))

(define (predict-draw position)
  (if (player-is-computer? position)
      (format #t 
	      ">>> This is a draw position: ~A will play forever to avoid losing.\n"
	      (name-of-player position))
      (if (opponent-is-computer? position)
	  (format #t 
		  ">>> This is a draw position: ~A will play forever. Game ends only when you err.\n"
		  (name-of-opponent position))
	  (format #t 
		  ">>> This is a draw position: The game will end only when you or ~A makes a mistake.\n"
		  (name-of-opponent position)))))
			        
(define (predict-loss position moves)
  (format #t ">>> ~A" (name-of-player position))
  (if (= moves 1)
      (display " is about to make the final move before losing the game.\n")
      (format #t " ~A lose in ~A moves.\n" 
	      (if (opponent-is-computer? position) "will" "should")
	      moves)))

(define (predict-win position moves)
  (format #t ">>> ~A" (name-of-player position))
  (if (= moves 1)
      (show (if (player-is-computer? position)
		" is about to make the final move and win the game."
		" should make the final move and win the game now."))
      (begin (display (if (player-is-computer? position)
			  " will win the game in "
			  " should win the game in "))
	     (display moves)
	     (show " moves."))))

(define (predict-tie position moves)
  (format #t ">>> ~A" (name-of-player position))
  (if (= moves 1)
      (show (if (player-is-computer? position)
		" is about to make the final move and tie the game. "
		" should make the final move and tie the game now."))
      (begin (display " should tie the game in ")
	     (display moves)
	     (show " moves."))))


;; Prompts the human named NAME for the next move and verifies that the 
;; move is valid by checking it against the moves that can be generated 
;; from POSITION. Allows user to type "q" to exit Gamesman or type "?" to 
;; call the PRINT-HELP procedure. 
(define (get-human-move position name) 
  (newline) 
  (safe-print-position position)
  (if tk:initialized? (update 'idletasks))
  (if (equal? (get-option 'graphics *play-options*) "SIMPLE")
      (safe-draw-position position))
  (format #t 
	  "\n>>> Your move, ~A (press ENTER for all moves, ? for options): "
	  (get-option (word (safe-whose-move position) '-name) *play-options*))
  (if (eq? (char-downcase (peek-char)) #\newline)         
      (begin (read-char)
	     (display "\n>>> The valid moves are: ") 
	     (for-each (lambda (move) (display move) (display " ")) 
		       (safe-generate-moves position))
	     (newline)
	     (get-human-move position name))
      (let ((move (read)))
	(cond ((eq? move '?) (print-get-user-move-help) 
	       (get-human-move position name))
	      ((eq? move 'q) (if tk:initialized? (wm 'withdraw *root*)) 
	       (quit "Thanks for using Gamesman!"))
	      ((eq? move 'h) (safe-print-help) (press-enter-to-continue) 
	       (get-human-move position name))
	      ((and (eq? move 's) (not *play-without-solving*)) (safe-moves position) 
	       (get-human-move position name))
	      ((eq? move 'u) 'undo)
	      ((eq? move 'l) (load-menu))
	      ((and (eq? move 't)  (not *play-without-solving*))
	       (set-option! 'predictions 
			    (not (get-option 'predictions *play-options*)) *play-options*)
	       (if (get-option 'predictions *play-options*)
		   (begin (newline) (print-prediction (car *game-so-far*))))
	       (get-human-move position name))
	      ((eq? move 'p) (play-options))
	      ((eq? move 'g) (game-specific-options))
	      ((member move (safe-generate-moves position)) move)
	      (else (format #t "\n[Oops!] Invalid move: ~A\n>>> The valid moves are: " move) 
		    (for-each (lambda (move) (display move) (display " ")) 
			      (safe-generate-moves position))
		    (newline) 
		    (get-human-move position name))))))


(define (print-get-user-move-help)
  (display "\nMove Options Menu\n")
  (display "------------------------------------------------------------------------\n")
  (display ">>> Type any of the following -- or your move.\n")
  (display "------------------------------------------------------------------------\n")
  (display "(?) Print this menu\n")
  (if (not *play-without-solving*)
      (display "(S) View safe moves\n"))
  (display "(H) Print game help\n")
  (display "(U) Undo last move\n")
  (if (not *play-without-solving*)
      (format #t 
	      "(T) Turn predictions ~A \n" 
	      (if (get-option 'predictions *play-options*) "off" "on")))
  (display "(P) View Play Options menu\n")
  (display "(G) View Game-Specific Options menu\n")
  (display "(L) Load a different game\n")
  (display "(Q) Quit Gamesman\n\n"))
 
;; Prints the safe (value-equivalent) moves (if any) from POSITION. 
(define (safe-moves position) 
   
  (if *play-without-solving* 
      (display "The game has not been solved so you are on your own.")
      (begin 
        (newline) 
        (let ((value&remote (determine-value position #f)))
           (if (lose? (value value&remote)) 
              (display ">>> This is a losing position -- every move is equally futile.\n") 
              (begin (display ">>> Your safe moves are: ")
                 (for-each (lambda (m) (display m) (display " ")) 
                           (get-value-equivalent-moves position))
	       (newline))))) ) )
 
;; Chooses a value-equivalent move at random. Signals an error if moves are EMPTY? 
;; because GENERATE-MOVES should supply moves for every non-primitive position. 
(define (get-computer-move position dummy)
  (if (not (gui-graphics-on?))
     (begin 
        (newline)
        (safe-print-position position)))
  (if tk:initialized? (update 'idletasks))
  (if (equal? (get-option 'graphics *play-options*) "SIMPLE")
             (safe-draw-position position))
  (if (not *play-without-solving*)
    (let ((moves (get-value-equivalent-moves position)))
      (if (empty? moves) 
          (gamesman:fatal "GET-COMPUTER-MOVE\n"
  			"No moves available for non-primitive position: "
  			position)
          (list-ref moves (random-generator 'generate (length moves)))))
    (let ((moves (safe-generate-moves position)))
      (if (empty? moves) 
          (gamesman:fatal "GET-COMPUTER-MOVE\n"
  			"No moves available for non-primitive position: "
  			position)
          (list-ref moves (random-generator 'generate (length moves)))))) )

(define (simple-graphics-on?)
  (equal? (get-option 'graphics *play-options*) "SIMPLE"))

;; Informs user of the outcome of the game and asks if another is to be played.
(define (game-over position game-value) 
  (newline) 
  (safe-print-position position)
  (if (simple-graphics-on?)
      (safe-draw-position position))
  (newline) 
  (cond ((tie? game-value)
	 (format #t ">>> GAME OVER: It's a tie.\n"))
	((lose? game-value)
	 (format #t ">>> GAME OVER: ~A wins!\n" (name-of-opponent position)))
	((win? game-value)
	 (format #t ">>> GAME OVER: ~A wins!\n" (name-of-player position)))
	(else
	 (gamesman:fatal "GAME-OVER\n"
			 "Game value neither win, lose or tie for position: " position)))
  (press-enter-to-continue)
  (play-options))
 
;; Takes a variable number of arguments and displays them in order with 
;; no whitespace between them and a newline at the end. 
(define (show-all . args) 
  (if (empty? args) 
      (newline) 
      (begin (display (first args)) 
             (apply show-all (bf args)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
;;; GUI FUNCTIONS   The fun stuff!!                            ;;; 
;;; ---------------------------------------------------------  ;;; 
;;; WARNING: RAW TK functions used below! Read at own risk.    ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 

;;global for keeping a list of moves which have occurred thus far

(define *moves-so-far* #f)
(define *delay-between-moves* 1)
(define *delay-between-games* 1)
(define *gui-move-state* 'none) 

;;Initializes the gui window, including all buttons, labels and pictures
(define (gui-initialize)
   (let ((gui-color "White")
         (status-color "gray25"))
    (toplevel '.gamesmanGUI :bg gui-color)
    (label '.gamesmanGUI.picture2 
	   :background gui-color
	   :image (image 'create 'photo '.gamesmanGUI.pic2
			 :file (string-append *gamesman-path* "images/guiicon2.ppm")))
    
(if *play-without-solving*  
    (label '.gamesmanGUI.picture3 
	   :background gui-color
	   :image (image 'create 'photo '.gamesmanGUI.pic3
			 :file (string-append *gamesman-path* "images/guiicon3NS.ppm")))
    (label '.gamesmanGUI.picture3 
	   :background gui-color
	   :image (image 'create 'photo '.gamesmanGUI.pic3
			 :file (string-append *gamesman-path* "images/guiicon3.ppm"))) )
    (label '.gamesmanGUI.picture1 
	   :background gui-color
	   :image (image 'create 'photo '.gamesmanGUI.pic1
			 :file (string-append *gamesman-path* "images/guiicon1.ppm")))
    (label '.gamesmanGUI.whosemove
           :bg gui-color 
                  :height 1
                  :text "Welcome to Gamesman"
                  :font '(20)
		  :relief 'flat)
     (label '.gamesmanGUI.messenger 
                  :wrap 256
                  :bg gui-color
                  :height 3
		  :text "Click New Game to Start"
                  :font '(20)
		  :relief 'flat)
    (frame '.gamesmanGUI.options :bg gui-color)
    (button '.gamesmanGUI.options.newgame :text "New Game"
	   
	    :font '(20)
	    :command gui-new-game)
    (button '.gamesmanGUI.options.undo :text "Undo"
	   
	    :font '(20)
	    :command (lambda ()
                 (if (not (null? (cdr *game-so-far*)))
                    (begin (gui-disable-undo)
                       (gui-undo)))))
   (button '.gamesmanGUI.options.quit :text "Quit"
          
           :font '(20)
           :command gui-quit)
   (button '.gamesmanGUI.options.about :text "About"
          
           :font '(20)
           :command gui-about)
   (frame '.gamesmanGUI.moveframe :bg gui-color)
     (radiobutton '.gamesmanGUI.moveframe.hidemoves :text "None"
	    
	    :font '(20)
            :anchor "w"
            :relief 'raised
	    :command (lambda ()
		       (gui-move-toggle 'none))
            :variable 'move-var
            :value 1)                       
    (radiobutton '.gamesmanGUI.moveframe.allmoves :text "All"
	    
	    :font '(20)
            :anchor "w"
            :relief 'raised
	    :command (lambda ()
		       (gui-move-toggle 'all))
            :variable 'move-var
            :value 2) 
            
(if (not *play-without-solving*)                        
    (radiobutton '.gamesmanGUI.moveframe.valuemoves :text "Value"
	    :font '(20)
            :relief 'raised
            :anchor "w"
	    :command (lambda ()
		       (gui-move-toggle 'value))
            :variable 'move-var
            :value 3) )
(if (not *play-without-solving*)            
    (radiobutton '.gamesmanGUI.moveframe.safemoves :text "Safe"
	    :font '(20)
            :relief 'raised
            :anchor "w"
	    :command (lambda ()
		       (gui-move-toggle 'safe))
            :variable 'move-var
            :value 4) )
            
;; only show delay sliders if computer vs. computer
(if (and (player-is-computer? (get-rule 'initial-position))
         (opponent-is-computer? (get-rule 'initial-position)))
    (begin
              (label '.gamesmanGUI.game-delay-label
                     :bg gui-color
                     :text "Game Delay"
                     :font '(20)
                     :relief 'flat)
    
              (label '.gamesmanGUI.move-delay-label
                     :bg gui-color
                     :text "Move Delay"
                     :font '(20)
                     :relief 'flat)
    
              (scale '.gamesmanGUI.game-delay-scale :orient 'horizontal :from 0 :to 2 
                     :resolution .25 :tick .25 :variable '*delay-between-games* :bg gui-color 
                     :borderwidth 0 :highlightthickness 0)
                     
              (scale '.gamesmanGUI.move-delay-scale :orient 'horizontal :from 0 :to 2 
                     :resolution .25 :tick .25 :variable '*delay-between-moves* :bg gui-color 
                     :borderwidth 0 :highlightthickness 0) ) )

    ;pack it up
    
    ;pack top picture
    (pack .gamesmanGUI.picture1 :side 'top) 
    
    ;pack status
    (pack .gamesmanGUI.whosemove :fill "both")
    (pack .gamesmanGUI.messenger :fill "both")
    
    ;pack rest of frames
    (pack .gamesmanGUI.picture3 :side 'top )
    (pack .gamesmanGUI.moveframe :expand #t :fill "both")
    (pack .gamesmanGUI.picture2 :side 'top)
    (pack .gamesmanGUI.options :expand #t :fill "both")
    
    
    ;pack moveframe
    (pack .gamesmanGUI.moveframe.hidemoves :side 'left :fill "both" :expand #t)
    (pack .gamesmanGUI.moveframe.allmoves :side 'left :fill "both" :expand #t)

   (if (not *play-without-solving*)            
       (begin 
      (pack .gamesmanGUI.moveframe.valuemoves :side 'left :fill "both" :expand #t)
      (pack .gamesmanGUI.moveframe.safemoves :side 'left :fill "both" :expand #t) ) )
      
    
    ;pack options
    (pack .gamesmanGUI.options.about :side 'left :fill "both" :expand #t)
    (pack .gamesmanGUI.options.newgame :side 'left :fill "both" :expand #t)
    (pack .gamesmanGUI.options.undo :side 'left :fill "both" :expand #t)
    (pack .gamesmanGUI.options.quit :side 'left :fill "both" :expand #t)
    
;pack delay sliders only if computer on computer
(if (and (player-is-computer? (get-rule 'initial-position))
         (opponent-is-computer? (get-rule 'initial-position)))
    (begin
               (pack .gamesmanGUi.move-delay-label :fill "both" :expand #t)
               (pack .gamesmanGUI.move-delay-scale :fill "both" :expand #t)
               (pack .gamesmanGUi.game-delay-label :fill "both" :expand #t)
               (pack .gamesmanGUI.game-delay-scale :fill "both" :expand #t) ))
    

;Setup Initial Variable States
   (set! move-var 1)
   (set! *gui-move-state* 'none)
   (if (and (player-is-computer? (get-rule 'initial-position))
            (opponent-is-computer? (get-rule 'initial-position)))
          (gui-disable-newgame))
   (gui-disable-moves)
   (gui-disable-undo)
   
;Start New Game   
   (set! *game-so-far*
         (list (get-rule 'initial-position)))
   (set! *moves-so-far* '())
   (wm 'deiconify *root*)
   (clear-graphics!)
   (gui-init-board (car *game-so-far*))
   (update 'idletasks)
   (gui-play-game)))
   

;; Determines whether a quit command has been requested resulting in the destruction of the gui-window
(define (gui-exists?)
   (symbol-bound? '.gamesmanGUI))
   
;; Function which starts up a new game
(define (gui-new-game)
   (set! *game-so-far*
         (list (get-rule 'initial-position)))
   (set! *moves-so-far* '())
   (wm 'deiconify *root*)
   (clear-graphics!)
   (gui-init-board (car *game-so-far*))
   (update 'idletasks)
   (gui-disable-undo)
   (gui-disable-moves)
   (gui-play-game)
  (if *play-without-solving*
   (gui-messenger "") 'done))
   

;;Disables all gui-buttons
(define (gui-disable-all-buttons)
   (gui-disable-undo)
   (gui-disable-moves)
   (gui-disable-newgame)
   (gui-disable-quit))

;; Displays an About window with picture... Yaaay!
(define (gui-about)
   (if (not (winfo 'exists '.about))
      (begin
         (.gamesmanGUI.options.about 'configure :state 'disabled)  
         (toplevel '.about :bg "White")
         (label '.about.picture 
                :background "White"
                :image (image 'create 'photo '.about.pic
                              :file (string-append *gamesman-path* "images/about.ppm")))
         (pack .about.picture)
         (label '.about.description :text "The Gamesmen")
         (button '.about.done 
                 :text "OK" 
                 :command (lambda () 
                             (.gamesmanGUI.options.about 'configure :state 'normal) 
                             (destroy .about)))
         (pack .about.done :fill "both"))))

;; Disables the Quit Button
(define (gui-disable-quit)
   (.gamesmanGUI.options.quit 'configure :state 'disabled))

;; Enables the Quit Button
(define (gui-disable-quit)
   (.gamesmanGUI.options.quit 'configure :state 'normal))
   
;; Disables the New Game button
(define (gui-disable-newgame)
   (.gamesmanGUI.options.newgame 'configure :state 'disabled))

;; Enables the New Game button
(define (gui-enable-newgame)
   (.gamesmanGUI.options.newgame 'configure :state 'normal))

;; Disables the undo button
(define (gui-disable-undo)
   (.gamesmanGUI.options.undo 'configure :state 'disabled)) 

;; Enables the undo button
(define (gui-enable-undo)
   (.gamesmanGUI.options.undo 'configure :state 'normal))

;; Disables the move selection buttons
(define (gui-disable-moves)
   (.gamesmanGUI.moveframe.hidemoves 'configure :state 'disabled)
   (.gamesmanGUI.moveframe.allmoves 'configure :state 'disabled)
   (if (not *play-without-solving*)
      (begin
        (.gamesmanGUI.moveframe.safemoves 'configure :state 'disabled)
        (.gamesmanGUI.moveframe.valuemoves 'configure :state 'disabled)) ) )
 
;; Enables the move selection buttons
(define (gui-enable-moves)
   (.gamesmanGUI.moveframe.hidemoves 'configure :state 'normal)
   (.gamesmanGUI.moveframe.allmoves 'configure :state 'normal)
   (if (not *play-without-solving*)
      (begin
        (.gamesmanGUI.moveframe.safemoves 'configure :state 'normal)
        (.gamesmanGUI.moveframe.valuemoves 'configure :state 'normal)) ) )

;; Alter the most-state variable which controls which type of move the player
;; wishes to view.  Either none,all,value or safe. 
(define (gui-move-toggle message)
   (gui-hide-moves)
   (set! *gui-move-state* message)
   (gui-show-moves))
 
;; Shows the moves so that the user may click on them to make a move.  
;; Most of this function deals with processing the move-list and move-values.

;; Helper function added to swap the value of a position if the position reflects
;; a go again move
(define (gui-swap-value val)
   (cond ((lose? val) win)
         ((win? val) lose)
         ((tie? val) val)
         ((draw? val) val)
         (else (error (word "Bad value to gui-swap-value" val)))))



(define (gui-show-moves)
   (gui-enable-moves)
   (gui-enable-undo)
   (gui-enable-newgame)
   (let* ((position (car *game-so-far*))
          (moves (safe-generate-moves position)))
          (cond ((equal? *gui-move-state* 'all)
                 (gui-show-all-moves (car *game-so-far*) 
                                     moves))
                ((and (equal? *gui-move-state* 'value) (not *play-without-solving*))
                 (let* ((child-positions (map (lambda (move) 
                                                 (safe-do-move position move)) 
                                                 moves))
                        (from-hash-table (map (lambda (pos) 
                                                 (let ((val (lookup-position pos)))
                                                    (if (equal? (safe-whose-move pos)
                                                                (safe-whose-move position))
                                                        (cons (gui-swap-value (car val)) (cdr val))
                                                        val)))
                                                     
                                                      child-positions)) 
                        (values (map value from-hash-table))
                        (values-moves (map list values moves)))
                       (gui-show-value-moves (car *game-so-far*)
                       (map cadr (filter (lambda (pair) (lose? (car pair))) values-moves))
                       (map cadr (filter (lambda (pair) (win? (car pair))) values-moves))
                       (map cadr (filter (lambda (pair) (tie? (car pair))) values-moves))
                       (map cadr (filter (lambda (pair) (draw? (car pair))) values-moves)))))
                ((and (equal? *gui-move-state* 'safe) (not *play-without-solving*))
                 (gui-show-safe-moves (car *game-so-far*)
                                      (get-value-equivalent-moves position)
                                      (value (lookup-position position))))
                (else 'okay))))

;; Hides all the possible moves. This is done to allow clean animation of the move.
;; Most of this function deals with processing the move-list and move-values.

(define (gui-hide-moves) 
   (gui-disable-moves)
   (gui-disable-undo)
   (gui-disable-newgame)
   (let* ((position (car *game-so-far*))
          (moves (safe-generate-moves position)))
         (cond ((equal? *gui-move-state* 'all)
                (gui-hide-all-moves (car *game-so-far*) 
                                    moves))
               ((and (equal? *gui-move-state* 'value) (not *play-without-solving*))
                (let* ((child-positions (map (lambda (move) 
                                         (safe-do-move position move)) 
                                         moves))
                       (from-hash-table (map lookup-position child-positions))
                       (values (map value from-hash-table))
                       (values-moves (map list values moves)))
                      (gui-hide-value-moves (car *game-so-far*)
                      (map cadr (filter (lambda (pair) (lose? (car pair))) values-moves))
                      (map cadr (filter (lambda (pair) (win? (car pair))) values-moves))
                      (map cadr (filter (lambda (pair) (tie? (car pair))) values-moves))
                      (map cadr (filter (lambda (pair) (draw? (car pair))) values-moves)))))
               ((and (equal? *gui-move-state* 'safe) (not *play-without-solving*))
               	                (gui-hide-safe-moves (car *game-so-far*) (get-value-equivalent-moves position) 
                                     (value (lookup-position position))))
               (else 'okay))))

;; This function handles undos.  If a player hits undo on a new game, the function 
;; returns gracefully and does nothing.  If a player hits undo on a new game, but the
;; computer has gone first, then the computer's move is undone and the computer goes
;; again.  Otherwise, if a player hits undo when playing a computer, both the player's
;; last move and the computers is undone.  Otherwise, only one move is undone.

(define (gui-undo)
  (if (not (safe-primitive-position (car *game-so-far*)))
      (gui-hide-moves))
      (gui-disable-undo)
      (gui-disable-moves)
      (gui-disable-newgame)
      (gui-undo-loop)
      (gui-enable-undo)
      (gui-enable-moves)
      (gui-enable-newgame)
      (gui-play-game)
  (if *play-without-solving*
      (gui-messenger "")))
      
(define (gui-undo-loop)
  (let ((undo-once (cdr *game-so-far*)))
    (if (not (null? undo-once))
       (begin
          (gui-handle-undo (car *game-so-far*) (car *moves-so-far*) (car undo-once))
          (update 'idletasks)
          (set! *game-so-far* undo-once)
          (set! *moves-so-far* (cdr *moves-so-far*))
          (if (player-is-computer? (car *game-so-far*))
             (gui-undo-loop))))))

;; Function which handles the output messages and cleanup when a game is over.
(define (gui-game-over position game-value)
   (if (or (not (player-is-computer? (car *game-so-far*)))
           (not (opponent-is-computer? (car *game-so-far*))))
       (gui-enable-undo))
       (gui-enable-newgame)
   (let ((message (cond ((tie? game-value)
                         "GAME OVER: It's a tie.\n")
                         ((lose? game-value)
                          (string-append "GAME OVER: " (name-of-opponent position) " wins!\n"))
                         ((win? game-value)
                          (string-append "GAME OVER: " (name-of-player position) "wins!\n")))))
  (gui-messenger message)
  (gui-whosemove "")
  (gui-disable-moves)

  (if (and (player-is-computer? position)
           (opponent-is-computer? position))
           (begin (after (round (* 1000 *delay-between-games*)) gui-new-game)))))
 

;; Function which controls predictions
(define (gui-predictions position) 
   (if (not *play-without-solving*)
  (let* ((value&remote (lookup-position position)))
    (cond ((draw? (value value&remote)) (gui-predict-draw position))
	  ((win? (value value&remote)) (gui-predict-win position (remoteness value&remote)))
	  ((lose? (value value&remote)) (gui-predict-loss position (remoteness value&remote)))
	  ((tie? (value value&remote)) (gui-predict-tie position (remoteness value&remote)))))))


;; Function which manipulates the messenger on the gui to display the text
;; that predicts a draw   
(define (gui-predict-draw position)
  (if (player-is-computer? position)
      (gui-messenger (string-append "This is a draw position: " 
                                    (name-of-player position) 
                                    " will play forever to avoid losing."))	
      (if (opponent-is-computer? position)
	  (gui-messenger (string-append "This is a draw position: "
                                 (name-of-player position) 
                                 "A will play forever. Game ends only when you err."))
	  (gui-messenger (string-append "This is a draw position: The game will end only when you or "
                                 (name-of-opponent position) "makes a mistake.")))))

;; Function which manipulates the messenger on the gui to display the text
;; that predicts a loss			        
(define (gui-predict-loss position moves)
  (gui-messenger (string-append (name-of-player position)
                                (if (= moves 1)
                                   " is about to make the final move before losing the game."
                                   (string-append 
                                       (if (opponent-is-computer? position) " will " " should ")
                                       "lose in " (word->string moves) " moves.")))))

;; Function which manipulates the messenger on the gui to display the text
;; that predicts a win	
(define (gui-predict-win position moves)
  (gui-messenger (string-append (name-of-player position)
                                (if (= moves 1)
                                   (if (player-is-computer? position)
                                      " is about to make the final move and win the game."
                                      " should make the final move and win the game now.")
                                   (string-append (if (player-is-computer? position)
                                                     " will win the game in "
                                                     " should win the game in ")
                                                     (word->string moves) " moves.")))))
;; Function which manipulates the messenger on the gui to display the text
;; that predicts a tie	
(define (gui-predict-tie position moves)
  (gui-messenger (string-append (name-of-player position)
                                (if (= moves 1)
                                   (if (player-is-computer? position)
                                      " is about to make the final move and tie the game. "
                                      " should make the final move and tie the game now.")
                                      (string-append " should tie the game in " (word->string moves) " moves.")))))

;; Destroys the gui and hides the gameboard
(define (gui-quit)
   (wm 'withdraw *root*)
   (destroy .gamesmanGUI))

;; The game loop driver.  The function determines whether a game is over, or whether
;; a player needs to make a move;

(define (gui-play-game)
  (update 'idletasks)
  (let ((primitive (safe-primitive-position (car *game-so-far*)))
        (position (car *game-so-far*)))
       (if primitive
          (gui-game-over position primitive)
          (begin
             (if (get-option 'predictions *play-options*)
                (gui-predictions position)
                (gui-messenger "")) ;; added to get rid of GAME OVER message if undo-ing after game over
                (gui-whosemove (string-append (safe-whose-move position) "'s move"))
                (gui-get-move-and-continue (get-option (safe-whose-move position) *play-options*))))))

;; The function which determines either the computer's move, if it's the computer's
;; turn, or calls show-moves to allow for the human player to enter a move        

(define (gui-get-move-and-continue get-move)
  (let ((position (car *game-so-far*)))
    (if (player-is-computer? position) 
       (if (gui-exists?)
          (let ((move (get-computer-move position 'dummy)))
             (set! *game-so-far* (cons (safe-do-move position move) *game-so-far*))
             (set! *moves-so-far* (cons move *moves-so-far*))
             (after (round (* 1000 *delay-between-moves*)) 
               (lambda ()
                  (gui-handle-move position move (car *game-so-far*))
                  (gui-play-game)))))
         (gui-show-moves))))

;; The function that is called from the module when a move is made.
;; Its only argument is the move.  If the move is valid, then it is
;; processed and handle-moves is called.  If the move is invalid,
;; the function gracefully returns and nothing happens. 

(define (gui-return-from-human-move move)
   (let ((primitive (safe-primitive-position (car *game-so-far*)))
         (position (car *game-so-far*)))
         (if (and (not primitive) (member move (safe-generate-moves position)))
            (let ((new-position (safe-do-move position move)))
               (gui-hide-moves)
               (gui-handle-move (car *game-so-far*) move new-position )
               (set! *game-so-far* (cons new-position *game-so-far*))
               (set! *moves-so-far* (cons move *moves-so-far*))
               (gui-play-game)))))

;; Function which resets the lower message label to the value of text_string
(define (gui-messenger text_string) 
   (.gamesmanGUI.messenger 'configure :text text_string))

;; Function which resets the upper whosemove label to the value of text_string
(define (gui-whosemove text_string) 
   (.gamesmanGUI.whosemove 'configure :text text_string))


;; Clears the functions for when you return to the load game menu and select a different game
(define (gui-make-functions-clean)
   (eval '(define (gui-init-board position) #f))
   (eval '(define (gui-handle-move old-pos move new-pos) #f))
   (eval '(define (gui-handle-undo current-pos move-to-undo pos-after-undo) #f))
   (eval '(define (gui-show-all-moves position move-list) #f))
   (eval '(define (gui-hide-all-moves position move-list) #f))
   (eval '(define (gui-show-value-moves pos win-moves lose-moves tie-moves draw-moves) #f))
   (eval '(define (gui-hide-value-moves pos win-moves lose-moves tie-moves draw-moves) #f))
   (eval '(define (gui-show-safe-moves pos move-list value) #f))
   (eval '(define (gui-hide-safe-moves pos move-list value) #f)))

;; Function which creates a wrapper for all other functions to execute only if the gui actually exists   
(define (gui-make-safe proc)
      (lambda (. args) (if (gui-exists?)
                           (apply proc args))))

;; Makes all the internal gamesman procedures safe to use
;; This function wrapps each of the necessary above functions so they only execute if the gui has
;; not been destroyed
(define (make-gui-procs-safe)
   (map (lambda (proc)
           (eval `(define ,proc (gui-make-safe ,(eval proc)))))
        '(gui-new-game gui-return-from-human-move gui-get-move-and-continue gui-play-game
                       gui-game-over gui-show-moves gui-hide-moves gui-undo
                       gui-messenger gui-whosemove gui-predictions
                       gui-predict-win gui-predict-tie gui-predict-loss gui-predict-draw)))
                       
(make-gui-procs-safe)




;; The abstractions:
(define draw 'd)
(define tie 't)
(define win 'w)
(define lose 'l)
(define undecided 'u)

(define (draw? value) (equal? value draw))
(define (win? value) (equal? value win))
(define (lose? value) (equal? value lose))
(define (tie? value) (equal? value tie))
(define (undecided? value) (equal? value undecided)) 

(define (value->string value) 
  (cond ((draw? value) "DRAW")
	((win? value) "WIN") 
        ((tie? value) "TIE")
        ((lose? value) "LOSE") 
        ((undecided? value) "UNDECIDED") ;; should NEVER be printed
	(gamesman:fatal "VALUE->STRING\n"
			"Value neither WIN, TIE, LOSE or UNDECIDED: " value)))

;; Creates the game database which, after the game is solved, contains the 
;; value WIN/TIE/LOSE of every possible game position, keyed by its HASH value. 
;; DATABASE is initialized with UNDECIDED values. 
(define (initialize-database) 
  (set! *database* (make-hash-table equal?))
  (gc))

;; Returns true iff any item in SENT satisfies PRED. 
(define (any? pred sent) 
  (< 0 (count (keep pred sent))))

;; This is used for determine-value to decide which pred to use depending
;; on who you are.
(define (any-with-move-again? pred-for-them pred-for-me sent-vals sent-turns me) 
  (if (empty? sent-vals)
      #f
      (if (equal? (first sent-turns) me)
	  (or (pred-for-me (first sent-vals))
	      (any-with-move-again? pred-for-them pred-for-me (bf sent-vals) (bf sent-turns) me))
	  (or (pred-for-them (first sent-vals))
	      (any-with-move-again? pred-for-them pred-for-me (bf sent-vals) (bf sent-turns) me)))))

(define (all? pred sent)
  (null? (filter (lambda (x) (not (pred x))) sent)))

;; Use for determine value to see if the values are all win or lose
;; depending on whose turn it is

(define (all-with-move-again? pred-for-them pred-for-me sent-vals sent-turns me) 
  (if (empty? sent-vals)
      #t
      (if (equal? (first sent-turns) me)
	  (and (pred-for-me (first sent-vals))
	      (all-with-move-again? pred-for-them pred-for-me (bf sent-vals) (bf sent-turns) me))
	  (and (pred-for-them (first sent-vals))
	      (all-with-move-again? pred-for-them pred-for-me (bf sent-vals) (bf sent-turns) me)))))

;; Takes an association list ((key . value) (key . value) ...) and returns 
;; a list of those pairs for which (pred key) returns true. 
(define (filter-assoc pred a) 
  (cond ((null? a) '())
        ((pred (caar a)) 
         (cons (car a) (filter-assoc pred (cdr a)))) 
        (else (filter-assoc pred (cdr a)))))
 
;; Stores the given VALUE in the game database keyed by HASHED-POSITION. 
(define (store-value! position value)
  (hash-table-put! *database* position value)
  value)

;; Looks up the value of HASHED-POSITION in the game database. Game database 
;; should be initilaized with UNDECIDED values, so UNDECIDED is returned for 
;; any position whose value is not yet determined. 
(define (lookup-position position) 
  (hash-table-get *database* position #f))

(define (visited? val) val)

(define value car)
(define remoteness cdr)
(define glue-together cons)

(define (all-are-draws draw-positions)
  (format #t ">>> The game has ~A positions that are draws.\n" 
	  (length draw-positions))
  (for-each (lambda (pos)
	      (store-value! pos (glue-together draw -1)))
	    draw-positions))

(define (resolve-loopy-queue)
  (display "[Solving] The loopy queue contains ")
  (display (queue-size loopy-queue))
  (show " positions.")
  (define (resolve-queue all-draws draws)
    (if (empty-queue? loopy-queue)
	(if all-draws
	    (all-are-draws draws)
	    (begin (add-to-queue loopy-queue draws)
		   (resolve-loopy-queue)))
	(begin (store-value! (queue-front loopy-queue) #f) 
	       (let ((value (determine-value (queue-front loopy-queue) #f)))
		 (if (undecided? (car value))
		     (let ((pos (queue-front loopy-queue)))
		       (pop-queue! loopy-queue)
		       (resolve-queue all-draws (cons pos draws)))
		     (begin (store-value! (queue-front loopy-queue) value)
			    (pop-queue! loopy-queue)
			    (resolve-queue #f draws)))))))
  (resolve-queue #t '()))

(define *determine-value:called* 0)

(define (print-progress-report)
  (let ((o (open-output-string)))
    (with-error-to-port o (lambda () (hash-table-stats *database*)))
    (let ((entries (with-input-from-string (get-output-string o) (lambda () (read)))))
      (format #t "[Solving] The hash table contains ~A positions.\n" entries))
    (close-port o)))

(define (determine-value position push)
  (let ((value&remote (lookup-position position))
	(primitive (safe-primitive-position position)))
    (set! *determine-value:called* (+ *determine-value:called* 1))
    (if (and push (= (remainder *determine-value:called* 3000) 0))
	(print-progress-report))
    (cond ((visited? value&remote))
          (primitive                
           (store-value! position (glue-together primitive 0)))   ;; primitve = 0 remoteness
          (else
	   (store-value! position (glue-together undecided -1))
	   (let* ((moves (safe-generate-moves position)) 
		  (val-remote-pairs 
		   (map (lambda (move) 
			  (determine-value (safe-do-move position move) push))
			moves))
		  (just-values (map value val-remote-pairs))
		  (just-turns (map (lambda (mv) (whose-move (safe-do-move position mv))) moves)))
	     (cond ((null? moves) 
		    (gamesman:fatal "DETERMINE-VALUE\n"
				    "No moves available for non-primitive position: "
				    position))
		   ((any-with-move-again? lose? win? just-values just-turns (whose-move position))
		    (store-value! position 
				  (glue-together win (+ (filter-reduce-go-again val-remote-pairs min win? lose? just-turns
								       (whose-move position)) 1))))
		   ((any? tie? just-values)
		    (store-value! position 
				  (glue-together 
				   tie 
				   (+ (filter-reduce val-remote-pairs max tie?) 1))))
		   ((any? undecided? just-values)
		    (if push
			(push! position loopy-queue))
		    (glue-together undecided -1))
		   ((any? draw? just-values) (glue-together draw -1))
		   ((all-with-move-again? win? lose? just-values just-turns (whose-move position)) 
		    (store-value! position 
				  (glue-together lose (+ (filter-reduce-go-again val-remote-pairs max lose? win? just-turns
										 (whose-move position)) 1))))
		   (else 
		    (gamesman:fatal "DETERMINE-VALUE\n"
				    "No wins, ties, loses, draws or undecided values among " 
				    just-values 
				    "\n for position: " position))))))))


(define (filter-reduce value-remote-pairs minmax predicate)
  (let ((filtered (filter (lambda (value&remote) (predicate (car value&remote)))
			  value-remote-pairs)))
    (accumulate minmax (map remoteness filtered))))

(define (filter-reduce-go-again value-remote-pairs minmax my-pred their-pred turns me)
  (let ((filtered (filter-go-again their-pred my-pred turns me value-remote-pairs)))
    (accumulate minmax (map remoteness filtered))))

(define (filter-go-again their-pred my-pred turns me value-remote-pairs)
  (if (null? value-remote-pairs) '()
      (if (equal? me (first turns))
	  (append (if (my-pred (value (first value-remote-pairs))) (list (car value-remote-pairs)) '())
	      (filter-go-again their-pred my-pred (cdr turns) me (cdr value-remote-pairs)))
	  (append (if (their-pred (value (first value-remote-pairs))) (list (car value-remote-pairs)) '())
	      (filter-go-again their-pred my-pred (cdr turns) me (cdr value-remote-pairs))))))
	  

;; Takes a HASHED-POSITION and, depending on its value, returns a list of 
;; all possible moves of the same value. If the value of HASHED-POSITION is 
;; WIN, a list of all losing moves is returned to put the board in a loosing 
;; position for opponent; if the value of HASHED-POSITION is lose, then all 
;; possible moves are returned, as there is no hope of winning the game.
(define (get-value-equivalent-moves position) 
   (if (not *play-without-solving*)
  (let ((primitive (safe-primitive-position position)) 
	(position-value (value (lookup-position position)))) 
    (cond (primitive '())                   ;; if primitive, no moves possible
	  ((not position-value)
	   (gamesman:fatal "GET-VALUE-EQUIVALENT-MOVES\n" 
			   "Position not found in hash table: " position))
          ((undecided? position-value) 
           (gamesman:fatal "GET-VALUE-EQUIVALENT-MOVES\n" 
			   "Position value is undecided: " position)) 
          (else (let* ((moves (safe-generate-moves position)) 
                       (child-positions (map (lambda (move) 
					       (safe-do-move position move)) 
					     moves)) 
                       (from-hash-table (map lookup-position child-positions)) 
                       (values (map value from-hash-table))
		       (depths (map remoteness from-hash-table))
		       (values-depths-moves (map list values depths moves))
		       (turns (map whose-move child-positions)))
		  (cond ((win? position-value) 
                         (quickest-wins
			  (filter-go-again lose? win? turns (whose-move position) values-depths-moves)))
			((tie? position-value)
			 (longest-ties
			  (filter (lambda (triple) (tie? (car triple))) values-depths-moves)))
			((draw? position-value)
			 (map caddr 
			      (filter (lambda (triple) (draw? (car triple))) values-depths-moves)))
                        ((lose? position-value)
			 (longest-loses values-depths-moves))
                        (else 
			 (gamesman:fatal "GET-VALUE-EQUIVALENT-MOVES\n"
					 "Position value neither win, tie, lose or draw: " position)))))))))  ;;;;;;;; dont forget to close the 'if'

;;Filters out all values with remoteness
(define (quickest-wins values-remoteness-moves)
  (define (quick-help triples quickest)
    (cond ((null? triples) (map caddr quickest))
	  ((< (cadr (car triples)) (cadr (car quickest)))
	   (quick-help (cdr triples) (list (car triples))))
	  ((> (cadr (car triples)) (cadr (car quickest)))
	   (quick-help (cdr triples) quickest))
	  (else
	   (quick-help (cdr triples) (cons (car triples) quickest)))))
  (if (not *play-without-solving*)
      (quick-help (cdr values-remoteness-moves) (list (car values-remoteness-moves)))))
	  

(define (longest-ties values-remoteness-moves)
  (define (long-help triples longest)
    (cond ((null? triples) (map caddr longest))
	  ((> (cadr (car triples)) (cadr (car longest)))
	   (long-help (cdr triples) (list (car triples))))
	  ((< (cadr (car triples)) (cadr (car longest)))
	   (long-help (cdr triples) longest))
	  (else
	   (long-help (cdr triples) (cons (car triples) longest)))))
  (if (not *play-without-solving*)
    (long-help (cdr values-remoteness-moves) (list (car values-remoteness-moves)))))

(define (longest-loses values-remoteness-moves)
   
  (if (not *play-without-solving*)
    (longest-ties values-remoteness-moves)))

(define (make-queue)
  (cons '() '()))

(define (push! elt q)
  (if (empty-queue? q)
      (begin (set-car! q (list elt))
	     (set-cdr! q (car q)))
      (begin (set-cdr! (cdr q) (list elt))
	     (set-cdr! q (cdr (cdr q))))))


(define (add-to-queue q lst)
  (for-each (lambda (elt) (push! elt q)) lst))

(define (empty-queue? q)
  (null? (car q)))

(define (pop-queue! q)
  (set-car! q (cdr (car q))))

(define (queue-size q)
  (length (car q)))

(define (queue-front q)
  (caar q))

(define loopy-queue 'not-initialized-yet)

;;; overwritten scheme procedure to allow 2^17 variations instead of 
;;; 2^8
(define (rand-update x)
   (let ((a 251) 
         (b 521) 
         (m 131071)) ;; (2^17 - 1)
     (modulo (+ (* a x) b) m)))
          


;;Random Number Generator
(define random-generator
  (let ((seed 5297))
    (define (set-seed value)
      (set! seed value))
    (define (generate upper-bound)
      (set! seed (rand-update seed))
      (remainder seed upper-bound))
    (define (handler message value)
      (cond ((equal? message 'generate)
	     (generate value))
	    ((equal? message 'set-seed)
	     (set-seed value))
	    ((equal? message 'get-seed)
	     seed)
	    (else
	     (gamesman:fatal "RANDOM-GENERATOR\n"
			     "Unknown message: " message))))
    handler))

;; Returns the value of the option called KEY in table TABLE. 
(define (get-option key table) 
  (let ((record (assoc key (cdr table)))) 
    (if record (cdr record) 
        (gamesman:fatal "GET-OPTION\n"
			"No such option " key " in " table))))
 
;; Sets the value of the option called KEY to be VALUE in table TABLE. 
;; Overwrites any previous value for the option called KEY. 
(define (set-option! key value table) 
  (if (eq? table *game-specific-options*) 
      (set! *game-specific-options-changed* #t)) 
  (let ((record (assoc key (cdr table)))) 
    (if record (set-cdr! record value) 
        (set-cdr! table (cons (cons key value) (cdr table))))) 'okay) 

;; Abstractions for the module: 
(define (get-rule key) (get-option key *game-specific-options*)) 

(define (set-rule! key value) (set-option! key value *game-specific-options*)) 

;; This creates the two menus. 
(define *game-specific-options-menu* (list 'GAME-SPECIFIC-MENU)) 

(define *play-options-menu* (list 'PLAY-MENU)) 

;; Adds to the end of menu MENU a new cons-cell of two procedures: 
;; OPT-PRINTER which prints the value of an option and OPT-PROC 
;; which changes the value of that option. 
(define (add-to-menu! letter opt-printer opt-proc menu) 
  (cond ((not (procedure? opt-printer)) 
         (error "Second argument not a procedure -- ADD-MENU-ENTRY!")) 
        ((not (procedure? opt-proc)) 
         (error "Third argument not a procedure -- ADD-MENU-ENTRY!")) 
        ((not (and (word? letter) (= (count letter) 1))) 
         (error "First argument not a single letter -- ADD-MENU-ENTRY!")) 
        (else (append! menu (list (list letter opt-printer opt-proc))))))

;; Take 61a to know what this is all about. 
(define (append! L1 L2) 
  (set-cdr! (last-pair L1) L2)) ;; The last cons-cell in list L. 
 
;; NOTE that this procedure must be used as part of an argument to 
;; the set! procedure to have desired results on global variables .
;(define (remove-from-menu! letter menu)
;  (filter (lambda (x) (not (equal? (car x) letter))) (cdr menu)))      
                     
(define (last-pair L) 
  (if (null? (cdr L)) 
      L 
      (last-pair (cdr L))))
 
;; Abstraction for the module: 
(define (add-menu-entry! opt-printer opt-proc) 
  (add-to-menu! "Z" opt-printer opt-proc *game-specific-options-menu*))

;; Shows the current value of the random-number seed, which determines the 
;; sequence of pseudorandom numbers that may be obtained. (Initial setting: 807) 
(define (display-random-seed) 
  (display "Set random seed (Current setting: ")
  (display (random-generator 'get-seed 'dummy))
  (display ")"))
 
;; Will allow you to set the ranmdom seed ... soon. Doesn't do anything but 
;; error-check now. 
(define (set-random-seed) 
  (display ">>> The random seed determines the sequence of random moves carried\n")
  (display ">>> out by the computer player. Resetting the seed will cause the\n")
  (display ">>> computer to choose the same moves when given the same position.\n")
  (display "\n>>> Enter new value for random seed: ")
  (let ((seed (read))) 
    (if (and (integer? seed) (> seed 0))
	(begin (random-generator 'set-seed seed)
	       (play-options))
        (begin (format #t "\n[Oops!] New seed value not a positive integer: ~A\n" seed)
	       (set-random-seed)))))
 
;; displays whether predictions are on or off. (initial setting: on) 
(define (display-preds-on-off) 
  (if (and (get-option 'predictions *play-options*) (not *play-without-solving*)
      (display "Toggle predictions from [ON] to off") 
      (display "Toggle predictions from [OFF] to on"))))
 
;; toggles predictions on/off. 
(define (toggle-preds)
    (set-option! 'predictions (and *play-without-solving* (not (get-option 'predictions *play-options*))) *play-options*))

(define (initialize)
  (undefine-all *required-variables*)
  (initialize-database)
  (set! *game-specific-options-changed* #t)
  (clear-menu! *play-options-menu*)
  (clear-table! *play-options*)
  (clear-menu! *game-specific-options-menu*)
  (clear-table! *game-specific-options*)
  (set! loopy-queue (make-queue))
  (gc)
  (set-option! 'predictions #t *play-options*)
  (set-option! 'random-seed (random-generator 'get-seed 'dummy) *play-options*)
  (set-option! 'graphics "NONE" *play-options*)
  #t)

(define (clear-menu! menu)
  (set-cdr! menu '()))

(define (clear-table! table)
  (set-cdr! table '()))

(define quit 'not-yet)

;; redefine DISPLAY to flush output
(define display
  (let ((old-display display))
    (lambda args (apply old-display args) (flush))))

;; redefine FORMAT to flush output
(define format
  (let ((old-format format))
    (lambda args
      (apply old-format args)
      (flush))))

(define (press-enter-to-continue)
  (display ">>> Press ENTER to continue.")
  (read-line))

;; Saves the state of the program to a file of the user's choosing. The name
;; of the file must be of the form "*.tree", and it will be created in the
;; directory specified by*gamesman-path*. This function will write to the
;;file the following, in order and with no other output:
;; 1. *game-name*
;; 2. *group-members*
;; 3. *game-specific-options* 
;; 4. *database* (via HASH-TABLE->LIST)
;;
;; The play options are not written because they are generated dynamically
;; each time a game module is loaded.
(define (write-game-tree)
  (display "\n>>> Write game tree to file. Use (R) to read in tree later.\n")
  (format #t
	  ">>> File will be created in ~A\n"
	  (expand-file-name 
	   (string-append *gamesman-path* "trees/")))

  
  (show-tree-menu)
  (display "Type your selection and press ENTER: ") 
  (let ((ans (read)))
    (if (not (and (word? ans) (member? ans '(s m c u o))))
        (begin (display "Invalid answer. Game tree not written.")
               (play-options))
        (let ((file-name (cond ((equal? ans 's) (get-file-string "std"))
                               ((equal? ans 'm) (get-file-string "mis"))
                               ((equal? ans 'c) (get-file-string "cmp"))
                               ((equal? ans 'u) (get-file-string "usr"))
                               ((equal? ans 'o) (get-file-string (number->string (next-tree-num 1)))))))
          (let ((out (open-output-file (string-append *gamesman-path* "trees/" file-name))))  
            
            (write *game-name* out)
            (newline out)
            (write *group-members* out)
            (newline out)    
            (write *game-specific-options* out)
            (newline out)
            (write (hash-table->list *database*) out)
            (close-port out)
            (format #t "\n>>> Game tree written successfully as file ~A\n" file-name))
          
          (press-enter-to-continue)
          (play-options))) ))

(define (show-tree-menu)
  (show "\nWrite Tree Menu")
  (display "------------------------------------------------------------------------\n")
  (show "(S) Write tree as STANDARD tree.")
  (show "(M) Write tree as MISERE tree.")
  (show "(C) Write tree as COMPULSORY tree.")
  (show "(U) Write tree as USER tree.")
  (show "(O) Write tree to OTHER tree."))

  
  
(define (get-file-string n)
  (string-append *game-name* "_" n ".tree"))

(define (next-tree-num n)
  (let ((file-name (expand-file-name (string-append *gamesman-path* "trees/" *game-name* "_" (number->string n) ".tree"))))
    (if (file-exists? file-name)
      ;; check to see if game options for FILE-NAME are same as current
      ;; if they are, we overwrite that existing tree
        (let ((in (open-input-file file-name)))
          (read in) ;; game-name
          (read in) ;; group-name
          (if (equal? *game-specific-options* (read in))
              n
              (next-tree-num (+ n 1))))
        n)))


;; Restores the state of the program by reading in a previously solved and
;; saved game tree of the user's choosing. Game tree file must be located in the
;; directory indicated by *gamesman-path* and must be of the form "*.tree". The
;; current state of the program -- from the game tree to the game-specific options
;; -- WILL BE OVERWRITTEN. This function does a trivial check to make sure that
;; the game tree file contains a tree for the currently loaded game module: *game-name*
;; and *group-members* are checked against those found in the game tree file. 
(define (read-game-tree)
  (display "\n>>> Read game tree from file. Warning: current game will be overwritten.\n")
  (format #t ">>> Looking for files in ~A\n\n"
	  (expand-file-name 
	   (string-append *gamesman-path* "trees/")))
  
  (let* ((non-num-trees (count (keep tree-exists? '("std" "mis" "cmp" "usr"))))
         (num-trees (- (+ non-num-trees (next-tree-num 1))  1)))
    (if (= num-trees 0)
        (begin (format #t "\nThere are no trees for this game in ~A\n" (string-append *gamesman-path* "trees/"))
               (press-enter-to-continue)
               (game-specific-options))
        (begin 
          (for-each display-tree (keep tree-exists? '("std" "mis" "cmp" "usr")))
          (let ((ans (display-num-trees 1)))
            (if (not ans)
                (begin (display "Game tree not read.\n")
                       (press-enter-to-continue)
                       (game-specific-options))
                (begin (cond ((equal? ans 's) (load-tree "std"))
                             ((equal? ans 'm) (load-tree "mis"))
                             ((equal? ans 'c) (load-tree "cmp"))
                             ((equal? ans 'u) (load-tree "usr"))
                             (else (load-tree (number->string ans))))
                       (press-enter-to-continue)
                       (game-specific-options))))))))

(define (tree-exists? t)
  (let ((file-name (expand-file-name (string-append *gamesman-path* "trees/" *game-name* "_" t ".tree"))))
    (file-exists? file-name)))

(define (load-tree t)
  (let* ((file-name (expand-file-name (string-append *gamesman-path* "trees/" *game-name* "_" t ".tree")))
         (in (open-input-file file-name)))
    (initialize-database)
    (let ((game (read in))
          (group (read in)))
      (cond ((and (equal? game *game-name*) (equal? group *group-members*))
             (set! *game-specific-options* (read in))
             (set! *game-specific-options-changed* #f)
             (for-each (lambda (key-val) (store-value! (car key-val) (cdr key-val)))
                       (read in))
             (display "\n>>> Game tree read successfully.\n"))
            (else
             (format #t 
                     "\n>>> You must load the appropriate game module before reading its game tree.\n")
             (format #t ">>> Currently, you are playing ~A by ~A.\n"
                     *game-name* *group-members*)
             (format #t ">>> First load the ~A module by ~A, then try again.\n"
                     game group))))))

(define (next-tree-num n)
  (let ((file-name (expand-file-name (string-append *gamesman-path* "trees/" *game-name* "_" (number->string n) ".tree"))))
    (if (file-exists? file-name)
      ;; check to see if game options for FILE-NAME are same as current
      ;; if they are, we overwrite that existing tree
        (let ((in (open-input-file file-name)))
          (read in) ;; game-name
          (read in) ;; group-name
          (if (equal? *game-specific-options* (read in))
              n
              (next-tree-num (+ n 1))))
        n)))

(define (display-tree ext)
  (let* ((file-name (expand-file-name (string-append *gamesman-path* "trees/" *game-name* "_" ext ".tree")))
         (in (open-input-file file-name)))
    (read in) ;;game-name
    (read in) ;;group-members
    (let ((game-options (read in)))
      (display (string-append "(" (substring ext 0 1) ") " *game-name* "_" ext ".tree\n"))
      (for-each display-options (cdr game-options)))))


(define (total-num-trees n)
  (let ((file-name (expand-file-name (string-append *gamesman-path* "trees/" *game-name* "_" (number->string n) ".tree"))))
    (if (file-exists? file-name)
        (total-num-trees (+ n 1))
        (- n 1))))

(define (display-num-trees n)
  (let ((file-name (expand-file-name (string-append *gamesman-path* "trees/" *game-name* "_" (number->string n) ".tree"))))
    (if (file-exists? file-name)
        (if (and (= (count (keep tree-exists? '("std" "mis" "cmp" "usr")))  (remainder n 5)) (not (= n 1)))
            (begin
              (display "\nEnter the number for the desired tree or press 'n' to continue to next page: ")
              (let ((ans (read)))
                (cond ((equal? ans 'n) (display-tree (number->string n)) (display-num-trees (+ n 1)))
                      ((and (number? ans) (> ans 0) (<= ans (total-num-trees 1))) ans)
                      ((and (word? ans) (member? ans (every (lambda (t) (substring t 0 1)) (keep tree-exists? '("std" "mis" "cmp" "usr"))))) ans)
                      (else (begin (display "Invalid answer. ")
                                   #f)))))
            (begin (display-tree (number->string n)) 
                   (display-num-trees (+ n 1))))
        (begin
          (display "\nEnter the number for the desired tree: ")
          (let ((ans (read)))
            (cond ((and (number? ans) (> ans 0) (<= ans (total-num-trees 1))) ans)
                  ((and (word? ans) (member? ans (every (lambda (t) (substring t 0 1)) (keep tree-exists? '("std" "mis" "cmp" "usr"))))) ans)
                  (else (begin (display "Invalid answer. ")
                                   #f))))))))

(define (display-options option)
  (let ((option-name (car option))
        (option-setting (cdr option)))
    (cond ((equal? option-name 'initial-position) (display "\tThe initial position is ")(display option-setting))
          ((equal? option-name 'standard-game) (if option-setting (display "\tStandard game.") (display "\tMisere game.")))
          (else (format #t "\tOption ~A is set to ~A." option-name option-setting))))
    (newline))
  
;;Checks if a module ends in .tree.  If it does, returns it, else it adds it.
(define (check-dot-tree name)
  (cond ((<= (count name) 5)
         (string-append name ".tree"))
        ((equal? (word (last (bl (bl (bl (bl name)))))
                       (last (bl (bl (bl name))))
                        (last (bl (bl name)))
                        (last (bl name))
                        (last name)) 
                        ".tree")
          name)
         (else (string-append name ".tree"))))

;; Signals a fatal error and quits. 
(define (gamesman:fatal . what-happened)
  (display "Fatal Error in Gamesman: ")
  (for-each display what-happened)
  (newline)
  (quit "Oops"))