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<%> (provide text:drawings<%>
text:mouse-drawings<%> text:mouse-drawings<%>
text:arrows<%> text:arrows<%>
text:drawings-mixin text:drawings-mixin
text:mouse-drawings-mixin text:mouse-drawings-mixin
text:arrows-mixin) text:arrows-mixin)
(define (mean x y) (define (mean x y)
(/ (+ x y) 2)) (/ (+ x y) 2))
(define-syntax with-saved-pen&brush (define-syntax with-saved-pen&brush
(syntax-rules () (syntax-rules ()
[(with-saved-pen&brush dc . body) [(with-saved-pen&brush dc . body)
(save-pen&brush dc (lambda () . body))])) (save-pen&brush dc (lambda () . body))]))
(define (save-pen&brush dc thunk) (define (save-pen&brush dc thunk)
(let ([old-pen (send dc get-pen)] (let ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]) [old-brush (send dc get-brush)])
(begin0 (thunk) (begin0 (thunk)
(send dc set-pen old-pen) (send dc set-pen old-pen)
(send dc set-brush old-brush)))) (send dc set-brush old-brush))))
(define-syntax with-saved-text-config (define-syntax with-saved-text-config
(syntax-rules () (syntax-rules ()
[(with-saved-text-config dc . body) [(with-saved-text-config dc . body)
(save-text-config dc (lambda () . body))])) (save-text-config dc (lambda () . body))]))
(define (save-text-config dc thunk) (define (save-text-config dc thunk)
(let ([old-font (send dc get-font)] (let ([old-font (send dc get-font)]
[old-color (send dc get-text-foreground)] [old-color (send dc get-text-foreground)]
@ -44,34 +44,39 @@
(send dc set-text-foreground old-color) (send dc set-text-foreground old-color)
(send dc set-text-background old-background) (send dc set-text-background old-background)
(send dc set-text-mode old-mode)))) (send dc set-text-mode old-mode))))
(define text:drawings<%> (define text:drawings<%>
(interface (text:basic<%>) (interface (text:basic<%>)
add-drawings add-drawings
delete-drawings)) delete-drawings
delete-all-drawings))
(define text:mouse-drawings<%> (define text:mouse-drawings<%>
(interface (text:drawings<%>) (interface (text:drawings<%>)
add-mouse-drawing add-mouse-drawing
delete-mouse-drawings)) delete-mouse-drawings))
(define text:arrows<%> (define text:arrows<%>
(interface (text:mouse-drawings<%>) (interface (text:mouse-drawings<%>)
add-arrow add-arrow
add-question-arrow)) add-question-arrow))
(define text:drawings-mixin (define text:drawings-mixin
(mixin (text:basic<%>) (text:drawings<%>) (mixin (text:basic<%>) (text:drawings<%>)
(define draw-table (make-hash-table)) (define draw-table (make-hash-table))
(define/public (add-drawings key draws) (define/public (add-drawings key draws)
(hash-table-put! draw-table (hash-table-put! draw-table
key key
(append draws (hash-table-get draw-table key (lambda () null))))) (append draws (hash-table-get draw-table key (lambda () null)))))
(define/public (delete-drawings key) (define/public (delete-drawings key)
(hash-table-remove! draw-table 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) (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) (super on-paint before? dc left top right bottom dx dy draw-caret)
(unless before? (unless before?
@ -80,9 +85,12 @@
(lambda (k v) (lambda (k v)
(for-each (lambda (d) (d this dc left top right bottom dx dy)) (for-each (lambda (d) (d this dc left top right bottom dx dy))
v))))) v)))))
(super-new))) (super-new)))
;; A Drawing is (make-drawing number number (??? -> void))
(define-struct drawing (start end draw) #f)
(define text:mouse-drawings-mixin (define text:mouse-drawings-mixin
(mixin (text:drawings<%>) (text:mouse-drawings<%>) (mixin (text:drawings<%>) (text:mouse-drawings<%>)
(inherit dc-location-to-editor-location (inherit dc-location-to-editor-location
@ -90,18 +98,24 @@
invalidate-bitmap-cache invalidate-bitmap-cache
add-drawings add-drawings
delete-drawings) delete-drawings)
(define inactive-list null) ;; lists of Drawings
(define active-list null) (field [inactive-list null]
[active-list null])
(define/public (add-mouse-drawing start end draw) (define/public (add-mouse-drawing start end draw)
(set! inactive-list (set! inactive-list
(cons (cons (cons start end) draw) (cons (make-drawing start end draw)
inactive-list))) inactive-list)))
(define/public (delete-mouse-drawings) (define/public (delete-mouse-drawings)
(set! inactive-list null)) (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/override (on-default-event ev)
(define gx (send ev get-x)) (define gx (send ev get-x))
(define gy (send ev get-y)) (define gy (send ev get-y))
@ -111,19 +125,20 @@
(case (send ev get-event-type) (case (send ev get-event-type)
((enter motion) ((enter motion)
(let ([new-active-annotations (let ([new-active-annotations
(filter (lambda (rec) (<= (caar rec) pos (cdar rec))) (filter (lambda (rec)
(<= (drawing-start rec) pos (drawing-end rec)))
inactive-list)]) inactive-list)])
(unless (equal? active-list new-active-annotations) (unless (equal? active-list new-active-annotations)
(set! active-list new-active-annotations) (set! active-list new-active-annotations)
(delete-drawings 'mouse-over) (delete-drawings 'mouse-over)
(add-drawings 'mouse-over (map cdr active-list)) (add-drawings 'mouse-over (map drawing-draw active-list))
(invalidate-bitmap-cache)))) (invalidate-bitmap-cache))))
((leave) ((leave)
(unless (null? active-list) (unless (null? active-list)
(set! active-list null) (set! active-list null)
(delete-drawings 'mouse-over) (delete-drawings 'mouse-over)
(invalidate-bitmap-cache))))) (invalidate-bitmap-cache)))))
(super-new))) (super-new)))
(define arrow-brush (send the-brush-list find-or-create-brush "white" 'solid)) (define arrow-brush (send the-brush-list find-or-create-brush "white" 'solid))
@ -132,18 +147,18 @@
(mixin (text:mouse-drawings<%>) (text:arrows<%>) (mixin (text:mouse-drawings<%>) (text:arrows<%>)
(inherit position-location (inherit position-location
add-mouse-drawing add-mouse-drawing
find-wordbreak) find-wordbreak
add-drawings
(define (?-font dc) delete-drawings
(let ([size (send (send dc get-font) get-point-size)]) get-canvas)
(send the-font-list find-or-create-font size 'default 'normal 'bold))) (inherit-field active-list inactive-list)
(define/public (add-arrow from1 from2 to1 to2 color) (define/public (add-arrow from1 from2 to1 to2 color)
(internal-add-arrow from1 from2 to1 to2 color #f)) (internal-add-arrow from1 from2 to1 to2 color #f))
(define/public (add-question-arrow from1 from2 to1 to2 color) (define/public (add-question-arrow from1 from2 to1 to2 color)
(internal-add-arrow from1 from2 to1 to2 color #t)) (internal-add-arrow from1 from2 to1 to2 color #t))
(define/private (internal-add-arrow from1 from2 to1 to2 color question?) (define/private (internal-add-arrow from1 from2 to1 to2 color question?)
(unless (and (= from1 to1) (= from2 to2)) (unless (and (= from1 to1) (= from2 to2))
(let ([draw (let ([draw
@ -181,24 +196,43 @@
(position-location p xbox ybox) (position-location p xbox ybox)
(values (unbox xbox) (unbox ybox))) (values (unbox xbox) (unbox ybox)))
#; (define/override (on-event ev)
(define/public (add-dot position) (case (send ev get-event-type)
(define-values (pos1 pos2) (word-at position)) ((right-down)
(add-mouse-drawing pos1 pos2 (let ([arrows active-list])
(lambda (text dc left top right bottom dx dy) (if (pair? arrows)
(let-values ([(x y) (position->location position)]) (send (get-canvas) popup-menu
(send dc draw-ellipse (make-tack/untack-menu)
(+ x dx) (send ev get-x)
(+ y dy) (send ev get-y))
20 20))))) (super on-event ev))))
(else
#; (super on-event ev))))
(define/private (word-at p)
(define sbox (box p)) (define/private (make-tack/untack-menu)
(define ebox (box p)) (define menu (new popup-menu%))
(find-wordbreak sbox ebox 'caret) (new menu-item% (label "Tack arrows")
(values (unbox sbox) (unbox ebox))) (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))) (super-new)))
(define text:mouse-drawings% (define text:mouse-drawings%
@ -208,38 +242,6 @@
(define text:arrows% (define text:arrows%
(text:arrows-mixin text:mouse-drawings%)) (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 (begin
(define f (new frame% (label "testing") (width 100) (height 100))) (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) (define/public (erase-all)
(with-unlock -text (with-unlock -text
(send -text erase) (send -text erase)
(send -text delete-mouse-drawings)) (send -text delete-all-drawings))
(send controller erase)) (send controller erase))
(define/public (select-syntax stx) (define/public (select-syntax stx)