From: WANG Date: Thu, 22 Aug 2013 15:34:50 +0000 (+0200) Subject: Merge branch 'OOP' X-Git-Url: https://scm.cri.mines-paristech.fr/git/Faustine.git/commitdiff_plain/8c48d01c4b78dba6159c13438b06cb7e07a1f338?hp=29c1f4c9f2543b9b079aa3960761214c920bb1f2 Merge branch 'OOP' Conflicts: Makefile Makefile.in interpretor/faust-0.9.47mr3/compiler/faust interpretor/faust-0.9.47mr3/compiler/preprocess.a interpretor/faust-0.9.47mr3/compiler/preprocess/preprocess.o interpretor/faustine interpretor/gmon.out --- diff --git a/Makefile b/Makefile deleted file mode 100644 index 0a0a5a7..0000000 --- a/Makefile +++ /dev/null @@ -1,38 +0,0 @@ -SRC_DIR = interpretor -PREPROCESSOR_DIR = $(SRC_DIR)/faust-0.9.47mr3 -OUTPUTSOUNDS_DIR = output_sounds -EXEC = faustine - -all: $(EXEC) - -faustine: - @cp $(SNDFILE_PATH)/sndfile_stub.o $(SRC_DIR) - @cd $(SRC_DIR) && $(MAKE) opt OCAML_INCLUDE_PATH=$(OCAML_INCLUDE_PATH) SNDFILE_PATH=$(SNDFILE_PATH) - @cd $(SRC_DIR) && $(MAKE) clean - -.PHONY: clean mrproper - -clean: - @(cd $(SRC_DIR) && $(MAKE) clean) - @(rm -f *~) - -mrproper: clean - @(cd $(SRC_DIR) && $(MAKE) mrproper) - @(cd $(PREPROCESSOR_DIR) && $(MAKE) clean) - -test: - @rm -f $(OUTPUTSOUNDS_DIR)/output0.wav - @cd $(SRC_DIR) && ./faustine -csv -wav ../dsp_files/sin.dsp - @ls -l $(OUTPUTSOUNDS_DIR)/output0.wav - - @echo " You might want to check the output file with either:" - @echo "audacity ../output_sounds/output0.wav" - @echo "open ../output_sounds/output0.wav" - @echo "octave -q --eval 'plot(wavread(\"output_sounds/output0.wav\")); pause'" - -# Library paths for OCaml and libsndfile-ocaml -# OCAML_INCLUDE_PATH -# SNDFILE_PATH - -OCAML_INCLUDE_PATH = /usr/local/lib/ocaml -SNDFILE_PATH = ~/Boulot/2013-07-CRI/lib/libsndfile-ocaml diff --git a/Makefile.in b/Makefile.in index 81ef8f0..c27a93f 100644 --- a/Makefile.in +++ b/Makefile.in @@ -33,4 +33,3 @@ test: # Library paths for OCaml and libsndfile-ocaml # OCAML_INCLUDE_PATH # SNDFILE_PATH - diff --git a/dsp_files/fft-svg/process.svg b/dsp_files/fft-svg/process.svg index 30a9ebd..1e37bdf 100644 --- a/dsp_files/fft-svg/process.svg +++ b/dsp_files/fft-svg/process.svg @@ -1,72 +1,1347 @@ - - - + + + - - -8 - - - -vectorize - - - - - - - - + + +128 + + + +vectorize + + + + + + + + - -eo(8) + +fft(128) - - - - - - + + + + + + - -output + +pcplx_moduls(128) - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +nconcat(128) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + - + process - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/dsp_files/fft.dsp b/dsp_files/fft.dsp index 34a795e..bbe62ad 100644 --- a/dsp_files/fft.dsp +++ b/dsp_files/fft.dsp @@ -7,8 +7,8 @@ import ( "mrfaustlib/complex.lib" ) ; //fft_test(n,m) = _ : overlap(n,m) : fft(n) : stops(n/2), pcplx_moduls(n/2) : nconcat(n/2); fft_test(n,m) = vectorize(n) : fft(n) : pcplx_moduls(n) : nconcat(n); -//process = +, _ : + : fft_test(128); -process = fft_test(128,128); +process = +, _ : + : fft_test(128,128); +//process = fft_test(128,128); //process = (0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7) <: shuffle(8); diff --git a/dsp_files/fft2d-svg/process.svg b/dsp_files/fft2d-svg/process.svg index 407aa9e..5dc643f 100644 --- a/dsp_files/fft2d-svg/process.svg +++ b/dsp_files/fft2d-svg/process.svg @@ -1,7 +1,7 @@ - - - + + + @@ -27,74 +27,76 @@ normalize(256) - - - + + +32 + + + +vectorize + + + + + + + + - -matricize(32)(32) + +lines_fft(32)(32) - - - - - - + + + + + + - -lines_fft(32)(32) + +matrix_transpose(32)(32) - - - - - - + + + + + + - -matrix_transpose(32)(32) + +lines_fftc(32)(32) - - - - - - + + + + + + - -lines_fftc(32)(32) + +matrix_transpose(32)(32) - - - - - - + + + + + + - -matrix_transpose(32)(32) + +norm_out(32)(32) - - - - - - - - -norm_out(32)(32) - - - - + + + - - + + - + process - - + + @@ -109,23 +111,33 @@ + + - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/dsp_files/fft2d.dsp b/dsp_files/fft2d.dsp index 2b50b0b..870c1e2 100644 --- a/dsp_files/fft2d.dsp +++ b/dsp_files/fft2d.dsp @@ -25,7 +25,8 @@ matrix_pcplx2modul(n, m) = _ <: picks(n) : par(i, n, ( _ <: picks(m) : pcplx_mod matrix_real2pcplx(n, m) = _ <: picks(n) : par(i, n, ( _ <: picks(m) : real2pcplx(m) : nconcat(m))) : nconcat(n); -normalize(n) = _ , n : /; +//normalize(n) = _ , n : /; +normalize(n, m) = _, (m : vectorize(n)) : /; unnormalize(n) = par(i, n, ( _ , GREY_MAX : *)); @@ -39,6 +40,11 @@ output(n, m) = serialize; //fft2d(x, y) = matricize(x, y) : output(x, y); fft2d(x, y) = normalize(GREY_MAX) : matricize(x, y) : lines_fft(x, y) : matrix_transpose(x, y) : lines_fftc(y, x) : matrix_transpose(y, x) : norm_out(x, y); +new_fft2d(x, y) = normalize(y, GREY_MAX) : vectorize(x) : lines_fft(x, y) : matrix_transpose(x, y) : lines_fftc(y, x) : matrix_transpose(y, x) : norm_out(x, y); + //safer with x=y because tests and zero padding are still to implement -process = fft2d(32,32); +//process = fft2d(32,32); +process = new_fft2d(32,32); + + diff --git a/dsp_files/mrfaustlib/fft.lib b/dsp_files/mrfaustlib/fft.lib index 7758d04..6d29068 100644 --- a/dsp_files/mrfaustlib/fft.lib +++ b/dsp_files/mrfaustlib/fft.lib @@ -3,9 +3,6 @@ * Implementation contributed by Remy Muller *****************************************************************/ -// bus(n) : n parallel cables -bus(2) = _,_; // avoids a lot of "bus(1)" labels in block diagrams -bus(n) = par(i, n, _); // twiddle_mult(n) : n parallel cables @@ -13,17 +10,6 @@ W(k, n) = 1, (0, ( k, ((2 * PI) / n) : *) : -) : polar_cplx; twiddle_mult(k, n) = _, W(k, n) : pcplx_mul; -// selector(i,n) : select ith cable among n -selector(i,n) = par(j, n, S(i, j)) with { S(i,i) = _; S(i,j) = !; }; - -// interleave(m,n) : interleave m*n cables : x(0), x(m), x(2m), ..., x(1),x(1+m), x(1+2m)... -//interleave(m,n) = bus(m*n) <: par(i, m, par(j, n, selector(i+j*m,m*n))); - -// interleave(row,col) : interleave row*col cables from column order to row order. -// input : x(0), x(1), x(2) ..., x(row*col-1) -// output: x(0+0*row), x(0+1*row), x(0+2*row), ..., x(1+0*row), x(1+1*row), x(1+2*row), ... -interleave(row,col) = bus(row*col) <: par(r, row, par(c, col, selector(r+c*row,row*col))); - // butterfly(n) : addition then substraction of interleaved signals : xbutterfly(n) = (bus(n/2), par(k, n/2, twiddle_mult(k, n))) <: interleave(n/2,2), interleave(n/2,2) : par(i, n/2, pcplx_add), par(i, n/2, pcplx_sub); diff --git a/dsp_files/sin.dsp b/dsp_files/sin.dsp index 16982a6..b1650f2 100644 --- a/dsp_files/sin.dsp +++ b/dsp_files/sin.dsp @@ -15,4 +15,5 @@ osc(freq) = phase(freq) : rdtable(tablesize, sinwavform); vol = 1; freq = 1000; -process = osc(freq) * vol; \ No newline at end of file +process = osc(freq) * vol; +//process = freq / samplingfreq : @(1): ( + : decimal) ~ _ : * (tablesize) : int ; diff --git a/interpretor/Makefile b/interpretor/Makefile index 56a213b..e287f8b 100644 --- a/interpretor/Makefile +++ b/interpretor/Makefile @@ -2,7 +2,7 @@ # # 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 symbol.ml aux.ml value.ml signal.ml beam.ml process.ml faustio.ml preprocess.ml main.ml preprocess_stubs.cpp # The executable file to generate @@ -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 @@ -45,7 +45,7 @@ CC = g++ # LIBS=$(WITHGRAPHICS) $(WITHUNIX) $(WITHSTR) $(WITHNUMS) $(WITHTHREADS)\ # $(WITHDBM) -LIBS = $(WITHSNDFILE) $(WITHUNIX) +LIBS = $(WITHSNDFILE) $(WITHUNIX) $(WITHSTR) # Should be set to -INCLUDE if you use any of the libraries above # or if any C code have to be linked with your program @@ -73,6 +73,8 @@ WITHUNIX =unix.cma WITHSNDFILE = sndfile.cma +WITHSTR = str.cma + # c++ wrap options GPP_CALL = -cc "g++" @@ -146,6 +148,12 @@ preprocess.cmx: preprocess.ml preprocess_stubs.o: preprocess_stubs.cpp $(CC) $(CC_OPTIONS) $< +faustio.cmo: faustio.ml + $(CAMLC) $(INCLUDE) $(LIBS) -c $< + +faustio.cmx: faustio.ml + $(CAMLOPT) $(INCLUDE) $(LIBS:.cma=.cmxa) -c $< + .SUFFIXES: .ml .mli .cmo .cmi .cmx .mll .mly .ml.cmo: diff --git a/interpretor/aux.ml b/interpretor/aux.ml new file mode 100644 index 0000000..3f75f06 --- /dev/null +++ b/interpretor/aux.ml @@ -0,0 +1,26 @@ +(** + Module: Aux + Description: all auxiliary functions + @author WANG Haisheng + Created: 12/08/2013 Modified: 13/08/2013 +*) + + +let array_map = fun f -> fun a -> + let n = Array.length a in + Array.init n (fun i -> f a.(i));; + +let array_map2 = fun f -> fun a -> fun b -> + let n1 = Array.length a in + let n2 = Array.length b in + if n1 = n2 then Array.init n1 (fun i -> f a.(i) b.(i)) + else raise (Invalid_argument "Array.map2 size not matched.");; + +let array_map3 = fun f -> fun a -> fun b -> fun c -> + let n1 = Array.length a in + let n2 = Array.length b in + let n3 = Array.length c in + if n1 = n2 && n1 = n3 then Array.init n1 (fun i -> f a.(i) b.(i) c.(i)) + else raise (Invalid_argument "Array.map3 size not matched.");; + +let decorate = fun s -> " Faustine -> " ^ s;; diff --git a/interpretor/basic.ml b/interpretor/basic.ml new file mode 100644 index 0000000..1e56142 --- /dev/null +++ b/interpretor/basic.ml @@ -0,0 +1,400 @@ +(** + Module: Basic + Description: basic data type in the vectorial faust interpreter. + @author WANG Haisheng + Created: 31/05/2013 Modified: 17/07/2013 +*) + +open Types;; + +exception Convert_Error of string;; +exception Basic_operation of string;; + + +(* MACRO *) + +let faust_max = 2147483647;; +let faust_min = -2147483648;; +let faust_bits = 32;; + +(* Functional operations *) + +let fun_unary oper f = fun x -> oper (f x);; +let fun_binary oper f g = fun x -> oper (f x) (g x);; +let fun_ternary oper f g h = fun x -> oper (f x) (g x) (h x);; + +(* basic operations *) + +let memorize : int -> (index -> basic) -> (index -> basic) = + fun size -> + fun vec -> + let memory = Array.create size Error in + let filled = Array.create size false in + let vec_mem : index -> basic = + fun i -> + if i >= 0 && i < size then ( + if filled.(i) then + memory.(i) + else + let result = vec i in + let () = memory.(i) <- result in + let () = filled.(i) <- true in + result) + else raise (Invalid_argument "vector overflow.") in + vec_mem;; + +class vector : int -> (index -> basic) -> vector_type = + fun (size_init : int) -> + fun (vec_init : index -> basic) -> + object + val s = size_init + val vec = memorize size_init vec_init + method size = s + method nth = vec + end;; + +let rec basic_to_int : basic -> int = + fun v -> + match v with + |N i -> i + |R f -> int_of_float f + |Vec vec -> + raise (Convert_Error "basic_to_int : vector.") + |Zero -> 0 + |Error -> raise (Convert_Error "basic_to_int : Error");; + + +let basic_to_float : basic -> float = + fun v -> + match v with + |N i -> float_of_int i + |R f -> f + |Vec vec -> + raise (Convert_Error "basic_to_float : vector.") + |Zero -> 0. + |Error -> 0.;; + + +let basic_to_float_array : basic -> float array = + fun v -> + match v with + |Vec vec -> + let basics : basic array = + Array.init vec#size vec#nth in + Array.map basic_to_float basics + |_ -> [| (basic_to_float v)|];; + + +let rec basic_to_string : basic -> string = + fun (v : basic) -> + match v with + |N i1 -> string_of_int i1 + |R f1 -> string_of_float f1 + |Vec vec -> + let basics : basic array = + Array.init vec#size vec#nth in + let strings = Array.to_list + (Array.map basic_to_string basics) in + String.concat "," strings + |Zero -> "0" + |Error -> "0";; + +let basic_of_float : float -> basic = fun f -> R f;; + +let rec basic_of_float_array : float array -> basic = + fun (data : float array) -> + let n = Array.length data in + if n = 0 then + raise (Convert_Error "basic_of_float_array : empty.") + else if n = 1 then basic_of_float data.(0) + else + let vec = Array.get (Array.map basic_of_float data) in + Vec (new vector n vec);; + +(* VALUE OPERATIONS *) + +let rec basic_normalize : basic -> basic = + fun b -> + let n = 2. ** float_of_int (faust_bits) in + match b with + |N i -> + if i > faust_max then + N (i - int_of_float + (n *. floor (((float_of_int i) +. n/.2.)/.n))) + else if i < faust_min then + N (i + int_of_float + (n *. floor ((n/.2. -. (float_of_int i) -. 1.)/.n))) + else N i + |R f -> + if f > float_of_int (faust_max) then + R (f -. (n *. floor ((f +. n/.2.)/.n))) + else if f < float_of_int (faust_min) then + R (f +. (n *. floor ((n/.2. -. f -. 1.)/.n))) + else R f + |Vec vec -> + Vec (new vector vec#size + (fun_unary basic_normalize vec#nth)) + |Zero -> Zero + |Error -> Error;; + + +let rec basic_add : basic -> basic -> basic = + fun b1 -> fun b2 -> + match (b1, b2) with + | (Zero, _) -> b2 + | (_, Zero) -> b1 + + | (Vec vec1, Vec vec2) -> + if vec1#size = vec2#size then + Vec (new vector vec1#size + (fun_binary basic_add vec1#nth vec2#nth)) + else raise (Basic_operation "vector size not matched.") + | (Vec vec1, _) -> raise (Basic_operation "vec1 +~ sca2") + + | (N i1, N i2) -> basic_normalize (N (i1 + i2)) + | (N i1, R f2) -> basic_normalize (R ((float_of_int i1) +. f2)) + | (N i1, Vec vec2) -> raise (Basic_operation "i1 +~ vec2") + | (N i1, Error) -> Error + + | (R f1, N i2) -> basic_normalize (R (f1 +. (float_of_int i2))) + | (R f1, R f2) -> basic_normalize (R (f1 +. f2)) + | (R f1, Vec vec2) -> raise (Basic_operation "f1 +~ vec2") + | (R f1, Error) -> Error + + | (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2") + | (Error, _) -> Error;; + + +let (+~) b1 b2 = basic_add b1 b2;; + + +let rec basic_neg : basic -> basic = + fun b -> + match b with + |N i -> N (-i) + |R f -> R (-.f) + |Vec vec -> Vec (new vector vec#size (fun_unary basic_neg vec#nth)) + |Zero -> Zero + |Error -> Error;; + + +let basic_sub : basic -> basic -> basic = + fun b1 -> + fun b2 -> + basic_add b1 (basic_neg b2);; + + +let (-~) b1 b2 = basic_sub b1 b2;; + + +let rec basic_mul : basic -> basic -> basic = + fun b1 -> + fun b2 -> + match (b1, b2) with + | (Vec vec1, Vec vec2) -> + if vec1#size = vec2#size then + Vec (new vector vec1#size + (fun_binary basic_mul vec1#nth vec2#nth)) + else raise (Basic_operation "vector size not matched.") + | (Vec vec1, Zero) -> + Vec (new vector vec1#size + (fun_unary (basic_mul Zero) vec1#nth)) + | (Vec vec1, _) -> raise (Basic_operation "vec1 *~ sca2") + + | (N i1, N i2) -> basic_normalize (N (i1 * i2)) + | (N i1, R f2) -> basic_normalize (R ((float_of_int i1) *. f2)) + | (N i1, Vec vec2) -> raise (Basic_operation "i1 *~ vec2") + | (N i1, Zero) -> N 0 + | (N i1, Error) -> Error + + | (R f1, N i2) -> basic_normalize (R (f1 *. (float_of_int i2))) + | (R f1, R f2) -> basic_normalize (R (f1 *. f2)) + | (R f1, Vec vec2) -> raise (Basic_operation "f1 *~ vec2") + | (R f1, Zero) -> R 0. + | (R f1, Error) -> Error + + | (Zero, N i2) -> N 0 + | (Zero, R f2) -> R 0. + | (Zero, Vec vec2) -> + Vec (new vector vec2#size + (fun i -> basic_mul Zero (vec2#nth i))) + | (Zero, Zero) -> Zero + | (Zero, Error) -> Error + + | (Error, Vec vec2) -> raise (Basic_operation "Error +~ vec2") + | (Error, _) -> Error;; + + +let ( *~ ) b1 b2 = basic_mul b1 b2;; + + +let rec basic_recip : basic -> basic = + fun v -> + match v with + |N i -> basic_recip (R (float_of_int i)) + |R f -> if f = 0. then Error else R (1./.f) + |Vec vec -> Vec (new vector vec#size + (fun_unary basic_recip vec#nth)) + |Zero -> Error + |Error -> R 0.;; + + +let basic_div : basic -> basic -> basic = + fun b1 -> + fun b2 -> + basic_mul b1 (basic_recip b2);; + + +let (/~) b1 b2 = basic_div b1 b2;; + + +let rec basic_zero : basic -> basic = + fun v -> + match v with + |N i -> N 0 + |R f -> R 0. + |Vec vec -> Vec (new vector vec#size + (fun_unary basic_zero vec#nth)) + |Zero -> Zero + |Error -> R 0.;; + + +let rec basic_floor : basic -> basic = + fun v -> + match v with + |N i -> R (float_of_int i) + |R f -> R (floor f) + |Vec vec -> Vec (new vector vec#size + (fun_unary basic_floor vec#nth)) + |Zero -> R 0. + |Error -> Error;; + + +let rec basic_int : basic -> basic = + fun v -> + match v with + |N i -> v + |R f -> N (int_of_float f) + |Vec vec -> Vec (new vector vec#size + (fun_unary basic_int vec#nth)) + |Zero -> N 0 + |Error -> Error;; + + +let rec basic_unary : (float -> float) -> basic -> basic = + fun oper -> + fun b -> + match b with + |N i -> R (oper (float_of_int i)) + |R f -> R (oper f) + |Vec vec -> Vec (new vector vec#size + (fun_unary (basic_unary oper) vec#nth)) + |Zero -> R (oper 0.) + |Error -> Error;; + + +let basic_sin : basic -> basic = basic_unary sin;; +let basic_cos : basic -> basic = basic_unary cos;; +let basic_atan : basic -> basic = basic_unary atan;; + + +let rec basic_atan2 : basic -> basic -> basic = + fun v1 -> + fun v2 -> + match (v1, v2) with + | (N i1, N i2) -> basic_atan2 + (R (float_of_int i1)) (R (float_of_int i2)) + | (N i1, R f2) -> basic_atan2 (R (float_of_int i1)) v2 + | (N i1, Zero) -> basic_atan2 (R (float_of_int i1)) (R 0.) + | (N i1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.") + | (N i1, Error) -> Error + + | (R f1, N i2) -> basic_atan2 v1 (R (float_of_int i2)) + | (R f1, R f2) -> R (atan2 f1 f2) + | (R f1, Zero) -> basic_atan2 v1 (R 0.) + | (R f1, Vec vec2) -> raise (Basic_operation "atan2 sca vec.") + | (R f1, Error) -> Error + + | (Vec vec1, Vec vec2) -> Vec (new vector vec1#size + (fun_binary basic_atan2 vec1#nth vec2#nth)) + | (Vec vec1, Zero) -> Vec (new vector vec1#size + (fun i -> basic_atan2 (vec1#nth i) Zero)) + | (Vec vec1, _) -> raise (Basic_operation "atan2 vec sca.") + + | (Zero, N i2) -> basic_atan2 (R 0.) (R (float_of_int i2)) + | (Zero, R f2) -> basic_atan2 (R 0.) v2 + | (Zero, Vec vec2) -> Vec (new vector vec2#size + (fun_unary (basic_atan2 Zero) vec2#nth)) + | (Zero, Zero) -> basic_atan2 (R 0.) (R 0.) + | (Zero, Error) -> Error + + | (Error, Vec vec2) -> raise (Basic_operation "atan2 sca vec.") + | (Error, _) -> Error;; + + +let rec basic_sqrt v = match v with + |N i -> + if i >= 0 then R (sqrt (float_of_int i)) + else raise (Basic_operation "sqrt parameter < 0.") + |R f -> + if f >= 0. then R (sqrt f) + else raise (Basic_operation "sqrt parameter < 0.") + |Vec vec -> Vec (new vector vec#size (fun_unary basic_sqrt vec#nth)) + |Zero -> R (sqrt 0.) + |Error -> Error;; + + +let rec basic_mod : basic -> basic -> basic = + fun b1 -> + fun b2 -> + match (b1, b2) with + | (N i1, N i2) -> N (i1 mod i2) + | (N i1, R f2) -> basic_mod b1 (N (int_of_float f2)) + | (N i1, Vec vec2) -> + raise (Basic_operation "Scalaire_Vector: int mod vec.") + | (_, Zero) -> + raise (Basic_operation "b1 mod b2: b2 cannot be zero.") + | (N i1, Error) -> Error + + | (R f1, _) -> basic_mod (N (int_of_float f1)) b2 + + | (Vec vec1, Vec vec2) -> + if vec1#size = vec2#size then + Vec (new vector vec1#size (fun_binary basic_mod vec1#nth vec2#nth)) + else raise (Basic_operation "vector size not matched.") + | (Vec vec1, _) -> + raise (Basic_operation "Vector_Scalaire: vec mod int.") + + | (Zero, Vec vec2) -> + basic_mod (Vec (new vector vec2#size (fun i -> Zero))) b2 + | (Zero, _) -> basic_mod (N 0) b2 + + | (Error, Vec vec2) -> + raise (Basic_operation "Scalaire_Vector: int mod vec.") + | (Error, _) -> Error;; + + +let rec basic_larger_than_zero : basic -> basic = + fun v -> + match v with + |N i -> if i > 0 then N 1 else N 0 + |R f -> if f > 0. then N 1 else N 0 + |Vec vec -> + Vec (new vector vec#size + (fun_unary basic_larger_than_zero vec#nth )) + |Zero -> N 0 + |Error -> Error;; + + +let basic_larger : basic -> basic -> basic = + fun b1 -> + fun b2 -> + basic_larger_than_zero (b1 -~ b2);; + + +let basic_smaller : basic -> basic -> basic = + fun b1 -> + fun b2 -> + basic_larger_than_zero (b2 -~ b1);; + + diff --git a/interpretor/beam.ml b/interpretor/beam.ml new file mode 100644 index 0000000..b66ac2b --- /dev/null +++ b/interpretor/beam.ml @@ -0,0 +1,108 @@ +(** + Module: Beam + Description: beam definition and operations + @author WANG Haisheng + Created: 21/07/2013 Modified: 21/07/2013 +*) + +exception Beam_matching of string;; + +open Types;; +open Basic;; +open Value;; +open Signal;; + +class beam : signal_type array -> beam_type = + fun (signals_init : signal_type array) -> + object (self) + val signals = signals_init + + method get = signals + method width = Array.length signals + + method sub : int -> int -> beam_type = + fun start -> + fun len -> + new beam (Array.sub self#get start len) + + method cut : int -> beam_type * beam_type = + fun (cut_width : int)-> + ((self#sub 0 cut_width),(self#sub cut_width (self#width - cut_width))) + + method append : beam_type -> beam_type = + fun (b : beam_type) -> + new beam (Array.append self#get b#get) + + method private add_memory : int -> unit = + fun (window : int) -> + let signal_add_memory : int -> signal_type -> unit = + fun (l : int) -> + fun (s : signal) -> + s#add_memory l in + let _ = Array.map (signal_add_memory window) self#get in () + + method matching : int -> beam_type = + fun size -> + if size = self#width then new beam self#get + + else if (size > self#width) && (size mod self#width = 0) then + let () = self#add_memory 1 in + let split_signals = + Array.concat (Array.to_list + (Array.make (size/self#width) self#get)) in + new beam split_signals + + else if (size < self#width) && (self#width mod size = 0) then + let rec merge_rec = + fun (sa : signal_type array) -> + fun (l : int) -> + fun (i : int) -> + if i + l < Array.length sa then + (sa.(i))#add (merge_rec sa l (i + l)) + else sa.(i) in + let merge_signals = Array.init size (merge_rec self#get size) in + new beam merge_signals + + else raise (Beam_matching "matching size error") + + method at : time -> value_type array = + fun t -> + let signal_at = fun (t : time) -> fun (s : signal_type) -> s#at t in + Array.map (signal_at t) self#get + + method output : int -> float array array array = + fun (length_max : int) -> + let transpose : 'a array array -> 'a array array = + fun matrix -> + let get_element = fun i -> fun array -> array.(i) in + let get_column = fun m -> fun i -> Array.map (get_element i) m in + Array.init self#width (get_column matrix) in + let value2float = fun (v : value_type) -> v#to_float_array in + let init = [|0.|] in + let container = Array.make length_max + (Array.make self#width init) in + let index = ref 0 in + + try + while !index < length_max do + container.(!index) <- Array.map value2float (self#at !index); + incr index; + done; + transpose container + + with x -> + match x with + | Invalid_argument s -> + transpose (Array.sub container 0 !index) + | _ -> raise x + + method frequency : int array = + let each_rate : signal -> int = + fun (s : signal) -> + let rate = s#frequency in + if rate > 0 then rate + else if rate = 0 then 44100 + else raise (Beam_matching "frequency error.") in + Array.map each_rate self#get + + end diff --git a/interpretor/faust-0.9.47mr3/compiler/preprocess.a b/interpretor/faust-0.9.47mr3/compiler/preprocess.a deleted file mode 100644 index 422ad78..0000000 Binary files a/interpretor/faust-0.9.47mr3/compiler/preprocess.a and /dev/null differ diff --git a/interpretor/faust-0.9.47mr3/compiler/preprocess/preprocess.o b/interpretor/faust-0.9.47mr3/compiler/preprocess/preprocess.o deleted file mode 100644 index 7663721..0000000 Binary files a/interpretor/faust-0.9.47mr3/compiler/preprocess/preprocess.o and /dev/null differ diff --git a/interpretor/faustexp.ml b/interpretor/faustexp.ml deleted file mode 100644 index 5904569..0000000 --- a/interpretor/faustexp.ml +++ /dev/null @@ -1,204 +0,0 @@ -(** - Module: Faustexp - Description: dimension estimation and delay estimation of faust expressions. - @author WANG Haisheng - Created: 03/06/2013 Modified: 04/06/2013 -*) - -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;; - - -(* PROCESS DELAY ESTIMATION *) - -(** val delay : faust_exp -> int, returns the number of delays estimated staticly. -Attention: delays of "@" is estimated as 10 constant, -delays of "vectorize" and "serialize" haven't been implemented, -delays of "rdtable" hasn't been implemented.*) -let rec delay exp_faust = match exp_faust with - |Const v -> 0 - |Ident s -> - ( - match s with - |Add -> 0 - |Sup -> 0 - |Mul -> 0 - |Div -> 0 - |Pass -> 0 - |Stop -> 0 - |Mem -> 1 - |Delay -> 100000 (* danger! *) - |Floor -> 0 - |Int -> 0 - |Sin -> 0 - |Cos -> 0 - |Atan -> 0 - |Atantwo -> 0 - |Sqrt -> 0 - |Rdtable -> 100000 (* danger! *) - |Mod -> 0 - |Larger -> 0 - |Smaller -> 0 - |Vectorize -> 100 (* danger! *) - |Concat -> 0 - |Nth -> 0 - |Serialize -> 0 - |Prefix -> 1 - |Selecttwo -> 0 - |Selectthree -> 0 - ) - |Par (e1, e2) -> max (delay e1) (delay e2) - |Seq (e1, e2) -> (delay e1) + (delay e2) - |Split (e1, e2) -> (delay e1) + (delay e2) - |Merge (e1, e2) -> (delay e1) + (delay e2) - |Rec (e1, e2) -> delay e1;; - - -(* PARSER *) - -(** val exp_of_string : string -> faust_exp, faust expression parser. *) -let exp_of_string s = (Parser.main Lexer.token (Lexing.from_string s));; - - - -(* PROCESS DIMENSION ESTIMATION *) -(* process dimension := (size of input beam, size of output beam).*) - - -(** val get_root : dimension -> int * int, returns the root of dimension tree. *) -let get_root = fun d_tree -> match d_tree with - | End d -> d - | Tree (d, branches) -> d;; - - -(** val subtree : dimention -> int -> dimension, returns a subtree of dimension tree.*) -let subtree = fun d_tree -> fun i -> - match d_tree with - | End d -> raise (Beam_Matching_Error "Subtree left absent.") - | Tree (d, branches) -> ( - match branches with - (left, right) -> if i = 0 then left else right);; - -(** val subtree_left : dimension -> dimension, returns the left subtree of dimension tree.*) -let subtree_left = fun d_tree -> subtree d_tree 0;; - - -(** val subtree_right : dimension -> dimension, returns the right subtree of dimension tree.*) -let subtree_right = fun d_tree -> subtree d_tree 1;; - - -(** val d_par : int * int -> int * int -> int * int, process dimension for constructor "par(,)", -which is the addition of two dimensions.*) -let d_par a b = (((fst a) + (fst b)), ((snd a) + (snd b)));; - - -(** val d_seq : int * int -> int * int -> int * int, process dimension for constructor "seq(:)", -which is (size of input beam of first exp, size of output beam of second exp) -along with beam matching.*) -let d_seq a b = if (snd a) = (fst b) then (fst a, snd b) else raise (Beam_Matching_Error "seq");; - - -(** val d_split : int * int -> int * int -> int * int, process dimension for constructor "split(<:)", -which is (size of input beam of first exp, size of output beam of second exp) -along with beam matching.*) -let d_split a b = - if ((fst b) mod (snd a)) = 0 then - (fst a, snd b) - else raise (Beam_Matching_Error "split");; - - -(** val d_merge : int * int -> int * int -> int * int, process dimension for constructor "merge(:>)", -which is (size of input beam of first exp, size of output beam of second exp) -along with beam matching. *) -let d_merge a b = - if ((snd a) mod (fst b)) = 0 then - (fst a, snd b) - else raise (Beam_Matching_Error "merge");; - - -(** val d_rec : int * int -> int * int -> int * int, process dimension for constructor "rec(~)", -which is (size of input beam of first exp - size of output beam of second exp, -size of output beam of first exp) -along with beam matching.*) -let d_rec a b = - if (fst a) >= (snd b) && (snd a) >= (fst b) then - ((fst a) - (snd b), snd a) - else raise (Beam_Matching_Error "rec");; - - -(** val dim : faust_exp -> int * int, returns dimension for faust expression, -along with beam matching.*) -let rec dim exp_faust = - -(** val dimension_constructor : ((int * int) -> (int * int) -> (int * int)) -> faust_exp --> faust_exp -> dimension, -returns the dimension tree of constructor(e1, e2).*) - let dimension_constructor = fun constructor -> fun e1 -> fun e2 -> - let subtree1 = dim e1 in - let subtree2 = dim e2 in - let root = constructor (get_root subtree1) (get_root subtree2) in - Tree (root, (subtree1, subtree2)) in - - match exp_faust with - |Const v -> End (0, 1) - |Ident s -> - ( - match s with - |Add -> End (2, 1) - |Sup -> End (2, 1) - |Mul -> End (2, 1) - |Div -> End (2, 1) - |Pass -> End (1, 1) - |Stop -> End (1, 0) - |Mem -> End (1, 1) - |Delay -> End (2, 1) - |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) - |Concat -> End (2, 1) - |Nth -> End (2, 1) - |Serialize -> End (1, 1) - |Larger -> End (2, 1) - |Smaller -> End (2, 1) - |Prefix -> End (2, 1) - |Selecttwo -> End (3, 1) - |Selectthree -> End (4, 1) - ) - - |Par (e1, e2) -> dimension_constructor d_par e1 e2 - |Seq (e1, e2) -> dimension_constructor d_seq e1 e2 - |Split (e1, e2) -> dimension_constructor d_split e1 e2 - |Merge (e1, e2) -> dimension_constructor d_merge e1 e2 - |Rec (e1, e2) -> dimension_constructor d_rec e1 e2;; - - - -(* AUXILIARY 'CONVERT_TO_STRING' FUNCTIONS *) - -(** val print_exp : faust_exp -> unit, print to console the input faust expression.*) -let print_exp exp = - let rec string_of_exp exp = match exp with - |Const v -> "Const" ^ " (" ^ (string_of_value v) ^ ")" - |Ident s -> "Ident" ^ " \"" ^ "s" ^ "\"" - |Par (e1, e2) -> "Par" ^ " (" ^ (string_of_exp e1) ^ ", " ^ (string_of_exp e2) ^ ")" - |Seq (e1, e2) -> "Seq" ^ " (" ^ (string_of_exp e1) ^ ", " ^ (string_of_exp e2) ^ ")" - |Split (e1, e2) -> "Split" ^ " (" ^ (string_of_exp e1) ^ ", " ^ (string_of_exp e2) ^ ")" - |Merge (e1, e2) -> "Merge" ^ " (" ^ (string_of_exp e1) ^ ", " ^ (string_of_exp e2) ^ ")" - |Rec (e1, e2) -> "Rec" ^ " (" ^ (string_of_exp e1) ^ ", " ^ (string_of_exp e2) ^ ")" - in - print_string("Parer : Types.faust_exp = "^ (string_of_exp exp));; diff --git a/interpretor/faustio.ml b/interpretor/faustio.ml new file mode 100644 index 0000000..3094ce9 --- /dev/null +++ b/interpretor/faustio.ml @@ -0,0 +1,192 @@ +(** + Module: Faustio + Description: audio input/output, csv input/output + @author WANG Haisheng + Created: 12/08/2013 Modified: 13/08/2013 +*) + +open Types;; +open Basic;; +open Value;; +open Signal;; +open Beam;; +open Aux;; + +let csv_read_buffer_length = 0xFFFF;; + +class virtual io = + object + val mutable _basename = "" + val mutable _dir = "" + method set : string -> string -> unit = + fun (dir : string) -> + fun (basename : string) -> + _basename <- basename; _dir <- dir + + method virtual read : string array -> beam + method virtual write : int array -> float array array array -> string array + + method private concat : float array array array -> float array array = + fun (origin : float array array array) -> + Array.map Array.concat (Array.map Array.to_list origin) + + method private channels : float array array array -> int array = + fun data -> + let get_channel = fun s -> + let l = Array.length s in + Array.length s.(l - 1) in + Array.map get_channel data + end;; + +class waveio : io_type = + object (self) + inherit io + method read : string array -> beam = + fun (paths : string array) -> + let n = Array.length paths in + if n = 0 then + new beam [||] + else + let signals = + let files = Array.map Sndfile.openfile paths in + let frames = Array.map Int64.to_int + (Array.map Sndfile.frames files) in + let rates = Array.map Sndfile.samplerate files in + let create_container = fun l -> Array.create l 1. in + let containers = Array.map create_container frames in + let _ = array_map2 Sndfile.read files containers in + let _ = Array.map Sndfile.close files in + let stream2func = + fun stream -> fun t -> new value (R stream.(t)) in + array_map2 (new signal) rates (Array.map stream2func containers) in + new beam signals + + method write : int array -> float array array array -> string array = + fun (rates : int array) -> + fun (output : float array array array) -> + let n = Array.length output in + let paths = Array.init n (fun i -> + _dir ^ _basename ^ (string_of_int (i + 1)) ^ ".wav") in + + let files = + let channels = self#channels output in + let file_format = Sndfile.format + Sndfile.MAJOR_WAV Sndfile.MINOR_PCM_16 in + let openwr = fun path -> fun channel -> fun rate -> + Sndfile.openfile ~info:(Sndfile.RDWR, file_format, channel, rate) path in + array_map3 openwr paths channels rates in + + let data = self#concat output in + let _ = array_map2 Sndfile.write files data in + let _ = Array.map Sndfile.close files in + paths + end;; + + + +class csvio : io_type = + object (self) + inherit io + method private csvread : in_channel -> signal = + fun (ic : in_channel) -> + let buffer = Buffer.create csv_read_buffer_length in + let () = + try + while true do + Buffer.add_string buffer (input_line ic); + Buffer.add_char buffer '\t'; + done; + with End_of_file -> () in + let content = Buffer.contents buffer in + let lines = Str.split (Str.regexp "\t") content in + let elements = List.map (Str.split (Str.regexp ",")) lines in + let data = + let data_in_list = List.map (List.map float_of_string) elements in + Array.of_list (List.map Array.of_list data_in_list) in + let values = + let convertor = new value Zero in + Array.map (convertor#of_float_array) data in + new signal 0 (Array.get values) + + method read : string array -> beam = + fun (paths : string array) -> + let files = Array.map open_in paths in + let signals = Array.map self#csvread files in + new beam signals + + method write : int array -> float array array array -> string array = + fun (rates : int array) -> + fun (data : float array array array) -> + let paths = + let n = Array.length data in + let path_pattern = fun i -> + _dir ^ _basename ^ (string_of_int (i + 1)) ^ ".csv" in + Array.init n path_pattern in + + let files = Array.map open_out paths in + let strings = + let value2string : float array -> string = + fun (v : float array) -> + let strings = Array.map string_of_float v in + String.concat "," (Array.to_list strings) in + let signal2string : float array array -> string = + fun (s : float array array) -> + let lines = Array.map value2string s in + String.concat "\n" (Array.to_list lines) in + Array.map signal2string data in + let _ = array_map2 output_string files strings in + let _ = Array.map close_out files in + paths + end;; + + +class iomanager = + object (self) + val wave = new waveio + val csv = new csvio + val mutable _dir = "" + val mutable _format = "" + val mutable _basename = "" + + method private grab_format : string -> string = + fun (path : string) -> + let fragments = Str.split (Str.regexp "\.") path in + let n = List.length fragments in + List.nth fragments (n - 1) + + method read : string list -> beam_type = + fun (paths : string list) -> + let formats = List.map self#grab_format paths in + let read_one : string -> string -> beam_type = + fun (format : string) -> + fun (path : string) -> + if format = "wav" then wave#read [|path|] + else if format = "csv" then csv#read [|path|] + else raise (Invalid_argument "Unknown format.") in + let beams = List.map2 read_one formats paths in + let concat : beam_type -> beam_type -> beam_type = + fun b1 -> fun b2 -> b1#append b2 in + List.fold_left concat (new beam [||]) beams + + method set : string -> string -> string -> unit = + fun (dir : string) -> + fun (format : string) -> + fun (basename : string) -> + _dir <- dir; + _format <- format; + _basename <- basename; + wave#set _dir _basename; + csv#set _dir _basename + + method write : int array -> float array array array -> string array = + fun (rates : int array) -> + fun (data : float array array array) -> + if _format = "" then + raise (Invalid_argument "output format unset.") + else if _format = "wav" then + wave#write rates data + else if _format = "csv" then + csv#write rates data + else raise (Invalid_argument "unknown format.") + + end;; diff --git a/interpretor/interpreter.ml b/interpretor/interpreter.ml deleted file mode 100644 index 4f0e1ba..0000000 --- a/interpretor/interpreter.ml +++ /dev/null @@ -1,517 +0,0 @@ -(** - 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);; - diff --git a/interpretor/lexer.mll b/interpretor/lexer.mll index a3a4746..1c427a9 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 Sub} +| "*" { 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 Atan2} +| "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 Select2} +| "selectthree" { IDENT Select3} + + +| ['0'-'9']+ as a { CONST a } +| '.' { POINT } + + +| '(' { LPAR } +| ')' { RPAR } +| ',' { PAR } +| ':' { SEQ } +| "<:" { SPLIT } +| ":>" { MERGE } +| "~" { REC } +| eof { EOF } diff --git a/interpretor/main.ml b/interpretor/main.ml index b703a72..a99a7a5 100644 --- a/interpretor/main.ml +++ b/interpretor/main.ml @@ -2,242 +2,111 @@ Module: Interpreter Description: Input wave -> interpretation -> output wave @author WANG Haisheng - Created: 15/05/2013 Modified: 04/06/2013 + Created: 15/05/2013 Modified: 14/08/2013 *) -open Faustexp;; -open Interpreter;; +open Aux;; +open Process;; +open Faustio;; -(* EXCEPTIONS *) - -(** Exception raised when no string expression of faust process is typed in console.*) exception Missing_Expression;; +let version = "Faustine: 0.0.1";; - -(* MACRO *) - -(** Macro constants of input/output route.*) -type io_macro = - | Input_Route_string - | Output_Route_string - | Dsp_Route_string;; - -(** val io_macro_to_string : io_macro -> string.*) -let io_macro_to_string m = match m with - | Input_Route_string -> "" - | Output_Route_string -> "../output_sounds/" - | Dsp_Route_string -> "";; - - -(** val set_GC : unit -> unit *) let set_GC () = - let _ = Gc.set { (Gc.get()) with Gc.minor_heap_size = 0xFFFFFF } in - let _ = Gc.set { (Gc.get()) with Gc.major_heap_increment = 0xFFFFFF } in - let _ = Gc.set { (Gc.get()) with Gc.space_overhead = 100 } in - let _ = Gc.set { (Gc.get()) with Gc.max_overhead = 0xFFFFF } in - let _ = Gc.set { (Gc.get()) with Gc.stack_limit = 0xFFFFF } in - let _ = Gc.set { (Gc.get()) with Gc.allocation_policy = 0 } in + let _ = Gc.set { (Gc.get()) + with Gc.minor_heap_size = 0xFFFFFF } in + let _ = Gc.set { (Gc.get()) + with Gc.major_heap_increment = 0xFFFFFF } in + let _ = Gc.set { (Gc.get()) + with Gc.space_overhead = 100 } in + let _ = Gc.set { (Gc.get()) + with Gc.max_overhead = 0xFFFFF } in + let _ = Gc.set { (Gc.get()) + with Gc.stack_limit = 0xFFFFF } in + let _ = Gc.set { (Gc.get()) + with Gc.allocation_policy = 0 } in () ;; -(* INPUT && OUTPUT*) - -(** val read_input_wave : string array -> int list * float array list - [read_input_wave argv] gets information from command line, - returns sample rate list and data (in form of float array) list. -*) -let read_input_wave = fun argv -> - let n_input = (Array.length argv) - 4 in - if n_input < 0 then - raise Missing_Expression - else if n_input = 0 then - ([], []) - else - (* open wave file *) - let file_string_array = Array.sub argv 4 n_input in - let make_chemin s = io_macro_to_string Input_Route_string ^ s in - let file_chemin_string_array = Array.map make_chemin file_string_array in - let file_array = Array.map Sndfile.openfile file_chemin_string_array in - let file_list = Array.to_list file_array in - - (* prepare data container *) - let frames_array = Array.map Int64.to_int (Array.map Sndfile.frames file_array) in - let create_data_array num = Array.create num 1. in - let data_float_array_array = Array.map create_data_array frames_array in - let data_float_array_list = Array.to_list data_float_array_array in - - (* read sample rates and data *) - let rate_list = List.map Sndfile.samplerate file_list in - let _ = List.map2 Sndfile.read file_list data_float_array_list in - let _ = List.map Sndfile.close file_list in - (rate_list, data_float_array_list);; - - -(** val write_output_wave : int list -> int list -> float_array_list -> unit. - [write_output_wave channel_numbers sample_rates data] -*) -let write_output_wave = fun channel_int_list -> fun rate_int_list -> fun data_float_array_list -> - let () = print_string(" Faustine -> Writing wave files...") in - let tic = Sys.time () in - - (* make output wave file names : output0, output1, ... *) - let n_output = List.length data_float_array_list in - let n_array = Array.init n_output (fun n -> n) in - let make_file_name i = "output" ^ (string_of_int i) ^ ".wav" in - - (* make output wave file routes *) - let make_chemin s = io_macro_to_string Output_Route_string ^ s in - let file_name_string_array = Array.map make_file_name n_array in - let file_chemin_string_array = Array.map make_chemin file_name_string_array in - let file_chemin_string_list = Array.to_list file_chemin_string_array in - - (* open files for writing with respects to channel numbers and sample rates *) - let file_format = Sndfile.format Sndfile.MAJOR_WAV Sndfile.MINOR_PCM_16 in - let openwr = fun file_chemin_string -> fun channel -> fun rate -> - Sndfile.openfile ~info:(Sndfile.RDWR, file_format, channel, rate) file_chemin_string in - let openwr_fun_list = fun fl -> fun cl -> fun rl -> fun i -> - openwr (List.nth fl i) (List.nth cl i) (List.nth rl i) in - let output_file_list = List.map - (openwr_fun_list file_chemin_string_list channel_int_list rate_int_list) - (Array.to_list (Array.init n_output (fun n -> n))) in - - (* write data into files *) - let _ = List.map2 Sndfile.write output_file_list data_float_array_list in - let _ = List.map Sndfile.close output_file_list in - let toc = Sys.time () in - print_endline(" Done. (duration: " ^ (string_of_float (toc -. tic)) ^ "s)");; - - -let csvread = fun (ic : in_channel) -> - let string_list = ref [] in - try - while true do - string_list := !string_list @ [(input_line ic)] - done; - [||] - with End_of_file -> - (*let () = print_endline(List.nth !string_list 0) in*) - Array.of_list (List.map float_of_string !string_list);; - -let read_input_csv = fun argv -> - let n_input = (Array.length argv) - 4 in - if n_input < 0 then - raise Missing_Expression - else if n_input = 0 then - ([], []) - else - (* open csv file *) - let file_string_array = Array.sub argv 4 n_input in - let make_chemin s = io_macro_to_string Input_Route_string ^ s in - let file_chemin_string_array = Array.map make_chemin file_string_array in - let file_array = Array.map open_in file_chemin_string_array in - let file_list = Array.to_list file_array in - - (* read sample rates and data *) - let rate_list = Array.to_list (Array.create n_input 0) in - let data_float_array_list = List.map csvread file_list in - let _ = List.map close_in file_list in - (rate_list, data_float_array_list);; - - -let write_output_csv = fun channel_int_list -> fun data_float_array_list -> - let () = print_string(" Faustine -> Writing csv files...") in - let tic = Sys.time () in - - (* make output txt file names : output0, output1, ... *) - let n_output = List.length data_float_array_list in - let n_array = Array.init n_output (fun n -> n) in - let make_file_name i = "output" ^ (string_of_int i) ^ ".csv" in - - (* make output wave file routes *) - let make_chemin s = io_macro_to_string Output_Route_string ^ s in - let file_name_string_array = Array.map make_file_name n_array in - let file_chemin_string_array = Array.map make_chemin file_name_string_array in - let file_chemin_string_list = Array.to_list file_chemin_string_array in - - (* open output channels *) - let file_list = List.map open_out file_chemin_string_list in - let data_string_array_list = List.map (Array.map string_of_float) data_float_array_list in - let array_to_string = fun data_string_array -> fun channel_int -> - let data_length = Array.length data_string_array in - let rec to_string_rec = - fun data -> fun channel -> fun n -> fun i -> fun column -> - if i < n then - ( - let element = data.(i) in - if column < (channel - 1) then - element ^ "," ^ (to_string_rec data channel n (i + 1) (column + 1)) - else if column = (channel - 1) then - element ^ "\n" ^ (to_string_rec data channel n (i + 1) 0) - else raise (Invalid_argument "write_output_txt.") - ) - else "" in - to_string_rec data_string_array channel_int data_length 0 0 in - - let data_string_list = List.map2 array_to_string data_string_array_list channel_int_list in - let _ = List.map2 output_string file_list data_string_list in - let _ = List.map close_out file_list in - let toc = Sys.time () in - print_endline(" Done. (duration: " ^ (string_of_float (toc -. tic)) ^ "s)");; - - -let read_input = fun option_in -> fun argv -> - if option_in = "-wav" then - read_input_wave argv - else if option_in = "-csv" then - read_input_csv argv - else raise (Invalid_argument ("Unkown option: " ^ option_in));; - - -(* MAIN *) - -(** val main : unit -> unit -main function reads console input strings (Sys.argv) with -input: string of faust process, input waves in default directory 'input_sounds/' -output: output waves in default directory 'output_sounds/'.*) +let path_dsp = ref "";; +let size_input = ref 0;; +let inputs = ref [];; +let time_max = ref 0xFFFF;; +let dir_output = ref "../output_sounds/";; +let format_output = ref "wav";; +let basename_output = ref "output";; + +let option_usage = "usage: " ^ Sys.argv.(0) + ^ " [-d dsp_src] [-i input] [-t time] [--odir dir] [--oformat wav/csv] [--obasename name]";; + +let option_unknown = + fun x -> raise (Arg.Bad ("Bad argument : " ^ x)) + +let speclist = [ + ("-d", Arg.String (fun s -> path_dsp := s), ": set dsp source file"); + ("-i", Arg.String (fun s -> incr size_input; inputs := !inputs @ [s]), ": set input wave file"); + ("-t", Arg.Int (fun i -> time_max := i), ": set max output length"); + ("--odir", Arg.String (fun s -> dir_output := s), ": set output directory"); + ("--oformat", Arg.String (fun s -> format_output := s), ": set output format"); + ("--obasename", Arg.String (fun s -> basename_output := s), ": set output basename"); + ];; + let main () = - (* ignore system alarm clock *) + let () = Arg.parse speclist option_unknown option_usage in let _ = Sys.signal Sys.sigalrm Sys.Signal_ignore in - - (* set garbage collector *) let _ = set_GC () in + let io = new iomanager in + let () = io#set !dir_output !format_output !basename_output in + + + let () = print_string(" Faustine -> Reading input ...") in + let tic0 = Sys.time () in + let input = io#read !inputs in + let toc0 = Sys.time () in + let () = print_endline(" Done. (duration: " ^ (string_of_float (toc0 -. tic0)) ^ "s.)") in + + + let () = print_string(" Faustine -> Preprocessing...") in + let tic1 = Sys.time () in + let faust_core = Preprocess.preprocess !path_dsp in + let toc1 = Sys.time () in + let () = print_endline(" Done. (duration: " ^ (string_of_float (toc1 -. tic1)) ^ "s.)") in + - (* select output type *) - let option_in = Sys.argv.(1) in - let option_out = Sys.argv.(2) in + let () = print_string(" Faustine -> Constructing process...") in + let tic2 = Sys.time () in + let faust_exp = exp_of_string faust_core in + let proc = (new proc_factory)#make faust_exp in + let toc2 = Sys.time () in + let () = print_endline(" Done. (duration: " ^ (string_of_float (toc2 -. tic2)) ^ "s.)") in - (* read input wave files *) - let (input_rate_list, input_float_array_list) = read_input option_in Sys.argv in + let () = print_string(" Faustine -> Evaluating...") in + let tic3 = Sys.time () in + let output = proc#eval input in + let toc3 = Sys.time () in + let () = print_endline(" Done. (duration: " ^ (string_of_float (toc3 -. tic3)) ^ "s.)") in - try - (* preprocess *) - let dsp_file_route_string = (io_macro_to_string Dsp_Route_string) ^ Sys.argv.(3) in - let () = print_string(" Faustine -> Preprocessing...") in - let tic = Sys.time () in - let exp_string = Preprocess.preprocess(dsp_file_route_string) in - let toc = Sys.time () in - let () = print_endline(" Done. (duration: " ^ - (string_of_float (toc -. tic)) ^ "s)") in - (* parsing *) - let exp_faust = exp_of_string exp_string in + let () = print_string(" Faustine -> Calculating...") in + let tic4 = Sys.time () in + let data = output#output !time_max in + let rates = output#frequency in + let toc4 = Sys.time () in + let () = print_endline(" Done. (duration: " ^ (string_of_float (toc4 -. tic4)) ^ "s.)") in - (* interpretation *) - let (output_channel_list, output_rate_list, output_float_array_list) = - interpreter exp_faust (input_rate_list, input_float_array_list) in - (* make output wave files *) - if option_out = "-wav" then - write_output_wave output_channel_list output_rate_list output_float_array_list - else if option_out = "-csv" then - write_output_csv output_channel_list output_float_array_list - else raise (Invalid_argument ("Unkown option: " ^ option_out)) + let () = print_string(" Faustine -> Writing output...") in + let tic5 = Sys.time () in + let output_paths = io#write rates data in + let toc5 = Sys.time () in + let () = print_endline(" Done. (duration: " ^ (string_of_float (toc5 -. tic5)) ^ "s.)") in - with NotYetDone -> - print_endline("Operation not yet programed..");; + let _ = Array.map print_endline + (Array.map decorate output_paths) in + ();; main();; diff --git a/interpretor/parser.mly b/interpretor/parser.mly index a9b470e..9e9b151 100644 --- a/interpretor/parser.mly +++ b/interpretor/parser.mly @@ -3,7 +3,7 @@ %} %token CONST -%token IDENT +%token IDENT %token LPAR RPAR SEQ SPLIT MERGE PAR REC EOF POINT %right SPLIT MERGE %right SEQ @@ -17,7 +17,7 @@ main: faust_exp EOF { $1 }; faust_exp: CONST { Const(N (int_of_string $1)) } | CONST POINT { Const(R (float_of_string $1)) } | CONST POINT CONST { Const(R (float_of_string ($1 ^ "." ^ $3))) } - | IDENT { Ident(symbol_of_string $1) } + | IDENT { Ident($1) } | LPAR faust_exp RPAR { $2 } | faust_exp PAR faust_exp { Par($1,$3) } | faust_exp SPLIT faust_exp { Split($1,$3) } diff --git a/interpretor/process.ml b/interpretor/process.ml new file mode 100644 index 0000000..31cc6c9 --- /dev/null +++ b/interpretor/process.ml @@ -0,0 +1,315 @@ +(** + Module: Process + Description: Faust process classes + @author WANG Haisheng + Created: 03/06/2013 Modified: 14/08/2013 +*) + +open Types;; +open Aux;; +open Basic;; +open Symbol;; +open Value;; +open Signal;; +open Beam;; + +exception NotYetDone;; +exception Dimension_error of string;; +exception Process_error of string;; + + +(* PARSER *) + +let exp_of_string s = (Parser.main Lexer.token (Lexing.from_string s));; + + +class dimension : int * int -> dimension_type = + fun (init : int * int) -> + object (self) + val _input = fst init + val _output = snd init + + method input = _input + method output = _output + + method par : dimension_type -> dimension_type = + fun dim -> + new dimension + ((self#input + dim#input), (self#output + dim#output)) + + method seq : dimension_type -> dimension_type = + fun dim -> + if self#output = dim#input then + new dimension (self#input, dim#output) + else raise (Dimension_error "seq dimension not matched.") + + method split : dimension_type -> dimension_type = + fun dim -> + if dim#input mod self#output = 0 then + new dimension (self#input, dim#output) + else raise (Dimension_error "split dimension not matched.") + + method merge : dimension_type -> dimension_type = + fun dim -> + if self#output mod dim#input = 0 then + new dimension (self#input, dim#output) + else raise (Dimension_error "merge dimension not matched.") + + method _rec : dimension_type -> dimension_type = + fun dim -> + if self#output >= dim#input && self#input >= dim#output then + new dimension (self#input - dim#output, self#output) + else raise (Dimension_error "rec dimension not matched.") + end;; + +class virtual process = + fun (exp_init : faust_exp) -> + object + val _exp = exp_init + val virtual _dim : dimension_type + val virtual _delay : int + method exp = _exp + method dim = _dim + method delay = _delay + method virtual eval : beam_type -> beam_type + end + +class proc_const : faust_exp -> process_type = + fun (exp_init : faust_exp) -> + let _const = + match exp_init with + | Const b -> b + | _ -> raise (Process_error "const process constructor.") in + + object (self) + inherit process exp_init + val _dim = new dimension (0,1) + val _delay = 0 + method private const = _const + method eval : beam_type -> beam_type = + fun (input : beam_type) -> + if input#get = [||] then + new beam [| new signal 0 (fun t -> new value self#const)|] + else + raise (Process_error "proc_const accepts no input.") + end;; + + +class proc_ident : faust_exp -> process_type = + fun (exp_init : faust_exp) -> + let _symbol = + match exp_init with + | Ident s -> s + | _ -> raise (Process_error "ident process constructor.") in + + object (self) + inherit process exp_init + val _dim = new dimension (dimension_of_symbol _symbol) + val _delay = delay_of_symbol _symbol + method private symb = _symbol + + method private beam_of_ident : int -> signal_type -> beam_type = + fun (n : int) -> + fun (s : signal_type) -> + if n = (self#dim)#input then + new beam [|s|] + else raise (Process_error ("Ident " ^ string_of_symbol self#symb)) + + method eval : beam_type -> beam_type = + fun (input : beam_type) -> + let n = Array.length input#get in + match self#symb with + | Pass -> self#beam_of_ident n input#get.(0) + | Stop -> if n = 1 then new beam [||] + else raise (Process_error "Ident !") + | Add -> self#beam_of_ident n + ((input#get.(0))#add input#get.(1)) + | Sub -> self#beam_of_ident n + ((input#get.(0))#sub input#get.(1)) + | Mul -> self#beam_of_ident n + ((input#get.(0))#mul input#get.(1)) + | Div -> self#beam_of_ident n + ((input#get.(0))#div input#get.(1)) + | Mem -> self#beam_of_ident n + ((input#get.(0))#mem) + | Delay -> self#beam_of_ident n + ((input#get.(0))#delay input#get.(1)) + | Floor -> self#beam_of_ident n + ((input#get.(0))#floor) + | Int -> self#beam_of_ident n + ((input#get.(0))#int) + | Sin -> self#beam_of_ident n + ((input#get.(0))#sin) + | Cos -> self#beam_of_ident n + ((input#get.(0))#cos) + | Atan -> self#beam_of_ident n + ((input#get.(0))#atan) + | Atan2 -> self#beam_of_ident n + ((input#get.(0))#atan2 input#get.(1)) + | Sqrt -> self#beam_of_ident n + ((input#get.(0))#sqrt) + | Rdtable -> self#beam_of_ident n + ((input#get.(1))#rdtable input#get.(0) input#get.(2)) + | Mod -> self#beam_of_ident n + ((input#get.(0))#_mod input#get.(1)) + | Vectorize -> self#beam_of_ident n + ((input#get.(0))#vectorize input#get.(1)) + | Vconcat -> self#beam_of_ident n + ((input#get.(0))#vconcat input#get.(1)) + | Vpick -> self#beam_of_ident n + ((input#get.(0))#vpick input#get.(1)) + | Serialize -> self#beam_of_ident n + (input#get.(0))#serialize + | Larger -> self#beam_of_ident n + ((input#get.(0))#larger input#get.(1)) + | Smaller -> self#beam_of_ident n + ((input#get.(0))#smaller input#get.(1)) + | Prefix -> self#beam_of_ident n + ((input#get.(1))#prefix input#get.(0)) + | Select2 -> self#beam_of_ident n + ((input#get.(0))#select2 input#get.(1) input#get.(2)) + | Select3 -> self#beam_of_ident n + ((input#get.(0))#select3 input#get.(1) + input#get.(2) input#get.(3)) + end;; + +class virtual process_binary = + fun (exp_init : faust_exp) -> + let (exp_left, exp_right) = + match exp_init with + | Par (e1, e2) -> (e1, e2) + | Seq (e1, e2) -> (e1, e2) + | Split (e1, e2) -> (e1, e2) + | Merge (e1, e2) -> (e1, e2) + | Rec (e1, e2) -> (e1, e2) + | _ -> raise (Process_error "binary process constructor.") in + let proc_left = (new proc_factory)#make exp_left in + let proc_right = (new proc_factory)#make exp_right in + + object + inherit process exp_init + method private proc_left = proc_left + method private proc_right = proc_right + + val _dim = + match exp_init with + | Par (e1, e2) -> (proc_left#dim)#par proc_right#dim + | Seq (e1, e2) -> (proc_left#dim)#seq proc_right#dim + | Split (e1, e2) -> (proc_left#dim)#split proc_right#dim + | Merge (e1, e2) -> (proc_left#dim)#merge proc_right#dim + | Rec (e1, e2) -> (proc_left#dim)#_rec proc_right#dim + | _ -> raise (Process_error "binary process constructor.") + + val _delay = + match exp_init with + | Par (e1, e2) -> max proc_left#delay proc_right#delay + | Seq (e1, e2) -> proc_left#delay + proc_right#delay + | Split (e1, e2) -> proc_left#delay + proc_right#delay + | Merge (e1, e2) -> proc_left#delay + proc_right#delay + | Rec (e1, e2) -> 1 + proc_left#delay + proc_right#delay + | _ -> raise (Process_error "binary process constructor.") + end + +and proc_par : faust_exp -> process_type = + fun (exp_init : faust_exp) -> + object (self) + inherit process_binary exp_init + method eval : beam_type -> beam_type = + fun (input : beam_type) -> + let (sub_input1, sub_input2) = input#cut self#proc_left#dim#input in + let sub_output1 = self#proc_left#eval sub_input1 in + let sub_output2 = self#proc_right#eval sub_input2 in + sub_output1#append sub_output2 + end + +and proc_split : faust_exp -> process_type = + fun (exp_init : faust_exp) -> + object (self) + inherit process_binary exp_init + method eval : beam_type -> beam_type = + fun (input : beam_type) -> + let mid_output = self#proc_left#eval input in + let mid_input = mid_output#matching self#proc_right#dim#input in + self#proc_right#eval mid_input + end + +and proc_merge : faust_exp -> process_type = + fun (exp_init : faust_exp) -> + object (self) + inherit process_binary exp_init + method eval : beam_type -> beam_type = + fun (input : beam_type) -> + let mid_output = self#proc_left#eval input in + let mid_input = mid_output#matching self#proc_right#dim#input in + self#proc_right#eval mid_input + end + +and proc_seq : faust_exp -> process_type = + fun (exp_init : faust_exp) -> + object (self) + inherit process_binary exp_init + method eval : beam_type -> beam_type = + fun (input : beam_type) -> + let mid_output = self#proc_left#eval input in + self#proc_right#eval mid_output + end + +and proc_rec : faust_exp -> process_type = + fun (exp_init : faust_exp) -> + object (self) + inherit process_binary exp_init + method eval : beam_type -> beam_type = + fun (input : beam_type) -> + let memory = Hashtbl.create self#delay in + let rates = ref (Array.make self#dim#output 0) in + + let split : (time -> value_type array) -> (time -> value_type) array = + fun beam_at -> + let get_signal = + fun beam_func -> fun i -> fun t -> + (beam_func t).(i) in + Array.init self#dim#output (get_signal beam_at) in + + let feedback : (time -> value_type array) -> beam = + fun beam_at -> + let signals_at = split beam_at in + let delay_by_one = fun s -> fun t -> s (t - 1) in + let delay_signal_funcs = Array.map delay_by_one + (Array.sub signals_at 0 self#proc_right#dim#input) in + new beam (array_map2 (new signal) + (Array.sub !rates 0 self#proc_right#dim#input) + delay_signal_funcs) in + + let rec beam_at : time -> value_type array = + fun (t : time) -> + if t < 0 then + Array.make self#dim#output (new value Zero) + else if Hashtbl.mem memory t then + Hashtbl.find memory t + else + let beam_fb_in = feedback beam_at in + let beam_fb_out = self#proc_right#eval beam_fb_in in + let beam_in = beam_fb_out#append input in + let beam_out = self#proc_left#eval beam_in in + let values = beam_out#at t in + let () = (rates := beam_out#frequency) in + let () = Hashtbl.add memory t values in + let () = if t - self#delay >= 0 then + Hashtbl.remove memory (t - self#delay) else () in + values in + new beam (array_map2 (new signal) !rates (split beam_at)) + end + +and proc_factory = + object + method make : faust_exp -> process_type = + fun (exp : faust_exp) -> + match exp with + | Const b -> new proc_const exp + | Ident s -> new proc_ident exp + | Par (e1, e2) -> new proc_par exp + | Seq (e1, e2) -> new proc_seq exp + | Split (e1, e2) -> new proc_split exp + | Merge (e1, e2) -> new proc_merge exp + | Rec (e1, e2) -> new proc_rec exp + end;; diff --git a/interpretor/signal.ml b/interpretor/signal.ml index 3440adc..2dd9f73 100644 --- a/interpretor/signal.ml +++ b/interpretor/signal.ml @@ -1,339 +1,209 @@ (** 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 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 i t 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 1 t 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 () = self#add_memory 1 in + let func : time -> value_type = + fun t -> + if t = 0 then s_init#at 0 + else if t > 0 then self#at (t - 1) + 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/symbol.ml b/interpretor/symbol.ml new file mode 100644 index 0000000..a37f1d3 --- /dev/null +++ b/interpretor/symbol.ml @@ -0,0 +1,106 @@ +(** + Module: Symbol + Description: Symbols' information in faust. + @author WANG Haisheng + Created: 05/08/2013 Modified: 05/08/2013 +*) + +open Types;; + +exception Symbol_error of string;; + +(* MACRO *) +let delay_memory_length = 100000;; +let rdtable_memory_length = 100000;; +let vectorize_memory_length = 1000;; + +let dimension_of_symbol : symbol -> int * int = + fun (s : symbol) -> + match s with + |Add -> (2, 1) + |Sub -> (2, 1) + |Mul -> (2, 1) + |Div -> (2, 1) + |Pass -> (1, 1) + |Stop -> (1, 0) + |Mem -> (1, 1) + |Delay -> (2, 1) + |Floor -> (1, 1) + |Int -> (1, 1) + |Sin -> (1, 1) + |Cos -> (1, 1) + |Atan -> (1, 1) + |Atan2 -> (2, 1) + |Sqrt -> (1, 1) + |Rdtable -> (3, 1) + |Mod -> (2, 1) + |Vectorize -> (2, 1) + |Vconcat -> (2, 1) + |Vpick -> (2, 1) + |Serialize -> (1, 1) + |Larger -> (2, 1) + |Smaller -> (2, 1) + |Prefix -> (2, 1) + |Select2 -> (3, 1) + |Select3 -> (4, 1);; + +let delay_of_symbol : symbol -> int = + fun (s : symbol) -> + match s with + |Add -> 0 + |Sub -> 0 + |Mul -> 0 + |Div -> 0 + |Pass -> 0 + |Stop -> 0 + |Mem -> 1 + |Delay -> delay_memory_length + |Floor -> 0 + |Int -> 0 + |Sin -> 0 + |Cos -> 0 + |Atan -> 0 + |Atan2 -> 0 + |Sqrt -> 0 + |Rdtable -> rdtable_memory_length + |Mod -> 0 + |Larger -> 0 + |Smaller -> 0 + |Vectorize -> vectorize_memory_length + |Vconcat -> 0 + |Vpick -> 0 + |Serialize -> 0 + |Prefix -> 1 + |Select2 -> 0 + |Select3 -> 0;; + +let string_of_symbol : symbol -> string = + fun (s : symbol) -> + match s with + |Add -> "Add" + |Sub -> "Sub" + |Mul -> "Mul" + |Div -> "Div" + |Pass -> "Pass" + |Stop -> "Stop" + |Mem -> "Mem" + |Delay -> "Delay" + |Floor -> "Floor" + |Int -> "Int" + |Sin -> "Sin" + |Cos -> "Cos" + |Atan -> "Atan" + |Atan2 -> "Atan2" + |Sqrt -> "Sqrt" + |Rdtable -> "Rdtable" + |Mod -> "Mod" + |Larger -> "Larger" + |Smaller -> "Smaller" + |Vectorize -> "Vectorize" + |Vconcat -> "Vconcat" + |Vpick -> "Vpick" + |Serialize -> "Serialize" + |Prefix -> "Prefix" + |Select2 -> "Select2" + |Select3 -> "Select3";; + diff --git a/interpretor/types.ml b/interpretor/types.ml index 5c2c29d..dae188f 100644 --- a/interpretor/types.ml +++ b/interpretor/types.ml @@ -1,12 +1,52 @@ -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 of_float_array : float array -> value_type + 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 + | Sub | Mul | Div | Pass @@ -18,59 +58,23 @@ type symbol = Add | Sin | Cos | Atan - | Atantwo + | Atan2 | Sqrt | Rdtable | Mod | Vectorize - | Concat - | Nth + | Vconcat + | Vpick | Serialize | Larger | Smaller | Prefix - | 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) + | Select2 + | Select3 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 +83,77 @@ 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_memory : int -> unit + 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 get : signal_type array + method width : int + method sub : int -> int -> beam_type + method cut : int -> beam_type * beam_type + method append : beam_type -> beam_type + method matching : int -> beam_type + method at : time -> value_type array + method output : int -> float array array array + method frequency : int array + end;; + + +class type dimension_type = + object + method input : int + method output : int + method par : dimension_type -> dimension_type + method seq : dimension_type -> dimension_type + method split : dimension_type -> dimension_type + method merge : dimension_type -> dimension_type + method _rec : dimension_type -> dimension_type + end;; + + +class type process_type = + object + method exp : faust_exp + method dim : dimension_type + method delay : int + method eval : beam_type -> beam_type + end;; + + +class type io_type = + object + method set : string -> string -> unit + method read : string array -> beam_type + method write : int array -> float array array array -> string array + end;; diff --git a/interpretor/value.ml b/interpretor/value.ml index 1701b4e..3c97aa0 100644 --- a/interpretor/value.ml +++ b/interpretor/value.ml @@ -2,479 +2,56 @@ 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 of_float_array : float array -> value_type = + fun data -> new value (basic_of_float_array data) + + 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;; diff --git a/output_sounds/output0.csv b/output_sounds/output0.csv deleted file mode 100644 index 2b76430..0000000 --- a/output_sounds/output0.csv +++ /dev/null @@ -1 +0,0 @@ -11.7147434919,14.7244318637,21.8646614527,13.0995405061,4.81455509541,1.81200558906,0.985314140699,0.657336220842,0.480263717254,0.369198828126,0.293610919264,0.239431890082,0.199096695505,0.168215674241,0.14396373467,0.124547035321,0.108830638738,0.0958529856501,0.0849893365752,0.0758324610431,0.0680867661039,0.0612975764474,0.0556597101255,0.0505611872284,0.0462751307322,0.042379194851,0.038564116328,0.0358757660985,0.0327819409999,0.0303545995073,0.0283130511756,0.0260217011052,0.0244516499572,0.0227531029172,0.0210358278932,0.0196693939287,0.0183035214354,0.0171118352455,0.0160864158164,0.0150388854444,0.0140544948901,0.0131173447842,0.0122472575581,0.0119764568614,0.0102131753247,0.00947366553556,0.0103306471841,0.00909380608468,0.00845798636029,0.0068121972559,0.00595819695743,0.00663240250984,0.00724001738186,0.00644375114071,0.00498097616174,0.006585079271,0.00499721534749,0.00292955159168,0.00409498970219,0.00445818375496,0.0023379079251,0.00453618881051,0.00440644607224,0.003663670503,0.00161748100223,0.003663670503,0.00440644607225,0.00453618881051,0.0023379079251,0.00445818375496,0.00409498970219,0.00292955159168,0.00499721534749,0.006585079271,0.00498097616174,0.00644375114071,0.00724001738186,0.00663240250984,0.00595819695743,0.0068121972559,0.00845798636029,0.00909380608468,0.0103306471841,0.00947366553556,0.0102131753247,0.0119764568614,0.0122472575581,0.0131173447842,0.0140544948901,0.0150388854444,0.0160864158164,0.0171118352455,0.0183035214354,0.0196693939287,0.0210358278932,0.0227531029172,0.0244516499572,0.0260217011052,0.0283130511756,0.0303545995073,0.0327819409999,0.0358757660985,0.038564116328,0.042379194851,0.0462751307322,0.0505611872284,0.0556597101255,0.0612975764474,0.0680867661039,0.0758324610431,0.0849893365752,0.0958529856501,0.108830638738,0.124547035321,0.14396373467,0.168215674241,0.199096695505,0.239431890082,0.293610919264,0.369198828126,0.480263717254,0.657336220842,0.985314140699,1.81200558906,4.81455509541,13.0995405061,21.8646614527,14.7244318637