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

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

@ -48,7 +48,8 @@
(define text:drawings<%>
(interface (text:basic<%>)
add-drawings
delete-drawings))
delete-drawings
delete-all-drawings))
(define text:mouse-drawings<%>
(interface (text:drawings<%>)
@ -72,6 +73,10 @@
(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?
@ -83,6 +88,9 @@
(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
@ -91,17 +99,23 @@
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,12 +125,13 @@
(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)
@ -132,11 +147,11 @@
(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))
@ -181,23 +196,42 @@
(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/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 (word-at p)
(define sbox (box p))
(define ebox (box p))
(find-wordbreak sbox ebox 'caret)
(values (unbox sbox) (unbox ebox)))
(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)))
@ -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)