From ebb27d0d0f482ebaf946fff2fb63bd38ba7f1ff6 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 13 Apr 2007 16:56:32 +0000 Subject: [PATCH] Macro stepper: tackable arrows svn: r5930 --- .../macro-debugger/syntax-browser/text.ss | 160 +++++++++--------- .../macro-debugger/syntax-browser/widget.ss | 2 +- 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 index dc6d9f310d..826fa04610 100644 --- 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% @@ -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))) diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index 64133d5185..f80df0b765 100644 --- 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)