
(* This file is part of Numerix.  Numerix is free software; you can
   redistribute it and/or modify it under the terms of the GNU General
   Public License as published by the Free Software Foundation; either
   version 2 of the License, or (at your option) any later version.

   This program is distributed in the hope that it will be useful, but
   WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   General Public License for more details.

   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
   USA *)

(* +------------------------------------------------------------------------+
   |                                                                        |
   |                 Calcul de Pi, formule de Ramanujan                     |
   |                                                                        |
   +------------------------------------------------------------------------+ *)
(* M.Quercia, le 06/02/2001 *)

(* Programme de test pour les différentes implémentations des entiers *)
(* en Ocaml.                                                          *)
(* cf. "The Caml Numbers Reference Manual", Inria, RT-0141            *)
(* annexe A, pp. 115 et suivantes.                                    *)

open Numerix
open Printf

(* +------------------------------------------------------------------------+
   |                             Module de calcul                           |
   +------------------------------------------------------------------------+ *)

module Main(E:Int_type) = struct
  open E
  module I = Infixes(E)

  (* Affichage par tranches de 5 chiffres, lignes de 10 tranches *)
  let pretty_print s i skip =
    let j = ref i in
    while !j < String.length(s) do
      print_char s.[!j];
      j := !j + 1;
           if (!j-i) mod 250 = 0 then print_string "\n\n"
      else if (!j-i) mod  50 = 0 then print_string "\n"
      else if (!j-i) mod  10 = 0 then print_string "  "
      else if (!j-i) mod   5 = 0 then print_string " ";
      if skip && ((!j-i) mod 50 = 0) then begin
	let k = (String.length(s) - !j)/50 - 1 in
	if k > 0 then begin
	  printf "... (%d lignes omises)\n" k;
	  j := !j + 50*k
	end;
      end;
    done;
    if (String.length(s)-1-i) mod 50 <> 49 then print_string "\n"

  (* constantes *)
  let zero  = of_int 0
  and un    = of_int 1
  and deux  = of_int 2
  and trois = of_int 3
  and cinq  = of_int 5
  and six   = of_int 6
  and sept  = of_int 7
  and onze  = of_int 11
  and a     = of_int 13591409
  and b     = of_int 545140134
  and c     = quo_1 (pow (of_int 320160) 3) 3
  and c0    = of_int  53360
  and d     = of_int 640320
  and (~~)   = look

  (* pas de Array.init_vect dans Oaml < 2.02 *)
  let init_vect n f =
    let v = Array.create n (f 0) in
    for i=1 to n-1 do v.(i) <- f(i) done;
    v

                    (* +----------------------+
                       |  somme dichotomique  |
                       +----------------------+ *)


  open I
  let somme_func prec =

    (* état du calcul :
          p     = index série
          alpha = 2p+1
          beta  = 6p+1
          gamma = 6p+5
          delta = c*p^3
          eps   = a + b*p
    *)

    (* calcule et retranche les termes de rangs p et p+1 *)
    let calc2 (p,alpha,beta,gamma,delta,eps) =

      let  ma    = (alpha * beta) * gamma        in
      let  mb    = delta                         in
      let  ms    = eps                           in
      
      let  p     = p      + un                   in
      let  alpha = alpha  + deux                 in
      let  beta  = beta   + six                  in
      let  gamma = gamma  + six                  in
      let  delta = sqr(p) * p * c                in
      let  eps   = eps    + b                    in
      
      let  ms    = delta * ms - ma * eps         in
      let  ma    = (alpha * beta * gamma) * ma   in
      let  mb    = mb * delta                    in
      
      let  p     = p      + un                   in
      let  alpha = alpha  + deux                 in
      let  beta  = beta   + six                  in
      let  gamma = gamma  + six                  in
      let  delta = sqr(p) * p * c                in
      let  eps   = eps    + b                    in

      (ma,mb,ms), (p,alpha,beta,gamma,delta,eps)
    in

    (* calcule et additionne 2*k termes *)
    let rec calc k etat =

      if k =! 1 then calc2 etat

      else let (a0, b0, s0), etat = calc (k/!2)      etat  in
           let (a1, b1, s1), etat = calc (k -! k/!2) etat  in
	   (a0*a1, b0*b1, a0*s1 + b1*s0), etat
    in

    (* lance les calculs *)
    let k    = (prec +! 197)/!94           in
    let etat = (zero, un, un, cinq, c0, a) in
    let (a,b,s),_ = calc k etat            in (b,s)

  open Pervasives

                  (* +---------------------------+
                     |  Idem en calcul surplace  |
                     +---------------------------+ *)

  let somme_surplace prec =

    let etapes = (prec+197)/94        in  (* nb d'étapes *)
    let prof   = nbits(of_int etapes) in  (* profondeur de récursion *)
    let mem    = init_vect prof           (* pile de récursion       *)
		     (fun _ -> make_ref zero, make_ref zero, make_ref zero)
    and sp     = ref(-1)             	    (* pointeur de pile *)
    and p      = make_ref zero       	    (* index série *)
    and alpha  = make_ref un         	    (* 2p + 1      *)
    and beta   = make_ref un         	    (* 6p + 1      *)
    and gamma  = make_ref cinq       	    (* 6p + 5      *)
    and delta  = make_ref c0         	    (* c*p^3       *)
    and eps    = make_ref a          	    (* a + bp      *)
    and t      = make_ref zero       	    (* scratch     *)
    and u      = make_ref zero       	    (* scratch     *)
    and x1     = make_ref zero       	    (* scratch     *)
    and x2     = make_ref zero       	    (* scratch     *)
    and x3     = make_ref zero       	    (* scratch     *)
    and y1     = make_ref zero       	    (* scratch     *)
    and y2     = make_ref zero       	    (* scratch     *)
    and j      = ref 0               	    (* scratch     *)
    in

    for i=1 to etapes do

      (* calcule et retranche les termes de rangs p et p+1 *)
      incr sp;
      let (ma, mb, ms) = mem.(!sp) in

      mul_in  t      ~~alpha   ~~beta;
      mul_in  ma     ~~t       ~~gamma;
      copy_in mb     ~~delta;
      copy_in ms     ~~eps;
      
      add_in  p      ~~p       un;
      add_in  alpha  ~~alpha   deux;
      add_in  beta   ~~beta    six;
      add_in  gamma  ~~gamma   six;
      sqr_in  t      ~~p;
      mul_in  u       c       ~~p;
      mul_in  delta  ~~t       ~~u;
      add_in  eps    ~~eps     b;
      
      mul_in  t      ~~delta   ~~ms;
      mul_in  u      ~~ma      ~~eps;
      sub_in  ms     ~~t       ~~u;
      mul_in  t      ~~alpha   ~~beta;
      mul_in  u      ~~ma      ~~gamma;
      mul_in  ma     ~~t       ~~u;
      mul_in  mb     ~~mb      ~~delta;
      
      add_in  p      ~~p       un;
      add_in  alpha  ~~alpha   deux;
      add_in  beta   ~~beta    six;
      add_in  gamma  ~~gamma   six;
      sqr_in  t      ~~p;
      mul_in  u      c        ~~p;
      mul_in  delta  ~~t       ~~u;
      add_in  eps    ~~eps     b;
      
      (* combine avec les calculs précédents *)
      j := 1;
      while !j land i = 0 do
	
	let (a1,b1,s1) = mem.(!sp) in
	decr sp;
	let (a0,b0,s0) = mem.(!sp) in
	mul_in  t   ~~b1  ~~s0;
	mul_in  s0  ~~a0  ~~s1;
	add_in  s0  ~~s0  ~~t;
	mul_in  a0  ~~a0  ~~a1;
	mul_in  b0  ~~b0  ~~b1;
	
	j := !j*2
      done;

    done;

    (* termine les calculs en instance *)
    while !sp > 0 do

      let (a1,b1,s1) = mem.(!sp) in
      decr sp;
      let (a0,b0,s0) = mem.(!sp) in
      mul_in  t   ~~b1  ~~s0;
      mul_in  s0  ~~a0  ~~s1;
      add_in  s0  ~~s0  ~~t;
     (* mul_in  a0  ~~a0  ~~a1; *) (* inutile, a0 ne servira plus *)
      mul_in  b0  ~~b0  ~~b1;
      
    done;
    let (a0,b0,s0) = mem.(0) in (~~b0, ~~s0)

            (* +------------------------------------+
               |  calcule pi avec digits décimales  |
               +------------------------------------+ *)

  type opts = {
    digits : int;  (* nombre de chiffres demandés *)
    pgcd   : bool; (* simplifier avant division ? *)
    prt    : bool; (* imprimer le résultat ?      *)
    skip   : bool; (* n'afficher que la première et la dernière ligne *)
    debug  : bool; (* détailler les étapes        *)
    func   : bool} (* calcul fonctionnel          *)

  let pi opts =

    if opts.debug then chrono(name()^(if opts.func then ", func" else ", surplace"));
    let p5 = pow cinq (opts.digits - 2) in
    if opts.debug then chrono "puiss 5";

    let rac = E.sqrt(shl (mul d (sqr p5)) (2*(opts.digits-2)) ) in
    if opts.debug then chrono "sqrt";
    
    let prec = nbits(p5) + opts.digits - 2 in
    let (b,s) = (if opts.func then somme_func else somme_surplace) prec in
    if opts.debug then chrono(sprintf "série lb=%d ls=%d" (nbits b) (nbits s));

    let b,s = if opts.pgcd then begin
      let b,s,_,_,_ = cfrac b s in
      if opts.debug then chrono(sprintf "pgcd  lb=%d ls=%d" (nbits b) (nbits s));
      b,s
    end else b,s in

    let pi = quo (mul (mul_1 rac 100) b) s in
    if opts.debug then chrono "quotient";

    if opts.prt then begin
      let s = string_of pi in
      if opts.debug then chrono "conversion";
      print_char s.[0];
      print_string ".\n";
      pretty_print s 1 opts.skip;
    end

                     (* +---------------------+
                        |  lance les calculs  |
                        +---------------------+ *)

  let main arglist =
    try
      let opts =
	let rec parse opts = function
	  | "-noprint"::s  -> parse {opts with prt    = false} s
	  | "-skip"::s     -> parse {opts with skip   = true } s
	  | "-gcd"::s      -> parse {opts with pgcd   = true } s
	  | "-d"::s        -> parse {opts with debug  = true } s
	  | "-func"::s     -> parse {opts with func   = true } s
	  | "-test"::s     -> parse {opts with digits = 1000; skip=true; debug=false} s
	  | d::s           -> parse {opts with digits = int_of_string d} s
	  | []             -> opts
	in parse {digits = 100;
		  pgcd   = false;
		  prt    = true;
		  skip   = false;
		  debug  = true;
		  func   = false} arglist in

      if opts.digits <= 0 then failwith "digits <= 0";
      pi opts

    with ex ->
      fprintf stderr "syntaxe : pi <digits> [-d] [-noprint] [-skip] [-gcd] func] [-e entiers] [-count]\n";
      flush   stderr;
      raise ex

end

module S = Numcount.Start(Main)
let _ = S.start()
