suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix terminology in maze errors, and add support for bitmap snips along with bitmaps

Browse Source 
svn: r4744
This commit is contained in:
Matthew Flatt 2006-11-01 23:05:32 +00:00
parent 33e75ab6ec
commit 0adaa9e162
3 changed files with 45 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/games/doors/doors.ss
View File

@ -155,7 +155,7 @@
(define/public (with-gl-context f) (define/public (with-gl-context f)
(send board with-gl-context f)) (send board with-gl-context f))
(define/public (set-wall ri rj dir wall? door) (define/public (set-wall ri rj dir wall? door-image)
(case dir (case dir
[(n s e w) 'ok] [(n s e w) 'ok]
[else (raise-type-error [else (raise-type-error
@ -172,7 +172,7 @@
[(s) 0]))] [(s) 0]))]
[wall (vector-ref (vector-ref walls i) j)] [wall (vector-ref (vector-ref walls i) j)]
[drawer (if wall? [drawer (if wall?
(make-wall-draw ri rj dir door) (make-wall-draw ri rj dir door-image)
void)]) void)])
(if (wall-drawer wall) (if (wall-drawer wall)
(send board set-space-draw wall drawer) (send board set-space-draw wall drawer)

58
collects/games/doors/maze.ss
View File

@ -19,75 +19,75 @@
(let loop ([layout layout] (let loop ([layout layout]
[j (sub1 (quotient (length layout) 2))]) [j (sub1 (quotient (length layout) 2))])
(unless (null? (cdr layout)) (unless (null? (cdr layout))
(let loop ([doors (car layout)] (let loop ([walls (car layout)]
[rooms (cadr layout)] [rooms (cadr layout)]
[next-doors (caddr layout)] [next-walls (caddr layout)]
[i 0]) [i 0])
(unless (null? (cdr rooms)) (unless (null? (cdr rooms))
(let ([n (car doors)] (let ([n (car walls)]
[s (car next-doors)] [s (car next-walls)]
[e (caddr rooms)] [e (caddr rooms)]
[w (car rooms)] [w (car rooms)]
[r (cadr rooms)]) [r (cadr rooms)])
(send r connect i j n s e w)) (send r connect i j n s e w))
(loop (cdr doors) (loop (cdr walls)
(cddr rooms) (cddr rooms)
(cdr next-doors) (cdr next-walls)
(add1 i)))) (add1 i))))
(loop (cddr layout) (sub1 j))))) (loop (cddr layout) (sub1 j)))))
(define-syntax maze (define-syntax maze
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(maze connect door<%> room<%> (items ...) ...) [(maze connect wall<%> room<%> (items ...) ...)
(let ([itemss (syntax->list #'((items ...) ...))]) (let ([itemss (syntax->list #'((items ...) ...))])
(unless (odd? (length itemss)) (unless (odd? (length itemss))
(raise-syntax-error (raise-syntax-error
#f #f
"need an odd number of rows" "need an odd number of rows"
stx)) stx))
(let-values ([(doorss roomss) (alternates itemss)]) (let-values ([(wallss roomss) (alternates itemss)])
(when (null? roomss) (when (null? roomss)
(raise-syntax-error (raise-syntax-error
#f #f
"no rooms supplied" "no rooms supplied"
stx)) stx))
(let ([first-doors-len (let ([first-walls-len
(length (syntax->list (car doorss)))]) (length (syntax->list (car wallss)))])
(for-each (lambda (doors) (for-each (lambda (walls)
(let ([len (length (syntax->list doors))]) (let ([len (length (syntax->list walls))])
(unless (= len first-doors-len) (unless (= len first-walls-len)
(raise-syntax-error (raise-syntax-error
#f #f
"N/S doors sequence length doesn't match first doors sequence" "N/S walls sequence length doesn't match first walls sequence"
stx stx
doors)))) walls))))
doorss) wallss)
(for-each (lambda (rooms) (for-each (lambda (rooms)
(let ([len (length (syntax->list rooms))]) (let ([len (length (syntax->list rooms))])
(unless (= len (add1 (* 2 first-doors-len))) (unless (= len (add1 (* 2 first-walls-len)))
(raise-syntax-error (raise-syntax-error
#f #f
"rooms with E/W doors sequence length doesn't match first doors sequence" "rooms with E/W walls sequence length doesn't match first walls sequence"
stx stx
rooms)))) rooms))))
roomss)) roomss))
(with-syntax ([((items ...) ...) (with-syntax ([((items ...) ...)
(interleave (interleave
(map (lambda (doors) (map (lambda (walls)
(map (lambda (door) (map (lambda (wall)
(quasisyntax/loc door (quasisyntax/loc wall
(instance door<%> #,door))) (instance wall<%> #,wall)))
(syntax->list doors))) (syntax->list walls)))
doorss) wallss)
(map (lambda (rooms) (map (lambda (rooms)
(let-values ([(doors rooms) (let-values ([(walls rooms)
(alternates (syntax->list rooms))]) (alternates (syntax->list rooms))])
(interleave (interleave
(map (lambda (door) (map (lambda (wall)
(quasisyntax/loc door (quasisyntax/loc wall
(instance door<%> #,door))) (instance wall<%> #,wall)))
doors) walls)
(map (lambda (room) (map (lambda (room)
(quasisyntax/loc room (quasisyntax/loc room
(instance room<%> #,room))) (instance room<%> #,room)))

15
collects/games/doors/utils.ss
View File

@ -38,7 +38,20 @@
(send game with-gl-context f))) (send game with-gl-context f)))
(define (bitmap->drawer bm game) (define (bitmap->drawer bm game)
(let ([dl (bitmap->gl-list bm (with-gl 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 () (lambda ()
(gl-call-list dl)))) (gl-call-list dl))))