(********* Exercice 1 *********) (* First implementation freezing values *) type 'a frozen_flow = | End of 'a | Step of (unit -> 'a frozen_flow);; let thaw t = match t with | End x -> End x | Step f -> f();; let ppcm x y = let rec ppcm_rec x y mul = if (y > x) then (ppcm_rec y x mul) else (* Ensures x >= y *) if (x = 0) then 0 else (* Ensures both are positive *) let r = (x mod y) in if (r = 0) then (mul/y) else ppcm_rec y r mul in ppcm_rec x y (x*y);; let ppcm_lazy x y = let rec ppcm_lazy_rec x y mul = if (y > x) then Step (fun () -> (ppcm_lazy_rec y x mul)) else if (y = 0) then End 0 else let r = (x mod y) in if (r = 0) then End (mul/y) else Step (fun () -> (ppcm_lazy_rec y r mul)) in ppcm_lazy_rec x y (x*y);; ppcm_lazy 12 14;; thaw(thaw(ppcm_lazy 12 14));; (* Second implementation displaying the values taken during the computation *) type ('key,'data) frozen_data_flow = | End of 'data | Step of (unit -> (('key*'data) list) * ('key,'data) frozen_data_flow);; let nthaw t = match t with | End x -> ([],End x) | Step f -> f();; let nppcm x y = let rec nppcm_rec x y mul = if (y > x) then Step (fun () -> ([("x",y);("y",x)],nppcm_rec y x mul)) else if (y = 0) then End 0 else let r = (x mod y) in if (r = 0) then End (mul/y) else Step (fun () -> ([("x",y);("y",r)],nppcm_rec y r mul)) in nppcm_rec x y (x*y);; nppcm 12 14;; nthaw(snd(nthaw(nppcm 12 14)));; (********* Exercice 2 *********) let lazy_int = lazy(1);; let lazy_list = lazy([5;6;7]);; let lazy_array = lazy(Array.make 5 "Cot");; Lazy.force lazy_array;; Lazy.force lazy_array;; (* Notice that the type of lazy_array is not modified *) lazy_array;; let lazy_print = lazy(print_string "Codec");; Lazy.force lazy_print;; (* The print is done only once *) Lazy.force lazy_print;; (* The result of the evaluation is unit *) let f = lazy (failwith "Marchera pas");; Lazy.force f;; (* The exception is thrown each time *) Lazy.force f;; (* It can be thought as the result of the evaluation *) (********* Exercice 3 *********) type 'a stm = | StmEmpty | StmCons of ('a * 'a stm) lazy_t let my_stm = StmCons (lazy (1, StmCons(lazy (1/0, StmEmpty))));; (* Problem : the first element must be evaluated *) let stm_head stm = match stm with | StmEmpty -> failwith "No head" | StmCons(lazy(x,_)) -> x;; let stm_tail stm = match stm with | StmEmpty -> failwith "No tail" | StmCons(lazy(_,t)) -> t;; stm_head my_stm;; stm_tail my_stm;; let rec length_evaluated stm = match stm with | StmEmpty -> 0 | StmCons(t) -> if not(Lazy.is_val t) then 0 else let (_,u) = Lazy.force t in 1 + length_evaluated u;; length_evaluated my_stm;; (* -> 0 *) stm_head my_stm;; (* -> 1, the head of the stream *) length_evaluated my_stm;; (* -> 1 *) let rec stm_npeek stm n = if (n<=0) then [] else match stm with | StmEmpty -> [] | StmCons(lazy(u,v)) -> u::(stm_npeek v (n-1));; let rec list_to_stream l = match l with | [] -> StmEmpty | x::c -> StmCons (lazy(x, list_to_stream c));; list_to_stream [1;2;3;4];; stm_npeek (list_to_stream [1;2;3;4]) 72;; let rec fun_to_stream_bounded f x n = if (n=0) then StmEmpty else StmCons (lazy (x, fun_to_stream_bounded f (f x) (n-1)));; let rec fun_to_stream f x = StmCons (lazy (x, fun_to_stream f (f x)));; stm_npeek (fun_to_stream_bounded (fun x -> x + 1) 1 10) 72;; stm_npeek (fun_to_stream (fun x -> x + 1) 1) 72;; let rec stm_map f stm = match stm with | StmEmpty -> StmEmpty | StmCons(lazy(u,v)) -> StmCons(lazy(f u, stm_map f v));; let rec stm_compose f stm1 stm2 = match (stm1,stm2) with | (StmEmpty,StmEmpty) -> StmEmpty | (StmCons(lazy(u1,v1)),StmCons(lazy(u2,v2))) -> StmCons(lazy( ((f u1 u2),(stm_compose f v1 v2)))) | _ -> failwith "stm_compose : different lengths";; let rec stm_concat stm1 stm2 = match stm1 with | StmEmpty -> stm2 | StmCons(lazy(u,v)) -> StmCons(lazy(u, stm_concat v stm2));; (********* Exercice 4 *********) type 'a tree = TmEmpty | TmCons of ('a * 'a tree list) let rec list_build a b = if (a>=b) then [] else a::(list_build (a+1) b);; let rec tree_build f n start = let nl = f start in let tl = if (n<=0) then [] else List.map (tree_build f (n-1)) nl in TmCons (start, tl);; (* Builds a tree of integers of depth d and branching k *) let tree_interv k d = tree_build (fun x -> list_build (k*x-k+2) (k*x+2)) d 1;; let rec tree_to_string t = match t with | TmEmpty -> "" | TmCons(x,xs) -> if (xs = []) then string_of_int x else let ss = String.concat "," (List.map tree_to_string xs) in (string_of_int x)^"["^ss^"]";; tree_to_string (tree_interv 2 3);; type 'a stm = StmEmpty | StmCons of ('a * 'a stm) lazy_t let rec fun_to_stream_bounded f x n = if (n=0) then StmEmpty else StmCons (lazy (x, fun_to_stream_bounded f (f x) (n-1)));; let rec stm_map f stm = match stm with | StmEmpty -> StmEmpty | StmCons(x) -> StmCons(lazy(let (u,v) = Lazy.force x in (f u, stm_map f v)));; let rec stm_to_list stm = match stm with | StmEmpty -> [] | StmCons(lazy(u,s)) -> u::(stm_to_list s);; type 'a lazytree = LTEmpty | LTCons of ('a lazy_t) * (('a lazytree) stm);; let rec lazytree_build f start = let nstm = f start in let tstm = stm_map (lazytree_build f) nstm in LTCons (lazy(start), tstm);; (* Builds a lazytree of integers with branching degree k *) let lazytree_interv k = lazytree_build (fun x -> fun_to_stream_bounded (fun y -> y+1) (k*x-k+2) k) 1;; let rec lazytree_to_string d t = match t with | LTEmpty -> "" | LTCons(lazy x,xs) -> if (xs = StmEmpty) || (d<=1) then string_of_int x else let ss = String.concat "," (stm_to_list (stm_map (lazytree_to_string (d-1)) xs)) in (string_of_int x)^"["^ss^"]";; lazytree_to_string 3 (lazytree_interv 3);;