(**************************************************************) (* Chapitre 6 de Programmation fonctionnelle, générique et objet (Une introduction avec le langage OCaml) Ph. Narbel, Vuibert, 2005 Ces programmes ont pour but d'illustrer les sujets traités dans le livre. Il n'est donné aucune garantie quant à leur utilisation dans le cadre d'une activité professionnelle ou commerciale. Ces programmes peuvent être copiés sous reserve que leur provenance soit citée et que cet avertissement soit inclus. These programs are provided without warranty of any kind. Their purpose is just to serve as illustrations in the book. Permission to copy is granted provided that citation and this disclaimer of warranty are included. *) let rec list_build f n x = if n <= 0 then [] else x :: (list_build f (n - 1) (f x));; let list_interv n len = list_build (fun x -> x + 1) len n;; let list_from f k m = List.map f (list_interv k m);; let hd l = match l with | [] -> None | x :: _ -> Some x;; let hd l = match l with | [] -> failwith "hd" | x :: _ -> x;; let rec assoc x l = match l with | [] -> failwith "Not_found" | (key, data) :: xs -> if key = x then data else assoc x xs;; type ('a, 'b) assoc_list = | AEmpty | ACons of ('a * 'b) * ('a, 'b) assoc_list;; let rec assoc x l = match l with | AEmpty -> failwith "Not_found" | ACons ((key, data), xs) -> if key = x then data else assoc x xs;; 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 rec bintree_map f tree = match tree with | BinEmpty -> BinEmpty | BinNode (x, t1, t2) -> BinNode (f x, bintree_map f t1, bintree_map f t2);; type 'a tree = | TEmpty | TNode of 'a * 'a tree list;; let rec tree_build f h x = if h < 0 then TEmpty else if h = 0 then TNode (x, []) else TNode (x, List.map (tree_build f (h - 1)) (f x));; let tree_interv h d = tree_build (fun x -> list_interv (d * x - d + 2) d) h 1;; let rec tree_map f t = match t with | TEmpty -> TEmpty | TNode (x, t_list) -> TNode (f x, List.map (tree_map f) t_list);; type 'a binlitree = BinLiTree of 'a tree list bintree;; let binlitree_map f (BinLiTree t) = let rec aux t = match t with | BinEmpty -> BinEmpty | BinNode (x, t1, t2) -> BinNode (List.map (tree_map f) x, aux t1, aux t2) in BinLiTree (aux t);; let filter f l = let rec aux x l = match l with | [] -> [] | x1 :: [] -> [x1] | x1 :: x2 :: xs -> f(x, x1, x2) :: (aux x1 (x2 :: xs)) in match l with | [] -> [] | x :: xs -> x :: (aux x xs);; let rec rev l = match l with | [] -> [] | x :: xs -> (rev xs) @ [x];; let rev' l = let rec aux l1 l2 = match l1 with | [] -> l2 | x :: xs -> aux xs (x :: l2) in aux l [];; type 'a path = | Root | Left of 'a * 'a bintree * 'a path | Right of 'a * 'a bintree * 'a path;; type 'a zipper = Zip of 'a bintree * 'a path;; let move_left (Zip (tree, path)) = match tree with | BinEmpty -> failwith "Empty" | BinNode (x, t1, t2) -> Zip (t1, Left (x, t2, path));; let move_right (Zip (tree, path)) = match tree with | BinEmpty -> failwith "Empty" | BinNode (x, t1, t2) -> Zip (t2, Right (x, t1, path));; let move_up (Zip (tree, path)) = match path with | Root -> failwith "Root" | Left (x, t, path_tail) -> Zip (BinNode (x, tree, t), path_tail) | Right (x, t, path_tail) -> Zip (BinNode (x, t, tree), path_tail) let rec bintree_mem x t = match t with | BinEmpty -> false | BinNode (y, t1, t2) -> x = y || (bintree_mem x t1) || (bintree_mem x t2);; let bintree_mem_breadth x t = let rec aux to_visit = match to_visit with | [] -> false | BinEmpty :: ys -> aux ys | BinNode (y, t1, t2) :: ys -> x = y || aux (ys @ [t1; t2]) in aux [t];; type 'a queue = Q of 'a list * 'a list;; let q_empty = Q ([], []);; let q_transfer (Q (l1, l2) as q) = match l1 with | [] -> Q (List.rev l2, []) | _ -> q;; let q_add x (Q (l1, l2)) = q_transfer (Q (l1, x :: l2));; let q_fst (Q (l1, _)) = match l1 with | [] -> failwith "q_fst" | x :: _ -> x;; let q_out (Q (l1, l2)) = match l1 with | [] -> failwith "q_out" | _ -> q_transfer (Q (List.tl l1, l2));; let bintree_mem_breadth' x t = let rec aux to_visit = if to_visit = q_empty then false else match q_fst to_visit with | BinEmpty -> aux (q_out to_visit) | BinNode (y, t1, t2) -> x = y || aux (q_add t1 (q_add t2 (q_out to_visit))) in aux (q_add t q_empty);; let rec list_of_bintree t = match t with | BinEmpty -> [] | BinNode (y, t1, t2) -> y :: (list_of_bintree t1 @ list_of_bintree t2);; let list_of_bintree' t = let rec aux t acc = match t with | BinEmpty -> acc | BinNode (y, t1, t2) -> y :: (aux t1 (aux t2 acc)) in aux t [];; let rec list_build f n x = if n <= 0 then [] else x :: (list_build f (n - 1) (f x));; let list_build' f n x = let rec aux x n acc = if n <= 0 then acc else aux (f x) (n - 1) (x :: acc) in List.rev (aux x n []);; type height = int;; type 'a bintree = | BinEmpty | BinNode of 'a * 'a bintree * 'a bintree;; type 'a bal_bintree = Baltree of 'a bintree * height;; let balanced_tree_build x (Baltree (t1, h1)) (Baltree (t2, h2)) = if h1 != h2 then None else Some (Baltree (BinNode (x, t1, t2), h1 + 1)) ;; type 'a tree1 = | TEmpty | TNode of 'a * 'a tree1 list;; let rec tree1_build f h x = if h < 0 then TEmpty else if h = 0 then TNode (x, []) else TNode (x, List.map (tree1_build f (h - 1)) (f x));; let rec tree1_build' f h x = if h < 0 then TEmpty else TNode (x, List.map (tree1_build' f (h - 1)) (f x));; type 'a tree2 = | TEmpty | T of 'a tree2_aux and 'a tree2_aux = TNode of 'a * ('a tree2_aux list);; let tree2_build f h x = let rec aux h x = if h = 0 then TNode (x, []) else TNode (x, List.map (aux (h - 1)) (f x)) in if h < 0 then TEmpty else T (aux h x);; type 'a non_empty_list = | End of 'a | NCons of 'a * 'a non_empty_list;; type 'a tree3 = | TEmpty | T of 'a tree3_aux and 'a tree3_aux = | TLeaf of 'a | TNode of 'a * ('a tree3_aux non_empty_list);; type 'a llist = | LListEmpty | LList of 'a full_value * 'a llist and 'a full_value = | Val of 'a | SubList of 'a llist;; let rec append l1 l2 = match l1 with | LListEmpty -> l2 | LList (v, l) -> LList (v, append l l2);; let rec full_flatten l = match l with | LListEmpty -> LListEmpty | LList (v, l) -> ( match v with | Val x as v -> LList (v, full_flatten l) | SubList ll -> append (full_flatten ll) (full_flatten l) );; type 'a vertex = V of 'a and 'a graph1 = Graph of ('a vertex * 'a vertex list) list;; let g1 = Graph [ V "Hay River", [V "Fort Resolution"; V "Fort Smith"]; V "Fort Resolution", []; V "Fort Smith", [V "Fort Vermillon"]; V "Fort Vermillon", [V "Hay River"; V "Fort Chipewyan"]; V "Fort Chipewyan", [V "Fort Smith"]; V "Peace River", [V "Fort Vermillon"] ];; let v1 = V "Hay River" and v2 = V "Fort Resolution" and v3 = V "Fort Smith" and v4 = V "Fort Vermillon" and v5 = V "Fort Chipewyan" and v6 = V "Peace River";; let g1 = Graph [ v1, [v2; v3]; v2, []; v3, [v4]; v4, [v1; v5]; v5, [v3]; v6, [v4] ];; let graph1_mem v (Graph g) = let rec aux x l = match l with | [] -> false | (y, _) :: ys -> y == x || aux x ys in aux v g;; let graph1_nexts (Graph adj) v = List.assq v adj;; let graph1_map f (Graph g) = Graph (List.map (fun (x, l) -> (f (x, l))) g);; type 'k key = K of 'k and ('k, 'a) vertex = 'k key * 'a and ('k, 'a) graph = Graph of (('k, 'a) vertex * 'k key list) list;; let g1 = Graph [ (K 1, "Hay River"), [K 2; K 3]; (K 2, "Fort Resolution"), []; (K 3, "Fort Smith"), [K 4]; (K 4, "Fort Vermillon"), [K 1; K 5]; (K 5, "Fort Chipewyan"), [K 3]; (K 6, "Peace River"), [K 4]; ];; let graph_assoc key (Graph adj) = List.assoc key (List.map fst adj);; let graph_nexts (Graph adj) key = List.assoc key (List.map (fun ((k, _), a) -> (k, a)) adj);; let graph_map f (Graph adj) = Graph (List.map (fun ((key, x), a) -> (key, f x), a) adj);;