lacking names

first reductions, simplifying of some leaves into anonymous functions.

README

@@ -5,11 +5,13 @@ scientific devices. In one story, Qfwfq is a dinosaur, but in other stories he
 is also a fish, a small mammal, a subatomic particle eternally plummeting
 through the void. Qfwfq's constantly shifting position in the universe, despite
 his consistent first-person narration, suggests the extent to which his form
-accommodates his point of view."
+accommodates his point of view." -- Dean Swinford 
+
+further documentation can be found in the folder 't-zero' and several examples
+can be found in the folder 'games without end'
 
 libarynth topics
  http://libarynth.fo.am/cgi-bin/view/Libarynth/VisualProgramming
  http://libarynth.fo.am/cgi-bin/view/Libarynth/ProjectQfwfq
 
 
- 

punctiform-convergence/eddies.scm

@@ -155,8 +155,9 @@
   
   ;; a recursive-snip can contain other node-snips,.
   ;; should be incorporated into basic node-snips
-  ;(define recursive-snip-mixin 
+  
-  ;  (mixin (graph-snip<%>) (editor<%>)))
+;;  (define recursive-snip% 
+;;     (graph-snipboard-mixin editor-snip%))
 
   (define recursive-snip%
     (class (graph-snip-mixin editor-snip%) 
@@ -195,6 +196,10 @@
           ((list? x) (apply string-append (map to-string x))) 
           (else (error "don't know how to convert to string: " x))))
   
+  ;; copypaste 
+  (define (copypaste pb)
+    (debug 1 "selection: " (selected-snips pb))
+    )
   
   ;; decor
   ;; brushes/ pens see -> 6.15  pen%
@@ -289,7 +294,7 @@
                  (set! result link))) links) result))
   
   ;; relabel
-  ;;  note that this uses a global so is not threadsafe
+  ;;  note that this uses a mutable global so is not threadsafe
   (define *travail* 0)
   
   (define (re-label! link)
@@ -313,6 +318,11 @@
             (list-ref c 2) 
             (list-ref c 3)))
   
+  ;;;; ; ;;; ;  ;   ;  ; ; ;   ;
+  ;;
+  ;; translation, evaluation, circumspection
+  ;;
+  ;;;;;; ;   ;;  ;
   
   ;; eval [sub]graph from a node. ..
   ;;  absolutely no chekcing or error handling yet.
@@ -321,7 +331,7 @@
                    (eval (tree->sexp (car (send node get-parents))))))
   
   ;; traverse a tree [or graph] to create a corresponding s-expresion
-  ;; doesnt cope with cycles, nor muliple children (if a node has muliple
+  ;; doesnt cope with cycles, nor multiple children (if a node has muliple
   ;; children, it is translated into separate expressions)  
   (define (tree->sexp node)
     (let ([parents (send node get-parents)]
@@ -334,5 +344,78 @@
       (debug 1 "tree->sexp: ~a ~%" out)         
       out))
 
+  ;; return a list of the selected snips
+  (define (selected-snips pb) 
+    (let* ((snip (send pb find-next-selected-snip #f))
+           (selection (list snip)))
+      (while snip
+        (set! snip (send pb find-next-selected-snip snip))
+        (if snip
+            (set! selection (cons snip selection)) #f))
+      selection))
+
+  
+  ;; convert a given selection to a (pseudonymous) function, given a list of
+  ;; nodes, and a pasteboard to draw to. namespace is currently unspecified,
+  ;; values not yet multiple.
+  (define (encapsulate selection pb)
+    (let* ((fname (string->symbol (symbol->string (gensym "q-"))))
+          (nodes selection)
+          (inputs (find-inputs nodes))
+          (outputs (find-outputs nodes)))
+
+      (debug 1 "function: ~a~%" fname)
+      (debug 1 "nodes: ~a~%" nodes)
+      (debug 1 "input: ~a~%" inputs)
+      (debug 1 "outpt: ~a~%" outputs)
+
+      ;; subtree -> leaves ie. no inputs, single output
+      (cond ((empty? inputs)
+             (debug 1 "grnks...~%")
+             (let* ((fnode (make-node-snip))
+                   (prune (caar outputs)) ;; map -> multiple
+                   (graft (cadar outputs)))
+               
+               (debug 1 "prune ~a~%" prune)
+               (debug 1 "graft ~a -> ~a ~% " graft (send graft get-parents))
+               (send pb insert fnode)
+               (add-links fnode graft pen1 pen2 brush1 brush2)
+               (send (send fnode get-editor) insert (format "(~a)" (to-string fname)))
+               (send graft remove-parent prune)
+               (debug 1 "fdef ~a ~%"
+                      (eval `(define ,fname (lambda () ,(tree->sexp prune)))))
+                           
+      )))))
+
+            
+            
+  ;; find the nodes leading into/outof a subgraph, given as a list returns a
+  ;; list of lists (node in the subgraph, followed by nodes to which it
+  ;; connects)
+
+  (define (find-inputs nodes)
+    (if nodes
+        (let ((inputs
+               (filter
+                (lambda (l) (< 1 (length l)))
+                (map
+                  (lambda (node)
+                    (cons node (remove* nodes (send node get-parents))))
+                  nodes))))
+          inputs)
+        #f))
+  
+  (define (find-outputs nodes)
+    (if nodes
+        (let ((outputs
+               (filter
+                (lambda (l) (< 1 (length l)))
+                (map
+                  (lambda (node)
+                    (cons node (remove* nodes (send node get-children))))
+                  nodes))))
+          outputs)
+        #f))
+  
 
   ) ;; end of module

punctiform-convergence/graph.scm

@@ -12,7 +12,10 @@
   (provide graph-snip<%>
            graph-snip-mixin
            graph-pasteboard<%>
-           graph-pasteboard-mixin)
+           graph-pasteboard-mixin
+           graph-snipboard<%>
+           graph-snipboard-mixin)
+           
   
   (define graph-snip<%>
     (interface ()
@@ -275,12 +278,13 @@
       
       (define/augment (on-interactive-move evt)
         (invalidate-selected-snips)
-        #;(super on-interactive-move evt)
+        ;;(super on-interactive-move evt)
         )
       
       (define/augment (after-interactive-move evt)
         (invalidate-selected-snips)
-        #;(super on-interactive-move evt))
+        ;;(super on-interactive-move evt)
+        )
       
       (define/override (interactive-adjust-move snip x y)
         (let ([dc (get-dc)])
@@ -292,7 +296,8 @@
         (let ([dc (get-dc)])
           (when dc
             (invalidate-to-children/parents snip dc)))
-        #;(super after-insert snip before x y))
+        ;;(super after-insert snip before x y)
+        )
       
       ;; invalidate-selected-snips : -> void
       ;; invalidates the region around the selected
@@ -775,7 +780,8 @@
                                            [(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))]
+                                           [(flip?) #f ] ;(negative? (- to-x from-x))
+                                            
                                            [(text-angle) 
                                             (if flip?
                                                 (+ theta pi)
@@ -1050,5 +1056,32 @@
   
   ;; get-all-parents : snip -> (listof snip)
   (define (get-all-parents snip)
-    (get-all-relatives (lambda (snip) (send snip get-parents)) snip)))
+    (get-all-relatives (lambda (snip) (send snip get-parents)) snip))
+
+
+  
+  ;; merge graph-snips and pasteboard, for which there must be a simpler way...
+  (define graph-snipboard<%>
+    (interface ()
+      get-children 
+      add-child
+      remove-child
+      
+      get-parents
+      add-parent
+      remove-parent
+      has-self-loop?
+      find-shortest-path
+      
+      on-mouse-over-snips
+      set-arrowhead-params
+      get-arrowhead-params))
+
+  (define graph-snipboard-mixin
+    (mixin ((class->interface pasteboard%)) (graph-pasteboard<%>))
+    ;;(mixin ((class->interface snip%)) (graph-snip<%>))
+    )
+
+           
+  )
 

punctiform-convergence/layout.scm

@@ -13,6 +13,7 @@
 ;; authors
 ;;  - nik gaffney <nik@fo.am>
 ;;  - tim boykett <tim@timesup.org>
+;;  - dave griffiths <dave@pawfal.org>
 
 ;; requirements
 ;;  - qfwfq and descendants
@@ -21,8 +22,10 @@
 ;;  - wobble -> hierarchical rectangular spread 
 ;;  - shuffle -> randomise positions
 ;;  - relax -> pseudo stabilisation using edge lengths 
+;;  - circles -> concentric radial layout
 ;;  - shadowpi -> variation on circular parent-centric splay
 
+
 ;; changes
 ;;  2006-09-11
 ;;  - scraped into coherence from various sources
@@ -44,6 +47,7 @@
   (provide wobble-tree
            shuffle-tree
            relax-tree
+           circles-tree
            shadowpi-tree)
 
   
@@ -108,28 +112,26 @@
   ;;;;; ;   ;; ;;    ;   ;
   
   (define (circles-tree node pb x y angle-start angle-end radius)
-    ; loop over all parents for this node
+    ;; loop over all parents for this node
     (define (parent-loop parents n angle-per-parent)
-      ; calculate the section of angles for this node, and call circles-tree for it
+      ;; calculate the section of angles for this node, and call circles-tree for it
       (let ([parent-start (+ angle-start (* angle-per-parent n))])
         (circles-tree (car parents) pb x y parent-start (+ parent-start angle-per-parent) (+ radius 50)))
-      (if (null? (cdr parents))
+      (if (not (null? (cdr parents)))
-            0
+          (parent-loop (cdr parents)
-            (parent-loop (cdr parents) (+ n 1) angle-per-parent)))
+                       (+ n 1) angle-per-parent)))
    
-    ; position this in the middle of the range of angles we've been given
+    ;; position this in the middle of the range of angles we've been given
     (send pb move node 
           (* (sin (+ angle-start (/ (- angle-end angle-start) 2))) radius)
           (* (cos (+ angle-start (/ (- angle-end angle-start) 2))) radius))
    
-    ; now call parent-loop for the parents if we have any parents
+    ;; now call parent-loop for the parents if we have any parents
     (let ([parents (send node get-parents)])
-    (cond 
+      (if (not (null? parents))
-      ((null? parents)
+          (let ([angle-per-parent (/ (- angle-end angle-start)
-          0)
+                                     (length parents))])
-      (else
+            (parent-loop parents 0 angle-per-parent)))))
-       (let ([angle-per-parent (/ (- angle-end angle-start) (length parents))])
-          (parent-loop parents 0 angle-per-parent))))))
       
      
  

punctiform-convergence/snipets.scm

@@ -16,7 +16,7 @@
   ;; a snip to act as the varying argument to a recursive functions
   (define linked-snip? (union snip? false/c))
   ;; a function to act on snips being mapped
-  (define snip-visitor? any/c #;((snip?) (listof any/c) . ->* . (void)))
+  (define snip-visitor? any/c ) ;((snip?) (listof any/c) . ->* . (void))
   ;; the rest of the lists passed to a snip mapping function
   (define rest-lists? (listof (listof any/c)))
   ;; a class that contains a snip
@@ -29,8 +29,8 @@
    (snip-y (snip? . -> . number?))
    (snip-parent (snip? . -> . (union editor? false/c)))
    (fold-snip ((snip? any/c . -> . any/c) any/c linked-snip? . -> . any/c))
-   (for-each-snip any/c #;((snip-visitor? linked-snip?) rest-lists? . ->* . (void)))
+   (for-each-snip any/c ) ;((snip-visitor? linked-snip?) rest-lists? . ->* . (void))
-   (map-snip any/c #;((snip-visitor? linked-snip?) rest-lists? . ->* . ((listof any/c)))))
+   (map-snip any/c )) ;((snip-visitor? linked-snip?) rest-lists? . ->* . ((listof any/c)))
   
   ;; the width of a snip in the parent pasteboard
   (define (snip-width snip)

qfwfq.scm

@@ -49,6 +49,10 @@
            insert-nodes
            add-links
            
+           selected-snips
+           find-inputs
+           find-outputs
+           
            set-node-text
            get-node-text
            set-node-value
@@ -60,6 +64,9 @@
            relax-tree
            eval-tree
            shadowpi-tree
+           circles-tree
+
+           encapsulate
            
            tree->sexp
            to-string

xaueneuax.scm

@@ -14,7 +14,7 @@
 ;;  - nik gaffney <nik@fo.am>
 
 ;; requirements
-;;  - uses qfwfq for layout and slipulation
+;;  - uses qfwfq for layout and slipping between
 
 ;; commentary
 ;;  a simple dataflow like visual wrapper to the underlying scheme,
@@ -41,12 +41,15 @@
 
 (require "qfwfq.scm") 
 
+
 (define xauen-pasteboard%
   (class graph-pasteboard%
     ;; should probably figure out how keymaps work,. 
     (define/override (on-char event)
       (temp-keymap event)
       (super on-char event))
+    (define/override (do-paste time)
+      (super do-paste time))
     (super-new)))
 
 ;; setup frame and windows.. 
@@ -121,6 +124,8 @@
              (colour-tree selected-snip p)]
             [(#\l) ;; C-l re.lapse -> splay
              (shadowpi-tree selected-snip p 0 63)]
+            [(#\e) ;; C-e encapsulate the selection
+             (encapsulate (selected-snips p) p)]
             [(#\=) ;; C-= zoom->out
              (send p zoom 1.1)]
             [(#\-) ;; C-- zoom->in
@@ -133,11 +138,10 @@
 (send p move-to n1 15 15)
 
 ;; test a recursive node
-;; (define r1 (new recursive-snip%))
+;(define r1 (new recursive-snip%))
-;; (send p insert r1)
+;(send p insert r1)
-;; (define n2 (new output-snip%))
+;(define n2 (new output-snip%))
-;; (send r1 insert n1)
+;(send r1 insert n1)
 
 (send f show #t)
 
-