graph.rkt
1 #lang racket/base 2 (require racket/class 3 racket/list 4 racket/math 5 racket/gui/base 6 racket/match 7 (for-syntax racket/base) 8 racket/contract) 9 10 (provide graph-snip<%> 11 graph-snip-mixin 12 graph-pasteboard<%> 13 graph-pasteboard-mixin) 14 (provide add-links add-links/text-colors remove-links set-link-label) 15 16 (define-local-member-name invalidate-edge-cache) 17 18 (define graph-snip<%> 19 (interface () 20 get-children 21 add-child 22 remove-child 23 24 get-parents 25 add-parent 26 remove-parent 27 has-self-loop? 28 29 set-parent-link-label 30 31 find-shortest-path)) 32 33 (define-local-member-name get-parent-links) 34 35 (define self-offset 10) 36 37 ;; (or-2v arg ...) 38 ;; like `or', except each `arg' returns two values. The 39 ;; truth value of each arg is #t if both args are #t and 40 ;; #f otherwise 41 (define-syntax (or-2v stx) 42 (syntax-case stx () 43 [(_ arg) 44 (syntax arg)] 45 [(_ arg args ...) 46 (syntax 47 (let-values ([(one two) arg]) 48 (if (and one two) 49 (values one two) 50 (or-2v args ...))))])) 51 52 (define snipclass (make-object snip-class%)) 53 54 (define default-dark-pen (send the-pen-list find-or-create-pen "blue" 1 'solid)) 55 (define default-light-pen (send the-pen-list find-or-create-pen "light blue" 1 'solid)) 56 (define default-dark-brush (send the-brush-list find-or-create-brush "light blue" 'solid)) 57 (define default-light-brush (send the-brush-list find-or-create-brush "white" 'solid)) 58 (define default-dark-text (send the-color-database find-color "blue")) 59 (define default-light-text (send the-color-database find-color "light blue")) 60 61 62 ;; label is boolean or string 63 (define-struct link (snip dark-pen light-pen dark-brush light-brush dark-text light-text dx dy 64 [label #:mutable])) 65 66 ;; add-links : (is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) -> void 67 ;; : (is-a?/c graph-snip<%>) (is-a?/c graph-snip<%>) pen pen brush brush -> void 68 (define add-links 69 (case-lambda 70 [(parent child) (add-links parent child #f #f #f #f)] 71 [(parent child dark-pen light-pen dark-brush light-brush) 72 (add-links parent child dark-pen light-pen dark-brush light-brush 0 0)] 73 [(parent child dark-pen light-pen dark-brush light-brush label) 74 (add-links parent child dark-pen light-pen dark-brush light-brush 0 0 label)] 75 [(parent child dark-pen light-pen dark-brush light-brush dx dy) 76 (add-links parent child dark-pen light-pen dark-brush light-brush dx dy #f)] 77 [(parent child dark-pen light-pen dark-brush light-brush dx dy label) 78 (add-links/text-colors parent child 79 dark-pen light-pen dark-brush light-brush 80 #f #f 81 dx dy 82 label)])) 83 84 (define (add-links/text-colors prnt child 85 dark-pen lite-pen dark-brush lite-brush 86 dark-txt lite-txt 87 dx dy 88 lbl) 89 (send prnt add-child child) 90 (send child add-parent prnt dark-pen lite-pen dark-brush lite-brush dark-txt lite-txt dx dy lbl)) 91 92 (define (remove-links parent child) 93 (send parent remove-child child) 94 (send child remove-parent parent)) 95 96 (define (set-link-label parent child label) 97 (send child set-parent-link-label parent label)) 98 99 (define graph-snip-mixin 100 (mixin ((class->interface snip%)) (graph-snip<%>) 101 (inherit get-admin) 102 103 (define children null) 104 (define/public (get-children) children) 105 (define/public (add-child child) 106 (unless (member child children object=?) 107 (set! children (cons child children)))) 108 (define/public (remove-child child) 109 (when (member child children object=?) 110 (set! children (remove child children object=?)))) 111 112 (define parent-links null) 113 (define/public (get-parent-links) parent-links) 114 (define/public (get-parents) (map link-snip parent-links)) 115 (define/public add-parent 116 (case-lambda 117 [(parent) (add-parent parent #f #f #f #f)] 118 [(parent dark-pen light-pen dark-brush light-brush) 119 (add-parent parent dark-pen light-pen dark-brush light-brush 0 0)] 120 [(parent dark-pen light-pen dark-brush light-brush dx dy) 121 (add-parent parent dark-pen light-pen dark-brush light-brush #f #f dx dy #f)] 122 [(parent dark-pen light-pen dark-brush light-brush dark-text light-text dx dy label) 123 (unless (memf (lambda (parent-link) (object=? (link-snip parent-link) parent)) parent-links) 124 (define admin (get-admin)) 125 (when admin 126 (define ed (send admin get-editor)) 127 (when (is-a? ed graph-pasteboard<%>) 128 (send ed invalidate-edge-cache))) 129 (set! parent-links 130 (cons (make-link parent 131 (or dark-pen default-dark-pen) 132 (or light-pen default-light-pen) 133 (or dark-brush default-dark-brush) 134 (or light-brush default-light-brush) 135 (or dark-text default-dark-text) 136 (or light-text default-light-text) 137 dx 138 dy 139 label) 140 parent-links)))])) 141 (define/public (remove-parent parent) 142 (when (memf (lambda (parent-link) (object=? (link-snip parent-link) parent)) parent-links) 143 (set! parent-links 144 (remove 145 parent 146 parent-links 147 (lambda (parent parent-link) (object=? (link-snip parent-link) parent)))))) 148 (define/public (set-parent-link-label parent label) 149 (let ([parent-link 150 (cond [(memf (lambda (parent-link) 151 (object=? (link-snip parent-link) parent)) 152 parent-links) 153 => car] 154 [else #f])]) 155 (when parent-link 156 (set-link-label! parent-link label)))) 157 158 (define/public (has-self-loop?) 159 (member this (get-children) object=?)) 160 161 (define/public (find-shortest-path other) 162 (define visited-ht (make-hasheq)) ;; should be based on object=? 163 (define (first-view? n) 164 (hash-ref visited-ht n (lambda () 165 (hash-set! visited-ht n #f) 166 #t))) 167 (let loop ((horizon (list (list this)))) 168 (cond 169 [(null? horizon) #f] 170 [(assq other horizon) => (lambda (winner) winner)] 171 [else 172 (let inner-loop ((paths horizon) 173 (acc '())) 174 (cond 175 [(null? paths) (loop (apply append acc))] 176 [else 177 (let ((path (car paths))) 178 (inner-loop 179 (cdr paths) 180 (cons 181 (map (lambda (child) (cons child path)) 182 (filter first-view? (send (car path) get-children))) 183 acc)))]))]))) 184 185 (super-new) 186 187 (inherit set-snipclass) 188 (set-snipclass snipclass))) 189 190 (define graph-pasteboard<%> 191 (interface () 192 on-mouse-over-snips 193 set-arrowhead-params 194 get-arrowhead-params 195 set-draw-arrow-heads? 196 set-flip-labels? 197 draw-edges)) 198 199 (define-struct rect (left top right bottom)) 200 201 (define graph-pasteboard-mixin 202 (mixin ((class->interface pasteboard%)) (graph-pasteboard<%>) 203 (inherit find-first-snip find-next-selected-snip) 204 205 (init-field [edge-label-font #f] 206 [edge-labels? #t] 207 [cache-arrow-drawing? #f]) 208 209 (define/public (set-edge-label-font f) 210 (set! edge-label-font f) 211 (invalidate-bitmap-cache)) 212 (define/public (get-edge-label-font) edge-label-font) 213 214 (define draw-arrow-heads? #t) 215 (define flip-labels? #t) 216 (inherit refresh get-admin) 217 (define (refresh*) 218 (let ([admin (get-admin)]) 219 (when admin 220 (let ([xb (box 0)] [yb (box 0)] [wb (box 0)] [hb (box 0)]) 221 (send admin get-view xb yb wb hb) 222 (send admin needs-update 223 (unbox xb) (unbox yb) (unbox wb) (unbox hb)))))) 224 (define/public (set-draw-arrow-heads? x) 225 (set! draw-arrow-heads? x) 226 (refresh*)) 227 (define/public (set-flip-labels? x) 228 (set! flip-labels? x) 229 (refresh*)) 230 231 (define arrowhead-angle-width (* 1/4 pi)) 232 (define arrowhead-short-side 8) 233 (define arrowhead-long-side 12) 234 235 (define/public (set-arrowhead-params angle-width long-side short-side) 236 (set! arrowhead-angle-width angle-width) 237 (set! arrowhead-short-side short-side) 238 (set! arrowhead-long-side long-side)) 239 (define/public (get-arrowhead-params) 240 (values arrowhead-angle-width 241 arrowhead-long-side 242 arrowhead-short-side)) 243 244 (inherit dc-location-to-editor-location get-canvas get-dc) 245 (field (currently-overs null)) 246 (define/override (on-event evt) 247 (cond 248 [(send evt leaving?) 249 (change-currently-overs null (get-dc)) 250 (super on-event evt)] 251 [(or (send evt entering?) 252 (send evt moving?)) 253 (let ([ex (send evt get-x)] 254 [ey (send evt get-y)]) 255 (let-values ([(x y) (dc-location-to-editor-location ex ey)]) 256 (change-currently-overs (find-snips-under-mouse x y) (get-dc)))) 257 (super on-event evt)] 258 [else 259 (super on-event evt)])) 260 261 (define/augment (on-interactive-move evt) 262 (invalidate-selected-snips) 263 (inner (void) on-interactive-move evt)) 264 265 (define/augment (after-interactive-move evt) 266 (invalidate-selected-snips) 267 (inner (void) on-interactive-move evt)) 268 269 (define/override (interactive-adjust-move snip x y) 270 (let ([dc (get-dc)]) 271 (when dc 272 (invalidate-to-children/parents snip dc))) 273 (super interactive-adjust-move snip x y)) 274 275 (define/augment (after-insert snip before x y) 276 (let ([dc (get-dc)]) 277 (when dc 278 (invalidate-to-children/parents snip dc))) 279 (inner (void) after-insert snip before x y)) 280 281 ;; invalidate-selected-snips : -> void 282 ;; invalidates the region around the selected 283 ;; snips and their parents and children 284 (define/private (invalidate-selected-snips) 285 (let ([dc (get-dc)]) 286 (when dc 287 (let loop ([snip (find-next-selected-snip #f)]) 288 (when snip 289 (invalidate-to-children/parents snip dc) 290 (loop (find-next-selected-snip snip))))))) 291 292 (define/private (add-to-rect from to rect) 293 (let-values ([(xf yf wf hf) (get-position from)] 294 [(xt yt wt ht) (get-position to)]) 295 (make-rect 296 (if rect 297 (min xf xt (rect-left rect)) 298 (min xf xt)) 299 (if rect 300 (min yf yt (rect-top rect)) 301 (min yf yt)) 302 (if rect 303 (max (+ xf wf) (+ xt wt) (rect-right rect)) 304 (max (+ xf wf) (+ xt wt))) 305 (if rect 306 (max (+ yf hf) (+ yt ht) (rect-bottom rect)) 307 (max (+ yf hf) (+ yt ht)))))) 308 309 ;; find-snips-under-mouse : num num -> (listof graph-snip<%>) 310 (define/private (find-snips-under-mouse x y) 311 (let loop ([snip (find-first-snip)]) 312 (cond 313 [snip 314 (let-values ([(sx sy sw sh) (get-position snip)]) 315 (if (and (<= sx x (+ sx sw)) 316 (<= sy y (+ sy sh)) 317 (is-a? snip graph-snip<%>)) 318 (cons snip (loop (send snip next))) 319 (loop (send snip next))))] 320 [else null]))) 321 322 ;; change-currently-overs : (listof snip) -> void 323 (define/private (change-currently-overs new-currently-overs dc) 324 (unless (set-equal new-currently-overs currently-overs) 325 (let ([old-currently-overs currently-overs]) 326 (set! currently-overs new-currently-overs) 327 328 (on-mouse-over-snips currently-overs) 329 (for-each 330 (lambda (old-currently-over) 331 (invalidate-to-children/parents old-currently-over dc)) 332 old-currently-overs) 333 (for-each 334 (lambda (new-currently-over) 335 (invalidate-to-children/parents new-currently-over dc)) 336 new-currently-overs)))) 337 338 (define/public (on-mouse-over-snips snips) (void)) 339 340 ;; set-equal : (listof snip) (listof snip) -> boolean 341 ;; typically lists will be small (length 1), 342 ;; so use andmap/member rather than hashes 343 (define/private (set-equal los1 los2) 344 (and (andmap (lambda (s1) (member s1 los2 object=?)) los1) 345 (andmap (lambda (s2) (member s2 los1 object=?)) los2) 346 #t)) 347 348 ;; invalidate-to-children/parents : snip dc -> void 349 ;; invalidates the region containing this snip and 350 ;; all of its children and parents. 351 (define/private (invalidate-to-children/parents snip dc) 352 (when (is-a? snip graph-snip<%>) 353 (define-values (_1 text-height _2 _3) 354 (send dc get-text-extent "Label" edge-label-font #f 0)) 355 (define parents-and-children (append (get-all-parents snip) 356 (get-all-children snip))) 357 (define rects (get-rectangles snip parents-and-children)) 358 (for ([rect (in-list rects)]) 359 (save-rectangle-to-invalidate 360 (- (rect-left rect) text-height) 361 (- (rect-top rect) text-height) 362 (+ (rect-right rect) text-height) 363 (+ (rect-bottom rect) text-height))))) 364 365 (define pending-invalidate-rectangle #f) 366 (define pending-invalidate-rectangle-timer #f) 367 (inherit invalidate-bitmap-cache) 368 (define/private (run-pending-invalidate-rectangle) 369 (define the-pending-invalidate-rectangle pending-invalidate-rectangle) 370 (set! pending-invalidate-rectangle #f) 371 (match the-pending-invalidate-rectangle 372 [(list l t r b) 373 (invalidate-bitmap-cache l t (- r l) (- b t))])) 374 375 (define/private (save-rectangle-to-invalidate l t r b) 376 (unless pending-invalidate-rectangle-timer 377 (set! pending-invalidate-rectangle-timer 378 (new timer% [notify-callback 379 (λ () (run-pending-invalidate-rectangle))]))) 380 (add-to-pending-indvalidate-rectangle l t r b) 381 (send pending-invalidate-rectangle-timer start 20 #t)) 382 383 (define/private (add-to-pending-indvalidate-rectangle l t r b) 384 (set! pending-invalidate-rectangle 385 (match pending-invalidate-rectangle 386 [(list l2 t2 r2 b2) 387 (list (min l l2) (min t t2) (max r r2) (max b b2))] 388 [#f 389 (list l t r b)]))) 390 391 ;; get-rectangles : snip (listof snip) -> rect 392 ;; computes the rectangles that need to be invalidated for connecting 393 (define/private (get-rectangles main-snip c/p-snips) 394 (let ([main-snip-rect (snip->rect main-snip)]) 395 (let loop ([c/p-snips c/p-snips]) 396 (cond 397 [(null? c/p-snips) null] 398 [else 399 (let* ([c/p (car c/p-snips)] 400 [rect 401 (if (object=? c/p main-snip) 402 (let-values ([(sx sy sw sh) (get-position c/p)] 403 [(_1 h _2 _3) (send (get-dc) get-text-extent "yX" 404 edge-label-font)]) 405 (make-rect (- sx self-offset) 406 sy 407 (+ (+ sx sw) self-offset) 408 (+ (+ sy sh) self-offset h))) 409 (or/c-rects (list main-snip-rect 410 (snip->rect c/p))))]) 411 (cons rect (loop (cdr c/p-snips))))])))) 412 413 (define/private (snip->rect snip) 414 (let-values ([(sx sy sw sh) (get-position snip)]) 415 (let* ([dc (get-dc)] 416 [h (if dc 417 (let-values ([(_1 h _2 _3) (send dc get-text-extent "yX" 418 edge-label-font)]) 419 h) 420 10)]) 421 (make-rect sx 422 sy 423 (+ sx sw) 424 (max (+ sy sh) 425 (+ sy (/ sh 2) (* 2 426 (sin (/ arrowhead-angle-width 2)) 427 arrowhead-long-side) h)))))) 428 429 (define/private (rect-area rect) 430 (* (- (rect-right rect) 431 (rect-left rect)) 432 (- (rect-bottom rect) 433 (rect-top rect)))) 434 435 (define/private (or/c-rects rects) 436 (cond 437 [(null? rects) (make-rect 0 0 0 0)] 438 [else 439 (let loop ([rects (cdr rects)] 440 [l (rect-left (car rects))] 441 [t (rect-top (car rects))] 442 [r (rect-right (car rects))] 443 [b (rect-bottom (car rects))]) 444 (cond 445 [(null? rects) (make-rect l t r b)] 446 [else 447 (let ([rect (car rects)]) 448 (loop (cdr rects) 449 (min l (rect-left rect)) 450 (min t (rect-top rect)) 451 (max r (rect-right rect)) 452 (max b (rect-bottom rect))))]))])) 453 454 (define/override (on-paint before? dc left top right bottom dx dy draw-caret) 455 (when before? 456 (let ([old-font (send dc get-font)]) 457 (when edge-label-font 458 (send dc set-font edge-label-font)) 459 (cond 460 [pending-invalidate-rectangle 461 (add-to-pending-indvalidate-rectangle left top right bottom)] 462 [else 463 (draw-edges dc left top right bottom dx dy)]) 464 (when edge-label-font 465 (send dc set-font old-font)))) 466 (super on-paint before? dc left top right bottom dx dy draw-caret)) 467 468 (define/public (draw-edges dc left top right bottom dx dy) 469 (cond 470 [cache-arrow-drawing? 471 (define admin (get-admin)) 472 (when admin 473 (define-values (x y w h) 474 (let ([xb (box 0)] 475 [yb (box 0)] 476 [wb (box 0)] 477 [hb (box 0)]) 478 (send admin get-max-view xb yb wb hb) 479 (values (unbox xb) (unbox yb) (unbox wb) (unbox hb)))) 480 (define this-time (list x y w h)) 481 (unless (and edges-cache (equal? this-time edges-cache-last-time)) 482 (set! edges-cache-last-time this-time) 483 (set! edges-cache (make-bitmap (inexact->exact (ceiling w)) 484 (inexact->exact (ceiling h)))) 485 (define bdc (make-object bitmap-dc% edges-cache)) 486 (draw-edges/compute bdc x y (+ x w) (+ y h) dx dy #f) 487 (send bdc set-bitmap #f)) 488 (send dc draw-bitmap edges-cache 0 0) 489 (draw-edges/compute dc left top right bottom dx dy #t))] 490 [else 491 (draw-edges/compute dc left top right bottom dx dy #f) 492 (draw-edges/compute dc left top right bottom dx dy #t)])) 493 494 (define/augment (on-change) 495 (set! edges-cache #f) 496 (inner (void) on-change)) 497 498 (define/public (invalidate-edge-cache) (set! edges-cache #f)) 499 (define edges-cache #f) 500 (define edges-cache-last-time #f) 501 502 (define/private (draw-edges/compute dc left top right bottom dx dy draw-dark-lines?) 503 ;; draw-connection : link snip boolean boolean -> void 504 ;; sets the drawing context (pen and brush) 505 ;; determines if the connection is between a snip and itself or two different snips 506 ;; and calls draw-self-connection or draw-non-self-connection 507 (define (draw-connection from-link to dark-lines?) 508 (let ([from (link-snip from-link)]) 509 (when (send from get-admin) 510 (let ([dx (+ dx (link-dx from-link))] 511 [dy (+ dy (link-dy from-link))]) 512 (cond 513 [(object=? from to) 514 (set-pen/brush from-link dark-lines?) 515 (draw-self-connection dx dy (link-snip from-link) from-link dark-lines?)] 516 [else 517 (draw-non-self-connection dx dy from-link dark-lines? to)]))))) 518 519 (define (get-text-length txt) 520 (let-values ([(text-len h d v) (send dc get-text-extent txt)]) 521 text-len)) 522 523 (define (draw-self-connection dx dy snip the-link dark-lines?) 524 (let*-values 525 ([(sx sy sw sh) (get-position snip)] 526 [(s1x s1y) (values (+ sx sw) (+ sy (* sh 1/2)))] 527 [(s2x s2y) (values (+ sx sw self-offset) (+ sy (* 3/4 sh) (* 1/2 self-offset)))] 528 [(s3x s3y) (values (+ sx sw) (+ sy sh self-offset))] 529 [(b12x b12y) (values s2x s1y)] 530 [(b23x b23y) (values s2x s3y)] 531 532 [(s4x s4y) (values (- sx arrowhead-short-side) 533 (+ sy (* sh 1/2)))] 534 [(s5x s5y) (values (- sx arrowhead-short-side self-offset) 535 (+ sy (* 3/4 sh) (* 1/2 self-offset)))] 536 [(s6x s6y) (values (- sx arrowhead-short-side) 537 (+ sy sh self-offset))] 538 [(b45x b45y) (values s5x s4y)] 539 [(b56x b56y) (values s5x s6y)]) 540 541 (update-arrowhead-polygon s4x s4y sx s4y point1 point2 point3 point4) 542 (send dc draw-spline (+ dx s1x) (+ dy s1y) (+ dx b12x) (+ dy b12y) (+ dx s2x) 543 (+ dy s2y)) 544 (send dc draw-spline (+ dx s2x) (+ dy s2y) (+ dx b23x) (+ dy b23y) (+ dx s3x) 545 (+ dy s3y)) 546 (send dc draw-line (+ dx s3x) (+ dy s3y) (+ dx s6x) (+ dy s6y)) 547 548 (when (and edge-labels? (link-label the-link)) 549 (let* ((textlen (get-text-length (link-label the-link))) 550 (linelen (- s6x s3x)) 551 (offset (* 1/2 (- linelen textlen)))) 552 (when (or #t (> sw textlen)) 553 (send dc draw-text 554 (link-label the-link) 555 (+ dx s3x offset) 556 (+ dy s3y) 557 #f 558 0 559 0)))) 560 561 (send dc draw-spline (+ dx s4x) (+ dy s4y) (+ dx b45x) (+ dy b45y) (+ dx s5x) 562 (+ dy s5y)) 563 (send dc draw-spline (+ dx s5x) (+ dy s5y) (+ dx b56x) (+ dy b56y) (+ dx s6x) 564 (+ dy s6y)) 565 (send dc draw-polygon points dx dy))) 566 567 (define (draw-non-self-connection dx dy from-link dark-lines? to) 568 (let ([from (link-snip from-link)]) 569 (let*-values ([(xf yf wf hf) (get-position from)] 570 [(xt yt wt ht) (get-position to)] 571 [(lf tf rf bf) (values xf yf (+ xf wf) (+ yf hf))] 572 [(lt tt rt bt) (values xt yt (+ xt wt) (+ yt ht))]) 573 (let ([x1 (+ xf (/ wf 2))] 574 [y1 (+ yf (/ hf 2))] 575 [x2 (+ xt (/ wt 2))] 576 [y2 (+ yt (/ ht 2))]) 577 578 (set-pen/brush from-link dark-lines?) 579 (let-values ([(from-x from-y) 580 (or-2v (find-intersection x1 y1 x2 y2 581 lf tf rf tf) 582 (find-intersection x1 y1 x2 y2 583 lf bf rf bf) 584 (find-intersection x1 y1 x2 y2 585 lf tf lf bf) 586 (find-intersection x1 y1 x2 y2 587 rf tf rf bf))] 588 [(to-x to-y) 589 (or-2v (find-intersection x1 y1 x2 y2 590 lt tt rt tt) 591 (find-intersection x1 y1 x2 y2 592 lt bt rt bt) 593 (find-intersection x1 y1 x2 y2 594 lt tt lt bt) 595 (find-intersection x1 y1 x2 y2 596 rt tt rt bt))]) 597 (when (and from-x from-y to-x to-y) 598 (let ((from-pt (make-rectangular from-x from-y)) 599 (to-pt (make-rectangular to-x to-y))) 600 (define (arrow-point-ok? point-x point-y) 601 (and (in-rectangle? point-x point-y 602 (min lt rt lf rf) (min tt bt tf bf) 603 (max lt rt lf rf) (max tt bt tf bf)) 604 (not (strict-in-rectangle? point-x point-y 605 (min lt rt) (min tt bt) 606 (max lt rt) (max tt bt))) 607 (not (strict-in-rectangle? point-x point-y 608 (min lf rf) (min tf bf) 609 (max lf rf) (max tf bf))))) 610 (cond 611 [(or (in-rectangle? from-x from-y lt tt rt bt) 612 (in-rectangle? to-x to-y lf tf rf bf)) 613 ;; the snips overlap, draw nothing 614 (void)] 615 [else 616 (draw-single-edge dc dx dy from to from-x from-y to-x to-y arrow-point-ok?) 617 (when (and edge-labels? (link-label from-link)) 618 (let-values ([(text-len h d v) 619 (send dc get-text-extent (link-label from-link))]) 620 (let* ([arrow-end-x (send point3 get-x)] 621 [arrow-end-y (send point3 get-y)] 622 [arrowhead-end (make-rectangular arrow-end-x arrow-end-y)] 623 [vec (- arrowhead-end from-pt)] 624 [angle (- (angle vec))] 625 [flip? (and flip-labels? 626 (not (< (/ pi -2) angle (/ pi 2))))] 627 [angle (if flip? (+ angle pi) angle)] 628 [middle (+ from-pt 629 (- (* 1/2 vec) 630 (make-polar (/ text-len 2) (- angle))))]) 631 (when (> (sqrt (+ (sqr (- arrow-end-x from-x)) 632 (sqr (- arrow-end-y from-y)))) 633 text-len) 634 (send dc draw-text (link-label from-link) 635 (+ dx (real-part middle)) 636 (+ dy (imag-part middle)) 637 #f 638 0 639 angle)))))])))))))) 640 641 (define (set-pen/brush from-link dark-lines?) 642 (send dc set-brush 643 (if dark-lines? 644 (link-dark-brush from-link) 645 (link-light-brush from-link))) 646 (send dc set-pen 647 (if dark-lines? 648 (link-dark-pen from-link) 649 (link-light-pen from-link))) 650 (send dc set-text-foreground 651 (if dark-lines? 652 (link-dark-text from-link) 653 (link-light-text from-link)))) 654 655 (let ([old-pen (send dc get-pen)] 656 [old-brush (send dc get-brush)] 657 [old-fg (send dc get-text-foreground)] 658 [os (send dc get-smoothing)]) 659 (send dc set-smoothing 'aligned) 660 661 (let ([pairs '()]) 662 (for-each-to-redraw 663 left top right bottom 664 (lambda (from-link to) 665 (let ([from (link-snip from-link)]) 666 (when (and (or (member from currently-overs object=?) 667 (member to currently-overs object=?)) 668 draw-dark-lines?) 669 (set! pairs (cons (cons from-link to) pairs))) 670 (unless draw-dark-lines? 671 (draw-connection from-link to #f))))) 672 (for-each (lambda (pr) 673 (draw-connection (car pr) (cdr pr) #t)) 674 pairs)) 675 676 (send dc set-smoothing os) 677 (send dc set-pen old-pen) 678 (send dc set-text-foreground old-fg) 679 (send dc set-brush old-brush))) 680 681 (define/public (draw-single-edge dc dx dy from to from-x from-y to-x to-y arrow-point-ok?) 682 (send dc draw-line 683 (+ dx from-x) (+ dy from-y) 684 (+ dx to-x) (+ dy to-y)) 685 (update-arrowhead-polygon from-x from-y to-x to-y point1 point2 point3 point4) 686 (when (and draw-arrow-heads? 687 (arrow-point-ok? (send point1 get-x) (send point1 get-y)) 688 (arrow-point-ok? (send point2 get-x) (send point2 get-y)) 689 (arrow-point-ok? (send point3 get-x) (send point3 get-y)) 690 (arrow-point-ok? (send point4 get-x) (send point4 get-y))) 691 ;; the arrowhead is not overlapping the snips, so draw it 692 ;; (this is only an approximate test, but probably good enough) 693 (send dc draw-polygon points dx dy))) 694 695 ;; for-each-to-redraw : number number number number (link snip -> void) 696 (define/private (for-each-to-redraw left top right bottom f) 697 ;; : link snip boolean boolean -> void 698 ;; sets the drawing context (pen and brush) 699 ;; determines if the connection is between a snip and itself or two different snips 700 ;; and calls draw-self-connection or draw-non-self-connection 701 (define (maybe-call-f from-link to) 702 (let ([from (link-snip from-link)]) 703 (when (send from get-admin) 704 (cond 705 [(object=? from to) 706 (f from-link to)] 707 [else 708 (let*-values ([(xf yf wf hf) (get-position from)] 709 [(xt yt wt ht) (get-position to)] 710 [(lf tf rf bf) (values xf yf (+ xf wf) (+ yf hf))] 711 [(lt tt rt bt) (values xt yt (+ xt wt) (+ yt ht))]) 712 (let ([x1 (+ xf (/ wf 2))] 713 [y1 (+ yf (/ hf 2))] 714 [x2 (+ xt (/ wt 2))] 715 [y2 (+ yt (/ ht 2))]) 716 717 (unless (or (and (x1 . <= . left) 718 (x2 . <= . left)) 719 (and (x1 . >= . right) 720 (x2 . >= . right)) 721 (and (y1 . <= . top) 722 (y2 . <= . top)) 723 (and (y1 . >= . bottom) 724 (y2 . >= . bottom))) 725 (f from-link to))))])))) 726 727 (let loop ([snip (find-first-snip)]) 728 (when snip 729 (when (and (send snip get-admin) 730 (is-a? snip graph-snip<%>)) 731 (for-each (lambda (parent-link) (maybe-call-f parent-link snip)) 732 (send snip get-parent-links))) 733 (loop (send snip next))))) 734 735 736 (field 737 [point1 (make-object point% 0 0)] 738 [point2 (make-object point% 0 0)] 739 [point3 (make-object point% 0 0)] 740 [point4 (make-object point% 0 0)] 741 [points (list point1 point2 point3 point4)]) 742 743 ;; update-arrowhead-polygon : number^4 -> void 744 ;; updates points1, 2, and 3 with the arrow head's 745 ;; points. Use a turtle-like movement to find the points. 746 ;; point3 is the point where the line should end. 747 (define/public (update-arrowhead-polygon from-x from-y to-x to-y point1 point2 point3 point4) 748 (define (move tx ty ta d) (values (+ tx (* d (cos ta))) 749 (+ ty (* d (sin ta))) 750 ta)) 751 (define (turn tx ty ta a) (values tx 752 ty 753 (+ ta a))) 754 (define init-angle 755 (cond 756 [(and (from-x . = . to-x) 757 (from-y . < . to-y)) 758 (* pi 3/2)] 759 [(from-x . = . to-x) 760 (* pi 1/2)] 761 [(from-x . < . to-x) 762 (+ pi (atan (/ (- from-y to-y) (- from-x to-x))))] 763 [else 764 (atan (/ (- from-y to-y) (- from-x to-x)))])) 765 (let*-values ([(t1x t1y t1a) (values to-x to-y init-angle)] 766 [(t2x t2y t2a) (turn t1x t1y t1a (/ arrowhead-angle-width 2))] 767 [(t3x t3y t3a) (move t2x t2y t2a arrowhead-long-side)] 768 [(t4x t4y t4a) (turn t1x t1y t1a (- (/ arrowhead-angle-width 2)))] 769 [(t5x t5y t5a) (move t4x t4y t4a arrowhead-long-side)] 770 [(t6x t6y t6a) (move t1x t1y t1a arrowhead-short-side)]) 771 (send point1 set-x t1x) 772 (send point1 set-y t1y) 773 (send point2 set-x t3x) 774 (send point2 set-y t3y) 775 (send point3 set-x t6x) 776 (send point3 set-y t6y) 777 (send point4 set-x t5x) 778 (send point4 set-y t5y))) 779 780 (define/private (should-hilite? snip) 781 (let ([check-one-way 782 (lambda (way) 783 (let loop ([snip snip]) 784 (or (member snip currently-overs object=?) 785 (and (is-a? snip graph-snip<%>) 786 (loop (car (way snip)))))))]) 787 (or (check-one-way (lambda (snip) (send snip get-children))) 788 (check-one-way (lambda (snip) (send snip get-parents)))))) 789 790 (inherit get-snip-location) 791 (field [lb (box 0)] 792 [tb (box 0)] 793 [rb (box 0)] 794 [bb (box 0)]) 795 (define/private (get-position snip) 796 (get-snip-location snip lb tb #f) 797 (get-snip-location snip rb bb #t) 798 (values (unbox lb) 799 (unbox tb) 800 (- (unbox rb) (unbox lb)) 801 (- (unbox bb) (unbox tb)))) 802 803 (super-new))) 804 805 ;; in-rectangle? : number^2 number^2 number^2 -> boolean 806 ;; determines if (x,y) is in the rectangle described 807 ;; by (p1x,p1y) and (p2x,p2y). 808 (define (in-rectangle? x y p1x p1y p2x p2y) 809 (and (<= (min p1x p2x) x (max p1x p2x)) 810 (<= (min p1y p2y) y (max p1y p2y)))) 811 812 ;; strict-in-rectangle? : number^2 number^2 number^2 -> boolean 813 ;; determines if (x,y) is in the rectangle described 814 ;; by (p1x,p1y) and (p2x,p2y), but not on the border 815 (define (strict-in-rectangle? x y p1x p1y p2x p2y) 816 (and (< (min p1x p2x) x (max p1x p2x)) 817 (< (min p1y p2y) y (max p1y p2y)))) 818 819 ;; find-intersection : number^8 -> (values (or/c #f number) (or/c #f number)) 820 ;; calculates the intersection between two line segments, 821 ;; described as pairs of points. Returns #f if they do not intersect 822 (define (find-intersection x1 y1 x2 y2 x3 y3 x4 y4) 823 (let-values ([(m1 b1) (find-mb x1 y1 x2 y2)] 824 [(m2 b2) (find-mb x3 y3 x4 y4)]) 825 (let-values ([(int-x int-y) 826 (cond 827 [(and m1 m2 b1 b2 828 (= m1 0) 829 (= m2 0)) 830 (values #f #f)] 831 [(and m1 m2 b1 b2 832 (= m1 0)) 833 (let* ([y y1] 834 [x (/ (- y b2) m2)]) 835 (values x y))] 836 [(and m1 m2 b1 b2 837 (= m2 0)) 838 (let* ([y y3] 839 [x (/ (- y b1) m1)]) 840 (values x y))] 841 [(and m1 m2 b1 b2 842 (not (= m1 m2))) 843 (let* ([y (/ (- b2 b1) (- m1 m2))] 844 [x (/ (- y b1) m1)]) 845 (values x y))] 846 [(and m1 b1) 847 (let* ([x x3] 848 [y (+ (* m1 x) b1)]) 849 (values x y))] 850 [(and m2 b2) 851 (let* ([x x1] 852 [y (+ (* m2 x) b2)]) 853 (values x y))] 854 [else 855 (values #f #f)])]) 856 857 (if (and int-x 858 int-y 859 (<= (min x1 x2) int-x (max x1 x2)) 860 (<= (min y1 y2) int-y (max y1 y2)) 861 (<= (min x3 x4) int-x (max x3 x4)) 862 (<= (min y3 y4) int-y (max y3 y4))) 863 (values int-x int-y) 864 (values #f #f))))) 865 866 ;; find-mb : number number number number -> (values (or/c #f number) (or/c #f number)) 867 ;; finds the "m" and "b" constants that describe the 868 ;; lines from (x1, y1) to (x2, y2) 869 (define (find-mb x1 y1 x2 y2) 870 (if (= x1 x2) 871 (values #f #f) 872 (let-values ([(xl yl xr yr) 873 (if (x1 . <= . x2) 874 (values x1 y1 x2 y2) 875 (values x2 y2 x1 y1))]) 876 (let* ([m (/ (- yr yl) (- xr xl))] 877 [b (- y1 (* m x1))]) 878 (values m b))))) 879 880 ;; get-all-relatives : (snip -> (listof snip)) snip -> (listof snip) 881 ;; returns all editor-snip relatives (of a particular sort), including 882 ;; any regular snip relatives along the way. 883 (define (get-all-relatives get-relatives snip) 884 (let loop ([flat-relatives (get-relatives snip)] 885 [relatives null]) 886 (cond 887 [(null? flat-relatives) relatives] 888 [else 889 (let i-loop ([dummy (car flat-relatives)] 890 [acc relatives]) 891 (cond 892 [(is-a? dummy graph-snip<%>) 893 (loop (cdr flat-relatives) (cons dummy acc))] 894 [else 895 (i-loop (car (get-relatives dummy)) 896 (cons dummy acc))]))]))) 897 898 ;; get-all-children : snip -> (listof snip) 899 (define (get-all-children snip) 900 (get-all-relatives (lambda (snip) (send snip get-children)) snip)) 901 902 ;; get-all-parents : snip -> (listof snip) 903 (define (get-all-parents snip) 904 (get-all-relatives (lambda (snip) (send snip get-parents)) snip)) 905