extra/benchmark/partial-sums/partial-sums.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: math math.functions kernel io io.styles prettyprint
   4 combinators hints fry namespaces sequences ;
   5 IN: benchmark.partial-sums
   6
   7 ! Helper words
   8 : summing-integers ( n quot -- y ) [ 0.0 ] 2dip '[ 1+ @ + ] each ; inline
   9 : summing-floats ( n quot -- y ) '[ >float @ ] summing-integers ; inline
  10 : cube ( x -- y ) dup dup * * ; inline
  11 : -1^ ( n -- -1/1 ) 2 mod 2 * 1- ; inline
  12
  13 ! The functions
  14 : 2/3^k ( n -- y ) [ 2.0 3.0 / swap 1- ^ ] summing-floats ; inline
  15 : k^-0.5 ( n -- y ) [ -0.5 ^ ] summing-floats ; inline
  16 : 1/k(k+1) ( n -- y ) [ dup 1+ * recip ] summing-floats ; inline
  17 : flint-hills ( n -- y ) [ [ cube ] [ sin sq ] bi * recip ] summing-floats ; inline
  18 : cookson-hills ( n -- y ) [ [ cube ] [ cos sq ] bi * recip ] summing-floats ; inline
  19 : harmonic ( n -- y ) [ recip ] summing-floats ; inline
  20 : riemann-zeta ( n -- y ) [ sq recip ] summing-floats ; inline
  21 : alternating-harmonic ( n -- y ) [ [ -1^ ] keep /f ] summing-integers ; inline
  22 : gregory ( n -- y ) [ [ -1^ ] [ 2.0 * 1- ] bi / ] summing-integers ; inline
  23
  24 : partial-sums ( n -- results )
  25     [
  26         {
  27             [ 2/3^k                 \ 2/3^k                set ]
  28             [ k^-0.5                \ k^-0.5               set ]
  29             [ 1/k(k+1)              \ 1/k(k+1)             set ]
  30             [ flint-hills           \ flint-hills          set ]
  31             [ cookson-hills         \ cookson-hills        set ]
  32             [ harmonic              \ harmonic             set ]
  33             [ riemann-zeta          \ riemann-zeta         set ]
  34             [ alternating-harmonic  \ alternating-harmonic set ]
  35             [ gregory               \ gregory              set ]
  36         } cleave
  37     ] { } make-assoc ;
  38
  39 HINTS: partial-sums fixnum ;
  40
  41 : partial-sums-main ( -- )
  42     2500000 partial-sums simple-table. ;
  43
  44 MAIN: partial-sums-main