1 ! Copyright (C) 2007, 2009 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 fry sets ;
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 % ]
24 [ traverse-step traverse-to-path ]
30 : traverse-from-path ( frompath gadget -- )
38 [ traverse-step traverse-from-path ]
40 [ children>> swap first 1 + tail-slice % ]
46 : traverse-pre ( frompath gadget -- )
47 traverse-step traverse-from-path ;
49 : (traverse-middle) ( frompath topath gadget -- )
50 [ first 1 + ] [ first ] [ children>> ] tri* <slice> % ;
52 : traverse-post ( topath gadget -- )
53 traverse-step traverse-to-path ;
55 : traverse-middle ( frompath topath gadget -- )
58 3dup (traverse-middle)
63 DEFER: (gadget-subtree)
65 : traverse-child ( frompath topath gadget -- )
67 [ [ rest-slice ] 2dip traverse-step (gadget-subtree) ]
70 : (gadget-subtree) ( frompath topath gadget -- )
72 { [ dup not ] [ 3drop ] }
73 { [ pick empty? pick empty? and ] [ 2nip , ] }
74 { [ pick empty? ] [ traverse-to-path drop ] }
75 { [ over empty? ] [ nip traverse-from-path ] }
76 { [ pick first pick first = ] [ traverse-child ] }
80 : gadget-subtree ( frompath topath gadget -- seq )
81 [ (gadget-subtree) ] { } make ;
84 [ children>> ] [ value>> ] bi gadget-seq-text ;
86 : gadget-text-range ( frompath topath gadget -- str )
87 gadget-subtree gadget-text ;
89 : gadget-at-path ( parent path -- gadget )
90 [ swap nth-gadget ] each ;
92 GENERIC# leaves* 1 ( tree set -- )
94 M: node leaves* [ children>> ] dip leaves* ;
96 M: array leaves* '[ _ leaves* ] each ;
98 M: gadget leaves* adjoin ;
100 : leaves ( tree -- set ) HS{ } clone [ leaves* ] keep ;