From 397f2878434d1a1a3ea2091f309ae03c58c6c4db Mon Sep 17 00:00:00 2001
From: Sébastien Dailly <sebastien@chimrod.com>
Date: Wed, 1 Nov 2017 10:40:44 +0100
Subject: Added splaytree

---
 splay.ml | 127 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 127 insertions(+)
 create mode 100644 splay.ml

(limited to 'splay.ml')

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
-- 
cgit v1.2.3