(**
 	Module: Interpreter	
	Description: input beam -> process -> output beam
	@author WANG Haisheng	
	Created: 15/05/2013	Modified: 04/06/2013
*)

open Types;;
open Value;;
open Signal;;
open Faustexp;;

(* EXCEPTIONS *)

(** Exception raised during interpretation of faust process.*)
exception Evaluation_Error of string;;



(* MACRO *)

(** Macro constants of this file.*)
type interpreter_macro = 
  | Number_samples_int
  | Max_Eval_Time_int;;

(** val interpreter_macro_to_value : returns the value associated with the macro.*)
let interpreter_macro_to_value m = match m with
				| Number_samples_int -> 0xFF
				| Max_Eval_Time_int -> 0xFFFFFFFF;;


(* OUTPUT WAVE COMPUTATION *)

(** val func_of_func_array : (int -> value) array -> (int -> value array),
applies the same int parameter to each element of function array, 
produces a value array.*)
let fun_array_to_fun = fun fun_array -> 
	let reverse = fun t -> fun f -> f t in
	let new_fun = fun t-> Array.map (reverse t) fun_array in
	new_fun;;
	

(** val computing : (int -> value array) -> int -> int -> float array array array,
applies time sequence "0,1,2,3,...,max" to signal beam,
returns primitive output data.*)
let computing = fun f -> fun width -> fun length ->
	let container_float_array_array_array = 
	        ref (Array.make length (Array.make width [||])) in
	let index = ref 0 in

	try
		while !index < length do
			(!container_float_array_array_array).(!index) 
		                      <- (Array.map convert_back_R (f (!index)));
			incr index;
		done;
	        let () = print_string ("Done.") in
		!container_float_array_array_array

	with x ->
		let error_message = 
			match x with
			|Convert_Error s -> "Convert_Error: " ^ s
			|Value_operation s -> "Value_operation: " ^ s
			|Signal_operation s -> "Signal_operation: " ^ s
			|Beam_Matching_Error s -> "Beam_Matching_Error: " ^ s
			|Evaluation_Error s -> "Evaluation_Error: " ^ s
			|NotYetDone -> "NotYetDone"
			|_ -> "Done."
		in
		let () = print_string error_message in
		Array.sub (!container_float_array_array_array) 0 !index;;


(** val matrix_transpose : 'a array array -> 'a array array, 
transposes the input matrix.*)
let matrix_transpose = fun m_array_array -> fun width -> 
	let get_element = fun i -> fun array -> Array.get array i in
	let get_line = fun array_array -> fun i -> 
	        Array.map (get_element i) array_array in
	let transpose array_array = Array.init width (get_line array_array) in
	transpose m_array_array;;


(** val channels : 'a array array array -> int -> int array, 
returns an array of number of channels. *)
let channels = fun f_array_array_array -> fun width ->
  	let channel = fun faaa -> fun i -> 
		let faa = faaa.(i) in
		let length = Array.length faa in
		let fa = faa.(length - 1) in
		Array.length fa
	in
	let channel_array = Array.init width (channel f_array_array_array) in
	channel_array;;


(** val arrange : 'a array array array -> int -> 'a array list, 
arranges the output data in "array list" form. *)
let arrange = fun float_array_array_array -> fun width ->
	let concat faaa = fun i -> 
		let faa = faaa.(i) in
		Array.concat (Array.to_list faa)
	in
	let float_array_array = Array.init width (concat float_array_array_array) in
	let float_array_list = Array.to_list float_array_array in
	float_array_list;;


(** val compute : (int -> value) list -> (int list) * (float array list).
input: a list of signal functions
output: channel number list, data list.*)
let compute fun_list = 
	let () = print_string("    Faustine -> Signals computing... ") in
	let tic = Sys.time () in
	
	(* arrange input information *)
	let length = interpreter_macro_to_value Number_samples_int in
	let width = List.length fun_list in
	let beam_fun = fun_array_to_fun (Array.of_list fun_list) in

	(* calculate output wave *)
	let tmp_float_array_array_array = computing beam_fun width length in

	(* arrange output data *)
	let output_float_array_array_array = matrix_transpose tmp_float_array_array_array width in
	let channel_array = channels output_float_array_array_array width in
	let channel_list = Array.to_list channel_array in
	let output_float_array_list = arrange output_float_array_array_array width in
	let toc = Sys.time () in
	let () = print_endline(" (duration: " ^ (string_of_float (toc -. tic)) ^ "s)") in
	(channel_list, output_float_array_list);;



(* INTERPRETATION *)

(** val sublist : 'a list -> int -> int -> 'a list, 
[sublist l start length], returns the sublist of list 'l', 
from index 'start', with length 'length'.*)
let sublist l start length = 
	try
		let arr = Array.of_list l in
		let sub_array = Array.sub arr start length in
			Array.to_list sub_array

	with (Invalid_argument "Array.sub") ->
		raise (Invalid_argument "List.sub");;


(** val make_beam : (int list) * (float array list) -> (int * (int -> value)) list,
input: (sample rate list, data list)
output: beam = (sample rate, function) list *)
let make_beam = fun input ->
	let rate_list = fst input in
	let float_array_list = snd input in
	let value_array_list = 
	        List.map (Array.map return_R) float_array_list in
	let fun_list = List.map Array.get value_array_list in
	let make_signal = fun rate -> fun f -> (rate, f) in
	let beam = List.map2 make_signal rate_list fun_list in
	beam;;


(** val interpret_const : value -> beam -> beam, generates constant signal with frequency 0. *)
let interpret_const = fun v -> fun input_beam ->
	let n = List.length input_beam in
	if n = 0 then [(0,(fun t -> v))] 
	else raise (Evaluation_Error "Const");;
     

(** val interpret_ident : string -> beam -> beam, 
generates signals according to identified symbols. *)
let interpret_ident = fun s -> fun input_beam ->
	let n = List.length input_beam in
	match s with
	|Pass -> if n = 1 then input_beam else raise (Evaluation_Error "Ident _")

	|Stop -> if n = 1 then [] else raise (Evaluation_Error "Ident !")

	|Add -> if n = 2 then [signal_add (List.nth input_beam 0) (List.nth input_beam 1)] 
			else raise (Evaluation_Error "Ident +")

	|Sup -> if n = 2 then [signal_sub (List.nth input_beam 0) (List.nth input_beam 1)] 
			else raise (Evaluation_Error "Ident -")

	|Mul -> if n = 2 then [signal_mul (List.nth input_beam 0) (List.nth input_beam 1)] 
			else raise (Evaluation_Error "Ident *")

	|Div -> if n = 2 then [signal_div (List.nth input_beam 0) (List.nth input_beam 1)] 
			else raise (Evaluation_Error "Ident /")

	|Delay -> if n = 2 then [signal_delay (List.nth input_beam 0) (List.nth input_beam 1)] 
			else raise (Evaluation_Error "Ident @")

	|Mem -> if n = 1 then [signal_mem (List.nth input_beam 0)] 
			else raise (Evaluation_Error "Ident mem")

	|Vectorize -> if n = 2 then [signal_vectorize (List.nth input_beam 0) (List.nth input_beam 1)]
			else raise (Evaluation_Error "Ident vectorize")

	|Serialize -> if n = 1 then [signal_serialize (List.nth input_beam 0)]
			else raise (Evaluation_Error "Ident serialize")

	|Concat -> if n = 2 then [signal_append (List.nth input_beam 0) (List.nth input_beam 1)]
			else raise (Evaluation_Error "Ident #")

	|Nth -> if n = 2 then [signal_nth (List.nth input_beam 0) (List.nth input_beam 1)]
			else raise (Evaluation_Error "Ident []")

	|Floor -> if n = 1 then [signal_floor (List.nth input_beam 0)]
			else raise (Evaluation_Error "Ident floor")

	|Int -> if n = 1 then [signal_int (List.nth input_beam 0)]
			else raise (Evaluation_Error "Ident int")

	|Sin -> if n = 1 then [signal_sin (List.nth input_beam 0)]
			else raise (Evaluation_Error "Ident sin")

	|Cos -> if n = 1 then [signal_cos (List.nth input_beam 0)]
			else raise (Evaluation_Error "Ident cos")

	|Atan -> if n = 1 then [signal_atan (List.nth input_beam 0)]
			else raise (Evaluation_Error "Ident atan")

	|Atantwo -> if n = 2 then [signal_atantwo (List.nth input_beam 0) (List.nth input_beam 1)]
			else raise (Evaluation_Error "Ident atantwo")

	|Sqrt -> if n = 1 then [signal_sqrt (List.nth input_beam 0)]
			else raise (Evaluation_Error "Ident sqrt")

	|Rdtable -> if n = 3 then [signal_rdtable (List.nth input_beam 0) 
					(List.nth input_beam 1) (List.nth input_beam 2)] 
			else raise (Evaluation_Error "Ident rdtable")

	|Selecttwo -> if n = 3 then [signal_select2 (List.nth input_beam 0) (List.nth input_beam 1) 
					(List.nth input_beam 2)] 
			else raise (Evaluation_Error "Ident select2")

	|Selectthree -> if n = 4 then [signal_select3 (List.nth input_beam 0) (List.nth input_beam 1) 
					(List.nth input_beam 2) (List.nth input_beam 3)] 
			else raise (Evaluation_Error "Ident select3")

	|Prefix -> if n = 2 then [signal_prefix (List.nth input_beam 0) (List.nth input_beam 1)] 
			else raise (Evaluation_Error "Ident prefix")

	|Mod -> if n = 2 then [signal_mod (List.nth input_beam 0) (List.nth input_beam 1)] 
			else raise (Evaluation_Error "Ident %")

	|Larger -> if n = 2 then [signal_sup (List.nth input_beam 0) (List.nth input_beam 1)] 
			else raise (Evaluation_Error "Ident >")

	|Smaller -> if n = 2 then [signal_inf (List.nth input_beam 0) (List.nth input_beam 1)] 
		else raise (Evaluation_Error "Ident <");;



(** val rec eval : faust_exp -> beam -> beam,
main interpretation work is done here. *)
let rec eval exp_faust dimension_tree input_beam = 


(** val interpret_par : faust_exp -> faust_exp -> beam -> beam, 
interprets par(e1, e2) with input beam, produces output beam.*)
let interpret_par = fun e1 -> fun e2 -> fun dimension_tree -> fun input_beam ->

	(* dimension information *)
	let n = List.length input_beam in
	let subtree1 = subtree_left dimension_tree in
	let subtree2 = subtree_right dimension_tree in
	let d1 = get_root subtree1 in
	let d2 = get_root subtree2 in

	if n = (fst d1) + (fst d2) then 
	(		
		(* segmentation of input beam *)
		let input_beam1 = sublist input_beam 0 (fst d1) in
		let input_beam2 = sublist input_beam (fst d1) (fst d2) in

		(* evaluate two expressions respectively *)
		let output_beam1 = eval e1 subtree1 input_beam1 in
		let output_beam2 = eval e2 subtree2 input_beam2 in

		(* concat two output beams *)
		if List.length output_beam1 = snd d1 && List.length output_beam2 = snd d2 
		then (output_beam1 @ output_beam2) 
		else raise (Evaluation_Error "Par")
	)
	else raise (Evaluation_Error "Par") in


(** val interpret_seq : faust_exp -> faust_exp -> beam -> beam, 
interprets seq(e1, e2) with input beam, produces output beam.*)
let interpret_seq = fun e1 -> fun e2 -> fun dimension_tree -> fun input_beam ->

	(* dimension information *)
	let n = List.length input_beam in
	let subtree1 = subtree_left dimension_tree in
	let subtree2 = subtree_right dimension_tree in
	let d1 = get_root subtree1 in
	let d2 = get_root subtree2 in


	if n = fst d1 then
	(
		(* evaluate the first expression *)
		let output_beam1 = eval e1 subtree1 input_beam in

		(* evaluate the second expression *)
		if List.length output_beam1 = fst d2 
		then eval e2 subtree2 output_beam1
		else raise (Evaluation_Error "Seq")
	)
	else raise (Evaluation_Error "Seq") in


(** val interpret_split : faust_exp -> faust_exp -> beam -> beam, 
interprets split(e1, e2) with input beam, produces output beam.*)
let interpret_split = fun e1 -> fun e2 -> fun dimension_tree -> fun input_beam ->

	(* dimension information *)
	let n = List.length input_beam in
	let subtree1 = subtree_left dimension_tree in
	let subtree2 = subtree_right dimension_tree in
	let d1 = get_root subtree1 in
	let d2 = get_root subtree2 in


	if n = fst d1 then
	(
		(* evaluate the first expression *)
		let output_beam1 = eval e1 subtree1 input_beam in

		(* beam matching *)
		let ref_output_beam1 = ref (beam_add_one_memory output_beam1) in
		let input_beam2 = List.concat 
		    (Array.to_list (Array.make ((fst d2)/(List.length output_beam1)) !ref_output_beam1)) 
		in

		(* evaluate the second expression *)
		if List.length input_beam2 = fst d2
		then eval e2 subtree2 input_beam2
		else raise (Evaluation_Error "Split")
	)
	else raise (Evaluation_Error "Split") in


(** val interpret_merge : faust_exp -> faust_exp -> beam -> beam, 
interprets merge(e1, e2) with input beam, produces output beam.*)
let interpret_merge = fun e1 -> fun e2 -> fun dimension_tree -> fun input_beam ->

	(* dimension information *)
	let n = List.length input_beam in
	let subtree1 = subtree_left dimension_tree in
	let subtree2 = subtree_right dimension_tree in
	let d1 = get_root subtree1 in
	let d2 = get_root subtree2 in


	if n = fst d1 then
	(
		(* evaluate the first expression *)
		let output_beam1 = eval e1 subtree1 input_beam in

		(* beam matching *)
		let input_beam2 = 
		(
			let fois = (snd d1)/(fst d2) in
			let ref_beam = ref (sublist output_beam1 0 (fst d2)) in
			for i = 1 to fois - 1 do
				let temp_beam = sublist output_beam1 (i*(fst d2)) (fst d2) in
				ref_beam := List.map2 signal_add (!ref_beam) temp_beam;
			done;
			!ref_beam
		)
		in

		(* evaluate the second expression *)
		if List.length input_beam2 = fst d2
		then eval e2 subtree2 input_beam2
		else raise (Evaluation_Error "Merge")
	)
	else raise (Evaluation_Error "Merge") in


(** val interpret_rec : faust_exp -> faust_exp -> beam -> beam, 
interprets rec(e1, e2) with input beam, produces output beam.*)
let interpret_rec = fun e1 -> fun e2 -> fun dimension_tree -> fun input_beam ->

	(* dimension information *)
	let subtree1 = subtree_left dimension_tree in
	let subtree2 = subtree_right dimension_tree in
	let d1 = get_root subtree1 in
	let d2 = get_root subtree2 in

	(* estimate stockage size for delay *)
	let delay_int = 1 + delay e2 + delay e1 in

	(* prepare stockage *)
	let memory_hashtbl = Hashtbl.create delay_int in
	let rate_list = ref (Array.to_list (Array.make (snd d1) 0)) in

	(** val apply_to : 'a -> ('a -> 'b) -> 'b *)
	let apply_to = fun t -> fun f -> f t in

	(** val get_value_fun_list : (int -> (int list) * (value list)) -> (int -> value) list *)		
	let get_value_fun_list = fun beam_fun -> 
		let tmp = fun beam_fun -> fun i -> fun t -> 
			List.nth (snd (beam_fun t)) i in
		List.map (tmp beam_fun) (Array.to_list (Array.init (snd d1) (fun n -> n))) in

	(** val make_signal : int -> (int -> value) -> signal, combines rate and function. *)
	let make_signal = fun rate -> fun f -> (rate, f) in

	(** val output_beam_fun : int -> (int list) * (value list), with
	input : time
	output: rate list * value list *)
	let rec output_beam_fun = fun t ->

	        (* initial value in constrctor "rec '~'" *)
		if t < 0 then
			let init_rate_list = Array.to_list (Array.make (snd d1) 0) in
			let value_list = Array.to_list (Array.make (snd d1) Zero) in
			(init_rate_list, value_list)

		(* check stockage at time t *)
		else if Hashtbl.mem memory_hashtbl t then 
		        (!rate_list, Hashtbl.find memory_hashtbl t)

		(* blocks : "a ~ b", calculate rate list and value list at time t *)
		else 	
		        (* mid_output_fun_list : (int -> value) list *)
			let mid_output_fun_list = get_value_fun_list output_beam_fun in

			(* b_input_fun_list : (int -> value) list *)
			let b_input_fun_list = List.map 
			    (fun s -> fun t -> s (t - 1)) 
			    (sublist mid_output_fun_list 0 (fst d2)) in

			(* b_input_beam : signal list *)
			let b_input_beam = List.map2 make_signal 
			    (sublist !rate_list 0 (fst d2))
			    b_input_fun_list in

			(* evaluation of block "b" *)
			let b_output_beam = (eval e2 subtree2 b_input_beam) in

			(* evaluation of block "a" *)
			let a_input_beam = b_output_beam @ input_beam in
			let mid_output_beam = eval e1 subtree1 a_input_beam in

			(* calculate rate list and value list at time t *)
			let mid_output_rate_list = List.map fst mid_output_beam in
			let mid_output_value_list = List.map (apply_to t) (List.map snd mid_output_beam) in

			(* update stockage *)
			let () = (rate_list := mid_output_rate_list) in
			let () = Hashtbl.add memory_hashtbl t mid_output_value_list in
			let () = Hashtbl.remove memory_hashtbl (t - delay_int) in
			(mid_output_rate_list, mid_output_value_list) in

	(* output_beam : signal list *)
	let output_beam = List.map2 make_signal !rate_list (get_value_fun_list output_beam_fun) in
	output_beam in


        (** Call for previous functions *)
	match exp_faust with
	|Const v -> interpret_const v input_beam
	|Ident s -> interpret_ident s input_beam
	|Par (e1, e2) -> interpret_par e1 e2 dimension_tree input_beam
	|Seq (e1, e2) -> interpret_seq e1 e2 dimension_tree input_beam
	|Split (e1, e2) -> interpret_split e1 e2 dimension_tree input_beam
	|Merge (e1, e2) -> interpret_merge e1 e2 dimension_tree input_beam
	|Rec (e1, e2) -> interpret_rec e1 e2 dimension_tree input_beam;;


(** val extract_rate : (int * (int -> value)) list -> int list,
gets the sample rate list from beam.*)
let extract_rate = fun beam ->
  	let rate_naive_list = List.map fst beam in
	let correct_rate r = 
		if r = 0 then 44100 
		else if r > 0 then r
		else raise (Evaluation_Error "Rec2")
	in
	let rate_list = List.map correct_rate rate_naive_list in
	rate_list;;


(** val interpreter : faust_exp -> (int list) * (float array list) -> 
(int list) * (int list) * (float array list)
input: faust expression, sample rate list * input data list
output: channel list * sample rate list * output data list.*)
let interpreter exp_faust input = 
	let () = print_string("    Faustine -> Interpretation...") in
	let tic = Sys.time () in

	(* make input beam *)
	let input_beam = make_beam input in

	(* estimate process dimension *)
	let dimension_tree = dim exp_faust in

	(* interprete output beam *)
	let output_beam = eval exp_faust dimension_tree input_beam in
	let toc = Sys.time () in
	let () = print_endline(" Done.    (duration: " ^ (string_of_float (toc -. tic)) ^ "s)") in

	(* get rate list from output beam *)
	let rate_list = extract_rate output_beam in

	(* get channel list and data list from output beam *)
	let (channel_list, float_array_list) = compute (List.map snd output_beam) in
		(channel_list, rate_list, float_array_list);;