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

seed

Browse source
This commit is contained in:
nik gaffney 2006-09-11 19:00:50 +02:00
commit d105ce2b3b
2 changed files with 382 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

262
qfwfq.scm Normal file
View file

@ -0,0 +1,262 @@
;; -*- 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 Lisp Lesser GNU Public License, known
;; as the LLGPL. The LLGPL consists of a preamble and the LGPL.
;; Where these conflict, the preamble takes precedence. The LLGPL
;; is available online at http://opensource.franz.com/preamble.html
;; and is distributed with this code (see: LICENCE and LGPL files)
;; 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 colelction of sexps), so some things should be
;; reasonably common between different (although admittedly graph
;; based) VPLs, for example tree 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
(module qfwfq mzscheme
(require (lib "graph.ss" "mrlib")
(lib "class.ss")
(lib "list.ss")
(lib "string.ss")
(lib "math.ss")
(lib "mred.ss" "mred")
(lib "contract.ss"))
(provide graph-pasteboard%
node-snip%
output-snip%
insert-nodes
set-node-text
get-node-text
set-node-value
get-node-value
draw-parse-tree
wobble-tree
eval-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))
(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))
(public set-value besmirch clean)
(define (set-value v)
(set! value v))
(define (besmirch)
(debug 2 "smirched: ~a ~%" this)
(set! dirty #t)
(map (lambda (x) (send x besmirch))
(send this get-children)))
(define (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 1 "node: ~a got keybrd focus~%" this)
(if dirty
(begin (debug 1 "node: ~a lost keybrd focus~%" this)
(send this besmirch)
(send this clean))))
(super own-caret own-it?))
(super-new)))
;; 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)))
;; 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))
;; 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))
; convert given object to string
(define (to-string x)
(cond ((string? x) x)
((char? x) (list->string (list x)))
((number? x) (number->string x))
((symbol? x) (symbol->string x))
((list? x) (apply string-append (map to-string x)))
(else (error "don't know how to convert to string: " x))))
;;;;;;;;; ; ; ;; ;
;;
;; re-traversal
;;
;;;;;;;;; ;; ;;
;; 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 (new 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 (new 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))))))
;; 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

120
xaueneuax.scm Normal file
View file

@ -0,0 +1,120 @@
;; -*- mode: scheme -*-
;;
;; x a u e n e u a x - nqdataflow
;;
;; copyright (C) 2004 FoAM vzw
;; You are granted the rights to distribute and use this software
;; under the terms of the Lisp Lesser GNU Public License, known
;; as the LLGPL. The LLGPL consists of a preamble and the LGPL.
;; Where these conflict, the preamble takes precedence. The LLGPL
;; is available online at http://opensource.franz.com/preamble.html
;; and is distributed with this code (see: LICENCE and LGPL files)
;; authors
;; - nik gaffney <nik@fo.am>
;; requirements
;; - uses qfwfq for layout and slipulation
;; commentary
;; a simple dataflow like visual wrapper to the underlying scheme,
;; using an evaluation model which is not quite dataflow, yet not
;; quite scheme -> nqdataflow
;;
;; keyboard controls
;; n - adds new node, connected to a selected node
;; c - conencts 2 selected nodes
;; d - disconnects selected node
;; delete - deletes node
;; enter - evaluates current node
;; to do
;; - deal with evaluation order display
;; - check directions of node connection with 'c'
;; - multiple connections -> clarify
;; - deal with circularity
;; changes
;; 2006-09-11
;; - scraped into coherence from various sources
(require (lib "graph.ss" "mrlib")
"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))
(super-new)))
;; setup frame and windows..
(define f (new frame% [label " } x a u e n e u a x { "]))
(define p (new xauen-pasteboard%))
(define ec (new editor-canvas% (parent f)))
(send ec min-client-width 450)
(send ec min-client-height 450)
(send ec set-editor p)
(define dc (send ec get-dc))
;; text input calllback - spit and polish
;; beware hardcoded node & pasteboard & lack of error checking
(define (parse-text-input tf event)
(if (eqv? (send event get-event-type) 'text-field-enter)
(let ([input (read-from-string (send tf get-value))]
[node n1]
[pasteboard p])
(draw-parse-tree input 1 1 node pasteboard)
(eval-tree node)
;(set-node-text node (eval input))
(wobble-tree n1 p))))
;; textmode input,. .
(define input (new text-field%
[label "inslkon >"] [parent f] [callback parse-text-input]
[init-value "(* 3 4 5 (* 7 8 9))"]))
;; keyboard overloading..,
(define (temp-keymap event)
(let* ([target p] ;; should get dynamically pasteboard..,
[key (send event get-key-code)]
[selected-snip (send target find-next-selected-snip #f)]
[Gx (send event get-x)]
[Gy (send event get-y)])
(let-values ([(x y) (send target editor-location-to-dc-location Gx Gy)])
(debug 1 "key[de]maping->key: ~a ~%" key)
(debug 1 "selected-snip: ~a ~%" selected-snip)
(case key
[(#\n) ;; n fr 'new'
(debug 1 "add: ~a" key)
(let ([node (new node-snip%)])
(send target insert node)
(if selected-snip
(add-links node selected-snip))
;;(send target move-to node x y)
)]
[(#\c) ;; c fr 'connect'
(let ([next (send target find-next-selected-snip selected-snip)])
(debug 1 "next-snip: ~a ~%" next)
(add-links selected-snip next))]
[(#\d) ;; d fr 'disconnect'
(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))]
))))
;; basic nodewrenching
(define n1 (new output-snip%))
(send p insert n1)
(send p move-to n1 15 15)
(send f show #t)