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