From be217c70fbc89dad7ef74701a40f836048942fa6 Mon Sep 17 00:00:00 2001 From: nik gaffney Date: Sun, 12 Nov 2006 23:02:23 +0100 Subject: [PATCH] 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? --- punctiform-convergence/eddies.scm | 338 +++++++++++++++++ graph.scm => punctiform-convergence/graph.scm | 3 +- punctiform-convergence/layout.scm | 225 ++++++++++++ punctiform-convergence/scritch.scm | 46 +++ punctiform-convergence/snipets.scm | 132 +++++++ qfwfq.scm | 342 +----------------- xaueneuax.scm | 68 ++-- 7 files changed, 797 insertions(+), 357 deletions(-) create mode 100644 punctiform-convergence/eddies.scm rename graph.scm => punctiform-convergence/graph.scm (99%) create mode 100644 punctiform-convergence/layout.scm create mode 100644 punctiform-convergence/scritch.scm create mode 100644 punctiform-convergence/snipets.scm diff --git a/punctiform-convergence/eddies.scm b/punctiform-convergence/eddies.scm new file mode 100644 index 0000000..689bb7d --- /dev/null +++ b/punctiform-convergence/eddies.scm @@ -0,0 +1,338 @@ +;; -*- mode: scheme -*- +;; +;; 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 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 + +;; requirements +;; - based on the MrEd environment for PLT scheme +;; - uses MrLib for graph display and editing + +;; commentary +;; aims to provide a simple framework for testing VPL models, ideas +;; or techniques. this code is based around the implicit assumption +;; that a VPL will be a graph based representation which is mapable +;; to a sexp (or collection of sexps), so some things should be +;; reasonably common between different (although admittedly graph +;; based) VPLs, for example graph traversal, node placement and layout. +;; it is not intended to be complete, exhaustive, or stable. + +;; changes +;; 2006-09-11 +;; - scraped into coherence from various sources +;; 2006-09-14 +;; - fixed tree-colouring and traversal +;; 2006-11-10 +;; - scattered energy stabilisation attempts +;; - scattered modules and files + + +(module eddies mzscheme + + (require (lib "misc.ss" "swindle") + (lib "mred.ss" "mred") + (lib "class.ss") + ;(lib "list.ss") + ;(lib "math.ss") + "scritch.scm" + "snipets.scm" + "graph.scm") + + (provide (all-defined)) + + + ;;;;;;;;; ;; ;; ;; + ;; + ;; graphs, graphing and graphics + ;; + ;;;;;; ; ;;; ; ;;; ; ; ; + + (define graph-pasteboard% + (class (graph-pasteboard-mixin pasteboard%) + (define/augment (on-delete snip) + ;; remove from parent list of children + (for-each (lambda (child) + (send child remove-parent snip)) + (send snip get-children)) + ;; remove from child list of parents + (for-each (lambda (parent) + (send parent remove-child snip)) + (send snip get-parents))) + (define/public (zoom n) + ;; zoom in/out by a given factor + (let ([snip (send this find-first-snip)]) + (while snip + (send snip resize + (* n (snip-width snip)) + (* n (snip-height snip))) + (send snip move + (* n (snip-x snip)) + (* n (snip-y snip))) + (set! snip (send snip next))))) + (super-new))) + + ;; nodes can contain any valid expression, which is stored as text [for now] + ;; able to be read by read-string. the field 'value' may contain a precomputed + ;; value of the nodes subtree, and the 'dirty' flag indicates wheter the subtree + ;; (ie. any of its children) have changed. + + (define node-snip% + (class (graph-snip-mixin editor-snip%) + (init-field (value ())) + (init-field (dirty #f)) + (inherit-field parent-links) + (define/public (set-value v) + (set! value v)) + (define/public (besmirch) + (debug 2 "smirched: ~a ~%" this) + (set! dirty #t) + (map (lambda (x) (send x besmirch)) + (send this get-children))) + (define/public (clean) + (set! dirty #f)) + + (define/public (move x y) + (let ([p (send (send this get-admin) get-editor)]) + (send p move-to this x y) + (send p set-modified #t))) + + ;; should be more coarse grained than 'on-event', but what?+ + (define/override (on-char dc x y editorx editory event) + (if (eqv? (send event get-key-code) #\return) + (begin (send event set-key-code #\nul) + (besmirch)) + (set! dirty #t)) + (super on-char dc x y editorx editory event)) + (define/override (own-caret own-it?) + (if own-it? + (debug 3 "node: ~a got keybrd focus~%" this) + (if dirty + (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))) + + ;; of suns, and of planets, and fields of wheat... + (define (make-node-snip) + (new node-snip% + (with-border? #t) + (left-margin 3) + (top-margin 3) + (right-margin 4) + (bottom-margin 2) + (left-inset 1) + (top-inset 1) + (right-inset 1) + (bottom-inset 1))) + + + ;; .. 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% + (define/override (besmirch) + (send (send this get-editor) erase) + (eval-tree this)) + (super-new))) + + ;; 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% + (class (graph-snip-mixin editor-snip%) + ;; details.. + (define (insert) + (debug "recurse..." this)) + (super-new))) + + + ;; node/graph utils,. + (define (insert-nodes p . nodes) + (for-each (lambda (x) (send p insert x)) nodes)) + + ;; insert non specific data into a node's text-field% + (define (set-node-text node data) + (send (send node get-editor) + insert (to-string data))) + + ;; get the text from a node + (define (get-node-text node) + (send (send node get-editor) get-text)) + + ;; partial [e]valuation + (define (set-node-value node value) + (send node set-value value)) + + (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<%> + + ;; function links -> active/inactive + (define pen1 (send the-pen-list find-or-create-pen "Red" 1 'solid)) + (define brush1 (send the-brush-list find-or-create-brush "orange" 'solid)) + (define pen2 (send the-pen-list find-or-create-pen "DarkSeaGreen" 1 'solid)) + (define brush2 (send the-brush-list find-or-create-brush "Gold" 'solid)) + ;; data links -> active/inactive + (define pen3 (send the-pen-list find-or-create-pen "orange" 1 'solid)) + (define brush3 (send the-brush-list find-or-create-brush "yellow" 'solid)) + (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)) + + ;;;;;;;;; ; ; ;; ; + ;; + ;; re-traversal + ;; + ;;;;;;;;; ;; ;; + + ;; build a tree from a given list, starting from the node% parent, + ;; drawing to the graph-pasteboard% pb .. . + (define (draw-parse-tree tree x y parent pb) + (if (list? tree) + (begin + (let ((size 5) + (root (car tree)) + (node (make-node-snip))) + (debug 2 "root: ~a ~%" root) + (draw-parse-tree root x y parent pb) + ;; function node + (send pb insert node) + (add-links node parent pen1 pen2 brush1 brush2) + (send (send node get-editor) insert (to-string root)) + ;; subtrees, or args + (for-each + (lambda (child) + (if (list? child) + (draw-parse-tree child x y node pb) + (let ((sibling (make-node-snip))) + (send pb insert sibling) + (add-links sibling node pen3 pen4 brush3 brush4) + (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 + ;; note that this uses a global so is not threadsafe + (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))) + + + ;; eval [sub]graph from a node. .. + ;; absolutely no chekcing or error handling yet. + (define (eval-tree node) + (set-node-text node + (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 + ;; children, it is translated into separate expressions) + (define (tree->sexp node) + (let ([parents (send node get-parents)] + [data (get-node-text node)] + [out ()]) + (if (not (null? parents)) + (set! out (cons (read-from-string data) + (reverse (map tree->sexp parents)))) + (set! out (read-from-string data))) + (debug 1 "tree->sexp: ~a ~%" out) + out)) + + + ) ;; end of module diff --git a/graph.scm b/punctiform-convergence/graph.scm similarity index 99% rename from graph.scm rename to punctiform-convergence/graph.scm index f90a5cd..d3f2c21 100644 --- a/graph.scm +++ b/punctiform-convergence/graph.scm @@ -1,4 +1,5 @@ - +;; -*- mode: scheme -*- +;; ;; modified version of graph.ss from mrlib as distributed with PLT Scheme v352 (module graph mzscheme diff --git a/punctiform-convergence/layout.scm b/punctiform-convergence/layout.scm new file mode 100644 index 0000000..cd6c046 --- /dev/null +++ b/punctiform-convergence/layout.scm @@ -0,0 +1,225 @@ +;; -*- mode: scheme -*- +;; +;; basic layout attmepts +;; +;; copyright (C) 2004 FoAM vzw +;; 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 + +;; requirements +;; - + +;; commentary +;; - wobble -> heirarchical rectangular spread +;; - shuffle -> randomise positions +;; - relax -> pseudo stabilisation using edge lengths +;; - shadowpi -> variation on circular parent-centric splay + +;; changes +;; 2006-09-11 +;; - scraped into coherence from various sources +;; 2006-11-12 +;; - mottled shadows, multiple beginings + + +(module layout mzscheme + (require (lib "misc.ss" "swindle") + (lib "class.ss") + (lib "list.ss") + (lib "math.ss") + "scritch.scm" + "snipets.scm" + "graph.scm") + + (provide wobble-tree + shuffle-tree + relax-tree + shadowpi-tree) + + + ;;;;;; ; ; ;; ;;;; ;; ; ;; + ;; + ;; traverse from a node, and s p r e a d + ;; + ;;;;; ; ; ; ; ; + + (define (wobble-tree node pb) + (let* ([parents (reverse (send node get-parents))] + [n (length parents)] + [x1 50] + [y1 30]) + (debug 2 "~% node.~a " node) + (debug 2 "~% parents.~a " parents) + (send pb move node x1 y1) + (do ((i 0 (+ i 1))) + ((= i n)) + (debug 2 ".~a." i) + (let* ([parent (list-ref parents i)] + [nx (box 0)] + [ny (box 0)] + [loco (send pb get-snip-location node nx ny)]) + (debug 2 ".[~a,~a]." (unbox nx) (unbox ny)) + (send pb move-to parent + (+ (* i x1) (/ (unbox nx) n)) + (+ y1 (unbox ny))) + (wobble-tree parent pb))))) + + + ;;;;;;;;;;; ;; ; ;; ; + ;; + ;; autoslonk + ;; + ;;;;; ; ;; ;; ; ; + + (define (shuffle-tree node pb x y) + (let ([parents (send node get-parents)] + [x1 200] + [y1 200]) + (debug 2 "shuffling: ~a ~%" parents) + (send pb move node (random x1) (random y1)) + (cond + ((= 1 (length parents)) + (shuffle-tree (car parents) pb (random x1) (random y1))) + ((< 1 (length parents)) + (for-each + (lambda (parent) + (shuffle-tree parent pb (random x1) (random y1))) + parents))))) + + + ;;;;; ;;;;;; ;; ; ;; ; + ;; + ;; energy stabilisation + ;; - single itteration only, call as reqd. + ;; - local epsilon & delta only + ;; + ;;;;; ; ;;; ; ; + + (define (relax-tree node pb x y) + (let ([parents (send node get-parents)]) + (debug 2 "minimising: ~a ~%" node) + ;; move given node + (send pb move node x y) + ;; stabilise distance between siblings + (if (not (empty? parents)) + (for-each + (lambda (parent) + (let ([siblings (send parent get-children)]) + (if(< 1 (length siblings)) + (send pb move node + (shuffle-x node (random-ref siblings)) + (shuffle-y node (random-ref siblings)))))) parents)) + ;; stabilise distance betwen node and parents + (cond + ((= 1 (length parents)) + (debug 1 "distance between ~a and ~a is ~a~%" + node (car parents) (distance node (car parents))) + (let ([parent (car parents)]) + (relax-tree parent pb + (shuffle-x node parent) + (shuffle-y node parent)))) + ((< 1 (length parents)) + (for-each + (lambda (parent) + (debug 1 "distance between ~a and ~a is ~a~%" node parent (distance node parent)) + (relax-tree parent pb + (shuffle-x node parent) + (shuffle-y node parent))) parents))))) + + (define (random-ref l) + (list-ref l (random (length l)))) + + (define (shuffle-x n1 n2) + (let ([x1 (snip-x n1)] + [x2 (snip-x n2)] + [epsilon 100] + [d 10]) + (if (> epsilon (distance n1 n2)) + (if (= x2 (max x1 x2)) ;; move outward + (random d) + (-ve (random d))) + (if (= x2 (max x1 x2)) ;; move inward + (-ve (random d)) + (random d))))) + + (define (shuffle-y n1 n2) + (let ([y1 (snip-y n1)] + [y2 (snip-y n2)] + [epsilon 100] + [d 10]) + (if (> epsilon (distance n1 n2)) + (if (= y2 (max y1 y2)) ;; move outward + (random d) + (-ve (random d))) + (if (= y2 (max y1 y2)) ;; move inward + (-ve (random d)) + (random d))))) + + (define (distance n1 n2) + (let ([x1 (snip-x n1)] + [x2 (snip-x n2)] + [y1 (snip-y n1)] + [y2 (snip-y n2)]) + (sqrt (+ (sq (abs (- x1 x2))) + (sq (abs (- y1 y2))))))) + + (define (sq n) + (* n n)) + + (define (-ve n) + (- 0 n)) + + ;;;;;;;;;;; ;; ; ;; ; + ;; + ;; circular parent centric layout, in the shade of twopi + ;; + ;; ref: arxiv:cs.HC/0606007 v1 -> "A parent-centered radial layout algorithm + ;; for interactive graph visualization and animation" by Andrew Pavlo, + ;; Christopher Homan & Jonathan Schull + ;; + ;; - since each node may have any number of parents, yet only a single child, + ;; thi sinterpretation of the algorithm is essentially the same, if 'children' + ;; is read as 'parents' + ;; + ;;;;; ; ;;; ; ; + + (define twopi (* 2 pi)) + + (define (shadowpi-tree node pb x y r) + (let* ([parents (reverse (send node get-parents))] + [n (length parents)] + [xi (snip-x node)] + [yi (snip-y node)] + (phi 0.85)) + + ;; distribute parents of given node evenly along a containment circle + ;; centered on the node. + + (dotimes (i n) + (let ((parent (list-ref parents i)) + (x1 (* r (cos (* (/ 1 pi) + (- (/ n 2) (+ 1 i)))))) + (y1 (* r (sin (* (/ 1 pi) + (- (/ n 2) (+ 1 i))))))) + (send pb move-to parent + (+ xi x1) (+ yi y1)) + + ;; draw circles around the node’s parents and evenly distribute their + ;; parents along containment arcs. + + (shadowpi-tree parent pb (+ xi x1) (+ yi y1) (* r phi)) + + ;; this proceeds recursively, so that successively distant descendants of + ;; the goven node are positioned on successively smaller containment arcs. + + )))) + + + ) ;; end of module diff --git a/punctiform-convergence/scritch.scm b/punctiform-convergence/scritch.scm new file mode 100644 index 0000000..66aeffe --- /dev/null +++ b/punctiform-convergence/scritch.scm @@ -0,0 +1,46 @@ +;; -*- mode: scheme -*- +;; +;; formless scratches in space +;; +;; copyright (C) 2004 FoAM vzw +;; 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 + +;; requirements +;; - space +;; - something to scratch with + +;; commentary +;; - scritch, scratch. .. + + +(module scritch mzscheme + + (require "graph.scm" + "snipets.scm" + (lib "misc.ss" "swindle") + (lib "mred.ss" "mred") + (lib "class.ss")) + + (provide (all-defined)) + + ;; quik'n dirty debuggin' + (define (debug level fstring . fargs) + (let ([debugging #t] ; toggle #t/#f + [debug-level 1]) ; higher is more info + (if (and debugging (>= debug-level level)) + (if (list? fargs) + (apply printf (cons fstring fargs)) + (printf fstring fargs))))) + + + +) ;; end of module + diff --git a/punctiform-convergence/snipets.scm b/punctiform-convergence/snipets.scm new file mode 100644 index 0000000..4fb7383 --- /dev/null +++ b/punctiform-convergence/snipets.scm @@ -0,0 +1,132 @@ +;; -*- mode: scheme -*- +;; +;; based on snip-lib from the embedded-gui collection + +(module snipets mzscheme + + (require + (lib "class.ss") + (lib "etc.ss") + (lib "mred.ss" "mred") + (lib "list.ss") + (lib "contract.ss")) + + ;; a snip + (define snip? (is-a?/c snip%)) + ;; 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))) + ;; the rest of the lists passed to a snip mapping function + (define rest-lists? (listof (listof any/c))) + ;; a class that contains a snip + (define editor? (is-a?/c editor<%>)) + + (provide/contract + (snip-width (snip? . -> . number?)) + (snip-height (snip? . -> . number?)) + (snip-x (snip? . -> . number?)) + (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))) + (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) + (let ([left (box 0)] + [right (box 0)] + [pasteboard (snip-parent snip)]) + (send pasteboard get-snip-location snip left (box 0) false) + (send pasteboard get-snip-location snip right (box 0) true) + (- (unbox right) (unbox left)))) + + ;; the height of a snip in the parent pasteboard + (define (snip-height snip) + (let ([top (box 0)] + [bottom (box 0)] + [pasteboard (snip-parent snip)]) + (send pasteboard get-snip-location snip (box 0) top false) + (send pasteboard get-snip-location snip (box 0) bottom true) + (- (unbox bottom) (unbox top)))) + + ;; the x-ccordinate of a snip in the parent pasteboard + (define (snip-x snip) + (let ([x (box 0)] + [pasteboard (snip-parent snip)]) + (send pasteboard get-snip-location snip x (box 0) false) + (unbox x))) + + ;; the y-ccordinate of a snip in the parent pasteboard + (define (snip-y snip) + (let ([y (box 0)] + [pasteboard (snip-parent snip)]) + (send pasteboard get-snip-location snip (box 0) y false) + (unbox y))) + +; ;; the minimum width of the snip +; (define (snip-min-width snip) +; (cond +; [(is-a? snip stretchable-snip<%>) +; (send snip get-aligned-min-width)] +; [else (snip-width snip)])) +; +; ;; the minimum height of the snip +; (define (snip-min-height snip) +; (cond +; [(is-a? snip stretchable-snip<%>) +; (send snip get-aligned-min-height)] +; [else (snip-height snip)])) +; + ;; the pasteboard that contains the snip + (define (snip-parent snip) + (let ([admin (send snip get-admin)]) + (if admin + (send admin get-editor) + false))) + + ;; the application of f on all snips from snip to the end in a foldl foldr mannor + (define (fold-snip f init-acc snip) + (let loop ([snip snip] + [acc init-acc]) + (cond + [(is-a? snip snip%) + (loop (send snip next) (f snip acc))] + [else acc]))) + + ;; applies the function to all the snips + (define (for-each-snip f first-snip . init-lists) + (let loop ([snip first-snip] + [lists init-lists]) + (cond + [(is-a? snip snip%) + (apply f (cons snip (map first lists))) + (loop (send snip next) + (map rest lists))] + [else (void)]))) + + ;; a list of f applied to each snip + (define (map-snip f first-snip . init-lists) + (let loop ([snip first-snip] + [lists init-lists]) + (cond + [(is-a? snip snip%) + (cons (apply f (cons snip (map first lists))) + (loop (send snip next) + (map rest lists)))] + [else empty]))) + +; ;; true if the snip can be resized in the x dimention +; (define (stretchable-width? snip) +; (cond +; [(is-a? snip stretchable-snip<%>) +; (send snip stretchable-width)] +; [else false])) +; +; ;; true if the snip can be resized in the y dimention +; (define (stretchable-height? snip) +; (cond +; [(is-a? snip stretchable-snip<%>) +; (send snip stretchable-height)] +; [else false])) + ) diff --git a/qfwfq.scm b/qfwfq.scm index f594ed1..5c9b1b2 100644 --- a/qfwfq.scm +++ b/qfwfq.scm @@ -6,7 +6,7 @@ ;; 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 +;; 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 @@ -29,345 +29,39 @@ ;; changes ;; 2006-09-11 ;; - scraped into coherence from various sources -;; 2006-09-14 -;; - fixed tree-colouring and traversal +;; 2006-11-10 +;; - scattered energy stabilisation attempts +;; - scattered modules and files + (module qfwfq mzscheme - (require "graph.scm" ;modified from (lib "graph.ss" "mrlib") - (lib "class.ss") - (lib "list.ss") - (lib "string.ss") - (lib "math.ss") - (lib "mred.ss" "mred") - (lib "contract.ss")) + (require "punctiform-convergence/graph.scm" + "punctiform-convergence/eddies.scm" + "punctiform-convergence/snipets.scm" + "punctiform-convergence/layout.scm" + "punctiform-convergence/scritch.scm") (provide graph-pasteboard% node-snip% output-snip% - ;recursive-snip% + recursive-snip% insert-nodes + add-links + set-node-text get-node-text set-node-value get-node-value draw-parse-tree colour-tree + wobble-tree + relax-tree eval-tree + shadowpi-tree + tree->sexp to-string debug) - - ;; quik'n dirty debuggin' - (define (debug level fstring . fargs) - (let ([debugging #t] ; toggle #t/#f - [debug-level 1]) ; higher is more info - (if (and debugging (>= debug-level level)) - (if (list? fargs) - (apply printf (cons fstring fargs)) - (printf fstring fargs))))) - - ;;;;;;;;; ;; ;; ;; - ;; - ;; graphs, graphing and graphics - ;; - ;;;;;; ; ;;; ; ;;; ; ; ; - - (define graph-pasteboard% - (class (graph-pasteboard-mixin pasteboard%) - (define/augment (on-delete snip) - ;; remove from parent list of children - (for-each (lambda (child) - (send child remove-parent snip)) - (send snip get-children)) - ;; remove from child list of parents - (for-each (lambda (parent) - (send parent remove-child snip)) - (send snip get-parents))) - (super-new))) - - ;; nodes can contain any valid expression, which is stored as text [for now] - ;; able to be read by read-string. the field 'value' may contain a precomputed - ;; value of the nodes subtree, and the 'dirty' flag indicates wheter the subtree - ;; (ie. any of its children) have changed. - - (define node-snip% - (class (graph-snip-mixin editor-snip%) - (init-field (value ())) - (init-field (dirty #f)) - (inherit-field parent-links) - (define/public (set-value v) - (set! value v)) - (define/public (besmirch) - (debug 2 "smirched: ~a ~%" this) - (set! dirty #t) - (map (lambda (x) (send x besmirch)) - (send this get-children))) - (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) - (if (eqv? (send event get-key-code) #\return) - (begin (send event set-key-code #\nul) - (besmirch)) - (set! dirty #t)) - (super on-char dc x y editorx editory event)) - (define/override (own-caret own-it?) - (if own-it? - (debug 3 "node: ~a got keybrd focus~%" this) - (if dirty - (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))) - - ;; of suns, and of planets, and fields of wheat... - (define (make-node-snip) - (new node-snip% - (with-border? #t) - (left-margin 3) - (top-margin 3) - (right-margin 4) - (bottom-margin 2) - (left-inset 1) - (top-inset 1) - (right-inset 1) - (bottom-inset 1))) - - - ;; .. 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% - (define/override (besmirch) - (send (send this get-editor) erase) - (eval-tree this)) - (super-new))) - - ;; a recursive-snip can contain other node-snips - ;(define recursive-snip-mixin - ; (mixin () (graph-snip<%>))) - - ;(define recursive-snip% - ; (class (recursive-snip-mixin editor-snip%) - ; ;; details.. - ; (super-new))) - - - ;; node/graph utils,. - (define (insert-nodes p . nodes) - (for-each (lambda (x) (send p insert x)) nodes)) - - ;; insert non specific data into a node's text-field% - (define (set-node-text node data) - (send (send node get-editor) - insert (to-string data))) - - ;; get the text from a node - (define (get-node-text node) - (send (send node get-editor) get-text)) - - ;; partial [e]valuation - (define (set-node-value node value) - (send node set-value value)) - - (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<%> - - ;; function links -> active/inactive - (define pen1 (send the-pen-list find-or-create-pen "Red" 1 'solid)) - (define brush1 (send the-brush-list find-or-create-brush "orange" 'solid)) - (define pen2 (send the-pen-list find-or-create-pen "DarkSeaGreen" 1 'solid)) - (define brush2 (send the-brush-list find-or-create-brush "Gold" 'solid)) - ;; data links -> active/inactive - (define pen3 (send the-pen-list find-or-create-pen "orange" 1 'solid)) - (define brush3 (send the-brush-list find-or-create-brush "yellow" 'solid)) - (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)) - - ;;;;;;;;; ; ; ;; ; - ;; - ;; re-traversal - ;; - ;;;;;;;;; ;; ;; - - ;; build a tree from a given list, starting from the node% parent, - ;; drawing to the graph-pasteboard% pb .. . - (define (draw-parse-tree tree x y parent pb) - (if (list? tree) - (begin - (let ((size 5) - (root (car tree)) - (node (make-node-snip))) - (debug 2 "root: ~a ~%" root) - (draw-parse-tree root x y parent pb) - ;; function node - (send pb insert node) - (add-links node parent pen1 pen2 brush1 brush2) - (send (send node get-editor) insert (to-string root)) - ;; subtrees, or args - (for-each - (lambda (child) - (if (list? child) - (draw-parse-tree child x y node pb) - (let ((sibling (make-node-snip))) - (send pb insert sibling) - (add-links sibling node pen3 pen4 brush3 brush4) - (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 - ;; note that this uses a global so is not threadsafe - (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 - (define (wobble-tree node pb) - (let* ([parents (reverse (send node get-parents))] - [n (length parents)] - [x1 50] - [y1 30]) - (debug 2 "~% node.~a " node) - (debug 2 "~% parents.~a " parents) - (send pb move node x1 y1) - (do ((i 0 (+ i 1))) - ((= i n)) - (debug 2 ".~a." i) - (let* ([parent (list-ref parents i)] - [nx (box 0)] - [ny (box 0)] - [loco (send pb get-snip-location node nx ny)]) - (debug 2 ".[~a,~a]." (unbox nx) (unbox ny)) - (send pb move-to parent - (+ (* i x1) (/ (unbox nx) n)) - (+ y1 (unbox ny))) - (wobble-tree parent pb))))) - - ;; autoslonk - (define (shuffle-tree node pb x y) - (let ([parents (send node get-parents)] - [x1 200] - [y1 200]) - (debug 2 "grinding: ~a ~%" parents) - (send pb move node (random x1) (random y1)) - (cond - ((= 1 (length parents)) - (shuffle-tree (car parents) pb (random x1) (random y1))) - ((< 1 (length parents)) - (for-each - (lambda (parent) - (shuffle-tree parent pb (random x1) (random y1))) - parents))))) - - ;; eval [sub]graph from a node. .. - ;; absolutely no chekcing or error handling yet. - (define (eval-tree node) - (set-node-text node - (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 - ;; children, it is translated into separate expressions) - (define (tree->sexp node) - (let ([parents (send node get-parents)] - [data (get-node-text node)] - [out ()]) - (if (not (null? parents)) - (set! out (cons (read-from-string data) - (reverse (map tree->sexp parents)))) - (set! out (read-from-string data))) - (debug 1 "tree->sexp: ~a ~%" out) - out)) - + ) ;; end of module diff --git a/xaueneuax.scm b/xaueneuax.scm index 98a1b39..09b4aaa 100644 --- a/xaueneuax.scm +++ b/xaueneuax.scm @@ -38,8 +38,7 @@ ;; 2006-09-11 ;; - scraped into coherence from various sources -(require "graph.scm" - "qfwfq.scm") +(require "qfwfq.scm") (define xauen-pasteboard% (class graph-pasteboard% @@ -82,7 +81,7 @@ ;; textmode input,. . (define input (new text-field% [label "inslkon >"] [parent f] [callback parse-text-input] - [init-value "(* 3 4 5 (* 7 8 9))"])) + [init-value "(* 3 4 5 (* 7 (+ 1 1 1) 9))"])) ;; keyboard overloading.., (define (temp-keymap event) @@ -95,30 +94,36 @@ (debug 3 "key[de]maping->key: ~a ~%" key) (debug 1 "selected-snip: ~a ~%" selected-snip) (if (send event get-control-down) - (case key - [(#\n) ;; C-n fr 'new' - (debug 1 "add: ~a" key) - (let ([node (make-node-snip)]) - (send target insert node) - (if selected-snip - (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-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) ;; 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)] - ))))) + (case key + [(#\n) ;; C-n fr 'new' + (debug 1 "add: ~a" key) + (let ([node (make-node-snip)]) + (send target insert node) + (if selected-snip + (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-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) ;; 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)] + [(#\x) ;; C-x re.lapse + (shadowpi-tree selected-snip p 0 0 120)] + [(#\=) ;; C-= zoom->out + (send p zoom 1.1)] + [(#\-) ;; C-- zoom->in + (send p zoom 0.9)] + ))))) ;; basic nodewrenching (define n1 (new output-snip%)) @@ -126,11 +131,10 @@ (send p move-to n1 15 15) ;; test a recursive node -;(define r1 (new recursive-snip%)) -;(send p insert r1) -;(define n2 (new output-snip%)) -;(send r1 insert n1) - +;; (define r1 (new recursive-snip%)) +;; (send p insert r1) +;; (define n2 (new output-snip%)) +;; (send r1 insert n1) (send f show #t)