(**************************************************************) (* Chapitre 9 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 Math = struct let rec fact n = if n <= 1 then 1 else n * fact (n - 1) let rec fib n = if n <= 0 then 0 else if n = 1 then 1 else fib (n - 1) + fib (n - 2) let rec sum f n0 n = if n < n0 then 0 else (f n) + (sum f n0 (n - 1)) end;; module Complex = struct type complex = { re: float; im: float } let make (r, i) = { re = r; im = i } let add z w = { re = z.re +. w.re; im = z.im +. w.im } let norm z = sqrt (z.re ** 2. +. z.im ** 2.) 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 L = struct type 'a lin = Empty | Cons of 'a * 'a lin let empty () = Empty let add x l = Cons (x, l) let rec mem x l = match l with | Empty -> false | Cons (y, ys) -> x = y || mem x ys let rec append l1 l2 = match l1 with | Empty -> l2 | Cons (x, xs) -> Cons (x, append xs l2) end;; module M = struct print_endline "enfermé dans M";; print_endline "oui, enfermé";; let f x = x + 1 end;; module M = struct let () = print_endline "enfermé dans M" let () = print_endline "oui, enfermé" let f x = x + 1 end;; module type METRIC_SPACE_2D = sig type point val make_point : float * float -> point val dist : point -> point -> float end;; module Plane : METRIC_SPACE_2D = struct type point = float * float let make_point (x, y) = (x,y) let dist (x1, y1) (x2, y2) = 1. end;; module Plane_Count : METRIC_SPACE_2D = struct type point = { number: int; coord: float * float } let count = ref 0 let make_point (x, y) = incr count; { number = !count; coord = (x, y) } let dist p1 p2 = let (x1, y1) = p1.coord and (x2, y2) = p2.coord in sqrt ((x1 -. x2) ** 2. +. (y1 -. y2) ** 2.) end;; module Manhattan_Plane : METRIC_SPACE_2D = struct type point = float * float let make_point (x, y) = (x, y) let dist (x1, y1) (x2, y2) = abs_float (x1 -. x2) +. abs_float (y1 -. y2) end;; 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 Assoc_List : ASSOC_TABLE = struct type ('a, 'b) assoc = ('a * 'b) list let empty () = [] let get_pair l = try List.hd l with Failure "hd" -> failwith "No pair" let assoc l key = List.assoc key l let add key data l = try (assoc l key; failwith "Already inserted") with Not_found -> (key, data) :: l end;; module Assoc_RBTree : ASSOC_TABLE = struct type color = R | B type ('a, 'b) assoc = | Empty | RBNode of color * ('a * 'b) * ('a, 'b) assoc * ('a, 'b) assoc let empty () = Empty let get_pair t = match t with | Empty -> failwith "No pair" | RBNode (_, x, _, _) -> x let rec assoc t key = match t with | Empty -> raise Not_found | RBNode (_, (key', data), t1, t2) -> if key = key' then data else if key < key' then assoc t1 key else assoc t2 key let local_balance tree = match tree with | B, z, RBNode (R, y, RBNode (R, x, t1, t2), t3), t4 | B, z, RBNode (R, x, t1, RBNode (R, y, t2, t3)), t4 | B, x, t1, RBNode (R, z, RBNode (R, y, t2, t3), t4) | B, x, t1, RBNode (R, y, t2, RBNode (R, z, t3, t4)) -> RBNode (R, y, RBNode (B, x, t1, t2), RBNode (B, z, t3, t4)) | c, x, t1, t2 -> RBNode (c, x, t1, t2) let add key data tree = let rec aux t kont = match t with | Empty -> kont (RBNode (R, (key, data), Empty, Empty)) | RBNode (color, (key', data'), t1, t2) -> if key = key' then tree else if key < key' then aux t1 (fun t -> kont (local_balance (color, (key', data'), t, t2))) else aux t2 (fun t -> kont (local_balance (color, (key', data'), t1, t))) in let RBNode (_, (key, data), t1, t2) = aux tree (fun x -> x) in RBNode (B, (key, data), t1, t2) end;; module type COMPLEX = sig type complex val make : float * float -> complex val show : complex -> float * float val add : complex -> complex -> complex val norm : complex -> float end;; module Complex_Memo : COMPLEX = struct type complex = { re: float; im: float; mutable norm: float option } let make (r, i) = { re = r; im = i; norm = None } let show z = (z.re, z.im) let add z w = make (z.re +. w.re, z.im +. w.im) let norm z = match z.norm with | Some x -> x | None -> let m = sqrt (z.re ** 2. +. z.im ** 2.) in (z.norm <- Some m; m) end;; module Assoc_Tree_Cache : ASSOC_TABLE = struct let cache_size = 5 type ('a, 'b) bintree = | BinEmpty | BinNode of ('a * 'b) * ('a, 'b) bintree * ('a, 'b) bintree type ('a, 'b) assoc = { tree: ('a, 'b) bintree; cache: ('a * 'b) Weak.t; mutable index: int } let empty () = { tree = BinEmpty; cache = Weak.create cache_size; index = 0 } let get_pair {tree = t} = match t with | BinEmpty -> failwith "No pair" | BinNode (x, _, _) -> x let assoc_direct table key = let rec aux t = match t with | BinEmpty -> raise Not_found | BinNode ((key', data'), t1, t2) -> if key = key' then data' else if key < key' then aux t1 else aux t2 in aux table.tree let assoc table key = let res = ref None in let index = ref 0 in begin while (!index < cache_size) && (!res = None) do match Weak.get table.cache !index with | Some (key', data) -> if key = key' then res := Some data else incr index | None -> incr index done; match !res with | None -> let data = assoc_direct table key in Weak.set table.cache table.index (Some (key, data)); table.index <- (table.index + 1) mod cache_size; data | Some x -> x end let add key data table = let rec aux t key data = match t with | BinEmpty -> BinNode ((key, data), BinEmpty, BinEmpty) | BinNode ((key', data') as d, t1, t2) -> if key = key' then t else if key < key' then BinNode (d, aux t1 key data, t2) else BinNode (d, t1, aux t2 key data) in { tree = aux table.tree key data; cache = table.cache; index = table.index } end;; module type SET = sig type 'a set val empty : unit -> 'a set val mem : 'a -> 'a set -> bool val add : 'a -> 'a set -> 'a set val union : 'a set -> 'a set -> 'a set val inter : 'a set -> 'a set -> 'a set end;; module Set_Fun : SET = struct type 'a set = 'a -> bool let empty () = fun y -> false let mem x s = s x let add x s = if mem x s then s else fun y -> s y || x = y let rec union s1 s2 = fun y -> s1 y || s2 y let rec inter s1 s2 = fun y -> s1 y && s2 y end;; module Set_H : SET = struct type 'a set = ('a, unit) Hashtbl.t let dummy = () let empty () = Hashtbl.create 0 let mem x h = Hashtbl.mem h x let add x h1 = if mem x h1 then h1 else let h = Hashtbl.copy h1 in (Hashtbl.add h x dummy; h) let union h1 h2 = let h = Hashtbl.copy h1 in Hashtbl.iter (fun x _ -> ignore (add x h)) h2; h let inter h1 h2 = let h = empty () in Hashtbl.iter (fun x _ -> if (Hashtbl.mem h1 x) && (Hashtbl.mem h2 x) then Hashtbl.add h x dummy) h1; h end;; module type SET = sig type 'a set val empty : unit -> 'a set val mem : 'a -> 'a set -> bool val add : 'a -> 'a set -> unit val union : 'a set -> 'a set -> 'a set val inter : 'a set -> 'a set -> 'a set end;; module Set_H : SET = struct type 'a set = ('a, unit) Hashtbl.t let dummy = () let empty () = Hashtbl.create 0 let mem x h = Hashtbl.mem h x let add x h = if not (mem x h) then Hashtbl.add h x dummy let union h1 h2 = let h = Hashtbl.copy h1 in Hashtbl.iter (fun x _ -> ignore (add x h)) h2; h let inter h1 h2 = let h = empty () in Hashtbl.iter (fun x _ -> if (Hashtbl.mem h1 x) && (Hashtbl.mem h2 x) then Hashtbl.add h x dummy) h1; h end;; module type COMPLEX_MASK = sig type complex type extern_complex val make : extern_complex -> complex val show : complex -> extern_complex val add : complex -> complex -> complex val norm : complex -> float end;; module Complex_Num : COMPLEX_MASK with type extern_complex = string * string = struct type complex = C of Num.num * Num.num type extern_complex = string * string let make (str_r, str_i) = C (Num.num_of_string str_r, Num.num_of_string str_i) let show (C (r, i)) = (Num.string_of_num r, Num.string_of_num i) let add (C (r1, i1)) (C (r2, i2)) = C (Num.( +/ ) r1 r2, Num.( +/ ) i1 i2) let norm (C (r, i)) = sqrt (Num.float_of_num (Num.add_num (Num.square_num r) (Num.square_num i))) end;; module type METRIC_SPACE = sig type point type extern_point val make_point : extern_point -> point val dist : point -> point -> float end;; module Line : METRIC_SPACE with type extern_point = float = struct type point = float type extern_point = float let make_point x = x let dist x1 x2 = abs_float (x1 -. x2) end;; module Bit_maps : METRIC_SPACE with type extern_point = int array array = struct type point = BitMap of int array array type extern_point = int array array let make_point b = BitMap b let dist (BitMap b1) (BitMap b2) = let len_x = Array.length b1 in let len_y = Array.length b1.(0) in let diff_count = ref 0 in if len_x = Array.length b2 && len_y = Array.length b2.(0) then for i = 0 to len_x - 1 do for j = 0 to len_y - 1 do if b1.(i).(j) <> b2.(i).(j) then incr diff_count done done else failwith "Different bitmap size"; float (!diff_count) end;; module type ORDER = sig type t type extern_t val make : extern_t -> t val show : t -> extern_t val less_or_equal : t -> t -> bool end;; module String_Ordered : ORDER = struct type t = Str of string * Num.num option ref type extern_t = string let make s = Str (s, ref None) let show (Str (s, _)) = s let ascii_value s = let value = ref (Num.Int 0) and len = (String.length s) - 1 in let basis = ref (Num.Int 1) in for i = len downto 0 do value := Num.add_num !value (Num.mult_num !basis (Num.Int (Char.code s.[i]))); basis := Num.mult_num !basis (Num.Int 256) done; !value let less_or_equal s1 s2 = let extract_ascii_value (Str (s, c)) = match !c with | None -> let d = ascii_value s in c := Some d; d | Some d -> d in Num.le_num (extract_ascii_value s1) (extract_ascii_value s2) end;; module Complex = struct type complex = float * float let make (r, i) = (r, i) let add (r1, i1) (r2, i2) = (r1 +. r2, i1 +. i2) let norm (r, i) = sqrt (r ** 2. +. i ** 2.) end;; module Complex_Ext = struct include Complex let mul (r1, i1) (r2, i2) = (r1 *. r2 -. i1 *. i2, i1 *. r2 +. i2 *. r1) end;; module type COMPLEX = sig type complex val make : float * float -> complex val add : complex -> complex -> complex val norm : complex -> float end;; module type COMPLEX_EXT = sig include COMPLEX val mul : complex -> complex -> complex end;; module C1 : COMPLEX = Complex_Ext;; module C2 : COMPLEX_EXT = Complex_Ext;; module type COMPLEX = sig type complex val make : float * float -> complex val show : complex -> float * float val add : complex -> complex -> complex val norm : complex -> float end;; module type COMPLEX_EXT = sig include COMPLEX val mul : complex -> complex -> complex end;; module Complex : COMPLEX = struct type complex = float * float let make (r, i) = (r, i) let show = make let add (r1, i1) (r2, i2) = (r1 +. r2, i1 +. i2) let norm (r, i) = sqrt (r ** 2. +. i ** 2.) end;; module Complex_Ext : COMPLEX_EXT = struct include Complex let mul z w = let (r1, i1) = show z and (r2, i2) = show w in make (r1 *. r2 -. i1 *. i2, i1 *. r2 +. i2 *. r1) 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_Int64 : ARITH with type extern_nb = string = struct include Int64 type nb = Int64.t type extern_nb = string let make = of_string let show = to_string 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 : GRAPHIC_ENVIRONMENT = struct module T = Assoc_RBTree 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 type COMPLEX = sig type complex type extern_complex val make : extern_complex -> complex val show : complex -> extern_complex val zero : complex val one : complex val add : complex -> complex -> complex val mul : complex -> complex -> complex val norm : complex -> float end;; module Complex_Fl : COMPLEX with type extern_complex = float * float = struct type complex = float * float type extern_complex = complex let make (r, i) = (r, i) let show (r, i) = (r, i) let zero = (0., 0.) let one = (1., 0.) let add (r1, i1) (r2, i2) = (r1+.r2, i1+.i2) let mul (r1, i1) (r2, i2) = (r1*.r2 -. i1*.i2, i1*.r2 +. i2*.r1) let norm (r, i) = sqrt (r*.r +. i*.i) end;; module type COMPLEX_FUN = sig module C : COMPLEX type fun_t type extern_fun_t val make : extern_fun_t -> fun_t val apply : fun_t -> C.complex -> C.complex val iterate : fun_t -> int -> C.complex -> C.complex end;; module CFuns : COMPLEX_FUN with type extern_fun_t = Complex_Fl.complex -> Complex_Fl.complex with module C = Complex_Fl = struct module C = Complex_Fl type fun_t = Fun of (C.complex -> C.complex) type extern_fun_t = C.complex -> C.complex let make f = Fun f let apply (Fun f) z = f z let rec iterate (Fun f) n z = if n < 1 then z else iterate (Fun f) (n - 1) (f z) end;; module CPolynom : COMPLEX_FUN with type extern_fun_t = (Complex_Fl.complex * int) list with module C = Complex_Fl = struct module C = Complex_Fl type fun_t = Fun of (C.complex -> C.complex) type extern_fun_t = (C.complex * int) list let apply (Fun f) z = f z let rec iterate (Fun f) n z = if n < 1 then z else iterate (Fun f) (n - 1) (f z) let power z0 n = iterate (Fun (fun z -> C.mul z z0)) n C.one let make coeflist = Fun (fun z -> (List.fold_right (fun (x, y) v -> C.add v (C.mul x (power z y))) coeflist C.zero)) end;; module type APPLE_MEN = sig module CF : COMPLEX_FUN module S : SET type complex = CF.C.complex type complex_fun = CF.fun_t type set_elements type apple_man = set_elements S.set val make : f_c: (complex -> complex_fun) -> diverg_ball: float -> max_iter: int -> size: int -> start: float -> apple_man end;; module A : APPLE_MEN with type set_elements = int * int and module CF = CPolynom and module S = Set_H = struct module CF = CPolynom module S = Set_H type complex = CF.C.complex type complex_fun = CF.fun_t type set_elements = int * int type apple_man = set_elements S.set let make ~f_c ~diverg_ball ~max_iter ~size ~start = let rec diverg f z n = let z' = CF.apply f z in if CF.C.norm z' > diverg_ball then true else if n >= max_iter then false else diverg f z' (n + 1) in let start2 = (start *. 2.) /. (float size) in let origin = CF.C.zero in let set = S.empty () in let arr = Array.make size 0. in for i = 0 to size - 1 do arr.(i) <- -.start +. ((float i) *. start2) done; for i = 0 to size - 1 do for j = 0 to size - 1 do let z = (CF.C.make (arr.(i), arr.(j))) in let f = f_c z in if not (diverg f origin 0) then S.add (i, j) set done done; set; end;; let bonze = A.make ~f_c:(fun c -> CPolynom.make [(Complex_Fl.one, 4); (Complex_Fl.one, 2); (c, 0)]) ~diverg_ball:100.0 ~max_iter:10 ~size:200 ~start:1.5;; let draw = set_draw (fun s point -> Set_H.mem point s);; draw 300 300 bonze;; module type ORDER = sig type t val less_or_equal : t -> t -> bool end;; module CharSet_Ordered = struct type t = Set of (char, unit) Hashtbl.t let less_or_equal (Set h1) (Set h2) = let flag = ref true in ( try Hashtbl.iter (fun x y -> if not (Hashtbl.mem h2 x) then raise Not_found) h1 with Not_found -> flag := false ); !flag end;; module type ORDER_MASK = sig include ORDER type extern_t val make : extern_t -> t val show : t -> extern_t end;; module CharSet_Ordered_Mask : ORDER_MASK with type extern_t = char list = struct include CharSet_Ordered type extern_t = char list let make s = let h = Hashtbl.create (List.length s) in List.iter (fun x -> Hashtbl.add h x ()) s; Set h let show (Set h) = let l = ref [] in Hashtbl.iter (fun x y -> l := x::!l) h; !l end;; module type COMPLEX_MASK = sig type complex type extern_complex val make : extern_complex -> complex val show : complex -> extern_complex end;; module Complex_Num : COMPLEX_MASK with type extern_complex = [`Complex of string * string] = struct type extern_complex = [`Complex of string * string] type complex = C of Num.num * Num.num let make (`Complex (str_r, str_i)) = C (Num.num_of_string str_r, Num.num_of_string str_i) let show (C (r, i)) = `Complex (Num.string_of_num r, Num.string_of_num i) end;; module type VALUE = sig type value val make_int : int -> value val make_float : float -> value val int_of_value : value -> int end;; module Value : VALUE = struct type value = Int of int | Float of float let make_int i = Int i let make_float r = Float r let int_of_value v = match v with | Int x -> x | Float y -> int_of_float y end;; module type VALUE_EXT = sig include VALUE val make_ratio : int -> int -> value end module Value_Ext : VALUE_EXT = struct module Val = Value type value = | V of Val.value | Ratio of int * int let make_int i = V (Val.make_int i) let make_float r = V (Val.make_float r) let make_ratio a b = Ratio (a, b) let int_of_value v = match v with | V v -> Val.int_of_value v | Ratio (a, b) -> a / b end;;