! Copyright (C) 2009 Peter Salvi.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays infix io kernel locals 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 ( 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 ;

: 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 ;

! Old version (without locals & infix)
!
! : 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 ;
!
! : extr ( z x -- y )
!     [ 2 cut-slice ] dip
!     [ over first * swap second + ] curry bi@ / ;