stack_temp

examples/DFS/DFS.ml

 
 
-
-
-
-
-
 (*************************************************************************)
 (** Graph representation by adjacency lists *)
 
 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
 
-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)
 
 end
@@ -28,15 +23,61 @@ type color = White | Gray | Black
 
  let rec dfs_from g c i =
     c.(i) <- Gray;
-    Graph.iter_edges (fun j -> 
-       if c.(j) = White 
-          then dfs_from g c j) g i;
+    Graph.iter_edges g i (fun j ->
+       if c.(j) = White
+          then dfs_from g c j);
     c.(i) <- Black
 
 let dfs_main g rs =
    let n = Graph.nb_nodes g in
    let c = Array.make n White in
-   List.iter (fun i -> 
+   List.iter (fun i ->
      if c.(i) = White then
        dfs_from g c i) rs;
    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)
+

examples/DFS/DFS_proof.v

@@ -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 j E, j \notin E -> has_edge G i j ->
      (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 \{})
     POST (# I (out_edges G i)).
 Proof.
@@ -630,28 +630,3 @@ Hint Extern 1 (RegisterSpec dfs_main) => Provide dfs_main_spec.
 
 
 
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-

examples/DFS/OtherAlgo.ml

@@ -11,7 +11,7 @@ Inv
 
 
 No black to white false
-(* 2 <-> grays C = \{} 
+(* 2 <-> grays C = \{}
    5 <-> i \in blacks C
    6 <-> j \notin white C <-> j \in (blacks C \u grays C) *)
 
@@ -34,8 +34,8 @@ Proof using. (* trivial *)
 Qed.
 *)
 
-Lemma evolution_trans' : forall C2 X C1 C3, 
-  evolution' X C1 C2 -> 
+Lemma evolution_trans' : forall C2 X C1 C3,
+  evolution' X C1 C2 ->
   evolution C2 C3 ->
   evolution' X C1 C3.
 Proof using. (* trivial *)
@@ -50,7 +50,7 @@ Lemma no_white_in_evolution' : forall C C' X E,
   evolution' X C C' ->
   no_white_in E C'.
 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. }
   { forwards~ (H2a&_): H2 i. rewrite~ H2a. auto_false. }
   rewrite~ H1. auto_false.
@@ -75,7 +75,7 @@ Lemma reachables_monotone : forall G E1 E2 F1 F2,
 Proof using.
   introv R HE HF. rewrite incl_in_eq in HE,HF. skip.
 Qed.
- 
+
 Lemma reachables_trans : forall G E1 E2 E3,
   reachables G E1 E2 ->
   reachables G E2 E3 ->
@@ -96,13 +96,13 @@ Definition grays C :=
 
 Lemma iter_nodes_spec : forall (I:set int->hprop) (G:graph) g f,
   (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]
-    PRE (g ~> GraphAdj G \* I \{}) 
+    PRE (g ~> GraphAdj G \* I \{})
     POST (# g ~> GraphAdj G \* I (nodes G)).
 Proof.
   (* -- TODO -- *)
-Admitted. 
+Admitted.
 
 Hint Extern 1 (RegisterSpec iter_nodes) => Provide iter_nodes_spec.
 
@@ -130,9 +130,9 @@ let dfs_main g r =
 
 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
 
 let iter_edges_of (g:'a t) (i:int) (f:int->'a->unit) =
@@ -171,9 +171,9 @@ end
 
 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
 
 let get_edge (g:'a t) i j =
@@ -201,8 +201,8 @@ let reachable_recursive g a b =
    let c = Array.make n White in
    let rec visit i =
       c.(i) <- Gray;
-      GraphAdj.iter_edges_target_of g i (fun j -> 
-         if c.(j) = White 
+      GraphAdj.iter_edges_target_of g i (fun j ->
+         if c.(j) = White
             then visit j);
       c.(i) <- Black;
       in
@@ -213,17 +213,17 @@ let reachable_recursive g a b =
 (*************************************************************************)
 (** 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 c = Array.make n false in
    let s = Stack.create() in
-   c.(a) <- true; 
+   c.(a) <- true;
    Stack.push a s;
    while not (Stack.is_empty s) do
       let i = Stack.pop s in
-      GraphAdj.iter_edges_target_of g i (fun j -> 
-         if not c.(j) then begin 
-           c.(i) <- true; 
+      GraphAdj.iter_edges_target_of g i (fun j ->
+         if not c.(j) then begin
+           c.(i) <- true;
            Stack.push i s;
          end);
    done;
@@ -233,7 +233,7 @@ let reachable_imperative g a b =
 (*************************************************************************)
 (** 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. *)
 
 let cycle_detection g s e =
@@ -242,8 +242,8 @@ let cycle_detection g s e =
    let r = ref false in
    let rec visit i =
       c.(i) <- Gray;
-      GraphAdj.iter_edges_target_of g i (fun j -> 
-         if c.(j) = White 
+      GraphAdj.iter_edges_target_of g i (fun j ->
+         if c.(j) = White
             then visit j
          else if c.(j) = Gray
             then r := true);
@@ -267,8 +267,8 @@ let topological_sort g s e =
    let k = ref (n-1) in
    let rec visit i =
       c.(i) <- processed;
-      GraphAdj.iter_edges_target_of g i (fun j -> 
-         if c.(j) = neverseen 
+      GraphAdj.iter_edges_target_of g i (fun j ->
+         if c.(j) = neverseen
             then visit j);
       c.(i) <- !k;
       decr k;
@@ -281,18 +281,18 @@ let topological_sort g s e =
 (*************************************************************************)
 (** Connected components by recursive DFS, two-colored *)
 
-let connected_recursive g = 
+let connected_recursive g =
    let n = GraphAdj.nb_nodes g in
    let neverseen = -1 in
    let c = Array.make n neverseen in
    let k = ref 0 in
    let rec visit i =
       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
             then visit j)
       in
-   GraphAdj.iter_nodes g (fun i ->      
+   GraphAdj.iter_nodes g (fun i ->
       if c.(i) = neverseen then begin
          visit i;
          incr k
@@ -307,15 +307,15 @@ let connected_recursive g =
 type tree = Tree of int * tree list
 type forest = tree list
 
-let spanning_forest g = 
+let spanning_forest g =
    let n = GraphAdj.nb_nodes g in
    let c = Array.make n false in
    let rec build_tree i =
       c.(i) <- true;
       let ts = GraphAdj.fold_edges_target_of g i [] harvest in
-      Tree (i,ts) 
-   and harvest acc i = 
-      if c.(i) then acc else (build_tree i)::acc 
+      Tree (i,ts)
+   and harvest acc i =
+      if c.(i) then acc else (build_tree i)::acc
    in
    GraphAdj.fold_nodes g [] harvest
 
@@ -330,7 +330,7 @@ let connected_imperative g =
    let k = ref 0 in
    let s = Stack.create() in
    let find i =
-      c.(i) <- !k; 
+      c.(i) <- !k;
       Stack.push i s
       in
    GraphAdj.iter_nodes g (fun i ->
@@ -338,8 +338,8 @@ let connected_imperative g =
          find i;
          while not (Stack.is_empty s) do
             let i = Stack.pop s in
-            GraphAdj.iter_edges_target_of g i (fun j -> 
-               if c.(j) = neverseen 
+            GraphAdj.iter_edges_target_of g i (fun j ->
+               if c.(j) = neverseen
                   then find j)
          done;
          incr k;
@@ -350,7 +350,7 @@ let connected_imperative g =
 (*************************************************************************)
 (** 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 n = GraphMat.nb_nodes g in
@@ -370,7 +370,7 @@ let connected_warshall_floyd g =
          nbcompo++
          foreach neighbor
             mark it
-         
+
 *)
 
 
@@ -457,7 +457,7 @@ Parameter array_to_map : forall A, array A -> map int A.
 (* ** TLC Graph *)
 
 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 ->
       is_path g x x nil
   | 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 :=
 (********************************************************************)
 (* ** 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).
 
 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)).
 
 Hint Extern 1 (RegisterSpec ml_stack_create) => Provide ml_stack_create_spec.
 
 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),
      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.
 
 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),
      R (l ~> Stack L) (# l ~> Stack (X::L)).
 
 Hint Extern 1 (RegisterSpec ml_stack_push_spec) => Provide ml_stack_push_spec.
 
 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 ->
      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.
 (********************************************************************)
 (********************************************************************)
 (********************************************************************)
-(* ** Representation predicate for unweighted graphs 
+(* ** Representation predicate for unweighted graphs
       by adjacency lists *)
 
 (** [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) :=
 
 Definition GraphAdjList A (G:graph A) (g:loc) :=
   Hexists N, g ~> Array N
-   \* \[nodes_index G (LibArray.length N) 
-   /\ forall i j w, i \in nodes G -> 
+   \* \[nodes_index G (LibArray.length N)
+   /\ forall i j w, i \in nodes G ->
         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.
 Hint Immediate has_edge_in_nodes_l has_edge_in_nodes_r.
 Hint Extern 1 (nodes_index _ _) => congruence.
 Hint Extern 1 (index ?n ?x) =>
-  eapply graph_adj_index; 
-  [ try eassumption 
+  eapply graph_adj_index;
+  [ try eassumption
   | instantiate; try eassumption
   | instantiate; try congruence ].
 
@@ -554,22 +554,22 @@ Hint Extern 1 (index ?n ?x) =>
 Import MLGraphAdj.
 
 Ltac hdata_simpl_step ::=
-  match goal with |- context C [ ?l ~> ?S ] => 
+  match goal with |- context C [ ?l ~> ?S ] =>
     match S with (fun _ => _) =>
       rewrite (hdata_fun' l)
     end
   end.
-    
+
 
 Lemma nb_nodes_spec : forall A,
-  Spec nb_nodes g |R>> 
+  Spec nb_nodes g |R>>
     forall (G:graph A),
     keep R (g ~> GraphAdjList G) (fun n => \[nodes_index G n]).
 
 Proof.
   xcf. instantiate (1:=A). (* todo: fix instantiation *)
   intros. unfold GraphAdjList. hdata_simpl.
-  xextract as N [GI GN]. xapp. hsimpl~. 
+  xextract as N [GI GN]. xapp. hsimpl~.
 Admitted. (*faster*)
 
 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,
 
 Parameter ml_list_iter_spec' : forall a,
   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).
 
-Lemma iter_edges_target_of_spec : 
-  Spec iter_edges_target_of g i f |R>> 
+Lemma iter_edges_target_of_spec :
+  Spec iter_edges_target_of g i f |R>>
     forall (G:graph unit) (I:set int->hprop), i \in nodes G ->
     (forall j js, has_edge G i j tt -> j \notin js ->
-      (App f j;) (I js) (# I (\{j} \u js))) -> 
-    R (g ~> GraphAdjList G \* I \{}) 
+      (App f j;) (I js) (# I (\{j} \u js))) ->
+    R (g ~> GraphAdjList G \* I \{})