From 440ca0ba93966e89b68dc54207c461afc0d56264 Mon Sep 17 00:00:00 2001 From: WANG Date: Mon, 29 Jul 2013 18:00:24 +0200 Subject: [PATCH] OOP initial commit. --- interpretor/Makefile | 6 +- interpretor/faustexp.ml | 80 +++++- interpretor/lexer.mll | 62 +++-- interpretor/signal.ml | 525 +++++++++++++++------------------------- interpretor/types.ml | 149 ++++++++---- interpretor/value.ml | 519 ++++----------------------------------- 6 files changed, 464 insertions(+), 877 deletions(-) diff --git a/interpretor/Makefile b/interpretor/Makefile index 56a213b..d9be60a 100644 --- a/interpretor/Makefile +++ b/interpretor/Makefile @@ -2,11 +2,11 @@ # # The Caml sources (including camlyacc and camllex source files) -SOURCES = types.ml parser.mly lexer.mll value.ml signal.ml faustexp.ml interpreter.ml preprocess.ml main.ml preprocess_stubs.cpp +SOURCES = types.ml parser.mly lexer.mll basic.ml value.ml signal.ml beam.ml faustexp.ml interpreter.ml preprocess.ml main.ml preprocess_stubs.cpp # The executable file to generate -EXEC = faustine +EXEC = mrfausti # Path to ocaml include header files export OCAML_INCLUDE_PATH @@ -15,7 +15,7 @@ export OCAML_INCLUDE_PATH #SNDFILE_PATH = /home/wang/Desktop/libsndfile-ocaml export SNDFILE_PATH -# Path to Faust.mr3 +# Path to Faust.mr2 FAUST_PATH = faust-0.9.47mr3 # Path to preprocessor library diff --git a/interpretor/faustexp.ml b/interpretor/faustexp.ml index 5904569..6b324a0 100644 --- a/interpretor/faustexp.ml +++ b/interpretor/faustexp.ml @@ -8,15 +8,77 @@ open Types;; open Value;; -(* EXCEPTIONS *) -(** Exception raised in beam matching of faust expressions.*) -exception Beam_Matching_Error of string;; - -(** Exception raised in case that the branch under call hasn't yet been programed.*) exception NotYetDone;; + +class virtual expression : expression_type = + fun (exp_init : faust_exp) -> + object + val exp = exp_init + val dim = new dimension + val delay = 0 + method get_exp = exp + method get_dim = dim + method get_delay = delay + method to_string = "NotYetDone" + method virtual evaluate : beam_type -> beam_type +end;; + + +class exp_const = + object + inherit expression + method evaluate = fun b1 -> + + end;; + + +class exp_ident = + object + inherit expression + + end;; + + +class exp_par = + object + inherit expression + + end;; + + +class exp_split = + object + inherit expression + + end;; + + +class exp_merge = + object + inherit expression + + end;; + +class exp_seq = + object + inherit expression + + end;; + +class exp_rec = + object + inherit expression + + end;; + + + + + + (* PROCESS DELAY ESTIMATION *) (** val delay : faust_exp -> int, returns the number of delays estimated staticly. @@ -39,10 +101,6 @@ let rec delay exp_faust = match exp_faust with |Floor -> 0 |Int -> 0 |Sin -> 0 - |Cos -> 0 - |Atan -> 0 - |Atantwo -> 0 - |Sqrt -> 0 |Rdtable -> 100000 (* danger! *) |Mod -> 0 |Larger -> 0 @@ -163,10 +221,6 @@ returns the dimension tree of constructor(e1, e2).*) |Floor -> End (1, 1) |Int -> End (1, 1) |Sin -> End (1, 1) - |Cos -> End (1, 1) - |Atan -> End (1, 1) - |Atantwo -> End (2, 1) - |Sqrt -> End (1, 1) |Rdtable -> End (3, 1) |Mod -> End (2, 1) |Vectorize -> End (2, 1) diff --git a/interpretor/lexer.mll b/interpretor/lexer.mll index a3a4746..c6a7cb5 100644 --- a/interpretor/lexer.mll +++ b/interpretor/lexer.mll @@ -1,18 +1,48 @@ -{open Parser} +{ +open Parser +open Types +} rule token = parse - [' ' '\t' '\n' ] { token lexbuf } -| ['a'-'z' 'A'-'Z']+ as x { IDENT x } -| ['+' '*' '-' '/' '!' '_' '#' - '@' '<' '>' '%'] as x { IDENT (String.make 1 x) } -| "[]" { IDENT "[]" } -| ['0'-'9']+ as a { CONST a } -| '.' { POINT } -| '(' { LPAR } -| ')' { RPAR } -| ',' { PAR } -| ':' { SEQ } -| "<:" { SPLIT } -| ":>" { MERGE } -| "~" { REC } -| eof { EOF } + [' ' '\t' '\n' ] { token lexbuf } + +| "+" { IDENT Add} +| "-" { IDENT Sup} +| "*" { IDENT Mul} +| "/" { IDENT Div} +| "_" { IDENT Pass} +| "!" { IDENT Stop} +| "mem" { IDENT Mem} +| "@" { IDENT Delay} +| "floor" { IDENT Floor} +| "int" { IDENT Int} +| "sin" { IDENT Sin} +| "cos" { IDENT Cos} +| "atan" { IDENT Atan} +| "atantwo" { IDENT Atantwo} +| "sqrt" { IDENT Sqrt} +| "rdtable" { IDENT Rdtable} +| "%" { IDENT Mod} +| "vectorize" { IDENT Vectorize} +| "#" { IDENT Vconcat} +| "[]" { IDENT Vpick } +| "serialize" { IDENT Serialize} +| ">" { IDENT Larger} +| "<" { IDENT Smaller} +| "prefix" { IDENT Prefix} +| "selecttwo" { IDENT Selecttwo} +| "selectthree" { IDENT Selectthree} + + +| ['0'-'9']+ as a { CONST a } +| '.' { POINT } + + +| '(' { LPAR } +| ')' { RPAR } +| ',' { PAR } +| ':' { SEQ } +| "<:" { SPLIT } +| ":>" { MERGE } +| "~" { REC } +| eof { EOF } diff --git a/interpretor/signal.ml b/interpretor/signal.ml index 3440adc..b493b6c 100644 --- a/interpretor/signal.ml +++ b/interpretor/signal.ml @@ -1,339 +1,208 @@ (** Module: Signal - Description: type signal = rate * (int -> value), operations of signals. + Description: signal definition and operations. @author WANG Haisheng Created: 03/06/2013 Modified: 03/06/2013 *) open Types;; +open Basic;; open Value;; -(* EXCEPTIONS *) - -(** Exception raised in operations of signals.*) exception Signal_operation of string;; - - -(* MACRO *) - -(** Macro constants of the file.*) -type signal_macro = Delay_Memory_Length_int;; - - -(** val signal_macro_to_int : signal_macro -> int.*) -let signal_macro_to_int m = match m with - |Delay_Memory_Length_int -> 10000;; - - -(* SIGNAL OPERATIONS *) - -(** val frequency : signal -> int, returns the frequency of a signal.*) -let frequency s = fst s;; - - -(** val signal_fun : signal -> (int -> value), returns the functional part of a signal.*) -let signal_fun s = snd s;; - - -(** val check_frequency : int -> int -> int, returns the correction of frequency.*) -let check_frequency = fun f1 -> fun f2 -> - if f1 = f2 || f2 = 0 then f1 - else if f1 = 0 then f2 - else raise (Signal_operation "frequency not matched.");; - -(** val signal_check_frequency : signal -> signal -> int, -checks the frequencies of two input signals, and returns common frequency or raise an exception.*) -let signal_check_frequency = fun s1 -> fun s2 -> - let f1 = frequency s1 in - let f2 = frequency s2 in - check_frequency f1 f2;; - - -(** val signal_check_frequency3 : signal -> signal -> signal -> int, -checks the frequencies of three input signal, and returns common frequency or raise an exception.*) -let signal_check_frequency3 = fun s1 -> fun s2 -> fun s3 -> - let f1 = signal_check_frequency s1 s2 in - let f2 = signal_check_frequency s1 s3 in - check_frequency f1 f2;; - - -(** val signal_check_frequency4 : signal -> signal -> signal -> signal -> int, -checks the frequencies of three input signal, and returns common frequency or raise an exception.*) -let signal_check_frequency4 = fun s1 -> fun s2 -> fun s3 -> fun s4 -> - let f1 = signal_check_frequency s1 s2 in - let f2 = signal_check_frequency s3 s4 in - check_frequency f1 f2;; - - -(** val signal_add_one_memory : signal -> signal, -returns the signal with memory of one latest sample.*) -let signal_add_one_memory = fun s -> - let new_signal = factory_add_memory (signal_fun s) 1 in - (frequency s, new_signal);; - - -(** val beam_add_one_memory : signal list -> signal list, -adds memory of one latest sample for each element in signal list.*) -let beam_add_one_memory = fun beam -> - List.map signal_add_one_memory beam;; - - -(** val signal_add : signal -> signal -> signal, output(t) = input1(t) + input2(t), - frequency consistent.*) -let signal_add s1 s2 = - let f = signal_check_frequency s1 s2 in - let new_signal = fun t -> ((signal_fun s1) t) +~ ((signal_fun s2) t) in - (f, new_signal);; - - -(** val signal_neg : signal -> signal, output(t) = -input(t), frequency consistent.*) -let signal_neg s = - let new_signal = fun t -> v_neg ((signal_fun s) t) in - (frequency s, new_signal);; - - -(** val signal_sub : signal -> signal -> signal, output(t) = input1(t) - input2(t), - frequency consistent.*) -let signal_sub s1 s2 = signal_add s1 (signal_neg s2);; - - -(** val signal_mul : signal -> signal -> signal, output(t) = input1(t) * input2(t), - frequency consistent.*) -let signal_mul s1 s2 = - let f = signal_check_frequency s1 s2 in - let new_signal = fun t -> ((signal_fun s1) t) *~ ((signal_fun s2) t) in - (f, new_signal);; - - -(** val signal_div : signal -> signal -> signal, output(t) = input1(t) / input2(t), - frequency consistent.*) -let signal_div s1 s2 = - let f = signal_check_frequency s1 s2 in - let new_signal = fun t -> ((signal_fun s1) t) /~ ((signal_fun s2) t) in - (f, new_signal);; - - -(** val signal_delay : signal -> signal -> signal, output(t) = input1(t - input2(t)), - Attention: delay dynamic, frequency of output signal equals to that of first input signal.*) -let signal_delay s1 s2 = - let s1_mem = factory_add_memory (signal_fun s1) - (signal_macro_to_int Delay_Memory_Length_int) in - let new_signal = fun t -> - let delay = (signal_fun s2) t in - match delay with - |N i -> if i < 0 then raise (Signal_operation "Delay time < 0.") - else if (t - i) >= 0 then s1_mem (t - i) - else v_zero (s1_mem 0) - |R f -> let i = int_of_float f in - if i < 0 then raise (Signal_operation "Delay time < 0.") - else if (t - i) >= 0 then s1_mem (t - i) - else v_zero (s1_mem 0) - |Vec (size, vec) -> raise (Signal_operation "Delay time can not be a vector.") - |Zero -> s1_mem t - |W -> raise (Signal_operation "Delay time error.") - in - (frequency s1, new_signal);; - - -(** val signal_mem : signal -> signal, equivalent to signal_delay with constant delay 1.*) -let signal_mem s = signal_delay s (1, (fun t -> N 1));; - - -(** val signal_vectorize : signal -> signal -> signal, output(t)(i) = input1(input2(0) * t + i), -Attention: vector size n static, frequency of output signal is (1/n * frequency of input1)*) -let signal_vectorize s1 s2 = - let size = (signal_fun s2) 0 in - match size with - |N size_int -> - ( - let new_signal = fun t -> - make_vector size_int (fun i -> (signal_fun s1) (size_int * t + i)) in - let new_frequency = (frequency s1) / size_int in - (new_frequency, new_signal) - ) - |_ -> raise (Signal_operation "Vectorize: vector size should be int.");; - - -(** val signal_serialize : signal -> signal, output(t) = input(floor(t/n))(t%n), - with n = size of input(0). - Attention: input size unknown in the cas of "rec".*) -let signal_serialize s = - let temp0 = (signal_fun s) 0 in - match temp0 with - |Vec (size0, vec0) -> - let new_signal = fun t -> - ( - let temp = (signal_fun s) (t/size0) in - match temp with - |Vec (size, vec) -> - if size = size0 then - vec (t mod size) - else - raise (Signal_operation "Serialize: vector length not consistent.") - |_ -> raise (Signal_operation "Serialize: signal type not consistent.") - ) - in - let new_frequency = (frequency s) * size0 in - (new_frequency, new_signal) - |_ -> raise (Signal_operation "Serialize: input signal should be vector.");; - - -(** val signal_append : signal -> signal -> signal, symbol "#", - appends vectors of the two input signals at each time, frequency consistent.*) -let signal_append s1 s2 = - let f = signal_check_frequency s1 s2 in - let new_signal = fun t -> - let temp1 = (signal_fun s1) t in - let temp2 = (signal_fun s2) t in - match (temp1, temp2) with - |(Vec (size1, vec1), Vec (size2, vec2)) -> - let new_vec = fun i -> if i < size1 then vec1 i else vec2 (i - size1) in - make_vector (size1 + size2) new_vec - |_ -> raise (Signal_operation "Append: input signals should be vectors.") - in - (f, new_signal);; - - -(** val signal_nth : signal -> signal -> signal, symbol "[]", output(t) = input1(t)(input2(t)), - frequency consistent. Attention: selection index dynamic.*) -let signal_nth s1 s2 = - let f = signal_check_frequency s1 s2 in - let new_signal = fun t -> - let temp1 = (signal_fun s1) t in - let temp2 = (signal_fun s2) t in - match temp1 with - |Vec (size1, vec1) -> - ( - match temp2 with - |N i -> vec1 i - |R f -> - raise (Signal_operation "Get: second input signal should be int.") - |Vec (size2, vec2) -> - raise (Signal_operation "Get: second input signal should be int.") - |Zero -> vec1 0 - |W -> - raise (Signal_operation "Get: second input signal should be int.") - ) - |_ -> raise (Signal_operation "Get: first input signal should be vector.") - in - (f, new_signal);; - - -(** val signal_floor : signal -> signal, output(t) = v_floor(input(t)), frequency consistent.*) -let signal_floor s = - let new_signal = fun t -> v_floor ((signal_fun s) t) in - (frequency s, new_signal);; - - -(** val signal_int : signal -> signal, output(t) = v_int(input(t)), frequency consistent.*) -let signal_int s = - let new_signal = fun t -> v_int ((signal_fun s) t) in - (frequency s, new_signal);; - - -(** val signal_sin : signal -> signal, output(t) = v_sin(input(t)), frequency consistent.*) -let signal_sin s = - let new_signal = fun t -> v_sin ((signal_fun s) t) in - (frequency s, new_signal);; - - -(** val signal_cos : signal -> signal, output(t) = v_cos(input(t)), frequency consistent.*) -let signal_cos s = - let new_signal = fun t -> v_cos ((signal_fun s) t) in - (frequency s, new_signal);; - - -(** val signal_atan : signal -> signal, output(t) = v_atan(input(t)), frequency consistent.*) -let signal_atan s = - let new_signal = fun t -> v_atan ((signal_fun s) t) in - (frequency s, new_signal);; - - -let signal_atantwo s1 s2 = - let new_signal = fun t -> v_atantwo ((signal_fun s1) t) ((signal_fun s2) t) in - (frequency s1, new_signal);; - - -(** val signal_sqrt : signal -> signal, output(t) = v_sqrt(input(t)), frequency consistent.*) -let signal_sqrt s = - let new_signal = fun t -> v_sqrt ((signal_fun s) t) in - (frequency s, new_signal);; - - -(** val signal_rdtable : signal -> signal -> signal, - output(t) = input1(input2(t)), frequency equals to that of input2. - Attention: no memory implemented, very expensive when input1 comes from rec or delays.*) -let signal_rdtable s0 s1 s2 = - let memory_length_int = take_off_N ((signal_fun s0) 0) in - let s1_mem = factory_add_memory (signal_fun s1) memory_length_int in - let new_signal = fun t -> - let index = (signal_fun s2) t in - match index with - |N i -> s1_mem i - |R f -> raise (Signal_operation "Rdtable index cannot be float.") - |Vec (size, vec) -> raise (Signal_operation "Rdtable index cannot be vector.") - |Zero -> s1_mem 0 - |W -> raise (Signal_operation "Rdtable index cannot be Error.") - in - (frequency s2, new_signal);; - - -(** val signal_mod : signal -> signal -> signal, - output(t) = input1(t) % input2(t), frequency consistent.*) -let signal_mod s1 s2 = - let f = signal_check_frequency s1 s2 in - let new_signal = fun t -> v_mod ((signal_fun s1) t) ((signal_fun s2) t) in - (f, new_signal);; - - -(** val signal_sup : signal -> signal -> signal, - output(t) = input1(t) > input2(t), frequency consistent.*) -let signal_sup s1 s2 = - let f = signal_check_frequency s1 s2 in - let new_signal = fun t -> v_sup ((signal_fun s1) t) ((signal_fun s2) t) in - (f, new_signal);; - - -(** val signal_inf : signal -> signal -> signal, - output(t) = input1(t) < input2(t), frequency consistent.*) -let signal_inf s1 s2 = - let f = signal_check_frequency s1 s2 in - let new_signal = fun t -> v_inf ((signal_fun s1) t) ((signal_fun s2) t) in - (f, new_signal);; - - -(** val signal_select2 : signal -> signal -> signal -> signal, -[signal_select2 si s0 s1] selects s0 or s1 by index si, frequency consistent.*) -let signal_select2 si s0 s1 = - let f = signal_check_frequency3 si s0 s1 in - let new_signal = fun t -> - if (signal_fun si) t = N 0 then (signal_fun s0) t - else if (signal_fun si) t = N 1 then (signal_fun s1) t - else raise (Signal_operation "select2 index should be 0 or 1.") - in - (f, new_signal);; - - -(** val signal_select3 : signal -> signal -> signal -> signal -> signal, -[signal_select3 si s0 s1 s2] selects s0 or s1 or s2 by index si, frequency consistent.*) -let signal_select3 si s0 s1 s2 = - let f = signal_check_frequency4 si s0 s1 s2 in - let new_signal = fun t -> - if (signal_fun si) t = N 0 then (signal_fun s0) t - else if (signal_fun si) t = N 1 then (signal_fun s1) t - else if (signal_fun si) t = N 2 then (signal_fun s2) t - else raise (Signal_operation "select3 index should be 0 or 1 or 2.") - in - (f, new_signal);; - - -(** val signal_prefix : signal -> signal -> signal, -[signal_prefix s0 s1] returns s0(0) if t = 0, s1(t-1) if t > 0, frequency same to s1.*) -let signal_prefix = fun s0 -> fun s1 -> - let new_signal = fun t -> - if t = 0 then (signal_fun s0) 0 - else if t > 0 then (signal_fun s1) t - else raise (Signal_operation "prefix time cannot be < 0.") - in - (frequency s1, new_signal);; +let delay_memory_length = 10000;; + +class signal : int -> (time -> value_type) -> signal_type = + fun (freq_init : int) -> + fun (func_init : time -> value_type) -> + object (self) + val mutable signal_func = func_init + val mutable memory_length = 0 + method frequency = freq_init + method at = signal_func + + method private check_freq : signal_type list -> int = + fun (sl : signal_type list) -> + let check : int -> signal_type -> int = + fun (f : int) -> + fun (s : signal_type) -> + if f = s#frequency || s#frequency = 0 then f + else if f = 0 then s#frequency + else raise (Signal_operation "frequency not matched.") in + List.fold_left check self#frequency sl + + method private add_memory : int -> unit = + fun (length : int) -> + assert (length >= 0); + if memory_length >= length then () + else + let memory = Hashtbl.create length in + let func : time -> value = + fun (t : time) -> + try Hashtbl.find memory t + with Not_found -> + let result = func_init t in + let () = Hashtbl.replace memory t result in + let () = + if (t - length) >= 0 then + Hashtbl.remove memory (t - length) + else () in + result in + memory_length <- length; + signal_func <- func + + method private delay_by : int -> time -> value = + fun i -> fun t -> + if (t - i) >= 0 then + self#at (t - i) + else if t >= 0 && (t - i) < 0 then + (self#at 0)#zero + else raise (Signal_operation "Delay time < 0.") + + method private prim1 : + (time -> value_type) -> signal_type = + fun (func : time -> value_type) -> + let freq = self#frequency in + new signal freq func + + method private prim2 : + (time -> value_type -> value_type) -> signal_type -> signal_type = + fun (func_binary : time -> value_type -> value_type) -> + fun (s : signal_type) -> + let freq = self#check_freq [s] in + let func = fun t -> (func_binary t) (s#at t) in + new signal freq func + + method neg = self#prim1 (fun t -> (self#at t)#neg) + method floor = self#prim1 (fun t -> (self#at t)#floor) + method sin = self#prim1 (fun t -> (self#at t)#sin) + method cos = self#prim1 (fun t -> (self#at t)#cos) + method atan = self#prim1 (fun t -> (self#at t)#atan) + method sqrt = self#prim1 (fun t -> (self#at t)#sqrt) + method int = self#prim1 (fun t -> (self#at t)#int) + + method add = self#prim2 (fun t -> (self#at t)#add) + method sub = self#prim2 (fun t -> (self#at t)#sub) + method mul = self#prim2 (fun t -> (self#at t)#mul) + method div = self#prim2 (fun t -> (self#at t)#div) + method atan2 = self#prim2 (fun t -> (self#at t)#atan2) + method _mod = self#prim2 (fun t -> (self#at t)#_mod) + method larger = self#prim2 (fun t -> (self#at t)#larger) + method smaller = self#prim2 (fun t -> (self#at t)#smaller) + + method delay : signal_type -> signal_type = + fun (s : signal_type) -> + let freq = self#check_freq [s] in + let () = self#add_memory delay_memory_length in + let func : time -> value_type = + fun (t : time) -> + let i = (s#at t)#to_int in + self#delay_by t i in + new signal freq func + + method mem : signal_type = + let freq = self#frequency in + let () = self#add_memory 1 in + let func = fun (t : time) -> self#delay_by t 1 in + new signal freq func + + method rdtable : signal_type -> signal_type -> signal_type = + fun (s_size : signal_type) -> + fun (s_index : signal_type) -> + let freq = self#check_freq [s_index] in + let () = self#add_memory ((s_size#at 0)#to_int) in + let func : time -> value_type = fun t -> + self#at ((s_index#at t)#to_int) in + new signal freq func + + method select2 : signal_type -> signal_type -> signal_type = + fun s_first -> + fun s_second -> + let freq = self#check_freq [s_first; s_second] in + let func : time -> value_type = + fun t -> let i = (self#at t)#to_int in + if i = 0 then s_first#at t + else if i = 1 then s_second#at t + else raise (Signal_operation "select2 index 0|1.") in + new signal freq func + + method select3 : + signal_type -> signal_type -> signal_type -> signal_type = + fun s_first -> fun s_second -> fun s_third -> + let freq = self#check_freq [s_first; s_second; s_third] in + let func : time -> value_type = + fun t -> let i = (self#at t)#to_int in + if i = 0 then s_first#at t + else if i = 1 then s_second#at t + else if i = 2 then s_third#at t + else raise (Signal_operation "select2 index 0|1.") in + new signal freq func + + method prefix : signal_type -> signal_type = + fun (s_init : signal_type) -> + let func : time -> value_type = + fun t -> + if t = 0 then s_init#at 0 + else if t > 0 then self#at t + else raise (Signal_operation "prefix time < 0.") in + new signal self#frequency func + + + method vectorize : signal_type -> signal_type = + fun s_size -> + let size = (s_size#at 0)#to_int in + if size <= 0 then + raise (Signal_operation "Vectorize: size <= 0.") + else + let freq = self#frequency / size in + let func : time -> value_type = + fun t -> + let vec = fun i -> (self#at (size * t + i))#get in + new value (Vec (new vector size vec)) in + new signal freq func + + + method serialize : signal_type = + let size = + match (self#at 0)#get with + | Vec vec -> vec#size + | _ -> raise (Signal_operation "Serialize: scalar input.") in + let freq = self#frequency * size in + let func : time -> value_type = + fun t -> + match (self#at (t/size))#get with + | Vec vec -> new value (vec#nth (t mod size)) + | _ -> raise (Signal_operation + "Serialize: signal type not consistent.") in + new signal freq func + + method vconcat : signal_type -> signal_type = + fun s -> + let freq = self#check_freq [s] in + let func : time -> value_type = + fun t -> + match ((self#at t)#get, (s#at t)#get) with + | (Vec vec1, Vec vec2) -> + let size1 = vec1#size in + let size2 = vec2#size in + let size = size1 + size2 in + let vec = fun i -> + if i < size1 then vec1#nth i + else vec2#nth (i - size1) in + new value (Vec (new vector size vec)) + | _ -> raise (Signal_operation "Vconcat: scalar.") in + new signal freq func + + method vpick : signal_type -> signal_type = + fun s_index -> + let freq = self#check_freq [s_index] in + let func : time -> value_type = + fun t -> + let i = (s_index#at t)#to_int in + match (self#at t)#get with + | Vec vec -> new value (vec#nth i) + | _ -> raise (Signal_operation "Vpick: scalar.") in + new signal freq func + + end;; diff --git a/interpretor/types.ml b/interpretor/types.ml index 5c2c29d..ba61990 100644 --- a/interpretor/types.ml +++ b/interpretor/types.ml @@ -1,10 +1,49 @@ -type value = N of int + +type index = int;; + +type time = int;; + +type basic = N of int | R of float - | Vec of int * (int -> value) + | Vec of vector | Zero - | W + | Error +and vector = < size : int; nth : (index -> basic) >;; + +class type vector_type = + object + method size : int + method nth : index -> basic + end;; + +class type value_type = + object + method get : basic + method to_int : int + method to_float : float + method to_float_array : float array + method to_string : string + method normalize : unit + method add : value_type -> value_type + method neg : value_type + method sub : value_type -> value_type + method mul : value_type -> value_type + method recip : value_type + method div : value_type -> value_type + method zero : value_type + method floor : value_type + method int : value_type + method sin : value_type + method cos : value_type + method atan : value_type + method sqrt : value_type + method atan2 : value_type -> value_type + method _mod : value_type -> value_type + method larger : value_type -> value_type + method smaller : value_type -> value_type + end;; + -(** type symbol, defines valid identifiers in faust expressions.*) type symbol = Add | Sup | Mul @@ -23,8 +62,8 @@ type symbol = Add | Rdtable | Mod | Vectorize - | Concat - | Nth + | Vconcat + | Vpick | Serialize | Larger | Smaller @@ -32,45 +71,9 @@ type symbol = Add | Selecttwo | Selectthree -exception Symbol_not_defined;; - -let symbol_of_string = fun s -> - match s with - |"+" -> Add - |"-" -> Sup - |"*" -> Mul - |"/" -> Div - |"_" -> Pass - |"!" -> Stop - |"mem" -> Mem - |"@" -> Delay - |"floor" -> Floor - |"int" -> Int - |"sin" -> Sin - |"cos" -> Cos - |"atan" -> Atan - |"atantwo" -> Atantwo - |"sqrt" -> Sqrt - |"rdtable" -> Rdtable - |"%" -> Mod - |"vectorize" -> Vectorize - |"#" -> Concat - |"[]" -> Nth - |"serialize" -> Serialize - |">" -> Larger - |"<" -> Smaller - |"prefix" -> Prefix - |"selecttwo" -> Selecttwo - |"selectthree" -> Selectthree - | _ -> raise Symbol_not_defined - - - -type signal = int * (int -> value) - type faust_exp = - Const of value + Const of basic | Ident of symbol | Par of faust_exp * faust_exp | Seq of faust_exp * faust_exp @@ -79,5 +82,61 @@ type faust_exp = | Merge of faust_exp * faust_exp -type dimension = End of (int * int) - | Tree of (int * int) * (dimension * dimension) +class type signal_type = + object + method frequency : int + method at : time -> value_type + method add : signal_type -> signal_type + method neg : signal_type + method sub : signal_type -> signal_type + method mul : signal_type -> signal_type + method div : signal_type -> signal_type + method delay : signal_type -> signal_type + method mem : signal_type + method vectorize : signal_type -> signal_type + method serialize : signal_type + method vconcat : signal_type -> signal_type + method vpick : signal_type -> signal_type + method floor : signal_type + method int : signal_type + method sin : signal_type + method cos : signal_type + method atan : signal_type + method atan2 : signal_type -> signal_type + method sqrt : signal_type + method _mod : signal_type -> signal_type + method larger : signal_type -> signal_type + method smaller : signal_type -> signal_type + method rdtable : signal_type -> signal_type -> signal_type + method select2 : signal_type -> signal_type -> signal_type + method select3 : signal_type -> signal_type -> signal_type -> signal_type + method prefix : signal_type -> signal_type + end;; + + +class type beam_type = + object + method length : int + method sub : start: int -> length: int -> beam_type + method append : beam_type -> beam_type + method matching : size: int -> beam_type + method time : time -> basic list + method output : length: int -> (int list) * (float array list) + end;; + + +class type dimension_type = + object + method input : int + method output : int + end;; + + +class type expression_type = + object + method get_exp : faust_exp + method get_dim : dimension_type + method get_delay : int + method to_string : string + method evaluate : beam_type -> beam_type + end;; diff --git a/interpretor/value.ml b/interpretor/value.ml index 1701b4e..a13739e 100644 --- a/interpretor/value.ml +++ b/interpretor/value.ml @@ -2,479 +2,54 @@ Module: Value Description: basic data type in the vectorial faust interpreter. @author WANG Haisheng - Created: 31/05/2013 Modified: 03/06/2013 + Created: 31/05/2013 Modified: 17/07/2013 *) open Types;; - -(* EXCEPTIONS *) - -(** Exception raised in convertions between float/int and type 'Value'.*) -exception Convert_Error of string;; - -(** Exception raised in type 'Value' operations.*) -exception Value_operation of string;; - - -(* MACRO *) - -(** Macro constants of the file.*) -type value_macro = Faust_Max_int - | Faust_Min_int - | Faust_Bits_int;; - -(** val value_macro_to_value : value_macro -> int.*) -let value_macro_to_int m = match m with - |Faust_Max_int -> 2147483647 - |Faust_Min_int -> -2147483648 - |Faust_Bits_int -> 32;; - - -(* VALUE CONVERT FUNCTIONS *) - -(** val return_N : int -> value, convert from int to value N.*) -let return_N i = N i;; - -(** val return_R : float -> value, convert from float to value R.*) -let return_R f = R f;; - -(** val return_Vec : int * (int -> value) -> value, convert (size, vec) to value Vec.*) -let return_Vec (size, vec) = Vec (size, vec);; - -(** val fail, return value W.*) -let fail = W;; - -(** val take_off_N : value -> int, convert from value N to int. -Attention: Zero and W are converted to 0.*) -let rec take_off_N v = - match v with - |N i -> i - |R f -> - raise (Convert_Error "float take_off_N int") - |Vec (size, vec) -> - raise (Convert_Error "take_off_N can not convert vector.") - |Zero -> 0 - |W -> 0;; (* Danger! *) - -(** val take_off_R : value -> float, convert from value R to float. -Attention: Zero and W are converted to 0.0, int converted to float.*) -let take_off_R v = - match v with - |N i -> float_of_int i - |R f -> f - |Vec (size, vec) -> - raise (Convert_Error "take_off_R can not convert vector.") - |Zero -> 0. - |W -> 0.;; - -(** val convert_back_r : value -> float array, -return a float array of size 1 if v is N|R|Zero|W, a float array of size n if v is Vec.*) -let convert_back_R v = - match v with - |N i -> [| float_of_int i |] - |R f -> [| f |] - (** realise the function int -> value into float list.*) - |Vec (size, vec) -> - let result_value_array = Array.init size vec in - let result_float_array = Array.map take_off_R result_value_array in - result_float_array - |Zero -> [| 0. |] - |W -> [| 0. |];; - - - -(* AUXILIARY FUNCTIONS*) - -(** val string_of_value : value -> string, converts value to following -strings "N i" | "R f" | "Vec" | "Zero" | "W".*) -let rec string_of_value v = match v with - |N i1 -> "N " ^ (string_of_int i1) - |R f1 -> "R " ^ (string_of_float f1) - |Vec (size, vec) -> "Vec" - |Zero -> "Zero" - |W -> "W";; - -(** val print_value_list: value list -> unit, prints to console the value list.*) -let print_value_list value_list = - let s = ref "[" in - let n = List.length value_list in - for i = 0 to n - 1 do - let current = List.nth value_list i in - s := if i + 1 < n then !s ^ string_of_value current ^ "; " - else !s ^ string_of_value current ^ "]" - done; - print_endline !s;; - - -(** val factory_add_memory : (int -> 'b) -> int -> (int -> 'b), -[factory_add_memory f n] adds a memory of size n to fun f.*) -let factory_add_memory = fun f -> fun n -> - if n > 0 then - ( - let memory = Hashtbl.create n in - let new_fun = fun i -> - try Hashtbl.find memory i - with Not_found -> - let result = f i in - let () = Hashtbl.replace memory i result in - let () = Hashtbl.remove memory (i - n) in - result - in - new_fun - ) - else raise (Value_operation "memory length cannot be < 0." );; - - -(** val v_memory : value -> value, returns value Vec with memory.*) -let v_memory v = match v with - | Vec (size, vec) -> - let memory_array = Array.create size W in - let index_array = Array.create size false in - let new_vec = fun i -> - if i >= 0 && i < size then - ( - if index_array.(i) then - memory_array.(i) - else - let result = vec i in - let () = memory_array.(i) <- result in - let () = index_array.(i) <- true in - result - ) - else raise (Invalid_argument "vector overflow.") - in - return_Vec (size, new_vec) - | _ -> v;; - - -(** val v_list_memory : value list -> value list, returns value list with memory. *) -let v_list_memory vl = List.map v_memory vl;; - - -(** val make_vector : int -> (int -> value) -> value, -[make_vector size vec], return a value Vec of (size, vec).*) -let make_vector = fun size -> fun vec -> - let new_vec = fun i -> - if i >= 0 && i < size then vec i - else raise (Value_operation "vector overflow") - in - v_memory (return_Vec (size, new_vec));; - - -(* VALUE OPERATIONS *) - -(** val normalize: value -> value, normalize value to bounded [-2147483648,2147483647].*) -let rec normalize v = - let n = 2. ** float_of_int (value_macro_to_int Faust_Bits_int) in - match v with - |N i -> - if i > value_macro_to_int Faust_Max_int then - return_N (i - int_of_float (n *. floor (((float_of_int i) +. n/.2.)/.n))) - else if i < value_macro_to_int Faust_Min_int then - return_N (i + int_of_float (n *. floor ((n/.2. -. (float_of_int i) -. 1.)/.n))) - else return_N i - |R f -> - if f > float_of_int (value_macro_to_int Faust_Max_int) then - return_R (f -. (n *. floor ((f +. n/.2.)/.n))) - else if f < float_of_int (value_macro_to_int Faust_Min_int) then - return_R (f +. (n *. floor ((n/.2. -. f -. 1.)/.n))) - else return_R f - |Vec (size, vec) -> make_vector size (fun i -> normalize (vec i)) - |Zero -> Zero - |W -> W;; - - -(** val v_add : value -> value -> value, value addition, recursive for value.Vec.*) -let rec v_add v1 v2 = match v1 with - |Vec (size1, vec1) -> - ( - match v2 with - |Vec (size2, vec2) -> - if size1 = size2 then - make_vector size1 (fun i -> v_add (vec1 i) (vec2 i)) - else raise (Value_operation "vector size not matched.") - |Zero -> v1 - |_ -> raise (Value_operation "Vector_Scalar vec1 +~ sca2") - ) - |N i1 -> - ( - match v2 with - |N i2 -> normalize (return_N (i1 + i2)) - |R f2 -> normalize (return_R ((float_of_int i1) +. f2)) - |Vec (size2, vec2) -> raise (Value_operation "Vector_Scalar i1 +~ vec2") - |Zero -> v1 - |W -> fail - ) - |R f1 -> - ( - match v2 with - |N i2 -> normalize (return_R (f1 +. (float_of_int i2))) - |R f2 -> normalize (return_R (f1 +. f2)) - |Vec (size2, vec2) -> raise (Value_operation "Vector_Scalar f1 +~ vec2") - |Zero -> v1 - |W -> fail - ) - |Zero -> v2 - |W -> - ( - match v2 with - |N i2 -> fail - |R f2 -> fail - |Vec (size2, vec2) -> raise (Value_operation "Vector_Scalar W +~ vec2") - |Zero -> v1 - |W -> fail - );; - - -(** val (+~) : value -> value -> value, operator of v_add.*) -let (+~) v1 v2 = v_add v1 v2;; - - -(** val v_neg : value -> value, v_neg v = -v.*) -let rec v_neg v = match v with - |N i -> return_N (-i) - |R f -> return_R (-.f) - |Vec (size, vec) -> make_vector size (fun i -> v_neg (vec i)) - |Zero -> Zero - |W -> fail;; - - -(** val v_sub : value -> value -> value, returns (v1 - v2).*) -let v_sub v1 v2 = v_add v1 (v_neg v2);; - - -(** val (-~) : value -> value -> value, operator of v_sub.*) -let (-~) v1 v2 = v_sub v1 v2;; - - -(** val v_mul : value -> value -> value, returns (v1 * v2), recursive for value.Vec.*) -let rec v_mul v1 v2 = match v1 with - |Vec (size1, vec1) -> - ( - match v2 with - |Vec (size2, vec2) -> - if size1 = size2 then - make_vector size1 (fun i -> v_mul (vec1 i) (vec2 i)) - else raise (Value_operation "vector size not matched.") - |Zero -> make_vector size1 (fun i -> v_mul (vec1 i) Zero) - |_ -> raise (Value_operation "Vector_Scalar vec1 *~ sca2") - ) - |N i1 -> - ( - match v2 with - |N i2 -> normalize (return_N (i1 * i2)) - |R f2 -> normalize (return_R ((float_of_int i1) *. f2)) - |Vec (size2, vec2) -> - raise (Value_operation "Vector_Scalar i1 *~ vec2") - |Zero -> return_N 0 - |W -> if i1 = 0 then N 0 else fail - ) - |R f1 -> - ( - match v2 with - |N i2 -> normalize (return_R (f1 *. (float_of_int i2))) - |R f2 -> normalize (return_R (f1 *. f2)) - |Vec (size2, vec2) -> - raise (Value_operation "Vector_Scalar f1 *~ vec2") - |Zero -> return_R 0. - |W -> if f1 = 0. then R 0. else fail - ) - |Zero -> - ( - match v2 with - |N i2 -> return_N 0 - |R f2 -> return_R 0. - |Vec (size2, vec2) -> make_vector size2 (fun i -> v_mul Zero (vec2 i)) - |Zero -> Zero - |W -> Zero (* Danger! *) - ) - |W -> - ( - match v2 with - |N i2 -> if i2 = 0 then N 0 else fail - |R f2 -> if f2 = 0. then R 0. else fail - |Vec (size2, vec2) -> - raise (Value_operation "Vector_Scalar W +~ vec2") - |Zero -> Zero - |W -> fail - );; - - -(** val ( *~ ) : value -> value -> value, operator of v_mul.*) -let ( *~ ) v1 v2 = v_mul v1 v2;; - - -(** val v_recip : value -> value, v_recip v = 1./.v.*) -let rec v_recip v = match v with - |N i -> v_recip (R (float_of_int i)) - |R f -> if f = 0. then fail else return_R (1./.f) - |Vec (size, vec) -> make_vector size (fun i -> v_recip (vec i)) - |Zero -> fail - |W -> return_R 0. ;; (* Danger! *) - - -(** val v_div : value -> value -> value, value division, returns (v1/.v2).*) -let v_div v1 v2 = - match (v1, v2) with - | (N i1, N i2) -> N (i1/i2) - | _ -> v_mul v1 (v_recip v2);; - - -(** val (/~) : value -> value -> value, operator of v_div.*) -let (/~) v1 v2 = v_div v1 v2;; - - -(** val v_zero : value -> value, Attention: N i -> N 0 | R f -> R 0. | Zero -> Zero | W -> R 0., -and recursive for value.Vec.*) -let rec v_zero v = match v with - |N i -> N 0 - |R f -> R 0. - |Vec (size, vec) -> make_vector size (fun i -> v_zero (vec i)) - |Zero -> Zero (* Danger! *) - |W -> R 0.;; (* Danger! *) - - -(** val v_floor : value -> value, returns floor of float, converts int to float, Zero to 0., - error to error, recursive for value.Vec.*) -let rec v_floor v = match v with - |N i -> return_R (float_of_int i) - |R f -> return_R (floor f) - |Vec (size, vec) -> make_vector size (fun i -> v_floor (vec i)) - |Zero -> return_R 0. - |W -> W;; - - -(** val v_int : value -> value, converts value to value.N, error to error, recursive for value.Vec.*) -let rec v_int v = match v with - |N i -> v - |R f -> return_N (int_of_float f) - |Vec (size, vec) -> make_vector size (fun i -> v_int (vec i)) - |Zero -> return_N 0 - |W -> W;; - - -(** val v_sin : value -> value, returns sin(v), recursive for value.Vec.*) -let rec v_sin v = match v with - |N i -> return_R (sin (float_of_int i)) - |R f -> return_R (sin f) - |Vec (size, vec) -> make_vector size (fun i -> v_sin (vec i)) - |Zero -> return_R (sin 0.) - |W -> W;; - -(** val v_cos : value -> value, returns cos(v), recursive for value.Vec.*) -let rec v_cos v = match v with - |N i -> return_R (cos (float_of_int i)) - |R f -> return_R (cos f) - |Vec (size, vec) -> make_vector size (fun i -> v_cos (vec i)) - |Zero -> return_R (cos 0.) - |W -> W;; - -(** val v_atan : value -> value, returns atan(v), recursive for value.Vec.*) -let rec v_atan v = match v with - |N i -> return_R (atan (float_of_int i)) - |R f -> return_R (atan f) - |Vec (size, vec) -> make_vector size (fun i -> v_atan (vec i)) - |Zero -> return_R (atan 0.) - |W -> W;; - - -(** val v_atantwo : value -> value, returns atantwo(v), recursive for value.Vec.*) -let rec v_atantwo v1 v2 = match (v1, v2) with - | (N i1, N i2) -> v_atantwo (R (float_of_int i1)) (R (float_of_int i2)) - | (N i1, R f2) -> v_atantwo (R (float_of_int i1)) v2 - | (N i1, Zero) -> v_atantwo (R (float_of_int i1)) (R 0.) - | (N i1, Vec (size2, vec2)) -> raise (Value_operation "atan2 sca vec.") - | (N i1, W) -> W - - | (R f1, N i2) -> v_atantwo v1 (R (float_of_int i2)) - | (R f1, R f2) -> R (atan2 f1 f2) - | (R f1, Zero) -> v_atantwo v1 (R 0.) - | (R f1, Vec (size2, vec2)) -> raise (Value_operation "atan2 sca vec.") - | (R f1, W) -> W - - | (Vec (size1, vec1), Vec (size2, vec2)) -> make_vector size1 (fun i -> v_atantwo (vec1 i) (vec2 i)) - | (Vec (size1, vec1), Zero) -> make_vector size1 (fun i -> v_atantwo (vec1 i) Zero) - | (Vec (size1, vec1), _) -> raise (Value_operation "atan2 vec sca.") - - | (Zero, N i2) -> v_atantwo (R 0.) (R (float_of_int i2)) - | (Zero, R f2) -> v_atantwo (R 0.) v2 - | (Zero, Vec (size2, vec2)) -> make_vector size2 (fun i -> v_atantwo Zero (vec2 i)) - | (Zero, Zero) -> v_atantwo (R 0.) (R 0.) - | (Zero, W) -> W - - | (W, Vec (size2, vec2)) -> raise (Value_operation "atan2 sca vec.") - | (W, _) -> W;; - - -(** val v_sqrt : value -> value, returns sqrt(v), recursive for value.Vec.*) -let rec v_sqrt v = match v with - |N i -> - if i >= 0 then return_R (sqrt (float_of_int i)) - else raise (Value_operation "sqrt parameter < 0.") - |R f -> - if f >= 0. then return_R (sqrt f) - else raise (Value_operation "sqrt parameter < 0.") - |Vec (size, vec) -> make_vector size (fun i -> v_sqrt (vec i)) - |Zero -> return_R (sqrt 0.) - |W -> W;; - - -(** val v_mod : value -> value -> value, returns (v1 % v2), recursive for value.Vec.*) -let rec v_mod v1 v2 = match v1 with - |N i1 -> - ( - match v2 with - |N i2 -> return_N (i1 mod i2) - |R f2 -> return_N (i1 mod (int_of_float f2)) - |Vec (size, vec) -> raise (Value_operation "Scalaire_Vector: int mod vec.") - |Zero -> raise (Value_operation "v1 mod v2: v2 cannot be zero.") - |W -> W - ) - |R f1 -> let i = return_N (int_of_float f1) in v_mod i v2 - |Vec (size1, vec1) -> - ( - match v2 with - |Vec (size2, vec2) -> - if size1 = size2 then - make_vector size1 (fun i -> v_mod (vec1 i) (vec2 i)) - else raise (Value_operation "vector size not matched.") - |Zero -> raise (Value_operation "v1 mod v2: v2 cannot be zero.") - |_ -> raise (Value_operation "Vector_Scalaire: vec mod int.") - ) - |Zero -> - ( - match v2 with - |Vec (size2, vec2) -> - let v = make_vector size2 (fun i -> Zero) in - v_mod v v2 - |_ -> v_mod (N 0) v2 - ) - |W -> - ( - match v2 with - |Vec (size2, vec2) -> raise (Value_operation "Scalaire_Vector: int mod vec.") - |Zero -> raise (Value_operation "v1 mod v2: v2 cannot be zero.") - |_ -> W - );; - - -(** val v_larger_than_zero : value -> value, primitive comparison between value and zero, -returns value.N 1 if true, value.N 0 if false.*) -let rec v_larger_than_zero v = match v with - |N i -> if i > 0 then return_N 1 else return_N 0 - |R f -> if f > 0. then return_N 1 else return_N 0 - |Vec (size, vec) -> make_vector size (fun i -> v_larger_than_zero (vec i)) - |Zero -> return_N 0 - |W -> W;; - - -(** val v_sup : value -> value -> value, comparison of two values, returns value.N 1 if (v1 > v2), -value.N 0 else.*) -let v_sup v1 v2 = v_larger_than_zero (v1 -~ v2);; - - -(** val v_inf : value -> value -> value, comparison of two values, returns value.N 1 if (v1 < v2), -value.N 0 else.*) -let v_inf v1 v2 = v_larger_than_zero (v2 -~ v1);; - +open Basic;; + +let convert : (basic -> 'a) -> basic -> 'a = + fun oper -> fun b -> oper b;; + +class value : basic -> value_type = + fun (b_init : basic) -> + object (self) + val mutable b = b_init + method get = b + method normalize = b <- basic_normalize self#get + + method to_float = convert basic_to_float self#get + method to_int = convert basic_to_int self#get + method to_float_array = convert basic_to_float_array self#get + method to_string = convert basic_to_string self#get + + method private prim1 : (basic -> basic) -> value = + fun oper -> + new value (oper self#get) + + method neg = self#prim1 basic_neg + method recip = self#prim1 basic_recip + method zero = self#prim1 basic_zero + method floor = self#prim1 basic_floor + method int = self#prim1 basic_int + method sin = self#prim1 basic_sin + method cos = self#prim1 basic_cos + method atan = self#prim1 basic_atan + method sqrt = self#prim1 basic_sqrt + + method private prim2 : (basic -> basic -> basic) -> value -> value = + fun oper -> + fun v -> + new value (oper self#get v#get) + + method add = self#prim2 basic_add + method sub = self#prim2 basic_sub + method mul = self#prim2 basic_mul + method div = self#prim2 basic_div + method atan2 = self#prim2 basic_atan2 + method _mod = self#prim2 basic_mod + method larger = self#prim2 basic_larger + method smaller = self#prim2 basic_smaller + + end;; -- 2.20.1