(********* Exercice 1 *********) type weight = | Kilo of float | Livre of float | Carat of float;; let weight_to_float w = match w with | Kilo f -> f | Livre f -> f/.2.205 | Carat f -> f/.5000.;; type zloty = One | Seven | Thirteen;; let rec petty_cash n = if (n>=13) then Thirteen::(petty_cash (n-13)) else if (n>7) then Seven::(petty_cash (n-7)) else if (n>=1) then One::(petty_cash (n-1)) else [];; petty_cash 254;; type numeric = Real of float | Complex of (float*float) type solution = One of numeric | TwoReal of (numeric*numeric) | TwoComplex of (numeric*numeric) (* Finds the roots of a trinom ax^2+bx+c *) let trinom_root (a,b,c) = let delta = b*.b -. 4.*.a*.c in if (delta > 0.) then TwoReal (Real ((-.b+.sqrt(delta))/.(2.*.a)), Real ((-.b-.sqrt(delta))/.(2.*.a))) else if (delta < 0.) then TwoComplex (Complex ((-.b/.(2.*.a), sqrt(delta)/.(2.*.a))), Complex ((-.b/.(2.*.a), -.sqrt(delta)/.(2.*.a)))) else One (Real (-.b/.2./.a));; trinom_root (1.,2.,1.);; (* Here the type 'solution' does not ensure that, for example, the TwoReal constructors contains effectively real values (in fact they could be complex). A more precise choice for types could be : *) type real = Real of float type complex = Complex of (float*float) type solution = One of real | TwoReal of (real*real) | TwoComplex of (complex*complex) (********* Exercice 2 *********) (***** Binary trees *****) type 'a bintree = | BinEmpty | BinNode of ('a * 'a bintree * 'a bintree) let rec bintree_build f h x = if (h <= 0) then BinEmpty else let (x1,x2) = f(x) in BinNode (x, (bintree_build f (h-1) x1), (bintree_build f (h-1) x2));; let bintree_interv h = bintree_build (fun x -> (2*x,2*x+1)) h 1;; let t1 = bintree_interv 3;; let rec bintree_insert t x = match t with | BinEmpty -> BinNode(x, BinEmpty, BinEmpty) | BinNode(y, tl, tr) -> if (y < x) then BinNode(y, tl, bintree_insert tr x) else BinNode(y, bintree_insert tl x, tr) (* Successively insert the values into the tree *) let t2 = List.fold_left bintree_insert BinEmpty [4;1;6;0;3;5;7];; let rec bintree_fold f e t = match t with | BinEmpty -> e | BinNode(y, tl, tr) -> f y (bintree_fold f e tl) (bintree_fold f e tr);; bintree_fold (fun el x y -> el + x + y) 0 t1;; (* sum of values *) bintree_fold (fun el x y -> el::x@y) [] t2;; (* tree to list *) (***** Arbitrary trees *****) type 'a tree = | TEmpty | TNode of 'a * 'a tree list;; (* Map -- not tail-recursive *) let rec tree_map f tr = match tr with | TEmpty -> TEmpty | TNode(a,l) -> TNode (f(a),List.map (tree_map f) l);; let rec tree_build f n rac = match n with | 0 -> TNode(rac,[]) | _ -> let lrac = f(rac) in let ltree = List.map (tree_build f (n-1)) lrac in TNode(rac,ltree);; let n = 11;; let t = tree_build (fun x -> [x;x+1]) n 1;; tree_map (float) t;; (* Map - tail-recursive / long *) let rec int_list n = let rec int_list_rec n l = match n with | 0 -> [] | 1 -> 1::l | _ -> (int_list_rec (n-1) (n::l)) in int_list_rec n [];; int_list 15;; (* [1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15] *) let list_concat l1 l2 = let rec list_concat_rec l1 l2 r = match (l1,l2) with | ([],[]) -> List.rev r; | (x::c,_) -> list_concat_rec c l2 (x::r) | (_,y::d) -> list_concat_rec l1 d (y::r) in list_concat_rec l1 l2 [];; list_concat [1;2;3] [4;5;6];; let rec enum_paths tr = let rec parcours to_visit visited = if (List.length to_visit) = 0 then (List.rev visited) else let (p,t) = (List.hd to_visit) in match t with | TEmpty -> parcours (List.tl to_visit) visited | TNode(a,l) -> let patl = int_list (List.length l) in let newl = List.map2 (fun x y -> ((list_concat p [x]),y)) patl l in parcours (list_concat (List.tl to_visit) newl) ((p,a)::visited) in parcours [([],tr)] [];; let rec replace_nth l n e = let rec replace_rec l n e r = match n with | 1 -> list_concat (List.rev r) (e::(List.tl l)) | _ -> replace_rec (List.tl l) (n-1) e ((List.hd l)::r) in replace_rec l n e [];; replace_nth [1;2;3;4] 3 8;; let rec is_prefix l1 l2 = match (l1,l2) with | ([],_) -> true | (x::c,y::d) -> (x=y) && is_prefix c d | _ -> false;; is_prefix [1;3] [1;2;4];; let remove_last l = List.rev(List.tl(List.rev l));; let remove_and_get l x = let rec remove_and_get_rec l x rl rx = match l with | [] -> ((List.rev rl),rx) | (a,b)::c -> if (b=x) then remove_and_get_rec c x rl (a::rx) else remove_and_get_rec c x ((a,b)::rl) rx in remove_and_get_rec l x [] [];; remove_and_get [("a",1);("b",1);("c",5)] 1;; remove_and_get [("a",1);("b",3);("c",5)] 2;; let rec insert_along_paths pathlist treelist = match pathlist with | [] -> failwith "Malformed graph"; | ([],value)::e -> let (finaltreelist,sons) = remove_and_get treelist [] in TNode(value,(List.rev sons)); | (path,value)::c -> let (newtreelist,sons) = remove_and_get treelist path in let newpath = remove_last path in insert_along_paths c ((TNode(value,(List.rev sons)),newpath)::newtreelist);; let tr = TNode(1, [TNode(2, [TNode(4,[]);TNode(5,[])]); TNode(3,[])]);; enum_paths tr;; insert_along_paths (List.rev (enum_paths tr)) [];; let rec list_map_second f l r = match l with | [] -> (List.rev r) | (a,b)::c -> list_map_second f c ((a,f(b))::r);; list_map_second (float) [("a",1);("b",2)] [];; let tree_map f tr = let l = List.rev (enum_paths tr) in let nl = list_map_second f l [] in insert_along_paths nl [];; tree_map (fun x -> (float x)) tr;; (* Tail-recursive CPS-style tree map function *) let tree_map_tail_rec f t = let rec tr t k = match t with | TreeEmpty -> k TreeEmpty | TreeNode(x,[]) -> k (TreeNode(f x,[])) | TreeNode(x,h::t) -> tr h (fun rh -> tr (TreeNode(x,t)) (function | (TreeNode(fx,t')) -> k (TreeNode(fx,rh::t')) | _ -> failwith "Never reached")) in tr t (fun x -> x) (********* Exercice 3 *********) interface Plus { kind: "op_plus"; } interface Minus { kind: "op_minus"; } interface Equal { kind: "op_equal"; } interface Mult { kind: "op_mult"; } // operators type Op = Plus | Minus | Equal | Mult; interface ExprInt { kind: "expr_int", int: number } interface ExprVar { kind: "expr_var", var: string } interface ExprBin { kind: "expr_bin", lhs: Expr, op: Op, rhs : Expr } type Expr = ExprInt | ExprVar | ExprBin; interface ValInt { kind: "val_int", val: number } interface ValBool { kind: "val_bool", val: boolean } type Value = ValInt | ValBool; type Env = { [id: string] : Value; } interface InstrGoto { kind: "instr_goto", line: number } interface InstrJumpIf { kind: "instr_jumpif", cond: Expr, line: number } interface InstrLet { kind: "instr_let", id: string, expr: Expr } type Instr = InstrGoto | InstrJumpIf | InstrLet ; interface Line { instr : Instr, line: number } type Prog = Line[]; interface State { env: Env, line: number } function env_lookup(env: Env, id: string) : Value { return env[id]; } function env_add(env: Env, id: string, val: Value) : Env { env[id] = val; return env; } function op_apply(lval: Value, op: Op, rval: Value) : Value { switch (op.kind) { case "op_equal": return { kind: "val_bool", val: (lval as ValBool).val == (rval as ValBool).val } case "op_plus": return { kind: "val_int", val: (lval as ValInt).val + (rval as ValInt).val } case "op_minus": return { kind: "val_int", val: (lval as ValInt).val - (rval as ValInt).val } case "op_mult": return { kind: "val_int", val: (lval as ValInt).val * (rval as ValInt).val } } } function eval_expr(expr: Expr, env: Env) : Value { switch (expr.kind) { case "expr_int": return { kind: "val_int", val: expr.int } case "expr_var": return env_lookup(env, expr.var); case "expr_bin": { let lval = eval_expr(expr.lhs, env); let rval = eval_expr(expr.rhs, env); return op_apply(lval, expr.op, rval); } } } function prog_lookup(prog: Prog, line: number) : Line | undefined { return prog.find((l) => l.line == line); } function eval_instr(instr: Instr, state: State) : State { switch (instr.kind) { case "instr_goto": return { env: state.env, line: instr.line } case "instr_let": return { env: env_add(state.env, instr.id, eval_expr(instr.expr, state.env)), line: state.line + 10 } case "instr_jumpif": { let v : Value = eval_expr(instr.cond, state.env); console.log(v); console.log(state.env); if ((v as ValBool).val) return { env: state.env, line: instr.line } else return { env: state.env, line: state.line + 10 } } } } let prog : Prog = [ { line: 10, instr: { kind: "instr_let", id: "i", expr: { kind: "expr_int", int: 1}} }, { line: 20, instr: { kind: "instr_let", id: "s", expr: { kind: "expr_int", int: 1}} }, { line: 30, instr: { kind: "instr_let", id: "i", expr: { kind: "expr_bin", op: { kind: "op_plus"}, lhs: { kind: "expr_var", var: "i"}, rhs: { kind: "expr_int", int: 1} }} }, { line: 40, instr: { kind: "instr_let", id: "s", expr: { kind: "expr_bin", op: { kind: "op_mult"}, lhs: { kind: "expr_var", var: "i"}, rhs: { kind: "expr_var", var: "s"} }} }, { line: 50, instr: { kind: "instr_jumpif", cond: { kind: "expr_bin", op: { kind: "op_equal" }, lhs: { kind: "expr_var", var: "i"}, rhs: {kind: "expr_var", var: "n"}}, line: 70} }, { line: 60, instr: { kind: "instr_goto", line: 30} }, ] function eval_prog(prog: Prog, start: number, env: Env) : Env { console.log("Evaluating line " + start); let line = prog_lookup(prog, start); if (line == undefined) return env; let state : State = { env: env, line: line.line} let next : State = eval_instr(line.instr, state) return eval_prog(prog, next.line, next.env); } let res : Env = eval_prog(prog, 10, { n: { kind: "val_int", val: 4 }}); console.log(res);