Paste: Shootout - Pidigts

Author: sunwukong factor Sat, 30 May 2009 03:43:24
Plain Text |
```USING: arrays io kernel make math math.functions math.parser namespaces
sequences ;
IN: shootout-pidigits

! A straightforward (and very slow) translation of the algorithm in the paper
!   J. Gibbons: Unbounded Spigot Algorithms for the Digits of Pi.
! See http://shootout.alioth.debian.org/u64q/benchmark.php?test=pidigits

CONSTANT: line-length 10

: unit ( -- z ) { 1 0 0 1 } ;

: lifts ( k -- z ) dup 2 * 1+ dup 2 * 0 rot 4array ;

! extr computes (q*x+r)/(s*x+t), where z = { q r s t }.
: extr ( z x -- y )
[ 2 cut-slice ] dip
[ over first * swap second + ] curry bi@ / ;

! comp computes { q*u+r*w q*v+r*x s*u+t*w s*v+t*x },
!   where z1 = { q r s t } and z2 = { u v w x }.
: comp-1 ( z1 z2 i-array -- n ) dup second rot nth -rot first swap nth * ;
: comp ( z1 z2 -- z3 )
{ { 0 0 1 2 } { 0 1 1 3 } { 2 0 3 2 } { 2 1 3 3 } }
[ [ 2dup ] dip 2 cut-slice [ comp-1 ] dip swap [ comp-1 ] dip + ]
with with map ;

: prod ( z n -- z' ) 10 swap -10 * 0 1 4array swap comp ;

: next-safe? ( z -- n/f )
[ 3 extr floor ] [ 4 extr floor ] bi
over = [ drop f ] unless ;

: pi-stream ( z k digits -- )
[ rot dup next-safe? dup
[ dup , prod -rot 1- ]
[ drop rot [ lifts comp ] keep 1+ rot ]
if dup 0 >
] loop 3drop ;

: pidigit-array ( n -- array ) unit 1 rot [ pi-stream ] { } make ;

: print-running-total ( n -- ) "\t:" write number>string print ;

: print-last-line ( n -- )
dup line-length mod dup 0 = [ 2drop ]
[ line-length swap - [ " " write ] times print-running-total ] if ;

: print-pidigits ( n -- )
dup pidigit-array
[ swap number>string write 1+ dup line-length mod 0 =
[ print-running-total ] [ drop ] if
] each-index print-last-line ;```

Annotation: Using infix

Author: sunwukong factor Sat, 30 May 2009 06:09:07
Plain Text |
```! After the post, I've discovered the infix library, so
! here are some more readable versions of extr and comp:

:: extr ( z x -- y )
[let | q [ z first ] r [ z second ] s [ z third ] T [ z fourth ]
x [ x ] |
[infix (q*x+r)/(s*x+T) infix]
] ;

:: comp ( z1 z2 -- z3 )
[let | q [ z1 first ] r [ z1 second ] s [ z1 third ] T [ z1 fourth ]
u [ z2 first ] v [ z2 second ] w [ z2 third ] x [ z2 fourth ] |
[infix q*u+r*w infix] [infix q*v+r*x infix]
[infix s*u+T*w infix] [infix s*v+T*x infix]
] 4array ;

! still I think there should be some nicer way...```

Annotation: stack cleanup

Author: R` factor Sat, 30 May 2009 13:19:57
Plain Text |
```! some stack cleanup (but all untested)
: (n>z) ( n -- z )
[ 10 ] dip -10 * 0 1 4array ;

: prod ( z n -- z' ) (n>z) swap comp ;

: pidigit-array ( n -- array ) [ unit 1 ] dip [ pi-stream ] { } make ;

: lifts ( k -- z )
dup 2 * 1+     ! k 2k+1
[ 2 * 0 ] keep ! k 4k+2 0 2k+1
4array ;

! for other words, try to split to smaller words, keep constants seperated from the word's functionality, and don't put two implementations in one word. split it and use its name.

! also try to use the cleave and spread combinators.
for example:
z1 first4 { [ :> q ] [ :> r ] [ :> s ] [ :> T ] } spread
although the let solution is good also.

note: all of the above code is untested```