extra/benchmark/pidigits/pidigits.factor

   1 ! Copyright (c) 2009 Aaron Schaefer. All rights reserved.
   2 ! The contents of this file are licensed under the Simplified BSD License
   3 ! A copy of the license is available at http://factorcode.org/license.txt
   4 USING: arrays formatting fry grouping io kernel locals math
   5 math.functions math.matrices math.parser math.primes.factors
   6 math.vectors prettyprint sequences sequences.deep ;
   7 IN: benchmark.pidigits
   8
   9 : extract ( z x -- n )
  10     [ first2 ] dip '[ first2 [ _ * ] [ + ] bi* ] bi@ /i ;
  11
  12 : next ( z -- n )
  13     3 extract ;
  14
  15 : safe? ( z n -- ? )
  16     [ 4 extract ] dip = ;
  17
  18 : >matrix ( q s r t -- z )
  19     [ 2array ] 2bi@ 2array ;
  20
  21 : produce ( z y -- z' )
  22     [ 10 ] dip -10 * 0 1 >matrix swap mdot ;
  23
  24 : gen-x ( x -- matrix )
  25     dup 2 * 1 + [ 2 * 0 ] keep >matrix ;
  26
  27 : consume ( z k -- z' )
  28     gen-x mdot ;
  29
  30 :: (padded-total) ( row col -- str n format )
  31     "" row col + "%" "s\t:%d\n"
  32     10 col - number>string glue ;
  33
  34 : padded-total ( row col -- )
  35     (padded-total) '[ _ printf ] call( str n -- ) ;
  36
  37 :: (pidigits) ( k z n row col -- )
  38     n 0 > [
  39         z next :> y
  40         z y safe? [
  41             col 10 = [
  42                 row 10 + y "\t:%d\n%d" printf
  43                 k z y produce n 1 - row 10 + 1 (pidigits)
  44             ] [
  45                 y number>string write
  46                 k z y produce n 1 - row col 1 + (pidigits)
  47             ] if
  48         ] [
  49             k 1 + z k consume n row col (pidigits)
  50         ] if
  51     ] [ row col padded-total ] if ;
  52
  53 : pidigits ( n -- )
  54     [ 1 { { 1 0 } { 0 1 } } ] dip 0 0 (pidigits) ;
  55
  56 : pidigits-benchmark ( -- )
  57     2000 pidigits ;
  58
  59 MAIN: pidigits-benchmark