zzkt/qfwfq
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Z'zus cupboard

Browse source 
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?
This commit is contained in:
nik gaffney 2006-11-12 23:02:23 +01:00
parent df866822ab
commit be217c70fb
7 changed files with 797 additions and 357 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

338
punctiform-convergence/eddies.scm Normal file
View file

@ -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 <nik@fo.am>
;; 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

3
graph.scm → punctiform-convergence/graph.scm
View file

@ -1,4 +1,5 @@
;; -*- mode: scheme -*-
;;
;; modified version of graph.ss from mrlib as distributed with PLT Scheme v352 ;; modified version of graph.ss from mrlib as distributed with PLT Scheme v352
(module graph mzscheme (module graph mzscheme

225
punctiform-convergence/layout.scm Normal file
View file

@ -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 <nik@fo.am>
;; 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

46
punctiform-convergence/scritch.scm Normal file
View file

@ -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 <nik@fo.am>
;; 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

132
punctiform-convergence/snipets.scm Normal file
View file

@ -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]))
)

340
qfwfq.scm
View file

@ -6,7 +6,7 @@
;; You are granted the rights to distribute and use this software ;; You are granted the rights to distribute and use this software
;; under the terms of the GNU Lesser General Public License as ;; under the terms of the GNU Lesser General Public License as
;; published by the Free Software Foundation; either version 2.1 of ;; 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 ;; distributed with this code (see: LICENCE) and available online
;; at http://www.gnu.org/copyleft/lesser.html ;; at http://www.gnu.org/copyleft/lesser.html
@ -29,345 +29,39 @@
;; changes ;; changes
;; 2006-09-11 ;; 2006-09-11
;; - scraped into coherence from various sources ;; - scraped into coherence from various sources
;; 2006-09-14 ;; 2006-11-10
;; - fixed tree-colouring and traversal ;; - scattered energy stabilisation attempts
;; - scattered modules and files
(module qfwfq mzscheme (module qfwfq mzscheme
(require "graph.scm" ;modified from (lib "graph.ss" "mrlib") (require "punctiform-convergence/graph.scm"
(lib "class.ss") "punctiform-convergence/eddies.scm"
(lib "list.ss") "punctiform-convergence/snipets.scm"
(lib "string.ss") "punctiform-convergence/layout.scm"
(lib "math.ss") "punctiform-convergence/scritch.scm")
(lib "mred.ss" "mred")
(lib "contract.ss"))
(provide graph-pasteboard% (provide graph-pasteboard%
node-snip% node-snip%
output-snip% output-snip%
;recursive-snip% recursive-snip%
insert-nodes insert-nodes
add-links
set-node-text set-node-text
get-node-text get-node-text
set-node-value set-node-value
get-node-value get-node-value
draw-parse-tree draw-parse-tree
colour-tree colour-tree
wobble-tree wobble-tree
relax-tree
eval-tree eval-tree
shadowpi-tree
tree->sexp tree->sexp
to-string to-string
debug) 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 ) ;; end of module

68
xaueneuax.scm
View file

@ -38,8 +38,7 @@
;; 2006-09-11 ;; 2006-09-11
;; - scraped into coherence from various sources ;; - scraped into coherence from various sources
(require "graph.scm" (require "qfwfq.scm")
"qfwfq.scm")
(define xauen-pasteboard% (define xauen-pasteboard%
(class graph-pasteboard% (class graph-pasteboard%
@ -82,7 +81,7 @@
;; textmode input,. . ;; textmode input,. .
(define input (new text-field% (define input (new text-field%
[label "inslkon >"] [parent f] [callback parse-text-input] [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.., ;; keyboard overloading..,
(define (temp-keymap event) (define (temp-keymap event)
@ -95,30 +94,36 @@
(debug 3 "key[de]maping->key: ~a ~%" key) (debug 3 "key[de]maping->key: ~a ~%" key)
(debug 1 "selected-snip: ~a ~%" selected-snip) (debug 1 "selected-snip: ~a ~%" selected-snip)
(if (send event get-control-down) (if (send event get-control-down)
(case key (case key
[(#\n) ;; C-n fr 'new' [(#\n) ;; C-n fr 'new'
(debug 1 "add: ~a" key) (debug 1 "add: ~a" key)
(let ([node (make-node-snip)]) (let ([node (make-node-snip)])
(send target insert node) (send target insert node)
(if selected-snip (if selected-snip
(begin (add-links node selected-snip) (begin (add-links node selected-snip)
;; re.colour the tree, first [grand]child should do... ;; re.colour the tree, first [grand]child should do...
(colour-tree (car (send selected-snip get-children)) p))) (colour-tree (car (send selected-snip get-children)) p)))
(send target move-to node x y) (send target move-to node x y)
)] )]
[(#\c) ;; C-c fr 'connect' [(#\c) ;; C-c fr 'connect'
(let ([next (send target find-next-selected-snip selected-snip)]) (let ([next (send target find-next-selected-snip selected-snip)])
(debug 1 "next-snip: ~a ~%" next) (debug 1 "next-snip: ~a ~%" next)
(add-links selected-snip next))] (add-links selected-snip next))]
[(#\d) ;; C-d fr 'disconnect' [(#\d) ;; C-d fr 'disconnect'
(let ([next (send target find-next-selected-snip selected-snip)]) (let ([next (send target find-next-selected-snip selected-snip)])
(send selected-snip remove-child next) (send selected-snip remove-child next)
(send selected-snip remove-parent next) (send selected-snip remove-parent next)
(send next remove-parent selected-snip) (send next remove-parent selected-snip)
(send next remove-child selected-snip))] (send next remove-child selected-snip))]
[(#\z) ;; C-z re.colour [(#\z) ;; C-z re.colour
(colour-tree selected-snip p)] (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 ;; basic nodewrenching
(define n1 (new output-snip%)) (define n1 (new output-snip%))
@ -126,11 +131,10 @@
(send p move-to n1 15 15) (send p move-to n1 15 15)
;; test a recursive node ;; 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) (send f show #t)