1 files changed, 142 insertions, 0 deletions
diff --git a/src/splay.ml b/src/splay.ml
new file mode 100644
index 0000000..ec5750c
--- /dev/null
+++ b/src/splay.ml
@@ -0,0 +1,142 @@
+module type KEY = sig
+
+    type 'a t
+
+    val comp: 'a t -> 'b t -> ('a, 'b) Tools.cmp
+
+    val repr: Format.formatter -> 'a t -> unit
+
+end
+
+module Make (El : KEY) = struct
+
+  type 'a elem = 'a El.t
+
+  type leaf (** Fantom type for typing the tree *)
+  type node (** Fantom type for typing the tree *)
+
+  type 'a treeVal =
+    | Leaf : leaf treeVal
+    | Node : _ treeVal * ('a elem * 'a) * _ treeVal -> node treeVal
+
+  type t = T : 'a treeVal ref -> t [@@unboxed]
+
+  let empty = T (ref Leaf)
+
+  let isEmpty (T tree) = match !tree with
+    | Leaf -> true
+    | _ -> false
+
+  let rec splay : type a. a elem -> node treeVal -> node treeVal = fun x t -> begin
+    let Node (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 -> Node (ll, z, Node (rr, y, r))
+              | Tools.Lt ->
+                begin match ll with
+                  | Leaf -> Node (ll, z, Node (rr, y, r))
+                  | Node _ as ll ->
+                    let Node (newL, newV, newR) = splay x ll
+                    in Node (newL, newV, Node (newR, z, Node (rr, y, r)))
+                end
+              | Tools.Gt ->
+                begin match rr with
+                  | Leaf -> Node (ll, z, Node (rr, y, r))
+                  | Node _ as rr ->
+                    let Node (newL, newV, newR) = splay x rr
+                    in Node (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 -> Node (Node (l, y, ll), z, rr)
+              | Tools.Lt ->
+                begin match ll with
+                  | Leaf -> Node (Node (l, y, ll), z, rr)
+                  | Node _ as ll ->
+                    let Node (newL, newV, newR) = splay x ll
+                    in Node (Node (l, y, newL), newV, Node (newR, z, rr))
+                end
+              | Tools.Gt ->
+                begin match rr with
+                  | Leaf -> Node (Node (l, y, ll), z, rr)
+                  | Node _ as rr ->
+                    let Node (newL, newV, newR) = splay x rr
+                    in Node (Node (Node(l, y, ll), z, newL), newV, newR)
+                end
+            end
+        end
+    end
+  end
+
+  let member: type a. a elem -> t -> bool = fun x (T t) -> match !t with
+    | Leaf -> false
+    | Node _ as root ->
+        let root' = splay x root in
+        t := root';
+        let Node (_, c', _) = root' in
+        begin match El.comp (fst c') x  with
+          | Tools.Eq -> true
+          | _ -> false
+        end
+
+  let find: type a. a elem -> t -> a = fun x (T t) -> match !t with
+    | Leaf -> raise Not_found
+    | Node _ as root ->
+        let root' = splay x root in
+        t := root';
+        let Node (_, c', _) = root' in
+        begin match El.comp (fst c') x with
+          | Tools.Eq -> snd c'
+          | _ -> raise Not_found
+        end
+
+  let add: type a. a elem -> a -> t -> t = fun key value (T t) -> match !t with
+    | Leaf -> T (ref (Node (Leaf, (key, value), Leaf)))
+    | Node _ as root ->
+        let root' = splay key root in
+        let Node (l, y, r) = root' in
+        begin match El.comp key (fst y)  with
+          | Tools.Eq -> T (ref root')
+          | Tools.Lt -> T (ref (Node (l, (key, value), Node (Leaf, y, r))))
+          | Tools.Gt -> T (ref (Node (Node (l, y, Leaf), (key, value), r)))
+        end
+
+  let repr formatter (T t) = begin
+
+    let repr_edge from formatter dest = begin
+      Format.fprintf formatter "\"%a\" -> \"%a\"\n"
+        El.repr from
+        El.repr dest
+    end in
+
+    let rec repr': type a b. a El.t -> Format.formatter -> b treeVal -> unit = fun parent formatter -> function
+    | Leaf -> ()
+    | Node (l, c, r) ->
+        let key = fst c in
+        Format.fprintf formatter "%a%a%a"
+        (repr_edge parent) key
+        (repr' key) l
+        (repr' key) r in
+
+    begin match !t with
+    | Leaf -> Format.fprintf formatter "digraph G {}"
+    | Node (l, c, r) ->
+      let key = fst c in
+      Format.fprintf formatter "digraph G {\n%a%a}"
+        (repr' key) l
+        (repr' key) r
+    end
+
+  end
+
+end