typedgui.rkt

#lang typed/racket
#|

The paint-by-numbers-canavas% class accepts two initalization
arguments. They must be lists of lists of numbers and they must be the
same length. paint-by-numbers-canvas% objects accepts four methods:

set-rect : (int int (union 'on 'off 'unknown) -> void)
Sets the grid point specified by the first two arguments to the third.
The coordinates are from the top-left and the x coordinate comes first.

get-rect : (int int ->  (union 'on 'off 'unknown))
Gets the value of the grid at the coordinates specified by the two integers

paint-rect : (int int -> void)
Draws the rectangle specified by the arguments.
Call this after calling set-rect to see the changes updated on the screen.

get-grid : (-> (list-of (list-of (union 'on 'off 'unknown 'wrong))))
Returns the current state of the entire board as a list of lists.

set-grid : ((vector-of (vector-of (union 'on 'off 'unknown 'wrong)))-> void)
Sets the state of the board. No drawing takes place

on-paint : (-> void)
Redraws the entire canvas. May be used if many rects were set.

all-unknown : (-> void)
Sets all board positions to 'unknown

close-up : (-> void)
call when canvas is closed.

See the bottom of this file for the creation of a file and a test
paint by numbers.

|#

(require typed/racket/gui
         typed/racket/class)

(provide paint-by-numbers-canvas%
         #;design-paint-by-numbers-canvas%)

(: UNKNOWN-BRUSH : (Instance Brush%))
(define UNKNOWN-BRUSH (assert (send the-brush-list find-or-create-brush "DARK GRAY" 'solid)))
(: ON-BRUSH : (Instance Brush%))
(define ON-BRUSH (assert (send the-brush-list find-or-create-brush "BLUE" 'solid)))
(: OFF-BRUSH : (Instance Brush%))
(define OFF-BRUSH (assert (send the-brush-list find-or-create-brush "WHITE" 'solid)))
(: WRONG-BRUSH : (Instance Brush%))
(define WRONG-BRUSH (assert (send the-brush-list find-or-create-brush "RED" 'solid)))

(define LINES/NUMBERS-PEN (send the-pen-list find-or-create-pen "BLACK" 1 'solid))

(define BLACK-PEN (send the-pen-list find-or-create-pen "BLACK" 1 'solid))
(define WHITE-PEN (send the-pen-list find-or-create-pen "WHITE" 1 'solid))
(: WHITE-BRUSH : (Instance Brush%))
(define WHITE-BRUSH (assert (send the-brush-list find-or-create-brush "WHITE" 'solid)))

(define BAR-PEN (send the-pen-list find-or-create-pen "SALMON" 1 'solid))
(define BAR-BRUSH (assert (send the-brush-list find-or-create-brush "SALMON" 'solid)))

(define-struct: ado ([x : Integer] [y : Integer] [before : (Instance Brush%)] [after : (Instance Brush%)]))

(define-struct: pt ([x : Integer] [y : Integer]))

#| == define types == |#
(define-type brush-sym (U 'unknown 'off 'on 'wrong))
(provide brush-sym)
(define-type history (U Null (Listof ado)))
(define-type highlight (U #f Integer))
(define-type pt/f (U pt #f))

(define-type Paint-By-Numbers-Canvas%
  (Class #:implements Canvas%
         (init-field [row-numbers (Listof (Listof Integer))]
                     [col-numbers (Listof (Listof Integer))])
         (init [parent (Instance Area-Container<%>)] ; FIXME
               [style (Listof (U 'border 'control-border 'combo
                                 'vscroll 'hscroll 'resize-corner
                                 'gl 'no-autoclear 'transparent
                                 'no-focus 'deleted))
                      #:optional]
               [paint-callback ((Instance Canvas%) (Instance DC<%>) -> Any)
                               #:optional]
               [label (Option String) #:optional]
               [gl-config (Option Any) #:optional]
               [enabled Any #:optional]
               [vert-margin Natural #:optional]
               [horiz-margin Natural #:optional]
               [min-width (Option Natural) #:optional]
               [min-height (Option Natural) #:optional]
               [stretchable-width Any #:optional]
               [stretchable-height Any #:optional])
         [get-rect (-> Integer Integer brush-sym)]
         [set-rect (-> Integer Integer brush-sym Void)]
         [set-raw-rect (Integer Integer Integer -> Void)]
         [set-grid ((Listof (Listof brush-sym)) -> Void)]
         [get-col-numbers (-> (Listof (Listof Integer)))]
         [get-max-col-entries (-> Integer)]
         [draw-col-label (-> Integer Void)]
         [get-row-numbers (-> (Listof (Listof Integer)))]
         [draw-row-label (-> Integer Void)]
         [calculate-row-margins (-> Void)]
         [calculate-col-margins (-> Void)]
         [update-min-spacing (-> Void)]
         [get-grid (-> Any)]
         [undo (-> Void)]
         [redo (-> Void)]
         [paint-rect (-> Void)]
         
         [paint-rect/lines-numbers-pen (-> Void)]
         ))

(: paint-by-numbers-canvas% Paint-By-Numbers-Canvas%)
(define paint-by-numbers-canvas%
  (class canvas%
    (init-field [row-numbers : (Listof (Listof Integer))]
                [col-numbers : (Listof (Listof Integer))])
    
    (inherit get-dc get-client-size)
    
    (: get-font (-> (Instance Font%)))
    (define/private (get-font) (send (get-dc) get-font))
    
    (: get-row-numbers (-> (Listof (Listof Integer))))
    (define/public (get-row-numbers) row-numbers)
    
    (: get-col-numbers (-> (Listof (Listof Integer))))
    (define/public (get-col-numbers) col-numbers)
    
    (: get-max-col-entries (-> Integer))
    (define/public (get-max-col-entries)
      (apply max (map (inst length Integer) (get-col-numbers))))
    
    [define: extra-space-every : Integer 5]
    
    [define: grid-x-size : Integer (length (get-col-numbers))]
    [define: grid-y-size : Integer (length (get-row-numbers))]
    [define: y-margin : Integer 1]
    [define: x-margin : Integer 3]
    [define: row-label-width : Integer 10]
    [define: row-label-height : Integer 10]
    [define: col-label-width : Real 10]
    [define: col-label-height : Integer 10]
    
    (: get-row-label-string ((Listof Integer) -> String))
    [define/private (get-row-label-string l)
      (if (null? l)
          ""
          (let ([first (car l)] 
                [rest (cdr l)])
            (apply string-append 
                   (number->string first)
                   (map (lambda (x) (format " ~a" x)) rest))))]
    
    (: get-col-label-strings ((Listof Integer) -> (Listof String)))
    [define/private get-col-label-strings
      (lambda (l)
        (map number->string l))]
    
   
    [define: grid : (Vectorof (Vectorof (Instance Brush%))) 
      (build-vector grid-x-size (lambda: ([i : Number]) (make-vector grid-y-size UNKNOWN-BRUSH)))]
    
    (: get-string-height (String -> Real))
    [define/private get-string-height
      (lambda (s)
        (let ([dc (get-dc)])
          (let-values ([((width : Real) (height : Real) 
                         (descent : Real) (ascent : Real)) 
                        (send dc get-text-extent s)])
            (- height descent))))]
    
    (: get-string-height/descent (String -> Real))
    [define/private get-string-height/descent
      (lambda (s)
        (let ([dc (get-dc)])
          (let-values ([((width : Real) (height : Real) 
                         (descent : Real) (ascent : Real)) 
                        (send dc get-text-extent s)])
            height)))]
    
    (: get-string-ascent (String -> Real))
    [define/private get-string-ascent
      (lambda (s)
        (let ([dc (get-dc)])
          (let-values ([((width : Real) (height : Real) 
                         (descent : Real) (ascent : Real)) 
                        (send dc get-text-extent s)])
            ascent)))]
    
    (: get-string-width (String -> Real))
    [define/private get-string-width
      (lambda (s)
        (let ([dc (get-dc)])
          (let-values ([((width : Real) (height : Real) 
                         (descent : Real) (ascent : Real))
                        (send dc get-text-extent s)])
            width)))]
    
    (: loc->string (Integer Integer -> String))
    [define/private loc->string
      (lambda (x y)
        (format "(~a,~a)" x y))]
    
    (: xy->grid (Integer Integer -> (U pt #f)))
    [define/private xy->grid
      (lambda (x y)
        (let* ([grid-width (/ (- (get-canvas-width) row-label-width) grid-x-size)]
               [grid-height (/ (- (get-canvas-height) col-label-height) grid-y-size)]
               [xp : Integer (- x row-label-width)]
               [yp : Integer (- y col-label-height)]
               [x : Integer (inexact->exact (floor (/ xp grid-width)))]
               [y : Integer (inexact->exact (floor (/ yp grid-height)))])
          (if (and (<= 0 x)
                   (< x grid-x-size)
                   (<= 0 y)
                   (< y grid-y-size))
              (make-pt x y)
              #f)))]
    
    (: grid->rect (Integer Integer -> (values Real Real Real Real)))
    [define/private grid->rect
      (lambda (x y)
        (let* ([grid-width (- (get-canvas-width)
                              row-label-width
                              (quotient grid-x-size extra-space-every))]
               [grid-height (- (get-canvas-height)
                               col-label-height
                               (quotient grid-y-size extra-space-every))]
               [left (+ row-label-width
                        (quotient x extra-space-every)
                        (* x (/ grid-width grid-x-size)))]
               [top (+ col-label-height
                       (quotient y extra-space-every)
                       (* y (/ grid-height grid-y-size)))]
               [width (/ grid-width grid-x-size)]
               [height (/ grid-height grid-y-size)])
          (values left top width height)))]
    
    (: get-canvas-width (-> Integer))
    (define/private (get-canvas-width) (let-values ([(w h) (get-client-size)]) w))
    
    (: get-canvas-height (-> Integer))
    (define/private (get-canvas-height) (let-values ([(w h) (get-client-size)]) h))
    
    
    [define: undo-history : history null]
    [define: redo-history : history null]
    
    
    (: do-do (ado (-> ado (Instance Brush%)) (-> ado (Instance Brush%)) -> Void))
    [define/private do-do
      (lambda (do current-sel new-sel)
        (let* ([x (ado-x do)]
               [y (ado-y do)]
               [actual (get-raw-rect x y)]
               [current (current-sel do)]
               [new (new-sel do)]
               [color->val
                (lambda ([brush : (Instance Brush%)])
                  (let ([color (send brush get-color)])
                    (list (send color red)
                          (send color green)
                          (send color blue))))])
          (unless (eq? current actual)
            (error 'do-do "expected ~a found ~a at (~a,~a)"
                   (color->val current)
                   (color->val actual)
                   x y))
          (set-raw-rect x y new)
          (paint-rect x y)))]
    
    (: brush->symbol ((Instance Brush%) -> brush-sym))
    [define/private brush->symbol
      (lambda (res)
        (cond
          [(eq? res UNKNOWN-BRUSH) 'unknown]
          [(eq? res OFF-BRUSH) 'off]
          [(eq? res ON-BRUSH) 'on]
          [(eq? res WRONG-BRUSH) 'wrong]
          [else (error 'brush->symbol "wrong brush")]))]
    
    (: sym->brush (brush-sym -> (Instance Brush%)))
    [define/private sym->brush
      (lambda (sym)
        (case sym
          [(unknown) UNKNOWN-BRUSH]
          [(off) OFF-BRUSH]
          [(on) ON-BRUSH]
          [(wrong) WRONG-BRUSH]))]
    
    (: in-rect? (pt pt pt -> Boolean))
    [define/private in-rect?
      (lambda (p cp1 cp2)
        (or (and (<= (pt-x cp1) (pt-x p) (pt-x cp2))
                 (<= (pt-y cp1) (pt-y p) (pt-y cp2)))
            (and (<= (pt-x cp2) (pt-x p) (pt-x cp1))
                 (<= (pt-y cp2) (pt-y p) (pt-y cp1)))))]
    
    ;; ((list-of (list-of (union 'unknown 'off 'on 'wrong))) -> void)
    (: set-grid ((Listof (Listof brush-sym)) -> Void))
    [define/public set-grid
      (lambda (g)
        (set! undo-history null)
        (set! redo-history null)
        (set! grid
              (list->vector
               (map (lambda: ([x : (Listof brush-sym)]) (list->vector (map (lambda: ([x : brush-sym]) (sym->brush x)) x)))
                    g))))]
    
    ;; (-> (list-of (list-of (union 'unknown 'off 'on 'wrong))))
    (: get-grid (-> (Listof (Listof brush-sym))))
    [define/public get-grid
      (lambda ()
        (map (lambda: ([x : (Vectorof (Instance Brush%))]) (map (lambda: ([x : (Instance Brush%)]) (brush->symbol x)) (vector->list x)))
             (vector->list grid)))]
    
    ;; (-> void)
    (: undo (-> Void))
    [define/public undo
      (lambda ()
        (cond
          [(null? undo-history) (bell)]
          [else
           (let ([do (car undo-history)])
             (set! undo-history (cdr undo-history))
             (set! redo-history (cons do redo-history))
             (do-do do ado-after ado-before))]))]
    
    ;; (-> void)
    (: redo (-> Void))
    [define/public redo
      (lambda ()
        (cond
          [(null? redo-history) (bell)]
          [else
           (let ([do (car redo-history)])
             (set! redo-history (cdr redo-history))
             (set! undo-history (cons do undo-history))
             (do-do do ado-before ado-after))]))]
    
    (: paint-rect  (Integer Integer -> Void))
    [define/public paint-rect
      (lambda (i j)
        (send (get-dc) set-pen LINES/NUMBERS-PEN)
        (paint-rect/lines-numbers-pen i j))]
    
    ;; (int int -> void)
    (: paint-rect/lines-numbers-pen (Integer Integer -> Void))
    [define/public paint-rect/lines-numbers-pen
      (lambda (i j)
        (let ([dc (get-dc)]
              ;; Change because these are mutable variables
              [draw-small-start-p draw-small-start-p]
              [draw-small-end-p draw-small-end-p])
          (let-values ([((left : Real) (top : Real) 
                         (width : Real) (height : Real)) (grid->rect i j)])
            (cond
              [(and draw-small-start-p
                    draw-small-end-p
                    (in-rect? (make-pt i j)
                              draw-small-start-p
                              draw-small-end-p))
               (send dc set-pen WHITE-PEN)
               (send dc set-brush WHITE-BRUSH)
               (send dc draw-rectangle left top (cast width Nonnegative-Real) 
                                                (cast height Nonnegative-Real))
               
               (let ([spacing 2])
                 (send dc set-pen LINES/NUMBERS-PEN)
                 (send dc set-brush (new-brush (get-raw-rect (pt-x draw-small-start-p)
                                                             (pt-y draw-small-start-p))
                                               modifier-on?))
                 (send dc draw-rectangle
                       (+ left spacing)
                       (+ top spacing)
                       (cast (- width spacing spacing) Nonnegative-Real)
                       (cast (- height spacing spacing) Nonnegative-Real)))]
              
              [else
               (send dc set-brush (get-raw-rect i j))
               (send dc draw-rectangle left top (cast width Nonnegative-Real) (cast height Nonnegative-Real))]))))]
    
    
    ;; (int int -> (instance brush%))
    (: get-raw-rect (Integer Integer -> (Instance Brush%)))
    [define/public get-raw-rect
      (lambda (i j)
        '(unless (and (<= 0 i)
                      (< i grid-x-size)
                      (<= 0 j)
                      (< j grid-y-size))
           (error 'get-raw-rect "cannot get (~a, ~a) in ~ax~a board"
                  i j grid-x-size grid-y-size))
        (vector-ref (vector-ref grid i) j))]
    
    ;; (int int -> (union 'on 'off 'unknown 'wrong))
    (: get-rect (Integer Integer -> brush-sym))
    [define/public get-rect
      (lambda (i j)
        (brush->symbol (get-raw-rect i j)))]
    
    ;; (int int (instance brush%) -> void)
    (: set-raw-rect (Integer Integer (Instance Brush%) -> Void))
    [define/public set-raw-rect
      (lambda (i j brush)
        '(unless (and (<= 0 i)
                      (< i grid-x-size)
                      (<= 0 j)
                      (< j grid-y-size))
           (error 'set-raw-rect "cannot set (~a, ~a) in ~ax~a board"
                  i j grid-x-size grid-y-size))
        (vector-set! (vector-ref grid i) j brush))]
    
    ;; (int int (union 'on 'off 'unknown 'wrong) -> void)
    (: set-rect (Integer Integer brush-sym -> Void))
    [define/public set-rect
      (lambda (i j sym)
        (set-raw-rect i j (sym->brush sym)))]
    
    
    ;; (int int -> void)
    (: set-to-error (Integer Integer -> Void))
    [define/public set-to-error
      (lambda (i j)
        (let ([brush (sym->brush 'wrong)])
          (set! undo-history (cons (make-ado i j (get-raw-rect i j) brush) undo-history))
          (set-raw-rect i j brush)
          (paint-rect i j)))]
    
    ;; (-> void)
    (: all-unknown (-> Void))
    [define/public all-unknown
      (lambda ()
        (let loop : Void
          ([i : Integer grid-x-size])
          (cond
            [(zero? i) (void)]
            [else
             (let loop : Void
               ([j : Integer grid-y-size])
               (cond
                 [(zero? j) (void)]
                 [else (set-rect (- i 1) (- j 1) 'unknown)
                       (loop (- j 1))]))
             (loop (- i 1))])))]
    
    
    [define: highlight-row : highlight #f]
    [define: highlight-col : highlight #f]
    
    (: draw-row-label (Integer -> Void))
    (define/public draw-row-label
      (lambda (n)
        (let-values ([(gx gy gw gh) (grid->rect 0 n)])
          (when (and (gx . >= . 0)
                     (gy . >= . 0)
                     (gw . >= . 0)
                     (gh . >= . 0))
            (let* ([nums (list-ref (get-row-numbers) n)]
                   [dc (get-dc)]
                   [str (get-row-label-string nums)]
                   [str-height (get-string-height str)]
                   [str-ascent (get-string-ascent str)]
                   [str-width (get-string-width str)]
                   [sy (+ gy
                          (- (/ gh 2)
                             (/ str-height 2)))]
                   [sx (- row-label-width str-width x-margin)]
                   
                   [x 0]
                   [y gy]
                   [w gx]
                   [h gh]
                   ;; another fix for mutable variables
                   [highlight-row highlight-row])
              
              (if (and highlight-row
                       (= highlight-row n))
                  (begin
                    (send dc set-pen BAR-PEN)
                    (send dc set-brush BAR-BRUSH))
                  (begin
                    (send dc set-pen WHITE-PEN)
                    (send dc set-brush WHITE-BRUSH)))
              
              (send dc draw-rectangle x y w h)
              (send dc draw-text str sx sy))))))
    
    (: draw-col-label (Integer -> Void))
    [define/public draw-col-label
      (lambda (n)
        (let-values ([(gx gy gw gh) (grid->rect n 0)])
          (when (and (gx . >= . 0)
                     (gy . >= . 0)
                     (gw . >= . 0)
                     (gh . >= . 0))
            (let* ([nums (list-ref (get-col-numbers) n)]
                   [strs (get-col-label-strings nums)]
                   [dc (get-dc)]
                   [highlight-col highlight-col])
              
              (if (and highlight-col
                       (= highlight-col n))
                  (begin
                    (send dc set-pen BAR-PEN)
                    (send dc set-brush BAR-BRUSH))
                  (begin
                    (send dc set-pen WHITE-PEN)
                    (send dc set-brush WHITE-BRUSH)))
              
              (send dc draw-rectangle gx 0 gw gy)
              (let loop : Void
                ([ss : (Listof String) strs]
                 [line : Integer (- (get-max-col-entries) (length strs))])
                (cond
                  [(null? ss) (void)]
                  [else
                   (let* ([s (car ss)]
                          [str-width (get-string-width s)]
                          [str-height (get-string-height s)]
                          [x (+ gx
                                (- (/ gw 2)
                                   (/ str-width 2)))]
                          [y (* line (+ str-height y-margin))])
                     (send dc draw-text (car ss) x y)
                     (loop (cdr ss)
                           (+ line 1)))]))))))]
    
    (: new-brush ((Instance Brush%) Boolean -> (Instance Brush%)))
    [define/private new-brush
      (lambda (prev modifier?)
        (cond
          [(eq? prev UNKNOWN-BRUSH)
           (if modifier?
               OFF-BRUSH
               ON-BRUSH)]
          [(eq? prev ON-BRUSH) UNKNOWN-BRUSH]
          [(eq? prev OFF-BRUSH) UNKNOWN-BRUSH]
          [(eq? prev WRONG-BRUSH) UNKNOWN-BRUSH]
          [else
           (error 'internal-error
                  "unkown brush in board ~s\n" prev)]))]
    
    (: check-modifier ((Instance Mouse-Event%) -> Boolean))
    [define/private check-modifier
      (lambda (evt)
        (or (send evt get-right-down)
            (send evt button-up? 'right)
            (send evt get-alt-down)
            (send evt get-meta-down)
            (send evt get-control-down)
            (send evt get-shift-down)))]
    
    [define: modifier-on? : Boolean #f]
    [define: last-p : pt/f #f]
    
    ;; (union #f                   if button not down
    ;;        (make-pt num num))   if button down
    [define: draw-small-start-p : pt/f #f]
    
    ;; (union #f                   if button dragged outside board
    ;;        (make-pt num num))   if button dragged in board
    [define: draw-small-end-p : pt/f #f]
    
    [define: coordinate-p : pt/f #f]
    
    ;; (p1 p2 -> void)
    (: update-range-of-rects (pt pt -> Void))
    [define/private update-range-of-rects
      (lambda (p1 p2)
        (let ([x-small : Integer (min (pt-x p1) (pt-x p2))]
              [x-large : Integer (max (pt-x p1) (pt-x p2))]
              [y-small : Integer (min (pt-y p1) (pt-y p2))]
              [y-large : Integer (max (pt-y p1) (pt-y p2))])
          (let loop : Void
            ([x : Integer x-small])
            (when (<= x x-large)
              (let loop : Void
                ([y : Integer y-small])
                (when (<= y y-large)
                  (paint-rect x y)
                  (loop (+ y 1))))
              (loop (+ x 1))))))]
    
    (: on-event ((Instance Mouse-Event%) -> Void))
    [define/override on-event
      (lambda (evt)
        (let* ([x (send evt get-x)]
               [y (send evt get-y)]
               [p (xy->grid x y)])
          (cond
            [(or (send evt moving?)
                 (send evt entering?)
                 (send evt leaving?))
             
             ;; update depressed squares
             (when draw-small-start-p
               (let ([old-draw-small-end-p draw-small-end-p]
                     ;; change to work around mutability
                     [draw-small-start-p draw-small-start-p])
                 (cond
                   [(and draw-small-start-p
                         p
                         (or (= (pt-x p) (pt-x draw-small-start-p))
                             (= (pt-y p) (pt-y draw-small-start-p))))
                    (unless (equal? draw-small-end-p p)
                      (set! draw-small-end-p p)
                      ;; let is used to work around mutability 
                      (let ([draw-small-end-p draw-small-end-p])
                      (when old-draw-small-end-p
                        (update-range-of-rects draw-small-start-p old-draw-small-end-p))
                      (when draw-small-end-p
                        (update-range-of-rects draw-small-start-p draw-small-end-p))))]
                   [draw-small-start-p
                    (set! draw-small-end-p #f)
                    (when old-draw-small-end-p
                      (update-range-of-rects draw-small-start-p old-draw-small-end-p))])))
             
             (let ([dc (get-dc)])
               
               ;; update the bars
               (let ([new-highlight-col
                      (if (and p
                               (not (send evt leaving?)))
                          (pt-x p)
                          #f)]
                     [old-highlight-col highlight-col])
                 (unless (equal? old-highlight-col new-highlight-col)
                   (set! highlight-col new-highlight-col)
                   (when new-highlight-col
                     (draw-col-label new-highlight-col))
                   (when old-highlight-col
                     (draw-col-label old-highlight-col))))
               
               (let ([new-highlight-row
                      (if (and p
                               (not (send evt leaving?)))
                          (pt-y p)
                          #f)]
                     [old-highlight-row highlight-row])
                 (unless (equal? old-highlight-row new-highlight-row)
                   (set! highlight-row new-highlight-row)
                   (when new-highlight-row
                     (draw-row-label new-highlight-row))
                   (when old-highlight-row
                     (draw-row-label old-highlight-row))))
               
               (set! last-p p)
               
               ;; update the coordinates
               (send dc set-pen WHITE-PEN)
               (send dc set-brush WHITE-BRUSH)
               (send dc draw-rectangle 0 0 (cast row-label-width Nonnegative-Integer) 
                                           (cast col-label-height Nonnegative-Integer))
               (when (and (not (send evt leaving?))
                          p)
                 (unless (equal? coordinate-p p)
                   (let* ([i (pt-x p)]
                          [j (pt-y p)]
                          [string (loc->string (+ i 1) (+ j 1))]
                          [width (get-string-width string)]
                          [height (get-string-height string)]
                          [sx (- (/ row-label-width 2)
                                 (/ width 2))]
                          [sy (- (/ col-label-height 2)
                                 (/ height 2))])
                     (send dc draw-text string sx sy)))))]
            [(send evt button-down?)
             (set! draw-small-start-p p)
             (set! draw-small-end-p p)
             (set! modifier-on? (check-modifier evt))
             (when p
               (paint-rect (pt-x p) (pt-y p)))]
            [(send evt button-up?)
             ; let to get around mutability
             (let ([draw-small-start-p* draw-small-start-p])
             (cond
               [(and p draw-small-start-p*
                     (or (= (pt-x p) (pt-x draw-small-start-p*))
                         (= (pt-y p) (pt-y draw-small-start-p*))))
                (let ([new (new-brush (get-raw-rect 
                                       (pt-x draw-small-start-p*)
                                       (pt-y draw-small-start-p*))
                                      (check-modifier evt))])
                  ;(set! undo-history (cons (make-ado i j prev new) undo-history))
                  ;(set! redo-history null)
                  (let ([x-small (min (pt-x draw-small-start-p*) (pt-x p))]
                        [x-large (max (pt-x draw-small-start-p*) (pt-x p))]
                        [y-small (min (pt-y draw-small-start-p*) (pt-y p))]
                        [y-large (max (pt-y draw-small-start-p*) (pt-y p))])
                    
                    (set! draw-small-start-p #f)
                    (set! draw-small-end-p #f)
                    (set! modifier-on? #f)
                    
                    (let loop : Void
                      ([x x-small])
                      (when (<= x x-large)
                        (let loop : Void
                          ([y : Integer y-small])
                          (when (<= y y-large)
                            (set-raw-rect x y new)
                            (paint-rect x y)
                            (loop (+ y 1))))
                        (loop (+ x 1))))))]
               [else
                (let ([old-draw-small-start-p draw-small-start-p]
                      [old-draw-small-end-p draw-small-end-p])
                  (set! draw-small-start-p #f)
                  (set! draw-small-end-p #f)
                  (set! modifier-on? (check-modifier evt))
                  (when (and old-draw-small-start-p
                             old-draw-small-end-p)
                    (update-range-of-rects old-draw-small-start-p
                                           old-draw-small-end-p)))]))])))]
    
    (: on-paint (-> Void))
    [define/override on-paint
      (lambda ()
        (let ([dc (get-dc)])
          (send dc clear)
          (let-values ([(width height) (get-client-size)])
            
            (send dc set-pen LINES/NUMBERS-PEN)
            (let loop : Void 
              ([i : Integer grid-x-size])
              (cond
                [(zero? i) (void)]
                [else (let loop : Void  
                        ([j : Integer grid-y-size])
                        (cond
                          [(zero? j) (void)]
                          [else (paint-rect/lines-numbers-pen (- i 1) (- j 1))
                                (loop (- j 1))]))
                      (loop (- i 1))]))
            
            (let loop : Void
              ([l : (Listof (Listof Integer)) (get-col-numbers)]
               [n : Integer 0])
              (cond
                [(null? l) (void)]
                [else
                 
                 (draw-col-label n)
                 (loop (cdr l) (+ n 1))]))
            
            (let loop : Void
              ([l : (Listof (Listof Integer)) (get-row-numbers)]
               [n : Integer 0])
              (cond
                [(null? l) (void)]
                [else
                 (let ([last-p last-p])
                   (if (and last-p
                            (= (pt-y last-p) n))
                       (begin
                         (send dc set-pen BAR-PEN)
                         (send dc set-brush BAR-BRUSH))
                       (begin
                         (send dc set-pen WHITE-PEN)
                         (send dc set-brush WHITE-BRUSH)))
                   (draw-row-label n)
                   (loop (cdr l)
                         (+ n 1)))]))
            
            (void))))]
    
    (: calculate-row-margins (-> Void))
    [define/public calculate-row-margins
      (lambda ()
        (let* ([dc (get-dc)])
          (set! row-label-width
                (cast (max (get-string-width (loc->string grid-x-size grid-y-size))
                     (apply max (map (lambda: ([x : (Listof Integer)]) (+ x-margin
                                                    (get-string-width (get-row-label-string x))
                                                    x-margin))
                                     (get-row-numbers)))) Integer))
          
          (let-values ([(width height descent ascent) (send dc get-text-extent "0123456789")])
            (set! row-label-height (cast (+ y-margin height y-margin) Integer)))))]

    (: calculate-col-margins (-> Void))
    [define/public calculate-col-margins
      (lambda ()
        (let* ([dc (get-dc)])
          
          (set! col-label-height
                (cast (max
                 (get-string-height/descent (loc->string grid-x-size grid-y-size))
                 (apply max
                        (map (lambda: ([l : (Listof Integer)])
                               (let* ([strs (get-col-label-strings l)]
                                      [margins (* (length strs) y-margin)]
                                      [height (apply + (map (lambda: ([x : String]) (get-string-height x)) strs))])
                                 (+ margins height)))
                             (get-col-numbers)))) Integer))
          
          (set! col-label-width
                (apply max
                       (map (lambda: ([l : (Listof Integer)])
                              (let ([label-strings (get-col-label-strings l)])
                                (if (null? label-strings)
                                    (+ x-margin x-margin) ;; Minimum column label width (no labels)
                                    (apply max
                                           (map (lambda: ([x : String]) (+ x-margin
                                                               (get-string-width x)
                                                               x-margin))
                                                label-strings)))))
                            (get-col-numbers))))))]
    
    (: update-min-spacing : -> Void)
    [define/public update-min-spacing
      (lambda ()
        (min-width (cast (inexact->exact (ceiling (+ row-label-width (* grid-x-size col-label-width)))) Integer))
        (min-height (cast (inexact->exact (ceiling (+ col-label-height (* grid-y-size row-label-height)))) Integer)))]
    
    (inherit min-width min-height)
    
    (super-new)
    
    (: close-up (-> Void))
    [define/public close-up
      (lambda ()
        (remove-pref-callback))]
    
    (: reset-font ((Instance Font%) -> Void))
    [define/public reset-font
      (lambda (font)
        (send (get-dc) set-font font)
        (calculate-row-margins)
        (calculate-col-margins)
        (update-min-spacing))]
    
    (: pref-callback (-> Void))
    (define pref-callback void #;(preferences:add-callback
                           'paint-by-numbers:font
                           (lambda (pref new-value)
                             (reset-font new-value))))
    
    (: remove-pref-callback : -> Void)
    [define/public (remove-pref-callback) (pref-callback)]
    #;
    (reset-font (preferences:get 'paint-by-numbers:font))
    (calculate-row-margins)
    (calculate-col-margins)
    (update-min-spacing)))
#;#;#;
(define-type Design-Paint-By-Numbers-Canvas%
  (Class #:implements Paint-By-Numbers-Canvas%
         (init-field [width Integer]
                     [height Integer]) 
         
         ))

(: design-paint-by-numbers-canvas% Design-Paint-By-Numbers-Canvas%)
(define design-paint-by-numbers-canvas%
  (class paint-by-numbers-canvas% 
    (init-field [width : Integer] [height : Integer])
    [define: row-spacing : Integer 5]
    [define: col-spacing : Integer 5]
    [define: row-numbers : (Listof (Listof Integer))
      (vector->list (make-vector height (vector->list (make-vector row-spacing 1))))]
    [define: col-numbers : (Listof (Listof Integer))
      (vector->list (make-vector width (vector->list (make-vector col-spacing 1))))]
    
    (: get-max-col-entries (-> Integer))
    [define/override get-max-col-entries
      (lambda ()
        col-spacing)]
    
    (: get-row-numbers (-> (Listof (Listof Integer))))
    [define/override get-row-numbers
      (lambda ()
        row-numbers)]
    
    (: get-col-numbers (-> (Listof (Listof Integer))))
    [define/override get-col-numbers
      (lambda ()
        col-numbers)]
    
    (inherit draw-col-label draw-row-label get-rect
             calculate-row-margins
             calculate-col-margins
             update-min-spacing
             on-paint)
    
    (: calculate-col/row ((Integer -> brush-sym) (Listof (Listof Integer)) Integer -> (Listof Integer)))
    [define/private calculate-col/row
      (lambda (get-rect col/row-numbers num-row/cols)
        (let loop : (Listof Integer)
          ([i : Integer num-row/cols]
           [block-count : Integer 0]
           [ans : (Listof Integer) null])
          (cond
            [(zero? i) (if (= block-count 0)
                           ans
                           (cons block-count ans))]
            [else
             (let ([this (get-rect (- i 1))])
               (case this
                 [(unknown off wrong)
                  (if (zero? block-count)
                      (loop (- i 1) 0 ans)
                      (loop (- i 1) 0 (cons block-count ans)))]
                 [(on) (loop (- i 1) (+ block-count 1) ans)]
                 [else (error 'calculate-col "unknown response from get-rect: ~a\n" this)]))])))]
    
    (: calculate-col (Integer -> (Listof Integer)))
    [define/private calculate-col
      (lambda (col)
        (calculate-col/row
         (lambda: ([i : Integer]) (get-rect col i))
         col-numbers
         (length row-numbers)))]
    
    (: calculate-row (Integer -> (Listof Integer)))
    [define/private calculate-row
      (lambda (row)
        (calculate-col/row
         (lambda: ([i : Integer]) (get-rect i row))
         row-numbers
         (length col-numbers)))]
    
    (: update-col/row (Integer (Listof (Listof Integer)) (Integer -> (Listof Integer)) -> (Listof (Listof Integer))))
    [define/private update-col/row
      (lambda (col/row col/row-numbers calculate-col/row)
        (let loop : (Listof (Listof Integer))
          ([l col/row-numbers]
           [n col/row])
          (cond
            [(null? l) (error 'update-col/row "col/row too big: ~a\n" col/row)]
            [(zero? n)
             (cons (calculate-col/row col/row)
                   (cdr l))]
            [else
             (cons (car l)
                   (loop (cdr l)
                         (- n 1)))])))]
    
    (: update-col (Integer -> Void)) 
    [define/private update-col
      (lambda (col)
        (set! col-numbers
              (update-col/row col
                              col-numbers
                              (lambda: ([x : Integer]) (calculate-col x))))
        (draw-col-label col)
        (let ([len (length (list-ref col-numbers col))])
          (when (< col-spacing len)
            (set! col-spacing len)
            (calculate-col-margins)
            (update-min-spacing)
            (on-paint))))]
    
    (: update-row (Integer -> Void))
    [define/private update-row
      (lambda (row)
        (set! row-numbers
              (update-col/row row
                              row-numbers
                              (lambda: ([x : Integer]) (calculate-row x))))
        (draw-row-label row)
        (let ([len (length (list-ref row-numbers row))])
          (when (< row-spacing len)
            (set! row-spacing len)
            (calculate-row-margins)
            (update-min-spacing)
            (on-paint))))]
    
    [define: update-row-col? : Boolean #t]
    
    (: set-raw-rect (Integer Integer Integer -> Void))
    [define/override set-raw-rect
      (lambda (i j n)
        (super set-raw-rect i j n)
        (when update-row-col?
          (update-col i)
          (update-row j)))]
    
    (: update-all-rows-cols (-> Void))
    [define/private update-all-rows-cols
      (lambda ()
        (let loop : Void 
          ([i : Integer width])
          (unless (zero? i)
            (update-col (- i 1))
            (loop (- i 1))))
        (let loop : Void
          ([i height])
          (unless (zero? i)
            (update-row (- i 1))
            (loop (- i 1)))))]
    (inherit set-rect)
    
    (: set-bitmap ((Instance Bitmap%) -> Void))
    [define/public set-bitmap
      (lambda (bitmap)
        (set! update-row-col? #f)
        (let ([dc (make-object bitmap-dc% bitmap)]
              [c (make-object color%)]
              [width : Integer (send bitmap get-width)]
              [height : Integer (send bitmap get-height)]
              [warned? : Boolean #f])
          (let loop : Void
            ([i : Integer width])
            (unless (zero? i)
              (let loop : Void
                ([j : Integer height])
                (unless (zero? j)
                  (let ([m (- i 1)]
                        [n (- j 1)])
                    (send dc get-pixel m n c)
                    (when (and (not warned?)
                               (not (or (and (= 0 (send c red))
                                             (= 0 (send c blue))
                                             (= 0 (send c green)))
                                        (and (= 255 (send c red))
                                             (= 255 (send c blue))
                                             (= 255 (send c green))))))
                      (set! warned? #t)
                      (message-box
                       "Paint by Numbers"
                       "WARNING: This is a color bitmap; non-white pixels will be considered black"))
                    (set-rect m n
                              (if (and (= 255 (send c red))
                                       (= 255 (send c blue))
                                       (= 255 (send c green)))
                                  'off
                                  'on)))
                  (loop (- j 1))))
              (loop (- i 1)))))
        
        (set! update-row-col? #t)
        (update-all-rows-cols))]
    
    (: set-grid ((Listof (Listof brush-sym)) -> Void))
    [define/override set-grid
      (lambda (g)
        (set! update-row-col? #f)
        (super set-grid g)
        (set! update-row-col? #t)
        (update-all-rows-cols))]
    
    (super-new (row-numbers null) (col-numbers null))
    (set! row-numbers (vector->list (make-vector height (ann null (Listof Integer)))))
    (set! col-numbers (vector->list (make-vector width (ann null (Listof Integer)))))))