(**************************************************************) (* Chapitre 11 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. *) type counter = { mutable value: int; incr: (counter -> int -> unit) };; let new_counter init = { value = init; incr = (fun c n -> (c.value <- c.value + n)) };; type counter = { value: int ref; get_value: unit -> int; incr: int -> unit };; let new_counter init = let value = ref init in let incr n = value := !value + n in { value = value; get_value = (fun () -> !value); incr = incr };; module type COUNTER = sig type t val make : int -> t val get_value : t -> int val incr : t -> int -> unit end module Counter : COUNTER = struct type t = int ref let make init = ref init let get_value c = !c let incr c n = c := !c + n end;; module type COUNTER = sig val value : int ref val get_value : unit -> int val incr : int -> unit end module Counter (I : sig val init : int end) : COUNTER = struct let value = ref I.init let get_value () = !value let incr n = value := !value + n end;; module C1 = Counter (struct let init = 0 end);; module type COUNTER_EXT = sig include COUNTER val reset : unit -> unit end module Counter_Ext (C : COUNTER) : COUNTER_EXT = struct include C let reset () = value := 0 end;; let counter init = let value = ref init in fun n -> (value := !value + n; !value);; let counter init = let value = ref init in fun message -> match message with | `Get_value -> !value | `Incr n -> value := !value + n; !value;; let counter_ext init = let value = ref init in fun message -> match message with | `Get_value -> !value | `Incr n -> value := !value + n; !value | `Reset -> value := 0; !value;; let c1 = object val mutable value = 0 method get_value = value method incr n = value <- value + n end;; let c1 = object (self) val mutable value = 0 method get_value = value method incr_one = self#incr 1 method incr n = value <- value + n end;; type counter_t = < get_value: int; incr: int -> unit >;; let c1 : counter_t = object val mutable value = 0 method get_value = value method incr n = value <- value + n end;; let c2 = object val mutable access_count = 0 val mutable value = 0 method get_value = value method incr n = value <- value + n; access_count <- access_count + 1; Printf.printf "access number: %d \n" access_count; end;; type reduced_counter_t = < get_value: int>;; let c2 = (c1 :> reduced_counter_t);; class counter init = object val mutable value = init method get_value = value method incr n = value <- value + n end;; class counter = let gravity = 9.81 in let global_access_count = ref 0 in fun init -> object val mutable value = init method get_value = value method get_global_access_count = !global_access_count method incr n = value <- value +. n +. gravity; global_access_count := !global_access_count + 1 end;; class reduced_counter (init : float) = object val mutable value = init method get_value = value end;; class counter init = object val mutable value = init method get_value = value method incr n = value <- value + n end;; class counter_ext init = object inherit counter init method reset () = value <- 0 end;; class counter_special_incr init = object inherit counter init as super method incr_one = super#incr 1 end;; class ['a] counter_named init (init_name : 'a) = object val mutable value = init val name = init_name method get_value = value method get_name = name method incr n = value <- value + n end;; class ['a] counter init = object val mutable value = init method get_value = value method incr (k:int -> 'a) n = value <- value + n; k value end;; class counter_named_ext init init_name = object inherit [string] counter_named init init_name method print_name () = Printf.printf "counter name: %s \n" name end;; class ['a] counter_named_ext init (init_name : 'a) = object inherit ['a] counter_named init init_name method reset () = value <- 0 end;; class ['a] counter init = object val mutable value = init method get_value = value method incr (printer_obj : 'a) n = value <- value + n; printer_obj#print (value) end;; class virtual printable_counter init = object val mutable value = init method get_value = value method incr n = value <- value + n method virtual print : unit end;; class simple_printable_counter init = object inherit printable_counter init method print = Printf.printf "counter value: %d \n" value end;; class counter_fun init incr_fun = object val mutable value : int = init method get_value = value method incr () = value <- incr_fun value method reset () = value <- 0 end;; class counter_fun init incr_fun = object val mutable value : int = init val mutable incr_fun : int -> int = incr_fun method get_value = value method set_incr_fun f = incr_fun <- f method incr () = value <- incr_fun value method reset () = value <- 0 end;; open Graphics;; class type button_t = object val coord : int * int * int * int val label : string val color : color method set_label : string -> unit method set_color : color -> unit method draw : unit -> unit end;; class type button_action_t = object inherit button_t method action : unit -> unit method is_inside : int -> int -> bool end;; class type ['a] button_toggle_t = object inherit button_action_t val mutable state : 'a method change_state : unit end;; class button (x, y, w, h) lab col : button_t = object val mutable coord = (x, y, w, h) val mutable label = lab val mutable color = col method set_label l = label <- l method set_color c = color <- c method draw () = set_color color; fill_rect x y w h; set_color black; draw_rect x y w h; let (a, b) = text_size label in moveto (x + (w - a) / 2) (y + (h - b) / 2); draw_string label end;; class button_action (x, y, w, h) lab col action : button_action_t = object (self) inherit button (x, y, w, h) lab col method action = self#draw (); action; method is_inside a b = (a >= x) && (a <= x + w) && (b >= y) && (b <= y + h) end;; class virtual button_toggle (x, y, w, h) lab col action = object (self) inherit button_action (x, y, w, h) lab col action as super method virtual change_state : unit method action = self#change_state; super#action end;; class ['a] button_toggle_bool (x, y, w, h) lab col action init : ['a] button_toggle_t = object (self) inherit button_toggle (x, y, w, h) lab col action as super val mutable state : 'a = init method change_state = state <- not state method draw () = let l = label in if state then self#set_label (l ^ " (ON)") else self#set_label (l ^ " (OFF)"); super#draw (); self#set_label l end;; class ['a] button_toggle_counter (x, y, w, h) lab col action init states_nb : ['a] button_toggle_t = object (self) inherit button_toggle (x, y, w, h) lab col action as super val mutable state : 'a = new counter_fun init (fun n -> ((n + 1) mod states_nb)) method change_state = state#incr () method draw () = let l = label in self#set_label (l ^ ":" ^ (string_of_int state#get_value)); super#draw (); self#set_label l end;; let buttons_loop buttons_list = List.iter (fun b -> b#draw ()) buttons_list; while true do let stat = wait_next_event [Button_down] in if stat.button then let (x, y) = (stat.mouse_x, stat.mouse_y) in List.iter (fun b -> if (b#is_inside x y) then b#action ()) buttons_list done;; let b_out = new button_action (10, 10, 30, 30) "Exit" (rgb 200 200 200) (fun () -> raise Exit);; open_graph "";; let parachutes = new button_toggle_counter (100, 20, 100, 40) "Parachutes" green (fun () -> print_endline "Parachutes"; flush_all ()) 0 4;; parachutes#draw ();; let left = new button_action (50, 150, 50, 50) "Left" yellow (fun () -> print_endline "Left"; flush_all ());; left#draw ();; let right = new button_action (200, 150, 50, 50) "Right" yellow (fun () -> print_endline "Right"; flush_all ());; right#draw ();; let nose = new button_action (125, 170, 50, 50) "Nose" yellow (fun () -> print_endline "Nose"; flush_all ());; nose#draw ();; let arm = new button_toggle_bool (30, 70, 80, 40) "ARM" cyan (fun () -> print_endline "ARM"; flush_all ()) false;; arm#draw ();; let down = new button_toggle_bool (190, 70, 80, 40) "DOWN" cyan (fun () -> print_endline "DOWN"; flush_all ()) false;; down#draw ();; buttons_loop [b_out; left; right; nose; (parachutes :> button_action); (arm :> button_action); (down :> button_action)];; class type counter_eq_t = object method get_value : int method incr : int -> unit method equal : counter_eq_t -> bool end;; class counter_eq init : counter_eq_t = object (self) val mutable value = init method get_value = value method incr n = value <- value + n method equal c = (c#get_value = self#get_value) end;; class type counter_eq_t = object ('t) method get_value : int method incr : int -> unit method equal : 't -> bool end;; class counter_eq init : counter_eq_t = object (self : 't) val mutable value = init method get_value = value method incr n = value <- value + n method equal (c : 't) = (c#get_value = self#get_value) end;; class type counter_eq_named_t = object ('t) inherit counter_eq_t method get_name : string end;; class counter_eq_named init name : counter_eq_named_t = object (self : 't) inherit counter_eq init as super val name = name method get_name = name method equal (c : 't) = super#equal c && (c#get_name = self#get_name) end;; class type ['a] linear_container_t = object ('t) method to_list : 'a list method add : 'a -> unit end;; class ['a] c_list : ['a] linear_container_t = object (_ : 't) val mutable l1 = [] method to_list = l1 method add x = l1 <- x :: l1 end;; class ['a] cell (init : 'a) = object val mutable data = init val mutable next : 'a cell option = None method get_data = data method set_data d = data <- d method get_next = next method set_next c = next <- Some c end;; class ['a] c_list : ['a] linear_container_t = object (_ : 't) val mutable l1 = None method to_list = let rec aux l = match l with | None -> [] | Some c -> c#get_data :: (aux c#get_next) in aux l1 method add x = let cn = new cell x in match l1 with | None -> (l1 <- Some cn) | Some c -> (cn#set_next c; l1 <- Some cn) end;; module type C_LINEAR_CONTAINER = sig class ['a] c : ['a] linear_container_t end;; module C_List : C_LINEAR_CONTAINER = struct type 'a rlist = Empty | Cons of 'a * 'a rlist ref let rec list_of_rlist l = match l with | Empty -> [] | Cons (x, xs) -> x :: (list_of_rlist (!xs)) class ['a] c : ['a] linear_container_t = object (self : 't) val mutable l1 = Empty method to_list = list_of_rlist l1 method add x = l1 <- Cons (x, ref l1) end end;; (* alternative version : *) class type ['a, 'container] linear_container_t = object ('t) method to_list : 'a list method add : 'a -> unit end;; module type C_LINEAR_CONTAINER = sig type 'a container class ['a] c : ['a, 'a container] linear_container_t end;; module C_List : C_LINEAR_CONTAINER = struct type 'a container = Empty | Cons of 'a * 'a container ref let rec list_of_contain l = match l with | Empty -> [] | Cons (x, xs) -> x :: (list_of_contain (!xs)) class ['a] c : ['a, 'a container] linear_container_t = object (self : 't) val mutable l1 = Empty method to_list = list_of_contain l1 method add x = l1 <- Cons (x, ref l1) end end;; class type ['a] counter_generic_t = object val value : 'a method get_value : string method incr : string -> unit end;; class ['a] counter init : ['a] counter_generic_t = object val mutable value : 'a = int_of_string init method get_value = string_of_int value method incr n = value <- value + (int_of_string n) end;; class ['a] counter64 init : ['a] counter_generic_t = object val mutable value : 'a = Int64.of_string init method get_value = Int64.to_string value method incr n = value <- Int64.add value (Int64.of_string n) end;; module type ARITH = sig type nb val make : string -> nb val show : nb -> string 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 I64 : ARITH = struct include Int64 type nb = Int64.t let make = of_string let show = to_string end;; class ['a] counter64 init : ['a] counter_generic_t = object val mutable value : 'a = I64.make init method get_value = I64.show value method incr n = value <- I64.add value (I64.make n) end;; module type ARITH_COUNTER = sig module A : ARITH type t = A.nb class type arith_counter_t = object val mutable value : t method get_value : string method incr : string -> unit end class counter : string -> arith_counter_t end;; module Counter (Ar : ARITH) : ARITH_COUNTER with module A = Ar = struct module A = Ar type t = Ar.nb class type arith_counter_t = object val mutable value : t method get_value : string method incr : string -> unit end class counter init_value : arith_counter_t = object val mutable value = Ar.make init_value method get_value = Ar.show value method incr n = value <- Ar.add value (Ar.make n) end end;; module C = Counter (I64);; class type arith_counter_ext = object inherit C.arith_counter_t method reset : unit -> unit end;; class counter_ext init : arith_counter_ext = object inherit C.counter init method reset () = value <- C.A.zero end;; module type ARITH_COUNTER_EXT = sig module AC : ARITH_COUNTER type t = AC.t class type arith_counter_ext_t = object inherit AC.arith_counter_t method reset : unit -> unit end class counter : string -> arith_counter_ext_t end;; module Counter_Ext (Ar : ARITH_COUNTER) : ARITH_COUNTER_EXT with module AC = Ar = struct module AC = Ar type t = AC.t class type arith_counter_ext_t = object inherit AC.arith_counter_t method reset : unit -> unit end class counter init : arith_counter_ext_t = object inherit AC.counter init method reset () = value <- AC.A.zero end end;; class chicken (name : string) = object val name = name method lay () = new egg name end and egg (momy_name : string) = object val momy_name = momy_name val mutable hatched_out = false method hatch_out name = if not hatched_out then ( hatched_out <- true; new chicken name ) else failwith "Already hatched_out" end;; module rec Chicken : sig type t val make : string -> t val show_name : t -> string val lay : t -> Egg.t end = struct type t = Chick of string let make name = Chick name let show_name (Chick n) = n let lay chick = Egg.make (show_name chick) end and Egg : sig type t val make : string -> t val show_momy_name : t -> string val hatch_out : t -> string -> Chicken.t end = struct type t = { momy_name : string; mutable hatched_out : bool} let make n = { momy_name = n; hatched_out = false} let show_momy_name { momy_name = n} = n let hatch_out egg name = if not egg.hatched_out then ( egg.hatched_out <- true; Chicken.make name ) else failwith "Already hatched_out" end;;