radio
This commit is contained in:
parent
91d577dad5
commit
df866822ab
2 changed files with 46 additions and 10 deletions
40
qfwfq.scm
40
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)]
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
||||
|
|
Loading…
Reference in a new issue