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

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