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

lacking names

Browse source 
first reductions, simplifying of some leaves into anonymous functions.
This commit is contained in:
nik gaffney 2007-07-09 15:44:21 +02:00
parent a9694c42eb
commit e58bfc9877
7 changed files with 169 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
README
View file

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

91
punctiform-convergence/eddies.scm
View file

@ -155,9 +155,10 @@
;; 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%)
;; details..
@ -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)]
@ -333,6 +343,79 @@
(set! out (read-from-string data)))
(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

45
punctiform-convergence/graph.scm
View file

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

36
punctiform-convergence/layout.scm
View file

@ -13,16 +13,19 @@
;; authors
;; - nik gaffney <nik@fo.am>
;; - tim boykett <tim@timesup.org>
;; - dave griffiths <dave@pawfal.org>
;; requirements
;; - qfwfq and descendants
;; commentary
;; - wobble -> hierarchical rectangular spread
;; - shuffle -> randomise positions
;; - 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))
0
(parent-loop (cdr parents) (+ n 1) angle-per-parent)))
(if (not (null? (cdr parents)))
(parent-loop (cdr parents)
(+ 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))
(* (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
((null? parents)
0)
(else
(let ([angle-per-parent (/ (- angle-end angle-start) (length parents))])
(parent-loop parents 0 angle-per-parent))))))
(if (not (null? parents))
(let ([angle-per-parent (/ (- angle-end angle-start)
(length parents))])
(parent-loop parents 0 angle-per-parent)))))
@ -225,7 +227,7 @@
;; Christopher Homan & Jonathan Schull
;;
;;;;; ; ;;; ; ;
(define twopi (* 2 pi))
(define (shadowpi-tree node pb theta r)

6
punctiform-convergence/snipets.scm
View file

@ -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)))
(map-snip any/c #;((snip-visitor? linked-snip?) rest-lists? . ->* . ((listof 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)

7
qfwfq.scm
View file

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

16
xaueneuax.scm
View file

@ -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%))
;; (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)