diff options
Diffstat (limited to 'splay.ml')
| -rw-r--r-- | splay.ml | 127 |
1 files changed, 127 insertions, 0 deletions
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 |