374 lines
13 KiB
Scheme
374 lines
13 KiB
Scheme
;; -*- 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
|
|
|
|
(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"))
|
|
|
|
(provide graph-pasteboard%
|
|
node-snip%
|
|
output-snip%
|
|
;recursive-snip%
|
|
insert-nodes
|
|
set-node-text
|
|
get-node-text
|
|
set-node-value
|
|
get-node-value
|
|
draw-parse-tree
|
|
colour-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))
|
|
(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
|