869 lines
33 KiB
Racket
869 lines
33 KiB
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.
|
|
|
|
|#
|
|
|
|
(module gui mzscheme
|
|
(require mred
|
|
framework
|
|
mzlib/etc
|
|
mzlib/class)
|
|
|
|
(provide paint-by-numbers-canvas%
|
|
design-paint-by-numbers-canvas%)
|
|
|
|
(define UNKNOWN-BRUSH (send the-brush-list find-or-create-brush "DARK GRAY" 'solid))
|
|
(define ON-BRUSH (send the-brush-list find-or-create-brush "BLUE" 'solid))
|
|
(define OFF-BRUSH (send the-brush-list find-or-create-brush "WHITE" 'solid))
|
|
(define WRONG-BRUSH (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))
|
|
(define WHITE-BRUSH (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 (send the-brush-list find-or-create-brush "SALMON" 'solid))
|
|
|
|
(define-struct ado (x y before after))
|
|
|
|
(define-struct pt (x y))
|
|
|
|
(define paint-by-numbers-canvas%
|
|
(class canvas%
|
|
(init-field row-numbers col-numbers)
|
|
(inherit get-dc get-client-size)
|
|
|
|
(define/private (get-font) (send (get-dc) get-font))
|
|
|
|
(define/public (get-row-numbers) row-numbers)
|
|
(define/public (get-col-numbers) col-numbers)
|
|
|
|
(define/public (get-max-col-entries)
|
|
(apply max (map length (get-col-numbers))))
|
|
|
|
[define extra-space-every 5]
|
|
|
|
[define grid-x-size (length (get-col-numbers))]
|
|
[define grid-y-size (length (get-row-numbers))]
|
|
[define y-margin 1]
|
|
[define x-margin 3]
|
|
[define row-label-width 10]
|
|
[define row-label-height 10]
|
|
[define col-label-width 10]
|
|
[define col-label-height 10]
|
|
|
|
[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))))]
|
|
|
|
[define/private get-col-label-strings
|
|
(lambda (l)
|
|
(map number->string l))]
|
|
|
|
[define grid (build-vector grid-x-size (lambda (i) (make-vector grid-y-size UNKNOWN-BRUSH)))]
|
|
|
|
[define/private get-string-height
|
|
(lambda (s)
|
|
(let ([dc (get-dc)])
|
|
(let-values ([(width height descent ascent)
|
|
(send dc get-text-extent s)])
|
|
(- height descent))))]
|
|
[define/private get-string-height/descent
|
|
(lambda (s)
|
|
(let ([dc (get-dc)])
|
|
(let-values ([(width height descent ascent)
|
|
(send dc get-text-extent s)])
|
|
height)))]
|
|
[define/private get-string-ascent
|
|
(lambda (s)
|
|
(let ([dc (get-dc)])
|
|
(let-values ([(width height descent ascent)
|
|
(send dc get-text-extent s)])
|
|
ascent)))]
|
|
[define/private get-string-width
|
|
(lambda (s)
|
|
(let ([dc (get-dc)])
|
|
(let-values ([(width height descent ascent)
|
|
(send dc get-text-extent s)])
|
|
width)))]
|
|
|
|
[define/private loc->string
|
|
(lambda (x y)
|
|
(format "(~a,~a)" x y))]
|
|
|
|
[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 (- x row-label-width)]
|
|
[yp (- y col-label-height)]
|
|
[x (inexact->exact (floor (/ xp grid-width)))]
|
|
[y (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)))]
|
|
|
|
[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)))]
|
|
|
|
(define/private (get-canvas-width) (let-values ([(w h) (get-client-size)]) w))
|
|
(define/private (get-canvas-height) (let-values ([(w h) (get-client-size)]) h))
|
|
|
|
[define undo-history null]
|
|
[define redo-history null]
|
|
[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)
|
|
(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)))]
|
|
|
|
[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]))]
|
|
[define/private sym->brush
|
|
(lambda (sym)
|
|
(case sym
|
|
[(unknown) UNKNOWN-BRUSH]
|
|
[(off) OFF-BRUSH]
|
|
[(on) ON-BRUSH]
|
|
[(wrong) WRONG-BRUSH]))]
|
|
|
|
[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)
|
|
[define/public set-grid
|
|
(lambda (g)
|
|
(set! undo-history null)
|
|
(set! redo-history null)
|
|
(set! grid
|
|
(list->vector
|
|
(map (lambda (x) (list->vector (map (lambda (x) (sym->brush x)) x)))
|
|
g))))]
|
|
|
|
;; (-> (list-of (list-of (union 'unknown 'off 'on 'wrong))))
|
|
[define/public get-grid
|
|
(lambda ()
|
|
(map (lambda (x) (map (lambda (x) (brush->symbol x)) (vector->list x)))
|
|
(vector->list grid)))]
|
|
|
|
;; (-> 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)
|
|
[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))]))]
|
|
|
|
[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)
|
|
[define/public paint-rect/lines-numbers-pen
|
|
(lambda (i j)
|
|
(let ([dc (get-dc)])
|
|
(let-values ([(left top width height) (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 width height)
|
|
|
|
(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)
|
|
(- width spacing spacing)
|
|
(- height spacing spacing)))]
|
|
|
|
[else
|
|
(send dc set-brush (get-raw-rect i j))
|
|
(send dc draw-rectangle left top width height)]))))]
|
|
|
|
|
|
;; (int int -> (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))
|
|
[define/public get-rect
|
|
(lambda (i j)
|
|
(brush->symbol (get-raw-rect i j)))]
|
|
|
|
;; (int int (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)
|
|
[define/public set-rect
|
|
(lambda (i j sym)
|
|
(set-raw-rect i j (sym->brush sym)))]
|
|
|
|
|
|
;; (int int -> 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)
|
|
[define/public all-unknown
|
|
(lambda ()
|
|
(let loop ([i grid-x-size])
|
|
(cond
|
|
[(zero? i) (void)]
|
|
[else
|
|
(let loop ([j grid-y-size])
|
|
(cond
|
|
[(zero? j) (void)]
|
|
[else (set-rect (- i 1) (- j 1) 'unknown)
|
|
(loop (- j 1))]))
|
|
(loop (- i 1))])))]
|
|
|
|
[define highlight-row #f]
|
|
[define highlight-col #f]
|
|
(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])
|
|
|
|
(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))))))
|
|
|
|
[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)])
|
|
|
|
(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 ([ss strs]
|
|
[line (- (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)))]))))))]
|
|
|
|
[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)]))]
|
|
|
|
[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? #f]
|
|
[define last-p #f]
|
|
|
|
|
|
;; (union #f if button not down
|
|
;; (make-pt num num)) if button down
|
|
[define draw-small-start-p #f]
|
|
|
|
;; (union #f if button dragged outside board
|
|
;; (make-pt num num)) if button dragged in board
|
|
[define draw-small-end-p #f]
|
|
|
|
[define coordinate-p #f]
|
|
|
|
[define/private update-range-of-rects
|
|
(lambda (p1 p2)
|
|
(let ([x-small (min (pt-x p1) (pt-x p2))]
|
|
[x-large (max (pt-x p1) (pt-x p2))]
|
|
[y-small (min (pt-y p1) (pt-y p2))]
|
|
[y-large (max (pt-y p1) (pt-y p2))])
|
|
(let loop ([x x-small])
|
|
(when (<= x x-large)
|
|
(let loop ([y y-small])
|
|
(when (<= y y-large)
|
|
(paint-rect x y)
|
|
(loop (+ y 1))))
|
|
(loop (+ x 1))))))]
|
|
|
|
[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])
|
|
(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)
|
|
(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 row-label-width col-label-height)
|
|
(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?)
|
|
(cond
|
|
[(and 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 ([x x-small])
|
|
(when (<= x x-large)
|
|
(let loop ([y 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)))])])))]
|
|
[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 ([i grid-x-size])
|
|
(cond
|
|
[(zero? i) (void)]
|
|
[else (let loop ([j 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 ([l (get-col-numbers)]
|
|
[n 0])
|
|
(cond
|
|
[(null? l) (void)]
|
|
[else
|
|
|
|
(draw-col-label n)
|
|
(loop (cdr l) (+ n 1))]))
|
|
|
|
(let loop ([l (get-row-numbers)]
|
|
[n 0])
|
|
(cond
|
|
[(null? l) (void)]
|
|
[else
|
|
(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))))]
|
|
|
|
[define/public calculate-row-margins
|
|
(lambda ()
|
|
(let* ([dc (get-dc)])
|
|
(set! row-label-width
|
|
(max (get-string-width (loc->string grid-x-size grid-y-size))
|
|
(apply max (map (lambda (x) (+ x-margin
|
|
(get-string-width (get-row-label-string x))
|
|
x-margin))
|
|
(get-row-numbers)))))
|
|
|
|
(let-values ([(width height descent ascent) (send dc get-text-extent "0123456789")])
|
|
(set! row-label-height (+ y-margin height y-margin)))))]
|
|
[define/public calculate-col-margins
|
|
(lambda ()
|
|
(let* ([dc (get-dc)])
|
|
|
|
(set! col-label-height
|
|
(max
|
|
(get-string-height/descent (loc->string grid-x-size grid-y-size))
|
|
(apply max
|
|
(map (lambda (l)
|
|
(let* ([strs (get-col-label-strings l)]
|
|
[margins (* (length strs) y-margin)]
|
|
[height (apply + (map (lambda (x) (get-string-height x)) strs))])
|
|
(+ margins height)))
|
|
(get-col-numbers)))))
|
|
|
|
(set! col-label-width
|
|
(apply max
|
|
(map (lambda (l)
|
|
(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) (+ x-margin
|
|
(get-string-width x)
|
|
x-margin))
|
|
label-strings)))))
|
|
(get-col-numbers))))))]
|
|
[define/public update-min-spacing
|
|
(lambda ()
|
|
(min-width (inexact->exact (+ row-label-width (* grid-x-size col-label-width))))
|
|
(min-height (inexact->exact (+ col-label-height (* grid-y-size row-label-height)))))]
|
|
|
|
(inherit min-width min-height)
|
|
(super-instantiate ())
|
|
|
|
[define/public close-up
|
|
(lambda ()
|
|
(remove-pref-callback))]
|
|
[define/public reset-font
|
|
(lambda (font)
|
|
(send (get-dc) set-font font)
|
|
(calculate-row-margins)
|
|
(calculate-col-margins)
|
|
(update-min-spacing))]
|
|
|
|
(define pref-callback (preferences:add-callback
|
|
'paint-by-numbers:font
|
|
(lambda (pref new-value)
|
|
(reset-font new-value))))
|
|
[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 design-paint-by-numbers-canvas%
|
|
(class paint-by-numbers-canvas%
|
|
(init-field width height)
|
|
[define row-spacing 5]
|
|
[define col-spacing 5]
|
|
[define row-numbers
|
|
(vector->list (make-vector height (vector->list (make-vector row-spacing 1))))]
|
|
[define col-numbers
|
|
(vector->list (make-vector width (vector->list (make-vector col-spacing 1))))]
|
|
|
|
[define/override get-max-col-entries
|
|
(lambda ()
|
|
col-spacing)]
|
|
[define/override get-row-numbers
|
|
(lambda ()
|
|
row-numbers)]
|
|
[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)
|
|
|
|
[define/private calculate-col/row
|
|
(lambda (get-rect col/row-numbers num-row/cols)
|
|
(let loop ([i num-row/cols]
|
|
[block-count 0]
|
|
[ans 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)]))])))]
|
|
|
|
[define/private calculate-col
|
|
(lambda (col)
|
|
(calculate-col/row
|
|
(lambda (i) (get-rect col i))
|
|
col-numbers
|
|
(length row-numbers)))]
|
|
|
|
[define/private calculate-row
|
|
(lambda (row)
|
|
(calculate-col/row
|
|
(lambda (i) (get-rect i row))
|
|
row-numbers
|
|
(length col-numbers)))]
|
|
|
|
[define/private update-col/row
|
|
(lambda (col/row col/row-numbers calculate-col/row)
|
|
(let loop ([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)))])))]
|
|
|
|
[define/private update-col
|
|
(lambda (col)
|
|
(set! col-numbers
|
|
(update-col/row col
|
|
col-numbers
|
|
(lambda (x) (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))))]
|
|
|
|
[define/private update-row
|
|
(lambda (row)
|
|
(set! row-numbers
|
|
(update-col/row row
|
|
row-numbers
|
|
(lambda (x) (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? #t]
|
|
[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)))]
|
|
|
|
[define/private update-all-rows-cols
|
|
(lambda ()
|
|
(let loop ([i width])
|
|
(unless (zero? i)
|
|
(update-col (- i 1))
|
|
(loop (- i 1))))
|
|
(let loop ([i height])
|
|
(unless (zero? i)
|
|
(update-row (- i 1))
|
|
(loop (- i 1)))))]
|
|
(inherit set-rect)
|
|
[define/public set-bitmap
|
|
(lambda (bitmap)
|
|
(set! update-row-col? #f)
|
|
(let ([dc (make-object bitmap-dc% bitmap)]
|
|
[c (make-object color%)]
|
|
[width (send bitmap get-width)]
|
|
[height (send bitmap get-height)]
|
|
[warned? #f])
|
|
(let loop ([i width])
|
|
(unless (zero? i)
|
|
(let loop ([j 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))]
|
|
|
|
[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-instantiate () (row-numbers null) (col-numbers null))
|
|
(set! row-numbers (vector->list (make-vector height null)))
|
|
(set! col-numbers (vector->list (make-vector width null))))))
|