#!./mred -fmv-

(require-library "invoke.ss")

; Load the basic board library (also used by smart player program):
(load-relative "utils.ss")

;; Graphical size of a cell in pixels
(define cell-size 40)

;; x/o font size (points)
(define font-size 24)

;; Automated players
(define x-player #f)
(define o-player #f)

;; Built-in program players
(define-struct robot (name player))
(define robots (list (make-robot "Stupid (always B1)" 
				 (lambda (n moves) 
				   (sleep 1) 
				   '(B 1)))
		     (make-robot "Smart (30-sec strategy)"
				 (load-relative "robot.ss"))))

(define (local-file f)
  (build-path (collection-path "games" "pousse") f))

;;; Game State ;;;

(define board (new-board n))
(define history (new-history))

(define current-player x)

(define playing? #f) ; lock out board clicks when running an automated player

(define winner #f)
(define loser #f)

(define moves null)

;; For moving back and forth in the history:
(define past-state null)
(define future-state null)

(define (convert-move s)
  (list (string->symbol (string (char-downcase (string-ref s 0))))
	(string->number (substring s 1 (string-length s)))))

;;; More Utilities ;;;

(define (get-state) 
  (list board moves current-player history winner loser))


;; The move functions
(define (mk-push! side side-char)
  (lambda (i)
    (send canvas animate-push side i current-player)
    (set! future-state null)
    (set! past-state (cons (get-state) past-state))
    (set! board (push board side i current-player))
    (set! moves (append moves (list (format "~a~a" side-char (add1 i)))))
    (set! current-player (other-player current-player))
    (send clock-timer reset)
    (send canvas repaint)))
(define push-left! (mk-push! 'left #\L))
(define push-right! (mk-push! 'right #\R))
(define push-top! (mk-push! 'top #\T))
(define push-bottom! (mk-push! 'bottom #\B))

(define (check-winner)
  (let ([v (find-winner board)])
    (when v
      (set! winner v))))

(define (check-loser)
  (when (find-board-in-history board history)
    (set! loser (other-player current-player))))

(define (in-straight? board v i j)
  (or (andmap (lambda (x) x) 
	      (n-map n (lambda (j) (eq? (board-cell board i j) v))))
      (andmap (lambda (x) x)
	      (n-map n (lambda (i) (eq? (board-cell board i j) v))))))

;; past! and future! rewind or un-rewind the game:
(define-values (past! future!)
  (let ([set-past (lambda (x) (set! past-state x))]
	[set-future (lambda (x) (set! future-state x))])
    (values
     (lambda () (time-travel! (lambda () past-state) (lambda () future-state)
			      set-past set-future))
     (lambda ()
       (time-travel! (lambda () future-state) (lambda () past-state)
		     set-future set-past)))))

(define (time-travel! get-src get-dest set-src! set-dest!)
  ;; If it's a person versus a robot, and it's the person's turn, then
  ;; skip past the robot's turn. Cancel a running robot. If the game
  ;; is over because a person lost (by repeating a board position)
  ;; back up just once.
  (define skip-robot (and (or x-player o-player) 
			  ; Robot running?
			  (not (send canvas kill-robot))
			  ; Person lost?
			  (not (and loser
				    (eq? loser (if x-player o x))))))
  (set-dest! (cons (get-state) (get-dest)))
  (when skip-robot
    (set-dest! (cons (car (get-src)) (get-dest))))
  (let ([a ((if skip-robot cadr car) (get-src))])
    (set-src! ((if skip-robot cddr cdr) (get-src)))
    (set! board (car a))
    (set! moves (cadr a))
    (set! current-player (caddr a))
    (set! history (cadddr a))
    (set! winner (list-ref a 4))
    (set! loser (list-ref a 5)))
  (send canvas repaint)
  (send canvas refresh-controls))

;; Used to reset a game (via the "Setup..." dialog)
(define (init-game size)
  (set! n size)
  (set! board (new-board n))
  (set! history (new-history))
  (set! past-state null)
  (set! current-player x)
  (set! winner #f)
  (set! loser #f)
  (set! moves null)
  (set! future-state null)
  (set-canvas-size))

;; Restart for regular playing mode
(define (reset-game size)
  (init-game size)
  (send canvas repaint)
  (send clock-timer reset)
  (send canvas do-next-action))

;;; GUI ;;;

(define animate-step 2/10)
(define animate-delay 0.05)

(define red (make-object color% "RED"))
(define green (make-object color% "GREEN"))
(define black (make-object color% "BLACK"))
(define gray (make-object color% "GRAY"))
(define white (make-object color% "WHITE"))

(define the-font (make-object font% font-size 'decorative 'normal 'bold))
(define the-pen (send the-pen-list find-or-create-pen "GRAY" 1 'solid))

(define transparent-brush (send the-brush-list find-or-create-brush "WHITE" 'transparent))
(define solid-brush (send the-brush-list find-or-create-brush "GRAY" 'solid))

(define watch-cursor (make-object cursor% 'watch))

; The canvas (drawing/event area) class
(define pousse-canvas%
  (class canvas% args
    (inherit get-dc)
    (private
      [dc #f])
    (public
      [draw-box 
       ; Draw a string in a box
       (lambda (i j str)
	 (when str
	   (let-values ([(w h d s) (send dc get-text-extent str)])
	     (send dc draw-text str
		   (+ (* i cell-size) (/ (- cell-size w) 2))
		   (+ (* j cell-size) (/ (- cell-size h) 2))))))]
     [do-next-action
      (lambda ()
	;; See if anything interesting happened, then call refresh-controls (below)
	(check-loser)
	(check-winner)
	(set! history (extend-history board history))
	(refresh-controls))]
     [kill-robot (lambda () #f)] ;; installed by refresh-controls
     [refresh-controls
      ;; Update the GUI to reflect the current game state, and run
      ;; aa program player if it's time.
      (lambda ()
	(send history-text show-moves)
	(send clock show (not (or winner loser)))
	(if (or loser winner)
	    (begin
	      ;; Game over
	      (enable-arrows)
	      (repaint)
	      (send status set-label
		    (format "Game over: ~a ~a!" 
			    (if (equal? (or winner loser) x) "X" "O")
			    (if winner "wins" "loses")))
	      (send clock show #f))
	    ;; Check for automated player
	    (let* ([killed? 'not-yet]
		   [action void]
		   [lock (make-semaphore 1)]
		   [run-player-in-background
		    ;; Lots of messy stuff for calling the OS to run a player. The
		    ;; kill-robot method is installed for killing of the player process.
		    (lambda (player)
		      (let ([result #f]
			    [done (make-semaphore)]
			    [player-custodian (make-custodian)])
			(parameterize ([current-eventspace 
					(parameterize ([current-custodian player-custodian])
					  (make-eventspace))])
			  (queue-callback
			   (lambda ()
			     (let ([move (player 
					  ;; board size
					  n
					  ;; change move representation:
					  (map convert-move moves))])
			       (semaphore-wait lock)
			       (set! result move)
			       (set! killed? #f)
			       (semaphore-post lock)
			       (semaphore-post done)))))
			;; Install the process killer. Must return #f
			;;  if the robot is already done.
			(set! kill-robot (lambda ()
					   (semaphore-wait lock)
					   (begin0
					    (if (eq? killed? 'not-yet)
						(begin
						  (custodian-shutdown-all player-custodian)
						  (set! killed? #t)
						  (set! result #f)
						  (semaphore-post done))
						#f)
					    (semaphore-post lock))))
			
			;; Wait for a response (or kill)...
			(send canvas set-cursor watch-cursor)
			(semaphore-wait done)
			(custodian-shutdown-all player-custodian) ;; just in case
			(send canvas set-cursor #f)
			(when result
			  (unless (and (list? result)
				       (= 2 (length result))
				       (symbol? (car result))
				       (regexp-match "^[tblrTBLR]$" (symbol->string (car result)))
				       (number? (cadr result))
				       (<= 1 (cadr result) n))
			    (error 'play "unacceptable reply: ~a" result))
			  (let* ([d (char-upcase (string-ref (symbol->string (car result)) 0))]
				 [p (cadr result)])
			    (set! action
				  (lambda ()
				    (case d
				      [(#\T) (push-top! (sub1 p))]
				      [(#\B) (push-bottom! (sub1 p))]
				      [(#\L) (push-left! (sub1 p))]
				      [(#\R) (push-right! (sub1 p))])))))))]
		   [run-player
		    ;; A wrapper for monitoring the program player in a MrEd thread.
		    ;; Also handle the possibility that something goes wrong.
		    (lambda (robot who)
		      (send status set-label (format "~a: running ~a"
						     who 
						     (robot-name robot)))
		      (let ([s (make-semaphore)])
			(thread (lambda () 
				  (with-handlers ([void (lambda (exn)
							  (message-box
							   "Error"
							   (format
							    (string-append
							     "There was an error running the "
							     "program player for ~a.~n"
							     "We'll assume a default move, T1.~n"
							     "Here is the error message:~n~a")
							    who
							    (if (exn? exn)
								(exn-message exn)
								exn))
							   #f '(ok))
							  (set! action (lambda () (push-top! 0))))])
				    (run-player-in-background (robot-player robot)))
				  (semaphore-post s)))
			(set! playing? #t)
			(enable-arrows)
			;; Handle GUI events while we wait...
			(yield s)
			(set! playing? #f))
		      (unless killed?
			(send status set-label "")
			(action)
			(do-next-action)))])
	      ;; Run a program? Let a person play?
	      (cond
	       [(and (eq? current-player x) x-player) (run-player x-player "X")]
	       [(and (eq? current-player o) o-player) (run-player o-player "O")]
	       [else (send status set-label (format "~a's turn (click a number)"
						    (if (eq? current-player x) "X" "O")))
		     (enable-arrows)]))))])
    ;; Animation state
    (private
      [tracking-i 0] ;; for tracking mouse clicks
      [tracking-j 0]
      [tracking-highlight? #f]

      [pushpiece #f] ;; piece being pushed onto board, #f for none
      [pushrow -1]   ;; row being pushed, -1 for none
      [pushcol -1]   ;; col being pushed, -1 for none
      [pushdown? #t] ;; left or top push?
      [amt 0])       ;; displacement for push, between -1 and 1
						     
    (public
     [do-draw
      ;;;;;;;;;;;;;;;;;;;; Draw the Board ;;;;;;;;;;;;;;;;;;;;;;;
      (lambda ()
	(send dc clear)
	(send dc set-pen the-pen)
	(send dc set-font the-font)
	(send dc set-text-foreground gray)
	(n-times (+ n 2) 
		 (lambda (i)
		   (when (<= 1 i (add1 n))
		     (send dc draw-line cell-size (* i cell-size) 
			   (* (+ n 1) cell-size) (* i cell-size))
		     (send dc draw-line (* i cell-size) cell-size 
			   (* i cell-size) (* (+ n 1) cell-size)))
		   (when (<= 1 i n)
		     (let ([draw-box
			    (lambda (i j s)
			      (if (and tracking-highlight?
				       (= i tracking-i)
				       (= j tracking-j))
				  (begin
				    (send dc set-text-foreground white)
				    (send dc set-brush solid-brush)
				    (send dc draw-ellipse
					  (+ 2 (* i cell-size))
					  (+ 2 (* j cell-size))
					  (- cell-size 4)
					  (- cell-size 4))
				    (draw-box i j s)
				    (send dc set-brush transparent-brush)
				    (send dc set-text-foreground gray))
				  (draw-box i j s)))])
		       (draw-box i 0 (number->string i))
		       (draw-box 0 i (number->string i))
		       (draw-box i (add1 n) (number->string i))
		       (draw-box (add1 n) i (number->string i))))))
	(send dc set-text-foreground black)
	(n-times n
		 (lambda (i)
		   (n-times n (lambda (j) 
				(let ([v (board-cell board i j)])
				  (when (and (eq? winner v)
					     (in-straight? board v i j))
				    (send dc set-text-foreground green))
				  (when (eq? loser v) 
				    (send dc set-text-foreground red))
				  (draw-box (+ i 1
					       ;; Need to offset for animation?
					       (if (= j pushrow)
						   (if (let ([step (if pushdown? -1 1)])
							 (let loop ([i i])
							   (cond
							    [(or (= i -1) (= i n)) #t]
							    [(eq? (board-cell board i j) none) #f]
							    [else (loop (+ i step))])))
						       amt
						       0)
						   0))
					    (+ j 1
					       ;; Need to offset for animation?
					       (if (= i pushcol)
						   (if (let ([step (if pushdown? -1 1)])
							 (let loop ([j j])
							   (cond
							    [(or (= j -1) (= j n)) #t]
							    [(eq? (board-cell board i j) none) #f]
							    [else (loop (+ j step))])))
						       amt
						       0)
						   0))
					    (cond
					     [(eq? v none) #f]
					     [(eq? v x) "x"]
					     [(eq? v o) "o"]))
				  (when (or (eq? winner v) (eq? loser v))
				    (send dc set-text-foreground black)))))))
	(when pushpiece
	  (draw-box (if (>= pushrow 0)
			(if pushdown?
			    amt
			    (+ n 1 amt))
			(+ 1 pushcol))
		    (if (>= pushcol 0)
			(if pushdown?
			    amt
			    (+ n 1 amt))
			(+ 1 pushrow))
		    (cond
		     [(eq? pushpiece x) "x"]
		     [(eq? pushpiece o) "o"]))))])
    (private
      [bitmap #f])
    (public
      [repaint (lambda ()
		 (set! pushpiece #f)
		 (set! pushcol -1)
		 (set! pushrow -1)
		 (unless dc
		   (set! bitmap (make-object bitmap%
					     (* (+ n 2) cell-size)
					     (* (+ n 2) cell-size)))
		   (set! dc (make-object bitmap-dc% bitmap)))
		 (do-draw)
		 (on-paint))]

      [new-bitmap (lambda () 
		    (set! bitmap #f)
		    (set! dc #f))]

      [animate-push (lambda (side pos player)
		      (set! pushpiece player)
		      (set! pushrow (if (memq side '(right left))
					pos
					-1))
		      (set! pushcol (if (memq side '(top bottom))
					pos
					-1))
		      (set! pushdown? (memq side '(left top)))
		      (set! tracking-i (if (memq side '(top bottom))
					   (add1 pushcol)
					   (if pushdown? 0 (add1 n))))
		      (set! tracking-j (if (memq side '(right left))
					   (add1 pushrow)
					   (if pushdown? 0 (add1 n))))
		      (set! tracking-highlight? #t)
		      (let loop ([a 0])
			(set! amt ((if pushdown? + -) a))
			(do-draw)
			(send (get-dc) draw-bitmap bitmap 0 0)
			(sleep animate-delay)
			(if (= a 1)
			    (set! tracking-highlight? #f) ;; expects redraw triggered afterwards...
			    (loop (+ a animate-step)))))])

    (override
     [on-paint (lambda ()
		 (when bitmap
		   (send (get-dc) draw-bitmap bitmap 0 0)))]

     ;;;;;;;;;;;;;;;;;;;; Handle Clicks ;;;;;;;;;;;;;;;;;;;;;;;
     [on-event (lambda (e)
		 ;; There are a lot of reasons why you might not be allowed to click...
		 (cond
		  [(and (not winner) (not loser) 
			(or (send e button-down?)
			    (send e dragging?)
			    (send e button-up?))
			(not playing?)
			(not (if (eq? current-player x) x-player o-player)))
		   (let ([i (inexact->exact (floor (/ (send e get-x) cell-size)))]
			 [j (inexact->exact (floor (/ (send e get-y) cell-size)))])
		     (cond
		      [(send e button-down?)
		       (set! tracking-i i)
		       (set! tracking-j j)
		       (set! tracking-highlight? #t)
		       (repaint)]
		      [(send e moving?)
		       (let ([th? tracking-highlight?])
			 (set! tracking-highlight? (and
						    (= tracking-i i)
						    (= tracking-j j)))
			 (unless (eq? th? tracking-highlight?)
			   (repaint)))]
		      [(send e button-up?)
		       (if (and (= tracking-i i)
				(= tracking-j j))
			   (begin
			     (when (cond
				    [(and (= j 0) (<= 1 i n)) (push-top! (sub1 i)) #t]
				    [(and (= j (add1 n)) (<= 1 i n)) (push-bottom! (sub1 i)) #t]
				    [(and (= i 0) (<= 1 j n)) (push-left! (sub1 j)) #t]
				    [(and (= i (add1 n)) (<= 1 j n)) (push-right! (sub1 j)) #t]
				    [else #f]) ; not on a number
			       ; Check for win/loss, run automated player
			       (do-next-action)))
			   (when tracking-highlight?
			     (set! tracking-highlight? #f)
			     (repaint)))]))]
		  [else
		   (when tracking-highlight?
		     (set! tracking-highlight? #f)
		     (repaint))]))])

    (sequence (apply super-init args))))

;; Create the GUI interface with the above pieces ;;

; Instantiate the canvas in a frame (= a top-level window)
(define frame (make-object (class frame% args
			     (override
			      [can-close? (lambda () #t)]
			      ; Close the frame => exit the program
			      ; No fancy "Quit" menus here!
			      [on-close exit])
			     (sequence (apply super-init args)))
			   "Pousse"))

;; Panels are for GUI item layout (auto geometry management)
(define h-layout-panel (make-object horizontal-panel% frame))
(send h-layout-panel spacing 5)
(define game-panel (make-object vertical-panel% h-layout-panel))
(send game-panel stretchable-width #f)
(define history-panel (make-object vertical-panel% h-layout-panel))

;; Make the left and right arrow buttons
(define button-panel (make-object horizontal-panel% game-panel))
(send button-panel stretchable-height #f)
(define left-panel (make-object vertical-panel% button-panel))
(define past-button (make-object button% (make-object bitmap% (local-file "left.gif"))
				 button-panel (lambda (b e) (past!))))
(define future-button (make-object button% (make-object bitmap% (local-file "right.gif"))
				   button-panel (lambda (b e) (future!))))
(define right-panel (make-object vertical-panel% button-panel))
(define clock (make-object message% "00:00" right-panel))
(send left-panel min-width (send clock min-width)) ; layout trick
(send right-panel set-alignment 'right 'bottom)

(define clock-timer (make-object
		     (class timer% ()
			    (private [init 0][dinged 0])
			    (rename [super-start start])
			    (public [reset (lambda ()
					     (send clock set-label "00:00")
					     (set! dinged 0)
					     (set! init (current-seconds)))])
			    (override
			      [notify 
			       (lambda ()
				 (let* ([v (- (current-seconds) init)])
				   ;; Ring bell once at 30 seconds, twice at 60 seconds
				   (when (send clock is-shown?)
				     (when (>= v 30)
				       (unless (> dinged 0) (bell) (set! dinged 1))
				       (when (>= v 60)
					 (unless (> dinged 1) (bell) (bell) (set! dinged 2)))))
				   (let ([v (if (>= v 3600) ; more than an hour
						(quotient v 3600)
						v)])
				     (send clock set-label
					   (format "~a~a:~a~a"
						   (quotient v 600)
						   (modulo (quotient v 60) 10)
						   (quotient (modulo v 60) 10)
						   (modulo v 10))))))]
			      [start (lambda ()
				       (set! init (current-seconds))
				       (super-start 1000 #f))])
			    (sequence (super-init)))))
(send clock-timer start)

;; This procedure is called to enable/disable the arrow buttons
(define (enable-arrows)
  (let ([ok? (lambda (state)
	       (and ;; Something to rewind to?
		    (pair? state)
		    ;; Is it program vs. program?
		    (not (and x-player o-player))
		    ;; If we're playing a program, can we rewind twice?
		    (or (not (or x-player o-player))
			(pair? (cdr state)))))])
    (send past-button enable (ok? past-state))
    (send future-button enable (ok? future-state))))

;; Make the status line
(define status (make-object message% "Pousse" game-panel))
(send status stretchable-width #t)

;; Make the canvas for drawing the game board
(define canvas (make-object pousse-canvas% game-panel))

; The canvas should stretch/shrink to fit the board
(define (set-canvas-size)
  (send canvas min-client-width (* (+ n 2) cell-size))
  (send canvas min-client-height (* (+ n 2) cell-size))
  (send canvas new-bitmap))
(set-canvas-size)
(send canvas focus)

; Make a text window for showing the board history to the right.
; Uses the built-in text editor in MrEd, adding a show-moves
; method to refresh the window after a move or rewind.
(make-object message% "Moves" history-panel)
(define history-canvas (make-object editor-canvas% history-panel #f '(no-hscroll)))
(define history-text (make-object (class text% ()
				     (inherit begin-edit-sequence end-edit-sequence
					      erase insert delete change-style hide-caret
					      set-position line-start-position line-end-position)
				     ; Ignore all user actions:
				     (override [on-char void] [on-event void])
				     (public
				       [show-moves
					(lambda ()
					  (begin-edit-sequence)
					  (erase)
					  (change-style (make-object style-delta% 'change-normal))
					  (change-style (make-object style-delta% 'change-family 'swiss))
					  (for-each
					   (lambda (m) (insert m) (insert #\newline))
					   (if (null? future-state)
					       moves
					       (cadr (list-ref future-state (sub1 (length future-state))))))
					  (delete) ; delete that last newline
					  (if (null? moves)
					      (set-position 0)
					      (let* ([past-move (sub1 (length moves))]
						     [start (line-start-position past-move)])
						(change-style (send 
							       (make-object style-delta% 'change-bold)
							       set-delta-foreground "BLUE")
							      start
							      (line-end-position past-move))
						(set-position start)))
					  (end-edit-sequence))])
				     (sequence (super-init) (hide-caret #t)))))
(send history-canvas set-editor history-text)

;; Setup and miscellaneous buttons at the bottom

(define misc-panel (make-object horizontal-panel% frame))
(send misc-panel stretchable-height #f)

(make-object button% "Help" misc-panel (lambda (b e) (help #f)))
(make-object button% "Setup..." misc-panel (lambda (b e) (setup)))
(make-object vertical-pane% misc-panel) ; spacer

;; Makes the setup dialog. Options dialogs are always a pain.
(define (make-setup-dialog)
  (define d (make-object dialog% "Pousse Setup" frame 300 200))
  (define config-panel (make-object vertical-panel% d))
  (define game-panel (make-object vertical-panel% config-panel))
  (define (make-player name)
    (letrec ([p (make-object vertical-panel% game-panel '(border))]
	     [m (make-object choice% (format "~a Player:" name) '("Person" "Program") p
			     (lambda (m e) 
			       (send l enable (positive? (send m get-selection)))
			       (enable-ok)))]
	     [l (make-object list-box% "Programs:" (map robot-name robots) p 
			     (lambda (l e) (enable-ok)))])
      (send l enable #f)
      (values m l)))
  (define board-size (make-object slider% "Board Size:" 4 20 game-panel void n))
  (define-values (x-kind x-robot) (make-player "X"))
  (define-values (o-kind o-robot) (make-player "O"))

  (define button-panel (make-object horizontal-pane% d))
  (define load-button (make-object button% "Add a Player Program..." button-panel
				   (lambda (b e)
				     (with-handlers ([void
						      (lambda (exn)
							(message-box "Error"
								     (format "There was an error:~n~a"
									     (if (exn? exn)
										 (exn-message exn)
										 exn))))])
				       (let ([f (get-file "Get Player Program" d)])
					 (when f
					   (let ([player (parameterize ([current-namespace (make-namespace 'mred)])
							   (load f))])
					     (let ([name (get-text-from-user "Player Name"
									     "Player Program Name:"
									     d
									     (let-values ([(base name dir?)
											   (split-path f)])
									       name))])
					       (when name
						 (set! robots (append robots
								      (list (make-robot name player))))
						 (send x-robot set (map robot-name robots))
						 (send o-robot set (map robot-name robots)))))))))))
  (define spacer (make-object vertical-pane% button-panel))
  (define cancel-button (make-object button% "Cancel" button-panel 
				     (lambda (b e) (send d show #f))))
  (define ok-button (make-object button% "Start" button-panel 
				 ;; Callback procedure invoked when the button is hit:
				 (lambda (b e) 
				   (send d show #f)
				   (send canvas kill-robot) ; in case a robot was running
				   (queue-callback
				    (lambda ()
				      (let ([get-robot
					     (lambda (l)
					       (list-ref robots
							 (send l get-selection)))]
					    [size (send board-size get-value)])
					(if (zero? (send x-kind get-selection))
					    (set! x-player #f) ; person player
					    (set! x-player (get-robot x-robot)))
					(if (zero? (send o-kind get-selection))
					    (set! o-player #f) ; person player
					    (set! o-player (get-robot o-robot)))
					(reset-game size)))))
				 '(border)))

  (define enable-ok (lambda () (send ok-button enable (and
						       (or (zero? (send x-kind get-selection))
							   (send x-robot get-selection))
						       (or (zero? (send o-kind get-selection))
							   (send o-robot get-selection))))))
  
  (send button-panel set-alignment 'right 'center)
  (send button-panel stretchable-height #f)

  d)

(define setup-dialog (make-setup-dialog))
(define setup-once? #f)

(define (setup) 
  (unless setup-once?
    (send setup-dialog center)
    (set! setup-once? #t))
  (send setup-dialog show #t))

;; Help or source code window:
(define (help code?)
  (define f (make-object frame% 
			 (if code? "Pousse GUI Source Code" "Pousse Help")
			 #f 580 300))
  (define p (if code?
		(void)
		(make-object choice% #f '("Rules" "Using the GUI" "Writing Players")
			     f
			     (lambda (p ev)
			       (send e lock #f)
			       (send e load-file
				     (local-file (case (send p get-selection)
						   [(0) "doc.txt"]
						   [(1) "help.txt"]
						   [(2) "robots.txt"])))
			       (send e lock #t)))))
  (define c (make-object editor-canvas% f))
  (define e (make-object text%))
  (send c set-editor e)
  (send (send (send e get-style-list) 
	      find-named-style 
	      "Standard")
	set-delta
	(make-object style-delta% 'change-family 'modern))
  (send e load-file (local-file "doc.txt"))
  (send e lock #t)
  (send f show #t))

; Draw initial board
(send canvas repaint)

; Arrow buttons initially enabled?
(enable-arrows)

; Don't allowing resizing the frame. Everything fits just right.
(send frame stretchable-width #f)
(send frame stretchable-height #f)

; Show the frame - we're off and running, now!
(send frame show #t)

; Take the first action.
(send canvas do-next-action)

; Loop forever (handling events). Frame's on-close callback method will exit.
(yield (make-semaphore 0))
