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.

qfwfq.scm

@@ -4,11 +4,11 @@
 ;;
 ;; 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 
+;;  under the terms of the GNU Lesser General Public License as 
-;;  as the LLGPL. The LLGPL consists of a preamble and the LGPL. 
+;;  published by the Free Software Foundation; either version 2.1 of
-;;  Where these conflict, the preamble takes precedence. The LLGPL
+;;  the License, or (at your option] any later version. The LGPL is
-;;  is available online at http://opensource.franz.com/preamble.html 
+;;  distributed with this code (see: LICENCE) and available online 
-;;  and is distributed with this code (see: LICENCE and LGPL files)
+;;  at http://www.gnu.org/copyleft/lesser.html
 
 ;; authors
 ;;  - nik gaffney <nik@fo.am>
@@ -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)
+      (inherit-field parent-links)
-      (define (set-value v)
+      ;(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
@@ -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  

xaueneuax.scm

@@ -4,11 +4,11 @@
 ;;
 ;; 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 
+;;  under the terms of the GNU Lesser General Public License as 
-;;  as the LLGPL. The LLGPL consists of a preamble and the LGPL. 
+;;  published by the Free Software Foundation; either version 2.1 of
-;;  Where these conflict, the preamble takes precedence. The LLGPL
+;;  the License, or (at your option] any later version. The LGPL is
-;;  is available online at http://opensource.franz.com/preamble.html 
+;;  distributed with this code (see: LICENCE) and available online 
-;;  and is distributed with this code (see: LICENCE and LGPL files)
+;;  at http://www.gnu.org/copyleft/lesser.html
 
 ;; authors
 ;;  - nik gaffney <nik@fo.am>
@@ -22,15 +22,15 @@
 ;;  quite scheme -> nqdataflow
 ;;
 ;;  keyboard controls
-;;   n - adds new node, connected to a selected node
+;;   C-n - adds new node, connected to a selected node
-;;   c - conencts 2 selected nodes
+;;   C-c - conencts 2 selected nodes
-;;   d - disconnects selected node
+;;   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))
+               (begin (add-links node selected-snip)
-           ;;(send target move-to node x y)
+                      ;; 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))]
-        ))))
+        [(#\z) ;; C-z re.colour
+         (colour-tree selected-snip p)]
+        )))))
 
 ;; basic nodewrenching
 (define n1 (new output-snip%))