773 lines
41 KiB
Racket
773 lines
41 KiB
Racket
(module pousse racket/base
|
|
(require "utils.rkt"
|
|
"board.rkt"
|
|
"board-size.rkt"
|
|
"../show-scribbling.rkt"
|
|
racket/class
|
|
racket/unit
|
|
mred
|
|
(prefix-in robot: "robot.rkt"))
|
|
|
|
(provide game@)
|
|
|
|
(define game@
|
|
(unit
|
|
(import)
|
|
(export)
|
|
|
|
;; 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)"
|
|
robot:robot)))
|
|
|
|
(define (local-file f)
|
|
(build-path (collection-path "games" "pousse") f))
|
|
|
|
;;; Game State ;;;
|
|
|
|
(define board (new-board (current-board-size)))
|
|
(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)
|
|
(let ([n (current-board-size)])
|
|
(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)
|
|
(current-board-size size)
|
|
(set! board (new-board size))
|
|
(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%
|
|
(init-rest args)
|
|
(inherit get-dc)
|
|
(define dc #f)
|
|
(define do-kill-robot (lambda () #f)) ; installed by refresh-controls
|
|
(public*
|
|
[kill-robot (lambda () (do-kill-robot))]
|
|
[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))]
|
|
[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
|
|
(current-board-size)
|
|
;; 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! do-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) (current-board-size)))
|
|
(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 GRacket 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
|
|
(define tracking-i 0) ;; for tracking mouse clicks
|
|
(define tracking-j 0)
|
|
(define tracking-highlight? #f)
|
|
|
|
(define pushpiece #f) ;; piece being pushed onto board, #f for none
|
|
(define pushrow -1) ;; row being pushed, -1 for none
|
|
(define pushcol -1) ;; col being pushed, -1 for none
|
|
(define pushdown? #t) ;; left or top push?
|
|
(define amt 0) ;; displacement for push, between -1 and 1
|
|
|
|
(public*
|
|
[do-draw
|
|
;;;;;;;;;;;;;;;;;;;; Draw the Board ;;;;;;;;;;;;;;;;;;;;;;;
|
|
(lambda ()
|
|
(let ([n (current-board-size)])
|
|
(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"])))))])
|
|
(define bitmap #f)
|
|
(public*
|
|
[repaint (lambda ()
|
|
(set! pushpiece #f)
|
|
(set! pushcol -1)
|
|
(set! pushrow -1)
|
|
(unless dc
|
|
(set! bitmap (make-object bitmap%
|
|
(* (+ (current-board-size) 2) cell-size)
|
|
(* (+ (current-board-size) 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)
|
|
(let ([n (current-board-size)])
|
|
(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))
|
|
(let ([n (current-board-size)])
|
|
(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))]))])
|
|
(apply super-make-object args)))
|
|
|
|
;; Create the GUI interface with the above pieces ;;
|
|
|
|
; Instantiate the canvas in a frame (= a top-level window)
|
|
(define frame (new (class frame%
|
|
(augment*
|
|
[can-close? (lambda () (inner #t can-close?))]
|
|
;; Close the frame => exit the program
|
|
;; No fancy "Quit" menus here!
|
|
[on-close (lambda () (inner (void) on-close) (exit))])
|
|
(super-new))
|
|
[label "Pousse"] [style '(metal no-resize-border)]))
|
|
|
|
;; 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%
|
|
(define init 0)
|
|
(define dinged 0)
|
|
(rename-super [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))])
|
|
(super-make-object))))
|
|
(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)
|
|
(let ([n (current-board-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 GRacket, 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 (lambda (e) (void))] [on-event (lambda (e) (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))])
|
|
(super-make-object)
|
|
(hide-caret #t))))
|
|
(send history-canvas set-editor history-text)
|
|
(send history-canvas min-client-width 30)
|
|
|
|
;; 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)))
|
|
(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:" 3 20 game-panel void (current-board-size)))
|
|
(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 (dynamic-require f 'robot)])
|
|
(let ([name (get-text-from-user "Player Name"
|
|
"Player Program Name:"
|
|
d
|
|
(let-values ([(base name dir?)
|
|
(split-path f)])
|
|
(path->string 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
|
|
(show-scribbling
|
|
'(lib "games/scribblings/games.scrbl")
|
|
"pousse"))
|
|
|
|
|
|
; 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)))))
|