(**************************************************************) (* Chapitre 10 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. *) module type LINEAR_CONTAINER = sig type 'a t val empty : unit -> 'a t val add : 'a -> 'a t -> 'a t val mem : 'a -> 'a t -> bool val length : 'a t -> int val nth : 'a t -> int -> 'a end;; module type LINEAR_CONTAINER_EXT = sig include LINEAR_CONTAINER val first : 'a t -> 'a val last : 'a t -> 'a end;; module Lin_Ext (L : LINEAR_CONTAINER) : LINEAR_CONTAINER_EXT = struct include L let first l = L.nth l 0 let last l = L.nth l ((L.length l) - 1) end;; module Simple_List : LINEAR_CONTAINER = struct type 'a t = 'a list let empty () = [] let add x l = x :: l let mem = List.mem let length = List.length let nth = List.nth end;; module Simple_Array : LINEAR_CONTAINER = struct type 'a t = 'a array let empty () = [||] let add x l = let a = Array.make 1 x in Array.append a l let mem x l = List.mem x (Array.to_list l) let length = Array.length let nth l x = l.(x) end;; module L_Ext = Lin_Ext (Simple_List);; module A_Ext = Lin_Ext (Simple_Array);; module type ARITH_STRING = sig type t val of_string : string -> t val to_string : t -> string val zero : t val one : t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val div : t -> t -> t end;; module type ARITH = sig type nb type extern_nb val make : extern_nb -> nb val show : nb -> extern_nb val zero : nb val one : nb val add : nb -> nb -> nb val sub : nb -> nb -> nb val mul : nb -> nb -> nb val div : nb -> nb -> nb end;; module Arith_Adapter (A : ARITH_STRING) : ARITH with type extern_nb = string = struct include A type nb = A.t type extern_nb = string let make = A.of_string let show = A.to_string end;; module Arith_Int64 = Arith_Adapter (Int64);; module Arith_Int32 = Arith_Adapter (Int32);; module type METRIC_SPACE_2D = sig type point val make_point : float * float -> point val dist : point -> point -> float end;; module Metric_Print (M : METRIC_SPACE_2D) : METRIC_SPACE_2D = struct type point = M.point let make_point (x, y) = Printf.printf "POINT CREATION : (%g, %g) \n" x y; M.make_point (x, y) let dist x y = let d = M.dist x y in Printf.printf "COMPUTED DISTANCE : %g \n" d; d end;; module Plane = struct type point = P of float * float let make_point (x, y) = P (x, y) let dist (P (x1, y1)) (P (x2, y2)) = sqrt ( (x1 -. x2) ** 2. +. (y1 -. y2) ** 2.) end;; module Plane_Print = Metric_Print (Plane);; module Bugged_Plane : METRIC_SPACE_2D = struct type point = float * float let make_point (x, y) = (x, y) let dist (x1, y1) (x2, y2) = x1 +. y1 +. x2 +. y2 end;; module Metric_Test (M : METRIC_SPACE_2D) : METRIC_SPACE_2D = struct type point = M.point let make_point = M.make_point let dist x y = let dxy = M.dist x y in if not (dxy >= 0.) then failwith "Negative Distance"; if not ((M.dist x x) = 0.) || not ((M.dist y y) = 0.) then failwith "Non Zero Distance"; if dxy <> (M.dist y x) then failwith "Non Commutative Distance"; let rand = M.make_point (Random.float 1., Random.float 1.) in if not ((M.dist x rand) < dxy +. (M.dist y rand)) then failwith "Non Triangular Distance"; dxy end;; module M_Test = Metric_Test (Bugged_Plane);; module M_TP = Metric_Print (Metric_Test (Bugged_Plane));; module type GRAPHIC_ELEM = sig type t type extern_t val make : extern_t -> t val draw : t -> unit val translate : int * int -> t -> t end;; module Picture (G : GRAPHIC_ELEM) : GRAPHIC_ELEM with type extern_t = G.t list = struct type t = G.t list type extern_t = G.t list let make l = l let draw l = List.iter G.draw l let translate (t1, t2) l = List.map (G.translate (t1, t2)) l end;; module Disk2D (S : sig val radius : int end) : GRAPHIC_ELEM with type extern_t = int * int = struct module G = Graphics let radius = S.radius type t = { x: int; y: int } type extern_t = int * int let make (x, y) = { x = x; y = y } let draw p = G.fill_circle p.x p.y radius let translate (t1, t2) { x = x; y = y } = { x = x + t1; y = y + t2 } end;; module Disk = (Disk2D (struct let radius = 4 end));; module Pic2D = Picture (Disk);; module PPic2D = Picture (Pic2D);; module type ASSOC_TABLE = sig type ('a, 'b) assoc val empty : unit -> ('a, 'b) assoc val get_pair : ('a, 'b) assoc -> 'a * 'b val assoc : ('a, 'b) assoc -> 'a -> 'b val add : 'a -> 'b -> ('a, 'b) assoc -> ('a, 'b) assoc end;; module type GRAPHIC_ENVIRONMENT = sig module T : ASSOC_TABLE type action = int -> int -> unit type behaviors = (char, action) T.assoc val empty : unit -> behaviors val add : char -> action -> behaviors -> behaviors val interaction_with_mouse : behaviors -> unit end;; module G_Env (Assoc : ASSOC_TABLE) : GRAPHIC_ENVIRONMENT = struct module T = Assoc module G = Graphics type action = int -> int -> unit type behaviors = (char, action) T.assoc let empty () = T.empty () let add key action l = T.add key action l let interaction_with_mouse l = let action_state = ref (snd (T.get_pair l)) in while true do let s = G.wait_next_event [G.Button_down; G.Key_pressed] in if s.G.button then !action_state s.G.mouse_x s.G.mouse_y else if s.G.keypressed then try action_state := T.assoc l s.G.key with Not_found -> () done end;; module G_List = G_Env (Assoc_List);; (* cf. chap. 9 *) module G_Tree = G_Env (Assoc_RBTree);; (* cf. chap. 9 *) module type OP = sig type t val op : t -> t -> t end;; module type MATRIX = sig module Coef : OP type 'a gen_mat type t = Coef.t gen_mat val op : t -> t -> t end;; module Matrix (C : OP) (S : sig val size : int end) = struct module Coef = C type 'a gen_mat = 'a array array type t = Coef.t gen_mat let op m1 m2 = let mat = Array.make_matrix S.size S.size m1.(0).(0) in for i = 0 to (S.size - 1) do for j = 0 to (S.size - 1) do mat.(i).(j) <- Coef.op m1.(i).(j) m2.(i).(j) done done; mat end;; module Simple_Float = struct type t = float let op = ( +. ) end;; module Float_2x2 = Matrix (Simple_Float) (struct let size = 2 end);; module Simple_Complex = struct type t = float * float let op (r1, i1) (r2, i2) = (r1 +. r2, i1 +. i2) end;; module Complex_3x3 = Matrix (Simple_Complex) (struct let size = 3 end) ;; module Float_Mat = Matrix (Simple_Float);; module Complex_Mat = Matrix (Simple_Complex);; (* version avec typage explicite : *) module type OP = sig type t val op : t -> t -> t end;; module type MATRIX = sig module Coef : OP type 'a gen_mat type t = Coef.t gen_mat val op : t -> t -> t end;; module Matrix (C : OP) (S : sig val size : int end) : MATRIX with module Coef = C and type 'a gen_mat = 'a array array and type t = C.t array array = struct module Coef = C type 'a gen_mat = 'a array array type t = Coef.t gen_mat let op m1 m2 = let mat = Array.make_matrix S.size S.size m1.(0).(0) in for i = 0 to (S.size - 1) do for j = 0 to (S.size - 1) do mat.(i).(j) <- Coef.op m1.(i).(j) m2.(i).(j) done done; mat end;; module Simple_Int = struct type t = int let op = ( + ) end;; module Int_Matrix_3x3 = Matrix (Simple_Int) (struct let size = 3 end);; let m = [|[|1; 1; 1|]; [|1; 0; 1|]; [|1; 1; 1|]|];; Int_Matrix_3x3.op m m;; module type METRIC_SPACE = sig type point val dist : point -> point -> float val ball : radius:float -> point -> point list end;; module type ORDER = sig type elt val compare : elt -> elt -> int end;; module type OPTIMISATION = sig module M : METRIC_SPACE module O : ORDER type valuation_t = M.point -> O.elt val find_optimal : M.point -> radius:float -> valuation_t -> M.point end;; module Optimis (Metric : METRIC_SPACE) (Ord : ORDER) : OPTIMISATION with module M = Metric and module O = Ord = struct module M = Metric module O = Ord type valuation_t = M.point -> O.elt let rec find_optimal p ~radius f = let val_ball = List.map (fun x -> (x, f x)) (M.ball radius p) in let sorted_ball = List.sort (fun (_, y1) (_, y2) -> O.compare y1 y2) val_ball in if O.compare (f p) (snd (List.hd sorted_ball)) <= 0 then p else find_optimal (fst (List.hd sorted_ball)) ~radius:radius f end;; module Discrete_Line = struct type point = int let dist x y = float (abs (x - y)) let ball ~radius p = let rec aux r p i = if i <= r then p - i :: p + i :: (aux r p (i + 1)) else [] in aux (int_of_float radius) p 1 end;; module Order_Float = struct type elt = float let compare = Pervasives.compare end;; module Grad_Line = Optimis (Discrete_Line) (Order_Float);; module type TYPE = sig type t end module type EQUAL = sig type t val eq : t -> t -> bool end;; module type GRAPH = sig module Key : EQUAL module Label : EQUAL type vertex_data type vertex_key = Key.t type label = Label.t type graph type extern_graph val make : extern_graph -> graph val show : graph -> (vertex_key * vertex_data) list val assoc : vertex_key -> graph -> vertex_data val nexts : vertex_key -> graph -> (vertex_key * label) list val update : vertex_key -> vertex_data -> graph -> unit end;; module Graph (T : TYPE) (Key : EQUAL) (Label : EQUAL) : GRAPH with module Key = Key and module Label = Label with type vertex_data = T.t with type extern_graph = ((Key.t * T.t) * ((Key.t * Label.t) list)) list = struct module Key = Key module Label = Label type vertex_data = T.t type vertex_key = Key.t type label = Label.t type vertex = vertex_key * (T.t ref) type adjacency = vertex_key * (vertex_key * label) list type graph = Graph of adjacency list * vertex list type extern_graph = ((vertex_key * T.t) * ((vertex_key * label) list)) list let rec assoc_gen eq f l x = match l with | [] -> raise Not_found | (a, b) :: l -> if eq a x then f a b else assoc_gen eq f l x let assoc v_key (Graph (_, vertex_list)) = !(assoc_gen Key.eq (fun a b -> b) vertex_list v_key) let make full_adjlist = let adjlist = List.map (fun ((x, _), z) -> x, z) full_adjlist in let vertex_list = List.map (fun ((x, y), _) -> (x, ref y)) full_adjlist in Graph (adjlist, vertex_list) let show (Graph (_, vertex_list)) = List.map (fun (x, y) -> (x, !y)) vertex_list let update v_key v_data (Graph (_, vertex_list) as g) = assoc_gen Key.eq (fun a b -> b := v_data) vertex_list v_key let nexts v_key (Graph (adjlist, _)) = try assoc_gen Key.eq (fun a b -> b) adjlist v_key with Not_found -> [] end;; module Eq_Str = struct type t = string end;; module Eq_Int = struct type t = int let eq = ( = ) end;; type kilometer = Km of float;; module Kilometer = struct type t = kilometer let eq = ( = ) end;; module Geo = Graph (Eq_Str) (Eq_Int) (Kilometer);; module type VALUED = sig type elt val eval : elt -> int end;; module type ORDER = sig type t val less_or_equal : t -> t -> bool end;; module Val_Ordered (Val : VALUED) (Ord : ORDER with type t = Val.elt) = struct type t = Val.elt let less_or_equal x1 x2 = let e1 = Val.eval x1 and e2 = Val.eval x2 in if e1 = e2 then Ord.less_or_equal x1 x2 else e1 < e2 end;; module Length_Str = struct type elt = string let eval = String.length end;; module Order_Str = struct type t = string let less_or_equal = ( <= ) end;; module Short_Lex = Val_Ordered (Length_Str) (Order_Str);; module Val_and_Order (Val : VALUED) (Ord : ORDER with type t = Val.elt) = struct include Ord include Val end;; module OL_Str = Val_and_Order (Length_Str) (Order_Str);; type hash_set = Set of (char, unit) Hashtbl.t module Size_Set = struct type elt = hash_set let eval (Set s) = Hashtbl.length s end;; module Order_Set = struct type t = hash_set let less_or_equal = ( <= ) end;; module OS_Set = Val_and_Order (Size_Set) (Order_Set);; module type METRIC_SPACE = sig type point val dist : point -> point -> float val ball : radius:float -> point -> point list end;; module type ORDER = sig type elt val compare : elt -> elt -> int end;; module type OPTIMISATION_F = functor (Metric : METRIC_SPACE) -> functor (Ord : ORDER) -> OPTIMISATION;; module Inv (F : OPTIMISATION_F) (O : ORDER) (M : METRIC_SPACE) = struct include F (M) (O) end;; module Inv_Optimis = Inv (Optimis);; module Grad_Float = Inv_Optimis (Order_Float);; module type AUTOMATON = sig module Label : EQUAL type label = Label.t type automaton type extern_automaton val make : extern_automaton -> automaton val path_exist : automaton -> label list -> bool end;; module type GRAPH_F = functor (T : TYPE) -> functor (Key : EQUAL) -> functor (Label : EQUAL) -> GRAPH with module Key = Key and module Label = Label with type vertex_data = T.t with type extern_graph = ((Key.t * T.t) * ((Key.t * Label.t) list)) list;; module Automaton (Label : EQUAL) (Graph_F : GRAPH_F) : AUTOMATON with module Label = Label with type extern_automaton = (int * ((int * Label.t) list)) list = struct module Label = Label module State = struct type t = int let eq = ( = ) end module Data_Dummy = struct type t = unit end module G = Graph_F (Data_Dummy) (State) (Label) type label = Label.t type automaton = G.graph type extern_automaton = (G.Key.t * ((G.Key.t * Label.t) list)) list let make l = let dummy = () in G.make (List.map (fun (x, y) -> ((x, dummy), y)) l) let path_exist autom word = let rec aux visited word = match word with | [] -> true | first :: tail -> List.mem true (List.map (fun v -> let nexts = List.filter (fun (_, lab) -> lab = first) (G.nexts v autom) in if nexts = [] then false else aux (List.map fst nexts) tail) visited) in aux [1] word (* starting state *) end;; module Label = struct type t = string let eq = ( = ) end;; module A = Automaton (Label) (Graph);; module type S = sig val f : int -> int end;; module F_Add (M : S) = struct let g x = M.f x + 3 let () = print_endline "F_Add APPLIED" end;; module Increm_1 = struct let f x = x + 1 end module Increm_2 = struct let f x = x + 2 end;; let dynamical_module_choice x = let f = ref (fun x -> x) in (if x = 0 then let module N = F_Add (Increm_1) in f := N.g else let module N = F_Add (Increm_2) in f := N.g); !f;; (dynamical_module_choice 0) 1;; (dynamical_module_choice 222) 1;; module type ORDER = sig type t val compare : t -> t -> int end;; module type ORDER_MASK = sig type t type extern_t val make : extern_t -> t val show : t -> extern_t val compare : t -> t -> int end;; module type ORDERED_CONTAINER = sig module O : ORDER type elt = O.t type t val empty : unit -> t val add : elt -> t -> t val max_elt : t -> elt val remove_max : t -> t end;; module type ORDERED_CONTAINER_F = functor (Ord : ORDER) -> ORDERED_CONTAINER;; module type EXEC_QUEUE = sig module C : ORDERED_CONTAINER type processus = C.elt type t = C.t val empty : unit -> t val add : processus -> t -> t val execute : (processus -> unit) -> t -> t end;; module type EXEC_QUEUE_F = functor (Ord : ORDERED_CONTAINER) -> EXEC_QUEUE;; module L (Ord : ORDER) : ORDERED_CONTAINER with module O = Ord = struct module O = Ord type elt = O.t type t = O.t list let empty () = [] let add x l = List.sort O.compare (x :: l) let max_elt l = List.hd l let remove_max l = List.tl l end;; module Exec_Q (Cont : ORDERED_CONTAINER) : EXEC_QUEUE with module C = Cont = struct module C = Cont type processus = C.elt type t = C.t let empty = C.empty let add = C.add let execute apply_process q = apply_process (C.max_elt q); C.remove_max q end;; module Proc : ORDER_MASK with type extern_t = int * (float -> unit) * float = struct type t = { priority: int; pid: int; proc: float -> unit; param: float} type extern_t = int * (float -> unit) * float let counter = ref 0 let make (priority, proc, param) = incr counter; { priority = priority; pid = !counter; proc = proc; param = param } let show x = (x.priority, x.proc, x.param) let compare = Pervasives.compare end;; module Q = Exec_Q (L (Proc));; module type CONTAINER = sig type 'a t val empty : unit -> 'a t val add : 'a -> 'a t -> 'a t val mem : 'a -> 'a t -> bool val map : ('a -> 'b) -> 'a t -> 'b t end;; module type LINEAR_CONTAINER = sig include CONTAINER val build : ('a -> 'a) -> 'a -> 'a t val hd : 'a t -> 'a val tl : 'a t -> 'a t val npeek : int -> 'a t -> 'a list val length : 'a t -> int val nth : 'a t -> int -> 'a end;; module type BINTREE_CONTAINER = sig type 'a bintree val make_empty : unit -> 'a bintree val build : ('a -> 'a * 'a) -> int -> 'a -> 'a bintree val add : 'a -> 'a bintree -> 'a bintree val mem : 'a -> 'a bintree -> bool val map : ('a -> 'b) -> 'a bintree -> 'b bintree val height : 'a bintree -> int val balance : 'a bintree -> 'a bintree end;; module type BINTREE_CONTAINER' = sig include BINTREE_CONTAINER type 'a t = 'a bintree val empty : unit -> 'a t end;; module type ADAPT_BIN_NAMES = functor (T : BINTREE_CONTAINER) -> BINTREE_CONTAINER';; module Bin_Adapt (T : BINTREE_CONTAINER) : BINTREE_CONTAINER' = struct include T type 'a t = 'a T.bintree let empty = make_empty end;; module Tree : BINTREE_CONTAINER = struct type 'a bintree = | BinEmpty | BinNode of 'a * 'a bintree * 'a bintree let make_empty () = BinEmpty let build f n x = BinEmpty let add x t = BinEmpty let mem x t = failwith "not implemented" let height t = 0 let balance t = BinEmpty let rec map f t = match t with | BinEmpty -> BinEmpty | BinNode (x, t1, t2) -> BinNode (f x, map f t1, map f t2) end;; module Tree1 : CONTAINER = Bin_Adapt (Tree);; module Tree2 : BINTREE_CONTAINER' = Bin_Adapt (Tree);; module type P_LINE = sig type data_in type data_out type 'a input_line type 'a output_line val make : data_in input_line -> data_out output_line val read_fst : data_out output_line -> data_out val delete_fst : data_out output_line -> data_out output_line end;; module type STREAM = sig exception Empty type 'a stm val empty : unit -> 'a stm val cons : (unit -> 'a) -> (unit -> 'a stm) -> 'a stm val hd : 'a stm -> 'a val tl : 'a stm -> 'a stm val npeek : int -> 'a stm -> 'a list val iterate : ('a -> 'a) -> 'a -> 'a stm val map : ('a -> 'b) -> 'a stm -> 'b stm end module type P_LINE_STM = sig module St : STREAM include P_LINE with type 'a output_line = 'a St.stm end;; module type P_LINE_STM_F = functor (St : STREAM) -> P_LINE_STM module type P_LINE_TRANSFORM_STM_F = functor (St : STREAM) -> functor (P : P_LINE_STM) -> P_LINE_STM with type data_in = P.data_out with type 'a input_line = 'a P.output_line;; module St1 : STREAM = struct exception Empty type 'a stm = EmptyStm | Cons of 'a * (unit -> 'a stm) let empty () = EmptyStm let cons x s = Cons (x (), s) let hd s = match s with | Cons (x, _) -> x | _ -> raise Empty let tl s = match s with | Cons (_, xf) -> xf () | _ -> raise Empty let rec npeek n stm = match stm with | EmptyStm -> [] | Cons (x, f) -> if n = 0 then [] else x :: npeek (n - 1) (f ()) let rec iterate f x = Cons (x, fun () -> iterate f (f x)) let rec map f stm = match stm with | EmptyStm -> EmptyStm | Cons (x, xf) -> Cons (f x, fun () -> map f (xf ())) end;; module St2 : STREAM = struct exception Empty type 'a stm = | StmEmpty | Cons of 'a Lazy.t * 'a stm Lazy.t let (!!) x = Lazy.force x let empty () = StmEmpty let cons x s = Cons (lazy (x ()), lazy (s ())) let hd s = match s with | Cons (x, _) -> (!!)x | _ -> raise Empty let tl s = match s with | Cons (_, xs) -> (!!)xs | _ -> raise Empty let rec npeek n s = match s with | StmEmpty -> [] | Cons (x, xs) -> if n <= 0 then [] else ((!!)x) :: npeek (n - 1) ((!!)xs) let rec iterate f x = Cons (lazy x, lazy (iterate f (f x))) let rec map f s = match s with | StmEmpty -> StmEmpty | Cons (x, xs) -> Cons (lazy (f ((!!)x)), lazy (map f ((!!)xs))) end;; module Rand_Bin (Stream : STREAM) : P_LINE_STM with type data_out = int with type 'a input_line = int = struct module St = Stream type data_in = unit type data_out = int type 'a input_line = int type 'a output_line = 'a St.stm let rec make init = Random.init init; St.iterate (fun x -> (Random.int 2)) 0 let read_fst s = St.hd s let delete_fst s = St.tl s end;; module Compress (Stream : STREAM) (P : P_LINE_STM) : P_LINE_STM with type data_in = P.data_out with type 'a input_line = 'a P.output_line with type data_out = int * P.data_out = struct module St = Stream type data_in = P.data_out type data_out = int * P.data_out type 'a input_line = 'a P.output_line type 'a output_line = 'a St.stm let rec make s = let rec one_element el s n = if el = P.read_fst s then one_element el (P.delete_fst s) (n + 1) else ((n, el), s) in let consx (pair, s) = St.cons (fun () -> pair) (fun () -> (make s)) in consx (one_element (P.read_fst s) (P.delete_fst s) 1) let read_fst s = St.hd s let delete_fst s = St.tl s end;; module R = Rand_Bin (St2);; module Compressed_R = Compress (St1) (R);; module CCompressed_R = Compress (St2) (Compressed_R);;