zzkt/qfwfq
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity
qfwfq/punctiform-convergence/graph.scm

1088 lines
49 KiB
Scheme
Raw Normal View History

Z'zus cupboard all at a single point. almost instantly, expanding into scratches, eddies and snipets of layout algorithms. gradually reshaping, drawn with puctiform convergence. what did those Z'zus have hidden in their cupboard?
2006-11-12 22:02:23 +00:00
;; -*- mode: scheme -*-
;;
wrong eye fixed various problems with the graph traversal, and colouring. included a modified version of the graph library from MrLib, to expose internal structs and provide new possibilites for breaking things. keyboard commands are now prefixed by the control-key.
2006-09-14 16:38:47 +00:00
;; 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<%>
lacking names first reductions, simplifying of some leaves into anonymous functions.
2007-07-09 13:44:21 +00:00
graph-pasteboard-mixin
graph-snipboard<%>
graph-snipboard-mixin)
wrong eye fixed various problems with the graph traversal, and colouring. included a modified version of the graph library from MrLib, to expose internal structs and provide new possibilites for breaking things. keyboard commands are now prefixed by the control-key.
2006-09-14 16:38:47 +00:00
(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 #<struct:link> 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 #<struct:link> 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)
lacking names first reductions, simplifying of some leaves into anonymous functions.
2007-07-09 13:44:21 +00:00
;;(super on-interactive-move evt)
wrong eye fixed various problems with the graph traversal, and colouring. included a modified version of the graph library from MrLib, to expose internal structs and provide new possibilites for breaking things. keyboard commands are now prefixed by the control-key.
2006-09-14 16:38:47 +00:00
)
(define/augment (after-interactive-move evt)
(invalidate-selected-snips)
lacking names first reductions, simplifying of some leaves into anonymous functions.
2007-07-09 13:44:21 +00:00
;;(super on-interactive-move evt)
)
wrong eye fixed various problems with the graph traversal, and colouring. included a modified version of the graph library from MrLib, to expose internal structs and provide new possibilites for breaking things. keyboard commands are now prefixed by the control-key.
2006-09-14 16:38:47 +00:00
(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)))
lacking names first reductions, simplifying of some leaves into anonymous functions.
2007-07-09 13:44:21 +00:00
;;(super after-insert snip before x y)
)
wrong eye fixed various problems with the graph traversal, and colouring. included a modified version of the graph library from MrLib, to expose internal structs and provide new possibilites for breaking things. keyboard commands are now prefixed by the control-key.
2006-09-14 16:38:47 +00:00
;; 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)))]
lacking names first reductions, simplifying of some leaves into anonymous functions.
2007-07-09 13:44:21 +00:00
[(flip?) #f ] ;(negative? (- to-x from-x))
wrong eye fixed various problems with the graph traversal, and colouring. included a modified version of the graph library from MrLib, to expose internal structs and provide new possibilites for breaking things. keyboard commands are now prefixed by the control-key.
2006-09-14 16:38:47 +00:00
[(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)
lacking names first reductions, simplifying of some leaves into anonymous functions.
2007-07-09 13:44:21 +00:00
(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<%>))
)
)
wrong eye fixed various problems with the graph traversal, and colouring. included a modified version of the graph library from MrLib, to expose internal structs and provide new possibilites for breaking things. keyboard commands are now prefixed by the control-key.
2006-09-14 16:38:47 +00:00
Reference in a new issue Copy permalink