Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 221 lines (184 sloc) 6.341 kb
2d5ff4a [enhance] libbase: add RAList
Raja authored
1 (* see mli *)
2 type comparison = Lesser | Equal | Greater
3 exception Invalid_subscript of (int*int)
4 exception Empty
5 exception StopFold (*to implement fold until *)
6
7 (** the asked value is lesser than all entries *)
8 exception Not_found_lesser
9 (** the asked value is greater than all entries *)
10 exception Not_found_greater
11
12 (** Random Access List
13 Happily copied from Purely Functional Random-Access Lists from Okasaki
14 Add lookup for monotonuous list *)
15
16 (** CompleteBinaryTree ********************************************************************************************************)
17 module Tree :
18 sig
19 type 'a tree
20 type 'a treeview = Leaf of 'a | Node of 'a * 'a tree * 'a tree (* Duplication, NAAAAAAAAAAAAAAAAAAAAAAAAAAAAAN ! *)
21 val view : 'a tree -> 'a treeview (* get a possibly simplified view *)
22 val node : 'a -> 'a tree -> 'a tree -> 'a tree
23 val leaf : 'a -> 'a tree
24 val root : 'a tree -> 'a
25 val get : int(*size*) -> int(*pos*) -> 'a tree -> 'a
26 val update : int(*size*) -> int(*pos*) -> 'a tree -> 'a -> 'a tree
27 val generic_get : accept_lesser:bool -> compared_to:('a->comparison) -> 'a tree -> 'a
28 val fold : ('a->'acc->'acc) -> 'a tree -> 'acc -> 'acc
29 val rev_fold : ('a->'acc->'acc) -> 'a tree -> 'acc -> 'acc
30 end =
31 struct
32 (** public view *)
33 type 'a tree = 'a treeview
34 and 'a treeview = Leaf of 'a | Node of 'a * 'a tree * 'a tree
35 let view (x:'a tree) = (x:'a treeview) (* to abstract true tree representation *)
36
37 let node x l r = Node( x,l,r)
38 let leaf x = Leaf x
39 let root tree =
40 match tree with
41 | Leaf x | Node(x,_,_) -> x
42
43 let rec get size i tree =
44 match tree with
45 | Node(x,l,r) ->
46 if i==0 then x
47 else
48 let size = size / 2 in
49 if i <= size
50 then get size (i-1) l
51 else get size (i-1-size) r
52 | Leaf(x) ->
53 if i==0 then x
54 else raise (Invalid_subscript(i,size))
55
56 let rec update size i tree x =
57 match tree with
58 | Node (o,l,r) ->
59 if i==0 then Node (x,l,r)
60 else
61 let size = size / 2 in
62 if i <= size
63 then Node (o, update size (i-1) l x, r)
64 else Node (o, l, update size (i-1-size) r x)
65 | Leaf _ ->
66 if i==0 then Leaf x
67 else raise (Invalid_subscript(i,size))
68
69
70 (**
71 return the first entry that is equal according to comparison function (or lesser then if accept_lesser is true)
72 assuming all entry have been consed in increasing order wrt to the comparison function
73 raise Not_found_greater , asked is greater than all entry (when accept_lesser=false)
74 raise Not_found_lesser , asked is lesser than all entry
75 *)
76 (* recursively search right subtree first than left subtree if needed (in this case first search is O(1))
77 if searching a value bigger than all tree value => returning it in O(1) *)
78 let rec generic_get ~accept_lesser ~compared_to tree =
79 let x = root tree in
80 match (*asked*) compared_to x with
81 | Greater when accept_lesser -> x
82 | Greater -> raise Not_found_greater
83 | Equal -> x
84 | Lesser ->
85 match tree with
86 | Leaf _ -> raise Not_found_lesser
87 | Node(_,l,r) ->
88 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 *)
89 (*NOP | Not_found_lesser -> raise Not_found_lesser *)
90 | Not_found_greater (* asked is greater than all r *)->
91 try generic_get ~accept_lesser ~compared_to l with
92 | Not_found_lesser (* asked is lesser than all l *) -> root r
93 (*NOP | Not_found_greater -> raise Not_found_greater *)
94
95
96
97
98 let (|>) a f = f a
99
100 let rec fold f t acc =
101 match t with
102 | Leaf x ->
103 (try
104 f x acc
105 with StopFold -> acc)
106 | Node(x,l,r) ->
107 (try
108 f x acc |> fold f l |> fold f r
109 with StopFold -> acc)
110
111 let rec rev_fold f t acc =
112 match t with
113 | Leaf x ->
114 (try
115 f x acc
116 with StopFold -> acc)
117 | Node(x,l,r) ->
118 (try
119 fold f r acc |> fold f l |> f x
120 with StopFold -> acc)
121
122
123 end
124
125 (** RA list types *)
126 type 'a tree = { size : int ; tree : 'a Tree.tree} (* should be size1 size3 sizeN *)
127 type 'a ra_list = 'a tree list
128
129 (** List interface ********************************************************************************************************)
130 module AsList = struct
131 exception StopFold =StopFold
132 let empty = ([] : 'a ra_list)
133 let is_empty l = l=empty
134
135 let cons x l =
136 match l with
137 | {size=s1;tree=t1} :: {size=s2;tree=t2} :: rest when s1=s2->
138 {size=1+s1+s2;tree=Tree.node x t1 t2 } :: rest
139 | _ ->
140 {size=1;tree=Tree.leaf x} :: l
141
142 let head l =
143 match l with
144 | {size=_;tree=t} :: _ -> Tree.root t
145 | [] -> raise Empty
146
147 let tail l =
148 match l with
149 | {size=1;tree=_}::rest -> rest
150 | {size=s;tree=t}::rest ->
151 let s=s/2 in
152 begin match Tree.view t with
153 | Tree.Node(_,t1,t2) -> {size=s;tree=t1} :: {size=s;tree=t2} :: rest
154 | _ -> assert false
155 end
156 | [] -> raise Empty
157
158 let rec fold f (l:'a ra_list) acc =
159 match l with
160 | [] -> acc
161 | {size=_;tree=t}::rl ->
162 try fold f rl (Tree.fold f t acc)
163 with StopFold -> acc
164
165 let rev_fold f l acc =
166 let rec aux l acc =
167 match l with
168 | [] -> acc
169 | {size=_; tree=t}::rl ->
170 try aux rl (Tree.rev_fold f t acc)
171 with StopFold -> acc
172 in aux (List.rev l) acc
173
174 end
175
176 (** Array interface ********************************************************************************************************)
177 module AsArray = struct
178
179 let size l = List.fold_left (fun acc {size=s;tree=_} -> acc+s) 0 l
180
181 let rec raw_get l i =
182 match l with
183 | [] -> raise (Invalid_subscript(i,0))
184 | {size=s;tree=t}::rest ->
185 if i < s
186 then Tree.get s i t
187 else raw_get rest (i-s)
188
189 let get l i =
190 try raw_get l i
191 with Invalid_subscript _ -> raise (Invalid_subscript(i,size l))
192
193 let rec raw_update l i v =
194 match l with
195 | [] -> raise (Invalid_subscript(i,0))
196 | ({size=s;tree=t} as e)::rest ->
197 if i < s
198 then {e with tree=(Tree.update s i t v)}::rest
199 else e::raw_update rest (i-s) v
200
201 let update l i v =
202 try raw_update l i v
203 with Invalid_subscript _ -> raise (Invalid_subscript(i,size l))
204
205 end
206
207 module AsMonotoniousList = struct
208
209 let rec get_lesser compared_to l =
210 match l with
211 | [] -> raise Not_found
212 | {size=_;tree=t}::rest ->
213 try Tree.generic_get ~accept_lesser:true ~compared_to t
214 with
215 | Not_found_lesser -> get_lesser compared_to rest
216 | Not_found_greater -> raise Not_found
217
218 end
219
220
Something went wrong with that request. Please try again.