Select Git revision
imperativeBL.ml
Guyslain Naves authored
imperativeBL.ml 20.19 KiB
open! DataStruct
module type S =
sig
type elt
val pqtree : elt PqTree.t
val index : elt -> int
end
module Make =
functor (T : S) ->
struct
open PqTree
type elt = T.elt
let max_nb_nodes = 3 * length T.pqtree
let pool = ref (Pool.make_int_pool max_nb_nodes)
let get_new_index () =
let (index, p) = Pool.get !pool in
pool := p;
index
let free_index index =
pool := Pool.free index !pool
type kind = L of T.elt | PNode | QNode
type status = Full | Partial | Empty
type node = int
let root = ref 0
let parent = Array.make max_nb_nodes None
let next = Array.make max_nb_nodes None
let previous = Array.make max_nb_nodes None
let leftmost_child = Array.make max_nb_nodes None
let rightmost_child = Array.make max_nb_nodes None
let kind = Array.make max_nb_nodes PNode
let nb_children = Array.make max_nb_nodes 0
let is_visited = Array.make max_nb_nodes false
let active_children = Array.make max_nb_nodes []
let status = Array.make max_nb_nodes Empty
let visited = ref []
let leaf = Array.make (length T.pqtree) (-1)
let clean_node node =
if is_visited.(node) then
begin
is_visited.(node) <- false;
active_children.(node) <- [];
status.(node) <- Empty
end
let clean () =
List.iter clean_node !visited;
visited := []
let free = free_index
let add_child ?(left_of=None) p child =
next.(child) <- left_of;
parent.(child) <- Some p;
nb_children.(p) <- nb_children.(p) + 1; match left_of with
| None ->
begin match rightmost_child.(p) with
| Some right -> next.(right) <- Some child
| None -> leftmost_child.(p) <- Some child
end;
previous.(child) <- rightmost_child.(p);
rightmost_child.(p) <- Some child
| Some c ->
begin match previous.(c) with
| Some left -> next.(left) <- Some child
| None -> leftmost_child.(p) <- Some child
end;
previous.(child) <- previous.(c);
previous.(c) <- Some child
let add_last_child ?(rev=false) p child =
if rev then add_child ~left_of:leftmost_child.(p) p child
else add_child ~left_of:None p child
let add_first_child ?(rev=false) p child =
add_last_child ~rev:(not rev) p child
let detach child =
match parent.(child) with
| None -> ()
| Some p ->
parent.(child) <- None;
nb_children.(p) <- nb_children.(p) - 1;
begin match previous.(child) with
| None -> leftmost_child.(p) <- next.(child)
| Some left -> next.(left) <- next.(child)
end;
begin match next.(child) with
| None -> rightmost_child.(p) <- previous.(child)
| Some right -> previous.(right) <- previous.(child)
end ;
previous.(child) <- None;
next.(child) <- None
let replace p q =
match parent.(p) with
| None ->
root := q;
parent.(q) <- None
| Some r ->
let left_of = next.(p) in
detach p;
add_child ~left_of r q
let contract_if_trivial p =
match nb_children.(p) with
| 1 ->
leftmost_child.(p)
|> Option.iter (fun child ->
detach child;
replace p child;
free p
)
| 0 ->
detach p;
free p
| _ -> ()
let previous_seq start =
Seq.unfold (Option.map (fun child -> (child, previous.(child)))) start |> List.of_seq
let next_seq start =
Seq.unfold (Option.map (fun child -> (child, next.(child)))) start |> List.of_seq
let children_seq p = next_seq leftmost_child.(p)
let rev_children_seq p = previous_seq rightmost_child.(p)
let absorb ?(rev=false) p q =
let left_of = next.(q) in
detach q;
List.iter (add_child ~left_of p) (if rev then rev_children_seq q else children_seq q);
free q;
p
let expand ?(rev=false) p q =
let (left_seq,right_seq) =
if rev then (next_seq next.(q), previous_seq previous.(q))
else (previous_seq previous.(q), next_seq next.(q))
in
List.iter (fun c -> detach c; add_first_child q c) left_seq;
List.iter (fun c -> detach c; add_last_child q c) right_seq;
detach q;
replace p q;
free p;
q
let vertical_q_merge (p,p_is_leftist) (q,q_is_leftist) =
let rev = p_is_leftist <> q_is_leftist in
if nb_children.(p) >= nb_children.(q) then
(absorb ~rev p q, p_is_leftist)
else
(expand ~rev p q, q_is_leftist)
let horizontal_q_merge partial1 full_nodes partial2 =
let ((small, small_is_leftist),(big,big_is_leftist)) =
if nb_children.(fst partial1) >= nb_children.(fst partial2) then (partial2, partial1)
else (partial1, partial2)
in
let rev = big_is_leftist in
detach small;
Option.iter (fun node -> add_last_child ~rev big node) full_nodes;
List.iter
(fun c -> detach c; add_last_child ~rev big c)
(if small_is_leftist then
children_seq small
else
rev_children_seq small
);
free small;
big
let create_node ?(p=None) ~k ?(left=None) ?(right=None) children =
let index = get_new_index () in
parent.(index) <- p;
kind.(index) <- k;
next.(index) <- right;
previous.(index) <- left;
leftmost_child.(index) <- None;
rightmost_child.(index) <- None;
nb_children.(index) <- 0;
List.iter (add_last_child index) children;
begin match k with
| L elt -> leaf.(T.index elt) <- index
| _ -> ()
end; is_visited.(index) <- false;
active_children.(index) <- [];
status.(index) <- Empty;
index
let join_p = function
| [] -> assert false
| [single] ->
detach single;
single
| full_trees ->
List.iter detach full_trees;
create_node ~k:PNode full_trees
let initialize () =
let rec go node =
match node with
| Leaf elt ->
create_node ~k:(L elt) ~p:None []
| P children_nodes ->
let children = List.map go children_nodes in
create_node ~k:PNode ~p:None children
| Q children_nodes ->
let children = List.map go children_nodes in
create_node ~k:QNode ~p:None children
in
root := go T.pqtree
let mark_active_nodes leaves =
let visit node queue =
is_visited.(node) <- true;
visited := node :: !visited;
match parent.(node) with
| Some p ->
let is_new_node = active_children.(p) = [] in
active_children.(p) <- node :: active_children.(p);
if is_new_node then
begin
FQueue.enqueue queue p
end
else queue
| None -> FQueue.enqueue queue node
in
let rec go queue =
match FQueue.view queue with
| None -> assert false
| Some (index, others) when FQueue.is_empty others ->
if (not is_visited.(index)) then
begin
is_visited.(index) <- true;
visited := index :: !visited
end;
index
| Some (index, others) -> go (visit index others)
in
leaves
|> FQueue.of_list
|> go
let find_pertinent_node leaves =
let common_ancestor = mark_active_nodes leaves in
let rec go ancestor =
match active_children.(ancestor) with
| [single_child] -> go single_child
| _ -> ancestor
in go common_ancestor
let rec set_status node =
let are_all_fulls =
active_children.(node)
|> List.map set_status
|> List.for_all (fun b -> b)
in
let is_full = are_all_fulls && List.length active_children.(node) = nb_children.(node) in
status.(node) <- if is_full then Full else Partial;
is_full
type active_interval =
| LeftInterval of node
| RightInterval of node
| MiddleInterval of node * node
| NotAnInterval
let is_left_end_of_interval node =
match previous.(node) with
| None -> true
| Some sibling -> status.(sibling) = Empty
let is_youngest node =
next.(node) = None
let is_right_end_of_interval node =
match next.(node) with
| None -> true
| Some sibling -> status.(sibling) = Empty
let is_oldest node =
previous.(node) = None
let is_middle node =
not (is_left_end_of_interval node) && not (is_right_end_of_interval node)
let is_middle_partial node =
is_middle node && status.(node) = Partial
let get_active_interval node =
let achildren = active_children.(node) in
let leftmosts = List.filter is_left_end_of_interval achildren in
let rightmosts = List.filter is_right_end_of_interval achildren in
match leftmosts, rightmosts with
| _ when List.exists is_middle_partial achildren -> NotAnInterval
| [lchild], [rchild] when lchild = rchild ->
if is_oldest lchild then LeftInterval rchild
else if is_youngest rchild then RightInterval lchild
else MiddleInterval (lchild, rchild)
| [lchild], [rchild] ->
if is_oldest lchild && not (status.(lchild) == Partial) then
LeftInterval rchild
else if is_youngest rchild && not (status.(rchild) == Partial) then
RightInterval lchild
else
MiddleInterval (lchild, rchild)
| _, _ -> NotAnInterval
type 'subtree reducible =
| Reduced of (node * bool)
| Reduction of 'subtree
type 'subtree reducibility = | Irreducible
| Reducible of 'subtree reducible
type partial_subtree =
| PartialP0 of node * node list
| PartialP1 of node * partial_subtree reducible * node list
| PartialQ1 of node * bool * partial_subtree reducible
type pertinent_subtree =
| PartialSubtree of partial_subtree
| PertinentP2 of node * partial_subtree reducible * partial_subtree reducible * node list
| PertinentQMiddlePBoth of node * partial_subtree reducible * partial_subtree reducible
| PertinentQMiddlePLeft of node * partial_subtree reducible
| PertinentQMiddlePRight of node * partial_subtree reducible
let is_full node = status.(node) = Full
let partition_p_children node =
List.partition is_full active_children.(node)
let (>>=) e f = match e with
| Irreducible -> Irreducible
| Reducible reduction -> f reduction
let rec make_q_subtree node = function
| NotAnInterval -> Irreducible
| LeftInterval rchild when status.(rchild) = Partial ->
make_subtree rchild >>= fun sub ->
Reducible (Reduction (PartialQ1 (node, true, sub)))
| LeftInterval _ ->
Reducible (Reduced (node, true))
| RightInterval lchild when status.(lchild) = Partial ->
make_subtree lchild >>= fun sub ->
Reducible (Reduction (PartialQ1 (node, false, sub)))
| RightInterval _ ->
Reducible (Reduced (node, false))
| MiddleInterval _ -> Irreducible
and make_p_subtree node = function
| fulls, [] ->
Reducible (Reduction (PartialP0 (node, fulls)))
| fulls, [partial] ->
make_subtree partial >>= fun sub ->
Reducible (Reduction (PartialP1 (node, sub, fulls)))
| _ -> Irreducible
and make_subtree node =
if status.(node) = Full then Reducible (Reduced (node, false))
else match kind.(node) with
| PNode -> make_p_subtree node (partition_p_children node)
| QNode -> make_q_subtree node (get_active_interval node)
| L _ -> Reducible (Reduced (node, false))
let lift_to_pertinent = function
| Reduced _ as red -> Reducible red
| Reduction subtree -> Reducible (Reduction (PartialSubtree subtree))
let make_pertinent_p_subtree pertinent_node = function
| fulls, [partial1; partial2] ->
make_subtree partial1 >>= fun sub1 ->
make_subtree partial2 >>= fun sub2 ->
Reducible (Reduction (PertinentP2 (pertinent_node, sub1, sub2, fulls)))
| partition -> make_p_subtree pertinent_node partition >>= lift_to_pertinent
let make_pertinent_q_subtree pertinent_node = function
| MiddleInterval (lchild, rchild)
when status.(lchild) = Partial && status.(rchild) = Partial ->
make_subtree lchild >>= fun sub1 ->
make_subtree rchild >>= fun sub2 ->
Reducible (Reduction (PertinentQMiddlePBoth (pertinent_node, sub1, sub2)))
| MiddleInterval (lchild, _) when status.(lchild) = Partial ->
make_subtree lchild >>= fun sub1 ->
Reducible (Reduction (PertinentQMiddlePLeft (pertinent_node, sub1)))
| MiddleInterval (_, rchild) when status.(rchild) = Partial ->
make_subtree rchild >>= fun sub2 ->
Reducible (Reduction (PertinentQMiddlePRight (pertinent_node, sub2)))
| MiddleInterval (_,_) ->
Reducible (Reduced (pertinent_node, false))
| interval ->
make_q_subtree pertinent_node interval >>= lift_to_pertinent
let make_pertinent_subtree pertinent_node =
match kind.(pertinent_node) with
| _ when status.(pertinent_node) = Full ->
Reducible (Reduced (pertinent_node, false))
| PNode -> make_pertinent_p_subtree pertinent_node (partition_p_children pertinent_node)
| QNode -> make_pertinent_q_subtree pertinent_node (get_active_interval pertinent_node)
| L _ -> Irreducible
(* always returns a partial Q-node *)
let rec reduce = function
| Reduced red -> red
| Reduction (PartialP0 (p, fulls)) ->
let full = join_p fulls in
if nb_children.(p) = 1 then
begin
kind.(p) <- QNode;
add_last_child p full;
(p, false)
end
else
begin
let q = create_node ~k:QNode [full] in
replace p q;
add_first_child q p;
(q,false)
end
| Reduction (PartialP1 (p, partial, fulls)) ->
let (q,q_is_leftist) = reduce partial in
detach q;
replace p q;
add_first_child ~rev:q_is_leftist q p;
if fulls <> [] then
begin
let full = join_p fulls in
add_last_child ~rev:q_is_leftist q full
end;
contract_if_trivial p;
(q, q_is_leftist)
| Reduction (PartialQ1 (p, p_is_leftist, reducible)) ->
vertical_q_merge (p,p_is_leftist) (reduce reducible)
let reduce_pertinent = function
| Reduced _ -> ()
| Reduction (PartialSubtree (PartialP0 (p,fulls))) ->
let q = join_p fulls in
add_last_child p q
| Reduction (PartialSubtree (PartialP1 (p, partial, fulls))) ->
let (q, rev) = reduce partial in List.iter detach fulls;
detach q;
if fulls <> [] then
begin
let s = join_p fulls in
add_last_child ~rev q s
end;
if nb_children.(p) > 0 then
add_last_child p q
else
begin
replace p q;
free p
end
| Reduction (PartialSubtree sub) ->
let (q,_ ) = reduce (Reduction sub) in
if kind.(q) = QNode && nb_children.(q) = 2 then
kind.(q) <- PNode
| Reduction (PertinentP2 (p, partial1, partial2, full_nodes)) ->
let full =
if full_nodes = [] then None
else Some (join_p full_nodes)
in
let qnode = horizontal_q_merge (reduce partial1) full (reduce partial2) in
if nb_children.(p) = 1 then
begin
replace p qnode;
free p
end
| Reduction (PertinentQMiddlePLeft (p, partial_left)) ->
vertical_q_merge (p, false) (reduce partial_left) |> ignore
| Reduction (PertinentQMiddlePRight (p, partial_right)) ->
vertical_q_merge (p,true) (reduce partial_right) |> ignore
| Reduction (PertinentQMiddlePBoth (p, partial_left, partial_right)) ->
let (r, r_is_left) = vertical_q_merge (p, false) (reduce partial_left) in
vertical_q_merge (r, not r_is_left) (reduce partial_right) |> ignore
let subtree_is_block = function
| Reducible (Reduced _) -> true
| _ -> false
let subtree_is_interval = function
| Reducible _ -> true
| _ -> false
let pertinent_subtree interval =
let leaves = List.map (fun elt -> leaf.(T.index elt)) interval in
let pertinent_node = find_pertinent_node leaves in
let _ = set_status pertinent_node in
let subtree = make_pertinent_subtree pertinent_node in
clean ();
subtree
let test_subtree condition = function
| [] -> true
| [_] -> true
| interval ->
condition (pertinent_subtree interval)
let is_interval =
test_subtree subtree_is_interval
let is_block =
test_subtree subtree_is_block
let insert = function
| [] | [_] -> true | interval ->
match pertinent_subtree interval with
| Irreducible -> false
| Reducible red ->
reduce_pertinent red;
true
let get () =
let rec go node =
match kind.(node) with
| L elt -> Leaf elt
| PNode ->
children_seq node
|> List.map go
|> fun children -> P children
| QNode ->
children_seq node
|> List.map go
|> fun children -> Q children
in
go !root
module Test = struct
let write_option fmt = function
| None -> Format.fprintf fmt "-"
| Some node -> Format.fprintf fmt "%d" node
let indent k = String.make (2 * k) ' '
let write_node i fmt node =
let write_inner kind =
Format.fprintf fmt "%s%s %d, parent %a, leftmost child %a, rightmost child %a, previous %a, next %a\n"
(indent i)
kind
node
write_option parent.(node)
write_option leftmost_child.(node)
write_option rightmost_child.(node)
write_option previous.(node)
write_option next.(node)
in
match kind.(node) with
| L _ ->
Format.fprintf fmt "%sLeaf %d, parent %a, previous %a, next %a\n"
(indent i)
node
write_option parent.(node)
write_option previous.(node)
write_option next.(node)
| PNode ->
write_inner "P"
| QNode ->
write_inner "Q"
let write_tree fmt =
let rec go i node =
write_node i fmt node;
Option.iter (go (i+1)) leftmost_child.(node);
Option.iter (go i) next.(node)
in
go 0 !root
end
end
module type BLSig =
sig
type elt
val is_interval : elt list -> bool
val is_block : elt list -> bool
val insert : elt list -> bool
val get : unit -> elt PqTree.t
module Test : sig
val write_tree : Format.formatter -> unit
end
end
let get_bl_module (type e) (module T : S with type elt = e) =
let module BLAlgo = Make(T) in
BLAlgo.initialize ();
(module BLAlgo : BLSig with type elt = e)
type 'elt algorithms =
{ is_interval : 'elt list -> bool;
is_block : 'elt list -> bool;
insert : 'elt list -> bool;
get : unit -> 'elt PqTree.t
}
let get_algorithms (type elt) pqtree index =
let module R =
struct
type nonrec elt = elt
let pqtree = pqtree
let index = index
end
in
let (module BL : BLSig with type elt = elt) =
get_bl_module (module R : S with type elt = elt)
in
BL.({ is_interval; is_block; insert; get})