From c7403699a5d030d9a5981ea7e831f5ae30a8bb5e Mon Sep 17 00:00:00 2001 From: nik gaffney Date: Thu, 14 Sep 2006 18:38:47 +0200 Subject: [PATCH] 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. --- graph.scm | 1053 +++++++++++++++++++++++++++++++++++++++++++++++++ qfwfq.scm | 135 +++++-- xaueneuax.scm | 45 ++- 3 files changed, 1189 insertions(+), 44 deletions(-) create mode 100644 graph.scm diff --git a/graph.scm b/graph.scm new file mode 100644 index 0000000..f90a5cd --- /dev/null +++ b/graph.scm @@ -0,0 +1,1053 @@ + +;; 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) + + (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))) + diff --git a/qfwfq.scm b/qfwfq.scm index 1c70b7e..f441d9e 100644 --- a/qfwfq.scm +++ b/qfwfq.scm @@ -3,12 +3,12 @@ ;; a simple setup for testing ideas about visual programming ;; ;; copyright (C) 2004 FoAM vzw -;; You are granted the rights to distribute and use this software -;; under the terms of the Lisp Lesser GNU Public License, known -;; as the LLGPL. The LLGPL consists of a preamble and the LGPL. -;; Where these conflict, the preamble takes precedence. The LLGPL -;; is available online at http://opensource.franz.com/preamble.html -;; and is distributed with this code (see: LICENCE and LGPL files) +;; You are granted the rights to distribute and use this software +;; under the terms of the GNU Lesser General Public License as +;; published by the Free Software Foundation; either version 2.1 of +;; the License, or (at your option] any later version. The LGPL is +;; distributed with this code (see: LICENCE) and available online +;; at http://www.gnu.org/copyleft/lesser.html ;; authors ;; - nik gaffney @@ -29,9 +29,11 @@ ;; changes ;; 2006-09-11 ;; - scraped into coherence from various sources +;; 2006-09-14 +;; - fixed tree-colouring and traversal (module qfwfq mzscheme - (require (lib "graph.ss" "mrlib") + (require "graph.scm" ;modified from (lib "graph.ss" "mrlib") (lib "class.ss") (lib "list.ss") (lib "string.ss") @@ -48,6 +50,7 @@ set-node-value get-node-value draw-parse-tree + colour-tree wobble-tree eval-tree tree->sexp @@ -59,7 +62,9 @@ (let ([debugging #t] ; toggle #t/#f [debug-level 1]) ; higher is more info (if (and debugging (>= debug-level level)) - (printf fstring fargs)))) + (if (list? fargs) + (apply printf (cons fstring fargs)) + (printf fstring fargs))))) ;;;;;;;;; ;; ;; ;; ;; @@ -89,15 +94,17 @@ (class (graph-snip-mixin editor-snip%) (init-field (value ())) (init-field (dirty #f)) - (public set-value besmirch clean) - (define (set-value v) + (inherit-field parent-links) + ;(inherit link) + + (define/public (set-value v) (set! value v)) - (define (besmirch) + (define/public (besmirch) (debug 2 "smirched: ~a ~%" this) (set! dirty #t) (map (lambda (x) (send x besmirch)) (send this get-children))) - (define (clean) + (define/public (clean) (set! dirty #f)) ;; should be more coarse grained than 'on-event', but what?+ (define/override (on-char dc x y editorx editory event) @@ -108,14 +115,23 @@ (super on-char dc x y editorx editory event)) (define/override (own-caret own-it?) (if own-it? - (debug 1 "node: ~a got keybrd focus~%" this) + (debug 3 "node: ~a got keybrd focus~%" this) (if dirty - (begin (debug 1 "node: ~a lost keybrd focus~%" this) + (begin (debug 3 "node: ~a lost keybrd focus~%" this) (send this besmirch) (send this clean)))) (super own-caret own-it?)) + ;; links + (define/public (get-parent-links) parent-links) (super-new))) + ;; .. edges? + ;; would require modifying private methods in graph. + ;; see -> draw-non-self-connection for example + + ;; maybe directly modify the list via get-parent-links + ;; see -> (define-local-member-name get-parent-links) + ;; an output snip will display or modify its contents when besmirched.. . (define output-snip% (class node-snip% @@ -144,6 +160,16 @@ (define (get-node-value node) (send node value)) + ;; convert given object to string + (define (to-string x) + (cond ((string? x) x) + ((char? x) (list->string (list x))) + ((number? x) (number->string x)) + ((symbol? x) (symbol->string x)) + ((list? x) (apply string-append (map to-string x))) + (else (error "don't know how to convert to string: " x)))) + + ;; decor ;; brushes/ pens see -> 6.15 pen% ;; colours -> 6.7 color-database<%> @@ -159,15 +185,6 @@ (define pen4 (send the-pen-list find-or-create-pen "DarkSeaGreen" 1 'solid)) (define brush4 (send the-brush-list find-or-create-brush "Beige" 'solid)) - ; convert given object to string - (define (to-string x) - (cond ((string? x) x) - ((char? x) (list->string (list x))) - ((number? x) (number->string x)) - ((symbol? x) (symbol->string x)) - ((list? x) (apply string-append (map to-string x))) - (else (error "don't know how to convert to string: " x)))) - ;;;;;;;;; ; ; ;; ; ;; ;; re-traversal @@ -191,7 +208,7 @@ ;; subtrees, or args (for-each (lambda (child) - (if (list? child) + (if (list? child) (draw-parse-tree child x y node pb) (let ((sibling (new node-snip%))) (send pb insert sibling) @@ -199,6 +216,76 @@ (send (send sibling get-editor) insert (to-string child))))) (cdr tree)))))) + ;; tree colouring, using pens, brushes and wax. + ;; where the given node is the root of the tree to be traversed + (define (colour-tree node pb) + (let ([parents (send node get-parents)]) + (if (not (empty? parents)) + (begin (debug 1 "tree-coloring: ~a ~%" node) + (colour-links node + (list pen1 pen2 brush1 brush2) ;; functions + (list pen3 pen4 brush3 brush4)) ;; elements + ;; function node + ;; - set pens and brushes... + ;; subtrees, or args + (for-each + (lambda (parent) + (colour-tree parent pb)) + parents))))) + + ;; link colouring, of each link from a given node + ;; *-colours are each a list of 4 pens & brushes + (define (colour-links node fcn-colours elt-colours) + (let* ([parents (send node get-parents)] + [links (send node get-parent-links)]) + (let-values ([(fp1 fp2 fb1 fb2) (split-colours fcn-colours)] + [(ep1 ep2 eb1 eb2) (split-colours elt-colours)]) + (debug 1 "link-coloring: ~a -> ~a ~%" node parents) + (if (not (empty? links)) + (for-each + (lambda (parent) + (if (empty? (send parent get-parents)) + ;; elements) + (let ([link (find-link node parent)]) + (set-colours link ep1 ep2 eb1 eb2)) + ;; functions + (let ([link (find-link node parent)]) + (set-colours link fp1 fp2 fb1 fb2)))) + parents))))) + + ;; find a link from one node to another + (define (find-link n1 n2) + (let ([links (send n1 get-parent-links)] + [result #f]) + (map (lambda (link) + (debug 2 "finding link: ~a -> ~a~%" n2 (link-snip link)) + (if (equal? (link-snip link) n2) + (set! result link))) links) result)) + + ;; relabel + (define *travail* 0) + + (define (re-label! link) + (let ([label (link-label link)]) + (set! *travail* (+ 1 *travail*)) + (set-link-label! link (string-append (if label label "") + (format ".~a." *travail*))))) + + + ;; multicolour + (define (set-colours link p1 p2 b1 b2) + (set-link-dark-pen! link p1) + (set-link-dark-brush! link b1) + (set-link-light-pen! link p2) + (set-link-light-brush! link b2)) + + ;; return pens & brushes form a list as mulitple-values + (define (split-colours c) + (values (list-ref c 0) + (list-ref c 1) + (list-ref c 2) + (list-ref c 3))) + ;; basic layout attmepts ;; traverse from a node, and s p r e a d diff --git a/xaueneuax.scm b/xaueneuax.scm index 20879da..dd1b86a 100644 --- a/xaueneuax.scm +++ b/xaueneuax.scm @@ -3,12 +3,12 @@ ;; x a u e n e u a x - nqdataflow ;; ;; copyright (C) 2004 FoAM vzw -;; You are granted the rights to distribute and use this software -;; under the terms of the Lisp Lesser GNU Public License, known -;; as the LLGPL. The LLGPL consists of a preamble and the LGPL. -;; Where these conflict, the preamble takes precedence. The LLGPL -;; is available online at http://opensource.franz.com/preamble.html -;; and is distributed with this code (see: LICENCE and LGPL files) +;; You are granted the rights to distribute and use this software +;; under the terms of the GNU Lesser General Public License as +;; published by the Free Software Foundation; either version 2.1 of +;; the License, or (at your option] any later version. The LGPL is +;; distributed with this code (see: LICENCE) and available online +;; at http://www.gnu.org/copyleft/lesser.html ;; authors ;; - nik gaffney @@ -22,15 +22,15 @@ ;; quite scheme -> nqdataflow ;; ;; keyboard controls -;; n - adds new node, connected to a selected node -;; c - conencts 2 selected nodes -;; d - disconnects selected node +;; C-n - adds new node, connected to a selected node +;; C-c - conencts 2 selected nodes +;; C-d - disconnects selected node ;; delete - deletes node ;; enter - evaluates current node ;; to do ;; - deal with evaluation order display -;; - check directions of node connection with 'c' +;; - check directions of node connection with 'C-c' ;; - multiple connections -> clarify ;; - deal with circularity @@ -38,7 +38,7 @@ ;; 2006-09-11 ;; - scraped into coherence from various sources -(require (lib "graph.ss" "mrlib") +(require "graph.scm" "qfwfq.scm") (define xauen-pasteboard% @@ -61,7 +61,7 @@ (send ec set-editor p) (define dc (send ec get-dc)) -;; text input calllback - spit and polish +;; text input callback - spit and polish ;; beware hardcoded node & pasteboard & lack of error checking (define (parse-text-input tf event) (if (eqv? (send event get-event-type) 'text-field-enter) @@ -86,28 +86,33 @@ [Gx (send event get-x)] [Gy (send event get-y)]) (let-values ([(x y) (send target editor-location-to-dc-location Gx Gy)]) - (debug 1 "key[de]maping->key: ~a ~%" key) + (debug 3 "key[de]maping->key: ~a ~%" key) (debug 1 "selected-snip: ~a ~%" selected-snip) + (if (send event get-control-down) (case key - [(#\n) ;; n fr 'new' + [(#\n) ;; C-n fr 'new' (debug 1 "add: ~a" key) (let ([node (new node-snip%)]) (send target insert node) (if selected-snip - (add-links node selected-snip)) - ;;(send target move-to node x y) + (begin (add-links node selected-snip) + ;; re.colour the tree, first [grand]child should do... + (colour-tree (car (send selected-snip get-children)) p))) + (send target move-to node x y) )] - [(#\c) ;; c fr 'connect' + [(#\c) ;; C-c fr 'connect' (let ([next (send target find-next-selected-snip selected-snip)]) (debug 1 "next-snip: ~a ~%" next) (add-links selected-snip next))] - [(#\d) ;; d fr 'disconnect' + [(#\d) ;; C-d fr 'disconnect' (let ([next (send target find-next-selected-snip selected-snip)]) (send selected-snip remove-child next) (send selected-snip remove-parent next) (send next remove-parent selected-snip) - (send next remove-child selected-snip))] - )))) + (send next remove-child selected-snip))] + [(#\z) ;; C-z re.colour + (colour-tree selected-snip p)] + ))))) ;; basic nodewrenching (define n1 (new output-snip%))