simpler API for door games
svn: r4789
This commit is contained in:
Matthew Flatt
parent
bd1aaac077
commit
7e08f36804
|
|
@ -10,7 +10,8 @@
|
|||
|
||||
(provide door-game%
|
||||
player-data
|
||||
thing-data)
|
||||
thing-data
|
||||
bitmap->drawer)
|
||||
|
||||
(define-struct door-game (board))
|
||||
|
||||
|
|
@ -21,6 +22,25 @@
|
|||
(define-struct wall (drawer))
|
||||
(define-struct player (data drawer i j))
|
||||
(define-struct thing (data drawer i j heads-up?))
|
||||
|
||||
(define (bitmap->drawer bm game)
|
||||
(let*-values ([(bm mask)
|
||||
(cond
|
||||
[(bm . is-a? . bitmap%)
|
||||
(values bm (send bm get-loaded-mask))]
|
||||
[(bm . is-a? . image-snip%)
|
||||
(values (send bm get-bitmap)
|
||||
(send bm get-bitmap-mask))]
|
||||
[else (raise-type-error
|
||||
'bitmap->drawer
|
||||
"bitmap% or image-snip% object"
|
||||
bm)])]
|
||||
[(dl) (bitmap->gl-list bm
|
||||
#:with-gl (lambda (f)
|
||||
(send game with-gl-context f))
|
||||
#:mask mask)])
|
||||
(lambda ()
|
||||
(gl-call-list dl))))
|
||||
|
||||
(define door-game%
|
||||
(class object%
|
||||
|
|
@ -36,10 +56,10 @@
|
|||
(make-room #f null null))))))
|
||||
|
||||
(define walls (build-vector
|
||||
(add1 (* 2 x-rooms))
|
||||
(add1 (* 2 (add1 x-rooms)))
|
||||
(lambda (i)
|
||||
(build-vector
|
||||
(add1 (* 2 y-rooms))
|
||||
(add1 (* 2 (add1 y-rooms)))
|
||||
(lambda (j)
|
||||
(make-wall #f))))))
|
||||
|
||||
|
|
@ -155,85 +175,109 @@
|
|||
(define/public (with-gl-context f)
|
||||
(send board with-gl-context f))
|
||||
|
||||
(define/public (set-wall ri rj dir wall? door-image)
|
||||
(case dir
|
||||
[(n s e w) 'ok]
|
||||
[else (raise-type-error
|
||||
'set-wall
|
||||
"'n, 's, 'e, or 'w"
|
||||
dir)])
|
||||
(let* ([i (+ (* 2 ri) (case dir
|
||||
[(w) 0]
|
||||
[(n s) 1]
|
||||
[(e) 2]))]
|
||||
[j (+ (* 2 rj) (case dir
|
||||
[(n) 2]
|
||||
[(w e) 1]
|
||||
[(s) 0]))]
|
||||
[wall (vector-ref (vector-ref walls i) j)]
|
||||
[drawer (if wall?
|
||||
(make-wall-draw ri rj dir door-image)
|
||||
void)])
|
||||
(if (wall-drawer wall)
|
||||
(send board set-space-draw wall drawer)
|
||||
(send board add-space drawer wall))
|
||||
(set-wall-drawer! wall drawer))
|
||||
(send board refresh))
|
||||
(define/public (set-wall-image loc wall? door-image)
|
||||
(let-values ([(ri rj dir)
|
||||
(cond
|
||||
[(and (list? loc)
|
||||
(= 3 (length loc)))
|
||||
(apply values loc)]
|
||||
[(and (list? loc)
|
||||
(= 2 (length loc)))
|
||||
(let ([i (car loc)]
|
||||
[j (cadr loc)])
|
||||
(if (= 1 (+ (if (integer? i) 1 0)
|
||||
(if (integer? j) 1 0)))
|
||||
(values (if (integer? i)
|
||||
i
|
||||
(add1 (floor (inexact->exact i))))
|
||||
(if (integer? j)
|
||||
j
|
||||
(add1 (floor (inexact->exact j))))
|
||||
(if (integer? i) 's 'w))
|
||||
(values 0 0 'bad)))]
|
||||
[else (values 0 0 'bad)])])
|
||||
(case dir
|
||||
[(n s e w) 'ok]
|
||||
[else (raise-type-error
|
||||
'set-wall
|
||||
"location"
|
||||
loc)])
|
||||
(let* ([i (+ (* 2 ri) (case dir
|
||||
[(w) 0]
|
||||
[(n s) 1]
|
||||
[(e) 2]))]
|
||||
[j (+ (* 2 rj) (case dir
|
||||
[(n) 2]
|
||||
[(w e) 1]
|
||||
[(s) 0]))]
|
||||
[wall (vector-ref (vector-ref walls i) j)]
|
||||
[door-image (if (or (door-image . is-a? . bitmap%)
|
||||
(door-image . is-a? . image-snip%))
|
||||
(bitmap->drawer door-image this)
|
||||
door-image)]
|
||||
[drawer (if wall?
|
||||
(make-wall-draw ri rj dir door-image)
|
||||
void)])
|
||||
(if (wall-drawer wall)
|
||||
(send board set-space-draw wall drawer)
|
||||
(send board add-space drawer wall))
|
||||
(set-wall-drawer! wall drawer))
|
||||
(send board refresh)))
|
||||
|
||||
(define/public (set-room i j data)
|
||||
(let ([room (vector-ref (vector-ref rooms i) j)])
|
||||
(define/public (set-room-data loc data)
|
||||
(let ([room (vector-ref (vector-ref rooms (car loc)) (cadr loc))])
|
||||
(set-room-data! room data)))
|
||||
|
||||
(public [new-player make-player])
|
||||
(public [new-player make-player-icon])
|
||||
(define (new-player drawer data)
|
||||
(make-player data drawer #f #f))
|
||||
|
||||
(define/public (move-player player i j)
|
||||
(let ([from-room (and (player-i player)
|
||||
(vector-ref (vector-ref rooms (player-i player)) (player-j player)))]
|
||||
[to-room (and i (vector-ref (vector-ref rooms i) j))])
|
||||
(when from-room
|
||||
(set-room-players! from-room (remq player (room-players from-room))))
|
||||
(when to-room
|
||||
(set-room-players! to-room (cons player (room-players to-room))))
|
||||
(set-player-i! player i)
|
||||
(set-player-j! player j)
|
||||
(when from-room
|
||||
(send board remove-piece player))
|
||||
(when to-room
|
||||
(send board add-piece (+ i 0.5) (+ j 0.5) 0.0 (player-drawer player) player))
|
||||
(send board refresh)))
|
||||
(define/public (move-player-icon player loc)
|
||||
(let ([i (and loc (car loc))]
|
||||
[j (and loc (cadr loc))])
|
||||
(let ([from-room (and (player-i player)
|
||||
(vector-ref (vector-ref rooms (player-i player)) (player-j player)))]
|
||||
[to-room (and loc (vector-ref (vector-ref rooms i) j))])
|
||||
(when from-room
|
||||
(set-room-players! from-room (remq player (room-players from-room))))
|
||||
(when to-room
|
||||
(set-room-players! to-room (cons player (room-players to-room))))
|
||||
(set-player-i! player i)
|
||||
(set-player-j! player j)
|
||||
(when from-room
|
||||
(send board remove-piece player))
|
||||
(when to-room
|
||||
(send board add-piece (+ i 0.5) (+ j 0.5) 0.0 (player-drawer player) player))
|
||||
(send board refresh))))
|
||||
|
||||
(public [new-thing make-thing])
|
||||
(public [new-thing make-thing-icon])
|
||||
(define (new-thing drawer data)
|
||||
(make-thing data drawer #f #f #f))
|
||||
|
||||
(define/private (move-thing/hu thing i j hu?)
|
||||
(let ([from-hu? (thing-heads-up? thing)]
|
||||
[from-room (and (thing-i thing)
|
||||
(vector-ref (vector-ref rooms (thing-i thing)) (thing-j thing)))]
|
||||
[to-room (and i (vector-ref (vector-ref rooms i) j))])
|
||||
(when from-room
|
||||
(set-room-things! from-room (remq thing (room-things from-room))))
|
||||
(when to-room
|
||||
(set-room-things! to-room (cons thing (room-things to-room))))
|
||||
(set-thing-i! thing i)
|
||||
(set-thing-j! thing j)
|
||||
(set-thing-heads-up?! thing hu?)
|
||||
(when from-room
|
||||
(send board remove-piece thing))
|
||||
(when from-hu?
|
||||
(send board remove-heads-up thing))
|
||||
(when to-room
|
||||
(send board add-piece (+ i 0.5) (+ j 0.5) 0.0 (thing-drawer thing) thing)
|
||||
(send board enable-piece thing #f))
|
||||
(when hu?
|
||||
(send board add-heads-up 1.0 1.0 (thing-drawer thing) thing))
|
||||
(send board refresh)))
|
||||
|
||||
(define/public (move-thing thing i j)
|
||||
(move-thing/hu thing i j #f))
|
||||
(define/public (move-thing-heads-up thing)
|
||||
(move-thing/hu thing #f #f #t))
|
||||
(define/public (move-thing-icon thing loc)
|
||||
(let ([i (and (pair? loc) (car loc))]
|
||||
[j (and (pair? loc) (cadr loc))]
|
||||
[hu? (eq? loc 'heads-up)])
|
||||
(let ([from-hu? (thing-heads-up? thing)]
|
||||
[from-room (and (thing-i thing)
|
||||
(vector-ref (vector-ref rooms (thing-i thing)) (thing-j thing)))]
|
||||
[to-room (and i (vector-ref (vector-ref rooms i) j))])
|
||||
(when from-room
|
||||
(set-room-things! from-room (remq thing (room-things from-room))))
|
||||
(when to-room
|
||||
(set-room-things! to-room (cons thing (room-things to-room))))
|
||||
(set-thing-i! thing i)
|
||||
(set-thing-j! thing j)
|
||||
(set-thing-heads-up?! thing hu?)
|
||||
(when from-room
|
||||
(send board remove-piece thing))
|
||||
(when from-hu?
|
||||
(send board remove-heads-up thing))
|
||||
(when to-room
|
||||
(send board add-piece (+ i 0.5) (+ j 0.5) 0.0 (thing-drawer thing) thing)
|
||||
(send board enable-piece thing #f))
|
||||
(when hu?
|
||||
(send board add-heads-up 1.0 1.0 (thing-drawer thing) thing))
|
||||
(send board refresh))))
|
||||
|
||||
(super-new))))
|
||||
|
|
|
|||
148
collects/games/doors/graph.ss
Normal file
148
collects/games/doors/graph.ss
Normal file
|
|
@ -0,0 +1,148 @@
|
|||
|
||||
(module graph mzscheme
|
||||
(require (lib "class.ss")
|
||||
"private/utils.ss")
|
||||
(require-for-syntax "private/utils.ss")
|
||||
|
||||
(provide node% edge%
|
||||
grid-graph)
|
||||
|
||||
(define node%
|
||||
(class object%
|
||||
(define edges null)
|
||||
(define loc #f)
|
||||
(define/public (set-location l)
|
||||
(set! loc l))
|
||||
(define/public (get-location)
|
||||
loc)
|
||||
(define/public (connect e)
|
||||
(set! edges (cons e edges)))
|
||||
(define/public (get-edges)
|
||||
edges)
|
||||
(define/public (edge-to n)
|
||||
(ormap (lambda (e)
|
||||
(and (memq n (send e get-nodes))
|
||||
e))
|
||||
edges))
|
||||
(super-new)))
|
||||
|
||||
(define edge%
|
||||
(class object%
|
||||
(define nodes null)
|
||||
(define loc #f)
|
||||
(define/public (set-location l)
|
||||
(set! loc l))
|
||||
(define/public (get-location)
|
||||
loc)
|
||||
(define/public (connect n)
|
||||
(set! nodes (cons n nodes)))
|
||||
(define/public (get-nodes)
|
||||
nodes)
|
||||
(super-new)))
|
||||
|
||||
(define (check <%> v)
|
||||
(unless (v . is-a? . <%>)
|
||||
(error 'maze
|
||||
"not an instance of ~a: ~e"
|
||||
<%>
|
||||
v))
|
||||
v)
|
||||
|
||||
(define (connect-all! connect-key layout)
|
||||
(define-member-name connect connect-key)
|
||||
(let loop ([layout layout]
|
||||
[j (sub1 (quotient (length layout) 2))])
|
||||
(unless (null? (cdr layout))
|
||||
(let loop ([edges (car layout)]
|
||||
[nodes (cadr layout)]
|
||||
[next-edges (caddr layout)]
|
||||
[i 0])
|
||||
(unless (null? (cdr nodes))
|
||||
(let ([n (car edges)]
|
||||
[s (car next-edges)]
|
||||
[e (caddr nodes)]
|
||||
[w (car nodes)]
|
||||
[r (cadr nodes)])
|
||||
(send r set-location (list i j))
|
||||
(send n set-location (list i (+ j 0.5)))
|
||||
(send s set-location (list i (- j 0.5)))
|
||||
(send e set-location (list (+ i 0.5) j))
|
||||
(send w set-location (list (- i 0.5) j))
|
||||
(send r connect n)
|
||||
(send r connect s)
|
||||
(send r connect e)
|
||||
(send r connect w)
|
||||
(send n connect r)
|
||||
(send s connect r)
|
||||
(send e connect r)
|
||||
(send w connect r))
|
||||
(loop (cdr edges)
|
||||
(cddr nodes)
|
||||
(cdr next-edges)
|
||||
(add1 i))))
|
||||
(loop (cddr layout) (sub1 j)))))
|
||||
|
||||
(define-syntax grid-graph
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(maze edge<%> node<%> (items ...) ...)
|
||||
(let ([itemss (syntax->list #'((items ...) ...))])
|
||||
(unless (odd? (length itemss))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"need an odd number of rows"
|
||||
stx))
|
||||
(let-values ([(edgess nodess) (alternates itemss)])
|
||||
(when (null? nodess)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"no nodes supplied"
|
||||
stx))
|
||||
(let ([first-edges-len
|
||||
(length (syntax->list (car edgess)))])
|
||||
(for-each (lambda (edges)
|
||||
(let ([len (length (syntax->list edges))])
|
||||
(unless (= len first-edges-len)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"N/S edges sequence length doesn't match first edges sequence"
|
||||
stx
|
||||
edges))))
|
||||
edgess)
|
||||
(for-each (lambda (nodes)
|
||||
(let ([len (length (syntax->list nodes))])
|
||||
(unless (= len (add1 (* 2 first-edges-len)))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"nodes with E/W edges sequence length doesn't match first edges sequence"
|
||||
stx
|
||||
nodes))))
|
||||
nodess))
|
||||
(with-syntax ([((items ...) ...)
|
||||
(interleave
|
||||
(map (lambda (edges)
|
||||
(map (lambda (edge)
|
||||
(quasisyntax/loc edge
|
||||
(instance edge<%> #,edge)))
|
||||
(syntax->list edges)))
|
||||
edgess)
|
||||
(map (lambda (nodes)
|
||||
(let-values ([(edges nodes)
|
||||
(alternates (syntax->list nodes))])
|
||||
(interleave
|
||||
(map (lambda (edge)
|
||||
(quasisyntax/loc edge
|
||||
(instance edge<%> #,edge)))
|
||||
edges)
|
||||
(map (lambda (node)
|
||||
(quasisyntax/loc node
|
||||
(instance node<%> #,node)))
|
||||
nodes))))
|
||||
nodess))])
|
||||
(syntax/loc stx
|
||||
(connect-all! (member-name-key connect) (list (list items ...) ...))))))])))
|
||||
|
||||
(define-syntax instance
|
||||
(syntax-rules ()
|
||||
[(instance <%> v)
|
||||
(check <%> v)])))
|
||||
|
|
@ -1,105 +0,0 @@
|
|||
|
||||
(module maze mzscheme
|
||||
(require (lib "class.ss")
|
||||
"private/utils.ss")
|
||||
(require-for-syntax "private/utils.ss")
|
||||
|
||||
(provide maze)
|
||||
|
||||
(define (check <%> v)
|
||||
(unless (v . is-a? . <%>)
|
||||
(error 'maze
|
||||
"not an instance of ~a: ~e"
|
||||
<%>
|
||||
v))
|
||||
v)
|
||||
|
||||
(define (connect-all! connect-key layout)
|
||||
(define-member-name connect connect-key)
|
||||
(let loop ([layout layout]
|
||||
[j (sub1 (quotient (length layout) 2))])
|
||||
(unless (null? (cdr layout))
|
||||
(let loop ([walls (car layout)]
|
||||
[rooms (cadr layout)]
|
||||
[next-walls (caddr layout)]
|
||||
[i 0])
|
||||
(unless (null? (cdr rooms))
|
||||
(let ([n (car walls)]
|
||||
[s (car next-walls)]
|
||||
[e (caddr rooms)]
|
||||
[w (car rooms)]
|
||||
[r (cadr rooms)])
|
||||
(send r connect i j n s e w))
|
||||
(loop (cdr walls)
|
||||
(cddr rooms)
|
||||
(cdr next-walls)
|
||||
(add1 i))))
|
||||
(loop (cddr layout) (sub1 j)))))
|
||||
|
||||
(define-syntax maze
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(maze connect wall<%> room<%> (items ...) ...)
|
||||
(let ([itemss (syntax->list #'((items ...) ...))])
|
||||
(unless (odd? (length itemss))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"need an odd number of rows"
|
||||
stx))
|
||||
(let-values ([(wallss roomss) (alternates itemss)])
|
||||
(when (null? roomss)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"no rooms supplied"
|
||||
stx))
|
||||
(let ([first-walls-len
|
||||
(length (syntax->list (car wallss)))])
|
||||
(for-each (lambda (walls)
|
||||
(let ([len (length (syntax->list walls))])
|
||||
(unless (= len first-walls-len)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"N/S walls sequence length doesn't match first walls sequence"
|
||||
stx
|
||||
walls))))
|
||||
wallss)
|
||||
(for-each (lambda (rooms)
|
||||
(let ([len (length (syntax->list rooms))])
|
||||
(unless (= len (add1 (* 2 first-walls-len)))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"rooms with E/W walls sequence length doesn't match first walls sequence"
|
||||
stx
|
||||
rooms))))
|
||||
roomss))
|
||||
(with-syntax ([((items ...) ...)
|
||||
(interleave
|
||||
(map (lambda (walls)
|
||||
(map (lambda (wall)
|
||||
(quasisyntax/loc wall
|
||||
(instance wall<%> #,wall)))
|
||||
(syntax->list walls)))
|
||||
wallss)
|
||||
(map (lambda (rooms)
|
||||
(let-values ([(walls rooms)
|
||||
(alternates (syntax->list rooms))])
|
||||
(interleave
|
||||
(map (lambda (wall)
|
||||
(quasisyntax/loc wall
|
||||
(instance wall<%> #,wall)))
|
||||
walls)
|
||||
(map (lambda (room)
|
||||
(quasisyntax/loc room
|
||||
(instance room<%> #,room)))
|
||||
rooms))))
|
||||
roomss))])
|
||||
(syntax/loc stx
|
||||
(connect-all! (member-name-key connect) (list (list items ...) ...))))))])))
|
||||
|
||||
(define-syntax instance
|
||||
(syntax-rules (unquote)
|
||||
[(instance <%> (unquote v))
|
||||
(check <%> v)]
|
||||
[(instance <%> %)
|
||||
(check <%> (new %))])))
|
||||
|
||||
|
|
@ -1,17 +1,15 @@
|
|||
(module utils mzscheme
|
||||
(require (lib "gl-vectors.ss" "sgl")
|
||||
(prefix gl- (lib "sgl.ss" "sgl"))
|
||||
(lib "bitmap.ss" "sgl")
|
||||
(lib "math.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "list.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "class.ss")
|
||||
(lib "kw.ss"))
|
||||
(lib "kw.ss")
|
||||
"doors.ss")
|
||||
|
||||
(provide bitmap->drawer
|
||||
|
||||
door-bm
|
||||
(provide door-bm
|
||||
magic-door-bm
|
||||
locked-door-bm
|
||||
|
||||
|
|
@ -20,8 +18,8 @@
|
|||
magic-door-drawer
|
||||
open-door-drawer
|
||||
|
||||
make-i-player
|
||||
make-key-thing)
|
||||
make-i-player-icon
|
||||
make-key-thing-icon)
|
||||
|
||||
(define light-black (gl-float-vector 0.0 0.0 0.0 0.25))
|
||||
(define green (gl-float-vector 0.0 1.0 0.0 1.0))
|
||||
|
|
@ -32,28 +30,6 @@
|
|||
(define door-bm
|
||||
(make-object bitmap%
|
||||
(build-path (collection-path "games" "checkers") "light.jpg")))
|
||||
|
||||
(define (with-gl game)
|
||||
(lambda (f)
|
||||
(send game with-gl-context f)))
|
||||
|
||||
(define (bitmap->drawer bm game)
|
||||
(let*-values ([(bm mask)
|
||||
(cond
|
||||
[(bm . is-a? . bitmap%)
|
||||
(values bm (send bm get-loaded-mask))]
|
||||
[(bm . is-a? . image-snip%)
|
||||
(values (send bm get-bitmap)
|
||||
(send bm get-bitmap-mask))]
|
||||
[else (raise-type-error
|
||||
'bitmap->drawer
|
||||
"bitmap% or image-snip% object"
|
||||
bm)])]
|
||||
[(dl) (bitmap->gl-list bm
|
||||
#:with-gl (with-gl game)
|
||||
#:mask mask)])
|
||||
(lambda ()
|
||||
(gl-call-list dl))))
|
||||
|
||||
(define (door-drawer game)
|
||||
(bitmap->drawer door-bm game))
|
||||
|
|
@ -130,14 +106,15 @@
|
|||
(gl-end-list)
|
||||
list-id))))
|
||||
|
||||
(define/kw (make-i-player game
|
||||
#:key
|
||||
[color green]
|
||||
[data #f])
|
||||
(define/kw (make-i-player-icon game
|
||||
#:optional
|
||||
[data #f]
|
||||
#:key
|
||||
[color green] )
|
||||
(let ([shadow-cylinder-dl (make-cylinder-dl game dark-gray #t)]
|
||||
[cylinder-dl (make-cylinder-dl game color #f)]
|
||||
[sphere-dl (sphere-dl game color)])
|
||||
(send game make-player
|
||||
(send game make-player-icon
|
||||
(lambda (just-shadow?)
|
||||
(with-light
|
||||
just-shadow?
|
||||
|
|
@ -206,13 +183,15 @@
|
|||
(gl-light-model-v 'light-model-ambient (gl-float-vector 1.0 1.0 1.0 0.0))
|
||||
(gl-disable 'light0)))
|
||||
|
||||
(define/kw (make-key-thing game
|
||||
#:key
|
||||
[color yellow])
|
||||
(define/kw (make-key-thing-icon game
|
||||
#:optional
|
||||
[data #f]
|
||||
#:key
|
||||
[color yellow])
|
||||
(let ([dl (make-key-dl game color)])
|
||||
(send game make-thing
|
||||
(send game make-thing-icon
|
||||
(lambda/kw (#:optional [just-shadow? #f])
|
||||
(with-light just-shadow? (lambda ()
|
||||
(gl-scale 0.5 0.5 0.5)
|
||||
(gl-call-list dl))))
|
||||
'thing))))
|
||||
data))))
|
||||
Loading…
Reference in New Issue
Block a user