1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
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
|
