1 ! Copyright (C) 2007, 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors namespaces make sequences kernel math arrays io
4 ui.gadgets generic combinators ;
7 TUPLE: node value children ;
9 : traverse-step ( path gadget -- path' gadget' )
10 [ unclip ] dip children>> ?nth ;
12 : make-node ( quot -- ) { } make node boa , ; inline
14 : traverse-to-path ( topath gadget -- )
22 [ children>> swap first head-slice % ]
23 [ tuck traverse-step traverse-to-path ]
29 : traverse-from-path ( frompath gadget -- )
37 [ traverse-step traverse-from-path ]
38 [ tuck children>> swap first 1+ tail-slice % ] 2bi
43 : traverse-pre ( frompath gadget -- )
44 traverse-step traverse-from-path ;
46 : (traverse-middle) ( frompath topath gadget -- )
47 [ first 1+ ] [ first ] [ children>> ] tri* <slice> % ;
49 : traverse-post ( topath gadget -- )
50 traverse-step traverse-to-path ;
52 : traverse-middle ( frompath topath gadget -- )
55 3dup (traverse-middle)
60 DEFER: (gadget-subtree)
62 : traverse-child ( frompath topath gadget -- )
64 [ [ rest-slice ] 2dip traverse-step (gadget-subtree) ]
67 : (gadget-subtree) ( frompath topath gadget -- )
69 { [ dup not ] [ 3drop ] }
70 { [ pick empty? pick empty? and ] [ 2nip , ] }
71 { [ pick empty? ] [ traverse-to-path drop ] }
72 { [ over empty? ] [ nip traverse-from-path ] }
73 { [ pick first pick first = ] [ traverse-child ] }
77 : gadget-subtree ( frompath topath gadget -- seq )
78 [ (gadget-subtree) ] { } make ;
81 dup children>> swap value>> gadget-seq-text ;
83 : gadget-text-range ( frompath topath gadget -- str )
84 gadget-subtree gadget-text ;
86 : gadget-at-path ( parent path -- gadget )
87 [ swap nth-gadget ] each ;