258 lines
9.1 KiB
Scheme
258 lines
9.1 KiB
Scheme
|
|
(module text mzscheme
|
|
(require (lib "list.ss")
|
|
(lib "class.ss")
|
|
(lib "mred.ss" "mred")
|
|
(lib "arrow.ss" "drscheme")
|
|
(lib "framework.ss" "framework"))
|
|
|
|
(provide text:drawings<%>
|
|
text:mouse-drawings<%>
|
|
text:arrows<%>
|
|
|
|
text:drawings-mixin
|
|
text:mouse-drawings-mixin
|
|
text:arrows-mixin)
|
|
|
|
(define (mean x y)
|
|
(/ (+ x y) 2))
|
|
|
|
(define-syntax with-saved-pen&brush
|
|
(syntax-rules ()
|
|
[(with-saved-pen&brush dc . body)
|
|
(save-pen&brush dc (lambda () . body))]))
|
|
|
|
(define (save-pen&brush dc thunk)
|
|
(let ([old-pen (send dc get-pen)]
|
|
[old-brush (send dc get-brush)])
|
|
(begin0 (thunk)
|
|
(send dc set-pen old-pen)
|
|
(send dc set-brush old-brush))))
|
|
|
|
(define-syntax with-saved-text-config
|
|
(syntax-rules ()
|
|
[(with-saved-text-config dc . body)
|
|
(save-text-config dc (lambda () . body))]))
|
|
|
|
(define (save-text-config dc thunk)
|
|
(let ([old-font (send dc get-font)]
|
|
[old-color (send dc get-text-foreground)]
|
|
[old-background (send dc get-text-background)]
|
|
[old-mode (send dc get-text-mode)])
|
|
(begin0 (thunk)
|
|
(send dc set-font old-font)
|
|
(send dc set-text-foreground old-color)
|
|
(send dc set-text-background old-background)
|
|
(send dc set-text-mode old-mode))))
|
|
|
|
(define text:drawings<%>
|
|
(interface (text:basic<%>)
|
|
add-drawings
|
|
delete-drawings
|
|
delete-all-drawings))
|
|
|
|
(define text:mouse-drawings<%>
|
|
(interface (text:drawings<%>)
|
|
add-mouse-drawing
|
|
delete-mouse-drawings))
|
|
|
|
(define text:arrows<%>
|
|
(interface (text:mouse-drawings<%>)
|
|
add-arrow
|
|
add-question-arrow))
|
|
|
|
(define text:drawings-mixin
|
|
(mixin (text:basic<%>) (text:drawings<%>)
|
|
(define draw-table (make-hash-table))
|
|
|
|
(define/public (add-drawings key draws)
|
|
(hash-table-put! draw-table
|
|
key
|
|
(append draws (hash-table-get draw-table key (lambda () null)))))
|
|
|
|
(define/public (delete-drawings key)
|
|
(hash-table-remove! draw-table key))
|
|
|
|
(define/public (delete-all-drawings)
|
|
(for-each (lambda (key) (hash-table-remove! draw-table key))
|
|
(hash-table-map draw-table (lambda (k v) k))))
|
|
|
|
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
|
|
(super on-paint before? dc left top right bottom dx dy draw-caret)
|
|
(unless before?
|
|
(hash-table-for-each
|
|
draw-table
|
|
(lambda (k v)
|
|
(for-each (lambda (d) (d this dc left top right bottom dx dy))
|
|
v)))))
|
|
|
|
(super-new)))
|
|
|
|
;; A Drawing is (make-drawing number number (??? -> void))
|
|
(define-struct drawing (start end draw) #f)
|
|
|
|
(define text:mouse-drawings-mixin
|
|
(mixin (text:drawings<%>) (text:mouse-drawings<%>)
|
|
(inherit dc-location-to-editor-location
|
|
find-position
|
|
invalidate-bitmap-cache
|
|
add-drawings
|
|
delete-drawings)
|
|
|
|
;; lists of Drawings
|
|
(field [inactive-list null]
|
|
[active-list null])
|
|
|
|
(define/public (add-mouse-drawing start end draw)
|
|
(set! inactive-list
|
|
(cons (make-drawing start end draw)
|
|
inactive-list)))
|
|
|
|
(define/public (delete-mouse-drawings)
|
|
(set! inactive-list null))
|
|
|
|
(define/override (delete-all-drawings)
|
|
(super delete-all-drawings)
|
|
(set! inactive-list null)
|
|
(set! active-list null))
|
|
|
|
(define/override (on-default-event ev)
|
|
(define gx (send ev get-x))
|
|
(define gy (send ev get-y))
|
|
(define-values (x y) (dc-location-to-editor-location gx gy))
|
|
(define pos (find-position x y))
|
|
(super on-default-event ev)
|
|
(case (send ev get-event-type)
|
|
((enter motion)
|
|
(let ([new-active-annotations
|
|
(filter (lambda (rec)
|
|
(<= (drawing-start rec) pos (drawing-end rec)))
|
|
inactive-list)])
|
|
(unless (equal? active-list new-active-annotations)
|
|
(set! active-list new-active-annotations)
|
|
(delete-drawings 'mouse-over)
|
|
(add-drawings 'mouse-over (map drawing-draw active-list))
|
|
(invalidate-bitmap-cache))))
|
|
((leave)
|
|
(unless (null? active-list)
|
|
(set! active-list null)
|
|
(delete-drawings 'mouse-over)
|
|
(invalidate-bitmap-cache)))))
|
|
|
|
(super-new)))
|
|
|
|
(define arrow-brush (send the-brush-list find-or-create-brush "white" 'solid))
|
|
|
|
(define text:arrows-mixin
|
|
(mixin (text:mouse-drawings<%>) (text:arrows<%>)
|
|
(inherit position-location
|
|
add-mouse-drawing
|
|
find-wordbreak
|
|
add-drawings
|
|
delete-drawings
|
|
get-canvas)
|
|
(inherit-field active-list inactive-list)
|
|
|
|
(define/public (add-arrow from1 from2 to1 to2 color)
|
|
(internal-add-arrow from1 from2 to1 to2 color #f))
|
|
|
|
(define/public (add-question-arrow from1 from2 to1 to2 color)
|
|
(internal-add-arrow from1 from2 to1 to2 color #t))
|
|
|
|
(define/private (internal-add-arrow from1 from2 to1 to2 color question?)
|
|
(unless (and (= from1 to1) (= from2 to2))
|
|
(let ([draw
|
|
(lambda (text dc left top right bottom dx dy)
|
|
(let*-values ([(start1x start1y) (position->location from1)]
|
|
[(start2x start2y) (position->location from2)]
|
|
[(end1x end1y) (position->location to1)]
|
|
[(end2x end2y) (position->location to2)]
|
|
[(startx) (mean start1x start2x)]
|
|
[(starty) (mean start1y start2y)]
|
|
[(endx) (mean end1x end2x)]
|
|
[(endy) (mean end1y end2y)]
|
|
[(fw fh _d _v) (send dc get-text-extent "")])
|
|
(let ([starty (+ starty (/ fh 2))]
|
|
[endy (+ endy (/ fh 2))])
|
|
(with-saved-pen&brush dc
|
|
(with-saved-text-config dc
|
|
(send dc set-pen color 1 'solid)
|
|
(send dc set-brush arrow-brush)
|
|
(draw-arrow dc startx starty endx endy dx dy)
|
|
#;(send dc set-text-mode 'solid)
|
|
(when question?
|
|
(send dc set-font (?-font dc))
|
|
(send dc set-text-foreground
|
|
(send the-color-database find-color color))
|
|
(send dc draw-text "?"
|
|
(+ (+ startx dx) fw)
|
|
(- (+ starty dy) fh))))))))])
|
|
(add-mouse-drawing from1 from2 draw)
|
|
(add-mouse-drawing to1 to2 draw))))
|
|
|
|
(define/private (position->location p)
|
|
(define xbox (box 0.0))
|
|
(define ybox (box 0.0))
|
|
(position-location p xbox ybox)
|
|
(values (unbox xbox) (unbox ybox)))
|
|
|
|
(define/override (on-event ev)
|
|
(case (send ev get-event-type)
|
|
((right-down)
|
|
(let ([arrows active-list])
|
|
(if (pair? arrows)
|
|
(send (get-canvas) popup-menu
|
|
(make-tack/untack-menu)
|
|
(send ev get-x)
|
|
(send ev get-y))
|
|
(super on-event ev))))
|
|
(else
|
|
(super on-event ev))))
|
|
|
|
(define/private (make-tack/untack-menu)
|
|
(define menu (new popup-menu%))
|
|
(new menu-item% (label "Tack arrows")
|
|
(parent menu)
|
|
(callback
|
|
(lambda _ (tack-arrows))))
|
|
(new menu-item% (label "Untack arrows")
|
|
(parent menu)
|
|
(callback
|
|
(lambda _ (untack-arrows))))
|
|
menu)
|
|
|
|
(define/private (tack-arrows)
|
|
(for-each (lambda (arrow)
|
|
(add-drawings (drawing-draw arrow) (list (drawing-draw arrow))))
|
|
active-list))
|
|
(define/private (untack-arrows)
|
|
(for-each (lambda (arrow) (delete-drawings (drawing-draw arrow)))
|
|
active-list))
|
|
|
|
(define/private (?-font dc)
|
|
(let ([size (send (send dc get-font) get-point-size)])
|
|
(send the-font-list find-or-create-font size 'default 'normal 'bold)))
|
|
|
|
(super-new)))
|
|
|
|
(define text:mouse-drawings%
|
|
(text:mouse-drawings-mixin
|
|
(text:drawings-mixin text:standard-style-list%)))
|
|
|
|
(define text:arrows%
|
|
(text:arrows-mixin text:mouse-drawings%))
|
|
|
|
#;
|
|
(begin
|
|
(define f (new frame% (label "testing") (width 100) (height 100)))
|
|
(define t (new text:crazy% (auto-wrap #t)))
|
|
(define ec (new editor-canvas% (parent f) (editor t)))
|
|
(send f show #t)
|
|
(send t insert "this is the time to remember, because it will not last forever\n")
|
|
(send t insert "these are the days to hold on to, but we won't although we'll want to\n")
|
|
|
|
(send t add-dot 5)
|
|
(send t add-arrow 25 8 "blue"))
|
|
|
|
)
|