extra/trees/trees-tests.factor

   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 ;
   4 IN: trees.tests
   5
   6 : test-tree ( -- tree )
   7     TREE{
   8         { 7 "seven" }
   9         { 9 "nine" }
  10         { 4 "four" }
  11         { 4 "replaced four" }
  12         { 7 "replaced seven" }
  13     } clone ;
  14
  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
  23
  24 ! test delete-at
  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
  30
  31 ! test that cloning doesn't reshape the tree
  32 { TREE{
  33     { 7 "seven" }
  34     { 9 "nine" }
  35     { 4 "four" }
  36 } } [ TREE{
  37     { 7 "seven" }
  38     { 9 "nine" }
  39     { 4 "four" }
  40 } clone ] unit-test
  41
  42 ! test that converting from any tree to a basic tree doesn't reshape
  43 ! the tree
  44 { TREE{
  45     { 7 "seven" }
  46     { 9 "nine" }
  47     { 4 "four" }
  48 } } [ TREE{
  49     { 7 "seven" }
  50     { 9 "nine" }
  51     { 4 "four" }
  52 } >tree ] unit-test
  53
  54 ! test height
  55 { 0 } [ TREE{ } height ] unit-test
  56
  57 { 2 } [ TREE{
  58     { 7 "seven" }
  59     { 9 "nine" }
  60     { 4 "four" }
  61 } height ] unit-test
  62
  63 { 3 } [ TREE{
  64     { 9 "seven" }
  65     { 7 "nine" }
  66     { 4 "four" }
  67 } height ] unit-test
  68
  69 ! test assoc-size
  70 { 3 } [ test-tree assoc-size ] unit-test
  71 { 2 } [ test-tree 9 over delete-at assoc-size ] unit-test
  72
  73 TUPLE: constant-random pattern ;
  74 M: constant-random random-32* pattern>> ;
  75 { T{ tree
  76     { root
  77         T{ node
  78             { key 2 }
  79             { value 2 }
  80             { left  T{ node { key 0 } { value 0 } } }
  81             { right T{ node { key 3 } { value 3 } } }
  82         }
  83     } { count 3 } }
  84 } [
  85     TREE{ { 1 1 } { 3 3 } { 2 2 } { 0 0 } } clone
  86     T{ constant-random f 0xffffffff } random-generator [
  87         1 over delete-at
  88     ] with-variable
  89 ] unit-test
  90
  91 CONSTANT: test-tree2 TREE{
  92         { 110 110 }
  93         { 114 114 }
  94         { 106 106 }
  95         { 108 108 }
  96         { 104 104 }
  97         { 112 112 }
  98         { 116 116 }
  99         { 118 118 }
 100         { 120 120 }
 101         { 102 102 }
 102         { 100 100 }
 103     }
 104
 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' )
 110     dup 2 mod - ;
 111 : test-tree2-ceiling-key ( key -- key' )
 112     dup 2 mod + ;
 113
 114 { f } [ 99 test-tree2 lower-node ]  unit-test
 115 { f } [ 100 test-tree2 lower-node ]  unit-test
 116 100 121 (a..b] [
 117     [ test-tree2-lower-key 1array ] keep [ test-tree2 lower-node key>> ] curry unit-test
 118 ] each
 119
 120 99 120 [a..b) [
 121     [ test-tree2-higher-key 1array ] keep [ test-tree2 higher-node key>> ] curry unit-test
 122 ] each
 123 { f } [ 120 test-tree2 higher-node ]  unit-test
 124 { f } [ 121 test-tree2 higher-node ]  unit-test
 125
 126 { f } [ 99 test-tree2 floor-node ]  unit-test
 127 100 121 [a..b] [
 128     [ test-tree2-floor-key 1array ] keep [ test-tree2 floor-node key>> ] curry unit-test
 129 ] each
 130
 131 99 120 [a..b] [
 132     [ test-tree2-ceiling-key 1array ] keep [ test-tree2 ceiling-node key>> ] curry unit-test
 133 ] each
 134 { f } [ 121 test-tree2 ceiling-node ]  unit-test
 135
 136 { 100 } [ test-tree2 first-node key>> ] unit-test
 137 { 120 } [ test-tree2 last-node key>> ] unit-test
 138
 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
 155
 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
 164
 165 : ?a..b? ( a b ? ? -- range )
 166     2array {
 167         { { t t } [ [a..b] ] }
 168         { { t f } [ [a..b) ] }
 169         { { f t } [ (a..b] ] }
 170         { { f f } [ (a..b) ] }
 171     } case ;
 172
 173 ! subtree>alist
 174 : test-tree2-subtree>alist ( a b ? ? -- subalist )
 175     ?a..b? >array [ even? ] filter [ dup 2array ] map ;
 176
 177 : subtree>alist ( from-key to-key tree start-inclusive? end-inclusive? -- alist )
 178     2array {
 179         { { t f } [ subtree>alist[) ] }
 180         { { f t } [ subtree>alist(] ] }
 181         { { t t } [ subtree>alist[] ] }
 182         { { f f } [ subtree>alist() ] }
 183     } case ;
 184
 185 99 121 [a..b] 2 all-combinations
 186 { t f } dup 2array <product-sequence> 2array
 187 [ first2 [ first2 ] bi@
 188     {
 189         [ test-tree2-subtree>alist 1array ]
 190         [ [ [ test-tree2 ] 2dip subtree>alist ] 2curry 2curry unit-test ]
 191     } 4cleave
 192 ] product-each
 193
 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
 197
 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
 206
 207
 208 { { { 10 10 } TREE{ { 20 20 } { 30 30 } } } } [
 209     TREE{ { 20 20 } { 10 10 } { 30 30 } } clone [
 210         pop-tree-left
 211     ] keep 2array
 212 ] unit-test
 213
 214 { { { 30 30 } TREE{ { 20 20 } { 10 10 } } } } [
 215     TREE{ { 20 20 } { 10 10 } { 30 30 } } clone [
 216         pop-tree-right
 217     ] keep 2array
 218 ] unit-test
 219
 220 { { { 20 20 } TREE{ } } } [
 221     TREE{ { 20 20 } } clone [
 222         pop-tree-right
 223     ] keep 2array
 224 ] unit-test
 225
 226 { { { 20 20 } TREE{ } } } [
 227     TREE{ { 20 20 } } clone [
 228         pop-tree-left
 229     ] keep 2array
 230 ] unit-test
 231
 232 { f } [ TREE{ } pop-tree-left ] unit-test
 233 { f } [ TREE{ } pop-tree-right ] unit-test
 234
 235 : with-limited-calls ( n quot -- quot' )
 236     [let
 237         0 :> count!
 238         '[ count _ >=
 239             [ "too many calls" throw ]
 240             [ count 1 + count! @ ] if
 241          ]
 242     ] ; inline
 243
 244
 245 { V{ { 10 10 } { 15 10 } { 20 20 }
 246      { 15 20 } { 30 30 } { 35 30 }
 247 } } [
 248     TREE{ { 20 20 } { 10 10 } { 30 30 } } clone V{ } clone [
 249         dupd 6 [ [
 250                 over first {
 251                     { [ dup 20 mod zero? ] [ drop [ first2 swap 5 - ] dip set-at ] }
 252                     { [ dup 10 mod zero? ] [ drop [ first2 swap 5 + ] dip set-at ] }
 253                     [ 3drop ]
 254                 } cond
 255             ] [ push ] bi-curry* bi
 256         ] with-limited-calls 2curry slurp-tree-left
 257     ] keep
 258 ] unit-test
 259
 260 { V{
 261     { 30 30 } { 25 30 } { 20 20 }
 262     { 25 20 } { 10 10 } {  5 10 } }
 263 } [
 264     TREE{ { 20 20 } { 10 10 } { 30 30 } } clone V{ } clone [
 265         dupd 6 [ [
 266                 over first {
 267                     { [ dup 20 mod zero? ] [ drop [ first2 swap 5 + ] dip set-at ] }
 268                     { [ dup 10 mod zero? ] [ drop [ first2 swap 5 - ] dip set-at ] }
 269                     [ 3drop ]
 270                 } cond
 271             ] [ push ] bi-curry* bi
 272         ] with-limited-calls 2curry slurp-tree-right
 273     ] keep
 274 ] unit-test