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)
(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
[(n s e w) 'ok]
[else (raise-type-error
@ -172,7 +172,7 @@
[(s) 0]))]
[wall (vector-ref (vector-ref walls i) j)]
[drawer (if wall?
(make-wall-draw ri rj dir door)
(make-wall-draw ri rj dir door-image)
void)])
(if (wall-drawer wall)
(send board set-space-draw wall drawer)

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

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

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

@ -38,7 +38,20 @@
(send game with-gl-context f)))
(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 ()
(gl-call-list dl))))