Tally Maze

collects/games/scribblings/std-games.scrbl

@@ -23,4 +23,5 @@
 @include-section["parcheesi.scrbl"]
 @include-section["checkers.scrbl"]
 @include-section["chat-noir.scrbl"]
+@include-section["tally-maze.scrbl"]
 @include-section["gcalc.scrbl"]

collects/games/scribblings/tally-maze.scrbl

@@ -0,0 +1,35 @@
+#lang scribble/doc
+@(require "common.rkt" racket/class racket/draw (only-in slideshow/pict dc))
+
+@gametitle["Tally Maze" "tally-maze" "Maze Enumeration Game"]
+
+The object of @game{Tally Maze} is to help the blue ball 
+reach the exit of the maze without being caught by the pumpkins.
+
+Control the blue ball with the keyboard: 
+@itemlist[@item{the arrow keys move one step in each direction;}
+           @item{space and @litchar{.} let the pumpkins move without moving the blue ball;}
+           @item{@litchar{z} undoes the most recent move; and}
+           @item{@litchar{n} changes the maze.}]
+
+As you can quickly discover, simply moving around in the maze
+is a recipe for failure. The pumpkins know the best route 
+in the maze to reach your blue ball and they take it.
+
+The @litchar{n} key, however, adjusts the maze. More precisely,
+it moves forward to the next maze in an enumeration of all 
+40058175322602445443958933855600640 of the mazes that the game
+supports. Each maze is only a little bit different from
+the one before, so you have to plan ahead in order to understand
+how the current maze differs from the next one. (Use the
+undo key to help you plan.)
+
+Beware, however, that planning ahead one maze is not enough;
+although one pumpkin just chases you in the current maze,
+the other pumpkin tries to track where you might go if
+you advance to the next maze and to wait for you there.
+Not all games are winnable, although I believe most are.
+
+Thanks to Lazy Crazy (@url{http://lazycrazy.deviantart.com}) for
+the blue ball icons and to YOOtheme (@url{http://www.yootheme.com/icons})
+for the pumpkin icon.

collects/games/tally-maze/game.rkt

@@ -0,0 +1,285 @@
+#lang racket/base
+
+(require "maze.rkt" 
+         (except-in "godel.rkt" unit/s)
+         "../show-scribbling.rkt"
+         racket/gui/base
+         racket/class
+         racket/set
+         racket/list
+         racket/path
+         racket/runtime-path
+         racket/unit)
+
+(provide game@)
+
+(define-runtime-path bmps "bmps")
+(define big-pumpkin (read-bitmap (build-path bmps "pumpkin" "pumpkin-64x64.png")))
+(define two-pumpkins (make-bitmap (send big-pumpkin get-width) (send big-pumpkin get-height)))
+(let ([small-pumpkin (read-bitmap (build-path bmps "pumpkin" "pumpkin-48x48.png"))]
+      [bdc (make-object bitmap-dc% two-pumpkins)])
+  (send bdc draw-bitmap small-pumpkin 0 0)
+  (send bdc draw-bitmap small-pumpkin
+        (- (send big-pumpkin get-width)
+           (send small-pumpkin get-width))
+        (- (send big-pumpkin get-height)
+           (send small-pumpkin get-height)))
+  (send bdc set-bitmap #f))
+
+(define small-icon-size 4)
+(define (mk-small color)
+  (define bmp (make-bitmap small-icon-size small-icon-size))
+  (define bdc (make-object bitmap-dc% bmp))
+  (send bdc set-brush color 'solid)
+  (send bdc set-pen "black" 1 'transparent)
+  (send bdc draw-ellipse 0 0 small-icon-size small-icon-size)
+  (send bdc set-bitmap #f)
+  bmp)
+
+(define small-pumpkin (mk-small "orange"))
+(define small-player (mk-small "blue"))
+
+(define game@
+  (unit (import)
+        (export)
+(define maze-w 10)
+(define maze-h 10)
+
+(struct state 
+  (maze-index maze edges 
+              player
+              computer1
+              computer2
+              player-icon)
+  #:transparent)
+(define maze-count (spec-k (maze/s maze-w maze-h)))
+
+(define (state-next-edges the-state)
+  (build-walls
+   (decode (maze/s maze-w maze-h)
+           (modulo (+ (state-maze-index the-state) 1)
+                   maze-count))
+   maze-w
+   maze-h))
+
+(define (fill-in-maze the-state new-val)
+  (define current-maze (decode-maze maze-w maze-h new-val))
+  (struct-copy state the-state
+               [maze-index new-val]
+               [maze current-maze]
+               [edges (build-walls current-maze maze-w maze-h)]))
+
+(define initial-number (pick-a-maze maze-w maze-h))
+(define the-states
+  (list (fill-in-maze (state #f #f #f 
+                             (cons 0 0)
+                             (cons (- maze-w 1) (- maze-h 1))
+                             (cons (- maze-w 1) (- maze-h 1))
+                             21) 
+                      initial-number)))
+(define (current-state) (car the-states))
+(define (set-the-states! new-states)
+  (set! the-states new-states)
+  (send game-canvas refresh))
+
+(define (next-state! state)
+  (set-the-states! (cons state the-states)))
+
+(define (get-player-icon the-state)
+  (cond
+    [(and (= (car (state-player the-state)) (- maze-w 1))
+          (= (cdr (state-player the-state)) (- maze-h 1)))
+     ;; winner
+     (pick '(1))]
+    [(edge-connecting? (state-edges the-state)
+                       (state-player the-state)
+                       (cons (- maze-w 1) (- maze-h 1)))
+     ;; about to win
+     (pick '(19))]
+    [(or (edge-connecting? (state-edges the-state)
+                           (state-computer1 the-state)
+                           (state-player the-state))
+         (edge-connecting? (state-edges the-state)
+                           (state-computer2 the-state)
+                           (state-player the-state)))
+     ;; about to lose
+     (pick '(20 35))]
+    [else 
+     ;; nothing much going on
+     (pick '(21 36 37))]))
+
+(define (edge-connecting? edges a b) (set-member? (hash-ref edges a) b))
+
+(define (pick args)
+  (define pr (state-player (current-state)))
+  (list-ref args (modulo (+ (car pr) (cdr pr))
+                         (length args))))
+
+(define players (make-hash))
+(for ([file (in-directory (build-path bmps "very-emotional"))])
+  (when (regexp-match #rx"png$" (path->string file))
+    (define name (path->string (last (explode-path file))))
+    (define m-num (regexp-match #rx"[(]([0-9]+)[)]" name))
+    (define num (if m-num
+                    (string->number (list-ref m-num 1))
+                    0))
+    (hash-set! players num (read-bitmap file))))
+
+(define (move dx dy)
+  (unless (game-over?)
+    (define new-x (+ dx (car (state-player (current-state)))))
+    (define new-y (+ dy (cdr (state-player (current-state)))))
+    (define new-pr (cons new-x new-y))
+    (when (and (<= 0 new-x (- maze-w 1))
+               (<= 0 new-y (- maze-w 1))
+               (edge-connecting? (state-edges (current-state))
+                                 (state-player (current-state))
+                                 new-pr))
+      (next-state!
+       (struct-copy state (move-computer (current-state))
+                    [player new-pr])))))
+
+(define (stay-put)
+  (next-state! (move-computer (current-state))))
+
+(define (next-maze)
+  (define next-maze-state
+    (fill-in-maze (current-state)
+                  (modulo (+ (state-maze-index (current-state)) 1) maze-count)))
+  (next-state!
+   (if (game-over?)
+       next-maze-state
+       (move-computer next-maze-state))))
+
+(define (undo-maze)
+  (unless (null? (cdr the-states))
+    (set-the-states! (cdr the-states))))
+
+(define (move-computer the-state)
+  (cond
+    [(or (equal? (state-player (current-state)) 
+                 (state-computer1 (current-state)))
+         (equal? (state-player (current-state)) 
+                 (state-computer2 (current-state))))
+     the-state]
+    [else
+     (define end (state-player the-state))
+     (define this-edges (state-edges the-state))
+     (define next-edges (state-next-edges the-state))
+     
+     (define-values (this-maze-c1 this-maze-c1-dist)
+       (preferred-direction this-edges (state-computer1 the-state) end))
+     (define-values (this-maze-c2 this-maze-c2-dist)
+       (preferred-direction this-edges (state-computer2 the-state) end))
+     
+     (define-values (next-maze-c1 next-maze-c1-dist)
+       (preferred-direction next-edges (state-computer1 the-state) end))
+     (define-values (next-maze-c2 next-maze-c2-dist)
+       (preferred-direction next-edges (state-computer2 the-state) end))
+     (cond
+       [(<= this-maze-c1-dist this-maze-c2-dist)
+        (struct-copy state the-state
+                     [computer1 this-maze-c1]
+                     [computer2 (if (edge-connecting? this-edges 
+                                                      (state-computer2 the-state)
+                                                      next-maze-c2)
+                                    next-maze-c2
+                                    (state-computer2 the-state))])]
+       [else
+        (struct-copy state the-state
+                     [computer1 (if (edge-connecting? this-edges 
+                                                      (state-computer1 the-state)
+                                                      next-maze-c1)
+                                    next-maze-c1
+                                    (state-computer1 the-state))]
+                     [computer2 this-maze-c2])])]))
+
+(define (preferred-direction edges start end)
+  (define visited (make-hash))
+  (define dir
+    (let loop ([node start]
+               [dist 0])
+      (cond
+        [(hash-ref visited node #f) #f]
+        [else
+         (hash-set! visited node dist)
+         (cond
+           [(equal? node end) 
+            node]
+           [else
+            (for/or ([neighbor (in-set (hash-ref edges node))])
+              (and (loop neighbor (+ dist 1))
+                   neighbor))])])))
+  (values dir (hash-ref visited end)))
+  
+
+(define (add1/f n) (and n (+ n 1)))
+
+(define game-canvas%
+  (class canvas%
+    (inherit get-dc get-client-size)
+    (define/override (on-paint)
+      (define dc (get-dc))
+      (send dc set-smoothing 'smoothed)
+      (define-values (w h) (get-client-size))
+      (draw-a-state dc 0 0 w h (current-state) #f))
+    (define/override (on-char evt) 
+      (case (send evt get-key-code)
+        [(left) (move -1 0)]
+        [(up) (move 0 -1)]
+        [(right) (move 1 0)]
+        [(down) (move 0 1)]
+        [(#\space #\.) (stay-put)]
+        [(#\n) (next-maze)]
+        [(#\z) (undo-maze)]))
+    (super-new)))
+
+(define (draw-a-state dc dx dy w h the-state small?)
+  (draw-maze dc dx dy 
+             w h (state-edges the-state)
+             maze-w maze-h
+             #:images 
+             (cons (list (if small?
+                             (list small-player) 
+                             (list (hash-ref players (get-player-icon the-state))))
+                         (car (state-player the-state))
+                         (cdr (state-player the-state)))
+                   (if (equal? (state-computer1 the-state)
+                               (state-computer2 the-state))
+                       (list (list (if small? (list small-pumpkin) (list two-pumpkins))
+                                   (car (state-computer1 the-state))
+                                   (cdr (state-computer1 the-state))))
+                       (list (list (if small? (list small-pumpkin) (list big-pumpkin))
+                                   (car (state-computer1 the-state))
+                                   (cdr (state-computer1 the-state)))
+                             (list (if small? (list small-pumpkin) (list big-pumpkin))
+                                   (car (state-computer2 the-state))
+                                   (cdr (state-computer2 the-state))))))))
+
+(define (game-over?)
+  (or (equal? (state-player (current-state)) 
+              (state-computer1 (current-state)))
+      (equal? (state-player (current-state)) 
+              (state-computer2 (current-state)))
+      (and (= (car (state-player (current-state))) (- maze-w 1))
+           (= (cdr (state-player (current-state))) (- maze-h 1)))))
+  
+
+(define f (new frame% [label "Tally Maze"] [width 600] [height 600]))
+(define game-canvas (new game-canvas% 
+                         [parent f]
+                         [min-width (* maze-w 60)]
+                         [min-height (* maze-h 60)]))
+(define hp (new horizontal-panel% [parent f] [alignment '(right center)] [stretchable-height #f]))
+(define msg (new message% [parent hp] [label (format "Game #~a" initial-number)]))
+(void (new vertical-panel% [parent hp]))
+(define show-help (show-scribbling
+                   '(lib "games/scribblings/games.scrbl")
+                   "tally-maze"))
+(define help-button (new button%
+                         [label "Help"]
+                         [parent hp]
+                         [callback (lambda (_1 _2) (show-help))]))
+(send f show #t)))
+
+(module+ main (invoke-unit game@))

collects/games/tally-maze/godel.rkt

@@ -0,0 +1,738 @@
+#lang racket/base
+
+#|
+
+Originally from Jay McCarthy's gb library.
+
+|#
+
+(require racket/match
+         racket/contract
+         racket/function
+         racket/list)
+
+
+(provide k*k-bind/s
+         cons/s list/s
+         nat-range/s wrap/s enum/s unit/s
+         decode encode spec-k)
+
+(module+ test
+  (require rackunit)
+  (define N 10))
+
+;; The core: Pairing functions
+(define (core-nat-cons x y)
+  (arithmetic-shift (bitwise-ior 1 (arithmetic-shift y 1))
+                    x))
+
+(define (core-nat-hd n)
+  (unless (> n 0)
+    (error 'core-nat-hd "Cannot take the head of 0"))
+  (if (= 1 (bitwise-and n 1))
+    0
+    (add1 (core-nat-hd (arithmetic-shift n -1)))))
+
+(define (core-nat-tl n)
+  (arithmetic-shift n (* -1 (add1 (core-nat-hd n)))))
+
+(define (nat-cons x y)
+  (sub1 (core-nat-cons x y)))
+(define (nat-hd z)
+  (core-nat-hd (add1 z)))
+(define (nat-tl z)
+  (core-nat-tl (add1 z)))
+
+(define (pair hd-k tl-k hd tl)
+  (match* (hd-k tl-k)
+    [(+inf.0 +inf.0)
+     (nat-cons hd tl)]            
+    [(+inf.0 tl-k)
+     (+ (* hd tl-k) tl)]    
+    [(hd-k +inf.0)
+     (+ hd (* tl hd-k))]    
+    [(hd-k tl-k)
+     (+ hd (* tl hd-k))]))
+(define (pair-hd hd-k tl-k n)
+  (match* (hd-k tl-k)
+    [(+inf.0 +inf.0)
+     (nat-hd n)]    
+    [(+inf.0 tl-k)
+     (quotient n tl-k)]
+    [(hd-k +inf.0)
+     (remainder n hd-k)]
+    [(hd-k tl-k)
+     (remainder n hd-k)]))
+(define (pair-tl hd-k tl-k n)
+  (match* (hd-k tl-k)
+    [(+inf.0 +inf.0)
+     (nat-tl n)]    
+    [(+inf.0 tl-k)
+     (remainder n tl-k)]
+    [(hd-k +inf.0)
+     (quotient n hd-k)]
+    [(hd-k tl-k)
+     (quotient n hd-k)]))
+
+(module+ test
+  (for ([i (in-range N)])
+    (define fst (random (* N N)))
+    (define snd (random (* N N)))
+    (define n (nat-cons fst snd))
+    (test-equal? (format "~a,~a" fst snd) (nat-hd n) fst)
+    (test-equal? (format "~a,~a" fst snd) (nat-tl n) snd)))
+
+;; Encoding
+(struct spec (k in out) #:transparent)
+
+(define (encode spec v)
+  (define n ((spec-out spec) v))
+  (define k (spec-k spec))
+  (unless (< n k)
+    (error 
+     'encode
+     "spec(~e) returned encoding[~e] outside range[~e] for value[~e]"
+     spec n k v))
+  n)
+(define (decode spec n)
+  (define k (spec-k spec))
+  (unless (< n k)
+    (error
+     'decode
+     "spec(~e) received encoding[~e] outside range[~e]"
+     spec n k))  
+  ((spec-in spec) n))
+(module+ test
+  (define-syntax-rule (test-en/de s-e v-e)
+    (let ()
+      (define n 's-e)
+      (define s s-e)
+      (define v v-e)
+      (test-equal? (format "s=~a v=~a" n v)
+                   (decode s (encode s v))
+                   v)))
+  (define-syntax-rule (test-spec s-e)
+    (let ()
+      (define n 's-e)
+      (define s s-e)
+      (for ([i (in-range (min N (spec-k s)))])
+        (define v (decode s i))
+        (test-equal? (format "n=~a i=~a v=~a" n i v)
+                     (encode s v) i))))
+  (define-syntax-rule (test-spec-ex s-e v-e n-e)
+    (let ()
+      (define v v-e)
+      (define n n-e)
+      (define s s-e)
+      (test-equal? (format "encode ~a ~a = ~a" 's-e v n) (encode s v) n)
+      (test-equal? (format "decode ~a ~a = ~a" 's-e n v) (decode s n) v)))
+  (define-syntax-rule (test-spec-exs s-e [v n] ...)
+    (let ()
+      (test-spec-ex s-e v n)
+      ...)))
+
+;; Specs
+(define null/s
+  (spec 0 error error))
+(define (unit/s v)
+  (spec 1 (λ (n) v) (λ (v) 0)))
+(module+ test
+  (define empty/s (unit/s empty))
+  (test-spec empty/s)
+  (for ([i (in-range N)])
+    (test-en/de empty/s empty)))
+
+(define nat/s
+  (spec +inf.0 identity identity))
+(module+ test
+  (test-spec nat/s)
+  (for ([i (in-range N)])
+    (test-en/de nat/s (random (* N N)))))
+
+(define (nat-range/s k)
+  (spec k identity identity))
+(module+ test
+  (test-spec (nat-range/s N))
+  (for ([i (in-range N)])
+    (test-en/de (nat-range/s N) i)))
+
+(define (cons/s hd/s tl/s)
+  (match-define (spec hd-k _ _) hd/s)
+  (match-define (spec tl-k _ _) tl/s)
+  (spec (* hd-k tl-k)
+        (λ (n)          
+          (cons (decode hd/s (pair-hd hd-k tl-k n))
+                (decode tl/s (pair-tl hd-k tl-k n))))
+        (λ (v)
+          (pair hd-k tl-k
+                (encode hd/s (car v))
+                (encode tl/s (cdr v))))))
+(module+ test
+  (define 2nats/s (cons/s nat/s nat/s))
+  (test-spec 2nats/s)
+  (for ([i (in-range N)])
+    (test-en/de 2nats/s
+                (cons (random (* N N))
+                      (random (* N N))))))
+
+(define (cantor-cons/s hd/s tl/s)
+  (match-define (spec hd-k _ _) hd/s)
+  (match-define (spec tl-k _ _) tl/s)
+  (unless (= +inf.0 hd-k)
+    (raise-argument-error 'cantor-cons/s
+                          "an infinite /s"
+                          0
+                          (list hd/s tl/s)))
+  (unless (= +inf.0 tl-k)
+    (raise-argument-error 'cantor-cons/s
+                          "an infinite /s"
+                          1
+                          (list hd/s tl/s)))
+  (spec (* hd-k tl-k)
+        (λ (z)
+          (define q (- (integer-sqrt (+ (* 8 z) 1)) 1))
+          (define w (if (even? q)
+                        (/ q 2)
+                        (/ (- q 1) 2)))
+          (define t (/ (+ (* w w) w) 2))
+          (define y (- z t))
+          (define x (- w y))
+          (cons (decode hd/s x) (decode tl/s y)))
+        (λ (v)
+          (define k1 (encode hd/s (car v)))
+          (define k2 (encode tl/s (cdr v)))
+          (+ (* 1/2 (+ k1 k2) (+ k1 k2 1)) k2))))
+
+(module+ test
+  (define cantor-2nats/s (cantor-cons/s nat/s nat/s))
+  (test-spec cantor-2nats/s)
+  (for ([i (in-range N)])
+    (test-en/de cantor-2nats/s
+                (cons (random (* N N))
+                      (random (* N N)))))
+  (let ()
+    ;; big-n has the digits you get by doing to the cantor
+    ;; pairing function using normal sqrt (via floats)
+    ;; and then finding the first number that goes wrong
+    ;; via repeated squaring (due to the imprecision of floats)
+    ;; and then concatenating that number's digits with itself
+    (define big-n
+      340282366920938463463374607431768211456340282366920938463463374607431768211456)
+    (test-en/de cantor-2nats/s (cons big-n big-n))))
+
+(define (or/s left? left/s right? right/s)
+  (match-define (spec left-k _ _) left/s)
+  (match-define (spec right-k _ _) right/s)
+  (match* (left-k right-k)
+    [(+inf.0 +inf.0)
+     (spec +inf.0
+           (λ (n)
+             (match (pair-hd 2 +inf.0 n)
+               [0
+                (decode left/s (pair-tl 2 +inf.0 n))]
+               [1
+                (decode right/s (pair-tl 2 +inf.0 n))]))
+           (λ (v)
+             (match v
+               [(? left?)
+                (pair 2 +inf.0 0 (encode left/s v))]
+               [(? right?)
+                (pair 2 +inf.0 1 (encode right/s v))])))]
+    [(+inf.0 right-k)
+     (or/s right? right/s left? left/s)]
+    [(left-k right-k)
+     (spec (+ left-k right-k)
+           (λ (n)
+             (if (< n left-k)
+               (decode left/s n)
+               (decode right/s (- n left-k))))
+           (λ (v)
+             (match v
+               [(? left?)
+                (encode left/s v)]
+               [(? right?)
+                (+ (encode right/s v) left-k)])))]))
+
+(module+ test
+  (define int/s
+    (or/s exact-nonnegative-integer? nat/s
+          negative? (wrap/s (wrap/s nat/s
+                                    (λ (n) (* -1 n))
+                                    (λ (n) (* -1 n)))
+                            (λ (n) (- n 1))
+                            (λ (n) (+ n 1)))))
+  (test-spec int/s)
+  (for ([i (in-range N)])
+    (test-en/de int/s
+                (if (zero? (random 2))
+                  (add1 (random (* N N)))
+                  (* -1 (add1 (random (* N N)))))))
+
+  (define weird-nat/s
+    (or/s (λ (i) (<= 0 i 3)) (enum/s '(0 1 2 3))
+          (λ (i) (< 3 i)) (wrap/s nat/s
+                                  (λ (n) (+ n 4))
+                                  (λ (n) (- n 4)))))
+  (test-spec weird-nat/s)
+  (for ([i (in-range N)])
+    (test-en/de weird-nat/s
+                (random (* N N))))
+
+  (define weird-nat/s-2
+    (or/s (λ (i) (< 3 i)) (wrap/s nat/s
+                                  (λ (n) (+ n 4))
+                                  (λ (n) (- n 4)))
+          (λ (i) (<= 0 i 3)) (enum/s '(0 1 2 3))))
+  (test-spec weird-nat/s-2)
+  (for ([i (in-range N)])
+    (test-en/de weird-nat/s-2
+                (random (* N N))))
+
+  (define weird-nat/s-3
+    (or/s (λ (i) (<= 0 i 3)) (enum/s '(0 1 2 3))
+          (λ (i) (<= 4 i 6)) (enum/s '(4 5 6))))
+  (test-spec weird-nat/s-3)
+  (for ([i (in-range N)])
+    (test-en/de weird-nat/s-3
+                (random 7))))
+
+(define (enum/s elems)
+  (define elem->i
+    (for/hash ([e (in-list elems)]
+               [i (in-naturals)])
+      (values e i)))
+  (spec (length elems)
+        (λ (n) (list-ref elems n))
+        (λ (v) (hash-ref elem->i v))))
+(define bool/s
+  (enum/s (list #f #t)))
+
+(module+ test
+  (define (test-enum/s os)
+    (define bool/s (enum/s os))
+
+    (test-spec bool/s)
+    (for ([x (in-list os)])
+      (test-en/de bool/s x))
+
+    (define b*b/s (cons/s bool/s bool/s))
+    (test-spec b*b/s)
+    (for* ([x (in-list os)]
+           [y (in-list os)])
+      (test-en/de b*b/s (cons x y)))
+
+    (define n*b/s (cons/s nat/s bool/s))
+    (test-spec n*b/s)
+    (for* ([x (in-range N)]
+           [y (in-list os)])
+      (test-en/de n*b/s (cons (random (* N N)) y)))
+
+    (define b*n/s (cons/s bool/s nat/s))
+    (test-spec b*n/s)
+    (for* ([y (in-range N)]
+           [x (in-list os)])
+      (test-en/de b*n/s (cons x (random (* N N))))))
+
+  (test-enum/s '(#f #t))
+  (test-enum/s '(0 1 2)))
+
+(define (flist/s k elem/s)
+  (match k
+    [0
+     (unit/s empty)]
+    [n
+     (cons/s elem/s (flist/s (sub1 k) elem/s))]))
+(module+ test
+  (test-spec-exs (flist/s 0 (enum/s '(0 1 2)))
+                 [empty 0])
+  (test-spec-exs (flist/s 1 (enum/s '(0 1 2)))
+                 [(cons 0 empty) 0]
+                 [(cons 1 empty) 1]
+                 [(cons 2 empty) 2])
+  (test-spec-exs (flist/s 2 (enum/s '(0 1 2)))
+                 [(cons 0 (cons 0 empty)) 0]
+                 [(cons 1 (cons 0 empty)) 1]
+                 [(cons 2 (cons 0 empty)) 2]
+
+                 [(cons 0 (cons 1 empty)) 3]
+                 [(cons 1 (cons 1 empty)) 4]
+                 [(cons 2 (cons 1 empty)) 5]
+
+                 [(cons 0 (cons 2 empty)) 6]
+                 [(cons 1 (cons 2 empty)) 7]
+                 [(cons 2 (cons 2 empty)) 8])
+
+  (define 3nats/s (flist/s 3 nat/s))
+  (test-spec 3nats/s)
+  (for ([i (in-range N)])
+    (test-en/de 3nats/s
+                (cons (random (* N N))
+                      (cons (random (* N N))
+                            (cons (random (* N N))
+                                  empty))))))
+
+(define (wrap/s inner/s wrap-in wrap-out)
+  (match-define (spec inner-k _ _) inner/s)
+  (spec inner-k
+        (λ (n) (wrap-in (decode inner/s n)))
+        (λ (v) (encode inner/s (wrap-out v)))))
+
+(define (hetero-vector/s vector-of-spec)
+  (define list-spec
+    (foldr (λ (elem/s s) (cons/s elem/s s))
+           (unit/s empty)
+           (vector->list vector-of-spec)))
+  (wrap/s list-spec list->vector vector->list))
+(module+ test
+  (define weird-vector/s
+    (hetero-vector/s
+     (vector (nat-range/s 2)
+             (nat-range/s 3)
+             (nat-range/s 4))))
+  (test-spec weird-vector/s)
+  (for ([i (in-range N)])
+    (test-en/de weird-vector/s
+                (vector (random 2)
+                        (random 3)
+                        (random 4)))))
+
+(define (bind/s fst/s fst->rst/s
+                #:count 
+                [given-count #f]
+                #:fst->rst/s-k
+                [given-fst->rst/s-k
+                 #f]
+                #:rst-always-inf?
+                [rst-always-inf? #f])
+  (define fst->rst/s-k
+    (or given-fst->rst/s-k
+        (λ (i)
+          (define fst (decode fst/s i))
+          (define rst/s (fst->rst/s fst))
+          (spec-k rst/s))))
+  (define fst-k (spec-k fst/s))
+  (cond 
+    [rst-always-inf?
+     (spec (* fst-k +inf.0)
+           (λ (n)
+             (define fst-n
+               (pair-hd fst-k +inf.0 n))
+             (define fst 
+               (decode fst/s fst-n))
+             (define rst/s (fst->rst/s fst))
+             (define rst-n
+               (pair-tl fst-k +inf.0 n))
+             (define rst
+               (decode rst/s rst-n))
+             (cons fst rst))
+           (λ (v)
+             (match-define (cons fst rst) v)
+             (define rst/s (fst->rst/s fst))             
+             (pair fst-k +inf.0
+                   (encode fst/s fst)
+                   (encode rst/s rst))))]
+    [else
+     (define (check-rst-k! rst-k)
+       (when (= +inf.0 rst-k)
+         (error 'bind/s 
+                "rst/s not always inf, but ever inf not supported")))
+     (define count
+       (cond
+         [given-count
+          given-count]
+         [(= +inf.0 fst-k)
+          ;; XXX This is not actually correct if (sum (forall (f) (spec-k
+          ;; (fst->rst/s f)))) is finite, such as when the rst is always
+          ;; empty except a finite number of times, etc.
+          +inf.0]
+         [else
+          (for/fold ([total 0])
+              ([i (in-range fst-k)])
+            (define rst-k
+              (fst->rst/s-k i))
+            (check-rst-k! rst-k)
+            (+ total rst-k))]))
+
+     (define (bind-in i n)
+       (define fst (decode fst/s i))
+       (define rst/s (fst->rst/s fst))
+       (define rst-k (spec-k rst/s))
+       (check-rst-k! rst-k)
+       (cond
+         [(>= n rst-k)
+          (bind-in (add1 i) (- n rst-k))]
+         [else
+          (cons fst (decode rst/s n))]))
+     (define (bind-out-sum i)
+       (cond
+         [(< i 0)
+          0]
+         [else
+          (define fst (decode fst/s i))
+          (define rst/s (fst->rst/s fst))
+          (define rst-k (spec-k rst/s))
+          (check-rst-k! rst-k)
+          (+ rst-k (bind-out-sum (sub1 i)))]))
+
+     (spec count
+           (λ (n) (bind-in 0 n))
+           (λ (v)
+             (define fst (car v))
+             (define fst-n (encode fst/s fst))
+             (define rst/s (fst->rst/s fst))
+             (check-rst-k! (spec-k rst/s))
+             (+ (bind-out-sum (sub1 fst-n))
+                (encode rst/s (cdr v)))))]))
+
+(define (k*k-bind/s fst/s fst->rst/s
+                    #:count [count #f]
+                    #:rst-k [given-rst-k #f])
+  (bind/s fst/s fst->rst/s
+          #:count count
+          #:fst->rst/s-k
+          (and given-rst-k
+               (λ (i) given-rst-k))))
+
+(module+ test  
+  (let ()
+    (define outer-s
+      (nat-range/s 3))
+    (define ex-s
+      (k*k-bind/s outer-s
+                  (λ (i)
+                    (define inner-s
+                      (nat-range/s (+ i 1)))                    
+                    inner-s)))
+    (check-equal?
+     (for/list ([i (in-range (spec-k ex-s))])
+       (decode ex-s i))
+     '((0 . 0)
+       (1 . 0)
+       (1 . 1)
+       (2 . 0)       
+       (2 . 1)
+       (2 . 2))))
+
+  (define 3+less-than-three/s
+    (k*k-bind/s (enum/s '(0 1 2 3)) (λ (i) (nat-range/s (add1 i)))))
+  (test-spec
+   3+less-than-three/s)
+  (test-spec-exs
+   3+less-than-three/s
+   [(cons 0 0) 0]
+   [(cons 1 0) 1]
+   [(cons 1 1) 2]
+   [(cons 2 0) 3]
+   [(cons 2 1) 4]
+   [(cons 2 2) 5]
+   [(cons 3 0) 6]
+   [(cons 3 1) 7]
+   [(cons 3 2) 8]
+   [(cons 3 3) 9]))
+
+(define (k*k-bind2/s fst/s fst->rst/s
+                     #:count [count #f]
+                     #:rst-k [given-rst-k #f])
+  ;; XXX check
+  (match-define (spec fst-k _ _) fst/s)
+  
+  (define size-table (make-hash))
+  (define total-size 0)
+  (define subs
+    (for/list ([i (in-range fst-k)])
+      (define fst (decode fst/s i))
+      (define sub (fst->rst/s fst))
+      (define size (spec-k sub))
+      (hash-set! size-table fst total-size)
+      (set! total-size (+ total-size size))
+      sub))
+  (spec total-size
+        (λ (n)
+          (let loop ([subs subs]
+                     [n n]
+                     [i 0])
+            (define sub (car subs))
+            (define sub-k (spec-k sub))
+            (cond
+              [(< n sub-k)
+               (define fst (decode fst/s i))
+               (define rst/s (fst->rst/s fst))
+               (match-define (spec rst-k _ _) rst/s)
+               (cons fst (decode rst/s n))]
+              [else
+               (loop (cdr subs) (- n (spec-k sub)) (+ i 1))])))
+        (λ (v)
+          (match-define (cons fst rst) v)
+          (define rst/s (fst->rst/s fst))
+          (match-define (spec rst-k _ _) rst/s)
+          (+ (hash-ref size-table fst) (encode rst/s rst)))))
+
+(module+ test
+  (define 3+less-than-three2/s
+    (k*k-bind2/s (enum/s '(0 1 2 3)) (λ (i) (nat-range/s (add1 i)))))
+  (test-spec
+   3+less-than-three2/s)
+  (test-spec-exs
+   3+less-than-three2/s
+   [(cons 0 0) 0]
+   [(cons 1 0) 1]
+   [(cons 1 1) 2]
+   [(cons 2 0) 3]
+   [(cons 2 1) 4]
+   [(cons 2 2) 5]
+   [(cons 3 0) 6]
+   [(cons 3 1) 7]
+   [(cons 3 2) 8]
+   [(cons 3 3) 9]))
+
+(define (k*inf-bind/s fst/s fst->rst/s)
+  (bind/s fst/s fst->rst/s
+          #:rst-always-inf? #t))
+(module+ test
+  (define 3+more-than-three/s
+    (k*inf-bind/s (enum/s '(0 1 2 3))
+                  (λ (i)
+                    (wrap/s nat/s
+                            (λ (out) (+ out i))
+                            (λ (in) (- in i))))))
+  (test-spec
+   3+more-than-three/s)
+  (test-spec-exs
+   3+more-than-three/s
+   [(cons 0 0) 0]
+   [(cons 1 1) 1]
+   [(cons 2 2) 2]
+   [(cons 2 3) 6]
+   [(cons 3 3) 3]))
+
+;; XXX Add an optional function arg that tells you how many elements
+;; there are for each n
+(define (inf*k-bind/s fst/s fst->rst/s)
+  (bind/s fst/s fst->rst/s))
+
+(module+ test
+  (define nat+less-than-n/s
+    (inf*k-bind/s nat/s (λ (i) (nat-range/s (add1 i)))))
+  (test-spec-exs
+   nat+less-than-n/s
+   [(cons 0 0) 0]
+   [(cons 1 0) 1]
+   [(cons 1 1) 2]
+   [(cons 2 0) 3]
+   [(cons 2 1) 4]
+   [(cons 2 2) 5]
+   [(cons 3 0) 6]
+   [(cons 3 1) 7]
+   [(cons 3 2) 8]
+   [(cons 3 3) 9]))
+
+(define (inf*inf-bind/s fst/s fst->rst/s)
+  (bind/s fst/s fst->rst/s
+          #:rst-always-inf? #t))
+(module+ test
+  (define nat+greater-than-n/s
+    (inf*inf-bind/s
+     nat/s (λ (i)
+             (wrap/s nat/s
+                     (λ (out) (+ out i))
+                     (λ (in) (- in i))))))
+  (test-spec nat+greater-than-n/s))
+
+;; XXX
+;; (define (union/s pred->spec)
+;;   (define pred/s (enum/s (hash-keys pred->spec)))
+;;   (wrap/s
+;;    (bind/s pred/s (λ (pred) ((hash-ref pred->spec pred))))
+;;    (λ (de) (cdr de))
+;;    (λ (en) (cons (for/or ([pred (in-hash-keys pred->spec)])
+;;                    (and (pred en)
+;;                         pred))
+;;                  en))))
+
+;; (define (union-list/s elem/s)
+;;   (define this/s
+;;     (union/s (hash empty? (λ () (unit/s empty))
+;;                    cons? (λ () (cons/s elem/s this/s)))))
+;;   this/s)
+
+(define (flist-prep/s inner/s)
+  (wrap/s
+   inner/s
+   (λ (v) (cdr v))
+   (λ (l) (cons (length l) l))))
+
+(define nat-greater-than-1/s
+  (wrap/s nat/s
+          (λ (out) (+ out 1))
+          (λ (in) (- in 1))))
+
+(define (nelist/s elem/s)
+  (define f-elem-list/s
+    (λ (len) (flist/s len elem/s)))
+  (cond
+    [(= +inf.0 (spec-k elem/s))
+     (flist-prep/s
+      (inf*inf-bind/s
+       nat-greater-than-1/s
+       f-elem-list/s))]
+    [else
+     (flist-prep/s
+      (inf*k-bind/s
+       nat-greater-than-1/s f-elem-list/s))]))
+
+(define (bind-list/s elem/s)
+  (define f-elem-list/s
+    (λ (len) (flist/s len elem/s)))
+  (cond
+    [(= +inf.0 (spec-k elem/s))
+     (or/s empty?
+           (unit/s empty)
+           cons?
+           (flist-prep/s
+            (inf*inf-bind/s
+             nat-greater-than-1/s
+             f-elem-list/s)))]
+    [else
+     (flist-prep/s
+      (inf*k-bind/s
+       nat/s f-elem-list/s))]))
+
+(define list/s bind-list/s)
+
+(module+ test
+  (define 012-list/s (list/s (enum/s '(0 1 2))))
+  (test-spec 012-list/s)
+  (for ([i (in-range N)])
+    (test-en/de 012-list/s
+                (build-list (random (* N N))
+                            (λ (_) (random 3)))))
+
+  (define nat-list/s (list/s nat/s))
+  (test-spec nat-list/s)
+  (for ([i (in-range N)])
+    (test-en/de nat-list/s
+                (build-list (random (* N N))
+                            (λ (_) (random (* N N)))))))
+
+
+;; XXX
+(define (spec/c result/c)
+  spec?)
+
+;; XXX
+(provide (all-defined-out))
+
+(module+ main
+  (let ([np/s (cons/s (nat-range/s 4) (nat-range/s 4))])
+    (define (number->bits n)
+      (reverse
+       (let loop ([n n])
+         (cond
+           [(zero? n) '()]
+           [(odd? n) (cons 1 (loop (/ (- n 1) 2)))]
+           [(even? n) (cons 0 (loop (/ n 2)))]))))
+    (define (f p)
+      (+ (length (number->bits (car p)))
+         (length (number->bits (cdr p)))))
+    (for/list ([i (in-range 16)])
+      (f (decode np/s i)))))

collects/games/tally-maze/info.rkt

@@ -0,0 +1,4 @@
+#lang setup/infotab
+
+(define game-set "Puzzle Games")
+(define game "game.rkt")

collects/games/tally-maze/maze.rkt

@@ -0,0 +1,495 @@
+#lang racket/base
+
+(require "godel.rkt" 
+         racket/gui/base
+         racket/class
+         racket/set
+         racket/list)
+(module+ test (require rackunit))
+
+(provide pick-a-maze
+         draw-maze 
+         build-walls
+         decode-maze
+         maze/s)
+
+(define (decode-maze maze-w maze-h n)
+  (define mazes (maze/s maze-w maze-h))
+  (unless (and (exact-nonnegative-integer? n)
+               (< n (spec-k mazes)))
+    (raise-argument-error 'decode-maze 
+                          (format "number less than ~a" (spec-k mazes))
+                          n))
+    (decode mazes n))
+
+(define (memoize f)
+  (define ht (make-hash))
+  (λ args
+    (hash-ref 
+     ht args
+     (λ ()
+       (hash-set! ht args (apply f args))
+       (hash-ref ht args)))))
+
+(define maze/s 
+  (memoize
+   (λ (width height)
+     (cond
+       [(or (= 1 height) (= 1 width)) (unit/s #f)]
+       [else
+        (k*k-bind/s
+         (wrap/s (fixed-length-list/s
+                  (enum/s '(l t r b))
+                  (wrap/s (nat-range/s (- height 1)) add1 sub1)
+                  (wrap/s (nat-range/s (- width 1)) add1 sub1))
+                 reverse reverse)
+         (λ (ul-w/h-and-break)
+           (define ul-w (list-ref ul-w/h-and-break 0))
+           (define ul-h (list-ref ul-w/h-and-break 1))
+           (define missing (list-ref ul-w/h-and-break 2))
+           (define lr-w (- width ul-w))
+           (define lr-h (- height ul-h))
+           (fixed-length-list/s
+            
+            (case missing
+              [(l)
+               (fixed-length-list/s (unit/s #f)
+                                    (nat-range/s ul-h)
+                                    (nat-range/s lr-w)
+                                    (nat-range/s lr-h))]
+              [(t)
+               (fixed-length-list/s (nat-range/s ul-w)
+                                    (unit/s #f)
+                                    (nat-range/s lr-w)
+                                    (nat-range/s lr-h))]
+              [(r)
+               (fixed-length-list/s (nat-range/s ul-w)
+                                    (nat-range/s ul-h)
+                                    (unit/s #f)
+                                    (nat-range/s lr-h))]
+              [(b)
+               (fixed-length-list/s (nat-range/s ul-w)
+                                    (nat-range/s ul-h)
+                                    (nat-range/s lr-w)
+                                    (unit/s #f))])
+            
+            (maze/s ul-w ul-h)
+            (maze/s lr-w ul-h)
+            (maze/s ul-w lr-h)
+            (maze/s lr-w lr-h))))]))))
+
+(define (fixed-length-list/s . args)
+  (let loop ([args args])
+    (cond
+      [(null? args) (unit/s '())]
+      [else (cons/s (car args) (loop (cdr args)))])))
+
+(define (pick-a-maze maze-w maze-h)
+  (define maze-count (spec-k (maze/s maze-w maze-h)))
+  (define digits (max 1 (- (string-length (number->string maze-count)) 1)))
+  (string->number
+   (apply
+    string-append
+    (for/list ([i (in-range digits)])
+      (format "~a"
+              (if (= i 0)
+                  (+ (random 9) 1)
+                  (random 10)))))))
+
+(define (draw-maze dc dx dy w h edges maze-w maze-h 
+                   #:next-edges [next-edges #f] 
+                   #:solution [solution #f]
+                   #:images [images '()])
+  (define cell-size (min (/ w (+ maze-w 1/2)) (/ h (+ maze-h 1/2))))
+  (define wall-pen-size (max 2 (ceiling (/ cell-size 6))))
+  (define tot-maze-w (* cell-size maze-w))
+  (define tot-maze-h (* cell-size maze-h))
+  (define x-margin (/ (- w tot-maze-w) 2))
+  (define y-margin (/ (- h tot-maze-h) 2))
+  (define (mx->dcx mx) (+ (* mx cell-size) x-margin))
+  (define (my->dcy my) (+ (* my cell-size) y-margin))
+  
+  #;
+  (begin
+    (define start-distances (find-distances (cons 0 0) edges))
+    (define end-distances (find-distances (cons (- maze-w 1) (- maze-h 1)) edges))
+    (for* ([x (in-range maze-w)]
+           [y (in-range maze-h)])
+      (define k (cons x y))
+      (define ds (hash-ref start-distances k))
+      (define de (hash-ref end-distances k))
+      (define color (cond
+                      [(= ds de) "white"]
+                      [(< ds de) "Khaki"]
+                      [(> ds de) "Lavender"]))
+      (define dx (mx->dcx x))
+      (define dy (my->dcy y))
+      (send dc set-pen color 1 'transparent)
+      (send dc set-brush color 'solid)
+      (send dc draw-rectangle dx dy cell-size cell-size)))
+  
+  (send dc set-pen "lightblue" 1 'solid)
+  (for ([x (in-range 1 maze-w)])
+    (define e (mx->dcx x))
+    (send dc draw-line (+ dx e) (+ dy y-margin) (+ dx e) (+ dy y-margin tot-maze-h)))
+  (for ([y (in-range 1 maze-h)])
+    (define e (my->dcy y))
+    (send dc draw-line (+ dx x-margin) (+ dy e) (+ dx x-margin tot-maze-w) (+ dy e)))
+  
+  (send dc set-pen "black" wall-pen-size 'solid)
+  (send dc draw-line
+        (+ dx x-margin) (+ dy y-margin cell-size)
+        (+ dx x-margin) (+ dy y-margin tot-maze-h))
+  (send dc draw-line 
+        (+ dx x-margin cell-size) (+ dy y-margin)
+        (+ dx x-margin tot-maze-w) (+ dy y-margin))
+  (send dc draw-line  
+        (+ dx x-margin) (+ dy y-margin tot-maze-h)
+        (+ dx x-margin tot-maze-w (- cell-size)) (+ dy y-margin tot-maze-h))
+  (send dc draw-line
+        (+ dx x-margin tot-maze-w) (+ dy y-margin)
+        (+ dx x-margin tot-maze-w) (+ dy y-margin tot-maze-h (- cell-size)))
+  
+  (define (connect x1 y1 x2 y2)
+    (unless (and (= x1 x2)
+                 (= y1 y2))
+      (send dc draw-line 
+            (+ dx (mx->dcx x1))
+            (+ dy (my->dcy y1))
+            (+ dx (mx->dcx x2))
+            (+ dy (my->dcy y2)))))
+
+  (for ([(from neighbors) (in-hash edges)])
+    (define from-x (car from))
+    (define from-y (cdr from))
+    (define (try to-x to-y)
+      (when (<= 0 to-x (- maze-w 1))
+        (when (<= 0 to-y (- maze-h 1))
+          (define k (cons to-x to-y))
+          (unless (set-member? neighbors k)
+            (send dc set-pen "black"
+                  wall-pen-size
+                  'solid)
+            (cond
+              [(= from-x to-x)
+               (connect from-x
+                        to-y
+                        (+ from-x 1)
+                        to-y)]
+              [(= from-y to-y)
+               (connect to-x
+                        to-y
+                        to-x
+                        (+ to-y 1))])))))
+    (try (+ from-x 1) from-y)
+    (try from-x (+ from-y 1)))
+  
+  (when solution
+    (send dc set-pen "red" wall-pen-size 'solid)
+    (for ([solution1 (in-list solution)]
+          [solution2 (in-list (cdr solution))])
+      (connect (+ (car solution1) 1/2)
+               (+ (cdr solution1) 1/2)
+               (+ (car solution2) 1/2)
+               (+ (cdr solution2) 1/2))))
+  
+  (for ([image (in-list images)])
+    (define-values (icons x y) (apply values image))
+    (define icon (or (for/or ([icon (in-list icons)])
+                       (and (<= (send icon get-width) cell-size)
+                            (<= (send icon get-height) cell-size)
+                            icon))
+                     (last icons)))
+    (send dc draw-bitmap 
+          icon
+          (+ dx (mx->dcx x) (/ (- cell-size (send icon get-width)) 2))
+          (+ dy (my->dcy y) (/ (- cell-size (send icon get-height)) 2)))))
+
+(define (find-solution edges maze-w maze-h)
+  (define start (cons 0 0))
+  (define end (cons (- maze-w 1) (- maze-h 1)))
+  (define visited (make-hash))
+  (let loop ([node start])
+    (cond
+      [(equal? node end) (list end)]
+      [(hash-ref visited node #f) #f]
+      [else
+       (hash-set! visited node #t)
+       (define neighbor-ans
+         (for/or ([neighbor (in-set (hash-ref edges node))])
+           (loop neighbor)))
+       (and neighbor-ans
+            (cons node neighbor-ans))])))
+
+(define (find-distances end edges)
+  (define distances (make-hash))
+  (let loop ([node end]
+             [distance 0])
+    (cond
+      [(hash-ref distances node #f) (void)]
+      [else
+       (hash-set! distances node distance)
+       (for ([neighbor (in-set (hash-ref edges node))])
+         (loop neighbor
+               (+ distance 1)))]))
+  distances)
+
+(define (build-walls maze-spec maze-w maze-h)
+  (define edges (make-hash))
+  
+  (define (add-edge! x1 y1 x2 y2)
+    (add->edge! x1 y1 x2 y2)
+    (add->edge! x2 y2 x1 y1))
+  (define (add->edge! x1 y1 x2 y2)
+    (define k (cons x1 y1))
+    (hash-set! edges k (set-add (hash-ref edges k (set)) (cons x2 y2))))
+  
+  
+  (define (remove-edge! x1 y1 x2 y2)
+    (remove->edge! x1 y1 x2 y2)
+    (remove->edge! x2 y2 x1 y1))
+  (define (remove->edge! x1 y1 x2 y2)
+    (define k (cons x1 y1))
+    (define new-edges (set-remove (hash-ref edges k) (cons x2 y2)))
+    (hash-set! edges k new-edges))
+  
+  (for* ([x (in-range 0 maze-w)]
+         [y (in-range 0 maze-h)])
+    (unless (zero? x)
+      (add-edge! x y (- x 1) y))
+    (unless (zero? y)
+      (add-edge! x y x (- y 1))))
+  
+  ;; draws a line between (x1,y1) and (x2,y2)
+  ;; which removes some edges
+  (define (connect x1 y1 x2 y2)
+    (let loop ([x1 (min x1 x2)]
+               [y1 (min y1 y2)]
+               [x2 (max x1 x2)]
+               [y2 (max y1 y2)])
+      (cond
+        [(and (= x1 x2) (= y1 y2))
+         (void)]
+        [(= x1 x2)
+         (remove-edge! (- x1 1) y1 x1 y1)
+         (loop x1 (+ y1 1) x1 y2)]
+        [(= y1 y2)
+         (remove-edge! x1 (- y1 1) x1 y1)
+         (loop (+ x1 1) y1 x2 y2)]
+        [else 
+         (error 'connect "ack ~s => ~s\n" (cons x1 y1) (cons x2 y2))])))
+  
+  (define (draw-horizontal-line line-break width x-start y-start)
+    (cond
+      [line-break
+       (connect x-start y-start (+ x-start line-break) y-start)
+       (connect (+ x-start line-break 1) y-start (+ x-start width) y-start)]
+      [else
+       (connect x-start y-start (+ x-start width) y-start)]))
+  
+  (define (draw-vertical-line line-break height x-start y-start)
+    (cond
+      [line-break
+       (connect x-start y-start x-start (+ y-start line-break))
+       (connect x-start (+ y-start line-break 1) x-start (+ y-start height))]
+      [else
+       (connect x-start y-start x-start (+ y-start height))]))
+  
+  (let loop ([maze maze-spec]
+             [x 0]
+             [y 0]
+             [maze-w maze-w]
+             [maze-h maze-h])
+    (when maze
+      (define sub-maze-info (list-ref maze 0))
+      (define ul-w (list-ref sub-maze-info 0))
+      (define ul-h (list-ref sub-maze-info 1))
+      (define lr-w (- maze-w ul-w))
+      (define lr-h (- maze-h ul-h))
+      
+      (define line-break-info (list-ref maze 1))
+      (define-values (lb-left lb-top lb-right lb-bottom) (apply values line-break-info))
+      (draw-horizontal-line lb-left   ul-w x          (+ y ul-h))
+      (draw-vertical-line   lb-top    ul-h (+ x ul-w) y)
+      (draw-horizontal-line lb-right  lr-w (+ x ul-w) (+ y ul-h))
+      (draw-vertical-line   lb-bottom lr-h (+ x ul-w) (+ y ul-h))
+      (define ul-submaze (list-ref maze 2))
+      (define ur-submaze (list-ref maze 3))
+      (define ll-submaze (list-ref maze 4))
+      (define lr-submaze (list-ref maze 5))
+      
+      (loop ul-submaze x          y          ul-w ul-h)
+      (loop ur-submaze (+ x ul-w) y          lr-w ul-h)
+      (loop ll-submaze x          (+ y ul-h) ul-w lr-h)
+      (loop lr-submaze (+ x ul-w) (+ y ul-h) lr-w lr-h)))  
+  edges)
+
+(module+ test
+  
+  (check-equal?
+   (build-walls '((1 1 t) (0 #f 0 0) #f #f #f #f) 2 2)
+   (make-hash 
+    (list (cons '(0 . 0) (set '(0 . 1)))
+          (cons '(0 . 1) (set '(0 . 0) '(1 . 1)))
+          (cons '(1 . 0) (set '(1 . 1)))
+          (cons '(1 . 1) (set '(0 . 1) '(1 . 0))))))
+  
+  (check-equal?
+   (build-walls 
+    '((1 2 b) (0 1 1 #f) #f ((1 1 l) (#f 0 0 0) #f #f #f #f) #f #f)
+    3
+    3)
+   (make-hash 
+    (list (cons '(0 . 0) (set '(0 . 1)))
+          (cons '(0 . 1) (set '(0 . 0) '(1 . 1) '(0 . 2)))
+          (cons '(0 . 2) (set '(0 . 1)))
+          (cons '(1 . 0) (set '(2 . 0)))
+          (cons '(1 . 1) (set '(0 . 1) '(2 . 1)))
+          (cons '(1 . 2) (set '(2 . 2)))
+          (cons '(2 . 0) (set '(1 . 0) '(2 . 1)))
+          (cons '(2 . 1) (set '(2 . 0) '(2 . 2) '(1 . 1)))
+          (cons '(2 . 2) (set '(2 . 1) '(1 . 2))))))
+  
+  (check-equal?
+   (build-walls '((2 2 l) (#f 0 0 0) ((1 1 l) (#f 0 0 0) #f #f #f #f) #f #f #f)
+                3 3)
+   (make-hash 
+    (list (cons '(0 . 0) (set '(1 . 0)))
+          (cons '(0 . 1) (set '(1 . 1)))
+          (cons '(0 . 2) (set '(1 . 2)))
+          (cons '(1 . 0) (set '(0 . 0) '(1 . 1) '(2 . 0)))
+          (cons '(1 . 1) (set '(0 . 1) '(1 . 0)))
+          (cons '(1 . 2) (set '(0 . 2) '(2 . 2)))
+          (cons '(2 . 0) (set '(1 . 0) '(2 . 1)))
+          (cons '(2 . 1) (set '(2 . 0) '(2 . 2)))
+          (cons '(2 . 2) (set '(2 . 1) '(1 . 2)))))))
+
+(define (show-mazes)
+  
+  ;(define maze-w 34) (define maze-h 44)
+  (define maze-w 20) (define maze-h 20)
+  ;(define maze-w 2) (define maze-h 3)
+  ;(define maze-w 16) (define maze-h 16)
+  ;(define maze-w 8) (define maze-h 8)
+  
+  (define mazes (time (maze/s maze-w maze-h)))
+  (define maze-count (spec-k mazes))
+  (printf "~a mazes\n" maze-count)
+  
+  (define slider-max-value (min maze-count 10000))
+  (define max-starting-point (- maze-count slider-max-value))
+  (define starting-point (pick-a-maze maze-w maze-h))
+  (define f (new frame% [label ""] [width 400] [height 400]))
+  
+  (define current-solution #f)
+  (define current-edges #f)
+  (define next-edges #f)
+  (define which 0)
+  
+  (define c (new canvas% [parent f] 
+                 [paint-callback
+                  (λ (c dc) 
+                    (send dc set-smoothing 'smoothed)
+                    (define-values (w h) (send c get-client-size))
+                    (draw-maze dc w h current-edges maze-w maze-h 
+                               #:next-edges next-edges 
+                               #:solution current-solution))]))
+  (define bp (new horizontal-panel% [parent f] [stretchable-height #f]))
+  (define (move-to n)
+    (set! which (modulo n maze-count))
+    (set! current-edges (build-walls (decode mazes which) maze-w maze-h))
+    (set! current-solution (find-solution current-edges maze-w maze-h))
+    (set! next-edges (build-walls (decode mazes (modulo (+ which 1) maze-count))
+                                  maze-w maze-h))
+    (send slider set-value (- which starting-point))
+    (send c refresh))
+  
+  (define slider 
+    (new slider%
+         [label #f]
+         [min-value 0]
+         [max-value slider-max-value]
+         [parent bp]
+         [callback
+          (λ args
+            (move-to (+ starting-point (send slider get-value))))]))
+  (define tf (new text-field% 
+                  [label "Starting point"]
+                  [parent f]
+                  [stretchable-width #t]
+                  [init-value ""]
+                  [callback
+                   (λ args
+                     (define n (string->number (send tf get-value)))
+                     (define n-ok? (and n (<= n max-starting-point)))
+                     (send tf set-field-background
+                           (send the-color-database find-color
+                                 (if n-ok? "white" "pink")))
+                     (when n-ok?
+                       (set! starting-point n)
+                       (move-to starting-point)))]))
+  
+  (send tf set-value (format "~a" starting-point))
+  (define (mk-b lab adj)
+    (new button% 
+         [parent bp]
+         [label lab]
+         [callback
+          (λ args
+            (move-to (adj which)))]))
+  (mk-b "Next" add1)
+  (mk-b "Previous" sub1)
+  (new button%
+       [parent bp]
+       [label "Random"]
+       [callback
+        (λ args
+          (set! starting-point (pick-a-maze maze-w maze-h))
+          (send tf set-value (format "~a" starting-point))
+          (move-to starting-point))])
+  
+  (define run? #f)
+  (define timer
+    (new timer%
+         [notify-callback
+          (λ () (move-to (+ which 1)))]))
+  
+  (define run/stop-button
+    (new button% 
+         [label "Run"]
+         [parent f]
+         [stretchable-width #t]
+         [callback
+          (λ args
+            (send run/stop-button set-label 
+                  (if run? "Run" "Stop"))
+            (set! run? (not run?))
+            (if run?
+                (send timer start 100)
+                (send timer stop)))]))
+  (move-to starting-point)
+  (send f show #t))
+
+;(module+ main (show-mazes))
+(module+ main
+  (define chan (make-channel))
+  (collect-garbage) (collect-garbage) (collect-garbage) 
+  (collect-garbage) (collect-garbage) (collect-garbage)
+  (void
+   (thread
+    (λ ()
+      (let loop ([m (current-memory-use)])
+        (sync
+         (handle-evt
+          (alarm-evt (+ (current-inexact-milliseconds) 100))
+          (λ (_) (loop (max m (current-memory-use)))))
+         
+         (handle-evt
+          chan
+          (λ (c)
+            (channel-put c m))))))))
+  (void (time (maze/s 20 20)))
+  (let ([c (make-channel)])
+    (channel-put chan c)
+    (printf "peak mem use ~ak\n" (round (/ (channel-get c) 1024)))))
+