From 7e08f368049491f758b3eff845d5c307eb2cb0c4 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 6 Nov 2006 02:01:57 +0000
Subject: [PATCH] simpler API for door games

svn: r4789
---
 collects/games/doors/doors.ss | 190 +++++++++++++++++++++-------------
 collects/games/doors/graph.ss | 148 ++++++++++++++++++++++++++
 collects/games/doors/maze.ss  | 105 -------------------
 collects/games/doors/utils.ss |  57 ++++------
 4 files changed, 283 insertions(+), 217 deletions(-)
 create mode 100644 collects/games/doors/graph.ss
 delete mode 100644 collects/games/doors/maze.ss

diff --git a/collects/games/doors/doors.ss b/collects/games/doors/doors.ss
index 7bbf54cd0a..aaf8c9e5df 100644
--- a/collects/games/doors/doors.ss
+++ b/collects/games/doors/doors.ss
@@ -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))))
diff --git a/collects/games/doors/graph.ss b/collects/games/doors/graph.ss
new file mode 100644
index 0000000000..f7ff0545c2
--- /dev/null
+++ b/collects/games/doors/graph.ss
@@ -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)])))
diff --git a/collects/games/doors/maze.ss b/collects/games/doors/maze.ss
deleted file mode 100644
index 22ae6e1a69..0000000000
--- a/collects/games/doors/maze.ss
+++ /dev/null
@@ -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 %))])))
-
diff --git a/collects/games/doors/utils.ss b/collects/games/doors/utils.ss
index 78dca14ccf..4211f166cb 100644
--- a/collects/games/doors/utils.ss
+++ b/collects/games/doors/utils.ss
@@ -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))))
\ No newline at end of file
+            data))))
\ No newline at end of file