forked from alokmenghrajani/opalang
-
Notifications
You must be signed in to change notification settings - Fork 0
/
RAList.ml
220 lines (184 loc) · 6.19 KB
/
RAList.ml
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
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
(* see mli *)
type comparison = Lesser | Equal | Greater
exception Invalid_subscript of (int*int)
exception Empty
exception StopFold (*to implement fold until *)
(** the asked value is lesser than all entries *)
exception Not_found_lesser
(** the asked value is greater than all entries *)
exception Not_found_greater
(** Random Access List
Happily copied from Purely Functional Random-Access Lists from Okasaki
Add lookup for monotonuous list *)
(** CompleteBinaryTree ********************************************************************************************************)
module Tree :
sig
type 'a tree
type 'a treeview = Leaf of 'a | Node of 'a * 'a tree * 'a tree (* Duplication, NAAAAAAAAAAAAAAAAAAAAAAAAAAAAAN ! *)
val view : 'a tree -> 'a treeview (* get a possibly simplified view *)
val node : 'a -> 'a tree -> 'a tree -> 'a tree
val leaf : 'a -> 'a tree
val root : 'a tree -> 'a
val get : int(*size*) -> int(*pos*) -> 'a tree -> 'a
val update : int(*size*) -> int(*pos*) -> 'a tree -> 'a -> 'a tree
val generic_get : accept_lesser:bool -> compared_to:('a->comparison) -> 'a tree -> 'a
val fold : ('a->'acc->'acc) -> 'a tree -> 'acc -> 'acc
val rev_fold : ('a->'acc->'acc) -> 'a tree -> 'acc -> 'acc
end =
struct
(** public view *)
type 'a tree = 'a treeview
and 'a treeview = Leaf of 'a | Node of 'a * 'a tree * 'a tree
let view (x:'a tree) = (x:'a treeview) (* to abstract true tree representation *)
let node x l r = Node( x,l,r)
let leaf x = Leaf x
let root tree =
match tree with
| Leaf x | Node(x,_,_) -> x
let rec get size i tree =
match tree with
| Node(x,l,r) ->
if i==0 then x
else
let size = size / 2 in
if i <= size
then get size (i-1) l
else get size (i-1-size) r
| Leaf(x) ->
if i==0 then x
else raise (Invalid_subscript(i,size))
let rec update size i tree x =
match tree with
| Node (o,l,r) ->
if i==0 then Node (x,l,r)
else
let size = size / 2 in
if i <= size
then Node (o, update size (i-1) l x, r)
else Node (o, l, update size (i-1-size) r x)
| Leaf _ ->
if i==0 then Leaf x
else raise (Invalid_subscript(i,size))
(**
return the first entry that is equal according to comparison function (or lesser then if accept_lesser is true)
assuming all entry have been consed in increasing order wrt to the comparison function
raise Not_found_greater , asked is greater than all entry (when accept_lesser=false)
raise Not_found_lesser , asked is lesser than all entry
*)
(* recursively search right subtree first than left subtree if needed (in this case first search is O(1))
if searching a value bigger than all tree value => returning it in O(1) *)
let rec generic_get ~accept_lesser ~compared_to tree =
let x = root tree in
match (*asked*) compared_to x with
| Greater when accept_lesser -> x
| Greater -> raise Not_found_greater
| Equal -> x
| Lesser ->
match tree with
| Leaf _ -> raise Not_found_lesser
| Node(_,l,r) ->
try generic_get ~accept_lesser:false ~compared_to r with (* on root of r, will raise Not_found_greater in O(1) if l must be searched first *)
(*NOP | Not_found_lesser -> raise Not_found_lesser *)
| Not_found_greater (* asked is greater than all r *)->
try generic_get ~accept_lesser ~compared_to l with
| Not_found_lesser (* asked is lesser than all l *) -> root r
(*NOP | Not_found_greater -> raise Not_found_greater *)
let (|>) a f = f a
let rec fold f t acc =
match t with
| Leaf x ->
(try
f x acc
with StopFold -> acc)
| Node(x,l,r) ->
(try
f x acc |> fold f l |> fold f r
with StopFold -> acc)
let rec rev_fold f t acc =
match t with
| Leaf x ->
(try
f x acc
with StopFold -> acc)
| Node(x,l,r) ->
(try
fold f r acc |> fold f l |> f x
with StopFold -> acc)
end
(** RA list types *)
type 'a tree = { size : int ; tree : 'a Tree.tree} (* should be size1 size3 sizeN *)
type 'a ra_list = 'a tree list
(** List interface ********************************************************************************************************)
module AsList = struct
exception StopFold =StopFold
let empty = ([] : 'a ra_list)
let is_empty l = l=empty
let cons x l =
match l with
| {size=s1;tree=t1} :: {size=s2;tree=t2} :: rest when s1=s2->
{size=1+s1+s2;tree=Tree.node x t1 t2 } :: rest
| _ ->
{size=1;tree=Tree.leaf x} :: l
let head l =
match l with
| {size=_;tree=t} :: _ -> Tree.root t
| [] -> raise Empty
let tail l =
match l with
| {size=1;tree=_}::rest -> rest
| {size=s;tree=t}::rest ->
let s=s/2 in
begin match Tree.view t with
| Tree.Node(_,t1,t2) -> {size=s;tree=t1} :: {size=s;tree=t2} :: rest
| _ -> assert false
end
| [] -> raise Empty
let rec fold f (l:'a ra_list) acc =
match l with
| [] -> acc
| {size=_;tree=t}::rl ->
try fold f rl (Tree.fold f t acc)
with StopFold -> acc
let rev_fold f l acc =
let rec aux l acc =
match l with
| [] -> acc
| {size=_; tree=t}::rl ->
try aux rl (Tree.rev_fold f t acc)
with StopFold -> acc
in aux (List.rev l) acc
end
(** Array interface ********************************************************************************************************)
module AsArray = struct
let size l = List.fold_left (fun acc {size=s;tree=_} -> acc+s) 0 l
let rec raw_get l i =
match l with
| [] -> raise (Invalid_subscript(i,0))
| {size=s;tree=t}::rest ->
if i < s
then Tree.get s i t
else raw_get rest (i-s)
let get l i =
try raw_get l i
with Invalid_subscript _ -> raise (Invalid_subscript(i,size l))
let rec raw_update l i v =
match l with
| [] -> raise (Invalid_subscript(i,0))
| ({size=s;tree=t} as e)::rest ->
if i < s
then {e with tree=(Tree.update s i t v)}::rest
else e::raw_update rest (i-s) v
let update l i v =
try raw_update l i v
with Invalid_subscript _ -> raise (Invalid_subscript(i,size l))
end
module AsMonotoniousList = struct
let rec get_lesser compared_to l =
match l with
| [] -> raise Not_found
| {size=_;tree=t}::rest ->
try Tree.generic_get ~accept_lesser:true ~compared_to t
with
| Not_found_lesser -> get_lesser compared_to rest
| Not_found_greater -> raise Not_found
end