This commit is contained in:
nik gaffney 2006-10-30 10:11:19 +01:00
parent 91d577dad5
commit df866822ab
2 changed files with 46 additions and 10 deletions

View file

@ -21,9 +21,9 @@
;; 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
;; to a sexp (or collection of sexps), so some things should be
;; reasonably common between different (although admittedly graph
;; based) VPLs, for example tree traversal, node placement and layout.
;; based) VPLs, for example graph traversal, node placement and layout.
;; it is not intended to be complete, exhaustive, or stable.
;; changes
@ -43,7 +43,8 @@
(provide graph-pasteboard%
node-snip%
output-snip%
output-snip%
;recursive-snip%
insert-nodes
set-node-text
get-node-text
@ -95,8 +96,6 @@
(init-field (value ()))
(init-field (dirty #f))
(inherit-field parent-links)
;(inherit link)
(define/public (set-value v)
(set! value v))
(define/public (besmirch)
@ -125,6 +124,20 @@
(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
@ -140,6 +153,16 @@
(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))
@ -198,7 +221,7 @@
(begin
(let ((size 5)
(root (car tree))
(node (new node-snip%)))
(node (make-node-snip)))
(debug 2 "root: ~a ~%" root)
(draw-parse-tree root x y parent pb)
;; function node
@ -210,7 +233,7 @@
(lambda (child)
(if (list? child)
(draw-parse-tree child x y node pb)
(let ((sibling (new node-snip%)))
(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)))))
@ -263,6 +286,7 @@
(set! result link))) links) result))
;; relabel
;; note that this uses a global so is not threadsafe
(define *travail* 0)
(define (re-label! link)
@ -288,7 +312,7 @@
;; basic layout attmepts
;; traverse from a node, and s p r e a d
;; 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)]

View file

@ -52,6 +52,12 @@
;; setup frame and windows..
(define f (new frame% [label " } x a u e n e u a x { "]))
(define mb (instantiate menu-bar% (f)))
(define edit-menu (instantiate menu% ("Edit" mb)))
(define font-menu (instantiate menu% ("Font" mb)))
(append-editor-operation-menu-items edit-menu)
(append-editor-font-menu-items font-menu)
(define p (new xauen-pasteboard%))
(define ec (new editor-canvas% (parent f)))
@ -92,7 +98,7 @@
(case key
[(#\n) ;; C-n fr 'new'
(debug 1 "add: ~a" key)
(let ([node (new node-snip%)])
(let ([node (make-node-snip)])
(send target insert node)
(if selected-snip
(begin (add-links node selected-snip)
@ -117,9 +123,15 @@
;; basic nodewrenching
(define n1 (new output-snip%))
(send p insert n1)
(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)
(send f show #t)