(* $Id: fl_topo.ml 49 2003-12-30 09:48:02Z gerd $
* ----------------------------------------------------------------------
*
*)
(* TODO:
* - Use a hashtable in 'find'
* - implement le_than with an 'iter' like method
*)
(**********************************************************************)
module type IdentifiedType =
sig
type t
type id_t
val id : t -> id_t
end
exception Inconsistent_ordering
module type S =
sig
type key
type el_t
type t
val create : unit -> t
val add : t -> el_t -> unit
val let_le : t -> key -> key -> unit
val find : t -> key -> el_t
val le_than : t -> key -> key -> bool
val key : el_t -> key
val iter_up : (el_t -> unit) -> t -> unit
val iter_down : (el_t -> unit) -> t -> unit
val iter_up_at : (el_t -> unit) -> t -> key list -> unit
val iter_down_at : (el_t -> unit) -> t -> key list -> unit
val clear : t -> unit
val replace : t -> key -> el_t -> unit
val delete : t -> key -> unit
val copy : t -> t
end
(**********************************************************************)
module Make(H: IdentifiedType) =
struct
type key = H.id_t
type el_t = H.t
type 'a node =
{ mutable content : 'a;
mutable smaller : 'a node list;
mutable bigger : 'a node list;
mutable mark : bool; (* used in 'iter' *)
(* mutable ppmark : bool *) (* used in 'private_property' *)
}
type t =
{ mutable cnt : el_t node list;
mutable lock : bool
}
let copy ord =
(* This operation is quite expensive when the graph has already
* relations. In findlib, this case is avoided, and is here only
* implemented for completeness.
*)
let ord' =
{ cnt = List.map (fun n -> { n with
smaller = [];
bigger = [];
mark = false }) ord.cnt;
lock = false
} in
let combined_list = List.combine ord.cnt ord'.cnt in
let lookup_node n =
(* Find the new node corresponding to old node n *)
try List.assq n combined_list
with Not_found -> assert false
in
List.iter2
(fun n n' ->
(* n: old node, n': new node *)
let smaller = List.map lookup_node n.smaller in
let bigger = List.map lookup_node n.bigger in
n'.smaller <- smaller;
n'.bigger <- bigger;
)
ord.cnt
ord'.cnt;
ord'
let rec delete_all p l =
match l with
x::l' ->
if p x then delete_all p l' else x :: delete_all p l'
| [] -> []
(******************************************************************)
let create () = { cnt = []; lock = false }
let clear ordering =
ordering.cnt <- [];
ordering.lock <- false
(******************************************************************)
let add ordering x =
(* Is there already a node with the same key? *)
let k = H.id x in
if List.exists (fun y -> H.id y.content = k) ordering.cnt then
raise Inconsistent_ordering;
(* Ok, add the node to the list *)
let nx = { content = x;
smaller = [];
bigger = [];
mark = false
} in
ordering.cnt <- nx :: ordering.cnt
(******************************************************************)
let find_node ordering kx =
let rec search l =
match l with
[] -> raise Not_found
| y :: l' -> if H.id y.content = kx then y else search l'
in
search ordering.cnt
let find ordering kx = (find_node ordering kx).content
(******************************************************************)
let replace ordering kx x' =
let x = find_node ordering kx in
x.content <- x'
(******************************************************************)
let delete ordering kx =
let x = find_node ordering kx in
ordering.cnt <- delete_all (fun a -> a == x) ordering.cnt;
List.iter
(fun x ->
x.smaller <- delete_all (fun a -> a == x) x.smaller;
x.bigger <- delete_all (fun a -> a == x) x.bigger)
ordering.cnt
(******************************************************************)
let le_than ordering kx ky =
(* Find x, y: *)
let x = find_node ordering kx in
let y = find_node ordering ky in
let rec search x1 =
if x1 == y then
true
else
List.exists search x1.bigger
in
search x
(******************************************************************)
let let_le ordering kx ky =
(* Find x, y: *)
let x = find_node ordering kx in
let y = find_node ordering ky in
(* If already done just return (this is an idempotent function) *)
if not (List.memq x y.smaller) then begin
(* let x <= y. This is only allowed if not (y <= x) *)
if le_than ordering ky kx then
raise Inconsistent_ordering;
(* Ok, add the relation *)
x.bigger <- y :: x.bigger;
y.smaller <- x :: y.smaller
end
(******************************************************************)
let key x = H.id x
(******************************************************************)
let iter upwards f ordering =
let in_direction n =
if upwards then n.bigger else n.smaller in
let against_direction n =
if upwards then n.smaller else n.bigger in
(* the following is written as if for iter_up. *)
let rec find_biggest ordlist =
(* find biggest, non-marked node *)
match ordlist with
[] -> raise Not_found
| nx :: ordlist' -> if not nx.mark & in_direction nx = []
then nx
else find_biggest ordlist'
in
let rec run_up n =
(* iterate over all nodes <= x and return their number *)
let rec run_up_list l =
match l with
[] -> 0
| x :: l' -> run_up x + run_up_list l'
in
if n.mark then
(* have already visited this node *)
0
else
let u = run_up_list (against_direction n) in
n.mark <- true;
f n.content;
u + 1
in
(* Lock *)
if ordering.lock then
failwith "iter_up: recursive application not allowed";
ordering.lock <- true;
(* clear all marks *)
List.iter (fun nx -> nx.mark <- false) ordering.cnt;
(* Catch exceptions *)
try
(* while there is a biggest node... *)
let c = ref 0 in (* counter *)
while !c < List.length ordering.cnt do
(* Find a biggest node *)
let n_biggest = find_biggest ordering.cnt in
(* run through the graph *)
c := !c + run_up n_biggest
done;
(* unlock *)
ordering.lock <- false
with
any -> (* unlock, too *)
ordering.lock <- false;
raise any
let iter_up = iter true
let iter_down = iter false
(******************************************************************)
let iter_at upwards f ordering startpoints =
let in_direction n =
if upwards then n.bigger else n.smaller in
let against_direction n =
if upwards then n.smaller else n.bigger in
(* the following is written as if for iter_up. *)
let rec run_up n =
(* iterate over all nodes <= x and return their number *)
let rec run_up_list l =
match l with
[] -> 0
| x :: l' -> run_up x + run_up_list l'
in
if n.mark then
(* have already visited this node *)
0
else
let u = run_up_list (against_direction n) in
n.mark <- true;
f n.content;
u + 1
in
(* Lock *)
if ordering.lock then
failwith "iter_up: recursive application not allowed";
ordering.lock <- true;
(* clear all marks *)
List.iter (fun nx -> nx.mark <- false) ordering.cnt;
(* Catch exceptions *)
try
List.iter
(fun start ->
let _ = run_up (find_node ordering start) in ())
startpoints;
(* unlock *)
ordering.lock <- false
with
any -> (* unlock, too *)
ordering.lock <- false;
raise any
let iter_up_at = iter_at true
let iter_down_at = iter_at false
(******************************************************************)
end
