;; -*- mode: scheme -*- ;; ;; modified version of graph.ss from mrlib as distributed with PLT Scheme v352 (module graph mzscheme (require (lib "class.ss") (lib "list.ss") (lib "math.ss") (lib "mred.ss" "mred") (lib "contract.ss")) (provide graph-snip<%> graph-snip-mixin graph-pasteboard<%> graph-pasteboard-mixin graph-snipboard<%> graph-snipboard-mixin) (define graph-snip<%> (interface () get-children add-child remove-child get-parents add-parent remove-parent has-self-loop? find-shortest-path)) (define-local-member-name get-parent-links) (provide/contract (add-links (case-> ((is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) . -> . void?) ((is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) (or/c false/c (is-a?/c pen%)) (or/c false/c (is-a?/c pen%)) (or/c false/c (is-a?/c brush%)) (or/c false/c (is-a?/c brush%)) . -> . void?) ((is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) (or/c false/c (is-a?/c pen%)) (or/c false/c (is-a?/c pen%)) (or/c false/c (is-a?/c brush%)) (or/c false/c (is-a?/c brush%)) (or/c false/c string?) . -> . void?) ((is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) (or/c false/c (is-a?/c pen%)) (or/c false/c (is-a?/c pen%)) (or/c false/c (is-a?/c brush%)) (or/c false/c (is-a?/c brush%)) number? number? . -> . void?) ((is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) (or/c false/c (is-a?/c pen%)) (or/c false/c (is-a?/c pen%)) (or/c false/c (is-a?/c brush%)) (or/c false/c (is-a?/c brush%)) number? number? (or/c false/c string?) . -> . void?))) (add-links/text-colors ((is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) (or/c false/c (is-a?/c pen%)) (or/c false/c (is-a?/c pen%)) (or/c false/c (is-a?/c brush%)) (or/c false/c (is-a?/c brush%)) (or/c false/c (is-a?/c color%)) (or/c false/c (is-a?/c color%)) number? number? (or/c false/c string?) . -> . void?))) ;; interface to # stuff (provide (struct link (snip dark-pen light-pen dark-brush light-brush dark-text light-text dx dy label))) (define self-offset 10) ;; (or-2v arg ...) ;; like `or', except each `arg' returns two values. The ;; truth value of each arg is #t if both args are #t and ;; #f otherwise (define-syntax (or-2v stx) (syntax-case stx () [(_ arg) (syntax arg)] [(_ arg args ...) (syntax (let-values ([(one two) arg]) (if (and one two) (values one two) (or-2v args ...))))])) (define snipclass (make-object snip-class%)) (define default-dark-pen (send the-pen-list find-or-create-pen "blue" 1 'solid)) (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")) ;; label is boolean or string (define-struct link (snip dark-pen light-pen dark-brush light-brush dark-text light-text dx dy label)) ;; methods for # access ; (define (get-link-dark-pen link) (link-dark-pen link)) ; (define (get-link-light-pen link) (link-light-pen link)) ; (define (get-link-dark-brush link) (link-dark-brush link)) ; (define (get-link-light-brush link) (link-light-brushn link)) ; ;; 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 (define add-links (case-lambda [(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) (add-links/text-colors parent child dark-pen light-pen dark-brush light-brush #f #f dx dy label)])) (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) (unless (memq child children) (set! children (cons child children)))) (define/public (remove-child child) (when (memq child children) (set! children (remq child children)))) (field (parent-links null)) (define/public (get-parent-links) parent-links) (define/public (get-parents) (map link-snip parent-links)) (define/public add-parent (case-lambda [(parent) (add-parent parent #f #f #f #f)] [(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 (or dark-pen default-dark-pen) (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 label) parent-links)))])) (define/public (remove-parent parent) (when (memf (lambda (parent-link) (eq? (link-snip parent-link) parent)) parent-links) (set! parent-links (remove parent 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) (hash-table-get visited-ht n (lambda () (hash-table-put! visited-ht n #f) #t))) (let loop ((horizon (list (list this)))) (cond [(null? horizon) #f] [(assq other horizon) => (lambda (winner) winner)] [else (let inner-loop ((paths horizon) (acc '())) (cond [(null? paths) (loop (apply append acc))] [else (let ((path (car paths))) (inner-loop (cdr paths) (cons (map (lambda (child) (cons child path)) (filter first-view? (send (car path) get-children))) acc)))]))]))) (super-new) (inherit set-snipclass) (set-snipclass snipclass))) (define graph-pasteboard<%> (interface () on-mouse-over-snips set-arrowhead-params get-arrowhead-params)) (define-struct rect (left top right bottom)) (define graph-pasteboard-mixin (mixin ((class->interface pasteboard%)) (graph-pasteboard<%>) (inherit find-first-snip find-next-selected-snip) (define arrowhead-angle-width (* 1/4 pi)) (define arrowhead-short-side 8) (define arrowhead-long-side 12) (define/public (set-arrowhead-params angle-width long-side short-side) (set! arrowhead-angle-width angle-width) (set! arrowhead-short-side short-side) (set! arrowhead-long-side long-side)) (define/public (get-arrowhead-params) (values arrowhead-angle-width arrowhead-long-side arrowhead-short-side)) (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 (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) (get-dc)))) (super on-event evt)] [else (super on-event evt)])) (define/augment (on-interactive-move evt) (invalidate-selected-snips) ;;(super on-interactive-move evt) ) (define/augment (after-interactive-move evt) (invalidate-selected-snips) ;;(super on-interactive-move evt) ) (define/override (interactive-adjust-move snip x y) (let ([dc (get-dc)]) (when dc (invalidate-to-children/parents snip dc))) (super interactive-adjust-move snip x y)) (define/augment (after-insert snip before x y) (let ([dc (get-dc)]) (when dc (invalidate-to-children/parents snip dc))) ;;(super after-insert snip before x y) ) ;; invalidate-selected-snips : -> void ;; invalidates the region around the selected ;; snips and their parents and children (define/private (invalidate-selected-snips) (let ([dc (get-dc)]) (when dc (let loop ([snip (find-next-selected-snip #f)]) (when snip (invalidate-to-children/parents snip dc) (loop (find-next-selected-snip snip))))))) (define/private (add-to-rect from to rect) (let-values ([(xf yf wf hf) (get-position from)] [(xt yt wt ht) (get-position to)]) (make-rect (if rect (min xf xt (rect-left rect)) (min xf xt)) (if rect (min yf yt (rect-top rect)) (min yf yt)) (if rect (max (+ xf wf) (+ xt wt) (rect-right rect)) (max (+ xf wf) (+ xt wt))) (if rect (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)]) (cond [snip (let-values ([(sx sy sw sh) (get-position snip)]) (if (and (<= sx x (+ sx sw)) (<= sy y (+ sy sh)) (is-a? snip graph-snip<%>)) (cons snip (loop (send snip next))) (loop (send snip next))))] [else null]))) ;; change-currently-overs : (listof snip) -> void (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) (on-mouse-over-snips currently-overs) (for-each (lambda (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 dc)) new-currently-overs)))) (define/public (on-mouse-over-snips snips) (void)) ;; set-equal : (listof snip) (listof snip) -> boolean ;; typically lists will be small (length 1), ;; so use andmap/memq rather than hash-tables (define/private (set-equal los1 los2) (and (andmap (lambda (s1) (memq s1 los2)) los1) (andmap (lambda (s2) (memq s2 los1)) los2) #t)) ;; 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 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))] [or/c (or/c-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) 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 or/c) (apply + (map (lambda (x) (rect-area x)) rects))) (invalidate-rect or/c)] [else (for-each invalidate-rect rects)])))) ;; (listof rect) -> (listof rect) (define/private (eliminate-redundancies rects) (let loop ([rects rects] [acc null]) (cond [(null? rects) acc] [else (let ([r (car rects)]) (cond [(or (ormap (lambda (other-rect) (rect-included-in? r other-rect)) (cdr rects)) (ormap (lambda (other-rect) (rect-included-in? r other-rect)) acc)) (loop (cdr rects) acc)] [else (loop (cdr rects) (cons r acc))]))]))) ;; rect-included-in? : rect rect -> boolean (define/private (rect-included-in? r1 r2) (and ((rect-left r1) . >= . (rect-left r2)) ((rect-top r1) . >= . (rect-top r2)) ((rect-right r1) . <= . (rect-right r2)) ((rect-bottom r1) . <= . (rect-bottom r2)))) ;; get-rectangles : snip (listof snip) -> rect ;; computes the rectangles that need to be invalidated for connecting (define/private (get-rectangles main-snip c/p-snips) (let ([main-snip-rect (snip->rect main-snip)]) (let loop ([c/p-snips c/p-snips]) (cond [(null? c/p-snips) null] [else (let* ([c/p (car c/p-snips)] [rect (if (eq? c/p main-snip) (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 h))) (or/c-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)]) (let* ([dc (get-dc)] [h (if dc (let-values ([(_1 h _2 _3) (send dc get-text-extent "yX")]) h) 10)]) (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)) (- (rect-bottom rect) (rect-top rect)))) (define/private (or/c-rects rects) (cond [(null? rects) (make-rect 0 0 0 0)] [else (let loop ([rects (cdr rects)] [l (rect-left (car rects))] [t (rect-top (car rects))] [r (rect-right (car rects))] [b (rect-bottom (car rects))]) (cond [(null? rects) (make-rect l t r b)] [else (let ([rect (car rects)]) (loop (cdr rects) (min l (rect-left rect)) (min t (rect-top rect)) (max r (rect-right rect)) (max b (rect-bottom rect))))]))])) ;; on-paint : ... -> void ;; see docs, same as super ;; draws all of the lines and then draws all of the arrow heads (define/private (old-on-paint before? dc left top right bottom dx dy draw-caret) (let () ;; draw-connection : link snip boolean boolean -> void ;; sets the drawing context (pen and brush) ;; determines if the connection is between a snip and itself or two different snips ;; and calls draw-self-connection or draw-non-self-connection (define (draw-connection from-link to dark-lines?) (let ([from (link-snip from-link)]) (when (send from get-admin) (let ([dx (+ dx (link-dx from-link))] [dy (+ dy (link-dy from-link))]) (cond [(eq? from to) (set-pen/brush from-link dark-lines?) (draw-self-connection dx dy (link-snip from-link))] [else (draw-non-self-connection dx dy from-link dark-lines? to)]))))) (define (draw-self-connection dx dy snip) (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)))] [(s3x s3y) (values (+ sx sw) (+ sy sh self-offset))] [(b12x b12y) (values s2x s1y)] [(b23x b23y) (values s2x s3y)] [(s4x s4y) (values (- sx arrowhead-short-side) (+ sy (* sh 1/2)))] [(s5x s5y) (values (- sx arrowhead-short-side self-offset) (+ sy (* 3/4 sh) (* 1/2 self-offset)))] [(s6x s6y) (values (- sx arrowhead-short-side) (+ sy sh self-offset))] [(b45x b45y) (values s5x s4y)] [(b56x b56y) (values s5x s6y)]) (update-polygon s4x s4y sx s4y) (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)) (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))) (define (draw-non-self-connection dx dy from-link dark-lines? to) (let ([from (link-snip from-link)]) (let*-values ([(xf yf wf hf) (get-position from)] [(xt yt wt ht) (get-position to)] [(lf tf rf bf) (values xf yf (+ xf wf) (+ yf hf))] [(lt tt rt bt) (values xt yt (+ xt wt) (+ yt ht))]) (let ([x1 (+ xf (/ wf 2))] [y1 (+ yf (/ hf 2))] [x2 (+ xt (/ wt 2))] [y2 (+ yt (/ ht 2))]) (unless (or (and (x1 . <= . left) (x2 . <= . left)) (and (x1 . >= . right) (x2 . >= . right)) (and (y1 . <= . top) (y2 . <= . top)) (and (y1 . >= . bottom) (y2 . >= . bottom))) (set-pen/brush from-link dark-lines?) (let-values ([(from-x from-y) (or-2v (find-intersection x1 y1 x2 y2 lf tf rf tf) (find-intersection x1 y1 x2 y2 lf bf rf bf) (find-intersection x1 y1 x2 y2 lf tf lf bf) (find-intersection x1 y1 x2 y2 rf tf rf bf))] [(to-x to-y) (or-2v (find-intersection x1 y1 x2 y2 lt tt rt tt) (find-intersection x1 y1 x2 y2 lt bt rt bt) (find-intersection x1 y1 x2 y2 lt tt lt bt) (find-intersection x1 y1 x2 y2 rt tt rt bt))]) (when (and from-x from-y to-x to-y) (let () (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) (max lt rt lf rf) (max tt bt tf bf)) (not (strict-in-rectangle? point-x point-y (min lt rt) (min tt bt) (max lt rt) (max tt bt))) (not (strict-in-rectangle? point-x point-y (min lf rf) (min tf bf) (max lf rf) (max tf bf))))) (cond [(or (in-rectangle? from-x from-y lt tt rt bt) (in-rectangle? to-x to-y lf tf rf bf)) ;; the snips overlap, draw nothing (void)] [else (send dc draw-line (+ dx from-x) (+ dy from-y) (+ dx to-x) (+ dy to-y)) (update-polygon from-x from-y to-x to-y) (when (and (arrow-point-ok? (send point1 get-x) (send point1 get-y)) (arrow-point-ok? (send point2 get-x) (send point2 get-y)) (arrow-point-ok? (send point3 get-x) (send point3 get-y)) (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))]))))))))) (define (set-pen/brush from-link dark-lines?) (send dc set-brush (if dark-lines? (link-dark-brush from-link) (link-light-brush from-link))) (send dc set-pen (if dark-lines? (link-dark-pen from-link) (link-light-pen from-link)))) ;;; body of on-paint (when before? (let ([old-pen (send dc get-pen)] [old-brush (send dc get-brush)] [os (send dc get-smoothing)]) (send dc set-smoothing 'aligned) (let loop ([snip (find-first-snip)]) (when snip (when (and (send snip get-admin) (is-a? snip graph-snip<%>)) (for-each (lambda (parent-link) (draw-connection parent-link snip #f)) (send snip get-parent-links))) (loop (send snip next)))) (for-each (lambda (currently-over) (for-each (lambda (child) (let ([parent-link-f (memf (lambda (parent-link) (eq? currently-over (link-snip parent-link))) (send child get-parent-links))]) (when parent-link-f (draw-connection (car parent-link-f) child #t)))) (send currently-over get-children)) (for-each (lambda (parent-link) (draw-connection parent-link currently-over #t)) (send currently-over get-parent-links))) currently-overs) (send dc set-smoothing os) (send dc set-pen old-pen) (send dc set-brush old-brush))) (super on-paint before? dc left top right bottom dx dy draw-caret))) (define/override (on-paint before? dc left top right bottom dx dy draw-caret) (let () ;; draw-connection : link snip boolean boolean -> void ;; sets the drawing context (pen and brush) ;; determines if the connection is between a snip and itself or two different snips ;; and calls draw-self-connection or draw-non-self-connection (define splines? #f) ;; [en,dis]able spline drawing betwen nodes (define (draw-connection from-link to dark-lines?) (let ([from (link-snip from-link)]) (when (send from get-admin) (let ([dx (+ dx (link-dx from-link))] [dy (+ dy (link-dy from-link))]) (cond [(eq? from to) (set-pen/brush from-link dark-lines?) (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 (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)))] [(s3x s3y) (values (+ sx sw) (+ sy sh self-offset))] [(b12x b12y) (values s2x s1y)] [(b23x b23y) (values s2x s3y)] [(s4x s4y) (values (- sx arrowhead-short-side) (+ sy (* sh 1/2)))] [(s5x s5y) (values (- sx arrowhead-short-side self-offset) (+ sy (* 3/4 sh) (* 1/2 self-offset)))] [(s6x s6y) (values (- sx arrowhead-short-side) (+ sy sh self-offset))] [(b45x b45y) (values s5x s4y)] [(b56x b56y) (values s5x s6y)]) (update-polygon s4x s4y sx s4y) (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))) (define (draw-non-self-connection dx dy from-link dark-lines? to) (let ([from (link-snip from-link)]) (let*-values ([(xf yf wf hf) (get-position from)] [(xt yt wt ht) (get-position to)] [(lf tf rf bf) (values xf yf (+ xf wf) (+ yf hf))] [(lt tt rt bt) (values xt yt (+ xt wt) (+ yt ht))]) (let ([x1 (+ xf (/ wf 2))] [y1 (+ yf (/ hf 2))] [x2 (+ xt (/ wt 2))] [y2 (+ yt (/ ht 2))]) (set-pen/brush from-link dark-lines?) (let-values ([(from-x from-y) (or-2v (find-intersection x1 y1 x2 y2 lf tf rf tf) (find-intersection x1 y1 x2 y2 lf bf rf bf) (find-intersection x1 y1 x2 y2 lf tf lf bf) (find-intersection x1 y1 x2 y2 rf tf rf bf))] [(to-x to-y) (or-2v (find-intersection x1 y1 x2 y2 lt tt rt tt) (find-intersection x1 y1 x2 y2 lt bt rt bt) (find-intersection x1 y1 x2 y2 lt tt lt bt) (find-intersection x1 y1 x2 y2 rt tt rt bt))]) (when (and from-x from-y to-x to-y) (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) (max lt rt lf rf) (max tt bt tf bf)) (not (strict-in-rectangle? point-x point-y (min lt rt) (min tt bt) (max lt rt) (max tt bt))) (not (strict-in-rectangle? point-x point-y (min lf rf) (min tf bf) (max lf rf) (max tf bf))))) (cond [(or (in-rectangle? from-x from-y lt tt rt bt) (in-rectangle? to-x to-y lf tf rf bf)) ;; the snips overlap, draw nothing (void)] [else (if splines? (send dc draw-spline ;; modified link drawing (+ dx from-x) (+ dy from-y) (+ dx from-x) (+ dy to-y) (+ dx to-x) (+ dy to-y)) (send dc draw-line (+ dx from-x) (+ dy from-y) (+ dx to-x) (+ dy to-y))) (update-polygon from-x from-y to-x to-y) (when (and (arrow-point-ok? (send point1 get-x) (send point1 get-y)) (arrow-point-ok? (send point2 get-x) (send point2 get-y)) (arrow-point-ok? (send point3 get-x) (send point3 get-y)) (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)) (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 (if dark-lines? (link-dark-brush from-link) (link-light-brush from-link))) (send dc set-pen (if dark-lines? (link-dark-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) (let ([pairs '()]) (for-each-to-redraw left top right bottom (lambda (from-link to) (let ([from (link-snip from-link)]) (cond [(or (memq from currently-overs) (memq to currently-overs)) (set! pairs (cons (cons from-link to) pairs))] [else (draw-connection from-link to #f)])))) (for-each (lambda (pr) (draw-connection (car pr) (cdr pr) #t)) pairs)) (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))) ;; for-each-to-redraw : number number number number (link snip -> void) (define/private (for-each-to-redraw left top right bottom f) (let () ;; draw-connection : link snip boolean boolean -> void ;; sets the drawing context (pen and brush) ;; determines if the connection is between a snip and itself or two different snips ;; and calls draw-self-connection or draw-non-self-connection (define (maybe-call-f from-link to) (let ([from (link-snip from-link)]) (when (send from get-admin) (cond [(eq? from to) (f from-link to)] [else (let*-values ([(xf yf wf hf) (get-position from)] [(xt yt wt ht) (get-position to)] [(lf tf rf bf) (values xf yf (+ xf wf) (+ yf hf))] [(lt tt rt bt) (values xt yt (+ xt wt) (+ yt ht))]) (let ([x1 (+ xf (/ wf 2))] [y1 (+ yf (/ hf 2))] [x2 (+ xt (/ wt 2))] [y2 (+ yt (/ ht 2))]) (unless (or (and (x1 . <= . left) (x2 . <= . left)) (and (x1 . >= . right) (x2 . >= . right)) (and (y1 . <= . top) (y2 . <= . top)) (and (y1 . >= . bottom) (y2 . >= . bottom))) (f from-link to))))])))) (let loop ([snip (find-first-snip)]) (when snip (when (and (send snip get-admin) (is-a? snip graph-snip<%>)) (for-each (lambda (parent-link) (maybe-call-f parent-link snip)) (send snip get-parent-links))) (loop (send snip next)))))) (field [point1 (make-object point% 0 0)] [point2 (make-object point% 0 0)] [point3 (make-object point% 0 0)] [point4 (make-object point% 0 0)] [points (list point1 point2 point3 point4)]) ;; update-polygon : number^4 -> void ;; updates points1, 2, and 3 with the arrow head's ;; points. Use a turtle-like movement to find the points. ;; point3 is the point where the line should end. (define/private (update-polygon from-x from-y to-x to-y) (define (move tx ty ta d) (values (+ tx (* d (cos ta))) (+ ty (* d (sin ta))) ta)) (define (turn tx ty ta a) (values tx ty (+ ta a))) (define init-angle (cond [(and (from-x . = . to-x) (from-y . < . to-y)) (* pi 3/2)] [(from-x . = . to-x) (* pi 1/2)] [(from-x . < . to-x) (+ pi (atan (/ (- from-y to-y) (- from-x to-x))))] [else (atan (/ (- from-y to-y) (- from-x to-x)))])) (let*-values ([(t1x t1y t1a) (values to-x to-y init-angle)] [(t2x t2y t2a) (turn t1x t1y t1a (/ arrowhead-angle-width 2))] [(t3x t3y t3a) (move t2x t2y t2a arrowhead-long-side)] [(t4x t4y t4a) (turn t1x t1y t1a (- (/ arrowhead-angle-width 2)))] [(t5x t5y t5a) (move t4x t4y t4a arrowhead-long-side)] [(t6x t6y t6a) (move t1x t1y t1a arrowhead-short-side)]) (send point1 set-x t1x) (send point1 set-y t1y) (send point2 set-x t3x) (send point2 set-y t3y) (send point3 set-x t6x) (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 (lambda (way) (let loop ([snip snip]) (or (memq snip currently-overs) (and (is-a? snip graph-snip<%>) (loop (car (way snip)))))))]) (or (check-one-way (lambda (snip) (send snip get-children))) (check-one-way (lambda (snip) (send snip get-parents)))))) (inherit get-snip-location) (field [lb (box 0)] [tb (box 0)] [rb (box 0)] [bb (box 0)]) (define/private (get-position snip) (get-snip-location snip lb tb #f) (get-snip-location snip rb bb #t) (values (unbox lb) (unbox tb) (- (unbox rb) (unbox lb)) (- (unbox bb) (unbox tb)))) (super-new))) ;; in-rectangle? : number^2 number^2 number^2 -> boolean ;; determines if (x,y) is in the rectangle described ;; by (p1x,p1y) and (p2x,p2y). (define (in-rectangle? x y p1x p1y p2x p2y) (and (<= (min p1x p2x) x (max p1x p2x)) (<= (min p1y p2y) y (max p1y p2y)))) ;; strict-in-rectangle? : number^2 number^2 number^2 -> boolean ;; determines if (x,y) is in the rectangle described ;; by (p1x,p1y) and (p2x,p2y), but not on the border (define (strict-in-rectangle? x y p1x p1y p2x p2y) (and (< (min p1x p2x) x (max p1x p2x)) (< (min p1y p2y) y (max p1y p2y)))) ;; find-intersection : number^8 -> (values (or/c #f number) (or/c #f number)) ;; calculates the intersection between two line segments, ;; described as pairs of points. Returns #f if they do not intersect (define (find-intersection x1 y1 x2 y2 x3 y3 x4 y4) (let-values ([(m1 b1) (find-mb x1 y1 x2 y2)] [(m2 b2) (find-mb x3 y3 x4 y4)]) (let-values ([(int-x int-y) (cond [(and m1 m2 b1 b2 (= m1 0) (= m2 0)) (values #f #f)] [(and m1 m2 b1 b2 (= m1 0)) (let* ([y y1] [x (/ (- y b2) m2)]) (values x y))] [(and m1 m2 b1 b2 (= m2 0)) (let* ([y y3] [x (/ (- y b1) m1)]) (values x y))] [(and m1 m2 b1 b2 (not (= m1 m2))) (let* ([y (/ (- b2 b1) (- m1 m2))] [x (/ (- y b1) m1)]) (values x y))] [(and m1 b1) (let* ([x x3] [y (+ (* m1 x) b1)]) (values x y))] [(and m2 b2) (let* ([x x1] [y (+ (* m2 x) b2)]) (values x y))] [else (values #f #f)])]) (if (and int-x int-y (<= (min x1 x2) int-x (max x1 x2)) (<= (min y1 y2) int-y (max y1 y2)) (<= (min x3 x4) int-x (max x3 x4)) (<= (min y3 y4) int-y (max y3 y4))) (values int-x int-y) (values #f #f))))) ;; find-mb : number number number number -> (values (or/c #f number) (or/c #f number)) ;; finds the "m" and "b" constants that describe the ;; lines from (x1, y1) to (x2, y2) (define (find-mb x1 y1 x2 y2) (if (= x1 x2) (values #f #f) (let-values ([(xl yl xr yr) (if (x1 . <= . x2) (values x1 y1 x2 y2) (values x2 y2 x1 y1))]) (let* ([m (/ (- yr yl) (- xr xl))] [b (- y1 (* m x1))]) (values m b))))) ;; get-all-relatives : (snip -> (listof snip)) snip -> (listof snip) ;; returns all editor-snip relatives (of a particular sort), including ;; any regular snip relatives along the way. (define (get-all-relatives get-relatives snip) (let loop ([flat-relatives (get-relatives snip)] [relatives null]) (cond [(null? flat-relatives) relatives] [else (let i-loop ([dummy (car flat-relatives)] [acc relatives]) (cond [(is-a? dummy graph-snip<%>) (loop (cdr flat-relatives) (cons dummy acc))] [else (i-loop (car (get-relatives dummy)) (cons dummy acc))]))]))) ;; get-all-children : snip -> (listof snip) (define (get-all-children snip) (get-all-relatives (lambda (snip) (send snip get-children)) snip)) ;; get-all-parents : snip -> (listof snip) (define (get-all-parents snip) (get-all-relatives (lambda (snip) (send snip get-parents)) snip)) ;; merge graph-snips and pasteboard, for which there must be a simpler way... (define graph-snipboard<%> (interface () get-children add-child remove-child get-parents add-parent remove-parent has-self-loop? find-shortest-path on-mouse-over-snips set-arrowhead-params get-arrowhead-params)) (define graph-snipboard-mixin (mixin ((class->interface pasteboard%)) (graph-pasteboard<%>)) ;;(mixin ((class->interface snip%)) (graph-snip<%>)) ) )