Added splaytree

4 files changed, 158 insertions, 28 deletions

diff --git a/Makefile b/Makefile
index ec420a0..5dbb9a0 100755
--- a/Makefile
+++ b/Makefile
@@ -1,5 +1,5 @@
 OCAMLBUILD ?= ocamlbuild

-PACKAGES=num,curses,camlzip,ezxmlm,text,str,menhirLib

+PACKAGES=dynlink,num,curses,camlzip,ezxmlm,text,str,menhirLib

 PATHS=.,odf

 

 MENHIR=-use-menhir

@@ -33,6 +33,9 @@ doc:
 test.byte: stub

 	$(OCAMLBUILD) -pkgs $(PACKAGES),oUnit -cflag -g -lflag -g $(STUB_OPTIONS) $(MENHIR) -Is $(PATHS),tests,tests/odf $@

 

+%.cmxs: stub

+	$(OCAMLBUILD) -use-ocamlfind -tags optimize\(3\) -pkgs $(PACKAGES) $(MENHIR) -Is $(PATHS) $@

+

 test: test.byte

 	./test.byte

 

diff --git a/catalog.ml b/catalog.ml
index bd17a18..67ec69d 100755
--- a/catalog.ml
+++ b/catalog.ml
@@ -32,13 +32,13 @@ module Make(Data:DATA_SIG) = struct
 

   module ComparableSignature = struct

 

-    type 'a t = 'a sig_typ

+    type 'a t = string * 'a sig_typ

 

     (* Type for pure equality *)

     type (_, _) eq = Eq : ('a, 'a) eq

 

     (** Compare two signature *)

-    let eq: type a b. a sig_typ -> b sig_typ -> (a, b) T.cmp = begin fun a b ->

+    let comp: type a b. string * a sig_typ -> string * b sig_typ -> (a, b) T.cmp = begin fun (namea, a) (nameb, b) ->

 

       let cmp: type c d. c Data.typ -> d Data.typ -> ((c, d) eq -> (a, b) T.cmp) -> (a, b) T.cmp =

       begin fun a b f -> match Data.compare_typ a b with

@@ -47,14 +47,22 @@ module Make(Data:DATA_SIG) = struct
         | T.Gt -> T.Gt

       end in

 

-      match a, b with

+      if namea < nameb then

+        T.Lt

+      else if namea > nameb then

+        T.Gt

+      else match a, b with

 

       | T1(a), T1(b) -> cmp a b (fun Eq -> T.Eq)

+      | T1(_), _ -> T.Lt

+      | _, T1(_) -> T.Gt

 

       | T2(a, b), T2(c, d) ->

         cmp a c (fun Eq ->

           cmp b d (fun Eq -> T.Eq)

         )

+      | T2(_), _ -> T.Lt

+      | _, T2(_) -> T.Gt

 

       | T3(a, b, c), T3(d, e, f) ->

         cmp a d (fun Eq ->

@@ -63,22 +71,21 @@ module Make(Data:DATA_SIG) = struct
           )

         )

 

-      | x, y -> if (T.Ex x) > (T.Ex y) then T.Gt else T.Lt

       end

 

   end

 

   module Catalog = Map.Make(String)

-  module Functions = Tools.Map(ComparableSignature)

+  module Functions = Splay.Make(ComparableSignature)

 

 

   (* This is the map which contains all the registered functions.

      Each name is binded with another map with contains the function for each

      signature.

    *)

-  type t = Functions.t Catalog.t

+  type t = Functions.tree

 

-  let empty = Catalog.empty

+  let empty = Functions.empty

 

   (**

      Register a function in the catalog. If the function is already defined,

@@ -87,26 +94,17 @@ module Make(Data:DATA_SIG) = struct
   let register t name signature f = begin

 

     let name' = String.uppercase_ascii name in

-    let map = begin match Catalog.find name' t with

-    | exception Not_found ->

-        Functions.singleton signature f

-    | x ->

-        (* We prevent any update to already registered function *)

-        if (Functions.mem signature x) then

-          raise RegisteredFunction

-        else

-          Functions.add signature f x

-    end in

-

-    Catalog.add name' map t

+    if Functions.member (name', signature) t then

+      raise RegisteredFunction

+    else

+      Functions.add (name', signature) f t

   end

 

   (** Look in the catalog for a function with the given name and signature *)

   let find_function:

   type a. t -> string -> a t_function sig_typ -> a t_function =

   begin fun t name signature ->

-    Catalog.find (String.uppercase_ascii name) t

-    |> Functions.find signature

+    Functions.find ((String.uppercase_ascii name), signature) t

   end

 

 end

diff --git a/splay.ml b/splay.ml
new file mode 100644
index 0000000..6f740eb
--- /dev/null
+++ b/splay.ml
@@ -0,0 +1,127 @@
+module Make (El : Tools.COMPARABLE_TYPE) = struct
+
+  type 'a elem = 'a El.t
+
+  type treeVal =
+    | Leaf : treeVal
+    | Node : treeVal * ('a elem * 'a) * treeVal -> treeVal
+
+  type tree = treeVal ref
+
+  type splay = S : treeVal * ('a elem * 'a) * treeVal -> splay
+
+  let empty = ref Leaf;;
+
+  let isEmpty tree = !tree = Leaf
+
+  let rec splay : type a. a elem -> splay -> splay = fun x t -> begin
+    let S (l, y, r) = t in
+    begin match El.comp x (fst y)  with
+      | Tools.Eq -> t
+      | Tools.Lt ->
+        begin match l with
+          | Leaf -> t
+          | Node (ll, z, rr) ->
+            begin match El.comp x (fst z)  with
+              | Tools.Eq -> S (ll, z, Node (rr, y, r))
+              | Tools.Lt ->
+                begin match ll with
+                  | Leaf -> S (ll, z, Node (rr, y, r))
+                  | Node (t1, k, t2 ) ->
+                    let ll = S (t1, k, t2) in
+                    let S (newL, newV, newR) = splay x ll
+                    in S (newL, newV, Node (newR, z, Node (rr, y, r)))
+                end
+              | Tools.Gt ->
+                begin match rr with
+                  | Leaf -> S (ll, z, Node (rr, y, r))
+                  | Node (t1, k, t2 ) ->
+                    let rr = S (t1, k, t2) in
+                    let S (newL, newV, newR) = splay x rr
+                    in S (Node (ll, z, newL), newV, Node (newR, y, r))
+                end
+            end
+        end
+      | Tools.Gt ->
+        begin match r with
+          | Leaf -> t
+          | Node (ll, z, rr) ->
+            begin match El.comp x (fst z)  with
+              | Tools.Eq -> S (Node (l, y, ll), z, rr)
+              | Tools.Lt ->
+                begin match ll with
+                  | Leaf -> S (Node (l, y, ll), z, rr)
+                  | Node (t1, k, t2 ) ->
+                    let ll = S (t1, k, t2) in
+                    let S (newL, newV, newR) = splay x ll
+                    in S (Node (l, y, newL), newV, Node (newR, z, rr))
+                end
+              | Tools.Gt ->
+                begin match rr with
+                  | Leaf -> S (Node (l, y, ll), z, rr)
+                  | Node (t1, k, t2 ) ->
+                    let rr = S (t1, k, t2) in
+                    let S (newL, newV, newR) = splay x rr
+                    in S (Node (Node(l, y, ll), z, newL), newV, newR)
+                end
+            end
+        end
+    end
+  end
+
+  let member: type a. a elem -> treeVal ref -> bool = fun x t ->
+
+    match !t with
+    | Leaf -> false
+    | Node (l, c, r) ->
+        let S (l', c', r') = splay x (S (l, c, r)) in
+        t := Node (l', c', r');
+        begin match El.comp (fst c') x  with
+          | Tools.Eq -> true
+          | _ -> false
+        end
+
+  let find: type a. a elem -> treeVal ref -> a = fun x t ->
+
+    match !t with
+    | Leaf -> raise Not_found
+    | Node (l, c, r) ->
+        let S (l', c', r') = splay x (S (l, c, r)) in
+        t := Node (l', c', r');
+        begin match El.comp (fst c') x with
+          | Tools.Eq -> snd c'
+          | _ -> raise Not_found
+        end
+
+  let add: type a. a elem -> a -> treeVal ref -> treeVal ref = fun key value t ->
+    begin match !t with
+    | Leaf -> ref (Node (Leaf, (key, value), Leaf))
+    | Node (l, c, r) ->
+        let S (l, y, r) = splay key (S (l, c, r)) in
+        begin match El.comp key (fst y)  with
+          | Tools.Eq -> ref (Node (l, y, r))
+          | Tools.Lt -> ref (Node (l, (key, value), Node (Leaf, y, r)))
+          | Tools.Gt -> ref (Node (Node (l, y, Leaf), (key, value), r))
+        end
+    end
+
+  let delete: type a. a elem -> treeVal ref -> treeVal ref = fun x t ->
+    begin match !t with
+    | Leaf -> ref Leaf
+    | Node (l, c, r) ->
+        let S (l, y, r) = splay x (S (l, c, r)) in
+        begin match El.comp x (fst y)  with
+            Tools.Eq ->
+            begin match (l,r) with
+              | (Leaf, _) -> ref r
+              | (_, Leaf) -> ref l
+              | (Node (t1, c, t2), _) ->
+                let S (newL, newV, newR) = splay x (S (t1, c, t2))
+                in ref (Node (newL, newV, r)) end
+          | _ -> ref (Node (l, y, r)) end
+        end
+
+  let rec depth tree = match tree with
+    | Node (l, _, r) -> max (depth l) (depth r) + 1
+    | Leaf -> 0
+end
diff --git a/tools.ml b/tools.ml
index 53b1c15..f8f03cb 100755
--- a/tools.ml
+++ b/tools.ml
@@ -304,7 +304,7 @@ module type COMPARABLE_TYPE = sig
 
     type 'a t
 
-    val eq: 'a t -> 'b t -> ('a, 'b) cmp
+    val comp: 'a t -> 'b t -> ('a, 'b) cmp
 
 end
 
@@ -317,7 +317,7 @@ module ArrayMap(Ord: COMPARABLE_TYPE) = struct
   let find: type a. a key -> t -> a = begin fun k (Val map) ->
     let rec find_ idx : a = begin
         let x, v = Array.get map idx in
-        match Ord.eq x k with
+        match Ord.comp x k with
         | Eq -> v
         | Lt -> find_ ((2 * idx) + 1)
         | Gt -> find_ ((2 * idx) + 2)
@@ -326,7 +326,7 @@ module ArrayMap(Ord: COMPARABLE_TYPE) = struct
   end
 
   let from_list l = begin
-    let compare (key_x, _) (key_y, _) = match Ord.eq key_x key_y with
+    let compare (key_x, _) (key_y, _) = match Ord.comp key_x key_y with
     | Eq -> 0
     | Lt -> -1
     | Gt -> 1
@@ -401,7 +401,7 @@ module Map(Ord: COMPARABLE_TYPE) = struct
   let rec add: type a. a key -> a -> t -> t = begin fun x data t -> match t with
     | Empty -> Node(Empty, x, data, Empty, 1)
     | Node(l, v, d, r, h) ->
-        match Ord.eq x v with
+        match Ord.comp x v with
         | Eq -> Node(l, x, data, r, h)
         | Lt -> bal (add x data l) v d r
         | Gt -> bal l v d (add x data r)
@@ -410,7 +410,7 @@ module Map(Ord: COMPARABLE_TYPE) = struct
   let rec find: type a. a key -> t -> a = begin fun x t -> match t with
     | Empty -> raise Not_found
     | Node(l, k, v, r, _) ->
-        match Ord.eq x k with
+        match Ord.comp x k with
         | Eq -> v
         | Lt -> find x l
         | Gt -> find x r
@@ -419,12 +419,13 @@ module Map(Ord: COMPARABLE_TYPE) = struct
   let rec mem: type a. a key -> t -> bool = begin fun  x t -> match t with
     | Empty -> false
     | Node(l, k, v, r, _) ->
-        match Ord.eq x k with
+        match Ord.comp x k with
         | Eq -> true
         | Lt -> mem x l
         | Gt -> mem x r
   end
 
+  (*
   let rec fold: ('a -> wrapper -> 'a) -> 'a -> t -> 'a =
   begin fun f init t -> match t with
   | Empty -> init
@@ -433,4 +434,5 @@ module Map(Ord: COMPARABLE_TYPE) = struct
       let result = f res_left @@ Ex (k, v) in
       fold f result r
   end
+  *)
 end