324 lines
11 KiB
Scheme
324 lines
11 KiB
Scheme
|
|
#lang scheme/base
|
|
(require scheme/list
|
|
scheme/class
|
|
scheme/gui
|
|
drscheme/arrow
|
|
framework/framework
|
|
"../util/notify.ss")
|
|
|
|
(provide text:hover<%>
|
|
text:hover-identifier<%>
|
|
text:mouse-drawings<%>
|
|
text:arrows<%>
|
|
|
|
text:hover-mixin
|
|
text:hover-identifier-mixin
|
|
text:mouse-drawings-mixin
|
|
text:tacking-mixin
|
|
text:arrows-mixin)
|
|
|
|
(define arrow-brush
|
|
(send the-brush-list find-or-create-brush "white" 'solid))
|
|
(define (tacked-arrow-brush color)
|
|
(send the-brush-list find-or-create-brush color 'solid))
|
|
|
|
(define billboard-brush
|
|
(send the-brush-list find-or-create-brush "white" 'solid))
|
|
|
|
(define white (send the-color-database find-color "white"))
|
|
|
|
;; A Drawing is (make-drawing number number (??? -> void) boolean boolean)
|
|
(define-struct drawing (start end draw visible? tacked?) #:mutable)
|
|
|
|
(define-struct idloc (start end id))
|
|
|
|
(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:hover<%>
|
|
(interface (text:basic<%>)
|
|
update-hover-position))
|
|
|
|
(define text:hover-identifier<%>
|
|
(interface ()
|
|
get-hovered-identifier
|
|
set-hovered-identifier
|
|
listen-hovered-identifier))
|
|
|
|
(define text:mouse-drawings<%>
|
|
(interface (text:basic<%>)
|
|
add-mouse-drawing
|
|
for-each-drawing
|
|
delete-all-drawings))
|
|
|
|
(define text:arrows<%>
|
|
(interface (text:mouse-drawings<%>)
|
|
add-arrow
|
|
add-question-arrow
|
|
add-billboard))
|
|
|
|
(define text:hover-mixin
|
|
(mixin (text:basic<%>) (text:hover<%>)
|
|
(inherit dc-location-to-editor-location
|
|
find-position)
|
|
|
|
(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 leave)
|
|
(update-hover-position pos))))
|
|
|
|
(define/public (update-hover-position pos)
|
|
(void))
|
|
|
|
(super-new)))
|
|
|
|
(define text:hover-identifier-mixin
|
|
(mixin (text:hover<%>) (text:hover-identifier<%>)
|
|
(field/notify hovered-identifier (new notify-box% (value #f)))
|
|
|
|
(define idlocs null)
|
|
|
|
(define/public (add-identifier-location start end id)
|
|
(set! idlocs (cons (make-idloc start end id) idlocs)))
|
|
|
|
(define/public (delete-all-identifier-locations)
|
|
(set! idlocs null)
|
|
(set-hovered-identifier #f))
|
|
|
|
(define/override (update-hover-position pos)
|
|
(super update-hover-position pos)
|
|
(let search ([idlocs idlocs])
|
|
(cond [(null? idlocs) (set-hovered-identifier #f)]
|
|
[(and (<= (idloc-start (car idlocs)) pos)
|
|
(< pos (idloc-end (car idlocs))))
|
|
(set-hovered-identifier (idloc-id (car idlocs)))]
|
|
[else (search (cdr idlocs))])))
|
|
(super-new)))
|
|
|
|
(define text:mouse-drawings-mixin
|
|
(mixin (text:hover<%>) (text:mouse-drawings<%>)
|
|
(inherit dc-location-to-editor-location
|
|
find-position
|
|
invalidate-bitmap-cache)
|
|
|
|
;; list of Drawings
|
|
(field [drawings-list null])
|
|
|
|
(define/public add-mouse-drawing
|
|
(case-lambda
|
|
[(start end draw)
|
|
(add-mouse-drawing start end draw (box #f))]
|
|
[(start end draw tack-box)
|
|
(set! drawings-list
|
|
(cons (make-drawing start end draw #f tack-box)
|
|
drawings-list))]))
|
|
|
|
(define/public (delete-all-drawings)
|
|
(set! drawings-list null))
|
|
|
|
(define/public-final (for-each-drawing f)
|
|
(for-each f drawings-list))
|
|
|
|
(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?
|
|
(for-each-drawing
|
|
(lambda (d)
|
|
(when (or (drawing-visible? d) (unbox (drawing-tacked? d)))
|
|
((drawing-draw d) this dc left top right bottom dx dy))))))
|
|
|
|
(define/override (update-hover-position pos)
|
|
(super update-hover-position pos)
|
|
(let ([changed? (update-visible-drawings pos)])
|
|
(when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))))
|
|
|
|
(define/private (update-visible-drawings pos)
|
|
(let ([changed? #f])
|
|
(for-each-drawing
|
|
(lambda (d)
|
|
(let ([vis? (<= (drawing-start d) pos (drawing-end d))])
|
|
(unless (eqv? vis? (drawing-visible? d))
|
|
(set-drawing-visible?! d vis?)
|
|
(set! changed? #t)))))
|
|
changed?))
|
|
|
|
(super-new)))
|
|
|
|
(define text:tacking-mixin
|
|
(mixin (text:basic<%> text:mouse-drawings<%>) ()
|
|
(inherit get-canvas
|
|
for-each-drawing)
|
|
(inherit-field drawings-list)
|
|
(super-new)
|
|
|
|
(define/override (on-event ev)
|
|
(case (send ev get-event-type)
|
|
((right-down)
|
|
(if (ormap (lambda (d) (drawing-visible? d)) drawings-list)
|
|
(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")
|
|
(parent menu)
|
|
(callback
|
|
(lambda _ (tack))))
|
|
(new menu-item% (label "Untack")
|
|
(parent menu)
|
|
(callback
|
|
(lambda _ (untack))))
|
|
menu)
|
|
|
|
(define/private (tack)
|
|
(for-each-drawing
|
|
(lambda (d)
|
|
(when (drawing-visible? d)
|
|
(set-box! (drawing-tacked? d) #t)))))
|
|
(define/private (untack)
|
|
(for-each-drawing
|
|
(lambda (d)
|
|
(when (drawing-visible? d)
|
|
(set-box! (drawing-tacked? d) #f)))))))
|
|
|
|
(define text:arrows-mixin
|
|
(mixin (text:mouse-drawings<%>) (text:arrows<%>)
|
|
(inherit position-location
|
|
add-mouse-drawing
|
|
find-wordbreak)
|
|
|
|
(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/public (add-billboard pos1 pos2 str color-name)
|
|
(define color (send the-color-database find-color color-name))
|
|
(let ([draw
|
|
(lambda (text dc left top right bottom dx dy)
|
|
(let-values ([(x y) (range->mean-loc pos1 pos1)]
|
|
[(fw fh _d _v) (send dc get-text-extent "y")])
|
|
(with-saved-pen&brush dc
|
|
(with-saved-text-config dc
|
|
(send* dc
|
|
(set-pen color 1 'solid)
|
|
(set-brush billboard-brush)
|
|
(set-text-mode 'solid)
|
|
(set-font (billboard-font dc))
|
|
(set-text-foreground color))
|
|
(let-values ([(w h d v) (send dc get-text-extent str)]
|
|
[(adj-y) fh]
|
|
[(mini) _d])
|
|
(send* dc
|
|
(draw-rounded-rectangle
|
|
(+ x dx)
|
|
(+ y dy adj-y)
|
|
(+ w mini mini)
|
|
(+ h mini mini))
|
|
(draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))])
|
|
(add-mouse-drawing pos1 pos2 draw)))
|
|
|
|
(define/private (internal-add-arrow from1 from2 to1 to2 color-name question?)
|
|
(define color (send the-color-database find-color color-name))
|
|
(define tack-box (box #f))
|
|
(unless (and (= from1 to1) (= from2 to2))
|
|
(let ([draw
|
|
(lambda (text dc left top right bottom dx dy)
|
|
(let-values ([(startx starty) (range->mean-loc from1 from2)]
|
|
[(endx endy) (range->mean-loc to1 to2)]
|
|
[(fw fh _d _v) (send dc get-text-extent "x")])
|
|
(with-saved-pen&brush dc
|
|
(with-saved-text-config dc
|
|
(send dc set-pen color 1 'solid)
|
|
(send dc set-brush
|
|
(if (unbox tack-box)
|
|
(tacked-arrow-brush color)
|
|
arrow-brush))
|
|
(draw-arrow dc startx
|
|
(+ starty (/ fh 2))
|
|
endx
|
|
(+ endy (/ fh 2))
|
|
dx dy)
|
|
(send dc set-text-mode 'transparent)
|
|
(when question?
|
|
(send dc set-font (?-font dc))
|
|
(send dc set-text-foreground color)
|
|
(send dc draw-text "?"
|
|
(+ endx dx fw)
|
|
(- endy dy fh)))))))])
|
|
(add-mouse-drawing from1 from2 draw tack-box)
|
|
(add-mouse-drawing to1 to2 draw tack-box))))
|
|
|
|
(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/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)))
|
|
|
|
(define/private (billboard-font dc)
|
|
(let ([size (send (send dc get-font) get-point-size)])
|
|
(send the-font-list find-or-create-font size 'default 'normal)))
|
|
|
|
(define/private (range->mean-loc pos1 pos2)
|
|
(let*-values ([(loc1x loc1y) (position->location pos1)]
|
|
[(loc2x loc2y) (position->location pos2)]
|
|
[(locx) (mean loc1x loc2x)]
|
|
[(locy) (mean loc1y loc2y)])
|
|
(values locx locy)))
|
|
|
|
(super-new)))
|
|
|
|
(define text:mouse-drawings%
|
|
(text:mouse-drawings-mixin
|
|
(text:hover-mixin
|
|
text:standard-style-list%)))
|
|
|
|
(define text:arrows%
|
|
(text:arrows-mixin
|
|
(text:tacking-mixin
|
|
text:mouse-drawings%)))
|