suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Macro stepper: tackable arrows

Browse Source 
svn: r5930
This commit is contained in:
Ryan Culpepper 2007-04-13 16:56:32 +00:00
parent 80af3f491c
commit ebb27d0d0f
2 changed files with 82 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

160
collects/macro-debugger/syntax-browser/text.ss
View File

@ -9,31 +9,31 @@
(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)]
@ -44,34 +44,39 @@
(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-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?
@ -80,9 +85,12 @@
(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
@ -90,18 +98,24 @@
invalidate-bitmap-cache
add-drawings
delete-drawings)
(define inactive-list null)
(define active-list null)
;; lists of Drawings
(field [inactive-list null]
[active-list null])
(define/public (add-mouse-drawing start end draw)
(set! inactive-list
(cons (cons (cons start end) draw)
(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))
@ -111,19 +125,20 @@
(case (send ev get-event-type)
((enter motion)
(let ([new-active-annotations
(filter (lambda (rec) (<= (caar rec) pos (cdar rec)))
(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 cdr active-list))
(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))
@ -132,18 +147,18 @@
(mixin (text:mouse-drawings<%>) (text:arrows<%>)
(inherit position-location
add-mouse-drawing
find-wordbreak)
(define (?-font dc)
(let ([size (send (send dc get-font) get-point-size)])
(send the-font-list find-or-create-font size 'default 'normal 'bold)))
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
@ -181,24 +196,43 @@
(position-location p xbox ybox)
(values (unbox xbox) (unbox ybox)))
#;
(define/public (add-dot position)
(define-values (pos1 pos2) (word-at position))
(add-mouse-drawing pos1 pos2
(lambda (text dc left top right bottom dx dy)
(let-values ([(x y) (position->location position)])
(send dc draw-ellipse
(+ x dx)
(+ y dy)
20 20)))))
#;
(define/private (word-at p)
(define sbox (box p))
(define ebox (box p))
(find-wordbreak sbox ebox 'caret)
(values (unbox sbox) (unbox ebox)))
(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%
@ -208,38 +242,6 @@
(define text:arrows%
(text:arrows-mixin text:mouse-drawings%))
#;
(define text:crazy%
(class text:arrows%
(inherit add-arrow
find-position
invalidate-bitmap-cache)
(define loc #f)
(define prev-pos #f)
(define/override (on-default-event ev)
(define x (send ev get-x))
(define y (send ev get-y))
(case (send ev get-event-type)
((motion)
(set! loc (cons x y))
(when prev-pos (invalidate-bitmap-cache)))
((left-down)
(let ([pos (find-position x y)])
(if prev-pos
(when (and pos (not (= pos prev-pos)))
(add-arrow prev-pos pos "red")
(set! prev-pos #f))
(set! prev-pos pos)))))
(super on-default-event ev))
(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?
(when (and loc prev-pos)
(send dc draw-ellipse (- (car loc) 5) (- (cdr loc) 5) 10 10))))
(super-new)))
#;
(begin
(define f (new frame% (label "testing") (width 100) (height 100)))

2
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -141,7 +141,7 @@
(define/public (erase-all)
(with-unlock -text
(send -text erase)
(send -text delete-mouse-drawings))
(send -text delete-all-drawings))
(send controller erase))
(define/public (select-syntax stx)