added Doors game support ( in time for for APLAS talk )

svn: r4726

collects/games/doors/doc.txt

@@ -0,0 +1,9 @@
+
+_doors.ss_
+
+The "doors.ss" library builds on "gl-board.ss" to support simple
+maze-like games, where the maze is formed by a grid of squares and
+doors of various types can appears between adjacent squares.
+
+But it's not ready, yet. Check back later.
+

collects/games/doors/doors.ss

@@ -0,0 +1,237 @@
+(module doors mzscheme
+  (require (lib "gl-board.ss" "games" "gl-board-game")
+           (lib "gl-vectors.ss" "sgl")
+           (prefix gl- (lib "sgl.ss" "sgl"))
+           (lib "bitmap.ss" "sgl")
+           (lib "mred.ss" "mred")
+           (lib "list.ss")
+           (lib "etc.ss")
+           (lib "class.ss"))
+  
+  (provide door-game%
+           player-data
+           thing-data)
+  
+  (define-struct door-game (board))
+  
+  (define light-blue (gl-float-vector 0.5 0.5 1.0 0.5))
+  (define light-red (gl-float-vector 1.0 0.5 0.5 0.5))
+    
+  (define-struct room (data players things))
+  (define-struct wall (drawer))
+  (define-struct player (data drawer i j))
+  (define-struct thing (data drawer i j heads-up?))
+    
+  (define door-game%
+    (class object%
+      (init [(canvas-parent parent)] x-rooms y-rooms 
+            [move-callback void])
+      
+      (define rooms (build-vector
+                     x-rooms
+                     (lambda (i)
+                       (build-vector
+                        y-rooms
+                        (lambda (j)
+                          (make-room #f null null))))))
+
+      (define walls (build-vector
+                     (add1 (* 2 x-rooms))
+                     (lambda (i)
+                       (build-vector
+                        (add1 (* 2 y-rooms))
+                        (lambda (j)
+                          (make-wall #f))))))
+
+      (define board
+        (new gl-board% 
+             (parent canvas-parent)
+             (min-x -1) (max-x (add1 x-rooms))
+             (min-y -1) (max-y (add1 y-rooms))
+             (lift 0.15)
+             (move (lambda (piece to)
+                     (let ((to-i (inexact->exact (floor (gl-vector-ref to 0))))
+                           (to-j (inexact->exact (floor (gl-vector-ref to 1)))))
+                       (when (and (< -1 to-i x-rooms)
+                                  (< -1 to-j y-rooms))
+                         (let ([room (vector-ref (vector-ref rooms to-i) to-j)])
+                           (move-callback (player-data piece) (room-data room) to-i to-j))))))
+             (phi 30)))
+      
+      (define/private (make-wall-dl dir door?)
+        (send board with-gl-context
+              (lambda ()
+                (let ((list-id (gl-gen-lists 1)))
+                  (gl-new-list list-id 'compile)
+                  (let ([one-wall
+                         (lambda (color)
+                           (gl-material-v 'front-and-back 'ambient-and-diffuse color)
+                           (when door?
+                             (gl-begin 'polygon)
+                             (gl-vertex 0.0 0.0 0.0)
+                             (gl-vertex 0.33 0.0 0.0)
+                             (gl-vertex 0.33 0.0 0.35)
+                             (gl-vertex 0.0 0.0 0.35)
+                             (gl-end)
+                             (gl-begin 'polygon)
+                             (gl-vertex 0.66 0.0 0.0)
+                             (gl-vertex 1.0 0.0 0.0)
+                             (gl-vertex 1.0 0.0 0.35)
+                             (gl-vertex 0.66 0.0 0.35)
+                             (gl-end))
+                           (gl-begin 'polygon)
+                           (gl-vertex 0.0 0.0 (if door? 0.35 0.0))
+                           (gl-vertex 1.0 0.0 (if door? 0.35 0.0))
+                           (gl-vertex 1.0 0.0 0.52)
+                           (gl-vertex 0.0 0.0 0.52)
+                           (gl-end))])
+                    (case dir
+                      [(s)
+                       (one-wall light-blue)]
+                      [(n)
+                       (gl-push-matrix)
+                       (gl-translate 0.0 1.0 0.0)
+                       (one-wall light-blue)
+                       (gl-pop-matrix)]
+                      [(w)
+                       (gl-push-matrix)
+                       (gl-rotate 90 0 0 1)
+                       (one-wall light-red)
+                       (gl-pop-matrix)]
+                      [(e)
+                       (gl-push-matrix)
+                       (gl-rotate 90 0 0 1)
+                       (gl-translate 0.0 -1.0 0.0)
+                       (one-wall light-red)
+                       (gl-pop-matrix)])
+                    (gl-end-list)
+                    list-id)))))
+      
+      (define cache (make-hash-table 'equal))
+      (define/private (make-wall-dl/cached dir door?)
+        (let ([key (list dir door?)])
+          (hash-table-get cache key
+                          (lambda ()
+                            (let ([dl (make-wall-dl dir door?)])
+                              (hash-table-put! cache key dl)
+                              dl)))))
+    
+      (define/private (make-wall-draw dx dy dir door)
+        (let ([space-dl (make-wall-dl/cached dir
+                                             (and door #t))])
+          (lambda ()
+            (gl-enable 'blend)
+            (gl-blend-func 'src-alpha 'one-minus-src-alpha)
+            (gl-push-matrix)
+            (gl-translate dx dy 0.0)
+            (gl-call-list space-dl)
+            (gl-pop-matrix)
+            (gl-blend-func 'one 'one)
+            (gl-disable 'blend)
+            (when door
+              (let ([a-door
+                     (lambda (ddx ddy rot)
+                       (gl-push-matrix)
+                       (gl-translate dx dy 0.0)
+                       (gl-translate ddx ddy 0.0)
+                       (gl-rotate rot 0 0 1)
+                       (gl-translate 0.33 0.0 0.35)
+                       (gl-scale 0.33 1 0.35)
+                       (gl-rotate -90 1 0 0)
+                       (door)
+                       (gl-pop-matrix))])
+                (case dir
+                  [(s) (a-door 0 0 0)]
+                  [(e) (a-door 1.0 0 90)]
+                  [(n) (a-door 0 1.0 0)]
+                  [(w) (a-door 0 0 90)]))))))
+      
+      ;; Switch lighting to ambient
+      (send board with-gl-context
+            (lambda () 
+              (gl-disable 'light0)        
+              (gl-light-model-v 'light-model-ambient (gl-float-vector 1.0 1.0 1.0 0.0))))
+      
+      (define/public (with-gl-context f)
+        (send board with-gl-context f))
+      
+      (define/public (set-wall ri rj dir wall? door)
+        (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)
+                           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)])
+          (set-room-data! room data)))
+      
+      (public [new-player make-player])
+      (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))))
+
+      (public [new-thing make-thing])
+      (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))))
+
+      (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))
+
+      (super-new))))

collects/games/doors/info.ss

@@ -0,0 +1,3 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "Doors game library")
+  (define doc.txt "doc.txt"))

collects/games/doors/maze.ss

@@ -0,0 +1,105 @@
+
+(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 ([doors (car layout)]
+                   [rooms (cadr layout)]
+                   [next-doors (caddr layout)]
+                   [i 0])
+          (unless (null? (cdr rooms))
+            (let ([n (car doors)]
+                  [s (car next-doors)]
+                  [e (caddr rooms)]
+                  [w (car rooms)]
+                  [r (cadr rooms)])
+              (send r connect i j n s e w))
+            (loop (cdr doors)
+                  (cddr rooms)
+                  (cdr next-doors)
+                  (add1 i))))
+        (loop (cddr layout) (sub1 j)))))
+
+  (define-syntax maze
+    (lambda (stx)
+      (syntax-case stx ()
+        [(maze connect door<%> 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)])
+             (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)
+                               (raise-syntax-error
+                                #f
+                                "N/S doors sequence length doesn't match first doors sequence"
+                                stx
+                                doors))))
+                         doorss)
+               (for-each (lambda (rooms)
+                           (let ([len (length (syntax->list rooms))])
+                             (unless (= len (add1 (* 2 first-doors-len)))
+                               (raise-syntax-error
+                                #f
+                                "rooms with E/W doors sequence length doesn't match first doors 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 (rooms)
+                                    (let-values ([(doors rooms) 
+                                                  (alternates (syntax->list rooms))])
+                                      (interleave
+                                       (map (lambda (door)
+                                              (quasisyntax/loc door 
+                                                (instance door<%> #,door)))
+                                            doors)
+                                       (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 %))])))
+

collects/games/doors/private/utils.ss

@@ -0,0 +1,21 @@
+
+(module utils mzscheme
+  (provide alternates
+           interleave)
+
+  (define (alternates l)
+    (let loop ([l l])
+      (cond
+       [(null? l) (values null null)]
+       [(null? (cdr l)) (values l null)]
+       [else
+        (let-values ([(as bs) (loop (cddr l))])
+          (values (cons (car l) as)
+                  (cons (cadr l) bs)))])))
+
+  (define (interleave l1 l2)
+    (cond
+     [(null? l2) l1]
+     [else (list* (car l1)
+                  (car l2)
+                  (interleave (cdr l1) (cdr l2)))])))

collects/games/doors/utils.ss

@@ -0,0 +1,205 @@
+(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"))
+  
+  (provide bitmap->drawer
+           
+           door-bm
+           magic-door-bm
+           locked-door-bm
+
+           door-drawer
+           locked-door-drawer
+           magic-door-drawer
+           open-door-drawer
+           
+           make-i-player
+           make-key-thing)
+  
+  (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))
+  (define yellow (gl-float-vector 1.0 1.0 0.0 1.0))
+  (define black (gl-float-vector 0.0 0.0 0.0 1.0))
+  (define dark-gray (gl-float-vector 0.2 0.2 0.2 1.0))
+  
+  (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 ([dl (bitmap->gl-list bm (with-gl game))])
+      (lambda ()
+        (gl-call-list dl))))
+  
+  (define (door-drawer game)
+    (bitmap->drawer door-bm game))
+  
+  (define (open-door-drawer game)
+    void)
+
+  (define (add-to-door draw)
+    (let* ([w (send door-bm get-width)]
+           [h (send door-bm get-height)]
+           [bm (make-object bitmap% w h)]
+           [dc (make-object bitmap-dc% bm)])
+      (send dc draw-bitmap door-bm 0 0)
+      (draw dc w h)
+      (send dc set-bitmap #f)
+      bm))
+
+  (define magic-door-bm
+    (add-to-door
+     (lambda (dc w h)
+       (send dc set-font (send the-font-list find-or-create-font 32 'default))
+       (send dc set-text-foreground (make-object color% "yellow"))
+       (let-values ([(sw sh sd sa) (send dc get-text-extent "\u2605")])
+         (send dc draw-text "\u2605" (/ (- w sw) 2) (/ (- h sh) 2))))))
+
+  (define (magic-door-drawer game)
+    (bitmap->drawer magic-door-bm game))
+
+  (define locked-door-bm
+    (add-to-door
+     (lambda (dc w h)
+       (send dc set-brush (send the-brush-list find-or-create-brush "black" 'solid))
+       (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
+       (send dc draw-ellipse (/ (- w (* 0.2 h)) 2) (* 0.2 h)
+             (* 0.2 h) (* 0.2 h))
+       (send dc draw-rectangle (* w 0.45) (* 0.3 h)
+             (* 0.1 w) (* 0.3 h)))))
+
+  (define (locked-door-drawer game)
+    (bitmap->drawer locked-door-bm game))
+
+  (define (q game)
+    (send game with-gl-context
+          (lambda () 
+            (let ([q (gl-new-quadric)])
+              (gl-quadric-draw-style q 'fill)
+              (gl-quadric-normals q 'smooth)
+              q))))
+  
+  (define (sphere-dl game color)
+    (send game with-gl-context
+          (let ([q (q game)])
+            (lambda ()
+              (let ((list-id (gl-gen-lists 1)))
+                (gl-new-list list-id 'compile)
+                (gl-material-v 'front-and-back 'ambient-and-diffuse color)
+                (gl-sphere q 0.5 20 20)
+                (gl-end-list)
+                list-id)))))
+  
+  (define (make-cylinder-dl game color disk?)
+    (send game with-gl-context
+          (lambda ()
+            (let ((list-id (gl-gen-lists 1))
+                  (q (q game)))
+              (gl-new-list list-id 'compile)
+              (gl-material-v 'front-and-back 'ambient-and-diffuse color)
+              (gl-cylinder q 0.5 0.5 1.0 20 1)
+              (when disk?
+                (gl-push-matrix)
+                (gl-translate 0 0 1.0)
+                (gl-disk q 0.0 0.5 25 1)
+                (gl-pop-matrix))
+              (gl-end-list)
+              list-id))))
+  
+  (define/kw (make-i-player game
+                            #:key
+                            [color green] 
+                            [data #f])
+    (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
+            (lambda (just-shadow?)
+              (with-light
+               just-shadow?
+               (lambda ()
+                 (unless just-shadow?
+                   (gl-push-matrix)
+                   (gl-translate 0.0 0.0 0.30)
+                   (gl-scale 0.25 0.25 0.25)
+                   (gl-scale 0.5 0.5 0.5)
+                   (gl-call-list sphere-dl)
+                   (gl-pop-matrix))
+                 (gl-push-matrix)
+                 (gl-scale 0.25 0.25 0.5)
+                 (gl-scale 0.5 0.5 0.5)
+                 (gl-call-list (if just-shadow?
+                                   shadow-cylinder-dl
+                                   cylinder-dl))
+                 (gl-pop-matrix))))
+            data)))
+
+  (define (make-key-dl game color) 
+    (send game with-gl-context
+          (lambda ()
+            (let ((list-id (gl-gen-lists 1))
+                  (q (q game)))
+              (gl-new-list list-id 'compile)
+              (gl-material-v 'front-and-back 'ambient-and-diffuse color)
+              (gl-push-matrix)
+              (gl-translate -0.25 0 0)
+              (gl-cylinder q 0.25 0.25 0.2 20 1)
+              (gl-cylinder q 0.1 0.1 0.2 20 1)
+              (gl-disk q 0.1 0.25 20 2)
+              (gl-translate 0 0 0.2)
+              (gl-disk q 0.1 0.25 20 2)
+              (gl-pop-matrix)
+              (gl-push-matrix)
+              (gl-translate -0.05 0 0.1)
+              (gl-rotate 90 0 1 0)
+              (gl-cylinder q 0.1 0.1 0.5 16 1)
+              (gl-push-matrix)
+              (gl-translate 0 0 0.5)
+              (gl-disk q 0 0.1 16 1)
+              (gl-pop-matrix)
+              (let ([tooth
+                     (lambda ()
+                       (gl-push-matrix)
+                       (gl-rotate 90 1 0 0)
+                       (gl-cylinder q 0.05 0.05 0.25 16 1)
+                       (gl-translate 0 0 0.25)
+                       (gl-disk q 0 0.05 16 1)
+                       (gl-pop-matrix))])
+                (gl-translate 0 0 0.2)
+                (tooth)
+                (gl-translate 0 0 0.2)
+                (tooth))
+              (gl-pop-matrix)      
+              (gl-end-list)
+              list-id))))
+
+    (define (with-light just-shadow? thunk)
+      (unless just-shadow?
+        (gl-enable 'light0)
+        (gl-light-model-v 'light-model-ambient (gl-float-vector 0.5 0.5 0.5 0.0)))
+      (thunk)
+      (unless just-shadow?
+        (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])
+    (let ([dl (make-key-dl game color)])
+      (send game make-thing 
+            (lambda/kw (#:optional [just-shadow? #f]) 
+              (with-light just-shadow? (lambda ()
+                                         (gl-scale 0.5 0.5 0.5)
+                                         (gl-call-list dl))))
+            'thing))))

collects/games/gl-board-game/doc.txt

@@ -82,7 +82,9 @@ the board.  They are used to setup viewing parameters.  The board is viewed
 centered around the center of the coordinates, and the view attempts to fill
 the window to them. The optional theta and phi arguments determine the initial
 rotation of the board, with respective defaults 45 and 0; theta corresponds to
-the up and down keys, and phi corresponds to the left and right keys.
+the up and down keys, and phi corresponds to the left and right keys. (Holding
+down Command/Meta/Alt while pressing an arrow key pans the display, instead
+of rotating.)
 
 The lift parameter specifies how high off the board mouse-dragged pieces are.
 

collects/games/info.ss

@@ -7,7 +7,7 @@
     (list "cards" "paint-by-numbers" "same" "lights-out" "aces" "spider"
 	  "memory" "pousse" "crazy8s"
           "gcalc" "parcheesi" "gl-board-game"
-	  "jewel"))
+	  "jewel" "doors"))
   (define blurb 
     (list "Demos a few small "
 	  '(a ((MZSCHEME "