module type BSML =
sig


  (*******************************************************************)
  (** {3 Types} *)

  (** Abstract type for parallel vector of size p. 

      In the following we will note <v{_0}, ..., v{_p-1}> the parallel
      vector with value v{_i} at processor i *)
  type 'a par

  (*******************************************************************)
  (** {3 Machine parameters accessors} *)

  (** Returns the arguments from command line with implementation-specific
      arguments removed. *)
  val argv : string array 
    
  (** Number {i p} of processes in the parallel machine. *)
  val bsp_p : int

  val within_bounds: int -> bool
    (** [within_bounds n] is [true] is n is between 0 and {i p-1},
	[false] otherwise. *)

  (** BSP parameter {i g} of the parallel machine. *)  
  val bsp_g : float

  (** BSP parameter {i l} of the parallel machine. *)  
  val bsp_l : float

  (** BSP parameter {i r} of the parallel machine. *)  
  val bsp_r : float

  (*******************************************************************)
  (** {3 Exceptions} *)

  (** Raised when asked for a processor id that is not between [0] and
      [bsp_p] - 1. In particular, this exception can be raised by the
      functions that [proj] and [put] return. *)
  exception Invalid_processor of int

  exception Timer_failure of string

  (*******************************************************************)
  (** {3 Parallel operators} *)

  (** Parallel vector creation. {b Parameters :}
      - [f] function to evaluate in parallel
      @return the parallel vector with [f] applied to each pid:
      <[f 0], ..., [f (p-1)]> *)
  val mkpar : (int -> 'a) -> 'a par

  (** Pointwise parallel application. {b Parameters :}
      - [vf] a parallel vector of functions <f{_0}, ..., f{_p-1}>
      - [vv] a parallel vector of values <v{_0}, ..., v{_p-1}>
      @return the parallel vector <f{_0} v{_0}, ..., f{_p-1} v{_p-1}> *) 
  val apply : ('a -> 'b) par -> 'a par -> 'b par
  
  (** Global communication. {b Parameters :}
      - [f] = <f{_0}, ..., f{_p-1}>, f{_i} j is the value that processor
        [i] should send to processor [j].
      @return a parallel vector [g] = <g{_0}, ..., g{_p-1}> where g{_j} i = f{_i}
      j is the value received by processor [j] from processor [i].
  *)
  val put : (int -> 'a) par -> (int -> 'a) par 

  (** projection (dual of [mkpar]). Makes all the elements of a parallel vector
      global. {b Parameters :}
      - [v] a parallel vector <v{_0}, ..., v{_p-1}>
      @return a function f such that f i = v{_i} *)
  val proj : 'a par -> (int -> 'a)
  
  (** Aborts computation and quits. {b Parameters :}
      - [err] error code to return
      - [msg] message to print on standard error *)
  val abort : int -> string -> 'a

  val start_timing : unit -> unit
  val stop_timing : unit -> unit

  (** returns a parallel vector which contains, at each processor, the time
      elapsed between the calls to [start_timing] and [stop_timing].
      @raise Timer_failure if the call to one of those functions was meaningless
      ({e e.g.} [stop_timing] called before [start_timing]). *)
  val get_cost : unit -> float par
end

(** {2 Interface for modules providing BSP parameters} *)

(** Access to the machine parameters from a configuration file. *)

module type MACHINE_PARAMETERS =
sig

  (** Describes the BSP parameters of the machine. *)
  type bsp = {
    p:int;
    g:float;
    l:float;
    r:float
  }
  
  (** Reads the parameters from the configuration file.
      {b Parameters :}
      - [bsp_p] The current number of processors to choose among the possible configurations *)
      (* - [valid] function returning wether a read parameter is correct *)
  val read : int -> unit

  (** Get the current parameters.
      @return the value of the parameters as initialised by [read ()] *)
  val get : unit -> bsp
end

(* (\** {2 Interface for low-level communication modules} *\) *)

(* (\**  Module providing the implementation of the communication functions *\) *)

(* module type COMM = *)
(* sig *)
(*   (\** Performs implementation-dependent initialization. Should be *)
(*       called only once in the course of a program *\) *)
(*   val initialize : unit -> unit *)

(*   (\** Performs implementation-dependent finalization. This will be *)
(*       called at the end of the program. *\) *)
(*   val finalize : unit -> unit *)

(*   (\** Returns the processor ID of the host processor *\) *)
(*   val pid : unit -> int *)

(*   (\** Returns the number of processors in the parallel machine *\) *)
(*   val nprocs : unit -> int *)

(*   (\** Returns the array of command-line arguments *\) *)
(*   val argv : unit -> string array *)

(*   (\** *\) *)
(*   val send : 'a array -> 'a array *)

(*   (\** Returns the clock *\) *)
(*   val wtime : unit -> float *)

(*   (\** Aborts the computation *\) *)
(*   val abort : int -> unit *)
(* end *)

module Bsml 
 =
struct 
  module Make = functor (P:MACHINE_PARAMETERS) ->
  struct

  (* Exceptions *)

  exception Invalid_processor of int

  exception Timer_failure of string

  exception Parmatch_nextcase
  exception Parmatch_failure

  let parameters = 
    begin 
      P.read 0; 
      (* Suppose que (read 0) renvoie les paramètres mpm dans la première
	 entrée du fichier de configuration *)
      P.get ()
    end

  let bsp_p = parameters.P.p
  let bsp_g = parameters.P.g 
  and bsp_l = parameters.P.l
  let bsp_r = parameters.P.r

  let bsp_time_start = ref 0.

  (* val with_bounds : int -> bool = <fun> *)
  let within_bounds i = (0 <= i) && (i < bsp_p)
    
  type 'a par = BsmlSequentialPar of ('a array)

  let mkpar f = 
    BsmlSequentialPar(Array.init bsp_p f)

  let get (BsmlSequentialPar vv) (BsmlSequentialPar vi) =
    BsmlSequentialPar(Array.init bsp_p 
				 (fun j->
				    if within_bounds j
				    then vv.(vi.(j))
				    else raise (Invalid_processor j)))

  let put (BsmlSequentialPar vf) = 
    BsmlSequentialPar(Array.init bsp_p (fun i -> fun j -> (vf.(j)) i))

  let apply (BsmlSequentialPar vf) (BsmlSequentialPar vv) =
    BsmlSequentialPar (Array.init bsp_p (fun i-> (vf.(i)) (vv.(i))))

  let proj (BsmlSequentialPar v) n =
    if not (within_bounds n)
    then raise (Invalid_processor n)
    else v.(n)

  let argv = Sys.argv

  type timing_state = Running | Stopped

  let timing = ref Stopped

  let start_timing () = 
    if !timing=Stopped
    then 
      (bsp_time_start := Sys.time();
       timing := Running)
    else
      raise (Timer_failure "Timer is already running")

  let stop_timing () =
    if !timing=Running
    then 
      (bsp_time_start := (Sys.time()) -. (!bsp_time_start);
       timing:=Stopped)
    else
      raise (Timer_failure "Timer was not started!")

  let get_cost () = 
    mkpar(fun pid -> !bsp_time_start)

  exception Error of string

  let abort i s = 
    print_string s;
    flush stdout;
    exit i

  (* For Pretty-Printing *)

  open Format
  open Outcometree

  exception Ellipsis
  let cautious f ppf arg =
    try f ppf arg with
	Ellipsis -> fprintf ppf "..."

  let rec print_ident ppf =
    function
	Oide_ident s -> fprintf ppf "%s" s
      | Oide_dot (id, s) -> fprintf ppf "%a.%s" print_ident id s
      | Oide_apply (id1, id2) ->
	  fprintf ppf "%a(%a)" print_ident id1 print_ident id2
	    
  let print_out_value ppf tree =
    let rec print_tree ppf =
      function
	| Oval_constr (Oide_ident "BsmlSequentialPar", 
		       [Oval_array tl]) ->
            fprintf ppf "@[<2><%a>@]" (print_tree_list print_tree ",") tl
	| Oval_constr (Oide_dot (Oide_ident "Bsml", "BsmlSequentialPar"),
		       [Oval_array tl]) ->
            fprintf ppf "@[<2><%a>@]" (print_tree_list print_tree ",") tl
	| Oval_constr (name, (_ :: _ as params)) ->
            fprintf ppf "@[<1>%a@ %a@]" print_ident name
              (print_tree_list print_simple_tree "") params
	| Oval_variant (name, Some param) ->
            fprintf ppf "@[<2>`%s@ %a@]" name print_simple_tree param
	| tree -> print_simple_tree ppf tree
    and print_simple_tree ppf =
      function
	  Oval_int i -> fprintf ppf "%i" i
	| Oval_int32 i -> fprintf ppf "%ldl" i
	| Oval_int64 i -> fprintf ppf "%LdL" i
	| Oval_nativeint i -> fprintf ppf "%ndn" i
	| Oval_float f -> fprintf ppf "%.12g" f
	| Oval_char c -> fprintf ppf "'%s'" (Char.escaped c)
	| Oval_string s ->
            begin try fprintf ppf "\"%s\"" (String.escaped s) with
		Invalid_argument "String.create" -> fprintf ppf "<huge string>"
            end
	| Oval_list tl ->
            fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree ";") tl
	| Oval_array tl ->
            fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree ";") tl
	| Oval_constr (Oide_ident "true", []) -> fprintf ppf "true"
	| Oval_constr (Oide_ident "false", []) -> fprintf ppf "false"
	| Oval_constr (name, []) -> print_ident ppf name
	| Oval_variant (name, None) -> fprintf ppf "`%s" name
	| Oval_stuff s -> fprintf ppf "%s" s
	| Oval_record fel ->
            fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel
	| Oval_tuple tree_list ->
            fprintf ppf "@[(%a)@]" (print_tree_list print_tree ",") tree_list
	| Oval_ellipsis -> raise Ellipsis
	| Oval_printer f -> f ppf
	| tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree) tree
    and print_fields first ppf =
      function
	  [] -> ()
	| (name, tree) :: fields ->
            if not first then fprintf ppf ";@ ";
            fprintf ppf "@[<1>%a = @,%a@]" print_ident name (cautious print_tree)
              tree;
            print_fields false ppf fields
    and print_tree_list print_item sep ppf tree_list =
      let rec print_list first ppf =
	function
            [] -> ()
	  | tree :: tree_list ->
              if not first then fprintf ppf "%s@ " sep;
              print_item ppf tree;
              print_list false ppf tree_list
      in
	cautious (print_list true) ppf tree_list
    in
      cautious print_tree ppf tree
	
end



module Machine_Parameters : MACHINE_PARAMETERS =
struct

  (** Describes the BSP parameters of the machine. *)
  type bsp = {
    p:int;
    g:float;
    l:float;
    r:float
  }
  
  (** Reads the parameters from the configuration file.
      {b Parameters :}
      - [bsp_p] The current number of processors to choose among the possible configurations *)
      (* - [valid] function returning wether a read parameter is correct *)
  let read : int -> unit  = fun i -> ()

  (** Get the current parameters.
      @return the value of the parameters as initialised by [read ()] *)
  let get : unit -> bsp = fun () ->   {p=4;g=1.;l=10.;r=10.}

end

include Make(Machine_Parameters)
end


(**************************************************************)

(* Impression des valeurs parallèles sur des scalaires de types de base. *) 

let print_bool_par (Bsml.BsmlSequentialPar v) = 
  let len = Array.length v in 
  Format.open_box 0; Format.print_string "<";  
  Array.iteri 
    (fun i n -> Format.print_bool n ; 
       Format.print_string (if i<>len-1 then ", " else "")) 
    v ; 
  Format.print_string " >" ;  
  Format.close_box ()     ;;

(* pour la version interactive: *)
#install_printer print_bool_par  


let print_int_par (Bsml.BsmlSequentialPar v) = 
  let len = Array.length v in 
  Format.open_box 0; Format.print_string "<";  
  Array.iteri 
    (fun i n -> Format.print_int n ; 
       Format.print_string (if i<>len-1 then ", " else "")) 
    v ; 
  Format.print_string " >" ;  
  Format.close_box () ;;    

(* pour la version interactive: *)
#install_printer print_int_par 

let print_int_int_par (Bsml.BsmlSequentialPar v) = 
  let soi = string_of_int in 
  let len = Array.length v in 
  Format.open_box 0; Format.print_string "<";  
  Array.iteri 
    (fun i (m,n) -> Format.print_string ("("^ soi m ^ "," ^ soi n ^ ")") ; 
       Format.print_string (if i<>len-1 then ", " else "")) 
    v ; 
  Format.print_string " >" ;  
  Format.close_box ()     
;;  
(* pour la version interactive: *)
#install_printer print_int_int_par   
  
let print_float_par (Bsml.BsmlSequentialPar v) = 
  let len = Array.length v in 
  Format.open_box 0; Format.print_string "<";  
  Array.iteri 
    (fun i x -> Format.print_float x ; 
       Format.print_string (if i<>len-1 then ", " else "")) 
    v ; 
  Format.print_string " >" ;  
  Format.close_box ()     

;;  
(* pour la version interactive: *)
#install_printer print_float_par 

let print_float_float_par (Bsml.BsmlSequentialPar v) = 
  let sof = string_of_float in 
  let len = Array.length v in 
  Format.open_box 0; Format.print_string "<";  
  Array.iteri 
    (fun i (x,y) -> Format.print_string ("("^ sof x ^ "," ^ sof y ^ ")") ; 
       Format.print_string (if i<>len-1 then ", " else "")) 
    v ; 
  Format.print_string " >" ;  
  Format.close_box ()     
  
;;  
(* pour la version interactive: *)
#install_printer print_float_float_par   

let print_string_par (Bsml.BsmlSequentialPar v) = 
  let len = Array.length v in 
  Format.open_box 0; Format.print_string "<";  
  Array.iteri 
    (fun i s -> Format.print_string ("\""^s^"\"") ; 
       Format.print_string (if i<>len-1 then ", " else "")) 
    v ; 
  Format.print_string " >" ;  
  Format.close_box ()     

;;  
(* pour la version interactive: *)
#install_printer print_string_par 

let print_char_par (Bsml.BsmlSequentialPar v) = 
  let len = Array.length v in 
  Format.open_box 0; Format.print_string "<";  
  Array.iteri 
    (fun i c -> Format.print_char '\'';
       Format.print_char c; Format.print_char '\'' ; 
       Format.print_string (if i<>len-1 then ", " else ""))  
    v ; 
  Format.print_string " >" ;  
  Format.close_box ()     

;;  
(* pour la version interactive: *)
#install_printer print_char_par 

let print_a_list printer l = 
  let t = Array.of_list l in 
  let len = Array.length t in 
  Format.open_box 0; Format.print_string "[";  
  Array.iteri 
    (fun i x -> printer x ; 
       Format.print_string (if i<>len-1 then "; " else "")) 
    t ; 
  Format.print_string "]" ;  
  Format.close_box ()     

let print_int_list_par (Bsml.BsmlSequentialPar v) = 
  let len = Array.length v in 
  Format.open_box 0; Format.print_string "<";  
  Array.iteri 
    (fun i l -> print_a_list Format.print_int l ; 
       Format.print_string (if i<>len-1 then ", " else "")) 
    v ; 
  Format.print_string " >" ;  
  Format.close_box ()     

;;  
(* pour la version interactive: *)
#install_printer print_int_list_par 

(* ce qui suit sert à imprimer les types de base de put_list *)

let print_int_a_list printer l = 
  let t = Array.of_list l in 
  let len = Array.length t in 
  Format.open_box 0; Format.print_string "[";  
  Array.iteri 
    (fun i (x,y) -> Format.print_string "("; Format.print_int x; 
       Format.print_string ","; printer y ; 
       Format.print_string ")"; 
       Format.print_string (if i<>len-1 then "; " else "")) 
    t ; 
  Format.print_string "]" ;  
  Format.close_box ()     

let print_int_bool_list_par (Bsml.BsmlSequentialPar v) = 
  let len = Array.length v in 
  Format.open_box 0; Format.print_string "<";  
  Array.iteri 
    (fun i l -> print_int_a_list Format.print_bool l ; 
       Format.print_string (if i<>len-1 then ", " else "")) 
    v ; 
  Format.print_string " >" ;  
  Format.close_box () ;;    

(* pour la version interactive: *) 
#install_printer print_int_bool_list_par 

let print_int_int_list_par (Bsml.BsmlSequentialPar v) = 
  let len = Array.length v in 
  Format.open_box 0; Format.print_string "<";  
  Array.iteri 
    (fun i l -> print_int_a_list Format.print_int l ; 
       Format.print_string (if i<>len-1 then ", " else "")) 
    v ; 
  Format.print_string " >" ;  
  Format.close_box ()     

;;  
(* pour la version interactive: *)
#install_printer print_int_int_list_par 

let print_int_float_list_par (Bsml.BsmlSequentialPar v) = 
  let len = Array.length v in 
  Format.open_box 0; Format.print_string "<";  
  Array.iteri 
    (fun i l -> print_int_a_list Format.print_float l ; 
       Format.print_string (if i<>len-1 then ", " else "")) 
    v ; 
  Format.print_string " >" ;  
  Format.close_box ()     

;;  
(* pour la version interactive: *)
#install_printer print_int_float_list_par 

let print_int_string_list_par (Bsml.BsmlSequentialPar v) = 
  let len = Array.length v in 
  Format.open_box 0; Format.print_string "<";  
  Array.iteri 
    (fun i l -> 
       print_int_a_list 
         (fun s -> Format.print_string ("\""^s^"\"")) 
         l ; 
       Format.print_string (if i<>len-1 then ", " else "")) 
    v ; 
  Format.print_string " >" ;  
  Format.close_box ()     

;;  
(* pour la version interactive: *)
#install_printer print_int_string_list_par  

let print_int_char_list_par (Bsml.BsmlSequentialPar v) = 
  let len = Array.length v in 
  Format.open_box 0; Format.print_string "<";  
  Array.iteri 
    (fun i l -> 
       print_int_a_list 
         (fun c -> Format.print_char '\'' ; 
                   Format.print_char c    ;
                   Format.print_char '\'' )
         l ; 
       Format.print_string (if i<>len-1 then ", " else "")) 
    v ; 
  Format.print_string " >" ;  
  Format.close_box ()     

;;  
(* pour la version interactive: *)
#install_printer print_int_char_list_par  

let (print_fun_par: ('a->'b)Bsml.par -> unit) = fun (Bsml.BsmlSequentialPar v) -> 
  let sof = "<fun>" in 
  let len = Array.length v in 
  Format.open_box 0; Format.print_string "< ";  
  Array.iteri 
    (fun i f -> Format.print_string sof; 
       Format.print_string (if i<>len-1 then ", " else "")) 
    v ; 
  Format.print_string " >" ;  
  Format.close_box ()     
  
;;  
(* pour la version interactive: *)
#install_printer print_fun_par   

(**************************************************************)