520 lines
16 KiB
Racket
520 lines
16 KiB
Racket
(module gui mzscheme
|
|
(require games/gl-board-game/gl-board
|
|
mzlib/class
|
|
mred
|
|
mzlib/file
|
|
sgl/gl-vectors
|
|
sgl
|
|
mzlib/unitsig
|
|
"sig.ss")
|
|
|
|
(provide gui-unit)
|
|
|
|
(define gui-unit
|
|
(unit/sig ()
|
|
(import config^ model^ restart^ heuristics^ explore^)
|
|
|
|
;; Configuration ------------------------------
|
|
|
|
(define JR? (= BOARD-SIZE 3))
|
|
|
|
(define PIECE-SIZES (if JR?
|
|
'(0.4 0.6 0.75)
|
|
'(0.3 0.45 0.65 0.8)))
|
|
|
|
;; Auto-play:
|
|
(define smart? (get-preference 'gobblet:auto-play-smart? (lambda () #f)))
|
|
(define timeout (let ([v (get-preference 'gobblet:auto-play-timeout (lambda () #f))])
|
|
(if (and (number? v) (real? v))
|
|
v
|
|
3.0)))
|
|
|
|
;; GUI ------------------------------
|
|
|
|
(define yellow (gl-float-vector 1.0 1.0 0.0 1.0))
|
|
(define red (gl-float-vector 1.0 0.0 0.0 1.0))
|
|
(define light-blue (gl-float-vector 0.5 0.5 1.0 1.0))
|
|
(define dark-blue (gl-float-vector 0.0 0.0 1.0 1.0))
|
|
|
|
;; A gui-piece is
|
|
;; (make-gui-piece piece gl-description num num)
|
|
;; where the nums might be < 0 or > BOARD-SIZE
|
|
(define-struct gui-piece (piece dl i j))
|
|
|
|
;; State ------------------------------
|
|
|
|
;; The state of the game, as reflected in the GUI:
|
|
(define board empty-board)
|
|
(define turn 'red)
|
|
|
|
;; past, future : (list-of (cons thunk thunk))
|
|
;; where first thunk is do and second is undo
|
|
(define past null)
|
|
(define future null)
|
|
|
|
;; When `playing?' is true, double-check reset request
|
|
(define playing? #f)
|
|
|
|
;; GUI Move ------------------------------
|
|
|
|
;; This function is called when the user tries to move `gp'
|
|
;; to location `to'
|
|
(define (gui-move gp to)
|
|
(when (gui-piece? gp)
|
|
;; Get dest and source locations:
|
|
(let* ((to-i (inexact->exact (floor (gl-vector-ref to 0))))
|
|
(to-j (inexact->exact (floor (gl-vector-ref to 1))))
|
|
(from-i (gui-piece-i gp))
|
|
(from-j (gui-piece-j gp))
|
|
(on-board? (<= 0 from-i (sub1 BOARD-SIZE))))
|
|
;; Only move if the requent lands on the board:
|
|
(when (and (<= 0 to-i (sub1 BOARD-SIZE))
|
|
(<= 0 to-j (sub1 BOARD-SIZE)))
|
|
;; Only move if the model says that it's ok:
|
|
(move board (gui-piece-piece gp)
|
|
(and on-board? from-i) (and on-board? from-j)
|
|
to-i to-j
|
|
(lambda (new-board)
|
|
(install-board new-board gp to-i to-j))
|
|
(lambda ()
|
|
;; Move not allowed by model
|
|
(void)))))))
|
|
|
|
(define (install-board new-board gp to-i to-j)
|
|
;; Move allowed by the model. Create a thunk to
|
|
;; execute this move and a thunk to undo this
|
|
;; move:
|
|
(let ([new-gp (make-gui-piece (gui-piece-piece gp) (gui-piece-dl gp)
|
|
to-i to-j)]
|
|
[old-board board]
|
|
[old-turn turn])
|
|
(action!
|
|
;; Forward thunk:
|
|
(lambda ()
|
|
(set! board new-board)
|
|
(send gui-board remove-piece gp)
|
|
(gui-add-piece new-gp)
|
|
(let ([r? (winner? new-board 'red)]
|
|
[y? (winner? new-board 'yellow)])
|
|
(cond
|
|
[(and r? y?) (set-winner! (case old-turn
|
|
[(red) "Yellow"]
|
|
[(yellow) "Red"]))]
|
|
[r? (set-winner! "Red")]
|
|
[y? (set-winner! "Yellow")]
|
|
[else (set-turn! (other old-turn))])))
|
|
;; Rewind thunk:
|
|
(lambda ()
|
|
(set! board old-board)
|
|
(send gui-board remove-piece new-gp)
|
|
(gui-add-piece gp)
|
|
(set-turn! old-turn)))))
|
|
|
|
;; GUI Board and Pieces ------------------------------
|
|
|
|
(define f (new (class frame%
|
|
(define/augment (on-close)
|
|
(inner (void) on-close)
|
|
(exit))
|
|
(super-new))
|
|
(label "Gobblet") (width 800) (height 600)))
|
|
(define gui-board
|
|
(new gl-board% (parent f) (who "Gobblet")
|
|
(min-x (if JR? (- 1 BOARD-SIZE) -1))
|
|
(max-x (if JR? (sub1 (* 2 BOARD-SIZE)) (add1 BOARD-SIZE)))
|
|
(min-y 0)
|
|
(max-y BOARD-SIZE)
|
|
(lift 1.2)
|
|
(move gui-move)
|
|
(theta 30)))
|
|
|
|
(define q
|
|
(send gui-board with-gl-context
|
|
(lambda () (gl-new-quadric))))
|
|
|
|
;; Space description:
|
|
(define space-dl
|
|
(send gui-board with-gl-context
|
|
(lambda ()
|
|
(let ((list-id (gl-gen-lists 1)))
|
|
(gl-quadric-draw-style q 'fill)
|
|
(gl-quadric-normals q 'smooth)
|
|
(gl-new-list list-id 'compile)
|
|
(gl-material-v 'front 'ambient-and-diffuse dark-blue)
|
|
(gl-begin 'polygon)
|
|
(gl-vertex 0.0 0.0 -0.02)
|
|
(gl-vertex 1.0 0.0 -0.02)
|
|
(gl-vertex 1.0 1.0 -0.02)
|
|
(gl-vertex 0.0 1.0 -0.02)
|
|
(gl-end)
|
|
(gl-material-v 'front 'ambient-and-diffuse light-blue)
|
|
(gl-push-matrix)
|
|
(gl-translate 0.5 0.5 -0.01)
|
|
(gl-disk q 0.0 .40 25 1)
|
|
(gl-pop-matrix)
|
|
(gl-end-list)
|
|
list-id))))
|
|
|
|
;; Install spaces on board:
|
|
(fold-board (lambda (i j v)
|
|
(send gui-board add-space
|
|
(lambda ()
|
|
(gl-push-matrix)
|
|
(gl-translate i j 0.01)
|
|
(gl-call-list space-dl)
|
|
(gl-pop-matrix))
|
|
(cons i j)))
|
|
void)
|
|
|
|
;; Piece description-maker:
|
|
(define (make-piece-dl color scale)
|
|
(send gui-board with-gl-context
|
|
(lambda ()
|
|
(let ((list-id (gl-gen-lists 1)))
|
|
(gl-quadric-draw-style q 'fill)
|
|
(gl-quadric-normals q 'smooth)
|
|
(gl-new-list list-id 'compile)
|
|
(gl-material-v 'front 'ambient-and-diffuse color)
|
|
(gl-cylinder q (/ scale 2) (/ scale 2) (* 1.5 scale) 25 1)
|
|
(gl-push-matrix)
|
|
(gl-translate 0.0 0.0 (* 1.5 scale))
|
|
(gl-disk q 0.0 (/ scale 2) 25 1)
|
|
(gl-pop-matrix)
|
|
(gl-end-list)
|
|
list-id))))
|
|
|
|
;; Red piece descriptions:
|
|
(define red-dls (map (lambda (size)
|
|
(make-piece-dl red size))
|
|
PIECE-SIZES))
|
|
|
|
;; Yellow piece descriptions:
|
|
(define yellow-dls (map (lambda (size)
|
|
(make-piece-dl yellow size))
|
|
PIECE-SIZES))
|
|
|
|
;; GUI piece records, with each piece at its initial place:
|
|
(define gui-pieces
|
|
(let loop ([red-dls red-dls][yellow-dls yellow-dls]
|
|
[red-pieces red-pieces][yellow-pieces yellow-pieces]
|
|
[sizes PIECE-SIZES][z 0])
|
|
(if (null? red-dls)
|
|
null
|
|
(append
|
|
(let ([sz (car sizes)])
|
|
(let loop ([dw (if JR?
|
|
(- BOARD-SIZE 2)
|
|
(- BOARD-SIZE 1.5))])
|
|
(if (negative? dw)
|
|
null
|
|
(list*
|
|
(make-gui-piece (car red-pieces) (car red-dls)
|
|
(if JR? (- dw BOARD-SIZE -1) -1)
|
|
(if JR? z dw))
|
|
(make-gui-piece (car yellow-pieces) (car yellow-dls)
|
|
(if JR? (+ BOARD-SIZE dw) BOARD-SIZE)
|
|
(if JR? z dw))
|
|
(loop (sub1 dw))))))
|
|
(loop (cdr red-dls) (cdr yellow-dls)
|
|
(cdr red-pieces) (cdr yellow-pieces)
|
|
(cdr sizes) (+ z 1))))))
|
|
|
|
;; Places a gui-piece at its location on the board:
|
|
(define (gui-add-piece gp)
|
|
(send gui-board add-piece
|
|
(+ (gui-piece-i gp) 0.5) (+ (gui-piece-j gp) 0.5) 0
|
|
(lambda (for-shadow?)
|
|
(when for-shadow?
|
|
(gl-disable 'lighting))
|
|
(gl-call-list (gui-piece-dl gp))
|
|
(when for-shadow?
|
|
(gl-enable 'lighting)))
|
|
gp))
|
|
|
|
;; Extra GUI controls ----------------------------------------
|
|
|
|
;; Define a 3-element pane that makes the left and right parts
|
|
;; the same width (so that the middle part is centered):
|
|
(define controls (new (class horizontal-pane%
|
|
;; Override place-children for the 3-child case,
|
|
;; make first and third the same width
|
|
(define/override (place-children l w h)
|
|
(let ([r (super place-children l w h)])
|
|
(if (= (length r) 3)
|
|
(let ([a (list-ref r 0)]
|
|
[b (list-ref r 1)]
|
|
[c (list-ref r 2)])
|
|
(let* ([aw (list-ref a 2)]
|
|
[cw (list-ref c 2)]
|
|
[naw (quotient (+ aw cw) 2)])
|
|
(list
|
|
(list (car a) (cadr a)
|
|
naw (cadddr a))
|
|
(list (+ (car b) (- naw aw)) (cadr b)
|
|
(caddr b) (cadddr b))
|
|
(list (+ naw (caddr b)) (cadr c)
|
|
(- (+ cw aw) naw) (cadddr c)))))
|
|
r)))
|
|
(super-new))
|
|
(parent f)
|
|
(stretchable-height #f)))
|
|
|
|
;; Status message:
|
|
(define msg
|
|
(new message% (label "") (parent controls) (stretchable-width #t)))
|
|
|
|
;; Forward & Reverse buttons
|
|
(define controls-middle (new horizontal-pane%
|
|
(parent controls)
|
|
(stretchable-height #f)
|
|
(stretchable-width #f)))
|
|
(define arrows? (let ([f (make-object font% 12 'system)])
|
|
(and (send f screen-glyph-exists? #\u25C0 #t)
|
|
(send f screen-glyph-exists? #\u25B6 #t))))
|
|
(define backward-button
|
|
(new button% (label (if arrows? " \u25C0 " " < ")) (parent controls-middle)
|
|
(callback (lambda (b e) (backward!)))))
|
|
(define forward-button
|
|
(new button% (label (if arrows? " \u25B6 " " > ")) (parent controls-middle)
|
|
(callback (lambda (b e) (forward!)))))
|
|
(define (enable-buttons)
|
|
(send backward-button enable (pair? past))
|
|
(send forward-button enable (pair? future)))
|
|
|
|
;; Reset & Help buttons:
|
|
(define controls-right (new horizontal-pane%
|
|
(parent controls)
|
|
(stretchable-height #f)
|
|
(alignment '(right center))))
|
|
(new button% (label "Reset") (parent controls-right)
|
|
(callback (lambda (b e)
|
|
(when (or (not playing?)
|
|
(equal? 1 (message-box/custom
|
|
"Warning"
|
|
"Stop game in progress and reset?"
|
|
"Reset"
|
|
"Cancel"
|
|
#f
|
|
f
|
|
'(default=1 caution))))
|
|
(reset!)))))
|
|
(new button% (label (if (= BOARD-SIZE 3) "4x4 Game" "3x3 Game"))
|
|
(parent controls-right)
|
|
(callback (lambda (b e)
|
|
(new-game (if (= BOARD-SIZE 3) 4 3)))))
|
|
(new button% (label "Help") (parent controls-right)
|
|
(callback (lambda (b e)
|
|
(show-gobblet-help))))
|
|
|
|
(define bottom (new horizontal-pane%
|
|
(parent f)
|
|
(stretchable-height #f)
|
|
(alignment '(left center))))
|
|
|
|
(define auto-red (new check-box%
|
|
(label "Auto-Play Red")
|
|
(parent bottom)
|
|
(callback (lambda (c e)
|
|
(when (eq? turn 'red)
|
|
(check-auto-play))))))
|
|
(define auto-yellow (new check-box%
|
|
(label "Auto-Play Yellow")
|
|
(parent bottom)
|
|
(callback (lambda (c e)
|
|
(when (eq? turn 'yellow)
|
|
(check-auto-play))))))
|
|
|
|
(define auto-play-msg (new message%
|
|
(label "") (parent bottom) (stretchable-width #t)))
|
|
|
|
(new button%
|
|
[label "Auto-Play Options..."]
|
|
[parent bottom]
|
|
[callback
|
|
(lambda (b e)
|
|
(letrec ([d (new dialog%
|
|
[label "Auto-Play Options"]
|
|
[alignment '(left center)]
|
|
[parent f])]
|
|
[mode (new choice%
|
|
[label "Mode:"]
|
|
[parent d]
|
|
[choices '("Smart - plays Red perfectly in 3x3 game"
|
|
"Ok - tries to plan for next move")]
|
|
[callback void])]
|
|
[timeout-field (new text-field%
|
|
[label "Auto-play Think Time (seconds):"]
|
|
[parent d]
|
|
[init-value (number->string timeout)]
|
|
[callback
|
|
(lambda (t e)
|
|
(let* ([e (send t get-editor)]
|
|
[val (string->number (send e get-text))]
|
|
[bad? (or (not val)
|
|
(not (real? val))
|
|
(val . < . 0))])
|
|
(send ok-button enable (not bad?))
|
|
(send e change-style
|
|
(send (make-object style-delta%)
|
|
set-delta-background
|
|
(if bad? "yellow" "white"))
|
|
0 (send e last-position))))])]
|
|
[button-panel (new horizontal-pane%
|
|
[parent d]
|
|
[alignment '(right center)]
|
|
[stretchable-height #f])]
|
|
[ok-button
|
|
(new button%
|
|
[label "Ok"] [parent button-panel] [style '(border)]
|
|
[callback (lambda (b e)
|
|
(set! smart? (= 0 (send mode get-selection)))
|
|
(set! timeout (string->number
|
|
(send timeout-field get-value)))
|
|
(put-preferences '(gobblet:auto-play-smart?)
|
|
(list smart?)
|
|
void)
|
|
(send d show #f))])])
|
|
(new button%
|
|
[label "Cancel"] [parent button-panel]
|
|
[callback (lambda (b e) (send d show #f))])
|
|
(send mode set-selection (if smart? 0 1))
|
|
(send d center)
|
|
(send d show #t)))])
|
|
|
|
(new grow-box-spacer-pane% [parent bottom])
|
|
|
|
;; Extra controls ----------------------------------------
|
|
|
|
(define (action! forward backward)
|
|
(set! playing? #t)
|
|
(set! future null)
|
|
(set! past (cons (cons forward backward) past))
|
|
(forward)
|
|
(check-auto-play)
|
|
(enable-buttons))
|
|
|
|
(define (backward!)
|
|
(let ([fb (car past)])
|
|
(set! past (cdr past))
|
|
(set! future (cons fb future))
|
|
((cdr fb))
|
|
(enable-buttons)
|
|
(send gui-board refresh)))
|
|
|
|
(define (forward!)
|
|
(let ([fb (car future)])
|
|
(set! future (cdr future))
|
|
(set! past (cons fb past))
|
|
((car fb))
|
|
(enable-buttons)
|
|
(send gui-board refresh)
|
|
(check-auto-play)))
|
|
|
|
(define (reset!)
|
|
(for-each (lambda (p)
|
|
(send gui-board remove-piece p))
|
|
(send gui-board get-pieces))
|
|
(init-game!)
|
|
(send gui-board refresh)
|
|
(check-auto-play))
|
|
|
|
(define (set-turn! c)
|
|
(set! turn c)
|
|
(send msg set-label (format "~a's turn" (if (eq? turn 'red) "Red" "Yellow")))
|
|
(enable-for-turn! c)
|
|
(check-auto-play))
|
|
|
|
(define (enable-for-turn! who)
|
|
(for-each (lambda (p)
|
|
(send gui-board enable-piece p (eq? who (piece-color (gui-piece-piece p)))))
|
|
(send gui-board get-pieces)))
|
|
|
|
(define (set-winner! who)
|
|
(set! playing? #f)
|
|
(set! turn #f)
|
|
(send msg set-label (format "~a wins!" who))
|
|
(enable-for-turn! #f)
|
|
(check-auto-play))
|
|
|
|
(define (init-game!)
|
|
(set! board empty-board)
|
|
(set! past null)
|
|
(set! future null)
|
|
(set! playing? #f)
|
|
(enable-buttons)
|
|
(for-each gui-add-piece gui-pieces)
|
|
(set-turn! 'red))
|
|
|
|
;; Auto-play ----------------------------------------
|
|
|
|
(define auto-play-key #f)
|
|
(define auto-play-custodian #f)
|
|
|
|
(define (check-auto-play)
|
|
(when auto-play-custodian
|
|
(set! auto-play-key (gensym))
|
|
(custodian-shutdown-all auto-play-custodian)
|
|
(set! auto-play-custodian #f)
|
|
(send auto-play-msg set-label "")
|
|
(enable-for-turn! turn))
|
|
(when (and (null? future)
|
|
turn
|
|
(send (if (eq? turn 'red) auto-red auto-yellow) get-value))
|
|
(let ([key (gensym)]
|
|
[board board]
|
|
[turn turn])
|
|
(enable-for-turn! #f)
|
|
(set! auto-play-key key)
|
|
(set! auto-play-custodian (make-custodian))
|
|
(parameterize ([current-custodian auto-play-custodian])
|
|
(thread
|
|
(lambda ()
|
|
(let ([move (auto-play board turn)])
|
|
(queue-callback
|
|
(lambda ()
|
|
(when (eq? auto-play-key key)
|
|
(auto-move board turn move))))))))
|
|
(send auto-play-msg set-label
|
|
(format " Auto-play thinking for ~a..."
|
|
(if (eq? turn 'red) "Red" "Yellow"))))))
|
|
|
|
|
|
(define (auto-play board turn)
|
|
(let ([search (make-search (if (= BOARD-SIZE 3)
|
|
make-3x3-rate-board
|
|
make-4x4-rate-board)
|
|
(if (= BOARD-SIZE 3)
|
|
(if smart?
|
|
make-3x3-canned-moves
|
|
make-3x3-no-canned-moves)
|
|
make-4x4-canned-moves))])
|
|
(search timeout ; timeout
|
|
2 ; lookahead steps (non-exhaustive)
|
|
3 ; single-step lookahead (exhaustive)
|
|
turn board null)))
|
|
|
|
(define (auto-move board turn move)
|
|
(send auto-play-msg set-label "")
|
|
(let ([gp (let ([piece (list-ref move 0)]
|
|
[from-i (list-ref move 1)]
|
|
[from-j (list-ref move 2)])
|
|
(ormap (lambda (gp)
|
|
(and (eq? piece (gui-piece-piece gp))
|
|
(if from-i
|
|
(and (= from-i (gui-piece-i gp))
|
|
(= from-j (gui-piece-j gp)))
|
|
(not (<= 0 (gui-piece-i gp) (sub1 BOARD-SIZE))))
|
|
gp))
|
|
(send gui-board get-pieces)))]
|
|
[to-i (list-ref move 3)]
|
|
[to-j (list-ref move 4)])
|
|
(let ([new-board (apply-play board move)])
|
|
(install-board new-board gp to-i to-j))
|
|
(send gui-board refresh)))
|
|
|
|
;; Go ----------------------------------------
|
|
|
|
(init-game!)
|
|
|
|
(send f show #t))))
|