1 ! Copyright (C) 2007 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: namespaces sequences kernel math arrays io ui.gadgets
7 TUPLE: node value children ;
9 : traverse-step ( path gadget -- path' gadget' )
10 >r unclip r> gadget-children ?nth ;
12 : make-node ( quot -- ) { } make node construct-boa , ; inline
14 : traverse-to-path ( topath gadget -- )
22 2dup gadget-children swap first head-slice %
23 tuck traverse-step traverse-to-path
28 : traverse-from-path ( frompath gadget -- )
36 2dup traverse-step traverse-from-path
37 tuck gadget-children swap first 1+ tail-slice %
42 : traverse-pre ( frompath gadget -- )
43 traverse-step traverse-from-path ;
45 : (traverse-middle) ( frompath topath gadget -- )
46 >r >r first 1+ r> first r> gadget-children <slice> % ;
48 : traverse-post ( topath gadget -- )
49 traverse-step traverse-to-path ;
51 : traverse-middle ( frompath topath gadget -- )
54 3dup (traverse-middle)
59 DEFER: (gadget-subtree)
61 : traverse-child ( frompath topath gadget -- )
63 >r >r 1 tail-slice r> r> traverse-step (gadget-subtree)
66 : (gadget-subtree) ( frompath topath gadget -- )
68 { [ dup not ] [ 3drop ] }
69 { [ pick empty? pick empty? and ] [ 2nip , ] }
70 { [ pick empty? ] [ rot drop traverse-to-path ] }
71 { [ over empty? ] [ nip traverse-from-path ] }
72 { [ pick first pick first = ] [ traverse-child ] }
73 { [ t ] [ traverse-middle ] }
76 : gadget-subtree ( frompath topath gadget -- seq )
77 [ (gadget-subtree) ] { } make ;
80 dup node-children swap node-value gadget-seq-text ;
82 : gadget-text-range ( frompath topath gadget -- str )
83 gadget-subtree gadget-text ;
85 : gadget-at-path ( parent path -- gadget )
86 [ swap nth-gadget ] each ;