From fd45f9d71a39f9d16c56ffcdbc51fd38e534f4ec Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sun, 21 Feb 2016 12:16:31 -0500
Subject: [PATCH] Add ModelCheck

---
 Frap.v          | 41 ++++++++++++++++++++-
 ModelCheck.v    | 97 +++++++++++++++++++++++++++++++++++++++++++++++++
 ModelChecking.v |  2 +-
 README.md       |  1 +
 _CoqProject     |  1 +
 5 files changed, 139 insertions(+), 3 deletions(-)
 create mode 100644 ModelCheck.v

diff --git a/Frap.v b/Frap.v
index b95b0d6..f54b292 100644
--- a/Frap.v
+++ b/Frap.v
@@ -1,5 +1,5 @@
-Require Import String Arith Omega Program Sets Relations Map Var Invariant Bool.
-Export String Arith Sets Relations Map Var Invariant Bool.
+Require Import String Arith Omega Program Sets Relations Map Var Invariant Bool ModelCheck.
+Export String Arith Sets Relations Map Var Invariant Bool ModelCheck.
 Require Import List.
 Export List ListNotations.
 Open Scope string_scope.
@@ -89,3 +89,40 @@ Export Frap.Map.
 Ltac maps_equal := Frap.Map.M.maps_equal; simplify.
 
 Ltac first_order := firstorder idtac.
+
+
+(** * Model checking *)
+
+Ltac model_check_done :=
+  apply MscDone; apply prove_oneStepClosure; simplify; propositional; subst;
+  repeat match goal with
+         | [ H : _ |- _ ] => invert H
+         end; simplify; equality.
+
+Ltac singletoner :=
+  repeat match goal with
+         | _ => apply singleton_in
+         | [ |- (_ \cup _) _ ] => apply singleton_in_other
+         end.
+
+Ltac model_check_step :=
+  eapply MscStep; [
+    repeat ((apply oneStepClosure_empty; simplify)
+            || (apply oneStepClosure_split; [ simplify;
+                                              repeat match goal with
+                                                     | [ H : _ |- _ ] => invert H; try congruence
+                                                     end; solve [ singletoner ] | ]))
+  | simplify ].
+
+Ltac model_check_steps1 := model_check_done || model_check_step.
+Ltac model_check_steps := repeat model_check_steps1.
+
+Ltac model_check_finish := simplify; propositional; subst; simplify; equality.
+
+Ltac model_check_infer :=
+  apply multiStepClosure_ok; simplify; model_check_steps.
+
+Ltac model_check_find_invariant :=
+  simplify; eapply invariant_weaken; [ model_check_infer | ]; cbv beta in *.
+
+Ltac model_check := model_check_find_invariant; model_check_finish.
diff --git a/ModelCheck.v b/ModelCheck.v
new file mode 100644
index 0000000..f7a25ab
--- /dev/null
+++ b/ModelCheck.v
@@ -0,0 +1,97 @@
+Require Import Invariant Sets.
+
+Definition oneStepClosure_current {state} (sys : trsys state)
+           (invariant1 invariant2 : state -> Prop) :=
+  forall st, invariant1 st
+             -> invariant2 st.
+
+Definition oneStepClosure_new {state} (sys : trsys state)
+           (invariant1 invariant2 : state -> Prop) :=
+  forall st st', invariant1 st
+                 -> sys.(Step) st st'
+                 -> invariant2 st'.
+
+Definition oneStepClosure {state} (sys : trsys state)
+           (invariant1 invariant2 : state -> Prop) :=
+  oneStepClosure_current sys invariant1 invariant2
+  /\ oneStepClosure_new sys invariant1 invariant2.
+
+Theorem prove_oneStepClosure : forall state (sys : trsys state) (inv1 inv2 : state -> Prop),
+  (forall st, inv1 st -> inv2 st)
+  -> (forall st st', inv1 st -> sys.(Step) st st' -> inv2 st')
+  -> oneStepClosure sys inv1 inv2.
+Proof.
+  unfold oneStepClosure; tauto.
+Qed.
+
+Theorem oneStepClosure_done : forall state (sys : trsys state) (invariant : state -> Prop),
+  (forall st, sys.(Initial) st -> invariant st)
+  -> oneStepClosure sys invariant invariant
+  -> invariantFor sys invariant.
+Proof.
+  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new.
+  intuition eauto using invariant_induction.
+Qed.
+
+Inductive multiStepClosure {state} (sys : trsys state)
+  : (state -> Prop) -> (state -> Prop) -> Prop :=
+| MscDone : forall inv,
+    oneStepClosure sys inv inv
+    -> multiStepClosure sys inv inv
+| MscStep : forall inv inv' inv'',
+    oneStepClosure sys inv inv'
+    -> multiStepClosure sys inv' inv''
+    -> multiStepClosure sys inv inv''.
+
+Lemma multiStepClosure_ok' : forall state (sys : trsys state) (inv inv' : state -> Prop),
+  multiStepClosure sys inv inv'
+  -> (forall st, sys.(Initial) st -> inv st)
+  -> invariantFor sys inv'.
+Proof.
+  induction 1; simpl; intuition eauto using oneStepClosure_done.
+
+  unfold oneStepClosure, oneStepClosure_current in *.
+  intuition eauto.
+Qed.
+
+Theorem multiStepClosure_ok : forall state (sys : trsys state) (inv : state -> Prop),
+  multiStepClosure sys sys.(Initial) inv
+  -> invariantFor sys inv.
+Proof.
+  eauto using multiStepClosure_ok'.
+Qed.
+
+Theorem oneStepClosure_empty : forall state (sys : trsys state),
+  oneStepClosure sys (constant nil) (constant nil).
+Proof.
+  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new; intuition.
+Qed.
+
+Theorem oneStepClosure_split : forall state (sys : trsys state) st sts (inv1 inv2 : state -> Prop),
+  (forall st', sys.(Step) st st' -> inv1 st')
+  -> oneStepClosure sys (constant sts) inv2
+  -> oneStepClosure sys (constant (st :: sts)) ({st} \cup inv1 \cup inv2).
+Proof.
+  unfold oneStepClosure, oneStepClosure_current, oneStepClosure_new; intuition.
+
+  inversion H0; subst.
+  unfold union; simpl; tauto.
+
+  unfold union; simpl; eauto.
+
+  unfold union in *; simpl in *.
+  intuition (subst; eauto).
+Qed.
+
+Theorem singleton_in : forall {A} (x : A) rest,
+  ({x} \cup rest) x.
+Proof.
+  unfold union; simpl; auto.
+Qed.
+
+Theorem singleton_in_other : forall {A} (x : A) (s1 s2 : set A),
+  s2 x
+  -> (s1 \cup s2) x.
+Proof.
+  unfold union; simpl; auto.
+Qed.
diff --git a/ModelChecking.v b/ModelChecking.v
index 5b94ac2..04892cc 100644
--- a/ModelChecking.v
+++ b/ModelChecking.v
@@ -103,7 +103,7 @@ Proof.
 
   apply IHmultiStepClosure.
   simplify.
-  unfold oneStepClosure, oneStepClosure_current in *. (* <-- *)
+  unfold oneStepClosure, oneStepClosure_current in *.
   propositional.
   apply H3.
   apply H1.
diff --git a/README.md b/README.md
index 03306b3..bb043a9 100644
--- a/README.md
+++ b/README.md
@@ -9,3 +9,4 @@ Just run `make` here to build everything, including the book `frap.pdf` and the
 * Chapter 2: `BasicSyntax.v`
 * Chapter 3: `Interpreters.v`
 * Chapter 4: `TransitionSystems.v`
+* Chapter 5: `ModelChecking.v`
diff --git a/_CoqProject b/_CoqProject
index 76fa450..e6bdf5f 100644
--- a/_CoqProject
+++ b/_CoqProject
@@ -4,6 +4,7 @@ Var.v
 Sets.v
 Relations.v
 Invariant.v
+ModelCheck.v
 Frap.v
 BasicSyntax_template.v
 BasicSyntax.v