1 USING: accessors arrays assocs combinators fry kernel locals
2 math math.combinatorics ranges namespaces random sequences
3 sequences.product tools.test trees trees.private ;
6 : test-tree ( -- tree )
12 { 7 "replaced seven" }
15 ! test set-at, at, at*
16 { "seven" } [ <tree> "seven" 7 pick set-at 7 of ] unit-test
17 { "seven" t } [ <tree> "seven" 7 pick set-at 7 ?of ] unit-test
18 { 8 f } [ <tree> "seven" 7 pick set-at 8 ?of ] unit-test
19 { "seven" } [ <tree> "seven" 7 pick set-at 7 of ] unit-test
20 { "replacement" } [ <tree> "seven" 7 pick set-at "replacement" 7 pick set-at 7 of ] unit-test
21 { "replaced four" } [ test-tree 4 of ] unit-test
22 { "nine" } [ test-tree 9 of ] unit-test
25 { f } [ test-tree 9 over delete-at 9 of ] unit-test
26 { "replaced seven" } [ test-tree 9 over delete-at 7 of ] unit-test
27 { "replaced four" } [ test-tree 9 over delete-at 4 of ] unit-test
28 { "nine" "replaced four" } [ test-tree 7 over delete-at 9 over at 4 rot at ] unit-test
29 { "nine" } [ test-tree 7 over delete-at 4 over delete-at 9 of ] unit-test
31 ! test that cloning doesn't reshape the tree
42 ! test that converting from any tree to a basic tree doesn't reshape
55 { 0 } [ TREE{ } height ] unit-test
70 { 3 } [ test-tree assoc-size ] unit-test
71 { 2 } [ test-tree 9 over delete-at assoc-size ] unit-test
73 TUPLE: constant-random pattern ;
74 M: constant-random random-32* pattern>> ;
80 { left T{ node { key 0 } { value 0 } } }
81 { right T{ node { key 3 } { value 3 } } }
85 TREE{ { 1 1 } { 3 3 } { 2 2 } { 0 0 } } clone
86 T{ constant-random f 0xffffffff } random-generator [
91 CONSTANT: test-tree2 TREE{
105 : test-tree2-lower-key ( key -- key' )
106 dup 2 mod 2 swap - - ;
107 : test-tree2-higher-key ( key -- key' )
108 dup 2 mod 2 swap - + ;
109 : test-tree2-floor-key ( key -- key' )
111 : test-tree2-ceiling-key ( key -- key' )
114 { f } [ 99 test-tree2 lower-node ] unit-test
115 { f } [ 100 test-tree2 lower-node ] unit-test
117 [ test-tree2-lower-key 1array ] keep [ test-tree2 lower-node key>> ] curry unit-test
121 [ test-tree2-higher-key 1array ] keep [ test-tree2 higher-node key>> ] curry unit-test
123 { f } [ 120 test-tree2 higher-node ] unit-test
124 { f } [ 121 test-tree2 higher-node ] unit-test
126 { f } [ 99 test-tree2 floor-node ] unit-test
128 [ test-tree2-floor-key 1array ] keep [ test-tree2 floor-node key>> ] curry unit-test
132 [ test-tree2-ceiling-key 1array ] keep [ test-tree2 ceiling-node key>> ] curry unit-test
134 { f } [ 121 test-tree2 ceiling-node ] unit-test
136 { 100 } [ test-tree2 first-node key>> ] unit-test
137 { 120 } [ test-tree2 last-node key>> ] unit-test
139 { f } [ 99 test-tree2 lower-entry ] unit-test
140 { f } [ 99 test-tree2 lower-key ] unit-test
141 { f } [ 121 test-tree2 higher-entry ] unit-test
142 { f } [ 121 test-tree2 higher-key ] unit-test
143 { f } [ 99 test-tree2 floor-entry ] unit-test
144 { f } [ 99 test-tree2 floor-key ] unit-test
145 { f } [ 121 test-tree2 ceiling-entry ] unit-test
146 { f } [ 121 test-tree2 ceiling-key ] unit-test
147 { { 108 108 } } [ 110 test-tree2 lower-entry ] unit-test
148 { 108 } [ 110 test-tree2 lower-key ] unit-test
149 { { 112 112 } } [ 110 test-tree2 higher-entry ] unit-test
150 { 112 } [ 110 test-tree2 higher-key ] unit-test
151 { { 110 110 } } [ 110 test-tree2 floor-entry ] unit-test
152 { 110 } [ 110 test-tree2 floor-key ] unit-test
153 { { 110 110 } } [ 110 test-tree2 ceiling-entry ] unit-test
154 { 110 } [ 110 test-tree2 ceiling-key ] unit-test
156 { f } [ TREE{ } clone first-key ] unit-test
157 { f } [ TREE{ } clone first-entry ] unit-test
158 { f } [ TREE{ } clone last-key ] unit-test
159 { f } [ TREE{ } clone last-entry ] unit-test
160 { { 100 100 } } [ test-tree2 first-entry ] unit-test
161 { 100 } [ test-tree2 first-key ] unit-test
162 { { 120 120 } } [ test-tree2 last-entry ] unit-test
163 { 120 } [ test-tree2 last-key ] unit-test
165 : ?a..b? ( a b ? ? -- range )
167 { { t t } [ [a..b] ] }
168 { { t f } [ [a..b) ] }
169 { { f t } [ (a..b] ] }
170 { { f f } [ (a..b) ] }
174 : test-tree2-subtree>alist ( a b ? ? -- subalist )
175 ?a..b? >array [ even? ] filter [ dup 2array ] map ;
177 : subtree>alist ( from-key to-key tree start-inclusive? end-inclusive? -- alist )
179 { { t f } [ subtree>alist[) ] }
180 { { f t } [ subtree>alist(] ] }
181 { { t t } [ subtree>alist[] ] }
182 { { f f } [ subtree>alist() ] }
185 99 121 [a..b] 2 all-combinations
186 { t f } dup 2array <product-sequence> 2array
187 [ first2 [ first2 ] bi@
189 [ test-tree2-subtree>alist 1array ]
190 [ [ [ test-tree2 ] 2dip subtree>alist ] 2curry 2curry unit-test ]
194 { { } } [ 100 120 TREE{ } clone subtree>alist[] ] unit-test
195 { { } } [ 120 TREE{ } clone headtree>alist[] ] unit-test
196 { { } } [ 100 TREE{ } clone tailtree>alist[] ] unit-test
198 { { 100 102 104 106 108 110 112 114 } }
199 [ 114 test-tree2 headtree>alist[] keys ] unit-test
200 { { 100 102 104 106 108 110 112 } }
201 [ 114 test-tree2 headtree>alist[) keys ] unit-test
202 { { 106 108 110 112 114 116 118 120 } }
203 [ 106 test-tree2 tailtree>alist[] keys ] unit-test
204 { { 108 110 112 114 116 118 120 } }
205 [ 106 test-tree2 tailtree>alist(] keys ] unit-test
208 { { { 10 10 } TREE{ { 20 20 } { 30 30 } } } } [
209 TREE{ { 20 20 } { 10 10 } { 30 30 } } clone [
214 { { { 30 30 } TREE{ { 20 20 } { 10 10 } } } } [
215 TREE{ { 20 20 } { 10 10 } { 30 30 } } clone [
220 { { { 20 20 } TREE{ } } } [
221 TREE{ { 20 20 } } clone [
226 { { { 20 20 } TREE{ } } } [
227 TREE{ { 20 20 } } clone [
232 { f } [ TREE{ } pop-tree-left ] unit-test
233 { f } [ TREE{ } pop-tree-right ] unit-test
235 : with-limited-calls ( n quot -- quot' )
239 [ "too many calls" throw ]
240 [ count 1 + count! @ ] if
245 { V{ { 10 10 } { 15 10 } { 20 20 }
246 { 15 20 } { 30 30 } { 35 30 }
248 TREE{ { 20 20 } { 10 10 } { 30 30 } } clone V{ } clone [
251 { [ dup 20 mod zero? ] [ drop [ first2 swap 5 - ] dip set-at ] }
252 { [ dup 10 mod zero? ] [ drop [ first2 swap 5 + ] dip set-at ] }
255 ] [ push ] bi-curry* bi
256 ] with-limited-calls 2curry slurp-tree-left
261 { 30 30 } { 25 30 } { 20 20 }
262 { 25 20 } { 10 10 } { 5 10 } }
264 TREE{ { 20 20 } { 10 10 } { 30 30 } } clone V{ } clone [
267 { [ dup 20 mod zero? ] [ drop [ first2 swap 5 + ] dip set-at ] }
268 { [ dup 10 mod zero? ] [ drop [ first2 swap 5 - ] dip set-at ] }
271 ] [ push ] bi-curry* bi
272 ] with-limited-calls 2curry slurp-tree-right