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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
module type KEY = sig
type 'a t
(** Parametrized comparator *)
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
|
