extra/benchmark/binary-trees/binary-trees.factor

   1 USING: kernel math accessors prettyprint io locals sequences
   2 math.ranges math.order ;
   3 IN: benchmark.binary-trees
   4
   5 TUPLE: tree-node item left right ;
   6
   7 C: <tree-node> tree-node
   8
   9 : bottom-up-tree ( item depth -- tree )
  10     dup 0 > [
  11         1 -
  12         [ drop ]
  13         [ [ 2 * 1 - ] dip bottom-up-tree ]
  14         [ [ 2 *     ] dip bottom-up-tree ] 2tri
  15     ] [
  16         drop f f
  17     ] if <tree-node> ; inline recursive
  18
  19 GENERIC: item-check ( node -- n )
  20
  21 M: tree-node item-check
  22     [ item>> ] [ left>> ] [ right>> ] tri [ item-check ] bi@ - + ;
  23
  24 M: f item-check drop 0 ;
  25
  26 : min-depth 4 ; inline
  27
  28 : stretch-tree ( max-depth -- )
  29     1 + 0 over bottom-up-tree item-check
  30     [ "stretch tree of depth " write pprint ]
  31     [ "\t check: " write . ] bi* ; inline
  32
  33 :: long-lived-tree ( max-depth -- )
  34     0 max-depth bottom-up-tree
  35
  36     min-depth max-depth 2 <range> [| depth |
  37         max-depth depth - min-depth + 2^ [
  38             [1,b] 0 [
  39                 dup neg
  40                 [ depth bottom-up-tree item-check + ] bi@
  41             ] reduce
  42         ]
  43         [ 2 * ] bi
  44         pprint "\t trees of depth " write depth pprint
  45         "\t check: " write .
  46     ] each
  47
  48     "long lived tree of depth " write max-depth pprint
  49     "\t check: " write item-check . ; inline
  50
  51 : binary-trees ( n -- )
  52     min-depth 2 + max [ stretch-tree ] [ long-lived-tree ] bi ; inline
  53
  54 : binary-trees-main ( -- )
  55     16 binary-trees ;
  56
  57 MAIN: binary-trees-main