350 lines
12 KiB
Racket
350 lines
12 KiB
Racket
#|
|
|
|
|
TODO: copying/pasting of pict snips doesn't preserve all of the information.
|
|
It only preserves the look, for now. The bounding boxes for children, in particular,
|
|
are gone.
|
|
|
|
When pressing or releasing the modifier keys, the snip doesn't update immediately;
|
|
the user has to move the mouse first.
|
|
|
|
|#
|
|
|
|
(module pict-value-snip mzscheme
|
|
(require texpict/mrpict
|
|
texpict/utils
|
|
mzlib/class
|
|
mred
|
|
mzlib/etc
|
|
mzlib/list)
|
|
|
|
(provide pict-value-snip%)
|
|
|
|
(define pict-value-snip%
|
|
(class snip%
|
|
(init-field pict)
|
|
(define top-align? #t)
|
|
(define white? #f)
|
|
(define pict-drawer (make-pict-drawer pict))
|
|
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
|
(let ([smoothing (send dc get-smoothing)])
|
|
(send dc set-smoothing 'aligned)
|
|
(pict-drawer dc x y)
|
|
(send dc set-smoothing smoothing))
|
|
(let ([old-pen (send dc get-pen)]
|
|
[old-brush (send dc get-brush)])
|
|
(send dc set-brush (send the-brush-list find-or-create-brush "black" 'transparent))
|
|
(send dc set-pen (send the-pen-list find-or-create-pen
|
|
(if white? "white" "black")
|
|
1
|
|
'solid))
|
|
(for-each (lambda (child)
|
|
(send dc draw-rectangle
|
|
(+ x (hbox-x child))
|
|
(+ y (hbox-y child))
|
|
(hbox-w child)
|
|
(hbox-h child)))
|
|
highlight-children)
|
|
(send dc set-pen old-pen)
|
|
(send dc set-brush old-brush)))
|
|
(define/override (get-extent dc x y w h descent space lspace rspace)
|
|
(set-box/f! w (pict-width pict))
|
|
(set-box/f! h (pict-height pict))
|
|
(cond
|
|
[top-align?
|
|
(set-box/f! descent (- (pict-height pict) (pict-ascent pict)))
|
|
(set-box/f! space 0)]
|
|
[else
|
|
(set-box/f! descent (pict-descent pict))
|
|
(set-box/f! space 0)])
|
|
(set-box/f! lspace 0)
|
|
(set-box/f! rspace 0))
|
|
|
|
(define highlight-children '())
|
|
|
|
(define/override (on-event dc x y editorx editory evt)
|
|
(let* ([sx (- (send evt get-x) x)]
|
|
[sy (- (send evt get-y) y)]
|
|
[needs-update? #f]
|
|
[update-children
|
|
(lambda (children)
|
|
(unless (equal? children highlight-children)
|
|
(set! needs-update? #t)
|
|
(set! highlight-children children)))])
|
|
|
|
(unless (equal? white? (send evt get-shift-down))
|
|
(set! white? (send evt get-shift-down))
|
|
(set! needs-update? #t))
|
|
|
|
(cond
|
|
[(send evt get-control-down)
|
|
(update-children (all-boxes pict))]
|
|
[(or (send evt get-alt-down)
|
|
(send evt get-meta-down))
|
|
(update-children (included-boxes pict sx sy))]
|
|
[else
|
|
(update-children (minimal-boxes pict sx sy))])
|
|
|
|
(when needs-update?
|
|
(refresh))))
|
|
|
|
;; this doesn't work at all.
|
|
(define/override (on-char dc x y editorx editory evt)
|
|
(cond
|
|
[(eq? (send evt get-key-code) 'shift)
|
|
(set! white? (eq? 'press (send evt get-key-release-code)))
|
|
(refresh)]
|
|
[else (void)]))
|
|
|
|
(define/override (adjust-cursor dc x y editorx editory event)
|
|
arrow-cursor)
|
|
|
|
(inherit get-admin)
|
|
(define/private (refresh)
|
|
(let ([admin (get-admin)])
|
|
(when admin
|
|
(send admin needs-update this 0 0 (pict-width pict) (pict-height pict)))))
|
|
|
|
(define/override (copy) (new pict-value-snip% (pict pict)))
|
|
|
|
(define/override (write in)
|
|
(let ([w (inexact->exact (ceiling (pict-width pict)))]
|
|
[h (inexact->exact (ceiling (pict-height pict)))])
|
|
(send in put h)
|
|
(cond
|
|
[(or (= w 0)
|
|
(= h 0))
|
|
(send in put 1 #"")]
|
|
[else
|
|
(let* ([bm (make-object bitmap% w h)]
|
|
[str (make-bytes (* w h 4))]
|
|
[bdc (make-object bitmap-dc% bm)])
|
|
(send bdc clear)
|
|
(send bdc set-smoothing 'aligned)
|
|
(pict-drawer bdc 0 0)
|
|
(send bdc get-argb-pixels 0 0 w h str)
|
|
(send bdc set-bitmap #f)
|
|
(send in put (+ 1 (bytes-length str)) str))])))
|
|
|
|
(super-new)
|
|
(inherit set-snipclass set-flags get-flags)
|
|
(set-snipclass pict-snipclass)
|
|
(set-flags (cons 'handles-events (get-flags)))))
|
|
|
|
(define arrow-cursor (make-object cursor% 'arrow))
|
|
|
|
(define pict-snip-class%
|
|
(class snip-class%
|
|
(define/override (read in)
|
|
(define pict
|
|
(let ([h (send in get-exact)]
|
|
[bitmap-bstr (send in get-bytes)])
|
|
(cond
|
|
[(and (number? h)
|
|
(bytes? bitmap-bstr)
|
|
(or (zero? h)
|
|
(zero? (modulo (bytes-length bitmap-bstr) (* 4 h)))))
|
|
(if (zero? h)
|
|
(blank)
|
|
(let* ([w (quotient (bytes-length bitmap-bstr) (* 4 h))]
|
|
[bm (make-object bitmap% w h)]
|
|
[bdc (make-object bitmap-dc% bm)])
|
|
(send bdc set-argb-pixels 0 0 w h bitmap-bstr)
|
|
(send bdc set-bitmap #f)
|
|
(bitmap bm)))]
|
|
[else (x-out (ellipse 10 10))])))
|
|
(new pict-value-snip% (pict pict)))
|
|
(super-new)))
|
|
|
|
(define (x-out p)
|
|
(cc-superimpose
|
|
p
|
|
(dc (lambda (dc dx dy)
|
|
(send dc draw-line dx dy (+ dx (pict-width p)) (+ dy (pict-height p)))
|
|
(send dc draw-line dx (+ dy (pict-height p)) (+ dx (pict-width p)) dy))
|
|
(pict-width p)
|
|
(pict-height p)
|
|
0
|
|
0)))
|
|
|
|
(define pict-snipclass (new pict-snip-class%))
|
|
(send pict-snipclass set-classname "drscheme:pict-value-snip%")
|
|
(send pict-snipclass set-version 0)
|
|
(send (get-the-snip-class-list) add pict-snipclass)
|
|
|
|
(define (set-box/f! b v) (when (box? b) (set-box! b v)))
|
|
|
|
(define (minimal-boxes pict x y)
|
|
(minimal-boxes/a '() (included-boxes pict x y)))
|
|
|
|
(define (minimal-boxes/a minimal included)
|
|
(cond
|
|
[(null? included) minimal]
|
|
[else (minimal-boxes/a (adjust-minimal minimal (car included))
|
|
(cdr included))]))
|
|
|
|
(define (adjust-minimal minimal candidate)
|
|
(cond
|
|
[(ormap (lambda (x) (inside? x candidate)) minimal)
|
|
minimal]
|
|
[(ormap (lambda (x) (inside? candidate x)) minimal)
|
|
(cons
|
|
candidate
|
|
(filter (lambda (x) (not (inside? candidate x)))
|
|
minimal))]
|
|
[else (cons candidate minimal)]))
|
|
|
|
(define (inside? c1 c2)
|
|
(and (<= (hbox-x c2)
|
|
(hbox-x c1)
|
|
(+ (hbox-x c1) (hbox-w c1))
|
|
(+ (hbox-x c2) (hbox-w c2)))
|
|
(<= (hbox-y c2)
|
|
(hbox-y c1)
|
|
(+ (hbox-y c1) (hbox-h c1))
|
|
(+ (hbox-y c2) (hbox-h c2)))))
|
|
|
|
(define (test)
|
|
|
|
(define (same-boxes? l1 l2)
|
|
(and (list? l1)
|
|
(list? l2)
|
|
(andmap hbox? l1)
|
|
(andmap hbox? l2)
|
|
(andmap (lambda (e1) (memf (same-box? e1) l2)) l1)
|
|
(andmap (lambda (e2) (memf (same-box? e2) l1)) l2)
|
|
#t))
|
|
(define ((same-box? b1) b2)
|
|
(and (= (hbox-x b1) (hbox-x b2))
|
|
(= (hbox-y b1) (hbox-y b2))
|
|
(= (hbox-w b1) (hbox-w b2))
|
|
(= (hbox-h b1) (hbox-h b2))))
|
|
|
|
(define (chk l1 l2)
|
|
(cond
|
|
[(same-boxes? l1 l2) #t]
|
|
[else
|
|
(printf "got ~s expected ~s\n" (map conv l1) (map conv l2))
|
|
#f]))
|
|
|
|
(list (chk (minimal-boxes/a '() (list (make-hbox 1 1 10 10)))
|
|
(list (make-hbox 1 1 10 10)))
|
|
(chk (minimal-boxes/a '() (list (make-hbox 5 5 10 10)
|
|
(make-hbox 0 0 20 20)))
|
|
(list (make-hbox 5 5 10 10)))
|
|
(chk (minimal-boxes/a '() (list (make-hbox 5 5 10 10)
|
|
(make-hbox 6 6 10 10)))
|
|
(list (make-hbox 5 5 10 10)
|
|
(make-hbox 6 6 10 10)))
|
|
(chk (minimal-boxes/a '() (list (make-hbox 0 0 10 10)
|
|
(make-hbox 0 0 20 20)))
|
|
(list (make-hbox 0 0 10 10)))
|
|
(chk (minimal-boxes/a '() (list (make-hbox 0 0 20 20)
|
|
(make-hbox 0 0 10 10)))
|
|
(list (make-hbox 0 0 10 10)))))
|
|
|
|
(define (conv x)
|
|
(list (hbox-x x) (hbox-y x) (hbox-w x) (hbox-h x)))
|
|
|
|
|
|
(define (included-boxes pict x y)
|
|
(filter (lambda (child)
|
|
(and (<= (hbox-x child)
|
|
x
|
|
(+ (hbox-x child) (hbox-w child)))
|
|
(<= (hbox-y child)
|
|
y
|
|
(+ (hbox-y child) (hbox-h child)))))
|
|
(all-boxes pict)))
|
|
|
|
;; y coordinates is from top going down (not bottom going up, which is what picts do)
|
|
(define-struct hbox (x y w h))
|
|
|
|
(define (make-hbox/conv orig-pict x y w h)
|
|
(make-hbox x
|
|
(- (pict-height orig-pict) y h)
|
|
w
|
|
h))
|
|
|
|
;; all-boxes : pict -> (listof hbox)
|
|
(define (all-boxes orig-pict)
|
|
(let loop ([pict orig-pict]
|
|
[adx 0]
|
|
[ady 0]
|
|
[boxes (list (make-hbox 0 0 (pict-width orig-pict) (pict-height orig-pict)))])
|
|
(let ([children (pict-children pict)])
|
|
(let i-loop ([children children]
|
|
[boxes boxes])
|
|
(cond
|
|
[(null? children) boxes]
|
|
[else
|
|
(let ([child (car children)])
|
|
(i-loop (cdr children)
|
|
(loop (child-pict child)
|
|
(+ adx (child-dx child))
|
|
(+ ady (child-dy child))
|
|
(cons
|
|
(make-hbox/conv
|
|
orig-pict
|
|
(+ adx (child-dx child))
|
|
(+ ady (child-dy child))
|
|
(pict-width (child-pict child))
|
|
(pict-height (child-pict child)))
|
|
boxes))))])))))
|
|
|
|
#|
|
|
(define (fish color open?)
|
|
(standard-fish 30 20 'left color "black" open?))
|
|
|
|
(define lunch-fish (fish "orange" #f))
|
|
(define small-fish (fish "blue" #f))
|
|
(define small-aaah-fish (fish "blue" #t))
|
|
|
|
(define spacer (blank 10 0))
|
|
|
|
(define fc 6)
|
|
|
|
(define meal-fish
|
|
(build-list (- fc 1)
|
|
(lambda (i) (launder lunch-fish))))
|
|
(define eating-fish
|
|
(build-list fc
|
|
(lambda (i) (launder (scale small-fish (sqrt (+ i 1)))))))
|
|
(define eating-aaah-fish
|
|
(build-list fc
|
|
(lambda (i) (launder (scale small-aaah-fish (sqrt (+ i 1)))))))
|
|
|
|
(define (on set pict) (if (memq pict set) pict (ghost pict)))
|
|
|
|
(define (main-characters active)
|
|
(foldl (lambda (meal-fish eating-fish eating-aaah-fish rest-of-scene)
|
|
(lc-superimpose
|
|
(on active eating-fish)
|
|
(on active eating-aaah-fish)
|
|
(hc-append (on active meal-fish)
|
|
spacer
|
|
rest-of-scene)))
|
|
(cc-superimpose (on active (car eating-fish))
|
|
(on active (car eating-aaah-fish)))
|
|
meal-fish
|
|
(cdr eating-fish)
|
|
(cdr eating-aaah-fish)))
|
|
|
|
|
|
(dc-for-text-size (make-object bitmap-dc% (make-object bitmap% 1 1)))
|
|
|
|
(define txt (vc-append (text "yXy" 'roman 12) (text "y" 'roman 12)))
|
|
|
|
(all-boxes txt)
|
|
|
|
(define t (new text%))
|
|
(send t insert (new pict-snip% (pict (main-characters (append meal-fish eating-fish eating-aaah-fish)))))
|
|
(send t copy #f 0 0 1)
|
|
(send t insert "\n")
|
|
(send t paste)
|
|
(define f (new frame% (label "") (width 600) (height 200)))
|
|
(define ec (new editor-canvas% (editor t) (parent f)))
|
|
(send f show #t)
|
|
|
|
|#
|
|
)
|