commit cd359e9c9a1968f4af93d0911750f8332937aab6
parent d0781e4e82e84ea6463953f2bf7f9cee9569e69a
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Fri, 13 Apr 2007 16:56:32 +0000
Macro stepper: tackable arrows
svn: r5930
original commit: ebb27d0d0f482ebaf946fff2fb63bd38ba7f1ff6
Diffstat:
2 files changed, 82 insertions(+), 80 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/text.ss b/collects/macro-debugger/syntax-browser/text.ss
@@ -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%
@@ -209,38 +243,6 @@
(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)))
(define t (new text:crazy% (auto-wrap #t)))
diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss
@@ -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)
