diff --git a/qfwfq.scm b/qfwfq.scm index f441d9e..f594ed1 100644 --- a/qfwfq.scm +++ b/qfwfq.scm @@ -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)] diff --git a/xaueneuax.scm b/xaueneuax.scm index dd1b86a..98a1b39 100644 --- a/xaueneuax.scm +++ b/xaueneuax.scm @@ -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)