From ea2ea13a841b464f65077ff1160565a0f2ca89ef Mon Sep 17 00:00:00 2001 From: Jacob Matthews Date: Sat, 22 Oct 2005 02:47:51 +0000 Subject: [PATCH] merged 1115:1124 from branches/redex-names, adds support for named reductions that get drawn in the traces window svn: r1126 original commit: a255e439ea7abebb1e45b3bb963a77e468801e29 --- collects/mrlib/graph.ss | 201 ++++++++++++++++++++++++++++++++-------- 1 file changed, 164 insertions(+), 37 deletions(-) diff --git a/collects/mrlib/graph.ss b/collects/mrlib/graph.ss index 5451b085..ea8bacc3 100644 --- a/collects/mrlib/graph.ss +++ b/collects/mrlib/graph.ss @@ -15,10 +15,11 @@ get-children add-child remove-child - + get-parents add-parent remove-parent + has-self-loop? find-shortest-path)) @@ -36,6 +37,17 @@ (union false/c (is-a?/c pen%)) (union false/c (is-a?/c brush%)) (union false/c (is-a?/c brush%)) + number? + number? + . -> . + void?) + ((is-a?/c graph-snip<%>) + (is-a?/c graph-snip<%>) + (union false/c (is-a?/c pen%)) + (union false/c (is-a?/c pen%)) + (union false/c (is-a?/c brush%)) + (union false/c (is-a?/c brush%)) + (union false/c string?) . -> . void?) ((is-a?/c graph-snip<%>) @@ -47,8 +59,22 @@ number? number? . -> . - void?)))) - + void?))) + (add-links/text-colors + ((is-a?/c graph-snip<%>) + (is-a?/c graph-snip<%>) + (union false/c (is-a?/c pen%)) + (union false/c (is-a?/c pen%)) + (union false/c (is-a?/c brush%)) + (union false/c (is-a?/c brush%)) + (union false/c (is-a?/c color%)) + (union false/c (is-a?/c color%)) + number? + number? + (union false/c string?) + . -> . + void?))) + (define self-offset 10) ;; (or-2v arg ...) @@ -72,8 +98,12 @@ (define default-light-pen (send the-pen-list find-or-create-pen "light blue" 1 'solid)) (define default-dark-brush (send the-brush-list find-or-create-brush "light blue" 'solid)) (define default-light-brush (send the-brush-list find-or-create-brush "white" 'solid)) + (define default-dark-text "blue") + (define default-light-text "light blue") - (define-struct link (snip dark-pen light-pen dark-brush light-brush dx dy)) + + ;; label is boolean or string + (define-struct link (snip dark-pen light-pen dark-brush light-brush dark-text light-text dx dy label)) ;; add-links : (is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) -> void ;; : (is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) pen pen brush brush -> void @@ -82,12 +112,20 @@ [(parent child) (add-links parent child #f #f #f #f)] [(parent child dark-pen light-pen dark-brush light-brush) (add-links parent child dark-pen light-pen dark-brush light-brush 0 0)] + [(parent child dark-pen light-pen dark-brush light-brush label) + (add-links parent child dark-pen light-pen dark-brush light-brush 0 0 label)] [(parent child dark-pen light-pen dark-brush light-brush dx dy) + (add-links parent child dark-pen light-pen dark-brush light-brush dx dy #f)] + [(parent child dark-pen light-pen dark-brush light-brush dx dy label) (send parent add-child child) - (send child add-parent parent dark-pen light-pen dark-brush light-brush dx dy)])) + (send child add-parent parent dark-pen light-pen dark-brush light-brush dx dy label)])) - (define (graph-snip-mixin %) - (class* % (graph-snip<%>) + (define (add-links/text-colors parent child dark-pen light-pen dark-brush light-brush dark-text light-text dx dy label) + (send parent add-child child) + (send child add-parent parent dark-pen light-pen dark-brush light-brush dark-text light-text dx dy label)) + + (define graph-snip-mixin + (mixin ((class->interface editor-snip%)) (graph-snip<%>) (field (children null)) (define/public (get-children) children) (define/public (add-child child) @@ -106,6 +144,10 @@ [(parent dark-pen light-pen dark-brush light-brush) (add-parent parent dark-pen light-pen dark-brush light-brush 0 0)] [(parent dark-pen light-pen dark-brush light-brush dx dy) + (add-parent parent dark-pen light-pen dark-brush light-brush dx dy #f)] + [(parent dark-pen light-pen dark-brush light-brush dx dy) + (add-parent parent dark-pen light-pen dark-brush light-brush #f #f dx dy #f)] + [(parent dark-pen light-pen dark-brush light-brush dark-text light-text dx dy label) (unless (memf (lambda (parent-link) (eq? (link-snip parent-link) parent)) parent-links) (set! parent-links (cons (make-link parent @@ -113,8 +155,11 @@ (or light-pen default-light-pen) (or dark-brush default-dark-brush) (or light-brush default-light-brush) + (or dark-text default-dark-text) + (or light-text default-light-text) dx - dy) + dy + label) parent-links)))])) (define/public (remove-parent parent) (when (memf (lambda (parent-link) (eq? (link-snip parent-link) parent)) parent-links) @@ -124,6 +169,9 @@ parent-links (lambda (parent parent-link) (eq? (link-snip parent-link) parent)))))) + (define/public (has-self-loop?) + (memq this (get-children))) + (define/public (find-shortest-path other) (define visited-ht (make-hash-table)) (define (first-view? n) @@ -147,7 +195,29 @@ (map (lambda (child) (cons child path)) (filter first-view? (send (car path) get-children))) acc)))]))]))) - (super-instantiate ()) + (init-field [left-margin 1] + [right-margin 1] + [top-margin 1] + [bottom-margin 1] + + [left-inset 0] + [right-inset 0] + [top-inset 0] + [bottom-inset 0] + ) + + (super-new [left-margin left-margin] + [right-margin right-margin] + [top-margin top-margin] + [bottom-margin bottom-margin] + + [left-inset left-inset] + [right-inset right-inset] + [top-inset top-inset] + [bottom-inset bottom-inset] + ) + + (inherit set-snipclass) (set-snipclass snipclass))) @@ -176,19 +246,19 @@ arrowhead-long-side arrowhead-short-side)) - (inherit dc-location-to-editor-location get-canvas) + (inherit dc-location-to-editor-location get-canvas get-dc) (field (currently-overs null)) (define/override (on-event evt) (cond [(send evt leaving?) - (change-currently-overs null) + (change-currently-overs null (get-dc)) (super on-event evt)] [(or (send evt entering?) (send evt moving?)) (let ([ex (send evt get-x)] [ey (send evt get-y)]) (let-values ([(x y) (dc-location-to-editor-location ex ey)]) - (change-currently-overs (find-snips-under-mouse x y)))) + (change-currently-overs (find-snips-under-mouse x y) (get-dc)))) (super on-event evt)] [else (super on-event evt)])) @@ -203,11 +273,11 @@ #;(super on-interactive-move evt)) (define/override (interactive-adjust-move snip x y) - (invalidate-to-children/parents snip) + (invalidate-to-children/parents snip (get-dc)) (super interactive-adjust-move snip x y)) (define/augment (after-insert snip before x y) - (invalidate-to-children/parents snip) + (invalidate-to-children/parents snip (get-dc)) #;(super after-insert snip before x y)) ;; invalidate-selected-snips : -> void @@ -216,7 +286,7 @@ (define/private (invalidate-selected-snips) (let loop ([snip (find-next-selected-snip #f)]) (when snip - (invalidate-to-children/parents snip) + (invalidate-to-children/parents snip (get-dc)) (loop (find-next-selected-snip snip))))) (define/private (add-to-rect from to rect) @@ -236,7 +306,6 @@ (max (+ yf hf) (+ yt ht) (rect-bottom rect)) (max (+ yf hf) (+ yt ht)))))) - ;; find-snips-under-mouse : num num -> (listof graph-snip<%>) (define/private (find-snips-under-mouse x y) (let loop ([snip (find-first-snip)]) @@ -251,7 +320,7 @@ [else null]))) ;; change-currently-overs : (listof snip) -> void - (define/private (change-currently-overs new-currently-overs) + (define/private (change-currently-overs new-currently-overs dc) (unless (set-equal new-currently-overs currently-overs) (let ([old-currently-overs currently-overs]) (set! currently-overs new-currently-overs) @@ -259,11 +328,11 @@ (on-mouse-over-snips currently-overs) (for-each (lambda (old-currently-over) - (invalidate-to-children/parents old-currently-over)) + (invalidate-to-children/parents old-currently-over dc)) old-currently-overs) (for-each (lambda (new-currently-over) - (invalidate-to-children/parents new-currently-over)) + (invalidate-to-children/parents new-currently-over dc)) new-currently-overs)))) (define/public (on-mouse-over-snips snips) @@ -277,24 +346,29 @@ (andmap (lambda (s2) (memq s2 los1)) los2) #t)) - ;; invalidate-to-children/parents : snip -> void + ;; invalidate-to-children/parents : snip dc -> void ;; invalidates the region containing this snip and ;; all of its children and parents. (inherit invalidate-bitmap-cache) - (define/private (invalidate-to-children/parents snip) + (define/private (invalidate-to-children/parents snip dc) (when (is-a? snip graph-snip<%>) (let* ([parents-and-children (append (get-all-parents snip) (get-all-children snip))] [rects (eliminate-redundancies (get-rectangles snip parents-and-children))] [union (union-rects rects)] + [text-height (call-with-values + (λ () (send dc get-text-extent "Label" #f #f 0)) + (λ (w h a s) h))] [invalidate-rect (lambda (rect) - (invalidate-bitmap-cache (rect-left rect) - (rect-top rect) - (- (rect-right rect) - (rect-left rect)) - (- (rect-bottom rect) - (rect-top rect))))]) + (invalidate-bitmap-cache (- (rect-left rect) text-height) + (- (rect-top rect) text-height) + (+ (- (rect-right rect) + (rect-left rect)) + text-height) + (+ (- (rect-bottom rect) + (rect-top rect)) + text-height)))]) (cond [(< (rect-area union) (apply + (map (lambda (x) (rect-area x)) rects))) @@ -338,20 +412,24 @@ (let* ([c/p (car c/p-snips)] [rect (if (eq? c/p main-snip) - (let-values ([(sx sy sw sh) (get-position c/p)]) + (let-values ([(sx sy sw sh) (get-position c/p)] + [(_1 h _2 _3) (send (get-dc) get-text-extent "yX")]) (make-rect (- sx self-offset) sy (+ (+ sx sw) self-offset) - (+ (+ sy sh) self-offset))) + (+ (+ sy sh) self-offset h))) (union-rects (list main-snip-rect (snip->rect c/p))))]) (cons rect (loop (cdr c/p-snips))))])))) (define/private (snip->rect snip) - (let-values ([(sx sy sw sh) (get-position snip)]) - (make-rect sx sy (+ sx sw) (+ sy sh)))) + (let-values ([(sx sy sw sh) (get-position snip)] + [(_1 h _2 _3) (send (get-dc) get-text-extent "yX")]) + (make-rect sx + sy + (+ sx sw) + (max (+ sy sh) (+ sy (/ sh 2) (* 2 (sin (/ arrowhead-angle-width 2)) arrowhead-long-side) h))))) - (define/private (rect-area rect) (* (- (rect-right rect) (rect-left rect)) @@ -553,11 +631,15 @@ (cond [(eq? from to) (set-pen/brush from-link dark-lines?) - (draw-self-connection dx dy (link-snip from-link))] + (draw-self-connection dx dy (link-snip from-link) from-link dark-lines?)] [else (draw-non-self-connection dx dy from-link dark-lines? to)]))))) - (define (draw-self-connection dx dy snip) + (define (get-text-length txt) + (let-values ([(text-len h d v) (send dc get-text-extent txt)]) + text-len)) + + (define (draw-self-connection dx dy snip the-link dark-lines?) (let*-values ([(sx sy sw sh) (get-position snip)] [(s1x s1y) (values (+ sx sw) (+ sy (* sh 1/2)))] [(s2x s2y) (values (+ sx sw self-offset) (+ sy (* 3/4 sh) (* 1/2 self-offset)))] @@ -578,6 +660,19 @@ (send dc draw-spline (+ dx s1x) (+ dy s1y) (+ dx b12x) (+ dy b12y) (+ dx s2x) (+ dy s2y)) (send dc draw-spline (+ dx s2x) (+ dy s2y) (+ dx b23x) (+ dy b23y) (+ dx s3x) (+ dy s3y)) (send dc draw-line (+ dx s3x) (+ dy s3y) (+ dx s6x) (+ dy s6y)) + + (let* ((textlen (get-text-length (link-label the-link))) + (linelen (- s6x s3x)) + (offset (* 1/2 (- linelen textlen)))) + (when #t (> sw textlen) + (send dc draw-text + (link-label the-link) + (+ dx s3x offset) + (+ dy s3y) + #f + 0 + 0))) + (send dc draw-spline (+ dx s4x) (+ dy s4y) (+ dx b45x) (+ dy b45y) (+ dx s5x) (+ dy s5y)) (send dc draw-spline (+ dx s5x) (+ dy s5y) (+ dx b56x) (+ dy b56y) (+ dx s6x) (+ dy s6y)) (send dc draw-polygon points dx dy))) @@ -613,7 +708,8 @@ (find-intersection x1 y1 x2 y2 rt tt rt bt))]) (when (and from-x from-y to-x to-y) - (let () + (let ((from-pt (make-rectangular from-x from-y)) + (to-pt (make-rectangular to-x to-y))) (define (arrow-point-ok? point-x point-y) (and (in-rectangle? point-x point-y (min lt rt lf rf) (min tt bt tf bf) @@ -640,7 +736,31 @@ (arrow-point-ok? (send point4 get-x) (send point4 get-y))) ;; the arrowhead is not overlapping the snips, so draw it ;; (this is only an approximate test, but probably good enough) - (send dc draw-polygon points dx dy))])))))))) + (send dc draw-polygon points dx dy)) + (when (named-link? from-link) + (let*-values ([(text-len h d v) (send dc get-text-extent (link-label from-link))] + [(x) (/ (+ from-x to-x) 2)] + [(y) (/ (+ from-y to-y) 2)] + [(theta) (- (angle (- to-pt from-pt)))] + [(flip?) #f #;(negative? (- to-x from-x))] + [(text-angle) + (if flip? + (+ theta pi) + theta)] + [(x) + (- x (* h (cos (if flip? (+ (- theta) pi) (- theta)))))] + [(y) + (- y (* h (sin (if flip? (+ (- theta) pi) (- theta)))))] + [(sqr) (λ (x) (* x x))]) + (when (> (sqrt (+ (sqr (- to-x from-x)) (sqr (- to-y from-y)))) text-len) + (send dc draw-text (link-label from-link) + (+ dx x) + (+ dy y) + #f + 0 + text-angle)) + ))])))))))) + (define (named-link? l) (link-label l)) (define (set-pen/brush from-link dark-lines?) (send dc set-brush @@ -650,12 +770,17 @@ (send dc set-pen (if dark-lines? (link-dark-pen from-link) - (link-light-pen from-link)))) + (link-light-pen from-link))) + (send dc set-text-foreground + (if dark-lines? + (link-dark-text from-link) + (link-light-text from-link)))) ;;; body of on-paint (when before? (let ([old-pen (send dc get-pen)] [old-brush (send dc get-brush)] + [old-fg (send dc get-text-foreground)] [os (send dc get-smoothing)]) (send dc set-smoothing 'aligned) @@ -676,6 +801,7 @@ (send dc set-smoothing os) (send dc set-pen old-pen) + (send dc set-text-foreground old-fg) (send dc set-brush old-brush))) (super on-paint before? dc left top right bottom dx dy draw-caret))) @@ -765,6 +891,7 @@ (send point3 set-y t6y) (send point4 set-x t5x) (send point4 set-y t5y))) + ;; HERE!!! (define/private (should-hilite? snip) (let ([check-one-way