Commits

camlspotter committed 46798a6

added example

Comments (0)

Files changed (1)

dcamlexamples/ex061_coll_overload.ml

+(* ex060_coll.ml is too closed. Coll class takes a completely closed overloaded
+   values Ord. Here, using Overload module, one of $'Caml-0.2.0's new features,
+   we introduce some amount of openness.
+*)
+
+module Ord : sig
+  type 'a t
+  val compare : $:'a t -> 'a -> 'a -> int
+  val lift : ('a -> 'a -> int) -> 'a t
+  val max : $:'a t -> 'a -> 'a -> 'a
+  val min : $:'a t -> 'a -> 'a -> 'a
+end = struct
+  type 'a t = 'a -> 'a -> int
+  let compare $:t = t
+  let lift x = x
+  let max x y = if compare x y >= 0 then x else y
+  let min x y = if compare x y <= 0 then x else y
+end
+
+module Ord_int = struct
+  let int (x : int) y = Pervasives.compare x y
+  let int = Ord.lift int
+end
+
+module Ord_float = struct
+  let float (x : float) y = Pervasives.compare x y
+  let float = Ord.lift float
+end
+
+module Class = struct
+  type ('a, 'ac) t = {
+    empty : 'ac;
+    insert : 'a -> 'ac -> 'ac;
+    mem : 'a -> 'ac -> bool
+  }
+
+  let empty $:t = t.empty
+  let insert $:t = t.insert
+  let mem $:t = t.mem
+
+  module Make(M : sig
+    type 'a c
+    val empty : 'a c
+    val insert : 'a -> 'a c -> 'a c
+    val mem : 'a -> 'a c -> bool
+  end) : sig
+    val t : ('a, 'a M.c) t
+  end = struct
+    open M
+    let t = { empty = empty; insert = insert; mem = mem }
+  end
+
+  module Make_with_ord(M : sig
+    type 'a c
+    val empty : 'a c
+    val insert : $:'a Ord.t -> 'a -> 'a c -> 'a c
+    val mem : $:'a Ord.t -> 'a -> 'a c -> bool
+  end) : sig
+    val t : $:'a Ord.t -> ('a, 'a M.c) t
+  end = struct
+    open M
+    (* CR jfuruse: pity, but we need explicit abstractions for now *)
+    let t $:t = { empty = empty; insert = insert $:t; mem = mem $:t }
+  end
+end
+
+module List = Class.Make(struct
+  type 'a c = 'a list
+  let empty = []
+  let insert x xs = x :: xs
+  let mem = List.mem
+end)
+
+(* polymorphic set using Ord.compare *)
+module Set_impl : sig
+  type 'a c
+  val empty : 'a c
+  val insert : $:'a Ord.t -> 'a -> 'a c -> 'a c
+  val mem : $:'a Ord.t -> 'a -> 'a c -> bool
+end = struct
+  type 'a c = Empty | Node of 'a * 'a c * 'a c
+    
+  let rec height = function
+    | Empty -> 0
+    | Node (_, t1, t2) -> max (height t1) (height t2)
+
+  let empty = Empty
+    
+  let node v t1 t2 = Node (v, t1, t2)
+
+  (* It may not be correct, but who cares ? *)
+  let rotate a t1 t2 =
+    let h1 = height t1 in
+    let h2 = height t2 in
+    if h1 - h2 > 1 then begin
+      match t1 with
+      | Empty -> assert false
+      | Node (a1, t11, t12) ->
+          Node (a1, t11, Node(a, t12, t2))
+    end else if h2 - h1 > 1 then begin
+      match t2 with
+      | Empty -> assert false
+      | Node (a2, t21, t22) ->
+          Node (a2, Node(a, t1, t21), t22)
+    end else Node(a, t1, t2) 
+
+  let rec insert a t =
+    match t with
+    | Empty -> Node (a, Empty, Empty)
+    | Node (a', t1, t2) ->
+        match Ord.compare a a' with
+        | 0 -> t
+        | -1 ->
+            let t1' = insert a t1 in
+            rotate a' t1' t2
+        | 1 ->
+            let t2' = insert a t2 in
+            rotate a' t1 t2'
+        | _ -> assert false
+
+  let rec mem a t =
+    match t with
+    | Empty -> false
+    | Node (a', t1, t2) ->
+        match Ord.compare a a' with
+        | 0 -> true
+        | -1 -> mem a t1
+        | 1 -> mem a t2
+        | _ -> assert false
+end
+
+module Set = Class.Make_with_ord(Set_impl)
+
+open Class
+
+(* Sigh, needs explicit types. Disappointed. *)
+let () = 
+  (* assert (empty = []); (* $:('a, 'b list) Class.t -> unit *) *)
+  (* assert ((empty : int list) = []); (* $:('a, int list) Class.t -> unit *) *)
+  assert (empty $:List.t = []);
+  assert (insert $:List.t 1 [] = [1]);
+  assert (mem $:List.t 1 (empty $:List.t) = false);
+
+  (* It translates Set.t => Set.t Ord_int.int That's nice. *) 
+  assert (mem $:Set.t 1 (empty $:Set.t) = false);
+(*
+  assert (mem $:(Set.t $:Ord_int.int) 1 (empty $:(Set.t $:Ord_int.int)) = false);
+*)
+;;