Paste: Shootout - Pidigts

Author: sunwukong
Mode: factor
Date: 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
Mode: factor
Date: 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`
Mode: factor
Date: 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

New Annotation

Summary:
Author:
Mode:
Body: