Skip to content
Browse files

[enhance] libbase: add RAList

  • Loading branch information...
1 parent 76e6168 commit 2d5ff4ad451aa5a461ccc02758f2bdfe4d202a02 Raja committed
Showing with 258 additions and 0 deletions.
  1. +1 −0 libbase.mllib
  2. +220 −0 libbase/RAList.ml
  3. +37 −0 libbase/RAList.mli
View
1 libbase.mllib
@@ -81,6 +81,7 @@ libbase/DebugVariables
libbase/UnionFind
libbase/SRope
libbase/HdList
+libbase/RAList
libbase/IdentGenerator
libbase/File_mimetype
# From weblib
View
220 libbase/RAList.ml
@@ -0,0 +1,220 @@
+(* 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
+
+
View
37 libbase/RAList.mli
@@ -0,0 +1,37 @@
+(** result of a comparison *)
+type comparison = Lesser | Equal | Greater
+(** invalid access of the ith element when only n elements (Invalid_subscript(i,n)) *)
+exception Invalid_subscript of (int*int)
+(** invalid operation on empty ra_list *)
+exception Empty
+
+type 'a ra_list
+
+(** classic operations of list, all O(1) *)
+module AsList :
+sig
+ exception StopFold (*to implement fold until *)
+ val is_empty : 'a ra_list -> bool
+ val empty : 'a ra_list
+ val cons : 'a -> 'a ra_list -> 'a ra_list
+ val head : 'a ra_list -> 'a (* raise Empty *)
+ val tail : 'a ra_list -> 'a ra_list (* raise Empty *)
+ val fold : ('a->'b->'b) -> 'a ra_list -> 'b -> 'b (* catch StopFold to implement fold until *)
+ val rev_fold : ('a->'b->'b) -> 'a ra_list -> 'b -> 'b (* catch StopFold to implement fold until *)
+end
+
+(** classic operations of functional array, O(ln(N)) *)
+module AsArray :
+sig
+ val size : 'a ra_list -> int
+ val get : 'a ra_list -> int -> 'a (* raise Invalid_subscript *)
+ val update : 'a ra_list -> int -> 'a -> 'a ra_list (* raise Invalid_subscript *)
+end
+
+module AsMonotoniousList :
+sig
+ (** return the lastest entry that is <= hypothetical asked entry,
+ via the comparison function which asked entry has already been passed to (facilitate comparison on projection) *)
+ val get_lesser : ('a -> comparison ) -> 'a ra_list -> 'a (* raise Not_found *)
+(* val get *)
+end

0 comments on commit 2d5ff4a

Please sign in to comment.
Something went wrong with that request. Please try again.