diff --git a/collects/mrlib/graph.ss b/collects/mrlib/graph.ss index 5451b08503..ebb7dc1128 100644 --- a/collects/mrlib/graph.ss +++ b/collects/mrlib/graph.ss @@ -8,6 +8,7 @@ (provide graph-snip<%> graph-snip-mixin + graph-pasteboard<%> graph-pasteboard-mixin) (define graph-snip<%> @@ -15,10 +16,11 @@ get-children add-child remove-child - + get-parents add-parent remove-parent + has-self-loop? find-shortest-path)) @@ -38,6 +40,15 @@ (union false/c (is-a?/c brush%)) . -> . 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<%>) (is-a?/c graph-snip<%>) (union false/c (is-a?/c pen%)) @@ -47,8 +58,33 @@ number? number? . -> . - void?)))) - + 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%)) + number? + number? + (union false/c string?) + . -> . + 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 +108,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 (send the-color-database find-color "blue")) + (define default-light-text (send the-color-database find-color "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 +122,27 @@ [(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) - (send parent add-child child) - (send child add-parent parent 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) + (add-links/text-colors parent child + dark-pen light-pen dark-brush light-brush + #f #f + 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 snip%)) (graph-snip<%>) (field (children null)) (define/public (get-children) children) (define/public (add-child child) @@ -106,6 +161,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 +172,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 +186,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 +212,7 @@ (map (lambda (child) (cons child path)) (filter first-view? (send (car path) get-children))) acc)))]))]))) - (super-instantiate ()) + (super-new) (inherit set-snipclass) (set-snipclass snipclass))) @@ -155,7 +220,8 @@ (define graph-pasteboard<%> (interface () on-mouse-over-snips - set-arrowhead-params)) + set-arrowhead-params + get-arrowhead-params)) (define-struct rect (left top right bottom)) @@ -176,19 +242,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 +269,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 +282,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 +302,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 +316,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 +324,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 +342,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 +408,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 +627,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 +656,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 +704,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 +732,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 +766,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 +797,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 +887,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