Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

221 lines (184 sloc) 6.341 kb
(* 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
Jump to Line
Something went wrong with that request. Please try again.