#!/bin/sh
#|
exec mred -r "$0" "$@"
|#

;; Written by Eli Barzilay: Maze is Life! (eli@barzilay.org)

;;;============================================================================

(define *xcells-default* 20)
(define *ycells-default* 20)
(let ((n (box 0)))
  (when (get-resource "mazer" "default-width" n)
    (set! *xcells-default* (unbox n)))
  (when (get-resource "mazer" "default-height" n)
    (set! *ycells-default* (unbox n))))

(define *fg-color* "BLACK")

(define *bg-colors*
  `((192 192 192) ; #f -- doesn't work well
    ( 64 128  64)
    (128  64  64)
    ( 64  64 128)
    (255   0 255)
    (  0 255 255)
    (255 255   0)
    (  0 255   0)
    (255   0   0)
    (  0   0 255)
    ;; colors below are used for the maze solution
    (128 192 128)
    (192 128 128)
    (128 128 192)
    (192 128 192)
    (128 192 192)
    (192 192 128)
    (192 255 192)
    (255 192 192)
    (192 192 255)
    (255 192 255)
    (192 255 255)
    (255 255 192)
    (128 255 128)
    (255 128 128)
    (128 128 255)
    (255 128 255)
    (128 255 255)
    (255 255 128)))

(define *ps-margin* 10)


;;;============================================================================

(require (lib "list.ss"))
(require (lib "etc.ss"))
(require (lib "process.ss"))

(define-syntax thunk
  (syntax-rules () ((_ body ...) (lambda () body ...))))
(define-syntax fluid-let*
  (syntax-rules ()
    ((_ () body ...) (begin body ...))
    ((_ ((var val) . more) body ...)
     (fluid-let ((var val)) (fluid-let* more body ...)))))


;;;============================================================================


(define-struct cell (state walls) #:mutable)

(define (make-empty-cell)
  (make-cell 1 '(l t)))

(define-syntax get-cell
  (syntax-rules ()
    ((_ maze x y) (vector-ref (vector-ref maze x) y))))

(define (for-all-cells maze f)
  (do ((x 0 (add1 x))) ((= x (vector-length maze)))
    (let ((col (vector-ref maze x)))
      (do ((y 0 (add1 y))) ((= y (vector-length col)))
        (f (vector-ref col y) x y)))))

(define (make-maze xc yc)
  (let* ((maze (build-vector xc
                 (lambda (i) (build-vector yc (lambda (j) (make-empty-cell))))))
         (f (lambda (x y w)
              (let ((c (get-cell maze x y)))
                (set-cell-state! c 0)
                (set-cell-walls! c (if w (list w) '()))))))
    (do ((x 1 (add1 x))) ((= x (sub1 xc)))
      (f x 0 #f)
      (f x (sub1 yc) 't))
    (do ((y 1 (add1 y))) ((= y (sub1 yc)))
      (f 0 y #f)
      (f (sub1 xc) y 'l))
    (f 0 0 #f)
    (f (sub1 xc) 0 #f)
    (f 0 (sub1 yc) #f)
    (f (sub1 xc) (sub1 yc) #f)
    maze))


;;;============================================================================

(define macro-frame%
  (class dialog%
    (init-field mazer)
    (inherit show)
    (define recording?    #f)
    (define key-name      #f)
    (define record-button #f)
    (define abort-button  #f)
    (define current-key   #f)
    (define (record-op . abort?)
      (cond
       ((and (not (null? abort?)) (car abort?) recording?)
        (set! recording? #f)
        (send mazer start/end-macro #f)
        (send record-button set-label "Start Recording"))
       ((and (not (null? abort?)) (car abort?)) (show #f))
       ((send record-button is-enabled?)
        (set! recording? (not recording?))
        (send mazer start/end-macro current-key)
        (send record-button set-label
              (if recording? "Stop Recording" "Start Recording"))
        (send abort-button enable recording?)
        (unless recording? (show #f)))))
    (define/override (on-subwindow-char w e)
      (let* ((ch  (send e get-key-code))
             (S   (send e get-shift-down))
             (C   (send e get-control-down))
             (M   (send e get-meta-down))
             (key (list ch S C M)))
        (cond
         ((eq? ch 'release) #f)
         ((equal? key '(#\return #f #f #f)) (record-op))
         ((equal? key '(escape #f #f #f)) (record-op #t))
         (recording? (send mazer on-char e))
         (else
          (set! current-key key)
          (send key-name set-label
                (format "Key: ~a~a~a~a~a"
                        (if S "S-" "") (if C "C-" "") (if M "M-" "")
                        (if (eq? ch #\nul)
                          ""
                          (caddr (regexp-match (regexp "(#\\\\)?(.*)")
                                               (format "~s" ch))))
                        (if (send mazer key-bound? current-key)
                          " (bound)"
                          "")))
          (send record-button enable (not (eq? ch #\nul)))))))
    (super-instantiate ("Macro" (send mazer get-parent)))
    (set! key-name
          (make-object message% "Hit a key...                  " this))
    (set! record-button
          (make-object button% "Start Recording" this
                       (lambda (b e) (record-op))))
    (set! abort-button
          (make-object button% "Abort Recording" this
                       (lambda (b e) (record-op #t))))
    (send record-button enable #f)
    (send abort-button enable #f)))


;;;============================================================================

(define mazer%
  (class canvas%
    (inherit get-dc min-client-width min-client-height
             stretchable-width stretchable-height popup-menu)
    (define frame #f)
    (define macro-frame #f)
    (define ycells      #f)
    (define xcells      #f)
    (define cell-size   #f)
    (define line-width  #f)
    (define fg-pen      #f)
    (define no-pen      #f)
    (define cr-pen      #f)
    (define bl-brush
      (make-object brush% *fg-color* 'xor))
    (define bg-brushes
      (build-vector
       (length *bg-colors*)
       (lambda (n)
         (let ((rgb (list-ref *bg-colors* n)))
           (send the-brush-list find-or-create-brush
                 (if rgb (apply make-object color% rgb) (get-panel-background))
                 'solid)))))
    (define the-maze #f)
    (define (draw-cell-bg c x y)
      (let ((x (* x cell-size)) (y (* y cell-size)))
        (send* back-dc
          (set-brush (vector-ref bg-brushes (max 0 (cell-state c))))
          (draw-rectangle x y cell-size cell-size))))
    (define (draw-cell-walls c x y . rest)
      (let* ((walls (cell-walls c))
             (x1 (* x  cell-size)) (y1 (* y  cell-size))
             (x2 (+ x1 cell-size)) (y2 (+ y1 cell-size)))
        (when (memq 'l walls) (send back-dc draw-line x1 y1 x1 y2))
        (when (memq 't walls) (send back-dc draw-line x1 y1 x2 y1))
        (when (and (not (null? rest)) (car rest))
          (unless (= x 0)
            (unless (= y 0) (send back-dc draw-line x1 y1 x1 y1))
            (unless (= y (sub1 ycells)) (send back-dc draw-line x1 y2 x1 y2)))
          (unless (= x (sub1 xcells))
            (unless (= y (sub1 ycells)) (send back-dc draw-line x2 y2 x2 y2))
            (unless (= y 0) (send back-dc draw-line x2 y1 x2 y1))))))
    (define xx 0)
    (define yy 0)
    (define (refresh-cell)
      (let* ((d (add1 (quotient line-width 2)))
             (x (max 0 (- (* xx cell-size) d)))
             (y (max 0 (- (* yy cell-size) d)))
             (w (+ cell-size d d))
             (h (+ cell-size d d)))
        (send dc draw-bitmap-section back-bmp x y x y w h)))
    (define (redraw-cell)
      (let ((x+1 (add1 xx)) (y+1 (add1 yy)) (x-1 (sub1 xx)) (y-1 (sub1 yy))
            (c (get-cell the-maze xx yy)))
        (send back-dc set-pen no-pen) (draw-cell-bg c xx yy)
        (send back-dc set-pen fg-pen) (draw-cell-walls c xx yy #t)
        (when (< x+1 xcells)
          (draw-cell-walls (get-cell the-maze x+1 yy) x+1 yy))
        (when (< y+1 ycells)
          (draw-cell-walls (get-cell the-maze xx y+1) xx y+1))
        (refresh-cell)))
    (define flashing-disabled 0)
    (define flashed? #f)
    (define flasher-semaphore (make-semaphore 1))
    (define (flash-cursor)
      (let ((x (* xx cell-size)) (y (* yy cell-size))
            (w (add1 (quotient line-width 2))))
        (send dc set-pen no-pen)
        (send dc set-brush bl-brush)
        (send dc draw-ellipse
              (+ x w) (+ y w) (- cell-size w w -1) (- cell-size w w -1)))
      (set! flashed? (not flashed?)))
    (define (flasher)
      (semaphore-wait flasher-semaphore)
      (flash-cursor)
      (semaphore-post flasher-semaphore)
      (sleep 0.1)
      (flasher))
    (define (flash-on)
      (set! flashing-disabled (sub1 flashing-disabled))
      (when (eq? 0 flashing-disabled)
        (flash-cursor)
        (semaphore-post flasher-semaphore)))
    (define (flash-off)
      (when (eq? 0 flashing-disabled)
        (semaphore-wait flasher-semaphore))
      (set! flashing-disabled (add1 flashing-disabled))
      (when flashed? (flash-cursor)))
    (define (c-up)    (when (< 0 yy)             (set! yy (sub1 yy))))
    (define (c-down)  (when (< yy (sub1 ycells)) (set! yy (add1 yy))))
    (define (c-left)  (when (< 0 xx)             (set! xx (sub1 xx))))
    (define (c-right) (when (< xx (sub1 xcells)) (set! xx (add1 xx))))
    (define (cursor-draw f)
      (set! modified? #t)
      (let ((x+1 (add1 xx)) (y+1 (add1 yy)))
        (cond ((eq? f c-up)
               (set-cell-walls!
                (get-cell the-maze xx yy)
                (remq 't (cell-walls (get-cell the-maze xx yy)))))
              ((and (eq? f c-down) (< y+1 ycells))
               (set-cell-walls!
                (get-cell the-maze xx y+1)
                (remq 't (cell-walls (get-cell the-maze xx y+1)))))
              ((eq? f c-left)
               (set-cell-walls!
                (get-cell the-maze xx yy)
                (remq 'l (cell-walls (get-cell the-maze xx yy)))))
              ((and (eq? f c-right) (< x+1 xcells))
               (set-cell-walls!
                (get-cell the-maze x+1 yy)
                (remq 'l (cell-walls (get-cell the-maze x+1 yy))))))
        (set-cell-state! (get-cell the-maze xx yy) 0) (redraw-cell)
        (when f
          (f) (set-cell-state! (get-cell the-maze xx yy) 0) (redraw-cell))))
    (define (cursor-del f)
      (define (del x y)
        (let ((x+1 (add1 x)) (y+1 (add1 y)))
          (set-cell-state! (get-cell the-maze x y) 1)
          (set-cell-walls! (get-cell the-maze x y)
                           (cond ((and (> x 0) (> y 0)) (list 't 'l))
                                 ((and (= x 0) (= y 0)) '())
                                 (else (if (= x 0) (list 't) (list 'l)))))
          (when (< x+1 xcells)
            (set-cell-walls!
             (get-cell the-maze x+1 y)
             (cons 'l (remq 'l (cell-walls (get-cell the-maze x+1 y))))))
          (when (< y+1 ycells)
            (set-cell-walls!
             (get-cell the-maze x y+1)
             (cons 't (remq 't (cell-walls (get-cell the-maze x y+1))))))))
      (set! modified? #t)
      (del xx yy) (redraw-cell)
      (when f (f) (del xx yy) (redraw-cell)))
    (define current-cursor-state 1)
    (define (cursor-state s)
      (let ((f #f))
        (when (or (procedure? s) (not s))
          (set! f s)
          (set! s current-cursor-state))
        (set! modified? #t)
        (set! current-cursor-state s)
        (set-cell-state! (get-cell the-maze xx yy) s) (redraw-cell)
        (when f
          (f) (set-cell-state! (get-cell the-maze xx yy) s) (redraw-cell))))
    (define (solve colors? . delay)
      (let ((saved-state current-cursor-state)
            (original-state (cell-state (get-cell the-maze xx yy))))
        (begin-busy-cursor)
        (let loop ((firsts '()))
          (unless (null? delay) (sleep (car delay)))
          (let* ((ws (cell-walls (get-cell the-maze xx yy)))
                 (not-ok? (lambda (x y)
                            (not (= (cell-state (get-cell the-maze x y))
                                    original-state))))
                 (walls (lambda (x y)
                          (cell-walls (get-cell the-maze x y))))
                 (u (thunk
                      (not (or (= 0 yy) (memq 't ws) (not-ok? xx (sub1 yy))))))
                 (l (thunk
                      (not (or (= 0 xx) (memq 'l ws) (not-ok? (sub1 xx) yy)))))
                 (r (thunk
                      (not (or (= xx (sub1 xcells)) (not-ok? (add1 xx) yy)
                               (memq 'l (walls (add1 xx) yy))))))
                 (d (thunk
                      (not (or (= yy (sub1 ycells)) (not-ok? xx (add1 yy))
                               (memq 't (walls xx (add1 yy)))))))
                 (n (+ (if (u) 1 0) (if (l) 1 0) (if (r) 1 0) (if (d) 1 0)))
                 (do-loop
                  (lambda (f1 f2)
                    (f1) (cursor-state #f)
                    (when (and colors? (> n 1) (not firsts))
                      (cursor-state
                       (let ((s (add1 current-cursor-state)))
                         (when (= s (length *bg-colors*)) (set! s 10))
                         (when (= s original-state) (set! s (add1 s)))
                         (when (= s (length *bg-colors*)) (set! s 10))
                         s)))
                    (loop #f) (f2)))
                 (do-init-loop
                  (lambda (f1 f2)
                    (let ((xy (list xx yy)))
                      (f1) (loop (cons xy firsts)) (f2)))))
            (if (and (list? firsts) colors? (> n 1))
              (cond ((and (u) (not (member (list xx (sub1 yy)) firsts)))
                    (do-init-loop c-up    c-down))
                    ((and (l) (not (member (list (sub1 xx) yy) firsts)))
                     (do-init-loop c-left  c-right))
                    ((and (d) (not (member (list xx (add1 yy)) firsts)))
                     (do-init-loop c-down  c-up))
                    ((and (r) (not (member (list (add1 xx) yy) firsts)))
                     (do-init-loop c-right c-left))
                    (else (loop #t)))
              (begin
                (when firsts
                  (cursor-state
                   (if colors?
                     (let loop ()
                       (let ((s (+ 10 (random (- (length *bg-colors*) 10)))))
                         (if (= s original-state) (loop) s)))
                     (and (= saved-state original-state)
                          (if (= original-state 0) 1 0)))))
                (when (u) (do-loop c-up    c-down))
                (when (l) (do-loop c-left  c-right))
                (when (d) (do-loop c-down  c-up))
                (when (r) (do-loop c-right c-left))
                (when (and colors? (> n 1))
                  (fluid-let ((current-cursor-state
                               (if (zero? original-state) -1 0)))
                    (cursor-state #f)))))))
        (set! current-cursor-state saved-state)
        (when (and colors? (zero? original-state))
          (for-all-cells
           the-maze (lambda (c x y)
                      (when (= -1 (cell-state c)) (set-cell-state! c 0)))))
        (end-busy-cursor)))
    (define file-name #f)
    (define (set-file-name! f)
      (set! file-name f)
      (send frame set-label (string-append "Mazer: " (or f "<untitled>"))))
    (define modified? #f)
    (define (save)
      (if file-name
        (begin
          (when (file-exists? file-name) (delete-file file-name))
          (let* ((f (open-output-file file-name))
                 (out (lambda args (apply fprintf f args) (newline f))))
            (out "~s ~s ~s ~s" xcells ycells xx yy)
            (out "(vector")
            (do ((x 0 (add1 x))) ((= x xcells))
              (out "(vector")
              (do ((y 0 (add1 y))) ((= y ycells))
                (let ((c (get-cell the-maze x y)))
                  (out "(make-cell ~s '~s)" (cell-state c) (cell-walls c))))
              (out ")"))
            (out ")")
            (close-output-port f)
            (set! modified? #f)))
        (save-as)))
    (define (open . file)
      (maybe-save)
      (let ((f (if (not (null? file))
                 (car file)
                 (get-file "Open" frame #f #f "ss" '()))))
        (when f
          (if (file-exists? f)
            (begin
              (set-file-name! f)
              (let ((f (open-input-file f)))
                (set-new-size (read f) (read f))
                (set! xx (read f))
                (set! yy (read f))
                (set! the-maze (eval (read f)))
                (draw-initial)
                (set! modified? #f)))
            (message-box
             "Open" (format "~s does not exists." f) frame '(ok))))))
    (define (maybe-save)
      (when (and modified?
                 (begin
                   (bell)
                   (eq? 'yes
                        (message-box
                         "Mazer" "Maze modified, save?" frame '(yes-no)))))
        (save)))
    (define (save-as)
      (let ((f (get-file "Save-as" frame #f #f "ss" '())))
        (when f
          (if (directory-exists? f)
            (message
             "Save-as" (format "~s names a directory." f) frame '(ok))
            (when (or (not (file-exists? f))
                      (eq? 'yes
                           (message-box
                            "Save-as" (format "~s exists, overwrite?" f)
                            frame '(yes-no))))
              (set-file-name! f)
              (save))))))
    (define (new-maze . name+xy)
      (maybe-save)
      (let ((xy (if (null? name+xy)
                  (with-handlers ((void (lambda _ #f)))
                    (read
                     (open-input-string
                      (string-append
                       "("
                       (get-text-from-user
                        "New maze" "Enter new dimensions" frame
                        (if (= xcells ycells)
                          (format "~s" (- xcells 2))
                          (format "~s ~s" (- xcells 2) (- ycells 2))))
                       ")"))))
                  (cdr name+xy))))
        (when (and (list? xy) (= (length xy) 1))
          (set! xy (list (car xy) (car xy))))
        (cond
         ((and xy (list? xy) (= (length xy) 2) (andmap integer? xy)
               (andmap (lambda (x) (< 0 x 201)) xy))
          (set-file-name! (and (not (null? name+xy)) (car name+xy)))
          (apply set-new-size (map (lambda (x) (+ x 2)) xy))
          (set! the-maze (make-maze xcells ycells))
          (set! xx 0)
          (set! yy 0)
          (set! modified? #f)
          (draw-initial))
         (xy (message-box "Mazer" "Illegal response.")))))
    (define (print)
      (define p (make-object post-script-dc%))
      (fluid-let* ((back-dc p)
                   (cell-size
                    (let-values (((sx sy) (send p get-size)))
                      (min
                       (quotient
                        (round (- (inexact->exact sx) *ps-margin* *ps-margin*))
                        xcells)
                       (quotient
                        (round (- (inexact->exact sy) *ps-margin* *ps-margin*))
                        ycells))))
                   (line-width (quotient cell-size 5))
                   (fg-pen (make-object pen% *fg-color* line-width 'solid))
                   (no-pen (make-object pen% *fg-color* 0 'transparent))
                   (cr-pen (make-object pen% *fg-color* (quotient line-width 2)
                                        'solid)))
        (send p start-doc "Printing...")
        (send p start-page)
        (send p set-pen fg-pen)
        (for-all-cells the-maze draw-cell-walls)
        (send p end-page)
        (send p end-doc)))
    (define (quit)
      (maybe-save)
      (exit))
    (define (redefine-key key func)
      (cond ((assoc key key-bindings) =>
             (lambda (x) (set-car! (cdr x) func)))
            (else (set! key-bindings
                        (append! key-bindings (list (list key func)))))))
    (define macro-list #f)
    (define/public (key-bound? key)
      (assoc key key-bindings))
    (define/public (start/end-macro key)
      (cond
       ((not key)
        (set! macro-list #f))
       (macro-list
        (let ((key-funcs (reverse! macro-list)))
          (redefine-key (car key-funcs)
                        (thunk (for-each (lambda (x) (x)) (cdr key-funcs)))))
        (set! macro-list #f))
       (else
        (set! macro-list (list key)))))
    (define back-bmp #f)
    (define back-dc  #f)
    (define (draw-initial)
      (set! back-bmp
            (make-object bitmap% (min-client-width) (min-client-height)))
      (set! back-dc (make-object bitmap-dc% back-bmp))
      (send back-dc clear)
      (send back-dc set-pen no-pen)
      (for-all-cells the-maze draw-cell-bg)
      (send back-dc set-pen fg-pen)
      (for-all-cells the-maze draw-cell-walls)
      (send dc draw-bitmap back-bmp 0 0))
    (define/override (on-paint)
      (when (eq? 0 flashing-disabled)
        (semaphore-wait flasher-semaphore))
      (send dc draw-bitmap back-bmp 0 0)
      (when flashed? (flash-cursor) (set! flashed? #t))
      (when (eq? 0 flashing-disabled)
        (semaphore-post flasher-semaphore)))
    (define (save-png)
      (when (or file-name (begin (save) file-name))
        (let ((fname (regexp-replace #rx"(?:[.][^.]+)?$" file-name ".png")))
          (eprintf ">>> saving to ~s~%" fname)
          (send back-bmp save-file fname 'png))))
    (define (show-macro-window)
      (thread
       (thunk (send macro-frame show (not (send macro-frame is-shown?))))))
    (define key-bindings
      `(((up       #f #f #f) ,c-up)
        ((down     #f #f #f) ,c-down)
        ((left     #f #f #f) ,c-left)
        ((right    #f #f #f) ,c-right)
        ((shift    #f #f #f) ,(thunk (cursor-del   #f)))
        ((up       #t #f #f) ,(thunk (cursor-del   c-up)))
        ((down     #t #f #f) ,(thunk (cursor-del   c-down)))
        ((left     #t #f #f) ,(thunk (cursor-del   c-left)))
        ((right    #t #f #f) ,(thunk (cursor-del   c-right)))
        ((control  #f #f #f) ,(thunk (cursor-draw  #f)))
        ((up       #f #t #f) ,(thunk (cursor-draw  c-up)))
        ((down     #f #t #f) ,(thunk (cursor-draw  c-down)))
        ((left     #f #t #f) ,(thunk (cursor-draw  c-left)))
        ((right    #f #t #f) ,(thunk (cursor-draw  c-right)))
        ((meta     #f #f #f) ,(thunk (cursor-state #f)))
        ((up       #f #f #t) ,(thunk (cursor-state c-up)))
        ((down     #f #f #t) ,(thunk (cursor-state c-down)))
        ((left     #f #f #t) ,(thunk (cursor-state c-left)))
        ((right    #f #f #t) ,(thunk (cursor-state c-right)))
        ((home     #f #f #f) ,(thunk (set! xx 0)))
        ((end      #f #f #f) ,(thunk (set! xx (sub1 xcells))))
        ((prior    #f #f #f) ,(thunk (set! yy 0)))
        ((next     #f #f #f) ,(thunk (set! yy (sub1 ycells))))
        ((#\0      #f #f #f) ,(thunk (cursor-state 0)))
        ((#\1      #f #f #f) ,(thunk (cursor-state 1)))
        ((#\2      #f #f #f) ,(thunk (cursor-state 2)))
        ((#\3      #f #f #f) ,(thunk (cursor-state 3)))
        ((#\4      #f #f #f) ,(thunk (cursor-state 4)))
        ((#\5      #f #f #f) ,(thunk (cursor-state 5)))
        ((#\6      #f #f #f) ,(thunk (cursor-state 6)))
        ((#\7      #f #f #f) ,(thunk (cursor-state 7)))
        ((#\8      #f #f #f) ,(thunk (cursor-state 8)))
        ((#\9      #f #f #f) ,(thunk (cursor-state 9)))
        ((#\rubout #f #f #f) ,(thunk (solve #f)))
        ((#\c      #f #f #f) ,(thunk (solve #f 0.01)))
        ((insert   #f #f #f) ,(thunk (solve #t)))
        ((#\n      #f #f #f) ,new-maze)
        ((#\o      #f #f #f) ,open)
        ((#\s      #f #f #f) ,save)
        ((#\a      #f #f #f) ,save-as)
        ((#\p      #f #f #f) ,print)
        ((#\g      #f #f #f) ,save-png)
        ((#\q      #f #f #f) ,quit)
        ((#\z      #f #f #f) ,show-macro-window)
        ))
    (define (handle-char char+modifs)
      (let* ((k+f  (assoc char+modifs key-bindings))
             (func (and k+f (cadr k+f))))
        (when func
          (unless (or (not macro-list) (eq? func show-macro-window))
            (set! macro-list (cons func macro-list)))
          (func))))
    (define mazer-menu
      (let* ((m (make-object popup-menu% "Mazer"))
             (entry (lambda (title func)
                      (if title
                        (make-object menu-item% title m
                                     (lambda _ (flash-off) (func) (flash-on)))
                        (make-object separator-menu-item% m)))))
        (entry "New"          new-maze)
        (entry "Open"         open)
        (entry "Save"         save)
        (entry "Save-as"      save-as)
        (entry "Print"        print)
        (entry "pnG-save"     save-png)
        (entry #f #f)
        (entry "Solve"        (thunk (solve #f)))
        (entry "Solve slow"   (thunk (solve #f 0.01)))
        (entry "Colorize"     (thunk (solve #t)))
        (entry #f #f)
        (entry "Record macro" show-macro-window)
        (entry #f #f)
        (entry "Quit"         quit)
        m))
    (define/override (on-event e)
      (unless (and (send e moving?) (not (send e dragging?)))
        (let* ((x (quotient (inexact->exact (floor (send e get-x)))
                            cell-size))
               (y (quotient (inexact->exact (floor (send e get-y)))
                            cell-size))
               (D  (send e button-down?))
               (Dr (send e dragging?))
               (S  (send e get-shift-down))
               (C  (send e get-control-down))
               (M  (send e get-meta-down))
               (dx (- x xx)) (dy (- y yy)))
          (flash-off)
          (cond
           ((eq? 'right-down (send e get-event-type))
            (popup-menu mazer-menu
                        (inexact->exact (send e get-x))
                        (inexact->exact (send e get-y))))
           ((send e get-right-down) #f)
           (macro-list #f)
           (D (set! xx (min (max x 0) (sub1 xcells)))
              (set! yy (min (max y 0) (sub1 ycells))))
           ((and Dr S (cond ((and (= dx  1) (= dy  0)) (cursor-del   c-right))
                            ((and (= dx -1) (= dy  0)) (cursor-del   c-left))
                            ((and (= dx  0) (= dy  1)) (cursor-del   c-down))
                            ((and (= dx  0) (= dy -1)) (cursor-del   c-up))
                            (else #f))))
           ((and Dr C (cond ((and (= dx  1) (= dy  0)) (cursor-draw  c-right))
                            ((and (= dx -1) (= dy  0)) (cursor-draw  c-left))
                            ((and (= dx  0) (= dy  1)) (cursor-draw  c-down))
                            ((and (= dx  0) (= dy -1)) (cursor-draw  c-up))
                            (else #f))))
           ((and Dr M (cond ((and (= dx  1) (= dy  0)) (cursor-state c-right))
                            ((and (= dx -1) (= dy  0)) (cursor-state c-left))
                            ((and (= dx  0) (= dy  1)) (cursor-state c-down))
                            ((and (= dx  0) (= dy -1)) (cursor-state c-up))
                            (else #f))))
           (Dr (set! xx (min (max x 0) (sub1 xcells)))
               (set! yy (min (max y 0) (sub1 ycells)))))
          (flash-on))))
    (define/override (on-char e)
      (flash-off)
      (let ((key (send e get-key-code)))
        (unless (eq? e 'release)
          (handle-char (list key
                             (send e get-shift-down)
                             (send e get-control-down)
                             (send e get-meta-down)))))
      (flash-on))
    (define (set-new-size x y)
      (set! xcells x) (set! ycells y)
      (write-resource "mazer" "default-width" (- x 2))
      (write-resource "mazer" "default-height" (- y 2))
      (let-values (((sx sy) (get-display-size)))
        (set! cell-size (max (min (quotient sx x) (quotient (- sy 20) y)) 4)))
      (set! line-width (quotient cell-size 5))
      (set! fg-pen (make-object pen% *fg-color* line-width 'solid))
      (set! no-pen (make-object pen% *fg-color* 0 'transparent))
      (set! cr-pen
            (make-object pen% *fg-color* (quotient line-width 2) 'solid))
      (min-client-width  (* cell-size xcells))
      (min-client-height (* cell-size ycells))
      (stretchable-width #f)
      (stretchable-height #f))
    (set! frame
          (make-object
           (class frame%
             (define/augment (on-close) (quit))
             (super-instantiate ("Mazer"))
             (send this stretchable-width #f)
             (send this stretchable-height #f))))
    (super-instantiate (frame))
    (define dc (get-dc))
    (send dc clear)
    (let* ((argv (current-command-line-arguments))
           (fname (and (= 1 (vector-length argv))
                       (string? (vector-ref argv 0))
                       (vector-ref argv 0))))
      (if (and fname (file-exists? fname))
        (open fname)
        (new-maze fname *xcells-default* *ycells-default*)))
    (set! macro-frame
          (parameterize ((current-eventspace (make-eventspace)))
            (make-object macro-frame% this)))
    (send (current-ps-setup) set-mode 'file)
    (send (current-ps-setup) set-orientation 'landscape)
    (send (current-ps-setup) set-translation *ps-margin* *ps-margin*)
    (thread flasher)
    (send frame show #t)))


;;;============================================================================

(instantiate mazer% ())