Commit 79ba7394 authored by charguer's avatar charguer

stack_temp

parent 9474d364
(*************************************************************************) (*************************************************************************)
(** Graph representation by adjacency lists *) (** Graph representation by adjacency lists *)
module Graph = struct module Graph = struct
type t = (int list) array type t = (int list) array
let nb_nodes (g:t) = let nb_nodes (g:t) =
Array.length g Array.length g
let iter_edges (f:int->unit) (g:t) (i:int) = let iter_edges (g:t) (i:int) (f:int->unit) =
List.iter (fun j -> f j) g.(i) List.iter (fun j -> f j) g.(i)
end end
...@@ -28,15 +23,61 @@ type color = White | Gray | Black ...@@ -28,15 +23,61 @@ type color = White | Gray | Black
let rec dfs_from g c i = let rec dfs_from g c i =
c.(i) <- Gray; c.(i) <- Gray;
Graph.iter_edges (fun j -> Graph.iter_edges g i (fun j ->
if c.(j) = White if c.(j) = White
then dfs_from g c j) g i; then dfs_from g c j);
c.(i) <- Black c.(i) <- Black
let dfs_main g rs = let dfs_main g rs =
let n = Graph.nb_nodes g in let n = Graph.nb_nodes g in
let c = Array.make n White in let c = Array.make n White in
List.iter (fun i -> List.iter (fun i ->
if c.(i) = White then if c.(i) = White then
dfs_from g c i) rs; dfs_from g c i) rs;
c c
(*************************************************************************)
(** Minimal stack structure *)
module Stack = struct
type 'a t = ('a list) ref
let create () : 'a t =
ref []
let is_empty (s : 'a t) =
!s = []
let pop (s : 'a t) =
match !s with
| [] -> assert false
| x::n -> s := n; x
let push (x : 'a) (s : 'a t) =
s := x::!s
end
(*************************************************************************)
(** DFS Algorithm, using two colors and a stack *)
let reachable_imperative g a b =
let n = Graph.nb_nodes g in
let c = Array.make n false in
let s = Stack.create() in
c.(a) <- true;
Stack.push a s;
while not (Stack.is_empty s) do
let i = Stack.pop s in
Graph.iter_edges g i (fun j ->
if not c.(j) then begin
c.(i) <- true;
Stack.push i s;
end);
done;
c.(b)
...@@ -333,7 +333,7 @@ Lemma iter_edges_spec : forall (I:set int->hprop) (G:graph) g f i, ...@@ -333,7 +333,7 @@ Lemma iter_edges_spec : forall (I:set int->hprop) (G:graph) g f i,
(forall L, (g ~> RGraph G) \c (I L)) -> (forall L, (g ~> RGraph G) \c (I L)) ->
(forall j E, j \notin E -> has_edge G i j -> (forall j E, j \notin E -> has_edge G i j ->
(app f [j] (I E) (# I (\{j} \u E)))) -> (app f [j] (I E) (# I (\{j} \u E)))) ->
app Graph_ml.iter_edges [f g i] app Graph_ml.iter_edges [g i f]
PRE (I \{}) PRE (I \{})
POST (# I (out_edges G i)). POST (# I (out_edges G i)).
Proof. Proof.
...@@ -630,28 +630,3 @@ Hint Extern 1 (RegisterSpec dfs_main) => Provide dfs_main_spec. ...@@ -630,28 +630,3 @@ Hint Extern 1 (RegisterSpec dfs_main) => Provide dfs_main_spec.
...@@ -11,7 +11,7 @@ Inv ...@@ -11,7 +11,7 @@ Inv
No black to white false No black to white false
(* 2 <-> grays C = \{} (* 2 <-> grays C = \{}
5 <-> i \in blacks C 5 <-> i \in blacks C
6 <-> j \notin white C <-> j \in (blacks C \u grays C) *) 6 <-> j \notin white C <-> j \in (blacks C \u grays C) *)
...@@ -34,8 +34,8 @@ Proof using. (* trivial *) ...@@ -34,8 +34,8 @@ Proof using. (* trivial *)
Qed. Qed.
*) *)
Lemma evolution_trans' : forall C2 X C1 C3, Lemma evolution_trans' : forall C2 X C1 C3,
evolution' X C1 C2 -> evolution' X C1 C2 ->
evolution C2 C3 -> evolution C2 C3 ->
evolution' X C1 C3. evolution' X C1 C3.
Proof using. (* trivial *) Proof using. (* trivial *)
...@@ -50,7 +50,7 @@ Lemma no_white_in_evolution' : forall C C' X E, ...@@ -50,7 +50,7 @@ Lemma no_white_in_evolution' : forall C C' X E,
evolution' X C C' -> evolution' X C C' ->
no_white_in E C'. no_white_in E C'.
Proof using. (* trivial *) Proof using. (* trivial *)
=>> N (H1&H2) i Hi. cases (C[i]) as Ci. =>> N (H1&H2) i Hi. cases (C[i]) as Ci.
{ false* N. } { false* N. }
{ forwards~ (H2a&_): H2 i. rewrite~ H2a. auto_false. } { forwards~ (H2a&_): H2 i. rewrite~ H2a. auto_false. }
rewrite~ H1. auto_false. rewrite~ H1. auto_false.
...@@ -75,7 +75,7 @@ Lemma reachables_monotone : forall G E1 E2 F1 F2, ...@@ -75,7 +75,7 @@ Lemma reachables_monotone : forall G E1 E2 F1 F2,
Proof using. Proof using.
introv R HE HF. rewrite incl_in_eq in HE,HF. skip. introv R HE HF. rewrite incl_in_eq in HE,HF. skip.
Qed. Qed.
Lemma reachables_trans : forall G E1 E2 E3, Lemma reachables_trans : forall G E1 E2 E3,
reachables G E1 E2 -> reachables G E1 E2 ->
reachables G E2 E3 -> reachables G E2 E3 ->
...@@ -96,13 +96,13 @@ Definition grays C := ...@@ -96,13 +96,13 @@ Definition grays C :=
Lemma iter_nodes_spec : forall (I:set int->hprop) (G:graph) g f, Lemma iter_nodes_spec : forall (I:set int->hprop) (G:graph) g f,
(forall i N, i \in nodes G -> i \notin N -> (forall i N, i \in nodes G -> i \notin N ->
(app f [i] (I N) (# I (\{i}\u N)))) -> (app f [i] (I N) (# I (\{i}\u N)))) ->
app iter_nodes [f g] app iter_nodes [f g]
PRE (g ~> GraphAdj G \* I \{}) PRE (g ~> GraphAdj G \* I \{})
POST (# g ~> GraphAdj G \* I (nodes G)). POST (# g ~> GraphAdj G \* I (nodes G)).
Proof. Proof.
(* -- TODO -- *) (* -- TODO -- *)
Admitted. Admitted.
Hint Extern 1 (RegisterSpec iter_nodes) => Provide iter_nodes_spec. Hint Extern 1 (RegisterSpec iter_nodes) => Provide iter_nodes_spec.
...@@ -130,9 +130,9 @@ let dfs_main g r = ...@@ -130,9 +130,9 @@ let dfs_main g r =
module GraphAdj = struct module GraphAdj = struct
type 'a t = ((int*'a) list) array type 'a t = ((int*'a) list) array
let nb_nodes (g:'a t) = let nb_nodes (g:'a t) =
Array.length g Array.length g
let iter_edges_of (g:'a t) (i:int) (f:int->'a->unit) = let iter_edges_of (g:'a t) (i:int) (f:int->'a->unit) =
...@@ -171,9 +171,9 @@ end ...@@ -171,9 +171,9 @@ end
module GraphMat = struct module GraphMat = struct
type 'a t = ('a array) array type 'a t = ('a array) array
let nb_nodes (g:'a t) = let nb_nodes (g:'a t) =
Array.length g Array.length g
let get_edge (g:'a t) i j = let get_edge (g:'a t) i j =
...@@ -201,8 +201,8 @@ let reachable_recursive g a b = ...@@ -201,8 +201,8 @@ let reachable_recursive g a b =
let c = Array.make n White in let c = Array.make n White in
let rec visit i = let rec visit i =
c.(i) <- Gray; c.(i) <- Gray;
GraphAdj.iter_edges_target_of g i (fun j -> GraphAdj.iter_edges_target_of g i (fun j ->
if c.(j) = White if c.(j) = White
then visit j); then visit j);
c.(i) <- Black; c.(i) <- Black;
in in
...@@ -213,17 +213,17 @@ let reachable_recursive g a b = ...@@ -213,17 +213,17 @@ let reachable_recursive g a b =
(*************************************************************************) (*************************************************************************)
(** Reachability by imperative DFS, two-colored *) (** Reachability by imperative DFS, two-colored *)
let reachable_imperative g a b = let reachable_imperative g a b =
let n = GraphAdj.nb_nodes g in let n = GraphAdj.nb_nodes g in
let c = Array.make n false in let c = Array.make n false in
let s = Stack.create() in let s = Stack.create() in
c.(a) <- true; c.(a) <- true;
Stack.push a s; Stack.push a s;
while not (Stack.is_empty s) do while not (Stack.is_empty s) do
let i = Stack.pop s in let i = Stack.pop s in
GraphAdj.iter_edges_target_of g i (fun j -> GraphAdj.iter_edges_target_of g i (fun j ->
if not c.(j) then begin if not c.(j) then begin
c.(i) <- true; c.(i) <- true;
Stack.push i s; Stack.push i s;
end); end);
done; done;
...@@ -233,7 +233,7 @@ let reachable_imperative g a b = ...@@ -233,7 +233,7 @@ let reachable_imperative g a b =
(*************************************************************************) (*************************************************************************)
(** Cycle detection by recursive DFS, three-colored *) (** Cycle detection by recursive DFS, three-colored *)
(** Note: for simlicity, the current implementation does not exit (** Note: for simlicity, the current implementation does not exit
abruptly when detecting a cycle. *) abruptly when detecting a cycle. *)
let cycle_detection g s e = let cycle_detection g s e =
...@@ -242,8 +242,8 @@ let cycle_detection g s e = ...@@ -242,8 +242,8 @@ let cycle_detection g s e =
let r = ref false in let r = ref false in
let rec visit i = let rec visit i =
c.(i) <- Gray; c.(i) <- Gray;
GraphAdj.iter_edges_target_of g i (fun j -> GraphAdj.iter_edges_target_of g i (fun j ->
if c.(j) = White if c.(j) = White
then visit j then visit j
else if c.(j) = Gray else if c.(j) = Gray
then r := true); then r := true);
...@@ -267,8 +267,8 @@ let topological_sort g s e = ...@@ -267,8 +267,8 @@ let topological_sort g s e =
let k = ref (n-1) in let k = ref (n-1) in
let rec visit i = let rec visit i =
c.(i) <- processed; c.(i) <- processed;
GraphAdj.iter_edges_target_of g i (fun j -> GraphAdj.iter_edges_target_of g i (fun j ->
if c.(j) = neverseen if c.(j) = neverseen
then visit j); then visit j);
c.(i) <- !k; c.(i) <- !k;
decr k; decr k;
...@@ -281,18 +281,18 @@ let topological_sort g s e = ...@@ -281,18 +281,18 @@ let topological_sort g s e =
(*************************************************************************) (*************************************************************************)
(** Connected components by recursive DFS, two-colored *) (** Connected components by recursive DFS, two-colored *)
let connected_recursive g = let connected_recursive g =
let n = GraphAdj.nb_nodes g in let n = GraphAdj.nb_nodes g in
let neverseen = -1 in let neverseen = -1 in
let c = Array.make n neverseen in let c = Array.make n neverseen in
let k = ref 0 in let k = ref 0 in
let rec visit i = let rec visit i =
c.(i) <- !k; c.(i) <- !k;
GraphAdj.iter_edges_target_of g i (fun j -> GraphAdj.iter_edges_target_of g i (fun j ->
if c.(j) = neverseen if c.(j) = neverseen
then visit j) then visit j)
in in
GraphAdj.iter_nodes g (fun i -> GraphAdj.iter_nodes g (fun i ->
if c.(i) = neverseen then begin if c.(i) = neverseen then begin
visit i; visit i;
incr k incr k
...@@ -307,15 +307,15 @@ let connected_recursive g = ...@@ -307,15 +307,15 @@ let connected_recursive g =
type tree = Tree of int * tree list type tree = Tree of int * tree list
type forest = tree list type forest = tree list
let spanning_forest g = let spanning_forest g =
let n = GraphAdj.nb_nodes g in let n = GraphAdj.nb_nodes g in
let c = Array.make n false in let c = Array.make n false in
let rec build_tree i = let rec build_tree i =
c.(i) <- true; c.(i) <- true;
let ts = GraphAdj.fold_edges_target_of g i [] harvest in let ts = GraphAdj.fold_edges_target_of g i [] harvest in
Tree (i,ts) Tree (i,ts)
and harvest acc i = and harvest acc i =
if c.(i) then acc else (build_tree i)::acc if c.(i) then acc else (build_tree i)::acc
in in
GraphAdj.fold_nodes g [] harvest GraphAdj.fold_nodes g [] harvest
...@@ -330,7 +330,7 @@ let connected_imperative g = ...@@ -330,7 +330,7 @@ let connected_imperative g =
let k = ref 0 in let k = ref 0 in
let s = Stack.create() in let s = Stack.create() in
let find i = let find i =
c.(i) <- !k; c.(i) <- !k;
Stack.push i s Stack.push i s
in in
GraphAdj.iter_nodes g (fun i -> GraphAdj.iter_nodes g (fun i ->
...@@ -338,8 +338,8 @@ let connected_imperative g = ...@@ -338,8 +338,8 @@ let connected_imperative g =
find i; find i;
while not (Stack.is_empty s) do while not (Stack.is_empty s) do
let i = Stack.pop s in let i = Stack.pop s in
GraphAdj.iter_edges_target_of g i (fun j -> GraphAdj.iter_edges_target_of g i (fun j ->
if c.(j) = neverseen if c.(j) = neverseen
then find j) then find j)
done; done;
incr k; incr k;
...@@ -350,7 +350,7 @@ let connected_imperative g = ...@@ -350,7 +350,7 @@ let connected_imperative g =
(*************************************************************************) (*************************************************************************)
(** Connected components by warshall-floyd *) (** Connected components by warshall-floyd *)
(** Note: implemented by side-effects on the adjacency matrix *) (** Note: implemented by side-effects on the adjacency matrix *)
let connected_warshall_floyd g = let connected_warshall_floyd g =
let n = GraphMat.nb_nodes g in let n = GraphMat.nb_nodes g in
...@@ -370,7 +370,7 @@ let connected_warshall_floyd g = ...@@ -370,7 +370,7 @@ let connected_warshall_floyd g =
nbcompo++ nbcompo++
foreach neighbor foreach neighbor
mark it mark it
*) *)
...@@ -457,7 +457,7 @@ Parameter array_to_map : forall A, array A -> map int A. ...@@ -457,7 +457,7 @@ Parameter array_to_map : forall A, array A -> map int A.
(* ** TLC Graph *) (* ** TLC Graph *)
Inductive is_path A (g:graph A) : int -> int -> path A -> Prop := Inductive is_path A (g:graph A) : int -> int -> path A -> Prop :=
| is_path_nil : forall x, | is_path_nil : forall x,
x \in nodes g -> x \in nodes g ->
is_path g x x nil is_path g x x nil
| is_path_cons : forall x y z w p, | is_path_cons : forall x y z w p,
...@@ -469,32 +469,32 @@ Inductive is_path A (g:graph A) : int -> int -> path A -> Prop := ...@@ -469,32 +469,32 @@ Inductive is_path A (g:graph A) : int -> int -> path A -> Prop :=
(********************************************************************) (********************************************************************)
(* ** Stdlib Stack *) (* ** Stdlib Stack *)
Parameter StackOf : forall a A (T:htype A a) (L:list A) (l:loc), hprop. Parameter StackOf : forall a A (T:htype A a) (L:list A) (l:loc), hprop.
Notation "'Stack'" := (StackOf Id). Notation "'Stack'" := (StackOf Id).
Parameter ml_stack_create_spec : forall a, Parameter ml_stack_create_spec : forall a,
Spec ml_stack_create (i:unit) |R>> Spec ml_stack_create (i:unit) |R>>
R \[] (~> Stack (@nil a)). R \[] (~> Stack (@nil a)).
Hint Extern 1 (RegisterSpec ml_stack_create) => Provide ml_stack_create_spec. Hint Extern 1 (RegisterSpec ml_stack_create) => Provide ml_stack_create_spec.
Parameter ml_stack_is_empty_spec : forall a, Parameter ml_stack_is_empty_spec : forall a,
Spec ml_stack_is_empty (l:loc) |R>> Spec ml_stack_is_empty (l:loc) |R>>
forall (L:list a), forall (L:list a),
keep R (l ~> Stack L) (fun b => \[b = bool_of (L = nil)]). keep R (l ~> Stack L) (fun b => \[b = bool_of (L = nil)]).
Hint Extern 1 (RegisterSpec ml_stack_is_empty) => Provide ml_stack_is_empty_spec. Hint Extern 1 (RegisterSpec ml_stack_is_empty) => Provide ml_stack_is_empty_spec.
Parameter ml_stack_push_spec : forall a, Parameter ml_stack_push_spec : forall a,
Spec ml_stack_push (X:a) (l:loc) |R>> Spec ml_stack_push (X:a) (l:loc) |R>>
forall (L:list a), forall (L:list a),
R (l ~> Stack L) (# l ~> Stack (X::L)). R (l ~> Stack L) (# l ~> Stack (X::L)).
Hint Extern 1 (RegisterSpec ml_stack_push_spec) => Provide ml_stack_push_spec. Hint Extern 1 (RegisterSpec ml_stack_push_spec) => Provide ml_stack_push_spec.
Parameter ml_stack_pop_spec : forall a, Parameter ml_stack_pop_spec : forall a,
Spec ml_stack_pop (l:loc) |R>> Spec ml_stack_pop (l:loc) |R>>
forall (L:list a), L <> nil -> forall (L:list a), L <> nil ->
R (l ~> Stack L) (fun X => Hexists L', \[L = X::L'] \* l ~> Stack L'). R (l ~> Stack L) (fun X => Hexists L', \[L = X::L'] \* l ~> Stack L').
...@@ -503,7 +503,7 @@ Hint Extern 1 (RegisterSpec ml_stack_pop) => Provide ml_stack_pop_spec. ...@@ -503,7 +503,7 @@ Hint Extern 1 (RegisterSpec ml_stack_pop) => Provide ml_stack_pop_spec.
(********************************************************************) (********************************************************************)
(********************************************************************) (********************************************************************)
(********************************************************************) (********************************************************************)
(* ** Representation predicate for unweighted graphs (* ** Representation predicate for unweighted graphs
by adjacency lists *) by adjacency lists *)
(** [nodes_index G n] holds if the nodes in [G] are indexed from (** [nodes_index G n] holds if the nodes in [G] are indexed from
...@@ -517,8 +517,8 @@ Definition nodes_index A (G:graph A) (n:int) := ...@@ -517,8 +517,8 @@ Definition nodes_index A (G:graph A) (n:int) :=
Definition GraphAdjList A (G:graph A) (g:loc) := Definition GraphAdjList A (G:graph A) (g:loc) :=
Hexists N, g ~> Array N Hexists N, g ~> Array N
\* \[nodes_index G (LibArray.length N) \* \[nodes_index G (LibArray.length N)
/\ forall i j w, i \in nodes G -> /\ forall i j w, i \in nodes G ->
Mem (j,w) (N[i]) = has_edge G i j w]. Mem (j,w) (N[i]) = has_edge G i j w].
...@@ -541,8 +541,8 @@ Hint Resolve @index_array_length_eq @index_make @index_update. ...@@ -541,8 +541,8 @@ Hint Resolve @index_array_length_eq @index_make @index_update.
Hint Immediate has_edge_in_nodes_l has_edge_in_nodes_r. Hint Immediate has_edge_in_nodes_l has_edge_in_nodes_r.
Hint Extern 1 (nodes_index _ _) => congruence. Hint Extern 1 (nodes_index _ _) => congruence.
Hint Extern 1 (index ?n ?x) => Hint Extern 1 (index ?n ?x) =>
eapply graph_adj_index; eapply graph_adj_index;
[ try eassumption [ try eassumption
| instantiate; try eassumption | instantiate; try eassumption
| instantiate; try congruence ]. | instantiate; try congruence ].
...@@ -554,22 +554,22 @@ Hint Extern 1 (index ?n ?x) => ...@@ -554,22 +554,22 @@ Hint Extern 1 (index ?n ?x) =>
Import MLGraphAdj. Import MLGraphAdj.
Ltac hdata_simpl_step ::= Ltac hdata_simpl_step ::=
match goal with |- context C [ ?l ~> ?S ] => match goal with |- context C [ ?l ~> ?S ] =>
match S with (fun _ => _) => match S with (fun _ => _) =>
rewrite (hdata_fun' l) rewrite (hdata_fun' l)
end end
end. end.
Lemma nb_nodes_spec : forall A, Lemma nb_nodes_spec : forall A,
Spec nb_nodes g |R>> Spec nb_nodes g |R>>
forall (G:graph A), forall (G:graph A),
keep R (g ~> GraphAdjList G) (fun n => \[nodes_index G n]). keep R (g ~> GraphAdjList G) (fun n => \[nodes_index G n]).
Proof. Proof.
xcf. instantiate (1:=A). (* todo: fix instantiation *) xcf. instantiate (1:=A). (* todo: fix instantiation *)
intros. unfold GraphAdjList. hdata_simpl. intros. unfold GraphAdjList. hdata_simpl.
xextract as N [GI GN]. xapp. hsimpl~. xextract as N [GI GN]. xapp. hsimpl~.
Admitted. (*faster*) Admitted. (*faster*)
Hint Extern 1 (RegisterSpec nb_nodes) => Provide nb_nodes_spec. Hint Extern 1 (RegisterSpec nb_nodes) => Provide nb_nodes_spec.
...@@ -587,38 +587,38 @@ Parameter out_edges_target_has_edge : forall (G:graph unit) i j, ...@@ -587,38 +587,38 @@ Parameter out_edges_target_has_edge : forall (G:graph unit) i j,
Parameter ml_list_iter_spec' : forall a, Parameter ml_list_iter_spec' : forall a,
Spec ml_list_iter f l |R>> forall (I:list a->hprop), Spec ml_list_iter f l |R>> forall (I:list a->hprop),
(forall x t, (App f x;) (I t) (# I (t&x))) -> (forall x t, (App f x;) (I t) (# I (t&x))) ->
R (I nil) (# I l). R (I nil) (# I l).
Lemma iter_edges_target_of_spec : Lemma iter_edges_target_of_spec :
Spec iter_edges_target_of g i f |R>> Spec iter_edges_target_of g i f |R>>
forall (G:graph unit) (I:set int->hprop), i \in nodes G -> forall (G:graph unit) (I:set int->hprop), i \in nodes G ->
(forall j js, has_edge G i j tt -> j \notin js -> (forall j js, has_edge G i j tt -> j \notin js ->
(App f j;) (I js) (# I (\{j} \u js))) -> (App f j;) (I js) (# I (\{j} \u js))) ->
R (g ~> GraphAdjList G \* I \{}) R (g ~> GraphAdjList G \* I \{})