Branch merge for isabelle mainline updates.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Admin/E/eproof Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,92 @@
+#!/usr/bin/perl -w
+#
+# eproof - run E and translate its output into TSTP format
+#
+# Author: Sascha Boehme, TU Muenchen
+#
+# This script is a port of a Bash script with the same name coming with
+# E 1.0-004 (written by Stephan Schulz).
+#
+
+
+use File::Basename qw/ dirname /;
+use File::Temp qw/ tempfile /;
+
+
+# E executables
+
+my $edir = dirname($0);
+my $eprover = "$edir/eprover";
+my $epclextract = "$edir/epclextract";
+
+
+# build E command from given commandline arguments
+
+my $format = "";
+my $timelimit = 2000000000; # effectively unlimited
+
+my $eprover_cmd = "'$eprover'";
+foreach (@ARGV) {
+ if (m/--cpu-limit=([0-9]+)/) {
+ $timelimit = $1;
+ }
+
+ if (m/--tstp-out/) {
+ $format = $_;
+ }
+ else {
+ $eprover_cmd = "$eprover_cmd '$_'";
+ }
+}
+$eprover_cmd = "$eprover_cmd -l4 -R -o- --pcl-terms-compressed --pcl-compact";
+
+
+# run E, redirecting output into a temporary file
+
+my ($fh, $filename) = tempfile(UNLINK => 1);
+my $r = system "$eprover_cmd > $filename";
+exit ($r >> 8) if $r != 0;
+
+
+# analyze E output
+
+my @lines = <$fh>;
+my $content = join "", @lines[-60 .. -1];
+ # Note: Like the original eproof, we only look at the last 60 lines.
+
+if ($content =~ m/Total time\s*:\s*([0-9]+\.[0-9]+)/) {
+ $timelimit = $timelimit - $1 - 1;
+
+ if ($content =~ m/No proof found!/) {
+ print "# Problem is satisfiable (or invalid), " .
+ "generating saturation derivation\n";
+ }
+ elsif ($content =~ m/Proof found!/) {
+ print "# Problem is unsatisfiable (or provable), " .
+ "constructing proof object\n";
+ }
+ elsif ($content =~ m/Watchlist is empty!/) {
+ print "# All watchlist clauses generated, constructing derivation\n";
+ }
+ else {
+ print "# Cannot determine problem status\n";
+ exit $r;
+ }
+}
+else {
+ print "# Cannot determine problem status within resource limit\n";
+ exit $r;
+}
+
+
+# translate E output
+
+foreach (@lines) {
+ print if (m/# SZS status/ or m/"# Failure"/);
+}
+$r = system ("exec bash -c \"ulimit -S -t $timelimit; " .
+ "'$epclextract' $format -f --competition-framing $filename\"");
+ # Note: Setting the user time is not supported on Cygwin, i.e., ulimit fails
+ # and prints and error message. How could we then limit the execution time?
+exit ($r >> 8);
+
--- a/Admin/isatest/isatest-stats Thu Sep 17 14:17:37 2009 +1000
+++ b/Admin/isatest/isatest-stats Tue Sep 22 13:52:19 2009 +1000
@@ -24,9 +24,9 @@
HOL-MetisExamples \
HOL-MicroJava \
HOL-NSA \
- HOL-NewNumberTheory \
HOL-Nominal-Examples \
- HOL-NumberTheory \
+ HOL-Number_Theory \
+ HOL-Old_Number_Theory \
HOL-SET-Protocol \
HOL-UNITY \
HOL-Word \
--- a/CONTRIBUTORS Thu Sep 17 14:17:37 2009 +1000
+++ b/CONTRIBUTORS Tue Sep 22 13:52:19 2009 +1000
@@ -7,6 +7,15 @@
Contributions to this Isabelle version
--------------------------------------
+* September 2009: Sascha Boehme, TUM
+ SMT method using external SMT solvers
+
+* September 2009: Florian Haftmann, TUM
+ Refinement of Sets and Lattices
+
+* July 2009: Jeremy Avigad and Amine Chaieb
+ New number theory
+
* July 2009: Philipp Meyer, TUM
HOL/Library/Sum_of_Squares: functionality to call a remote csdp prover
--- a/NEWS Thu Sep 17 14:17:37 2009 +1000
+++ b/NEWS Tue Sep 22 13:52:19 2009 +1000
@@ -18,15 +18,36 @@
*** HOL ***
+* New proof method "smt" for a combination of first-order logic
+with equality, linear and nonlinear (natural/integer/real)
+arithmetic, and fixed-size bitvectors; there is also basic
+support for higher-order features (esp. lambda abstractions).
+It is an incomplete decision procedure based on external SMT
+solvers using the oracle mechanism.
+
* Reorganization of number theory:
- * former session NumberTheory now named Old_Number_Theory; former session NewNumberTheory
- named NumberTheory;
- * split off prime number ingredients from theory GCD to theory Number_Theory/Primes;
+ * former session NumberTheory now named Old_Number_Theory
+ * new session Number_Theory by Jeremy Avigad; if possible, prefer this.
* moved legacy theories Legacy_GCD and Primes from Library/ to Old_Number_Theory/;
* moved theory Pocklington from Library/ to Old_Number_Theory/;
* removed various references to Old_Number_Theory from HOL distribution.
INCOMPATIBILITY.
+* Theory GCD now has functions Gcd/GCD and Lcm/LCM for the gcd and lcm
+of finite and infinite sets. It is shown that they form a complete
+lattice.
+
+* Split off prime number ingredients from theory GCD
+to theory Number_Theory/Primes;
+
+* Class semiring_div requires superclass no_zero_divisors and proof of
+div_mult_mult1; theorems div_mult_mult1, div_mult_mult2,
+div_mult_mult1_if, div_mult_mult1 and div_mult_mult2 have been
+generalized to class semiring_div, subsuming former theorems
+zdiv_zmult_zmult1, zdiv_zmult_zmult1_if, zdiv_zmult_zmult1 and
+zdiv_zmult_zmult2. div_mult_mult1 is now [simp] by default.
+INCOMPATIBILITY.
+
* New testing tool "Mirabelle" for automated (proof) tools. Applies
several tools and tactics like sledgehammer, metis, or quickcheck, to
every proof step in a theory. To be used in batch mode via the
@@ -47,16 +68,15 @@
etc.
INCOMPATIBILITY.
-* New class "boolean_algebra".
-
* Refinements to lattice classes and sets:
- less default intro/elim rules in locale variant, more default
intro/elim rules in class variant: more uniformity
- lemma ge_sup_conv renamed to le_sup_iff, in accordance with le_inf_iff
- dropped lemma alias inf_ACI for inf_aci (same for sup_ACI and sup_aci)
- renamed ACI to inf_sup_aci
+ - new class "boolean_algebra"
- class "complete_lattice" moved to separate theory "complete_lattice";
- corresponding constants (and abbreviations) renamed:
+ corresponding constants (and abbreviations) renamed and with authentic syntax:
Set.Inf ~> Complete_Lattice.Inf
Set.Sup ~> Complete_Lattice.Sup
Set.INFI ~> Complete_Lattice.INFI
@@ -66,24 +86,22 @@
Set.INTER ~> Complete_Lattice.INTER
Set.UNION ~> Complete_Lattice.UNION
- more convenient names for set intersection and union:
- Set.Int ~> Set.inter
- Set.Un ~> Set.union
+ Set.Int ~> Set.inter
+ Set.Un ~> Set.union
+ - authentic syntax for
+ Set.Pow
+ Set.image
- mere abbreviations:
Set.empty (for bot)
Set.UNIV (for top)
Complete_Lattice.Inter (for Inf)
Complete_Lattice.Union (for Sup)
+ Complete_Lattice.INTER (for INFI)
+ Complete_Lattice.UNION (for SUPR)
+ - object-logic definitions as far as appropriate
INCOMPATIBILITY.
-* Class semiring_div requires superclass no_zero_divisors and proof of
-div_mult_mult1; theorems div_mult_mult1, div_mult_mult2,
-div_mult_mult1_if, div_mult_mult1 and div_mult_mult2 have been
-generalized to class semiring_div, subsuming former theorems
-zdiv_zmult_zmult1, zdiv_zmult_zmult1_if, zdiv_zmult_zmult1 and
-zdiv_zmult_zmult2. div_mult_mult1 is now [simp] by default.
-INCOMPATIBILITY.
-
* Power operations on relations and functions are now one dedicate
constant "compow" with infix syntax "^^". Power operations on
multiplicative monoids retains syntax "^" and is now defined generic
@@ -96,10 +114,6 @@
this. Fix using O_assoc[symmetric]. The same applies to the curried
version "R OO S".
-* Theory GCD now has functions Gcd/GCD and Lcm/LCM for the gcd and lcm
-of finite and infinite sets. It is shown that they form a complete
-lattice.
-
* ML antiquotation @{code_datatype} inserts definition of a datatype
generated by the code generator; see Predicate.thy for an example.
@@ -110,10 +124,6 @@
default generators are provided for all suitable HOL types, records
and datatypes.
-* Constants Set.Pow and Set.image now with authentic syntax;
-object-logic definitions Set.Pow_def and Set.image_def.
-INCOMPATIBILITY.
-
* Renamed theorems:
Suc_eq_add_numeral_1 -> Suc_eq_plus1
Suc_eq_add_numeral_1_left -> Suc_eq_plus1_left
@@ -127,6 +137,9 @@
ATPs down considerably but eliminates a source of unsound "proofs"
that fail later.
+* New method metisFT: A version of metis that uses full type information
+in order to avoid failures of proof reconstruction.
+
* Discontinued ancient tradition to suffix certain ML module names
with "_package", e.g.:
@@ -135,9 +148,6 @@
INCOMPATIBILITY.
-* NewNumberTheory: Jeremy Avigad's new version of part of
-NumberTheory. If possible, use NewNumberTheory, not NumberTheory.
-
* Discontinued abbreviation "arbitrary" of constant
"undefined". INCOMPATIBILITY, use "undefined" directly.
--- a/etc/components Thu Sep 17 14:17:37 2009 +1000
+++ b/etc/components Tue Sep 22 13:52:19 2009 +1000
@@ -15,3 +15,4 @@
src/HOL/Tools/ATP_Manager
src/HOL/Mirabelle
src/HOL/Library/Sum_Of_Squares
+src/HOL/SMT
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Auth/All_Symmetric.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,12 @@
+theory All_Symmetric
+imports Message
+begin
+
+text {* All keys are symmetric *}
+
+defs all_symmetric_def: "all_symmetric \<equiv> True"
+
+lemma isSym_keys: "K \<in> symKeys"
+ by (simp add: symKeys_def all_symmetric_def invKey_symmetric)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Auth/Auth_Public.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,15 @@
+(* Author: Lawrence C Paulson, Cambridge University Computer Laboratory
+ Copyright 1996 University of Cambridge
+*)
+
+header {* Conventional protocols: rely on conventional Message, Event and Public -- Public-key protocols *}
+
+theory Auth_Public
+imports
+ "NS_Public_Bad"
+ "NS_Public"
+ "TLS"
+ "CertifiedEmail"
+begin
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Auth/Auth_Shared.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,27 @@
+(* Author: Lawrence C Paulson, Cambridge University Computer Laboratory
+ Copyright 1996 University of Cambridge
+*)
+
+header {* Conventional protocols: rely on conventional Message, Event and Public -- Shared-key protocols *}
+
+theory Auth_Shared
+imports
+ "NS_Shared"
+ "Kerberos_BAN"
+ "Kerberos_BAN_Gets"
+ "KerberosIV"
+ "KerberosIV_Gets"
+ "KerberosV"
+ "OtwayRees"
+ "OtwayRees_AN"
+ "OtwayRees_Bad"
+ "OtwayReesBella"
+ "WooLam"
+ "Recur"
+ "Yahalom"
+ "Yahalom2"
+ "Yahalom_Bad"
+ "ZhouGollmann"
+begin
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Auth/Guard/Auth_Guard_Public.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,15 @@
+(* Author: Lawrence C Paulson, Cambridge University Computer Laboratory
+ Copyright 1996 University of Cambridge
+*)
+
+header {* Blanqui's "guard" concept: protocol-independent secrecy *}
+
+theory Auth_Guard_Public
+imports
+ "P1"
+ "P2"
+ "Guard_NS_Public"
+ "Proto"
+begin
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Auth/Guard/Auth_Guard_Shared.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,13 @@
+(* Author: Lawrence C Paulson, Cambridge University Computer Laboratory
+ Copyright 1996 University of Cambridge
+*)
+
+header {* Blanqui's "guard" concept: protocol-independent secrecy *}
+
+theory Auth_Guard_Shared
+imports
+ "Guard_OtwayRees"
+ "Guard_Yahalom"
+begin
+
+end
--- a/src/HOL/Auth/Public.thy Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Auth/Public.thy Tue Sep 22 13:52:19 2009 +1000
@@ -1,5 +1,4 @@
(* Title: HOL/Auth/Public
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Copyright 1996 University of Cambridge
@@ -8,7 +7,9 @@
Private and public keys; initial states of agents
*)
-theory Public imports Event begin
+theory Public
+imports Event
+begin
lemma invKey_K: "K \<in> symKeys ==> invKey K = K"
by (simp add: symKeys_def)
--- a/src/HOL/Auth/ROOT.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Auth/ROOT.ML Tue Sep 22 13:52:19 2009 +1000
@@ -1,51 +1,2 @@
-(* Title: HOL/Auth/ROOT.ML
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
- Copyright 1996 University of Cambridge
-Root file for protocol proofs.
-*)
-
-use_thys [
-
-(* Conventional protocols: rely on
- conventional Message, Event and Public *)
-
-(*Shared-key protocols*)
- "NS_Shared",
- "Kerberos_BAN",
- "Kerberos_BAN_Gets",
- "KerberosIV",
- "KerberosIV_Gets",
- "KerberosV",
- "OtwayRees",
- "OtwayRees_AN",
- "OtwayRees_Bad",
- "OtwayReesBella",
- "WooLam",
- "Recur",
- "Yahalom",
- "Yahalom2",
- "Yahalom_Bad",
- "ZhouGollmann",
-
-(*Public-key protocols*)
- "NS_Public_Bad",
- "NS_Public",
- "TLS",
- "CertifiedEmail",
-
-(*Smartcard protocols: rely on conventional Message and on new
- EventSC and Smartcard *)
-
- "Smartcard/ShoupRubin",
- "Smartcard/ShoupRubinBella",
-
-(*Blanqui's "guard" concept: protocol-independent secrecy*)
- "Guard/P1",
- "Guard/P2",
- "Guard/Guard_NS_Public",
- "Guard/Guard_OtwayRees",
- "Guard/Guard_Yahalom",
- "Guard/Proto"
-];
+use_thys ["Auth_Shared", "Auth_Public", "Smartcard/Auth_Smartcard", "Guard/Auth_Guard_Shared", "Guard/Auth_Guard_Public"];
--- a/src/HOL/Auth/Shared.thy Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Auth/Shared.thy Tue Sep 22 13:52:19 2009 +1000
@@ -1,5 +1,4 @@
(* Title: HOL/Auth/Shared
- ID: $Id$
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Copyright 1996 University of Cambridge
@@ -8,7 +7,9 @@
Shared, long-term keys; initial states of agents
*)
-theory Shared imports Event begin
+theory Shared
+imports Event All_Symmetric
+begin
consts
shrK :: "agent => key" (*symmetric keys*);
@@ -20,13 +21,6 @@
apply (simp add: inj_on_def split: agent.split)
done
-text{*All keys are symmetric*}
-
-defs all_symmetric_def: "all_symmetric == True"
-
-lemma isSym_keys: "K \<in> symKeys"
-by (simp add: symKeys_def all_symmetric_def invKey_symmetric)
-
text{*Server knows all long-term keys; other agents know only their own*}
primrec
initState_Server: "initState Server = Key ` range shrK"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Auth/Smartcard/Auth_Smartcard.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,13 @@
+(* Author: Lawrence C Paulson, Cambridge University Computer Laboratory
+ Copyright 1996 University of Cambridge
+*)
+
+header {* Smartcard protocols: rely on conventional Message and on new EventSC and Smartcard *}
+
+theory Auth_Smartcard
+imports
+ "ShoupRubin"
+ "ShoupRubinBella"
+begin
+
+end
--- a/src/HOL/Auth/Smartcard/Smartcard.thy Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Auth/Smartcard/Smartcard.thy Tue Sep 22 13:52:19 2009 +1000
@@ -1,10 +1,11 @@
-(* ID: $Id$
- Author: Giampaolo Bella, Catania University
+(* Author: Giampaolo Bella, Catania University
*)
header{*Theory of smartcards*}
-theory Smartcard imports EventSC begin
+theory Smartcard
+imports EventSC All_Symmetric
+begin
text{*
As smartcards handle long-term (symmetric) keys, this theoy extends and
@@ -42,14 +43,6 @@
shrK_disj_pin [iff]: "shrK P \<noteq> pin Q"
crdK_disj_pin [iff]: "crdK C \<noteq> pin P"
-
-text{*All keys are symmetric*}
-defs all_symmetric_def: "all_symmetric == True"
-
-lemma isSym_keys: "K \<in> symKeys"
-by (simp add: symKeys_def all_symmetric_def invKey_symmetric)
-
-
constdefs
legalUse :: "card => bool" ("legalUse (_)")
"legalUse C == C \<notin> stolen"
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Bali/Bali.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,11 @@
+(* Author: David von Oheimb
+ Copyright 1999 Technische Universitaet Muenchen
+*)
+
+header {* The Hoare logic for Bali. *}
+
+theory Bali
+imports AxExample AxSound AxCompl Trans
+begin
+
+end
--- a/src/HOL/Bali/ROOT.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Bali/ROOT.ML Tue Sep 22 13:52:19 2009 +1000
@@ -1,9 +1,2 @@
-(* Title: HOL/Bali/ROOT.ML
- ID: $Id$
- Author: David von Oheimb
- Copyright 1999 Technische Universitaet Muenchen
-The Hoare logic for Bali.
-*)
-
-use_thys ["AxExample", "AxSound", "AxCompl", "Trans"];
+use_thy "Bali"
--- a/src/HOL/Complete_Lattice.thy Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Complete_Lattice.thy Tue Sep 22 13:52:19 2009 +1000
@@ -278,8 +278,8 @@
subsection {* Unions of families *}
-definition UNION :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'b set" where
- SUPR_set_eq [symmetric]: "UNION S f = (SUP x:S. f x)"
+abbreviation UNION :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'b set" where
+ "UNION \<equiv> SUPR"
syntax
"@UNION1" :: "pttrns => 'b set => 'b set" ("(3UN _./ _)" [0, 10] 10)
@@ -314,7 +314,7 @@
lemma UNION_eq_Union_image:
"(\<Union>x\<in>A. B x) = \<Union>(B`A)"
- by (simp add: SUPR_def SUPR_set_eq [symmetric])
+ by (fact SUPR_def)
lemma Union_def:
"\<Union>S = (\<Union>x\<in>S. x)"
@@ -351,7 +351,7 @@
by blast
lemma UN_upper: "a \<in> A ==> B a \<subseteq> (\<Union>x\<in>A. B x)"
- by blast
+ by (fact le_SUPI)
lemma UN_least: "(!!x. x \<in> A ==> B x \<subseteq> C) ==> (\<Union>x\<in>A. B x) \<subseteq> C"
by (iprover intro: subsetI elim: UN_E dest: subsetD)
@@ -514,8 +514,8 @@
subsection {* Intersections of families *}
-definition INTER :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'b set" where
- INFI_set_eq [symmetric]: "INTER S f = (INF x:S. f x)"
+abbreviation INTER :: "'a set \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'b set" where
+ "INTER \<equiv> INFI"
syntax
"@INTER1" :: "pttrns => 'b set => 'b set" ("(3INT _./ _)" [0, 10] 10)
@@ -541,7 +541,7 @@
lemma INTER_eq_Inter_image:
"(\<Inter>x\<in>A. B x) = \<Inter>(B`A)"
- by (simp add: INFI_def INFI_set_eq [symmetric])
+ by (fact INFI_def)
lemma Inter_def:
"\<Inter>S = (\<Inter>x\<in>S. x)"
@@ -579,10 +579,10 @@
by blast
lemma INT_lower: "a \<in> A ==> (\<Inter>x\<in>A. B x) \<subseteq> B a"
- by blast
+ by (fact INF_leI)
lemma INT_greatest: "(!!x. x \<in> A ==> C \<subseteq> B x) ==> C \<subseteq> (\<Inter>x\<in>A. B x)"
- by (iprover intro: INT_I subsetI dest: subsetD)
+ by (fact le_INFI)
lemma INT_empty [simp]: "(\<Inter>x\<in>{}. B x) = UNIV"
by blast
--- a/src/HOL/HoareParallel/Gar_Coll.thy Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,846 +0,0 @@
-
-header {* \section{The Single Mutator Case} *}
-
-theory Gar_Coll imports Graph OG_Syntax begin
-
-declare psubsetE [rule del]
-
-text {* Declaration of variables: *}
-
-record gar_coll_state =
- M :: nodes
- E :: edges
- bc :: "nat set"
- obc :: "nat set"
- Ma :: nodes
- ind :: nat
- k :: nat
- z :: bool
-
-subsection {* The Mutator *}
-
-text {* The mutator first redirects an arbitrary edge @{text "R"} from
-an arbitrary accessible node towards an arbitrary accessible node
-@{text "T"}. It then colors the new target @{text "T"} black.
-
-We declare the arbitrarily selected node and edge as constants:*}
-
-consts R :: nat T :: nat
-
-text {* \noindent The following predicate states, given a list of
-nodes @{text "m"} and a list of edges @{text "e"}, the conditions
-under which the selected edge @{text "R"} and node @{text "T"} are
-valid: *}
-
-constdefs
- Mut_init :: "gar_coll_state \<Rightarrow> bool"
- "Mut_init \<equiv> \<guillemotleft> T \<in> Reach \<acute>E \<and> R < length \<acute>E \<and> T < length \<acute>M \<guillemotright>"
-
-text {* \noindent For the mutator we
-consider two modules, one for each action. An auxiliary variable
-@{text "\<acute>z"} is set to false if the mutator has already redirected an
-edge but has not yet colored the new target. *}
-
-constdefs
- Redirect_Edge :: "gar_coll_state ann_com"
- "Redirect_Edge \<equiv> .{\<acute>Mut_init \<and> \<acute>z}. \<langle>\<acute>E:=\<acute>E[R:=(fst(\<acute>E!R), T)],, \<acute>z:= (\<not>\<acute>z)\<rangle>"
-
- Color_Target :: "gar_coll_state ann_com"
- "Color_Target \<equiv> .{\<acute>Mut_init \<and> \<not>\<acute>z}. \<langle>\<acute>M:=\<acute>M[T:=Black],, \<acute>z:= (\<not>\<acute>z)\<rangle>"
-
- Mutator :: "gar_coll_state ann_com"
- "Mutator \<equiv>
- .{\<acute>Mut_init \<and> \<acute>z}.
- WHILE True INV .{\<acute>Mut_init \<and> \<acute>z}.
- DO Redirect_Edge ;; Color_Target OD"
-
-subsubsection {* Correctness of the mutator *}
-
-lemmas mutator_defs = Mut_init_def Redirect_Edge_def Color_Target_def
-
-lemma Redirect_Edge:
- "\<turnstile> Redirect_Edge pre(Color_Target)"
-apply (unfold mutator_defs)
-apply annhoare
-apply(simp_all)
-apply(force elim:Graph2)
-done
-
-lemma Color_Target:
- "\<turnstile> Color_Target .{\<acute>Mut_init \<and> \<acute>z}."
-apply (unfold mutator_defs)
-apply annhoare
-apply(simp_all)
-done
-
-lemma Mutator:
- "\<turnstile> Mutator .{False}."
-apply(unfold Mutator_def)
-apply annhoare
-apply(simp_all add:Redirect_Edge Color_Target)
-apply(simp add:mutator_defs Redirect_Edge_def)
-done
-
-subsection {* The Collector *}
-
-text {* \noindent A constant @{text "M_init"} is used to give @{text "\<acute>Ma"} a
-suitable first value, defined as a list of nodes where only the @{text
-"Roots"} are black. *}
-
-consts M_init :: nodes
-
-constdefs
- Proper_M_init :: "gar_coll_state \<Rightarrow> bool"
- "Proper_M_init \<equiv> \<guillemotleft> Blacks M_init=Roots \<and> length M_init=length \<acute>M \<guillemotright>"
-
- Proper :: "gar_coll_state \<Rightarrow> bool"
- "Proper \<equiv> \<guillemotleft> Proper_Roots \<acute>M \<and> Proper_Edges(\<acute>M, \<acute>E) \<and> \<acute>Proper_M_init \<guillemotright>"
-
- Safe :: "gar_coll_state \<Rightarrow> bool"
- "Safe \<equiv> \<guillemotleft> Reach \<acute>E \<subseteq> Blacks \<acute>M \<guillemotright>"
-
-lemmas collector_defs = Proper_M_init_def Proper_def Safe_def
-
-subsubsection {* Blackening the roots *}
-
-constdefs
- Blacken_Roots :: " gar_coll_state ann_com"
- "Blacken_Roots \<equiv>
- .{\<acute>Proper}.
- \<acute>ind:=0;;
- .{\<acute>Proper \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>M
- INV .{\<acute>Proper \<and> (\<forall>i<\<acute>ind. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind\<le>length \<acute>M}.
- DO .{\<acute>Proper \<and> (\<forall>i<\<acute>ind. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
- IF \<acute>ind\<in>Roots THEN
- .{\<acute>Proper \<and> (\<forall>i<\<acute>ind. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<in>Roots}.
- \<acute>M:=\<acute>M[\<acute>ind:=Black] FI;;
- .{\<acute>Proper \<and> (\<forall>i<\<acute>ind+1. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
- \<acute>ind:=\<acute>ind+1
- OD"
-
-lemma Blacken_Roots:
- "\<turnstile> Blacken_Roots .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M}."
-apply (unfold Blacken_Roots_def)
-apply annhoare
-apply(simp_all add:collector_defs Graph_defs)
-apply safe
-apply(simp_all add:nth_list_update)
- apply (erule less_SucE)
- apply simp+
- apply force
-apply force
-done
-
-subsubsection {* Propagating black *}
-
-constdefs
- PBInv :: "gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
- "PBInv \<equiv> \<guillemotleft> \<lambda>ind. \<acute>obc < Blacks \<acute>M \<or> (\<forall>i <ind. \<not>BtoW (\<acute>E!i, \<acute>M) \<or>
- (\<not>\<acute>z \<and> i=R \<and> (snd(\<acute>E!R)) = T \<and> (\<exists>r. ind \<le> r \<and> r < length \<acute>E \<and> BtoW(\<acute>E!r,\<acute>M))))\<guillemotright>"
-
-constdefs
- Propagate_Black_aux :: "gar_coll_state ann_com"
- "Propagate_Black_aux \<equiv>
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M}.
- \<acute>ind:=0;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>E
- INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>E}.
- DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E}.
- IF \<acute>M!(fst (\<acute>E!\<acute>ind)) = Black THEN
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E \<and> \<acute>M!fst(\<acute>E!\<acute>ind)=Black}.
- \<acute>M:=\<acute>M[snd(\<acute>E!\<acute>ind):=Black];;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv (\<acute>ind + 1) \<and> \<acute>ind<length \<acute>E}.
- \<acute>ind:=\<acute>ind+1
- FI
- OD"
-
-lemma Propagate_Black_aux:
- "\<turnstile> Propagate_Black_aux
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> ( \<acute>obc < Blacks \<acute>M \<or> \<acute>Safe)}."
-apply (unfold Propagate_Black_aux_def PBInv_def collector_defs)
-apply annhoare
-apply(simp_all add:Graph6 Graph7 Graph8 Graph12)
- apply force
- apply force
- apply force
---{* 4 subgoals left *}
-apply clarify
-apply(simp add:Proper_Edges_def Proper_Roots_def Graph6 Graph7 Graph8 Graph12)
-apply (erule disjE)
- apply(rule disjI1)
- apply(erule Graph13)
- apply force
-apply (case_tac "M x ! snd (E x ! ind x)=Black")
- apply (simp add: Graph10 BtoW_def)
- apply (rule disjI2)
- apply clarify
- apply (erule less_SucE)
- apply (erule_tac x=i in allE , erule (1) notE impE)
- apply simp
- apply clarify
- apply (drule_tac y = r in le_imp_less_or_eq)
- apply (erule disjE)
- apply (subgoal_tac "Suc (ind x)\<le>r")
- apply fast
- apply arith
- apply fast
- apply fast
-apply(rule disjI1)
-apply(erule subset_psubset_trans)
-apply(erule Graph11)
-apply fast
---{* 3 subgoals left *}
-apply force
-apply force
---{* last *}
-apply clarify
-apply simp
-apply(subgoal_tac "ind x = length (E x)")
- apply (rotate_tac -1)
- apply (simp (asm_lr))
- apply(drule Graph1)
- apply simp
- apply clarify
- apply(erule allE, erule impE, assumption)
- apply force
- apply force
-apply arith
-done
-
-subsubsection {* Refining propagating black *}
-
-constdefs
- Auxk :: "gar_coll_state \<Rightarrow> bool"
- "Auxk \<equiv> \<guillemotleft>\<acute>k<length \<acute>M \<and> (\<acute>M!\<acute>k\<noteq>Black \<or> \<not>BtoW(\<acute>E!\<acute>ind, \<acute>M) \<or>
- \<acute>obc<Blacks \<acute>M \<or> (\<not>\<acute>z \<and> \<acute>ind=R \<and> snd(\<acute>E!R)=T
- \<and> (\<exists>r. \<acute>ind<r \<and> r<length \<acute>E \<and> BtoW(\<acute>E!r, \<acute>M))))\<guillemotright>"
-
-constdefs
- Propagate_Black :: " gar_coll_state ann_com"
- "Propagate_Black \<equiv>
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M}.
- \<acute>ind:=0;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>E
- INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>E}.
- DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E}.
- IF (\<acute>M!(fst (\<acute>E!\<acute>ind)))=Black THEN
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E \<and> (\<acute>M!fst(\<acute>E!\<acute>ind))=Black}.
- \<acute>k:=(snd(\<acute>E!\<acute>ind));;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E \<and> (\<acute>M!fst(\<acute>E!\<acute>ind))=Black
- \<and> \<acute>Auxk}.
- \<langle>\<acute>M:=\<acute>M[\<acute>k:=Black],, \<acute>ind:=\<acute>ind+1\<rangle>
- ELSE .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E}.
- \<langle>IF (\<acute>M!(fst (\<acute>E!\<acute>ind)))\<noteq>Black THEN \<acute>ind:=\<acute>ind+1 FI\<rangle>
- FI
- OD"
-
-lemma Propagate_Black:
- "\<turnstile> Propagate_Black
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> ( \<acute>obc < Blacks \<acute>M \<or> \<acute>Safe)}."
-apply (unfold Propagate_Black_def PBInv_def Auxk_def collector_defs)
-apply annhoare
-apply(simp_all add:Graph6 Graph7 Graph8 Graph12)
- apply force
- apply force
- apply force
---{* 5 subgoals left *}
-apply clarify
-apply(simp add:BtoW_def Proper_Edges_def)
---{* 4 subgoals left *}
-apply clarify
-apply(simp add:Proper_Edges_def Graph6 Graph7 Graph8 Graph12)
-apply (erule disjE)
- apply (rule disjI1)
- apply (erule psubset_subset_trans)
- apply (erule Graph9)
-apply (case_tac "M x!k x=Black")
- apply (case_tac "M x ! snd (E x ! ind x)=Black")
- apply (simp add: Graph10 BtoW_def)
- apply (rule disjI2)
- apply clarify
- apply (erule less_SucE)
- apply (erule_tac x=i in allE , erule (1) notE impE)
- apply simp
- apply clarify
- apply (drule_tac y = r in le_imp_less_or_eq)
- apply (erule disjE)
- apply (subgoal_tac "Suc (ind x)\<le>r")
- apply fast
- apply arith
- apply fast
- apply fast
- apply (simp add: Graph10 BtoW_def)
- apply (erule disjE)
- apply (erule disjI1)
- apply clarify
- apply (erule less_SucE)
- apply force
- apply simp
- apply (subgoal_tac "Suc R\<le>r")
- apply fast
- apply arith
-apply(rule disjI1)
-apply(erule subset_psubset_trans)
-apply(erule Graph11)
-apply fast
---{* 3 subgoals left *}
-apply force
---{* 2 subgoals left *}
-apply clarify
-apply(simp add:Proper_Edges_def Graph6 Graph7 Graph8 Graph12)
-apply (erule disjE)
- apply fast
-apply clarify
-apply (erule less_SucE)
- apply (erule_tac x=i in allE , erule (1) notE impE)
- apply simp
- apply clarify
- apply (drule_tac y = r in le_imp_less_or_eq)
- apply (erule disjE)
- apply (subgoal_tac "Suc (ind x)\<le>r")
- apply fast
- apply arith
- apply (simp add: BtoW_def)
-apply (simp add: BtoW_def)
---{* last *}
-apply clarify
-apply simp
-apply(subgoal_tac "ind x = length (E x)")
- apply (rotate_tac -1)
- apply (simp (asm_lr))
- apply(drule Graph1)
- apply simp
- apply clarify
- apply(erule allE, erule impE, assumption)
- apply force
- apply force
-apply arith
-done
-
-subsubsection {* Counting black nodes *}
-
-constdefs
- CountInv :: "gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
- "CountInv \<equiv> \<guillemotleft> \<lambda>ind. {i. i<ind \<and> \<acute>Ma!i=Black}\<subseteq>\<acute>bc \<guillemotright>"
-
-constdefs
- Count :: " gar_coll_state ann_com"
- "Count \<equiv>
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>bc={}}.
- \<acute>ind:=0;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>bc={}
- \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>M
- INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv \<acute>ind
- \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind\<le>length \<acute>M}.
- DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv \<acute>ind
- \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind<length \<acute>M}.
- IF \<acute>M!\<acute>ind=Black
- THEN .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv \<acute>ind
- \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
- \<acute>bc:=insert \<acute>ind \<acute>bc
- FI;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv (\<acute>ind+1)
- \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind<length \<acute>M}.
- \<acute>ind:=\<acute>ind+1
- OD"
-
-lemma Count:
- "\<turnstile> Count
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> length \<acute>Ma=length \<acute>M
- \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe)}."
-apply(unfold Count_def)
-apply annhoare
-apply(simp_all add:CountInv_def Graph6 Graph7 Graph8 Graph12 Blacks_def collector_defs)
- apply force
- apply force
- apply force
- apply clarify
- apply simp
- apply(fast elim:less_SucE)
- apply clarify
- apply simp
- apply(fast elim:less_SucE)
- apply force
-apply force
-done
-
-subsubsection {* Appending garbage nodes to the free list *}
-
-consts Append_to_free :: "nat \<times> edges \<Rightarrow> edges"
-
-axioms
- Append_to_free0: "length (Append_to_free (i, e)) = length e"
- Append_to_free1: "Proper_Edges (m, e)
- \<Longrightarrow> Proper_Edges (m, Append_to_free(i, e))"
- Append_to_free2: "i \<notin> Reach e
- \<Longrightarrow> n \<in> Reach (Append_to_free(i, e)) = ( n = i \<or> n \<in> Reach e)"
-
-constdefs
- AppendInv :: "gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
- "AppendInv \<equiv> \<guillemotleft>\<lambda>ind. \<forall>i<length \<acute>M. ind\<le>i \<longrightarrow> i\<in>Reach \<acute>E \<longrightarrow> \<acute>M!i=Black\<guillemotright>"
-
-constdefs
- Append :: " gar_coll_state ann_com"
- "Append \<equiv>
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe}.
- \<acute>ind:=0;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>M
- INV .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>M}.
- DO .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M}.
- IF \<acute>M!\<acute>ind=Black THEN
- .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
- \<acute>M:=\<acute>M[\<acute>ind:=White]
- ELSE .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<notin>Reach \<acute>E}.
- \<acute>E:=Append_to_free(\<acute>ind,\<acute>E)
- FI;;
- .{\<acute>Proper \<and> \<acute>AppendInv (\<acute>ind+1) \<and> \<acute>ind<length \<acute>M}.
- \<acute>ind:=\<acute>ind+1
- OD"
-
-lemma Append:
- "\<turnstile> Append .{\<acute>Proper}."
-apply(unfold Append_def AppendInv_def)
-apply annhoare
-apply(simp_all add:collector_defs Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
- apply(force simp:Blacks_def nth_list_update)
- apply force
- apply force
- apply(force simp add:Graph_defs)
- apply force
- apply clarify
- apply simp
- apply(rule conjI)
- apply (erule Append_to_free1)
- apply clarify
- apply (drule_tac n = "i" in Append_to_free2)
- apply force
- apply force
-apply force
-done
-
-subsubsection {* Correctness of the Collector *}
-
-constdefs
- Collector :: " gar_coll_state ann_com"
- "Collector \<equiv>
-.{\<acute>Proper}.
- WHILE True INV .{\<acute>Proper}.
- DO
- Blacken_Roots;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M}.
- \<acute>obc:={};;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={}}.
- \<acute>bc:=Roots;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots}.
- \<acute>Ma:=M_init;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots \<and> \<acute>Ma=M_init}.
- WHILE \<acute>obc\<noteq>\<acute>bc
- INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe)}.
- DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M}.
- \<acute>obc:=\<acute>bc;;
- Propagate_Black;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>obc < Blacks \<acute>M \<or> \<acute>Safe)}.
- \<acute>Ma:=\<acute>M;;
- .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma
- \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> length \<acute>Ma=length \<acute>M
- \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe)}.
- \<acute>bc:={};;
- Count
- OD;;
- Append
- OD"
-
-lemma Collector:
- "\<turnstile> Collector .{False}."
-apply(unfold Collector_def)
-apply annhoare
-apply(simp_all add: Blacken_Roots Propagate_Black Count Append)
-apply(simp_all add:Blacken_Roots_def Propagate_Black_def Count_def Append_def collector_defs)
- apply (force simp add: Proper_Roots_def)
- apply force
- apply force
-apply clarify
-apply (erule disjE)
-apply(simp add:psubsetI)
- apply(force dest:subset_antisym)
-done
-
-subsection {* Interference Freedom *}
-
-lemmas modules = Redirect_Edge_def Color_Target_def Blacken_Roots_def
- Propagate_Black_def Count_def Append_def
-lemmas Invariants = PBInv_def Auxk_def CountInv_def AppendInv_def
-lemmas abbrev = collector_defs mutator_defs Invariants
-
-lemma interfree_Blacken_Roots_Redirect_Edge:
- "interfree_aux (Some Blacken_Roots, {}, Some Redirect_Edge)"
-apply (unfold modules)
-apply interfree_aux
-apply safe
-apply (simp_all add:Graph6 Graph12 abbrev)
-done
-
-lemma interfree_Redirect_Edge_Blacken_Roots:
- "interfree_aux (Some Redirect_Edge, {}, Some Blacken_Roots)"
-apply (unfold modules)
-apply interfree_aux
-apply safe
-apply(simp add:abbrev)+
-done
-
-lemma interfree_Blacken_Roots_Color_Target:
- "interfree_aux (Some Blacken_Roots, {}, Some Color_Target)"
-apply (unfold modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:Graph7 Graph8 nth_list_update abbrev)
-done
-
-lemma interfree_Color_Target_Blacken_Roots:
- "interfree_aux (Some Color_Target, {}, Some Blacken_Roots)"
-apply (unfold modules )
-apply interfree_aux
-apply safe
-apply(simp add:abbrev)+
-done
-
-lemma interfree_Propagate_Black_Redirect_Edge:
- "interfree_aux (Some Propagate_Black, {}, Some Redirect_Edge)"
-apply (unfold modules )
-apply interfree_aux
---{* 11 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(erule conjE)+
-apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
- apply(erule Graph4)
- apply(simp)+
- apply (simp add:BtoW_def)
- apply (simp add:BtoW_def)
-apply(rule conjI)
- apply (force simp add:BtoW_def)
-apply(erule Graph4)
- apply simp+
---{* 7 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(erule conjE)+
-apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
- apply(erule Graph4)
- apply(simp)+
- apply (simp add:BtoW_def)
- apply (simp add:BtoW_def)
-apply(rule conjI)
- apply (force simp add:BtoW_def)
-apply(erule Graph4)
- apply simp+
---{* 6 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(erule conjE)+
-apply(rule conjI)
- apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
- apply(erule Graph4)
- apply(simp)+
- apply (simp add:BtoW_def)
- apply (simp add:BtoW_def)
- apply(rule conjI)
- apply (force simp add:BtoW_def)
- apply(erule Graph4)
- apply simp+
-apply(simp add:BtoW_def nth_list_update)
-apply force
---{* 5 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12)
---{* 4 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(rule conjI)
- apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
- apply(erule Graph4)
- apply(simp)+
- apply (simp add:BtoW_def)
- apply (simp add:BtoW_def)
- apply(rule conjI)
- apply (force simp add:BtoW_def)
- apply(erule Graph4)
- apply simp+
-apply(rule conjI)
- apply(simp add:nth_list_update)
- apply force
-apply(rule impI, rule impI, erule disjE, erule disjI1, case_tac "R = (ind x)" ,case_tac "M x ! T = Black")
- apply(force simp add:BtoW_def)
- apply(case_tac "M x !snd (E x ! ind x)=Black")
- apply(rule disjI2)
- apply simp
- apply (erule Graph5)
- apply simp+
- apply(force simp add:BtoW_def)
-apply(force simp add:BtoW_def)
---{* 3 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12)
---{* 2 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12)
-apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
- apply clarify
- apply(erule Graph4)
- apply(simp)+
- apply (simp add:BtoW_def)
- apply (simp add:BtoW_def)
-apply(rule conjI)
- apply (force simp add:BtoW_def)
-apply(erule Graph4)
- apply simp+
-done
-
-lemma interfree_Redirect_Edge_Propagate_Black:
- "interfree_aux (Some Redirect_Edge, {}, Some Propagate_Black)"
-apply (unfold modules )
-apply interfree_aux
-apply(clarify, simp add:abbrev)+
-done
-
-lemma interfree_Propagate_Black_Color_Target:
- "interfree_aux (Some Propagate_Black, {}, Some Color_Target)"
-apply (unfold modules )
-apply interfree_aux
---{* 11 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)+
-apply(erule conjE)+
-apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
- case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
- erule allE, erule impE, assumption, erule impE, assumption,
- simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
---{* 7 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
-apply(erule conjE)+
-apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
- case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
- erule allE, erule impE, assumption, erule impE, assumption,
- simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
---{* 6 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
-apply clarify
-apply (rule conjI)
- apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
- case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
- erule allE, erule impE, assumption, erule impE, assumption,
- simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
-apply(simp add:nth_list_update)
---{* 5 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
---{* 4 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
-apply (rule conjI)
- apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
- case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
- erule allE, erule impE, assumption, erule impE, assumption,
- simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
-apply(rule conjI)
-apply(simp add:nth_list_update)
-apply(rule impI,rule impI, case_tac "M x!T=Black",rotate_tac -1, force simp add: BtoW_def Graph10,
- erule subset_psubset_trans, erule Graph11, force)
---{* 3 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
---{* 2 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
-apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
- case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
- erule allE, erule impE, assumption, erule impE, assumption,
- simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
---{* 3 subgoals left *}
-apply(simp add:abbrev)
-done
-
-lemma interfree_Color_Target_Propagate_Black:
- "interfree_aux (Some Color_Target, {}, Some Propagate_Black)"
-apply (unfold modules )
-apply interfree_aux
-apply(clarify, simp add:abbrev)+
-done
-
-lemma interfree_Count_Redirect_Edge:
- "interfree_aux (Some Count, {}, Some Redirect_Edge)"
-apply (unfold modules)
-apply interfree_aux
---{* 9 subgoals left *}
-apply(simp_all add:abbrev Graph6 Graph12)
---{* 6 subgoals left *}
-apply(clarify, simp add:abbrev Graph6 Graph12,
- erule disjE,erule disjI1,rule disjI2,rule subset_trans, erule Graph3,force,force)+
-done
-
-lemma interfree_Redirect_Edge_Count:
- "interfree_aux (Some Redirect_Edge, {}, Some Count)"
-apply (unfold modules )
-apply interfree_aux
-apply(clarify,simp add:abbrev)+
-apply(simp add:abbrev)
-done
-
-lemma interfree_Count_Color_Target:
- "interfree_aux (Some Count, {}, Some Color_Target)"
-apply (unfold modules )
-apply interfree_aux
---{* 9 subgoals left *}
-apply(simp_all add:abbrev Graph7 Graph8 Graph12)
---{* 6 subgoals left *}
-apply(clarify,simp add:abbrev Graph7 Graph8 Graph12,
- erule disjE, erule disjI1, rule disjI2,erule subset_trans, erule Graph9)+
---{* 2 subgoals left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
-apply(rule conjI)
- apply(erule disjE, erule disjI1, rule disjI2,erule subset_trans, erule Graph9)
-apply(simp add:nth_list_update)
---{* 1 subgoal left *}
-apply(clarify, simp add:abbrev Graph7 Graph8 Graph12,
- erule disjE, erule disjI1, rule disjI2,erule subset_trans, erule Graph9)
-done
-
-lemma interfree_Color_Target_Count:
- "interfree_aux (Some Color_Target, {}, Some Count)"
-apply (unfold modules )
-apply interfree_aux
-apply(clarify, simp add:abbrev)+
-apply(simp add:abbrev)
-done
-
-lemma interfree_Append_Redirect_Edge:
- "interfree_aux (Some Append, {}, Some Redirect_Edge)"
-apply (unfold modules )
-apply interfree_aux
-apply( simp_all add:abbrev Graph6 Append_to_free0 Append_to_free1 Graph12)
-apply(clarify, simp add:abbrev Graph6 Append_to_free0 Append_to_free1 Graph12, force dest:Graph3)+
-done
-
-lemma interfree_Redirect_Edge_Append:
- "interfree_aux (Some Redirect_Edge, {}, Some Append)"
-apply (unfold modules )
-apply interfree_aux
-apply(clarify, simp add:abbrev Append_to_free0)+
-apply (force simp add: Append_to_free2)
-apply(clarify, simp add:abbrev Append_to_free0)+
-done
-
-lemma interfree_Append_Color_Target:
- "interfree_aux (Some Append, {}, Some Color_Target)"
-apply (unfold modules )
-apply interfree_aux
-apply(clarify, simp add:abbrev Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12 nth_list_update)+
-apply(simp add:abbrev Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12 nth_list_update)
-done
-
-lemma interfree_Color_Target_Append:
- "interfree_aux (Some Color_Target, {}, Some Append)"
-apply (unfold modules )
-apply interfree_aux
-apply(clarify, simp add:abbrev Append_to_free0)+
-apply (force simp add: Append_to_free2)
-apply(clarify,simp add:abbrev Append_to_free0)+
-done
-
-lemmas collector_mutator_interfree =
- interfree_Blacken_Roots_Redirect_Edge interfree_Blacken_Roots_Color_Target
- interfree_Propagate_Black_Redirect_Edge interfree_Propagate_Black_Color_Target
- interfree_Count_Redirect_Edge interfree_Count_Color_Target
- interfree_Append_Redirect_Edge interfree_Append_Color_Target
- interfree_Redirect_Edge_Blacken_Roots interfree_Color_Target_Blacken_Roots
- interfree_Redirect_Edge_Propagate_Black interfree_Color_Target_Propagate_Black
- interfree_Redirect_Edge_Count interfree_Color_Target_Count
- interfree_Redirect_Edge_Append interfree_Color_Target_Append
-
-subsubsection {* Interference freedom Collector-Mutator *}
-
-lemma interfree_Collector_Mutator:
- "interfree_aux (Some Collector, {}, Some Mutator)"
-apply(unfold Collector_def Mutator_def)
-apply interfree_aux
-apply(simp_all add:collector_mutator_interfree)
-apply(unfold modules collector_defs mutator_defs)
-apply(tactic {* TRYALL (interfree_aux_tac) *})
---{* 32 subgoals left *}
-apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
---{* 20 subgoals left *}
-apply(tactic{* TRYALL (clarify_tac @{claset}) *})
-apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
-apply(tactic {* TRYALL (etac disjE) *})
-apply simp_all
-apply(tactic {* TRYALL(EVERY'[rtac disjI2,rtac subset_trans,etac @{thm Graph3},force_tac @{clasimpset}, assume_tac]) *})
-apply(tactic {* TRYALL(EVERY'[rtac disjI2,etac subset_trans,rtac @{thm Graph9},force_tac @{clasimpset}]) *})
-apply(tactic {* TRYALL(EVERY'[rtac disjI1,etac @{thm psubset_subset_trans},rtac @{thm Graph9},force_tac @{clasimpset}]) *})
-done
-
-subsubsection {* Interference freedom Mutator-Collector *}
-
-lemma interfree_Mutator_Collector:
- "interfree_aux (Some Mutator, {}, Some Collector)"
-apply(unfold Collector_def Mutator_def)
-apply interfree_aux
-apply(simp_all add:collector_mutator_interfree)
-apply(unfold modules collector_defs mutator_defs)
-apply(tactic {* TRYALL (interfree_aux_tac) *})
---{* 64 subgoals left *}
-apply(simp_all add:nth_list_update Invariants Append_to_free0)+
-apply(tactic{* TRYALL (clarify_tac @{claset}) *})
---{* 4 subgoals left *}
-apply force
-apply(simp add:Append_to_free2)
-apply force
-apply(simp add:Append_to_free2)
-done
-
-subsubsection {* The Garbage Collection algorithm *}
-
-text {* In total there are 289 verification conditions. *}
-
-lemma Gar_Coll:
- "\<parallel>- .{\<acute>Proper \<and> \<acute>Mut_init \<and> \<acute>z}.
- COBEGIN
- Collector
- .{False}.
- \<parallel>
- Mutator
- .{False}.
- COEND
- .{False}."
-apply oghoare
-apply(force simp add: Mutator_def Collector_def modules)
-apply(rule Collector)
-apply(rule Mutator)
-apply(simp add:interfree_Collector_Mutator)
-apply(simp add:interfree_Mutator_Collector)
-apply force
-done
-
-end
--- a/src/HOL/HoareParallel/Graph.thy Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,410 +0,0 @@
-header {* \chapter{Case Study: Single and Multi-Mutator Garbage Collection Algorithms}
-
-\section {Formalization of the Memory} *}
-
-theory Graph imports Main begin
-
-datatype node = Black | White
-
-types
- nodes = "node list"
- edge = "nat \<times> nat"
- edges = "edge list"
-
-consts Roots :: "nat set"
-
-constdefs
- Proper_Roots :: "nodes \<Rightarrow> bool"
- "Proper_Roots M \<equiv> Roots\<noteq>{} \<and> Roots \<subseteq> {i. i<length M}"
-
- Proper_Edges :: "(nodes \<times> edges) \<Rightarrow> bool"
- "Proper_Edges \<equiv> (\<lambda>(M,E). \<forall>i<length E. fst(E!i)<length M \<and> snd(E!i)<length M)"
-
- BtoW :: "(edge \<times> nodes) \<Rightarrow> bool"
- "BtoW \<equiv> (\<lambda>(e,M). (M!fst e)=Black \<and> (M!snd e)\<noteq>Black)"
-
- Blacks :: "nodes \<Rightarrow> nat set"
- "Blacks M \<equiv> {i. i<length M \<and> M!i=Black}"
-
- Reach :: "edges \<Rightarrow> nat set"
- "Reach E \<equiv> {x. (\<exists>path. 1<length path \<and> path!(length path - 1)\<in>Roots \<and> x=path!0
- \<and> (\<forall>i<length path - 1. (\<exists>j<length E. E!j=(path!(i+1), path!i))))
- \<or> x\<in>Roots}"
-
-text{* Reach: the set of reachable nodes is the set of Roots together with the
-nodes reachable from some Root by a path represented by a list of
- nodes (at least two since we traverse at least one edge), where two
-consecutive nodes correspond to an edge in E. *}
-
-subsection {* Proofs about Graphs *}
-
-lemmas Graph_defs= Blacks_def Proper_Roots_def Proper_Edges_def BtoW_def
-declare Graph_defs [simp]
-
-subsubsection{* Graph 1 *}
-
-lemma Graph1_aux [rule_format]:
- "\<lbrakk> Roots\<subseteq>Blacks M; \<forall>i<length E. \<not>BtoW(E!i,M)\<rbrakk>
- \<Longrightarrow> 1< length path \<longrightarrow> (path!(length path - 1))\<in>Roots \<longrightarrow>
- (\<forall>i<length path - 1. (\<exists>j. j < length E \<and> E!j=(path!(Suc i), path!i)))
- \<longrightarrow> M!(path!0) = Black"
-apply(induct_tac "path")
- apply force
-apply clarify
-apply simp
-apply(case_tac "list")
- apply force
-apply simp
-apply(rotate_tac -2)
-apply(erule_tac x = "0" in all_dupE)
-apply simp
-apply clarify
-apply(erule allE , erule (1) notE impE)
-apply simp
-apply(erule mp)
-apply(case_tac "lista")
- apply force
-apply simp
-apply(erule mp)
-apply clarify
-apply(erule_tac x = "Suc i" in allE)
-apply force
-done
-
-lemma Graph1:
- "\<lbrakk>Roots\<subseteq>Blacks M; Proper_Edges(M, E); \<forall>i<length E. \<not>BtoW(E!i,M) \<rbrakk>
- \<Longrightarrow> Reach E\<subseteq>Blacks M"
-apply (unfold Reach_def)
-apply simp
-apply clarify
-apply(erule disjE)
- apply clarify
- apply(rule conjI)
- apply(subgoal_tac "0< length path - Suc 0")
- apply(erule allE , erule (1) notE impE)
- apply force
- apply simp
- apply(rule Graph1_aux)
-apply auto
-done
-
-subsubsection{* Graph 2 *}
-
-lemma Ex_first_occurrence [rule_format]:
- "P (n::nat) \<longrightarrow> (\<exists>m. P m \<and> (\<forall>i. i<m \<longrightarrow> \<not> P i))";
-apply(rule nat_less_induct)
-apply clarify
-apply(case_tac "\<forall>m. m<n \<longrightarrow> \<not> P m")
-apply auto
-done
-
-lemma Compl_lemma: "(n::nat)\<le>l \<Longrightarrow> (\<exists>m. m\<le>l \<and> n=l - m)"
-apply(rule_tac x = "l - n" in exI)
-apply arith
-done
-
-lemma Ex_last_occurrence:
- "\<lbrakk>P (n::nat); n\<le>l\<rbrakk> \<Longrightarrow> (\<exists>m. P (l - m) \<and> (\<forall>i. i<m \<longrightarrow> \<not>P (l - i)))"
-apply(drule Compl_lemma)
-apply clarify
-apply(erule Ex_first_occurrence)
-done
-
-lemma Graph2:
- "\<lbrakk>T \<in> Reach E; R<length E\<rbrakk> \<Longrightarrow> T \<in> Reach (E[R:=(fst(E!R), T)])"
-apply (unfold Reach_def)
-apply clarify
-apply simp
-apply(case_tac "\<forall>z<length path. fst(E!R)\<noteq>path!z")
- apply(rule_tac x = "path" in exI)
- apply simp
- apply clarify
- apply(erule allE , erule (1) notE impE)
- apply clarify
- apply(rule_tac x = "j" in exI)
- apply(case_tac "j=R")
- apply(erule_tac x = "Suc i" in allE)
- apply simp
- apply (force simp add:nth_list_update)
-apply simp
-apply(erule exE)
-apply(subgoal_tac "z \<le> length path - Suc 0")
- prefer 2 apply arith
-apply(drule_tac P = "\<lambda>m. m<length path \<and> fst(E!R)=path!m" in Ex_last_occurrence)
- apply assumption
-apply clarify
-apply simp
-apply(rule_tac x = "(path!0)#(drop (length path - Suc m) path)" in exI)
-apply simp
-apply(case_tac "length path - (length path - Suc m)")
- apply arith
-apply simp
-apply(subgoal_tac "(length path - Suc m) + nat \<le> length path")
- prefer 2 apply arith
-apply(drule nth_drop)
-apply simp
-apply(subgoal_tac "length path - Suc m + nat = length path - Suc 0")
- prefer 2 apply arith
-apply simp
-apply clarify
-apply(case_tac "i")
- apply(force simp add: nth_list_update)
-apply simp
-apply(subgoal_tac "(length path - Suc m) + nata \<le> length path")
- prefer 2 apply arith
-apply(subgoal_tac "(length path - Suc m) + (Suc nata) \<le> length path")
- prefer 2 apply arith
-apply simp
-apply(erule_tac x = "length path - Suc m + nata" in allE)
-apply simp
-apply clarify
-apply(rule_tac x = "j" in exI)
-apply(case_tac "R=j")
- prefer 2 apply force
-apply simp
-apply(drule_tac t = "path ! (length path - Suc m)" in sym)
-apply simp
-apply(case_tac " length path - Suc 0 < m")
- apply(subgoal_tac "(length path - Suc m)=0")
- prefer 2 apply arith
- apply(simp del: diff_is_0_eq)
- apply(subgoal_tac "Suc nata\<le>nat")
- prefer 2 apply arith
- apply(drule_tac n = "Suc nata" in Compl_lemma)
- apply clarify
- using [[linarith_split_limit = 0]]
- apply force
- using [[linarith_split_limit = 9]]
-apply(drule leI)
-apply(subgoal_tac "Suc (length path - Suc m + nata)=(length path - Suc 0) - (m - Suc nata)")
- apply(erule_tac x = "m - (Suc nata)" in allE)
- apply(case_tac "m")
- apply simp
- apply simp
-apply simp
-done
-
-
-subsubsection{* Graph 3 *}
-
-lemma Graph3:
- "\<lbrakk> T\<in>Reach E; R<length E \<rbrakk> \<Longrightarrow> Reach(E[R:=(fst(E!R),T)]) \<subseteq> Reach E"
-apply (unfold Reach_def)
-apply clarify
-apply simp
-apply(case_tac "\<exists>i<length path - 1. (fst(E!R),T)=(path!(Suc i),path!i)")
---{* the changed edge is part of the path *}
- apply(erule exE)
- apply(drule_tac P = "\<lambda>i. i<length path - 1 \<and> (fst(E!R),T)=(path!Suc i,path!i)" in Ex_first_occurrence)
- apply clarify
- apply(erule disjE)
---{* T is NOT a root *}
- apply clarify
- apply(rule_tac x = "(take m path)@patha" in exI)
- apply(subgoal_tac "\<not>(length path\<le>m)")
- prefer 2 apply arith
- apply(simp)
- apply(rule conjI)
- apply(subgoal_tac "\<not>(m + length patha - 1 < m)")
- prefer 2 apply arith
- apply(simp add: nth_append)
- apply(rule conjI)
- apply(case_tac "m")
- apply force
- apply(case_tac "path")
- apply force
- apply force
- apply clarify
- apply(case_tac "Suc i\<le>m")
- apply(erule_tac x = "i" in allE)
- apply simp
- apply clarify
- apply(rule_tac x = "j" in exI)
- apply(case_tac "Suc i<m")
- apply(simp add: nth_append)
- apply(case_tac "R=j")
- apply(simp add: nth_list_update)
- apply(case_tac "i=m")
- apply force
- apply(erule_tac x = "i" in allE)
- apply force
- apply(force simp add: nth_list_update)
- apply(simp add: nth_append)
- apply(subgoal_tac "i=m - 1")
- prefer 2 apply arith
- apply(case_tac "R=j")
- apply(erule_tac x = "m - 1" in allE)
- apply(simp add: nth_list_update)
- apply(force simp add: nth_list_update)
- apply(simp add: nth_append)
- apply(rotate_tac -4)
- apply(erule_tac x = "i - m" in allE)
- apply(subgoal_tac "Suc (i - m)=(Suc i - m)" )
- prefer 2 apply arith
- apply simp
---{* T is a root *}
- apply(case_tac "m=0")
- apply force
- apply(rule_tac x = "take (Suc m) path" in exI)
- apply(subgoal_tac "\<not>(length path\<le>Suc m)" )
- prefer 2 apply arith
- apply clarsimp
- apply(erule_tac x = "i" in allE)
- apply simp
- apply clarify
- apply(case_tac "R=j")
- apply(force simp add: nth_list_update)
- apply(force simp add: nth_list_update)
---{* the changed edge is not part of the path *}
-apply(rule_tac x = "path" in exI)
-apply simp
-apply clarify
-apply(erule_tac x = "i" in allE)
-apply clarify
-apply(case_tac "R=j")
- apply(erule_tac x = "i" in allE)
- apply simp
-apply(force simp add: nth_list_update)
-done
-
-subsubsection{* Graph 4 *}
-
-lemma Graph4:
- "\<lbrakk>T \<in> Reach E; Roots\<subseteq>Blacks M; I\<le>length E; T<length M; R<length E;
- \<forall>i<I. \<not>BtoW(E!i,M); R<I; M!fst(E!R)=Black; M!T\<noteq>Black\<rbrakk> \<Longrightarrow>
- (\<exists>r. I\<le>r \<and> r<length E \<and> BtoW(E[R:=(fst(E!R),T)]!r,M))"
-apply (unfold Reach_def)
-apply simp
-apply(erule disjE)
- prefer 2 apply force
-apply clarify
---{* there exist a black node in the path to T *}
-apply(case_tac "\<exists>m<length path. M!(path!m)=Black")
- apply(erule exE)
- apply(drule_tac P = "\<lambda>m. m<length path \<and> M!(path!m)=Black" in Ex_first_occurrence)
- apply clarify
- apply(case_tac "ma")
- apply force
- apply simp
- apply(case_tac "length path")
- apply force
- apply simp
- apply(erule_tac P = "\<lambda>i. i < nata \<longrightarrow> ?P i" and x = "nat" in allE)
- apply simp
- apply clarify
- apply(erule_tac P = "\<lambda>i. i < Suc nat \<longrightarrow> ?P i" and x = "nat" in allE)
- apply simp
- apply(case_tac "j<I")
- apply(erule_tac x = "j" in allE)
- apply force
- apply(rule_tac x = "j" in exI)
- apply(force simp add: nth_list_update)
-apply simp
-apply(rotate_tac -1)
-apply(erule_tac x = "length path - 1" in allE)
-apply(case_tac "length path")
- apply force
-apply force
-done
-
-subsubsection {* Graph 5 *}
-
-lemma Graph5:
- "\<lbrakk> T \<in> Reach E ; Roots \<subseteq> Blacks M; \<forall>i<R. \<not>BtoW(E!i,M); T<length M;
- R<length E; M!fst(E!R)=Black; M!snd(E!R)=Black; M!T \<noteq> Black\<rbrakk>
- \<Longrightarrow> (\<exists>r. R<r \<and> r<length E \<and> BtoW(E[R:=(fst(E!R),T)]!r,M))"
-apply (unfold Reach_def)
-apply simp
-apply(erule disjE)
- prefer 2 apply force
-apply clarify
---{* there exist a black node in the path to T*}
-apply(case_tac "\<exists>m<length path. M!(path!m)=Black")
- apply(erule exE)
- apply(drule_tac P = "\<lambda>m. m<length path \<and> M!(path!m)=Black" in Ex_first_occurrence)
- apply clarify
- apply(case_tac "ma")
- apply force
- apply simp
- apply(case_tac "length path")
- apply force
- apply simp
- apply(erule_tac P = "\<lambda>i. i < nata \<longrightarrow> ?P i" and x = "nat" in allE)
- apply simp
- apply clarify
- apply(erule_tac P = "\<lambda>i. i < Suc nat \<longrightarrow> ?P i" and x = "nat" in allE)
- apply simp
- apply(case_tac "j\<le>R")
- apply(drule le_imp_less_or_eq [of _ R])
- apply(erule disjE)
- apply(erule allE , erule (1) notE impE)
- apply force
- apply force
- apply(rule_tac x = "j" in exI)
- apply(force simp add: nth_list_update)
-apply simp
-apply(rotate_tac -1)
-apply(erule_tac x = "length path - 1" in allE)
-apply(case_tac "length path")
- apply force
-apply force
-done
-
-subsubsection {* Other lemmas about graphs *}
-
-lemma Graph6:
- "\<lbrakk>Proper_Edges(M,E); R<length E ; T<length M\<rbrakk> \<Longrightarrow> Proper_Edges(M,E[R:=(fst(E!R),T)])"
-apply (unfold Proper_Edges_def)
- apply(force simp add: nth_list_update)
-done
-
-lemma Graph7:
- "\<lbrakk>Proper_Edges(M,E)\<rbrakk> \<Longrightarrow> Proper_Edges(M[T:=a],E)"
-apply (unfold Proper_Edges_def)
-apply force
-done
-
-lemma Graph8:
- "\<lbrakk>Proper_Roots(M)\<rbrakk> \<Longrightarrow> Proper_Roots(M[T:=a])"
-apply (unfold Proper_Roots_def)
-apply force
-done
-
-text{* Some specific lemmata for the verification of garbage collection algorithms. *}
-
-lemma Graph9: "j<length M \<Longrightarrow> Blacks M\<subseteq>Blacks (M[j := Black])"
-apply (unfold Blacks_def)
- apply(force simp add: nth_list_update)
-done
-
-lemma Graph10 [rule_format (no_asm)]: "\<forall>i. M!i=a \<longrightarrow>M[i:=a]=M"
-apply(induct_tac "M")
-apply auto
-apply(case_tac "i")
-apply auto
-done
-
-lemma Graph11 [rule_format (no_asm)]:
- "\<lbrakk> M!j\<noteq>Black;j<length M\<rbrakk> \<Longrightarrow> Blacks M \<subset> Blacks (M[j := Black])"
-apply (unfold Blacks_def)
-apply(rule psubsetI)
- apply(force simp add: nth_list_update)
-apply safe
-apply(erule_tac c = "j" in equalityCE)
-apply auto
-done
-
-lemma Graph12: "\<lbrakk>a\<subseteq>Blacks M;j<length M\<rbrakk> \<Longrightarrow> a\<subseteq>Blacks (M[j := Black])"
-apply (unfold Blacks_def)
-apply(force simp add: nth_list_update)
-done
-
-lemma Graph13: "\<lbrakk>a\<subset> Blacks M;j<length M\<rbrakk> \<Longrightarrow> a \<subset> Blacks (M[j := Black])"
-apply (unfold Blacks_def)
-apply(erule psubset_subset_trans)
-apply(force simp add: nth_list_update)
-done
-
-declare Graph_defs [simp del]
-
-end
--- a/src/HOL/HoareParallel/Mul_Gar_Coll.thy Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1283 +0,0 @@
-
-header {* \section{The Multi-Mutator Case} *}
-
-theory Mul_Gar_Coll imports Graph OG_Syntax begin
-
-text {* The full theory takes aprox. 18 minutes. *}
-
-record mut =
- Z :: bool
- R :: nat
- T :: nat
-
-text {* Declaration of variables: *}
-
-record mul_gar_coll_state =
- M :: nodes
- E :: edges
- bc :: "nat set"
- obc :: "nat set"
- Ma :: nodes
- ind :: nat
- k :: nat
- q :: nat
- l :: nat
- Muts :: "mut list"
-
-subsection {* The Mutators *}
-
-constdefs
- Mul_mut_init :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
- "Mul_mut_init \<equiv> \<guillemotleft> \<lambda>n. n=length \<acute>Muts \<and> (\<forall>i<n. R (\<acute>Muts!i)<length \<acute>E
- \<and> T (\<acute>Muts!i)<length \<acute>M) \<guillemotright>"
-
- Mul_Redirect_Edge :: "nat \<Rightarrow> nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Redirect_Edge j n \<equiv>
- .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}.
- \<langle>IF T(\<acute>Muts!j) \<in> Reach \<acute>E THEN
- \<acute>E:= \<acute>E[R (\<acute>Muts!j):= (fst (\<acute>E!R(\<acute>Muts!j)), T (\<acute>Muts!j))] FI,,
- \<acute>Muts:= \<acute>Muts[j:= (\<acute>Muts!j) \<lparr>Z:=False\<rparr>]\<rangle>"
-
- Mul_Color_Target :: "nat \<Rightarrow> nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Color_Target j n \<equiv>
- .{\<acute>Mul_mut_init n \<and> \<not> Z (\<acute>Muts!j)}.
- \<langle>\<acute>M:=\<acute>M[T (\<acute>Muts!j):=Black],, \<acute>Muts:=\<acute>Muts[j:= (\<acute>Muts!j) \<lparr>Z:=True\<rparr>]\<rangle>"
-
- Mul_Mutator :: "nat \<Rightarrow> nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Mutator j n \<equiv>
- .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}.
- WHILE True
- INV .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}.
- DO Mul_Redirect_Edge j n ;;
- Mul_Color_Target j n
- OD"
-
-lemmas mul_mutator_defs = Mul_mut_init_def Mul_Redirect_Edge_def Mul_Color_Target_def
-
-subsubsection {* Correctness of the proof outline of one mutator *}
-
-lemma Mul_Redirect_Edge: "0\<le>j \<and> j<n \<Longrightarrow>
- \<turnstile> Mul_Redirect_Edge j n
- pre(Mul_Color_Target j n)"
-apply (unfold mul_mutator_defs)
-apply annhoare
-apply(simp_all)
-apply clarify
-apply(simp add:nth_list_update)
-done
-
-lemma Mul_Color_Target: "0\<le>j \<and> j<n \<Longrightarrow>
- \<turnstile> Mul_Color_Target j n
- .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}."
-apply (unfold mul_mutator_defs)
-apply annhoare
-apply(simp_all)
-apply clarify
-apply(simp add:nth_list_update)
-done
-
-lemma Mul_Mutator: "0\<le>j \<and> j<n \<Longrightarrow>
- \<turnstile> Mul_Mutator j n .{False}."
-apply(unfold Mul_Mutator_def)
-apply annhoare
-apply(simp_all add:Mul_Redirect_Edge Mul_Color_Target)
-apply(simp add:mul_mutator_defs Mul_Redirect_Edge_def)
-done
-
-subsubsection {* Interference freedom between mutators *}
-
-lemma Mul_interfree_Redirect_Edge_Redirect_Edge:
- "\<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
- interfree_aux (Some (Mul_Redirect_Edge i n),{}, Some(Mul_Redirect_Edge j n))"
-apply (unfold mul_mutator_defs)
-apply interfree_aux
-apply safe
-apply(simp_all add: nth_list_update)
-done
-
-lemma Mul_interfree_Redirect_Edge_Color_Target:
- "\<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
- interfree_aux (Some(Mul_Redirect_Edge i n),{},Some(Mul_Color_Target j n))"
-apply (unfold mul_mutator_defs)
-apply interfree_aux
-apply safe
-apply(simp_all add: nth_list_update)
-done
-
-lemma Mul_interfree_Color_Target_Redirect_Edge:
- "\<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
- interfree_aux (Some(Mul_Color_Target i n),{},Some(Mul_Redirect_Edge j n))"
-apply (unfold mul_mutator_defs)
-apply interfree_aux
-apply safe
-apply(simp_all add:nth_list_update)
-done
-
-lemma Mul_interfree_Color_Target_Color_Target:
- " \<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
- interfree_aux (Some(Mul_Color_Target i n),{},Some(Mul_Color_Target j n))"
-apply (unfold mul_mutator_defs)
-apply interfree_aux
-apply safe
-apply(simp_all add: nth_list_update)
-done
-
-lemmas mul_mutator_interfree =
- Mul_interfree_Redirect_Edge_Redirect_Edge Mul_interfree_Redirect_Edge_Color_Target
- Mul_interfree_Color_Target_Redirect_Edge Mul_interfree_Color_Target_Color_Target
-
-lemma Mul_interfree_Mutator_Mutator: "\<lbrakk>i < n; j < n; i \<noteq> j\<rbrakk> \<Longrightarrow>
- interfree_aux (Some (Mul_Mutator i n), {}, Some (Mul_Mutator j n))"
-apply(unfold Mul_Mutator_def)
-apply(interfree_aux)
-apply(simp_all add:mul_mutator_interfree)
-apply(simp_all add: mul_mutator_defs)
-apply(tactic {* TRYALL (interfree_aux_tac) *})
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
-apply (simp_all add:nth_list_update)
-done
-
-subsubsection {* Modular Parameterized Mutators *}
-
-lemma Mul_Parameterized_Mutators: "0<n \<Longrightarrow>
- \<parallel>- .{\<acute>Mul_mut_init n \<and> (\<forall>i<n. Z (\<acute>Muts!i))}.
- COBEGIN
- SCHEME [0\<le> j< n]
- Mul_Mutator j n
- .{False}.
- COEND
- .{False}."
-apply oghoare
-apply(force simp add:Mul_Mutator_def mul_mutator_defs nth_list_update)
-apply(erule Mul_Mutator)
-apply(simp add:Mul_interfree_Mutator_Mutator)
-apply(force simp add:Mul_Mutator_def mul_mutator_defs nth_list_update)
-done
-
-subsection {* The Collector *}
-
-constdefs
- Queue :: "mul_gar_coll_state \<Rightarrow> nat"
- "Queue \<equiv> \<guillemotleft> length (filter (\<lambda>i. \<not> Z i \<and> \<acute>M!(T i) \<noteq> Black) \<acute>Muts) \<guillemotright>"
-
-consts M_init :: nodes
-
-constdefs
- Proper_M_init :: "mul_gar_coll_state \<Rightarrow> bool"
- "Proper_M_init \<equiv> \<guillemotleft> Blacks M_init=Roots \<and> length M_init=length \<acute>M \<guillemotright>"
-
- Mul_Proper :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
- "Mul_Proper \<equiv> \<guillemotleft> \<lambda>n. Proper_Roots \<acute>M \<and> Proper_Edges (\<acute>M, \<acute>E) \<and> \<acute>Proper_M_init \<and> n=length \<acute>Muts \<guillemotright>"
-
- Safe :: "mul_gar_coll_state \<Rightarrow> bool"
- "Safe \<equiv> \<guillemotleft> Reach \<acute>E \<subseteq> Blacks \<acute>M \<guillemotright>"
-
-lemmas mul_collector_defs = Proper_M_init_def Mul_Proper_def Safe_def
-
-subsubsection {* Blackening Roots *}
-
-constdefs
- Mul_Blacken_Roots :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Blacken_Roots n \<equiv>
- .{\<acute>Mul_Proper n}.
- \<acute>ind:=0;;
- .{\<acute>Mul_Proper n \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>M
- INV .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind\<le>length \<acute>M}.
- DO .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
- IF \<acute>ind\<in>Roots THEN
- .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<in>Roots}.
- \<acute>M:=\<acute>M[\<acute>ind:=Black] FI;;
- .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind+1. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
- \<acute>ind:=\<acute>ind+1
- OD"
-
-lemma Mul_Blacken_Roots:
- "\<turnstile> Mul_Blacken_Roots n
- .{\<acute>Mul_Proper n \<and> Roots \<subseteq> Blacks \<acute>M}."
-apply (unfold Mul_Blacken_Roots_def)
-apply annhoare
-apply(simp_all add:mul_collector_defs Graph_defs)
-apply safe
-apply(simp_all add:nth_list_update)
- apply (erule less_SucE)
- apply simp+
- apply force
-apply force
-done
-
-subsubsection {* Propagating Black *}
-
-constdefs
- Mul_PBInv :: "mul_gar_coll_state \<Rightarrow> bool"
- "Mul_PBInv \<equiv> \<guillemotleft>\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue
- \<or> (\<forall>i<\<acute>ind. \<not>BtoW(\<acute>E!i,\<acute>M)) \<and> \<acute>l\<le>\<acute>Queue\<guillemotright>"
-
- Mul_Auxk :: "mul_gar_coll_state \<Rightarrow> bool"
- "Mul_Auxk \<equiv> \<guillemotleft>\<acute>l<\<acute>Queue \<or> \<acute>M!\<acute>k\<noteq>Black \<or> \<not>BtoW(\<acute>E!\<acute>ind, \<acute>M) \<or> \<acute>obc\<subset>Blacks \<acute>M\<guillemotright>"
-
-constdefs
- Mul_Propagate_Black :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Propagate_Black n \<equiv>
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M)}.
- \<acute>ind:=0;;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> Blacks \<acute>M\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M) \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>E
- INV .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>Mul_PBInv \<and> \<acute>ind\<le>length \<acute>E}.
- DO .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>Mul_PBInv \<and> \<acute>ind<length \<acute>E}.
- IF \<acute>M!(fst (\<acute>E!\<acute>ind))=Black THEN
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>Mul_PBInv \<and> (\<acute>M!fst(\<acute>E!\<acute>ind))=Black \<and> \<acute>ind<length \<acute>E}.
- \<acute>k:=snd(\<acute>E!\<acute>ind);;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue \<or> (\<forall>i<\<acute>ind. \<not>BtoW(\<acute>E!i,\<acute>M))
- \<and> \<acute>l\<le>\<acute>Queue \<and> \<acute>Mul_Auxk ) \<and> \<acute>k<length \<acute>M \<and> \<acute>M!fst(\<acute>E!\<acute>ind)=Black
- \<and> \<acute>ind<length \<acute>E}.
- \<langle>\<acute>M:=\<acute>M[\<acute>k:=Black],,\<acute>ind:=\<acute>ind+1\<rangle>
- ELSE .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> \<acute>Mul_PBInv \<and> \<acute>ind<length \<acute>E}.
- \<langle>IF \<acute>M!(fst (\<acute>E!\<acute>ind))\<noteq>Black THEN \<acute>ind:=\<acute>ind+1 FI\<rangle> FI
- OD"
-
-lemma Mul_Propagate_Black:
- "\<turnstile> Mul_Propagate_Black n
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue \<and> (\<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))}."
-apply(unfold Mul_Propagate_Black_def)
-apply annhoare
-apply(simp_all add:Mul_PBInv_def mul_collector_defs Mul_Auxk_def Graph6 Graph7 Graph8 Graph12 mul_collector_defs Queue_def)
---{* 8 subgoals left *}
-apply force
-apply force
-apply force
-apply(force simp add:BtoW_def Graph_defs)
---{* 4 subgoals left *}
-apply clarify
-apply(simp add: mul_collector_defs Graph12 Graph6 Graph7 Graph8)
-apply(disjE_tac)
- apply(simp_all add:Graph12 Graph13)
- apply(case_tac "M x! k x=Black")
- apply(simp add: Graph10)
- apply(rule disjI2, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
-apply(case_tac "M x! k x=Black")
- apply(simp add: Graph10 BtoW_def)
- apply(rule disjI2, clarify, erule less_SucE, force)
- apply(case_tac "M x!snd(E x! ind x)=Black")
- apply(force)
- apply(force)
-apply(rule disjI2, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
---{* 3 subgoals left *}
-apply force
---{* 2 subgoals left *}
-apply clarify
-apply(conjI_tac)
-apply(disjE_tac)
- apply (simp_all)
-apply clarify
-apply(erule less_SucE)
- apply force
-apply (simp add:BtoW_def)
---{* 1 subgoal left *}
-apply clarify
-apply simp
-apply(disjE_tac)
-apply (simp_all)
-apply(rule disjI1 , rule Graph1)
- apply simp_all
-done
-
-subsubsection {* Counting Black Nodes *}
-
-constdefs
- Mul_CountInv :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
- "Mul_CountInv \<equiv> \<guillemotleft> \<lambda>ind. {i. i<ind \<and> \<acute>Ma!i=Black}\<subseteq>\<acute>bc \<guillemotright>"
-
- Mul_Count :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Count n \<equiv>
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M) )
- \<and> \<acute>q<n+1 \<and> \<acute>bc={}}.
- \<acute>ind:=0;;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M) )
- \<and> \<acute>q<n+1 \<and> \<acute>bc={} \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>M
- INV .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv \<acute>ind
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1 \<and> \<acute>ind\<le>length \<acute>M}.
- DO .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv \<acute>ind
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1 \<and> \<acute>ind<length \<acute>M}.
- IF \<acute>M!\<acute>ind=Black
- THEN .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv \<acute>ind
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1 \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
- \<acute>bc:=insert \<acute>ind \<acute>bc
- FI;;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv (\<acute>ind+1)
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1 \<and> \<acute>ind<length \<acute>M}.
- \<acute>ind:=\<acute>ind+1
- OD"
-
-lemma Mul_Count:
- "\<turnstile> Mul_Count n
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1}."
-apply (unfold Mul_Count_def)
-apply annhoare
-apply(simp_all add:Mul_CountInv_def mul_collector_defs Mul_Auxk_def Graph6 Graph7 Graph8 Graph12 mul_collector_defs Queue_def)
---{* 7 subgoals left *}
-apply force
-apply force
-apply force
---{* 4 subgoals left *}
-apply clarify
-apply(conjI_tac)
-apply(disjE_tac)
- apply simp_all
-apply(simp add:Blacks_def)
-apply clarify
-apply(erule less_SucE)
- back
- apply force
-apply force
---{* 3 subgoals left *}
-apply clarify
-apply(conjI_tac)
-apply(disjE_tac)
- apply simp_all
-apply clarify
-apply(erule less_SucE)
- back
- apply force
-apply simp
-apply(rotate_tac -1)
-apply (force simp add:Blacks_def)
---{* 2 subgoals left *}
-apply force
---{* 1 subgoal left *}
-apply clarify
-apply(drule_tac x = "ind x" in le_imp_less_or_eq)
-apply (simp_all add:Blacks_def)
-done
-
-subsubsection {* Appending garbage nodes to the free list *}
-
-consts Append_to_free :: "nat \<times> edges \<Rightarrow> edges"
-
-axioms
- Append_to_free0: "length (Append_to_free (i, e)) = length e"
- Append_to_free1: "Proper_Edges (m, e)
- \<Longrightarrow> Proper_Edges (m, Append_to_free(i, e))"
- Append_to_free2: "i \<notin> Reach e
- \<Longrightarrow> n \<in> Reach (Append_to_free(i, e)) = ( n = i \<or> n \<in> Reach e)"
-
-constdefs
- Mul_AppendInv :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
- "Mul_AppendInv \<equiv> \<guillemotleft> \<lambda>ind. (\<forall>i. ind\<le>i \<longrightarrow> i<length \<acute>M \<longrightarrow> i\<in>Reach \<acute>E \<longrightarrow> \<acute>M!i=Black)\<guillemotright>"
-
- Mul_Append :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Append n \<equiv>
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe}.
- \<acute>ind:=0;;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe \<and> \<acute>ind=0}.
- WHILE \<acute>ind<length \<acute>M
- INV .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>M}.
- DO .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M}.
- IF \<acute>M!\<acute>ind=Black THEN
- .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
- \<acute>M:=\<acute>M[\<acute>ind:=White]
- ELSE
- .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<notin>Reach \<acute>E}.
- \<acute>E:=Append_to_free(\<acute>ind,\<acute>E)
- FI;;
- .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv (\<acute>ind+1) \<and> \<acute>ind<length \<acute>M}.
- \<acute>ind:=\<acute>ind+1
- OD"
-
-lemma Mul_Append:
- "\<turnstile> Mul_Append n
- .{\<acute>Mul_Proper n}."
-apply(unfold Mul_Append_def)
-apply annhoare
-apply(simp_all add: mul_collector_defs Mul_AppendInv_def
- Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
-apply(force simp add:Blacks_def)
-apply(force simp add:Blacks_def)
-apply(force simp add:Blacks_def)
-apply(force simp add:Graph_defs)
-apply force
-apply(force simp add:Append_to_free1 Append_to_free2)
-apply force
-apply force
-done
-
-subsubsection {* Collector *}
-
-constdefs
- Mul_Collector :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
- "Mul_Collector n \<equiv>
-.{\<acute>Mul_Proper n}.
-WHILE True INV .{\<acute>Mul_Proper n}.
-DO
-Mul_Blacken_Roots n ;;
-.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M}.
- \<acute>obc:={};;
-.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={}}.
- \<acute>bc:=Roots;;
-.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots}.
- \<acute>l:=0;;
-.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots \<and> \<acute>l=0}.
- WHILE \<acute>l<n+1
- INV .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and>
- (\<acute>Safe \<or> (\<acute>l\<le>\<acute>Queue \<or> \<acute>bc\<subset>Blacks \<acute>M) \<and> \<acute>l<n+1)}.
- DO .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>l\<le>\<acute>Queue \<or> \<acute>bc\<subset>Blacks \<acute>M)}.
- \<acute>obc:=\<acute>bc;;
- Mul_Propagate_Black n;;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue
- \<and> (\<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))}.
- \<acute>bc:={};;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue
- \<and> (\<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M)) \<and> \<acute>bc={}}.
- \<langle> \<acute>Ma:=\<acute>M,, \<acute>q:=\<acute>Queue \<rangle>;;
- Mul_Count n;;
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1}.
- IF \<acute>obc=\<acute>bc THEN
- .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1 \<and> \<acute>obc=\<acute>bc}.
- \<acute>l:=\<acute>l+1
- ELSE .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
- \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
- \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
- \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
- \<and> \<acute>q<n+1 \<and> \<acute>obc\<noteq>\<acute>bc}.
- \<acute>l:=0 FI
- OD;;
- Mul_Append n
-OD"
-
-lemmas mul_modules = Mul_Redirect_Edge_def Mul_Color_Target_def
- Mul_Blacken_Roots_def Mul_Propagate_Black_def
- Mul_Count_def Mul_Append_def
-
-lemma Mul_Collector:
- "\<turnstile> Mul_Collector n
- .{False}."
-apply(unfold Mul_Collector_def)
-apply annhoare
-apply(simp_all only:pre.simps Mul_Blacken_Roots
- Mul_Propagate_Black Mul_Count Mul_Append)
-apply(simp_all add:mul_modules)
-apply(simp_all add:mul_collector_defs Queue_def)
-apply force
-apply force
-apply force
-apply (force simp add: less_Suc_eq_le)
-apply force
-apply (force dest:subset_antisym)
-apply force
-apply force
-apply force
-done
-
-subsection {* Interference Freedom *}
-
-lemma le_length_filter_update[rule_format]:
- "\<forall>i. (\<not>P (list!i) \<or> P j) \<and> i<length list
- \<longrightarrow> length(filter P list) \<le> length(filter P (list[i:=j]))"
-apply(induct_tac "list")
- apply(simp)
-apply(clarify)
-apply(case_tac i)
- apply(simp)
-apply(simp)
-done
-
-lemma less_length_filter_update [rule_format]:
- "\<forall>i. P j \<and> \<not>(P (list!i)) \<and> i<length list
- \<longrightarrow> length(filter P list) < length(filter P (list[i:=j]))"
-apply(induct_tac "list")
- apply(simp)
-apply(clarify)
-apply(case_tac i)
- apply(simp)
-apply(simp)
-done
-
-lemma Mul_interfree_Blacken_Roots_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk> \<Longrightarrow>
- interfree_aux (Some(Mul_Blacken_Roots n),{},Some(Mul_Redirect_Edge j n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:Graph6 Graph9 Graph12 nth_list_update mul_mutator_defs mul_collector_defs)
-done
-
-lemma Mul_interfree_Redirect_Edge_Blacken_Roots: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Redirect_Edge j n ),{},Some (Mul_Blacken_Roots n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Blacken_Roots_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Blacken_Roots n),{},Some (Mul_Color_Target j n ))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:mul_mutator_defs mul_collector_defs nth_list_update Graph7 Graph8 Graph9 Graph12)
-done
-
-lemma Mul_interfree_Color_Target_Blacken_Roots: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Color_Target j n ),{},Some (Mul_Blacken_Roots n ))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Propagate_Black_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Propagate_Black n),{},Some (Mul_Redirect_Edge j n ))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply(simp_all add:mul_mutator_defs mul_collector_defs Mul_PBInv_def nth_list_update Graph6)
---{* 7 subgoals left *}
-apply clarify
-apply(disjE_tac)
- apply(simp_all add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
---{* 6 subgoals left *}
-apply clarify
-apply(disjE_tac)
- apply(simp_all add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
---{* 5 subgoals left *}
-apply clarify
-apply(disjE_tac)
- apply(simp_all add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(erule conjE)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule conjI)
- apply(rule impI,(rule disjI2)+,rule conjI)
- apply clarify
- apply(case_tac "R (Muts x! j)=i")
- apply (force simp add: nth_list_update BtoW_def)
- apply (force simp add: nth_list_update)
- apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,(rule disjI2)+, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
- apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
-apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
---{* 4 subgoals left *}
-apply clarify
-apply(disjE_tac)
- apply(simp_all add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(erule conjE)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule conjI)
- apply(rule impI,(rule disjI2)+,rule conjI)
- apply clarify
- apply(case_tac "R (Muts x! j)=i")
- apply (force simp add: nth_list_update BtoW_def)
- apply (force simp add: nth_list_update)
- apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,(rule disjI2)+, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
- apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
-apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
---{* 3 subgoals left *}
-apply clarify
-apply(disjE_tac)
- apply(simp_all add:Graph6)
- apply (rule impI)
- apply(rule conjI)
- apply(rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule conjI)
- apply(rule impI)
- apply(rule conjI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(rule impI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule conjI)
- apply(rule impI)
- apply(rule conjI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(rule impI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(erule conjE)
- apply(rule conjI)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule impI,rule conjI,(rule disjI2)+,rule conjI)
- apply clarify
- apply(case_tac "R (Muts x! j)=i")
- apply (force simp add: nth_list_update BtoW_def)
- apply (force simp add: nth_list_update)
- apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(rule impI,rule conjI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
- apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
- apply(case_tac "R (Muts x! j)=ind x")
- apply (force simp add: nth_list_update)
- apply (force simp add: nth_list_update)
-apply(rule impI, (rule disjI2)+, erule le_trans)
-apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
---{* 2 subgoals left *}
-apply clarify
-apply(rule conjI)
- apply(disjE_tac)
- apply(simp_all add:Mul_Auxk_def Graph6)
- apply (rule impI)
- apply(rule conjI)
- apply(rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule impI)
- apply(rule conjI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
- apply(rule impI)
- apply(rule conjI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
-apply(rule impI)
-apply(rule conjI)
- apply(erule conjE)+
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply((rule disjI2)+,rule conjI)
- apply clarify
- apply(case_tac "R (Muts x! j)=i")
- apply (force simp add: nth_list_update BtoW_def)
- apply (force simp add: nth_list_update)
- apply(rule conjI)
- apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update BtoW_def)
- apply (simp add:nth_list_update)
- apply(rule impI)
- apply simp
- apply(disjE_tac)
- apply(rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply force
- apply(rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
- apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
- apply(case_tac "R (Muts x ! j)= ind x")
- apply(simp add:nth_list_update)
- apply(simp add:nth_list_update)
-apply(disjE_tac)
-apply simp_all
-apply(conjI_tac)
- apply(rule impI)
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(erule conjE)+
-apply(rule impI,(rule disjI2)+,rule conjI)
- apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule impI)+
-apply simp
-apply(disjE_tac)
- apply(rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply force
---{* 1 subgoal left *}
-apply clarify
-apply(disjE_tac)
- apply(simp_all add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(erule conjE)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule conjI)
- apply(rule impI,(rule disjI2)+,rule conjI)
- apply clarify
- apply(case_tac "R (Muts x! j)=i")
- apply (force simp add: nth_list_update BtoW_def)
- apply (force simp add: nth_list_update)
- apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,(rule disjI2)+, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
- apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
-apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
-apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
-done
-
-lemma Mul_interfree_Redirect_Edge_Propagate_Black: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Redirect_Edge j n ),{},Some (Mul_Propagate_Black n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Propagate_Black_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Propagate_Black n),{},Some (Mul_Color_Target j n ))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply(simp_all add: mul_collector_defs mul_mutator_defs)
---{* 7 subgoals left *}
-apply clarify
-apply (simp add:Graph7 Graph8 Graph12)
-apply(disjE_tac)
- apply(simp add:Graph7 Graph8 Graph12)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,erule subset_psubset_trans, erule Graph11, simp)
-apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
---{* 6 subgoals left *}
-apply clarify
-apply (simp add:Graph7 Graph8 Graph12)
-apply(disjE_tac)
- apply(simp add:Graph7 Graph8 Graph12)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,erule subset_psubset_trans, erule Graph11, simp)
-apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
---{* 5 subgoals left *}
-apply clarify
-apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
-apply(disjE_tac)
- apply(simp add:Graph7 Graph8 Graph12)
- apply(rule disjI2,rule disjI1, erule psubset_subset_trans,simp add:Graph9)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
-apply(erule conjE)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply((rule disjI2)+)
- apply (rule conjI)
- apply(simp add:Graph10)
- apply(erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
-apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
---{* 4 subgoals left *}
-apply clarify
-apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
-apply(disjE_tac)
- apply(simp add:Graph7 Graph8 Graph12)
- apply(rule disjI2,rule disjI1, erule psubset_subset_trans,simp add:Graph9)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
-apply(erule conjE)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply((rule disjI2)+)
- apply (rule conjI)
- apply(simp add:Graph10)
- apply(erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
-apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
---{* 3 subgoals left *}
-apply clarify
-apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(simp add:Graph10)
- apply(disjE_tac)
- apply simp_all
- apply(rule disjI2, rule disjI2, rule disjI1,erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply(erule conjE)
- apply((rule disjI2)+,erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
-apply(rule conjI)
- apply(rule disjI2,rule disjI1, erule subset_psubset_trans,simp add:Graph11)
-apply (force simp add:nth_list_update)
---{* 2 subgoals left *}
-apply clarify
-apply(simp add:Mul_Auxk_def Graph7 Graph8 Graph12)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(simp add:Graph10)
- apply(disjE_tac)
- apply simp_all
- apply(rule disjI2, rule disjI2, rule disjI1,erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply(erule conjE)+
- apply((rule disjI2)+,rule conjI, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule impI)+)
- apply simp
- apply(erule disjE)
- apply(rule disjI1, erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply force
-apply(rule conjI)
- apply(rule disjI2,rule disjI1, erule subset_psubset_trans,simp add:Graph11)
-apply (force simp add:nth_list_update)
---{* 1 subgoal left *}
-apply clarify
-apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
-apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(simp add:Graph10)
- apply(disjE_tac)
- apply simp_all
- apply(rule disjI2, rule disjI2, rule disjI1,erule less_le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply(erule conjE)
- apply((rule disjI2)+,erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
-apply(rule disjI2,rule disjI1, erule subset_psubset_trans,simp add:Graph11)
-done
-
-lemma Mul_interfree_Color_Target_Propagate_Black: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Color_Target j n),{},Some(Mul_Propagate_Black n ))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Count_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Count n ),{},Some(Mul_Redirect_Edge j n))"
-apply (unfold mul_modules)
-apply interfree_aux
---{* 9 subgoals left *}
-apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def Graph6)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(simp add:Graph6)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(simp add:Graph6)
---{* 8 subgoals left *}
-apply(simp add:mul_mutator_defs nth_list_update)
---{* 7 subgoals left *}
-apply(simp add:mul_mutator_defs mul_collector_defs)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(simp add:Graph6)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(simp add:Graph6)
---{* 6 subgoals left *}
-apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6 Queue_def)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(simp add:Graph6)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(simp add:Graph6)
---{* 5 subgoals left *}
-apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(simp add:Graph6)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(simp add:Graph6)
---{* 4 subgoals left *}
-apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(simp add:Graph6)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(simp add:Graph6)
---{* 3 subgoals left *}
-apply(simp add:mul_mutator_defs nth_list_update)
---{* 2 subgoals left *}
-apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
- apply(simp add:Graph6)
-apply clarify
-apply disjE_tac
- apply(simp add:Graph6)
- apply(rule conjI)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
- apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(simp add:Graph6)
---{* 1 subgoal left *}
-apply(simp add:mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Redirect_Edge_Count: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Redirect_Edge j n),{},Some(Mul_Count n ))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Count_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Count n ),{},Some(Mul_Color_Target j n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply(simp_all add:mul_collector_defs mul_mutator_defs Mul_CountInv_def)
---{* 6 subgoals left *}
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply (simp add: Graph7 Graph8 Graph12)
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
-apply (simp add: Graph7 Graph8 Graph12)
-apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
---{* 5 subgoals left *}
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply (simp add: Graph7 Graph8 Graph12)
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
-apply (simp add: Graph7 Graph8 Graph12)
-apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
---{* 4 subgoals left *}
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply (simp add: Graph7 Graph8 Graph12)
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
-apply (simp add: Graph7 Graph8 Graph12)
-apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
---{* 3 subgoals left *}
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply (simp add: Graph7 Graph8 Graph12)
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
-apply (simp add: Graph7 Graph8 Graph12)
-apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
---{* 2 subgoals left *}
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12 nth_list_update)
- apply (simp add: Graph7 Graph8 Graph12 nth_list_update)
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply(rule conjI)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
- apply (simp add: nth_list_update)
-apply (simp add: Graph7 Graph8 Graph12)
-apply(rule conjI)
- apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
-apply (simp add: nth_list_update)
---{* 1 subgoal left *}
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply (simp add: Graph7 Graph8 Graph12)
-apply clarify
-apply disjE_tac
- apply (simp add: Graph7 Graph8 Graph12)
- apply(case_tac "M x!(T (Muts x!j))=Black")
- apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
- apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
- apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
-apply (simp add: Graph7 Graph8 Graph12)
-apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
-done
-
-lemma Mul_interfree_Color_Target_Count: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Color_Target j n),{}, Some(Mul_Count n ))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply safe
-apply(simp_all add:mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Append_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Append n),{}, Some(Mul_Redirect_Edge j n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
-apply(simp_all add:Graph6 Append_to_free0 Append_to_free1 mul_collector_defs mul_mutator_defs Mul_AppendInv_def)
-apply(erule_tac x=j in allE, force dest:Graph3)+
-done
-
-lemma Mul_interfree_Redirect_Edge_Append: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Redirect_Edge j n),{},Some(Mul_Append n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
-apply(simp_all add:mul_collector_defs Append_to_free0 Mul_AppendInv_def mul_mutator_defs nth_list_update)
-done
-
-lemma Mul_interfree_Append_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Append n),{}, Some(Mul_Color_Target j n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
-apply(simp_all add:mul_mutator_defs mul_collector_defs Mul_AppendInv_def Graph7 Graph8 Append_to_free0 Append_to_free1
- Graph12 nth_list_update)
-done
-
-lemma Mul_interfree_Color_Target_Append: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
- interfree_aux (Some(Mul_Color_Target j n),{}, Some(Mul_Append n))"
-apply (unfold mul_modules)
-apply interfree_aux
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
-apply(simp_all add: mul_mutator_defs nth_list_update)
-apply(simp add:Mul_AppendInv_def Append_to_free0)
-done
-
-subsubsection {* Interference freedom Collector-Mutator *}
-
-lemmas mul_collector_mutator_interfree =
- Mul_interfree_Blacken_Roots_Redirect_Edge Mul_interfree_Blacken_Roots_Color_Target
- Mul_interfree_Propagate_Black_Redirect_Edge Mul_interfree_Propagate_Black_Color_Target
- Mul_interfree_Count_Redirect_Edge Mul_interfree_Count_Color_Target
- Mul_interfree_Append_Redirect_Edge Mul_interfree_Append_Color_Target
- Mul_interfree_Redirect_Edge_Blacken_Roots Mul_interfree_Color_Target_Blacken_Roots
- Mul_interfree_Redirect_Edge_Propagate_Black Mul_interfree_Color_Target_Propagate_Black
- Mul_interfree_Redirect_Edge_Count Mul_interfree_Color_Target_Count
- Mul_interfree_Redirect_Edge_Append Mul_interfree_Color_Target_Append
-
-lemma Mul_interfree_Collector_Mutator: "j<n \<Longrightarrow>
- interfree_aux (Some (Mul_Collector n), {}, Some (Mul_Mutator j n))"
-apply(unfold Mul_Collector_def Mul_Mutator_def)
-apply interfree_aux
-apply(simp_all add:mul_collector_mutator_interfree)
-apply(unfold mul_modules mul_collector_defs mul_mutator_defs)
-apply(tactic {* TRYALL (interfree_aux_tac) *})
---{* 42 subgoals left *}
-apply (clarify,simp add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)+
---{* 24 subgoals left *}
-apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
---{* 14 subgoals left *}
-apply(tactic {* TRYALL (clarify_tac @{claset}) *})
-apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
-apply(tactic {* TRYALL (rtac conjI) *})
-apply(tactic {* TRYALL (rtac impI) *})
-apply(tactic {* TRYALL (etac disjE) *})
-apply(tactic {* TRYALL (etac conjE) *})
-apply(tactic {* TRYALL (etac disjE) *})
-apply(tactic {* TRYALL (etac disjE) *})
---{* 72 subgoals left *}
-apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
---{* 35 subgoals left *}
-apply(tactic {* TRYALL(EVERY'[rtac disjI1,rtac subset_trans,etac @{thm Graph3},force_tac @{clasimpset}, assume_tac]) *})
---{* 28 subgoals left *}
-apply(tactic {* TRYALL (etac conjE) *})
-apply(tactic {* TRYALL (etac disjE) *})
---{* 34 subgoals left *}
-apply(rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
-apply(case_tac [!] "M x!(T (Muts x ! j))=Black")
-apply(simp_all add:Graph10)
---{* 47 subgoals left *}
-apply(tactic {* TRYALL(EVERY'[REPEAT o (rtac disjI2),etac (thm "subset_psubset_trans"),etac (thm "Graph11"),force_tac @{clasimpset}]) *})
---{* 41 subgoals left *}
-apply(tactic {* TRYALL(EVERY'[rtac disjI2, rtac disjI1, etac @{thm le_trans}, force_tac (@{claset},@{simpset} addsimps [@{thm Queue_def}, @{thm less_Suc_eq_le}, @{thm le_length_filter_update}])]) *})
---{* 35 subgoals left *}
-apply(tactic {* TRYALL(EVERY'[rtac disjI2,rtac disjI1,etac (thm "psubset_subset_trans"),rtac (thm "Graph9"),force_tac @{clasimpset}]) *})
---{* 31 subgoals left *}
-apply(tactic {* TRYALL(EVERY'[rtac disjI2,rtac disjI1,etac (thm "subset_psubset_trans"),etac (thm "Graph11"),force_tac @{clasimpset}]) *})
---{* 29 subgoals left *}
-apply(tactic {* TRYALL(EVERY'[REPEAT o (rtac disjI2),etac (thm "subset_psubset_trans"),etac (thm "subset_psubset_trans"),etac (thm "Graph11"),force_tac @{clasimpset}]) *})
---{* 25 subgoals left *}
-apply(tactic {* TRYALL(EVERY'[rtac disjI2, rtac disjI2, rtac disjI1, etac @{thm le_trans}, force_tac (@{claset},@{simpset} addsimps [@{thm Queue_def}, @{thm less_Suc_eq_le}, @{thm le_length_filter_update}])]) *})
---{* 10 subgoals left *}
-apply(rule disjI2,rule disjI2,rule conjI,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update, rule disjI1, rule less_imp_le, erule less_le_trans, force simp add:Queue_def less_Suc_eq_le le_length_filter_update)+
-done
-
-subsubsection {* Interference freedom Mutator-Collector *}
-
-lemma Mul_interfree_Mutator_Collector: " j < n \<Longrightarrow>
- interfree_aux (Some (Mul_Mutator j n), {}, Some (Mul_Collector n))"
-apply(unfold Mul_Collector_def Mul_Mutator_def)
-apply interfree_aux
-apply(simp_all add:mul_collector_mutator_interfree)
-apply(unfold mul_modules mul_collector_defs mul_mutator_defs)
-apply(tactic {* TRYALL (interfree_aux_tac) *})
---{* 76 subgoals left *}
-apply (clarify,simp add: nth_list_update)+
---{* 56 subgoals left *}
-apply(clarify,simp add:Mul_AppendInv_def Append_to_free0 nth_list_update)+
-done
-
-subsubsection {* The Multi-Mutator Garbage Collection Algorithm *}
-
-text {* The total number of verification conditions is 328 *}
-
-lemma Mul_Gar_Coll:
- "\<parallel>- .{\<acute>Mul_Proper n \<and> \<acute>Mul_mut_init n \<and> (\<forall>i<n. Z (\<acute>Muts!i))}.
- COBEGIN
- Mul_Collector n
- .{False}.
- \<parallel>
- SCHEME [0\<le> j< n]
- Mul_Mutator j n
- .{False}.
- COEND
- .{False}."
-apply oghoare
---{* Strengthening the precondition *}
-apply(rule Int_greatest)
- apply (case_tac n)
- apply(force simp add: Mul_Collector_def mul_mutator_defs mul_collector_defs nth_append)
- apply(simp add: Mul_Mutator_def mul_collector_defs mul_mutator_defs nth_append)
- apply force
-apply clarify
-apply(case_tac i)
- apply(simp add:Mul_Collector_def mul_mutator_defs mul_collector_defs nth_append)
-apply(simp add: Mul_Mutator_def mul_mutator_defs mul_collector_defs nth_append nth_map_upt)
---{* Collector *}
-apply(rule Mul_Collector)
---{* Mutator *}
-apply(erule Mul_Mutator)
---{* Interference freedom *}
-apply(simp add:Mul_interfree_Collector_Mutator)
-apply(simp add:Mul_interfree_Mutator_Collector)
-apply(simp add:Mul_interfree_Mutator_Mutator)
---{* Weakening of the postcondition *}
-apply(case_tac n)
- apply(simp add:Mul_Collector_def mul_mutator_defs mul_collector_defs nth_append)
-apply(simp add:Mul_Mutator_def mul_mutator_defs mul_collector_defs nth_append)
-done
-
-end
--- a/src/HOL/HoareParallel/OG_Com.thy Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,55 +0,0 @@
-
-header {* \chapter{The Owicki-Gries Method}
-
-\section{Abstract Syntax} *}
-
-theory OG_Com imports Main begin
-
-text {* Type abbreviations for boolean expressions and assertions: *}
-
-types
- 'a bexp = "'a set"
- 'a assn = "'a set"
-
-text {* The syntax of commands is defined by two mutually recursive
-datatypes: @{text "'a ann_com"} for annotated commands and @{text "'a
-com"} for non-annotated commands. *}
-
-datatype 'a ann_com =
- AnnBasic "('a assn)" "('a \<Rightarrow> 'a)"
- | AnnSeq "('a ann_com)" "('a ann_com)"
- | AnnCond1 "('a assn)" "('a bexp)" "('a ann_com)" "('a ann_com)"
- | AnnCond2 "('a assn)" "('a bexp)" "('a ann_com)"
- | AnnWhile "('a assn)" "('a bexp)" "('a assn)" "('a ann_com)"
- | AnnAwait "('a assn)" "('a bexp)" "('a com)"
-and 'a com =
- Parallel "('a ann_com option \<times> 'a assn) list"
- | Basic "('a \<Rightarrow> 'a)"
- | Seq "('a com)" "('a com)"
- | Cond "('a bexp)" "('a com)" "('a com)"
- | While "('a bexp)" "('a assn)" "('a com)"
-
-text {* The function @{text pre} extracts the precondition of an
-annotated command: *}
-
-consts
- pre ::"'a ann_com \<Rightarrow> 'a assn"
-primrec
- "pre (AnnBasic r f) = r"
- "pre (AnnSeq c1 c2) = pre c1"
- "pre (AnnCond1 r b c1 c2) = r"
- "pre (AnnCond2 r b c) = r"
- "pre (AnnWhile r b i c) = r"
- "pre (AnnAwait r b c) = r"
-
-text {* Well-formedness predicate for atomic programs: *}
-
-consts atom_com :: "'a com \<Rightarrow> bool"
-primrec
- "atom_com (Parallel Ts) = False"
- "atom_com (Basic f) = True"
- "atom_com (Seq c1 c2) = (atom_com c1 \<and> atom_com c2)"
- "atom_com (Cond b c1 c2) = (atom_com c1 \<and> atom_com c2)"
- "atom_com (While b i c) = atom_com c"
-
-end
\ No newline at end of file
--- a/src/HOL/HoareParallel/OG_Examples.thy Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,549 +0,0 @@
-
-header {* \section{Examples} *}
-
-theory OG_Examples imports OG_Syntax begin
-
-subsection {* Mutual Exclusion *}
-
-subsubsection {* Peterson's Algorithm I*}
-
-text {* Eike Best. "Semantics of Sequential and Parallel Programs", page 217. *}
-
-record Petersons_mutex_1 =
- pr1 :: nat
- pr2 :: nat
- in1 :: bool
- in2 :: bool
- hold :: nat
-
-lemma Petersons_mutex_1:
- "\<parallel>- .{\<acute>pr1=0 \<and> \<not>\<acute>in1 \<and> \<acute>pr2=0 \<and> \<not>\<acute>in2 }.
- COBEGIN .{\<acute>pr1=0 \<and> \<not>\<acute>in1}.
- WHILE True INV .{\<acute>pr1=0 \<and> \<not>\<acute>in1}.
- DO
- .{\<acute>pr1=0 \<and> \<not>\<acute>in1}. \<langle> \<acute>in1:=True,,\<acute>pr1:=1 \<rangle>;;
- .{\<acute>pr1=1 \<and> \<acute>in1}. \<langle> \<acute>hold:=1,,\<acute>pr1:=2 \<rangle>;;
- .{\<acute>pr1=2 \<and> \<acute>in1 \<and> (\<acute>hold=1 \<or> \<acute>hold=2 \<and> \<acute>pr2=2)}.
- AWAIT (\<not>\<acute>in2 \<or> \<not>(\<acute>hold=1)) THEN \<acute>pr1:=3 END;;
- .{\<acute>pr1=3 \<and> \<acute>in1 \<and> (\<acute>hold=1 \<or> \<acute>hold=2 \<and> \<acute>pr2=2)}.
- \<langle>\<acute>in1:=False,,\<acute>pr1:=0\<rangle>
- OD .{\<acute>pr1=0 \<and> \<not>\<acute>in1}.
- \<parallel>
- .{\<acute>pr2=0 \<and> \<not>\<acute>in2}.
- WHILE True INV .{\<acute>pr2=0 \<and> \<not>\<acute>in2}.
- DO
- .{\<acute>pr2=0 \<and> \<not>\<acute>in2}. \<langle> \<acute>in2:=True,,\<acute>pr2:=1 \<rangle>;;
- .{\<acute>pr2=1 \<and> \<acute>in2}. \<langle> \<acute>hold:=2,,\<acute>pr2:=2 \<rangle>;;
- .{\<acute>pr2=2 \<and> \<acute>in2 \<and> (\<acute>hold=2 \<or> (\<acute>hold=1 \<and> \<acute>pr1=2))}.
- AWAIT (\<not>\<acute>in1 \<or> \<not>(\<acute>hold=2)) THEN \<acute>pr2:=3 END;;
- .{\<acute>pr2=3 \<and> \<acute>in2 \<and> (\<acute>hold=2 \<or> (\<acute>hold=1 \<and> \<acute>pr1=2))}.
- \<langle>\<acute>in2:=False,,\<acute>pr2:=0\<rangle>
- OD .{\<acute>pr2=0 \<and> \<not>\<acute>in2}.
- COEND
- .{\<acute>pr1=0 \<and> \<not>\<acute>in1 \<and> \<acute>pr2=0 \<and> \<not>\<acute>in2}."
-apply oghoare
---{* 104 verification conditions. *}
-apply auto
-done
-
-subsubsection {*Peterson's Algorithm II: A Busy Wait Solution *}
-
-text {* Apt and Olderog. "Verification of sequential and concurrent Programs", page 282. *}
-
-record Busy_wait_mutex =
- flag1 :: bool
- flag2 :: bool
- turn :: nat
- after1 :: bool
- after2 :: bool
-
-lemma Busy_wait_mutex:
- "\<parallel>- .{True}.
- \<acute>flag1:=False,, \<acute>flag2:=False,,
- COBEGIN .{\<not>\<acute>flag1}.
- WHILE True
- INV .{\<not>\<acute>flag1}.
- DO .{\<not>\<acute>flag1}. \<langle> \<acute>flag1:=True,,\<acute>after1:=False \<rangle>;;
- .{\<acute>flag1 \<and> \<not>\<acute>after1}. \<langle> \<acute>turn:=1,,\<acute>after1:=True \<rangle>;;
- .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
- WHILE \<not>(\<acute>flag2 \<longrightarrow> \<acute>turn=2)
- INV .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
- DO .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}. SKIP OD;;
- .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>flag2 \<and> \<acute>after2 \<longrightarrow> \<acute>turn=2)}.
- \<acute>flag1:=False
- OD
- .{False}.
- \<parallel>
- .{\<not>\<acute>flag2}.
- WHILE True
- INV .{\<not>\<acute>flag2}.
- DO .{\<not>\<acute>flag2}. \<langle> \<acute>flag2:=True,,\<acute>after2:=False \<rangle>;;
- .{\<acute>flag2 \<and> \<not>\<acute>after2}. \<langle> \<acute>turn:=2,,\<acute>after2:=True \<rangle>;;
- .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
- WHILE \<not>(\<acute>flag1 \<longrightarrow> \<acute>turn=1)
- INV .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
- DO .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}. SKIP OD;;
- .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>flag1 \<and> \<acute>after1 \<longrightarrow> \<acute>turn=1)}.
- \<acute>flag2:=False
- OD
- .{False}.
- COEND
- .{False}."
-apply oghoare
---{* 122 vc *}
-apply auto
-done
-
-subsubsection {* Peterson's Algorithm III: A Solution using Semaphores *}
-
-record Semaphores_mutex =
- out :: bool
- who :: nat
-
-lemma Semaphores_mutex:
- "\<parallel>- .{i\<noteq>j}.
- \<acute>out:=True ,,
- COBEGIN .{i\<noteq>j}.
- WHILE True INV .{i\<noteq>j}.
- DO .{i\<noteq>j}. AWAIT \<acute>out THEN \<acute>out:=False,, \<acute>who:=i END;;
- .{\<not>\<acute>out \<and> \<acute>who=i \<and> i\<noteq>j}. \<acute>out:=True OD
- .{False}.
- \<parallel>
- .{i\<noteq>j}.
- WHILE True INV .{i\<noteq>j}.
- DO .{i\<noteq>j}. AWAIT \<acute>out THEN \<acute>out:=False,,\<acute>who:=j END;;
- .{\<not>\<acute>out \<and> \<acute>who=j \<and> i\<noteq>j}. \<acute>out:=True OD
- .{False}.
- COEND
- .{False}."
-apply oghoare
---{* 38 vc *}
-apply auto
-done
-
-subsubsection {* Peterson's Algorithm III: Parameterized version: *}
-
-lemma Semaphores_parameterized_mutex:
- "0<n \<Longrightarrow> \<parallel>- .{True}.
- \<acute>out:=True ,,
- COBEGIN
- SCHEME [0\<le> i< n]
- .{True}.
- WHILE True INV .{True}.
- DO .{True}. AWAIT \<acute>out THEN \<acute>out:=False,, \<acute>who:=i END;;
- .{\<not>\<acute>out \<and> \<acute>who=i}. \<acute>out:=True OD
- .{False}.
- COEND
- .{False}."
-apply oghoare
---{* 20 vc *}
-apply auto
-done
-
-subsubsection{* The Ticket Algorithm *}
-
-record Ticket_mutex =
- num :: nat
- nextv :: nat
- turn :: "nat list"
- index :: nat
-
-lemma Ticket_mutex:
- "\<lbrakk> 0<n; I=\<guillemotleft>n=length \<acute>turn \<and> 0<\<acute>nextv \<and> (\<forall>k l. k<n \<and> l<n \<and> k\<noteq>l
- \<longrightarrow> \<acute>turn!k < \<acute>num \<and> (\<acute>turn!k =0 \<or> \<acute>turn!k\<noteq>\<acute>turn!l))\<guillemotright> \<rbrakk>
- \<Longrightarrow> \<parallel>- .{n=length \<acute>turn}.
- \<acute>index:= 0,,
- WHILE \<acute>index < n INV .{n=length \<acute>turn \<and> (\<forall>i<\<acute>index. \<acute>turn!i=0)}.
- DO \<acute>turn:= \<acute>turn[\<acute>index:=0],, \<acute>index:=\<acute>index +1 OD,,
- \<acute>num:=1 ,, \<acute>nextv:=1 ,,
- COBEGIN
- SCHEME [0\<le> i< n]
- .{\<acute>I}.
- WHILE True INV .{\<acute>I}.
- DO .{\<acute>I}. \<langle> \<acute>turn :=\<acute>turn[i:=\<acute>num],, \<acute>num:=\<acute>num+1 \<rangle>;;
- .{\<acute>I}. WAIT \<acute>turn!i=\<acute>nextv END;;
- .{\<acute>I \<and> \<acute>turn!i=\<acute>nextv}. \<acute>nextv:=\<acute>nextv+1
- OD
- .{False}.
- COEND
- .{False}."
-apply oghoare
---{* 35 vc *}
-apply simp_all
---{* 21 vc *}
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
---{* 11 vc *}
-apply simp_all
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
---{* 10 subgoals left *}
-apply(erule less_SucE)
- apply simp
-apply simp
---{* 9 subgoals left *}
-apply(case_tac "i=k")
- apply force
-apply simp
-apply(case_tac "i=l")
- apply force
-apply force
---{* 8 subgoals left *}
-prefer 8
-apply force
-apply force
---{* 6 subgoals left *}
-prefer 6
-apply(erule_tac x=i in allE)
-apply fastsimp
---{* 5 subgoals left *}
-prefer 5
-apply(case_tac [!] "j=k")
---{* 10 subgoals left *}
-apply simp_all
-apply(erule_tac x=k in allE)
-apply force
---{* 9 subgoals left *}
-apply(case_tac "j=l")
- apply simp
- apply(erule_tac x=k in allE)
- apply(erule_tac x=k in allE)
- apply(erule_tac x=l in allE)
- apply force
-apply(erule_tac x=k in allE)
-apply(erule_tac x=k in allE)
-apply(erule_tac x=l in allE)
-apply force
---{* 8 subgoals left *}
-apply force
-apply(case_tac "j=l")
- apply simp
-apply(erule_tac x=k in allE)
-apply(erule_tac x=l in allE)
-apply force
-apply force
-apply force
---{* 5 subgoals left *}
-apply(erule_tac x=k in allE)
-apply(erule_tac x=l in allE)
-apply(case_tac "j=l")
- apply force
-apply force
-apply force
---{* 3 subgoals left *}
-apply(erule_tac x=k in allE)
-apply(erule_tac x=l in allE)
-apply(case_tac "j=l")
- apply force
-apply force
-apply force
---{* 1 subgoals left *}
-apply(erule_tac x=k in allE)
-apply(erule_tac x=l in allE)
-apply(case_tac "j=l")
- apply force
-apply force
-done
-
-subsection{* Parallel Zero Search *}
-
-text {* Synchronized Zero Search. Zero-6 *}
-
-text {*Apt and Olderog. "Verification of sequential and concurrent Programs" page 294: *}
-
-record Zero_search =
- turn :: nat
- found :: bool
- x :: nat
- y :: nat
-
-lemma Zero_search:
- "\<lbrakk>I1= \<guillemotleft> a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
- \<and> (\<not>\<acute>found \<and> a<\<acute> x \<longrightarrow> f(\<acute>x)\<noteq>0) \<guillemotright> ;
- I2= \<guillemotleft>\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
- \<and> (\<not>\<acute>found \<and> \<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0) \<guillemotright> \<rbrakk> \<Longrightarrow>
- \<parallel>- .{\<exists> u. f(u)=0}.
- \<acute>turn:=1,, \<acute>found:= False,,
- \<acute>x:=a,, \<acute>y:=a+1 ,,
- COBEGIN .{\<acute>I1}.
- WHILE \<not>\<acute>found
- INV .{\<acute>I1}.
- DO .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
- WAIT \<acute>turn=1 END;;
- .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
- \<acute>turn:=2;;
- .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
- \<langle> \<acute>x:=\<acute>x+1,,
- IF f(\<acute>x)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
- OD;;
- .{\<acute>I1 \<and> \<acute>found}.
- \<acute>turn:=2
- .{\<acute>I1 \<and> \<acute>found}.
- \<parallel>
- .{\<acute>I2}.
- WHILE \<not>\<acute>found
- INV .{\<acute>I2}.
- DO .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
- WAIT \<acute>turn=2 END;;
- .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
- \<acute>turn:=1;;
- .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
- \<langle> \<acute>y:=(\<acute>y - 1),,
- IF f(\<acute>y)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
- OD;;
- .{\<acute>I2 \<and> \<acute>found}.
- \<acute>turn:=1
- .{\<acute>I2 \<and> \<acute>found}.
- COEND
- .{f(\<acute>x)=0 \<or> f(\<acute>y)=0}."
-apply oghoare
---{* 98 verification conditions *}
-apply auto
---{* auto takes about 3 minutes !! *}
-done
-
-text {* Easier Version: without AWAIT. Apt and Olderog. page 256: *}
-
-lemma Zero_Search_2:
-"\<lbrakk>I1=\<guillemotleft> a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
- \<and> (\<not>\<acute>found \<and> a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)\<guillemotright>;
- I2= \<guillemotleft>\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
- \<and> (\<not>\<acute>found \<and> \<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)\<guillemotright>\<rbrakk> \<Longrightarrow>
- \<parallel>- .{\<exists>u. f(u)=0}.
- \<acute>found:= False,,
- \<acute>x:=a,, \<acute>y:=a+1,,
- COBEGIN .{\<acute>I1}.
- WHILE \<not>\<acute>found
- INV .{\<acute>I1}.
- DO .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
- \<langle> \<acute>x:=\<acute>x+1,,IF f(\<acute>x)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
- OD
- .{\<acute>I1 \<and> \<acute>found}.
- \<parallel>
- .{\<acute>I2}.
- WHILE \<not>\<acute>found
- INV .{\<acute>I2}.
- DO .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
- \<langle> \<acute>y:=(\<acute>y - 1),,IF f(\<acute>y)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
- OD
- .{\<acute>I2 \<and> \<acute>found}.
- COEND
- .{f(\<acute>x)=0 \<or> f(\<acute>y)=0}."
-apply oghoare
---{* 20 vc *}
-apply auto
---{* auto takes aprox. 2 minutes. *}
-done
-
-subsection {* Producer/Consumer *}
-
-subsubsection {* Previous lemmas *}
-
-lemma nat_lemma2: "\<lbrakk> b = m*(n::nat) + t; a = s*n + u; t=u; b-a < n \<rbrakk> \<Longrightarrow> m \<le> s"
-proof -
- assume "b = m*(n::nat) + t" "a = s*n + u" "t=u"
- hence "(m - s) * n = b - a" by (simp add: diff_mult_distrib)
- also assume "\<dots> < n"
- finally have "m - s < 1" by simp
- thus ?thesis by arith
-qed
-
-lemma mod_lemma: "\<lbrakk> (c::nat) \<le> a; a < b; b - c < n \<rbrakk> \<Longrightarrow> b mod n \<noteq> a mod n"
-apply(subgoal_tac "b=b div n*n + b mod n" )
- prefer 2 apply (simp add: mod_div_equality [symmetric])
-apply(subgoal_tac "a=a div n*n + a mod n")
- prefer 2
- apply(simp add: mod_div_equality [symmetric])
-apply(subgoal_tac "b - a \<le> b - c")
- prefer 2 apply arith
-apply(drule le_less_trans)
-back
- apply assumption
-apply(frule less_not_refl2)
-apply(drule less_imp_le)
-apply (drule_tac m = "a" and k = n in div_le_mono)
-apply(safe)
-apply(frule_tac b = "b" and a = "a" and n = "n" in nat_lemma2, assumption, assumption)
-apply assumption
-apply(drule order_antisym, assumption)
-apply(rotate_tac -3)
-apply(simp)
-done
-
-
-subsubsection {* Producer/Consumer Algorithm *}
-
-record Producer_consumer =
- ins :: nat
- outs :: nat
- li :: nat
- lj :: nat
- vx :: nat
- vy :: nat
- buffer :: "nat list"
- b :: "nat list"
-
-text {* The whole proof takes aprox. 4 minutes. *}
-
-lemma Producer_consumer:
- "\<lbrakk>INIT= \<guillemotleft>0<length a \<and> 0<length \<acute>buffer \<and> length \<acute>b=length a\<guillemotright> ;
- I= \<guillemotleft>(\<forall>k<\<acute>ins. \<acute>outs\<le>k \<longrightarrow> (a ! k) = \<acute>buffer ! (k mod (length \<acute>buffer))) \<and>
- \<acute>outs\<le>\<acute>ins \<and> \<acute>ins-\<acute>outs\<le>length \<acute>buffer\<guillemotright> ;
- I1= \<guillemotleft>\<acute>I \<and> \<acute>li\<le>length a\<guillemotright> ;
- p1= \<guillemotleft>\<acute>I1 \<and> \<acute>li=\<acute>ins\<guillemotright> ;
- I2 = \<guillemotleft>\<acute>I \<and> (\<forall>k<\<acute>lj. (a ! k)=(\<acute>b ! k)) \<and> \<acute>lj\<le>length a\<guillemotright> ;
- p2 = \<guillemotleft>\<acute>I2 \<and> \<acute>lj=\<acute>outs\<guillemotright> \<rbrakk> \<Longrightarrow>
- \<parallel>- .{\<acute>INIT}.
- \<acute>ins:=0,, \<acute>outs:=0,, \<acute>li:=0,, \<acute>lj:=0,,
- COBEGIN .{\<acute>p1 \<and> \<acute>INIT}.
- WHILE \<acute>li <length a
- INV .{\<acute>p1 \<and> \<acute>INIT}.
- DO .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a}.
- \<acute>vx:= (a ! \<acute>li);;
- .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a \<and> \<acute>vx=(a ! \<acute>li)}.
- WAIT \<acute>ins-\<acute>outs < length \<acute>buffer END;;
- .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a \<and> \<acute>vx=(a ! \<acute>li)
- \<and> \<acute>ins-\<acute>outs < length \<acute>buffer}.
- \<acute>buffer:=(list_update \<acute>buffer (\<acute>ins mod (length \<acute>buffer)) \<acute>vx);;
- .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a
- \<and> (a ! \<acute>li)=(\<acute>buffer ! (\<acute>ins mod (length \<acute>buffer)))
- \<and> \<acute>ins-\<acute>outs <length \<acute>buffer}.
- \<acute>ins:=\<acute>ins+1;;
- .{\<acute>I1 \<and> \<acute>INIT \<and> (\<acute>li+1)=\<acute>ins \<and> \<acute>li<length a}.
- \<acute>li:=\<acute>li+1
- OD
- .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li=length a}.
- \<parallel>
- .{\<acute>p2 \<and> \<acute>INIT}.
- WHILE \<acute>lj < length a
- INV .{\<acute>p2 \<and> \<acute>INIT}.
- DO .{\<acute>p2 \<and> \<acute>lj<length a \<and> \<acute>INIT}.
- WAIT \<acute>outs<\<acute>ins END;;
- .{\<acute>p2 \<and> \<acute>lj<length a \<and> \<acute>outs<\<acute>ins \<and> \<acute>INIT}.
- \<acute>vy:=(\<acute>buffer ! (\<acute>outs mod (length \<acute>buffer)));;
- .{\<acute>p2 \<and> \<acute>lj<length a \<and> \<acute>outs<\<acute>ins \<and> \<acute>vy=(a ! \<acute>lj) \<and> \<acute>INIT}.
- \<acute>outs:=\<acute>outs+1;;
- .{\<acute>I2 \<and> (\<acute>lj+1)=\<acute>outs \<and> \<acute>lj<length a \<and> \<acute>vy=(a ! \<acute>lj) \<and> \<acute>INIT}.
- \<acute>b:=(list_update \<acute>b \<acute>lj \<acute>vy);;
- .{\<acute>I2 \<and> (\<acute>lj+1)=\<acute>outs \<and> \<acute>lj<length a \<and> (a ! \<acute>lj)=(\<acute>b ! \<acute>lj) \<and> \<acute>INIT}.
- \<acute>lj:=\<acute>lj+1
- OD
- .{\<acute>p2 \<and> \<acute>lj=length a \<and> \<acute>INIT}.
- COEND
- .{ \<forall>k<length a. (a ! k)=(\<acute>b ! k)}."
-apply oghoare
---{* 138 vc *}
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
---{* 112 subgoals left *}
-apply(simp_all (no_asm))
-apply(tactic {*ALLGOALS (conjI_Tac (K all_tac)) *})
---{* 930 subgoals left *}
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
-apply(simp_all (asm_lr) only:length_0_conv [THEN sym])
---{* 44 subgoals left *}
-apply (simp_all (asm_lr) del:length_0_conv add: neq0_conv nth_list_update mod_less_divisor mod_lemma)
---{* 32 subgoals left *}
-apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
-
-apply(tactic {* TRYALL (Lin_Arith.tac @{context}) *})
---{* 9 subgoals left *}
-apply (force simp add:less_Suc_eq)
-apply(drule sym)
-apply (force simp add:less_Suc_eq)+
-done
-
-subsection {* Parameterized Examples *}
-
-subsubsection {* Set Elements of an Array to Zero *}
-
-record Example1 =
- a :: "nat \<Rightarrow> nat"
-
-lemma Example1:
- "\<parallel>- .{True}.
- COBEGIN SCHEME [0\<le>i<n] .{True}. \<acute>a:=\<acute>a (i:=0) .{\<acute>a i=0}. COEND
- .{\<forall>i < n. \<acute>a i = 0}."
-apply oghoare
-apply simp_all
-done
-
-text {* Same example with lists as auxiliary variables. *}
-record Example1_list =
- A :: "nat list"
-lemma Example1_list:
- "\<parallel>- .{n < length \<acute>A}.
- COBEGIN
- SCHEME [0\<le>i<n] .{n < length \<acute>A}. \<acute>A:=\<acute>A[i:=0] .{\<acute>A!i=0}.
- COEND
- .{\<forall>i < n. \<acute>A!i = 0}."
-apply oghoare
-apply force+
-done
-
-subsubsection {* Increment a Variable in Parallel *}
-
-text {* First some lemmas about summation properties. *}
-(*
-lemma Example2_lemma1: "!!b. j<n \<Longrightarrow> (\<Sum>i::nat<n. b i) = (0::nat) \<Longrightarrow> b j = 0 "
-apply(induct n)
- apply simp_all
-apply(force simp add: less_Suc_eq)
-done
-*)
-lemma Example2_lemma2_aux: "!!b. j<n \<Longrightarrow>
- (\<Sum>i=0..<n. (b i::nat)) =
- (\<Sum>i=0..<j. b i) + b j + (\<Sum>i=0..<n-(Suc j) . b (Suc j + i))"
-apply(induct n)
- apply simp_all
-apply(simp add:less_Suc_eq)
- apply(auto)
-apply(subgoal_tac "n - j = Suc(n- Suc j)")
- apply simp
-apply arith
-done
-
-lemma Example2_lemma2_aux2:
- "!!b. j\<le> s \<Longrightarrow> (\<Sum>i::nat=0..<j. (b (s:=t)) i) = (\<Sum>i=0..<j. b i)"
-apply(induct j)
- apply simp_all
-done
-
-lemma Example2_lemma2:
- "!!b. \<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow> Suc (\<Sum>i::nat=0..<n. b i)=(\<Sum>i=0..<n. (b (j := Suc 0)) i)"
-apply(frule_tac b="(b (j:=(Suc 0)))" in Example2_lemma2_aux)
-apply(erule_tac t="setsum (b(j := (Suc 0))) {0..<n}" in ssubst)
-apply(frule_tac b=b in Example2_lemma2_aux)
-apply(erule_tac t="setsum b {0..<n}" in ssubst)
-apply(subgoal_tac "Suc (setsum b {0..<j} + b j + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))=(setsum b {0..<j} + Suc (b j) + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))")
-apply(rotate_tac -1)
-apply(erule ssubst)
-apply(subgoal_tac "j\<le>j")
- apply(drule_tac b="b" and t="(Suc 0)" in Example2_lemma2_aux2)
-apply(rotate_tac -1)
-apply(erule ssubst)
-apply simp_all
-done
-
-
-record Example2 =
- c :: "nat \<Rightarrow> nat"
- x :: nat
-
-lemma Example_2: "0<n \<Longrightarrow>
- \<parallel>- .{\<acute>x=0 \<and> (\<Sum>i=0..<n. \<acute>c i)=0}.
- COBEGIN
- SCHEME [0\<le>i<n]
- .{\<acute>x=(\<Sum>i=0..<n. \<acute>c i) \<and> \<acute>c i=0}.
- \<langle> \<acute>x:=\<acute>x+(Suc 0),, \<acute>c:=\<acute>c (i:=(Suc 0)) \<rangle>
- .{\<acute>x=(\<Sum>i=0..<n. \<acute>c i) \<and> \<acute>c i=(Suc 0)}.
- COEND
- .{\<acute>x=n}."
-apply oghoare
-apply (simp_all cong del: strong_setsum_cong)
-apply (tactic {* ALLGOALS (clarify_tac @{claset}) *})
-apply (simp_all cong del: strong_setsum_cong)
- apply(erule (1) Example2_lemma2)
- apply(erule (1) Example2_lemma2)
- apply(erule (1) Example2_lemma2)
-apply(simp)
-done
-
-end
--- a/src/HOL/HoareParallel/OG_Hoare.thy Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,469 +0,0 @@
-
-header {* \section{The Proof System} *}
-
-theory OG_Hoare imports OG_Tran begin
-
-consts assertions :: "'a ann_com \<Rightarrow> ('a assn) set"
-primrec
- "assertions (AnnBasic r f) = {r}"
- "assertions (AnnSeq c1 c2) = assertions c1 \<union> assertions c2"
- "assertions (AnnCond1 r b c1 c2) = {r} \<union> assertions c1 \<union> assertions c2"
- "assertions (AnnCond2 r b c) = {r} \<union> assertions c"
- "assertions (AnnWhile r b i c) = {r, i} \<union> assertions c"
- "assertions (AnnAwait r b c) = {r}"
-
-consts atomics :: "'a ann_com \<Rightarrow> ('a assn \<times> 'a com) set"
-primrec
- "atomics (AnnBasic r f) = {(r, Basic f)}"
- "atomics (AnnSeq c1 c2) = atomics c1 \<union> atomics c2"
- "atomics (AnnCond1 r b c1 c2) = atomics c1 \<union> atomics c2"
- "atomics (AnnCond2 r b c) = atomics c"
- "atomics (AnnWhile r b i c) = atomics c"
- "atomics (AnnAwait r b c) = {(r \<inter> b, c)}"
-
-consts com :: "'a ann_triple_op \<Rightarrow> 'a ann_com_op"
-primrec "com (c, q) = c"
-
-consts post :: "'a ann_triple_op \<Rightarrow> 'a assn"
-primrec "post (c, q) = q"
-
-constdefs interfree_aux :: "('a ann_com_op \<times> 'a assn \<times> 'a ann_com_op) \<Rightarrow> bool"
- "interfree_aux \<equiv> \<lambda>(co, q, co'). co'= None \<or>
- (\<forall>(r,a) \<in> atomics (the co'). \<parallel>= (q \<inter> r) a q \<and>
- (co = None \<or> (\<forall>p \<in> assertions (the co). \<parallel>= (p \<inter> r) a p)))"
-
-constdefs interfree :: "(('a ann_triple_op) list) \<Rightarrow> bool"
- "interfree Ts \<equiv> \<forall>i j. i < length Ts \<and> j < length Ts \<and> i \<noteq> j \<longrightarrow>
- interfree_aux (com (Ts!i), post (Ts!i), com (Ts!j)) "
-
-inductive
- oghoare :: "'a assn \<Rightarrow> 'a com \<Rightarrow> 'a assn \<Rightarrow> bool" ("(3\<parallel>- _//_//_)" [90,55,90] 50)
- and ann_hoare :: "'a ann_com \<Rightarrow> 'a assn \<Rightarrow> bool" ("(2\<turnstile> _// _)" [60,90] 45)
-where
- AnnBasic: "r \<subseteq> {s. f s \<in> q} \<Longrightarrow> \<turnstile> (AnnBasic r f) q"
-
-| AnnSeq: "\<lbrakk> \<turnstile> c0 pre c1; \<turnstile> c1 q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnSeq c0 c1) q"
-
-| AnnCond1: "\<lbrakk> r \<inter> b \<subseteq> pre c1; \<turnstile> c1 q; r \<inter> -b \<subseteq> pre c2; \<turnstile> c2 q\<rbrakk>
- \<Longrightarrow> \<turnstile> (AnnCond1 r b c1 c2) q"
-| AnnCond2: "\<lbrakk> r \<inter> b \<subseteq> pre c; \<turnstile> c q; r \<inter> -b \<subseteq> q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnCond2 r b c) q"
-
-| AnnWhile: "\<lbrakk> r \<subseteq> i; i \<inter> b \<subseteq> pre c; \<turnstile> c i; i \<inter> -b \<subseteq> q \<rbrakk>
- \<Longrightarrow> \<turnstile> (AnnWhile r b i c) q"
-
-| AnnAwait: "\<lbrakk> atom_com c; \<parallel>- (r \<inter> b) c q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnAwait r b c) q"
-
-| AnnConseq: "\<lbrakk>\<turnstile> c q; q \<subseteq> q' \<rbrakk> \<Longrightarrow> \<turnstile> c q'"
-
-
-| Parallel: "\<lbrakk> \<forall>i<length Ts. \<exists>c q. Ts!i = (Some c, q) \<and> \<turnstile> c q; interfree Ts \<rbrakk>
- \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts!i))))
- Parallel Ts
- (\<Inter>i\<in>{i. i<length Ts}. post(Ts!i))"
-
-| Basic: "\<parallel>- {s. f s \<in>q} (Basic f) q"
-
-| Seq: "\<lbrakk> \<parallel>- p c1 r; \<parallel>- r c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Seq c1 c2) q "
-
-| Cond: "\<lbrakk> \<parallel>- (p \<inter> b) c1 q; \<parallel>- (p \<inter> -b) c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Cond b c1 c2) q"
-
-| While: "\<lbrakk> \<parallel>- (p \<inter> b) c p \<rbrakk> \<Longrightarrow> \<parallel>- p (While b i c) (p \<inter> -b)"
-
-| Conseq: "\<lbrakk> p' \<subseteq> p; \<parallel>- p c q ; q \<subseteq> q' \<rbrakk> \<Longrightarrow> \<parallel>- p' c q'"
-
-section {* Soundness *}
-(* In the version Isabelle-10-Sep-1999: HOL: The THEN and ELSE
-parts of conditional expressions (if P then x else y) are no longer
-simplified. (This allows the simplifier to unfold recursive
-functional programs.) To restore the old behaviour, we declare
-@{text "lemmas [cong del] = if_weak_cong"}. *)
-
-lemmas [cong del] = if_weak_cong
-
-lemmas ann_hoare_induct = oghoare_ann_hoare.induct [THEN conjunct2]
-lemmas oghoare_induct = oghoare_ann_hoare.induct [THEN conjunct1]
-
-lemmas AnnBasic = oghoare_ann_hoare.AnnBasic
-lemmas AnnSeq = oghoare_ann_hoare.AnnSeq
-lemmas AnnCond1 = oghoare_ann_hoare.AnnCond1
-lemmas AnnCond2 = oghoare_ann_hoare.AnnCond2
-lemmas AnnWhile = oghoare_ann_hoare.AnnWhile
-lemmas AnnAwait = oghoare_ann_hoare.AnnAwait
-lemmas AnnConseq = oghoare_ann_hoare.AnnConseq
-
-lemmas Parallel = oghoare_ann_hoare.Parallel
-lemmas Basic = oghoare_ann_hoare.Basic
-lemmas Seq = oghoare_ann_hoare.Seq
-lemmas Cond = oghoare_ann_hoare.Cond
-lemmas While = oghoare_ann_hoare.While
-lemmas Conseq = oghoare_ann_hoare.Conseq
-
-subsection {* Soundness of the System for Atomic Programs *}
-
-lemma Basic_ntran [rule_format]:
- "(Basic f, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow> t = f s"
-apply(induct "n")
- apply(simp (no_asm))
-apply(fast dest: rel_pow_Suc_D2 Parallel_empty_lemma elim: transition_cases)
-done
-
-lemma SEM_fwhile: "SEM S (p \<inter> b) \<subseteq> p \<Longrightarrow> SEM (fwhile b S k) p \<subseteq> (p \<inter> -b)"
-apply (induct "k")
- apply(simp (no_asm) add: L3_5v_lemma3)
-apply(simp (no_asm) add: L3_5iv L3_5ii Parallel_empty)
-apply(rule conjI)
- apply (blast dest: L3_5i)
-apply(simp add: SEM_def sem_def id_def)
-apply (blast dest: Basic_ntran rtrancl_imp_UN_rel_pow)
-done
-
-lemma atom_hoare_sound [rule_format]:
- " \<parallel>- p c q \<longrightarrow> atom_com(c) \<longrightarrow> \<parallel>= p c q"
-apply (unfold com_validity_def)
-apply(rule oghoare_induct)
-apply simp_all
---{*Basic*}
- apply(simp add: SEM_def sem_def)
- apply(fast dest: rtrancl_imp_UN_rel_pow Basic_ntran)
---{* Seq *}
- apply(rule impI)
- apply(rule subset_trans)
- prefer 2 apply simp
- apply(simp add: L3_5ii L3_5i)
---{* Cond *}
- apply(simp add: L3_5iv)
---{* While *}
- apply (force simp add: L3_5v dest: SEM_fwhile)
---{* Conseq *}
-apply(force simp add: SEM_def sem_def)
-done
-
-subsection {* Soundness of the System for Component Programs *}
-
-inductive_cases ann_transition_cases:
- "(None,s) -1\<rightarrow> (c', s')"
- "(Some (AnnBasic r f),s) -1\<rightarrow> (c', s')"
- "(Some (AnnSeq c1 c2), s) -1\<rightarrow> (c', s')"
- "(Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (c', s')"
- "(Some (AnnCond2 r b c), s) -1\<rightarrow> (c', s')"
- "(Some (AnnWhile r b I c), s) -1\<rightarrow> (c', s')"
- "(Some (AnnAwait r b c),s) -1\<rightarrow> (c', s')"
-
-text {* Strong Soundness for Component Programs:*}
-
-lemma ann_hoare_case_analysis [rule_format]:
- defines I: "I \<equiv> \<lambda>C q'.
- ((\<forall>r f. C = AnnBasic r f \<longrightarrow> (\<exists>q. r \<subseteq> {s. f s \<in> q} \<and> q \<subseteq> q')) \<and>
- (\<forall>c0 c1. C = AnnSeq c0 c1 \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and> \<turnstile> c0 pre c1 \<and> \<turnstile> c1 q)) \<and>
- (\<forall>r b c1 c2. C = AnnCond1 r b c1 c2 \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and>
- r \<inter> b \<subseteq> pre c1 \<and> \<turnstile> c1 q \<and> r \<inter> -b \<subseteq> pre c2 \<and> \<turnstile> c2 q)) \<and>
- (\<forall>r b c. C = AnnCond2 r b c \<longrightarrow>
- (\<exists>q. q \<subseteq> q' \<and> r \<inter> b \<subseteq> pre c \<and> \<turnstile> c q \<and> r \<inter> -b \<subseteq> q)) \<and>
- (\<forall>r i b c. C = AnnWhile r b i c \<longrightarrow>
- (\<exists>q. q \<subseteq> q' \<and> r \<subseteq> i \<and> i \<inter> b \<subseteq> pre c \<and> \<turnstile> c i \<and> i \<inter> -b \<subseteq> q)) \<and>
- (\<forall>r b c. C = AnnAwait r b c \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and> \<parallel>- (r \<inter> b) c q)))"
- shows "\<turnstile> C q' \<longrightarrow> I C q'"
-apply(rule ann_hoare_induct)
-apply (simp_all add: I)
- apply(rule_tac x=q in exI,simp)+
-apply(rule conjI,clarify,simp,clarify,rule_tac x=qa in exI,fast)+
-apply(clarify,simp,clarify,rule_tac x=qa in exI,fast)
-done
-
-lemma Help: "(transition \<inter> {(x,y). True}) = (transition)"
-apply force
-done
-
-lemma Strong_Soundness_aux_aux [rule_format]:
- "(co, s) -1\<rightarrow> (co', t) \<longrightarrow> (\<forall>c. co = Some c \<longrightarrow> s\<in> pre c \<longrightarrow>
- (\<forall>q. \<turnstile> c q \<longrightarrow> (if co' = None then t\<in>q else t \<in> pre(the co') \<and> \<turnstile> (the co') q )))"
-apply(rule ann_transition_transition.induct [THEN conjunct1])
-apply simp_all
---{* Basic *}
- apply clarify
- apply(frule ann_hoare_case_analysis)
- apply force
---{* Seq *}
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply(fast intro: AnnConseq)
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply clarify
- apply(rule conjI)
- apply force
- apply(rule AnnSeq,simp)
- apply(fast intro: AnnConseq)
---{* Cond1 *}
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply(fast intro: AnnConseq)
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply(fast intro: AnnConseq)
---{* Cond2 *}
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply(fast intro: AnnConseq)
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply(fast intro: AnnConseq)
---{* While *}
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply force
- apply clarify
- apply(frule ann_hoare_case_analysis,simp)
- apply auto
- apply(rule AnnSeq)
- apply simp
- apply(rule AnnWhile)
- apply simp_all
---{* Await *}
-apply(frule ann_hoare_case_analysis,simp)
-apply clarify
-apply(drule atom_hoare_sound)
- apply simp
-apply(simp add: com_validity_def SEM_def sem_def)
-apply(simp add: Help All_None_def)
-apply force
-done
-
-lemma Strong_Soundness_aux: "\<lbrakk> (Some c, s) -*\<rightarrow> (co, t); s \<in> pre c; \<turnstile> c q \<rbrakk>
- \<Longrightarrow> if co = None then t \<in> q else t \<in> pre (the co) \<and> \<turnstile> (the co) q"
-apply(erule rtrancl_induct2)
- apply simp
-apply(case_tac "a")
- apply(fast elim: ann_transition_cases)
-apply(erule Strong_Soundness_aux_aux)
- apply simp
-apply simp_all
-done
-
-lemma Strong_Soundness: "\<lbrakk> (Some c, s)-*\<rightarrow>(co, t); s \<in> pre c; \<turnstile> c q \<rbrakk>
- \<Longrightarrow> if co = None then t\<in>q else t \<in> pre (the co)"
-apply(force dest:Strong_Soundness_aux)
-done
-
-lemma ann_hoare_sound: "\<turnstile> c q \<Longrightarrow> \<Turnstile> c q"
-apply (unfold ann_com_validity_def ann_SEM_def ann_sem_def)
-apply clarify
-apply(drule Strong_Soundness)
-apply simp_all
-done
-
-subsection {* Soundness of the System for Parallel Programs *}
-
-lemma Parallel_length_post_P1: "(Parallel Ts,s) -P1\<rightarrow> (R', t) \<Longrightarrow>
- (\<exists>Rs. R' = (Parallel Rs) \<and> (length Rs) = (length Ts) \<and>
- (\<forall>i. i<length Ts \<longrightarrow> post(Rs ! i) = post(Ts ! i)))"
-apply(erule transition_cases)
-apply simp
-apply clarify
-apply(case_tac "i=ia")
-apply simp+
-done
-
-lemma Parallel_length_post_PStar: "(Parallel Ts,s) -P*\<rightarrow> (R',t) \<Longrightarrow>
- (\<exists>Rs. R' = (Parallel Rs) \<and> (length Rs) = (length Ts) \<and>
- (\<forall>i. i<length Ts \<longrightarrow> post(Ts ! i) = post(Rs ! i)))"
-apply(erule rtrancl_induct2)
- apply(simp_all)
-apply clarify
-apply simp
-apply(drule Parallel_length_post_P1)
-apply auto
-done
-
-lemma assertions_lemma: "pre c \<in> assertions c"
-apply(rule ann_com_com.induct [THEN conjunct1])
-apply auto
-done
-
-lemma interfree_aux1 [rule_format]:
- "(c,s) -1\<rightarrow> (r,t) \<longrightarrow> (interfree_aux(c1, q1, c) \<longrightarrow> interfree_aux(c1, q1, r))"
-apply (rule ann_transition_transition.induct [THEN conjunct1])
-apply(safe)
-prefer 13
-apply (rule TrueI)
-apply (simp_all add:interfree_aux_def)
-apply force+
-done
-
-lemma interfree_aux2 [rule_format]:
- "(c,s) -1\<rightarrow> (r,t) \<longrightarrow> (interfree_aux(c, q, a) \<longrightarrow> interfree_aux(r, q, a) )"
-apply (rule ann_transition_transition.induct [THEN conjunct1])
-apply(force simp add:interfree_aux_def)+
-done
-
-lemma interfree_lemma: "\<lbrakk> (Some c, s) -1\<rightarrow> (r, t);interfree Ts ; i<length Ts;
- Ts!i = (Some c, q) \<rbrakk> \<Longrightarrow> interfree (Ts[i:= (r, q)])"
-apply(simp add: interfree_def)
-apply clarify
-apply(case_tac "i=j")
- apply(drule_tac t = "ia" in not_sym)
- apply simp_all
-apply(force elim: interfree_aux1)
-apply(force elim: interfree_aux2 simp add:nth_list_update)
-done
-
-text {* Strong Soundness Theorem for Parallel Programs:*}
-
-lemma Parallel_Strong_Soundness_Seq_aux:
- "\<lbrakk>interfree Ts; i<length Ts; com(Ts ! i) = Some(AnnSeq c0 c1) \<rbrakk>
- \<Longrightarrow> interfree (Ts[i:=(Some c0, pre c1)])"
-apply(simp add: interfree_def)
-apply clarify
-apply(case_tac "i=j")
- apply(force simp add: nth_list_update interfree_aux_def)
-apply(case_tac "i=ia")
- apply(erule_tac x=ia in allE)
- apply(force simp add:interfree_aux_def assertions_lemma)
-apply simp
-done
-
-lemma Parallel_Strong_Soundness_Seq [rule_format (no_asm)]:
- "\<lbrakk> \<forall>i<length Ts. (if com(Ts!i) = None then b \<in> post(Ts!i)
- else b \<in> pre(the(com(Ts!i))) \<and> \<turnstile> the(com(Ts!i)) post(Ts!i));
- com(Ts ! i) = Some(AnnSeq c0 c1); i<length Ts; interfree Ts \<rbrakk> \<Longrightarrow>
- (\<forall>ia<length Ts. (if com(Ts[i:=(Some c0, pre c1)]! ia) = None
- then b \<in> post(Ts[i:=(Some c0, pre c1)]! ia)
- else b \<in> pre(the(com(Ts[i:=(Some c0, pre c1)]! ia))) \<and>
- \<turnstile> the(com(Ts[i:=(Some c0, pre c1)]! ia)) post(Ts[i:=(Some c0, pre c1)]! ia)))
- \<and> interfree (Ts[i:= (Some c0, pre c1)])"
-apply(rule conjI)
- apply safe
- apply(case_tac "i=ia")
- apply simp
- apply(force dest: ann_hoare_case_analysis)
- apply simp
-apply(fast elim: Parallel_Strong_Soundness_Seq_aux)
-done
-
-lemma Parallel_Strong_Soundness_aux_aux [rule_format]:
- "(Some c, b) -1\<rightarrow> (co, t) \<longrightarrow>
- (\<forall>Ts. i<length Ts \<longrightarrow> com(Ts ! i) = Some c \<longrightarrow>
- (\<forall>i<length Ts. (if com(Ts ! i) = None then b\<in>post(Ts!i)
- else b\<in>pre(the(com(Ts!i))) \<and> \<turnstile> the(com(Ts!i)) post(Ts!i))) \<longrightarrow>
- interfree Ts \<longrightarrow>
- (\<forall>j. j<length Ts \<and> i\<noteq>j \<longrightarrow> (if com(Ts!j) = None then t\<in>post(Ts!j)
- else t\<in>pre(the(com(Ts!j))) \<and> \<turnstile> the(com(Ts!j)) post(Ts!j))) )"
-apply(rule ann_transition_transition.induct [THEN conjunct1])
-apply safe
-prefer 11
-apply(rule TrueI)
-apply simp_all
---{* Basic *}
- apply(erule_tac x = "i" in all_dupE, erule (1) notE impE)
- apply(erule_tac x = "j" in allE , erule (1) notE impE)
- apply(simp add: interfree_def)
- apply(erule_tac x = "j" in allE,simp)
- apply(erule_tac x = "i" in allE,simp)
- apply(drule_tac t = "i" in not_sym)
- apply(case_tac "com(Ts ! j)=None")
- apply(force intro: converse_rtrancl_into_rtrancl
- simp add: interfree_aux_def com_validity_def SEM_def sem_def All_None_def)
- apply(simp add:interfree_aux_def)
- apply clarify
- apply simp
- apply(erule_tac x="pre y" in ballE)
- apply(force intro: converse_rtrancl_into_rtrancl
- simp add: com_validity_def SEM_def sem_def All_None_def)
- apply(simp add:assertions_lemma)
---{* Seqs *}
- apply(erule_tac x = "Ts[i:=(Some c0, pre c1)]" in allE)
- apply(drule Parallel_Strong_Soundness_Seq,simp+)
- apply(erule_tac x = "Ts[i:=(Some c0, pre c1)]" in allE)
- apply(drule Parallel_Strong_Soundness_Seq,simp+)
---{* Await *}
-apply(rule_tac x = "i" in allE , assumption , erule (1) notE impE)
-apply(erule_tac x = "j" in allE , erule (1) notE impE)
-apply(simp add: interfree_def)
-apply(erule_tac x = "j" in allE,simp)
-apply(erule_tac x = "i" in allE,simp)
-apply(drule_tac t = "i" in not_sym)
-apply(case_tac "com(Ts ! j)=None")
- apply(force intro: converse_rtrancl_into_rtrancl simp add: interfree_aux_def
- com_validity_def SEM_def sem_def All_None_def Help)
-apply(simp add:interfree_aux_def)
-apply clarify
-apply simp
-apply(erule_tac x="pre y" in ballE)
- apply(force intro: converse_rtrancl_into_rtrancl
- simp add: com_validity_def SEM_def sem_def All_None_def Help)
-apply(simp add:assertions_lemma)
-done
-
-lemma Parallel_Strong_Soundness_aux [rule_format]:
- "\<lbrakk>(Ts',s) -P*\<rightarrow> (Rs',t); Ts' = (Parallel Ts); interfree Ts;
- \<forall>i. i<length Ts \<longrightarrow> (\<exists>c q. (Ts ! i) = (Some c, q) \<and> s\<in>(pre c) \<and> \<turnstile> c q ) \<rbrakk> \<Longrightarrow>
- \<forall>Rs. Rs' = (Parallel Rs) \<longrightarrow> (\<forall>j. j<length Rs \<longrightarrow>
- (if com(Rs ! j) = None then t\<in>post(Ts ! j)
- else t\<in>pre(the(com(Rs ! j))) \<and> \<turnstile> the(com(Rs ! j)) post(Ts ! j))) \<and> interfree Rs"
-apply(erule rtrancl_induct2)
- apply clarify
---{* Base *}
- apply force
---{* Induction step *}
-apply clarify
-apply(drule Parallel_length_post_PStar)
-apply clarify
-apply (ind_cases "(Parallel Ts, s) -P1\<rightarrow> (Parallel Rs, t)" for Ts s Rs t)
-apply(rule conjI)
- apply clarify
- apply(case_tac "i=j")
- apply(simp split del:split_if)
- apply(erule Strong_Soundness_aux_aux,simp+)
- apply force
- apply force
- apply(simp split del: split_if)
- apply(erule Parallel_Strong_Soundness_aux_aux)
- apply(simp_all add: split del:split_if)
- apply force
-apply(rule interfree_lemma)
-apply simp_all
-done
-
-lemma Parallel_Strong_Soundness:
- "\<lbrakk>(Parallel Ts, s) -P*\<rightarrow> (Parallel Rs, t); interfree Ts; j<length Rs;
- \<forall>i. i<length Ts \<longrightarrow> (\<exists>c q. Ts ! i = (Some c, q) \<and> s\<in>pre c \<and> \<turnstile> c q) \<rbrakk> \<Longrightarrow>
- if com(Rs ! j) = None then t\<in>post(Ts ! j) else t\<in>pre (the(com(Rs ! j)))"
-apply(drule Parallel_Strong_Soundness_aux)
-apply simp+
-done
-
-lemma oghoare_sound [rule_format]: "\<parallel>- p c q \<longrightarrow> \<parallel>= p c q"
-apply (unfold com_validity_def)
-apply(rule oghoare_induct)
-apply(rule TrueI)+
---{* Parallel *}
- apply(simp add: SEM_def sem_def)
- apply clarify
- apply(frule Parallel_length_post_PStar)
- apply clarify
- apply(drule_tac j=xb in Parallel_Strong_Soundness)
- apply clarify
- apply simp
- apply force
- apply simp
- apply(erule_tac V = "\<forall>i. ?P i" in thin_rl)
- apply(drule_tac s = "length Rs" in sym)
- apply(erule allE, erule impE, assumption)
- apply(force dest: nth_mem simp add: All_None_def)
---{* Basic *}
- apply(simp add: SEM_def sem_def)
- apply(force dest: rtrancl_imp_UN_rel_pow Basic_ntran)
---{* Seq *}
- apply(rule subset_trans)
- prefer 2 apply assumption
- apply(simp add: L3_5ii L3_5i)
---{* Cond *}
- apply(simp add: L3_5iv)
---{* While *}
- apply(simp add: L3_5v)
- apply (blast dest: SEM_fwhile)
---{* Conseq *}
-apply(auto simp add: SEM_def sem_def)
-done
-
-end
\ No newline at end of file
--- a/src/HOL/HoareParallel/OG_Syntax.thy Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,140 +0,0 @@
-theory OG_Syntax
-imports OG_Tactics Quote_Antiquote
-begin
-
-text{* Syntax for commands and for assertions and boolean expressions in
- commands @{text com} and annotated commands @{text ann_com}. *}
-
-syntax
- "_Assign" :: "idt \<Rightarrow> 'b \<Rightarrow> 'a com" ("(\<acute>_ :=/ _)" [70, 65] 61)
- "_AnnAssign" :: "'a assn \<Rightarrow> idt \<Rightarrow> 'b \<Rightarrow> 'a com" ("(_ \<acute>_ :=/ _)" [90,70,65] 61)
-
-translations
- "\<acute>\<spacespace>x := a" \<rightharpoonup> "Basic \<guillemotleft>\<acute>\<spacespace>(_update_name x (\<lambda>_. a))\<guillemotright>"
- "r \<acute>\<spacespace>x := a" \<rightharpoonup> "AnnBasic r \<guillemotleft>\<acute>\<spacespace>(_update_name x (\<lambda>_. a))\<guillemotright>"
-
-syntax
- "_AnnSkip" :: "'a assn \<Rightarrow> 'a ann_com" ("_//SKIP" [90] 63)
- "_AnnSeq" :: "'a ann_com \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com" ("_;;/ _" [60,61] 60)
-
- "_AnnCond1" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com"
- ("_ //IF _ /THEN _ /ELSE _ /FI" [90,0,0,0] 61)
- "_AnnCond2" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com"
- ("_ //IF _ /THEN _ /FI" [90,0,0] 61)
- "_AnnWhile" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a assn \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com"
- ("_ //WHILE _ /INV _ //DO _//OD" [90,0,0,0] 61)
- "_AnnAwait" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a ann_com"
- ("_ //AWAIT _ /THEN /_ /END" [90,0,0] 61)
- "_AnnAtom" :: "'a assn \<Rightarrow> 'a com \<Rightarrow> 'a ann_com" ("_//\<langle>_\<rangle>" [90,0] 61)
- "_AnnWait" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a ann_com" ("_//WAIT _ END" [90,0] 61)
-
- "_Skip" :: "'a com" ("SKIP" 63)
- "_Seq" :: "'a com \<Rightarrow> 'a com \<Rightarrow> 'a com" ("_,,/ _" [55, 56] 55)
- "_Cond" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com \<Rightarrow> 'a com"
- ("(0IF _/ THEN _/ ELSE _/ FI)" [0, 0, 0] 61)
- "_Cond2" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com" ("IF _ THEN _ FI" [0,0] 56)
- "_While_inv" :: "'a bexp \<Rightarrow> 'a assn \<Rightarrow> 'a com \<Rightarrow> 'a com"
- ("(0WHILE _/ INV _ //DO _ /OD)" [0, 0, 0] 61)
- "_While" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com"
- ("(0WHILE _ //DO _ /OD)" [0, 0] 61)
-
-translations
- "SKIP" \<rightleftharpoons> "Basic id"
- "c_1,, c_2" \<rightleftharpoons> "Seq c_1 c_2"
-
- "IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "Cond .{b}. c1 c2"
- "IF b THEN c FI" \<rightleftharpoons> "IF b THEN c ELSE SKIP FI"
- "WHILE b INV i DO c OD" \<rightharpoonup> "While .{b}. i c"
- "WHILE b DO c OD" \<rightleftharpoons> "WHILE b INV CONST undefined DO c OD"
-
- "r SKIP" \<rightleftharpoons> "AnnBasic r id"
- "c_1;; c_2" \<rightleftharpoons> "AnnSeq c_1 c_2"
- "r IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "AnnCond1 r .{b}. c1 c2"
- "r IF b THEN c FI" \<rightharpoonup> "AnnCond2 r .{b}. c"
- "r WHILE b INV i DO c OD" \<rightharpoonup> "AnnWhile r .{b}. i c"
- "r AWAIT b THEN c END" \<rightharpoonup> "AnnAwait r .{b}. c"
- "r \<langle>c\<rangle>" \<rightleftharpoons> "r AWAIT True THEN c END"
- "r WAIT b END" \<rightleftharpoons> "r AWAIT b THEN SKIP END"
-
-nonterminals
- prgs
-
-syntax
- "_PAR" :: "prgs \<Rightarrow> 'a" ("COBEGIN//_//COEND" [57] 56)
- "_prg" :: "['a, 'a] \<Rightarrow> prgs" ("_//_" [60, 90] 57)
- "_prgs" :: "['a, 'a, prgs] \<Rightarrow> prgs" ("_//_//\<parallel>//_" [60,90,57] 57)
-
- "_prg_scheme" :: "['a, 'a, 'a, 'a, 'a] \<Rightarrow> prgs"
- ("SCHEME [_ \<le> _ < _] _// _" [0,0,0,60, 90] 57)
-
-translations
- "_prg c q" \<rightleftharpoons> "[(Some c, q)]"
- "_prgs c q ps" \<rightleftharpoons> "(Some c, q) # ps"
- "_PAR ps" \<rightleftharpoons> "Parallel ps"
-
- "_prg_scheme j i k c q" \<rightleftharpoons> "map (\<lambda>i. (Some c, q)) [j..<k]"
-
-print_translation {*
- let
- fun quote_tr' f (t :: ts) =
- Term.list_comb (f $ Syntax.quote_tr' "_antiquote" t, ts)
- | quote_tr' _ _ = raise Match;
-
- fun annquote_tr' f (r :: t :: ts) =
- Term.list_comb (f $ r $ Syntax.quote_tr' "_antiquote" t, ts)
- | annquote_tr' _ _ = raise Match;
-
- val assert_tr' = quote_tr' (Syntax.const "_Assert");
-
- fun bexp_tr' name ((Const ("Collect", _) $ t) :: ts) =
- quote_tr' (Syntax.const name) (t :: ts)
- | bexp_tr' _ _ = raise Match;
-
- fun annbexp_tr' name (r :: (Const ("Collect", _) $ t) :: ts) =
- annquote_tr' (Syntax.const name) (r :: t :: ts)
- | annbexp_tr' _ _ = raise Match;
-
- fun upd_tr' (x_upd, T) =
- (case try (unsuffix Record.updateN) x_upd of
- SOME x => (x, if T = dummyT then T else Term.domain_type T)
- | NONE => raise Match);
-
- fun update_name_tr' (Free x) = Free (upd_tr' x)
- | update_name_tr' ((c as Const ("_free", _)) $ Free x) =
- c $ Free (upd_tr' x)
- | update_name_tr' (Const x) = Const (upd_tr' x)
- | update_name_tr' _ = raise Match;
-
- fun K_tr' (Abs (_,_,t)) = if null (loose_bnos t) then t else raise Match
- | K_tr' (Abs (_,_,Abs (_,_,t)$Bound 0)) = if null (loose_bnos t) then t else raise Match
- | K_tr' _ = raise Match;
-
- fun assign_tr' (Abs (x, _, f $ k $ Bound 0) :: ts) =
- quote_tr' (Syntax.const "_Assign" $ update_name_tr' f)
- (Abs (x, dummyT, K_tr' k) :: ts)
- | assign_tr' _ = raise Match;
-
- fun annassign_tr' (r :: Abs (x, _, f $ k $ Bound 0) :: ts) =
- quote_tr' (Syntax.const "_AnnAssign" $ r $ update_name_tr' f)
- (Abs (x, dummyT, K_tr' k) :: ts)
- | annassign_tr' _ = raise Match;
-
- fun Parallel_PAR [(Const ("Cons",_) $ (Const ("Pair",_) $ (Const ("Some",_) $ t1 ) $ t2) $ Const ("Nil",_))] =
- (Syntax.const "_prg" $ t1 $ t2)
- | Parallel_PAR [(Const ("Cons",_) $ (Const ("Pair",_) $ (Const ("Some",_) $ t1) $ t2) $ ts)] =
- (Syntax.const "_prgs" $ t1 $ t2 $ Parallel_PAR [ts])
- | Parallel_PAR _ = raise Match;
-
-fun Parallel_tr' ts = Syntax.const "_PAR" $ Parallel_PAR ts;
- in
- [("Collect", assert_tr'), ("Basic", assign_tr'),
- ("Cond", bexp_tr' "_Cond"), ("While", bexp_tr' "_While_inv"),
- ("AnnBasic", annassign_tr'),
- ("AnnWhile", annbexp_tr' "_AnnWhile"), ("AnnAwait", annbexp_tr' "_AnnAwait"),
- ("AnnCond1", annbexp_tr' "_AnnCond1"), ("AnnCond2", annbexp_tr' "_AnnCond2")]
-
- end
-
-*}
-
-end
\ No newline at end of file
--- a/src/HOL/HoareParallel/OG_Tactics.thy Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,496 +0,0 @@
-header {* \section{Generation of Verification Conditions} *}
-
-theory OG_Tactics
-imports OG_Hoare
-begin
-
-lemmas ann_hoare_intros=AnnBasic AnnSeq AnnCond1 AnnCond2 AnnWhile AnnAwait AnnConseq
-lemmas oghoare_intros=Parallel Basic Seq Cond While Conseq
-
-lemma ParallelConseqRule:
- "\<lbrakk> p \<subseteq> (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts ! i))));
- \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts ! i))))
- (Parallel Ts)
- (\<Inter>i\<in>{i. i<length Ts}. post(Ts ! i));
- (\<Inter>i\<in>{i. i<length Ts}. post(Ts ! i)) \<subseteq> q \<rbrakk>
- \<Longrightarrow> \<parallel>- p (Parallel Ts) q"
-apply (rule Conseq)
-prefer 2
- apply fast
-apply assumption+
-done
-
-lemma SkipRule: "p \<subseteq> q \<Longrightarrow> \<parallel>- p (Basic id) q"
-apply(rule oghoare_intros)
- prefer 2 apply(rule Basic)
- prefer 2 apply(rule subset_refl)
-apply(simp add:Id_def)
-done
-
-lemma BasicRule: "p \<subseteq> {s. (f s)\<in>q} \<Longrightarrow> \<parallel>- p (Basic f) q"
-apply(rule oghoare_intros)
- prefer 2 apply(rule oghoare_intros)
- prefer 2 apply(rule subset_refl)
-apply assumption
-done
-
-lemma SeqRule: "\<lbrakk> \<parallel>- p c1 r; \<parallel>- r c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Seq c1 c2) q"
-apply(rule Seq)
-apply fast+
-done
-
-lemma CondRule:
- "\<lbrakk> p \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>w) \<and> (s\<notin>b \<longrightarrow> s\<in>w')}; \<parallel>- w c1 q; \<parallel>- w' c2 q \<rbrakk>
- \<Longrightarrow> \<parallel>- p (Cond b c1 c2) q"
-apply(rule Cond)
- apply(rule Conseq)
- prefer 4 apply(rule Conseq)
-apply simp_all
-apply force+
-done
-
-lemma WhileRule: "\<lbrakk> p \<subseteq> i; \<parallel>- (i \<inter> b) c i ; (i \<inter> (-b)) \<subseteq> q \<rbrakk>
- \<Longrightarrow> \<parallel>- p (While b i c) q"
-apply(rule Conseq)
- prefer 2 apply(rule While)
-apply assumption+
-done
-
-text {* Three new proof rules for special instances of the @{text
-AnnBasic} and the @{text AnnAwait} commands when the transformation
-performed on the state is the identity, and for an @{text AnnAwait}
-command where the boolean condition is @{text "{s. True}"}: *}
-
-lemma AnnatomRule:
- "\<lbrakk> atom_com(c); \<parallel>- r c q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnAwait r {s. True} c) q"
-apply(rule AnnAwait)
-apply simp_all
-done
-
-lemma AnnskipRule:
- "r \<subseteq> q \<Longrightarrow> \<turnstile> (AnnBasic r id) q"
-apply(rule AnnBasic)
-apply simp
-done
-
-lemma AnnwaitRule:
- "\<lbrakk> (r \<inter> b) \<subseteq> q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnAwait r b (Basic id)) q"
-apply(rule AnnAwait)
- apply simp
-apply(rule BasicRule)
-apply simp
-done
-
-text {* Lemmata to avoid using the definition of @{text
-map_ann_hoare}, @{text interfree_aux}, @{text interfree_swap} and
-@{text interfree} by splitting it into different cases: *}
-
-lemma interfree_aux_rule1: "interfree_aux(co, q, None)"
-by(simp add:interfree_aux_def)
-
-lemma interfree_aux_rule2:
- "\<forall>(R,r)\<in>(atomics a). \<parallel>- (q \<inter> R) r q \<Longrightarrow> interfree_aux(None, q, Some a)"
-apply(simp add:interfree_aux_def)
-apply(force elim:oghoare_sound)
-done
-
-lemma interfree_aux_rule3:
- "(\<forall>(R, r)\<in>(atomics a). \<parallel>- (q \<inter> R) r q \<and> (\<forall>p\<in>(assertions c). \<parallel>- (p \<inter> R) r p))
- \<Longrightarrow> interfree_aux(Some c, q, Some a)"
-apply(simp add:interfree_aux_def)
-apply(force elim:oghoare_sound)
-done
-
-lemma AnnBasic_assertions:
- "\<lbrakk>interfree_aux(None, r, Some a); interfree_aux(None, q, Some a)\<rbrakk> \<Longrightarrow>
- interfree_aux(Some (AnnBasic r f), q, Some a)"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnSeq_assertions:
- "\<lbrakk> interfree_aux(Some c1, q, Some a); interfree_aux(Some c2, q, Some a)\<rbrakk>\<Longrightarrow>
- interfree_aux(Some (AnnSeq c1 c2), q, Some a)"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnCond1_assertions:
- "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(Some c1, q, Some a);
- interfree_aux(Some c2, q, Some a)\<rbrakk>\<Longrightarrow>
- interfree_aux(Some(AnnCond1 r b c1 c2), q, Some a)"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnCond2_assertions:
- "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(Some c, q, Some a)\<rbrakk>\<Longrightarrow>
- interfree_aux(Some (AnnCond2 r b c), q, Some a)"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnWhile_assertions:
- "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(None, i, Some a);
- interfree_aux(Some c, q, Some a)\<rbrakk>\<Longrightarrow>
- interfree_aux(Some (AnnWhile r b i c), q, Some a)"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnAwait_assertions:
- "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(None, q, Some a)\<rbrakk>\<Longrightarrow>
- interfree_aux(Some (AnnAwait r b c), q, Some a)"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnBasic_atomics:
- "\<parallel>- (q \<inter> r) (Basic f) q \<Longrightarrow> interfree_aux(None, q, Some (AnnBasic r f))"
-by(simp add: interfree_aux_def oghoare_sound)
-
-lemma AnnSeq_atomics:
- "\<lbrakk> interfree_aux(Any, q, Some a1); interfree_aux(Any, q, Some a2)\<rbrakk>\<Longrightarrow>
- interfree_aux(Any, q, Some (AnnSeq a1 a2))"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnCond1_atomics:
- "\<lbrakk> interfree_aux(Any, q, Some a1); interfree_aux(Any, q, Some a2)\<rbrakk>\<Longrightarrow>
- interfree_aux(Any, q, Some (AnnCond1 r b a1 a2))"
-apply(simp add: interfree_aux_def)
-by force
-
-lemma AnnCond2_atomics:
- "interfree_aux (Any, q, Some a)\<Longrightarrow> interfree_aux(Any, q, Some (AnnCond2 r b a))"
-by(simp add: interfree_aux_def)
-
-lemma AnnWhile_atomics: "interfree_aux (Any, q, Some a)
- \<Longrightarrow> interfree_aux(Any, q, Some (AnnWhile r b i a))"
-by(simp add: interfree_aux_def)
-
-lemma Annatom_atomics:
- "\<parallel>- (q \<inter> r) a q \<Longrightarrow> interfree_aux (None, q, Some (AnnAwait r {x. True} a))"
-by(simp add: interfree_aux_def oghoare_sound)
-
-lemma AnnAwait_atomics:
- "\<parallel>- (q \<inter> (r \<inter> b)) a q \<Longrightarrow> interfree_aux (None, q, Some (AnnAwait r b a))"
-by(simp add: interfree_aux_def oghoare_sound)
-
-constdefs
- interfree_swap :: "('a ann_triple_op * ('a ann_triple_op) list) \<Rightarrow> bool"
- "interfree_swap == \<lambda>(x, xs). \<forall>y\<in>set xs. interfree_aux (com x, post x, com y)
- \<and> interfree_aux(com y, post y, com x)"
-
-lemma interfree_swap_Empty: "interfree_swap (x, [])"
-by(simp add:interfree_swap_def)
-
-lemma interfree_swap_List:
- "\<lbrakk> interfree_aux (com x, post x, com y);
- interfree_aux (com y, post y ,com x); interfree_swap (x, xs) \<rbrakk>
- \<Longrightarrow> interfree_swap (x, y#xs)"
-by(simp add:interfree_swap_def)
-
-lemma interfree_swap_Map: "\<forall>k. i\<le>k \<and> k<j \<longrightarrow> interfree_aux (com x, post x, c k)
- \<and> interfree_aux (c k, Q k, com x)
- \<Longrightarrow> interfree_swap (x, map (\<lambda>k. (c k, Q k)) [i..<j])"
-by(force simp add: interfree_swap_def less_diff_conv)
-
-lemma interfree_Empty: "interfree []"
-by(simp add:interfree_def)
-
-lemma interfree_List:
- "\<lbrakk> interfree_swap(x, xs); interfree xs \<rbrakk> \<Longrightarrow> interfree (x#xs)"
-apply(simp add:interfree_def interfree_swap_def)
-apply clarify
-apply(case_tac i)
- apply(case_tac j)
- apply simp_all
-apply(case_tac j,simp+)
-done
-
-lemma interfree_Map:
- "(\<forall>i j. a\<le>i \<and> i<b \<and> a\<le>j \<and> j<b \<and> i\<noteq>j \<longrightarrow> interfree_aux (c i, Q i, c j))
- \<Longrightarrow> interfree (map (\<lambda>k. (c k, Q k)) [a..<b])"
-by(force simp add: interfree_def less_diff_conv)
-
-constdefs map_ann_hoare :: "(('a ann_com_op * 'a assn) list) \<Rightarrow> bool " ("[\<turnstile>] _" [0] 45)
- "[\<turnstile>] Ts == (\<forall>i<length Ts. \<exists>c q. Ts!i=(Some c, q) \<and> \<turnstile> c q)"
-
-lemma MapAnnEmpty: "[\<turnstile>] []"
-by(simp add:map_ann_hoare_def)
-
-lemma MapAnnList: "\<lbrakk> \<turnstile> c q ; [\<turnstile>] xs \<rbrakk> \<Longrightarrow> [\<turnstile>] (Some c,q)#xs"
-apply(simp add:map_ann_hoare_def)
-apply clarify
-apply(case_tac i,simp+)
-done
-
-lemma MapAnnMap:
- "\<forall>k. i\<le>k \<and> k<j \<longrightarrow> \<turnstile> (c k) (Q k) \<Longrightarrow> [\<turnstile>] map (\<lambda>k. (Some (c k), Q k)) [i..<j]"
-apply(simp add: map_ann_hoare_def less_diff_conv)
-done
-
-lemma ParallelRule:"\<lbrakk> [\<turnstile>] Ts ; interfree Ts \<rbrakk>
- \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts!i))))
- Parallel Ts
- (\<Inter>i\<in>{i. i<length Ts}. post(Ts!i))"
-apply(rule Parallel)
- apply(simp add:map_ann_hoare_def)
-apply simp
-done
-(*
-lemma ParamParallelRule:
- "\<lbrakk> \<forall>k<n. \<turnstile> (c k) (Q k);
- \<forall>k l. k<n \<and> l<n \<and> k\<noteq>l \<longrightarrow> interfree_aux (Some(c k), Q k, Some(c l)) \<rbrakk>
- \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<n} . pre(c i)) COBEGIN SCHEME [0\<le>i<n] (c i) (Q i) COEND (\<Inter>i\<in>{i. i<n} . Q i )"
-apply(rule ParallelConseqRule)
- apply simp
- apply clarify
- apply force
- apply(rule ParallelRule)
- apply(rule MapAnnMap)
- apply simp
- apply(rule interfree_Map)
- apply simp
-apply simp
-apply clarify
-apply force
-done
-*)
-
-text {* The following are some useful lemmas and simplification
-tactics to control which theorems are used to simplify at each moment,
-so that the original input does not suffer any unexpected
-transformation. *}
-
-lemma Compl_Collect: "-(Collect b) = {x. \<not>(b x)}"
-by fast
-lemma list_length: "length []=0 \<and> length (x#xs) = Suc(length xs)"
-by simp
-lemma list_lemmas: "length []=0 \<and> length (x#xs) = Suc(length xs)
-\<and> (x#xs) ! 0=x \<and> (x#xs) ! Suc n = xs ! n"
-by simp
-lemma le_Suc_eq_insert: "{i. i <Suc n} = insert n {i. i< n}"
-by auto
-lemmas primrecdef_list = "pre.simps" "assertions.simps" "atomics.simps" "atom_com.simps"
-lemmas my_simp_list = list_lemmas fst_conv snd_conv
-not_less0 refl le_Suc_eq_insert Suc_not_Zero Zero_not_Suc nat.inject
-Collect_mem_eq ball_simps option.simps primrecdef_list
-lemmas ParallelConseq_list = INTER_def Collect_conj_eq length_map length_upt length_append list_length
-
-ML {*
-val before_interfree_simp_tac = (simp_tac (HOL_basic_ss addsimps [thm "com.simps", thm "post.simps"]))
-
-val interfree_simp_tac = (asm_simp_tac (HOL_ss addsimps [thm "split", thm "ball_Un", thm "ball_empty"]@(thms "my_simp_list")))
-
-val ParallelConseq = (simp_tac (HOL_basic_ss addsimps (thms "ParallelConseq_list")@(thms "my_simp_list")))
-*}
-
-text {* The following tactic applies @{text tac} to each conjunct in a
-subgoal of the form @{text "A \<Longrightarrow> a1 \<and> a2 \<and> .. \<and> an"} returning
-@{text n} subgoals, one for each conjunct: *}
-
-ML {*
-fun conjI_Tac tac i st = st |>
- ( (EVERY [rtac conjI i,
- conjI_Tac tac (i+1),
- tac i]) ORELSE (tac i) )
-*}
-
-
-subsubsection {* Tactic for the generation of the verification conditions *}
-
-text {* The tactic basically uses two subtactics:
-
-\begin{description}
-
-\item[HoareRuleTac] is called at the level of parallel programs, it
- uses the ParallelTac to solve parallel composition of programs.
- This verification has two parts, namely, (1) all component programs are
- correct and (2) they are interference free. @{text HoareRuleTac} is
- also called at the level of atomic regions, i.e. @{text "\<langle> \<rangle>"} and
- @{text "AWAIT b THEN _ END"}, and at each interference freedom test.
-
-\item[AnnHoareRuleTac] is for component programs which
- are annotated programs and so, there are not unknown assertions
- (no need to use the parameter precond, see NOTE).
-
- NOTE: precond(::bool) informs if the subgoal has the form @{text "\<parallel>- ?p c q"},
- in this case we have precond=False and the generated verification
- condition would have the form @{text "?p \<subseteq> \<dots>"} which can be solved by
- @{text "rtac subset_refl"}, if True we proceed to simplify it using
- the simplification tactics above.
-
-\end{description}
-*}
-
-ML {*
-
- fun WlpTac i = (rtac (@{thm SeqRule}) i) THEN (HoareRuleTac false (i+1))
-and HoareRuleTac precond i st = st |>
- ( (WlpTac i THEN HoareRuleTac precond i)
- ORELSE
- (FIRST[rtac (@{thm SkipRule}) i,
- rtac (@{thm BasicRule}) i,
- EVERY[rtac (@{thm ParallelConseqRule}) i,
- ParallelConseq (i+2),
- ParallelTac (i+1),
- ParallelConseq i],
- EVERY[rtac (@{thm CondRule}) i,
- HoareRuleTac false (i+2),
- HoareRuleTac false (i+1)],
- EVERY[rtac (@{thm WhileRule}) i,
- HoareRuleTac true (i+1)],
- K all_tac i ]
- THEN (if precond then (K all_tac i) else (rtac (@{thm subset_refl}) i))))
-
-and AnnWlpTac i = (rtac (@{thm AnnSeq}) i) THEN (AnnHoareRuleTac (i+1))
-and AnnHoareRuleTac i st = st |>
- ( (AnnWlpTac i THEN AnnHoareRuleTac i )
- ORELSE
- (FIRST[(rtac (@{thm AnnskipRule}) i),
- EVERY[rtac (@{thm AnnatomRule}) i,
- HoareRuleTac true (i+1)],
- (rtac (@{thm AnnwaitRule}) i),
- rtac (@{thm AnnBasic}) i,
- EVERY[rtac (@{thm AnnCond1}) i,
- AnnHoareRuleTac (i+3),
- AnnHoareRuleTac (i+1)],
- EVERY[rtac (@{thm AnnCond2}) i,
- AnnHoareRuleTac (i+1)],
- EVERY[rtac (@{thm AnnWhile}) i,
- AnnHoareRuleTac (i+2)],
- EVERY[rtac (@{thm AnnAwait}) i,
- HoareRuleTac true (i+1)],
- K all_tac i]))
-
-and ParallelTac i = EVERY[rtac (@{thm ParallelRule}) i,
- interfree_Tac (i+1),
- MapAnn_Tac i]
-
-and MapAnn_Tac i st = st |>
- (FIRST[rtac (@{thm MapAnnEmpty}) i,
- EVERY[rtac (@{thm MapAnnList}) i,
- MapAnn_Tac (i+1),
- AnnHoareRuleTac i],
- EVERY[rtac (@{thm MapAnnMap}) i,
- rtac (@{thm allI}) i,rtac (@{thm impI}) i,
- AnnHoareRuleTac i]])
-
-and interfree_swap_Tac i st = st |>
- (FIRST[rtac (@{thm interfree_swap_Empty}) i,
- EVERY[rtac (@{thm interfree_swap_List}) i,
- interfree_swap_Tac (i+2),
- interfree_aux_Tac (i+1),
- interfree_aux_Tac i ],
- EVERY[rtac (@{thm interfree_swap_Map}) i,
- rtac (@{thm allI}) i,rtac (@{thm impI}) i,
- conjI_Tac (interfree_aux_Tac) i]])
-
-and interfree_Tac i st = st |>
- (FIRST[rtac (@{thm interfree_Empty}) i,
- EVERY[rtac (@{thm interfree_List}) i,
- interfree_Tac (i+1),
- interfree_swap_Tac i],
- EVERY[rtac (@{thm interfree_Map}) i,
- rtac (@{thm allI}) i,rtac (@{thm allI}) i,rtac (@{thm impI}) i,
- interfree_aux_Tac i ]])
-
-and interfree_aux_Tac i = (before_interfree_simp_tac i ) THEN
- (FIRST[rtac (@{thm interfree_aux_rule1}) i,
- dest_assertions_Tac i])
-
-and dest_assertions_Tac i st = st |>
- (FIRST[EVERY[rtac (@{thm AnnBasic_assertions}) i,
- dest_atomics_Tac (i+1),
- dest_atomics_Tac i],
- EVERY[rtac (@{thm AnnSeq_assertions}) i,
- dest_assertions_Tac (i+1),
- dest_assertions_Tac i],
- EVERY[rtac (@{thm AnnCond1_assertions}) i,
- dest_assertions_Tac (i+2),
- dest_assertions_Tac (i+1),
- dest_atomics_Tac i],
- EVERY[rtac (@{thm AnnCond2_assertions}) i,
- dest_assertions_Tac (i+1),
- dest_atomics_Tac i],
- EVERY[rtac (@{thm AnnWhile_assertions}) i,
- dest_assertions_Tac (i+2),
- dest_atomics_Tac (i+1),
- dest_atomics_Tac i],
- EVERY[rtac (@{thm AnnAwait_assertions}) i,
- dest_atomics_Tac (i+1),
- dest_atomics_Tac i],
- dest_atomics_Tac i])
-
-and dest_atomics_Tac i st = st |>
- (FIRST[EVERY[rtac (@{thm AnnBasic_atomics}) i,
- HoareRuleTac true i],
- EVERY[rtac (@{thm AnnSeq_atomics}) i,
- dest_atomics_Tac (i+1),
- dest_atomics_Tac i],
- EVERY[rtac (@{thm AnnCond1_atomics}) i,
- dest_atomics_Tac (i+1),
- dest_atomics_Tac i],
- EVERY[rtac (@{thm AnnCond2_atomics}) i,
- dest_atomics_Tac i],
- EVERY[rtac (@{thm AnnWhile_atomics}) i,
- dest_atomics_Tac i],
- EVERY[rtac (@{thm Annatom_atomics}) i,
- HoareRuleTac true i],
- EVERY[rtac (@{thm AnnAwait_atomics}) i,
- HoareRuleTac true i],
- K all_tac i])
-*}
-
-
-text {* The final tactic is given the name @{text oghoare}: *}
-
-ML {*
-val oghoare_tac = SUBGOAL (fn (_, i) =>
- (HoareRuleTac true i))
-*}
-
-text {* Notice that the tactic for parallel programs @{text
-"oghoare_tac"} is initially invoked with the value @{text true} for
-the parameter @{text precond}.
-
-Parts of the tactic can be also individually used to generate the
-verification conditions for annotated sequential programs and to
-generate verification conditions out of interference freedom tests: *}
-
-ML {* val annhoare_tac = SUBGOAL (fn (_, i) =>
- (AnnHoareRuleTac i))
-
-val interfree_aux_tac = SUBGOAL (fn (_, i) =>
- (interfree_aux_Tac i))
-*}
-
-text {* The so defined ML tactics are then ``exported'' to be used in
-Isabelle proofs. *}
-
-method_setup oghoare = {*
- Scan.succeed (K (SIMPLE_METHOD' oghoare_tac)) *}
- "verification condition generator for the oghoare logic"
-
-method_setup annhoare = {*
- Scan.succeed (K (SIMPLE_METHOD' annhoare_tac)) *}
- "verification condition generator for the ann_hoare logic"
-
-method_setup interfree_aux = {*
- Scan.succeed (K (SIMPLE_METHOD' interfree_aux_tac)) *}
- "verification condition generator for interference freedom tests"
-
-text {* Tactics useful for dealing with the generated verification conditions: *}
-
-method_setup conjI_tac = {*
- Scan.succeed (K (SIMPLE_METHOD' (conjI_Tac (K all_tac)))) *}
- "verification condition generator for interference freedom tests"
-
-ML {*
-fun disjE_Tac tac i st = st |>
- ( (EVERY [etac disjE i,
- disjE_Tac tac (i+1),
- tac i]) ORELSE (tac i) )
-*}
-
-method_setup disjE_tac = {*
- Scan.succeed (K (SIMPLE_METHOD' (disjE_Tac (K all_tac)))) *}
- "verification condition generator for interference freedom tests"
-
-end
--- a/src/HOL/HoareParallel/OG_Tran.thy Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,309 +0,0 @@
-
-header {* \section{Operational Semantics} *}
-
-theory OG_Tran imports OG_Com begin
-
-types
- 'a ann_com_op = "('a ann_com) option"
- 'a ann_triple_op = "('a ann_com_op \<times> 'a assn)"
-
-consts com :: "'a ann_triple_op \<Rightarrow> 'a ann_com_op"
-primrec "com (c, q) = c"
-
-consts post :: "'a ann_triple_op \<Rightarrow> 'a assn"
-primrec "post (c, q) = q"
-
-constdefs
- All_None :: "'a ann_triple_op list \<Rightarrow> bool"
- "All_None Ts \<equiv> \<forall>(c, q) \<in> set Ts. c = None"
-
-subsection {* The Transition Relation *}
-
-inductive_set
- ann_transition :: "(('a ann_com_op \<times> 'a) \<times> ('a ann_com_op \<times> 'a)) set"
- and transition :: "(('a com \<times> 'a) \<times> ('a com \<times> 'a)) set"
- and ann_transition' :: "('a ann_com_op \<times> 'a) \<Rightarrow> ('a ann_com_op \<times> 'a) \<Rightarrow> bool"
- ("_ -1\<rightarrow> _"[81,81] 100)
- and transition' :: "('a com \<times> 'a) \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
- ("_ -P1\<rightarrow> _"[81,81] 100)
- and transitions :: "('a com \<times> 'a) \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
- ("_ -P*\<rightarrow> _"[81,81] 100)
-where
- "con_0 -1\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition"
-| "con_0 -P1\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition"
-| "con_0 -P*\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition\<^sup>*"
-
-| AnnBasic: "(Some (AnnBasic r f), s) -1\<rightarrow> (None, f s)"
-
-| AnnSeq1: "(Some c0, s) -1\<rightarrow> (None, t) \<Longrightarrow>
- (Some (AnnSeq c0 c1), s) -1\<rightarrow> (Some c1, t)"
-| AnnSeq2: "(Some c0, s) -1\<rightarrow> (Some c2, t) \<Longrightarrow>
- (Some (AnnSeq c0 c1), s) -1\<rightarrow> (Some (AnnSeq c2 c1), t)"
-
-| AnnCond1T: "s \<in> b \<Longrightarrow> (Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (Some c1, s)"
-| AnnCond1F: "s \<notin> b \<Longrightarrow> (Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (Some c2, s)"
-
-| AnnCond2T: "s \<in> b \<Longrightarrow> (Some (AnnCond2 r b c), s) -1\<rightarrow> (Some c, s)"
-| AnnCond2F: "s \<notin> b \<Longrightarrow> (Some (AnnCond2 r b c), s) -1\<rightarrow> (None, s)"
-
-| AnnWhileF: "s \<notin> b \<Longrightarrow> (Some (AnnWhile r b i c), s) -1\<rightarrow> (None, s)"
-| AnnWhileT: "s \<in> b \<Longrightarrow> (Some (AnnWhile r b i c), s) -1\<rightarrow>
- (Some (AnnSeq c (AnnWhile i b i c)), s)"
-
-| AnnAwait: "\<lbrakk> s \<in> b; atom_com c; (c, s) -P*\<rightarrow> (Parallel [], t) \<rbrakk> \<Longrightarrow>
- (Some (AnnAwait r b c), s) -1\<rightarrow> (None, t)"
-
-| Parallel: "\<lbrakk> i<length Ts; Ts!i = (Some c, q); (Some c, s) -1\<rightarrow> (r, t) \<rbrakk>
- \<Longrightarrow> (Parallel Ts, s) -P1\<rightarrow> (Parallel (Ts [i:=(r, q)]), t)"
-
-| Basic: "(Basic f, s) -P1\<rightarrow> (Parallel [], f s)"
-
-| Seq1: "All_None Ts \<Longrightarrow> (Seq (Parallel Ts) c, s) -P1\<rightarrow> (c, s)"
-| Seq2: "(c0, s) -P1\<rightarrow> (c2, t) \<Longrightarrow> (Seq c0 c1, s) -P1\<rightarrow> (Seq c2 c1, t)"
-
-| CondT: "s \<in> b \<Longrightarrow> (Cond b c1 c2, s) -P1\<rightarrow> (c1, s)"
-| CondF: "s \<notin> b \<Longrightarrow> (Cond b c1 c2, s) -P1\<rightarrow> (c2, s)"
-
-| WhileF: "s \<notin> b \<Longrightarrow> (While b i c, s) -P1\<rightarrow> (Parallel [], s)"
-| WhileT: "s \<in> b \<Longrightarrow> (While b i c, s) -P1\<rightarrow> (Seq c (While b i c), s)"
-
-monos "rtrancl_mono"
-
-text {* The corresponding syntax translations are: *}
-
-abbreviation
- ann_transition_n :: "('a ann_com_op \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a ann_com_op \<times> 'a)
- \<Rightarrow> bool" ("_ -_\<rightarrow> _"[81,81] 100) where
- "con_0 -n\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition ^^ n"
-
-abbreviation
- ann_transitions :: "('a ann_com_op \<times> 'a) \<Rightarrow> ('a ann_com_op \<times> 'a) \<Rightarrow> bool"
- ("_ -*\<rightarrow> _"[81,81] 100) where
- "con_0 -*\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition\<^sup>*"
-
-abbreviation
- transition_n :: "('a com \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
- ("_ -P_\<rightarrow> _"[81,81,81] 100) where
- "con_0 -Pn\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition ^^ n"
-
-subsection {* Definition of Semantics *}
-
-constdefs
- ann_sem :: "'a ann_com \<Rightarrow> 'a \<Rightarrow> 'a set"
- "ann_sem c \<equiv> \<lambda>s. {t. (Some c, s) -*\<rightarrow> (None, t)}"
-
- ann_SEM :: "'a ann_com \<Rightarrow> 'a set \<Rightarrow> 'a set"
- "ann_SEM c S \<equiv> \<Union>ann_sem c ` S"
-
- sem :: "'a com \<Rightarrow> 'a \<Rightarrow> 'a set"
- "sem c \<equiv> \<lambda>s. {t. \<exists>Ts. (c, s) -P*\<rightarrow> (Parallel Ts, t) \<and> All_None Ts}"
-
- SEM :: "'a com \<Rightarrow> 'a set \<Rightarrow> 'a set"
- "SEM c S \<equiv> \<Union>sem c ` S "
-
-syntax "_Omega" :: "'a com" ("\<Omega>" 63)
-translations "\<Omega>" \<rightleftharpoons> "While CONST UNIV CONST UNIV (Basic id)"
-
-consts fwhile :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> nat \<Rightarrow> 'a com"
-primrec
- "fwhile b c 0 = \<Omega>"
- "fwhile b c (Suc n) = Cond b (Seq c (fwhile b c n)) (Basic id)"
-
-subsubsection {* Proofs *}
-
-declare ann_transition_transition.intros [intro]
-inductive_cases transition_cases:
- "(Parallel T,s) -P1\<rightarrow> t"
- "(Basic f, s) -P1\<rightarrow> t"
- "(Seq c1 c2, s) -P1\<rightarrow> t"
- "(Cond b c1 c2, s) -P1\<rightarrow> t"
- "(While b i c, s) -P1\<rightarrow> t"
-
-lemma Parallel_empty_lemma [rule_format (no_asm)]:
- "(Parallel [],s) -Pn\<rightarrow> (Parallel Ts,t) \<longrightarrow> Ts=[] \<and> n=0 \<and> s=t"
-apply(induct n)
- apply(simp (no_asm))
-apply clarify
-apply(drule rel_pow_Suc_D2)
-apply(force elim:transition_cases)
-done
-
-lemma Parallel_AllNone_lemma [rule_format (no_asm)]:
- "All_None Ss \<longrightarrow> (Parallel Ss,s) -Pn\<rightarrow> (Parallel Ts,t) \<longrightarrow> Ts=Ss \<and> n=0 \<and> s=t"
-apply(induct "n")
- apply(simp (no_asm))
-apply clarify
-apply(drule rel_pow_Suc_D2)
-apply clarify
-apply(erule transition_cases,simp_all)
-apply(force dest:nth_mem simp add:All_None_def)
-done
-
-lemma Parallel_AllNone: "All_None Ts \<Longrightarrow> (SEM (Parallel Ts) X) = X"
-apply (unfold SEM_def sem_def)
-apply auto
-apply(drule rtrancl_imp_UN_rel_pow)
-apply clarify
-apply(drule Parallel_AllNone_lemma)
-apply auto
-done
-
-lemma Parallel_empty: "Ts=[] \<Longrightarrow> (SEM (Parallel Ts) X) = X"
-apply(rule Parallel_AllNone)
-apply(simp add:All_None_def)
-done
-
-text {* Set of lemmas from Apt and Olderog "Verification of sequential
-and concurrent programs", page 63. *}
-
-lemma L3_5i: "X\<subseteq>Y \<Longrightarrow> SEM c X \<subseteq> SEM c Y"
-apply (unfold SEM_def)
-apply force
-done
-
-lemma L3_5ii_lemma1:
- "\<lbrakk> (c1, s1) -P*\<rightarrow> (Parallel Ts, s2); All_None Ts;
- (c2, s2) -P*\<rightarrow> (Parallel Ss, s3); All_None Ss \<rbrakk>
- \<Longrightarrow> (Seq c1 c2, s1) -P*\<rightarrow> (Parallel Ss, s3)"
-apply(erule converse_rtrancl_induct2)
-apply(force intro:converse_rtrancl_into_rtrancl)+
-done
-
-lemma L3_5ii_lemma2 [rule_format (no_asm)]:
- "\<forall>c1 c2 s t. (Seq c1 c2, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow>
- (All_None Ts) \<longrightarrow> (\<exists>y m Rs. (c1,s) -P*\<rightarrow> (Parallel Rs, y) \<and>
- (All_None Rs) \<and> (c2, y) -Pm\<rightarrow> (Parallel Ts, t) \<and> m \<le> n)"
-apply(induct "n")
- apply(force)
-apply(safe dest!: rel_pow_Suc_D2)
-apply(erule transition_cases,simp_all)
- apply (fast intro!: le_SucI)
-apply (fast intro!: le_SucI elim!: rel_pow_imp_rtrancl converse_rtrancl_into_rtrancl)
-done
-
-lemma L3_5ii_lemma3:
- "\<lbrakk>(Seq c1 c2,s) -P*\<rightarrow> (Parallel Ts,t); All_None Ts\<rbrakk> \<Longrightarrow>
- (\<exists>y Rs. (c1,s) -P*\<rightarrow> (Parallel Rs,y) \<and> All_None Rs
- \<and> (c2,y) -P*\<rightarrow> (Parallel Ts,t))"
-apply(drule rtrancl_imp_UN_rel_pow)
-apply(fast dest: L3_5ii_lemma2 rel_pow_imp_rtrancl)
-done
-
-lemma L3_5ii: "SEM (Seq c1 c2) X = SEM c2 (SEM c1 X)"
-apply (unfold SEM_def sem_def)
-apply auto
- apply(fast dest: L3_5ii_lemma3)
-apply(fast elim: L3_5ii_lemma1)
-done
-
-lemma L3_5iii: "SEM (Seq (Seq c1 c2) c3) X = SEM (Seq c1 (Seq c2 c3)) X"
-apply (simp (no_asm) add: L3_5ii)
-done
-
-lemma L3_5iv:
- "SEM (Cond b c1 c2) X = (SEM c1 (X \<inter> b)) Un (SEM c2 (X \<inter> (-b)))"
-apply (unfold SEM_def sem_def)
-apply auto
-apply(erule converse_rtranclE)
- prefer 2
- apply (erule transition_cases,simp_all)
- apply(fast intro: converse_rtrancl_into_rtrancl elim: transition_cases)+
-done
-
-
-lemma L3_5v_lemma1[rule_format]:
- "(S,s) -Pn\<rightarrow> (T,t) \<longrightarrow> S=\<Omega> \<longrightarrow> (\<not>(\<exists>Rs. T=(Parallel Rs) \<and> All_None Rs))"
-apply (unfold UNIV_def)
-apply(rule nat_less_induct)
-apply safe
-apply(erule rel_pow_E2)
- apply simp_all
-apply(erule transition_cases)
- apply simp_all
-apply(erule rel_pow_E2)
- apply(simp add: Id_def)
-apply(erule transition_cases,simp_all)
-apply clarify
-apply(erule transition_cases,simp_all)
-apply(erule rel_pow_E2,simp)
-apply clarify
-apply(erule transition_cases)
- apply simp+
- apply clarify
- apply(erule transition_cases)
-apply simp_all
-done
-
-lemma L3_5v_lemma2: "\<lbrakk>(\<Omega>, s) -P*\<rightarrow> (Parallel Ts, t); All_None Ts \<rbrakk> \<Longrightarrow> False"
-apply(fast dest: rtrancl_imp_UN_rel_pow L3_5v_lemma1)
-done
-
-lemma L3_5v_lemma3: "SEM (\<Omega>) S = {}"
-apply (unfold SEM_def sem_def)
-apply(fast dest: L3_5v_lemma2)
-done
-
-lemma L3_5v_lemma4 [rule_format]:
- "\<forall>s. (While b i c, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow>
- (\<exists>k. (fwhile b c k, s) -P*\<rightarrow> (Parallel Ts, t))"
-apply(rule nat_less_induct)
-apply safe
-apply(erule rel_pow_E2)
- apply safe
-apply(erule transition_cases,simp_all)
- apply (rule_tac x = "1" in exI)
- apply(force dest: Parallel_empty_lemma intro: converse_rtrancl_into_rtrancl simp add: Id_def)
-apply safe
-apply(drule L3_5ii_lemma2)
- apply safe
-apply(drule le_imp_less_Suc)
-apply (erule allE , erule impE,assumption)
-apply (erule allE , erule impE, assumption)
-apply safe
-apply (rule_tac x = "k+1" in exI)
-apply(simp (no_asm))
-apply(rule converse_rtrancl_into_rtrancl)
- apply fast
-apply(fast elim: L3_5ii_lemma1)
-done
-
-lemma L3_5v_lemma5 [rule_format]:
- "\<forall>s. (fwhile b c k, s) -P*\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow>
- (While b i c, s) -P*\<rightarrow> (Parallel Ts,t)"
-apply(induct "k")
- apply(force dest: L3_5v_lemma2)
-apply safe
-apply(erule converse_rtranclE)
- apply simp_all
-apply(erule transition_cases,simp_all)
- apply(rule converse_rtrancl_into_rtrancl)
- apply(fast)
- apply(fast elim!: L3_5ii_lemma1 dest: L3_5ii_lemma3)
-apply(drule rtrancl_imp_UN_rel_pow)
-apply clarify
-apply(erule rel_pow_E2)
- apply simp_all
-apply(erule transition_cases,simp_all)
-apply(fast dest: Parallel_empty_lemma)
-done
-
-lemma L3_5v: "SEM (While b i c) = (\<lambda>x. (\<Union>k. SEM (fwhile b c k) x))"
-apply(rule ext)
-apply (simp add: SEM_def sem_def)
-apply safe
- apply(drule rtrancl_imp_UN_rel_pow,simp)
- apply clarify
- apply(fast dest:L3_5v_lemma4)
-apply(fast intro: L3_5v_lemma5)
-done
-
-section {* Validity of Correctness Formulas *}
-
-constdefs
- com_validity :: "'a assn \<Rightarrow> 'a com \<Rightarrow> 'a assn \<Rightarrow> bool" ("(3\<parallel>= _// _//_)" [90,55,90] 50)
- "\<parallel>= p c q \<equiv> SEM c p \<subseteq> q"
-
- ann_com_validity :: "'a ann_com \<Rightarrow> 'a assn \<Rightarrow> bool" ("\<Turnstile> _ _" [60,90] 45)
- "\<Turnstile> c q \<equiv> ann_SEM c (pre c) \<subseteq> q"
-
-end
\ No newline at end of file
--- a/src/HOL/HoareParallel/Quote_Antiquote.thy Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,24 +0,0 @@
-
-header {* \section{Concrete Syntax} *}
-
-theory Quote_Antiquote imports Main begin
-
-syntax
- "_quote" :: "'b \<Rightarrow> ('a \<Rightarrow> 'b)" ("(\<guillemotleft>_\<guillemotright>)" [0] 1000)
- "_antiquote" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b" ("\<acute>_" [1000] 1000)
- "_Assert" :: "'a \<Rightarrow> 'a set" ("(.{_}.)" [0] 1000)
-
-syntax (xsymbols)
- "_Assert" :: "'a \<Rightarrow> 'a set" ("(\<lbrace>_\<rbrace>)" [0] 1000)
-
-translations
- ".{b}." \<rightharpoonup> "Collect \<guillemotleft>b\<guillemotright>"
-
-parse_translation {*
- let
- fun quote_tr [t] = Syntax.quote_tr "_antiquote" t
- | quote_tr ts = raise TERM ("quote_tr", ts);
- in [("_quote", quote_tr)] end
-*}
-
-end
\ No newline at end of file
--- a/src/HOL/HoareParallel/RG_Com.thy Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,25 +0,0 @@
-
-header {* \chapter{The Rely-Guarantee Method}
-
-\section {Abstract Syntax}
-*}
-
-theory RG_Com imports Main begin
-
-text {* Semantics of assertions and boolean expressions (bexp) as sets
-of states. Syntax of commands @{text com} and parallel commands
-@{text par_com}. *}
-
-types
- 'a bexp = "'a set"
-
-datatype 'a com =
- Basic "'a \<Rightarrow>'a"
- | Seq "'a com" "'a com"
- | Cond "'a bexp" "'a com" "'a com"
- | While "'a bexp" "'a com"
- | Await "'a bexp" "'a com"
-
-types 'a par_com = "(('a com) option) list"
-
-end
\ No newline at end of file
--- a/src/HOL/HoareParallel/RG_Examples.thy Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,359 +0,0 @@
-header {* \section{Examples} *}
-
-theory RG_Examples
-imports RG_Syntax
-begin
-
-lemmas definitions [simp]= stable_def Pre_def Rely_def Guar_def Post_def Com_def
-
-subsection {* Set Elements of an Array to Zero *}
-
-lemma le_less_trans2: "\<lbrakk>(j::nat)<k; i\<le> j\<rbrakk> \<Longrightarrow> i<k"
-by simp
-
-lemma add_le_less_mono: "\<lbrakk> (a::nat) < c; b\<le>d \<rbrakk> \<Longrightarrow> a + b < c + d"
-by simp
-
-record Example1 =
- A :: "nat list"
-
-lemma Example1:
- "\<turnstile> COBEGIN
- SCHEME [0 \<le> i < n]
- (\<acute>A := \<acute>A [i := 0],
- \<lbrace> n < length \<acute>A \<rbrace>,
- \<lbrace> length \<ordmasculine>A = length \<ordfeminine>A \<and> \<ordmasculine>A ! i = \<ordfeminine>A ! i \<rbrace>,
- \<lbrace> length \<ordmasculine>A = length \<ordfeminine>A \<and> (\<forall>j<n. i \<noteq> j \<longrightarrow> \<ordmasculine>A ! j = \<ordfeminine>A ! j) \<rbrace>,
- \<lbrace> \<acute>A ! i = 0 \<rbrace>)
- COEND
- SAT [\<lbrace> n < length \<acute>A \<rbrace>, \<lbrace> \<ordmasculine>A = \<ordfeminine>A \<rbrace>, \<lbrace> True \<rbrace>, \<lbrace> \<forall>i < n. \<acute>A ! i = 0 \<rbrace>]"
-apply(rule Parallel)
-apply (auto intro!: Basic)
-done
-
-lemma Example1_parameterized:
-"k < t \<Longrightarrow>
- \<turnstile> COBEGIN
- SCHEME [k*n\<le>i<(Suc k)*n] (\<acute>A:=\<acute>A[i:=0],
- \<lbrace>t*n < length \<acute>A\<rbrace>,
- \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> \<ordmasculine>A!i = \<ordfeminine>A!i\<rbrace>,
- \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> (\<forall>j<length \<ordmasculine>A . i\<noteq>j \<longrightarrow> \<ordmasculine>A!j = \<ordfeminine>A!j)\<rbrace>,
- \<lbrace>\<acute>A!i=0\<rbrace>)
- COEND
- SAT [\<lbrace>t*n < length \<acute>A\<rbrace>,
- \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> (\<forall>i<n. \<ordmasculine>A!(k*n+i)=\<ordfeminine>A!(k*n+i))\<rbrace>,
- \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and>
- (\<forall>i<length \<ordmasculine>A . (i<k*n \<longrightarrow> \<ordmasculine>A!i = \<ordfeminine>A!i) \<and> ((Suc k)*n \<le> i\<longrightarrow> \<ordmasculine>A!i = \<ordfeminine>A!i))\<rbrace>,
- \<lbrace>\<forall>i<n. \<acute>A!(k*n+i) = 0\<rbrace>]"
-apply(rule Parallel)
- apply auto
- apply(erule_tac x="k*n +i" in allE)
- apply(subgoal_tac "k*n+i <length (A b)")
- apply force
- apply(erule le_less_trans2)
- apply(case_tac t,simp+)
- apply (simp add:add_commute)
- apply(simp add: add_le_mono)
-apply(rule Basic)
- apply simp
- apply clarify
- apply (subgoal_tac "k*n+i< length (A x)")
- apply simp
- apply(erule le_less_trans2)
- apply(case_tac t,simp+)
- apply (simp add:add_commute)
- apply(rule add_le_mono, auto)
-done
-
-
-subsection {* Increment a Variable in Parallel *}
-
-subsubsection {* Two components *}
-
-record Example2 =
- x :: nat
- c_0 :: nat
- c_1 :: nat
-
-lemma Example2:
- "\<turnstile> COBEGIN
- (\<langle> \<acute>x:=\<acute>x+1;; \<acute>c_0:=\<acute>c_0 + 1 \<rangle>,
- \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_0=0\<rbrace>,
- \<lbrace>\<ordmasculine>c_0 = \<ordfeminine>c_0 \<and>
- (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
- \<longrightarrow> \<ordfeminine>x = \<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
- \<lbrace>\<ordmasculine>c_1 = \<ordfeminine>c_1 \<and>
- (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
- \<longrightarrow> \<ordfeminine>x =\<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
- \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_0=1 \<rbrace>)
- \<parallel>
- (\<langle> \<acute>x:=\<acute>x+1;; \<acute>c_1:=\<acute>c_1+1 \<rangle>,
- \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_1=0 \<rbrace>,
- \<lbrace>\<ordmasculine>c_1 = \<ordfeminine>c_1 \<and>
- (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
- \<longrightarrow> \<ordfeminine>x = \<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
- \<lbrace>\<ordmasculine>c_0 = \<ordfeminine>c_0 \<and>
- (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
- \<longrightarrow> \<ordfeminine>x =\<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
- \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_1=1\<rbrace>)
- COEND
- SAT [\<lbrace>\<acute>x=0 \<and> \<acute>c_0=0 \<and> \<acute>c_1=0\<rbrace>,
- \<lbrace>\<ordmasculine>x=\<ordfeminine>x \<and> \<ordmasculine>c_0= \<ordfeminine>c_0 \<and> \<ordmasculine>c_1=\<ordfeminine>c_1\<rbrace>,
- \<lbrace>True\<rbrace>,
- \<lbrace>\<acute>x=2\<rbrace>]"
-apply(rule Parallel)
- apply simp_all
- apply clarify
- apply(case_tac i)
- apply simp
- apply(rule conjI)
- apply clarify
- apply simp
- apply clarify
- apply simp
- apply(case_tac j,simp)
- apply simp
- apply simp
- apply(rule conjI)
- apply clarify
- apply simp
- apply clarify
- apply simp
- apply(subgoal_tac "j=0")
- apply (rotate_tac -1)
- apply (simp (asm_lr))
- apply arith
- apply clarify
- apply(case_tac i,simp,simp)
- apply clarify
- apply simp
- apply(erule_tac x=0 in all_dupE)
- apply(erule_tac x=1 in allE,simp)
-apply clarify
-apply(case_tac i,simp)
- apply(rule Await)
- apply simp_all
- apply(clarify)
- apply(rule Seq)
- prefer 2
- apply(rule Basic)
- apply simp_all
- apply(rule subset_refl)
- apply(rule Basic)
- apply simp_all
- apply clarify
- apply simp
-apply(rule Await)
- apply simp_all
-apply(clarify)
-apply(rule Seq)
- prefer 2
- apply(rule Basic)
- apply simp_all
- apply(rule subset_refl)
-apply(auto intro!: Basic)
-done
-
-subsubsection {* Parameterized *}
-
-lemma Example2_lemma2_aux: "j<n \<Longrightarrow>
- (\<Sum>i=0..<n. (b i::nat)) =
- (\<Sum>i=0..<j. b i) + b j + (\<Sum>i=0..<n-(Suc j) . b (Suc j + i))"
-apply(induct n)
- apply simp_all
-apply(simp add:less_Suc_eq)
- apply(auto)
-apply(subgoal_tac "n - j = Suc(n- Suc j)")
- apply simp
-apply arith
-done
-
-lemma Example2_lemma2_aux2:
- "j\<le> s \<Longrightarrow> (\<Sum>i::nat=0..<j. (b (s:=t)) i) = (\<Sum>i=0..<j. b i)"
-apply(induct j)
- apply (simp_all cong:setsum_cong)
-done
-
-lemma Example2_lemma2:
- "\<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow> Suc (\<Sum>i::nat=0..<n. b i)=(\<Sum>i=0..<n. (b (j := Suc 0)) i)"
-apply(frule_tac b="(b (j:=(Suc 0)))" in Example2_lemma2_aux)
-apply(erule_tac t="setsum (b(j := (Suc 0))) {0..<n}" in ssubst)
-apply(frule_tac b=b in Example2_lemma2_aux)
-apply(erule_tac t="setsum b {0..<n}" in ssubst)
-apply(subgoal_tac "Suc (setsum b {0..<j} + b j + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))=(setsum b {0..<j} + Suc (b j) + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))")
-apply(rotate_tac -1)
-apply(erule ssubst)
-apply(subgoal_tac "j\<le>j")
- apply(drule_tac b="b" and t="(Suc 0)" in Example2_lemma2_aux2)
-apply(rotate_tac -1)
-apply(erule ssubst)
-apply simp_all
-done
-
-lemma Example2_lemma2_Suc0: "\<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow>
- Suc (\<Sum>i::nat=0..< n. b i)=(\<Sum>i=0..< n. (b (j:=Suc 0)) i)"
-by(simp add:Example2_lemma2)
-
-record Example2_parameterized =
- C :: "nat \<Rightarrow> nat"
- y :: nat
-
-lemma Example2_parameterized: "0<n \<Longrightarrow>
- \<turnstile> COBEGIN SCHEME [0\<le>i<n]
- (\<langle> \<acute>y:=\<acute>y+1;; \<acute>C:=\<acute>C (i:=1) \<rangle>,
- \<lbrace>\<acute>y=(\<Sum>i=0..<n. \<acute>C i) \<and> \<acute>C i=0\<rbrace>,
- \<lbrace>\<ordmasculine>C i = \<ordfeminine>C i \<and>
- (\<ordmasculine>y=(\<Sum>i=0..<n. \<ordmasculine>C i) \<longrightarrow> \<ordfeminine>y =(\<Sum>i=0..<n. \<ordfeminine>C i))\<rbrace>,
- \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>C j = \<ordfeminine>C j) \<and>
- (\<ordmasculine>y=(\<Sum>i=0..<n. \<ordmasculine>C i) \<longrightarrow> \<ordfeminine>y =(\<Sum>i=0..<n. \<ordfeminine>C i))\<rbrace>,
- \<lbrace>\<acute>y=(\<Sum>i=0..<n. \<acute>C i) \<and> \<acute>C i=1\<rbrace>)
- COEND
- SAT [\<lbrace>\<acute>y=0 \<and> (\<Sum>i=0..<n. \<acute>C i)=0 \<rbrace>, \<lbrace>\<ordmasculine>C=\<ordfeminine>C \<and> \<ordmasculine>y=\<ordfeminine>y\<rbrace>, \<lbrace>True\<rbrace>, \<lbrace>\<acute>y=n\<rbrace>]"
-apply(rule Parallel)
-apply force
-apply force
-apply(force)
-apply clarify
-apply simp
-apply(simp cong:setsum_ivl_cong)
-apply clarify
-apply simp
-apply(rule Await)
-apply simp_all
-apply clarify
-apply(rule Seq)
-prefer 2
-apply(rule Basic)
-apply(rule subset_refl)
-apply simp+
-apply(rule Basic)
-apply simp
-apply clarify
-apply simp
-apply(simp add:Example2_lemma2_Suc0 cong:if_cong)
-apply simp+
-done
-
-subsection {* Find Least Element *}
-
-text {* A previous lemma: *}
-
-lemma mod_aux :"\<lbrakk>i < (n::nat); a mod n = i; j < a + n; j mod n = i; a < j\<rbrakk> \<Longrightarrow> False"
-apply(subgoal_tac "a=a div n*n + a mod n" )
- prefer 2 apply (simp (no_asm_use))
-apply(subgoal_tac "j=j div n*n + j mod n")
- prefer 2 apply (simp (no_asm_use))
-apply simp
-apply(subgoal_tac "a div n*n < j div n*n")
-prefer 2 apply arith
-apply(subgoal_tac "j div n*n < (a div n + 1)*n")
-prefer 2 apply simp
-apply (simp only:mult_less_cancel2)
-apply arith
-done
-
-record Example3 =
- X :: "nat \<Rightarrow> nat"
- Y :: "nat \<Rightarrow> nat"
-
-lemma Example3: "m mod n=0 \<Longrightarrow>
- \<turnstile> COBEGIN
- SCHEME [0\<le>i<n]
- (WHILE (\<forall>j<n. \<acute>X i < \<acute>Y j) DO
- IF P(B!(\<acute>X i)) THEN \<acute>Y:=\<acute>Y (i:=\<acute>X i)
- ELSE \<acute>X:= \<acute>X (i:=(\<acute>X i)+ n) FI
- OD,
- \<lbrace>(\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i)\<rbrace>,
- \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordfeminine>Y j \<le> \<ordmasculine>Y j) \<and> \<ordmasculine>X i = \<ordfeminine>X i \<and>
- \<ordmasculine>Y i = \<ordfeminine>Y i\<rbrace>,
- \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>X j = \<ordfeminine>X j \<and> \<ordmasculine>Y j = \<ordfeminine>Y j) \<and>
- \<ordfeminine>Y i \<le> \<ordmasculine>Y i\<rbrace>,
- \<lbrace>(\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y j \<le> \<acute>X i) \<rbrace>)
- COEND
- SAT [\<lbrace> \<forall>i<n. \<acute>X i=i \<and> \<acute>Y i=m+i \<rbrace>,\<lbrace>\<ordmasculine>X=\<ordfeminine>X \<and> \<ordmasculine>Y=\<ordfeminine>Y\<rbrace>,\<lbrace>True\<rbrace>,
- \<lbrace>\<forall>i<n. (\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and>
- (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y j \<le> \<acute>X i)\<rbrace>]"
-apply(rule Parallel)
---{*5 subgoals left *}
-apply force+
-apply clarify
-apply simp
-apply(rule While)
- apply force
- apply force
- apply force
- apply(rule_tac pre'="\<lbrace> \<acute>X i mod n = i \<and> (\<forall>j. j<\<acute>X i \<longrightarrow> j mod n = i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i < n * q \<longrightarrow> P (B!(\<acute>Y i))) \<and> \<acute>X i<\<acute>Y i\<rbrace>" in Conseq)
- apply force
- apply(rule subset_refl)+
- apply(rule Cond)
- apply force
- apply(rule Basic)
- apply force
- apply fastsimp
- apply force
- apply force
- apply(rule Basic)
- apply simp
- apply clarify
- apply simp
- apply (case_tac "X x (j mod n) \<le> j")
- apply (drule le_imp_less_or_eq)
- apply (erule disjE)
- apply (drule_tac j=j and n=n and i="j mod n" and a="X x (j mod n)" in mod_aux)
- apply auto
-done
-
-text {* Same but with a list as auxiliary variable: *}
-
-record Example3_list =
- X :: "nat list"
- Y :: "nat list"
-
-lemma Example3_list: "m mod n=0 \<Longrightarrow> \<turnstile> (COBEGIN SCHEME [0\<le>i<n]
- (WHILE (\<forall>j<n. \<acute>X!i < \<acute>Y!j) DO
- IF P(B!(\<acute>X!i)) THEN \<acute>Y:=\<acute>Y[i:=\<acute>X!i] ELSE \<acute>X:= \<acute>X[i:=(\<acute>X!i)+ n] FI
- OD,
- \<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> (\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i)\<rbrace>,
- \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordfeminine>Y!j \<le> \<ordmasculine>Y!j) \<and> \<ordmasculine>X!i = \<ordfeminine>X!i \<and>
- \<ordmasculine>Y!i = \<ordfeminine>Y!i \<and> length \<ordmasculine>X = length \<ordfeminine>X \<and> length \<ordmasculine>Y = length \<ordfeminine>Y\<rbrace>,
- \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>X!j = \<ordfeminine>X!j \<and> \<ordmasculine>Y!j = \<ordfeminine>Y!j) \<and>
- \<ordfeminine>Y!i \<le> \<ordmasculine>Y!i \<and> length \<ordmasculine>X = length \<ordfeminine>X \<and> length \<ordmasculine>Y = length \<ordfeminine>Y\<rbrace>,
- \<lbrace>(\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y!j \<le> \<acute>X!i) \<rbrace>) COEND)
- SAT [\<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> (\<forall>i<n. \<acute>X!i=i \<and> \<acute>Y!i=m+i) \<rbrace>,
- \<lbrace>\<ordmasculine>X=\<ordfeminine>X \<and> \<ordmasculine>Y=\<ordfeminine>Y\<rbrace>,
- \<lbrace>True\<rbrace>,
- \<lbrace>\<forall>i<n. (\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and>
- (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y!j \<le> \<acute>X!i)\<rbrace>]"
-apply(rule Parallel)
---{* 5 subgoals left *}
-apply force+
-apply clarify
-apply simp
-apply(rule While)
- apply force
- apply force
- apply force
- apply(rule_tac pre'="\<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> \<acute>X ! i mod n = i \<and> (\<forall>j. j < \<acute>X ! i \<longrightarrow> j mod n = i \<longrightarrow> \<not> P (B ! j)) \<and> (\<acute>Y ! i < n * q \<longrightarrow> P (B ! (\<acute>Y ! i))) \<and> \<acute>X!i<\<acute>Y!i\<rbrace>" in Conseq)
- apply force
- apply(rule subset_refl)+
- apply(rule Cond)
- apply force
- apply(rule Basic)
- apply force
- apply force
- apply force
- apply force
- apply(rule Basic)
- apply simp
- apply clarify
- apply simp
- apply(rule allI)
- apply(rule impI)+
- apply(case_tac "X x ! i\<le> j")
- apply(drule le_imp_less_or_eq)
- apply(erule disjE)
- apply(drule_tac j=j and n=n and i=i and a="X x ! i" in mod_aux)
- apply auto
-done
-
-end
--- a/src/HOL/HoareParallel/RG_Hoare.thy Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1375 +0,0 @@
-header {* \section{The Proof System} *}
-
-theory RG_Hoare imports RG_Tran begin
-
-subsection {* Proof System for Component Programs *}
-
-declare Un_subset_iff [iff del]
-declare Cons_eq_map_conv[iff]
-
-constdefs
- stable :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"
- "stable \<equiv> \<lambda>f g. (\<forall>x y. x \<in> f \<longrightarrow> (x, y) \<in> g \<longrightarrow> y \<in> f)"
-
-inductive
- rghoare :: "['a com, 'a set, ('a \<times> 'a) set, ('a \<times> 'a) set, 'a set] \<Rightarrow> bool"
- ("\<turnstile> _ sat [_, _, _, _]" [60,0,0,0,0] 45)
-where
- Basic: "\<lbrakk> pre \<subseteq> {s. f s \<in> post}; {(s,t). s \<in> pre \<and> (t=f s \<or> t=s)} \<subseteq> guar;
- stable pre rely; stable post rely \<rbrakk>
- \<Longrightarrow> \<turnstile> Basic f sat [pre, rely, guar, post]"
-
-| Seq: "\<lbrakk> \<turnstile> P sat [pre, rely, guar, mid]; \<turnstile> Q sat [mid, rely, guar, post] \<rbrakk>
- \<Longrightarrow> \<turnstile> Seq P Q sat [pre, rely, guar, post]"
-
-| Cond: "\<lbrakk> stable pre rely; \<turnstile> P1 sat [pre \<inter> b, rely, guar, post];
- \<turnstile> P2 sat [pre \<inter> -b, rely, guar, post]; \<forall>s. (s,s)\<in>guar \<rbrakk>
- \<Longrightarrow> \<turnstile> Cond b P1 P2 sat [pre, rely, guar, post]"
-
-| While: "\<lbrakk> stable pre rely; (pre \<inter> -b) \<subseteq> post; stable post rely;
- \<turnstile> P sat [pre \<inter> b, rely, guar, pre]; \<forall>s. (s,s)\<in>guar \<rbrakk>
- \<Longrightarrow> \<turnstile> While b P sat [pre, rely, guar, post]"
-
-| Await: "\<lbrakk> stable pre rely; stable post rely;
- \<forall>V. \<turnstile> P sat [pre \<inter> b \<inter> {V}, {(s, t). s = t},
- UNIV, {s. (V, s) \<in> guar} \<inter> post] \<rbrakk>
- \<Longrightarrow> \<turnstile> Await b P sat [pre, rely, guar, post]"
-
-| Conseq: "\<lbrakk> pre \<subseteq> pre'; rely \<subseteq> rely'; guar' \<subseteq> guar; post' \<subseteq> post;
- \<turnstile> P sat [pre', rely', guar', post'] \<rbrakk>
- \<Longrightarrow> \<turnstile> P sat [pre, rely, guar, post]"
-
-constdefs
- Pre :: "'a rgformula \<Rightarrow> 'a set"
- "Pre x \<equiv> fst(snd x)"
- Post :: "'a rgformula \<Rightarrow> 'a set"
- "Post x \<equiv> snd(snd(snd(snd x)))"
- Rely :: "'a rgformula \<Rightarrow> ('a \<times> 'a) set"
- "Rely x \<equiv> fst(snd(snd x))"
- Guar :: "'a rgformula \<Rightarrow> ('a \<times> 'a) set"
- "Guar x \<equiv> fst(snd(snd(snd x)))"
- Com :: "'a rgformula \<Rightarrow> 'a com"
- "Com x \<equiv> fst x"
-
-subsection {* Proof System for Parallel Programs *}
-
-types 'a par_rgformula = "('a rgformula) list \<times> 'a set \<times> ('a \<times> 'a) set \<times> ('a \<times> 'a) set \<times> 'a set"
-
-inductive
- par_rghoare :: "('a rgformula) list \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> bool"
- ("\<turnstile> _ SAT [_, _, _, _]" [60,0,0,0,0] 45)
-where
- Parallel:
- "\<lbrakk> \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j<length xs \<and> j\<noteq>i}. Guar(xs!j)) \<subseteq> Rely(xs!i);
- (\<Union>j\<in>{j. j<length xs}. Guar(xs!j)) \<subseteq> guar;
- pre \<subseteq> (\<Inter>i\<in>{i. i<length xs}. Pre(xs!i));
- (\<Inter>i\<in>{i. i<length xs}. Post(xs!i)) \<subseteq> post;
- \<forall>i<length xs. \<turnstile> Com(xs!i) sat [Pre(xs!i),Rely(xs!i),Guar(xs!i),Post(xs!i)] \<rbrakk>
- \<Longrightarrow> \<turnstile> xs SAT [pre, rely, guar, post]"
-
-section {* Soundness*}
-
-subsubsection {* Some previous lemmas *}
-
-lemma tl_of_assum_in_assum:
- "(P, s) # (P, t) # xs \<in> assum (pre, rely) \<Longrightarrow> stable pre rely
- \<Longrightarrow> (P, t) # xs \<in> assum (pre, rely)"
-apply(simp add:assum_def)
-apply clarify
-apply(rule conjI)
- apply(erule_tac x=0 in allE)
- apply(simp (no_asm_use)only:stable_def)
- apply(erule allE,erule allE,erule impE,assumption,erule mp)
- apply(simp add:Env)
-apply clarify
-apply(erule_tac x="Suc i" in allE)
-apply simp
-done
-
-lemma etran_in_comm:
- "(P, t) # xs \<in> comm(guar, post) \<Longrightarrow> (P, s) # (P, t) # xs \<in> comm(guar, post)"
-apply(simp add:comm_def)
-apply clarify
-apply(case_tac i,simp+)
-done
-
-lemma ctran_in_comm:
- "\<lbrakk>(s, s) \<in> guar; (Q, s) # xs \<in> comm(guar, post)\<rbrakk>
- \<Longrightarrow> (P, s) # (Q, s) # xs \<in> comm(guar, post)"
-apply(simp add:comm_def)
-apply clarify
-apply(case_tac i,simp+)
-done
-
-lemma takecptn_is_cptn [rule_format, elim!]:
- "\<forall>j. c \<in> cptn \<longrightarrow> take (Suc j) c \<in> cptn"
-apply(induct "c")
- apply(force elim: cptn.cases)
-apply clarify
-apply(case_tac j)
- apply simp
- apply(rule CptnOne)
-apply simp
-apply(force intro:cptn.intros elim:cptn.cases)
-done
-
-lemma dropcptn_is_cptn [rule_format,elim!]:
- "\<forall>j<length c. c \<in> cptn \<longrightarrow> drop j c \<in> cptn"
-apply(induct "c")
- apply(force elim: cptn.cases)
-apply clarify
-apply(case_tac j,simp+)
-apply(erule cptn.cases)
- apply simp
- apply force
-apply force
-done
-
-lemma takepar_cptn_is_par_cptn [rule_format,elim]:
- "\<forall>j. c \<in> par_cptn \<longrightarrow> take (Suc j) c \<in> par_cptn"
-apply(induct "c")
- apply(force elim: cptn.cases)
-apply clarify
-apply(case_tac j,simp)
- apply(rule ParCptnOne)
-apply(force intro:par_cptn.intros elim:par_cptn.cases)
-done
-
-lemma droppar_cptn_is_par_cptn [rule_format]:
- "\<forall>j<length c. c \<in> par_cptn \<longrightarrow> drop j c \<in> par_cptn"
-apply(induct "c")
- apply(force elim: par_cptn.cases)
-apply clarify
-apply(case_tac j,simp+)
-apply(erule par_cptn.cases)
- apply simp
- apply force
-apply force
-done
-
-lemma tl_of_cptn_is_cptn: "\<lbrakk>x # xs \<in> cptn; xs \<noteq> []\<rbrakk> \<Longrightarrow> xs \<in> cptn"
-apply(subgoal_tac "1 < length (x # xs)")
- apply(drule dropcptn_is_cptn,simp+)
-done
-
-lemma not_ctran_None [rule_format]:
- "\<forall>s. (None, s)#xs \<in> cptn \<longrightarrow> (\<forall>i<length xs. ((None, s)#xs)!i -e\<rightarrow> xs!i)"
-apply(induct xs,simp+)
-apply clarify
-apply(erule cptn.cases,simp)
- apply simp
- apply(case_tac i,simp)
- apply(rule Env)
- apply simp
-apply(force elim:ctran.cases)
-done
-
-lemma cptn_not_empty [simp]:"[] \<notin> cptn"
-apply(force elim:cptn.cases)
-done
-
-lemma etran_or_ctran [rule_format]:
- "\<forall>m i. x\<in>cptn \<longrightarrow> m \<le> length x
- \<longrightarrow> (\<forall>i. Suc i < m \<longrightarrow> \<not> x!i -c\<rightarrow> x!Suc i) \<longrightarrow> Suc i < m
- \<longrightarrow> x!i -e\<rightarrow> x!Suc i"
-apply(induct x,simp)
-apply clarify
-apply(erule cptn.cases,simp)
- apply(case_tac i,simp)
- apply(rule Env)
- apply simp
- apply(erule_tac x="m - 1" in allE)
- apply(case_tac m,simp,simp)
- apply(subgoal_tac "(\<forall>i. Suc i < nata \<longrightarrow> (((P, t) # xs) ! i, xs ! i) \<notin> ctran)")
- apply force
- apply clarify
- apply(erule_tac x="Suc ia" in allE,simp)
-apply(erule_tac x="0" and P="\<lambda>j. ?H j \<longrightarrow> (?J j) \<notin> ctran" in allE,simp)
-done
-
-lemma etran_or_ctran2 [rule_format]:
- "\<forall>i. Suc i<length x \<longrightarrow> x\<in>cptn \<longrightarrow> (x!i -c\<rightarrow> x!Suc i \<longrightarrow> \<not> x!i -e\<rightarrow> x!Suc i)
- \<or> (x!i -e\<rightarrow> x!Suc i \<longrightarrow> \<not> x!i -c\<rightarrow> x!Suc i)"
-apply(induct x)
- apply simp
-apply clarify
-apply(erule cptn.cases,simp)
- apply(case_tac i,simp+)
-apply(case_tac i,simp)
- apply(force elim:etran.cases)
-apply simp
-done
-
-lemma etran_or_ctran2_disjI1:
- "\<lbrakk> x\<in>cptn; Suc i<length x; x!i -c\<rightarrow> x!Suc i\<rbrakk> \<Longrightarrow> \<not> x!i -e\<rightarrow> x!Suc i"
-by(drule etran_or_ctran2,simp_all)
-
-lemma etran_or_ctran2_disjI2:
- "\<lbrakk> x\<in>cptn; Suc i<length x; x!i -e\<rightarrow> x!Suc i\<rbrakk> \<Longrightarrow> \<not> x!i -c\<rightarrow> x!Suc i"
-by(drule etran_or_ctran2,simp_all)
-
-lemma not_ctran_None2 [rule_format]:
- "\<lbrakk> (None, s) # xs \<in>cptn; i<length xs\<rbrakk> \<Longrightarrow> \<not> ((None, s) # xs) ! i -c\<rightarrow> xs ! i"
-apply(frule not_ctran_None,simp)
-apply(case_tac i,simp)
- apply(force elim:etranE)
-apply simp
-apply(rule etran_or_ctran2_disjI2,simp_all)
-apply(force intro:tl_of_cptn_is_cptn)
-done
-
-lemma Ex_first_occurrence [rule_format]: "P (n::nat) \<longrightarrow> (\<exists>m. P m \<and> (\<forall>i<m. \<not> P i))";
-apply(rule nat_less_induct)
-apply clarify
-apply(case_tac "\<forall>m. m<n \<longrightarrow> \<not> P m")
-apply auto
-done
-
-lemma stability [rule_format]:
- "\<forall>j k. x \<in> cptn \<longrightarrow> stable p rely \<longrightarrow> j\<le>k \<longrightarrow> k<length x \<longrightarrow> snd(x!j)\<in>p \<longrightarrow>
- (\<forall>i. (Suc i)<length x \<longrightarrow>
- (x!i -e\<rightarrow> x!(Suc i)) \<longrightarrow> (snd(x!i), snd(x!(Suc i))) \<in> rely) \<longrightarrow>
- (\<forall>i. j\<le>i \<and> i<k \<longrightarrow> x!i -e\<rightarrow> x!Suc i) \<longrightarrow> snd(x!k)\<in>p \<and> fst(x!j)=fst(x!k)"
-apply(induct x)
- apply clarify
- apply(force elim:cptn.cases)
-apply clarify
-apply(erule cptn.cases,simp)
- apply simp
- apply(case_tac k,simp,simp)
- apply(case_tac j,simp)
- apply(erule_tac x=0 in allE)
- apply(erule_tac x="nat" and P="\<lambda>j. (0\<le>j) \<longrightarrow> (?J j)" in allE,simp)
- apply(subgoal_tac "t\<in>p")
- apply(subgoal_tac "(\<forall>i. i < length xs \<longrightarrow> ((P, t) # xs) ! i -e\<rightarrow> xs ! i \<longrightarrow> (snd (((P, t) # xs) ! i), snd (xs ! i)) \<in> rely)")
- apply clarify
- apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
- apply clarify
- apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j) \<longrightarrow> (?T j)\<in>rely" in allE,simp)
- apply(erule_tac x=0 and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran \<longrightarrow> ?T j" in allE,simp)
- apply(simp(no_asm_use) only:stable_def)
- apply(erule_tac x=s in allE)
- apply(erule_tac x=t in allE)
- apply simp
- apply(erule mp)
- apply(erule mp)
- apply(rule Env)
- apply simp
- apply(erule_tac x="nata" in allE)
- apply(erule_tac x="nat" and P="\<lambda>j. (?s\<le>j) \<longrightarrow> (?J j)" in allE,simp)
- apply(subgoal_tac "(\<forall>i. i < length xs \<longrightarrow> ((P, t) # xs) ! i -e\<rightarrow> xs ! i \<longrightarrow> (snd (((P, t) # xs) ! i), snd (xs ! i)) \<in> rely)")
- apply clarify
- apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
- apply clarify
- apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j) \<longrightarrow> (?T j)\<in>rely" in allE,simp)
-apply(case_tac k,simp,simp)
-apply(case_tac j)
- apply(erule_tac x=0 and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
- apply(erule etran.cases,simp)
-apply(erule_tac x="nata" in allE)
-apply(erule_tac x="nat" and P="\<lambda>j. (?s\<le>j) \<longrightarrow> (?J j)" in allE,simp)
-apply(subgoal_tac "(\<forall>i. i < length xs \<longrightarrow> ((Q, t) # xs) ! i -e\<rightarrow> xs ! i \<longrightarrow> (snd (((Q, t) # xs) ! i), snd (xs ! i)) \<in> rely)")
- apply clarify
- apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
-apply clarify
-apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j) \<longrightarrow> (?T j)\<in>rely" in allE,simp)
-done
-
-subsection {* Soundness of the System for Component Programs *}
-
-subsubsection {* Soundness of the Basic rule *}
-
-lemma unique_ctran_Basic [rule_format]:
- "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Basic f), s) \<longrightarrow>
- Suc i<length x \<longrightarrow> x!i -c\<rightarrow> x!Suc i \<longrightarrow>
- (\<forall>j. Suc j<length x \<longrightarrow> i\<noteq>j \<longrightarrow> x!j -e\<rightarrow> x!Suc j)"
-apply(induct x,simp)
-apply simp
-apply clarify
-apply(erule cptn.cases,simp)
- apply(case_tac i,simp+)
- apply clarify
- apply(case_tac j,simp)
- apply(rule Env)
- apply simp
-apply clarify
-apply simp
-apply(case_tac i)
- apply(case_tac j,simp,simp)
- apply(erule ctran.cases,simp_all)
- apply(force elim: not_ctran_None)
-apply(ind_cases "((Some (Basic f), sa), Q, t) \<in> ctran" for sa Q t)
-apply simp
-apply(drule_tac i=nat in not_ctran_None,simp)
-apply(erule etranE,simp)
-done
-
-lemma exists_ctran_Basic_None [rule_format]:
- "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Basic f), s)
- \<longrightarrow> i<length x \<longrightarrow> fst(x!i)=None \<longrightarrow> (\<exists>j<i. x!j -c\<rightarrow> x!Suc j)"
-apply(induct x,simp)
-apply simp
-apply clarify
-apply(erule cptn.cases,simp)
- apply(case_tac i,simp,simp)
- apply(erule_tac x=nat in allE,simp)
- apply clarify
- apply(rule_tac x="Suc j" in exI,simp,simp)
-apply clarify
-apply(case_tac i,simp,simp)
-apply(rule_tac x=0 in exI,simp)
-done
-
-lemma Basic_sound:
- " \<lbrakk>pre \<subseteq> {s. f s \<in> post}; {(s, t). s \<in> pre \<and> t = f s} \<subseteq> guar;
- stable pre rely; stable post rely\<rbrakk>
- \<Longrightarrow> \<Turnstile> Basic f sat [pre, rely, guar, post]"
-apply(unfold com_validity_def)
-apply clarify
-apply(simp add:comm_def)
-apply(rule conjI)
- apply clarify
- apply(simp add:cp_def assum_def)
- apply clarify
- apply(frule_tac j=0 and k=i and p=pre in stability)
- apply simp_all
- apply(erule_tac x=ia in allE,simp)
- apply(erule_tac i=i and f=f in unique_ctran_Basic,simp_all)
- apply(erule subsetD,simp)
- apply(case_tac "x!i")
- apply clarify
- apply(drule_tac s="Some (Basic f)" in sym,simp)
- apply(thin_tac "\<forall>j. ?H j")
- apply(force elim:ctran.cases)
-apply clarify
-apply(simp add:cp_def)
-apply clarify
-apply(frule_tac i="length x - 1" and f=f in exists_ctran_Basic_None,simp+)
- apply(case_tac x,simp+)
- apply(rule last_fst_esp,simp add:last_length)
- apply (case_tac x,simp+)
-apply(simp add:assum_def)
-apply clarify
-apply(frule_tac j=0 and k="j" and p=pre in stability)
- apply simp_all
- apply(erule_tac x=i in allE,simp)
- apply(erule_tac i=j and f=f in unique_ctran_Basic,simp_all)
-apply(case_tac "x!j")
-apply clarify
-apply simp
-apply(drule_tac s="Some (Basic f)" in sym,simp)
-apply(case_tac "x!Suc j",simp)
-apply(rule ctran.cases,simp)
-apply(simp_all)
-apply(drule_tac c=sa in subsetD,simp)
-apply clarify
-apply(frule_tac j="Suc j" and k="length x - 1" and p=post in stability,simp_all)
- apply(case_tac x,simp+)
- apply(erule_tac x=i in allE)
-apply(erule_tac i=j and f=f in unique_ctran_Basic,simp_all)
- apply arith+
-apply(case_tac x)
-apply(simp add:last_length)+
-done
-
-subsubsection{* Soundness of the Await rule *}
-
-lemma unique_ctran_Await [rule_format]:
- "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Await b c), s) \<longrightarrow>
- Suc i<length x \<longrightarrow> x!i -c\<rightarrow> x!Suc i \<longrightarrow>
- (\<forall>j. Suc j<length x \<longrightarrow> i\<noteq>j \<longrightarrow> x!j -e\<rightarrow> x!Suc j)"
-apply(induct x,simp+)
-apply clarify
-apply(erule cptn.cases,simp)
- apply(case_tac i,simp+)
- apply clarify
- apply(case_tac j,simp)
- apply(rule Env)
- apply simp
-apply clarify
-apply simp
-apply(case_tac i)
- apply(case_tac j,simp,simp)
- apply(erule ctran.cases,simp_all)
- apply(force elim: not_ctran_None)
-apply(ind_cases "((Some (Await b c), sa), Q, t) \<in> ctran" for sa Q t,simp)
-apply(drule_tac i=nat in not_ctran_None,simp)
-apply(erule etranE,simp)
-done
-
-lemma exists_ctran_Await_None [rule_format]:
- "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Await b c), s)
- \<longrightarrow> i<length x \<longrightarrow> fst(x!i)=None \<longrightarrow> (\<exists>j<i. x!j -c\<rightarrow> x!Suc j)"
-apply(induct x,simp+)
-apply clarify
-apply(erule cptn.cases,simp)
- apply(case_tac i,simp+)
- apply(erule_tac x=nat in allE,simp)
- apply clarify
- apply(rule_tac x="Suc j" in exI,simp,simp)
-apply clarify
-apply(case_tac i,simp,simp)
-apply(rule_tac x=0 in exI,simp)
-done
-
-lemma Star_imp_cptn:
- "(P, s) -c*\<rightarrow> (R, t) \<Longrightarrow> \<exists>l \<in> cp P s. (last l)=(R, t)
- \<and> (\<forall>i. Suc i<length l \<longrightarrow> l!i -c\<rightarrow> l!Suc i)"
-apply (erule converse_rtrancl_induct2)
- apply(rule_tac x="[(R,t)]" in bexI)
- apply simp
- apply(simp add:cp_def)
- apply(rule CptnOne)
-apply clarify
-apply(rule_tac x="(a, b)#l" in bexI)
- apply (rule conjI)
- apply(case_tac l,simp add:cp_def)
- apply(simp add:last_length)
- apply clarify
-apply(case_tac i,simp)
-apply(simp add:cp_def)
-apply force
-apply(simp add:cp_def)
- apply(case_tac l)
- apply(force elim:cptn.cases)
-apply simp
-apply(erule CptnComp)
-apply clarify
-done
-
-lemma Await_sound:
- "\<lbrakk>stable pre rely; stable post rely;
- \<forall>V. \<turnstile> P sat [pre \<inter> b \<inter> {s. s = V}, {(s, t). s = t},
- UNIV, {s. (V, s) \<in> guar} \<inter> post] \<and>
- \<Turnstile> P sat [pre \<inter> b \<inter> {s. s = V}, {(s, t). s = t},
- UNIV, {s. (V, s) \<in> guar} \<inter> post] \<rbrakk>
- \<Longrightarrow> \<Turnstile> Await b P sat [pre, rely, guar, post]"
-apply(unfold com_validity_def)
-apply clarify
-apply(simp add:comm_def)
-apply(rule conjI)
- apply clarify
- apply(simp add:cp_def assum_def)
- apply clarify
- apply(frule_tac j=0 and k=i and p=pre in stability,simp_all)
- apply(erule_tac x=ia in allE,simp)
- apply(subgoal_tac "x\<in> cp (Some(Await b P)) s")
- apply(erule_tac i=i in unique_ctran_Await,force,simp_all)
- apply(simp add:cp_def)
---{* here starts the different part. *}
- apply(erule ctran.cases,simp_all)
- apply(drule Star_imp_cptn)
- apply clarify
- apply(erule_tac x=sa in allE)
- apply clarify
- apply(erule_tac x=sa in allE)
- apply(drule_tac c=l in subsetD)
- apply (simp add:cp_def)
- apply clarify
- apply(erule_tac x=ia and P="\<lambda>i. ?H i \<longrightarrow> (?J i,?I i)\<in>ctran" in allE,simp)
- apply(erule etranE,simp)
- apply simp
-apply clarify
-apply(simp add:cp_def)
-apply clarify
-apply(frule_tac i="length x - 1" in exists_ctran_Await_None,force)
- apply (case_tac x,simp+)
- apply(rule last_fst_esp,simp add:last_length)
- apply(case_tac x, (simp add:cptn_not_empty)+)
-apply clarify
-apply(simp add:assum_def)
-apply clarify
-apply(frule_tac j=0 and k="j" and p=pre in stability,simp_all)
- apply(erule_tac x=i in allE,simp)
- apply(erule_tac i=j in unique_ctran_Await,force,simp_all)
-apply(case_tac "x!j")
-apply clarify
-apply simp
-apply(drule_tac s="Some (Await b P)" in sym,simp)
-apply(case_tac "x!Suc j",simp)
-apply(rule ctran.cases,simp)
-apply(simp_all)
-apply(drule Star_imp_cptn)
-apply clarify
-apply(erule_tac x=sa in allE)
-apply clarify
-apply(erule_tac x=sa in allE)
-apply(drule_tac c=l in subsetD)
- apply (simp add:cp_def)
- apply clarify
- apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> (?J i,?I i)\<in>ctran" in allE,simp)
- apply(erule etranE,simp)
-apply simp
-apply clarify
-apply(frule_tac j="Suc j" and k="length x - 1" and p=post in stability,simp_all)
- apply(case_tac x,simp+)
- apply(erule_tac x=i in allE)
-apply(erule_tac i=j in unique_ctran_Await,force,simp_all)
- apply arith+
-apply(case_tac x)
-apply(simp add:last_length)+
-done
-
-subsubsection{* Soundness of the Conditional rule *}
-
-lemma Cond_sound:
- "\<lbrakk> stable pre rely; \<Turnstile> P1 sat [pre \<inter> b, rely, guar, post];
- \<Turnstile> P2 sat [pre \<inter> - b, rely, guar, post]; \<forall>s. (s,s)\<in>guar\<rbrakk>
- \<Longrightarrow> \<Turnstile> (Cond b P1 P2) sat [pre, rely, guar, post]"
-apply(unfold com_validity_def)
-apply clarify
-apply(simp add:cp_def comm_def)
-apply(case_tac "\<exists>i. Suc i<length x \<and> x!i -c\<rightarrow> x!Suc i")
- prefer 2
- apply simp
- apply clarify
- apply(frule_tac j="0" and k="length x - 1" and p=pre in stability,simp+)
- apply(case_tac x,simp+)
- apply(simp add:assum_def)
- apply(simp add:assum_def)
- apply(erule_tac m="length x" in etran_or_ctran,simp+)
- apply(case_tac x, (simp add:last_length)+)
-apply(erule exE)
-apply(drule_tac n=i and P="\<lambda>i. ?H i \<and> (?J i,?I i)\<in> ctran" in Ex_first_occurrence)
-apply clarify
-apply (simp add:assum_def)
-apply(frule_tac j=0 and k="m" and p=pre in stability,simp+)
- apply(erule_tac m="Suc m" in etran_or_ctran,simp+)
-apply(erule ctran.cases,simp_all)
- apply(erule_tac x="sa" in allE)
- apply(drule_tac c="drop (Suc m) x" in subsetD)
- apply simp
- apply clarify
- apply simp
- apply clarify
- apply(case_tac "i\<le>m")
- apply(drule le_imp_less_or_eq)
- apply(erule disjE)
- apply(erule_tac x=i in allE, erule impE, assumption)
- apply simp+
- apply(erule_tac x="i - (Suc m)" and P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> (?I j)\<in>guar" in allE)
- apply(subgoal_tac "(Suc m)+(i - Suc m) \<le> length x")
- apply(subgoal_tac "(Suc m)+Suc (i - Suc m) \<le> length x")
- apply(rotate_tac -2)
- apply simp
- apply arith
- apply arith
-apply(case_tac "length (drop (Suc m) x)",simp)
-apply(erule_tac x="sa" in allE)
-back
-apply(drule_tac c="drop (Suc m) x" in subsetD,simp)
- apply clarify
-apply simp
-apply clarify
-apply(case_tac "i\<le>m")
- apply(drule le_imp_less_or_eq)
- apply(erule disjE)
- apply(erule_tac x=i in allE, erule impE, assumption)
- apply simp
- apply simp
-apply(erule_tac x="i - (Suc m)" and P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> (?I j)\<in>guar" in allE)
-apply(subgoal_tac "(Suc m)+(i - Suc m) \<le> length x")
- apply(subgoal_tac "(Suc m)+Suc (i - Suc m) \<le> length x")
- apply(rotate_tac -2)
- apply simp
- apply arith
-apply arith
-done
-
-subsubsection{* Soundness of the Sequential rule *}
-
-inductive_cases Seq_cases [elim!]: "(Some (Seq P Q), s) -c\<rightarrow> t"
-
-lemma last_lift_not_None: "fst ((lift Q) ((x#xs)!(length xs))) \<noteq> None"
-apply(subgoal_tac "length xs<length (x # xs)")
- apply(drule_tac Q=Q in lift_nth)
- apply(erule ssubst)
- apply (simp add:lift_def)
- apply(case_tac "(x # xs) ! length xs",simp)
-apply simp
-done
-
-declare map_eq_Cons_conv [simp del] Cons_eq_map_conv [simp del]
-lemma Seq_sound1 [rule_format]:
- "x\<in> cptn_mod \<Longrightarrow> \<forall>s P. x !0=(Some (Seq P Q), s) \<longrightarrow>
- (\<forall>i<length x. fst(x!i)\<noteq>Some Q) \<longrightarrow>
- (\<exists>xs\<in> cp (Some P) s. x=map (lift Q) xs)"
-apply(erule cptn_mod.induct)
-apply(unfold cp_def)
-apply safe
-apply simp_all
- apply(simp add:lift_def)
- apply(rule_tac x="[(Some Pa, sa)]" in exI,simp add:CptnOne)
- apply(subgoal_tac "(\<forall>i < Suc (length xs). fst (((Some (Seq Pa Q), t) # xs) ! i) \<noteq> Some Q)")
- apply clarify
- apply(rule_tac x="(Some Pa, sa) #(Some Pa, t) # zs" in exI,simp)
- apply(rule conjI,erule CptnEnv)
- apply(simp (no_asm_use) add:lift_def)
- apply clarify
- apply(erule_tac x="Suc i" in allE, simp)
- apply(ind_cases "((Some (Seq Pa Q), sa), None, t) \<in> ctran" for Pa sa t)
- apply(rule_tac x="(Some P, sa) # xs" in exI, simp add:cptn_iff_cptn_mod lift_def)
-apply(erule_tac x="length xs" in allE, simp)
-apply(simp only:Cons_lift_append)
-apply(subgoal_tac "length xs < length ((Some P, sa) # xs)")
- apply(simp only :nth_append length_map last_length nth_map)
- apply(case_tac "last((Some P, sa) # xs)")
- apply(simp add:lift_def)
-apply simp
-done
-declare map_eq_Cons_conv [simp del] Cons_eq_map_conv [simp del]
-
-lemma Seq_sound2 [rule_format]:
- "x \<in> cptn \<Longrightarrow> \<forall>s P i. x!0=(Some (Seq P Q), s) \<longrightarrow> i<length x
- \<longrightarrow> fst(x!i)=Some Q \<longrightarrow>
- (\<forall>j<i. fst(x!j)\<noteq>(Some Q)) \<longrightarrow>
- (\<exists>xs ys. xs \<in> cp (Some P) s \<and> length xs=Suc i
- \<and> ys \<in> cp (Some Q) (snd(xs !i)) \<and> x=(map (lift Q) xs)@tl ys)"
-apply(erule cptn.induct)
-apply(unfold cp_def)
-apply safe
-apply simp_all
- apply(case_tac i,simp+)
- apply(erule allE,erule impE,assumption,simp)
- apply clarify
- apply(subgoal_tac "(\<forall>j < nat. fst (((Some (Seq Pa Q), t) # xs) ! j) \<noteq> Some Q)",clarify)
- prefer 2
- apply force
- apply(case_tac xsa,simp,simp)
- apply(rule_tac x="(Some Pa, sa) #(Some Pa, t) # list" in exI,simp)
- apply(rule conjI,erule CptnEnv)
- apply(simp (no_asm_use) add:lift_def)
- apply(rule_tac x=ys in exI,simp)
-apply(ind_cases "((Some (Seq Pa Q), sa), t) \<in> ctran" for Pa sa t)
- apply simp
- apply(rule_tac x="(Some Pa, sa)#[(None, ta)]" in exI,simp)
- apply(rule conjI)
- apply(drule_tac xs="[]" in CptnComp,force simp add:CptnOne,simp)
- apply(case_tac i, simp+)
- apply(case_tac nat,simp+)
- apply(rule_tac x="(Some Q,ta)#xs" in exI,simp add:lift_def)
- apply(case_tac nat,simp+)
- apply(force)
-apply(case_tac i, simp+)
-apply(case_tac nat,simp+)
-apply(erule_tac x="Suc nata" in allE,simp)
-apply clarify
-apply(subgoal_tac "(\<forall>j<Suc nata. fst (((Some (Seq P2 Q), ta) # xs) ! j) \<noteq> Some Q)",clarify)
- prefer 2
- apply clarify
- apply force
-apply(rule_tac x="(Some Pa, sa)#(Some P2, ta)#(tl xsa)" in exI,simp)
-apply(rule conjI,erule CptnComp)
-apply(rule nth_tl_if,force,simp+)
-apply(rule_tac x=ys in exI,simp)
-apply(rule conjI)
-apply(rule nth_tl_if,force,simp+)
- apply(rule tl_zero,simp+)
- apply force
-apply(rule conjI,simp add:lift_def)
-apply(subgoal_tac "lift Q (Some P2, ta) =(Some (Seq P2 Q), ta)")
- apply(simp add:Cons_lift del:map.simps)
- apply(rule nth_tl_if)
- apply force
- apply simp+
-apply(simp add:lift_def)
-done
-(*
-lemma last_lift_not_None3: "fst (last (map (lift Q) (x#xs))) \<noteq> None"
-apply(simp only:last_length [THEN sym])
-apply(subgoal_tac "length xs<length (x # xs)")
- apply(drule_tac Q=Q in lift_nth)
- apply(erule ssubst)
- apply (simp add:lift_def)
- apply(case_tac "(x # xs) ! length xs",simp)
-apply simp
-done
-*)
-
-lemma last_lift_not_None2: "fst ((lift Q) (last (x#xs))) \<noteq> None"
-apply(simp only:last_length [THEN sym])
-apply(subgoal_tac "length xs<length (x # xs)")
- apply(drule_tac Q=Q in lift_nth)
- apply(erule ssubst)
- apply (simp add:lift_def)
- apply(case_tac "(x # xs) ! length xs",simp)
-apply simp
-done
-
-lemma Seq_sound:
- "\<lbrakk>\<Turnstile> P sat [pre, rely, guar, mid]; \<Turnstile> Q sat [mid, rely, guar, post]\<rbrakk>
- \<Longrightarrow> \<Turnstile> Seq P Q sat [pre, rely, guar, post]"
-apply(unfold com_validity_def)
-apply clarify
-apply(case_tac "\<exists>i<length x. fst(x!i)=Some Q")
- prefer 2
- apply (simp add:cp_def cptn_iff_cptn_mod)
- apply clarify
- apply(frule_tac Seq_sound1,force)
- apply force
- apply clarify
- apply(erule_tac x=s in allE,simp)
- apply(drule_tac c=xs in subsetD,simp add:cp_def cptn_iff_cptn_mod)
- apply(simp add:assum_def)
- apply clarify
- apply(erule_tac P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> ?I j" in allE,erule impE, assumption)
- apply(simp add:snd_lift)
- apply(erule mp)
- apply(force elim:etranE intro:Env simp add:lift_def)
- apply(simp add:comm_def)
- apply(rule conjI)
- apply clarify
- apply(erule_tac P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> ?I j" in allE,erule impE, assumption)
- apply(simp add:snd_lift)
- apply(erule mp)
- apply(case_tac "(xs!i)")
- apply(case_tac "(xs! Suc i)")
- apply(case_tac "fst(xs!i)")
- apply(erule_tac x=i in allE, simp add:lift_def)
- apply(case_tac "fst(xs!Suc i)")
- apply(force simp add:lift_def)
- apply(force simp add:lift_def)
- apply clarify
- apply(case_tac xs,simp add:cp_def)
- apply clarify
- apply (simp del:map.simps)
- apply(subgoal_tac "(map (lift Q) ((a, b) # list))\<noteq>[]")
- apply(drule last_conv_nth)
- apply (simp del:map.simps)
- apply(simp only:last_lift_not_None)
- apply simp
---{* @{text "\<exists>i<length x. fst (x ! i) = Some Q"} *}
-apply(erule exE)
-apply(drule_tac n=i and P="\<lambda>i. i < length x \<and> fst (x ! i) = Some Q" in Ex_first_occurrence)
-apply clarify
-apply (simp add:cp_def)
- apply clarify
- apply(frule_tac i=m in Seq_sound2,force)
- apply simp+
-apply clarify
-apply(simp add:comm_def)
-apply(erule_tac x=s in allE)
-apply(drule_tac c=xs in subsetD,simp)
- apply(case_tac "xs=[]",simp)
- apply(simp add:cp_def assum_def nth_append)
- apply clarify
- apply(erule_tac x=i in allE)
- back
- apply(simp add:snd_lift)
- apply(erule mp)
- apply(force elim:etranE intro:Env simp add:lift_def)
-apply simp
-apply clarify
-apply(erule_tac x="snd(xs!m)" in allE)
-apply(drule_tac c=ys in subsetD,simp add:cp_def assum_def)
- apply(case_tac "xs\<noteq>[]")
- apply(drule last_conv_nth,simp)
- apply(rule conjI)
- apply(erule mp)
- apply(case_tac "xs!m")
- apply(case_tac "fst(xs!m)",simp)
- apply(simp add:lift_def nth_append)
- apply clarify
- apply(erule_tac x="m+i" in allE)
- back
- back
- apply(case_tac ys,(simp add:nth_append)+)
- apply (case_tac i, (simp add:snd_lift)+)
- apply(erule mp)
- apply(case_tac "xs!m")
- apply(force elim:etran.cases intro:Env simp add:lift_def)
- apply simp
-apply simp
-apply clarify
-apply(rule conjI,clarify)
- apply(case_tac "i<m",simp add:nth_append)
- apply(simp add:snd_lift)
- apply(erule allE, erule impE, assumption, erule mp)
- apply(case_tac "(xs ! i)")
- apply(case_tac "(xs ! Suc i)")
- apply(case_tac "fst(xs ! i)",force simp add:lift_def)
- apply(case_tac "fst(xs ! Suc i)")
- apply (force simp add:lift_def)
- apply (force simp add:lift_def)
- apply(erule_tac x="i-m" in allE)
- back
- back
- apply(subgoal_tac "Suc (i - m) < length ys",simp)
- prefer 2
- apply arith
- apply(simp add:nth_append snd_lift)
- apply(rule conjI,clarify)
- apply(subgoal_tac "i=m")
- prefer 2
- apply arith
- apply clarify
- apply(simp add:cp_def)
- apply(rule tl_zero)
- apply(erule mp)
- apply(case_tac "lift Q (xs!m)",simp add:snd_lift)
- apply(case_tac "xs!m",case_tac "fst(xs!m)",simp add:lift_def snd_lift)
- apply(case_tac ys,simp+)
- apply(simp add:lift_def)
- apply simp
- apply force
- apply clarify
- apply(rule tl_zero)
- apply(rule tl_zero)
- apply (subgoal_tac "i-m=Suc(i-Suc m)")
- apply simp
- apply(erule mp)
- apply(case_tac ys,simp+)
- apply force
- apply arith
- apply force
-apply clarify
-apply(case_tac "(map (lift Q) xs @ tl ys)\<noteq>[]")
- apply(drule last_conv_nth)
- apply(simp add: snd_lift nth_append)
- apply(rule conjI,clarify)
- apply(case_tac ys,simp+)
- apply clarify
- apply(case_tac ys,simp+)
-done
-
-subsubsection{* Soundness of the While rule *}
-
-lemma last_append[rule_format]:
- "\<forall>xs. ys\<noteq>[] \<longrightarrow> ((xs@ys)!(length (xs@ys) - (Suc 0)))=(ys!(length ys - (Suc 0)))"
-apply(induct ys)
- apply simp
-apply clarify
-apply (simp add:nth_append length_append)
-done
-
-lemma assum_after_body:
- "\<lbrakk> \<Turnstile> P sat [pre \<inter> b, rely, guar, pre];
- (Some P, s) # xs \<in> cptn_mod; fst (last ((Some P, s) # xs)) = None; s \<in> b;
- (Some (While b P), s) # (Some (Seq P (While b P)), s) #
- map (lift (While b P)) xs @ ys \<in> assum (pre, rely)\<rbrakk>
- \<Longrightarrow> (Some (While b P), snd (last ((Some P, s) # xs))) # ys \<in> assum (pre, rely)"
-apply(simp add:assum_def com_validity_def cp_def cptn_iff_cptn_mod)
-apply clarify
-apply(erule_tac x=s in allE)
-apply(drule_tac c="(Some P, s) # xs" in subsetD,simp)
- apply clarify
- apply(erule_tac x="Suc i" in allE)
- apply simp
- apply(simp add:Cons_lift_append nth_append snd_lift del:map.simps)
- apply(erule mp)
- apply(erule etranE,simp)
- apply(case_tac "fst(((Some P, s) # xs) ! i)")
- apply(force intro:Env simp add:lift_def)
- apply(force intro:Env simp add:lift_def)
-apply(rule conjI)
- apply clarify
- apply(simp add:comm_def last_length)
-apply clarify
-apply(rule conjI)
- apply(simp add:comm_def)
-apply clarify
-apply(erule_tac x="Suc(length xs + i)" in allE,simp)
-apply(case_tac i, simp add:nth_append Cons_lift_append snd_lift del:map.simps)
- apply(simp add:last_length)
- apply(erule mp)
- apply(case_tac "last xs")
- apply(simp add:lift_def)
-apply(simp add:Cons_lift_append nth_append snd_lift del:map.simps)
-done
-
-lemma While_sound_aux [rule_format]:
- "\<lbrakk> pre \<inter> - b \<subseteq> post; \<Turnstile> P sat [pre \<inter> b, rely, guar, pre]; \<forall>s. (s, s) \<in> guar;
- stable pre rely; stable post rely; x \<in> cptn_mod \<rbrakk>
- \<Longrightarrow> \<forall>s xs. x=(Some(While b P),s)#xs \<longrightarrow> x\<in>assum(pre, rely) \<longrightarrow> x \<in> comm (guar, post)"
-apply(erule cptn_mod.induct)
-apply safe
-apply (simp_all del:last.simps)
---{* 5 subgoals left *}
-apply(simp add:comm_def)
---{* 4 subgoals left *}
-apply(rule etran_in_comm)
-apply(erule mp)
-apply(erule tl_of_assum_in_assum,simp)
---{* While-None *}
-apply(ind_cases "((Some (While b P), s), None, t) \<in> ctran" for s t)
-apply(simp add:comm_def)
-apply(simp add:cptn_iff_cptn_mod [THEN sym])
-apply(rule conjI,clarify)
- apply(force simp add:assum_def)
-apply clarify
-apply(rule conjI, clarify)
- apply(case_tac i,simp,simp)
- apply(force simp add:not_ctran_None2)
-apply(subgoal_tac "\<forall>i. Suc i < length ((None, t) # xs) \<longrightarrow> (((None, t) # xs) ! i, ((None, t) # xs) ! Suc i)\<in> etran")
- prefer 2
- apply clarify
- apply(rule_tac m="length ((None, s) # xs)" in etran_or_ctran,simp+)
- apply(erule not_ctran_None2,simp)
- apply simp+
-apply(frule_tac j="0" and k="length ((None, s) # xs) - 1" and p=post in stability,simp+)
- apply(force simp add:assum_def subsetD)
- apply(simp add:assum_def)
- apply clarify
- apply(erule_tac x="i" in allE,simp)
- apply(erule_tac x="Suc i" in allE,simp)
- apply simp
-apply clarify
-apply (simp add:last_length)
---{* WhileOne *}
-apply(thin_tac "P = While b P \<longrightarrow> ?Q")
-apply(rule ctran_in_comm,simp)
-apply(simp add:Cons_lift del:map.simps)
-apply(simp add:comm_def del:map.simps)
-apply(rule conjI)
- apply clarify
- apply(case_tac "fst(((Some P, sa) # xs) ! i)")
- apply(case_tac "((Some P, sa) # xs) ! i")
- apply (simp add:lift_def)
- apply(ind_cases "(Some (While b P), ba) -c\<rightarrow> t" for ba t)
- apply simp
- apply simp
- apply(simp add:snd_lift del:map.simps)
- apply(simp only:com_validity_def cp_def cptn_iff_cptn_mod)
- apply(erule_tac x=sa in allE)
- apply(drule_tac c="(Some P, sa) # xs" in subsetD)
- apply (simp add:assum_def del:map.simps)
- apply clarify
- apply(erule_tac x="Suc ia" in allE,simp add:snd_lift del:map.simps)
- apply(erule mp)
- apply(case_tac "fst(((Some P, sa) # xs) ! ia)")
- apply(erule etranE,simp add:lift_def)
- apply(rule Env)
- apply(erule etranE,simp add:lift_def)
- apply(rule Env)
- apply (simp add:comm_def del:map.simps)
- apply clarify
- apply(erule allE,erule impE,assumption)
- apply(erule mp)
- apply(case_tac "((Some P, sa) # xs) ! i")
- apply(case_tac "xs!i")
- apply(simp add:lift_def)
- apply(case_tac "fst(xs!i)")
- apply force
- apply force
---{* last=None *}
-apply clarify
-apply(subgoal_tac "(map (lift (While b P)) ((Some P, sa) # xs))\<noteq>[]")
- apply(drule last_conv_nth)
- apply (simp del:map.simps)
- apply(simp only:last_lift_not_None)
-apply simp
---{* WhileMore *}
-apply(thin_tac "P = While b P \<longrightarrow> ?Q")
-apply(rule ctran_in_comm,simp del:last.simps)
---{* metiendo la hipotesis antes de dividir la conclusion. *}
-apply(subgoal_tac "(Some (While b P), snd (last ((Some P, sa) # xs))) # ys \<in> assum (pre, rely)")
- apply (simp del:last.simps)
- prefer 2
- apply(erule assum_after_body)
- apply (simp del:last.simps)+
---{* lo de antes. *}
-apply(simp add:comm_def del:map.simps last.simps)
-apply(rule conjI)
- apply clarify
- apply(simp only:Cons_lift_append)
- apply(case_tac "i<length xs")
- apply(simp add:nth_append del:map.simps last.simps)
- apply(case_tac "fst(((Some P, sa) # xs) ! i)")
- apply(case_tac "((Some P, sa) # xs) ! i")
- apply (simp add:lift_def del:last.simps)
- apply(ind_cases "(Some (While b P), ba) -c\<rightarrow> t" for ba t)
- apply simp
- apply simp
- apply(simp add:snd_lift del:map.simps last.simps)
- apply(thin_tac " \<forall>i. i < length ys \<longrightarrow> ?P i")
- apply(simp only:com_validity_def cp_def cptn_iff_cptn_mod)
- apply(erule_tac x=sa in allE)
- apply(drule_tac c="(Some P, sa) # xs" in subsetD)
- apply (simp add:assum_def del:map.simps last.simps)
- apply clarify
- apply(erule_tac x="Suc ia" in allE,simp add:nth_append snd_lift del:map.simps last.simps, erule mp)
- apply(case_tac "fst(((Some P, sa) # xs) ! ia)")
- apply(erule etranE,simp add:lift_def)
- apply(rule Env)
- apply(erule etranE,simp add:lift_def)
- apply(rule Env)
- apply (simp add:comm_def del:map.simps)
- apply clarify
- apply(erule allE,erule impE,assumption)
- apply(erule mp)
- apply(case_tac "((Some P, sa) # xs) ! i")
- apply(case_tac "xs!i")
- apply(simp add:lift_def)
- apply(case_tac "fst(xs!i)")
- apply force
- apply force
---{* @{text "i \<ge> length xs"} *}
-apply(subgoal_tac "i-length xs <length ys")
- prefer 2
- apply arith
-apply(erule_tac x="i-length xs" in allE,clarify)
-apply(case_tac "i=length xs")
- apply (simp add:nth_append snd_lift del:map.simps last.simps)
- apply(simp add:last_length del:last.simps)
- apply(erule mp)
- apply(case_tac "last((Some P, sa) # xs)")
- apply(simp add:lift_def del:last.simps)
---{* @{text "i>length xs"} *}
-apply(case_tac "i-length xs")
- apply arith
-apply(simp add:nth_append del:map.simps last.simps)
-apply(rotate_tac -3)
-apply(subgoal_tac "i- Suc (length xs)=nat")
- prefer 2
- apply arith
-apply simp
---{* last=None *}
-apply clarify
-apply(case_tac ys)
- apply(simp add:Cons_lift del:map.simps last.simps)
- apply(subgoal_tac "(map (lift (While b P)) ((Some P, sa) # xs))\<noteq>[]")
- apply(drule last_conv_nth)
- apply (simp del:map.simps)
- apply(simp only:last_lift_not_None)
- apply simp
-apply(subgoal_tac "((Some (Seq P (While b P)), sa) # map (lift (While b P)) xs @ ys)\<noteq>[]")
- apply(drule last_conv_nth)
- apply (simp del:map.simps last.simps)
- apply(simp add:nth_append del:last.simps)
- apply(subgoal_tac "((Some (While b P), snd (last ((Some P, sa) # xs))) # a # list)\<noteq>[]")
- apply(drule last_conv_nth)
- apply (simp del:map.simps last.simps)
- apply simp
-apply simp
-done
-
-lemma While_sound:
- "\<lbrakk>stable pre rely; pre \<inter> - b \<subseteq> post; stable post rely;
- \<Turnstile> P sat [pre \<inter> b, rely, guar, pre]; \<forall>s. (s,s)\<in>guar\<rbrakk>
- \<Longrightarrow> \<Turnstile> While b P sat [pre, rely, guar, post]"
-apply(unfold com_validity_def)
-apply clarify
-apply(erule_tac xs="tl x" in While_sound_aux)
- apply(simp add:com_validity_def)
- apply force
- apply simp_all
-apply(simp add:cptn_iff_cptn_mod cp_def)
-apply(simp add:cp_def)
-apply clarify
-apply(rule nth_equalityI)
- apply simp_all
- apply(case_tac x,simp+)
-apply clarify
-apply(case_tac i,simp+)
-apply(case_tac x,simp+)
-done
-
-subsubsection{* Soundness of the Rule of Consequence *}
-
-lemma Conseq_sound:
- "\<lbrakk>pre \<subseteq> pre'; rely \<subseteq> rely'; guar' \<subseteq> guar; post' \<subseteq> post;
- \<Turnstile> P sat [pre', rely', guar', post']\<rbrakk>
- \<Longrightarrow> \<Turnstile> P sat [pre, rely, guar, post]"
-apply(simp add:com_validity_def assum_def comm_def)
-apply clarify
-apply(erule_tac x=s in allE)
-apply(drule_tac c=x in subsetD)
- apply force
-apply force
-done
-
-subsubsection {* Soundness of the system for sequential component programs *}
-
-theorem rgsound:
- "\<turnstile> P sat [pre, rely, guar, post] \<Longrightarrow> \<Turnstile> P sat [pre, rely, guar, post]"
-apply(erule rghoare.induct)
- apply(force elim:Basic_sound)
- apply(force elim:Seq_sound)
- apply(force elim:Cond_sound)
- apply(force elim:While_sound)
- apply(force elim:Await_sound)
-apply(erule Conseq_sound,simp+)
-done
-
-subsection {* Soundness of the System for Parallel Programs *}
-
-constdefs
- ParallelCom :: "('a rgformula) list \<Rightarrow> 'a par_com"
- "ParallelCom Ps \<equiv> map (Some \<circ> fst) Ps"
-
-lemma two:
- "\<lbrakk> \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
- \<subseteq> Rely (xs ! i);
- pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
- \<forall>i<length xs.
- \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
- length xs=length clist; x \<in> par_cp (ParallelCom xs) s; x\<in>par_assum(pre, rely);
- \<forall>i<length clist. clist!i\<in>cp (Some(Com(xs!i))) s; x \<propto> clist \<rbrakk>
- \<Longrightarrow> \<forall>j i. i<length clist \<and> Suc j<length x \<longrightarrow> (clist!i!j) -c\<rightarrow> (clist!i!Suc j)
- \<longrightarrow> (snd(clist!i!j), snd(clist!i!Suc j)) \<in> Guar(xs!i)"
-apply(unfold par_cp_def)
-apply (rule ccontr)
---{* By contradiction: *}
-apply (simp del: Un_subset_iff)
-apply(erule exE)
---{* the first c-tran that does not satisfy the guarantee-condition is from @{text "\<sigma>_i"} at step @{text "m"}. *}
-apply(drule_tac n=j and P="\<lambda>j. \<exists>i. ?H i j" in Ex_first_occurrence)
-apply(erule exE)
-apply clarify
---{* @{text "\<sigma>_i \<in> A(pre, rely_1)"} *}
-apply(subgoal_tac "take (Suc (Suc m)) (clist!i) \<in> assum(Pre(xs!i), Rely(xs!i))")
---{* but this contradicts @{text "\<Turnstile> \<sigma>_i sat [pre_i,rely_i,guar_i,post_i]"} *}
- apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> \<Turnstile> (?J i) sat [?I i,?K i,?M i,?N i]" in allE,erule impE,assumption)
- apply(simp add:com_validity_def)
- apply(erule_tac x=s in allE)
- apply(simp add:cp_def comm_def)
- apply(drule_tac c="take (Suc (Suc m)) (clist ! i)" in subsetD)
- apply simp
- apply (blast intro: takecptn_is_cptn)
- apply simp
- apply clarify
- apply(erule_tac x=m and P="\<lambda>j. ?I j \<and> ?J j \<longrightarrow> ?H j" in allE)
- apply (simp add:conjoin_def same_length_def)
-apply(simp add:assum_def del: Un_subset_iff)
-apply(rule conjI)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<in>cp (?K j) (?J j)" in allE)
- apply(simp add:cp_def par_assum_def)
- apply(drule_tac c="s" in subsetD,simp)
- apply simp
-apply clarify
-apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> ?M \<union> UNION (?S j) (?T j) \<subseteq> (?L j)" in allE)
-apply(simp del: Un_subset_iff)
-apply(erule subsetD)
-apply simp
-apply(simp add:conjoin_def compat_label_def)
-apply clarify
-apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (?P j) \<or> ?Q j" in allE,simp)
---{* each etran in @{text "\<sigma>_1[0\<dots>m]"} corresponds to *}
-apply(erule disjE)
---{* a c-tran in some @{text "\<sigma>_{ib}"} *}
- apply clarify
- apply(case_tac "i=ib",simp)
- apply(erule etranE,simp)
- apply(erule_tac x="ib" and P="\<lambda>i. ?H i \<longrightarrow> (?I i) \<or> (?J i)" in allE)
- apply (erule etranE)
- apply(case_tac "ia=m",simp)
- apply simp
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (\<forall> i. ?P i j)" in allE)
- apply(subgoal_tac "ia<m",simp)
- prefer 2
- apply arith
- apply(erule_tac x=ib and P="\<lambda>j. (?I j, ?H j)\<in> ctran \<longrightarrow> (?P i j)" in allE,simp)
- apply(simp add:same_state_def)
- apply(erule_tac x=i and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in all_dupE)
- apply(erule_tac x=ib and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
---{* or an e-tran in @{text "\<sigma>"},
-therefore it satisfies @{text "rely \<or> guar_{ib}"} *}
-apply (force simp add:par_assum_def same_state_def)
-done
-
-
-lemma three [rule_format]:
- "\<lbrakk> xs\<noteq>[]; \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
- \<subseteq> Rely (xs ! i);
- pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
- \<forall>i<length xs.
- \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
- length xs=length clist; x \<in> par_cp (ParallelCom xs) s; x \<in> par_assum(pre, rely);
- \<forall>i<length clist. clist!i\<in>cp (Some(Com(xs!i))) s; x \<propto> clist \<rbrakk>
- \<Longrightarrow> \<forall>j i. i<length clist \<and> Suc j<length x \<longrightarrow> (clist!i!j) -e\<rightarrow> (clist!i!Suc j)
- \<longrightarrow> (snd(clist!i!j), snd(clist!i!Suc j)) \<in> rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))"
-apply(drule two)
- apply simp_all
-apply clarify
-apply(simp add:conjoin_def compat_label_def)
-apply clarify
-apply(erule_tac x=j and P="\<lambda>j. ?H j \<longrightarrow> (?J j \<and> (\<exists>i. ?P i j)) \<or> ?I j" in allE,simp)
-apply(erule disjE)
- prefer 2
- apply(force simp add:same_state_def par_assum_def)
-apply clarify
-apply(case_tac "i=ia",simp)
- apply(erule etranE,simp)
-apply(erule_tac x="ia" and P="\<lambda>i. ?H i \<longrightarrow> (?I i) \<or> (?J i)" in allE,simp)
-apply(erule_tac x=j and P="\<lambda>j. \<forall>i. ?S j i \<longrightarrow> (?I j i, ?H j i)\<in> ctran \<longrightarrow> (?P i j)" in allE)
-apply(erule_tac x=ia and P="\<lambda>j. ?S j \<longrightarrow> (?I j, ?H j)\<in> ctran \<longrightarrow> (?P j)" in allE)
-apply(simp add:same_state_def)
-apply(erule_tac x=i and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in all_dupE)
-apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
-done
-
-lemma four:
- "\<lbrakk>xs\<noteq>[]; \<forall>i < length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
- \<subseteq> Rely (xs ! i);
- (\<Union>j\<in>{j. j < length xs}. Guar (xs ! j)) \<subseteq> guar;
- pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
- \<forall>i < length xs.
- \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
- x \<in> par_cp (ParallelCom xs) s; x \<in> par_assum (pre, rely); Suc i < length x;
- x ! i -pc\<rightarrow> x ! Suc i\<rbrakk>
- \<Longrightarrow> (snd (x ! i), snd (x ! Suc i)) \<in> guar"
-apply(simp add: ParallelCom_def del: Un_subset_iff)
-apply(subgoal_tac "(map (Some \<circ> fst) xs)\<noteq>[]")
- prefer 2
- apply simp
-apply(frule rev_subsetD)
- apply(erule one [THEN equalityD1])
-apply(erule subsetD)
-apply (simp del: Un_subset_iff)
-apply clarify
-apply(drule_tac pre=pre and rely=rely and x=x and s=s and xs=xs and clist=clist in two)
-apply(assumption+)
- apply(erule sym)
- apply(simp add:ParallelCom_def)
- apply assumption
- apply(simp add:Com_def)
- apply assumption
-apply(simp add:conjoin_def same_program_def)
-apply clarify
-apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> fst(?I j)=(?J j)" in all_dupE)
-apply(erule_tac x="Suc i" and P="\<lambda>j. ?H j \<longrightarrow> fst(?I j)=(?J j)" in allE)
-apply(erule par_ctranE,simp)
-apply(erule_tac x=i and P="\<lambda>j. \<forall>i. ?S j i \<longrightarrow> (?I j i, ?H j i)\<in> ctran \<longrightarrow> (?P i j)" in allE)
-apply(erule_tac x=ia and P="\<lambda>j. ?S j \<longrightarrow> (?I j, ?H j)\<in> ctran \<longrightarrow> (?P j)" in allE)
-apply(rule_tac x=ia in exI)
-apply(simp add:same_state_def)
-apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in all_dupE,simp)
-apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
-apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in all_dupE)
-apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in all_dupE,simp)
-apply(erule_tac x="Suc i" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
-apply(erule mp)
-apply(subgoal_tac "r=fst(clist ! ia ! Suc i)",simp)
-apply(drule_tac i=ia in list_eq_if)
-back
-apply simp_all
-done
-
-lemma parcptn_not_empty [simp]:"[] \<notin> par_cptn"
-apply(force elim:par_cptn.cases)
-done
-
-lemma five:
- "\<lbrakk>xs\<noteq>[]; \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
- \<subseteq> Rely (xs ! i);
- pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
- (\<Inter>i\<in>{i. i < length xs}. Post (xs ! i)) \<subseteq> post;
- \<forall>i < length xs.
- \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
- x \<in> par_cp (ParallelCom xs) s; x \<in> par_assum (pre, rely);
- All_None (fst (last x)) \<rbrakk> \<Longrightarrow> snd (last x) \<in> post"
-apply(simp add: ParallelCom_def del: Un_subset_iff)
-apply(subgoal_tac "(map (Some \<circ> fst) xs)\<noteq>[]")
- prefer 2
- apply simp
-apply(frule rev_subsetD)
- apply(erule one [THEN equalityD1])
-apply(erule subsetD)
-apply(simp del: Un_subset_iff)
-apply clarify
-apply(subgoal_tac "\<forall>i<length clist. clist!i\<in>assum(Pre(xs!i), Rely(xs!i))")
- apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> \<Turnstile> (?J i) sat [?I i,?K i,?M i,?N i]" in allE,erule impE,assumption)
- apply(simp add:com_validity_def)
- apply(erule_tac x=s in allE)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (?I j) \<in> cp (?J j) s" in allE,simp)
- apply(drule_tac c="clist!i" in subsetD)
- apply (force simp add:Com_def)
- apply(simp add:comm_def conjoin_def same_program_def del:last.simps)
- apply clarify
- apply(erule_tac x="length x - 1" and P="\<lambda>j. ?H j \<longrightarrow> fst(?I j)=(?J j)" in allE)
- apply (simp add:All_None_def same_length_def)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> length(?J j)=(?K j)" in allE)
- apply(subgoal_tac "length x - 1 < length x",simp)
- apply(case_tac "x\<noteq>[]")
- apply(simp add: last_conv_nth)
- apply(erule_tac x="clist!i" in ballE)
- apply(simp add:same_state_def)
- apply(subgoal_tac "clist!i\<noteq>[]")
- apply(simp add: last_conv_nth)
- apply(case_tac x)
- apply (force simp add:par_cp_def)
- apply (force simp add:par_cp_def)
- apply force
- apply (force simp add:par_cp_def)
- apply(case_tac x)
- apply (force simp add:par_cp_def)
- apply (force simp add:par_cp_def)
-apply clarify
-apply(simp add:assum_def)
-apply(rule conjI)
- apply(simp add:conjoin_def same_state_def par_cp_def)
- apply clarify
- apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
- apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
- apply(case_tac x,simp+)
- apply (simp add:par_assum_def)
- apply clarify
- apply(drule_tac c="snd (clist ! ia ! 0)" in subsetD)
- apply assumption
- apply simp
-apply clarify
-apply(erule_tac x=ia in all_dupE)
-apply(rule subsetD, erule mp, assumption)
-apply(erule_tac pre=pre and rely=rely and x=x and s=s in three)
- apply(erule_tac x=ic in allE,erule mp)
- apply simp_all
- apply(simp add:ParallelCom_def)
- apply(force simp add:Com_def)
-apply(simp add:conjoin_def same_length_def)
-done
-
-lemma ParallelEmpty [rule_format]:
- "\<forall>i s. x \<in> par_cp (ParallelCom []) s \<longrightarrow>
- Suc i < length x \<longrightarrow> (x ! i, x ! Suc i) \<notin> par_ctran"
-apply(induct_tac x)
- apply(simp add:par_cp_def ParallelCom_def)
-apply clarify
-apply(case_tac list,simp,simp)
-apply(case_tac i)
- apply(simp add:par_cp_def ParallelCom_def)
- apply(erule par_ctranE,simp)
-apply(simp add:par_cp_def ParallelCom_def)
-apply clarify
-apply(erule par_cptn.cases,simp)
- apply simp
-apply(erule par_ctranE)
-back
-apply simp
-done
-
-theorem par_rgsound:
- "\<turnstile> c SAT [pre, rely, guar, post] \<Longrightarrow>
- \<Turnstile> (ParallelCom c) SAT [pre, rely, guar, post]"
-apply(erule par_rghoare.induct)
-apply(case_tac xs,simp)
- apply(simp add:par_com_validity_def par_comm_def)
- apply clarify
- apply(case_tac "post=UNIV",simp)
- apply clarify
- apply(drule ParallelEmpty)
- apply assumption
- apply simp
- apply clarify
- apply simp
-apply(subgoal_tac "xs\<noteq>[]")
- prefer 2
- apply simp
-apply(thin_tac "xs = a # list")
-apply(simp add:par_com_validity_def par_comm_def)
-apply clarify
-apply(rule conjI)
- apply clarify
- apply(erule_tac pre=pre and rely=rely and guar=guar and x=x and s=s and xs=xs in four)
- apply(assumption+)
- apply clarify
- apply (erule allE, erule impE, assumption,erule rgsound)
- apply(assumption+)
-apply clarify
-apply(erule_tac pre=pre and rely=rely and post=post and x=x and s=s and xs=xs in five)
- apply(assumption+)
- apply clarify
- apply (erule allE, erule impE, assumption,erule rgsound)
- apply(assumption+)
-done
-
-end
--- a/src/HOL/HoareParallel/RG_Syntax.thy Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,95 +0,0 @@
-header {* \section{Concrete Syntax} *}
-
-theory RG_Syntax
-imports RG_Hoare Quote_Antiquote
-begin
-
-syntax
- "_Assign" :: "idt \<Rightarrow> 'b \<Rightarrow> 'a com" ("(\<acute>_ :=/ _)" [70, 65] 61)
- "_skip" :: "'a com" ("SKIP")
- "_Seq" :: "'a com \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(_;;/ _)" [60,61] 60)
- "_Cond" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(0IF _/ THEN _/ ELSE _/FI)" [0, 0, 0] 61)
- "_Cond2" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(0IF _ THEN _ FI)" [0,0] 56)
- "_While" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(0WHILE _ /DO _ /OD)" [0, 0] 61)
- "_Await" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(0AWAIT _ /THEN /_ /END)" [0,0] 61)
- "_Atom" :: "'a com \<Rightarrow> 'a com" ("(\<langle>_\<rangle>)" 61)
- "_Wait" :: "'a bexp \<Rightarrow> 'a com" ("(0WAIT _ END)" 61)
-
-translations
- "\<acute>\<spacespace>x := a" \<rightharpoonup> "Basic \<guillemotleft>\<acute>\<spacespace>(_update_name x (\<lambda>_. a))\<guillemotright>"
- "SKIP" \<rightleftharpoons> "Basic id"
- "c1;; c2" \<rightleftharpoons> "Seq c1 c2"
- "IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "Cond .{b}. c1 c2"
- "IF b THEN c FI" \<rightleftharpoons> "IF b THEN c ELSE SKIP FI"
- "WHILE b DO c OD" \<rightharpoonup> "While .{b}. c"
- "AWAIT b THEN c END" \<rightleftharpoons> "Await .{b}. c"
- "\<langle>c\<rangle>" \<rightleftharpoons> "AWAIT True THEN c END"
- "WAIT b END" \<rightleftharpoons> "AWAIT b THEN SKIP END"
-
-nonterminals
- prgs
-
-syntax
- "_PAR" :: "prgs \<Rightarrow> 'a" ("COBEGIN//_//COEND" 60)
- "_prg" :: "'a \<Rightarrow> prgs" ("_" 57)
- "_prgs" :: "['a, prgs] \<Rightarrow> prgs" ("_//\<parallel>//_" [60,57] 57)
-
-translations
- "_prg a" \<rightharpoonup> "[a]"
- "_prgs a ps" \<rightharpoonup> "a # ps"
- "_PAR ps" \<rightharpoonup> "ps"
-
-syntax
- "_prg_scheme" :: "['a, 'a, 'a, 'a] \<Rightarrow> prgs" ("SCHEME [_ \<le> _ < _] _" [0,0,0,60] 57)
-
-translations
- "_prg_scheme j i k c" \<rightleftharpoons> "(map (\<lambda>i. c) [j..<k])"
-
-text {* Translations for variables before and after a transition: *}
-
-syntax
- "_before" :: "id \<Rightarrow> 'a" ("\<ordmasculine>_")
- "_after" :: "id \<Rightarrow> 'a" ("\<ordfeminine>_")
-
-translations
- "\<ordmasculine>x" \<rightleftharpoons> "x \<acute>fst"
- "\<ordfeminine>x" \<rightleftharpoons> "x \<acute>snd"
-
-print_translation {*
- let
- fun quote_tr' f (t :: ts) =
- Term.list_comb (f $ Syntax.quote_tr' "_antiquote" t, ts)
- | quote_tr' _ _ = raise Match;
-
- val assert_tr' = quote_tr' (Syntax.const "_Assert");
-
- fun bexp_tr' name ((Const ("Collect", _) $ t) :: ts) =
- quote_tr' (Syntax.const name) (t :: ts)
- | bexp_tr' _ _ = raise Match;
-
- fun upd_tr' (x_upd, T) =
- (case try (unsuffix Record.updateN) x_upd of
- SOME x => (x, if T = dummyT then T else Term.domain_type T)
- | NONE => raise Match);
-
- fun update_name_tr' (Free x) = Free (upd_tr' x)
- | update_name_tr' ((c as Const ("_free", _)) $ Free x) =
- c $ Free (upd_tr' x)
- | update_name_tr' (Const x) = Const (upd_tr' x)
- | update_name_tr' _ = raise Match;
-
- fun K_tr' (Abs (_,_,t)) = if null (loose_bnos t) then t else raise Match
- | K_tr' (Abs (_,_,Abs (_,_,t)$Bound 0)) = if null (loose_bnos t) then t else raise Match
- | K_tr' _ = raise Match;
-
- fun assign_tr' (Abs (x, _, f $ k $ Bound 0) :: ts) =
- quote_tr' (Syntax.const "_Assign" $ update_name_tr' f)
- (Abs (x, dummyT, K_tr' k) :: ts)
- | assign_tr' _ = raise Match;
- in
- [("Collect", assert_tr'), ("Basic", assign_tr'),
- ("Cond", bexp_tr' "_Cond"), ("While", bexp_tr' "_While_inv")]
- end
-*}
-
-end
\ No newline at end of file
--- a/src/HOL/HoareParallel/RG_Tran.thy Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1075 +0,0 @@
-header {* \section{Operational Semantics} *}
-
-theory RG_Tran
-imports RG_Com
-begin
-
-subsection {* Semantics of Component Programs *}
-
-subsubsection {* Environment transitions *}
-
-types 'a conf = "(('a com) option) \<times> 'a"
-
-inductive_set
- etran :: "('a conf \<times> 'a conf) set"
- and etran' :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool" ("_ -e\<rightarrow> _" [81,81] 80)
-where
- "P -e\<rightarrow> Q \<equiv> (P,Q) \<in> etran"
-| Env: "(P, s) -e\<rightarrow> (P, t)"
-
-lemma etranE: "c -e\<rightarrow> c' \<Longrightarrow> (\<And>P s t. c = (P, s) \<Longrightarrow> c' = (P, t) \<Longrightarrow> Q) \<Longrightarrow> Q"
- by (induct c, induct c', erule etran.cases, blast)
-
-subsubsection {* Component transitions *}
-
-inductive_set
- ctran :: "('a conf \<times> 'a conf) set"
- and ctran' :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool" ("_ -c\<rightarrow> _" [81,81] 80)
- and ctrans :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool" ("_ -c*\<rightarrow> _" [81,81] 80)
-where
- "P -c\<rightarrow> Q \<equiv> (P,Q) \<in> ctran"
-| "P -c*\<rightarrow> Q \<equiv> (P,Q) \<in> ctran^*"
-
-| Basic: "(Some(Basic f), s) -c\<rightarrow> (None, f s)"
-
-| Seq1: "(Some P0, s) -c\<rightarrow> (None, t) \<Longrightarrow> (Some(Seq P0 P1), s) -c\<rightarrow> (Some P1, t)"
-
-| Seq2: "(Some P0, s) -c\<rightarrow> (Some P2, t) \<Longrightarrow> (Some(Seq P0 P1), s) -c\<rightarrow> (Some(Seq P2 P1), t)"
-
-| CondT: "s\<in>b \<Longrightarrow> (Some(Cond b P1 P2), s) -c\<rightarrow> (Some P1, s)"
-| CondF: "s\<notin>b \<Longrightarrow> (Some(Cond b P1 P2), s) -c\<rightarrow> (Some P2, s)"
-
-| WhileF: "s\<notin>b \<Longrightarrow> (Some(While b P), s) -c\<rightarrow> (None, s)"
-| WhileT: "s\<in>b \<Longrightarrow> (Some(While b P), s) -c\<rightarrow> (Some(Seq P (While b P)), s)"
-
-| Await: "\<lbrakk>s\<in>b; (Some P, s) -c*\<rightarrow> (None, t)\<rbrakk> \<Longrightarrow> (Some(Await b P), s) -c\<rightarrow> (None, t)"
-
-monos "rtrancl_mono"
-
-subsection {* Semantics of Parallel Programs *}
-
-types 'a par_conf = "('a par_com) \<times> 'a"
-
-inductive_set
- par_etran :: "('a par_conf \<times> 'a par_conf) set"
- and par_etran' :: "['a par_conf,'a par_conf] \<Rightarrow> bool" ("_ -pe\<rightarrow> _" [81,81] 80)
-where
- "P -pe\<rightarrow> Q \<equiv> (P,Q) \<in> par_etran"
-| ParEnv: "(Ps, s) -pe\<rightarrow> (Ps, t)"
-
-inductive_set
- par_ctran :: "('a par_conf \<times> 'a par_conf) set"
- and par_ctran' :: "['a par_conf,'a par_conf] \<Rightarrow> bool" ("_ -pc\<rightarrow> _" [81,81] 80)
-where
- "P -pc\<rightarrow> Q \<equiv> (P,Q) \<in> par_ctran"
-| ParComp: "\<lbrakk>i<length Ps; (Ps!i, s) -c\<rightarrow> (r, t)\<rbrakk> \<Longrightarrow> (Ps, s) -pc\<rightarrow> (Ps[i:=r], t)"
-
-lemma par_ctranE: "c -pc\<rightarrow> c' \<Longrightarrow>
- (\<And>i Ps s r t. c = (Ps, s) \<Longrightarrow> c' = (Ps[i := r], t) \<Longrightarrow> i < length Ps \<Longrightarrow>
- (Ps ! i, s) -c\<rightarrow> (r, t) \<Longrightarrow> P) \<Longrightarrow> P"
- by (induct c, induct c', erule par_ctran.cases, blast)
-
-subsection {* Computations *}
-
-subsubsection {* Sequential computations *}
-
-types 'a confs = "('a conf) list"
-
-inductive_set cptn :: "('a confs) set"
-where
- CptnOne: "[(P,s)] \<in> cptn"
-| CptnEnv: "(P, t)#xs \<in> cptn \<Longrightarrow> (P,s)#(P,t)#xs \<in> cptn"
-| CptnComp: "\<lbrakk>(P,s) -c\<rightarrow> (Q,t); (Q, t)#xs \<in> cptn \<rbrakk> \<Longrightarrow> (P,s)#(Q,t)#xs \<in> cptn"
-
-constdefs
- cp :: "('a com) option \<Rightarrow> 'a \<Rightarrow> ('a confs) set"
- "cp P s \<equiv> {l. l!0=(P,s) \<and> l \<in> cptn}"
-
-subsubsection {* Parallel computations *}
-
-types 'a par_confs = "('a par_conf) list"
-
-inductive_set par_cptn :: "('a par_confs) set"
-where
- ParCptnOne: "[(P,s)] \<in> par_cptn"
-| ParCptnEnv: "(P,t)#xs \<in> par_cptn \<Longrightarrow> (P,s)#(P,t)#xs \<in> par_cptn"
-| ParCptnComp: "\<lbrakk> (P,s) -pc\<rightarrow> (Q,t); (Q,t)#xs \<in> par_cptn \<rbrakk> \<Longrightarrow> (P,s)#(Q,t)#xs \<in> par_cptn"
-
-constdefs
- par_cp :: "'a par_com \<Rightarrow> 'a \<Rightarrow> ('a par_confs) set"
- "par_cp P s \<equiv> {l. l!0=(P,s) \<and> l \<in> par_cptn}"
-
-subsection{* Modular Definition of Computation *}
-
-constdefs
- lift :: "'a com \<Rightarrow> 'a conf \<Rightarrow> 'a conf"
- "lift Q \<equiv> \<lambda>(P, s). (if P=None then (Some Q,s) else (Some(Seq (the P) Q), s))"
-
-inductive_set cptn_mod :: "('a confs) set"
-where
- CptnModOne: "[(P, s)] \<in> cptn_mod"
-| CptnModEnv: "(P, t)#xs \<in> cptn_mod \<Longrightarrow> (P, s)#(P, t)#xs \<in> cptn_mod"
-| CptnModNone: "\<lbrakk>(Some P, s) -c\<rightarrow> (None, t); (None, t)#xs \<in> cptn_mod \<rbrakk> \<Longrightarrow> (Some P,s)#(None, t)#xs \<in>cptn_mod"
-| CptnModCondT: "\<lbrakk>(Some P0, s)#ys \<in> cptn_mod; s \<in> b \<rbrakk> \<Longrightarrow> (Some(Cond b P0 P1), s)#(Some P0, s)#ys \<in> cptn_mod"
-| CptnModCondF: "\<lbrakk>(Some P1, s)#ys \<in> cptn_mod; s \<notin> b \<rbrakk> \<Longrightarrow> (Some(Cond b P0 P1), s)#(Some P1, s)#ys \<in> cptn_mod"
-| CptnModSeq1: "\<lbrakk>(Some P0, s)#xs \<in> cptn_mod; zs=map (lift P1) xs \<rbrakk>
- \<Longrightarrow> (Some(Seq P0 P1), s)#zs \<in> cptn_mod"
-| CptnModSeq2:
- "\<lbrakk>(Some P0, s)#xs \<in> cptn_mod; fst(last ((Some P0, s)#xs)) = None;
- (Some P1, snd(last ((Some P0, s)#xs)))#ys \<in> cptn_mod;
- zs=(map (lift P1) xs)@ys \<rbrakk> \<Longrightarrow> (Some(Seq P0 P1), s)#zs \<in> cptn_mod"
-
-| CptnModWhile1:
- "\<lbrakk> (Some P, s)#xs \<in> cptn_mod; s \<in> b; zs=map (lift (While b P)) xs \<rbrakk>
- \<Longrightarrow> (Some(While b P), s)#(Some(Seq P (While b P)), s)#zs \<in> cptn_mod"
-| CptnModWhile2:
- "\<lbrakk> (Some P, s)#xs \<in> cptn_mod; fst(last ((Some P, s)#xs))=None; s \<in> b;
- zs=(map (lift (While b P)) xs)@ys;
- (Some(While b P), snd(last ((Some P, s)#xs)))#ys \<in> cptn_mod\<rbrakk>
- \<Longrightarrow> (Some(While b P), s)#(Some(Seq P (While b P)), s)#zs \<in> cptn_mod"
-
-subsection {* Equivalence of Both Definitions.*}
-
-lemma last_length: "((a#xs)!(length xs))=last (a#xs)"
-apply simp
-apply(induct xs,simp+)
-apply(case_tac xs)
-apply simp_all
-done
-
-lemma div_seq [rule_format]: "list \<in> cptn_mod \<Longrightarrow>
- (\<forall>s P Q zs. list=(Some (Seq P Q), s)#zs \<longrightarrow>
- (\<exists>xs. (Some P, s)#xs \<in> cptn_mod \<and> (zs=(map (lift Q) xs) \<or>
- ( fst(((Some P, s)#xs)!length xs)=None \<and>
- (\<exists>ys. (Some Q, snd(((Some P, s)#xs)!length xs))#ys \<in> cptn_mod
- \<and> zs=(map (lift (Q)) xs)@ys)))))"
-apply(erule cptn_mod.induct)
-apply simp_all
- apply clarify
- apply(force intro:CptnModOne)
- apply clarify
- apply(erule_tac x=Pa in allE)
- apply(erule_tac x=Q in allE)
- apply simp
- apply clarify
- apply(erule disjE)
- apply(rule_tac x="(Some Pa,t)#xsa" in exI)
- apply(rule conjI)
- apply clarify
- apply(erule CptnModEnv)
- apply(rule disjI1)
- apply(simp add:lift_def)
- apply clarify
- apply(rule_tac x="(Some Pa,t)#xsa" in exI)
- apply(rule conjI)
- apply(erule CptnModEnv)
- apply(rule disjI2)
- apply(rule conjI)
- apply(case_tac xsa,simp,simp)
- apply(rule_tac x="ys" in exI)
- apply(rule conjI)
- apply simp
- apply(simp add:lift_def)
- apply clarify
- apply(erule ctran.cases,simp_all)
- apply clarify
- apply(rule_tac x="xs" in exI)
- apply simp
- apply clarify
-apply(rule_tac x="xs" in exI)
-apply(simp add: last_length)
-done
-
-lemma cptn_onlyif_cptn_mod_aux [rule_format]:
- "\<forall>s Q t xs.((Some a, s), Q, t) \<in> ctran \<longrightarrow> (Q, t) # xs \<in> cptn_mod
- \<longrightarrow> (Some a, s) # (Q, t) # xs \<in> cptn_mod"
-apply(induct a)
-apply simp_all
---{* basic *}
-apply clarify
-apply(erule ctran.cases,simp_all)
-apply(rule CptnModNone,rule Basic,simp)
-apply clarify
-apply(erule ctran.cases,simp_all)
---{* Seq1 *}
-apply(rule_tac xs="[(None,ta)]" in CptnModSeq2)
- apply(erule CptnModNone)
- apply(rule CptnModOne)
- apply simp
-apply simp
-apply(simp add:lift_def)
---{* Seq2 *}
-apply(erule_tac x=sa in allE)
-apply(erule_tac x="Some P2" in allE)
-apply(erule allE,erule impE, assumption)
-apply(drule div_seq,simp)
-apply force
-apply clarify
-apply(erule disjE)
- apply clarify
- apply(erule allE,erule impE, assumption)
- apply(erule_tac CptnModSeq1)
- apply(simp add:lift_def)
-apply clarify
-apply(erule allE,erule impE, assumption)
-apply(erule_tac CptnModSeq2)
- apply (simp add:last_length)
- apply (simp add:last_length)
-apply(simp add:lift_def)
---{* Cond *}
-apply clarify
-apply(erule ctran.cases,simp_all)
-apply(force elim: CptnModCondT)
-apply(force elim: CptnModCondF)
---{* While *}
-apply clarify
-apply(erule ctran.cases,simp_all)
-apply(rule CptnModNone,erule WhileF,simp)
-apply(drule div_seq,force)
-apply clarify
-apply (erule disjE)
- apply(force elim:CptnModWhile1)
-apply clarify
-apply(force simp add:last_length elim:CptnModWhile2)
---{* await *}
-apply clarify
-apply(erule ctran.cases,simp_all)
-apply(rule CptnModNone,erule Await,simp+)
-done
-
-lemma cptn_onlyif_cptn_mod [rule_format]: "c \<in> cptn \<Longrightarrow> c \<in> cptn_mod"
-apply(erule cptn.induct)
- apply(rule CptnModOne)
- apply(erule CptnModEnv)
-apply(case_tac P)
- apply simp
- apply(erule ctran.cases,simp_all)
-apply(force elim:cptn_onlyif_cptn_mod_aux)
-done
-
-lemma lift_is_cptn: "c\<in>cptn \<Longrightarrow> map (lift P) c \<in> cptn"
-apply(erule cptn.induct)
- apply(force simp add:lift_def CptnOne)
- apply(force intro:CptnEnv simp add:lift_def)
-apply(force simp add:lift_def intro:CptnComp Seq2 Seq1 elim:ctran.cases)
-done
-
-lemma cptn_append_is_cptn [rule_format]:
- "\<forall>b a. b#c1\<in>cptn \<longrightarrow> a#c2\<in>cptn \<longrightarrow> (b#c1)!length c1=a \<longrightarrow> b#c1@c2\<in>cptn"
-apply(induct c1)
- apply simp
-apply clarify
-apply(erule cptn.cases,simp_all)
- apply(force intro:CptnEnv)
-apply(force elim:CptnComp)
-done
-
-lemma last_lift: "\<lbrakk>xs\<noteq>[]; fst(xs!(length xs - (Suc 0)))=None\<rbrakk>
- \<Longrightarrow> fst((map (lift P) xs)!(length (map (lift P) xs)- (Suc 0)))=(Some P)"
-apply(case_tac "(xs ! (length xs - (Suc 0)))")
-apply (simp add:lift_def)
-done
-
-lemma last_fst [rule_format]: "P((a#x)!length x) \<longrightarrow> \<not>P a \<longrightarrow> P (x!(length x - (Suc 0)))"
-apply(induct x,simp+)
-done
-
-lemma last_fst_esp:
- "fst(((Some a,s)#xs)!(length xs))=None \<Longrightarrow> fst(xs!(length xs - (Suc 0)))=None"
-apply(erule last_fst)
-apply simp
-done
-
-lemma last_snd: "xs\<noteq>[] \<Longrightarrow>
- snd(((map (lift P) xs))!(length (map (lift P) xs) - (Suc 0)))=snd(xs!(length xs - (Suc 0)))"
-apply(case_tac "(xs ! (length xs - (Suc 0)))",simp)
-apply (simp add:lift_def)
-done
-
-lemma Cons_lift: "(Some (Seq P Q), s) # (map (lift Q) xs) = map (lift Q) ((Some P, s) # xs)"
-by(simp add:lift_def)
-
-lemma Cons_lift_append:
- "(Some (Seq P Q), s) # (map (lift Q) xs) @ ys = map (lift Q) ((Some P, s) # xs)@ ys "
-by(simp add:lift_def)
-
-lemma lift_nth: "i<length xs \<Longrightarrow> map (lift Q) xs ! i = lift Q (xs! i)"
-by (simp add:lift_def)
-
-lemma snd_lift: "i< length xs \<Longrightarrow> snd(lift Q (xs ! i))= snd (xs ! i)"
-apply(case_tac "xs!i")
-apply(simp add:lift_def)
-done
-
-lemma cptn_if_cptn_mod: "c \<in> cptn_mod \<Longrightarrow> c \<in> cptn"
-apply(erule cptn_mod.induct)
- apply(rule CptnOne)
- apply(erule CptnEnv)
- apply(erule CptnComp,simp)
- apply(rule CptnComp)
- apply(erule CondT,simp)
- apply(rule CptnComp)
- apply(erule CondF,simp)
---{* Seq1 *}
-apply(erule cptn.cases,simp_all)
- apply(rule CptnOne)
- apply clarify
- apply(drule_tac P=P1 in lift_is_cptn)
- apply(simp add:lift_def)
- apply(rule CptnEnv,simp)
-apply clarify
-apply(simp add:lift_def)
-apply(rule conjI)
- apply clarify
- apply(rule CptnComp)
- apply(rule Seq1,simp)
- apply(drule_tac P=P1 in lift_is_cptn)
- apply(simp add:lift_def)
-apply clarify
-apply(rule CptnComp)
- apply(rule Seq2,simp)
-apply(drule_tac P=P1 in lift_is_cptn)
-apply(simp add:lift_def)
---{* Seq2 *}
-apply(rule cptn_append_is_cptn)
- apply(drule_tac P=P1 in lift_is_cptn)
- apply(simp add:lift_def)
- apply simp
-apply(case_tac "xs\<noteq>[]")
- apply(drule_tac P=P1 in last_lift)
- apply(rule last_fst_esp)
- apply (simp add:last_length)
- apply(simp add:Cons_lift del:map.simps)
- apply(rule conjI, clarify, simp)
- apply(case_tac "(((Some P0, s) # xs) ! length xs)")
- apply clarify
- apply (simp add:lift_def last_length)
-apply (simp add:last_length)
---{* While1 *}
-apply(rule CptnComp)
-apply(rule WhileT,simp)
-apply(drule_tac P="While b P" in lift_is_cptn)
-apply(simp add:lift_def)
---{* While2 *}
-apply(rule CptnComp)
-apply(rule WhileT,simp)
-apply(rule cptn_append_is_cptn)
-apply(drule_tac P="While b P" in lift_is_cptn)
- apply(simp add:lift_def)
- apply simp
-apply(case_tac "xs\<noteq>[]")
- apply(drule_tac P="While b P" in last_lift)
- apply(rule last_fst_esp,simp add:last_length)
- apply(simp add:Cons_lift del:map.simps)
- apply(rule conjI, clarify, simp)
- apply(case_tac "(((Some P, s) # xs) ! length xs)")
- apply clarify
- apply (simp add:last_length lift_def)
-apply simp
-done
-
-theorem cptn_iff_cptn_mod: "(c \<in> cptn) = (c \<in> cptn_mod)"
-apply(rule iffI)
- apply(erule cptn_onlyif_cptn_mod)
-apply(erule cptn_if_cptn_mod)
-done
-
-section {* Validity of Correctness Formulas*}
-
-subsection {* Validity for Component Programs. *}
-
-types 'a rgformula = "'a com \<times> 'a set \<times> ('a \<times> 'a) set \<times> ('a \<times> 'a) set \<times> 'a set"
-
-constdefs
- assum :: "('a set \<times> ('a \<times> 'a) set) \<Rightarrow> ('a confs) set"
- "assum \<equiv> \<lambda>(pre, rely). {c. snd(c!0) \<in> pre \<and> (\<forall>i. Suc i<length c \<longrightarrow>
- c!i -e\<rightarrow> c!(Suc i) \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> rely)}"
-
- comm :: "(('a \<times> 'a) set \<times> 'a set) \<Rightarrow> ('a confs) set"
- "comm \<equiv> \<lambda>(guar, post). {c. (\<forall>i. Suc i<length c \<longrightarrow>
- c!i -c\<rightarrow> c!(Suc i) \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> guar) \<and>
- (fst (last c) = None \<longrightarrow> snd (last c) \<in> post)}"
-
- com_validity :: "'a com \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> bool"
- ("\<Turnstile> _ sat [_, _, _, _]" [60,0,0,0,0] 45)
- "\<Turnstile> P sat [pre, rely, guar, post] \<equiv>
- \<forall>s. cp (Some P) s \<inter> assum(pre, rely) \<subseteq> comm(guar, post)"
-
-subsection {* Validity for Parallel Programs. *}
-
-constdefs
- All_None :: "(('a com) option) list \<Rightarrow> bool"
- "All_None xs \<equiv> \<forall>c\<in>set xs. c=None"
-
- par_assum :: "('a set \<times> ('a \<times> 'a) set) \<Rightarrow> ('a par_confs) set"
- "par_assum \<equiv> \<lambda>(pre, rely). {c. snd(c!0) \<in> pre \<and> (\<forall>i. Suc i<length c \<longrightarrow>
- c!i -pe\<rightarrow> c!Suc i \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> rely)}"
-
- par_comm :: "(('a \<times> 'a) set \<times> 'a set) \<Rightarrow> ('a par_confs) set"
- "par_comm \<equiv> \<lambda>(guar, post). {c. (\<forall>i. Suc i<length c \<longrightarrow>
- c!i -pc\<rightarrow> c!Suc i \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> guar) \<and>
- (All_None (fst (last c)) \<longrightarrow> snd( last c) \<in> post)}"
-
- par_com_validity :: "'a par_com \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set
-\<Rightarrow> 'a set \<Rightarrow> bool" ("\<Turnstile> _ SAT [_, _, _, _]" [60,0,0,0,0] 45)
- "\<Turnstile> Ps SAT [pre, rely, guar, post] \<equiv>
- \<forall>s. par_cp Ps s \<inter> par_assum(pre, rely) \<subseteq> par_comm(guar, post)"
-
-subsection {* Compositionality of the Semantics *}
-
-subsubsection {* Definition of the conjoin operator *}
-
-constdefs
- same_length :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
- "same_length c clist \<equiv> (\<forall>i<length clist. length(clist!i)=length c)"
-
- same_state :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
- "same_state c clist \<equiv> (\<forall>i <length clist. \<forall>j<length c. snd(c!j) = snd((clist!i)!j))"
-
- same_program :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
- "same_program c clist \<equiv> (\<forall>j<length c. fst(c!j) = map (\<lambda>x. fst(nth x j)) clist)"
-
- compat_label :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
- "compat_label c clist \<equiv> (\<forall>j. Suc j<length c \<longrightarrow>
- (c!j -pc\<rightarrow> c!Suc j \<and> (\<exists>i<length clist. (clist!i)!j -c\<rightarrow> (clist!i)! Suc j \<and>
- (\<forall>l<length clist. l\<noteq>i \<longrightarrow> (clist!l)!j -e\<rightarrow> (clist!l)! Suc j))) \<or>
- (c!j -pe\<rightarrow> c!Suc j \<and> (\<forall>i<length clist. (clist!i)!j -e\<rightarrow> (clist!i)! Suc j)))"
-
- conjoin :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool" ("_ \<propto> _" [65,65] 64)
- "c \<propto> clist \<equiv> (same_length c clist) \<and> (same_state c clist) \<and> (same_program c clist) \<and> (compat_label c clist)"
-
-subsubsection {* Some previous lemmas *}
-
-lemma list_eq_if [rule_format]:
- "\<forall>ys. xs=ys \<longrightarrow> (length xs = length ys) \<longrightarrow> (\<forall>i<length xs. xs!i=ys!i)"
-apply (induct xs)
- apply simp
-apply clarify
-done
-
-lemma list_eq: "(length xs = length ys \<and> (\<forall>i<length xs. xs!i=ys!i)) = (xs=ys)"
-apply(rule iffI)
- apply clarify
- apply(erule nth_equalityI)
- apply simp+
-done
-
-lemma nth_tl: "\<lbrakk> ys!0=a; ys\<noteq>[] \<rbrakk> \<Longrightarrow> ys=(a#(tl ys))"
-apply(case_tac ys)
- apply simp+
-done
-
-lemma nth_tl_if [rule_format]: "ys\<noteq>[] \<longrightarrow> ys!0=a \<longrightarrow> P ys \<longrightarrow> P (a#(tl ys))"
-apply(induct ys)
- apply simp+
-done
-
-lemma nth_tl_onlyif [rule_format]: "ys\<noteq>[] \<longrightarrow> ys!0=a \<longrightarrow> P (a#(tl ys)) \<longrightarrow> P ys"
-apply(induct ys)
- apply simp+
-done
-
-lemma seq_not_eq1: "Seq c1 c2\<noteq>c1"
-apply(rule com.induct)
-apply simp_all
-apply clarify
-done
-
-lemma seq_not_eq2: "Seq c1 c2\<noteq>c2"
-apply(rule com.induct)
-apply simp_all
-apply clarify
-done
-
-lemma if_not_eq1: "Cond b c1 c2 \<noteq>c1"
-apply(rule com.induct)
-apply simp_all
-apply clarify
-done
-
-lemma if_not_eq2: "Cond b c1 c2\<noteq>c2"
-apply(rule com.induct)
-apply simp_all
-apply clarify
-done
-
-lemmas seq_and_if_not_eq [simp] = seq_not_eq1 seq_not_eq2
-seq_not_eq1 [THEN not_sym] seq_not_eq2 [THEN not_sym]
-if_not_eq1 if_not_eq2 if_not_eq1 [THEN not_sym] if_not_eq2 [THEN not_sym]
-
-lemma prog_not_eq_in_ctran_aux:
- assumes c: "(P,s) -c\<rightarrow> (Q,t)"
- shows "P\<noteq>Q" using c
- by (induct x1 \<equiv> "(P,s)" x2 \<equiv> "(Q,t)" arbitrary: P s Q t) auto
-
-lemma prog_not_eq_in_ctran [simp]: "\<not> (P,s) -c\<rightarrow> (P,t)"
-apply clarify
-apply(drule prog_not_eq_in_ctran_aux)
-apply simp
-done
-
-lemma prog_not_eq_in_par_ctran_aux [rule_format]: "(P,s) -pc\<rightarrow> (Q,t) \<Longrightarrow> (P\<noteq>Q)"
-apply(erule par_ctran.induct)
-apply(drule prog_not_eq_in_ctran_aux)
-apply clarify
-apply(drule list_eq_if)
- apply simp_all
-apply force
-done
-
-lemma prog_not_eq_in_par_ctran [simp]: "\<not> (P,s) -pc\<rightarrow> (P,t)"
-apply clarify
-apply(drule prog_not_eq_in_par_ctran_aux)
-apply simp
-done
-
-lemma tl_in_cptn: "\<lbrakk> a#xs \<in>cptn; xs\<noteq>[] \<rbrakk> \<Longrightarrow> xs\<in>cptn"
-apply(force elim:cptn.cases)
-done
-
-lemma tl_zero[rule_format]:
- "P (ys!Suc j) \<longrightarrow> Suc j<length ys \<longrightarrow> ys\<noteq>[] \<longrightarrow> P (tl(ys)!j)"
-apply(induct ys)
- apply simp_all
-done
-
-subsection {* The Semantics is Compositional *}
-
-lemma aux_if [rule_format]:
- "\<forall>xs s clist. (length clist = length xs \<and> (\<forall>i<length xs. (xs!i,s)#clist!i \<in> cptn)
- \<and> ((xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#snd i) (zip xs clist))
- \<longrightarrow> (xs, s)#ys \<in> par_cptn)"
-apply(induct ys)
- apply(clarify)
- apply(rule ParCptnOne)
-apply(clarify)
-apply(simp add:conjoin_def compat_label_def)
-apply clarify
-apply(erule_tac x="0" and P="\<lambda>j. ?H j \<longrightarrow> (?P j \<or> ?Q j)" in all_dupE,simp)
-apply(erule disjE)
---{* first step is a Component step *}
- apply clarify
- apply simp
- apply(subgoal_tac "a=(xs[i:=(fst(clist!i!0))])")
- apply(subgoal_tac "b=snd(clist!i!0)",simp)
- prefer 2
- apply(simp add: same_state_def)
- apply(erule_tac x=i in allE,erule impE,assumption,
- erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- prefer 2
- apply(simp add:same_program_def)
- apply(erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=(?t j)" in allE,simp)
- apply(rule nth_equalityI,simp)
- apply clarify
- apply(case_tac "i=ia",simp,simp)
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
- apply(drule_tac t=i in not_sym,simp)
- apply(erule etranE,simp)
- apply(rule ParCptnComp)
- apply(erule ParComp,simp)
---{* applying the induction hypothesis *}
- apply(erule_tac x="xs[i := fst (clist ! i ! 0)]" in allE)
- apply(erule_tac x="snd (clist ! i ! 0)" in allE)
- apply(erule mp)
- apply(rule_tac x="map tl clist" in exI,simp)
- apply(rule conjI,clarify)
- apply(case_tac "i=ia",simp)
- apply(rule nth_tl_if)
- apply(force simp add:same_length_def length_Suc_conv)
- apply simp
- apply(erule allE,erule impE,assumption,erule tl_in_cptn)
- apply(force simp add:same_length_def length_Suc_conv)
- apply(rule nth_tl_if)
- apply(force simp add:same_length_def length_Suc_conv)
- apply(simp add:same_state_def)
- apply(erule_tac x=ia in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
- apply(drule_tac t=i in not_sym,simp)
- apply(erule etranE,simp)
- apply(erule allE,erule impE,assumption,erule tl_in_cptn)
- apply(force simp add:same_length_def length_Suc_conv)
- apply(simp add:same_length_def same_state_def)
- apply(rule conjI)
- apply clarify
- apply(case_tac j,simp,simp)
- apply(erule_tac x=ia in allE, erule impE, assumption,
- erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(force simp add:same_length_def length_Suc_conv)
- apply(rule conjI)
- apply(simp add:same_program_def)
- apply clarify
- apply(case_tac j,simp)
- apply(rule nth_equalityI,simp)
- apply clarify
- apply(case_tac "i=ia",simp,simp)
- apply(erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=(?t j)" in allE,simp)
- apply(rule nth_equalityI,simp,simp)
- apply(force simp add:length_Suc_conv)
- apply(rule allI,rule impI)
- apply(erule_tac x="Suc j" and P="\<lambda>j. ?H j \<longrightarrow> (?I j \<or> ?J j)" in allE,simp)
- apply(erule disjE)
- apply clarify
- apply(rule_tac x=ia in exI,simp)
- apply(case_tac "i=ia",simp)
- apply(rule conjI)
- apply(force simp add: length_Suc_conv)
- apply clarify
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE,assumption)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE,assumption)
- apply simp
- apply(case_tac j,simp)
- apply(rule tl_zero)
- apply(erule_tac x=l in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(force elim:etranE intro:Env)
- apply force
- apply force
- apply simp
- apply(rule tl_zero)
- apply(erule tl_zero)
- apply force
- apply force
- apply force
- apply force
- apply(rule conjI,simp)
- apply(rule nth_tl_if)
- apply force
- apply(erule_tac x=ia in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
- apply(drule_tac t=i in not_sym,simp)
- apply(erule etranE,simp)
- apply(erule tl_zero)
- apply force
- apply force
- apply clarify
- apply(case_tac "i=l",simp)
- apply(rule nth_tl_if)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply simp
- apply(erule_tac P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE,assumption,erule impE,assumption)
- apply(erule tl_zero,force)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply(rule nth_tl_if)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply(erule_tac x=l in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE, assumption,simp)
- apply(erule etranE,simp)
- apply(rule tl_zero)
- apply force
- apply force
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply(rule disjI2)
- apply(case_tac j,simp)
- apply clarify
- apply(rule tl_zero)
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j\<in>etran" in allE,erule impE, assumption)
- apply(case_tac "i=ia",simp,simp)
- apply(erule_tac x=ia in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE, assumption,simp)
- apply(force elim:etranE intro:Env)
- apply force
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply simp
- apply clarify
- apply(rule tl_zero)
- apply(rule tl_zero,force)
- apply force
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply force
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
---{* first step is an environmental step *}
-apply clarify
-apply(erule par_etran.cases)
-apply simp
-apply(rule ParCptnEnv)
-apply(erule_tac x="Ps" in allE)
-apply(erule_tac x="t" in allE)
-apply(erule mp)
-apply(rule_tac x="map tl clist" in exI,simp)
-apply(rule conjI)
- apply clarify
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (?I ?s j) \<in> cptn" in allE,simp)
- apply(erule cptn.cases)
- apply(simp add:same_length_def)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply(simp add:same_state_def)
- apply(erule_tac x=i in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> ?J j \<in>etran" in allE,simp)
- apply(erule etranE,simp)
-apply(simp add:same_state_def same_length_def)
-apply(rule conjI,clarify)
- apply(case_tac j,simp,simp)
- apply(erule_tac x=i in allE, erule impE, assumption,
- erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(rule tl_zero)
- apply(simp)
- apply force
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
-apply(rule conjI)
- apply(simp add:same_program_def)
- apply clarify
- apply(case_tac j,simp)
- apply(rule nth_equalityI,simp)
- apply clarify
- apply simp
- apply(erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=(?t j)" in allE,simp)
- apply(rule nth_equalityI,simp,simp)
- apply(force simp add:length_Suc_conv)
-apply(rule allI,rule impI)
-apply(erule_tac x="Suc j" and P="\<lambda>j. ?H j \<longrightarrow> (?I j \<or> ?J j)" in allE,simp)
-apply(erule disjE)
- apply clarify
- apply(rule_tac x=i in exI,simp)
- apply(rule conjI)
- apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
- apply(erule etranE,simp)
- apply(erule_tac x=i in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(rule nth_tl_if)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply simp
- apply(erule tl_zero,force)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply clarify
- apply(erule_tac x=l and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
- apply(erule etranE,simp)
- apply(erule_tac x=l in allE, erule impE, assumption,
- erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(rule nth_tl_if)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply simp
- apply(rule tl_zero,force)
- apply force
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
-apply(rule disjI2)
-apply simp
-apply clarify
-apply(case_tac j,simp)
- apply(rule tl_zero)
- apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
- apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
- apply(force elim:etranE intro:Env)
- apply force
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
-apply simp
-apply(rule tl_zero)
- apply(rule tl_zero,force)
- apply force
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply force
-apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
-done
-
-lemma less_Suc_0 [iff]: "(n < Suc 0) = (n = 0)"
-by auto
-
-lemma aux_onlyif [rule_format]: "\<forall>xs s. (xs, s)#ys \<in> par_cptn \<longrightarrow>
- (\<exists>clist. (length clist = length xs) \<and>
- (xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#(snd i)) (zip xs clist) \<and>
- (\<forall>i<length xs. (xs!i,s)#(clist!i) \<in> cptn))"
-apply(induct ys)
- apply(clarify)
- apply(rule_tac x="map (\<lambda>i. []) [0..<length xs]" in exI)
- apply(simp add: conjoin_def same_length_def same_state_def same_program_def compat_label_def)
- apply(rule conjI)
- apply(rule nth_equalityI,simp,simp)
- apply(force intro: cptn.intros)
-apply(clarify)
-apply(erule par_cptn.cases,simp)
- apply simp
- apply(erule_tac x="xs" in allE)
- apply(erule_tac x="t" in allE,simp)
- apply clarify
- apply(rule_tac x="(map (\<lambda>j. (P!j, t)#(clist!j)) [0..<length P])" in exI,simp)
- apply(rule conjI)
- prefer 2
- apply clarify
- apply(rule CptnEnv,simp)
- apply(simp add:conjoin_def same_length_def same_state_def)
- apply (rule conjI)
- apply clarify
- apply(case_tac j,simp,simp)
- apply(rule conjI)
- apply(simp add:same_program_def)
- apply clarify
- apply(case_tac j,simp)
- apply(rule nth_equalityI,simp,simp)
- apply simp
- apply(rule nth_equalityI,simp,simp)
- apply(simp add:compat_label_def)
- apply clarify
- apply(case_tac j,simp)
- apply(simp add:ParEnv)
- apply clarify
- apply(simp add:Env)
- apply simp
- apply(erule_tac x=nat in allE,erule impE, assumption)
- apply(erule disjE,simp)
- apply clarify
- apply(rule_tac x=i in exI,simp)
- apply force
-apply(erule par_ctran.cases,simp)
-apply(erule_tac x="Ps[i:=r]" in allE)
-apply(erule_tac x="ta" in allE,simp)
-apply clarify
-apply(rule_tac x="(map (\<lambda>j. (Ps!j, ta)#(clist!j)) [0..<length Ps]) [i:=((r, ta)#(clist!i))]" in exI,simp)
-apply(rule conjI)
- prefer 2
- apply clarify
- apply(case_tac "i=ia",simp)
- apply(erule CptnComp)
- apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (?I j \<in> cptn)" in allE,simp)
- apply simp
- apply(erule_tac x=ia in allE)
- apply(rule CptnEnv,simp)
-apply(simp add:conjoin_def)
-apply (rule conjI)
- apply(simp add:same_length_def)
- apply clarify
- apply(case_tac "i=ia",simp,simp)
-apply(rule conjI)
- apply(simp add:same_state_def)
- apply clarify
- apply(case_tac j, simp, simp (no_asm_simp))
- apply(case_tac "i=ia",simp,simp)
-apply(rule conjI)
- apply(simp add:same_program_def)
- apply clarify
- apply(case_tac j,simp)
- apply(rule nth_equalityI,simp,simp)
- apply simp
- apply(rule nth_equalityI,simp,simp)
- apply(erule_tac x=nat and P="\<lambda>j. ?H j \<longrightarrow> (fst (?a j))=((?b j))" in allE)
- apply(case_tac nat)
- apply clarify
- apply(case_tac "i=ia",simp,simp)
- apply clarify
- apply(case_tac "i=ia",simp,simp)
-apply(simp add:compat_label_def)
-apply clarify
-apply(case_tac j)
- apply(rule conjI,simp)
- apply(erule ParComp,assumption)
- apply clarify
- apply(rule_tac x=i in exI,simp)
- apply clarify
- apply(rule Env)
-apply simp
-apply(erule_tac x=nat and P="\<lambda>j. ?H j \<longrightarrow> (?P j \<or> ?Q j)" in allE,simp)
-apply(erule disjE)
- apply clarify
- apply(rule_tac x=ia in exI,simp)
- apply(rule conjI)
- apply(case_tac "i=ia",simp,simp)
- apply clarify
- apply(case_tac "i=l",simp)
- apply(case_tac "l=ia",simp,simp)
- apply(erule_tac x=l in allE,erule impE,assumption,erule impE, assumption,simp)
- apply simp
- apply(erule_tac x=l in allE,erule impE,assumption,erule impE, assumption,simp)
-apply clarify
-apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (?P j)\<in>etran" in allE, erule impE, assumption)
-apply(case_tac "i=ia",simp,simp)
-done
-
-lemma one_iff_aux: "xs\<noteq>[] \<Longrightarrow> (\<forall>ys. ((xs, s)#ys \<in> par_cptn) =
- (\<exists>clist. length clist= length xs \<and>
- ((xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#(snd i)) (zip xs clist)) \<and>
- (\<forall>i<length xs. (xs!i,s)#(clist!i) \<in> cptn))) =
- (par_cp (xs) s = {c. \<exists>clist. (length clist)=(length xs) \<and>
- (\<forall>i<length clist. (clist!i) \<in> cp(xs!i) s) \<and> c \<propto> clist})"
-apply (rule iffI)
- apply(rule subset_antisym)
- apply(rule subsetI)
- apply(clarify)
- apply(simp add:par_cp_def cp_def)
- apply(case_tac x)
- apply(force elim:par_cptn.cases)
- apply simp
- apply(erule_tac x="list" in allE)
- apply clarify
- apply simp
- apply(rule_tac x="map (\<lambda>i. (fst i, s) # snd i) (zip xs clist)" in exI,simp)
- apply(rule subsetI)
- apply(clarify)
- apply(case_tac x)
- apply(erule_tac x=0 in allE)
- apply(simp add:cp_def conjoin_def same_length_def same_program_def same_state_def compat_label_def)
- apply clarify
- apply(erule cptn.cases,force,force,force)
- apply(simp add:par_cp_def conjoin_def same_length_def same_program_def same_state_def compat_label_def)
- apply clarify
- apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in all_dupE)
- apply(subgoal_tac "a = xs")
- apply(subgoal_tac "b = s",simp)
- prefer 3
- apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=((?t j))" in allE)
- apply (simp add:cp_def)
- apply(rule nth_equalityI,simp,simp)
- prefer 2
- apply(erule_tac x=0 in allE)
- apply (simp add:cp_def)
- apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (\<forall>i. ?T i \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
- apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(erule_tac x=list in allE)
- apply(rule_tac x="map tl clist" in exI,simp)
- apply(rule conjI)
- apply clarify
- apply(case_tac j,simp)
- apply(erule_tac x=i in allE, erule impE, assumption,
- erule_tac x="0" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
- apply(erule_tac x=i in allE, erule impE, assumption,
- erule_tac x="Suc nat" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply(rule conjI)
- apply clarify
- apply(rule nth_equalityI,simp,simp)
- apply(case_tac j)
- apply clarify
- apply(erule_tac x=i in allE)
- apply(simp add:cp_def)
- apply clarify
- apply simp
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply(thin_tac "?H = (\<exists>i. ?J i)")
- apply(rule conjI)
- apply clarify
- apply(erule_tac x=j in allE,erule impE, assumption,erule disjE)
- apply clarify
- apply(rule_tac x=i in exI,simp)
- apply(case_tac j,simp)
- apply(rule conjI)
- apply(erule_tac x=i in allE)
- apply(simp add:cp_def)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply clarify
- apply(erule_tac x=l in allE)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
- apply clarify
- apply(simp add:cp_def)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!l",simp,simp)
- apply simp
- apply(rule conjI)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply clarify
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!l",simp,simp)
- apply clarify
- apply(erule_tac x=i in allE)
- apply(simp add:cp_def)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp)
- apply(rule nth_tl_if,simp,simp)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (?P j)\<in>etran" in allE, erule impE, assumption,simp)
- apply(simp add:cp_def)
- apply clarify
- apply(rule nth_tl_if)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply force
- apply force
-apply clarify
-apply(rule iffI)
- apply(simp add:par_cp_def)
- apply(erule_tac c="(xs, s) # ys" in equalityCE)
- apply simp
- apply clarify
- apply(rule_tac x="map tl clist" in exI)
- apply simp
- apply (rule conjI)
- apply(simp add:conjoin_def cp_def)
- apply(rule conjI)
- apply clarify
- apply(unfold same_length_def)
- apply clarify
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,simp)
- apply(rule conjI)
- apply(simp add:same_state_def)
- apply clarify
- apply(erule_tac x=i in allE, erule impE, assumption,
- erule_tac x=j and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
- apply(case_tac j,simp)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply(rule conjI)
- apply(simp add:same_program_def)
- apply clarify
- apply(rule nth_equalityI,simp,simp)
- apply(case_tac j,simp)
- apply clarify
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply clarify
- apply(simp add:compat_label_def)
- apply(rule allI,rule impI)
- apply(erule_tac x=j in allE,erule impE, assumption)
- apply(erule disjE)
- apply clarify
- apply(rule_tac x=i in exI,simp)
- apply(rule conjI)
- apply(erule_tac x=i in allE)
- apply(case_tac j,simp)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!i",simp,simp)
- apply clarify
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
- apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
- apply(case_tac "clist!l",simp,simp)
- apply(erule_tac x=l in allE,simp)
- apply(rule disjI2)
- apply clarify
- apply(rule tl_zero)
- apply(case_tac j,simp,simp)
- apply(rule tl_zero,force)
- apply force
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply force
- apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
- apply clarify
- apply(erule_tac x=i in allE)
- apply(simp add:cp_def)
- apply(rule nth_tl_if)
- apply(simp add:conjoin_def)
- apply clarify
- apply(simp add:same_length_def)
- apply(erule_tac x=i in allE,simp)
- apply simp
- apply simp
- apply simp
-apply clarify
-apply(erule_tac c="(xs, s) # ys" in equalityCE)
- apply(simp add:par_cp_def)
-apply simp
-apply(erule_tac x="map (\<lambda>i. (fst i, s) # snd i) (zip xs clist)" in allE)
-apply simp
-apply clarify
-apply(simp add:cp_def)
-done
-
-theorem one: "xs\<noteq>[] \<Longrightarrow>
- par_cp xs s = {c. \<exists>clist. (length clist)=(length xs) \<and>
- (\<forall>i<length clist. (clist!i) \<in> cp(xs!i) s) \<and> c \<propto> clist}"
-apply(frule one_iff_aux)
-apply(drule sym)
-apply(erule iffD2)
-apply clarify
-apply(rule iffI)
- apply(erule aux_onlyif)
-apply clarify
-apply(force intro:aux_if)
-done
-
-end
--- a/src/HOL/HoareParallel/ROOT.ML Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,3 +0,0 @@
-(* $Id$ *)
-
-use_thys ["OG_Examples", "Gar_Coll", "Mul_Gar_Coll", "RG_Examples"];
--- a/src/HOL/HoareParallel/document/root.bib Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,28 +0,0 @@
-@inproceedings{NipkowP-FASE99,author={Tobias Nipkow and Prensa Nieto, Leonor},
-title={{Owicki/Gries} in {Isabelle/HOL}},
-booktitle={Fundamental Approaches to Software Engineering (FASE'99)},
-editor={J.-P. Finance},publisher="Springer",series="LNCS",volume=1577,
-pages={188--203},year=1999}
-
-@InProceedings{PrenEsp00,
- author = {Prensa Nieto, Leonor and Javier Esparza},
- title = {Verifying Single and Multi-mutator Garbage Collectors
- with {Owicki/Gries} in {Isabelle/HOL}},
- booktitle = {Mathematical Foundations of Computer Science (MFCS 2000)},
- editor = {M. Nielsen and B. Rovan},
- publisher = {Springer-Verlag},
- series = {LNCS},
- volume = 1893,
- pages = {619--628},
- year = 2000
-}
-
-@PhdThesis{Prensa-PhD,author={Leonor Prensa Nieto},
-title={Verification of Parallel Programs with the Owicki-Gries and
-Rely-Guarantee Methods in Isabelle/HOL},
-school={Technische Universit{\"a}t M{\"u}nchen},year=2002}
-
-@inproceedings{Prensa-ESOP03,author={Prensa Nieto, Leonor},
-title={The {Rely-Guarantee} Method in {Isabelle/HOL}},
-booktitle={European Symposium on Programming (ESOP'03)},editor={P. Degano},
-publisher=Springer,series=LNCS,volume=2618,pages={348--362},year=2003}
--- a/src/HOL/HoareParallel/document/root.tex Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,62 +0,0 @@
-
-% $Id$
-
-\documentclass[11pt,a4paper]{report}
-\usepackage{graphicx}
-\usepackage[english]{babel}
-\usepackage{isabelle,isabellesym}
-\usepackage{pdfsetup}
-
-\urlstyle{rm}
-\isabellestyle{it}
-
-\renewcommand{\isamarkupheader}[1]{#1}
-
-\begin{document}
-
-\title{Hoare Logic for Parallel Programs}
-\author{Leonor Prensa Nieto}
-\maketitle
-
-\begin{abstract}\noindent
- In the following theories a formalization of the Owicki-Gries and
- the rely-guarantee methods is presented. These methods are widely
- used for correctness proofs of parallel imperative programs with
- shared variables. We define syntax, semantics and proof rules in
- Isabelle/HOL. The proof rules also provide for programs
- parameterized in the number of parallel components. Their
- correctness w.r.t.\ the semantics is proven. Completeness proofs
- for both methods are extended to the new case of parameterized
- programs. (These proofs have not been formalized in Isabelle. They
- can be found in~\cite{Prensa-PhD}.) Using this formalizations we
- verify several non-trivial examples for parameterized and
- non-parameterized programs. For the automatic generation of
- verification conditions with the Owicki-Gries method we define a
- tactic based on the proof rules. The most involved examples are the
- verification of two garbage-collection algorithms, the second one
- parameterized in the number of mutators.
-
-For excellent descriptions of this work see
-\cite{NipkowP-FASE99,PrenEsp00,Prensa-PhD,Prensa-ESOP03}.
-
-\end{abstract}
-
-\pagestyle{plain}
-\thispagestyle{empty}
-\tableofcontents
-
-\clearpage
-
-\begin{center}
- \includegraphics[scale=0.7]{session_graph}
-\end{center}
-
-\newpage
-
-\parindent 0pt\parskip 0.5ex
-\input{session}
-
-\bibliographystyle{plain}
-\bibliography{root}
-
-\end{document}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/Gar_Coll.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,846 @@
+
+header {* \section{The Single Mutator Case} *}
+
+theory Gar_Coll imports Graph OG_Syntax begin
+
+declare psubsetE [rule del]
+
+text {* Declaration of variables: *}
+
+record gar_coll_state =
+ M :: nodes
+ E :: edges
+ bc :: "nat set"
+ obc :: "nat set"
+ Ma :: nodes
+ ind :: nat
+ k :: nat
+ z :: bool
+
+subsection {* The Mutator *}
+
+text {* The mutator first redirects an arbitrary edge @{text "R"} from
+an arbitrary accessible node towards an arbitrary accessible node
+@{text "T"}. It then colors the new target @{text "T"} black.
+
+We declare the arbitrarily selected node and edge as constants:*}
+
+consts R :: nat T :: nat
+
+text {* \noindent The following predicate states, given a list of
+nodes @{text "m"} and a list of edges @{text "e"}, the conditions
+under which the selected edge @{text "R"} and node @{text "T"} are
+valid: *}
+
+constdefs
+ Mut_init :: "gar_coll_state \<Rightarrow> bool"
+ "Mut_init \<equiv> \<guillemotleft> T \<in> Reach \<acute>E \<and> R < length \<acute>E \<and> T < length \<acute>M \<guillemotright>"
+
+text {* \noindent For the mutator we
+consider two modules, one for each action. An auxiliary variable
+@{text "\<acute>z"} is set to false if the mutator has already redirected an
+edge but has not yet colored the new target. *}
+
+constdefs
+ Redirect_Edge :: "gar_coll_state ann_com"
+ "Redirect_Edge \<equiv> .{\<acute>Mut_init \<and> \<acute>z}. \<langle>\<acute>E:=\<acute>E[R:=(fst(\<acute>E!R), T)],, \<acute>z:= (\<not>\<acute>z)\<rangle>"
+
+ Color_Target :: "gar_coll_state ann_com"
+ "Color_Target \<equiv> .{\<acute>Mut_init \<and> \<not>\<acute>z}. \<langle>\<acute>M:=\<acute>M[T:=Black],, \<acute>z:= (\<not>\<acute>z)\<rangle>"
+
+ Mutator :: "gar_coll_state ann_com"
+ "Mutator \<equiv>
+ .{\<acute>Mut_init \<and> \<acute>z}.
+ WHILE True INV .{\<acute>Mut_init \<and> \<acute>z}.
+ DO Redirect_Edge ;; Color_Target OD"
+
+subsubsection {* Correctness of the mutator *}
+
+lemmas mutator_defs = Mut_init_def Redirect_Edge_def Color_Target_def
+
+lemma Redirect_Edge:
+ "\<turnstile> Redirect_Edge pre(Color_Target)"
+apply (unfold mutator_defs)
+apply annhoare
+apply(simp_all)
+apply(force elim:Graph2)
+done
+
+lemma Color_Target:
+ "\<turnstile> Color_Target .{\<acute>Mut_init \<and> \<acute>z}."
+apply (unfold mutator_defs)
+apply annhoare
+apply(simp_all)
+done
+
+lemma Mutator:
+ "\<turnstile> Mutator .{False}."
+apply(unfold Mutator_def)
+apply annhoare
+apply(simp_all add:Redirect_Edge Color_Target)
+apply(simp add:mutator_defs Redirect_Edge_def)
+done
+
+subsection {* The Collector *}
+
+text {* \noindent A constant @{text "M_init"} is used to give @{text "\<acute>Ma"} a
+suitable first value, defined as a list of nodes where only the @{text
+"Roots"} are black. *}
+
+consts M_init :: nodes
+
+constdefs
+ Proper_M_init :: "gar_coll_state \<Rightarrow> bool"
+ "Proper_M_init \<equiv> \<guillemotleft> Blacks M_init=Roots \<and> length M_init=length \<acute>M \<guillemotright>"
+
+ Proper :: "gar_coll_state \<Rightarrow> bool"
+ "Proper \<equiv> \<guillemotleft> Proper_Roots \<acute>M \<and> Proper_Edges(\<acute>M, \<acute>E) \<and> \<acute>Proper_M_init \<guillemotright>"
+
+ Safe :: "gar_coll_state \<Rightarrow> bool"
+ "Safe \<equiv> \<guillemotleft> Reach \<acute>E \<subseteq> Blacks \<acute>M \<guillemotright>"
+
+lemmas collector_defs = Proper_M_init_def Proper_def Safe_def
+
+subsubsection {* Blackening the roots *}
+
+constdefs
+ Blacken_Roots :: " gar_coll_state ann_com"
+ "Blacken_Roots \<equiv>
+ .{\<acute>Proper}.
+ \<acute>ind:=0;;
+ .{\<acute>Proper \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>M
+ INV .{\<acute>Proper \<and> (\<forall>i<\<acute>ind. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind\<le>length \<acute>M}.
+ DO .{\<acute>Proper \<and> (\<forall>i<\<acute>ind. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
+ IF \<acute>ind\<in>Roots THEN
+ .{\<acute>Proper \<and> (\<forall>i<\<acute>ind. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<in>Roots}.
+ \<acute>M:=\<acute>M[\<acute>ind:=Black] FI;;
+ .{\<acute>Proper \<and> (\<forall>i<\<acute>ind+1. i \<in> Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
+ \<acute>ind:=\<acute>ind+1
+ OD"
+
+lemma Blacken_Roots:
+ "\<turnstile> Blacken_Roots .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M}."
+apply (unfold Blacken_Roots_def)
+apply annhoare
+apply(simp_all add:collector_defs Graph_defs)
+apply safe
+apply(simp_all add:nth_list_update)
+ apply (erule less_SucE)
+ apply simp+
+ apply force
+apply force
+done
+
+subsubsection {* Propagating black *}
+
+constdefs
+ PBInv :: "gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
+ "PBInv \<equiv> \<guillemotleft> \<lambda>ind. \<acute>obc < Blacks \<acute>M \<or> (\<forall>i <ind. \<not>BtoW (\<acute>E!i, \<acute>M) \<or>
+ (\<not>\<acute>z \<and> i=R \<and> (snd(\<acute>E!R)) = T \<and> (\<exists>r. ind \<le> r \<and> r < length \<acute>E \<and> BtoW(\<acute>E!r,\<acute>M))))\<guillemotright>"
+
+constdefs
+ Propagate_Black_aux :: "gar_coll_state ann_com"
+ "Propagate_Black_aux \<equiv>
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M}.
+ \<acute>ind:=0;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>E
+ INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>E}.
+ DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E}.
+ IF \<acute>M!(fst (\<acute>E!\<acute>ind)) = Black THEN
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E \<and> \<acute>M!fst(\<acute>E!\<acute>ind)=Black}.
+ \<acute>M:=\<acute>M[snd(\<acute>E!\<acute>ind):=Black];;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv (\<acute>ind + 1) \<and> \<acute>ind<length \<acute>E}.
+ \<acute>ind:=\<acute>ind+1
+ FI
+ OD"
+
+lemma Propagate_Black_aux:
+ "\<turnstile> Propagate_Black_aux
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> ( \<acute>obc < Blacks \<acute>M \<or> \<acute>Safe)}."
+apply (unfold Propagate_Black_aux_def PBInv_def collector_defs)
+apply annhoare
+apply(simp_all add:Graph6 Graph7 Graph8 Graph12)
+ apply force
+ apply force
+ apply force
+--{* 4 subgoals left *}
+apply clarify
+apply(simp add:Proper_Edges_def Proper_Roots_def Graph6 Graph7 Graph8 Graph12)
+apply (erule disjE)
+ apply(rule disjI1)
+ apply(erule Graph13)
+ apply force
+apply (case_tac "M x ! snd (E x ! ind x)=Black")
+ apply (simp add: Graph10 BtoW_def)
+ apply (rule disjI2)
+ apply clarify
+ apply (erule less_SucE)
+ apply (erule_tac x=i in allE , erule (1) notE impE)
+ apply simp
+ apply clarify
+ apply (drule_tac y = r in le_imp_less_or_eq)
+ apply (erule disjE)
+ apply (subgoal_tac "Suc (ind x)\<le>r")
+ apply fast
+ apply arith
+ apply fast
+ apply fast
+apply(rule disjI1)
+apply(erule subset_psubset_trans)
+apply(erule Graph11)
+apply fast
+--{* 3 subgoals left *}
+apply force
+apply force
+--{* last *}
+apply clarify
+apply simp
+apply(subgoal_tac "ind x = length (E x)")
+ apply (rotate_tac -1)
+ apply (simp (asm_lr))
+ apply(drule Graph1)
+ apply simp
+ apply clarify
+ apply(erule allE, erule impE, assumption)
+ apply force
+ apply force
+apply arith
+done
+
+subsubsection {* Refining propagating black *}
+
+constdefs
+ Auxk :: "gar_coll_state \<Rightarrow> bool"
+ "Auxk \<equiv> \<guillemotleft>\<acute>k<length \<acute>M \<and> (\<acute>M!\<acute>k\<noteq>Black \<or> \<not>BtoW(\<acute>E!\<acute>ind, \<acute>M) \<or>
+ \<acute>obc<Blacks \<acute>M \<or> (\<not>\<acute>z \<and> \<acute>ind=R \<and> snd(\<acute>E!R)=T
+ \<and> (\<exists>r. \<acute>ind<r \<and> r<length \<acute>E \<and> BtoW(\<acute>E!r, \<acute>M))))\<guillemotright>"
+
+constdefs
+ Propagate_Black :: " gar_coll_state ann_com"
+ "Propagate_Black \<equiv>
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M}.
+ \<acute>ind:=0;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>E
+ INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>E}.
+ DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E}.
+ IF (\<acute>M!(fst (\<acute>E!\<acute>ind)))=Black THEN
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E \<and> (\<acute>M!fst(\<acute>E!\<acute>ind))=Black}.
+ \<acute>k:=(snd(\<acute>E!\<acute>ind));;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E \<and> (\<acute>M!fst(\<acute>E!\<acute>ind))=Black
+ \<and> \<acute>Auxk}.
+ \<langle>\<acute>M:=\<acute>M[\<acute>k:=Black],, \<acute>ind:=\<acute>ind+1\<rangle>
+ ELSE .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>PBInv \<acute>ind \<and> \<acute>ind<length \<acute>E}.
+ \<langle>IF (\<acute>M!(fst (\<acute>E!\<acute>ind)))\<noteq>Black THEN \<acute>ind:=\<acute>ind+1 FI\<rangle>
+ FI
+ OD"
+
+lemma Propagate_Black:
+ "\<turnstile> Propagate_Black
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> ( \<acute>obc < Blacks \<acute>M \<or> \<acute>Safe)}."
+apply (unfold Propagate_Black_def PBInv_def Auxk_def collector_defs)
+apply annhoare
+apply(simp_all add:Graph6 Graph7 Graph8 Graph12)
+ apply force
+ apply force
+ apply force
+--{* 5 subgoals left *}
+apply clarify
+apply(simp add:BtoW_def Proper_Edges_def)
+--{* 4 subgoals left *}
+apply clarify
+apply(simp add:Proper_Edges_def Graph6 Graph7 Graph8 Graph12)
+apply (erule disjE)
+ apply (rule disjI1)
+ apply (erule psubset_subset_trans)
+ apply (erule Graph9)
+apply (case_tac "M x!k x=Black")
+ apply (case_tac "M x ! snd (E x ! ind x)=Black")
+ apply (simp add: Graph10 BtoW_def)
+ apply (rule disjI2)
+ apply clarify
+ apply (erule less_SucE)
+ apply (erule_tac x=i in allE , erule (1) notE impE)
+ apply simp
+ apply clarify
+ apply (drule_tac y = r in le_imp_less_or_eq)
+ apply (erule disjE)
+ apply (subgoal_tac "Suc (ind x)\<le>r")
+ apply fast
+ apply arith
+ apply fast
+ apply fast
+ apply (simp add: Graph10 BtoW_def)
+ apply (erule disjE)
+ apply (erule disjI1)
+ apply clarify
+ apply (erule less_SucE)
+ apply force
+ apply simp
+ apply (subgoal_tac "Suc R\<le>r")
+ apply fast
+ apply arith
+apply(rule disjI1)
+apply(erule subset_psubset_trans)
+apply(erule Graph11)
+apply fast
+--{* 3 subgoals left *}
+apply force
+--{* 2 subgoals left *}
+apply clarify
+apply(simp add:Proper_Edges_def Graph6 Graph7 Graph8 Graph12)
+apply (erule disjE)
+ apply fast
+apply clarify
+apply (erule less_SucE)
+ apply (erule_tac x=i in allE , erule (1) notE impE)
+ apply simp
+ apply clarify
+ apply (drule_tac y = r in le_imp_less_or_eq)
+ apply (erule disjE)
+ apply (subgoal_tac "Suc (ind x)\<le>r")
+ apply fast
+ apply arith
+ apply (simp add: BtoW_def)
+apply (simp add: BtoW_def)
+--{* last *}
+apply clarify
+apply simp
+apply(subgoal_tac "ind x = length (E x)")
+ apply (rotate_tac -1)
+ apply (simp (asm_lr))
+ apply(drule Graph1)
+ apply simp
+ apply clarify
+ apply(erule allE, erule impE, assumption)
+ apply force
+ apply force
+apply arith
+done
+
+subsubsection {* Counting black nodes *}
+
+constdefs
+ CountInv :: "gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
+ "CountInv \<equiv> \<guillemotleft> \<lambda>ind. {i. i<ind \<and> \<acute>Ma!i=Black}\<subseteq>\<acute>bc \<guillemotright>"
+
+constdefs
+ Count :: " gar_coll_state ann_com"
+ "Count \<equiv>
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>bc={}}.
+ \<acute>ind:=0;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>bc={}
+ \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>M
+ INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv \<acute>ind
+ \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind\<le>length \<acute>M}.
+ DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv \<acute>ind
+ \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind<length \<acute>M}.
+ IF \<acute>M!\<acute>ind=Black
+ THEN .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv \<acute>ind
+ \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
+ \<acute>bc:=insert \<acute>ind \<acute>bc
+ FI;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>CountInv (\<acute>ind+1)
+ \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe) \<and> \<acute>ind<length \<acute>M}.
+ \<acute>ind:=\<acute>ind+1
+ OD"
+
+lemma Count:
+ "\<turnstile> Count
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> length \<acute>Ma=length \<acute>M
+ \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe)}."
+apply(unfold Count_def)
+apply annhoare
+apply(simp_all add:CountInv_def Graph6 Graph7 Graph8 Graph12 Blacks_def collector_defs)
+ apply force
+ apply force
+ apply force
+ apply clarify
+ apply simp
+ apply(fast elim:less_SucE)
+ apply clarify
+ apply simp
+ apply(fast elim:less_SucE)
+ apply force
+apply force
+done
+
+subsubsection {* Appending garbage nodes to the free list *}
+
+consts Append_to_free :: "nat \<times> edges \<Rightarrow> edges"
+
+axioms
+ Append_to_free0: "length (Append_to_free (i, e)) = length e"
+ Append_to_free1: "Proper_Edges (m, e)
+ \<Longrightarrow> Proper_Edges (m, Append_to_free(i, e))"
+ Append_to_free2: "i \<notin> Reach e
+ \<Longrightarrow> n \<in> Reach (Append_to_free(i, e)) = ( n = i \<or> n \<in> Reach e)"
+
+constdefs
+ AppendInv :: "gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
+ "AppendInv \<equiv> \<guillemotleft>\<lambda>ind. \<forall>i<length \<acute>M. ind\<le>i \<longrightarrow> i\<in>Reach \<acute>E \<longrightarrow> \<acute>M!i=Black\<guillemotright>"
+
+constdefs
+ Append :: " gar_coll_state ann_com"
+ "Append \<equiv>
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe}.
+ \<acute>ind:=0;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>M
+ INV .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>M}.
+ DO .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M}.
+ IF \<acute>M!\<acute>ind=Black THEN
+ .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
+ \<acute>M:=\<acute>M[\<acute>ind:=White]
+ ELSE .{\<acute>Proper \<and> \<acute>AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<notin>Reach \<acute>E}.
+ \<acute>E:=Append_to_free(\<acute>ind,\<acute>E)
+ FI;;
+ .{\<acute>Proper \<and> \<acute>AppendInv (\<acute>ind+1) \<and> \<acute>ind<length \<acute>M}.
+ \<acute>ind:=\<acute>ind+1
+ OD"
+
+lemma Append:
+ "\<turnstile> Append .{\<acute>Proper}."
+apply(unfold Append_def AppendInv_def)
+apply annhoare
+apply(simp_all add:collector_defs Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
+ apply(force simp:Blacks_def nth_list_update)
+ apply force
+ apply force
+ apply(force simp add:Graph_defs)
+ apply force
+ apply clarify
+ apply simp
+ apply(rule conjI)
+ apply (erule Append_to_free1)
+ apply clarify
+ apply (drule_tac n = "i" in Append_to_free2)
+ apply force
+ apply force
+apply force
+done
+
+subsubsection {* Correctness of the Collector *}
+
+constdefs
+ Collector :: " gar_coll_state ann_com"
+ "Collector \<equiv>
+.{\<acute>Proper}.
+ WHILE True INV .{\<acute>Proper}.
+ DO
+ Blacken_Roots;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M}.
+ \<acute>obc:={};;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={}}.
+ \<acute>bc:=Roots;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots}.
+ \<acute>Ma:=M_init;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots \<and> \<acute>Ma=M_init}.
+ WHILE \<acute>obc\<noteq>\<acute>bc
+ INV .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> (\<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe)}.
+ DO .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M}.
+ \<acute>obc:=\<acute>bc;;
+ Propagate_Black;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>obc < Blacks \<acute>M \<or> \<acute>Safe)}.
+ \<acute>Ma:=\<acute>M;;
+ .{\<acute>Proper \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma
+ \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and> length \<acute>Ma=length \<acute>M
+ \<and> ( \<acute>obc < Blacks \<acute>Ma \<or> \<acute>Safe)}.
+ \<acute>bc:={};;
+ Count
+ OD;;
+ Append
+ OD"
+
+lemma Collector:
+ "\<turnstile> Collector .{False}."
+apply(unfold Collector_def)
+apply annhoare
+apply(simp_all add: Blacken_Roots Propagate_Black Count Append)
+apply(simp_all add:Blacken_Roots_def Propagate_Black_def Count_def Append_def collector_defs)
+ apply (force simp add: Proper_Roots_def)
+ apply force
+ apply force
+apply clarify
+apply (erule disjE)
+apply(simp add:psubsetI)
+ apply(force dest:subset_antisym)
+done
+
+subsection {* Interference Freedom *}
+
+lemmas modules = Redirect_Edge_def Color_Target_def Blacken_Roots_def
+ Propagate_Black_def Count_def Append_def
+lemmas Invariants = PBInv_def Auxk_def CountInv_def AppendInv_def
+lemmas abbrev = collector_defs mutator_defs Invariants
+
+lemma interfree_Blacken_Roots_Redirect_Edge:
+ "interfree_aux (Some Blacken_Roots, {}, Some Redirect_Edge)"
+apply (unfold modules)
+apply interfree_aux
+apply safe
+apply (simp_all add:Graph6 Graph12 abbrev)
+done
+
+lemma interfree_Redirect_Edge_Blacken_Roots:
+ "interfree_aux (Some Redirect_Edge, {}, Some Blacken_Roots)"
+apply (unfold modules)
+apply interfree_aux
+apply safe
+apply(simp add:abbrev)+
+done
+
+lemma interfree_Blacken_Roots_Color_Target:
+ "interfree_aux (Some Blacken_Roots, {}, Some Color_Target)"
+apply (unfold modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:Graph7 Graph8 nth_list_update abbrev)
+done
+
+lemma interfree_Color_Target_Blacken_Roots:
+ "interfree_aux (Some Color_Target, {}, Some Blacken_Roots)"
+apply (unfold modules )
+apply interfree_aux
+apply safe
+apply(simp add:abbrev)+
+done
+
+lemma interfree_Propagate_Black_Redirect_Edge:
+ "interfree_aux (Some Propagate_Black, {}, Some Redirect_Edge)"
+apply (unfold modules )
+apply interfree_aux
+--{* 11 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(erule conjE)+
+apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
+ apply(erule Graph4)
+ apply(simp)+
+ apply (simp add:BtoW_def)
+ apply (simp add:BtoW_def)
+apply(rule conjI)
+ apply (force simp add:BtoW_def)
+apply(erule Graph4)
+ apply simp+
+--{* 7 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(erule conjE)+
+apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
+ apply(erule Graph4)
+ apply(simp)+
+ apply (simp add:BtoW_def)
+ apply (simp add:BtoW_def)
+apply(rule conjI)
+ apply (force simp add:BtoW_def)
+apply(erule Graph4)
+ apply simp+
+--{* 6 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(erule conjE)+
+apply(rule conjI)
+ apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
+ apply(erule Graph4)
+ apply(simp)+
+ apply (simp add:BtoW_def)
+ apply (simp add:BtoW_def)
+ apply(rule conjI)
+ apply (force simp add:BtoW_def)
+ apply(erule Graph4)
+ apply simp+
+apply(simp add:BtoW_def nth_list_update)
+apply force
+--{* 5 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12)
+--{* 4 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(rule conjI)
+ apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
+ apply(erule Graph4)
+ apply(simp)+
+ apply (simp add:BtoW_def)
+ apply (simp add:BtoW_def)
+ apply(rule conjI)
+ apply (force simp add:BtoW_def)
+ apply(erule Graph4)
+ apply simp+
+apply(rule conjI)
+ apply(simp add:nth_list_update)
+ apply force
+apply(rule impI, rule impI, erule disjE, erule disjI1, case_tac "R = (ind x)" ,case_tac "M x ! T = Black")
+ apply(force simp add:BtoW_def)
+ apply(case_tac "M x !snd (E x ! ind x)=Black")
+ apply(rule disjI2)
+ apply simp
+ apply (erule Graph5)
+ apply simp+
+ apply(force simp add:BtoW_def)
+apply(force simp add:BtoW_def)
+--{* 3 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12)
+--{* 2 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12)
+apply(erule disjE, erule disjI1, rule disjI2, rule allI, (rule impI)+, case_tac "R=i", rule conjI, erule sym)
+ apply clarify
+ apply(erule Graph4)
+ apply(simp)+
+ apply (simp add:BtoW_def)
+ apply (simp add:BtoW_def)
+apply(rule conjI)
+ apply (force simp add:BtoW_def)
+apply(erule Graph4)
+ apply simp+
+done
+
+lemma interfree_Redirect_Edge_Propagate_Black:
+ "interfree_aux (Some Redirect_Edge, {}, Some Propagate_Black)"
+apply (unfold modules )
+apply interfree_aux
+apply(clarify, simp add:abbrev)+
+done
+
+lemma interfree_Propagate_Black_Color_Target:
+ "interfree_aux (Some Propagate_Black, {}, Some Color_Target)"
+apply (unfold modules )
+apply interfree_aux
+--{* 11 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)+
+apply(erule conjE)+
+apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
+ case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
+ erule allE, erule impE, assumption, erule impE, assumption,
+ simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
+--{* 7 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
+apply(erule conjE)+
+apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
+ case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
+ erule allE, erule impE, assumption, erule impE, assumption,
+ simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
+--{* 6 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
+apply clarify
+apply (rule conjI)
+ apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
+ case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
+ erule allE, erule impE, assumption, erule impE, assumption,
+ simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
+apply(simp add:nth_list_update)
+--{* 5 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
+--{* 4 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
+apply (rule conjI)
+ apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
+ case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
+ erule allE, erule impE, assumption, erule impE, assumption,
+ simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
+apply(rule conjI)
+apply(simp add:nth_list_update)
+apply(rule impI,rule impI, case_tac "M x!T=Black",rotate_tac -1, force simp add: BtoW_def Graph10,
+ erule subset_psubset_trans, erule Graph11, force)
+--{* 3 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
+--{* 2 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
+apply(erule disjE,rule disjI1,erule psubset_subset_trans,erule Graph9,
+ case_tac "M x!T=Black", rule disjI2,rotate_tac -1, simp add: Graph10, clarify,
+ erule allE, erule impE, assumption, erule impE, assumption,
+ simp add:BtoW_def, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
+--{* 3 subgoals left *}
+apply(simp add:abbrev)
+done
+
+lemma interfree_Color_Target_Propagate_Black:
+ "interfree_aux (Some Color_Target, {}, Some Propagate_Black)"
+apply (unfold modules )
+apply interfree_aux
+apply(clarify, simp add:abbrev)+
+done
+
+lemma interfree_Count_Redirect_Edge:
+ "interfree_aux (Some Count, {}, Some Redirect_Edge)"
+apply (unfold modules)
+apply interfree_aux
+--{* 9 subgoals left *}
+apply(simp_all add:abbrev Graph6 Graph12)
+--{* 6 subgoals left *}
+apply(clarify, simp add:abbrev Graph6 Graph12,
+ erule disjE,erule disjI1,rule disjI2,rule subset_trans, erule Graph3,force,force)+
+done
+
+lemma interfree_Redirect_Edge_Count:
+ "interfree_aux (Some Redirect_Edge, {}, Some Count)"
+apply (unfold modules )
+apply interfree_aux
+apply(clarify,simp add:abbrev)+
+apply(simp add:abbrev)
+done
+
+lemma interfree_Count_Color_Target:
+ "interfree_aux (Some Count, {}, Some Color_Target)"
+apply (unfold modules )
+apply interfree_aux
+--{* 9 subgoals left *}
+apply(simp_all add:abbrev Graph7 Graph8 Graph12)
+--{* 6 subgoals left *}
+apply(clarify,simp add:abbrev Graph7 Graph8 Graph12,
+ erule disjE, erule disjI1, rule disjI2,erule subset_trans, erule Graph9)+
+--{* 2 subgoals left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12)
+apply(rule conjI)
+ apply(erule disjE, erule disjI1, rule disjI2,erule subset_trans, erule Graph9)
+apply(simp add:nth_list_update)
+--{* 1 subgoal left *}
+apply(clarify, simp add:abbrev Graph7 Graph8 Graph12,
+ erule disjE, erule disjI1, rule disjI2,erule subset_trans, erule Graph9)
+done
+
+lemma interfree_Color_Target_Count:
+ "interfree_aux (Some Color_Target, {}, Some Count)"
+apply (unfold modules )
+apply interfree_aux
+apply(clarify, simp add:abbrev)+
+apply(simp add:abbrev)
+done
+
+lemma interfree_Append_Redirect_Edge:
+ "interfree_aux (Some Append, {}, Some Redirect_Edge)"
+apply (unfold modules )
+apply interfree_aux
+apply( simp_all add:abbrev Graph6 Append_to_free0 Append_to_free1 Graph12)
+apply(clarify, simp add:abbrev Graph6 Append_to_free0 Append_to_free1 Graph12, force dest:Graph3)+
+done
+
+lemma interfree_Redirect_Edge_Append:
+ "interfree_aux (Some Redirect_Edge, {}, Some Append)"
+apply (unfold modules )
+apply interfree_aux
+apply(clarify, simp add:abbrev Append_to_free0)+
+apply (force simp add: Append_to_free2)
+apply(clarify, simp add:abbrev Append_to_free0)+
+done
+
+lemma interfree_Append_Color_Target:
+ "interfree_aux (Some Append, {}, Some Color_Target)"
+apply (unfold modules )
+apply interfree_aux
+apply(clarify, simp add:abbrev Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12 nth_list_update)+
+apply(simp add:abbrev Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12 nth_list_update)
+done
+
+lemma interfree_Color_Target_Append:
+ "interfree_aux (Some Color_Target, {}, Some Append)"
+apply (unfold modules )
+apply interfree_aux
+apply(clarify, simp add:abbrev Append_to_free0)+
+apply (force simp add: Append_to_free2)
+apply(clarify,simp add:abbrev Append_to_free0)+
+done
+
+lemmas collector_mutator_interfree =
+ interfree_Blacken_Roots_Redirect_Edge interfree_Blacken_Roots_Color_Target
+ interfree_Propagate_Black_Redirect_Edge interfree_Propagate_Black_Color_Target
+ interfree_Count_Redirect_Edge interfree_Count_Color_Target
+ interfree_Append_Redirect_Edge interfree_Append_Color_Target
+ interfree_Redirect_Edge_Blacken_Roots interfree_Color_Target_Blacken_Roots
+ interfree_Redirect_Edge_Propagate_Black interfree_Color_Target_Propagate_Black
+ interfree_Redirect_Edge_Count interfree_Color_Target_Count
+ interfree_Redirect_Edge_Append interfree_Color_Target_Append
+
+subsubsection {* Interference freedom Collector-Mutator *}
+
+lemma interfree_Collector_Mutator:
+ "interfree_aux (Some Collector, {}, Some Mutator)"
+apply(unfold Collector_def Mutator_def)
+apply interfree_aux
+apply(simp_all add:collector_mutator_interfree)
+apply(unfold modules collector_defs mutator_defs)
+apply(tactic {* TRYALL (interfree_aux_tac) *})
+--{* 32 subgoals left *}
+apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
+--{* 20 subgoals left *}
+apply(tactic{* TRYALL (clarify_tac @{claset}) *})
+apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
+apply(tactic {* TRYALL (etac disjE) *})
+apply simp_all
+apply(tactic {* TRYALL(EVERY'[rtac disjI2,rtac subset_trans,etac @{thm Graph3},force_tac @{clasimpset}, assume_tac]) *})
+apply(tactic {* TRYALL(EVERY'[rtac disjI2,etac subset_trans,rtac @{thm Graph9},force_tac @{clasimpset}]) *})
+apply(tactic {* TRYALL(EVERY'[rtac disjI1,etac @{thm psubset_subset_trans},rtac @{thm Graph9},force_tac @{clasimpset}]) *})
+done
+
+subsubsection {* Interference freedom Mutator-Collector *}
+
+lemma interfree_Mutator_Collector:
+ "interfree_aux (Some Mutator, {}, Some Collector)"
+apply(unfold Collector_def Mutator_def)
+apply interfree_aux
+apply(simp_all add:collector_mutator_interfree)
+apply(unfold modules collector_defs mutator_defs)
+apply(tactic {* TRYALL (interfree_aux_tac) *})
+--{* 64 subgoals left *}
+apply(simp_all add:nth_list_update Invariants Append_to_free0)+
+apply(tactic{* TRYALL (clarify_tac @{claset}) *})
+--{* 4 subgoals left *}
+apply force
+apply(simp add:Append_to_free2)
+apply force
+apply(simp add:Append_to_free2)
+done
+
+subsubsection {* The Garbage Collection algorithm *}
+
+text {* In total there are 289 verification conditions. *}
+
+lemma Gar_Coll:
+ "\<parallel>- .{\<acute>Proper \<and> \<acute>Mut_init \<and> \<acute>z}.
+ COBEGIN
+ Collector
+ .{False}.
+ \<parallel>
+ Mutator
+ .{False}.
+ COEND
+ .{False}."
+apply oghoare
+apply(force simp add: Mutator_def Collector_def modules)
+apply(rule Collector)
+apply(rule Mutator)
+apply(simp add:interfree_Collector_Mutator)
+apply(simp add:interfree_Mutator_Collector)
+apply force
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/Graph.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,410 @@
+header {* \chapter{Case Study: Single and Multi-Mutator Garbage Collection Algorithms}
+
+\section {Formalization of the Memory} *}
+
+theory Graph imports Main begin
+
+datatype node = Black | White
+
+types
+ nodes = "node list"
+ edge = "nat \<times> nat"
+ edges = "edge list"
+
+consts Roots :: "nat set"
+
+constdefs
+ Proper_Roots :: "nodes \<Rightarrow> bool"
+ "Proper_Roots M \<equiv> Roots\<noteq>{} \<and> Roots \<subseteq> {i. i<length M}"
+
+ Proper_Edges :: "(nodes \<times> edges) \<Rightarrow> bool"
+ "Proper_Edges \<equiv> (\<lambda>(M,E). \<forall>i<length E. fst(E!i)<length M \<and> snd(E!i)<length M)"
+
+ BtoW :: "(edge \<times> nodes) \<Rightarrow> bool"
+ "BtoW \<equiv> (\<lambda>(e,M). (M!fst e)=Black \<and> (M!snd e)\<noteq>Black)"
+
+ Blacks :: "nodes \<Rightarrow> nat set"
+ "Blacks M \<equiv> {i. i<length M \<and> M!i=Black}"
+
+ Reach :: "edges \<Rightarrow> nat set"
+ "Reach E \<equiv> {x. (\<exists>path. 1<length path \<and> path!(length path - 1)\<in>Roots \<and> x=path!0
+ \<and> (\<forall>i<length path - 1. (\<exists>j<length E. E!j=(path!(i+1), path!i))))
+ \<or> x\<in>Roots}"
+
+text{* Reach: the set of reachable nodes is the set of Roots together with the
+nodes reachable from some Root by a path represented by a list of
+ nodes (at least two since we traverse at least one edge), where two
+consecutive nodes correspond to an edge in E. *}
+
+subsection {* Proofs about Graphs *}
+
+lemmas Graph_defs= Blacks_def Proper_Roots_def Proper_Edges_def BtoW_def
+declare Graph_defs [simp]
+
+subsubsection{* Graph 1 *}
+
+lemma Graph1_aux [rule_format]:
+ "\<lbrakk> Roots\<subseteq>Blacks M; \<forall>i<length E. \<not>BtoW(E!i,M)\<rbrakk>
+ \<Longrightarrow> 1< length path \<longrightarrow> (path!(length path - 1))\<in>Roots \<longrightarrow>
+ (\<forall>i<length path - 1. (\<exists>j. j < length E \<and> E!j=(path!(Suc i), path!i)))
+ \<longrightarrow> M!(path!0) = Black"
+apply(induct_tac "path")
+ apply force
+apply clarify
+apply simp
+apply(case_tac "list")
+ apply force
+apply simp
+apply(rotate_tac -2)
+apply(erule_tac x = "0" in all_dupE)
+apply simp
+apply clarify
+apply(erule allE , erule (1) notE impE)
+apply simp
+apply(erule mp)
+apply(case_tac "lista")
+ apply force
+apply simp
+apply(erule mp)
+apply clarify
+apply(erule_tac x = "Suc i" in allE)
+apply force
+done
+
+lemma Graph1:
+ "\<lbrakk>Roots\<subseteq>Blacks M; Proper_Edges(M, E); \<forall>i<length E. \<not>BtoW(E!i,M) \<rbrakk>
+ \<Longrightarrow> Reach E\<subseteq>Blacks M"
+apply (unfold Reach_def)
+apply simp
+apply clarify
+apply(erule disjE)
+ apply clarify
+ apply(rule conjI)
+ apply(subgoal_tac "0< length path - Suc 0")
+ apply(erule allE , erule (1) notE impE)
+ apply force
+ apply simp
+ apply(rule Graph1_aux)
+apply auto
+done
+
+subsubsection{* Graph 2 *}
+
+lemma Ex_first_occurrence [rule_format]:
+ "P (n::nat) \<longrightarrow> (\<exists>m. P m \<and> (\<forall>i. i<m \<longrightarrow> \<not> P i))";
+apply(rule nat_less_induct)
+apply clarify
+apply(case_tac "\<forall>m. m<n \<longrightarrow> \<not> P m")
+apply auto
+done
+
+lemma Compl_lemma: "(n::nat)\<le>l \<Longrightarrow> (\<exists>m. m\<le>l \<and> n=l - m)"
+apply(rule_tac x = "l - n" in exI)
+apply arith
+done
+
+lemma Ex_last_occurrence:
+ "\<lbrakk>P (n::nat); n\<le>l\<rbrakk> \<Longrightarrow> (\<exists>m. P (l - m) \<and> (\<forall>i. i<m \<longrightarrow> \<not>P (l - i)))"
+apply(drule Compl_lemma)
+apply clarify
+apply(erule Ex_first_occurrence)
+done
+
+lemma Graph2:
+ "\<lbrakk>T \<in> Reach E; R<length E\<rbrakk> \<Longrightarrow> T \<in> Reach (E[R:=(fst(E!R), T)])"
+apply (unfold Reach_def)
+apply clarify
+apply simp
+apply(case_tac "\<forall>z<length path. fst(E!R)\<noteq>path!z")
+ apply(rule_tac x = "path" in exI)
+ apply simp
+ apply clarify
+ apply(erule allE , erule (1) notE impE)
+ apply clarify
+ apply(rule_tac x = "j" in exI)
+ apply(case_tac "j=R")
+ apply(erule_tac x = "Suc i" in allE)
+ apply simp
+ apply (force simp add:nth_list_update)
+apply simp
+apply(erule exE)
+apply(subgoal_tac "z \<le> length path - Suc 0")
+ prefer 2 apply arith
+apply(drule_tac P = "\<lambda>m. m<length path \<and> fst(E!R)=path!m" in Ex_last_occurrence)
+ apply assumption
+apply clarify
+apply simp
+apply(rule_tac x = "(path!0)#(drop (length path - Suc m) path)" in exI)
+apply simp
+apply(case_tac "length path - (length path - Suc m)")
+ apply arith
+apply simp
+apply(subgoal_tac "(length path - Suc m) + nat \<le> length path")
+ prefer 2 apply arith
+apply(drule nth_drop)
+apply simp
+apply(subgoal_tac "length path - Suc m + nat = length path - Suc 0")
+ prefer 2 apply arith
+apply simp
+apply clarify
+apply(case_tac "i")
+ apply(force simp add: nth_list_update)
+apply simp
+apply(subgoal_tac "(length path - Suc m) + nata \<le> length path")
+ prefer 2 apply arith
+apply(subgoal_tac "(length path - Suc m) + (Suc nata) \<le> length path")
+ prefer 2 apply arith
+apply simp
+apply(erule_tac x = "length path - Suc m + nata" in allE)
+apply simp
+apply clarify
+apply(rule_tac x = "j" in exI)
+apply(case_tac "R=j")
+ prefer 2 apply force
+apply simp
+apply(drule_tac t = "path ! (length path - Suc m)" in sym)
+apply simp
+apply(case_tac " length path - Suc 0 < m")
+ apply(subgoal_tac "(length path - Suc m)=0")
+ prefer 2 apply arith
+ apply(simp del: diff_is_0_eq)
+ apply(subgoal_tac "Suc nata\<le>nat")
+ prefer 2 apply arith
+ apply(drule_tac n = "Suc nata" in Compl_lemma)
+ apply clarify
+ using [[linarith_split_limit = 0]]
+ apply force
+ using [[linarith_split_limit = 9]]
+apply(drule leI)
+apply(subgoal_tac "Suc (length path - Suc m + nata)=(length path - Suc 0) - (m - Suc nata)")
+ apply(erule_tac x = "m - (Suc nata)" in allE)
+ apply(case_tac "m")
+ apply simp
+ apply simp
+apply simp
+done
+
+
+subsubsection{* Graph 3 *}
+
+lemma Graph3:
+ "\<lbrakk> T\<in>Reach E; R<length E \<rbrakk> \<Longrightarrow> Reach(E[R:=(fst(E!R),T)]) \<subseteq> Reach E"
+apply (unfold Reach_def)
+apply clarify
+apply simp
+apply(case_tac "\<exists>i<length path - 1. (fst(E!R),T)=(path!(Suc i),path!i)")
+--{* the changed edge is part of the path *}
+ apply(erule exE)
+ apply(drule_tac P = "\<lambda>i. i<length path - 1 \<and> (fst(E!R),T)=(path!Suc i,path!i)" in Ex_first_occurrence)
+ apply clarify
+ apply(erule disjE)
+--{* T is NOT a root *}
+ apply clarify
+ apply(rule_tac x = "(take m path)@patha" in exI)
+ apply(subgoal_tac "\<not>(length path\<le>m)")
+ prefer 2 apply arith
+ apply(simp)
+ apply(rule conjI)
+ apply(subgoal_tac "\<not>(m + length patha - 1 < m)")
+ prefer 2 apply arith
+ apply(simp add: nth_append)
+ apply(rule conjI)
+ apply(case_tac "m")
+ apply force
+ apply(case_tac "path")
+ apply force
+ apply force
+ apply clarify
+ apply(case_tac "Suc i\<le>m")
+ apply(erule_tac x = "i" in allE)
+ apply simp
+ apply clarify
+ apply(rule_tac x = "j" in exI)
+ apply(case_tac "Suc i<m")
+ apply(simp add: nth_append)
+ apply(case_tac "R=j")
+ apply(simp add: nth_list_update)
+ apply(case_tac "i=m")
+ apply force
+ apply(erule_tac x = "i" in allE)
+ apply force
+ apply(force simp add: nth_list_update)
+ apply(simp add: nth_append)
+ apply(subgoal_tac "i=m - 1")
+ prefer 2 apply arith
+ apply(case_tac "R=j")
+ apply(erule_tac x = "m - 1" in allE)
+ apply(simp add: nth_list_update)
+ apply(force simp add: nth_list_update)
+ apply(simp add: nth_append)
+ apply(rotate_tac -4)
+ apply(erule_tac x = "i - m" in allE)
+ apply(subgoal_tac "Suc (i - m)=(Suc i - m)" )
+ prefer 2 apply arith
+ apply simp
+--{* T is a root *}
+ apply(case_tac "m=0")
+ apply force
+ apply(rule_tac x = "take (Suc m) path" in exI)
+ apply(subgoal_tac "\<not>(length path\<le>Suc m)" )
+ prefer 2 apply arith
+ apply clarsimp
+ apply(erule_tac x = "i" in allE)
+ apply simp
+ apply clarify
+ apply(case_tac "R=j")
+ apply(force simp add: nth_list_update)
+ apply(force simp add: nth_list_update)
+--{* the changed edge is not part of the path *}
+apply(rule_tac x = "path" in exI)
+apply simp
+apply clarify
+apply(erule_tac x = "i" in allE)
+apply clarify
+apply(case_tac "R=j")
+ apply(erule_tac x = "i" in allE)
+ apply simp
+apply(force simp add: nth_list_update)
+done
+
+subsubsection{* Graph 4 *}
+
+lemma Graph4:
+ "\<lbrakk>T \<in> Reach E; Roots\<subseteq>Blacks M; I\<le>length E; T<length M; R<length E;
+ \<forall>i<I. \<not>BtoW(E!i,M); R<I; M!fst(E!R)=Black; M!T\<noteq>Black\<rbrakk> \<Longrightarrow>
+ (\<exists>r. I\<le>r \<and> r<length E \<and> BtoW(E[R:=(fst(E!R),T)]!r,M))"
+apply (unfold Reach_def)
+apply simp
+apply(erule disjE)
+ prefer 2 apply force
+apply clarify
+--{* there exist a black node in the path to T *}
+apply(case_tac "\<exists>m<length path. M!(path!m)=Black")
+ apply(erule exE)
+ apply(drule_tac P = "\<lambda>m. m<length path \<and> M!(path!m)=Black" in Ex_first_occurrence)
+ apply clarify
+ apply(case_tac "ma")
+ apply force
+ apply simp
+ apply(case_tac "length path")
+ apply force
+ apply simp
+ apply(erule_tac P = "\<lambda>i. i < nata \<longrightarrow> ?P i" and x = "nat" in allE)
+ apply simp
+ apply clarify
+ apply(erule_tac P = "\<lambda>i. i < Suc nat \<longrightarrow> ?P i" and x = "nat" in allE)
+ apply simp
+ apply(case_tac "j<I")
+ apply(erule_tac x = "j" in allE)
+ apply force
+ apply(rule_tac x = "j" in exI)
+ apply(force simp add: nth_list_update)
+apply simp
+apply(rotate_tac -1)
+apply(erule_tac x = "length path - 1" in allE)
+apply(case_tac "length path")
+ apply force
+apply force
+done
+
+subsubsection {* Graph 5 *}
+
+lemma Graph5:
+ "\<lbrakk> T \<in> Reach E ; Roots \<subseteq> Blacks M; \<forall>i<R. \<not>BtoW(E!i,M); T<length M;
+ R<length E; M!fst(E!R)=Black; M!snd(E!R)=Black; M!T \<noteq> Black\<rbrakk>
+ \<Longrightarrow> (\<exists>r. R<r \<and> r<length E \<and> BtoW(E[R:=(fst(E!R),T)]!r,M))"
+apply (unfold Reach_def)
+apply simp
+apply(erule disjE)
+ prefer 2 apply force
+apply clarify
+--{* there exist a black node in the path to T*}
+apply(case_tac "\<exists>m<length path. M!(path!m)=Black")
+ apply(erule exE)
+ apply(drule_tac P = "\<lambda>m. m<length path \<and> M!(path!m)=Black" in Ex_first_occurrence)
+ apply clarify
+ apply(case_tac "ma")
+ apply force
+ apply simp
+ apply(case_tac "length path")
+ apply force
+ apply simp
+ apply(erule_tac P = "\<lambda>i. i < nata \<longrightarrow> ?P i" and x = "nat" in allE)
+ apply simp
+ apply clarify
+ apply(erule_tac P = "\<lambda>i. i < Suc nat \<longrightarrow> ?P i" and x = "nat" in allE)
+ apply simp
+ apply(case_tac "j\<le>R")
+ apply(drule le_imp_less_or_eq [of _ R])
+ apply(erule disjE)
+ apply(erule allE , erule (1) notE impE)
+ apply force
+ apply force
+ apply(rule_tac x = "j" in exI)
+ apply(force simp add: nth_list_update)
+apply simp
+apply(rotate_tac -1)
+apply(erule_tac x = "length path - 1" in allE)
+apply(case_tac "length path")
+ apply force
+apply force
+done
+
+subsubsection {* Other lemmas about graphs *}
+
+lemma Graph6:
+ "\<lbrakk>Proper_Edges(M,E); R<length E ; T<length M\<rbrakk> \<Longrightarrow> Proper_Edges(M,E[R:=(fst(E!R),T)])"
+apply (unfold Proper_Edges_def)
+ apply(force simp add: nth_list_update)
+done
+
+lemma Graph7:
+ "\<lbrakk>Proper_Edges(M,E)\<rbrakk> \<Longrightarrow> Proper_Edges(M[T:=a],E)"
+apply (unfold Proper_Edges_def)
+apply force
+done
+
+lemma Graph8:
+ "\<lbrakk>Proper_Roots(M)\<rbrakk> \<Longrightarrow> Proper_Roots(M[T:=a])"
+apply (unfold Proper_Roots_def)
+apply force
+done
+
+text{* Some specific lemmata for the verification of garbage collection algorithms. *}
+
+lemma Graph9: "j<length M \<Longrightarrow> Blacks M\<subseteq>Blacks (M[j := Black])"
+apply (unfold Blacks_def)
+ apply(force simp add: nth_list_update)
+done
+
+lemma Graph10 [rule_format (no_asm)]: "\<forall>i. M!i=a \<longrightarrow>M[i:=a]=M"
+apply(induct_tac "M")
+apply auto
+apply(case_tac "i")
+apply auto
+done
+
+lemma Graph11 [rule_format (no_asm)]:
+ "\<lbrakk> M!j\<noteq>Black;j<length M\<rbrakk> \<Longrightarrow> Blacks M \<subset> Blacks (M[j := Black])"
+apply (unfold Blacks_def)
+apply(rule psubsetI)
+ apply(force simp add: nth_list_update)
+apply safe
+apply(erule_tac c = "j" in equalityCE)
+apply auto
+done
+
+lemma Graph12: "\<lbrakk>a\<subseteq>Blacks M;j<length M\<rbrakk> \<Longrightarrow> a\<subseteq>Blacks (M[j := Black])"
+apply (unfold Blacks_def)
+apply(force simp add: nth_list_update)
+done
+
+lemma Graph13: "\<lbrakk>a\<subset> Blacks M;j<length M\<rbrakk> \<Longrightarrow> a \<subset> Blacks (M[j := Black])"
+apply (unfold Blacks_def)
+apply(erule psubset_subset_trans)
+apply(force simp add: nth_list_update)
+done
+
+declare Graph_defs [simp del]
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/Hoare_Parallel.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,5 @@
+theory Hoare_Parallel
+imports OG_Examples Gar_Coll Mul_Gar_Coll RG_Examples
+begin
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/Mul_Gar_Coll.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,1283 @@
+
+header {* \section{The Multi-Mutator Case} *}
+
+theory Mul_Gar_Coll imports Graph OG_Syntax begin
+
+text {* The full theory takes aprox. 18 minutes. *}
+
+record mut =
+ Z :: bool
+ R :: nat
+ T :: nat
+
+text {* Declaration of variables: *}
+
+record mul_gar_coll_state =
+ M :: nodes
+ E :: edges
+ bc :: "nat set"
+ obc :: "nat set"
+ Ma :: nodes
+ ind :: nat
+ k :: nat
+ q :: nat
+ l :: nat
+ Muts :: "mut list"
+
+subsection {* The Mutators *}
+
+constdefs
+ Mul_mut_init :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
+ "Mul_mut_init \<equiv> \<guillemotleft> \<lambda>n. n=length \<acute>Muts \<and> (\<forall>i<n. R (\<acute>Muts!i)<length \<acute>E
+ \<and> T (\<acute>Muts!i)<length \<acute>M) \<guillemotright>"
+
+ Mul_Redirect_Edge :: "nat \<Rightarrow> nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Redirect_Edge j n \<equiv>
+ .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}.
+ \<langle>IF T(\<acute>Muts!j) \<in> Reach \<acute>E THEN
+ \<acute>E:= \<acute>E[R (\<acute>Muts!j):= (fst (\<acute>E!R(\<acute>Muts!j)), T (\<acute>Muts!j))] FI,,
+ \<acute>Muts:= \<acute>Muts[j:= (\<acute>Muts!j) \<lparr>Z:=False\<rparr>]\<rangle>"
+
+ Mul_Color_Target :: "nat \<Rightarrow> nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Color_Target j n \<equiv>
+ .{\<acute>Mul_mut_init n \<and> \<not> Z (\<acute>Muts!j)}.
+ \<langle>\<acute>M:=\<acute>M[T (\<acute>Muts!j):=Black],, \<acute>Muts:=\<acute>Muts[j:= (\<acute>Muts!j) \<lparr>Z:=True\<rparr>]\<rangle>"
+
+ Mul_Mutator :: "nat \<Rightarrow> nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Mutator j n \<equiv>
+ .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}.
+ WHILE True
+ INV .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}.
+ DO Mul_Redirect_Edge j n ;;
+ Mul_Color_Target j n
+ OD"
+
+lemmas mul_mutator_defs = Mul_mut_init_def Mul_Redirect_Edge_def Mul_Color_Target_def
+
+subsubsection {* Correctness of the proof outline of one mutator *}
+
+lemma Mul_Redirect_Edge: "0\<le>j \<and> j<n \<Longrightarrow>
+ \<turnstile> Mul_Redirect_Edge j n
+ pre(Mul_Color_Target j n)"
+apply (unfold mul_mutator_defs)
+apply annhoare
+apply(simp_all)
+apply clarify
+apply(simp add:nth_list_update)
+done
+
+lemma Mul_Color_Target: "0\<le>j \<and> j<n \<Longrightarrow>
+ \<turnstile> Mul_Color_Target j n
+ .{\<acute>Mul_mut_init n \<and> Z (\<acute>Muts!j)}."
+apply (unfold mul_mutator_defs)
+apply annhoare
+apply(simp_all)
+apply clarify
+apply(simp add:nth_list_update)
+done
+
+lemma Mul_Mutator: "0\<le>j \<and> j<n \<Longrightarrow>
+ \<turnstile> Mul_Mutator j n .{False}."
+apply(unfold Mul_Mutator_def)
+apply annhoare
+apply(simp_all add:Mul_Redirect_Edge Mul_Color_Target)
+apply(simp add:mul_mutator_defs Mul_Redirect_Edge_def)
+done
+
+subsubsection {* Interference freedom between mutators *}
+
+lemma Mul_interfree_Redirect_Edge_Redirect_Edge:
+ "\<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
+ interfree_aux (Some (Mul_Redirect_Edge i n),{}, Some(Mul_Redirect_Edge j n))"
+apply (unfold mul_mutator_defs)
+apply interfree_aux
+apply safe
+apply(simp_all add: nth_list_update)
+done
+
+lemma Mul_interfree_Redirect_Edge_Color_Target:
+ "\<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
+ interfree_aux (Some(Mul_Redirect_Edge i n),{},Some(Mul_Color_Target j n))"
+apply (unfold mul_mutator_defs)
+apply interfree_aux
+apply safe
+apply(simp_all add: nth_list_update)
+done
+
+lemma Mul_interfree_Color_Target_Redirect_Edge:
+ "\<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
+ interfree_aux (Some(Mul_Color_Target i n),{},Some(Mul_Redirect_Edge j n))"
+apply (unfold mul_mutator_defs)
+apply interfree_aux
+apply safe
+apply(simp_all add:nth_list_update)
+done
+
+lemma Mul_interfree_Color_Target_Color_Target:
+ " \<lbrakk>0\<le>i; i<n; 0\<le>j; j<n; i\<noteq>j\<rbrakk> \<Longrightarrow>
+ interfree_aux (Some(Mul_Color_Target i n),{},Some(Mul_Color_Target j n))"
+apply (unfold mul_mutator_defs)
+apply interfree_aux
+apply safe
+apply(simp_all add: nth_list_update)
+done
+
+lemmas mul_mutator_interfree =
+ Mul_interfree_Redirect_Edge_Redirect_Edge Mul_interfree_Redirect_Edge_Color_Target
+ Mul_interfree_Color_Target_Redirect_Edge Mul_interfree_Color_Target_Color_Target
+
+lemma Mul_interfree_Mutator_Mutator: "\<lbrakk>i < n; j < n; i \<noteq> j\<rbrakk> \<Longrightarrow>
+ interfree_aux (Some (Mul_Mutator i n), {}, Some (Mul_Mutator j n))"
+apply(unfold Mul_Mutator_def)
+apply(interfree_aux)
+apply(simp_all add:mul_mutator_interfree)
+apply(simp_all add: mul_mutator_defs)
+apply(tactic {* TRYALL (interfree_aux_tac) *})
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+apply (simp_all add:nth_list_update)
+done
+
+subsubsection {* Modular Parameterized Mutators *}
+
+lemma Mul_Parameterized_Mutators: "0<n \<Longrightarrow>
+ \<parallel>- .{\<acute>Mul_mut_init n \<and> (\<forall>i<n. Z (\<acute>Muts!i))}.
+ COBEGIN
+ SCHEME [0\<le> j< n]
+ Mul_Mutator j n
+ .{False}.
+ COEND
+ .{False}."
+apply oghoare
+apply(force simp add:Mul_Mutator_def mul_mutator_defs nth_list_update)
+apply(erule Mul_Mutator)
+apply(simp add:Mul_interfree_Mutator_Mutator)
+apply(force simp add:Mul_Mutator_def mul_mutator_defs nth_list_update)
+done
+
+subsection {* The Collector *}
+
+constdefs
+ Queue :: "mul_gar_coll_state \<Rightarrow> nat"
+ "Queue \<equiv> \<guillemotleft> length (filter (\<lambda>i. \<not> Z i \<and> \<acute>M!(T i) \<noteq> Black) \<acute>Muts) \<guillemotright>"
+
+consts M_init :: nodes
+
+constdefs
+ Proper_M_init :: "mul_gar_coll_state \<Rightarrow> bool"
+ "Proper_M_init \<equiv> \<guillemotleft> Blacks M_init=Roots \<and> length M_init=length \<acute>M \<guillemotright>"
+
+ Mul_Proper :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
+ "Mul_Proper \<equiv> \<guillemotleft> \<lambda>n. Proper_Roots \<acute>M \<and> Proper_Edges (\<acute>M, \<acute>E) \<and> \<acute>Proper_M_init \<and> n=length \<acute>Muts \<guillemotright>"
+
+ Safe :: "mul_gar_coll_state \<Rightarrow> bool"
+ "Safe \<equiv> \<guillemotleft> Reach \<acute>E \<subseteq> Blacks \<acute>M \<guillemotright>"
+
+lemmas mul_collector_defs = Proper_M_init_def Mul_Proper_def Safe_def
+
+subsubsection {* Blackening Roots *}
+
+constdefs
+ Mul_Blacken_Roots :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Blacken_Roots n \<equiv>
+ .{\<acute>Mul_Proper n}.
+ \<acute>ind:=0;;
+ .{\<acute>Mul_Proper n \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>M
+ INV .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind\<le>length \<acute>M}.
+ DO .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
+ IF \<acute>ind\<in>Roots THEN
+ .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<in>Roots}.
+ \<acute>M:=\<acute>M[\<acute>ind:=Black] FI;;
+ .{\<acute>Mul_Proper n \<and> (\<forall>i<\<acute>ind+1. i\<in>Roots \<longrightarrow> \<acute>M!i=Black) \<and> \<acute>ind<length \<acute>M}.
+ \<acute>ind:=\<acute>ind+1
+ OD"
+
+lemma Mul_Blacken_Roots:
+ "\<turnstile> Mul_Blacken_Roots n
+ .{\<acute>Mul_Proper n \<and> Roots \<subseteq> Blacks \<acute>M}."
+apply (unfold Mul_Blacken_Roots_def)
+apply annhoare
+apply(simp_all add:mul_collector_defs Graph_defs)
+apply safe
+apply(simp_all add:nth_list_update)
+ apply (erule less_SucE)
+ apply simp+
+ apply force
+apply force
+done
+
+subsubsection {* Propagating Black *}
+
+constdefs
+ Mul_PBInv :: "mul_gar_coll_state \<Rightarrow> bool"
+ "Mul_PBInv \<equiv> \<guillemotleft>\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue
+ \<or> (\<forall>i<\<acute>ind. \<not>BtoW(\<acute>E!i,\<acute>M)) \<and> \<acute>l\<le>\<acute>Queue\<guillemotright>"
+
+ Mul_Auxk :: "mul_gar_coll_state \<Rightarrow> bool"
+ "Mul_Auxk \<equiv> \<guillemotleft>\<acute>l<\<acute>Queue \<or> \<acute>M!\<acute>k\<noteq>Black \<or> \<not>BtoW(\<acute>E!\<acute>ind, \<acute>M) \<or> \<acute>obc\<subset>Blacks \<acute>M\<guillemotright>"
+
+constdefs
+ Mul_Propagate_Black :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Propagate_Black n \<equiv>
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M)}.
+ \<acute>ind:=0;;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> Blacks \<acute>M\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M) \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>E
+ INV .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>Mul_PBInv \<and> \<acute>ind\<le>length \<acute>E}.
+ DO .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>Mul_PBInv \<and> \<acute>ind<length \<acute>E}.
+ IF \<acute>M!(fst (\<acute>E!\<acute>ind))=Black THEN
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>Mul_PBInv \<and> (\<acute>M!fst(\<acute>E!\<acute>ind))=Black \<and> \<acute>ind<length \<acute>E}.
+ \<acute>k:=snd(\<acute>E!\<acute>ind);;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue \<or> (\<forall>i<\<acute>ind. \<not>BtoW(\<acute>E!i,\<acute>M))
+ \<and> \<acute>l\<le>\<acute>Queue \<and> \<acute>Mul_Auxk ) \<and> \<acute>k<length \<acute>M \<and> \<acute>M!fst(\<acute>E!\<acute>ind)=Black
+ \<and> \<acute>ind<length \<acute>E}.
+ \<langle>\<acute>M:=\<acute>M[\<acute>k:=Black],,\<acute>ind:=\<acute>ind+1\<rangle>
+ ELSE .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> \<acute>Mul_PBInv \<and> \<acute>ind<length \<acute>E}.
+ \<langle>IF \<acute>M!(fst (\<acute>E!\<acute>ind))\<noteq>Black THEN \<acute>ind:=\<acute>ind+1 FI\<rangle> FI
+ OD"
+
+lemma Mul_Propagate_Black:
+ "\<turnstile> Mul_Propagate_Black n
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue \<and> (\<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))}."
+apply(unfold Mul_Propagate_Black_def)
+apply annhoare
+apply(simp_all add:Mul_PBInv_def mul_collector_defs Mul_Auxk_def Graph6 Graph7 Graph8 Graph12 mul_collector_defs Queue_def)
+--{* 8 subgoals left *}
+apply force
+apply force
+apply force
+apply(force simp add:BtoW_def Graph_defs)
+--{* 4 subgoals left *}
+apply clarify
+apply(simp add: mul_collector_defs Graph12 Graph6 Graph7 Graph8)
+apply(disjE_tac)
+ apply(simp_all add:Graph12 Graph13)
+ apply(case_tac "M x! k x=Black")
+ apply(simp add: Graph10)
+ apply(rule disjI2, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
+apply(case_tac "M x! k x=Black")
+ apply(simp add: Graph10 BtoW_def)
+ apply(rule disjI2, clarify, erule less_SucE, force)
+ apply(case_tac "M x!snd(E x! ind x)=Black")
+ apply(force)
+ apply(force)
+apply(rule disjI2, rule disjI1, erule subset_psubset_trans, erule Graph11, force)
+--{* 3 subgoals left *}
+apply force
+--{* 2 subgoals left *}
+apply clarify
+apply(conjI_tac)
+apply(disjE_tac)
+ apply (simp_all)
+apply clarify
+apply(erule less_SucE)
+ apply force
+apply (simp add:BtoW_def)
+--{* 1 subgoal left *}
+apply clarify
+apply simp
+apply(disjE_tac)
+apply (simp_all)
+apply(rule disjI1 , rule Graph1)
+ apply simp_all
+done
+
+subsubsection {* Counting Black Nodes *}
+
+constdefs
+ Mul_CountInv :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
+ "Mul_CountInv \<equiv> \<guillemotleft> \<lambda>ind. {i. i<ind \<and> \<acute>Ma!i=Black}\<subseteq>\<acute>bc \<guillemotright>"
+
+ Mul_Count :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Count n \<equiv>
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M) )
+ \<and> \<acute>q<n+1 \<and> \<acute>bc={}}.
+ \<acute>ind:=0;;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M) )
+ \<and> \<acute>q<n+1 \<and> \<acute>bc={} \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>M
+ INV .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv \<acute>ind
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1 \<and> \<acute>ind\<le>length \<acute>M}.
+ DO .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv \<acute>ind
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1 \<and> \<acute>ind<length \<acute>M}.
+ IF \<acute>M!\<acute>ind=Black
+ THEN .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv \<acute>ind
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1 \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
+ \<acute>bc:=insert \<acute>ind \<acute>bc
+ FI;;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> \<acute>Mul_CountInv (\<acute>ind+1)
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1 \<and> \<acute>ind<length \<acute>M}.
+ \<acute>ind:=\<acute>ind+1
+ OD"
+
+lemma Mul_Count:
+ "\<turnstile> Mul_Count n
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1}."
+apply (unfold Mul_Count_def)
+apply annhoare
+apply(simp_all add:Mul_CountInv_def mul_collector_defs Mul_Auxk_def Graph6 Graph7 Graph8 Graph12 mul_collector_defs Queue_def)
+--{* 7 subgoals left *}
+apply force
+apply force
+apply force
+--{* 4 subgoals left *}
+apply clarify
+apply(conjI_tac)
+apply(disjE_tac)
+ apply simp_all
+apply(simp add:Blacks_def)
+apply clarify
+apply(erule less_SucE)
+ back
+ apply force
+apply force
+--{* 3 subgoals left *}
+apply clarify
+apply(conjI_tac)
+apply(disjE_tac)
+ apply simp_all
+apply clarify
+apply(erule less_SucE)
+ back
+ apply force
+apply simp
+apply(rotate_tac -1)
+apply (force simp add:Blacks_def)
+--{* 2 subgoals left *}
+apply force
+--{* 1 subgoal left *}
+apply clarify
+apply(drule_tac x = "ind x" in le_imp_less_or_eq)
+apply (simp_all add:Blacks_def)
+done
+
+subsubsection {* Appending garbage nodes to the free list *}
+
+consts Append_to_free :: "nat \<times> edges \<Rightarrow> edges"
+
+axioms
+ Append_to_free0: "length (Append_to_free (i, e)) = length e"
+ Append_to_free1: "Proper_Edges (m, e)
+ \<Longrightarrow> Proper_Edges (m, Append_to_free(i, e))"
+ Append_to_free2: "i \<notin> Reach e
+ \<Longrightarrow> n \<in> Reach (Append_to_free(i, e)) = ( n = i \<or> n \<in> Reach e)"
+
+constdefs
+ Mul_AppendInv :: "mul_gar_coll_state \<Rightarrow> nat \<Rightarrow> bool"
+ "Mul_AppendInv \<equiv> \<guillemotleft> \<lambda>ind. (\<forall>i. ind\<le>i \<longrightarrow> i<length \<acute>M \<longrightarrow> i\<in>Reach \<acute>E \<longrightarrow> \<acute>M!i=Black)\<guillemotright>"
+
+ Mul_Append :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Append n \<equiv>
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe}.
+ \<acute>ind:=0;;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>Safe \<and> \<acute>ind=0}.
+ WHILE \<acute>ind<length \<acute>M
+ INV .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind\<le>length \<acute>M}.
+ DO .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M}.
+ IF \<acute>M!\<acute>ind=Black THEN
+ .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>M!\<acute>ind=Black}.
+ \<acute>M:=\<acute>M[\<acute>ind:=White]
+ ELSE
+ .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv \<acute>ind \<and> \<acute>ind<length \<acute>M \<and> \<acute>ind\<notin>Reach \<acute>E}.
+ \<acute>E:=Append_to_free(\<acute>ind,\<acute>E)
+ FI;;
+ .{\<acute>Mul_Proper n \<and> \<acute>Mul_AppendInv (\<acute>ind+1) \<and> \<acute>ind<length \<acute>M}.
+ \<acute>ind:=\<acute>ind+1
+ OD"
+
+lemma Mul_Append:
+ "\<turnstile> Mul_Append n
+ .{\<acute>Mul_Proper n}."
+apply(unfold Mul_Append_def)
+apply annhoare
+apply(simp_all add: mul_collector_defs Mul_AppendInv_def
+ Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
+apply(force simp add:Blacks_def)
+apply(force simp add:Blacks_def)
+apply(force simp add:Blacks_def)
+apply(force simp add:Graph_defs)
+apply force
+apply(force simp add:Append_to_free1 Append_to_free2)
+apply force
+apply force
+done
+
+subsubsection {* Collector *}
+
+constdefs
+ Mul_Collector :: "nat \<Rightarrow> mul_gar_coll_state ann_com"
+ "Mul_Collector n \<equiv>
+.{\<acute>Mul_Proper n}.
+WHILE True INV .{\<acute>Mul_Proper n}.
+DO
+Mul_Blacken_Roots n ;;
+.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M}.
+ \<acute>obc:={};;
+.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={}}.
+ \<acute>bc:=Roots;;
+.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots}.
+ \<acute>l:=0;;
+.{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>obc={} \<and> \<acute>bc=Roots \<and> \<acute>l=0}.
+ WHILE \<acute>l<n+1
+ INV .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M \<and>
+ (\<acute>Safe \<or> (\<acute>l\<le>\<acute>Queue \<or> \<acute>bc\<subset>Blacks \<acute>M) \<and> \<acute>l<n+1)}.
+ DO .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>l\<le>\<acute>Queue \<or> \<acute>bc\<subset>Blacks \<acute>M)}.
+ \<acute>obc:=\<acute>bc;;
+ Mul_Propagate_Black n;;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue
+ \<and> (\<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))}.
+ \<acute>bc:={};;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>M \<or> \<acute>l<\<acute>Queue
+ \<and> (\<acute>l\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M)) \<and> \<acute>bc={}}.
+ \<langle> \<acute>Ma:=\<acute>M,, \<acute>q:=\<acute>Queue \<rangle>;;
+ Mul_Count n;;
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1}.
+ IF \<acute>obc=\<acute>bc THEN
+ .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1 \<and> \<acute>obc=\<acute>bc}.
+ \<acute>l:=\<acute>l+1
+ ELSE .{\<acute>Mul_Proper n \<and> Roots\<subseteq>Blacks \<acute>M
+ \<and> \<acute>obc\<subseteq>Blacks \<acute>Ma \<and> Blacks \<acute>Ma\<subseteq>Blacks \<acute>M \<and> \<acute>bc\<subseteq>Blacks \<acute>M
+ \<and> length \<acute>Ma=length \<acute>M \<and> Blacks \<acute>Ma\<subseteq>\<acute>bc
+ \<and> (\<acute>Safe \<or> \<acute>obc\<subset>Blacks \<acute>Ma \<or> \<acute>l<\<acute>q \<and> (\<acute>q\<le>\<acute>Queue \<or> \<acute>obc\<subset>Blacks \<acute>M))
+ \<and> \<acute>q<n+1 \<and> \<acute>obc\<noteq>\<acute>bc}.
+ \<acute>l:=0 FI
+ OD;;
+ Mul_Append n
+OD"
+
+lemmas mul_modules = Mul_Redirect_Edge_def Mul_Color_Target_def
+ Mul_Blacken_Roots_def Mul_Propagate_Black_def
+ Mul_Count_def Mul_Append_def
+
+lemma Mul_Collector:
+ "\<turnstile> Mul_Collector n
+ .{False}."
+apply(unfold Mul_Collector_def)
+apply annhoare
+apply(simp_all only:pre.simps Mul_Blacken_Roots
+ Mul_Propagate_Black Mul_Count Mul_Append)
+apply(simp_all add:mul_modules)
+apply(simp_all add:mul_collector_defs Queue_def)
+apply force
+apply force
+apply force
+apply (force simp add: less_Suc_eq_le)
+apply force
+apply (force dest:subset_antisym)
+apply force
+apply force
+apply force
+done
+
+subsection {* Interference Freedom *}
+
+lemma le_length_filter_update[rule_format]:
+ "\<forall>i. (\<not>P (list!i) \<or> P j) \<and> i<length list
+ \<longrightarrow> length(filter P list) \<le> length(filter P (list[i:=j]))"
+apply(induct_tac "list")
+ apply(simp)
+apply(clarify)
+apply(case_tac i)
+ apply(simp)
+apply(simp)
+done
+
+lemma less_length_filter_update [rule_format]:
+ "\<forall>i. P j \<and> \<not>(P (list!i)) \<and> i<length list
+ \<longrightarrow> length(filter P list) < length(filter P (list[i:=j]))"
+apply(induct_tac "list")
+ apply(simp)
+apply(clarify)
+apply(case_tac i)
+ apply(simp)
+apply(simp)
+done
+
+lemma Mul_interfree_Blacken_Roots_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk> \<Longrightarrow>
+ interfree_aux (Some(Mul_Blacken_Roots n),{},Some(Mul_Redirect_Edge j n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:Graph6 Graph9 Graph12 nth_list_update mul_mutator_defs mul_collector_defs)
+done
+
+lemma Mul_interfree_Redirect_Edge_Blacken_Roots: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Redirect_Edge j n ),{},Some (Mul_Blacken_Roots n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Blacken_Roots_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Blacken_Roots n),{},Some (Mul_Color_Target j n ))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:mul_mutator_defs mul_collector_defs nth_list_update Graph7 Graph8 Graph9 Graph12)
+done
+
+lemma Mul_interfree_Color_Target_Blacken_Roots: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Color_Target j n ),{},Some (Mul_Blacken_Roots n ))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Propagate_Black_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Propagate_Black n),{},Some (Mul_Redirect_Edge j n ))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply(simp_all add:mul_mutator_defs mul_collector_defs Mul_PBInv_def nth_list_update Graph6)
+--{* 7 subgoals left *}
+apply clarify
+apply(disjE_tac)
+ apply(simp_all add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+--{* 6 subgoals left *}
+apply clarify
+apply(disjE_tac)
+ apply(simp_all add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+--{* 5 subgoals left *}
+apply clarify
+apply(disjE_tac)
+ apply(simp_all add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(erule conjE)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule conjI)
+ apply(rule impI,(rule disjI2)+,rule conjI)
+ apply clarify
+ apply(case_tac "R (Muts x! j)=i")
+ apply (force simp add: nth_list_update BtoW_def)
+ apply (force simp add: nth_list_update)
+ apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,(rule disjI2)+, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+--{* 4 subgoals left *}
+apply clarify
+apply(disjE_tac)
+ apply(simp_all add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(erule conjE)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule conjI)
+ apply(rule impI,(rule disjI2)+,rule conjI)
+ apply clarify
+ apply(case_tac "R (Muts x! j)=i")
+ apply (force simp add: nth_list_update BtoW_def)
+ apply (force simp add: nth_list_update)
+ apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,(rule disjI2)+, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+--{* 3 subgoals left *}
+apply clarify
+apply(disjE_tac)
+ apply(simp_all add:Graph6)
+ apply (rule impI)
+ apply(rule conjI)
+ apply(rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule conjI)
+ apply(rule impI)
+ apply(rule conjI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(rule impI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule conjI)
+ apply(rule impI)
+ apply(rule conjI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(rule impI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(erule conjE)
+ apply(rule conjI)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule impI,rule conjI,(rule disjI2)+,rule conjI)
+ apply clarify
+ apply(case_tac "R (Muts x! j)=i")
+ apply (force simp add: nth_list_update BtoW_def)
+ apply (force simp add: nth_list_update)
+ apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(rule impI,rule conjI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+ apply(case_tac "R (Muts x! j)=ind x")
+ apply (force simp add: nth_list_update)
+ apply (force simp add: nth_list_update)
+apply(rule impI, (rule disjI2)+, erule le_trans)
+apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+--{* 2 subgoals left *}
+apply clarify
+apply(rule conjI)
+ apply(disjE_tac)
+ apply(simp_all add:Mul_Auxk_def Graph6)
+ apply (rule impI)
+ apply(rule conjI)
+ apply(rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule impI)
+ apply(rule conjI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+ apply(rule impI)
+ apply(rule conjI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+apply(rule impI)
+apply(rule conjI)
+ apply(erule conjE)+
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply((rule disjI2)+,rule conjI)
+ apply clarify
+ apply(case_tac "R (Muts x! j)=i")
+ apply (force simp add: nth_list_update BtoW_def)
+ apply (force simp add: nth_list_update)
+ apply(rule conjI)
+ apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update BtoW_def)
+ apply (simp add:nth_list_update)
+ apply(rule impI)
+ apply simp
+ apply(disjE_tac)
+ apply(rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply force
+ apply(rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+ apply(case_tac "R (Muts x ! j)= ind x")
+ apply(simp add:nth_list_update)
+ apply(simp add:nth_list_update)
+apply(disjE_tac)
+apply simp_all
+apply(conjI_tac)
+ apply(rule impI)
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(erule conjE)+
+apply(rule impI,(rule disjI2)+,rule conjI)
+ apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule impI)+
+apply simp
+apply(disjE_tac)
+ apply(rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply force
+--{* 1 subgoal left *}
+apply clarify
+apply(disjE_tac)
+ apply(simp_all add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(erule conjE)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule conjI)
+ apply(rule impI,(rule disjI2)+,rule conjI)
+ apply clarify
+ apply(case_tac "R (Muts x! j)=i")
+ apply (force simp add: nth_list_update BtoW_def)
+ apply (force simp add: nth_list_update)
+ apply(erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,(rule disjI2)+, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+apply(rule impI,rule disjI2,rule disjI2,rule disjI1, erule le_less_trans)
+apply(force simp add:Queue_def less_Suc_eq_le less_length_filter_update)
+done
+
+lemma Mul_interfree_Redirect_Edge_Propagate_Black: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Redirect_Edge j n ),{},Some (Mul_Propagate_Black n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Propagate_Black_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Propagate_Black n),{},Some (Mul_Color_Target j n ))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply(simp_all add: mul_collector_defs mul_mutator_defs)
+--{* 7 subgoals left *}
+apply clarify
+apply (simp add:Graph7 Graph8 Graph12)
+apply(disjE_tac)
+ apply(simp add:Graph7 Graph8 Graph12)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,erule subset_psubset_trans, erule Graph11, simp)
+apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+--{* 6 subgoals left *}
+apply clarify
+apply (simp add:Graph7 Graph8 Graph12)
+apply(disjE_tac)
+ apply(simp add:Graph7 Graph8 Graph12)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,erule subset_psubset_trans, erule Graph11, simp)
+apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+--{* 5 subgoals left *}
+apply clarify
+apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
+apply(disjE_tac)
+ apply(simp add:Graph7 Graph8 Graph12)
+ apply(rule disjI2,rule disjI1, erule psubset_subset_trans,simp add:Graph9)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
+apply(erule conjE)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply((rule disjI2)+)
+ apply (rule conjI)
+ apply(simp add:Graph10)
+ apply(erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
+--{* 4 subgoals left *}
+apply clarify
+apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
+apply(disjE_tac)
+ apply(simp add:Graph7 Graph8 Graph12)
+ apply(rule disjI2,rule disjI1, erule psubset_subset_trans,simp add:Graph9)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2,rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
+apply(erule conjE)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply((rule disjI2)+)
+ apply (rule conjI)
+ apply(simp add:Graph10)
+ apply(erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+apply(rule disjI2,rule disjI1,erule subset_psubset_trans, erule Graph11, simp)
+--{* 3 subgoals left *}
+apply clarify
+apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(simp add:Graph10)
+ apply(disjE_tac)
+ apply simp_all
+ apply(rule disjI2, rule disjI2, rule disjI1,erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply(erule conjE)
+ apply((rule disjI2)+,erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+apply(rule conjI)
+ apply(rule disjI2,rule disjI1, erule subset_psubset_trans,simp add:Graph11)
+apply (force simp add:nth_list_update)
+--{* 2 subgoals left *}
+apply clarify
+apply(simp add:Mul_Auxk_def Graph7 Graph8 Graph12)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(simp add:Graph10)
+ apply(disjE_tac)
+ apply simp_all
+ apply(rule disjI2, rule disjI2, rule disjI1,erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply(erule conjE)+
+ apply((rule disjI2)+,rule conjI, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule impI)+)
+ apply simp
+ apply(erule disjE)
+ apply(rule disjI1, erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply force
+apply(rule conjI)
+ apply(rule disjI2,rule disjI1, erule subset_psubset_trans,simp add:Graph11)
+apply (force simp add:nth_list_update)
+--{* 1 subgoal left *}
+apply clarify
+apply (simp add:mul_collector_defs Mul_PBInv_def Graph7 Graph8 Graph12)
+apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(simp add:Graph10)
+ apply(disjE_tac)
+ apply simp_all
+ apply(rule disjI2, rule disjI2, rule disjI1,erule less_le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply(erule conjE)
+ apply((rule disjI2)+,erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+apply(rule disjI2,rule disjI1, erule subset_psubset_trans,simp add:Graph11)
+done
+
+lemma Mul_interfree_Color_Target_Propagate_Black: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Color_Target j n),{},Some(Mul_Propagate_Black n ))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Count_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Count n ),{},Some(Mul_Redirect_Edge j n))"
+apply (unfold mul_modules)
+apply interfree_aux
+--{* 9 subgoals left *}
+apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def Graph6)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(simp add:Graph6)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(simp add:Graph6)
+--{* 8 subgoals left *}
+apply(simp add:mul_mutator_defs nth_list_update)
+--{* 7 subgoals left *}
+apply(simp add:mul_mutator_defs mul_collector_defs)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(simp add:Graph6)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(simp add:Graph6)
+--{* 6 subgoals left *}
+apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6 Queue_def)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(simp add:Graph6)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(simp add:Graph6)
+--{* 5 subgoals left *}
+apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(simp add:Graph6)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(simp add:Graph6)
+--{* 4 subgoals left *}
+apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(simp add:Graph6)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(simp add:Graph6)
+--{* 3 subgoals left *}
+apply(simp add:mul_mutator_defs nth_list_update)
+--{* 2 subgoals left *}
+apply(simp add:mul_mutator_defs mul_collector_defs Mul_CountInv_def)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule impI,rule disjI1,rule subset_trans,erule Graph3,simp,simp)
+ apply(simp add:Graph6)
+apply clarify
+apply disjE_tac
+ apply(simp add:Graph6)
+ apply(rule conjI)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+ apply(rule impI,rule disjI2,rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(simp add:Graph6)
+--{* 1 subgoal left *}
+apply(simp add:mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Redirect_Edge_Count: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Redirect_Edge j n),{},Some(Mul_Count n ))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Count_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Count n ),{},Some(Mul_Color_Target j n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply(simp_all add:mul_collector_defs mul_mutator_defs Mul_CountInv_def)
+--{* 6 subgoals left *}
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply (simp add: Graph7 Graph8 Graph12)
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
+apply (simp add: Graph7 Graph8 Graph12)
+apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+--{* 5 subgoals left *}
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply (simp add: Graph7 Graph8 Graph12)
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
+apply (simp add: Graph7 Graph8 Graph12)
+apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+--{* 4 subgoals left *}
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply (simp add: Graph7 Graph8 Graph12)
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
+apply (simp add: Graph7 Graph8 Graph12)
+apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+--{* 3 subgoals left *}
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply (simp add: Graph7 Graph8 Graph12)
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
+apply (simp add: Graph7 Graph8 Graph12)
+apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+--{* 2 subgoals left *}
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12 nth_list_update)
+ apply (simp add: Graph7 Graph8 Graph12 nth_list_update)
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply(rule conjI)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
+ apply (simp add: nth_list_update)
+apply (simp add: Graph7 Graph8 Graph12)
+apply(rule conjI)
+ apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+apply (simp add: nth_list_update)
+--{* 1 subgoal left *}
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply (simp add: Graph7 Graph8 Graph12)
+apply clarify
+apply disjE_tac
+ apply (simp add: Graph7 Graph8 Graph12)
+ apply(case_tac "M x!(T (Muts x!j))=Black")
+ apply(rule disjI2,rule disjI2, rule disjI1, erule le_trans)
+ apply(force simp add:Queue_def less_Suc_eq_le le_length_filter_update Graph10)
+ apply((rule disjI2)+,(erule subset_psubset_trans)+, simp add: Graph11)
+apply (simp add: Graph7 Graph8 Graph12)
+apply((rule disjI2)+,erule psubset_subset_trans, simp add: Graph9)
+done
+
+lemma Mul_interfree_Color_Target_Count: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Color_Target j n),{}, Some(Mul_Count n ))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply safe
+apply(simp_all add:mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Append_Redirect_Edge: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Append n),{}, Some(Mul_Redirect_Edge j n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+apply(simp_all add:Graph6 Append_to_free0 Append_to_free1 mul_collector_defs mul_mutator_defs Mul_AppendInv_def)
+apply(erule_tac x=j in allE, force dest:Graph3)+
+done
+
+lemma Mul_interfree_Redirect_Edge_Append: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Redirect_Edge j n),{},Some(Mul_Append n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+apply(simp_all add:mul_collector_defs Append_to_free0 Mul_AppendInv_def mul_mutator_defs nth_list_update)
+done
+
+lemma Mul_interfree_Append_Color_Target: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Append n),{}, Some(Mul_Color_Target j n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+apply(simp_all add:mul_mutator_defs mul_collector_defs Mul_AppendInv_def Graph7 Graph8 Append_to_free0 Append_to_free1
+ Graph12 nth_list_update)
+done
+
+lemma Mul_interfree_Color_Target_Append: "\<lbrakk>0\<le>j; j<n\<rbrakk>\<Longrightarrow>
+ interfree_aux (Some(Mul_Color_Target j n),{}, Some(Mul_Append n))"
+apply (unfold mul_modules)
+apply interfree_aux
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+apply(simp_all add: mul_mutator_defs nth_list_update)
+apply(simp add:Mul_AppendInv_def Append_to_free0)
+done
+
+subsubsection {* Interference freedom Collector-Mutator *}
+
+lemmas mul_collector_mutator_interfree =
+ Mul_interfree_Blacken_Roots_Redirect_Edge Mul_interfree_Blacken_Roots_Color_Target
+ Mul_interfree_Propagate_Black_Redirect_Edge Mul_interfree_Propagate_Black_Color_Target
+ Mul_interfree_Count_Redirect_Edge Mul_interfree_Count_Color_Target
+ Mul_interfree_Append_Redirect_Edge Mul_interfree_Append_Color_Target
+ Mul_interfree_Redirect_Edge_Blacken_Roots Mul_interfree_Color_Target_Blacken_Roots
+ Mul_interfree_Redirect_Edge_Propagate_Black Mul_interfree_Color_Target_Propagate_Black
+ Mul_interfree_Redirect_Edge_Count Mul_interfree_Color_Target_Count
+ Mul_interfree_Redirect_Edge_Append Mul_interfree_Color_Target_Append
+
+lemma Mul_interfree_Collector_Mutator: "j<n \<Longrightarrow>
+ interfree_aux (Some (Mul_Collector n), {}, Some (Mul_Mutator j n))"
+apply(unfold Mul_Collector_def Mul_Mutator_def)
+apply interfree_aux
+apply(simp_all add:mul_collector_mutator_interfree)
+apply(unfold mul_modules mul_collector_defs mul_mutator_defs)
+apply(tactic {* TRYALL (interfree_aux_tac) *})
+--{* 42 subgoals left *}
+apply (clarify,simp add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)+
+--{* 24 subgoals left *}
+apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
+--{* 14 subgoals left *}
+apply(tactic {* TRYALL (clarify_tac @{claset}) *})
+apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
+apply(tactic {* TRYALL (rtac conjI) *})
+apply(tactic {* TRYALL (rtac impI) *})
+apply(tactic {* TRYALL (etac disjE) *})
+apply(tactic {* TRYALL (etac conjE) *})
+apply(tactic {* TRYALL (etac disjE) *})
+apply(tactic {* TRYALL (etac disjE) *})
+--{* 72 subgoals left *}
+apply(simp_all add:Graph6 Graph7 Graph8 Append_to_free0 Append_to_free1 Graph12)
+--{* 35 subgoals left *}
+apply(tactic {* TRYALL(EVERY'[rtac disjI1,rtac subset_trans,etac @{thm Graph3},force_tac @{clasimpset}, assume_tac]) *})
+--{* 28 subgoals left *}
+apply(tactic {* TRYALL (etac conjE) *})
+apply(tactic {* TRYALL (etac disjE) *})
+--{* 34 subgoals left *}
+apply(rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(rule disjI2,rule disjI1,erule le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update)
+apply(case_tac [!] "M x!(T (Muts x ! j))=Black")
+apply(simp_all add:Graph10)
+--{* 47 subgoals left *}
+apply(tactic {* TRYALL(EVERY'[REPEAT o (rtac disjI2),etac (thm "subset_psubset_trans"),etac (thm "Graph11"),force_tac @{clasimpset}]) *})
+--{* 41 subgoals left *}
+apply(tactic {* TRYALL(EVERY'[rtac disjI2, rtac disjI1, etac @{thm le_trans}, force_tac (@{claset},@{simpset} addsimps [@{thm Queue_def}, @{thm less_Suc_eq_le}, @{thm le_length_filter_update}])]) *})
+--{* 35 subgoals left *}
+apply(tactic {* TRYALL(EVERY'[rtac disjI2,rtac disjI1,etac (thm "psubset_subset_trans"),rtac (thm "Graph9"),force_tac @{clasimpset}]) *})
+--{* 31 subgoals left *}
+apply(tactic {* TRYALL(EVERY'[rtac disjI2,rtac disjI1,etac (thm "subset_psubset_trans"),etac (thm "Graph11"),force_tac @{clasimpset}]) *})
+--{* 29 subgoals left *}
+apply(tactic {* TRYALL(EVERY'[REPEAT o (rtac disjI2),etac (thm "subset_psubset_trans"),etac (thm "subset_psubset_trans"),etac (thm "Graph11"),force_tac @{clasimpset}]) *})
+--{* 25 subgoals left *}
+apply(tactic {* TRYALL(EVERY'[rtac disjI2, rtac disjI2, rtac disjI1, etac @{thm le_trans}, force_tac (@{claset},@{simpset} addsimps [@{thm Queue_def}, @{thm less_Suc_eq_le}, @{thm le_length_filter_update}])]) *})
+--{* 10 subgoals left *}
+apply(rule disjI2,rule disjI2,rule conjI,erule less_le_trans,force simp add:Queue_def less_Suc_eq_le le_length_filter_update, rule disjI1, rule less_imp_le, erule less_le_trans, force simp add:Queue_def less_Suc_eq_le le_length_filter_update)+
+done
+
+subsubsection {* Interference freedom Mutator-Collector *}
+
+lemma Mul_interfree_Mutator_Collector: " j < n \<Longrightarrow>
+ interfree_aux (Some (Mul_Mutator j n), {}, Some (Mul_Collector n))"
+apply(unfold Mul_Collector_def Mul_Mutator_def)
+apply interfree_aux
+apply(simp_all add:mul_collector_mutator_interfree)
+apply(unfold mul_modules mul_collector_defs mul_mutator_defs)
+apply(tactic {* TRYALL (interfree_aux_tac) *})
+--{* 76 subgoals left *}
+apply (clarify,simp add: nth_list_update)+
+--{* 56 subgoals left *}
+apply(clarify,simp add:Mul_AppendInv_def Append_to_free0 nth_list_update)+
+done
+
+subsubsection {* The Multi-Mutator Garbage Collection Algorithm *}
+
+text {* The total number of verification conditions is 328 *}
+
+lemma Mul_Gar_Coll:
+ "\<parallel>- .{\<acute>Mul_Proper n \<and> \<acute>Mul_mut_init n \<and> (\<forall>i<n. Z (\<acute>Muts!i))}.
+ COBEGIN
+ Mul_Collector n
+ .{False}.
+ \<parallel>
+ SCHEME [0\<le> j< n]
+ Mul_Mutator j n
+ .{False}.
+ COEND
+ .{False}."
+apply oghoare
+--{* Strengthening the precondition *}
+apply(rule Int_greatest)
+ apply (case_tac n)
+ apply(force simp add: Mul_Collector_def mul_mutator_defs mul_collector_defs nth_append)
+ apply(simp add: Mul_Mutator_def mul_collector_defs mul_mutator_defs nth_append)
+ apply force
+apply clarify
+apply(case_tac i)
+ apply(simp add:Mul_Collector_def mul_mutator_defs mul_collector_defs nth_append)
+apply(simp add: Mul_Mutator_def mul_mutator_defs mul_collector_defs nth_append nth_map_upt)
+--{* Collector *}
+apply(rule Mul_Collector)
+--{* Mutator *}
+apply(erule Mul_Mutator)
+--{* Interference freedom *}
+apply(simp add:Mul_interfree_Collector_Mutator)
+apply(simp add:Mul_interfree_Mutator_Collector)
+apply(simp add:Mul_interfree_Mutator_Mutator)
+--{* Weakening of the postcondition *}
+apply(case_tac n)
+ apply(simp add:Mul_Collector_def mul_mutator_defs mul_collector_defs nth_append)
+apply(simp add:Mul_Mutator_def mul_mutator_defs mul_collector_defs nth_append)
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/OG_Com.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,55 @@
+
+header {* \chapter{The Owicki-Gries Method}
+
+\section{Abstract Syntax} *}
+
+theory OG_Com imports Main begin
+
+text {* Type abbreviations for boolean expressions and assertions: *}
+
+types
+ 'a bexp = "'a set"
+ 'a assn = "'a set"
+
+text {* The syntax of commands is defined by two mutually recursive
+datatypes: @{text "'a ann_com"} for annotated commands and @{text "'a
+com"} for non-annotated commands. *}
+
+datatype 'a ann_com =
+ AnnBasic "('a assn)" "('a \<Rightarrow> 'a)"
+ | AnnSeq "('a ann_com)" "('a ann_com)"
+ | AnnCond1 "('a assn)" "('a bexp)" "('a ann_com)" "('a ann_com)"
+ | AnnCond2 "('a assn)" "('a bexp)" "('a ann_com)"
+ | AnnWhile "('a assn)" "('a bexp)" "('a assn)" "('a ann_com)"
+ | AnnAwait "('a assn)" "('a bexp)" "('a com)"
+and 'a com =
+ Parallel "('a ann_com option \<times> 'a assn) list"
+ | Basic "('a \<Rightarrow> 'a)"
+ | Seq "('a com)" "('a com)"
+ | Cond "('a bexp)" "('a com)" "('a com)"
+ | While "('a bexp)" "('a assn)" "('a com)"
+
+text {* The function @{text pre} extracts the precondition of an
+annotated command: *}
+
+consts
+ pre ::"'a ann_com \<Rightarrow> 'a assn"
+primrec
+ "pre (AnnBasic r f) = r"
+ "pre (AnnSeq c1 c2) = pre c1"
+ "pre (AnnCond1 r b c1 c2) = r"
+ "pre (AnnCond2 r b c) = r"
+ "pre (AnnWhile r b i c) = r"
+ "pre (AnnAwait r b c) = r"
+
+text {* Well-formedness predicate for atomic programs: *}
+
+consts atom_com :: "'a com \<Rightarrow> bool"
+primrec
+ "atom_com (Parallel Ts) = False"
+ "atom_com (Basic f) = True"
+ "atom_com (Seq c1 c2) = (atom_com c1 \<and> atom_com c2)"
+ "atom_com (Cond b c1 c2) = (atom_com c1 \<and> atom_com c2)"
+ "atom_com (While b i c) = atom_com c"
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/OG_Examples.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,549 @@
+
+header {* \section{Examples} *}
+
+theory OG_Examples imports OG_Syntax begin
+
+subsection {* Mutual Exclusion *}
+
+subsubsection {* Peterson's Algorithm I*}
+
+text {* Eike Best. "Semantics of Sequential and Parallel Programs", page 217. *}
+
+record Petersons_mutex_1 =
+ pr1 :: nat
+ pr2 :: nat
+ in1 :: bool
+ in2 :: bool
+ hold :: nat
+
+lemma Petersons_mutex_1:
+ "\<parallel>- .{\<acute>pr1=0 \<and> \<not>\<acute>in1 \<and> \<acute>pr2=0 \<and> \<not>\<acute>in2 }.
+ COBEGIN .{\<acute>pr1=0 \<and> \<not>\<acute>in1}.
+ WHILE True INV .{\<acute>pr1=0 \<and> \<not>\<acute>in1}.
+ DO
+ .{\<acute>pr1=0 \<and> \<not>\<acute>in1}. \<langle> \<acute>in1:=True,,\<acute>pr1:=1 \<rangle>;;
+ .{\<acute>pr1=1 \<and> \<acute>in1}. \<langle> \<acute>hold:=1,,\<acute>pr1:=2 \<rangle>;;
+ .{\<acute>pr1=2 \<and> \<acute>in1 \<and> (\<acute>hold=1 \<or> \<acute>hold=2 \<and> \<acute>pr2=2)}.
+ AWAIT (\<not>\<acute>in2 \<or> \<not>(\<acute>hold=1)) THEN \<acute>pr1:=3 END;;
+ .{\<acute>pr1=3 \<and> \<acute>in1 \<and> (\<acute>hold=1 \<or> \<acute>hold=2 \<and> \<acute>pr2=2)}.
+ \<langle>\<acute>in1:=False,,\<acute>pr1:=0\<rangle>
+ OD .{\<acute>pr1=0 \<and> \<not>\<acute>in1}.
+ \<parallel>
+ .{\<acute>pr2=0 \<and> \<not>\<acute>in2}.
+ WHILE True INV .{\<acute>pr2=0 \<and> \<not>\<acute>in2}.
+ DO
+ .{\<acute>pr2=0 \<and> \<not>\<acute>in2}. \<langle> \<acute>in2:=True,,\<acute>pr2:=1 \<rangle>;;
+ .{\<acute>pr2=1 \<and> \<acute>in2}. \<langle> \<acute>hold:=2,,\<acute>pr2:=2 \<rangle>;;
+ .{\<acute>pr2=2 \<and> \<acute>in2 \<and> (\<acute>hold=2 \<or> (\<acute>hold=1 \<and> \<acute>pr1=2))}.
+ AWAIT (\<not>\<acute>in1 \<or> \<not>(\<acute>hold=2)) THEN \<acute>pr2:=3 END;;
+ .{\<acute>pr2=3 \<and> \<acute>in2 \<and> (\<acute>hold=2 \<or> (\<acute>hold=1 \<and> \<acute>pr1=2))}.
+ \<langle>\<acute>in2:=False,,\<acute>pr2:=0\<rangle>
+ OD .{\<acute>pr2=0 \<and> \<not>\<acute>in2}.
+ COEND
+ .{\<acute>pr1=0 \<and> \<not>\<acute>in1 \<and> \<acute>pr2=0 \<and> \<not>\<acute>in2}."
+apply oghoare
+--{* 104 verification conditions. *}
+apply auto
+done
+
+subsubsection {*Peterson's Algorithm II: A Busy Wait Solution *}
+
+text {* Apt and Olderog. "Verification of sequential and concurrent Programs", page 282. *}
+
+record Busy_wait_mutex =
+ flag1 :: bool
+ flag2 :: bool
+ turn :: nat
+ after1 :: bool
+ after2 :: bool
+
+lemma Busy_wait_mutex:
+ "\<parallel>- .{True}.
+ \<acute>flag1:=False,, \<acute>flag2:=False,,
+ COBEGIN .{\<not>\<acute>flag1}.
+ WHILE True
+ INV .{\<not>\<acute>flag1}.
+ DO .{\<not>\<acute>flag1}. \<langle> \<acute>flag1:=True,,\<acute>after1:=False \<rangle>;;
+ .{\<acute>flag1 \<and> \<not>\<acute>after1}. \<langle> \<acute>turn:=1,,\<acute>after1:=True \<rangle>;;
+ .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
+ WHILE \<not>(\<acute>flag2 \<longrightarrow> \<acute>turn=2)
+ INV .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
+ DO .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}. SKIP OD;;
+ .{\<acute>flag1 \<and> \<acute>after1 \<and> (\<acute>flag2 \<and> \<acute>after2 \<longrightarrow> \<acute>turn=2)}.
+ \<acute>flag1:=False
+ OD
+ .{False}.
+ \<parallel>
+ .{\<not>\<acute>flag2}.
+ WHILE True
+ INV .{\<not>\<acute>flag2}.
+ DO .{\<not>\<acute>flag2}. \<langle> \<acute>flag2:=True,,\<acute>after2:=False \<rangle>;;
+ .{\<acute>flag2 \<and> \<not>\<acute>after2}. \<langle> \<acute>turn:=2,,\<acute>after2:=True \<rangle>;;
+ .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
+ WHILE \<not>(\<acute>flag1 \<longrightarrow> \<acute>turn=1)
+ INV .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}.
+ DO .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>turn=1 \<or> \<acute>turn=2)}. SKIP OD;;
+ .{\<acute>flag2 \<and> \<acute>after2 \<and> (\<acute>flag1 \<and> \<acute>after1 \<longrightarrow> \<acute>turn=1)}.
+ \<acute>flag2:=False
+ OD
+ .{False}.
+ COEND
+ .{False}."
+apply oghoare
+--{* 122 vc *}
+apply auto
+done
+
+subsubsection {* Peterson's Algorithm III: A Solution using Semaphores *}
+
+record Semaphores_mutex =
+ out :: bool
+ who :: nat
+
+lemma Semaphores_mutex:
+ "\<parallel>- .{i\<noteq>j}.
+ \<acute>out:=True ,,
+ COBEGIN .{i\<noteq>j}.
+ WHILE True INV .{i\<noteq>j}.
+ DO .{i\<noteq>j}. AWAIT \<acute>out THEN \<acute>out:=False,, \<acute>who:=i END;;
+ .{\<not>\<acute>out \<and> \<acute>who=i \<and> i\<noteq>j}. \<acute>out:=True OD
+ .{False}.
+ \<parallel>
+ .{i\<noteq>j}.
+ WHILE True INV .{i\<noteq>j}.
+ DO .{i\<noteq>j}. AWAIT \<acute>out THEN \<acute>out:=False,,\<acute>who:=j END;;
+ .{\<not>\<acute>out \<and> \<acute>who=j \<and> i\<noteq>j}. \<acute>out:=True OD
+ .{False}.
+ COEND
+ .{False}."
+apply oghoare
+--{* 38 vc *}
+apply auto
+done
+
+subsubsection {* Peterson's Algorithm III: Parameterized version: *}
+
+lemma Semaphores_parameterized_mutex:
+ "0<n \<Longrightarrow> \<parallel>- .{True}.
+ \<acute>out:=True ,,
+ COBEGIN
+ SCHEME [0\<le> i< n]
+ .{True}.
+ WHILE True INV .{True}.
+ DO .{True}. AWAIT \<acute>out THEN \<acute>out:=False,, \<acute>who:=i END;;
+ .{\<not>\<acute>out \<and> \<acute>who=i}. \<acute>out:=True OD
+ .{False}.
+ COEND
+ .{False}."
+apply oghoare
+--{* 20 vc *}
+apply auto
+done
+
+subsubsection{* The Ticket Algorithm *}
+
+record Ticket_mutex =
+ num :: nat
+ nextv :: nat
+ turn :: "nat list"
+ index :: nat
+
+lemma Ticket_mutex:
+ "\<lbrakk> 0<n; I=\<guillemotleft>n=length \<acute>turn \<and> 0<\<acute>nextv \<and> (\<forall>k l. k<n \<and> l<n \<and> k\<noteq>l
+ \<longrightarrow> \<acute>turn!k < \<acute>num \<and> (\<acute>turn!k =0 \<or> \<acute>turn!k\<noteq>\<acute>turn!l))\<guillemotright> \<rbrakk>
+ \<Longrightarrow> \<parallel>- .{n=length \<acute>turn}.
+ \<acute>index:= 0,,
+ WHILE \<acute>index < n INV .{n=length \<acute>turn \<and> (\<forall>i<\<acute>index. \<acute>turn!i=0)}.
+ DO \<acute>turn:= \<acute>turn[\<acute>index:=0],, \<acute>index:=\<acute>index +1 OD,,
+ \<acute>num:=1 ,, \<acute>nextv:=1 ,,
+ COBEGIN
+ SCHEME [0\<le> i< n]
+ .{\<acute>I}.
+ WHILE True INV .{\<acute>I}.
+ DO .{\<acute>I}. \<langle> \<acute>turn :=\<acute>turn[i:=\<acute>num],, \<acute>num:=\<acute>num+1 \<rangle>;;
+ .{\<acute>I}. WAIT \<acute>turn!i=\<acute>nextv END;;
+ .{\<acute>I \<and> \<acute>turn!i=\<acute>nextv}. \<acute>nextv:=\<acute>nextv+1
+ OD
+ .{False}.
+ COEND
+ .{False}."
+apply oghoare
+--{* 35 vc *}
+apply simp_all
+--{* 21 vc *}
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+--{* 11 vc *}
+apply simp_all
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+--{* 10 subgoals left *}
+apply(erule less_SucE)
+ apply simp
+apply simp
+--{* 9 subgoals left *}
+apply(case_tac "i=k")
+ apply force
+apply simp
+apply(case_tac "i=l")
+ apply force
+apply force
+--{* 8 subgoals left *}
+prefer 8
+apply force
+apply force
+--{* 6 subgoals left *}
+prefer 6
+apply(erule_tac x=i in allE)
+apply fastsimp
+--{* 5 subgoals left *}
+prefer 5
+apply(case_tac [!] "j=k")
+--{* 10 subgoals left *}
+apply simp_all
+apply(erule_tac x=k in allE)
+apply force
+--{* 9 subgoals left *}
+apply(case_tac "j=l")
+ apply simp
+ apply(erule_tac x=k in allE)
+ apply(erule_tac x=k in allE)
+ apply(erule_tac x=l in allE)
+ apply force
+apply(erule_tac x=k in allE)
+apply(erule_tac x=k in allE)
+apply(erule_tac x=l in allE)
+apply force
+--{* 8 subgoals left *}
+apply force
+apply(case_tac "j=l")
+ apply simp
+apply(erule_tac x=k in allE)
+apply(erule_tac x=l in allE)
+apply force
+apply force
+apply force
+--{* 5 subgoals left *}
+apply(erule_tac x=k in allE)
+apply(erule_tac x=l in allE)
+apply(case_tac "j=l")
+ apply force
+apply force
+apply force
+--{* 3 subgoals left *}
+apply(erule_tac x=k in allE)
+apply(erule_tac x=l in allE)
+apply(case_tac "j=l")
+ apply force
+apply force
+apply force
+--{* 1 subgoals left *}
+apply(erule_tac x=k in allE)
+apply(erule_tac x=l in allE)
+apply(case_tac "j=l")
+ apply force
+apply force
+done
+
+subsection{* Parallel Zero Search *}
+
+text {* Synchronized Zero Search. Zero-6 *}
+
+text {*Apt and Olderog. "Verification of sequential and concurrent Programs" page 294: *}
+
+record Zero_search =
+ turn :: nat
+ found :: bool
+ x :: nat
+ y :: nat
+
+lemma Zero_search:
+ "\<lbrakk>I1= \<guillemotleft> a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
+ \<and> (\<not>\<acute>found \<and> a<\<acute> x \<longrightarrow> f(\<acute>x)\<noteq>0) \<guillemotright> ;
+ I2= \<guillemotleft>\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
+ \<and> (\<not>\<acute>found \<and> \<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0) \<guillemotright> \<rbrakk> \<Longrightarrow>
+ \<parallel>- .{\<exists> u. f(u)=0}.
+ \<acute>turn:=1,, \<acute>found:= False,,
+ \<acute>x:=a,, \<acute>y:=a+1 ,,
+ COBEGIN .{\<acute>I1}.
+ WHILE \<not>\<acute>found
+ INV .{\<acute>I1}.
+ DO .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
+ WAIT \<acute>turn=1 END;;
+ .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
+ \<acute>turn:=2;;
+ .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
+ \<langle> \<acute>x:=\<acute>x+1,,
+ IF f(\<acute>x)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
+ OD;;
+ .{\<acute>I1 \<and> \<acute>found}.
+ \<acute>turn:=2
+ .{\<acute>I1 \<and> \<acute>found}.
+ \<parallel>
+ .{\<acute>I2}.
+ WHILE \<not>\<acute>found
+ INV .{\<acute>I2}.
+ DO .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
+ WAIT \<acute>turn=2 END;;
+ .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
+ \<acute>turn:=1;;
+ .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
+ \<langle> \<acute>y:=(\<acute>y - 1),,
+ IF f(\<acute>y)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
+ OD;;
+ .{\<acute>I2 \<and> \<acute>found}.
+ \<acute>turn:=1
+ .{\<acute>I2 \<and> \<acute>found}.
+ COEND
+ .{f(\<acute>x)=0 \<or> f(\<acute>y)=0}."
+apply oghoare
+--{* 98 verification conditions *}
+apply auto
+--{* auto takes about 3 minutes !! *}
+done
+
+text {* Easier Version: without AWAIT. Apt and Olderog. page 256: *}
+
+lemma Zero_Search_2:
+"\<lbrakk>I1=\<guillemotleft> a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
+ \<and> (\<not>\<acute>found \<and> a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)\<guillemotright>;
+ I2= \<guillemotleft>\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> (a<\<acute>x \<and> f(\<acute>x)=0) \<or> (\<acute>y\<le>a \<and> f(\<acute>y)=0))
+ \<and> (\<not>\<acute>found \<and> \<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)\<guillemotright>\<rbrakk> \<Longrightarrow>
+ \<parallel>- .{\<exists>u. f(u)=0}.
+ \<acute>found:= False,,
+ \<acute>x:=a,, \<acute>y:=a+1,,
+ COBEGIN .{\<acute>I1}.
+ WHILE \<not>\<acute>found
+ INV .{\<acute>I1}.
+ DO .{a\<le>\<acute>x \<and> (\<acute>found \<longrightarrow> \<acute>y\<le>a \<and> f(\<acute>y)=0) \<and> (a<\<acute>x \<longrightarrow> f(\<acute>x)\<noteq>0)}.
+ \<langle> \<acute>x:=\<acute>x+1,,IF f(\<acute>x)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
+ OD
+ .{\<acute>I1 \<and> \<acute>found}.
+ \<parallel>
+ .{\<acute>I2}.
+ WHILE \<not>\<acute>found
+ INV .{\<acute>I2}.
+ DO .{\<acute>y\<le>a+1 \<and> (\<acute>found \<longrightarrow> a<\<acute>x \<and> f(\<acute>x)=0) \<and> (\<acute>y\<le>a \<longrightarrow> f(\<acute>y)\<noteq>0)}.
+ \<langle> \<acute>y:=(\<acute>y - 1),,IF f(\<acute>y)=0 THEN \<acute>found:=True ELSE SKIP FI\<rangle>
+ OD
+ .{\<acute>I2 \<and> \<acute>found}.
+ COEND
+ .{f(\<acute>x)=0 \<or> f(\<acute>y)=0}."
+apply oghoare
+--{* 20 vc *}
+apply auto
+--{* auto takes aprox. 2 minutes. *}
+done
+
+subsection {* Producer/Consumer *}
+
+subsubsection {* Previous lemmas *}
+
+lemma nat_lemma2: "\<lbrakk> b = m*(n::nat) + t; a = s*n + u; t=u; b-a < n \<rbrakk> \<Longrightarrow> m \<le> s"
+proof -
+ assume "b = m*(n::nat) + t" "a = s*n + u" "t=u"
+ hence "(m - s) * n = b - a" by (simp add: diff_mult_distrib)
+ also assume "\<dots> < n"
+ finally have "m - s < 1" by simp
+ thus ?thesis by arith
+qed
+
+lemma mod_lemma: "\<lbrakk> (c::nat) \<le> a; a < b; b - c < n \<rbrakk> \<Longrightarrow> b mod n \<noteq> a mod n"
+apply(subgoal_tac "b=b div n*n + b mod n" )
+ prefer 2 apply (simp add: mod_div_equality [symmetric])
+apply(subgoal_tac "a=a div n*n + a mod n")
+ prefer 2
+ apply(simp add: mod_div_equality [symmetric])
+apply(subgoal_tac "b - a \<le> b - c")
+ prefer 2 apply arith
+apply(drule le_less_trans)
+back
+ apply assumption
+apply(frule less_not_refl2)
+apply(drule less_imp_le)
+apply (drule_tac m = "a" and k = n in div_le_mono)
+apply(safe)
+apply(frule_tac b = "b" and a = "a" and n = "n" in nat_lemma2, assumption, assumption)
+apply assumption
+apply(drule order_antisym, assumption)
+apply(rotate_tac -3)
+apply(simp)
+done
+
+
+subsubsection {* Producer/Consumer Algorithm *}
+
+record Producer_consumer =
+ ins :: nat
+ outs :: nat
+ li :: nat
+ lj :: nat
+ vx :: nat
+ vy :: nat
+ buffer :: "nat list"
+ b :: "nat list"
+
+text {* The whole proof takes aprox. 4 minutes. *}
+
+lemma Producer_consumer:
+ "\<lbrakk>INIT= \<guillemotleft>0<length a \<and> 0<length \<acute>buffer \<and> length \<acute>b=length a\<guillemotright> ;
+ I= \<guillemotleft>(\<forall>k<\<acute>ins. \<acute>outs\<le>k \<longrightarrow> (a ! k) = \<acute>buffer ! (k mod (length \<acute>buffer))) \<and>
+ \<acute>outs\<le>\<acute>ins \<and> \<acute>ins-\<acute>outs\<le>length \<acute>buffer\<guillemotright> ;
+ I1= \<guillemotleft>\<acute>I \<and> \<acute>li\<le>length a\<guillemotright> ;
+ p1= \<guillemotleft>\<acute>I1 \<and> \<acute>li=\<acute>ins\<guillemotright> ;
+ I2 = \<guillemotleft>\<acute>I \<and> (\<forall>k<\<acute>lj. (a ! k)=(\<acute>b ! k)) \<and> \<acute>lj\<le>length a\<guillemotright> ;
+ p2 = \<guillemotleft>\<acute>I2 \<and> \<acute>lj=\<acute>outs\<guillemotright> \<rbrakk> \<Longrightarrow>
+ \<parallel>- .{\<acute>INIT}.
+ \<acute>ins:=0,, \<acute>outs:=0,, \<acute>li:=0,, \<acute>lj:=0,,
+ COBEGIN .{\<acute>p1 \<and> \<acute>INIT}.
+ WHILE \<acute>li <length a
+ INV .{\<acute>p1 \<and> \<acute>INIT}.
+ DO .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a}.
+ \<acute>vx:= (a ! \<acute>li);;
+ .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a \<and> \<acute>vx=(a ! \<acute>li)}.
+ WAIT \<acute>ins-\<acute>outs < length \<acute>buffer END;;
+ .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a \<and> \<acute>vx=(a ! \<acute>li)
+ \<and> \<acute>ins-\<acute>outs < length \<acute>buffer}.
+ \<acute>buffer:=(list_update \<acute>buffer (\<acute>ins mod (length \<acute>buffer)) \<acute>vx);;
+ .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li<length a
+ \<and> (a ! \<acute>li)=(\<acute>buffer ! (\<acute>ins mod (length \<acute>buffer)))
+ \<and> \<acute>ins-\<acute>outs <length \<acute>buffer}.
+ \<acute>ins:=\<acute>ins+1;;
+ .{\<acute>I1 \<and> \<acute>INIT \<and> (\<acute>li+1)=\<acute>ins \<and> \<acute>li<length a}.
+ \<acute>li:=\<acute>li+1
+ OD
+ .{\<acute>p1 \<and> \<acute>INIT \<and> \<acute>li=length a}.
+ \<parallel>
+ .{\<acute>p2 \<and> \<acute>INIT}.
+ WHILE \<acute>lj < length a
+ INV .{\<acute>p2 \<and> \<acute>INIT}.
+ DO .{\<acute>p2 \<and> \<acute>lj<length a \<and> \<acute>INIT}.
+ WAIT \<acute>outs<\<acute>ins END;;
+ .{\<acute>p2 \<and> \<acute>lj<length a \<and> \<acute>outs<\<acute>ins \<and> \<acute>INIT}.
+ \<acute>vy:=(\<acute>buffer ! (\<acute>outs mod (length \<acute>buffer)));;
+ .{\<acute>p2 \<and> \<acute>lj<length a \<and> \<acute>outs<\<acute>ins \<and> \<acute>vy=(a ! \<acute>lj) \<and> \<acute>INIT}.
+ \<acute>outs:=\<acute>outs+1;;
+ .{\<acute>I2 \<and> (\<acute>lj+1)=\<acute>outs \<and> \<acute>lj<length a \<and> \<acute>vy=(a ! \<acute>lj) \<and> \<acute>INIT}.
+ \<acute>b:=(list_update \<acute>b \<acute>lj \<acute>vy);;
+ .{\<acute>I2 \<and> (\<acute>lj+1)=\<acute>outs \<and> \<acute>lj<length a \<and> (a ! \<acute>lj)=(\<acute>b ! \<acute>lj) \<and> \<acute>INIT}.
+ \<acute>lj:=\<acute>lj+1
+ OD
+ .{\<acute>p2 \<and> \<acute>lj=length a \<and> \<acute>INIT}.
+ COEND
+ .{ \<forall>k<length a. (a ! k)=(\<acute>b ! k)}."
+apply oghoare
+--{* 138 vc *}
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+--{* 112 subgoals left *}
+apply(simp_all (no_asm))
+apply(tactic {*ALLGOALS (conjI_Tac (K all_tac)) *})
+--{* 930 subgoals left *}
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+apply(simp_all (asm_lr) only:length_0_conv [THEN sym])
+--{* 44 subgoals left *}
+apply (simp_all (asm_lr) del:length_0_conv add: neq0_conv nth_list_update mod_less_divisor mod_lemma)
+--{* 32 subgoals left *}
+apply(tactic {* ALLGOALS (clarify_tac @{claset}) *})
+
+apply(tactic {* TRYALL (Lin_Arith.tac @{context}) *})
+--{* 9 subgoals left *}
+apply (force simp add:less_Suc_eq)
+apply(drule sym)
+apply (force simp add:less_Suc_eq)+
+done
+
+subsection {* Parameterized Examples *}
+
+subsubsection {* Set Elements of an Array to Zero *}
+
+record Example1 =
+ a :: "nat \<Rightarrow> nat"
+
+lemma Example1:
+ "\<parallel>- .{True}.
+ COBEGIN SCHEME [0\<le>i<n] .{True}. \<acute>a:=\<acute>a (i:=0) .{\<acute>a i=0}. COEND
+ .{\<forall>i < n. \<acute>a i = 0}."
+apply oghoare
+apply simp_all
+done
+
+text {* Same example with lists as auxiliary variables. *}
+record Example1_list =
+ A :: "nat list"
+lemma Example1_list:
+ "\<parallel>- .{n < length \<acute>A}.
+ COBEGIN
+ SCHEME [0\<le>i<n] .{n < length \<acute>A}. \<acute>A:=\<acute>A[i:=0] .{\<acute>A!i=0}.
+ COEND
+ .{\<forall>i < n. \<acute>A!i = 0}."
+apply oghoare
+apply force+
+done
+
+subsubsection {* Increment a Variable in Parallel *}
+
+text {* First some lemmas about summation properties. *}
+(*
+lemma Example2_lemma1: "!!b. j<n \<Longrightarrow> (\<Sum>i::nat<n. b i) = (0::nat) \<Longrightarrow> b j = 0 "
+apply(induct n)
+ apply simp_all
+apply(force simp add: less_Suc_eq)
+done
+*)
+lemma Example2_lemma2_aux: "!!b. j<n \<Longrightarrow>
+ (\<Sum>i=0..<n. (b i::nat)) =
+ (\<Sum>i=0..<j. b i) + b j + (\<Sum>i=0..<n-(Suc j) . b (Suc j + i))"
+apply(induct n)
+ apply simp_all
+apply(simp add:less_Suc_eq)
+ apply(auto)
+apply(subgoal_tac "n - j = Suc(n- Suc j)")
+ apply simp
+apply arith
+done
+
+lemma Example2_lemma2_aux2:
+ "!!b. j\<le> s \<Longrightarrow> (\<Sum>i::nat=0..<j. (b (s:=t)) i) = (\<Sum>i=0..<j. b i)"
+apply(induct j)
+ apply simp_all
+done
+
+lemma Example2_lemma2:
+ "!!b. \<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow> Suc (\<Sum>i::nat=0..<n. b i)=(\<Sum>i=0..<n. (b (j := Suc 0)) i)"
+apply(frule_tac b="(b (j:=(Suc 0)))" in Example2_lemma2_aux)
+apply(erule_tac t="setsum (b(j := (Suc 0))) {0..<n}" in ssubst)
+apply(frule_tac b=b in Example2_lemma2_aux)
+apply(erule_tac t="setsum b {0..<n}" in ssubst)
+apply(subgoal_tac "Suc (setsum b {0..<j} + b j + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))=(setsum b {0..<j} + Suc (b j) + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))")
+apply(rotate_tac -1)
+apply(erule ssubst)
+apply(subgoal_tac "j\<le>j")
+ apply(drule_tac b="b" and t="(Suc 0)" in Example2_lemma2_aux2)
+apply(rotate_tac -1)
+apply(erule ssubst)
+apply simp_all
+done
+
+
+record Example2 =
+ c :: "nat \<Rightarrow> nat"
+ x :: nat
+
+lemma Example_2: "0<n \<Longrightarrow>
+ \<parallel>- .{\<acute>x=0 \<and> (\<Sum>i=0..<n. \<acute>c i)=0}.
+ COBEGIN
+ SCHEME [0\<le>i<n]
+ .{\<acute>x=(\<Sum>i=0..<n. \<acute>c i) \<and> \<acute>c i=0}.
+ \<langle> \<acute>x:=\<acute>x+(Suc 0),, \<acute>c:=\<acute>c (i:=(Suc 0)) \<rangle>
+ .{\<acute>x=(\<Sum>i=0..<n. \<acute>c i) \<and> \<acute>c i=(Suc 0)}.
+ COEND
+ .{\<acute>x=n}."
+apply oghoare
+apply (simp_all cong del: strong_setsum_cong)
+apply (tactic {* ALLGOALS (clarify_tac @{claset}) *})
+apply (simp_all cong del: strong_setsum_cong)
+ apply(erule (1) Example2_lemma2)
+ apply(erule (1) Example2_lemma2)
+ apply(erule (1) Example2_lemma2)
+apply(simp)
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/OG_Hoare.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,469 @@
+
+header {* \section{The Proof System} *}
+
+theory OG_Hoare imports OG_Tran begin
+
+consts assertions :: "'a ann_com \<Rightarrow> ('a assn) set"
+primrec
+ "assertions (AnnBasic r f) = {r}"
+ "assertions (AnnSeq c1 c2) = assertions c1 \<union> assertions c2"
+ "assertions (AnnCond1 r b c1 c2) = {r} \<union> assertions c1 \<union> assertions c2"
+ "assertions (AnnCond2 r b c) = {r} \<union> assertions c"
+ "assertions (AnnWhile r b i c) = {r, i} \<union> assertions c"
+ "assertions (AnnAwait r b c) = {r}"
+
+consts atomics :: "'a ann_com \<Rightarrow> ('a assn \<times> 'a com) set"
+primrec
+ "atomics (AnnBasic r f) = {(r, Basic f)}"
+ "atomics (AnnSeq c1 c2) = atomics c1 \<union> atomics c2"
+ "atomics (AnnCond1 r b c1 c2) = atomics c1 \<union> atomics c2"
+ "atomics (AnnCond2 r b c) = atomics c"
+ "atomics (AnnWhile r b i c) = atomics c"
+ "atomics (AnnAwait r b c) = {(r \<inter> b, c)}"
+
+consts com :: "'a ann_triple_op \<Rightarrow> 'a ann_com_op"
+primrec "com (c, q) = c"
+
+consts post :: "'a ann_triple_op \<Rightarrow> 'a assn"
+primrec "post (c, q) = q"
+
+constdefs interfree_aux :: "('a ann_com_op \<times> 'a assn \<times> 'a ann_com_op) \<Rightarrow> bool"
+ "interfree_aux \<equiv> \<lambda>(co, q, co'). co'= None \<or>
+ (\<forall>(r,a) \<in> atomics (the co'). \<parallel>= (q \<inter> r) a q \<and>
+ (co = None \<or> (\<forall>p \<in> assertions (the co). \<parallel>= (p \<inter> r) a p)))"
+
+constdefs interfree :: "(('a ann_triple_op) list) \<Rightarrow> bool"
+ "interfree Ts \<equiv> \<forall>i j. i < length Ts \<and> j < length Ts \<and> i \<noteq> j \<longrightarrow>
+ interfree_aux (com (Ts!i), post (Ts!i), com (Ts!j)) "
+
+inductive
+ oghoare :: "'a assn \<Rightarrow> 'a com \<Rightarrow> 'a assn \<Rightarrow> bool" ("(3\<parallel>- _//_//_)" [90,55,90] 50)
+ and ann_hoare :: "'a ann_com \<Rightarrow> 'a assn \<Rightarrow> bool" ("(2\<turnstile> _// _)" [60,90] 45)
+where
+ AnnBasic: "r \<subseteq> {s. f s \<in> q} \<Longrightarrow> \<turnstile> (AnnBasic r f) q"
+
+| AnnSeq: "\<lbrakk> \<turnstile> c0 pre c1; \<turnstile> c1 q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnSeq c0 c1) q"
+
+| AnnCond1: "\<lbrakk> r \<inter> b \<subseteq> pre c1; \<turnstile> c1 q; r \<inter> -b \<subseteq> pre c2; \<turnstile> c2 q\<rbrakk>
+ \<Longrightarrow> \<turnstile> (AnnCond1 r b c1 c2) q"
+| AnnCond2: "\<lbrakk> r \<inter> b \<subseteq> pre c; \<turnstile> c q; r \<inter> -b \<subseteq> q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnCond2 r b c) q"
+
+| AnnWhile: "\<lbrakk> r \<subseteq> i; i \<inter> b \<subseteq> pre c; \<turnstile> c i; i \<inter> -b \<subseteq> q \<rbrakk>
+ \<Longrightarrow> \<turnstile> (AnnWhile r b i c) q"
+
+| AnnAwait: "\<lbrakk> atom_com c; \<parallel>- (r \<inter> b) c q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnAwait r b c) q"
+
+| AnnConseq: "\<lbrakk>\<turnstile> c q; q \<subseteq> q' \<rbrakk> \<Longrightarrow> \<turnstile> c q'"
+
+
+| Parallel: "\<lbrakk> \<forall>i<length Ts. \<exists>c q. Ts!i = (Some c, q) \<and> \<turnstile> c q; interfree Ts \<rbrakk>
+ \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts!i))))
+ Parallel Ts
+ (\<Inter>i\<in>{i. i<length Ts}. post(Ts!i))"
+
+| Basic: "\<parallel>- {s. f s \<in>q} (Basic f) q"
+
+| Seq: "\<lbrakk> \<parallel>- p c1 r; \<parallel>- r c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Seq c1 c2) q "
+
+| Cond: "\<lbrakk> \<parallel>- (p \<inter> b) c1 q; \<parallel>- (p \<inter> -b) c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Cond b c1 c2) q"
+
+| While: "\<lbrakk> \<parallel>- (p \<inter> b) c p \<rbrakk> \<Longrightarrow> \<parallel>- p (While b i c) (p \<inter> -b)"
+
+| Conseq: "\<lbrakk> p' \<subseteq> p; \<parallel>- p c q ; q \<subseteq> q' \<rbrakk> \<Longrightarrow> \<parallel>- p' c q'"
+
+section {* Soundness *}
+(* In the version Isabelle-10-Sep-1999: HOL: The THEN and ELSE
+parts of conditional expressions (if P then x else y) are no longer
+simplified. (This allows the simplifier to unfold recursive
+functional programs.) To restore the old behaviour, we declare
+@{text "lemmas [cong del] = if_weak_cong"}. *)
+
+lemmas [cong del] = if_weak_cong
+
+lemmas ann_hoare_induct = oghoare_ann_hoare.induct [THEN conjunct2]
+lemmas oghoare_induct = oghoare_ann_hoare.induct [THEN conjunct1]
+
+lemmas AnnBasic = oghoare_ann_hoare.AnnBasic
+lemmas AnnSeq = oghoare_ann_hoare.AnnSeq
+lemmas AnnCond1 = oghoare_ann_hoare.AnnCond1
+lemmas AnnCond2 = oghoare_ann_hoare.AnnCond2
+lemmas AnnWhile = oghoare_ann_hoare.AnnWhile
+lemmas AnnAwait = oghoare_ann_hoare.AnnAwait
+lemmas AnnConseq = oghoare_ann_hoare.AnnConseq
+
+lemmas Parallel = oghoare_ann_hoare.Parallel
+lemmas Basic = oghoare_ann_hoare.Basic
+lemmas Seq = oghoare_ann_hoare.Seq
+lemmas Cond = oghoare_ann_hoare.Cond
+lemmas While = oghoare_ann_hoare.While
+lemmas Conseq = oghoare_ann_hoare.Conseq
+
+subsection {* Soundness of the System for Atomic Programs *}
+
+lemma Basic_ntran [rule_format]:
+ "(Basic f, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow> t = f s"
+apply(induct "n")
+ apply(simp (no_asm))
+apply(fast dest: rel_pow_Suc_D2 Parallel_empty_lemma elim: transition_cases)
+done
+
+lemma SEM_fwhile: "SEM S (p \<inter> b) \<subseteq> p \<Longrightarrow> SEM (fwhile b S k) p \<subseteq> (p \<inter> -b)"
+apply (induct "k")
+ apply(simp (no_asm) add: L3_5v_lemma3)
+apply(simp (no_asm) add: L3_5iv L3_5ii Parallel_empty)
+apply(rule conjI)
+ apply (blast dest: L3_5i)
+apply(simp add: SEM_def sem_def id_def)
+apply (blast dest: Basic_ntran rtrancl_imp_UN_rel_pow)
+done
+
+lemma atom_hoare_sound [rule_format]:
+ " \<parallel>- p c q \<longrightarrow> atom_com(c) \<longrightarrow> \<parallel>= p c q"
+apply (unfold com_validity_def)
+apply(rule oghoare_induct)
+apply simp_all
+--{*Basic*}
+ apply(simp add: SEM_def sem_def)
+ apply(fast dest: rtrancl_imp_UN_rel_pow Basic_ntran)
+--{* Seq *}
+ apply(rule impI)
+ apply(rule subset_trans)
+ prefer 2 apply simp
+ apply(simp add: L3_5ii L3_5i)
+--{* Cond *}
+ apply(simp add: L3_5iv)
+--{* While *}
+ apply (force simp add: L3_5v dest: SEM_fwhile)
+--{* Conseq *}
+apply(force simp add: SEM_def sem_def)
+done
+
+subsection {* Soundness of the System for Component Programs *}
+
+inductive_cases ann_transition_cases:
+ "(None,s) -1\<rightarrow> (c', s')"
+ "(Some (AnnBasic r f),s) -1\<rightarrow> (c', s')"
+ "(Some (AnnSeq c1 c2), s) -1\<rightarrow> (c', s')"
+ "(Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (c', s')"
+ "(Some (AnnCond2 r b c), s) -1\<rightarrow> (c', s')"
+ "(Some (AnnWhile r b I c), s) -1\<rightarrow> (c', s')"
+ "(Some (AnnAwait r b c),s) -1\<rightarrow> (c', s')"
+
+text {* Strong Soundness for Component Programs:*}
+
+lemma ann_hoare_case_analysis [rule_format]:
+ defines I: "I \<equiv> \<lambda>C q'.
+ ((\<forall>r f. C = AnnBasic r f \<longrightarrow> (\<exists>q. r \<subseteq> {s. f s \<in> q} \<and> q \<subseteq> q')) \<and>
+ (\<forall>c0 c1. C = AnnSeq c0 c1 \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and> \<turnstile> c0 pre c1 \<and> \<turnstile> c1 q)) \<and>
+ (\<forall>r b c1 c2. C = AnnCond1 r b c1 c2 \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and>
+ r \<inter> b \<subseteq> pre c1 \<and> \<turnstile> c1 q \<and> r \<inter> -b \<subseteq> pre c2 \<and> \<turnstile> c2 q)) \<and>
+ (\<forall>r b c. C = AnnCond2 r b c \<longrightarrow>
+ (\<exists>q. q \<subseteq> q' \<and> r \<inter> b \<subseteq> pre c \<and> \<turnstile> c q \<and> r \<inter> -b \<subseteq> q)) \<and>
+ (\<forall>r i b c. C = AnnWhile r b i c \<longrightarrow>
+ (\<exists>q. q \<subseteq> q' \<and> r \<subseteq> i \<and> i \<inter> b \<subseteq> pre c \<and> \<turnstile> c i \<and> i \<inter> -b \<subseteq> q)) \<and>
+ (\<forall>r b c. C = AnnAwait r b c \<longrightarrow> (\<exists>q. q \<subseteq> q' \<and> \<parallel>- (r \<inter> b) c q)))"
+ shows "\<turnstile> C q' \<longrightarrow> I C q'"
+apply(rule ann_hoare_induct)
+apply (simp_all add: I)
+ apply(rule_tac x=q in exI,simp)+
+apply(rule conjI,clarify,simp,clarify,rule_tac x=qa in exI,fast)+
+apply(clarify,simp,clarify,rule_tac x=qa in exI,fast)
+done
+
+lemma Help: "(transition \<inter> {(x,y). True}) = (transition)"
+apply force
+done
+
+lemma Strong_Soundness_aux_aux [rule_format]:
+ "(co, s) -1\<rightarrow> (co', t) \<longrightarrow> (\<forall>c. co = Some c \<longrightarrow> s\<in> pre c \<longrightarrow>
+ (\<forall>q. \<turnstile> c q \<longrightarrow> (if co' = None then t\<in>q else t \<in> pre(the co') \<and> \<turnstile> (the co') q )))"
+apply(rule ann_transition_transition.induct [THEN conjunct1])
+apply simp_all
+--{* Basic *}
+ apply clarify
+ apply(frule ann_hoare_case_analysis)
+ apply force
+--{* Seq *}
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply(fast intro: AnnConseq)
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply clarify
+ apply(rule conjI)
+ apply force
+ apply(rule AnnSeq,simp)
+ apply(fast intro: AnnConseq)
+--{* Cond1 *}
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply(fast intro: AnnConseq)
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply(fast intro: AnnConseq)
+--{* Cond2 *}
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply(fast intro: AnnConseq)
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply(fast intro: AnnConseq)
+--{* While *}
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply force
+ apply clarify
+ apply(frule ann_hoare_case_analysis,simp)
+ apply auto
+ apply(rule AnnSeq)
+ apply simp
+ apply(rule AnnWhile)
+ apply simp_all
+--{* Await *}
+apply(frule ann_hoare_case_analysis,simp)
+apply clarify
+apply(drule atom_hoare_sound)
+ apply simp
+apply(simp add: com_validity_def SEM_def sem_def)
+apply(simp add: Help All_None_def)
+apply force
+done
+
+lemma Strong_Soundness_aux: "\<lbrakk> (Some c, s) -*\<rightarrow> (co, t); s \<in> pre c; \<turnstile> c q \<rbrakk>
+ \<Longrightarrow> if co = None then t \<in> q else t \<in> pre (the co) \<and> \<turnstile> (the co) q"
+apply(erule rtrancl_induct2)
+ apply simp
+apply(case_tac "a")
+ apply(fast elim: ann_transition_cases)
+apply(erule Strong_Soundness_aux_aux)
+ apply simp
+apply simp_all
+done
+
+lemma Strong_Soundness: "\<lbrakk> (Some c, s)-*\<rightarrow>(co, t); s \<in> pre c; \<turnstile> c q \<rbrakk>
+ \<Longrightarrow> if co = None then t\<in>q else t \<in> pre (the co)"
+apply(force dest:Strong_Soundness_aux)
+done
+
+lemma ann_hoare_sound: "\<turnstile> c q \<Longrightarrow> \<Turnstile> c q"
+apply (unfold ann_com_validity_def ann_SEM_def ann_sem_def)
+apply clarify
+apply(drule Strong_Soundness)
+apply simp_all
+done
+
+subsection {* Soundness of the System for Parallel Programs *}
+
+lemma Parallel_length_post_P1: "(Parallel Ts,s) -P1\<rightarrow> (R', t) \<Longrightarrow>
+ (\<exists>Rs. R' = (Parallel Rs) \<and> (length Rs) = (length Ts) \<and>
+ (\<forall>i. i<length Ts \<longrightarrow> post(Rs ! i) = post(Ts ! i)))"
+apply(erule transition_cases)
+apply simp
+apply clarify
+apply(case_tac "i=ia")
+apply simp+
+done
+
+lemma Parallel_length_post_PStar: "(Parallel Ts,s) -P*\<rightarrow> (R',t) \<Longrightarrow>
+ (\<exists>Rs. R' = (Parallel Rs) \<and> (length Rs) = (length Ts) \<and>
+ (\<forall>i. i<length Ts \<longrightarrow> post(Ts ! i) = post(Rs ! i)))"
+apply(erule rtrancl_induct2)
+ apply(simp_all)
+apply clarify
+apply simp
+apply(drule Parallel_length_post_P1)
+apply auto
+done
+
+lemma assertions_lemma: "pre c \<in> assertions c"
+apply(rule ann_com_com.induct [THEN conjunct1])
+apply auto
+done
+
+lemma interfree_aux1 [rule_format]:
+ "(c,s) -1\<rightarrow> (r,t) \<longrightarrow> (interfree_aux(c1, q1, c) \<longrightarrow> interfree_aux(c1, q1, r))"
+apply (rule ann_transition_transition.induct [THEN conjunct1])
+apply(safe)
+prefer 13
+apply (rule TrueI)
+apply (simp_all add:interfree_aux_def)
+apply force+
+done
+
+lemma interfree_aux2 [rule_format]:
+ "(c,s) -1\<rightarrow> (r,t) \<longrightarrow> (interfree_aux(c, q, a) \<longrightarrow> interfree_aux(r, q, a) )"
+apply (rule ann_transition_transition.induct [THEN conjunct1])
+apply(force simp add:interfree_aux_def)+
+done
+
+lemma interfree_lemma: "\<lbrakk> (Some c, s) -1\<rightarrow> (r, t);interfree Ts ; i<length Ts;
+ Ts!i = (Some c, q) \<rbrakk> \<Longrightarrow> interfree (Ts[i:= (r, q)])"
+apply(simp add: interfree_def)
+apply clarify
+apply(case_tac "i=j")
+ apply(drule_tac t = "ia" in not_sym)
+ apply simp_all
+apply(force elim: interfree_aux1)
+apply(force elim: interfree_aux2 simp add:nth_list_update)
+done
+
+text {* Strong Soundness Theorem for Parallel Programs:*}
+
+lemma Parallel_Strong_Soundness_Seq_aux:
+ "\<lbrakk>interfree Ts; i<length Ts; com(Ts ! i) = Some(AnnSeq c0 c1) \<rbrakk>
+ \<Longrightarrow> interfree (Ts[i:=(Some c0, pre c1)])"
+apply(simp add: interfree_def)
+apply clarify
+apply(case_tac "i=j")
+ apply(force simp add: nth_list_update interfree_aux_def)
+apply(case_tac "i=ia")
+ apply(erule_tac x=ia in allE)
+ apply(force simp add:interfree_aux_def assertions_lemma)
+apply simp
+done
+
+lemma Parallel_Strong_Soundness_Seq [rule_format (no_asm)]:
+ "\<lbrakk> \<forall>i<length Ts. (if com(Ts!i) = None then b \<in> post(Ts!i)
+ else b \<in> pre(the(com(Ts!i))) \<and> \<turnstile> the(com(Ts!i)) post(Ts!i));
+ com(Ts ! i) = Some(AnnSeq c0 c1); i<length Ts; interfree Ts \<rbrakk> \<Longrightarrow>
+ (\<forall>ia<length Ts. (if com(Ts[i:=(Some c0, pre c1)]! ia) = None
+ then b \<in> post(Ts[i:=(Some c0, pre c1)]! ia)
+ else b \<in> pre(the(com(Ts[i:=(Some c0, pre c1)]! ia))) \<and>
+ \<turnstile> the(com(Ts[i:=(Some c0, pre c1)]! ia)) post(Ts[i:=(Some c0, pre c1)]! ia)))
+ \<and> interfree (Ts[i:= (Some c0, pre c1)])"
+apply(rule conjI)
+ apply safe
+ apply(case_tac "i=ia")
+ apply simp
+ apply(force dest: ann_hoare_case_analysis)
+ apply simp
+apply(fast elim: Parallel_Strong_Soundness_Seq_aux)
+done
+
+lemma Parallel_Strong_Soundness_aux_aux [rule_format]:
+ "(Some c, b) -1\<rightarrow> (co, t) \<longrightarrow>
+ (\<forall>Ts. i<length Ts \<longrightarrow> com(Ts ! i) = Some c \<longrightarrow>
+ (\<forall>i<length Ts. (if com(Ts ! i) = None then b\<in>post(Ts!i)
+ else b\<in>pre(the(com(Ts!i))) \<and> \<turnstile> the(com(Ts!i)) post(Ts!i))) \<longrightarrow>
+ interfree Ts \<longrightarrow>
+ (\<forall>j. j<length Ts \<and> i\<noteq>j \<longrightarrow> (if com(Ts!j) = None then t\<in>post(Ts!j)
+ else t\<in>pre(the(com(Ts!j))) \<and> \<turnstile> the(com(Ts!j)) post(Ts!j))) )"
+apply(rule ann_transition_transition.induct [THEN conjunct1])
+apply safe
+prefer 11
+apply(rule TrueI)
+apply simp_all
+--{* Basic *}
+ apply(erule_tac x = "i" in all_dupE, erule (1) notE impE)
+ apply(erule_tac x = "j" in allE , erule (1) notE impE)
+ apply(simp add: interfree_def)
+ apply(erule_tac x = "j" in allE,simp)
+ apply(erule_tac x = "i" in allE,simp)
+ apply(drule_tac t = "i" in not_sym)
+ apply(case_tac "com(Ts ! j)=None")
+ apply(force intro: converse_rtrancl_into_rtrancl
+ simp add: interfree_aux_def com_validity_def SEM_def sem_def All_None_def)
+ apply(simp add:interfree_aux_def)
+ apply clarify
+ apply simp
+ apply(erule_tac x="pre y" in ballE)
+ apply(force intro: converse_rtrancl_into_rtrancl
+ simp add: com_validity_def SEM_def sem_def All_None_def)
+ apply(simp add:assertions_lemma)
+--{* Seqs *}
+ apply(erule_tac x = "Ts[i:=(Some c0, pre c1)]" in allE)
+ apply(drule Parallel_Strong_Soundness_Seq,simp+)
+ apply(erule_tac x = "Ts[i:=(Some c0, pre c1)]" in allE)
+ apply(drule Parallel_Strong_Soundness_Seq,simp+)
+--{* Await *}
+apply(rule_tac x = "i" in allE , assumption , erule (1) notE impE)
+apply(erule_tac x = "j" in allE , erule (1) notE impE)
+apply(simp add: interfree_def)
+apply(erule_tac x = "j" in allE,simp)
+apply(erule_tac x = "i" in allE,simp)
+apply(drule_tac t = "i" in not_sym)
+apply(case_tac "com(Ts ! j)=None")
+ apply(force intro: converse_rtrancl_into_rtrancl simp add: interfree_aux_def
+ com_validity_def SEM_def sem_def All_None_def Help)
+apply(simp add:interfree_aux_def)
+apply clarify
+apply simp
+apply(erule_tac x="pre y" in ballE)
+ apply(force intro: converse_rtrancl_into_rtrancl
+ simp add: com_validity_def SEM_def sem_def All_None_def Help)
+apply(simp add:assertions_lemma)
+done
+
+lemma Parallel_Strong_Soundness_aux [rule_format]:
+ "\<lbrakk>(Ts',s) -P*\<rightarrow> (Rs',t); Ts' = (Parallel Ts); interfree Ts;
+ \<forall>i. i<length Ts \<longrightarrow> (\<exists>c q. (Ts ! i) = (Some c, q) \<and> s\<in>(pre c) \<and> \<turnstile> c q ) \<rbrakk> \<Longrightarrow>
+ \<forall>Rs. Rs' = (Parallel Rs) \<longrightarrow> (\<forall>j. j<length Rs \<longrightarrow>
+ (if com(Rs ! j) = None then t\<in>post(Ts ! j)
+ else t\<in>pre(the(com(Rs ! j))) \<and> \<turnstile> the(com(Rs ! j)) post(Ts ! j))) \<and> interfree Rs"
+apply(erule rtrancl_induct2)
+ apply clarify
+--{* Base *}
+ apply force
+--{* Induction step *}
+apply clarify
+apply(drule Parallel_length_post_PStar)
+apply clarify
+apply (ind_cases "(Parallel Ts, s) -P1\<rightarrow> (Parallel Rs, t)" for Ts s Rs t)
+apply(rule conjI)
+ apply clarify
+ apply(case_tac "i=j")
+ apply(simp split del:split_if)
+ apply(erule Strong_Soundness_aux_aux,simp+)
+ apply force
+ apply force
+ apply(simp split del: split_if)
+ apply(erule Parallel_Strong_Soundness_aux_aux)
+ apply(simp_all add: split del:split_if)
+ apply force
+apply(rule interfree_lemma)
+apply simp_all
+done
+
+lemma Parallel_Strong_Soundness:
+ "\<lbrakk>(Parallel Ts, s) -P*\<rightarrow> (Parallel Rs, t); interfree Ts; j<length Rs;
+ \<forall>i. i<length Ts \<longrightarrow> (\<exists>c q. Ts ! i = (Some c, q) \<and> s\<in>pre c \<and> \<turnstile> c q) \<rbrakk> \<Longrightarrow>
+ if com(Rs ! j) = None then t\<in>post(Ts ! j) else t\<in>pre (the(com(Rs ! j)))"
+apply(drule Parallel_Strong_Soundness_aux)
+apply simp+
+done
+
+lemma oghoare_sound [rule_format]: "\<parallel>- p c q \<longrightarrow> \<parallel>= p c q"
+apply (unfold com_validity_def)
+apply(rule oghoare_induct)
+apply(rule TrueI)+
+--{* Parallel *}
+ apply(simp add: SEM_def sem_def)
+ apply clarify
+ apply(frule Parallel_length_post_PStar)
+ apply clarify
+ apply(drule_tac j=xb in Parallel_Strong_Soundness)
+ apply clarify
+ apply simp
+ apply force
+ apply simp
+ apply(erule_tac V = "\<forall>i. ?P i" in thin_rl)
+ apply(drule_tac s = "length Rs" in sym)
+ apply(erule allE, erule impE, assumption)
+ apply(force dest: nth_mem simp add: All_None_def)
+--{* Basic *}
+ apply(simp add: SEM_def sem_def)
+ apply(force dest: rtrancl_imp_UN_rel_pow Basic_ntran)
+--{* Seq *}
+ apply(rule subset_trans)
+ prefer 2 apply assumption
+ apply(simp add: L3_5ii L3_5i)
+--{* Cond *}
+ apply(simp add: L3_5iv)
+--{* While *}
+ apply(simp add: L3_5v)
+ apply (blast dest: SEM_fwhile)
+--{* Conseq *}
+apply(auto simp add: SEM_def sem_def)
+done
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/OG_Syntax.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,140 @@
+theory OG_Syntax
+imports OG_Tactics Quote_Antiquote
+begin
+
+text{* Syntax for commands and for assertions and boolean expressions in
+ commands @{text com} and annotated commands @{text ann_com}. *}
+
+syntax
+ "_Assign" :: "idt \<Rightarrow> 'b \<Rightarrow> 'a com" ("(\<acute>_ :=/ _)" [70, 65] 61)
+ "_AnnAssign" :: "'a assn \<Rightarrow> idt \<Rightarrow> 'b \<Rightarrow> 'a com" ("(_ \<acute>_ :=/ _)" [90,70,65] 61)
+
+translations
+ "\<acute>\<spacespace>x := a" \<rightharpoonup> "Basic \<guillemotleft>\<acute>\<spacespace>(_update_name x (\<lambda>_. a))\<guillemotright>"
+ "r \<acute>\<spacespace>x := a" \<rightharpoonup> "AnnBasic r \<guillemotleft>\<acute>\<spacespace>(_update_name x (\<lambda>_. a))\<guillemotright>"
+
+syntax
+ "_AnnSkip" :: "'a assn \<Rightarrow> 'a ann_com" ("_//SKIP" [90] 63)
+ "_AnnSeq" :: "'a ann_com \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com" ("_;;/ _" [60,61] 60)
+
+ "_AnnCond1" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com"
+ ("_ //IF _ /THEN _ /ELSE _ /FI" [90,0,0,0] 61)
+ "_AnnCond2" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com"
+ ("_ //IF _ /THEN _ /FI" [90,0,0] 61)
+ "_AnnWhile" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a assn \<Rightarrow> 'a ann_com \<Rightarrow> 'a ann_com"
+ ("_ //WHILE _ /INV _ //DO _//OD" [90,0,0,0] 61)
+ "_AnnAwait" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a ann_com"
+ ("_ //AWAIT _ /THEN /_ /END" [90,0,0] 61)
+ "_AnnAtom" :: "'a assn \<Rightarrow> 'a com \<Rightarrow> 'a ann_com" ("_//\<langle>_\<rangle>" [90,0] 61)
+ "_AnnWait" :: "'a assn \<Rightarrow> 'a bexp \<Rightarrow> 'a ann_com" ("_//WAIT _ END" [90,0] 61)
+
+ "_Skip" :: "'a com" ("SKIP" 63)
+ "_Seq" :: "'a com \<Rightarrow> 'a com \<Rightarrow> 'a com" ("_,,/ _" [55, 56] 55)
+ "_Cond" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com \<Rightarrow> 'a com"
+ ("(0IF _/ THEN _/ ELSE _/ FI)" [0, 0, 0] 61)
+ "_Cond2" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com" ("IF _ THEN _ FI" [0,0] 56)
+ "_While_inv" :: "'a bexp \<Rightarrow> 'a assn \<Rightarrow> 'a com \<Rightarrow> 'a com"
+ ("(0WHILE _/ INV _ //DO _ /OD)" [0, 0, 0] 61)
+ "_While" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com"
+ ("(0WHILE _ //DO _ /OD)" [0, 0] 61)
+
+translations
+ "SKIP" \<rightleftharpoons> "Basic id"
+ "c_1,, c_2" \<rightleftharpoons> "Seq c_1 c_2"
+
+ "IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "Cond .{b}. c1 c2"
+ "IF b THEN c FI" \<rightleftharpoons> "IF b THEN c ELSE SKIP FI"
+ "WHILE b INV i DO c OD" \<rightharpoonup> "While .{b}. i c"
+ "WHILE b DO c OD" \<rightleftharpoons> "WHILE b INV CONST undefined DO c OD"
+
+ "r SKIP" \<rightleftharpoons> "AnnBasic r id"
+ "c_1;; c_2" \<rightleftharpoons> "AnnSeq c_1 c_2"
+ "r IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "AnnCond1 r .{b}. c1 c2"
+ "r IF b THEN c FI" \<rightharpoonup> "AnnCond2 r .{b}. c"
+ "r WHILE b INV i DO c OD" \<rightharpoonup> "AnnWhile r .{b}. i c"
+ "r AWAIT b THEN c END" \<rightharpoonup> "AnnAwait r .{b}. c"
+ "r \<langle>c\<rangle>" \<rightleftharpoons> "r AWAIT True THEN c END"
+ "r WAIT b END" \<rightleftharpoons> "r AWAIT b THEN SKIP END"
+
+nonterminals
+ prgs
+
+syntax
+ "_PAR" :: "prgs \<Rightarrow> 'a" ("COBEGIN//_//COEND" [57] 56)
+ "_prg" :: "['a, 'a] \<Rightarrow> prgs" ("_//_" [60, 90] 57)
+ "_prgs" :: "['a, 'a, prgs] \<Rightarrow> prgs" ("_//_//\<parallel>//_" [60,90,57] 57)
+
+ "_prg_scheme" :: "['a, 'a, 'a, 'a, 'a] \<Rightarrow> prgs"
+ ("SCHEME [_ \<le> _ < _] _// _" [0,0,0,60, 90] 57)
+
+translations
+ "_prg c q" \<rightleftharpoons> "[(Some c, q)]"
+ "_prgs c q ps" \<rightleftharpoons> "(Some c, q) # ps"
+ "_PAR ps" \<rightleftharpoons> "Parallel ps"
+
+ "_prg_scheme j i k c q" \<rightleftharpoons> "map (\<lambda>i. (Some c, q)) [j..<k]"
+
+print_translation {*
+ let
+ fun quote_tr' f (t :: ts) =
+ Term.list_comb (f $ Syntax.quote_tr' "_antiquote" t, ts)
+ | quote_tr' _ _ = raise Match;
+
+ fun annquote_tr' f (r :: t :: ts) =
+ Term.list_comb (f $ r $ Syntax.quote_tr' "_antiquote" t, ts)
+ | annquote_tr' _ _ = raise Match;
+
+ val assert_tr' = quote_tr' (Syntax.const "_Assert");
+
+ fun bexp_tr' name ((Const ("Collect", _) $ t) :: ts) =
+ quote_tr' (Syntax.const name) (t :: ts)
+ | bexp_tr' _ _ = raise Match;
+
+ fun annbexp_tr' name (r :: (Const ("Collect", _) $ t) :: ts) =
+ annquote_tr' (Syntax.const name) (r :: t :: ts)
+ | annbexp_tr' _ _ = raise Match;
+
+ fun upd_tr' (x_upd, T) =
+ (case try (unsuffix Record.updateN) x_upd of
+ SOME x => (x, if T = dummyT then T else Term.domain_type T)
+ | NONE => raise Match);
+
+ fun update_name_tr' (Free x) = Free (upd_tr' x)
+ | update_name_tr' ((c as Const ("_free", _)) $ Free x) =
+ c $ Free (upd_tr' x)
+ | update_name_tr' (Const x) = Const (upd_tr' x)
+ | update_name_tr' _ = raise Match;
+
+ fun K_tr' (Abs (_,_,t)) = if null (loose_bnos t) then t else raise Match
+ | K_tr' (Abs (_,_,Abs (_,_,t)$Bound 0)) = if null (loose_bnos t) then t else raise Match
+ | K_tr' _ = raise Match;
+
+ fun assign_tr' (Abs (x, _, f $ k $ Bound 0) :: ts) =
+ quote_tr' (Syntax.const "_Assign" $ update_name_tr' f)
+ (Abs (x, dummyT, K_tr' k) :: ts)
+ | assign_tr' _ = raise Match;
+
+ fun annassign_tr' (r :: Abs (x, _, f $ k $ Bound 0) :: ts) =
+ quote_tr' (Syntax.const "_AnnAssign" $ r $ update_name_tr' f)
+ (Abs (x, dummyT, K_tr' k) :: ts)
+ | annassign_tr' _ = raise Match;
+
+ fun Parallel_PAR [(Const ("Cons",_) $ (Const ("Pair",_) $ (Const ("Some",_) $ t1 ) $ t2) $ Const ("Nil",_))] =
+ (Syntax.const "_prg" $ t1 $ t2)
+ | Parallel_PAR [(Const ("Cons",_) $ (Const ("Pair",_) $ (Const ("Some",_) $ t1) $ t2) $ ts)] =
+ (Syntax.const "_prgs" $ t1 $ t2 $ Parallel_PAR [ts])
+ | Parallel_PAR _ = raise Match;
+
+fun Parallel_tr' ts = Syntax.const "_PAR" $ Parallel_PAR ts;
+ in
+ [("Collect", assert_tr'), ("Basic", assign_tr'),
+ ("Cond", bexp_tr' "_Cond"), ("While", bexp_tr' "_While_inv"),
+ ("AnnBasic", annassign_tr'),
+ ("AnnWhile", annbexp_tr' "_AnnWhile"), ("AnnAwait", annbexp_tr' "_AnnAwait"),
+ ("AnnCond1", annbexp_tr' "_AnnCond1"), ("AnnCond2", annbexp_tr' "_AnnCond2")]
+
+ end
+
+*}
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/OG_Tactics.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,496 @@
+header {* \section{Generation of Verification Conditions} *}
+
+theory OG_Tactics
+imports OG_Hoare
+begin
+
+lemmas ann_hoare_intros=AnnBasic AnnSeq AnnCond1 AnnCond2 AnnWhile AnnAwait AnnConseq
+lemmas oghoare_intros=Parallel Basic Seq Cond While Conseq
+
+lemma ParallelConseqRule:
+ "\<lbrakk> p \<subseteq> (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts ! i))));
+ \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts ! i))))
+ (Parallel Ts)
+ (\<Inter>i\<in>{i. i<length Ts}. post(Ts ! i));
+ (\<Inter>i\<in>{i. i<length Ts}. post(Ts ! i)) \<subseteq> q \<rbrakk>
+ \<Longrightarrow> \<parallel>- p (Parallel Ts) q"
+apply (rule Conseq)
+prefer 2
+ apply fast
+apply assumption+
+done
+
+lemma SkipRule: "p \<subseteq> q \<Longrightarrow> \<parallel>- p (Basic id) q"
+apply(rule oghoare_intros)
+ prefer 2 apply(rule Basic)
+ prefer 2 apply(rule subset_refl)
+apply(simp add:Id_def)
+done
+
+lemma BasicRule: "p \<subseteq> {s. (f s)\<in>q} \<Longrightarrow> \<parallel>- p (Basic f) q"
+apply(rule oghoare_intros)
+ prefer 2 apply(rule oghoare_intros)
+ prefer 2 apply(rule subset_refl)
+apply assumption
+done
+
+lemma SeqRule: "\<lbrakk> \<parallel>- p c1 r; \<parallel>- r c2 q \<rbrakk> \<Longrightarrow> \<parallel>- p (Seq c1 c2) q"
+apply(rule Seq)
+apply fast+
+done
+
+lemma CondRule:
+ "\<lbrakk> p \<subseteq> {s. (s\<in>b \<longrightarrow> s\<in>w) \<and> (s\<notin>b \<longrightarrow> s\<in>w')}; \<parallel>- w c1 q; \<parallel>- w' c2 q \<rbrakk>
+ \<Longrightarrow> \<parallel>- p (Cond b c1 c2) q"
+apply(rule Cond)
+ apply(rule Conseq)
+ prefer 4 apply(rule Conseq)
+apply simp_all
+apply force+
+done
+
+lemma WhileRule: "\<lbrakk> p \<subseteq> i; \<parallel>- (i \<inter> b) c i ; (i \<inter> (-b)) \<subseteq> q \<rbrakk>
+ \<Longrightarrow> \<parallel>- p (While b i c) q"
+apply(rule Conseq)
+ prefer 2 apply(rule While)
+apply assumption+
+done
+
+text {* Three new proof rules for special instances of the @{text
+AnnBasic} and the @{text AnnAwait} commands when the transformation
+performed on the state is the identity, and for an @{text AnnAwait}
+command where the boolean condition is @{text "{s. True}"}: *}
+
+lemma AnnatomRule:
+ "\<lbrakk> atom_com(c); \<parallel>- r c q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnAwait r {s. True} c) q"
+apply(rule AnnAwait)
+apply simp_all
+done
+
+lemma AnnskipRule:
+ "r \<subseteq> q \<Longrightarrow> \<turnstile> (AnnBasic r id) q"
+apply(rule AnnBasic)
+apply simp
+done
+
+lemma AnnwaitRule:
+ "\<lbrakk> (r \<inter> b) \<subseteq> q \<rbrakk> \<Longrightarrow> \<turnstile> (AnnAwait r b (Basic id)) q"
+apply(rule AnnAwait)
+ apply simp
+apply(rule BasicRule)
+apply simp
+done
+
+text {* Lemmata to avoid using the definition of @{text
+map_ann_hoare}, @{text interfree_aux}, @{text interfree_swap} and
+@{text interfree} by splitting it into different cases: *}
+
+lemma interfree_aux_rule1: "interfree_aux(co, q, None)"
+by(simp add:interfree_aux_def)
+
+lemma interfree_aux_rule2:
+ "\<forall>(R,r)\<in>(atomics a). \<parallel>- (q \<inter> R) r q \<Longrightarrow> interfree_aux(None, q, Some a)"
+apply(simp add:interfree_aux_def)
+apply(force elim:oghoare_sound)
+done
+
+lemma interfree_aux_rule3:
+ "(\<forall>(R, r)\<in>(atomics a). \<parallel>- (q \<inter> R) r q \<and> (\<forall>p\<in>(assertions c). \<parallel>- (p \<inter> R) r p))
+ \<Longrightarrow> interfree_aux(Some c, q, Some a)"
+apply(simp add:interfree_aux_def)
+apply(force elim:oghoare_sound)
+done
+
+lemma AnnBasic_assertions:
+ "\<lbrakk>interfree_aux(None, r, Some a); interfree_aux(None, q, Some a)\<rbrakk> \<Longrightarrow>
+ interfree_aux(Some (AnnBasic r f), q, Some a)"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnSeq_assertions:
+ "\<lbrakk> interfree_aux(Some c1, q, Some a); interfree_aux(Some c2, q, Some a)\<rbrakk>\<Longrightarrow>
+ interfree_aux(Some (AnnSeq c1 c2), q, Some a)"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnCond1_assertions:
+ "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(Some c1, q, Some a);
+ interfree_aux(Some c2, q, Some a)\<rbrakk>\<Longrightarrow>
+ interfree_aux(Some(AnnCond1 r b c1 c2), q, Some a)"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnCond2_assertions:
+ "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(Some c, q, Some a)\<rbrakk>\<Longrightarrow>
+ interfree_aux(Some (AnnCond2 r b c), q, Some a)"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnWhile_assertions:
+ "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(None, i, Some a);
+ interfree_aux(Some c, q, Some a)\<rbrakk>\<Longrightarrow>
+ interfree_aux(Some (AnnWhile r b i c), q, Some a)"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnAwait_assertions:
+ "\<lbrakk> interfree_aux(None, r, Some a); interfree_aux(None, q, Some a)\<rbrakk>\<Longrightarrow>
+ interfree_aux(Some (AnnAwait r b c), q, Some a)"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnBasic_atomics:
+ "\<parallel>- (q \<inter> r) (Basic f) q \<Longrightarrow> interfree_aux(None, q, Some (AnnBasic r f))"
+by(simp add: interfree_aux_def oghoare_sound)
+
+lemma AnnSeq_atomics:
+ "\<lbrakk> interfree_aux(Any, q, Some a1); interfree_aux(Any, q, Some a2)\<rbrakk>\<Longrightarrow>
+ interfree_aux(Any, q, Some (AnnSeq a1 a2))"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnCond1_atomics:
+ "\<lbrakk> interfree_aux(Any, q, Some a1); interfree_aux(Any, q, Some a2)\<rbrakk>\<Longrightarrow>
+ interfree_aux(Any, q, Some (AnnCond1 r b a1 a2))"
+apply(simp add: interfree_aux_def)
+by force
+
+lemma AnnCond2_atomics:
+ "interfree_aux (Any, q, Some a)\<Longrightarrow> interfree_aux(Any, q, Some (AnnCond2 r b a))"
+by(simp add: interfree_aux_def)
+
+lemma AnnWhile_atomics: "interfree_aux (Any, q, Some a)
+ \<Longrightarrow> interfree_aux(Any, q, Some (AnnWhile r b i a))"
+by(simp add: interfree_aux_def)
+
+lemma Annatom_atomics:
+ "\<parallel>- (q \<inter> r) a q \<Longrightarrow> interfree_aux (None, q, Some (AnnAwait r {x. True} a))"
+by(simp add: interfree_aux_def oghoare_sound)
+
+lemma AnnAwait_atomics:
+ "\<parallel>- (q \<inter> (r \<inter> b)) a q \<Longrightarrow> interfree_aux (None, q, Some (AnnAwait r b a))"
+by(simp add: interfree_aux_def oghoare_sound)
+
+constdefs
+ interfree_swap :: "('a ann_triple_op * ('a ann_triple_op) list) \<Rightarrow> bool"
+ "interfree_swap == \<lambda>(x, xs). \<forall>y\<in>set xs. interfree_aux (com x, post x, com y)
+ \<and> interfree_aux(com y, post y, com x)"
+
+lemma interfree_swap_Empty: "interfree_swap (x, [])"
+by(simp add:interfree_swap_def)
+
+lemma interfree_swap_List:
+ "\<lbrakk> interfree_aux (com x, post x, com y);
+ interfree_aux (com y, post y ,com x); interfree_swap (x, xs) \<rbrakk>
+ \<Longrightarrow> interfree_swap (x, y#xs)"
+by(simp add:interfree_swap_def)
+
+lemma interfree_swap_Map: "\<forall>k. i\<le>k \<and> k<j \<longrightarrow> interfree_aux (com x, post x, c k)
+ \<and> interfree_aux (c k, Q k, com x)
+ \<Longrightarrow> interfree_swap (x, map (\<lambda>k. (c k, Q k)) [i..<j])"
+by(force simp add: interfree_swap_def less_diff_conv)
+
+lemma interfree_Empty: "interfree []"
+by(simp add:interfree_def)
+
+lemma interfree_List:
+ "\<lbrakk> interfree_swap(x, xs); interfree xs \<rbrakk> \<Longrightarrow> interfree (x#xs)"
+apply(simp add:interfree_def interfree_swap_def)
+apply clarify
+apply(case_tac i)
+ apply(case_tac j)
+ apply simp_all
+apply(case_tac j,simp+)
+done
+
+lemma interfree_Map:
+ "(\<forall>i j. a\<le>i \<and> i<b \<and> a\<le>j \<and> j<b \<and> i\<noteq>j \<longrightarrow> interfree_aux (c i, Q i, c j))
+ \<Longrightarrow> interfree (map (\<lambda>k. (c k, Q k)) [a..<b])"
+by(force simp add: interfree_def less_diff_conv)
+
+constdefs map_ann_hoare :: "(('a ann_com_op * 'a assn) list) \<Rightarrow> bool " ("[\<turnstile>] _" [0] 45)
+ "[\<turnstile>] Ts == (\<forall>i<length Ts. \<exists>c q. Ts!i=(Some c, q) \<and> \<turnstile> c q)"
+
+lemma MapAnnEmpty: "[\<turnstile>] []"
+by(simp add:map_ann_hoare_def)
+
+lemma MapAnnList: "\<lbrakk> \<turnstile> c q ; [\<turnstile>] xs \<rbrakk> \<Longrightarrow> [\<turnstile>] (Some c,q)#xs"
+apply(simp add:map_ann_hoare_def)
+apply clarify
+apply(case_tac i,simp+)
+done
+
+lemma MapAnnMap:
+ "\<forall>k. i\<le>k \<and> k<j \<longrightarrow> \<turnstile> (c k) (Q k) \<Longrightarrow> [\<turnstile>] map (\<lambda>k. (Some (c k), Q k)) [i..<j]"
+apply(simp add: map_ann_hoare_def less_diff_conv)
+done
+
+lemma ParallelRule:"\<lbrakk> [\<turnstile>] Ts ; interfree Ts \<rbrakk>
+ \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<length Ts}. pre(the(com(Ts!i))))
+ Parallel Ts
+ (\<Inter>i\<in>{i. i<length Ts}. post(Ts!i))"
+apply(rule Parallel)
+ apply(simp add:map_ann_hoare_def)
+apply simp
+done
+(*
+lemma ParamParallelRule:
+ "\<lbrakk> \<forall>k<n. \<turnstile> (c k) (Q k);
+ \<forall>k l. k<n \<and> l<n \<and> k\<noteq>l \<longrightarrow> interfree_aux (Some(c k), Q k, Some(c l)) \<rbrakk>
+ \<Longrightarrow> \<parallel>- (\<Inter>i\<in>{i. i<n} . pre(c i)) COBEGIN SCHEME [0\<le>i<n] (c i) (Q i) COEND (\<Inter>i\<in>{i. i<n} . Q i )"
+apply(rule ParallelConseqRule)
+ apply simp
+ apply clarify
+ apply force
+ apply(rule ParallelRule)
+ apply(rule MapAnnMap)
+ apply simp
+ apply(rule interfree_Map)
+ apply simp
+apply simp
+apply clarify
+apply force
+done
+*)
+
+text {* The following are some useful lemmas and simplification
+tactics to control which theorems are used to simplify at each moment,
+so that the original input does not suffer any unexpected
+transformation. *}
+
+lemma Compl_Collect: "-(Collect b) = {x. \<not>(b x)}"
+by fast
+lemma list_length: "length []=0 \<and> length (x#xs) = Suc(length xs)"
+by simp
+lemma list_lemmas: "length []=0 \<and> length (x#xs) = Suc(length xs)
+\<and> (x#xs) ! 0=x \<and> (x#xs) ! Suc n = xs ! n"
+by simp
+lemma le_Suc_eq_insert: "{i. i <Suc n} = insert n {i. i< n}"
+by auto
+lemmas primrecdef_list = "pre.simps" "assertions.simps" "atomics.simps" "atom_com.simps"
+lemmas my_simp_list = list_lemmas fst_conv snd_conv
+not_less0 refl le_Suc_eq_insert Suc_not_Zero Zero_not_Suc nat.inject
+Collect_mem_eq ball_simps option.simps primrecdef_list
+lemmas ParallelConseq_list = INTER_def Collect_conj_eq length_map length_upt length_append list_length
+
+ML {*
+val before_interfree_simp_tac = (simp_tac (HOL_basic_ss addsimps [thm "com.simps", thm "post.simps"]))
+
+val interfree_simp_tac = (asm_simp_tac (HOL_ss addsimps [thm "split", thm "ball_Un", thm "ball_empty"]@(thms "my_simp_list")))
+
+val ParallelConseq = (simp_tac (HOL_basic_ss addsimps (thms "ParallelConseq_list")@(thms "my_simp_list")))
+*}
+
+text {* The following tactic applies @{text tac} to each conjunct in a
+subgoal of the form @{text "A \<Longrightarrow> a1 \<and> a2 \<and> .. \<and> an"} returning
+@{text n} subgoals, one for each conjunct: *}
+
+ML {*
+fun conjI_Tac tac i st = st |>
+ ( (EVERY [rtac conjI i,
+ conjI_Tac tac (i+1),
+ tac i]) ORELSE (tac i) )
+*}
+
+
+subsubsection {* Tactic for the generation of the verification conditions *}
+
+text {* The tactic basically uses two subtactics:
+
+\begin{description}
+
+\item[HoareRuleTac] is called at the level of parallel programs, it
+ uses the ParallelTac to solve parallel composition of programs.
+ This verification has two parts, namely, (1) all component programs are
+ correct and (2) they are interference free. @{text HoareRuleTac} is
+ also called at the level of atomic regions, i.e. @{text "\<langle> \<rangle>"} and
+ @{text "AWAIT b THEN _ END"}, and at each interference freedom test.
+
+\item[AnnHoareRuleTac] is for component programs which
+ are annotated programs and so, there are not unknown assertions
+ (no need to use the parameter precond, see NOTE).
+
+ NOTE: precond(::bool) informs if the subgoal has the form @{text "\<parallel>- ?p c q"},
+ in this case we have precond=False and the generated verification
+ condition would have the form @{text "?p \<subseteq> \<dots>"} which can be solved by
+ @{text "rtac subset_refl"}, if True we proceed to simplify it using
+ the simplification tactics above.
+
+\end{description}
+*}
+
+ML {*
+
+ fun WlpTac i = (rtac (@{thm SeqRule}) i) THEN (HoareRuleTac false (i+1))
+and HoareRuleTac precond i st = st |>
+ ( (WlpTac i THEN HoareRuleTac precond i)
+ ORELSE
+ (FIRST[rtac (@{thm SkipRule}) i,
+ rtac (@{thm BasicRule}) i,
+ EVERY[rtac (@{thm ParallelConseqRule}) i,
+ ParallelConseq (i+2),
+ ParallelTac (i+1),
+ ParallelConseq i],
+ EVERY[rtac (@{thm CondRule}) i,
+ HoareRuleTac false (i+2),
+ HoareRuleTac false (i+1)],
+ EVERY[rtac (@{thm WhileRule}) i,
+ HoareRuleTac true (i+1)],
+ K all_tac i ]
+ THEN (if precond then (K all_tac i) else (rtac (@{thm subset_refl}) i))))
+
+and AnnWlpTac i = (rtac (@{thm AnnSeq}) i) THEN (AnnHoareRuleTac (i+1))
+and AnnHoareRuleTac i st = st |>
+ ( (AnnWlpTac i THEN AnnHoareRuleTac i )
+ ORELSE
+ (FIRST[(rtac (@{thm AnnskipRule}) i),
+ EVERY[rtac (@{thm AnnatomRule}) i,
+ HoareRuleTac true (i+1)],
+ (rtac (@{thm AnnwaitRule}) i),
+ rtac (@{thm AnnBasic}) i,
+ EVERY[rtac (@{thm AnnCond1}) i,
+ AnnHoareRuleTac (i+3),
+ AnnHoareRuleTac (i+1)],
+ EVERY[rtac (@{thm AnnCond2}) i,
+ AnnHoareRuleTac (i+1)],
+ EVERY[rtac (@{thm AnnWhile}) i,
+ AnnHoareRuleTac (i+2)],
+ EVERY[rtac (@{thm AnnAwait}) i,
+ HoareRuleTac true (i+1)],
+ K all_tac i]))
+
+and ParallelTac i = EVERY[rtac (@{thm ParallelRule}) i,
+ interfree_Tac (i+1),
+ MapAnn_Tac i]
+
+and MapAnn_Tac i st = st |>
+ (FIRST[rtac (@{thm MapAnnEmpty}) i,
+ EVERY[rtac (@{thm MapAnnList}) i,
+ MapAnn_Tac (i+1),
+ AnnHoareRuleTac i],
+ EVERY[rtac (@{thm MapAnnMap}) i,
+ rtac (@{thm allI}) i,rtac (@{thm impI}) i,
+ AnnHoareRuleTac i]])
+
+and interfree_swap_Tac i st = st |>
+ (FIRST[rtac (@{thm interfree_swap_Empty}) i,
+ EVERY[rtac (@{thm interfree_swap_List}) i,
+ interfree_swap_Tac (i+2),
+ interfree_aux_Tac (i+1),
+ interfree_aux_Tac i ],
+ EVERY[rtac (@{thm interfree_swap_Map}) i,
+ rtac (@{thm allI}) i,rtac (@{thm impI}) i,
+ conjI_Tac (interfree_aux_Tac) i]])
+
+and interfree_Tac i st = st |>
+ (FIRST[rtac (@{thm interfree_Empty}) i,
+ EVERY[rtac (@{thm interfree_List}) i,
+ interfree_Tac (i+1),
+ interfree_swap_Tac i],
+ EVERY[rtac (@{thm interfree_Map}) i,
+ rtac (@{thm allI}) i,rtac (@{thm allI}) i,rtac (@{thm impI}) i,
+ interfree_aux_Tac i ]])
+
+and interfree_aux_Tac i = (before_interfree_simp_tac i ) THEN
+ (FIRST[rtac (@{thm interfree_aux_rule1}) i,
+ dest_assertions_Tac i])
+
+and dest_assertions_Tac i st = st |>
+ (FIRST[EVERY[rtac (@{thm AnnBasic_assertions}) i,
+ dest_atomics_Tac (i+1),
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm AnnSeq_assertions}) i,
+ dest_assertions_Tac (i+1),
+ dest_assertions_Tac i],
+ EVERY[rtac (@{thm AnnCond1_assertions}) i,
+ dest_assertions_Tac (i+2),
+ dest_assertions_Tac (i+1),
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm AnnCond2_assertions}) i,
+ dest_assertions_Tac (i+1),
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm AnnWhile_assertions}) i,
+ dest_assertions_Tac (i+2),
+ dest_atomics_Tac (i+1),
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm AnnAwait_assertions}) i,
+ dest_atomics_Tac (i+1),
+ dest_atomics_Tac i],
+ dest_atomics_Tac i])
+
+and dest_atomics_Tac i st = st |>
+ (FIRST[EVERY[rtac (@{thm AnnBasic_atomics}) i,
+ HoareRuleTac true i],
+ EVERY[rtac (@{thm AnnSeq_atomics}) i,
+ dest_atomics_Tac (i+1),
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm AnnCond1_atomics}) i,
+ dest_atomics_Tac (i+1),
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm AnnCond2_atomics}) i,
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm AnnWhile_atomics}) i,
+ dest_atomics_Tac i],
+ EVERY[rtac (@{thm Annatom_atomics}) i,
+ HoareRuleTac true i],
+ EVERY[rtac (@{thm AnnAwait_atomics}) i,
+ HoareRuleTac true i],
+ K all_tac i])
+*}
+
+
+text {* The final tactic is given the name @{text oghoare}: *}
+
+ML {*
+val oghoare_tac = SUBGOAL (fn (_, i) =>
+ (HoareRuleTac true i))
+*}
+
+text {* Notice that the tactic for parallel programs @{text
+"oghoare_tac"} is initially invoked with the value @{text true} for
+the parameter @{text precond}.
+
+Parts of the tactic can be also individually used to generate the
+verification conditions for annotated sequential programs and to
+generate verification conditions out of interference freedom tests: *}
+
+ML {* val annhoare_tac = SUBGOAL (fn (_, i) =>
+ (AnnHoareRuleTac i))
+
+val interfree_aux_tac = SUBGOAL (fn (_, i) =>
+ (interfree_aux_Tac i))
+*}
+
+text {* The so defined ML tactics are then ``exported'' to be used in
+Isabelle proofs. *}
+
+method_setup oghoare = {*
+ Scan.succeed (K (SIMPLE_METHOD' oghoare_tac)) *}
+ "verification condition generator for the oghoare logic"
+
+method_setup annhoare = {*
+ Scan.succeed (K (SIMPLE_METHOD' annhoare_tac)) *}
+ "verification condition generator for the ann_hoare logic"
+
+method_setup interfree_aux = {*
+ Scan.succeed (K (SIMPLE_METHOD' interfree_aux_tac)) *}
+ "verification condition generator for interference freedom tests"
+
+text {* Tactics useful for dealing with the generated verification conditions: *}
+
+method_setup conjI_tac = {*
+ Scan.succeed (K (SIMPLE_METHOD' (conjI_Tac (K all_tac)))) *}
+ "verification condition generator for interference freedom tests"
+
+ML {*
+fun disjE_Tac tac i st = st |>
+ ( (EVERY [etac disjE i,
+ disjE_Tac tac (i+1),
+ tac i]) ORELSE (tac i) )
+*}
+
+method_setup disjE_tac = {*
+ Scan.succeed (K (SIMPLE_METHOD' (disjE_Tac (K all_tac)))) *}
+ "verification condition generator for interference freedom tests"
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/OG_Tran.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,309 @@
+
+header {* \section{Operational Semantics} *}
+
+theory OG_Tran imports OG_Com begin
+
+types
+ 'a ann_com_op = "('a ann_com) option"
+ 'a ann_triple_op = "('a ann_com_op \<times> 'a assn)"
+
+consts com :: "'a ann_triple_op \<Rightarrow> 'a ann_com_op"
+primrec "com (c, q) = c"
+
+consts post :: "'a ann_triple_op \<Rightarrow> 'a assn"
+primrec "post (c, q) = q"
+
+constdefs
+ All_None :: "'a ann_triple_op list \<Rightarrow> bool"
+ "All_None Ts \<equiv> \<forall>(c, q) \<in> set Ts. c = None"
+
+subsection {* The Transition Relation *}
+
+inductive_set
+ ann_transition :: "(('a ann_com_op \<times> 'a) \<times> ('a ann_com_op \<times> 'a)) set"
+ and transition :: "(('a com \<times> 'a) \<times> ('a com \<times> 'a)) set"
+ and ann_transition' :: "('a ann_com_op \<times> 'a) \<Rightarrow> ('a ann_com_op \<times> 'a) \<Rightarrow> bool"
+ ("_ -1\<rightarrow> _"[81,81] 100)
+ and transition' :: "('a com \<times> 'a) \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
+ ("_ -P1\<rightarrow> _"[81,81] 100)
+ and transitions :: "('a com \<times> 'a) \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
+ ("_ -P*\<rightarrow> _"[81,81] 100)
+where
+ "con_0 -1\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition"
+| "con_0 -P1\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition"
+| "con_0 -P*\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition\<^sup>*"
+
+| AnnBasic: "(Some (AnnBasic r f), s) -1\<rightarrow> (None, f s)"
+
+| AnnSeq1: "(Some c0, s) -1\<rightarrow> (None, t) \<Longrightarrow>
+ (Some (AnnSeq c0 c1), s) -1\<rightarrow> (Some c1, t)"
+| AnnSeq2: "(Some c0, s) -1\<rightarrow> (Some c2, t) \<Longrightarrow>
+ (Some (AnnSeq c0 c1), s) -1\<rightarrow> (Some (AnnSeq c2 c1), t)"
+
+| AnnCond1T: "s \<in> b \<Longrightarrow> (Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (Some c1, s)"
+| AnnCond1F: "s \<notin> b \<Longrightarrow> (Some (AnnCond1 r b c1 c2), s) -1\<rightarrow> (Some c2, s)"
+
+| AnnCond2T: "s \<in> b \<Longrightarrow> (Some (AnnCond2 r b c), s) -1\<rightarrow> (Some c, s)"
+| AnnCond2F: "s \<notin> b \<Longrightarrow> (Some (AnnCond2 r b c), s) -1\<rightarrow> (None, s)"
+
+| AnnWhileF: "s \<notin> b \<Longrightarrow> (Some (AnnWhile r b i c), s) -1\<rightarrow> (None, s)"
+| AnnWhileT: "s \<in> b \<Longrightarrow> (Some (AnnWhile r b i c), s) -1\<rightarrow>
+ (Some (AnnSeq c (AnnWhile i b i c)), s)"
+
+| AnnAwait: "\<lbrakk> s \<in> b; atom_com c; (c, s) -P*\<rightarrow> (Parallel [], t) \<rbrakk> \<Longrightarrow>
+ (Some (AnnAwait r b c), s) -1\<rightarrow> (None, t)"
+
+| Parallel: "\<lbrakk> i<length Ts; Ts!i = (Some c, q); (Some c, s) -1\<rightarrow> (r, t) \<rbrakk>
+ \<Longrightarrow> (Parallel Ts, s) -P1\<rightarrow> (Parallel (Ts [i:=(r, q)]), t)"
+
+| Basic: "(Basic f, s) -P1\<rightarrow> (Parallel [], f s)"
+
+| Seq1: "All_None Ts \<Longrightarrow> (Seq (Parallel Ts) c, s) -P1\<rightarrow> (c, s)"
+| Seq2: "(c0, s) -P1\<rightarrow> (c2, t) \<Longrightarrow> (Seq c0 c1, s) -P1\<rightarrow> (Seq c2 c1, t)"
+
+| CondT: "s \<in> b \<Longrightarrow> (Cond b c1 c2, s) -P1\<rightarrow> (c1, s)"
+| CondF: "s \<notin> b \<Longrightarrow> (Cond b c1 c2, s) -P1\<rightarrow> (c2, s)"
+
+| WhileF: "s \<notin> b \<Longrightarrow> (While b i c, s) -P1\<rightarrow> (Parallel [], s)"
+| WhileT: "s \<in> b \<Longrightarrow> (While b i c, s) -P1\<rightarrow> (Seq c (While b i c), s)"
+
+monos "rtrancl_mono"
+
+text {* The corresponding syntax translations are: *}
+
+abbreviation
+ ann_transition_n :: "('a ann_com_op \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a ann_com_op \<times> 'a)
+ \<Rightarrow> bool" ("_ -_\<rightarrow> _"[81,81] 100) where
+ "con_0 -n\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition ^^ n"
+
+abbreviation
+ ann_transitions :: "('a ann_com_op \<times> 'a) \<Rightarrow> ('a ann_com_op \<times> 'a) \<Rightarrow> bool"
+ ("_ -*\<rightarrow> _"[81,81] 100) where
+ "con_0 -*\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> ann_transition\<^sup>*"
+
+abbreviation
+ transition_n :: "('a com \<times> 'a) \<Rightarrow> nat \<Rightarrow> ('a com \<times> 'a) \<Rightarrow> bool"
+ ("_ -P_\<rightarrow> _"[81,81,81] 100) where
+ "con_0 -Pn\<rightarrow> con_1 \<equiv> (con_0, con_1) \<in> transition ^^ n"
+
+subsection {* Definition of Semantics *}
+
+constdefs
+ ann_sem :: "'a ann_com \<Rightarrow> 'a \<Rightarrow> 'a set"
+ "ann_sem c \<equiv> \<lambda>s. {t. (Some c, s) -*\<rightarrow> (None, t)}"
+
+ ann_SEM :: "'a ann_com \<Rightarrow> 'a set \<Rightarrow> 'a set"
+ "ann_SEM c S \<equiv> \<Union>ann_sem c ` S"
+
+ sem :: "'a com \<Rightarrow> 'a \<Rightarrow> 'a set"
+ "sem c \<equiv> \<lambda>s. {t. \<exists>Ts. (c, s) -P*\<rightarrow> (Parallel Ts, t) \<and> All_None Ts}"
+
+ SEM :: "'a com \<Rightarrow> 'a set \<Rightarrow> 'a set"
+ "SEM c S \<equiv> \<Union>sem c ` S "
+
+syntax "_Omega" :: "'a com" ("\<Omega>" 63)
+translations "\<Omega>" \<rightleftharpoons> "While CONST UNIV CONST UNIV (Basic id)"
+
+consts fwhile :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> nat \<Rightarrow> 'a com"
+primrec
+ "fwhile b c 0 = \<Omega>"
+ "fwhile b c (Suc n) = Cond b (Seq c (fwhile b c n)) (Basic id)"
+
+subsubsection {* Proofs *}
+
+declare ann_transition_transition.intros [intro]
+inductive_cases transition_cases:
+ "(Parallel T,s) -P1\<rightarrow> t"
+ "(Basic f, s) -P1\<rightarrow> t"
+ "(Seq c1 c2, s) -P1\<rightarrow> t"
+ "(Cond b c1 c2, s) -P1\<rightarrow> t"
+ "(While b i c, s) -P1\<rightarrow> t"
+
+lemma Parallel_empty_lemma [rule_format (no_asm)]:
+ "(Parallel [],s) -Pn\<rightarrow> (Parallel Ts,t) \<longrightarrow> Ts=[] \<and> n=0 \<and> s=t"
+apply(induct n)
+ apply(simp (no_asm))
+apply clarify
+apply(drule rel_pow_Suc_D2)
+apply(force elim:transition_cases)
+done
+
+lemma Parallel_AllNone_lemma [rule_format (no_asm)]:
+ "All_None Ss \<longrightarrow> (Parallel Ss,s) -Pn\<rightarrow> (Parallel Ts,t) \<longrightarrow> Ts=Ss \<and> n=0 \<and> s=t"
+apply(induct "n")
+ apply(simp (no_asm))
+apply clarify
+apply(drule rel_pow_Suc_D2)
+apply clarify
+apply(erule transition_cases,simp_all)
+apply(force dest:nth_mem simp add:All_None_def)
+done
+
+lemma Parallel_AllNone: "All_None Ts \<Longrightarrow> (SEM (Parallel Ts) X) = X"
+apply (unfold SEM_def sem_def)
+apply auto
+apply(drule rtrancl_imp_UN_rel_pow)
+apply clarify
+apply(drule Parallel_AllNone_lemma)
+apply auto
+done
+
+lemma Parallel_empty: "Ts=[] \<Longrightarrow> (SEM (Parallel Ts) X) = X"
+apply(rule Parallel_AllNone)
+apply(simp add:All_None_def)
+done
+
+text {* Set of lemmas from Apt and Olderog "Verification of sequential
+and concurrent programs", page 63. *}
+
+lemma L3_5i: "X\<subseteq>Y \<Longrightarrow> SEM c X \<subseteq> SEM c Y"
+apply (unfold SEM_def)
+apply force
+done
+
+lemma L3_5ii_lemma1:
+ "\<lbrakk> (c1, s1) -P*\<rightarrow> (Parallel Ts, s2); All_None Ts;
+ (c2, s2) -P*\<rightarrow> (Parallel Ss, s3); All_None Ss \<rbrakk>
+ \<Longrightarrow> (Seq c1 c2, s1) -P*\<rightarrow> (Parallel Ss, s3)"
+apply(erule converse_rtrancl_induct2)
+apply(force intro:converse_rtrancl_into_rtrancl)+
+done
+
+lemma L3_5ii_lemma2 [rule_format (no_asm)]:
+ "\<forall>c1 c2 s t. (Seq c1 c2, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow>
+ (All_None Ts) \<longrightarrow> (\<exists>y m Rs. (c1,s) -P*\<rightarrow> (Parallel Rs, y) \<and>
+ (All_None Rs) \<and> (c2, y) -Pm\<rightarrow> (Parallel Ts, t) \<and> m \<le> n)"
+apply(induct "n")
+ apply(force)
+apply(safe dest!: rel_pow_Suc_D2)
+apply(erule transition_cases,simp_all)
+ apply (fast intro!: le_SucI)
+apply (fast intro!: le_SucI elim!: rel_pow_imp_rtrancl converse_rtrancl_into_rtrancl)
+done
+
+lemma L3_5ii_lemma3:
+ "\<lbrakk>(Seq c1 c2,s) -P*\<rightarrow> (Parallel Ts,t); All_None Ts\<rbrakk> \<Longrightarrow>
+ (\<exists>y Rs. (c1,s) -P*\<rightarrow> (Parallel Rs,y) \<and> All_None Rs
+ \<and> (c2,y) -P*\<rightarrow> (Parallel Ts,t))"
+apply(drule rtrancl_imp_UN_rel_pow)
+apply(fast dest: L3_5ii_lemma2 rel_pow_imp_rtrancl)
+done
+
+lemma L3_5ii: "SEM (Seq c1 c2) X = SEM c2 (SEM c1 X)"
+apply (unfold SEM_def sem_def)
+apply auto
+ apply(fast dest: L3_5ii_lemma3)
+apply(fast elim: L3_5ii_lemma1)
+done
+
+lemma L3_5iii: "SEM (Seq (Seq c1 c2) c3) X = SEM (Seq c1 (Seq c2 c3)) X"
+apply (simp (no_asm) add: L3_5ii)
+done
+
+lemma L3_5iv:
+ "SEM (Cond b c1 c2) X = (SEM c1 (X \<inter> b)) Un (SEM c2 (X \<inter> (-b)))"
+apply (unfold SEM_def sem_def)
+apply auto
+apply(erule converse_rtranclE)
+ prefer 2
+ apply (erule transition_cases,simp_all)
+ apply(fast intro: converse_rtrancl_into_rtrancl elim: transition_cases)+
+done
+
+
+lemma L3_5v_lemma1[rule_format]:
+ "(S,s) -Pn\<rightarrow> (T,t) \<longrightarrow> S=\<Omega> \<longrightarrow> (\<not>(\<exists>Rs. T=(Parallel Rs) \<and> All_None Rs))"
+apply (unfold UNIV_def)
+apply(rule nat_less_induct)
+apply safe
+apply(erule rel_pow_E2)
+ apply simp_all
+apply(erule transition_cases)
+ apply simp_all
+apply(erule rel_pow_E2)
+ apply(simp add: Id_def)
+apply(erule transition_cases,simp_all)
+apply clarify
+apply(erule transition_cases,simp_all)
+apply(erule rel_pow_E2,simp)
+apply clarify
+apply(erule transition_cases)
+ apply simp+
+ apply clarify
+ apply(erule transition_cases)
+apply simp_all
+done
+
+lemma L3_5v_lemma2: "\<lbrakk>(\<Omega>, s) -P*\<rightarrow> (Parallel Ts, t); All_None Ts \<rbrakk> \<Longrightarrow> False"
+apply(fast dest: rtrancl_imp_UN_rel_pow L3_5v_lemma1)
+done
+
+lemma L3_5v_lemma3: "SEM (\<Omega>) S = {}"
+apply (unfold SEM_def sem_def)
+apply(fast dest: L3_5v_lemma2)
+done
+
+lemma L3_5v_lemma4 [rule_format]:
+ "\<forall>s. (While b i c, s) -Pn\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow>
+ (\<exists>k. (fwhile b c k, s) -P*\<rightarrow> (Parallel Ts, t))"
+apply(rule nat_less_induct)
+apply safe
+apply(erule rel_pow_E2)
+ apply safe
+apply(erule transition_cases,simp_all)
+ apply (rule_tac x = "1" in exI)
+ apply(force dest: Parallel_empty_lemma intro: converse_rtrancl_into_rtrancl simp add: Id_def)
+apply safe
+apply(drule L3_5ii_lemma2)
+ apply safe
+apply(drule le_imp_less_Suc)
+apply (erule allE , erule impE,assumption)
+apply (erule allE , erule impE, assumption)
+apply safe
+apply (rule_tac x = "k+1" in exI)
+apply(simp (no_asm))
+apply(rule converse_rtrancl_into_rtrancl)
+ apply fast
+apply(fast elim: L3_5ii_lemma1)
+done
+
+lemma L3_5v_lemma5 [rule_format]:
+ "\<forall>s. (fwhile b c k, s) -P*\<rightarrow> (Parallel Ts, t) \<longrightarrow> All_None Ts \<longrightarrow>
+ (While b i c, s) -P*\<rightarrow> (Parallel Ts,t)"
+apply(induct "k")
+ apply(force dest: L3_5v_lemma2)
+apply safe
+apply(erule converse_rtranclE)
+ apply simp_all
+apply(erule transition_cases,simp_all)
+ apply(rule converse_rtrancl_into_rtrancl)
+ apply(fast)
+ apply(fast elim!: L3_5ii_lemma1 dest: L3_5ii_lemma3)
+apply(drule rtrancl_imp_UN_rel_pow)
+apply clarify
+apply(erule rel_pow_E2)
+ apply simp_all
+apply(erule transition_cases,simp_all)
+apply(fast dest: Parallel_empty_lemma)
+done
+
+lemma L3_5v: "SEM (While b i c) = (\<lambda>x. (\<Union>k. SEM (fwhile b c k) x))"
+apply(rule ext)
+apply (simp add: SEM_def sem_def)
+apply safe
+ apply(drule rtrancl_imp_UN_rel_pow,simp)
+ apply clarify
+ apply(fast dest:L3_5v_lemma4)
+apply(fast intro: L3_5v_lemma5)
+done
+
+section {* Validity of Correctness Formulas *}
+
+constdefs
+ com_validity :: "'a assn \<Rightarrow> 'a com \<Rightarrow> 'a assn \<Rightarrow> bool" ("(3\<parallel>= _// _//_)" [90,55,90] 50)
+ "\<parallel>= p c q \<equiv> SEM c p \<subseteq> q"
+
+ ann_com_validity :: "'a ann_com \<Rightarrow> 'a assn \<Rightarrow> bool" ("\<Turnstile> _ _" [60,90] 45)
+ "\<Turnstile> c q \<equiv> ann_SEM c (pre c) \<subseteq> q"
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/Quote_Antiquote.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,24 @@
+
+header {* \section{Concrete Syntax} *}
+
+theory Quote_Antiquote imports Main begin
+
+syntax
+ "_quote" :: "'b \<Rightarrow> ('a \<Rightarrow> 'b)" ("(\<guillemotleft>_\<guillemotright>)" [0] 1000)
+ "_antiquote" :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b" ("\<acute>_" [1000] 1000)
+ "_Assert" :: "'a \<Rightarrow> 'a set" ("(.{_}.)" [0] 1000)
+
+syntax (xsymbols)
+ "_Assert" :: "'a \<Rightarrow> 'a set" ("(\<lbrace>_\<rbrace>)" [0] 1000)
+
+translations
+ ".{b}." \<rightharpoonup> "Collect \<guillemotleft>b\<guillemotright>"
+
+parse_translation {*
+ let
+ fun quote_tr [t] = Syntax.quote_tr "_antiquote" t
+ | quote_tr ts = raise TERM ("quote_tr", ts);
+ in [("_quote", quote_tr)] end
+*}
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/RG_Com.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,25 @@
+
+header {* \chapter{The Rely-Guarantee Method}
+
+\section {Abstract Syntax}
+*}
+
+theory RG_Com imports Main begin
+
+text {* Semantics of assertions and boolean expressions (bexp) as sets
+of states. Syntax of commands @{text com} and parallel commands
+@{text par_com}. *}
+
+types
+ 'a bexp = "'a set"
+
+datatype 'a com =
+ Basic "'a \<Rightarrow>'a"
+ | Seq "'a com" "'a com"
+ | Cond "'a bexp" "'a com" "'a com"
+ | While "'a bexp" "'a com"
+ | Await "'a bexp" "'a com"
+
+types 'a par_com = "(('a com) option) list"
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/RG_Examples.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,359 @@
+header {* \section{Examples} *}
+
+theory RG_Examples
+imports RG_Syntax
+begin
+
+lemmas definitions [simp]= stable_def Pre_def Rely_def Guar_def Post_def Com_def
+
+subsection {* Set Elements of an Array to Zero *}
+
+lemma le_less_trans2: "\<lbrakk>(j::nat)<k; i\<le> j\<rbrakk> \<Longrightarrow> i<k"
+by simp
+
+lemma add_le_less_mono: "\<lbrakk> (a::nat) < c; b\<le>d \<rbrakk> \<Longrightarrow> a + b < c + d"
+by simp
+
+record Example1 =
+ A :: "nat list"
+
+lemma Example1:
+ "\<turnstile> COBEGIN
+ SCHEME [0 \<le> i < n]
+ (\<acute>A := \<acute>A [i := 0],
+ \<lbrace> n < length \<acute>A \<rbrace>,
+ \<lbrace> length \<ordmasculine>A = length \<ordfeminine>A \<and> \<ordmasculine>A ! i = \<ordfeminine>A ! i \<rbrace>,
+ \<lbrace> length \<ordmasculine>A = length \<ordfeminine>A \<and> (\<forall>j<n. i \<noteq> j \<longrightarrow> \<ordmasculine>A ! j = \<ordfeminine>A ! j) \<rbrace>,
+ \<lbrace> \<acute>A ! i = 0 \<rbrace>)
+ COEND
+ SAT [\<lbrace> n < length \<acute>A \<rbrace>, \<lbrace> \<ordmasculine>A = \<ordfeminine>A \<rbrace>, \<lbrace> True \<rbrace>, \<lbrace> \<forall>i < n. \<acute>A ! i = 0 \<rbrace>]"
+apply(rule Parallel)
+apply (auto intro!: Basic)
+done
+
+lemma Example1_parameterized:
+"k < t \<Longrightarrow>
+ \<turnstile> COBEGIN
+ SCHEME [k*n\<le>i<(Suc k)*n] (\<acute>A:=\<acute>A[i:=0],
+ \<lbrace>t*n < length \<acute>A\<rbrace>,
+ \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> \<ordmasculine>A!i = \<ordfeminine>A!i\<rbrace>,
+ \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> (\<forall>j<length \<ordmasculine>A . i\<noteq>j \<longrightarrow> \<ordmasculine>A!j = \<ordfeminine>A!j)\<rbrace>,
+ \<lbrace>\<acute>A!i=0\<rbrace>)
+ COEND
+ SAT [\<lbrace>t*n < length \<acute>A\<rbrace>,
+ \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and> (\<forall>i<n. \<ordmasculine>A!(k*n+i)=\<ordfeminine>A!(k*n+i))\<rbrace>,
+ \<lbrace>t*n < length \<ordmasculine>A \<and> length \<ordmasculine>A=length \<ordfeminine>A \<and>
+ (\<forall>i<length \<ordmasculine>A . (i<k*n \<longrightarrow> \<ordmasculine>A!i = \<ordfeminine>A!i) \<and> ((Suc k)*n \<le> i\<longrightarrow> \<ordmasculine>A!i = \<ordfeminine>A!i))\<rbrace>,
+ \<lbrace>\<forall>i<n. \<acute>A!(k*n+i) = 0\<rbrace>]"
+apply(rule Parallel)
+ apply auto
+ apply(erule_tac x="k*n +i" in allE)
+ apply(subgoal_tac "k*n+i <length (A b)")
+ apply force
+ apply(erule le_less_trans2)
+ apply(case_tac t,simp+)
+ apply (simp add:add_commute)
+ apply(simp add: add_le_mono)
+apply(rule Basic)
+ apply simp
+ apply clarify
+ apply (subgoal_tac "k*n+i< length (A x)")
+ apply simp
+ apply(erule le_less_trans2)
+ apply(case_tac t,simp+)
+ apply (simp add:add_commute)
+ apply(rule add_le_mono, auto)
+done
+
+
+subsection {* Increment a Variable in Parallel *}
+
+subsubsection {* Two components *}
+
+record Example2 =
+ x :: nat
+ c_0 :: nat
+ c_1 :: nat
+
+lemma Example2:
+ "\<turnstile> COBEGIN
+ (\<langle> \<acute>x:=\<acute>x+1;; \<acute>c_0:=\<acute>c_0 + 1 \<rangle>,
+ \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_0=0\<rbrace>,
+ \<lbrace>\<ordmasculine>c_0 = \<ordfeminine>c_0 \<and>
+ (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
+ \<longrightarrow> \<ordfeminine>x = \<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
+ \<lbrace>\<ordmasculine>c_1 = \<ordfeminine>c_1 \<and>
+ (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
+ \<longrightarrow> \<ordfeminine>x =\<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
+ \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_0=1 \<rbrace>)
+ \<parallel>
+ (\<langle> \<acute>x:=\<acute>x+1;; \<acute>c_1:=\<acute>c_1+1 \<rangle>,
+ \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_1=0 \<rbrace>,
+ \<lbrace>\<ordmasculine>c_1 = \<ordfeminine>c_1 \<and>
+ (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
+ \<longrightarrow> \<ordfeminine>x = \<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
+ \<lbrace>\<ordmasculine>c_0 = \<ordfeminine>c_0 \<and>
+ (\<ordmasculine>x=\<ordmasculine>c_0 + \<ordmasculine>c_1
+ \<longrightarrow> \<ordfeminine>x =\<ordfeminine>c_0 + \<ordfeminine>c_1)\<rbrace>,
+ \<lbrace>\<acute>x=\<acute>c_0 + \<acute>c_1 \<and> \<acute>c_1=1\<rbrace>)
+ COEND
+ SAT [\<lbrace>\<acute>x=0 \<and> \<acute>c_0=0 \<and> \<acute>c_1=0\<rbrace>,
+ \<lbrace>\<ordmasculine>x=\<ordfeminine>x \<and> \<ordmasculine>c_0= \<ordfeminine>c_0 \<and> \<ordmasculine>c_1=\<ordfeminine>c_1\<rbrace>,
+ \<lbrace>True\<rbrace>,
+ \<lbrace>\<acute>x=2\<rbrace>]"
+apply(rule Parallel)
+ apply simp_all
+ apply clarify
+ apply(case_tac i)
+ apply simp
+ apply(rule conjI)
+ apply clarify
+ apply simp
+ apply clarify
+ apply simp
+ apply(case_tac j,simp)
+ apply simp
+ apply simp
+ apply(rule conjI)
+ apply clarify
+ apply simp
+ apply clarify
+ apply simp
+ apply(subgoal_tac "j=0")
+ apply (rotate_tac -1)
+ apply (simp (asm_lr))
+ apply arith
+ apply clarify
+ apply(case_tac i,simp,simp)
+ apply clarify
+ apply simp
+ apply(erule_tac x=0 in all_dupE)
+ apply(erule_tac x=1 in allE,simp)
+apply clarify
+apply(case_tac i,simp)
+ apply(rule Await)
+ apply simp_all
+ apply(clarify)
+ apply(rule Seq)
+ prefer 2
+ apply(rule Basic)
+ apply simp_all
+ apply(rule subset_refl)
+ apply(rule Basic)
+ apply simp_all
+ apply clarify
+ apply simp
+apply(rule Await)
+ apply simp_all
+apply(clarify)
+apply(rule Seq)
+ prefer 2
+ apply(rule Basic)
+ apply simp_all
+ apply(rule subset_refl)
+apply(auto intro!: Basic)
+done
+
+subsubsection {* Parameterized *}
+
+lemma Example2_lemma2_aux: "j<n \<Longrightarrow>
+ (\<Sum>i=0..<n. (b i::nat)) =
+ (\<Sum>i=0..<j. b i) + b j + (\<Sum>i=0..<n-(Suc j) . b (Suc j + i))"
+apply(induct n)
+ apply simp_all
+apply(simp add:less_Suc_eq)
+ apply(auto)
+apply(subgoal_tac "n - j = Suc(n- Suc j)")
+ apply simp
+apply arith
+done
+
+lemma Example2_lemma2_aux2:
+ "j\<le> s \<Longrightarrow> (\<Sum>i::nat=0..<j. (b (s:=t)) i) = (\<Sum>i=0..<j. b i)"
+apply(induct j)
+ apply (simp_all cong:setsum_cong)
+done
+
+lemma Example2_lemma2:
+ "\<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow> Suc (\<Sum>i::nat=0..<n. b i)=(\<Sum>i=0..<n. (b (j := Suc 0)) i)"
+apply(frule_tac b="(b (j:=(Suc 0)))" in Example2_lemma2_aux)
+apply(erule_tac t="setsum (b(j := (Suc 0))) {0..<n}" in ssubst)
+apply(frule_tac b=b in Example2_lemma2_aux)
+apply(erule_tac t="setsum b {0..<n}" in ssubst)
+apply(subgoal_tac "Suc (setsum b {0..<j} + b j + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))=(setsum b {0..<j} + Suc (b j) + (\<Sum>i=0..<n - Suc j. b (Suc j + i)))")
+apply(rotate_tac -1)
+apply(erule ssubst)
+apply(subgoal_tac "j\<le>j")
+ apply(drule_tac b="b" and t="(Suc 0)" in Example2_lemma2_aux2)
+apply(rotate_tac -1)
+apply(erule ssubst)
+apply simp_all
+done
+
+lemma Example2_lemma2_Suc0: "\<lbrakk>j<n; b j=0\<rbrakk> \<Longrightarrow>
+ Suc (\<Sum>i::nat=0..< n. b i)=(\<Sum>i=0..< n. (b (j:=Suc 0)) i)"
+by(simp add:Example2_lemma2)
+
+record Example2_parameterized =
+ C :: "nat \<Rightarrow> nat"
+ y :: nat
+
+lemma Example2_parameterized: "0<n \<Longrightarrow>
+ \<turnstile> COBEGIN SCHEME [0\<le>i<n]
+ (\<langle> \<acute>y:=\<acute>y+1;; \<acute>C:=\<acute>C (i:=1) \<rangle>,
+ \<lbrace>\<acute>y=(\<Sum>i=0..<n. \<acute>C i) \<and> \<acute>C i=0\<rbrace>,
+ \<lbrace>\<ordmasculine>C i = \<ordfeminine>C i \<and>
+ (\<ordmasculine>y=(\<Sum>i=0..<n. \<ordmasculine>C i) \<longrightarrow> \<ordfeminine>y =(\<Sum>i=0..<n. \<ordfeminine>C i))\<rbrace>,
+ \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>C j = \<ordfeminine>C j) \<and>
+ (\<ordmasculine>y=(\<Sum>i=0..<n. \<ordmasculine>C i) \<longrightarrow> \<ordfeminine>y =(\<Sum>i=0..<n. \<ordfeminine>C i))\<rbrace>,
+ \<lbrace>\<acute>y=(\<Sum>i=0..<n. \<acute>C i) \<and> \<acute>C i=1\<rbrace>)
+ COEND
+ SAT [\<lbrace>\<acute>y=0 \<and> (\<Sum>i=0..<n. \<acute>C i)=0 \<rbrace>, \<lbrace>\<ordmasculine>C=\<ordfeminine>C \<and> \<ordmasculine>y=\<ordfeminine>y\<rbrace>, \<lbrace>True\<rbrace>, \<lbrace>\<acute>y=n\<rbrace>]"
+apply(rule Parallel)
+apply force
+apply force
+apply(force)
+apply clarify
+apply simp
+apply(simp cong:setsum_ivl_cong)
+apply clarify
+apply simp
+apply(rule Await)
+apply simp_all
+apply clarify
+apply(rule Seq)
+prefer 2
+apply(rule Basic)
+apply(rule subset_refl)
+apply simp+
+apply(rule Basic)
+apply simp
+apply clarify
+apply simp
+apply(simp add:Example2_lemma2_Suc0 cong:if_cong)
+apply simp+
+done
+
+subsection {* Find Least Element *}
+
+text {* A previous lemma: *}
+
+lemma mod_aux :"\<lbrakk>i < (n::nat); a mod n = i; j < a + n; j mod n = i; a < j\<rbrakk> \<Longrightarrow> False"
+apply(subgoal_tac "a=a div n*n + a mod n" )
+ prefer 2 apply (simp (no_asm_use))
+apply(subgoal_tac "j=j div n*n + j mod n")
+ prefer 2 apply (simp (no_asm_use))
+apply simp
+apply(subgoal_tac "a div n*n < j div n*n")
+prefer 2 apply arith
+apply(subgoal_tac "j div n*n < (a div n + 1)*n")
+prefer 2 apply simp
+apply (simp only:mult_less_cancel2)
+apply arith
+done
+
+record Example3 =
+ X :: "nat \<Rightarrow> nat"
+ Y :: "nat \<Rightarrow> nat"
+
+lemma Example3: "m mod n=0 \<Longrightarrow>
+ \<turnstile> COBEGIN
+ SCHEME [0\<le>i<n]
+ (WHILE (\<forall>j<n. \<acute>X i < \<acute>Y j) DO
+ IF P(B!(\<acute>X i)) THEN \<acute>Y:=\<acute>Y (i:=\<acute>X i)
+ ELSE \<acute>X:= \<acute>X (i:=(\<acute>X i)+ n) FI
+ OD,
+ \<lbrace>(\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i)\<rbrace>,
+ \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordfeminine>Y j \<le> \<ordmasculine>Y j) \<and> \<ordmasculine>X i = \<ordfeminine>X i \<and>
+ \<ordmasculine>Y i = \<ordfeminine>Y i\<rbrace>,
+ \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>X j = \<ordfeminine>X j \<and> \<ordmasculine>Y j = \<ordfeminine>Y j) \<and>
+ \<ordfeminine>Y i \<le> \<ordmasculine>Y i\<rbrace>,
+ \<lbrace>(\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y j \<le> \<acute>X i) \<rbrace>)
+ COEND
+ SAT [\<lbrace> \<forall>i<n. \<acute>X i=i \<and> \<acute>Y i=m+i \<rbrace>,\<lbrace>\<ordmasculine>X=\<ordfeminine>X \<and> \<ordmasculine>Y=\<ordfeminine>Y\<rbrace>,\<lbrace>True\<rbrace>,
+ \<lbrace>\<forall>i<n. (\<acute>X i) mod n=i \<and> (\<forall>j<\<acute>X i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and>
+ (\<acute>Y i<m \<longrightarrow> P(B!(\<acute>Y i)) \<and> \<acute>Y i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y j \<le> \<acute>X i)\<rbrace>]"
+apply(rule Parallel)
+--{*5 subgoals left *}
+apply force+
+apply clarify
+apply simp
+apply(rule While)
+ apply force
+ apply force
+ apply force
+ apply(rule_tac pre'="\<lbrace> \<acute>X i mod n = i \<and> (\<forall>j. j<\<acute>X i \<longrightarrow> j mod n = i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y i < n * q \<longrightarrow> P (B!(\<acute>Y i))) \<and> \<acute>X i<\<acute>Y i\<rbrace>" in Conseq)
+ apply force
+ apply(rule subset_refl)+
+ apply(rule Cond)
+ apply force
+ apply(rule Basic)
+ apply force
+ apply fastsimp
+ apply force
+ apply force
+ apply(rule Basic)
+ apply simp
+ apply clarify
+ apply simp
+ apply (case_tac "X x (j mod n) \<le> j")
+ apply (drule le_imp_less_or_eq)
+ apply (erule disjE)
+ apply (drule_tac j=j and n=n and i="j mod n" and a="X x (j mod n)" in mod_aux)
+ apply auto
+done
+
+text {* Same but with a list as auxiliary variable: *}
+
+record Example3_list =
+ X :: "nat list"
+ Y :: "nat list"
+
+lemma Example3_list: "m mod n=0 \<Longrightarrow> \<turnstile> (COBEGIN SCHEME [0\<le>i<n]
+ (WHILE (\<forall>j<n. \<acute>X!i < \<acute>Y!j) DO
+ IF P(B!(\<acute>X!i)) THEN \<acute>Y:=\<acute>Y[i:=\<acute>X!i] ELSE \<acute>X:= \<acute>X[i:=(\<acute>X!i)+ n] FI
+ OD,
+ \<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> (\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i)\<rbrace>,
+ \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordfeminine>Y!j \<le> \<ordmasculine>Y!j) \<and> \<ordmasculine>X!i = \<ordfeminine>X!i \<and>
+ \<ordmasculine>Y!i = \<ordfeminine>Y!i \<and> length \<ordmasculine>X = length \<ordfeminine>X \<and> length \<ordmasculine>Y = length \<ordfeminine>Y\<rbrace>,
+ \<lbrace>(\<forall>j<n. i\<noteq>j \<longrightarrow> \<ordmasculine>X!j = \<ordfeminine>X!j \<and> \<ordmasculine>Y!j = \<ordfeminine>Y!j) \<and>
+ \<ordfeminine>Y!i \<le> \<ordmasculine>Y!i \<and> length \<ordmasculine>X = length \<ordfeminine>X \<and> length \<ordmasculine>Y = length \<ordfeminine>Y\<rbrace>,
+ \<lbrace>(\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and> (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y!j \<le> \<acute>X!i) \<rbrace>) COEND)
+ SAT [\<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> (\<forall>i<n. \<acute>X!i=i \<and> \<acute>Y!i=m+i) \<rbrace>,
+ \<lbrace>\<ordmasculine>X=\<ordfeminine>X \<and> \<ordmasculine>Y=\<ordfeminine>Y\<rbrace>,
+ \<lbrace>True\<rbrace>,
+ \<lbrace>\<forall>i<n. (\<acute>X!i) mod n=i \<and> (\<forall>j<\<acute>X!i. j mod n=i \<longrightarrow> \<not>P(B!j)) \<and>
+ (\<acute>Y!i<m \<longrightarrow> P(B!(\<acute>Y!i)) \<and> \<acute>Y!i\<le> m+i) \<and> (\<exists>j<n. \<acute>Y!j \<le> \<acute>X!i)\<rbrace>]"
+apply(rule Parallel)
+--{* 5 subgoals left *}
+apply force+
+apply clarify
+apply simp
+apply(rule While)
+ apply force
+ apply force
+ apply force
+ apply(rule_tac pre'="\<lbrace>n<length \<acute>X \<and> n<length \<acute>Y \<and> \<acute>X ! i mod n = i \<and> (\<forall>j. j < \<acute>X ! i \<longrightarrow> j mod n = i \<longrightarrow> \<not> P (B ! j)) \<and> (\<acute>Y ! i < n * q \<longrightarrow> P (B ! (\<acute>Y ! i))) \<and> \<acute>X!i<\<acute>Y!i\<rbrace>" in Conseq)
+ apply force
+ apply(rule subset_refl)+
+ apply(rule Cond)
+ apply force
+ apply(rule Basic)
+ apply force
+ apply force
+ apply force
+ apply force
+ apply(rule Basic)
+ apply simp
+ apply clarify
+ apply simp
+ apply(rule allI)
+ apply(rule impI)+
+ apply(case_tac "X x ! i\<le> j")
+ apply(drule le_imp_less_or_eq)
+ apply(erule disjE)
+ apply(drule_tac j=j and n=n and i=i and a="X x ! i" in mod_aux)
+ apply auto
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/RG_Hoare.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,1375 @@
+header {* \section{The Proof System} *}
+
+theory RG_Hoare imports RG_Tran begin
+
+subsection {* Proof System for Component Programs *}
+
+declare Un_subset_iff [iff del]
+declare Cons_eq_map_conv[iff]
+
+constdefs
+ stable :: "'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> bool"
+ "stable \<equiv> \<lambda>f g. (\<forall>x y. x \<in> f \<longrightarrow> (x, y) \<in> g \<longrightarrow> y \<in> f)"
+
+inductive
+ rghoare :: "['a com, 'a set, ('a \<times> 'a) set, ('a \<times> 'a) set, 'a set] \<Rightarrow> bool"
+ ("\<turnstile> _ sat [_, _, _, _]" [60,0,0,0,0] 45)
+where
+ Basic: "\<lbrakk> pre \<subseteq> {s. f s \<in> post}; {(s,t). s \<in> pre \<and> (t=f s \<or> t=s)} \<subseteq> guar;
+ stable pre rely; stable post rely \<rbrakk>
+ \<Longrightarrow> \<turnstile> Basic f sat [pre, rely, guar, post]"
+
+| Seq: "\<lbrakk> \<turnstile> P sat [pre, rely, guar, mid]; \<turnstile> Q sat [mid, rely, guar, post] \<rbrakk>
+ \<Longrightarrow> \<turnstile> Seq P Q sat [pre, rely, guar, post]"
+
+| Cond: "\<lbrakk> stable pre rely; \<turnstile> P1 sat [pre \<inter> b, rely, guar, post];
+ \<turnstile> P2 sat [pre \<inter> -b, rely, guar, post]; \<forall>s. (s,s)\<in>guar \<rbrakk>
+ \<Longrightarrow> \<turnstile> Cond b P1 P2 sat [pre, rely, guar, post]"
+
+| While: "\<lbrakk> stable pre rely; (pre \<inter> -b) \<subseteq> post; stable post rely;
+ \<turnstile> P sat [pre \<inter> b, rely, guar, pre]; \<forall>s. (s,s)\<in>guar \<rbrakk>
+ \<Longrightarrow> \<turnstile> While b P sat [pre, rely, guar, post]"
+
+| Await: "\<lbrakk> stable pre rely; stable post rely;
+ \<forall>V. \<turnstile> P sat [pre \<inter> b \<inter> {V}, {(s, t). s = t},
+ UNIV, {s. (V, s) \<in> guar} \<inter> post] \<rbrakk>
+ \<Longrightarrow> \<turnstile> Await b P sat [pre, rely, guar, post]"
+
+| Conseq: "\<lbrakk> pre \<subseteq> pre'; rely \<subseteq> rely'; guar' \<subseteq> guar; post' \<subseteq> post;
+ \<turnstile> P sat [pre', rely', guar', post'] \<rbrakk>
+ \<Longrightarrow> \<turnstile> P sat [pre, rely, guar, post]"
+
+constdefs
+ Pre :: "'a rgformula \<Rightarrow> 'a set"
+ "Pre x \<equiv> fst(snd x)"
+ Post :: "'a rgformula \<Rightarrow> 'a set"
+ "Post x \<equiv> snd(snd(snd(snd x)))"
+ Rely :: "'a rgformula \<Rightarrow> ('a \<times> 'a) set"
+ "Rely x \<equiv> fst(snd(snd x))"
+ Guar :: "'a rgformula \<Rightarrow> ('a \<times> 'a) set"
+ "Guar x \<equiv> fst(snd(snd(snd x)))"
+ Com :: "'a rgformula \<Rightarrow> 'a com"
+ "Com x \<equiv> fst x"
+
+subsection {* Proof System for Parallel Programs *}
+
+types 'a par_rgformula = "('a rgformula) list \<times> 'a set \<times> ('a \<times> 'a) set \<times> ('a \<times> 'a) set \<times> 'a set"
+
+inductive
+ par_rghoare :: "('a rgformula) list \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> bool"
+ ("\<turnstile> _ SAT [_, _, _, _]" [60,0,0,0,0] 45)
+where
+ Parallel:
+ "\<lbrakk> \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j<length xs \<and> j\<noteq>i}. Guar(xs!j)) \<subseteq> Rely(xs!i);
+ (\<Union>j\<in>{j. j<length xs}. Guar(xs!j)) \<subseteq> guar;
+ pre \<subseteq> (\<Inter>i\<in>{i. i<length xs}. Pre(xs!i));
+ (\<Inter>i\<in>{i. i<length xs}. Post(xs!i)) \<subseteq> post;
+ \<forall>i<length xs. \<turnstile> Com(xs!i) sat [Pre(xs!i),Rely(xs!i),Guar(xs!i),Post(xs!i)] \<rbrakk>
+ \<Longrightarrow> \<turnstile> xs SAT [pre, rely, guar, post]"
+
+section {* Soundness*}
+
+subsubsection {* Some previous lemmas *}
+
+lemma tl_of_assum_in_assum:
+ "(P, s) # (P, t) # xs \<in> assum (pre, rely) \<Longrightarrow> stable pre rely
+ \<Longrightarrow> (P, t) # xs \<in> assum (pre, rely)"
+apply(simp add:assum_def)
+apply clarify
+apply(rule conjI)
+ apply(erule_tac x=0 in allE)
+ apply(simp (no_asm_use)only:stable_def)
+ apply(erule allE,erule allE,erule impE,assumption,erule mp)
+ apply(simp add:Env)
+apply clarify
+apply(erule_tac x="Suc i" in allE)
+apply simp
+done
+
+lemma etran_in_comm:
+ "(P, t) # xs \<in> comm(guar, post) \<Longrightarrow> (P, s) # (P, t) # xs \<in> comm(guar, post)"
+apply(simp add:comm_def)
+apply clarify
+apply(case_tac i,simp+)
+done
+
+lemma ctran_in_comm:
+ "\<lbrakk>(s, s) \<in> guar; (Q, s) # xs \<in> comm(guar, post)\<rbrakk>
+ \<Longrightarrow> (P, s) # (Q, s) # xs \<in> comm(guar, post)"
+apply(simp add:comm_def)
+apply clarify
+apply(case_tac i,simp+)
+done
+
+lemma takecptn_is_cptn [rule_format, elim!]:
+ "\<forall>j. c \<in> cptn \<longrightarrow> take (Suc j) c \<in> cptn"
+apply(induct "c")
+ apply(force elim: cptn.cases)
+apply clarify
+apply(case_tac j)
+ apply simp
+ apply(rule CptnOne)
+apply simp
+apply(force intro:cptn.intros elim:cptn.cases)
+done
+
+lemma dropcptn_is_cptn [rule_format,elim!]:
+ "\<forall>j<length c. c \<in> cptn \<longrightarrow> drop j c \<in> cptn"
+apply(induct "c")
+ apply(force elim: cptn.cases)
+apply clarify
+apply(case_tac j,simp+)
+apply(erule cptn.cases)
+ apply simp
+ apply force
+apply force
+done
+
+lemma takepar_cptn_is_par_cptn [rule_format,elim]:
+ "\<forall>j. c \<in> par_cptn \<longrightarrow> take (Suc j) c \<in> par_cptn"
+apply(induct "c")
+ apply(force elim: cptn.cases)
+apply clarify
+apply(case_tac j,simp)
+ apply(rule ParCptnOne)
+apply(force intro:par_cptn.intros elim:par_cptn.cases)
+done
+
+lemma droppar_cptn_is_par_cptn [rule_format]:
+ "\<forall>j<length c. c \<in> par_cptn \<longrightarrow> drop j c \<in> par_cptn"
+apply(induct "c")
+ apply(force elim: par_cptn.cases)
+apply clarify
+apply(case_tac j,simp+)
+apply(erule par_cptn.cases)
+ apply simp
+ apply force
+apply force
+done
+
+lemma tl_of_cptn_is_cptn: "\<lbrakk>x # xs \<in> cptn; xs \<noteq> []\<rbrakk> \<Longrightarrow> xs \<in> cptn"
+apply(subgoal_tac "1 < length (x # xs)")
+ apply(drule dropcptn_is_cptn,simp+)
+done
+
+lemma not_ctran_None [rule_format]:
+ "\<forall>s. (None, s)#xs \<in> cptn \<longrightarrow> (\<forall>i<length xs. ((None, s)#xs)!i -e\<rightarrow> xs!i)"
+apply(induct xs,simp+)
+apply clarify
+apply(erule cptn.cases,simp)
+ apply simp
+ apply(case_tac i,simp)
+ apply(rule Env)
+ apply simp
+apply(force elim:ctran.cases)
+done
+
+lemma cptn_not_empty [simp]:"[] \<notin> cptn"
+apply(force elim:cptn.cases)
+done
+
+lemma etran_or_ctran [rule_format]:
+ "\<forall>m i. x\<in>cptn \<longrightarrow> m \<le> length x
+ \<longrightarrow> (\<forall>i. Suc i < m \<longrightarrow> \<not> x!i -c\<rightarrow> x!Suc i) \<longrightarrow> Suc i < m
+ \<longrightarrow> x!i -e\<rightarrow> x!Suc i"
+apply(induct x,simp)
+apply clarify
+apply(erule cptn.cases,simp)
+ apply(case_tac i,simp)
+ apply(rule Env)
+ apply simp
+ apply(erule_tac x="m - 1" in allE)
+ apply(case_tac m,simp,simp)
+ apply(subgoal_tac "(\<forall>i. Suc i < nata \<longrightarrow> (((P, t) # xs) ! i, xs ! i) \<notin> ctran)")
+ apply force
+ apply clarify
+ apply(erule_tac x="Suc ia" in allE,simp)
+apply(erule_tac x="0" and P="\<lambda>j. ?H j \<longrightarrow> (?J j) \<notin> ctran" in allE,simp)
+done
+
+lemma etran_or_ctran2 [rule_format]:
+ "\<forall>i. Suc i<length x \<longrightarrow> x\<in>cptn \<longrightarrow> (x!i -c\<rightarrow> x!Suc i \<longrightarrow> \<not> x!i -e\<rightarrow> x!Suc i)
+ \<or> (x!i -e\<rightarrow> x!Suc i \<longrightarrow> \<not> x!i -c\<rightarrow> x!Suc i)"
+apply(induct x)
+ apply simp
+apply clarify
+apply(erule cptn.cases,simp)
+ apply(case_tac i,simp+)
+apply(case_tac i,simp)
+ apply(force elim:etran.cases)
+apply simp
+done
+
+lemma etran_or_ctran2_disjI1:
+ "\<lbrakk> x\<in>cptn; Suc i<length x; x!i -c\<rightarrow> x!Suc i\<rbrakk> \<Longrightarrow> \<not> x!i -e\<rightarrow> x!Suc i"
+by(drule etran_or_ctran2,simp_all)
+
+lemma etran_or_ctran2_disjI2:
+ "\<lbrakk> x\<in>cptn; Suc i<length x; x!i -e\<rightarrow> x!Suc i\<rbrakk> \<Longrightarrow> \<not> x!i -c\<rightarrow> x!Suc i"
+by(drule etran_or_ctran2,simp_all)
+
+lemma not_ctran_None2 [rule_format]:
+ "\<lbrakk> (None, s) # xs \<in>cptn; i<length xs\<rbrakk> \<Longrightarrow> \<not> ((None, s) # xs) ! i -c\<rightarrow> xs ! i"
+apply(frule not_ctran_None,simp)
+apply(case_tac i,simp)
+ apply(force elim:etranE)
+apply simp
+apply(rule etran_or_ctran2_disjI2,simp_all)
+apply(force intro:tl_of_cptn_is_cptn)
+done
+
+lemma Ex_first_occurrence [rule_format]: "P (n::nat) \<longrightarrow> (\<exists>m. P m \<and> (\<forall>i<m. \<not> P i))";
+apply(rule nat_less_induct)
+apply clarify
+apply(case_tac "\<forall>m. m<n \<longrightarrow> \<not> P m")
+apply auto
+done
+
+lemma stability [rule_format]:
+ "\<forall>j k. x \<in> cptn \<longrightarrow> stable p rely \<longrightarrow> j\<le>k \<longrightarrow> k<length x \<longrightarrow> snd(x!j)\<in>p \<longrightarrow>
+ (\<forall>i. (Suc i)<length x \<longrightarrow>
+ (x!i -e\<rightarrow> x!(Suc i)) \<longrightarrow> (snd(x!i), snd(x!(Suc i))) \<in> rely) \<longrightarrow>
+ (\<forall>i. j\<le>i \<and> i<k \<longrightarrow> x!i -e\<rightarrow> x!Suc i) \<longrightarrow> snd(x!k)\<in>p \<and> fst(x!j)=fst(x!k)"
+apply(induct x)
+ apply clarify
+ apply(force elim:cptn.cases)
+apply clarify
+apply(erule cptn.cases,simp)
+ apply simp
+ apply(case_tac k,simp,simp)
+ apply(case_tac j,simp)
+ apply(erule_tac x=0 in allE)
+ apply(erule_tac x="nat" and P="\<lambda>j. (0\<le>j) \<longrightarrow> (?J j)" in allE,simp)
+ apply(subgoal_tac "t\<in>p")
+ apply(subgoal_tac "(\<forall>i. i < length xs \<longrightarrow> ((P, t) # xs) ! i -e\<rightarrow> xs ! i \<longrightarrow> (snd (((P, t) # xs) ! i), snd (xs ! i)) \<in> rely)")
+ apply clarify
+ apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
+ apply clarify
+ apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j) \<longrightarrow> (?T j)\<in>rely" in allE,simp)
+ apply(erule_tac x=0 and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran \<longrightarrow> ?T j" in allE,simp)
+ apply(simp(no_asm_use) only:stable_def)
+ apply(erule_tac x=s in allE)
+ apply(erule_tac x=t in allE)
+ apply simp
+ apply(erule mp)
+ apply(erule mp)
+ apply(rule Env)
+ apply simp
+ apply(erule_tac x="nata" in allE)
+ apply(erule_tac x="nat" and P="\<lambda>j. (?s\<le>j) \<longrightarrow> (?J j)" in allE,simp)
+ apply(subgoal_tac "(\<forall>i. i < length xs \<longrightarrow> ((P, t) # xs) ! i -e\<rightarrow> xs ! i \<longrightarrow> (snd (((P, t) # xs) ! i), snd (xs ! i)) \<in> rely)")
+ apply clarify
+ apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
+ apply clarify
+ apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j) \<longrightarrow> (?T j)\<in>rely" in allE,simp)
+apply(case_tac k,simp,simp)
+apply(case_tac j)
+ apply(erule_tac x=0 and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
+ apply(erule etran.cases,simp)
+apply(erule_tac x="nata" in allE)
+apply(erule_tac x="nat" and P="\<lambda>j. (?s\<le>j) \<longrightarrow> (?J j)" in allE,simp)
+apply(subgoal_tac "(\<forall>i. i < length xs \<longrightarrow> ((Q, t) # xs) ! i -e\<rightarrow> xs ! i \<longrightarrow> (snd (((Q, t) # xs) ! i), snd (xs ! i)) \<in> rely)")
+ apply clarify
+ apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j)\<in>etran" in allE,simp)
+apply clarify
+apply(erule_tac x="Suc i" and P="\<lambda>j. (?H j) \<longrightarrow> (?J j) \<longrightarrow> (?T j)\<in>rely" in allE,simp)
+done
+
+subsection {* Soundness of the System for Component Programs *}
+
+subsubsection {* Soundness of the Basic rule *}
+
+lemma unique_ctran_Basic [rule_format]:
+ "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Basic f), s) \<longrightarrow>
+ Suc i<length x \<longrightarrow> x!i -c\<rightarrow> x!Suc i \<longrightarrow>
+ (\<forall>j. Suc j<length x \<longrightarrow> i\<noteq>j \<longrightarrow> x!j -e\<rightarrow> x!Suc j)"
+apply(induct x,simp)
+apply simp
+apply clarify
+apply(erule cptn.cases,simp)
+ apply(case_tac i,simp+)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(rule Env)
+ apply simp
+apply clarify
+apply simp
+apply(case_tac i)
+ apply(case_tac j,simp,simp)
+ apply(erule ctran.cases,simp_all)
+ apply(force elim: not_ctran_None)
+apply(ind_cases "((Some (Basic f), sa), Q, t) \<in> ctran" for sa Q t)
+apply simp
+apply(drule_tac i=nat in not_ctran_None,simp)
+apply(erule etranE,simp)
+done
+
+lemma exists_ctran_Basic_None [rule_format]:
+ "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Basic f), s)
+ \<longrightarrow> i<length x \<longrightarrow> fst(x!i)=None \<longrightarrow> (\<exists>j<i. x!j -c\<rightarrow> x!Suc j)"
+apply(induct x,simp)
+apply simp
+apply clarify
+apply(erule cptn.cases,simp)
+ apply(case_tac i,simp,simp)
+ apply(erule_tac x=nat in allE,simp)
+ apply clarify
+ apply(rule_tac x="Suc j" in exI,simp,simp)
+apply clarify
+apply(case_tac i,simp,simp)
+apply(rule_tac x=0 in exI,simp)
+done
+
+lemma Basic_sound:
+ " \<lbrakk>pre \<subseteq> {s. f s \<in> post}; {(s, t). s \<in> pre \<and> t = f s} \<subseteq> guar;
+ stable pre rely; stable post rely\<rbrakk>
+ \<Longrightarrow> \<Turnstile> Basic f sat [pre, rely, guar, post]"
+apply(unfold com_validity_def)
+apply clarify
+apply(simp add:comm_def)
+apply(rule conjI)
+ apply clarify
+ apply(simp add:cp_def assum_def)
+ apply clarify
+ apply(frule_tac j=0 and k=i and p=pre in stability)
+ apply simp_all
+ apply(erule_tac x=ia in allE,simp)
+ apply(erule_tac i=i and f=f in unique_ctran_Basic,simp_all)
+ apply(erule subsetD,simp)
+ apply(case_tac "x!i")
+ apply clarify
+ apply(drule_tac s="Some (Basic f)" in sym,simp)
+ apply(thin_tac "\<forall>j. ?H j")
+ apply(force elim:ctran.cases)
+apply clarify
+apply(simp add:cp_def)
+apply clarify
+apply(frule_tac i="length x - 1" and f=f in exists_ctran_Basic_None,simp+)
+ apply(case_tac x,simp+)
+ apply(rule last_fst_esp,simp add:last_length)
+ apply (case_tac x,simp+)
+apply(simp add:assum_def)
+apply clarify
+apply(frule_tac j=0 and k="j" and p=pre in stability)
+ apply simp_all
+ apply(erule_tac x=i in allE,simp)
+ apply(erule_tac i=j and f=f in unique_ctran_Basic,simp_all)
+apply(case_tac "x!j")
+apply clarify
+apply simp
+apply(drule_tac s="Some (Basic f)" in sym,simp)
+apply(case_tac "x!Suc j",simp)
+apply(rule ctran.cases,simp)
+apply(simp_all)
+apply(drule_tac c=sa in subsetD,simp)
+apply clarify
+apply(frule_tac j="Suc j" and k="length x - 1" and p=post in stability,simp_all)
+ apply(case_tac x,simp+)
+ apply(erule_tac x=i in allE)
+apply(erule_tac i=j and f=f in unique_ctran_Basic,simp_all)
+ apply arith+
+apply(case_tac x)
+apply(simp add:last_length)+
+done
+
+subsubsection{* Soundness of the Await rule *}
+
+lemma unique_ctran_Await [rule_format]:
+ "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Await b c), s) \<longrightarrow>
+ Suc i<length x \<longrightarrow> x!i -c\<rightarrow> x!Suc i \<longrightarrow>
+ (\<forall>j. Suc j<length x \<longrightarrow> i\<noteq>j \<longrightarrow> x!j -e\<rightarrow> x!Suc j)"
+apply(induct x,simp+)
+apply clarify
+apply(erule cptn.cases,simp)
+ apply(case_tac i,simp+)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(rule Env)
+ apply simp
+apply clarify
+apply simp
+apply(case_tac i)
+ apply(case_tac j,simp,simp)
+ apply(erule ctran.cases,simp_all)
+ apply(force elim: not_ctran_None)
+apply(ind_cases "((Some (Await b c), sa), Q, t) \<in> ctran" for sa Q t,simp)
+apply(drule_tac i=nat in not_ctran_None,simp)
+apply(erule etranE,simp)
+done
+
+lemma exists_ctran_Await_None [rule_format]:
+ "\<forall>s i. x \<in> cptn \<longrightarrow> x ! 0 = (Some (Await b c), s)
+ \<longrightarrow> i<length x \<longrightarrow> fst(x!i)=None \<longrightarrow> (\<exists>j<i. x!j -c\<rightarrow> x!Suc j)"
+apply(induct x,simp+)
+apply clarify
+apply(erule cptn.cases,simp)
+ apply(case_tac i,simp+)
+ apply(erule_tac x=nat in allE,simp)
+ apply clarify
+ apply(rule_tac x="Suc j" in exI,simp,simp)
+apply clarify
+apply(case_tac i,simp,simp)
+apply(rule_tac x=0 in exI,simp)
+done
+
+lemma Star_imp_cptn:
+ "(P, s) -c*\<rightarrow> (R, t) \<Longrightarrow> \<exists>l \<in> cp P s. (last l)=(R, t)
+ \<and> (\<forall>i. Suc i<length l \<longrightarrow> l!i -c\<rightarrow> l!Suc i)"
+apply (erule converse_rtrancl_induct2)
+ apply(rule_tac x="[(R,t)]" in bexI)
+ apply simp
+ apply(simp add:cp_def)
+ apply(rule CptnOne)
+apply clarify
+apply(rule_tac x="(a, b)#l" in bexI)
+ apply (rule conjI)
+ apply(case_tac l,simp add:cp_def)
+ apply(simp add:last_length)
+ apply clarify
+apply(case_tac i,simp)
+apply(simp add:cp_def)
+apply force
+apply(simp add:cp_def)
+ apply(case_tac l)
+ apply(force elim:cptn.cases)
+apply simp
+apply(erule CptnComp)
+apply clarify
+done
+
+lemma Await_sound:
+ "\<lbrakk>stable pre rely; stable post rely;
+ \<forall>V. \<turnstile> P sat [pre \<inter> b \<inter> {s. s = V}, {(s, t). s = t},
+ UNIV, {s. (V, s) \<in> guar} \<inter> post] \<and>
+ \<Turnstile> P sat [pre \<inter> b \<inter> {s. s = V}, {(s, t). s = t},
+ UNIV, {s. (V, s) \<in> guar} \<inter> post] \<rbrakk>
+ \<Longrightarrow> \<Turnstile> Await b P sat [pre, rely, guar, post]"
+apply(unfold com_validity_def)
+apply clarify
+apply(simp add:comm_def)
+apply(rule conjI)
+ apply clarify
+ apply(simp add:cp_def assum_def)
+ apply clarify
+ apply(frule_tac j=0 and k=i and p=pre in stability,simp_all)
+ apply(erule_tac x=ia in allE,simp)
+ apply(subgoal_tac "x\<in> cp (Some(Await b P)) s")
+ apply(erule_tac i=i in unique_ctran_Await,force,simp_all)
+ apply(simp add:cp_def)
+--{* here starts the different part. *}
+ apply(erule ctran.cases,simp_all)
+ apply(drule Star_imp_cptn)
+ apply clarify
+ apply(erule_tac x=sa in allE)
+ apply clarify
+ apply(erule_tac x=sa in allE)
+ apply(drule_tac c=l in subsetD)
+ apply (simp add:cp_def)
+ apply clarify
+ apply(erule_tac x=ia and P="\<lambda>i. ?H i \<longrightarrow> (?J i,?I i)\<in>ctran" in allE,simp)
+ apply(erule etranE,simp)
+ apply simp
+apply clarify
+apply(simp add:cp_def)
+apply clarify
+apply(frule_tac i="length x - 1" in exists_ctran_Await_None,force)
+ apply (case_tac x,simp+)
+ apply(rule last_fst_esp,simp add:last_length)
+ apply(case_tac x, (simp add:cptn_not_empty)+)
+apply clarify
+apply(simp add:assum_def)
+apply clarify
+apply(frule_tac j=0 and k="j" and p=pre in stability,simp_all)
+ apply(erule_tac x=i in allE,simp)
+ apply(erule_tac i=j in unique_ctran_Await,force,simp_all)
+apply(case_tac "x!j")
+apply clarify
+apply simp
+apply(drule_tac s="Some (Await b P)" in sym,simp)
+apply(case_tac "x!Suc j",simp)
+apply(rule ctran.cases,simp)
+apply(simp_all)
+apply(drule Star_imp_cptn)
+apply clarify
+apply(erule_tac x=sa in allE)
+apply clarify
+apply(erule_tac x=sa in allE)
+apply(drule_tac c=l in subsetD)
+ apply (simp add:cp_def)
+ apply clarify
+ apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> (?J i,?I i)\<in>ctran" in allE,simp)
+ apply(erule etranE,simp)
+apply simp
+apply clarify
+apply(frule_tac j="Suc j" and k="length x - 1" and p=post in stability,simp_all)
+ apply(case_tac x,simp+)
+ apply(erule_tac x=i in allE)
+apply(erule_tac i=j in unique_ctran_Await,force,simp_all)
+ apply arith+
+apply(case_tac x)
+apply(simp add:last_length)+
+done
+
+subsubsection{* Soundness of the Conditional rule *}
+
+lemma Cond_sound:
+ "\<lbrakk> stable pre rely; \<Turnstile> P1 sat [pre \<inter> b, rely, guar, post];
+ \<Turnstile> P2 sat [pre \<inter> - b, rely, guar, post]; \<forall>s. (s,s)\<in>guar\<rbrakk>
+ \<Longrightarrow> \<Turnstile> (Cond b P1 P2) sat [pre, rely, guar, post]"
+apply(unfold com_validity_def)
+apply clarify
+apply(simp add:cp_def comm_def)
+apply(case_tac "\<exists>i. Suc i<length x \<and> x!i -c\<rightarrow> x!Suc i")
+ prefer 2
+ apply simp
+ apply clarify
+ apply(frule_tac j="0" and k="length x - 1" and p=pre in stability,simp+)
+ apply(case_tac x,simp+)
+ apply(simp add:assum_def)
+ apply(simp add:assum_def)
+ apply(erule_tac m="length x" in etran_or_ctran,simp+)
+ apply(case_tac x, (simp add:last_length)+)
+apply(erule exE)
+apply(drule_tac n=i and P="\<lambda>i. ?H i \<and> (?J i,?I i)\<in> ctran" in Ex_first_occurrence)
+apply clarify
+apply (simp add:assum_def)
+apply(frule_tac j=0 and k="m" and p=pre in stability,simp+)
+ apply(erule_tac m="Suc m" in etran_or_ctran,simp+)
+apply(erule ctran.cases,simp_all)
+ apply(erule_tac x="sa" in allE)
+ apply(drule_tac c="drop (Suc m) x" in subsetD)
+ apply simp
+ apply clarify
+ apply simp
+ apply clarify
+ apply(case_tac "i\<le>m")
+ apply(drule le_imp_less_or_eq)
+ apply(erule disjE)
+ apply(erule_tac x=i in allE, erule impE, assumption)
+ apply simp+
+ apply(erule_tac x="i - (Suc m)" and P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> (?I j)\<in>guar" in allE)
+ apply(subgoal_tac "(Suc m)+(i - Suc m) \<le> length x")
+ apply(subgoal_tac "(Suc m)+Suc (i - Suc m) \<le> length x")
+ apply(rotate_tac -2)
+ apply simp
+ apply arith
+ apply arith
+apply(case_tac "length (drop (Suc m) x)",simp)
+apply(erule_tac x="sa" in allE)
+back
+apply(drule_tac c="drop (Suc m) x" in subsetD,simp)
+ apply clarify
+apply simp
+apply clarify
+apply(case_tac "i\<le>m")
+ apply(drule le_imp_less_or_eq)
+ apply(erule disjE)
+ apply(erule_tac x=i in allE, erule impE, assumption)
+ apply simp
+ apply simp
+apply(erule_tac x="i - (Suc m)" and P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> (?I j)\<in>guar" in allE)
+apply(subgoal_tac "(Suc m)+(i - Suc m) \<le> length x")
+ apply(subgoal_tac "(Suc m)+Suc (i - Suc m) \<le> length x")
+ apply(rotate_tac -2)
+ apply simp
+ apply arith
+apply arith
+done
+
+subsubsection{* Soundness of the Sequential rule *}
+
+inductive_cases Seq_cases [elim!]: "(Some (Seq P Q), s) -c\<rightarrow> t"
+
+lemma last_lift_not_None: "fst ((lift Q) ((x#xs)!(length xs))) \<noteq> None"
+apply(subgoal_tac "length xs<length (x # xs)")
+ apply(drule_tac Q=Q in lift_nth)
+ apply(erule ssubst)
+ apply (simp add:lift_def)
+ apply(case_tac "(x # xs) ! length xs",simp)
+apply simp
+done
+
+declare map_eq_Cons_conv [simp del] Cons_eq_map_conv [simp del]
+lemma Seq_sound1 [rule_format]:
+ "x\<in> cptn_mod \<Longrightarrow> \<forall>s P. x !0=(Some (Seq P Q), s) \<longrightarrow>
+ (\<forall>i<length x. fst(x!i)\<noteq>Some Q) \<longrightarrow>
+ (\<exists>xs\<in> cp (Some P) s. x=map (lift Q) xs)"
+apply(erule cptn_mod.induct)
+apply(unfold cp_def)
+apply safe
+apply simp_all
+ apply(simp add:lift_def)
+ apply(rule_tac x="[(Some Pa, sa)]" in exI,simp add:CptnOne)
+ apply(subgoal_tac "(\<forall>i < Suc (length xs). fst (((Some (Seq Pa Q), t) # xs) ! i) \<noteq> Some Q)")
+ apply clarify
+ apply(rule_tac x="(Some Pa, sa) #(Some Pa, t) # zs" in exI,simp)
+ apply(rule conjI,erule CptnEnv)
+ apply(simp (no_asm_use) add:lift_def)
+ apply clarify
+ apply(erule_tac x="Suc i" in allE, simp)
+ apply(ind_cases "((Some (Seq Pa Q), sa), None, t) \<in> ctran" for Pa sa t)
+ apply(rule_tac x="(Some P, sa) # xs" in exI, simp add:cptn_iff_cptn_mod lift_def)
+apply(erule_tac x="length xs" in allE, simp)
+apply(simp only:Cons_lift_append)
+apply(subgoal_tac "length xs < length ((Some P, sa) # xs)")
+ apply(simp only :nth_append length_map last_length nth_map)
+ apply(case_tac "last((Some P, sa) # xs)")
+ apply(simp add:lift_def)
+apply simp
+done
+declare map_eq_Cons_conv [simp del] Cons_eq_map_conv [simp del]
+
+lemma Seq_sound2 [rule_format]:
+ "x \<in> cptn \<Longrightarrow> \<forall>s P i. x!0=(Some (Seq P Q), s) \<longrightarrow> i<length x
+ \<longrightarrow> fst(x!i)=Some Q \<longrightarrow>
+ (\<forall>j<i. fst(x!j)\<noteq>(Some Q)) \<longrightarrow>
+ (\<exists>xs ys. xs \<in> cp (Some P) s \<and> length xs=Suc i
+ \<and> ys \<in> cp (Some Q) (snd(xs !i)) \<and> x=(map (lift Q) xs)@tl ys)"
+apply(erule cptn.induct)
+apply(unfold cp_def)
+apply safe
+apply simp_all
+ apply(case_tac i,simp+)
+ apply(erule allE,erule impE,assumption,simp)
+ apply clarify
+ apply(subgoal_tac "(\<forall>j < nat. fst (((Some (Seq Pa Q), t) # xs) ! j) \<noteq> Some Q)",clarify)
+ prefer 2
+ apply force
+ apply(case_tac xsa,simp,simp)
+ apply(rule_tac x="(Some Pa, sa) #(Some Pa, t) # list" in exI,simp)
+ apply(rule conjI,erule CptnEnv)
+ apply(simp (no_asm_use) add:lift_def)
+ apply(rule_tac x=ys in exI,simp)
+apply(ind_cases "((Some (Seq Pa Q), sa), t) \<in> ctran" for Pa sa t)
+ apply simp
+ apply(rule_tac x="(Some Pa, sa)#[(None, ta)]" in exI,simp)
+ apply(rule conjI)
+ apply(drule_tac xs="[]" in CptnComp,force simp add:CptnOne,simp)
+ apply(case_tac i, simp+)
+ apply(case_tac nat,simp+)
+ apply(rule_tac x="(Some Q,ta)#xs" in exI,simp add:lift_def)
+ apply(case_tac nat,simp+)
+ apply(force)
+apply(case_tac i, simp+)
+apply(case_tac nat,simp+)
+apply(erule_tac x="Suc nata" in allE,simp)
+apply clarify
+apply(subgoal_tac "(\<forall>j<Suc nata. fst (((Some (Seq P2 Q), ta) # xs) ! j) \<noteq> Some Q)",clarify)
+ prefer 2
+ apply clarify
+ apply force
+apply(rule_tac x="(Some Pa, sa)#(Some P2, ta)#(tl xsa)" in exI,simp)
+apply(rule conjI,erule CptnComp)
+apply(rule nth_tl_if,force,simp+)
+apply(rule_tac x=ys in exI,simp)
+apply(rule conjI)
+apply(rule nth_tl_if,force,simp+)
+ apply(rule tl_zero,simp+)
+ apply force
+apply(rule conjI,simp add:lift_def)
+apply(subgoal_tac "lift Q (Some P2, ta) =(Some (Seq P2 Q), ta)")
+ apply(simp add:Cons_lift del:map.simps)
+ apply(rule nth_tl_if)
+ apply force
+ apply simp+
+apply(simp add:lift_def)
+done
+(*
+lemma last_lift_not_None3: "fst (last (map (lift Q) (x#xs))) \<noteq> None"
+apply(simp only:last_length [THEN sym])
+apply(subgoal_tac "length xs<length (x # xs)")
+ apply(drule_tac Q=Q in lift_nth)
+ apply(erule ssubst)
+ apply (simp add:lift_def)
+ apply(case_tac "(x # xs) ! length xs",simp)
+apply simp
+done
+*)
+
+lemma last_lift_not_None2: "fst ((lift Q) (last (x#xs))) \<noteq> None"
+apply(simp only:last_length [THEN sym])
+apply(subgoal_tac "length xs<length (x # xs)")
+ apply(drule_tac Q=Q in lift_nth)
+ apply(erule ssubst)
+ apply (simp add:lift_def)
+ apply(case_tac "(x # xs) ! length xs",simp)
+apply simp
+done
+
+lemma Seq_sound:
+ "\<lbrakk>\<Turnstile> P sat [pre, rely, guar, mid]; \<Turnstile> Q sat [mid, rely, guar, post]\<rbrakk>
+ \<Longrightarrow> \<Turnstile> Seq P Q sat [pre, rely, guar, post]"
+apply(unfold com_validity_def)
+apply clarify
+apply(case_tac "\<exists>i<length x. fst(x!i)=Some Q")
+ prefer 2
+ apply (simp add:cp_def cptn_iff_cptn_mod)
+ apply clarify
+ apply(frule_tac Seq_sound1,force)
+ apply force
+ apply clarify
+ apply(erule_tac x=s in allE,simp)
+ apply(drule_tac c=xs in subsetD,simp add:cp_def cptn_iff_cptn_mod)
+ apply(simp add:assum_def)
+ apply clarify
+ apply(erule_tac P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> ?I j" in allE,erule impE, assumption)
+ apply(simp add:snd_lift)
+ apply(erule mp)
+ apply(force elim:etranE intro:Env simp add:lift_def)
+ apply(simp add:comm_def)
+ apply(rule conjI)
+ apply clarify
+ apply(erule_tac P="\<lambda>j. ?H j \<longrightarrow> ?J j \<longrightarrow> ?I j" in allE,erule impE, assumption)
+ apply(simp add:snd_lift)
+ apply(erule mp)
+ apply(case_tac "(xs!i)")
+ apply(case_tac "(xs! Suc i)")
+ apply(case_tac "fst(xs!i)")
+ apply(erule_tac x=i in allE, simp add:lift_def)
+ apply(case_tac "fst(xs!Suc i)")
+ apply(force simp add:lift_def)
+ apply(force simp add:lift_def)
+ apply clarify
+ apply(case_tac xs,simp add:cp_def)
+ apply clarify
+ apply (simp del:map.simps)
+ apply(subgoal_tac "(map (lift Q) ((a, b) # list))\<noteq>[]")
+ apply(drule last_conv_nth)
+ apply (simp del:map.simps)
+ apply(simp only:last_lift_not_None)
+ apply simp
+--{* @{text "\<exists>i<length x. fst (x ! i) = Some Q"} *}
+apply(erule exE)
+apply(drule_tac n=i and P="\<lambda>i. i < length x \<and> fst (x ! i) = Some Q" in Ex_first_occurrence)
+apply clarify
+apply (simp add:cp_def)
+ apply clarify
+ apply(frule_tac i=m in Seq_sound2,force)
+ apply simp+
+apply clarify
+apply(simp add:comm_def)
+apply(erule_tac x=s in allE)
+apply(drule_tac c=xs in subsetD,simp)
+ apply(case_tac "xs=[]",simp)
+ apply(simp add:cp_def assum_def nth_append)
+ apply clarify
+ apply(erule_tac x=i in allE)
+ back
+ apply(simp add:snd_lift)
+ apply(erule mp)
+ apply(force elim:etranE intro:Env simp add:lift_def)
+apply simp
+apply clarify
+apply(erule_tac x="snd(xs!m)" in allE)
+apply(drule_tac c=ys in subsetD,simp add:cp_def assum_def)
+ apply(case_tac "xs\<noteq>[]")
+ apply(drule last_conv_nth,simp)
+ apply(rule conjI)
+ apply(erule mp)
+ apply(case_tac "xs!m")
+ apply(case_tac "fst(xs!m)",simp)
+ apply(simp add:lift_def nth_append)
+ apply clarify
+ apply(erule_tac x="m+i" in allE)
+ back
+ back
+ apply(case_tac ys,(simp add:nth_append)+)
+ apply (case_tac i, (simp add:snd_lift)+)
+ apply(erule mp)
+ apply(case_tac "xs!m")
+ apply(force elim:etran.cases intro:Env simp add:lift_def)
+ apply simp
+apply simp
+apply clarify
+apply(rule conjI,clarify)
+ apply(case_tac "i<m",simp add:nth_append)
+ apply(simp add:snd_lift)
+ apply(erule allE, erule impE, assumption, erule mp)
+ apply(case_tac "(xs ! i)")
+ apply(case_tac "(xs ! Suc i)")
+ apply(case_tac "fst(xs ! i)",force simp add:lift_def)
+ apply(case_tac "fst(xs ! Suc i)")
+ apply (force simp add:lift_def)
+ apply (force simp add:lift_def)
+ apply(erule_tac x="i-m" in allE)
+ back
+ back
+ apply(subgoal_tac "Suc (i - m) < length ys",simp)
+ prefer 2
+ apply arith
+ apply(simp add:nth_append snd_lift)
+ apply(rule conjI,clarify)
+ apply(subgoal_tac "i=m")
+ prefer 2
+ apply arith
+ apply clarify
+ apply(simp add:cp_def)
+ apply(rule tl_zero)
+ apply(erule mp)
+ apply(case_tac "lift Q (xs!m)",simp add:snd_lift)
+ apply(case_tac "xs!m",case_tac "fst(xs!m)",simp add:lift_def snd_lift)
+ apply(case_tac ys,simp+)
+ apply(simp add:lift_def)
+ apply simp
+ apply force
+ apply clarify
+ apply(rule tl_zero)
+ apply(rule tl_zero)
+ apply (subgoal_tac "i-m=Suc(i-Suc m)")
+ apply simp
+ apply(erule mp)
+ apply(case_tac ys,simp+)
+ apply force
+ apply arith
+ apply force
+apply clarify
+apply(case_tac "(map (lift Q) xs @ tl ys)\<noteq>[]")
+ apply(drule last_conv_nth)
+ apply(simp add: snd_lift nth_append)
+ apply(rule conjI,clarify)
+ apply(case_tac ys,simp+)
+ apply clarify
+ apply(case_tac ys,simp+)
+done
+
+subsubsection{* Soundness of the While rule *}
+
+lemma last_append[rule_format]:
+ "\<forall>xs. ys\<noteq>[] \<longrightarrow> ((xs@ys)!(length (xs@ys) - (Suc 0)))=(ys!(length ys - (Suc 0)))"
+apply(induct ys)
+ apply simp
+apply clarify
+apply (simp add:nth_append length_append)
+done
+
+lemma assum_after_body:
+ "\<lbrakk> \<Turnstile> P sat [pre \<inter> b, rely, guar, pre];
+ (Some P, s) # xs \<in> cptn_mod; fst (last ((Some P, s) # xs)) = None; s \<in> b;
+ (Some (While b P), s) # (Some (Seq P (While b P)), s) #
+ map (lift (While b P)) xs @ ys \<in> assum (pre, rely)\<rbrakk>
+ \<Longrightarrow> (Some (While b P), snd (last ((Some P, s) # xs))) # ys \<in> assum (pre, rely)"
+apply(simp add:assum_def com_validity_def cp_def cptn_iff_cptn_mod)
+apply clarify
+apply(erule_tac x=s in allE)
+apply(drule_tac c="(Some P, s) # xs" in subsetD,simp)
+ apply clarify
+ apply(erule_tac x="Suc i" in allE)
+ apply simp
+ apply(simp add:Cons_lift_append nth_append snd_lift del:map.simps)
+ apply(erule mp)
+ apply(erule etranE,simp)
+ apply(case_tac "fst(((Some P, s) # xs) ! i)")
+ apply(force intro:Env simp add:lift_def)
+ apply(force intro:Env simp add:lift_def)
+apply(rule conjI)
+ apply clarify
+ apply(simp add:comm_def last_length)
+apply clarify
+apply(rule conjI)
+ apply(simp add:comm_def)
+apply clarify
+apply(erule_tac x="Suc(length xs + i)" in allE,simp)
+apply(case_tac i, simp add:nth_append Cons_lift_append snd_lift del:map.simps)
+ apply(simp add:last_length)
+ apply(erule mp)
+ apply(case_tac "last xs")
+ apply(simp add:lift_def)
+apply(simp add:Cons_lift_append nth_append snd_lift del:map.simps)
+done
+
+lemma While_sound_aux [rule_format]:
+ "\<lbrakk> pre \<inter> - b \<subseteq> post; \<Turnstile> P sat [pre \<inter> b, rely, guar, pre]; \<forall>s. (s, s) \<in> guar;
+ stable pre rely; stable post rely; x \<in> cptn_mod \<rbrakk>
+ \<Longrightarrow> \<forall>s xs. x=(Some(While b P),s)#xs \<longrightarrow> x\<in>assum(pre, rely) \<longrightarrow> x \<in> comm (guar, post)"
+apply(erule cptn_mod.induct)
+apply safe
+apply (simp_all del:last.simps)
+--{* 5 subgoals left *}
+apply(simp add:comm_def)
+--{* 4 subgoals left *}
+apply(rule etran_in_comm)
+apply(erule mp)
+apply(erule tl_of_assum_in_assum,simp)
+--{* While-None *}
+apply(ind_cases "((Some (While b P), s), None, t) \<in> ctran" for s t)
+apply(simp add:comm_def)
+apply(simp add:cptn_iff_cptn_mod [THEN sym])
+apply(rule conjI,clarify)
+ apply(force simp add:assum_def)
+apply clarify
+apply(rule conjI, clarify)
+ apply(case_tac i,simp,simp)
+ apply(force simp add:not_ctran_None2)
+apply(subgoal_tac "\<forall>i. Suc i < length ((None, t) # xs) \<longrightarrow> (((None, t) # xs) ! i, ((None, t) # xs) ! Suc i)\<in> etran")
+ prefer 2
+ apply clarify
+ apply(rule_tac m="length ((None, s) # xs)" in etran_or_ctran,simp+)
+ apply(erule not_ctran_None2,simp)
+ apply simp+
+apply(frule_tac j="0" and k="length ((None, s) # xs) - 1" and p=post in stability,simp+)
+ apply(force simp add:assum_def subsetD)
+ apply(simp add:assum_def)
+ apply clarify
+ apply(erule_tac x="i" in allE,simp)
+ apply(erule_tac x="Suc i" in allE,simp)
+ apply simp
+apply clarify
+apply (simp add:last_length)
+--{* WhileOne *}
+apply(thin_tac "P = While b P \<longrightarrow> ?Q")
+apply(rule ctran_in_comm,simp)
+apply(simp add:Cons_lift del:map.simps)
+apply(simp add:comm_def del:map.simps)
+apply(rule conjI)
+ apply clarify
+ apply(case_tac "fst(((Some P, sa) # xs) ! i)")
+ apply(case_tac "((Some P, sa) # xs) ! i")
+ apply (simp add:lift_def)
+ apply(ind_cases "(Some (While b P), ba) -c\<rightarrow> t" for ba t)
+ apply simp
+ apply simp
+ apply(simp add:snd_lift del:map.simps)
+ apply(simp only:com_validity_def cp_def cptn_iff_cptn_mod)
+ apply(erule_tac x=sa in allE)
+ apply(drule_tac c="(Some P, sa) # xs" in subsetD)
+ apply (simp add:assum_def del:map.simps)
+ apply clarify
+ apply(erule_tac x="Suc ia" in allE,simp add:snd_lift del:map.simps)
+ apply(erule mp)
+ apply(case_tac "fst(((Some P, sa) # xs) ! ia)")
+ apply(erule etranE,simp add:lift_def)
+ apply(rule Env)
+ apply(erule etranE,simp add:lift_def)
+ apply(rule Env)
+ apply (simp add:comm_def del:map.simps)
+ apply clarify
+ apply(erule allE,erule impE,assumption)
+ apply(erule mp)
+ apply(case_tac "((Some P, sa) # xs) ! i")
+ apply(case_tac "xs!i")
+ apply(simp add:lift_def)
+ apply(case_tac "fst(xs!i)")
+ apply force
+ apply force
+--{* last=None *}
+apply clarify
+apply(subgoal_tac "(map (lift (While b P)) ((Some P, sa) # xs))\<noteq>[]")
+ apply(drule last_conv_nth)
+ apply (simp del:map.simps)
+ apply(simp only:last_lift_not_None)
+apply simp
+--{* WhileMore *}
+apply(thin_tac "P = While b P \<longrightarrow> ?Q")
+apply(rule ctran_in_comm,simp del:last.simps)
+--{* metiendo la hipotesis antes de dividir la conclusion. *}
+apply(subgoal_tac "(Some (While b P), snd (last ((Some P, sa) # xs))) # ys \<in> assum (pre, rely)")
+ apply (simp del:last.simps)
+ prefer 2
+ apply(erule assum_after_body)
+ apply (simp del:last.simps)+
+--{* lo de antes. *}
+apply(simp add:comm_def del:map.simps last.simps)
+apply(rule conjI)
+ apply clarify
+ apply(simp only:Cons_lift_append)
+ apply(case_tac "i<length xs")
+ apply(simp add:nth_append del:map.simps last.simps)
+ apply(case_tac "fst(((Some P, sa) # xs) ! i)")
+ apply(case_tac "((Some P, sa) # xs) ! i")
+ apply (simp add:lift_def del:last.simps)
+ apply(ind_cases "(Some (While b P), ba) -c\<rightarrow> t" for ba t)
+ apply simp
+ apply simp
+ apply(simp add:snd_lift del:map.simps last.simps)
+ apply(thin_tac " \<forall>i. i < length ys \<longrightarrow> ?P i")
+ apply(simp only:com_validity_def cp_def cptn_iff_cptn_mod)
+ apply(erule_tac x=sa in allE)
+ apply(drule_tac c="(Some P, sa) # xs" in subsetD)
+ apply (simp add:assum_def del:map.simps last.simps)
+ apply clarify
+ apply(erule_tac x="Suc ia" in allE,simp add:nth_append snd_lift del:map.simps last.simps, erule mp)
+ apply(case_tac "fst(((Some P, sa) # xs) ! ia)")
+ apply(erule etranE,simp add:lift_def)
+ apply(rule Env)
+ apply(erule etranE,simp add:lift_def)
+ apply(rule Env)
+ apply (simp add:comm_def del:map.simps)
+ apply clarify
+ apply(erule allE,erule impE,assumption)
+ apply(erule mp)
+ apply(case_tac "((Some P, sa) # xs) ! i")
+ apply(case_tac "xs!i")
+ apply(simp add:lift_def)
+ apply(case_tac "fst(xs!i)")
+ apply force
+ apply force
+--{* @{text "i \<ge> length xs"} *}
+apply(subgoal_tac "i-length xs <length ys")
+ prefer 2
+ apply arith
+apply(erule_tac x="i-length xs" in allE,clarify)
+apply(case_tac "i=length xs")
+ apply (simp add:nth_append snd_lift del:map.simps last.simps)
+ apply(simp add:last_length del:last.simps)
+ apply(erule mp)
+ apply(case_tac "last((Some P, sa) # xs)")
+ apply(simp add:lift_def del:last.simps)
+--{* @{text "i>length xs"} *}
+apply(case_tac "i-length xs")
+ apply arith
+apply(simp add:nth_append del:map.simps last.simps)
+apply(rotate_tac -3)
+apply(subgoal_tac "i- Suc (length xs)=nat")
+ prefer 2
+ apply arith
+apply simp
+--{* last=None *}
+apply clarify
+apply(case_tac ys)
+ apply(simp add:Cons_lift del:map.simps last.simps)
+ apply(subgoal_tac "(map (lift (While b P)) ((Some P, sa) # xs))\<noteq>[]")
+ apply(drule last_conv_nth)
+ apply (simp del:map.simps)
+ apply(simp only:last_lift_not_None)
+ apply simp
+apply(subgoal_tac "((Some (Seq P (While b P)), sa) # map (lift (While b P)) xs @ ys)\<noteq>[]")
+ apply(drule last_conv_nth)
+ apply (simp del:map.simps last.simps)
+ apply(simp add:nth_append del:last.simps)
+ apply(subgoal_tac "((Some (While b P), snd (last ((Some P, sa) # xs))) # a # list)\<noteq>[]")
+ apply(drule last_conv_nth)
+ apply (simp del:map.simps last.simps)
+ apply simp
+apply simp
+done
+
+lemma While_sound:
+ "\<lbrakk>stable pre rely; pre \<inter> - b \<subseteq> post; stable post rely;
+ \<Turnstile> P sat [pre \<inter> b, rely, guar, pre]; \<forall>s. (s,s)\<in>guar\<rbrakk>
+ \<Longrightarrow> \<Turnstile> While b P sat [pre, rely, guar, post]"
+apply(unfold com_validity_def)
+apply clarify
+apply(erule_tac xs="tl x" in While_sound_aux)
+ apply(simp add:com_validity_def)
+ apply force
+ apply simp_all
+apply(simp add:cptn_iff_cptn_mod cp_def)
+apply(simp add:cp_def)
+apply clarify
+apply(rule nth_equalityI)
+ apply simp_all
+ apply(case_tac x,simp+)
+apply clarify
+apply(case_tac i,simp+)
+apply(case_tac x,simp+)
+done
+
+subsubsection{* Soundness of the Rule of Consequence *}
+
+lemma Conseq_sound:
+ "\<lbrakk>pre \<subseteq> pre'; rely \<subseteq> rely'; guar' \<subseteq> guar; post' \<subseteq> post;
+ \<Turnstile> P sat [pre', rely', guar', post']\<rbrakk>
+ \<Longrightarrow> \<Turnstile> P sat [pre, rely, guar, post]"
+apply(simp add:com_validity_def assum_def comm_def)
+apply clarify
+apply(erule_tac x=s in allE)
+apply(drule_tac c=x in subsetD)
+ apply force
+apply force
+done
+
+subsubsection {* Soundness of the system for sequential component programs *}
+
+theorem rgsound:
+ "\<turnstile> P sat [pre, rely, guar, post] \<Longrightarrow> \<Turnstile> P sat [pre, rely, guar, post]"
+apply(erule rghoare.induct)
+ apply(force elim:Basic_sound)
+ apply(force elim:Seq_sound)
+ apply(force elim:Cond_sound)
+ apply(force elim:While_sound)
+ apply(force elim:Await_sound)
+apply(erule Conseq_sound,simp+)
+done
+
+subsection {* Soundness of the System for Parallel Programs *}
+
+constdefs
+ ParallelCom :: "('a rgformula) list \<Rightarrow> 'a par_com"
+ "ParallelCom Ps \<equiv> map (Some \<circ> fst) Ps"
+
+lemma two:
+ "\<lbrakk> \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
+ \<subseteq> Rely (xs ! i);
+ pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
+ \<forall>i<length xs.
+ \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
+ length xs=length clist; x \<in> par_cp (ParallelCom xs) s; x\<in>par_assum(pre, rely);
+ \<forall>i<length clist. clist!i\<in>cp (Some(Com(xs!i))) s; x \<propto> clist \<rbrakk>
+ \<Longrightarrow> \<forall>j i. i<length clist \<and> Suc j<length x \<longrightarrow> (clist!i!j) -c\<rightarrow> (clist!i!Suc j)
+ \<longrightarrow> (snd(clist!i!j), snd(clist!i!Suc j)) \<in> Guar(xs!i)"
+apply(unfold par_cp_def)
+apply (rule ccontr)
+--{* By contradiction: *}
+apply (simp del: Un_subset_iff)
+apply(erule exE)
+--{* the first c-tran that does not satisfy the guarantee-condition is from @{text "\<sigma>_i"} at step @{text "m"}. *}
+apply(drule_tac n=j and P="\<lambda>j. \<exists>i. ?H i j" in Ex_first_occurrence)
+apply(erule exE)
+apply clarify
+--{* @{text "\<sigma>_i \<in> A(pre, rely_1)"} *}
+apply(subgoal_tac "take (Suc (Suc m)) (clist!i) \<in> assum(Pre(xs!i), Rely(xs!i))")
+--{* but this contradicts @{text "\<Turnstile> \<sigma>_i sat [pre_i,rely_i,guar_i,post_i]"} *}
+ apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> \<Turnstile> (?J i) sat [?I i,?K i,?M i,?N i]" in allE,erule impE,assumption)
+ apply(simp add:com_validity_def)
+ apply(erule_tac x=s in allE)
+ apply(simp add:cp_def comm_def)
+ apply(drule_tac c="take (Suc (Suc m)) (clist ! i)" in subsetD)
+ apply simp
+ apply (blast intro: takecptn_is_cptn)
+ apply simp
+ apply clarify
+ apply(erule_tac x=m and P="\<lambda>j. ?I j \<and> ?J j \<longrightarrow> ?H j" in allE)
+ apply (simp add:conjoin_def same_length_def)
+apply(simp add:assum_def del: Un_subset_iff)
+apply(rule conjI)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<in>cp (?K j) (?J j)" in allE)
+ apply(simp add:cp_def par_assum_def)
+ apply(drule_tac c="s" in subsetD,simp)
+ apply simp
+apply clarify
+apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> ?M \<union> UNION (?S j) (?T j) \<subseteq> (?L j)" in allE)
+apply(simp del: Un_subset_iff)
+apply(erule subsetD)
+apply simp
+apply(simp add:conjoin_def compat_label_def)
+apply clarify
+apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (?P j) \<or> ?Q j" in allE,simp)
+--{* each etran in @{text "\<sigma>_1[0\<dots>m]"} corresponds to *}
+apply(erule disjE)
+--{* a c-tran in some @{text "\<sigma>_{ib}"} *}
+ apply clarify
+ apply(case_tac "i=ib",simp)
+ apply(erule etranE,simp)
+ apply(erule_tac x="ib" and P="\<lambda>i. ?H i \<longrightarrow> (?I i) \<or> (?J i)" in allE)
+ apply (erule etranE)
+ apply(case_tac "ia=m",simp)
+ apply simp
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (\<forall> i. ?P i j)" in allE)
+ apply(subgoal_tac "ia<m",simp)
+ prefer 2
+ apply arith
+ apply(erule_tac x=ib and P="\<lambda>j. (?I j, ?H j)\<in> ctran \<longrightarrow> (?P i j)" in allE,simp)
+ apply(simp add:same_state_def)
+ apply(erule_tac x=i and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in all_dupE)
+ apply(erule_tac x=ib and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
+--{* or an e-tran in @{text "\<sigma>"},
+therefore it satisfies @{text "rely \<or> guar_{ib}"} *}
+apply (force simp add:par_assum_def same_state_def)
+done
+
+
+lemma three [rule_format]:
+ "\<lbrakk> xs\<noteq>[]; \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
+ \<subseteq> Rely (xs ! i);
+ pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
+ \<forall>i<length xs.
+ \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
+ length xs=length clist; x \<in> par_cp (ParallelCom xs) s; x \<in> par_assum(pre, rely);
+ \<forall>i<length clist. clist!i\<in>cp (Some(Com(xs!i))) s; x \<propto> clist \<rbrakk>
+ \<Longrightarrow> \<forall>j i. i<length clist \<and> Suc j<length x \<longrightarrow> (clist!i!j) -e\<rightarrow> (clist!i!Suc j)
+ \<longrightarrow> (snd(clist!i!j), snd(clist!i!Suc j)) \<in> rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))"
+apply(drule two)
+ apply simp_all
+apply clarify
+apply(simp add:conjoin_def compat_label_def)
+apply clarify
+apply(erule_tac x=j and P="\<lambda>j. ?H j \<longrightarrow> (?J j \<and> (\<exists>i. ?P i j)) \<or> ?I j" in allE,simp)
+apply(erule disjE)
+ prefer 2
+ apply(force simp add:same_state_def par_assum_def)
+apply clarify
+apply(case_tac "i=ia",simp)
+ apply(erule etranE,simp)
+apply(erule_tac x="ia" and P="\<lambda>i. ?H i \<longrightarrow> (?I i) \<or> (?J i)" in allE,simp)
+apply(erule_tac x=j and P="\<lambda>j. \<forall>i. ?S j i \<longrightarrow> (?I j i, ?H j i)\<in> ctran \<longrightarrow> (?P i j)" in allE)
+apply(erule_tac x=ia and P="\<lambda>j. ?S j \<longrightarrow> (?I j, ?H j)\<in> ctran \<longrightarrow> (?P j)" in allE)
+apply(simp add:same_state_def)
+apply(erule_tac x=i and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in all_dupE)
+apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
+done
+
+lemma four:
+ "\<lbrakk>xs\<noteq>[]; \<forall>i < length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
+ \<subseteq> Rely (xs ! i);
+ (\<Union>j\<in>{j. j < length xs}. Guar (xs ! j)) \<subseteq> guar;
+ pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
+ \<forall>i < length xs.
+ \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
+ x \<in> par_cp (ParallelCom xs) s; x \<in> par_assum (pre, rely); Suc i < length x;
+ x ! i -pc\<rightarrow> x ! Suc i\<rbrakk>
+ \<Longrightarrow> (snd (x ! i), snd (x ! Suc i)) \<in> guar"
+apply(simp add: ParallelCom_def del: Un_subset_iff)
+apply(subgoal_tac "(map (Some \<circ> fst) xs)\<noteq>[]")
+ prefer 2
+ apply simp
+apply(frule rev_subsetD)
+ apply(erule one [THEN equalityD1])
+apply(erule subsetD)
+apply (simp del: Un_subset_iff)
+apply clarify
+apply(drule_tac pre=pre and rely=rely and x=x and s=s and xs=xs and clist=clist in two)
+apply(assumption+)
+ apply(erule sym)
+ apply(simp add:ParallelCom_def)
+ apply assumption
+ apply(simp add:Com_def)
+ apply assumption
+apply(simp add:conjoin_def same_program_def)
+apply clarify
+apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> fst(?I j)=(?J j)" in all_dupE)
+apply(erule_tac x="Suc i" and P="\<lambda>j. ?H j \<longrightarrow> fst(?I j)=(?J j)" in allE)
+apply(erule par_ctranE,simp)
+apply(erule_tac x=i and P="\<lambda>j. \<forall>i. ?S j i \<longrightarrow> (?I j i, ?H j i)\<in> ctran \<longrightarrow> (?P i j)" in allE)
+apply(erule_tac x=ia and P="\<lambda>j. ?S j \<longrightarrow> (?I j, ?H j)\<in> ctran \<longrightarrow> (?P j)" in allE)
+apply(rule_tac x=ia in exI)
+apply(simp add:same_state_def)
+apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in all_dupE,simp)
+apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
+apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in all_dupE)
+apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in all_dupE,simp)
+apply(erule_tac x="Suc i" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+apply(erule mp)
+apply(subgoal_tac "r=fst(clist ! ia ! Suc i)",simp)
+apply(drule_tac i=ia in list_eq_if)
+back
+apply simp_all
+done
+
+lemma parcptn_not_empty [simp]:"[] \<notin> par_cptn"
+apply(force elim:par_cptn.cases)
+done
+
+lemma five:
+ "\<lbrakk>xs\<noteq>[]; \<forall>i<length xs. rely \<union> (\<Union>j\<in>{j. j < length xs \<and> j \<noteq> i}. Guar (xs ! j))
+ \<subseteq> Rely (xs ! i);
+ pre \<subseteq> (\<Inter>i\<in>{i. i < length xs}. Pre (xs ! i));
+ (\<Inter>i\<in>{i. i < length xs}. Post (xs ! i)) \<subseteq> post;
+ \<forall>i < length xs.
+ \<Turnstile> Com (xs ! i) sat [Pre (xs ! i), Rely (xs ! i), Guar (xs ! i), Post (xs ! i)];
+ x \<in> par_cp (ParallelCom xs) s; x \<in> par_assum (pre, rely);
+ All_None (fst (last x)) \<rbrakk> \<Longrightarrow> snd (last x) \<in> post"
+apply(simp add: ParallelCom_def del: Un_subset_iff)
+apply(subgoal_tac "(map (Some \<circ> fst) xs)\<noteq>[]")
+ prefer 2
+ apply simp
+apply(frule rev_subsetD)
+ apply(erule one [THEN equalityD1])
+apply(erule subsetD)
+apply(simp del: Un_subset_iff)
+apply clarify
+apply(subgoal_tac "\<forall>i<length clist. clist!i\<in>assum(Pre(xs!i), Rely(xs!i))")
+ apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> \<Turnstile> (?J i) sat [?I i,?K i,?M i,?N i]" in allE,erule impE,assumption)
+ apply(simp add:com_validity_def)
+ apply(erule_tac x=s in allE)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (?I j) \<in> cp (?J j) s" in allE,simp)
+ apply(drule_tac c="clist!i" in subsetD)
+ apply (force simp add:Com_def)
+ apply(simp add:comm_def conjoin_def same_program_def del:last.simps)
+ apply clarify
+ apply(erule_tac x="length x - 1" and P="\<lambda>j. ?H j \<longrightarrow> fst(?I j)=(?J j)" in allE)
+ apply (simp add:All_None_def same_length_def)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> length(?J j)=(?K j)" in allE)
+ apply(subgoal_tac "length x - 1 < length x",simp)
+ apply(case_tac "x\<noteq>[]")
+ apply(simp add: last_conv_nth)
+ apply(erule_tac x="clist!i" in ballE)
+ apply(simp add:same_state_def)
+ apply(subgoal_tac "clist!i\<noteq>[]")
+ apply(simp add: last_conv_nth)
+ apply(case_tac x)
+ apply (force simp add:par_cp_def)
+ apply (force simp add:par_cp_def)
+ apply force
+ apply (force simp add:par_cp_def)
+ apply(case_tac x)
+ apply (force simp add:par_cp_def)
+ apply (force simp add:par_cp_def)
+apply clarify
+apply(simp add:assum_def)
+apply(rule conjI)
+ apply(simp add:conjoin_def same_state_def par_cp_def)
+ apply clarify
+ apply(erule_tac x=ia and P="\<lambda>j. (?T j) \<longrightarrow> (\<forall>i. (?H j i) \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
+ apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
+ apply(case_tac x,simp+)
+ apply (simp add:par_assum_def)
+ apply clarify
+ apply(drule_tac c="snd (clist ! ia ! 0)" in subsetD)
+ apply assumption
+ apply simp
+apply clarify
+apply(erule_tac x=ia in all_dupE)
+apply(rule subsetD, erule mp, assumption)
+apply(erule_tac pre=pre and rely=rely and x=x and s=s in three)
+ apply(erule_tac x=ic in allE,erule mp)
+ apply simp_all
+ apply(simp add:ParallelCom_def)
+ apply(force simp add:Com_def)
+apply(simp add:conjoin_def same_length_def)
+done
+
+lemma ParallelEmpty [rule_format]:
+ "\<forall>i s. x \<in> par_cp (ParallelCom []) s \<longrightarrow>
+ Suc i < length x \<longrightarrow> (x ! i, x ! Suc i) \<notin> par_ctran"
+apply(induct_tac x)
+ apply(simp add:par_cp_def ParallelCom_def)
+apply clarify
+apply(case_tac list,simp,simp)
+apply(case_tac i)
+ apply(simp add:par_cp_def ParallelCom_def)
+ apply(erule par_ctranE,simp)
+apply(simp add:par_cp_def ParallelCom_def)
+apply clarify
+apply(erule par_cptn.cases,simp)
+ apply simp
+apply(erule par_ctranE)
+back
+apply simp
+done
+
+theorem par_rgsound:
+ "\<turnstile> c SAT [pre, rely, guar, post] \<Longrightarrow>
+ \<Turnstile> (ParallelCom c) SAT [pre, rely, guar, post]"
+apply(erule par_rghoare.induct)
+apply(case_tac xs,simp)
+ apply(simp add:par_com_validity_def par_comm_def)
+ apply clarify
+ apply(case_tac "post=UNIV",simp)
+ apply clarify
+ apply(drule ParallelEmpty)
+ apply assumption
+ apply simp
+ apply clarify
+ apply simp
+apply(subgoal_tac "xs\<noteq>[]")
+ prefer 2
+ apply simp
+apply(thin_tac "xs = a # list")
+apply(simp add:par_com_validity_def par_comm_def)
+apply clarify
+apply(rule conjI)
+ apply clarify
+ apply(erule_tac pre=pre and rely=rely and guar=guar and x=x and s=s and xs=xs in four)
+ apply(assumption+)
+ apply clarify
+ apply (erule allE, erule impE, assumption,erule rgsound)
+ apply(assumption+)
+apply clarify
+apply(erule_tac pre=pre and rely=rely and post=post and x=x and s=s and xs=xs in five)
+ apply(assumption+)
+ apply clarify
+ apply (erule allE, erule impE, assumption,erule rgsound)
+ apply(assumption+)
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/RG_Syntax.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,95 @@
+header {* \section{Concrete Syntax} *}
+
+theory RG_Syntax
+imports RG_Hoare Quote_Antiquote
+begin
+
+syntax
+ "_Assign" :: "idt \<Rightarrow> 'b \<Rightarrow> 'a com" ("(\<acute>_ :=/ _)" [70, 65] 61)
+ "_skip" :: "'a com" ("SKIP")
+ "_Seq" :: "'a com \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(_;;/ _)" [60,61] 60)
+ "_Cond" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(0IF _/ THEN _/ ELSE _/FI)" [0, 0, 0] 61)
+ "_Cond2" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(0IF _ THEN _ FI)" [0,0] 56)
+ "_While" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(0WHILE _ /DO _ /OD)" [0, 0] 61)
+ "_Await" :: "'a bexp \<Rightarrow> 'a com \<Rightarrow> 'a com" ("(0AWAIT _ /THEN /_ /END)" [0,0] 61)
+ "_Atom" :: "'a com \<Rightarrow> 'a com" ("(\<langle>_\<rangle>)" 61)
+ "_Wait" :: "'a bexp \<Rightarrow> 'a com" ("(0WAIT _ END)" 61)
+
+translations
+ "\<acute>\<spacespace>x := a" \<rightharpoonup> "Basic \<guillemotleft>\<acute>\<spacespace>(_update_name x (\<lambda>_. a))\<guillemotright>"
+ "SKIP" \<rightleftharpoons> "Basic id"
+ "c1;; c2" \<rightleftharpoons> "Seq c1 c2"
+ "IF b THEN c1 ELSE c2 FI" \<rightharpoonup> "Cond .{b}. c1 c2"
+ "IF b THEN c FI" \<rightleftharpoons> "IF b THEN c ELSE SKIP FI"
+ "WHILE b DO c OD" \<rightharpoonup> "While .{b}. c"
+ "AWAIT b THEN c END" \<rightleftharpoons> "Await .{b}. c"
+ "\<langle>c\<rangle>" \<rightleftharpoons> "AWAIT True THEN c END"
+ "WAIT b END" \<rightleftharpoons> "AWAIT b THEN SKIP END"
+
+nonterminals
+ prgs
+
+syntax
+ "_PAR" :: "prgs \<Rightarrow> 'a" ("COBEGIN//_//COEND" 60)
+ "_prg" :: "'a \<Rightarrow> prgs" ("_" 57)
+ "_prgs" :: "['a, prgs] \<Rightarrow> prgs" ("_//\<parallel>//_" [60,57] 57)
+
+translations
+ "_prg a" \<rightharpoonup> "[a]"
+ "_prgs a ps" \<rightharpoonup> "a # ps"
+ "_PAR ps" \<rightharpoonup> "ps"
+
+syntax
+ "_prg_scheme" :: "['a, 'a, 'a, 'a] \<Rightarrow> prgs" ("SCHEME [_ \<le> _ < _] _" [0,0,0,60] 57)
+
+translations
+ "_prg_scheme j i k c" \<rightleftharpoons> "(map (\<lambda>i. c) [j..<k])"
+
+text {* Translations for variables before and after a transition: *}
+
+syntax
+ "_before" :: "id \<Rightarrow> 'a" ("\<ordmasculine>_")
+ "_after" :: "id \<Rightarrow> 'a" ("\<ordfeminine>_")
+
+translations
+ "\<ordmasculine>x" \<rightleftharpoons> "x \<acute>fst"
+ "\<ordfeminine>x" \<rightleftharpoons> "x \<acute>snd"
+
+print_translation {*
+ let
+ fun quote_tr' f (t :: ts) =
+ Term.list_comb (f $ Syntax.quote_tr' "_antiquote" t, ts)
+ | quote_tr' _ _ = raise Match;
+
+ val assert_tr' = quote_tr' (Syntax.const "_Assert");
+
+ fun bexp_tr' name ((Const ("Collect", _) $ t) :: ts) =
+ quote_tr' (Syntax.const name) (t :: ts)
+ | bexp_tr' _ _ = raise Match;
+
+ fun upd_tr' (x_upd, T) =
+ (case try (unsuffix Record.updateN) x_upd of
+ SOME x => (x, if T = dummyT then T else Term.domain_type T)
+ | NONE => raise Match);
+
+ fun update_name_tr' (Free x) = Free (upd_tr' x)
+ | update_name_tr' ((c as Const ("_free", _)) $ Free x) =
+ c $ Free (upd_tr' x)
+ | update_name_tr' (Const x) = Const (upd_tr' x)
+ | update_name_tr' _ = raise Match;
+
+ fun K_tr' (Abs (_,_,t)) = if null (loose_bnos t) then t else raise Match
+ | K_tr' (Abs (_,_,Abs (_,_,t)$Bound 0)) = if null (loose_bnos t) then t else raise Match
+ | K_tr' _ = raise Match;
+
+ fun assign_tr' (Abs (x, _, f $ k $ Bound 0) :: ts) =
+ quote_tr' (Syntax.const "_Assign" $ update_name_tr' f)
+ (Abs (x, dummyT, K_tr' k) :: ts)
+ | assign_tr' _ = raise Match;
+ in
+ [("Collect", assert_tr'), ("Basic", assign_tr'),
+ ("Cond", bexp_tr' "_Cond"), ("While", bexp_tr' "_While_inv")]
+ end
+*}
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/RG_Tran.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,1075 @@
+header {* \section{Operational Semantics} *}
+
+theory RG_Tran
+imports RG_Com
+begin
+
+subsection {* Semantics of Component Programs *}
+
+subsubsection {* Environment transitions *}
+
+types 'a conf = "(('a com) option) \<times> 'a"
+
+inductive_set
+ etran :: "('a conf \<times> 'a conf) set"
+ and etran' :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool" ("_ -e\<rightarrow> _" [81,81] 80)
+where
+ "P -e\<rightarrow> Q \<equiv> (P,Q) \<in> etran"
+| Env: "(P, s) -e\<rightarrow> (P, t)"
+
+lemma etranE: "c -e\<rightarrow> c' \<Longrightarrow> (\<And>P s t. c = (P, s) \<Longrightarrow> c' = (P, t) \<Longrightarrow> Q) \<Longrightarrow> Q"
+ by (induct c, induct c', erule etran.cases, blast)
+
+subsubsection {* Component transitions *}
+
+inductive_set
+ ctran :: "('a conf \<times> 'a conf) set"
+ and ctran' :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool" ("_ -c\<rightarrow> _" [81,81] 80)
+ and ctrans :: "'a conf \<Rightarrow> 'a conf \<Rightarrow> bool" ("_ -c*\<rightarrow> _" [81,81] 80)
+where
+ "P -c\<rightarrow> Q \<equiv> (P,Q) \<in> ctran"
+| "P -c*\<rightarrow> Q \<equiv> (P,Q) \<in> ctran^*"
+
+| Basic: "(Some(Basic f), s) -c\<rightarrow> (None, f s)"
+
+| Seq1: "(Some P0, s) -c\<rightarrow> (None, t) \<Longrightarrow> (Some(Seq P0 P1), s) -c\<rightarrow> (Some P1, t)"
+
+| Seq2: "(Some P0, s) -c\<rightarrow> (Some P2, t) \<Longrightarrow> (Some(Seq P0 P1), s) -c\<rightarrow> (Some(Seq P2 P1), t)"
+
+| CondT: "s\<in>b \<Longrightarrow> (Some(Cond b P1 P2), s) -c\<rightarrow> (Some P1, s)"
+| CondF: "s\<notin>b \<Longrightarrow> (Some(Cond b P1 P2), s) -c\<rightarrow> (Some P2, s)"
+
+| WhileF: "s\<notin>b \<Longrightarrow> (Some(While b P), s) -c\<rightarrow> (None, s)"
+| WhileT: "s\<in>b \<Longrightarrow> (Some(While b P), s) -c\<rightarrow> (Some(Seq P (While b P)), s)"
+
+| Await: "\<lbrakk>s\<in>b; (Some P, s) -c*\<rightarrow> (None, t)\<rbrakk> \<Longrightarrow> (Some(Await b P), s) -c\<rightarrow> (None, t)"
+
+monos "rtrancl_mono"
+
+subsection {* Semantics of Parallel Programs *}
+
+types 'a par_conf = "('a par_com) \<times> 'a"
+
+inductive_set
+ par_etran :: "('a par_conf \<times> 'a par_conf) set"
+ and par_etran' :: "['a par_conf,'a par_conf] \<Rightarrow> bool" ("_ -pe\<rightarrow> _" [81,81] 80)
+where
+ "P -pe\<rightarrow> Q \<equiv> (P,Q) \<in> par_etran"
+| ParEnv: "(Ps, s) -pe\<rightarrow> (Ps, t)"
+
+inductive_set
+ par_ctran :: "('a par_conf \<times> 'a par_conf) set"
+ and par_ctran' :: "['a par_conf,'a par_conf] \<Rightarrow> bool" ("_ -pc\<rightarrow> _" [81,81] 80)
+where
+ "P -pc\<rightarrow> Q \<equiv> (P,Q) \<in> par_ctran"
+| ParComp: "\<lbrakk>i<length Ps; (Ps!i, s) -c\<rightarrow> (r, t)\<rbrakk> \<Longrightarrow> (Ps, s) -pc\<rightarrow> (Ps[i:=r], t)"
+
+lemma par_ctranE: "c -pc\<rightarrow> c' \<Longrightarrow>
+ (\<And>i Ps s r t. c = (Ps, s) \<Longrightarrow> c' = (Ps[i := r], t) \<Longrightarrow> i < length Ps \<Longrightarrow>
+ (Ps ! i, s) -c\<rightarrow> (r, t) \<Longrightarrow> P) \<Longrightarrow> P"
+ by (induct c, induct c', erule par_ctran.cases, blast)
+
+subsection {* Computations *}
+
+subsubsection {* Sequential computations *}
+
+types 'a confs = "('a conf) list"
+
+inductive_set cptn :: "('a confs) set"
+where
+ CptnOne: "[(P,s)] \<in> cptn"
+| CptnEnv: "(P, t)#xs \<in> cptn \<Longrightarrow> (P,s)#(P,t)#xs \<in> cptn"
+| CptnComp: "\<lbrakk>(P,s) -c\<rightarrow> (Q,t); (Q, t)#xs \<in> cptn \<rbrakk> \<Longrightarrow> (P,s)#(Q,t)#xs \<in> cptn"
+
+constdefs
+ cp :: "('a com) option \<Rightarrow> 'a \<Rightarrow> ('a confs) set"
+ "cp P s \<equiv> {l. l!0=(P,s) \<and> l \<in> cptn}"
+
+subsubsection {* Parallel computations *}
+
+types 'a par_confs = "('a par_conf) list"
+
+inductive_set par_cptn :: "('a par_confs) set"
+where
+ ParCptnOne: "[(P,s)] \<in> par_cptn"
+| ParCptnEnv: "(P,t)#xs \<in> par_cptn \<Longrightarrow> (P,s)#(P,t)#xs \<in> par_cptn"
+| ParCptnComp: "\<lbrakk> (P,s) -pc\<rightarrow> (Q,t); (Q,t)#xs \<in> par_cptn \<rbrakk> \<Longrightarrow> (P,s)#(Q,t)#xs \<in> par_cptn"
+
+constdefs
+ par_cp :: "'a par_com \<Rightarrow> 'a \<Rightarrow> ('a par_confs) set"
+ "par_cp P s \<equiv> {l. l!0=(P,s) \<and> l \<in> par_cptn}"
+
+subsection{* Modular Definition of Computation *}
+
+constdefs
+ lift :: "'a com \<Rightarrow> 'a conf \<Rightarrow> 'a conf"
+ "lift Q \<equiv> \<lambda>(P, s). (if P=None then (Some Q,s) else (Some(Seq (the P) Q), s))"
+
+inductive_set cptn_mod :: "('a confs) set"
+where
+ CptnModOne: "[(P, s)] \<in> cptn_mod"
+| CptnModEnv: "(P, t)#xs \<in> cptn_mod \<Longrightarrow> (P, s)#(P, t)#xs \<in> cptn_mod"
+| CptnModNone: "\<lbrakk>(Some P, s) -c\<rightarrow> (None, t); (None, t)#xs \<in> cptn_mod \<rbrakk> \<Longrightarrow> (Some P,s)#(None, t)#xs \<in>cptn_mod"
+| CptnModCondT: "\<lbrakk>(Some P0, s)#ys \<in> cptn_mod; s \<in> b \<rbrakk> \<Longrightarrow> (Some(Cond b P0 P1), s)#(Some P0, s)#ys \<in> cptn_mod"
+| CptnModCondF: "\<lbrakk>(Some P1, s)#ys \<in> cptn_mod; s \<notin> b \<rbrakk> \<Longrightarrow> (Some(Cond b P0 P1), s)#(Some P1, s)#ys \<in> cptn_mod"
+| CptnModSeq1: "\<lbrakk>(Some P0, s)#xs \<in> cptn_mod; zs=map (lift P1) xs \<rbrakk>
+ \<Longrightarrow> (Some(Seq P0 P1), s)#zs \<in> cptn_mod"
+| CptnModSeq2:
+ "\<lbrakk>(Some P0, s)#xs \<in> cptn_mod; fst(last ((Some P0, s)#xs)) = None;
+ (Some P1, snd(last ((Some P0, s)#xs)))#ys \<in> cptn_mod;
+ zs=(map (lift P1) xs)@ys \<rbrakk> \<Longrightarrow> (Some(Seq P0 P1), s)#zs \<in> cptn_mod"
+
+| CptnModWhile1:
+ "\<lbrakk> (Some P, s)#xs \<in> cptn_mod; s \<in> b; zs=map (lift (While b P)) xs \<rbrakk>
+ \<Longrightarrow> (Some(While b P), s)#(Some(Seq P (While b P)), s)#zs \<in> cptn_mod"
+| CptnModWhile2:
+ "\<lbrakk> (Some P, s)#xs \<in> cptn_mod; fst(last ((Some P, s)#xs))=None; s \<in> b;
+ zs=(map (lift (While b P)) xs)@ys;
+ (Some(While b P), snd(last ((Some P, s)#xs)))#ys \<in> cptn_mod\<rbrakk>
+ \<Longrightarrow> (Some(While b P), s)#(Some(Seq P (While b P)), s)#zs \<in> cptn_mod"
+
+subsection {* Equivalence of Both Definitions.*}
+
+lemma last_length: "((a#xs)!(length xs))=last (a#xs)"
+apply simp
+apply(induct xs,simp+)
+apply(case_tac xs)
+apply simp_all
+done
+
+lemma div_seq [rule_format]: "list \<in> cptn_mod \<Longrightarrow>
+ (\<forall>s P Q zs. list=(Some (Seq P Q), s)#zs \<longrightarrow>
+ (\<exists>xs. (Some P, s)#xs \<in> cptn_mod \<and> (zs=(map (lift Q) xs) \<or>
+ ( fst(((Some P, s)#xs)!length xs)=None \<and>
+ (\<exists>ys. (Some Q, snd(((Some P, s)#xs)!length xs))#ys \<in> cptn_mod
+ \<and> zs=(map (lift (Q)) xs)@ys)))))"
+apply(erule cptn_mod.induct)
+apply simp_all
+ apply clarify
+ apply(force intro:CptnModOne)
+ apply clarify
+ apply(erule_tac x=Pa in allE)
+ apply(erule_tac x=Q in allE)
+ apply simp
+ apply clarify
+ apply(erule disjE)
+ apply(rule_tac x="(Some Pa,t)#xsa" in exI)
+ apply(rule conjI)
+ apply clarify
+ apply(erule CptnModEnv)
+ apply(rule disjI1)
+ apply(simp add:lift_def)
+ apply clarify
+ apply(rule_tac x="(Some Pa,t)#xsa" in exI)
+ apply(rule conjI)
+ apply(erule CptnModEnv)
+ apply(rule disjI2)
+ apply(rule conjI)
+ apply(case_tac xsa,simp,simp)
+ apply(rule_tac x="ys" in exI)
+ apply(rule conjI)
+ apply simp
+ apply(simp add:lift_def)
+ apply clarify
+ apply(erule ctran.cases,simp_all)
+ apply clarify
+ apply(rule_tac x="xs" in exI)
+ apply simp
+ apply clarify
+apply(rule_tac x="xs" in exI)
+apply(simp add: last_length)
+done
+
+lemma cptn_onlyif_cptn_mod_aux [rule_format]:
+ "\<forall>s Q t xs.((Some a, s), Q, t) \<in> ctran \<longrightarrow> (Q, t) # xs \<in> cptn_mod
+ \<longrightarrow> (Some a, s) # (Q, t) # xs \<in> cptn_mod"
+apply(induct a)
+apply simp_all
+--{* basic *}
+apply clarify
+apply(erule ctran.cases,simp_all)
+apply(rule CptnModNone,rule Basic,simp)
+apply clarify
+apply(erule ctran.cases,simp_all)
+--{* Seq1 *}
+apply(rule_tac xs="[(None,ta)]" in CptnModSeq2)
+ apply(erule CptnModNone)
+ apply(rule CptnModOne)
+ apply simp
+apply simp
+apply(simp add:lift_def)
+--{* Seq2 *}
+apply(erule_tac x=sa in allE)
+apply(erule_tac x="Some P2" in allE)
+apply(erule allE,erule impE, assumption)
+apply(drule div_seq,simp)
+apply force
+apply clarify
+apply(erule disjE)
+ apply clarify
+ apply(erule allE,erule impE, assumption)
+ apply(erule_tac CptnModSeq1)
+ apply(simp add:lift_def)
+apply clarify
+apply(erule allE,erule impE, assumption)
+apply(erule_tac CptnModSeq2)
+ apply (simp add:last_length)
+ apply (simp add:last_length)
+apply(simp add:lift_def)
+--{* Cond *}
+apply clarify
+apply(erule ctran.cases,simp_all)
+apply(force elim: CptnModCondT)
+apply(force elim: CptnModCondF)
+--{* While *}
+apply clarify
+apply(erule ctran.cases,simp_all)
+apply(rule CptnModNone,erule WhileF,simp)
+apply(drule div_seq,force)
+apply clarify
+apply (erule disjE)
+ apply(force elim:CptnModWhile1)
+apply clarify
+apply(force simp add:last_length elim:CptnModWhile2)
+--{* await *}
+apply clarify
+apply(erule ctran.cases,simp_all)
+apply(rule CptnModNone,erule Await,simp+)
+done
+
+lemma cptn_onlyif_cptn_mod [rule_format]: "c \<in> cptn \<Longrightarrow> c \<in> cptn_mod"
+apply(erule cptn.induct)
+ apply(rule CptnModOne)
+ apply(erule CptnModEnv)
+apply(case_tac P)
+ apply simp
+ apply(erule ctran.cases,simp_all)
+apply(force elim:cptn_onlyif_cptn_mod_aux)
+done
+
+lemma lift_is_cptn: "c\<in>cptn \<Longrightarrow> map (lift P) c \<in> cptn"
+apply(erule cptn.induct)
+ apply(force simp add:lift_def CptnOne)
+ apply(force intro:CptnEnv simp add:lift_def)
+apply(force simp add:lift_def intro:CptnComp Seq2 Seq1 elim:ctran.cases)
+done
+
+lemma cptn_append_is_cptn [rule_format]:
+ "\<forall>b a. b#c1\<in>cptn \<longrightarrow> a#c2\<in>cptn \<longrightarrow> (b#c1)!length c1=a \<longrightarrow> b#c1@c2\<in>cptn"
+apply(induct c1)
+ apply simp
+apply clarify
+apply(erule cptn.cases,simp_all)
+ apply(force intro:CptnEnv)
+apply(force elim:CptnComp)
+done
+
+lemma last_lift: "\<lbrakk>xs\<noteq>[]; fst(xs!(length xs - (Suc 0)))=None\<rbrakk>
+ \<Longrightarrow> fst((map (lift P) xs)!(length (map (lift P) xs)- (Suc 0)))=(Some P)"
+apply(case_tac "(xs ! (length xs - (Suc 0)))")
+apply (simp add:lift_def)
+done
+
+lemma last_fst [rule_format]: "P((a#x)!length x) \<longrightarrow> \<not>P a \<longrightarrow> P (x!(length x - (Suc 0)))"
+apply(induct x,simp+)
+done
+
+lemma last_fst_esp:
+ "fst(((Some a,s)#xs)!(length xs))=None \<Longrightarrow> fst(xs!(length xs - (Suc 0)))=None"
+apply(erule last_fst)
+apply simp
+done
+
+lemma last_snd: "xs\<noteq>[] \<Longrightarrow>
+ snd(((map (lift P) xs))!(length (map (lift P) xs) - (Suc 0)))=snd(xs!(length xs - (Suc 0)))"
+apply(case_tac "(xs ! (length xs - (Suc 0)))",simp)
+apply (simp add:lift_def)
+done
+
+lemma Cons_lift: "(Some (Seq P Q), s) # (map (lift Q) xs) = map (lift Q) ((Some P, s) # xs)"
+by(simp add:lift_def)
+
+lemma Cons_lift_append:
+ "(Some (Seq P Q), s) # (map (lift Q) xs) @ ys = map (lift Q) ((Some P, s) # xs)@ ys "
+by(simp add:lift_def)
+
+lemma lift_nth: "i<length xs \<Longrightarrow> map (lift Q) xs ! i = lift Q (xs! i)"
+by (simp add:lift_def)
+
+lemma snd_lift: "i< length xs \<Longrightarrow> snd(lift Q (xs ! i))= snd (xs ! i)"
+apply(case_tac "xs!i")
+apply(simp add:lift_def)
+done
+
+lemma cptn_if_cptn_mod: "c \<in> cptn_mod \<Longrightarrow> c \<in> cptn"
+apply(erule cptn_mod.induct)
+ apply(rule CptnOne)
+ apply(erule CptnEnv)
+ apply(erule CptnComp,simp)
+ apply(rule CptnComp)
+ apply(erule CondT,simp)
+ apply(rule CptnComp)
+ apply(erule CondF,simp)
+--{* Seq1 *}
+apply(erule cptn.cases,simp_all)
+ apply(rule CptnOne)
+ apply clarify
+ apply(drule_tac P=P1 in lift_is_cptn)
+ apply(simp add:lift_def)
+ apply(rule CptnEnv,simp)
+apply clarify
+apply(simp add:lift_def)
+apply(rule conjI)
+ apply clarify
+ apply(rule CptnComp)
+ apply(rule Seq1,simp)
+ apply(drule_tac P=P1 in lift_is_cptn)
+ apply(simp add:lift_def)
+apply clarify
+apply(rule CptnComp)
+ apply(rule Seq2,simp)
+apply(drule_tac P=P1 in lift_is_cptn)
+apply(simp add:lift_def)
+--{* Seq2 *}
+apply(rule cptn_append_is_cptn)
+ apply(drule_tac P=P1 in lift_is_cptn)
+ apply(simp add:lift_def)
+ apply simp
+apply(case_tac "xs\<noteq>[]")
+ apply(drule_tac P=P1 in last_lift)
+ apply(rule last_fst_esp)
+ apply (simp add:last_length)
+ apply(simp add:Cons_lift del:map.simps)
+ apply(rule conjI, clarify, simp)
+ apply(case_tac "(((Some P0, s) # xs) ! length xs)")
+ apply clarify
+ apply (simp add:lift_def last_length)
+apply (simp add:last_length)
+--{* While1 *}
+apply(rule CptnComp)
+apply(rule WhileT,simp)
+apply(drule_tac P="While b P" in lift_is_cptn)
+apply(simp add:lift_def)
+--{* While2 *}
+apply(rule CptnComp)
+apply(rule WhileT,simp)
+apply(rule cptn_append_is_cptn)
+apply(drule_tac P="While b P" in lift_is_cptn)
+ apply(simp add:lift_def)
+ apply simp
+apply(case_tac "xs\<noteq>[]")
+ apply(drule_tac P="While b P" in last_lift)
+ apply(rule last_fst_esp,simp add:last_length)
+ apply(simp add:Cons_lift del:map.simps)
+ apply(rule conjI, clarify, simp)
+ apply(case_tac "(((Some P, s) # xs) ! length xs)")
+ apply clarify
+ apply (simp add:last_length lift_def)
+apply simp
+done
+
+theorem cptn_iff_cptn_mod: "(c \<in> cptn) = (c \<in> cptn_mod)"
+apply(rule iffI)
+ apply(erule cptn_onlyif_cptn_mod)
+apply(erule cptn_if_cptn_mod)
+done
+
+section {* Validity of Correctness Formulas*}
+
+subsection {* Validity for Component Programs. *}
+
+types 'a rgformula = "'a com \<times> 'a set \<times> ('a \<times> 'a) set \<times> ('a \<times> 'a) set \<times> 'a set"
+
+constdefs
+ assum :: "('a set \<times> ('a \<times> 'a) set) \<Rightarrow> ('a confs) set"
+ "assum \<equiv> \<lambda>(pre, rely). {c. snd(c!0) \<in> pre \<and> (\<forall>i. Suc i<length c \<longrightarrow>
+ c!i -e\<rightarrow> c!(Suc i) \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> rely)}"
+
+ comm :: "(('a \<times> 'a) set \<times> 'a set) \<Rightarrow> ('a confs) set"
+ "comm \<equiv> \<lambda>(guar, post). {c. (\<forall>i. Suc i<length c \<longrightarrow>
+ c!i -c\<rightarrow> c!(Suc i) \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> guar) \<and>
+ (fst (last c) = None \<longrightarrow> snd (last c) \<in> post)}"
+
+ com_validity :: "'a com \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> 'a set \<Rightarrow> bool"
+ ("\<Turnstile> _ sat [_, _, _, _]" [60,0,0,0,0] 45)
+ "\<Turnstile> P sat [pre, rely, guar, post] \<equiv>
+ \<forall>s. cp (Some P) s \<inter> assum(pre, rely) \<subseteq> comm(guar, post)"
+
+subsection {* Validity for Parallel Programs. *}
+
+constdefs
+ All_None :: "(('a com) option) list \<Rightarrow> bool"
+ "All_None xs \<equiv> \<forall>c\<in>set xs. c=None"
+
+ par_assum :: "('a set \<times> ('a \<times> 'a) set) \<Rightarrow> ('a par_confs) set"
+ "par_assum \<equiv> \<lambda>(pre, rely). {c. snd(c!0) \<in> pre \<and> (\<forall>i. Suc i<length c \<longrightarrow>
+ c!i -pe\<rightarrow> c!Suc i \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> rely)}"
+
+ par_comm :: "(('a \<times> 'a) set \<times> 'a set) \<Rightarrow> ('a par_confs) set"
+ "par_comm \<equiv> \<lambda>(guar, post). {c. (\<forall>i. Suc i<length c \<longrightarrow>
+ c!i -pc\<rightarrow> c!Suc i \<longrightarrow> (snd(c!i), snd(c!Suc i)) \<in> guar) \<and>
+ (All_None (fst (last c)) \<longrightarrow> snd( last c) \<in> post)}"
+
+ par_com_validity :: "'a par_com \<Rightarrow> 'a set \<Rightarrow> ('a \<times> 'a) set \<Rightarrow> ('a \<times> 'a) set
+\<Rightarrow> 'a set \<Rightarrow> bool" ("\<Turnstile> _ SAT [_, _, _, _]" [60,0,0,0,0] 45)
+ "\<Turnstile> Ps SAT [pre, rely, guar, post] \<equiv>
+ \<forall>s. par_cp Ps s \<inter> par_assum(pre, rely) \<subseteq> par_comm(guar, post)"
+
+subsection {* Compositionality of the Semantics *}
+
+subsubsection {* Definition of the conjoin operator *}
+
+constdefs
+ same_length :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
+ "same_length c clist \<equiv> (\<forall>i<length clist. length(clist!i)=length c)"
+
+ same_state :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
+ "same_state c clist \<equiv> (\<forall>i <length clist. \<forall>j<length c. snd(c!j) = snd((clist!i)!j))"
+
+ same_program :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
+ "same_program c clist \<equiv> (\<forall>j<length c. fst(c!j) = map (\<lambda>x. fst(nth x j)) clist)"
+
+ compat_label :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool"
+ "compat_label c clist \<equiv> (\<forall>j. Suc j<length c \<longrightarrow>
+ (c!j -pc\<rightarrow> c!Suc j \<and> (\<exists>i<length clist. (clist!i)!j -c\<rightarrow> (clist!i)! Suc j \<and>
+ (\<forall>l<length clist. l\<noteq>i \<longrightarrow> (clist!l)!j -e\<rightarrow> (clist!l)! Suc j))) \<or>
+ (c!j -pe\<rightarrow> c!Suc j \<and> (\<forall>i<length clist. (clist!i)!j -e\<rightarrow> (clist!i)! Suc j)))"
+
+ conjoin :: "'a par_confs \<Rightarrow> ('a confs) list \<Rightarrow> bool" ("_ \<propto> _" [65,65] 64)
+ "c \<propto> clist \<equiv> (same_length c clist) \<and> (same_state c clist) \<and> (same_program c clist) \<and> (compat_label c clist)"
+
+subsubsection {* Some previous lemmas *}
+
+lemma list_eq_if [rule_format]:
+ "\<forall>ys. xs=ys \<longrightarrow> (length xs = length ys) \<longrightarrow> (\<forall>i<length xs. xs!i=ys!i)"
+apply (induct xs)
+ apply simp
+apply clarify
+done
+
+lemma list_eq: "(length xs = length ys \<and> (\<forall>i<length xs. xs!i=ys!i)) = (xs=ys)"
+apply(rule iffI)
+ apply clarify
+ apply(erule nth_equalityI)
+ apply simp+
+done
+
+lemma nth_tl: "\<lbrakk> ys!0=a; ys\<noteq>[] \<rbrakk> \<Longrightarrow> ys=(a#(tl ys))"
+apply(case_tac ys)
+ apply simp+
+done
+
+lemma nth_tl_if [rule_format]: "ys\<noteq>[] \<longrightarrow> ys!0=a \<longrightarrow> P ys \<longrightarrow> P (a#(tl ys))"
+apply(induct ys)
+ apply simp+
+done
+
+lemma nth_tl_onlyif [rule_format]: "ys\<noteq>[] \<longrightarrow> ys!0=a \<longrightarrow> P (a#(tl ys)) \<longrightarrow> P ys"
+apply(induct ys)
+ apply simp+
+done
+
+lemma seq_not_eq1: "Seq c1 c2\<noteq>c1"
+apply(rule com.induct)
+apply simp_all
+apply clarify
+done
+
+lemma seq_not_eq2: "Seq c1 c2\<noteq>c2"
+apply(rule com.induct)
+apply simp_all
+apply clarify
+done
+
+lemma if_not_eq1: "Cond b c1 c2 \<noteq>c1"
+apply(rule com.induct)
+apply simp_all
+apply clarify
+done
+
+lemma if_not_eq2: "Cond b c1 c2\<noteq>c2"
+apply(rule com.induct)
+apply simp_all
+apply clarify
+done
+
+lemmas seq_and_if_not_eq [simp] = seq_not_eq1 seq_not_eq2
+seq_not_eq1 [THEN not_sym] seq_not_eq2 [THEN not_sym]
+if_not_eq1 if_not_eq2 if_not_eq1 [THEN not_sym] if_not_eq2 [THEN not_sym]
+
+lemma prog_not_eq_in_ctran_aux:
+ assumes c: "(P,s) -c\<rightarrow> (Q,t)"
+ shows "P\<noteq>Q" using c
+ by (induct x1 \<equiv> "(P,s)" x2 \<equiv> "(Q,t)" arbitrary: P s Q t) auto
+
+lemma prog_not_eq_in_ctran [simp]: "\<not> (P,s) -c\<rightarrow> (P,t)"
+apply clarify
+apply(drule prog_not_eq_in_ctran_aux)
+apply simp
+done
+
+lemma prog_not_eq_in_par_ctran_aux [rule_format]: "(P,s) -pc\<rightarrow> (Q,t) \<Longrightarrow> (P\<noteq>Q)"
+apply(erule par_ctran.induct)
+apply(drule prog_not_eq_in_ctran_aux)
+apply clarify
+apply(drule list_eq_if)
+ apply simp_all
+apply force
+done
+
+lemma prog_not_eq_in_par_ctran [simp]: "\<not> (P,s) -pc\<rightarrow> (P,t)"
+apply clarify
+apply(drule prog_not_eq_in_par_ctran_aux)
+apply simp
+done
+
+lemma tl_in_cptn: "\<lbrakk> a#xs \<in>cptn; xs\<noteq>[] \<rbrakk> \<Longrightarrow> xs\<in>cptn"
+apply(force elim:cptn.cases)
+done
+
+lemma tl_zero[rule_format]:
+ "P (ys!Suc j) \<longrightarrow> Suc j<length ys \<longrightarrow> ys\<noteq>[] \<longrightarrow> P (tl(ys)!j)"
+apply(induct ys)
+ apply simp_all
+done
+
+subsection {* The Semantics is Compositional *}
+
+lemma aux_if [rule_format]:
+ "\<forall>xs s clist. (length clist = length xs \<and> (\<forall>i<length xs. (xs!i,s)#clist!i \<in> cptn)
+ \<and> ((xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#snd i) (zip xs clist))
+ \<longrightarrow> (xs, s)#ys \<in> par_cptn)"
+apply(induct ys)
+ apply(clarify)
+ apply(rule ParCptnOne)
+apply(clarify)
+apply(simp add:conjoin_def compat_label_def)
+apply clarify
+apply(erule_tac x="0" and P="\<lambda>j. ?H j \<longrightarrow> (?P j \<or> ?Q j)" in all_dupE,simp)
+apply(erule disjE)
+--{* first step is a Component step *}
+ apply clarify
+ apply simp
+ apply(subgoal_tac "a=(xs[i:=(fst(clist!i!0))])")
+ apply(subgoal_tac "b=snd(clist!i!0)",simp)
+ prefer 2
+ apply(simp add: same_state_def)
+ apply(erule_tac x=i in allE,erule impE,assumption,
+ erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ prefer 2
+ apply(simp add:same_program_def)
+ apply(erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=(?t j)" in allE,simp)
+ apply(rule nth_equalityI,simp)
+ apply clarify
+ apply(case_tac "i=ia",simp,simp)
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
+ apply(drule_tac t=i in not_sym,simp)
+ apply(erule etranE,simp)
+ apply(rule ParCptnComp)
+ apply(erule ParComp,simp)
+--{* applying the induction hypothesis *}
+ apply(erule_tac x="xs[i := fst (clist ! i ! 0)]" in allE)
+ apply(erule_tac x="snd (clist ! i ! 0)" in allE)
+ apply(erule mp)
+ apply(rule_tac x="map tl clist" in exI,simp)
+ apply(rule conjI,clarify)
+ apply(case_tac "i=ia",simp)
+ apply(rule nth_tl_if)
+ apply(force simp add:same_length_def length_Suc_conv)
+ apply simp
+ apply(erule allE,erule impE,assumption,erule tl_in_cptn)
+ apply(force simp add:same_length_def length_Suc_conv)
+ apply(rule nth_tl_if)
+ apply(force simp add:same_length_def length_Suc_conv)
+ apply(simp add:same_state_def)
+ apply(erule_tac x=ia in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
+ apply(drule_tac t=i in not_sym,simp)
+ apply(erule etranE,simp)
+ apply(erule allE,erule impE,assumption,erule tl_in_cptn)
+ apply(force simp add:same_length_def length_Suc_conv)
+ apply(simp add:same_length_def same_state_def)
+ apply(rule conjI)
+ apply clarify
+ apply(case_tac j,simp,simp)
+ apply(erule_tac x=ia in allE, erule impE, assumption,
+ erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(force simp add:same_length_def length_Suc_conv)
+ apply(rule conjI)
+ apply(simp add:same_program_def)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(rule nth_equalityI,simp)
+ apply clarify
+ apply(case_tac "i=ia",simp,simp)
+ apply(erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=(?t j)" in allE,simp)
+ apply(rule nth_equalityI,simp,simp)
+ apply(force simp add:length_Suc_conv)
+ apply(rule allI,rule impI)
+ apply(erule_tac x="Suc j" and P="\<lambda>j. ?H j \<longrightarrow> (?I j \<or> ?J j)" in allE,simp)
+ apply(erule disjE)
+ apply clarify
+ apply(rule_tac x=ia in exI,simp)
+ apply(case_tac "i=ia",simp)
+ apply(rule conjI)
+ apply(force simp add: length_Suc_conv)
+ apply clarify
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE,assumption)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE,assumption)
+ apply simp
+ apply(case_tac j,simp)
+ apply(rule tl_zero)
+ apply(erule_tac x=l in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(force elim:etranE intro:Env)
+ apply force
+ apply force
+ apply simp
+ apply(rule tl_zero)
+ apply(erule tl_zero)
+ apply force
+ apply force
+ apply force
+ apply force
+ apply(rule conjI,simp)
+ apply(rule nth_tl_if)
+ apply force
+ apply(erule_tac x=ia in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
+ apply(drule_tac t=i in not_sym,simp)
+ apply(erule etranE,simp)
+ apply(erule tl_zero)
+ apply force
+ apply force
+ apply clarify
+ apply(case_tac "i=l",simp)
+ apply(rule nth_tl_if)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply simp
+ apply(erule_tac P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE,assumption,erule impE,assumption)
+ apply(erule tl_zero,force)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply(rule nth_tl_if)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply(erule_tac x=l in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE, assumption,simp)
+ apply(erule etranE,simp)
+ apply(rule tl_zero)
+ apply force
+ apply force
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply(rule disjI2)
+ apply(case_tac j,simp)
+ apply clarify
+ apply(rule tl_zero)
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j\<in>etran" in allE,erule impE, assumption)
+ apply(case_tac "i=ia",simp,simp)
+ apply(erule_tac x=ia in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE,erule impE, assumption,simp)
+ apply(force elim:etranE intro:Env)
+ apply force
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply simp
+ apply clarify
+ apply(rule tl_zero)
+ apply(rule tl_zero,force)
+ apply force
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply force
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+--{* first step is an environmental step *}
+apply clarify
+apply(erule par_etran.cases)
+apply simp
+apply(rule ParCptnEnv)
+apply(erule_tac x="Ps" in allE)
+apply(erule_tac x="t" in allE)
+apply(erule mp)
+apply(rule_tac x="map tl clist" in exI,simp)
+apply(rule conjI)
+ apply clarify
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (?I ?s j) \<in> cptn" in allE,simp)
+ apply(erule cptn.cases)
+ apply(simp add:same_length_def)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply(simp add:same_state_def)
+ apply(erule_tac x=i in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> ?J j \<in>etran" in allE,simp)
+ apply(erule etranE,simp)
+apply(simp add:same_state_def same_length_def)
+apply(rule conjI,clarify)
+ apply(case_tac j,simp,simp)
+ apply(erule_tac x=i in allE, erule impE, assumption,
+ erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(rule tl_zero)
+ apply(simp)
+ apply force
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+apply(rule conjI)
+ apply(simp add:same_program_def)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(rule nth_equalityI,simp)
+ apply clarify
+ apply simp
+ apply(erule_tac x="Suc(Suc nat)" and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=(?t j)" in allE,simp)
+ apply(rule nth_equalityI,simp,simp)
+ apply(force simp add:length_Suc_conv)
+apply(rule allI,rule impI)
+apply(erule_tac x="Suc j" and P="\<lambda>j. ?H j \<longrightarrow> (?I j \<or> ?J j)" in allE,simp)
+apply(erule disjE)
+ apply clarify
+ apply(rule_tac x=i in exI,simp)
+ apply(rule conjI)
+ apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
+ apply(erule etranE,simp)
+ apply(erule_tac x=i in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(rule nth_tl_if)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply simp
+ apply(erule tl_zero,force)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply clarify
+ apply(erule_tac x=l and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
+ apply(erule etranE,simp)
+ apply(erule_tac x=l in allE, erule impE, assumption,
+ erule_tac x=1 and P="\<lambda>j. (?H j) \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(rule nth_tl_if)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply simp
+ apply(rule tl_zero,force)
+ apply force
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+apply(rule disjI2)
+apply simp
+apply clarify
+apply(case_tac j,simp)
+ apply(rule tl_zero)
+ apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
+ apply(erule_tac x=i and P="\<lambda>i. ?H i \<longrightarrow> ?J i \<in>etran" in allE, erule impE, assumption)
+ apply(force elim:etranE intro:Env)
+ apply force
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+apply simp
+apply(rule tl_zero)
+ apply(rule tl_zero,force)
+ apply force
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply force
+apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+done
+
+lemma less_Suc_0 [iff]: "(n < Suc 0) = (n = 0)"
+by auto
+
+lemma aux_onlyif [rule_format]: "\<forall>xs s. (xs, s)#ys \<in> par_cptn \<longrightarrow>
+ (\<exists>clist. (length clist = length xs) \<and>
+ (xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#(snd i)) (zip xs clist) \<and>
+ (\<forall>i<length xs. (xs!i,s)#(clist!i) \<in> cptn))"
+apply(induct ys)
+ apply(clarify)
+ apply(rule_tac x="map (\<lambda>i. []) [0..<length xs]" in exI)
+ apply(simp add: conjoin_def same_length_def same_state_def same_program_def compat_label_def)
+ apply(rule conjI)
+ apply(rule nth_equalityI,simp,simp)
+ apply(force intro: cptn.intros)
+apply(clarify)
+apply(erule par_cptn.cases,simp)
+ apply simp
+ apply(erule_tac x="xs" in allE)
+ apply(erule_tac x="t" in allE,simp)
+ apply clarify
+ apply(rule_tac x="(map (\<lambda>j. (P!j, t)#(clist!j)) [0..<length P])" in exI,simp)
+ apply(rule conjI)
+ prefer 2
+ apply clarify
+ apply(rule CptnEnv,simp)
+ apply(simp add:conjoin_def same_length_def same_state_def)
+ apply (rule conjI)
+ apply clarify
+ apply(case_tac j,simp,simp)
+ apply(rule conjI)
+ apply(simp add:same_program_def)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(rule nth_equalityI,simp,simp)
+ apply simp
+ apply(rule nth_equalityI,simp,simp)
+ apply(simp add:compat_label_def)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(simp add:ParEnv)
+ apply clarify
+ apply(simp add:Env)
+ apply simp
+ apply(erule_tac x=nat in allE,erule impE, assumption)
+ apply(erule disjE,simp)
+ apply clarify
+ apply(rule_tac x=i in exI,simp)
+ apply force
+apply(erule par_ctran.cases,simp)
+apply(erule_tac x="Ps[i:=r]" in allE)
+apply(erule_tac x="ta" in allE,simp)
+apply clarify
+apply(rule_tac x="(map (\<lambda>j. (Ps!j, ta)#(clist!j)) [0..<length Ps]) [i:=((r, ta)#(clist!i))]" in exI,simp)
+apply(rule conjI)
+ prefer 2
+ apply clarify
+ apply(case_tac "i=ia",simp)
+ apply(erule CptnComp)
+ apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (?I j \<in> cptn)" in allE,simp)
+ apply simp
+ apply(erule_tac x=ia in allE)
+ apply(rule CptnEnv,simp)
+apply(simp add:conjoin_def)
+apply (rule conjI)
+ apply(simp add:same_length_def)
+ apply clarify
+ apply(case_tac "i=ia",simp,simp)
+apply(rule conjI)
+ apply(simp add:same_state_def)
+ apply clarify
+ apply(case_tac j, simp, simp (no_asm_simp))
+ apply(case_tac "i=ia",simp,simp)
+apply(rule conjI)
+ apply(simp add:same_program_def)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(rule nth_equalityI,simp,simp)
+ apply simp
+ apply(rule nth_equalityI,simp,simp)
+ apply(erule_tac x=nat and P="\<lambda>j. ?H j \<longrightarrow> (fst (?a j))=((?b j))" in allE)
+ apply(case_tac nat)
+ apply clarify
+ apply(case_tac "i=ia",simp,simp)
+ apply clarify
+ apply(case_tac "i=ia",simp,simp)
+apply(simp add:compat_label_def)
+apply clarify
+apply(case_tac j)
+ apply(rule conjI,simp)
+ apply(erule ParComp,assumption)
+ apply clarify
+ apply(rule_tac x=i in exI,simp)
+ apply clarify
+ apply(rule Env)
+apply simp
+apply(erule_tac x=nat and P="\<lambda>j. ?H j \<longrightarrow> (?P j \<or> ?Q j)" in allE,simp)
+apply(erule disjE)
+ apply clarify
+ apply(rule_tac x=ia in exI,simp)
+ apply(rule conjI)
+ apply(case_tac "i=ia",simp,simp)
+ apply clarify
+ apply(case_tac "i=l",simp)
+ apply(case_tac "l=ia",simp,simp)
+ apply(erule_tac x=l in allE,erule impE,assumption,erule impE, assumption,simp)
+ apply simp
+ apply(erule_tac x=l in allE,erule impE,assumption,erule impE, assumption,simp)
+apply clarify
+apply(erule_tac x=ia and P="\<lambda>j. ?H j \<longrightarrow> (?P j)\<in>etran" in allE, erule impE, assumption)
+apply(case_tac "i=ia",simp,simp)
+done
+
+lemma one_iff_aux: "xs\<noteq>[] \<Longrightarrow> (\<forall>ys. ((xs, s)#ys \<in> par_cptn) =
+ (\<exists>clist. length clist= length xs \<and>
+ ((xs, s)#ys \<propto> map (\<lambda>i. (fst i,s)#(snd i)) (zip xs clist)) \<and>
+ (\<forall>i<length xs. (xs!i,s)#(clist!i) \<in> cptn))) =
+ (par_cp (xs) s = {c. \<exists>clist. (length clist)=(length xs) \<and>
+ (\<forall>i<length clist. (clist!i) \<in> cp(xs!i) s) \<and> c \<propto> clist})"
+apply (rule iffI)
+ apply(rule subset_antisym)
+ apply(rule subsetI)
+ apply(clarify)
+ apply(simp add:par_cp_def cp_def)
+ apply(case_tac x)
+ apply(force elim:par_cptn.cases)
+ apply simp
+ apply(erule_tac x="list" in allE)
+ apply clarify
+ apply simp
+ apply(rule_tac x="map (\<lambda>i. (fst i, s) # snd i) (zip xs clist)" in exI,simp)
+ apply(rule subsetI)
+ apply(clarify)
+ apply(case_tac x)
+ apply(erule_tac x=0 in allE)
+ apply(simp add:cp_def conjoin_def same_length_def same_program_def same_state_def compat_label_def)
+ apply clarify
+ apply(erule cptn.cases,force,force,force)
+ apply(simp add:par_cp_def conjoin_def same_length_def same_program_def same_state_def compat_label_def)
+ apply clarify
+ apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in all_dupE)
+ apply(subgoal_tac "a = xs")
+ apply(subgoal_tac "b = s",simp)
+ prefer 3
+ apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (fst (?s j))=((?t j))" in allE)
+ apply (simp add:cp_def)
+ apply(rule nth_equalityI,simp,simp)
+ prefer 2
+ apply(erule_tac x=0 in allE)
+ apply (simp add:cp_def)
+ apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (\<forall>i. ?T i \<longrightarrow> (snd (?d j i))=(snd (?e j i)))" in allE,simp)
+ apply(erule_tac x=0 and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(erule_tac x=list in allE)
+ apply(rule_tac x="map tl clist" in exI,simp)
+ apply(rule conjI)
+ apply clarify
+ apply(case_tac j,simp)
+ apply(erule_tac x=i in allE, erule impE, assumption,
+ erule_tac x="0" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE,simp)
+ apply(erule_tac x=i in allE, erule impE, assumption,
+ erule_tac x="Suc nat" and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply(rule conjI)
+ apply clarify
+ apply(rule nth_equalityI,simp,simp)
+ apply(case_tac j)
+ apply clarify
+ apply(erule_tac x=i in allE)
+ apply(simp add:cp_def)
+ apply clarify
+ apply simp
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply(thin_tac "?H = (\<exists>i. ?J i)")
+ apply(rule conjI)
+ apply clarify
+ apply(erule_tac x=j in allE,erule impE, assumption,erule disjE)
+ apply clarify
+ apply(rule_tac x=i in exI,simp)
+ apply(case_tac j,simp)
+ apply(rule conjI)
+ apply(erule_tac x=i in allE)
+ apply(simp add:cp_def)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply clarify
+ apply(erule_tac x=l in allE)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
+ apply clarify
+ apply(simp add:cp_def)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!l",simp,simp)
+ apply simp
+ apply(rule conjI)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply clarify
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!l",simp,simp)
+ apply clarify
+ apply(erule_tac x=i in allE)
+ apply(simp add:cp_def)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp)
+ apply(rule nth_tl_if,simp,simp)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (?P j)\<in>etran" in allE, erule impE, assumption,simp)
+ apply(simp add:cp_def)
+ apply clarify
+ apply(rule nth_tl_if)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply force
+ apply force
+apply clarify
+apply(rule iffI)
+ apply(simp add:par_cp_def)
+ apply(erule_tac c="(xs, s) # ys" in equalityCE)
+ apply simp
+ apply clarify
+ apply(rule_tac x="map tl clist" in exI)
+ apply simp
+ apply (rule conjI)
+ apply(simp add:conjoin_def cp_def)
+ apply(rule conjI)
+ apply clarify
+ apply(unfold same_length_def)
+ apply clarify
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,simp)
+ apply(rule conjI)
+ apply(simp add:same_state_def)
+ apply clarify
+ apply(erule_tac x=i in allE, erule impE, assumption,
+ erule_tac x=j and P="\<lambda>j. ?H j \<longrightarrow> (snd (?d j))=(snd (?e j))" in allE)
+ apply(case_tac j,simp)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply(rule conjI)
+ apply(simp add:same_program_def)
+ apply clarify
+ apply(rule nth_equalityI,simp,simp)
+ apply(case_tac j,simp)
+ apply clarify
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply clarify
+ apply(simp add:compat_label_def)
+ apply(rule allI,rule impI)
+ apply(erule_tac x=j in allE,erule impE, assumption)
+ apply(erule disjE)
+ apply clarify
+ apply(rule_tac x=i in exI,simp)
+ apply(rule conjI)
+ apply(erule_tac x=i in allE)
+ apply(case_tac j,simp)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!i",simp,simp)
+ apply clarify
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> ?I j \<longrightarrow> ?J j" in allE)
+ apply(erule_tac x=l and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE)
+ apply(case_tac "clist!l",simp,simp)
+ apply(erule_tac x=l in allE,simp)
+ apply(rule disjI2)
+ apply clarify
+ apply(rule tl_zero)
+ apply(case_tac j,simp,simp)
+ apply(rule tl_zero,force)
+ apply force
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply force
+ apply(erule_tac x=i and P="\<lambda>j. ?H j \<longrightarrow> (length (?s j) = ?t)" in allE,force)
+ apply clarify
+ apply(erule_tac x=i in allE)
+ apply(simp add:cp_def)
+ apply(rule nth_tl_if)
+ apply(simp add:conjoin_def)
+ apply clarify
+ apply(simp add:same_length_def)
+ apply(erule_tac x=i in allE,simp)
+ apply simp
+ apply simp
+ apply simp
+apply clarify
+apply(erule_tac c="(xs, s) # ys" in equalityCE)
+ apply(simp add:par_cp_def)
+apply simp
+apply(erule_tac x="map (\<lambda>i. (fst i, s) # snd i) (zip xs clist)" in allE)
+apply simp
+apply clarify
+apply(simp add:cp_def)
+done
+
+theorem one: "xs\<noteq>[] \<Longrightarrow>
+ par_cp xs s = {c. \<exists>clist. (length clist)=(length xs) \<and>
+ (\<forall>i<length clist. (clist!i) \<in> cp(xs!i) s) \<and> c \<propto> clist}"
+apply(frule one_iff_aux)
+apply(drule sym)
+apply(erule iffD2)
+apply clarify
+apply(rule iffI)
+ apply(erule aux_onlyif)
+apply clarify
+apply(force intro:aux_if)
+done
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/ROOT.ML Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,2 @@
+
+use_thy "Hoare_Parallel";
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/document/root.bib Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,28 @@
+@inproceedings{NipkowP-FASE99,author={Tobias Nipkow and Prensa Nieto, Leonor},
+title={{Owicki/Gries} in {Isabelle/HOL}},
+booktitle={Fundamental Approaches to Software Engineering (FASE'99)},
+editor={J.-P. Finance},publisher="Springer",series="LNCS",volume=1577,
+pages={188--203},year=1999}
+
+@InProceedings{PrenEsp00,
+ author = {Prensa Nieto, Leonor and Javier Esparza},
+ title = {Verifying Single and Multi-mutator Garbage Collectors
+ with {Owicki/Gries} in {Isabelle/HOL}},
+ booktitle = {Mathematical Foundations of Computer Science (MFCS 2000)},
+ editor = {M. Nielsen and B. Rovan},
+ publisher = {Springer-Verlag},
+ series = {LNCS},
+ volume = 1893,
+ pages = {619--628},
+ year = 2000
+}
+
+@PhdThesis{Prensa-PhD,author={Leonor Prensa Nieto},
+title={Verification of Parallel Programs with the Owicki-Gries and
+Rely-Guarantee Methods in Isabelle/HOL},
+school={Technische Universit{\"a}t M{\"u}nchen},year=2002}
+
+@inproceedings{Prensa-ESOP03,author={Prensa Nieto, Leonor},
+title={The {Rely-Guarantee} Method in {Isabelle/HOL}},
+booktitle={European Symposium on Programming (ESOP'03)},editor={P. Degano},
+publisher=Springer,series=LNCS,volume=2618,pages={348--362},year=2003}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Hoare_Parallel/document/root.tex Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,62 @@
+
+% $Id$
+
+\documentclass[11pt,a4paper]{report}
+\usepackage{graphicx}
+\usepackage[english]{babel}
+\usepackage{isabelle,isabellesym}
+\usepackage{pdfsetup}
+
+\urlstyle{rm}
+\isabellestyle{it}
+
+\renewcommand{\isamarkupheader}[1]{#1}
+
+\begin{document}
+
+\title{Hoare Logic for Parallel Programs}
+\author{Leonor Prensa Nieto}
+\maketitle
+
+\begin{abstract}\noindent
+ In the following theories a formalization of the Owicki-Gries and
+ the rely-guarantee methods is presented. These methods are widely
+ used for correctness proofs of parallel imperative programs with
+ shared variables. We define syntax, semantics and proof rules in
+ Isabelle/HOL. The proof rules also provide for programs
+ parameterized in the number of parallel components. Their
+ correctness w.r.t.\ the semantics is proven. Completeness proofs
+ for both methods are extended to the new case of parameterized
+ programs. (These proofs have not been formalized in Isabelle. They
+ can be found in~\cite{Prensa-PhD}.) Using this formalizations we
+ verify several non-trivial examples for parameterized and
+ non-parameterized programs. For the automatic generation of
+ verification conditions with the Owicki-Gries method we define a
+ tactic based on the proof rules. The most involved examples are the
+ verification of two garbage-collection algorithms, the second one
+ parameterized in the number of mutators.
+
+For excellent descriptions of this work see
+\cite{NipkowP-FASE99,PrenEsp00,Prensa-PhD,Prensa-ESOP03}.
+
+\end{abstract}
+
+\pagestyle{plain}
+\thispagestyle{empty}
+\tableofcontents
+
+\clearpage
+
+\begin{center}
+ \includegraphics[scale=0.7]{session_graph}
+\end{center}
+
+\newpage
+
+\parindent 0pt\parskip 0.5ex
+\input{session}
+
+\bibliographystyle{plain}
+\bibliography{root}
+
+\end{document}
--- a/src/HOL/IsaMakefile Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/IsaMakefile Tue Sep 22 13:52:19 2009 +1000
@@ -18,7 +18,7 @@
HOL-Extraction \
HOL-Hahn_Banach \
HOL-Hoare \
- HOL-HoareParallel \
+ HOL-Hoare_Parallel \
HOL-Import \
HOL-IMP \
HOL-IMPP \
@@ -40,6 +40,7 @@
HOL-Prolog \
HOL-SET-Protocol \
HOL-SizeChange \
+ HOL-SMT \
HOL-Statespace \
HOL-Subst \
TLA-Buffer \
@@ -536,21 +537,22 @@
@$(ISABELLE_TOOL) usedir $(OUT)/HOL Hoare
-## HOL-HoareParallel
+## HOL-Hoare_Parallel
-HOL-HoareParallel: HOL $(LOG)/HOL-HoareParallel.gz
+HOL-Hoare_Parallel: HOL $(LOG)/HOL-Hoare_Parallel.gz
-$(LOG)/HOL-HoareParallel.gz: $(OUT)/HOL HoareParallel/Gar_Coll.thy \
- HoareParallel/Graph.thy HoareParallel/Mul_Gar_Coll.thy \
- HoareParallel/OG_Com.thy HoareParallel/OG_Examples.thy \
- HoareParallel/OG_Hoare.thy HoareParallel/OG_Syntax.thy \
- HoareParallel/OG_Tactics.thy HoareParallel/OG_Tran.thy \
- HoareParallel/Quote_Antiquote.thy HoareParallel/RG_Com.thy \
- HoareParallel/RG_Examples.thy HoareParallel/RG_Hoare.thy \
- HoareParallel/RG_Syntax.thy HoareParallel/RG_Tran.thy \
- HoareParallel/ROOT.ML HoareParallel/document/root.tex \
- HoareParallel/document/root.bib
- @$(ISABELLE_TOOL) usedir -g true $(OUT)/HOL HoareParallel
+$(LOG)/HOL-Hoare_Parallel.gz: $(OUT)/HOL Hoare_Parallel/Gar_Coll.thy \
+ Hoare_Parallel/Graph.thy Hoare_Parallel/Hoare_Parallel.thy \
+ Hoare_Parallel/Mul_Gar_Coll.thy \
+ Hoare_Parallel/OG_Com.thy Hoare_Parallel/OG_Examples.thy \
+ Hoare_Parallel/OG_Hoare.thy Hoare_Parallel/OG_Syntax.thy \
+ Hoare_Parallel/OG_Tactics.thy Hoare_Parallel/OG_Tran.thy \
+ Hoare_Parallel/Quote_Antiquote.thy Hoare_Parallel/RG_Com.thy \
+ Hoare_Parallel/RG_Examples.thy Hoare_Parallel/RG_Hoare.thy \
+ Hoare_Parallel/RG_Syntax.thy Hoare_Parallel/RG_Tran.thy \
+ Hoare_Parallel/ROOT.ML Hoare_Parallel/document/root.tex \
+ Hoare_Parallel/document/root.bib
+ @$(ISABELLE_TOOL) usedir -g true $(OUT)/HOL Hoare_Parallel
## HOL-MetisExamples
@@ -617,6 +619,10 @@
HOL-Auth: HOL $(LOG)/HOL-Auth.gz
$(LOG)/HOL-Auth.gz: $(OUT)/HOL \
+ Auth/Auth_Shared.thy Auth/Auth_Public.thy Auth/All_Symmetric.thy \
+ Auth/Guard/Auth_Guard_Shared.thy \
+ Auth/Guard/Auth_Guard_Public.thy \
+ Auth/Smartcard/Auth_Smartcard.thy Auth/All_Symmetric.thy \
Auth/CertifiedEmail.thy Auth/Event.thy Auth/Message.thy \
Auth/NS_Public.thy Auth/NS_Public_Bad.thy Auth/NS_Shared.thy \
Auth/OtwayRees.thy Auth/OtwayReesBella.thy Auth/OtwayRees_AN.thy \
@@ -641,7 +647,7 @@
HOL-UNITY: HOL $(LOG)/HOL-UNITY.gz
$(LOG)/HOL-UNITY.gz: $(OUT)/HOL Library/Multiset.thy UNITY/ROOT.ML \
- UNITY/UNITY_Main.thy UNITY/UNITY_tactics.ML UNITY/Comp.thy \
+ UNITY/UNITY_Main.thy UNITY/UNITY_Examples.thy UNITY/UNITY_tactics.ML UNITY/Comp.thy \
UNITY/Constrains.thy UNITY/Detects.thy UNITY/ELT.thy \
UNITY/Extend.thy UNITY/FP.thy UNITY/Follows.thy UNITY/Guar.thy \
UNITY/Lift_prog.thy UNITY/ListOrder.thy UNITY/ProgressSets.thy \
@@ -830,7 +836,7 @@
HOL-Bali: HOL $(LOG)/HOL-Bali.gz
-$(LOG)/HOL-Bali.gz: $(OUT)/HOL Bali/AxCompl.thy Bali/AxExample.thy \
+$(LOG)/HOL-Bali.gz: $(OUT)/HOL Bali/Bali.thy Bali/AxCompl.thy Bali/AxExample.thy \
Bali/AxSem.thy Bali/AxSound.thy Bali/Basis.thy Bali/Conform.thy \
Bali/Decl.thy Bali/DeclConcepts.thy Bali/Eval.thy Bali/Evaln.thy \
Bali/Example.thy Bali/Name.thy Bali/ROOT.ML Bali/State.thy \
@@ -1020,6 +1026,7 @@
HOL-Nominal-Examples: HOL-Nominal $(LOG)/HOL-Nominal-Examples.gz
$(LOG)/HOL-Nominal-Examples.gz: $(OUT)/HOL-Nominal \
+ Nominal/Examples/Nominal_Examples.thy \
Nominal/Examples/CK_Machine.thy \
Nominal/Examples/CR.thy \
Nominal/Examples/CR_Takahashi.thy \
@@ -1134,6 +1141,19 @@
@$(ISABELLE_TOOL) usedir $(OUT)/HOL Mirabelle
+## HOL-SMT
+
+HOL-SMT: HOL-Word $(LOG)/HOL-SMT.gz
+
+$(LOG)/HOL-SMT.gz: $(OUT)/HOL-Word SMT/SMT_Definitions.thy SMT/SMT.thy \
+ SMT/Tools/smt_normalize.ML SMT/Tools/smt_monomorph.ML \
+ SMT/Tools/smt_translate.ML SMT/Tools/smt_builtin.ML \
+ SMT/Tools/smtlib_interface.ML SMT/Tools/smt_solver.ML \
+ SMT/Tools/cvc3_solver.ML SMT/Tools/yices_solver.ML \
+ SMT/Tools/z3_interface.ML SMT/Tools/z3_solver.ML SMT/Tools/z3_model.ML
+ @cd SMT; $(ISABELLE_TOOL) usedir -b -g true $(OUT)/HOL-Word HOL-SMT
+
+
## clean
clean:
@@ -1143,7 +1163,7 @@
$(LOG)/HOL-Induct.gz $(LOG)/HOL-ex.gz \
$(LOG)/HOL-Subst.gz $(LOG)/HOL-IMP.gz \
$(LOG)/HOL-IMPP.gz $(LOG)/HOL-Hoare.gz \
- $(LOG)/HOL-HoareParallel.gz $(LOG)/HOL-Lex.gz \
+ $(LOG)/HOL-Hoare_Parallel.gz $(LOG)/HOL-Lex.gz \
$(LOG)/HOL-Algebra.gz $(LOG)/HOL-Auth.gz \
$(LOG)/HOL-UNITY.gz $(LOG)/HOL-Modelcheck.gz \
$(LOG)/HOL-Lambda.gz $(LOG)/HOL-Bali.gz \
@@ -1156,4 +1176,4 @@
$(LOG)/HOL-Unix.gz $(OUT)/HOL-Word $(LOG)/HOL-Word.gz \
$(LOG)/HOL-Word-Examples.gz $(OUT)/HOL-NSA \
$(LOG)/HOL-NSA.gz $(LOG)/HOL-NSA-Examples.gz \
- $(LOG)/HOL-Mirabelle.gz
+ $(LOG)/HOL-Mirabelle.gz $(LOG)/HOL-SMT.gz
--- a/src/HOL/Lambda/Eta.thy Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Lambda/Eta.thy Tue Sep 22 13:52:19 2009 +1000
@@ -1,5 +1,4 @@
(* Title: HOL/Lambda/Eta.thy
- ID: $Id$
Author: Tobias Nipkow and Stefan Berghofer
Copyright 1995, 2005 TU Muenchen
*)
@@ -87,7 +86,6 @@
lemma square_eta: "square eta eta (eta^==) (eta^==)"
apply (unfold square_def id_def)
apply (rule impI [THEN allI [THEN allI]])
- apply simp
apply (erule eta.induct)
apply (slowsimp intro: subst_not_free eta_subst free_eta [THEN iffD1])
apply safe
--- a/src/HOL/Library/Executable_Set.thy Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Library/Executable_Set.thy Tue Sep 22 13:52:19 2009 +1000
@@ -32,8 +32,8 @@
declare inter [code]
-declare Inter_image_eq [symmetric, code]
-declare Union_image_eq [symmetric, code]
+declare Inter_image_eq [symmetric, code_unfold]
+declare Union_image_eq [symmetric, code_unfold]
declare List_Set.project_def [symmetric, code_unfold]
--- a/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Mirabelle/Tools/mirabelle_sledgehammer.ML Tue Sep 22 13:52:19 2009 +1000
@@ -38,9 +38,9 @@
}
datatype min_data = MinData of {
- calls: int,
- ratios: int,
- lemmas: int
+ succs: int,
+ ab_ratios: int,
+ it_ratios: int
}
(* The first me_data component is only used if "minimize" is on.
@@ -52,8 +52,8 @@
ShData{calls=calls, success=success, lemmas=lemmas, time_isa=time_isa,
time_atp=time_atp, time_atp_fail=time_atp_fail}
-fun make_min_data (calls, ratios, lemmas) =
- MinData{calls=calls, ratios=ratios, lemmas=lemmas}
+fun make_min_data (succs, ab_ratios, it_ratios) =
+ MinData{succs=succs, ab_ratios=ab_ratios, it_ratios=it_ratios}
fun make_me_data (calls, success, time, timeout, lemmas, posns) =
MeData{calls=calls, success=success, time=time, timeout=timeout, lemmas=lemmas, posns=posns}
@@ -61,7 +61,7 @@
val empty_data =
Data(make_sh_data (0, 0, 0, 0, 0, 0),
make_me_data(0, 0, 0, 0, 0, []),
- MinData{calls=0, ratios=0, lemmas=0},
+ MinData{succs=0, ab_ratios=0, it_ratios=0},
make_me_data(0, 0, 0, 0, 0, []))
fun map_sh_data f
@@ -70,8 +70,8 @@
meda0, minda, meda)
fun map_min_data f
- (Data(shda, meda0, MinData{calls,ratios,lemmas}, meda)) =
- Data(shda, meda0, make_min_data(f(calls,ratios,lemmas)), meda)
+ (Data(shda, meda0, MinData{succs,ab_ratios,it_ratios}, meda)) =
+ Data(shda, meda0, make_min_data(f(succs,ab_ratios,it_ratios)), meda)
fun map_me_data0 f (Data (shda, MeData{calls,success,time,timeout,lemmas,posns}, minda, meda)) =
Data(shda, make_me_data(f (calls,success,time,timeout,lemmas,posns)), minda, meda)
@@ -103,11 +103,14 @@
map_sh_data (fn (calls, success, lemmas, time_isa, time_atp, time_atp_fail)
=> (calls, success, lemmas, time_isa, time_atp, time_atp_fail + t))
-val inc_min_calls =
- map_min_data (fn (calls, ratios, lemmas) => (calls + 1, ratios, lemmas))
+val inc_min_succs =
+ map_min_data (fn (succs,ab_ratios,it_ratios) => (succs+1, ab_ratios, it_ratios))
-fun inc_min_ratios n =
- map_min_data (fn (calls, ratios, lemmas) => (calls, ratios + n, lemmas))
+fun inc_min_ab_ratios r =
+ map_min_data (fn (succs, ab_ratios, it_ratios) => (succs, ab_ratios+r, it_ratios))
+
+fun inc_min_it_ratios r =
+ map_min_data (fn (succs, ab_ratios, it_ratios) => (succs, ab_ratios, it_ratios+r))
val inc_metis_calls = map_me_data
(fn (calls, success, time, timeout, lemmas,posns)
@@ -192,8 +195,6 @@
(log ("Total number of " ^ tag ^ "metis calls: " ^ str metis_calls);
log ("Number of successful " ^ tag ^ "metis calls: " ^ str metis_success);
log ("Number of " ^ tag ^ "metis timeouts: " ^ str metis_timeout);
- log ("Number of " ^ tag ^ "metis exceptions: " ^
- str (sh_success - metis_success - metis_timeout));
log ("Success rate: " ^ percentage metis_success sh_calls ^ "%");
log ("Number of successful " ^ tag ^ "metis lemmas: " ^ str metis_lemmas);
log ("Total time for successful metis calls: " ^ str3 (time metis_time));
@@ -204,9 +205,10 @@
else ()
)
-fun log_min_data log calls ratios =
- (log ("Number of minimizations: " ^ string_of_int calls);
- log ("Minimization ratios: " ^ string_of_int ratios)
+fun log_min_data log succs ab_ratios it_ratios =
+ (log ("Number of successful minimizations: " ^ string_of_int succs);
+ log ("After/before ratios: " ^ string_of_int ab_ratios);
+ log ("Iterations ratios: " ^ string_of_int it_ratios)
)
in
@@ -217,7 +219,7 @@
MeData{calls=metis_calls0,
success=metis_success0, time=metis_time0, timeout=metis_timeout0,
lemmas=metis_lemmas0,posns=metis_posns0},
- MinData{calls=min_calls, ratios=min_ratios, lemmas=min_lemmas},
+ MinData{succs=min_succs, ab_ratios=ab_ratios, it_ratios=it_ratios},
MeData{calls=metis_calls,
success=metis_success, time=metis_time, timeout=metis_timeout,
lemmas=metis_lemmas,posns=metis_posns})) =
@@ -230,7 +232,7 @@
metis_success metis_time metis_timeout metis_lemmas metis_posns else ();
log "";
if metis_calls0 > 0
- then (log_min_data log min_calls min_ratios; log "";
+ then (log_min_data log min_succs ab_ratios it_ratios; log "";
log_metis_data log "unminimized " sh_calls sh_success metis_calls0
metis_success0 metis_time0 metis_timeout0 metis_lemmas0 metis_posns0)
else ()
@@ -362,8 +364,9 @@
in
case minimize timeout st (these (!named_thms)) of
(SOME (named_thms',its), msg) =>
- (change_data id inc_min_calls;
- change_data id (inc_min_ratios ((100*its) div n0));
+ (change_data id inc_min_succs;
+ change_data id (inc_min_ab_ratios ((100 * length named_thms') div n0));
+ change_data id (inc_min_it_ratios ((100*its) div n0));
if length named_thms' = n0
then log (minimize_tag id ^ "already minimal")
else (named_thms := SOME named_thms';
@@ -398,27 +401,29 @@
|> log o prefix (metis_tag id)
end
-fun sledgehammer_action args id (st as {log, ...}: Mirabelle.run_args) =
+fun sledgehammer_action args id (st as {log, pre, ...}: Mirabelle.run_args) =
+ if can Logic.dest_conjunction (Thm.major_prem_of(snd(snd(Proof.get_goal pre))))
+ then () else
let
val metis_fns = (inc_metis_calls, inc_metis_success, inc_metis_time,
inc_metis_timeout, inc_metis_lemmas, inc_metis_posns)
val metis0_fns = (inc_metis_calls0, inc_metis_success0, inc_metis_time0,
inc_metis_timeout0, inc_metis_lemmas0, inc_metis_posns0)
val named_thms = ref (NONE : (string * thm list) list option)
-
- fun if_enabled k f =
- if AList.defined (op =) args k andalso is_some (!named_thms)
- then f id st else ()
-
- val _ = Mirabelle.catch sh_tag (run_sledgehammer args named_thms) id st
- val _ = if_enabled minimizeK
- (Mirabelle.catch metis_tag (run_metis metis0_fns args (these (!named_thms))))
- val _ = if_enabled minimizeK
- (Mirabelle.catch minimize_tag (run_minimize args named_thms))
- val _ = if is_some (!named_thms)
- then Mirabelle.catch metis_tag (run_metis metis_fns args (these (!named_thms))) id st
- else ()
- in () end
+ val minimize = AList.defined (op =) args minimizeK
+ in
+ Mirabelle.catch sh_tag (run_sledgehammer args named_thms) id st;
+ if is_some (!named_thms)
+ then
+ (if minimize
+ then Mirabelle.catch metis_tag (run_metis metis0_fns args (these (!named_thms))) id st
+ else ();
+ if minimize andalso not(null(these(!named_thms)))
+ then Mirabelle.catch minimize_tag (run_minimize args named_thms) id st
+ else ();
+ Mirabelle.catch metis_tag (run_metis metis_fns args (these (!named_thms))) id st)
+ else ()
+ end
fun invoke args =
let
--- a/src/HOL/Nominal/Examples/Crary.thy Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Nominal/Examples/Crary.thy Tue Sep 22 13:52:19 2009 +1000
@@ -408,20 +408,7 @@
declare trm.inject[simp del]
-lemma whn_eqvt[eqvt]:
- fixes pi::"name prm"
- assumes a: "t \<Down> t'"
- shows "(pi\<bullet>t) \<Down> (pi\<bullet>t')"
-using a
-apply(induct)
-apply(rule QAN_Reduce)
-apply(rule whr_def.eqvt)
-apply(assumption)+
-apply(rule QAN_Normal)
-apply(auto)
-apply(drule_tac pi="rev pi" in whr_def.eqvt)
-apply(perm_simp)
-done
+equivariance whn_def
lemma red_unicity :
assumes a: "x \<leadsto> a"
@@ -631,6 +618,7 @@
apply (force)
apply (rule ty_cases)
done
+
termination by lexicographic_order
lemma logical_monotonicity:
@@ -968,7 +956,7 @@
then show "\<Gamma> \<turnstile> s \<Leftrightarrow> t : T" using main_lemma(1) val by simp
qed
-text {* We leave soundness as an exercise - like in the book :-) \\
+text {* We leave soundness as an exercise - just like Crary in the ATS book :-) \\
@{prop[mode=IfThen] "\<lbrakk>\<Gamma> \<turnstile> s \<Leftrightarrow> t : T; \<Gamma> \<turnstile> t : T; \<Gamma> \<turnstile> s : T\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s \<equiv> t : T"} \\
@{prop "\<lbrakk>\<Gamma> \<turnstile> s \<leftrightarrow> t : T; \<Gamma> \<turnstile> t : T; \<Gamma> \<turnstile> s : T\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> s \<equiv> t : T"}
*}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/Nominal/Examples/Nominal_Examples.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,25 @@
+(* Author: Christian Urban TU Muenchen *)
+
+header {* Various examples involving nominal datatypes. *}
+
+theory Nominal_Examples
+imports
+ CR
+ CR_Takahashi
+ Class
+ Compile
+ Fsub
+ Height
+ Lambda_mu
+ SN
+ Weakening
+ Crary
+ SOS
+ LocalWeakening
+ Support
+ Contexts
+ Standardization
+ W
+begin
+
+end
--- a/src/HOL/Nominal/Examples/ROOT.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Nominal/Examples/ROOT.ML Tue Sep 22 13:52:19 2009 +1000
@@ -1,27 +1,4 @@
-(* Title: HOL/Nominal/Examples/ROOT.ML
- ID: $Id$
- Author: Christian Urban, TU Muenchen
-
-Various examples involving nominal datatypes.
-*)
-use_thys [
- "CR",
- "CR_Takahashi",
- "Class",
- "Compile",
- "Fsub",
- "Height",
- "Lambda_mu",
- "SN",
- "Weakening",
- "Crary",
- "SOS",
- "LocalWeakening",
- "Support",
- "Contexts",
- "Standardization",
- "W"
-];
+use_thy "Nominal_Examples";
-setmp_noncritical quick_and_dirty true use_thy "VC_Condition";
+setmp_noncritical quick_and_dirty true use_thy "VC_Condition"; (*FIXME*)
--- a/src/HOL/Nominal/Nominal.thy Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Nominal/Nominal.thy Tue Sep 22 13:52:19 2009 +1000
@@ -2623,74 +2623,77 @@
avoiding a finitely supported c and there is a permutation
which 'translates' between both sets.
*}
+
lemma at_set_avoiding_aux:
fixes Xs::"'a set"
and As::"'a set"
assumes at: "at TYPE('a)"
- and a: "finite Xs"
and b: "Xs \<subseteq> As"
and c: "finite As"
and d: "finite ((supp c)::'a set)"
- shows "\<exists>(Ys::'a set) (pi::'a prm). Ys\<sharp>*c \<and> Ys \<inter> As = {} \<and> (pi\<bullet>Xs=Ys) \<and>
- set pi \<subseteq> Xs \<times> Ys \<and> finite Ys"
-using a b c
-proof (induct)
- case empty
- have "({}::'a set)\<sharp>*c" by (simp add: fresh_star_def)
- moreover
- have "({}::'a set) \<inter> As = {}" by simp
- moreover
- have "([]::'a prm)\<bullet>{} = ({}::'a set)"
- by (rule pt1[OF pt_fun_inst, OF at_pt_inst[OF at], OF pt_bool_inst, OF at])
- moreover
- have "set ([]::'a prm) \<subseteq> {} \<times> {}" by simp
- moreover
- have "finite ({}::'a set)" by simp
- ultimately show ?case by blast
-next
- case (insert x Xs)
- then have ih: "\<exists>Ys pi. Ys\<sharp>*c \<and> Ys \<inter> As = {} \<and> pi\<bullet>Xs = Ys \<and> set pi \<subseteq> Xs \<times> Ys \<and> finite Ys" by simp
- then obtain Ys pi where a1: "Ys\<sharp>*c" and a2: "Ys \<inter> As = {}" and a3: "pi\<bullet>Xs = Ys" and
- a4: "set pi \<subseteq> Xs \<times> Ys" and a5: "finite Ys" by blast
- have b: "x\<notin>Xs" by fact
- have d1: "finite As" by fact
- have d2: "finite Xs" by fact
- have d3: "insert x Xs \<subseteq> As" by fact
- have "\<exists>y::'a. y\<sharp>(c,x,Ys,As)" using d d1 a5
- by (rule_tac at_exists_fresh'[OF at])
- (simp add: supp_prod at_supp[OF at] at_fin_set_supp[OF at])
- then obtain y::"'a" where e: "y\<sharp>(c,x,Ys,As)" by blast
- have "({y}\<union>Ys)\<sharp>*c" using a1 e by (simp add: fresh_star_def)
- moreover
- have "({y}\<union>Ys)\<inter>As = {}" using a2 d1 e by (simp add: fresh_prod at_fin_set_fresh[OF at])
- moreover
- have "(((pi\<bullet>x,y)#pi)\<bullet>(insert x Xs)) = {y}\<union>Ys"
- proof -
- have eq: "[(pi\<bullet>x,y)]\<bullet>Ys = Ys"
+ shows "\<exists>(pi::'a prm). (pi\<bullet>Xs)\<sharp>*c \<and> (pi\<bullet>Xs) \<inter> As = {} \<and> set pi \<subseteq> Xs \<times> (pi\<bullet>Xs)"
+proof -
+ from b c have "finite Xs" by (simp add: finite_subset)
+ then show ?thesis using b
+ proof (induct)
+ case empty
+ have "({}::'a set)\<sharp>*c" by (simp add: fresh_star_def)
+ moreover
+ have "({}::'a set) \<inter> As = {}" by simp
+ moreover
+ have "set ([]::'a prm) \<subseteq> {} \<times> {}" by simp
+ moreover
+ have "([]::'a prm)\<bullet>{} = ({}::'a set)"
+ by (rule pt1[OF pt_fun_inst, OF at_pt_inst[OF at] pt_bool_inst at])
+ ultimately show ?case by simp
+ next
+ case (insert x Xs)
+ then have ih: "\<exists>pi. (pi\<bullet>Xs)\<sharp>*c \<and> (pi\<bullet>Xs) \<inter> As = {} \<and> set pi \<subseteq> Xs \<times> (pi\<bullet>Xs)" by simp
+ then obtain pi where a1: "(pi\<bullet>Xs)\<sharp>*c" and a2: "(pi\<bullet>Xs) \<inter> As = {}" and
+ a4: "set pi \<subseteq> Xs \<times> (pi\<bullet>Xs)" by blast
+ have b: "x\<notin>Xs" by fact
+ have d1: "finite As" by fact
+ have d2: "finite Xs" by fact
+ have d3: "({x} \<union> Xs) \<subseteq> As" using insert(4) by simp
+ from d d1 d2
+ obtain y::"'a" where fr: "y\<sharp>(c,pi\<bullet>Xs,As)"
+ apply(rule_tac at_exists_fresh[OF at, where x="(c,pi\<bullet>Xs,As)"])
+ apply(auto simp add: supp_prod at_supp[OF at] at_fin_set_supp[OF at]
+ pt_supp_finite_pi[OF pt_fun_inst[OF at_pt_inst[OF at] pt_bool_inst at] at])
+ done
+ have "({y}\<union>(pi\<bullet>Xs))\<sharp>*c" using a1 fr by (simp add: fresh_star_def)
+ moreover
+ have "({y}\<union>(pi\<bullet>Xs))\<inter>As = {}" using a2 d1 fr
+ by (simp add: fresh_prod at_fin_set_fresh[OF at])
+ moreover
+ have "pi\<bullet>x=x" using a4 b a2 d3
+ by (rule_tac at_prm_fresh2[OF at]) (auto)
+ then have "set ((pi\<bullet>x,y)#pi) \<subseteq> ({x} \<union> Xs) \<times> ({y}\<union>(pi\<bullet>Xs))" using a4 by auto
+ moreover
+ have "(((pi\<bullet>x,y)#pi)\<bullet>({x} \<union> Xs)) = {y}\<union>(pi\<bullet>Xs)"
proof -
- have "(pi\<bullet>x)\<sharp>Ys" using a3[symmetric] b d2
- by(simp add: pt_fresh_bij[OF pt_fun_inst, OF at_pt_inst[OF at], OF pt_bool_inst, OF at, OF at]
- at_fin_set_fresh[OF at])
- moreover
- have "y\<sharp>Ys" using e by simp
- ultimately show "[(pi\<bullet>x,y)]\<bullet>Ys = Ys"
- by (simp add: pt_fresh_fresh[OF pt_fun_inst, OF at_pt_inst[OF at], OF pt_bool_inst, OF at, OF at])
+ have eq: "[(pi\<bullet>x,y)]\<bullet>(pi\<bullet>Xs) = (pi\<bullet>Xs)"
+ proof -
+ have "(pi\<bullet>x)\<sharp>(pi\<bullet>Xs)" using b d2
+ by(simp add: pt_fresh_bij[OF pt_fun_inst, OF at_pt_inst[OF at],
+ OF pt_bool_inst, OF at, OF at]
+ at_fin_set_fresh[OF at])
+ moreover
+ have "y\<sharp>(pi\<bullet>Xs)" using fr by simp
+ ultimately show "[(pi\<bullet>x,y)]\<bullet>(pi\<bullet>Xs) = (pi\<bullet>Xs)"
+ by (simp add: pt_fresh_fresh[OF pt_fun_inst,
+ OF at_pt_inst[OF at], OF pt_bool_inst, OF at, OF at])
+ qed
+ have "(((pi\<bullet>x,y)#pi)\<bullet>({x}\<union>Xs)) = ([(pi\<bullet>x,y)]\<bullet>(pi\<bullet>({x}\<union>Xs)))"
+ by (simp add: pt2[symmetric, OF pt_fun_inst, OF at_pt_inst[OF at],
+ OF pt_bool_inst, OF at])
+ also have "\<dots> = {y}\<union>([(pi\<bullet>x,y)]\<bullet>(pi\<bullet>Xs))"
+ by (simp only: union_eqvt perm_set_eq[OF at_pt_inst[OF at], OF at] at_calc[OF at])(auto)
+ finally show "(((pi\<bullet>x,y)#pi)\<bullet>({x} \<union> Xs)) = {y}\<union>(pi\<bullet>Xs)" using eq by simp
qed
- have "(((pi\<bullet>x,y)#pi)\<bullet>({x}\<union>Xs)) = ([(pi\<bullet>x,y)]\<bullet>(pi\<bullet>({x}\<union>Xs)))"
- by (simp add: pt2[symmetric, OF pt_fun_inst, OF at_pt_inst[OF at], OF pt_bool_inst, OF at])
- also have "\<dots> = {y}\<union>([(pi\<bullet>x,y)]\<bullet>(pi\<bullet>Xs))"
- by (simp only: union_eqvt perm_set_eq[OF at_pt_inst[OF at], OF at] at_calc[OF at])(auto)
- also have "\<dots> = {y}\<union>([(pi\<bullet>x,y)]\<bullet>Ys)" using a3 by simp
- also have "\<dots> = {y}\<union>Ys" using eq by simp
- finally show "(((pi\<bullet>x,y)#pi)\<bullet>(insert x Xs)) = {y}\<union>Ys" by auto
+ ultimately
+ show ?case by (rule_tac x="(pi\<bullet>x,y)#pi" in exI) (auto)
qed
- moreover
- have "pi\<bullet>x=x" using a4 b a2 a3 d3 by (rule_tac at_prm_fresh2[OF at]) (auto)
- then have "set ((pi\<bullet>x,y)#pi) \<subseteq> (insert x Xs) \<times> ({y}\<union>Ys)" using a4 by auto
- moreover
- have "finite ({y}\<union>Ys)" using a5 by simp
- ultimately
- show ?case by blast
qed
lemma at_set_avoiding:
@@ -2698,10 +2701,10 @@
assumes at: "at TYPE('a)"
and a: "finite Xs"
and b: "finite ((supp c)::'a set)"
- obtains pi::"'a prm" where "(pi \<bullet> Xs) \<sharp>* c" and "set pi \<subseteq> Xs \<times> (pi \<bullet> Xs)"
- using a b
- by (frule_tac As="Xs" in at_set_avoiding_aux[OF at]) auto
-
+ obtains pi::"'a prm" where "(pi\<bullet>Xs)\<sharp>*c" and "set pi \<subseteq> Xs \<times> (pi\<bullet>Xs)"
+using a b at_set_avoiding_aux[OF at, where Xs="Xs" and As="Xs" and c="c"]
+by (blast)
+
section {* composition instances *}
(* ============================= *)
--- a/src/HOL/Predicate.thy Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Predicate.thy Tue Sep 22 13:52:19 2009 +1000
@@ -75,29 +75,29 @@
subsubsection {* Binary union *}
-lemma sup1_iff [simp]: "sup A B x \<longleftrightarrow> A x | B x"
+lemma sup1_iff: "sup A B x \<longleftrightarrow> A x | B x"
by (simp add: sup_fun_eq sup_bool_eq)
-lemma sup2_iff [simp]: "sup A B x y \<longleftrightarrow> A x y | B x y"
+lemma sup2_iff: "sup A B x y \<longleftrightarrow> A x y | B x y"
by (simp add: sup_fun_eq sup_bool_eq)
lemma sup_Un_eq [pred_set_conv]: "sup (\<lambda>x. x \<in> R) (\<lambda>x. x \<in> S) = (\<lambda>x. x \<in> R \<union> S)"
- by (simp add: expand_fun_eq)
+ by (simp add: sup1_iff expand_fun_eq)
lemma sup_Un_eq2 [pred_set_conv]: "sup (\<lambda>x y. (x, y) \<in> R) (\<lambda>x y. (x, y) \<in> S) = (\<lambda>x y. (x, y) \<in> R \<union> S)"
- by (simp add: expand_fun_eq)
+ by (simp add: sup2_iff expand_fun_eq)
lemma sup1I1 [elim?]: "A x \<Longrightarrow> sup A B x"
- by simp
+ by (simp add: sup1_iff)
lemma sup2I1 [elim?]: "A x y \<Longrightarrow> sup A B x y"
- by simp
+ by (simp add: sup2_iff)
lemma sup1I2 [elim?]: "B x \<Longrightarrow> sup A B x"
- by simp
+ by (simp add: sup1_iff)
lemma sup2I2 [elim?]: "B x y \<Longrightarrow> sup A B x y"
- by simp
+ by (simp add: sup2_iff)
text {*
\medskip Classical introduction rule: no commitment to @{text A} vs
@@ -105,115 +105,115 @@
*}
lemma sup1CI [intro!]: "(~ B x ==> A x) ==> sup A B x"
- by auto
+ by (auto simp add: sup1_iff)
lemma sup2CI [intro!]: "(~ B x y ==> A x y) ==> sup A B x y"
- by auto
+ by (auto simp add: sup2_iff)
lemma sup1E [elim!]: "sup A B x ==> (A x ==> P) ==> (B x ==> P) ==> P"
- by simp iprover
+ by (simp add: sup1_iff) iprover
lemma sup2E [elim!]: "sup A B x y ==> (A x y ==> P) ==> (B x y ==> P) ==> P"
- by simp iprover
+ by (simp add: sup2_iff) iprover
subsubsection {* Binary intersection *}
-lemma inf1_iff [simp]: "inf A B x \<longleftrightarrow> A x \<and> B x"
+lemma inf1_iff: "inf A B x \<longleftrightarrow> A x \<and> B x"
by (simp add: inf_fun_eq inf_bool_eq)
-lemma inf2_iff [simp]: "inf A B x y \<longleftrightarrow> A x y \<and> B x y"
+lemma inf2_iff: "inf A B x y \<longleftrightarrow> A x y \<and> B x y"
by (simp add: inf_fun_eq inf_bool_eq)
lemma inf_Int_eq [pred_set_conv]: "inf (\<lambda>x. x \<in> R) (\<lambda>x. x \<in> S) = (\<lambda>x. x \<in> R \<inter> S)"
- by (simp add: expand_fun_eq)
+ by (simp add: inf1_iff expand_fun_eq)
lemma inf_Int_eq2 [pred_set_conv]: "inf (\<lambda>x y. (x, y) \<in> R) (\<lambda>x y. (x, y) \<in> S) = (\<lambda>x y. (x, y) \<in> R \<inter> S)"
- by (simp add: expand_fun_eq)
+ by (simp add: inf2_iff expand_fun_eq)
lemma inf1I [intro!]: "A x ==> B x ==> inf A B x"
- by simp
+ by (simp add: inf1_iff)
lemma inf2I [intro!]: "A x y ==> B x y ==> inf A B x y"
- by simp
+ by (simp add: inf2_iff)
lemma inf1D1: "inf A B x ==> A x"
- by simp
+ by (simp add: inf1_iff)
lemma inf2D1: "inf A B x y ==> A x y"
- by simp
+ by (simp add: inf2_iff)
lemma inf1D2: "inf A B x ==> B x"
- by simp
+ by (simp add: inf1_iff)
lemma inf2D2: "inf A B x y ==> B x y"
- by simp
+ by (simp add: inf2_iff)
lemma inf1E [elim!]: "inf A B x ==> (A x ==> B x ==> P) ==> P"
- by simp
+ by (simp add: inf1_iff)
lemma inf2E [elim!]: "inf A B x y ==> (A x y ==> B x y ==> P) ==> P"
- by simp
+ by (simp add: inf2_iff)
subsubsection {* Unions of families *}
-lemma SUP1_iff [simp]: "(SUP x:A. B x) b = (EX x:A. B x b)"
+lemma SUP1_iff: "(SUP x:A. B x) b = (EX x:A. B x b)"
by (simp add: SUPR_def Sup_fun_def Sup_bool_def) blast
-lemma SUP2_iff [simp]: "(SUP x:A. B x) b c = (EX x:A. B x b c)"
+lemma SUP2_iff: "(SUP x:A. B x) b c = (EX x:A. B x b c)"
by (simp add: SUPR_def Sup_fun_def Sup_bool_def) blast
lemma SUP1_I [intro]: "a : A ==> B a b ==> (SUP x:A. B x) b"
- by auto
+ by (auto simp add: SUP1_iff)
lemma SUP2_I [intro]: "a : A ==> B a b c ==> (SUP x:A. B x) b c"
- by auto
+ by (auto simp add: SUP2_iff)
lemma SUP1_E [elim!]: "(SUP x:A. B x) b ==> (!!x. x : A ==> B x b ==> R) ==> R"
- by auto
+ by (auto simp add: SUP1_iff)
lemma SUP2_E [elim!]: "(SUP x:A. B x) b c ==> (!!x. x : A ==> B x b c ==> R) ==> R"
- by auto
+ by (auto simp add: SUP2_iff)
lemma SUP_UN_eq: "(SUP i. (\<lambda>x. x \<in> r i)) = (\<lambda>x. x \<in> (UN i. r i))"
- by (simp add: expand_fun_eq)
+ by (simp add: SUP1_iff expand_fun_eq)
lemma SUP_UN_eq2: "(SUP i. (\<lambda>x y. (x, y) \<in> r i)) = (\<lambda>x y. (x, y) \<in> (UN i. r i))"
- by (simp add: expand_fun_eq)
+ by (simp add: SUP2_iff expand_fun_eq)
subsubsection {* Intersections of families *}
-lemma INF1_iff [simp]: "(INF x:A. B x) b = (ALL x:A. B x b)"
+lemma INF1_iff: "(INF x:A. B x) b = (ALL x:A. B x b)"
by (simp add: INFI_def Inf_fun_def Inf_bool_def) blast
-lemma INF2_iff [simp]: "(INF x:A. B x) b c = (ALL x:A. B x b c)"
+lemma INF2_iff: "(INF x:A. B x) b c = (ALL x:A. B x b c)"
by (simp add: INFI_def Inf_fun_def Inf_bool_def) blast
lemma INF1_I [intro!]: "(!!x. x : A ==> B x b) ==> (INF x:A. B x) b"
- by auto
+ by (auto simp add: INF1_iff)
lemma INF2_I [intro!]: "(!!x. x : A ==> B x b c) ==> (INF x:A. B x) b c"
- by auto
+ by (auto simp add: INF2_iff)
lemma INF1_D [elim]: "(INF x:A. B x) b ==> a : A ==> B a b"
- by auto
+ by (auto simp add: INF1_iff)
lemma INF2_D [elim]: "(INF x:A. B x) b c ==> a : A ==> B a b c"
- by auto
+ by (auto simp add: INF2_iff)
lemma INF1_E [elim]: "(INF x:A. B x) b ==> (B a b ==> R) ==> (a ~: A ==> R) ==> R"
- by auto
+ by (auto simp add: INF1_iff)
lemma INF2_E [elim]: "(INF x:A. B x) b c ==> (B a b c ==> R) ==> (a ~: A ==> R) ==> R"
- by auto
+ by (auto simp add: INF2_iff)
lemma INF_INT_eq: "(INF i. (\<lambda>x. x \<in> r i)) = (\<lambda>x. x \<in> (INT i. r i))"
- by (simp add: expand_fun_eq)
+ by (simp add: INF1_iff expand_fun_eq)
lemma INF_INT_eq2: "(INF i. (\<lambda>x y. (x, y) \<in> r i)) = (\<lambda>x y. (x, y) \<in> (INT i. r i))"
- by (simp add: expand_fun_eq)
+ by (simp add: INF2_iff expand_fun_eq)
subsection {* Predicates as relations *}
@@ -429,7 +429,7 @@
by (auto simp add: bind_def sup_pred_def expand_fun_eq)
lemma Sup_bind: "(\<Squnion>A \<guillemotright>= f) = \<Squnion>((\<lambda>x. x \<guillemotright>= f) ` A)"
- by (auto simp add: bind_def Sup_pred_def expand_fun_eq)
+ by (auto simp add: bind_def Sup_pred_def SUP1_iff expand_fun_eq)
lemma pred_iffI:
assumes "\<And>x. eval A x \<Longrightarrow> eval B x"
@@ -462,10 +462,10 @@
unfolding bot_pred_def by auto
lemma supI1: "eval A x \<Longrightarrow> eval (A \<squnion> B) x"
- unfolding sup_pred_def by simp
+ unfolding sup_pred_def by (simp add: sup1_iff)
lemma supI2: "eval B x \<Longrightarrow> eval (A \<squnion> B) x"
- unfolding sup_pred_def by simp
+ unfolding sup_pred_def by (simp add: sup1_iff)
lemma supE: "eval (A \<squnion> B) x \<Longrightarrow> (eval A x \<Longrightarrow> P) \<Longrightarrow> (eval B x \<Longrightarrow> P) \<Longrightarrow> P"
unfolding sup_pred_def by auto
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Examples/SMT_Examples.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,183 @@
+(* Title: SMT_Examples.thy
+ Author: Sascha Boehme, TU Muenchen
+*)
+
+header {* Examples for the 'smt' tactic. *}
+
+theory SMT_Examples
+imports "../SMT"
+begin
+
+declare [[smt_solver=z3, z3_proofs=false]]
+declare [[smt_trace=false]]
+
+
+section {* Propositional and first-order logic *}
+
+lemma "True" by smt
+lemma "p \<or> \<not>p" by smt
+lemma "(p \<and> True) = p" by smt
+lemma "(p \<or> q) \<and> \<not>p \<Longrightarrow> q" by smt
+lemma "(a \<and> b) \<or> (c \<and> d) \<Longrightarrow> (a \<and> b) \<or> (c \<and> d)" by smt
+lemma "P=P=P=P=P=P=P=P=P=P" by smt
+
+axiomatization symm_f :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" where
+ symm_f: "symm_f x y = symm_f y x"
+lemma "a = a \<and> symm_f a b = symm_f b a" by (smt add: symm_f)
+
+
+section {* Linear arithmetic *}
+
+lemma "(3::int) = 3" by smt
+lemma "(3::real) = 3" by smt
+lemma "(3 :: int) + 1 = 4" by smt
+lemma "max (3::int) 8 > 5" by smt
+lemma "abs (x :: real) + abs y \<ge> abs (x + y)" by smt
+lemma "let x = (2 :: int) in x + x \<noteq> 5" by smt
+
+text{*
+The following example was taken from HOL/ex/PresburgerEx.thy, where it says:
+
+ This following theorem proves that all solutions to the
+ recurrence relation $x_{i+2} = |x_{i+1}| - x_i$ are periodic with
+ period 9. The example was brought to our attention by John
+ Harrison. It does does not require Presburger arithmetic but merely
+ quantifier-free linear arithmetic and holds for the rationals as well.
+
+ Warning: it takes (in 2006) over 4.2 minutes!
+
+There, it is proved by "arith". SMT is able to prove this within a fraction
+of one second.
+*}
+
+lemma "\<lbrakk> x3 = abs x2 - x1; x4 = abs x3 - x2; x5 = abs x4 - x3;
+ x6 = abs x5 - x4; x7 = abs x6 - x5; x8 = abs x7 - x6;
+ x9 = abs x8 - x7; x10 = abs x9 - x8; x11 = abs x10 - x9 \<rbrakk>
+ \<Longrightarrow> x1 = x10 & x2 = (x11::int)"
+ by smt
+
+lemma "\<exists>x::int. 0 < x" by smt
+lemma "\<exists>x::real. 0 < x" by smt
+lemma "\<forall>x y::int. x < y \<longrightarrow> (2 * x + 1) < (2 * y)" by smt
+lemma "\<forall>x y::int. (2 * x + 1) \<noteq> (2 * y)" by smt
+lemma "~ (\<exists>x y z::int. 4 * x + -6 * y = (1::int))" by smt
+lemma "~ (\<exists>x::int. False)" by smt
+
+
+section {* Non-linear arithmetic *}
+
+lemma "((x::int) * (1 + y) - x * (1 - y)) = (2 * x * y)" by smt
+lemma
+ "(U::int) + (1 + p) * (b + e) + p * d =
+ U + (2 * (1 + p) * (b + e) + (1 + p) * d + d * p) - (1 + p) * (b + d + e)"
+ by smt
+
+
+section {* Linear arithmetic for natural numbers *}
+
+lemma "a < 3 \<Longrightarrow> (7::nat) > 2 * a" by smt
+lemma "let x = (1::nat) + y in x - y > 0 * x" by smt
+lemma
+ "let x = (1::nat) + y in
+ let P = (if x > 0 then True else False) in
+ False \<or> P = (x - 1 = y) \<or> (\<not>P \<longrightarrow> False)"
+ by smt
+
+
+section {* Bitvectors *}
+
+locale bv
+begin
+
+declare [[smt_solver=z3]]
+
+lemma "(27 :: 4 word) = -5" by smt
+lemma "(27 :: 4 word) = 11" by smt
+lemma "23 < (27::8 word)" by smt
+lemma "27 + 11 = (6::5 word)" by smt
+lemma "7 * 3 = (21::8 word)" by smt
+lemma "11 - 27 = (-16::8 word)" by smt
+lemma "- -11 = (11::5 word)" by smt
+lemma "-40 + 1 = (-39::7 word)" by smt
+lemma "a + 2 * b + c - b = (b + c) + (a :: 32 word)" by smt
+
+lemma "0b110 AND 0b101 = (0b100 :: 32 word)" by smt
+lemma "0b110 OR 0b011 = (0b111 :: 8 word)" by smt
+lemma "0xF0 XOR 0xFF = (0x0F :: 8 word)" by smt
+lemma "NOT (0xF0 :: 16 word) = 0xFF0F" by smt
+
+lemma "word_cat (27::4 word) (27::8 word) = (2843::12 word)" by smt
+lemma "word_cat (0b0011::4 word) (0b1111::6word) = (0b0011001111 :: 10 word)"
+ by smt
+
+lemma "slice 1 (0b10110 :: 4 word) = (0b11 :: 2 word)" by smt
+
+lemma "ucast (0b1010 :: 4 word) = (0b1010 :: 10 word)" by smt
+lemma "scast (0b1010 :: 4 word) = (0b111010 :: 6 word)" by smt
+
+lemma "bv_lshr 0b10011 2 = (0b100::8 word)" by smt
+lemma "bv_ashr 0b10011 2 = (0b100::8 word)" by smt
+
+lemma "word_rotr 2 0b0110 = (0b1001::4 word)" by smt
+lemma "word_rotl 1 0b1110 = (0b1101::4 word)" by smt
+
+lemma "(x AND 0xff00) OR (x AND 0x00ff) = (x::16 word)" by smt
+
+lemma "w < 256 \<Longrightarrow> (w :: 16 word) AND 0x00FF = w" by smt
+
+end
+
+
+section {* Pairs *}
+
+lemma "fst (x, y) = a \<Longrightarrow> x = a" by smt
+lemma "p1 = (x, y) \<and> p2 = (y, x) \<Longrightarrow> fst p1 = snd p2" by smt
+
+
+section {* Higher-order problems and recursion *}
+
+lemma "(f g x = (g x \<and> True)) \<or> (f g x = True) \<or> (g x = True)" by smt
+lemma "P ((2::int) < 3) = P True" by smt
+lemma "P ((2::int) < 3) = (P True :: bool)" by smt
+lemma "P (0 \<le> (a :: 4 word)) = P True" using [[smt_solver=z3]] by smt
+lemma "id 3 = 3 \<and> id True = True" by (smt add: id_def)
+lemma "i \<noteq> i1 \<and> i \<noteq> i2 \<Longrightarrow> ((f (i1 := v1)) (i2 := v2)) i = f i" by smt
+lemma "map (\<lambda>i::nat. i + 1) [0, 1] = [1, 2]" by (smt add: map.simps)
+lemma "(ALL x. P x) | ~ All P" by smt
+
+fun dec_10 :: "nat \<Rightarrow> nat" where
+ "dec_10 n = (if n < 10 then n else dec_10 (n - 10))"
+lemma "dec_10 (4 * dec_10 4) = 6" by (smt add: dec_10.simps)
+
+axiomatization
+ eval_dioph :: "int list \<Rightarrow> nat list \<Rightarrow> int"
+ where
+ eval_dioph_mod:
+ "eval_dioph ks xs mod int n = eval_dioph ks (map (\<lambda>x. x mod n) xs) mod int n"
+ and
+ eval_dioph_div_mult:
+ "eval_dioph ks (map (\<lambda>x. x div n) xs) * int n +
+ eval_dioph ks (map (\<lambda>x. x mod n) xs) = eval_dioph ks xs"
+lemma
+ "(eval_dioph ks xs = l) =
+ (eval_dioph ks (map (\<lambda>x. x mod 2) xs) mod 2 = l mod 2 \<and>
+ eval_dioph ks (map (\<lambda>x. x div 2) xs) =
+ (l - eval_dioph ks (map (\<lambda>x. x mod 2) xs)) div 2)"
+ using [[smt_solver=z3]]
+ by (smt add: eval_dioph_mod[where n=2] eval_dioph_div_mult[where n=2])
+
+
+section {* Monomorphization examples *}
+
+definition P :: "'a \<Rightarrow> bool" where "P x = True"
+lemma poly_P: "P x \<and> (P [x] \<or> \<not>P[x])" by (simp add: P_def)
+lemma "P (1::int)" by (smt add: poly_P)
+
+consts g :: "'a \<Rightarrow> nat"
+axioms
+ g1: "g (Some x) = g [x]"
+ g2: "g None = g []"
+ g3: "g xs = length xs"
+lemma "g (Some (3::int)) = g (Some True)" by (smt add: g1 g2 g3 list.size)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/ROOT.ML Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,1 @@
+use_thy "SMT";
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/SMT.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,51 @@
+(* Title: HOL/SMT/SMT.thy
+ Author: Sascha Boehme, TU Muenchen
+*)
+
+header {* SMT method using external SMT solvers (CVC3, Yices, Z3) *}
+
+theory SMT
+imports SMT_Definitions
+uses
+ "Tools/smt_normalize.ML"
+ "Tools/smt_monomorph.ML"
+ "Tools/smt_translate.ML"
+ "Tools/smt_solver.ML"
+ "Tools/smtlib_interface.ML"
+ "Tools/cvc3_solver.ML"
+ "Tools/yices_solver.ML"
+ "Tools/z3_model.ML"
+ "Tools/z3_interface.ML"
+ "Tools/z3_solver.ML"
+begin
+
+setup {*
+ SMT_Normalize.setup #>
+ SMT_Solver.setup #>
+ CVC3_Solver.setup #>
+ Yices_Solver.setup #>
+ Z3_Solver.setup
+*}
+
+ML {*
+OuterSyntax.improper_command "smt_status"
+ "Show the available SMT solvers and the currently selected solver."
+ OuterKeyword.diag
+ (Scan.succeed (Toplevel.no_timing o Toplevel.keep (fn state =>
+ SMT_Solver.print_setup (Context.Proof (Toplevel.context_of state)))))
+*}
+
+method_setup smt = {*
+ let fun solver thms ctxt = SMT_Solver.smt_tac ctxt thms
+ in
+ Scan.optional (Scan.lift (Args.add -- Args.colon) |-- Attrib.thms) [] >>
+ (Method.SIMPLE_METHOD' oo solver)
+ end
+*} "Applies an SMT solver to the current goal."
+
+declare [[ smt_solver = z3, smt_timeout = 20, smt_trace = false ]]
+declare [[ smt_unfold_defs = true ]]
+declare [[ z3_proofs = false ]]
+
+end
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/SMT_Definitions.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,113 @@
+(* Title: HOL/SMT/SMT_Definitions.thy
+ Author: Sascha Boehme, TU Muenchen
+*)
+
+header {* SMT-specific definitions *}
+
+theory SMT_Definitions
+imports Real Word "~~/src/HOL/Decision_Procs/Dense_Linear_Order"
+begin
+
+section {* Triggers for quantifier instantiation *}
+
+text {*
+Some SMT solvers support triggers for quantifier instantiation. Each trigger
+consists of one ore more patterns. A pattern may either be a list of positive
+subterms (the first being tagged by "pat" and the consecutive subterms tagged
+by "andpat"), or a list of negative subterms (the first being tagged by "nopat"
+and the consecutive subterms tagged by "andpat").
+*}
+
+datatype pattern = Pattern
+
+definition pat :: "'a \<Rightarrow> pattern"
+where "pat _ = Pattern"
+
+definition nopat :: "bool \<Rightarrow> pattern"
+where "nopat _ = Pattern"
+
+definition andpat :: "pattern \<Rightarrow> 'a \<Rightarrow> pattern" (infixl "andpat" 60)
+where "_ andpat _ = Pattern"
+
+definition trigger :: "pattern list \<Rightarrow> bool \<Rightarrow> bool"
+where "trigger _ P = P"
+
+
+section {* Arithmetic *}
+
+text {*
+The sign of @{term "op mod :: int \<Rightarrow> int \<Rightarrow> int"} follows the sign of the
+divisor. In contrast to that, the sign of the following operation is that of
+the dividend.
+*}
+
+definition rem :: "int \<Rightarrow> int \<Rightarrow> int" (infixl "rem" 70)
+where "a rem b =
+ (if (a \<ge> 0 \<and> b < 0) \<or> (a < 0 \<and> b \<ge> 0) then - (a mod b) else a mod b)"
+
+text {* A decision procedure for linear real arithmetic: *}
+
+setup {*
+ Arith_Data.add_tactic "Ferrante-Rackoff" (K FerranteRackoff.dlo_tac)
+*}
+
+
+section {* Bitvectors *}
+
+text {*
+The following definitions provide additional functions not found in HOL-Word.
+*}
+
+definition sdiv :: "'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infix "sdiv" 70)
+where "w1 sdiv w2 = word_of_int (sint w1 div sint w2)"
+
+definition smod :: "'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infix "smod" 70)
+ (* sign follows divisor *)
+where "w1 smod w2 = word_of_int (sint w1 mod sint w2)"
+
+definition srem :: "'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infix "srem" 70)
+ (* sign follows dividend *)
+where "w1 srem w2 = word_of_int (sint w1 rem sint w2)"
+
+definition bv_shl :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word"
+where "bv_shl w1 w2 = (w1 << unat w2)"
+
+definition bv_lshr :: "'a::len0 word \<Rightarrow> 'a word \<Rightarrow> 'a word"
+where "bv_lshr w1 w2 = (w1 >> unat w2)"
+
+definition bv_ashr :: "'a::len word \<Rightarrow> 'a word \<Rightarrow> 'a word"
+where "bv_ashr w1 w2 = (w1 >>> unat w2)"
+
+
+section {* Higher-order encoding *}
+
+definition "apply" where "apply f x = f x"
+
+
+section {* First-order logic *}
+
+text {*
+Some SMT solver formats require a strict separation between formulas and terms.
+The following marker symbols are used internally to separate those categories:
+*}
+
+definition formula :: "bool \<Rightarrow> bool" where "formula x = x"
+definition "term" where "term x = x"
+
+text {*
+Predicate symbols also occurring as function symbols are turned into function
+symbols by translating atomic formulas into terms:
+*}
+
+abbreviation holds :: "bool \<Rightarrow> bool" where "holds \<equiv> (\<lambda>P. term P = term True)"
+
+text {*
+The following constant represents equivalence, to be treated differently than
+the (polymorphic) equality predicate:
+*}
+
+definition iff :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infix "iff" 50) where
+ "(x iff y) = (x = y)"
+
+end
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/cvc3_solver.ML Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,59 @@
+(* Title: HOL/SMT/Tools/cvc3_solver.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Interface of the SMT solver CVC3.
+*)
+
+signature CVC3_SOLVER =
+sig
+ val setup: theory -> theory
+end
+
+structure CVC3_Solver: CVC3_SOLVER =
+struct
+
+val solver_name = "cvc3"
+val env_var = "CVC3_SOLVER"
+
+val options =
+ ["+counterexample", "-lang", "smtlib", "-output-lang", "presentation"]
+
+val is_sat = String.isPrefix "Satisfiable."
+val is_unsat = String.isPrefix "Unsatisfiable."
+val is_unknown = String.isPrefix "Unknown."
+
+fun cex_kind true = "Counterexample"
+ | cex_kind false = "Possible counterexample"
+
+fun raise_cex real ctxt recon ls =
+ let
+ val start = String.isPrefix "%Satisfiable Variable Assignment: %"
+ val index = find_index start ls
+ val ls = if index > 0 then Library.drop (index + 1, ls) else []
+ val p = Pretty.big_list (cex_kind real ^ " found:") (map Pretty.str ls)
+ in error (Pretty.string_of p) end
+
+fun core_oracle (SMT_Solver.ProofData {context, output, recon, ...}) =
+ let
+ val empty_line = (fn "" => true | _ => false)
+ val split_first = (fn [] => ("", []) | l :: ls => (l, ls))
+ val (l, ls) = split_first (dropwhile empty_line output)
+ in
+ if is_unsat l then @{cprop False}
+ else if is_sat l then raise_cex true context recon ls
+ else if is_unknown l then raise_cex false context recon ls
+ else error (solver_name ^ " failed")
+ end
+
+fun smtlib_solver oracle _ =
+ SMT_Solver.SolverConfig {
+ name = {env_var=env_var, remote_name=solver_name},
+ interface = SMTLIB_Interface.interface,
+ arguments = options,
+ reconstruct = oracle }
+
+val setup =
+ Thm.add_oracle (Binding.name solver_name, core_oracle) #-> (fn (_, oracle) =>
+ SMT_Solver.add_solver (solver_name, smtlib_solver oracle))
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/smt_builtin.ML Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,78 @@
+(* Title: HOL/SMT/Tools/smt_builtin.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Tables for built-in symbols.
+*)
+
+signature SMT_BUILTIN =
+sig
+ type sterm = (SMT_Translate.sym, typ) sterm
+ type builtin_fun = typ -> sterm list -> (string * sterm list) option
+ type table = (typ * builtin_fun) list Symtab.table
+
+ val make: (term * string) list -> table
+ val add: term * builtin_fun -> table -> table
+ val lookup: table -> theory -> string * typ -> sterm list ->
+ (string * sterm list) option
+
+ val bv_rotate: (int -> string) -> builtin_fun
+ val bv_extend: (int -> string) -> builtin_fun
+ val bv_extract: (int -> int -> string) -> builtin_fun
+end
+
+structure SMT_Builtin: SMT_BUILTIN =
+struct
+
+structure T = SMT_Translate
+
+type sterm = (SMT_Translate.sym, typ) sterm
+type builtin_fun = typ -> sterm list -> (string * sterm list) option
+type table = (typ * builtin_fun) list Symtab.table
+
+fun make entries =
+ let
+ fun dest (t, bn) =
+ let val (n, T) = Term.dest_Const t
+ in (n, (Logic.varifyT T, K (pair bn))) end
+ in Symtab.make (AList.group (op =) (map dest entries)) end
+
+fun add (t, f) tab =
+ let val (n, T) = apsnd Logic.varifyT (Term.dest_Const t)
+ in Symtab.map_default (n, []) (AList.update (op =) (T, f)) tab end
+
+fun lookup tab thy (n, T) =
+ AList.lookup (Sign.typ_instance thy) (Symtab.lookup_list tab n) T T
+
+
+fun dest_binT T =
+ (case T of
+ Type (@{type_name "Numeral_Type.num0"}, _) => 0
+ | Type (@{type_name "Numeral_Type.num1"}, _) => 1
+ | Type (@{type_name "Numeral_Type.bit0"}, [T]) => 2 * dest_binT T
+ | Type (@{type_name "Numeral_Type.bit1"}, [T]) => 1 + 2 * dest_binT T
+ | _ => raise TYPE ("dest_binT", [T], []))
+
+fun dest_wordT T =
+ (case T of
+ Type (@{type_name "word"}, [T]) => dest_binT T
+ | _ => raise TYPE ("dest_wordT", [T], []))
+
+
+val dest_nat = (fn
+ SApp (SConst (@{const_name nat}, _), [SApp (SNum (i, _), _)]) => SOME i
+ | _ => NONE)
+
+fun bv_rotate mk_name T ts =
+ dest_nat (hd ts) |> Option.map (fn i => (mk_name i, tl ts))
+
+fun bv_extend mk_name T ts =
+ (case (try dest_wordT (domain_type T), try dest_wordT (range_type T)) of
+ (SOME i, SOME j) => if j - i >= 0 then SOME (mk_name (j - i), ts) else NONE
+ | _ => NONE)
+
+fun bv_extract mk_name T ts =
+ (case (try dest_wordT (body_type T), dest_nat (hd ts)) of
+ (SOME i, SOME lb) => SOME (mk_name (i + lb - 1) lb, tl ts)
+ | _ => NONE)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/smt_monomorph.ML Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,120 @@
+(* Title: HOL/SMT/Tools/smt_monomorph.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Monomorphization of terms, i.e., computation of all (necessary) instances.
+*)
+
+signature SMT_MONOMORPH =
+sig
+ val monomorph: theory -> term list -> term list
+end
+
+structure SMT_Monomorph: SMT_MONOMORPH =
+struct
+
+fun selection [] = []
+ | selection (x :: xs) = (x, xs) :: map (apsnd (cons x)) (selection xs)
+
+fun permute [] = []
+ | permute [x] = [[x]]
+ | permute xs = maps (fn (y, ys) => map (cons y) (permute ys)) (selection xs)
+
+fun fold_all f = fold (fn x => maps (f x))
+
+
+val typ_has_tvars = Term.exists_subtype (fn TVar _ => true | _ => false)
+val term_has_tvars = Term.exists_type typ_has_tvars
+
+val ignored = member (op =) [
+ @{const_name All}, @{const_name Ex}, @{const_name Let}, @{const_name If},
+ @{const_name "op ="}, @{const_name zero_class.zero},
+ @{const_name one_class.one}, @{const_name number_of}]
+fun consts_of ts = AList.group (op =) (fold Term.add_consts ts [])
+ |> filter_out (ignored o fst)
+
+val join_consts = curry (AList.join (op =) (K (merge (op =))))
+fun diff_consts cs ds =
+ let fun diff (n, Ts) =
+ (case AList.lookup (op =) cs n of
+ NONE => SOME (n, Ts)
+ | SOME Us =>
+ let val Ts' = fold (remove (op =)) Us Ts
+ in if null Ts' then NONE else SOME (n, Ts') end)
+ in map_filter diff ds end
+
+fun instances thy is (n, Ts) env =
+ let
+ val Us = these (AList.lookup (op =) is n)
+ val Ts' = filter typ_has_tvars (map (Envir.subst_type env) Ts)
+ in
+ (case map_product pair Ts' Us of
+ [] => [env]
+ | TUs => map_filter (try (fn TU => Sign.typ_match thy TU env)) TUs)
+ end
+
+fun proper_match ps env =
+ forall (forall (not o typ_has_tvars o Envir.subst_type env) o snd) ps
+
+val eq_tab = gen_eq_set (op =) o pairself Vartab.dest
+
+fun specialize thy cs is ((r, ps), ces) (ts, ns) =
+ let
+ val ps' = filter (AList.defined (op =) is o fst) ps
+
+ val envs = permute ps'
+ |> maps (fn ps => fold_all (instances thy is) ps [Vartab.empty])
+ |> filter (proper_match ps')
+ |> filter_out (member eq_tab ces)
+ |> distinct eq_tab
+
+ val us = map (fn env => Envir.subst_term_types env r) envs
+ val ns' = join_consts (diff_consts is (diff_consts cs (consts_of us))) ns
+ in (envs @ ces, (fold (insert (op aconv)) us ts, ns')) end
+
+
+fun incr_tvar_indices i t =
+ let
+ val incrT = Logic.incr_tvar i
+
+ fun incr t =
+ (case t of
+ Const (n, T) => Const (n, incrT T)
+ | Free (n, T) => Free (n, incrT T)
+ | Abs (n, T, t1) => Abs (n, incrT T, incr t1)
+ | t1 $ t2 => incr t1 $ incr t2
+ | _ => t)
+ in incr t end
+
+
+val monomorph_limit = 10
+
+(* Instantiate all polymorphic constants (i.e., constants occurring both with
+ ground types and type variables) with all (necessary) ground types; thereby
+ create copies of terms containing those constants.
+ To prevent non-termination, there is an upper limit for the number of
+ recursions involved in the fixpoint construction. *)
+fun monomorph thy ts =
+ let
+ val (ps, ms) = List.partition term_has_tvars ts
+
+ fun with_tvar (n, Ts) =
+ let val Ts' = filter typ_has_tvars Ts
+ in if null Ts' then NONE else SOME (n, Ts') end
+ fun incr t idx = (incr_tvar_indices idx t, idx + Term.maxidx_of_term t + 1)
+ val rps = fst (fold_map incr ps 0)
+ |> map (fn r => (r, map_filter with_tvar (consts_of [r])))
+
+ fun mono count is ces cs ts =
+ let
+ val spec = specialize thy cs is
+ val (ces', (ts', is')) = fold_map spec (rps ~~ ces) (ts, [])
+ val cs' = join_consts is cs
+ in
+ if null is' then ts'
+ else if count > monomorph_limit then
+ (Output.warning "monomorphization limit reached"; ts')
+ else mono (count + 1) is' ces' cs' ts'
+ end
+ in mono 0 (consts_of ms) (map (K []) rps) [] ms end
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/smt_normalize.ML Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,408 @@
+(* Title: HOL/SMT/Tools/smt_normalize.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Normalization steps on theorems required by SMT solvers:
+ * unfold trivial let expressions,
+ * replace negative numerals by negated positive numerals,
+ * embed natural numbers into integers,
+ * add extra rules specifying types and constants which occur frequently,
+ * lift lambda terms,
+ * make applications explicit for functions with varying number of arguments,
+ * fully translate into object logic, add universal closure.
+*)
+
+signature SMT_NORMALIZE =
+sig
+ val normalize_rule: Proof.context -> thm -> thm
+ val instantiate_free: Thm.cterm * Thm.cterm -> thm -> thm
+ val discharge_definition: Thm.cterm -> thm -> thm
+
+ val trivial_let: Proof.context -> thm list -> thm list
+ val positive_numerals: Proof.context -> thm list -> thm list
+ val nat_as_int: Proof.context -> thm list -> thm list
+ val unfold_defs: bool Config.T
+ val add_pair_rules: Proof.context -> thm list -> thm list
+ val add_fun_upd_rules: Proof.context -> thm list -> thm list
+ val add_abs_min_max_rules: Proof.context -> thm list -> thm list
+
+ datatype config =
+ RewriteTrivialLets |
+ RewriteNegativeNumerals |
+ RewriteNaturalNumbers |
+ AddPairRules |
+ AddFunUpdRules |
+ AddAbsMinMaxRules
+
+ val normalize: config list -> Proof.context -> thm list ->
+ Thm.cterm list * thm list
+
+ val setup: theory -> theory
+end
+
+structure SMT_Normalize: SMT_NORMALIZE =
+struct
+
+val norm_binder_conv = Conv.try_conv (More_Conv.rewrs_conv [
+ @{lemma "All P == ALL x. P x" by (rule reflexive)},
+ @{lemma "Ex P == EX x. P x" by (rule reflexive)},
+ @{lemma "Let c P == let x = c in P x" by (rule reflexive)}])
+
+fun cert ctxt = Thm.cterm_of (ProofContext.theory_of ctxt)
+
+fun norm_meta_def cv thm =
+ let val thm' = Thm.combination thm (Thm.reflexive cv)
+ in Thm.transitive thm' (Thm.beta_conversion false (Thm.rhs_of thm')) end
+
+fun norm_def ctxt thm =
+ (case Thm.prop_of thm of
+ Const (@{const_name "=="}, _) $ _ $ Abs (_, T, _) =>
+ let val v = Var ((Name.uu, #maxidx (Thm.rep_thm thm) + 1), T)
+ in norm_def ctxt (norm_meta_def (cert ctxt v) thm) end
+ | @{term Trueprop} $ (Const (@{const_name "op ="}, _) $ _ $ Abs _) =>
+ norm_def ctxt (thm RS @{thm fun_cong})
+ | _ => thm)
+
+fun normalize_rule ctxt =
+ Conv.fconv_rule (
+ Thm.beta_conversion true then_conv
+ Thm.eta_conversion then_conv
+ More_Conv.bottom_conv (K norm_binder_conv) ctxt) #>
+ norm_def ctxt #>
+ Drule.forall_intr_vars #>
+ Conv.fconv_rule ObjectLogic.atomize
+
+fun instantiate_free (cv, ct) thm =
+ if Term.exists_subterm (equal (Thm.term_of cv)) (Thm.prop_of thm)
+ then Thm.forall_elim ct (Thm.forall_intr cv thm)
+ else thm
+
+fun discharge_definition ct thm =
+ let val (cv, cu) = Thm.dest_equals ct
+ in
+ Thm.implies_intr ct thm
+ |> instantiate_free (cv, cu)
+ |> (fn thm => Thm.implies_elim thm (Thm.reflexive cu))
+ end
+
+fun if_conv c cv1 cv2 ct = (if c (Thm.term_of ct) then cv1 else cv2) ct
+fun if_true_conv c cv = if_conv c cv Conv.all_conv
+
+
+(* simplification of trivial let expressions (whose bound variables occur at
+ most once) *)
+
+local
+ fun count i (Bound j) = if j = i then 1 else 0
+ | count i (t $ u) = count i t + count i u
+ | count i (Abs (_, _, t)) = count (i + 1) t
+ | count _ _ = 0
+
+ fun is_trivial_let (Const (@{const_name Let}, _) $ _ $ Abs (_, _, t)) =
+ (count 0 t <= 1)
+ | is_trivial_let _ = false
+
+ fun let_conv _ = if_true_conv is_trivial_let (Conv.rewr_conv @{thm Let_def})
+
+ fun cond_let_conv ctxt = if_true_conv (Term.exists_subterm is_trivial_let)
+ (More_Conv.top_conv let_conv ctxt)
+in
+fun trivial_let ctxt = map (Conv.fconv_rule (cond_let_conv ctxt))
+end
+
+
+(* rewriting of negative integer numerals into positive numerals *)
+
+local
+ fun neg_numeral @{term Int.Min} = true
+ | neg_numeral _ = false
+ fun is_number_sort thy T = Sign.of_sort thy (T, @{sort number_ring})
+ fun is_neg_number ctxt (Const (@{const_name number_of}, T) $ t) =
+ Term.exists_subterm neg_numeral t andalso
+ is_number_sort (ProofContext.theory_of ctxt) (Term.body_type T)
+ | is_neg_number _ _ = false
+ fun has_neg_number ctxt = Term.exists_subterm (is_neg_number ctxt)
+
+ val pos_numeral_ss = HOL_ss
+ addsimps [@{thm Int.number_of_minus}, @{thm Int.number_of_Min}]
+ addsimps [@{thm Int.numeral_1_eq_1}]
+ addsimps @{thms Int.pred_bin_simps}
+ addsimps @{thms Int.normalize_bin_simps}
+ addsimps @{lemma
+ "Int.Min = - Int.Bit1 Int.Pls"
+ "Int.Bit0 (- Int.Pls) = - Int.Pls"
+ "Int.Bit0 (- k) = - Int.Bit0 k"
+ "Int.Bit1 (- k) = - Int.Bit1 (Int.pred k)"
+ by simp_all (simp add: pred_def)}
+
+ fun pos_conv ctxt = if_conv (is_neg_number ctxt)
+ (Simplifier.rewrite (Simplifier.context ctxt pos_numeral_ss))
+ Conv.no_conv
+
+ fun cond_pos_conv ctxt = if_true_conv (has_neg_number ctxt)
+ (More_Conv.top_sweep_conv pos_conv ctxt)
+in
+fun positive_numerals ctxt = map (Conv.fconv_rule (cond_pos_conv ctxt))
+end
+
+
+(* embedding of standard natural number operations into integer operations *)
+
+local
+ val nat_embedding = @{lemma
+ "nat (int n) = n"
+ "i >= 0 --> int (nat i) = i"
+ "i < 0 --> int (nat i) = 0"
+ by simp_all}
+
+ val nat_rewriting = @{lemma
+ "0 = nat 0"
+ "1 = nat 1"
+ "number_of i = nat (number_of i)"
+ "int (nat 0) = 0"
+ "int (nat 1) = 1"
+ "a < b = (int a < int b)"
+ "a <= b = (int a <= int b)"
+ "Suc a = nat (int a + 1)"
+ "a + b = nat (int a + int b)"
+ "a - b = nat (int a - int b)"
+ "a * b = nat (int a * int b)"
+ "a div b = nat (int a div int b)"
+ "a mod b = nat (int a mod int b)"
+ "int (nat (int a + int b)) = int a + int b"
+ "int (nat (int a * int b)) = int a * int b"
+ "int (nat (int a div int b)) = int a div int b"
+ "int (nat (int a mod int b)) = int a mod int b"
+ by (simp add: nat_mult_distrib nat_div_distrib nat_mod_distrib
+ int_mult[symmetric] zdiv_int[symmetric] zmod_int[symmetric])+}
+
+ fun on_positive num f x =
+ (case try HOLogic.dest_number (Thm.term_of num) of
+ SOME (_, i) => if i >= 0 then SOME (f x) else NONE
+ | NONE => NONE)
+
+ val cancel_int_nat_ss = HOL_ss
+ addsimps [@{thm Nat_Numeral.nat_number_of}]
+ addsimps [@{thm Nat_Numeral.int_nat_number_of}]
+ addsimps @{thms neg_simps}
+
+ fun cancel_int_nat_simproc _ ss ct =
+ let
+ val num = Thm.dest_arg (Thm.dest_arg ct)
+ val goal = Thm.mk_binop @{cterm "op == :: int => _"} ct num
+ val simpset = Simplifier.inherit_context ss cancel_int_nat_ss
+ fun tac _ = Simplifier.simp_tac simpset 1
+ in on_positive num (Goal.prove_internal [] goal) tac end
+
+ val nat_ss = HOL_ss
+ addsimps nat_rewriting
+ addsimprocs [Simplifier.make_simproc {
+ name = "cancel_int_nat_num", lhss = [@{cpat "int (nat _)"}],
+ proc = cancel_int_nat_simproc, identifier = [] }]
+
+ fun conv ctxt = Simplifier.rewrite (Simplifier.context ctxt nat_ss)
+
+ val uses_nat_type = Term.exists_type (Term.exists_subtype (equal @{typ nat}))
+in
+fun nat_as_int ctxt thms =
+ let
+ fun norm thm uses_nat =
+ if not (uses_nat_type (Thm.prop_of thm)) then (thm, uses_nat)
+ else (Conv.fconv_rule (conv ctxt) thm, true)
+ val (thms', uses_nat) = fold_map norm thms false
+ in if uses_nat then nat_embedding @ thms' else thms' end
+end
+
+
+(* include additional rules *)
+
+val (unfold_defs, unfold_defs_setup) =
+ Attrib.config_bool "smt_unfold_defs" true
+
+local
+ val pair_rules = [@{thm fst_conv}, @{thm snd_conv}, @{thm pair_collapse}]
+
+ val pair_type = (fn Type (@{type_name "*"}, _) => true | _ => false)
+ val exists_pair_type = Term.exists_type (Term.exists_subtype pair_type)
+
+ val fun_upd_rules = [@{thm fun_upd_same}, @{thm fun_upd_apply}]
+ val is_fun_upd = (fn Const (@{const_name fun_upd}, _) => true | _ => false)
+ val exists_fun_upd = Term.exists_subterm is_fun_upd
+in
+fun add_pair_rules _ thms =
+ thms
+ |> exists (exists_pair_type o Thm.prop_of) thms ? append pair_rules
+
+fun add_fun_upd_rules _ thms =
+ thms
+ |> exists (exists_fun_upd o Thm.prop_of) thms ? append fun_upd_rules
+end
+
+
+local
+ fun mk_entry t thm = (Term.head_of t, (thm, thm RS @{thm eq_reflection}))
+ fun prepare_def thm =
+ (case HOLogic.dest_Trueprop (Thm.prop_of thm) of
+ Const (@{const_name "op ="}, _) $ t $ _ => mk_entry t thm
+ | t => raise TERM ("prepare_def", [t]))
+
+ val defs = map prepare_def [
+ @{thm abs_if[where 'a = int]}, @{thm abs_if[where 'a = real]},
+ @{thm min_def[where 'a = int]}, @{thm min_def[where 'a = real]},
+ @{thm max_def[where 'a = int]}, @{thm max_def[where 'a = real]}]
+
+ fun add_sym t = if AList.defined (op =) defs t then insert (op =) t else I
+ fun add_syms thms = fold (Term.fold_aterms add_sym o Thm.prop_of) thms []
+
+ fun unfold_conv ctxt ct =
+ (case AList.lookup (op =) defs (Term.head_of (Thm.term_of ct)) of
+ SOME (_, eq) => Conv.rewr_conv eq
+ | NONE => Conv.all_conv) ct
+in
+fun add_abs_min_max_rules ctxt thms =
+ if Config.get ctxt unfold_defs
+ then map (Conv.fconv_rule (More_Conv.bottom_conv unfold_conv ctxt)) thms
+ else map fst (map_filter (AList.lookup (op =) defs) (add_syms thms)) @ thms
+end
+
+
+(* lift lambda terms into additional rules *)
+
+local
+ val meta_eq = @{cpat "op =="}
+ val meta_eqT = hd (Thm.dest_ctyp (Thm.ctyp_of_term meta_eq))
+ fun inst_meta cT = Thm.instantiate_cterm ([(meta_eqT, cT)], []) meta_eq
+ fun mk_meta_eq ct cu = Thm.mk_binop (inst_meta (Thm.ctyp_of_term ct)) ct cu
+
+ fun lambda_conv conv =
+ let
+ fun sub_conv cvs ctxt ct =
+ (case Thm.term_of ct of
+ Const (@{const_name All}, _) $ Abs _ => quant_conv cvs ctxt
+ | Const (@{const_name Ex}, _) $ Abs _ => quant_conv cvs ctxt
+ | Const _ $ Abs _ => Conv.arg_conv (at_lambda_conv cvs ctxt)
+ | Const (@{const_name Let}, _) $ _ $ Abs _ => Conv.combination_conv
+ (Conv.arg_conv (sub_conv cvs ctxt)) (abs_conv cvs ctxt)
+ | Abs _ => at_lambda_conv cvs ctxt
+ | _ $ _ => Conv.comb_conv (sub_conv cvs ctxt)
+ | _ => Conv.all_conv) ct
+ and abs_conv cvs = Conv.abs_conv (fn (cv, cx) => sub_conv (cv::cvs) cx)
+ and quant_conv cvs ctxt = Conv.arg_conv (abs_conv cvs ctxt)
+ and at_lambda_conv cvs ctxt = abs_conv cvs ctxt then_conv conv cvs ctxt
+ in sub_conv [] end
+
+ fun used_vars cvs ct =
+ let
+ val lookup = AList.lookup (op aconv) (map (` Thm.term_of) cvs)
+ val add = (fn (SOME ct) => insert (op aconvc) ct | _ => I)
+ in Term.fold_aterms (add o lookup) (Thm.term_of ct) [] end
+
+ val rev_int_fst_ord = rev_order o int_ord o pairself fst
+ fun ordered_values tab =
+ Termtab.fold (fn (_, x) => OrdList.insert rev_int_fst_ord x) tab []
+ |> map snd
+in
+fun lift_lambdas ctxt thms =
+ let
+ val declare_frees = fold (Thm.fold_terms Term.declare_term_frees)
+ val names = ref (declare_frees thms (Name.make_context []))
+ val fresh_name = change_result names o yield_singleton Name.variants
+
+ val defs = ref (Termtab.empty : (int * thm) Termtab.table)
+ fun add_def t thm = change defs (Termtab.update (t, (serial (), thm)))
+ fun make_def cvs eq = Thm.symmetric (fold norm_meta_def cvs eq)
+ fun def_conv cvs ctxt ct =
+ let
+ val cvs' = used_vars cvs ct
+ val ct' = fold Thm.cabs cvs' ct
+ in
+ (case Termtab.lookup (!defs) (Thm.term_of ct') of
+ SOME (_, eq) => make_def cvs' eq
+ | NONE =>
+ let
+ val {t, T, ...} = Thm.rep_cterm ct'
+ val eq = mk_meta_eq (cert ctxt (Free (fresh_name "", T))) ct'
+ val thm = Thm.assume eq
+ in (add_def t thm; make_def cvs' thm) end)
+ end
+ val thms' = map (Conv.fconv_rule (lambda_conv def_conv ctxt)) thms
+ val eqs = ordered_values (!defs)
+ in
+ (maps (#hyps o Thm.crep_thm) eqs, map (normalize_rule ctxt) eqs @ thms')
+ end
+end
+
+
+(* make application explicit for functions with varying number of arguments *)
+
+local
+ val const = prefix "c" and free = prefix "f"
+ fun min i (e as (_, j)) = if i <> j then (true, Int.min (i, j)) else e
+ fun add t i = Symtab.map_default (t, (false, i)) (min i)
+ fun traverse t =
+ (case Term.strip_comb t of
+ (Const (n, _), ts) => add (const n) (length ts) #> fold traverse ts
+ | (Free (n, _), ts) => add (free n) (length ts) #> fold traverse ts
+ | (Abs (_, _, u), ts) => fold traverse (u :: ts)
+ | (_, ts) => fold traverse ts)
+ val prune = (fn (n, (true, i)) => Symtab.update (n, i) | _ => I)
+ fun prune_tab tab = Symtab.fold prune tab Symtab.empty
+
+ fun binop_conv cv1 cv2 = Conv.combination_conv (Conv.arg_conv cv1) cv2
+ fun nary_conv conv1 conv2 ct =
+ (Conv.combination_conv (nary_conv conv1 conv2) conv2 else_conv conv1) ct
+ fun abs_conv conv tb = Conv.abs_conv (fn (cv, cx) =>
+ let val n = fst (Term.dest_Free (Thm.term_of cv))
+ in conv (Symtab.update (free n, 0) tb) cx end)
+ val apply_rule = @{lemma "f x == apply f x" by (simp add: apply_def)}
+in
+fun explicit_application ctxt thms =
+ let
+ fun sub_conv tb ctxt ct =
+ (case Term.strip_comb (Thm.term_of ct) of
+ (Const (n, _), ts) => app_conv tb (const n) (length ts) ctxt
+ | (Free (n, _), ts) => app_conv tb (free n) (length ts) ctxt
+ | (Abs _, ts) => nary_conv (abs_conv sub_conv tb ctxt) (sub_conv tb ctxt)
+ | (_, ts) => nary_conv Conv.all_conv (sub_conv tb ctxt)) ct
+ and app_conv tb n i ctxt =
+ (case Symtab.lookup tb n of
+ NONE => nary_conv Conv.all_conv (sub_conv tb ctxt)
+ | SOME j => apply_conv tb ctxt (i - j))
+ and apply_conv tb ctxt i ct = (
+ if i = 0 then nary_conv Conv.all_conv (sub_conv tb ctxt)
+ else
+ Conv.rewr_conv apply_rule then_conv
+ binop_conv (apply_conv tb ctxt (i-1)) (sub_conv tb ctxt)) ct
+
+ val tab = prune_tab (fold (traverse o Thm.prop_of) thms Symtab.empty)
+ in map (Conv.fconv_rule (sub_conv tab ctxt)) thms end
+end
+
+
+(* combined normalization *)
+
+datatype config =
+ RewriteTrivialLets |
+ RewriteNegativeNumerals |
+ RewriteNaturalNumbers |
+ AddPairRules |
+ AddFunUpdRules |
+ AddAbsMinMaxRules
+
+fun normalize config ctxt thms =
+ let fun if_enabled c f = member (op =) config c ? f ctxt
+ in
+ thms
+ |> if_enabled RewriteTrivialLets trivial_let
+ |> if_enabled RewriteNegativeNumerals positive_numerals
+ |> if_enabled RewriteNaturalNumbers nat_as_int
+ |> if_enabled AddPairRules add_pair_rules
+ |> if_enabled AddFunUpdRules add_fun_upd_rules
+ |> if_enabled AddAbsMinMaxRules add_abs_min_max_rules
+ |> map (normalize_rule ctxt)
+ |> lift_lambdas ctxt
+ |> apsnd (explicit_application ctxt)
+ end
+
+val setup = unfold_defs_setup
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/smt_solver.ML Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,246 @@
+(* Title: HOL/SMT/Tools/smt_solver.ML
+ Author: Sascha Boehme, TU Muenchen
+
+SMT solvers registry and SMT tactic.
+*)
+
+signature SMT_SOLVER =
+sig
+ exception SMT_COUNTEREXAMPLE of bool * term list
+
+ datatype interface = Interface of {
+ normalize: SMT_Normalize.config list,
+ translate: SMT_Translate.config }
+
+ datatype proof_data = ProofData of {
+ context: Proof.context,
+ output: string list,
+ recon: SMT_Translate.recon,
+ assms: thm list option }
+
+ datatype solver_config = SolverConfig of {
+ name: {env_var: string, remote_name: string},
+ interface: interface,
+ arguments: string list,
+ reconstruct: proof_data -> thm }
+
+ (*options*)
+ val timeout: int Config.T
+ val with_timeout: Proof.context -> ('a -> 'b) -> 'a -> 'b
+ val trace: bool Config.T
+ val trace_msg: Proof.context -> ('a -> string) -> 'a -> unit
+
+ (*solvers*)
+ type solver = Proof.context -> thm list -> thm
+ type solver_info = Context.generic -> Pretty.T list
+ val add_solver: string * (Proof.context -> solver_config) -> theory ->
+ theory
+ val all_solver_names_of: theory -> string list
+ val add_solver_info: string * solver_info -> theory -> theory
+ val solver_name_of: Context.generic -> string
+ val select_solver: string -> Context.generic -> Context.generic
+ val solver_of: Context.generic -> solver
+
+ (*tactic*)
+ val smt_tac': bool -> Proof.context -> thm list -> int -> Tactical.tactic
+ val smt_tac: Proof.context -> thm list -> int -> Tactical.tactic
+
+ (*setup*)
+ val setup: theory -> theory
+ val print_setup: Context.generic -> unit
+end
+
+structure SMT_Solver: SMT_SOLVER =
+struct
+
+exception SMT_COUNTEREXAMPLE of bool * term list
+
+
+datatype interface = Interface of {
+ normalize: SMT_Normalize.config list,
+ translate: SMT_Translate.config }
+
+datatype proof_data = ProofData of {
+ context: Proof.context,
+ output: string list,
+ recon: SMT_Translate.recon,
+ assms: thm list option }
+
+datatype solver_config = SolverConfig of {
+ name: {env_var: string, remote_name: string},
+ interface: interface,
+ arguments: string list,
+ reconstruct: proof_data -> thm }
+
+
+(* SMT options *)
+
+val (timeout, setup_timeout) = Attrib.config_int "smt_timeout" 30
+
+fun with_timeout ctxt f x =
+ TimeLimit.timeLimit (Time.fromSeconds (Config.get ctxt timeout)) f x
+ handle TimeLimit.TimeOut => error ("SMT: timeout")
+
+val (trace, setup_trace) = Attrib.config_bool "smt_trace" false
+
+fun trace_msg ctxt f x =
+ if Config.get ctxt trace then Output.tracing (f x) else ()
+
+
+(* interface to external solvers *)
+
+local
+
+fun with_tmp_files f x =
+ let
+ fun tmp_path () = File.tmp_path (Path.explode ("smt-" ^ serial_string ()))
+ val in_path = tmp_path () and out_path = tmp_path ()
+ val y = Exn.capture (f in_path out_path) x
+ val _ = try File.rm in_path and _ = try File.rm out_path
+ in Exn.release y end
+
+fun run in_path out_path (ctxt, cmd, output) =
+ let
+ val x = File.open_output output in_path
+ val _ = trace_msg ctxt File.read in_path
+
+ val _ = with_timeout ctxt system_out (cmd in_path out_path)
+ fun lines_of path = the_default [] (try (File.fold_lines cons out_path) [])
+ val ls = rev (dropwhile (equal "") (lines_of out_path))
+ val _ = trace_msg ctxt cat_lines ls
+ in (x, ls) end
+
+in
+
+fun run_solver ctxt {env_var, remote_name} args output =
+ let
+ val qf = File.shell_path and qq = enclose "'" "'"
+ val path = getenv env_var and remote = getenv "REMOTE_SMT_SOLVER"
+ fun cmd f1 f2 =
+ if path <> ""
+ then map qq (path :: args) @ [qf f1, ">", qf f2]
+ else "perl -w" :: map qq (remote :: remote_name :: args) @ [qf f1, qf f2]
+ in with_tmp_files run (ctxt, space_implode " " oo cmd, output) end
+
+end
+
+fun make_proof_data ctxt ((recon, thms), ls) =
+ ProofData {context=ctxt, output=ls, recon=recon, assms=SOME thms}
+
+fun gen_solver solver ctxt prems =
+ let
+ val SolverConfig {name, interface, arguments, reconstruct} = solver ctxt
+ val Interface {normalize=nc, translate=tc} = interface
+ val thy = ProofContext.theory_of ctxt
+ in
+ SMT_Normalize.normalize nc ctxt prems
+ ||> run_solver ctxt name arguments o SMT_Translate.translate tc thy
+ ||> reconstruct o make_proof_data ctxt
+ |-> fold SMT_Normalize.discharge_definition
+ end
+
+
+(* solver store *)
+
+type solver = Proof.context -> thm list -> thm
+type solver_info = Context.generic -> Pretty.T list
+
+structure Solvers = TheoryDataFun
+(
+ type T = ((Proof.context -> solver_config) * solver_info) Symtab.table
+ val empty = Symtab.empty
+ val copy = I
+ val extend = I
+ fun merge _ = Symtab.merge (K true)
+ handle Symtab.DUP name => error ("Duplicate SMT solver: " ^ quote name)
+)
+
+val no_solver = "(none)"
+val add_solver = Solvers.map o Symtab.update_new o apsnd (rpair (K []))
+val all_solver_names_of = Symtab.keys o Solvers.get
+val lookup_solver = Symtab.lookup o Solvers.get
+fun add_solver_info (n, i) = Solvers.map (Symtab.map_entry n (apsnd (K i)))
+
+
+(* selected solver *)
+
+structure SelectedSolver = GenericDataFun
+(
+ type T = serial * string
+ val empty = (serial (), no_solver)
+ val extend = I
+ fun merge _ (sl1 as (s1, _), sl2 as (s2, _)) = if s1 > s2 then sl1 else sl2
+)
+
+val solver_name_of = snd o SelectedSolver.get
+
+fun select_solver name gen =
+ if is_none (lookup_solver (Context.theory_of gen) name)
+ then error ("SMT solver not registered: " ^ quote name)
+ else SelectedSolver.map (K (serial (), name)) gen
+
+fun raw_solver_of gen =
+ (case lookup_solver (Context.theory_of gen) (solver_name_of gen) of
+ NONE => error "No SMT solver selected"
+ | SOME (s, _) => s)
+
+val solver_of = gen_solver o raw_solver_of
+
+
+(* SMT tactic *)
+
+fun smt_unsat_tac solver ctxt rules =
+ Tactic.rtac @{thm ccontr} THEN'
+ SUBPROOF (fn {context, prems, ...} =>
+ Tactic.rtac (solver context (rules @ prems)) 1) ctxt
+
+fun pretty_counterex ctxt (real, ex) =
+ let
+ val msg = if real then "Counterexample found:"
+ else "Potential counterexample found:"
+ val cex = if null ex then [Pretty.str "(no assignments)"]
+ else map (Syntax.pretty_term ctxt) ex
+ in Pretty.string_of (Pretty.big_list msg cex) end
+
+fun smt_tac' pass_smt_exns ctxt =
+ let
+ val solver = solver_of (Context.Proof ctxt)
+ fun safe_solver ctxt thms = solver ctxt thms
+ handle SMT_COUNTEREXAMPLE cex => error (pretty_counterex ctxt cex)
+ val solver' = if pass_smt_exns then solver else safe_solver
+ in smt_unsat_tac solver' ctxt end
+
+val smt_tac = smt_tac' false
+
+
+(* setup *)
+
+val setup =
+ Attrib.setup (Binding.name "smt_solver")
+ (Scan.lift (OuterParse.$$$ "=" |-- Args.name) >>
+ (Thm.declaration_attribute o K o select_solver))
+ "SMT solver configuration" #>
+ setup_timeout #>
+ setup_trace
+
+fun print_setup gen =
+ let
+ val t = string_of_int (Config.get_generic gen timeout)
+ val names = sort string_ord (all_solver_names_of (Context.theory_of gen))
+ val ns = if null names then [no_solver] else names
+ val take_info = (fn (_, []) => NONE | info => SOME info)
+ val infos =
+ Context.theory_of gen
+ |> Symtab.dest o Solvers.get
+ |> map_filter (fn (n, (_, info)) => take_info (n, info gen))
+ |> sort (prod_ord string_ord (K EQUAL))
+ |> map (fn (n, ps) => Pretty.big_list (n ^ ":") ps)
+ in
+ Pretty.writeln (Pretty.big_list "SMT setup:" [
+ Pretty.str ("Current SMT solver: " ^ solver_name_of gen),
+ Pretty.str_list "Available SMT solvers: " "" ns,
+ Pretty.str ("Current timeout: " ^ t ^ " seconds"),
+ Pretty.big_list "Solver-specific settings:" infos])
+ end
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/smt_translate.ML Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,507 @@
+(* Title: HOL/SMT/Tools/smt_translate.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Translate theorems into an SMT intermediate format and serialize them,
+depending on an SMT interface.
+*)
+
+signature SMT_TRANSLATE =
+sig
+ (* intermediate term structure *)
+ datatype sym =
+ SConst of string * typ |
+ SFree of string * typ |
+ SNum of int * typ
+ datatype squant = SForall | SExists
+ datatype 'a spattern = SPat of 'a list | SNoPat of 'a list
+ datatype ('a, 'b) sterm =
+ SVar of int |
+ SApp of 'a * ('a, 'b) sterm list |
+ SLet of (string * 'b) * ('a, 'b) sterm * ('a, 'b) sterm |
+ SQuant of squant * (string * 'b) list * ('a, 'b) sterm spattern list *
+ ('a, 'b) sterm
+
+ (* table for built-in symbols *)
+ type builtin_fun = typ -> (sym, typ) sterm list ->
+ (string * (sym, typ) sterm list) option
+ type builtin_table = (typ * builtin_fun) list Symtab.table
+ val builtin_make: (term * string) list -> builtin_table
+ val builtin_add: term * builtin_fun -> builtin_table -> builtin_table
+ val builtin_lookup: builtin_table -> theory -> string * typ ->
+ (sym, typ) sterm list -> (string * (sym, typ) sterm list) option
+ val bv_rotate: (int -> string) -> builtin_fun
+ val bv_extend: (int -> string) -> builtin_fun
+ val bv_extract: (int -> int -> string) -> builtin_fun
+
+ (* configuration options *)
+ datatype prefixes = Prefixes of {
+ var_prefix: string,
+ typ_prefix: string,
+ fun_prefix: string,
+ pred_prefix: string }
+ datatype markers = Markers of {
+ term_marker: string,
+ formula_marker: string }
+ datatype builtins = Builtins of {
+ builtin_typ: typ -> string option,
+ builtin_num: int * typ -> string option,
+ builtin_fun: bool -> builtin_table }
+ datatype sign = Sign of {
+ typs: string list,
+ funs: (string * (string list * string)) list,
+ preds: (string * string list) list }
+ datatype config = Config of {
+ strict: bool,
+ prefixes: prefixes,
+ markers: markers,
+ builtins: builtins,
+ serialize: sign -> (string, string) sterm list -> TextIO.outstream -> unit}
+ datatype recon = Recon of {typs: typ Symtab.table, terms: term Symtab.table}
+
+ val translate: config -> theory -> thm list -> TextIO.outstream ->
+ recon * thm list
+
+ val dest_binT: typ -> int
+ val dest_funT: int -> typ -> typ list * typ
+end
+
+structure SMT_Translate: SMT_TRANSLATE =
+struct
+
+(* Intermediate term structure *)
+
+datatype sym =
+ SConst of string * typ |
+ SFree of string * typ |
+ SNum of int * typ
+datatype squant = SForall | SExists
+datatype 'a spattern = SPat of 'a list | SNoPat of 'a list
+datatype ('a, 'b) sterm =
+ SVar of int |
+ SApp of 'a * ('a, 'b) sterm list |
+ SLet of (string * 'b) * ('a, 'b) sterm * ('a, 'b) sterm |
+ SQuant of squant * (string * 'b) list * ('a, 'b) sterm spattern list *
+ ('a, 'b) sterm
+
+fun app c ts = SApp (c, ts)
+
+fun map_pat f (SPat ps) = SPat (map f ps)
+ | map_pat f (SNoPat ps) = SNoPat (map f ps)
+
+fun fold_map_pat f (SPat ps) = fold_map f ps #>> SPat
+ | fold_map_pat f (SNoPat ps) = fold_map f ps #>> SNoPat
+
+val make_sconst = SConst o Term.dest_Const
+
+
+(* General type destructors. *)
+
+fun dest_binT T =
+ (case T of
+ Type (@{type_name "Numeral_Type.num0"}, _) => 0
+ | Type (@{type_name "Numeral_Type.num1"}, _) => 1
+ | Type (@{type_name "Numeral_Type.bit0"}, [T]) => 2 * dest_binT T
+ | Type (@{type_name "Numeral_Type.bit1"}, [T]) => 1 + 2 * dest_binT T
+ | _ => raise TYPE ("dest_binT", [T], []))
+
+val dest_wordT = (fn
+ Type (@{type_name "word"}, [T]) => dest_binT T
+ | T => raise TYPE ("dest_wordT", [T], []))
+
+val dest_funT =
+ let
+ fun dest Ts 0 T = (rev Ts, T)
+ | dest Ts i (Type ("fun", [T, U])) = dest (T::Ts) (i-1) U
+ | dest _ _ T = raise TYPE ("dest_funT", [T], [])
+ in dest [] end
+
+
+(* Table for built-in symbols *)
+
+type builtin_fun = typ -> (sym, typ) sterm list ->
+ (string * (sym, typ) sterm list) option
+type builtin_table = (typ * builtin_fun) list Symtab.table
+
+fun builtin_make entries =
+ let
+ fun dest (t, bn) =
+ let val (n, T) = Term.dest_Const t
+ in (n, (Logic.varifyT T, K (SOME o pair bn))) end
+ in Symtab.make (AList.group (op =) (map dest entries)) end
+
+fun builtin_add (t, f) tab =
+ let val (n, T) = apsnd Logic.varifyT (Term.dest_Const t)
+ in Symtab.map_default (n, []) (AList.update (op =) (T, f)) tab end
+
+fun builtin_lookup tab thy (n, T) ts =
+ AList.lookup (Sign.typ_instance thy) (Symtab.lookup_list tab n) T
+ |> (fn SOME f => f T ts | NONE => NONE)
+
+local
+ val dest_nat = (fn
+ SApp (SConst (@{const_name nat}, _), [SApp (SNum (i, _), _)]) => SOME i
+ | _ => NONE)
+in
+fun bv_rotate mk_name T ts =
+ dest_nat (hd ts) |> Option.map (fn i => (mk_name i, tl ts))
+
+fun bv_extend mk_name T ts =
+ (case (try dest_wordT (domain_type T), try dest_wordT (range_type T)) of
+ (SOME i, SOME j) => if j - i >= 0 then SOME (mk_name (j - i), ts) else NONE
+ | _ => NONE)
+
+fun bv_extract mk_name T ts =
+ (case (try dest_wordT (body_type T), dest_nat (hd ts)) of
+ (SOME i, SOME lb) => SOME (mk_name (i + lb - 1) lb, tl ts)
+ | _ => NONE)
+end
+
+
+(* Configuration options *)
+
+datatype prefixes = Prefixes of {
+ var_prefix: string,
+ typ_prefix: string,
+ fun_prefix: string,
+ pred_prefix: string }
+datatype markers = Markers of {
+ term_marker: string,
+ formula_marker: string }
+datatype builtins = Builtins of {
+ builtin_typ: typ -> string option,
+ builtin_num: int * typ -> string option,
+ builtin_fun: bool -> builtin_table }
+datatype sign = Sign of {
+ typs: string list,
+ funs: (string * (string list * string)) list,
+ preds: (string * string list) list }
+datatype config = Config of {
+ strict: bool,
+ prefixes: prefixes,
+ markers: markers,
+ builtins: builtins,
+ serialize: sign -> (string, string) sterm list -> TextIO.outstream -> unit}
+datatype recon = Recon of {typs: typ Symtab.table, terms: term Symtab.table}
+
+
+(* Translate Isabelle/HOL terms into SMT intermediate terms.
+ We assume that lambda-lifting has been performed before, i.e., lambda
+ abstractions occur only at quantifiers and let expressions.
+*)
+local
+ val quantifier = (fn
+ @{const_name All} => SOME SForall
+ | @{const_name Ex} => SOME SExists
+ | _ => NONE)
+
+ fun group_quant qname vs (t as Const (q, _) $ Abs (n, T, u)) =
+ if q = qname then group_quant qname ((n, T) :: vs) u else (vs, t)
+ | group_quant qname vs t = (vs, t)
+
+ fun dest_trigger (@{term trigger} $ tl $ t) = (HOLogic.dest_list tl, t)
+ | dest_trigger t = ([], t)
+
+ fun pat f ps (Const (@{const_name pat}, _) $ p) = SPat (rev (f p :: ps))
+ | pat f ps (Const (@{const_name nopat}, _) $ p) = SNoPat (rev (f p :: ps))
+ | pat f ps (Const (@{const_name andpat}, _) $ p $ t) = pat f (f p :: ps) t
+ | pat _ _ t = raise TERM ("pat", [t])
+
+ fun trans Ts t =
+ (case Term.strip_comb t of
+ (t1 as Const (qn, qT), [t2 as Abs (n, T, t3)]) =>
+ (case quantifier qn of
+ SOME q =>
+ let
+ val (vs, u) = group_quant qn [(n, T)] t3
+ val Us = map snd vs @ Ts
+ val (ps, b) = dest_trigger u
+ in SQuant (q, rev vs, map (pat (trans Us) []) ps, trans Us b) end
+ | NONE => raise TERM ("intermediate", [t]))
+ | (Const (@{const_name Let}, _), [t1, Abs (n, T, t2)]) =>
+ SLet ((n, T), trans Ts t1, trans (T :: Ts) t2)
+ | (Const (c as (@{const_name distinct}, _)), [t1]) =>
+ (* this is not type-correct, but will be corrected at a later stage *)
+ SApp (SConst c, map (trans Ts) (HOLogic.dest_list t1))
+ | (Const c, ts) =>
+ (case try HOLogic.dest_number t of
+ SOME (T, i) => SApp (SNum (i, T), [])
+ | NONE => SApp (SConst c, map (trans Ts) ts))
+ | (Free c, ts) => SApp (SFree c, map (trans Ts) ts)
+ | (Bound i, []) => SVar i
+ | _ => raise TERM ("intermediate", [t]))
+in
+fun intermediate ts = map (trans [] o HOLogic.dest_Trueprop) ts
+end
+
+
+(* Separate formulas from terms by adding special marker symbols ("term",
+ "formula"). Atoms "P" whose head symbol also occurs as function symbol are
+ rewritten to "term P = term True". Connectives and built-in predicates
+ occurring at term level are replaced by new constants, and theorems
+ specifying their meaning are added.
+*)
+local
+ (** Add the marker symbols "term" and "formulas" to separate formulas and
+ terms. **)
+
+ val connectives = map make_sconst [@{term True}, @{term False},
+ @{term Not}, @{term "op &"}, @{term "op |"}, @{term "op -->"},
+ @{term "op = :: bool => _"}]
+
+ fun note false c (ps, fs) = (insert (op =) c ps, fs)
+ | note true c (ps, fs) = (ps, insert (op =) c fs)
+
+ val term_marker = SConst (@{const_name term}, Term.dummyT)
+ val formula_marker = SConst (@{const_name formula}, Term.dummyT)
+ fun mark f true t = f true t #>> app term_marker o single
+ | mark f false t = f false t #>> app formula_marker o single
+ fun mark' f false t = f true t #>> app term_marker o single
+ | mark' f true t = f true t
+ val mark_term = app term_marker o single
+ fun lift_term_marker c ts =
+ let val rem = (fn SApp (SConst (@{const_name term}, _), [t]) => t | t => t)
+ in mark_term (SApp (c, map rem ts)) end
+ fun is_term (SApp (SConst (@{const_name term}, _), _)) = true
+ | is_term _ = false
+
+ fun either x = (fn y as SOME _ => y | _ => x)
+ fun get_loc loc i t =
+ (case t of
+ SVar j => if i = j then SOME loc else NONE
+ | SApp (SConst (@{const_name term}, _), us) => get_locs true i us
+ | SApp (SConst (@{const_name formula}, _), us) => get_locs false i us
+ | SApp (_, us) => get_locs loc i us
+ | SLet (_, u1, u2) => either (get_loc true i u1) (get_loc loc (i+1) u2)
+ | SQuant (_, vs, _, u) => get_loc loc (i + length vs) u)
+ and get_locs loc i ts = fold (either o get_loc loc i) ts NONE
+
+ fun sep loc t =
+ (case t of
+ SVar i => pair t
+ | SApp (c as SConst (@{const_name If}, _), u :: us) =>
+ mark sep false u ##>> fold_map (sep loc) us #>> app c o (op ::)
+ | SApp (c, us) =>
+ if not loc andalso member (op =) connectives c
+ then fold_map (sep loc) us #>> app c
+ else note loc c #> fold_map (mark' sep loc) us #>> app c
+ | SLet (v, u1, u2) =>
+ sep loc u2 #-> (fn u2' =>
+ mark sep (the (get_loc loc 0 u2')) u1 #>> (fn u1' =>
+ SLet (v, u1', u2')))
+ | SQuant (q, vs, ps, u) =>
+ fold_map (fold_map_pat (mark sep true)) ps ##>>
+ sep loc u #>> (fn (ps', u') =>
+ SQuant (q, vs, ps', u')))
+
+ (** Rewrite atoms. **)
+
+ val unterm_rule = @{lemma "term x == x" by (simp add: term_def)}
+ val unterm_conv = More_Conv.top_sweep_conv (K (Conv.rewr_conv unterm_rule))
+
+ val dest_word_type = (fn Type (@{type_name word}, [T]) => T | T => T)
+ fun instantiate [] _ = I
+ | instantiate (v :: _) T =
+ Term.subst_TVars [(v, dest_word_type (Term.domain_type T))]
+
+ fun dest_alls (Const (@{const_name All}, _) $ Abs (_, _, t)) = dest_alls t
+ | dest_alls t = t
+ val dest_iff = (fn (Const (@{const_name iff}, _) $ t $ _ ) => t | t => t)
+ val dest_eq = (fn (Const (@{const_name "op ="}, _) $ t $ _ ) => t | t => t)
+ val dest_not = (fn (@{term Not} $ t) => t | t => t)
+ val head_of = HOLogic.dest_Trueprop #> dest_alls #> dest_iff #> dest_not #>
+ dest_eq #> Term.head_of
+
+ fun prepare ctxt thm =
+ let
+ val rule = Conv.fconv_rule (unterm_conv ctxt) thm
+ val prop = Thm.prop_of thm
+ val inst = instantiate (Term.add_tvar_names prop [])
+ fun inst_for T = (singleton intermediate (inst T prop), rule)
+ in (make_sconst (head_of (Thm.prop_of rule)), inst_for) end
+
+ val logicals = map (prepare @{context})
+ @{lemma
+ "~ holds False"
+ "ALL p. holds (~ p) iff (~ holds p)"
+ "ALL p q. holds (p & q) iff (holds p & holds q)"
+ "ALL p q. holds (p | q) iff (holds p | holds q)"
+ "ALL p q. holds (p --> q) iff (holds p --> holds q)"
+ "ALL p q. holds (p iff q) iff (holds p iff holds q)"
+ "ALL p q. holds (p = q) iff (p = q)"
+ "ALL (a::int) b. holds (a < b) iff (a < b)"
+ "ALL (a::int) b. holds (a <= b) iff (a <= b)"
+ "ALL (a::real) b. holds (a < b) iff (a < b)"
+ "ALL (a::real) b. holds (a <= b) iff (a <= b)"
+ "ALL (a::'a::len0 word) b. holds (a < b) iff (a < b)"
+ "ALL (a::'a::len0 word) b. holds (a <= b) iff (a <= b)"
+ "ALL a b. holds (a <s b) iff (a <s b)"
+ "ALL a b. holds (a <=s b) iff (a <=s b)"
+ by (simp_all add: term_def iff_def)}
+
+ fun is_instance thy (SConst (n, T), SConst (m, U)) =
+ (n = m) andalso Sign.typ_instance thy (T, U)
+ | is_instance _ _ = false
+
+ fun lookup_logical thy (c as SConst (_, T)) =
+ AList.lookup (is_instance thy) logicals c
+ |> Option.map (fn inst_for => inst_for T)
+ | lookup_logical _ _ = NONE
+
+ val s_eq = make_sconst @{term "op = :: bool => _"}
+ val s_True = mark_term (SApp (make_sconst @{term True}, []))
+ fun holds (SApp (c, ts)) = SApp (s_eq, [lift_term_marker c ts, s_True])
+ | holds t = SApp (s_eq, [mark_term t, s_True])
+
+ val rewr_iff = (fn
+ SConst (@{const_name "op ="}, T as @{typ "bool => bool => bool"}) =>
+ SConst (@{const_name iff}, T)
+ | c => c)
+
+ fun rewrite ls =
+ let
+ fun rewr env loc t =
+ (case t of
+ SVar i => if not loc andalso nth env i then holds t else t
+ | SApp (c as SConst (@{const_name term}, _), [u]) =>
+ SApp (c, [rewr env true u])
+ | SApp (c as SConst (@{const_name formula}, _), [u]) =>
+ SApp (c, [rewr env false u])
+ | SApp (c, us) =>
+ let val f = if not loc andalso member (op =) ls c then holds else I
+ in f (SApp (rewr_iff c, map (rewr env loc) us)) end
+ | SLet (v, u1, u2) =>
+ SLet (v, rewr env loc u1, rewr (is_term u1 :: env) loc u2)
+ | SQuant (q, vs, ps, u) =>
+ let val e = replicate (length vs) true @ env
+ in SQuant (q, vs, map (map_pat (rewr e loc)) ps, rewr e loc u) end)
+ in map (rewr [] false) end
+in
+fun separate thy ts =
+ let
+ val (ts', (ps, fs)) = fold_map (sep false) ts ([], [])
+ val eq_name = (fn
+ (SConst (n, _), SConst (m, _)) => n = m
+ | (SFree (n, _), SFree (m, _)) => n = m
+ | _ => false)
+ val ls = filter (member eq_name fs) ps
+ val (us, thms) = split_list (map_filter (lookup_logical thy) fs)
+ in (thms, us @ rewrite ls ts') end
+end
+
+
+(* Collect the signature of intermediate terms, identify built-in symbols,
+ rename uninterpreted symbols and types, make bound variables unique.
+ We require @{term distinct} to be a built-in constant of the SMT solver.
+*)
+local
+ fun empty_nctxt p = (p, 1)
+ fun make_nctxt (pT, pf, pp) = (empty_nctxt pT, empty_nctxt (pf, pp))
+ fun fresh_name (p, i) = (p ^ string_of_int i, (p, i+1))
+ fun fresh_typ (nT, nfp) = fresh_name nT ||> (fn nT' => (nT', nfp))
+ fun fresh_fun loc (nT, ((pf, pp), i)) =
+ let val p = if loc then pf else pp
+ in fresh_name (p, i) ||> (fn (_, i') => (nT, ((pf, pp), i'))) end
+
+ val empty_sign = (Typtab.empty, Termtab.empty, Termtab.empty)
+ fun lookup_typ (typs, _, _) = Typtab.lookup typs
+ fun lookup_fun true (_, funs, _) = Termtab.lookup funs
+ | lookup_fun false (_, _, preds) = Termtab.lookup preds
+ fun add_typ x (typs, funs, preds) = (Typtab.update x typs, funs, preds)
+ fun add_fun true x (typs, funs, preds) = (typs, Termtab.update x funs, preds)
+ | add_fun false x (typs, funs, preds) = (typs, funs, Termtab.update x preds)
+ fun make_sign (typs, funs, preds) = Sign {
+ typs = map snd (Typtab.dest typs),
+ funs = map snd (Termtab.dest funs),
+ preds = map (apsnd fst o snd) (Termtab.dest preds) }
+ fun make_rtab (typs, funs, preds) =
+ let
+ val rTs = Typtab.dest typs |> map swap |> Symtab.make
+ val rts = Termtab.dest funs @ Termtab.dest preds
+ |> map (apfst fst o swap) |> Symtab.make
+ in Recon {typs=rTs, terms=rts} end
+
+ fun either f g x = (case f x of NONE => g x | y => y)
+
+ fun rep_typ (Builtins {builtin_typ, ...}) T (st as (vars, ns, sgn)) =
+ (case either builtin_typ (lookup_typ sgn) T of
+ SOME n => (n, st)
+ | NONE =>
+ let val (n, ns') = fresh_typ ns
+ in (n, (vars, ns', add_typ (T, n) sgn)) end)
+
+ fun rep_var bs (n, T) (vars, ns, sgn) =
+ let val (n', vars') = fresh_name vars
+ in (vars', ns, sgn) |> rep_typ bs T |>> pair n' end
+
+ fun rep_fun bs loc t T i (st as (_, _, sgn0)) =
+ (case lookup_fun loc sgn0 t of
+ SOME (n, _) => (n, st)
+ | NONE =>
+ let
+ val (Us, U) = dest_funT i T
+ val (uns, (vars, ns, sgn)) =
+ st |> fold_map (rep_typ bs) Us ||>> rep_typ bs U
+ val (n, ns') = fresh_fun loc ns
+ in (n, (vars, ns', add_fun loc (t, (n, uns)) sgn)) end)
+
+ fun rep_num (bs as Builtins {builtin_num, ...}) (i, T) st =
+ (case builtin_num (i, T) of
+ SOME n => (n, st)
+ | NONE => rep_fun bs true (HOLogic.mk_number T i) T 0 st)
+in
+fun signature_of prefixes markers builtins thy ts =
+ let
+ val Prefixes {var_prefix, typ_prefix, fun_prefix, pred_prefix} = prefixes
+ val Markers {formula_marker, term_marker} = markers
+ val Builtins {builtin_fun, ...} = builtins
+
+ fun sign loc t =
+ (case t of
+ SVar i => pair (SVar i)
+ | SApp (c as SConst (@{const_name term}, _), [u]) =>
+ sign true u #>> app term_marker o single
+ | SApp (c as SConst (@{const_name formula}, _), [u]) =>
+ sign false u #>> app formula_marker o single
+ | SApp (SConst (c as (_, T)), ts) =>
+ (case builtin_lookup (builtin_fun loc) thy c ts of
+ SOME (n, ts') => fold_map (sign loc) ts' #>> app n
+ | NONE =>
+ rep_fun builtins loc (Const c) T (length ts) ##>>
+ fold_map (sign loc) ts #>> SApp)
+ | SApp (SFree (c as (_, T)), ts) =>
+ rep_fun builtins loc (Free c) T (length ts) ##>>
+ fold_map (sign loc) ts #>> SApp
+ | SApp (SNum n, _) => rep_num builtins n #>> (fn n => SApp (n, []))
+ | SLet (v, u1, u2) =>
+ rep_var builtins v #-> (fn v' =>
+ sign loc u1 ##>> sign loc u2 #>> (fn (u1', u2') =>
+ SLet (v', u1', u2')))
+ | SQuant (q, vs, ps, u) =>
+ fold_map (rep_var builtins) vs ##>>
+ fold_map (fold_map_pat (sign loc)) ps ##>>
+ sign loc u #>> (fn ((vs', ps'), u') =>
+ SQuant (q, vs', ps', u')))
+ in
+ (empty_nctxt var_prefix, make_nctxt (typ_prefix, fun_prefix, pred_prefix),
+ empty_sign)
+ |> fold_map (sign false) ts
+ |> (fn (us, (_, _, sgn)) => (make_rtab sgn, (make_sign sgn, us)))
+ end
+end
+
+
+(* Combination of all translation functions and invocation of serialization. *)
+
+fun translate config thy thms stream =
+ let val Config {strict, prefixes, markers, builtins, serialize} = config
+ in
+ map Thm.prop_of thms
+ |> SMT_Monomorph.monomorph thy
+ |> intermediate
+ |> (if strict then separate thy else pair [])
+ ||>> signature_of prefixes markers builtins thy
+ ||> (fn (sgn, ts) => serialize sgn ts stream)
+ |> (fn ((thms', rtab), _) => (rtab, thms' @ thms))
+ end
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/smtlib_interface.ML Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,168 @@
+(* Title: HOL/SMT/Tools/smtlib_interface.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Interface to SMT solvers based on the SMT-LIB format.
+*)
+
+signature SMTLIB_INTERFACE =
+sig
+ val basic_builtins: SMT_Translate.builtins
+ val default_attributes: string list
+ val gen_interface: SMT_Translate.builtins -> string list ->
+ SMT_Solver.interface
+ val interface: SMT_Solver.interface
+end
+
+structure SMTLIB_Interface: SMTLIB_INTERFACE =
+struct
+
+structure T = SMT_Translate
+
+
+(* built-in types, functions and predicates *)
+
+val builtin_typ = (fn
+ @{typ int} => SOME "Int"
+ | @{typ real} => SOME "Real"
+ | _ => NONE)
+
+val builtin_num = (fn
+ (i, @{typ int}) => SOME (string_of_int i)
+ | (i, @{typ real}) => SOME (string_of_int i ^ ".0")
+ | _ => NONE)
+
+val builtin_funcs = T.builtin_make [
+ (@{term If}, "ite"),
+ (@{term "uminus :: int => _"}, "~"),
+ (@{term "plus :: int => _"}, "+"),
+ (@{term "minus :: int => _"}, "-"),
+ (@{term "times :: int => _"}, "*"),
+ (@{term "uminus :: real => _"}, "~"),
+ (@{term "plus :: real => _"}, "+"),
+ (@{term "minus :: real => _"}, "-"),
+ (@{term "times :: real => _"}, "*") ]
+
+val builtin_preds = T.builtin_make [
+ (@{term True}, "true"),
+ (@{term False}, "false"),
+ (@{term Not}, "not"),
+ (@{term "op &"}, "and"),
+ (@{term "op |"}, "or"),
+ (@{term "op -->"}, "implies"),
+ (@{term "op iff"}, "iff"),
+ (@{term If}, "if_then_else"),
+ (@{term distinct}, "distinct"),
+ (@{term "op ="}, "="),
+ (@{term "op < :: int => _"}, "<"),
+ (@{term "op <= :: int => _"}, "<="),
+ (@{term "op < :: real => _"}, "<"),
+ (@{term "op <= :: real => _"}, "<=") ]
+
+
+(* serialization *)
+
+fun wr s stream = (TextIO.output (stream, s); stream)
+fun wr_line f = f #> wr "\n"
+
+fun sep f = wr " " #> f
+fun par f = sep (wr "(" #> f #> wr ")")
+
+fun wr1 s = sep (wr s)
+fun wrn f n = (fn [] => wr1 n | ts => par (wr n #> fold f ts))
+fun ins s f = (fn [] => I | x::xs => f x #> fold (fn x => wr1 s #> f x) xs)
+
+val term_marker = "__term"
+val formula_marker = "__form"
+fun dest_marker (T.SApp ("__term", [t])) = SOME (true, t)
+ | dest_marker (T.SApp ("__form", [t])) = SOME (false, t)
+ | dest_marker _ = NONE
+
+val tvar = prefix "?"
+val fvar = prefix "$"
+
+fun wr_expr loc env t =
+ (case t of
+ T.SVar i => wr1 (nth env i)
+ | T.SApp (n, ts) =>
+ (case dest_marker t of
+ SOME (loc', t') => wr_expr loc' env t'
+ | NONE => wrn (wr_expr loc env) n ts)
+ | T.SLet ((v, _), t1, t2) =>
+ if loc then raise TERM ("SMTLIB: let expression in term", [])
+ else
+ let
+ val (loc', t1') = the (dest_marker t1)
+ val (kind, v') = if loc' then ("let", tvar v) else ("flet", fvar v)
+ in
+ par (wr kind #> par (wr v' #> wr_expr loc' env t1') #>
+ wr_expr loc (v' :: env) t2)
+ end
+ | T.SQuant (q, vs, ps, b) =>
+ let
+ val wr_quant = wr o (fn T.SForall => "forall" | T.SExists => "exists")
+ fun wr_var (n, s) = par (wr (tvar n) #> wr1 s)
+
+ val wre = wr_expr loc (map (tvar o fst) (rev vs) @ env)
+
+ fun wrp s ts = wr1 (":" ^ s ^ "{") #> ins "," wre ts #> wr1 "}"
+ fun wr_pat (T.SPat ts) = wrp "pat" ts
+ | wr_pat (T.SNoPat ts) = wrp "nopat" ts
+ in par (wr_quant q #> fold wr_var vs #> wre b #> fold wr_pat ps) end)
+
+fun serialize attributes (T.Sign {typs, funs, preds}) ts stream =
+ let
+ fun wr_decl (n, Ts) = wr_line (sep (par (wr n #> fold wr1 Ts)))
+ in
+ stream
+ |> wr_line (wr "(benchmark Isabelle")
+ |> fold (wr_line o wr) attributes
+ |> length typs > 0 ?
+ wr_line (wr ":extrasorts" #> par (fold wr1 typs))
+ |> length funs > 0 ? (
+ wr_line (wr ":extrafuns (") #>
+ fold (wr_decl o apsnd (fn (Ts, T) => Ts @ [T])) funs #>
+ wr_line (wr " )"))
+ |> length preds > 0 ? (
+ wr_line (wr ":extrapreds (") #>
+ fold wr_decl preds #>
+ wr_line (wr " )"))
+ |> fold (fn t => wr ":assumption" #> wr_line (wr_expr false [] t)) ts
+ |> wr_line (wr ":formula true")
+ |> wr_line (wr ")")
+ |> K ()
+ end
+
+
+(* SMT solver interface using the SMT-LIB input format *)
+
+val basic_builtins = T.Builtins {
+ builtin_typ = builtin_typ,
+ builtin_num = builtin_num,
+ builtin_fun = (fn true => builtin_funcs | false => builtin_preds) }
+
+val default_attributes = [":logic AUFLIRA", ":status unknown"]
+
+fun gen_interface builtins attributes = SMT_Solver.Interface {
+ normalize = [
+ SMT_Normalize.RewriteTrivialLets,
+ SMT_Normalize.RewriteNegativeNumerals,
+ SMT_Normalize.RewriteNaturalNumbers,
+ SMT_Normalize.AddAbsMinMaxRules,
+ SMT_Normalize.AddPairRules,
+ SMT_Normalize.AddFunUpdRules ],
+ translate = T.Config {
+ strict = true,
+ prefixes = T.Prefixes {
+ var_prefix = "x",
+ typ_prefix = "T",
+ fun_prefix = "uf_",
+ pred_prefix = "up_" },
+ markers = T.Markers {
+ term_marker = term_marker,
+ formula_marker = formula_marker },
+ builtins = builtins,
+ serialize = serialize attributes }}
+
+val interface = gen_interface basic_builtins default_attributes
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/yices_solver.ML Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,52 @@
+(* Title: HOL/SMT/Tools/yices_solver.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Interface of the SMT solver Yices.
+*)
+
+signature YICES_SOLVER =
+sig
+ val setup: theory -> theory
+end
+
+structure Yices_Solver: YICES_SOLVER =
+struct
+
+val solver_name = "yices"
+val env_var = "YICES_SOLVER"
+
+val options = ["--evidence", "--smtlib"]
+
+fun cex_kind true = "Counterexample"
+ | cex_kind false = "Possible counterexample"
+
+fun raise_cex real ctxt rtab ls =
+ let val p = Pretty.big_list (cex_kind real ^ " found:") (map Pretty.str ls)
+ in error (Pretty.string_of p) end
+
+structure S = SMT_Solver
+
+fun core_oracle (SMT_Solver.ProofData {context, output, recon, ...}) =
+ let
+ val empty_line = (fn "" => true | _ => false)
+ val split_first = (fn [] => ("", []) | l :: ls => (l, ls))
+ val (l, ls) = split_first (dropwhile empty_line output)
+ in
+ if String.isPrefix "unsat" l then @{cprop False}
+ else if String.isPrefix "sat" l then raise_cex true context recon ls
+ else if String.isPrefix "unknown" l then raise_cex false context recon ls
+ else error (solver_name ^ " failed")
+ end
+
+fun smtlib_solver oracle _ =
+ SMT_Solver.SolverConfig {
+ name = {env_var=env_var, remote_name=solver_name},
+ interface = SMTLIB_Interface.interface,
+ arguments = options,
+ reconstruct = oracle }
+
+val setup =
+ Thm.add_oracle (Binding.name solver_name, core_oracle) #-> (fn (_, oracle) =>
+ SMT_Solver.add_solver (solver_name, smtlib_solver oracle))
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/z3_interface.ML Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,98 @@
+(* Title: HOL/SMT/Tools/z3_interface.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Interface to Z3 based on a relaxed version of SMT-LIB.
+*)
+
+signature Z3_INTERFACE =
+sig
+ val interface: SMT_Solver.interface
+end
+
+structure Z3_Interface: Z3_INTERFACE =
+struct
+
+structure T = SMT_Translate
+
+fun mk_name1 n i = n ^ "[" ^ string_of_int i ^ "]"
+fun mk_name2 n i j = n ^ "[" ^ string_of_int i ^ ":" ^ string_of_int j ^ "]"
+
+val builtin_typ = (fn
+ @{typ int} => SOME "Int"
+ | @{typ real} => SOME "Real"
+ | Type (@{type_name word}, [T]) =>
+ Option.map (mk_name1 "BitVec") (try T.dest_binT T)
+ | _ => NONE)
+
+val builtin_num = (fn
+ (i, @{typ int}) => SOME (string_of_int i)
+ | (i, @{typ real}) => SOME (string_of_int i ^ ".0")
+ | (i, Type (@{type_name word}, [T])) =>
+ Option.map (mk_name1 ("bv" ^ string_of_int i)) (try T.dest_binT T)
+ | _ => NONE)
+
+val builtin_funcs = T.builtin_make [
+ (@{term If}, "ite"),
+ (@{term "uminus :: int => _"}, "~"),
+ (@{term "plus :: int => _"}, "+"),
+ (@{term "minus :: int => _"}, "-"),
+ (@{term "times :: int => _"}, "*"),
+ (@{term "op div :: int => _"}, "div"),
+ (@{term "op mod :: int => _"}, "mod"),
+ (@{term "op rem"}, "rem"),
+ (@{term "uminus :: real => _"}, "~"),
+ (@{term "plus :: real => _"}, "+"),
+ (@{term "minus :: real => _"}, "-"),
+ (@{term "times :: real => _"}, "*"),
+ (@{term "op / :: real => _"}, "/"),
+ (@{term "bitNOT :: 'a::len0 word => _"}, "bvnot"),
+ (@{term "op AND :: 'a::len0 word => _"}, "bvand"),
+ (@{term "op OR :: 'a::len0 word => _"}, "bvor"),
+ (@{term "op XOR :: 'a::len0 word => _"}, "bvxor"),
+ (@{term "uminus :: 'a::len0 word => _"}, "bvneg"),
+ (@{term "op + :: 'a::len0 word => _"}, "bvadd"),
+ (@{term "op - :: 'a::len0 word => _"}, "bvsub"),
+ (@{term "op * :: 'a::len0 word => _"}, "bvmul"),
+ (@{term "op div :: 'a::len0 word => _"}, "bvudiv"),
+ (@{term "op mod :: 'a::len0 word => _"}, "bvurem"),
+ (@{term "op sdiv"}, "bvsdiv"),
+ (@{term "op smod"}, "bvsmod"),
+ (@{term "op srem"}, "bvsrem"),
+ (@{term word_cat}, "concat"),
+ (@{term bv_shl}, "bvshl"),
+ (@{term bv_lshr}, "bvlshr"),
+ (@{term bv_ashr}, "bvashr")]
+ |> T.builtin_add (@{term slice}, T.bv_extract (mk_name2 "extract"))
+ |> T.builtin_add (@{term ucast}, T.bv_extend (mk_name1 "zero_extend"))
+ |> T.builtin_add (@{term scast}, T.bv_extend (mk_name1 "sign_extend"))
+ |> T.builtin_add (@{term word_rotl}, T.bv_rotate (mk_name1 "rotate_left"))
+ |> T.builtin_add (@{term word_rotr}, T.bv_rotate (mk_name1 "rotate_right"))
+
+val builtin_preds = T.builtin_make [
+ (@{term True}, "true"),
+ (@{term False}, "false"),
+ (@{term Not}, "not"),
+ (@{term "op &"}, "and"),
+ (@{term "op |"}, "or"),
+ (@{term "op -->"}, "implies"),
+ (@{term "op iff"}, "iff"),
+ (@{term If}, "if_then_else"),
+ (@{term distinct}, "distinct"),
+ (@{term "op ="}, "="),
+ (@{term "op < :: int => _"}, "<"),
+ (@{term "op <= :: int => _"}, "<="),
+ (@{term "op < :: real => _"}, "<"),
+ (@{term "op <= :: real => _"}, "<="),
+ (@{term "op < :: 'a::len0 word => _"}, "bvult"),
+ (@{term "op <= :: 'a::len0 word => _"}, "bvule"),
+ (@{term word_sless}, "bvslt"),
+ (@{term word_sle}, "bvsle")]
+
+val builtins = T.Builtins {
+ builtin_typ = builtin_typ,
+ builtin_num = builtin_num,
+ builtin_fun = (fn true => builtin_funcs | false => builtin_preds) }
+
+val interface = SMTLIB_Interface.gen_interface builtins []
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/z3_model.ML Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,159 @@
+(* Title: HOL/SMT/Tools/z3_model.ML
+ Author: Sascha Boehme and Philipp Meyer, TU Muenchen
+
+Parser for counterexamples generated by Z3.
+*)
+
+signature Z3_MODEL =
+sig
+ val parse_counterex: SMT_Translate.recon -> string list -> term list
+end
+
+structure Z3_Model: Z3_MODEL =
+struct
+
+(* parsing primitives *)
+
+fun lift f (x, y) = apsnd (pair x) (f y)
+fun lift' f v (x, y) = apsnd (rpair y) (f v x)
+
+fun $$ s = lift (Scan.$$ s)
+fun this s = lift (Scan.this_string s)
+
+fun par scan = $$ "(" |-- scan --| $$ ")"
+
+val digit = (fn
+ "0" => SOME 0 | "1" => SOME 1 | "2" => SOME 2 | "3" => SOME 3 |
+ "4" => SOME 4 | "5" => SOME 5 | "6" => SOME 6 | "7" => SOME 7 |
+ "8" => SOME 8 | "9" => SOME 9 | _ => NONE)
+
+val nat_num = Scan.repeat1 (Scan.some digit) >>
+ (fn ds => fold (fn d => fn i => i * 10 + d) ds 0)
+val int_num = Scan.optional (Scan.$$ "-" >> K (fn i => ~i)) I :|--
+ (fn sign => nat_num >> sign)
+
+val is_char = Symbol.is_ascii_letter orf Symbol.is_ascii_digit orf
+ member (op =) (explode "_+*-/%~=<>$&|?!.@^#")
+val name = Scan.many1 is_char >> implode
+
+
+(* parsing counterexamples *)
+
+datatype context = Context of {
+ ttab: term Symtab.table,
+ nctxt: Name.context,
+ vtab: term Inttab.table }
+
+fun make_context (ttab, nctxt, vtab) =
+ Context {ttab=ttab, nctxt=nctxt, vtab=vtab}
+
+fun empty_context (SMT_Translate.Recon {terms, ...}) =
+ let
+ val ns = Symtab.fold (Term.add_free_names o snd) terms []
+ val nctxt = Name.make_context ns
+ in make_context (terms, nctxt, Inttab.empty) end
+
+fun map_context f (Context {ttab, nctxt, vtab}) =
+ make_context (f (ttab, nctxt, vtab))
+
+fun fresh_name (cx as Context {nctxt, ...}) =
+ let val (n, nctxt') = yield_singleton Name.variants "" nctxt
+ in (n, map_context (fn (ttab, _, vtab) => (ttab, nctxt', vtab)) cx) end
+
+fun ident name (cx as Context {ttab, ...}) =
+ (case Symtab.lookup ttab name of
+ SOME t => (t, cx)
+ | NONE =>
+ let val (n, cx') = fresh_name cx
+ in (Free (n, Term.dummyT), cx) end)
+
+fun set_value t i = map_context (fn (ttab, nctxt, vtab) =>
+ (ttab, nctxt, Inttab.update (i, t) vtab))
+
+fun get_value T i (cx as Context {vtab, ...}) =
+ (case Inttab.lookup vtab i of
+ SOME t => (t, cx)
+ | _ => cx |> fresh_name |-> (fn n =>
+ let val t = Free (n, T)
+ in set_value t i #> pair t end))
+
+
+fun space s = lift (Scan.many Symbol.is_ascii_blank) s
+fun spaced p = p --| space
+
+val key = spaced (lift name) #-> lift' ident
+val mapping = spaced (this "->")
+fun in_braces p = spaced ($$ "{") |-- p --| spaced ($$ "}")
+
+val bool_expr =
+ this "true" >> K @{term True} ||
+ this "false" >> K @{term False}
+
+fun number_expr T =
+ let
+ val num = lift int_num >> HOLogic.mk_number T
+ fun frac n d = Const (@{const_name divide}, T --> T --> T) $ n $ d
+ in num :|-- (fn n => Scan.optional ($$ "/" |-- num >> frac n) n) end
+
+val value = this "val!" |-- lift nat_num
+fun value_expr T = value #-> lift' (get_value T)
+
+val domT = Term.domain_type
+val ranT = Term.range_type
+fun const_array T t = Abs ("x", T, t)
+fun upd_array T ((a, t), u) =
+ Const (@{const_name fun_upd}, [T, domT T, ranT T] ---> T) $ a $ t $ u
+fun array_expr T st = if not (can domT T) then Scan.fail st else st |> (
+ par (spaced (this "const") |-- expr (ranT T)) >> const_array (domT T) ||
+ par (spaced (this "store") |-- spaced (array_expr T) --
+ expr (Term.domain_type T) -- expr (Term.range_type T)) >> upd_array T)
+
+and expr T st =
+ spaced (bool_expr || number_expr T || value_expr T || array_expr T) st
+
+fun const_val t =
+ let fun rep u = spaced value #-> apfst o set_value u #> pair []
+ in
+ if can HOLogic.dest_number t then rep t
+ else if t = @{term TT} then rep @{term True}
+ else expr (Term.fastype_of t) >> (fn u => [HOLogic.mk_eq (t, u)])
+ end
+
+fun func_value T = mapping |-- expr T
+
+fun first_pat T =
+ let
+ fun args T = if not (can domT T) then Scan.succeed [] else
+ expr (domT T) ::: args (ranT T)
+ fun value ts = func_value (snd (SMT_Translate.dest_funT (length ts) T))
+ in args T :-- value end
+
+fun func_pat (Ts, T) = fold_map expr Ts -- func_value T
+fun else_pat (Ts, T) =
+ let fun else_arg T cx = cx |> fresh_name |>> (fn n => Free (n, T))
+ in
+ fold_map (lift' else_arg) Ts ##>>
+ spaced (this "else") |-- func_value T
+ end
+fun next_pats T (fts as (ts, _)) =
+ let val Tps = SMT_Translate.dest_funT (length ts) T
+ in Scan.repeat (func_pat Tps) @@@ (else_pat Tps >> single) >> cons fts end
+
+fun mk_def' f (ts, t) = HOLogic.mk_eq (Term.list_comb (f, ts), t)
+fun mk_def (Const (@{const_name apply}, _)) (u :: us, t) = mk_def' u (us, t)
+ | mk_def f (ts, t) = mk_def' f (ts, t)
+fun func_pats t =
+ let val T = Term.fastype_of t
+ in first_pat T :|-- next_pats T >> map (mk_def t) end
+
+val assign =
+ key --| mapping :|-- (fn t => in_braces (func_pats t) || const_val t)
+
+val cex = space |-- Scan.repeat assign
+
+fun parse_counterex recon ls =
+ (empty_context recon, explode (cat_lines ls))
+ |> Scan.catch (Scan.finite' Symbol.stopper (Scan.error cex))
+ |> flat o fst
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/Tools/z3_solver.ML Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,83 @@
+(* Title: HOL/SMT/Tools/z3_solver.ML
+ Author: Sascha Boehme, TU Muenchen
+
+Interface of the SMT solver Z3.
+*)
+
+signature Z3_SOLVER =
+sig
+ val proofs: bool Config.T
+ val options: string Config.T
+
+ val setup: theory -> theory
+end
+
+structure Z3_Solver: Z3_SOLVER =
+struct
+
+val solver_name = "z3"
+val env_var = "Z3_SOLVER"
+
+val (proofs, proofs_setup) = Attrib.config_bool "z3_proofs" false
+val (options, options_setup) = Attrib.config_string "z3_options" ""
+
+fun add xs ys = ys @ xs
+
+fun get_options ctxt =
+ ["MODEL=true", "PRE_SIMPLIFY_EXPR=false", "CONTEXT_SIMPLIFIER=false"]
+ |> Config.get ctxt proofs ? add ["DISPLAY_PROOF=true", "PROOF_MODE=2"]
+ |> add (space_explode " " (Config.get ctxt options))
+
+fun pretty_config context = [
+ Pretty.str ("With proofs: " ^
+ (if Config.get_generic context proofs then "true" else "false")),
+ Pretty.str ("Options: " ^
+ space_implode " " (get_options (Context.proof_of context))) ]
+
+fun cmdline_options ctxt =
+ get_options ctxt
+ |> add ["-smt"]
+
+fun raise_cex real recon ls =
+ let val cex = Z3_Model.parse_counterex recon ls
+ in raise SMT_Solver.SMT_COUNTEREXAMPLE (real, cex) end
+
+fun check_unsat recon output =
+ let
+ val raw = not o String.isPrefix "WARNING" orf String.isPrefix "ERROR"
+ val (ls, l) = the_default ([], "") (try split_last (filter raw output))
+ in
+ if String.isPrefix "unsat" l then ls
+ else if String.isPrefix "sat" l then raise_cex true recon ls
+ else if String.isPrefix "unknown" l then raise_cex false recon ls
+ else error (solver_name ^ " failed")
+ end
+
+fun core_oracle (SMT_Solver.ProofData {output, recon, ...}) =
+ check_unsat recon output
+ |> K @{cprop False}
+
+(* FIXME
+fun prover (SMT_Solver.ProofData {context, output, recon, assms}) =
+ check_unsat recon output
+ |> Z3_Proof.reconstruct context assms recon
+*)
+
+fun solver oracle ctxt =
+ let val with_proof = Config.get ctxt proofs
+ in
+ SMT_Solver.SolverConfig {
+ name = {env_var=env_var, remote_name=solver_name},
+ interface = Z3_Interface.interface,
+ arguments = cmdline_options ctxt,
+ reconstruct = (*FIXME:if with_proof then prover else*) oracle }
+ end
+
+val setup =
+ proofs_setup #>
+ options_setup #>
+ Thm.add_oracle (Binding.name solver_name, core_oracle) #-> (fn (_, oracle) =>
+ SMT_Solver.add_solver (solver_name, solver oracle)) #>
+ SMT_Solver.add_solver_info (solver_name, pretty_config)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/etc/settings Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,13 @@
+ISABELLE_SMT="$COMPONENT"
+
+REMOTE_SMT_SOLVER="$ISABELLE_SMT/lib/scripts/remote_smt.pl"
+
+REMOTE_SMT_URL="http://www4.in.tum.de/smt/smt"
+
+#
+# Paths to local SMT solvers:
+#
+# CVC_SOLVER=PATH
+# YICES_SOLVER=PATH
+# Z3_SOLVER=PATH
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/SMT/lib/scripts/remote_smt.pl Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,42 @@
+#
+# Script to invoke remote SMT solvers.
+# Author: Sascha Boehme, TU Muenchen
+#
+
+use strict;
+use LWP;
+
+
+# environment
+
+my $remote_smt_url = $ENV{"REMOTE_SMT_URL"};
+
+
+# arguments
+
+my $solver = $ARGV[0];
+my @options = @ARGV[1 .. ($#ARGV - 2)];
+my $problem_file = $ARGV[-2];
+my $output_file = $ARGV[-1];
+
+
+# call solver
+
+my $agent = LWP::UserAgent->new;
+$agent->agent("SMT-Request");
+$agent->timeout(180);
+my $response = $agent->post($remote_smt_url, [
+ "Solver" => $solver,
+ "Options" => join(" ", @options),
+ "Problem" => [$problem_file] ],
+ "Content_Type" => "form-data");
+if (not $response->is_success) {
+ print "HTTP-Error: " . $response->message . "\n";
+ exit 1;
+}
+else {
+ open(FILE, ">$output_file");
+ print FILE $response->content;
+ close(FILE);
+}
+
--- a/src/HOL/SetInterval.thy Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/SetInterval.thy Tue Sep 22 13:52:19 2009 +1000
@@ -514,6 +514,30 @@
qed
+subsubsection {* Proving Inclusions and Equalities between Unions *}
+
+lemma UN_UN_finite_eq: "(\<Union>n::nat. \<Union>i\<in>{0..<n}. A i) = (\<Union>n. A n)"
+ by (auto simp add: atLeast0LessThan)
+
+lemma UN_finite_subset: "(!!n::nat. (\<Union>i\<in>{0..<n}. A i) \<subseteq> C) \<Longrightarrow> (\<Union>n. A n) \<subseteq> C"
+ by (subst UN_UN_finite_eq [symmetric]) blast
+
+lemma UN_finite2_subset:
+ assumes sb: "!!n::nat. (\<Union>i\<in>{0..<n}. A i) \<subseteq> (\<Union>i\<in>{0..<n}. B i)"
+ shows "(\<Union>n. A n) \<subseteq> (\<Union>n. B n)"
+proof (rule UN_finite_subset)
+ fix n
+ have "(\<Union>i\<in>{0..<n}. A i) \<subseteq> (\<Union>i\<in>{0..<n}. B i)" by (rule sb)
+ also have "... \<subseteq> (\<Union>n::nat. \<Union>i\<in>{0..<n}. B i)" by blast
+ also have "... = (\<Union>n. B n)" by (simp add: UN_UN_finite_eq)
+ finally show "(\<Union>i\<in>{0..<n}. A i) \<subseteq> (\<Union>n. B n)" .
+qed
+
+lemma UN_finite2_eq:
+ "(!!n::nat. (\<Union>i\<in>{0..<n}. A i) = (\<Union>i\<in>{0..<n}. B i)) \<Longrightarrow> (\<Union>n. A n) = (\<Union>n. B n)"
+ by (iprover intro: subset_antisym UN_finite2_subset elim: equalityE)
+
+
subsubsection {* Cardinality *}
lemma card_lessThan [simp]: "card {..<u} = u"
--- a/src/HOL/Tools/ATP_Manager/atp_wrapper.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/ATP_Manager/atp_wrapper.ML Tue Sep 22 13:52:19 2009 +1000
@@ -79,14 +79,17 @@
preparer goal_cls chain_ths the_axiom_clauses the_filtered_clauses thy
(* write out problem file and call prover *)
- val perl_script = "perl -w $ISABELLE_ATP_MANAGER/lib/scripts/local_atp.pl"
- fun cmd_line probfile = perl_script ^ " '" ^ space_implode " "
- [File.shell_path cmd, args, File.platform_path probfile] ^ "'"
+ fun cmd_line probfile = "TIMEFORMAT='%3U'; { time " ^ space_implode " "
+ [File.shell_path cmd, args, File.platform_path probfile] ^ " ; } 2>&1"
fun split_time s =
let
val split = String.tokens (fn c => str c = "\n")
val (proof, t) = s |> split |> split_last |> apfst cat_lines
- val time = Scan.many1 Symbol.is_ascii_digit >> (fst o read_int)
+ fun as_num f = f >> (fst o read_int)
+ val num = as_num (Scan.many1 Symbol.is_ascii_digit)
+ val digit = Scan.one Symbol.is_ascii_digit
+ val num3 = as_num (digit ::: digit ::: (digit >> single))
+ val time = num --| Scan.$$ "." -- num3 >> (fn (a, b) => a * 1000 + b)
val as_time = the_default 0 o Scan.read Symbol.stopper time o explode
in (proof, as_time t) end
fun run_on probfile =
@@ -97,7 +100,7 @@
else error ("Bad executable: " ^ Path.implode cmd)
(* if problemfile has not been exported, delete problemfile; otherwise export proof, too *)
- fun cleanup probfile = if destdir' = "" then File.rm probfile else ()
+ fun cleanup probfile = if destdir' = "" then try File.rm probfile else NONE
fun export probfile (((proof, _), _), _) = if destdir' = "" then ()
else File.write (Path.explode (Path.implode probfile ^ "_proof")) proof
--- a/src/HOL/Tools/ATP_Manager/lib/scripts/local_atp.pl Thu Sep 17 14:17:37 2009 +1000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,15 +0,0 @@
-use POSIX qw(setsid);
-
-$SIG{'INT'} = "DEFAULT";
-
-defined (my $pid = fork) or die "$!";
-if (not $pid) {
- POSIX::setsid or die $!;
- exec @ARGV;
-}
-else {
- wait;
- my ($user, $system, $cuser, $csystem) = times;
- my $time = ($user + $cuser) * 1000;
- print "$time\n";
-}
--- a/src/HOL/Tools/Function/decompose.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/Function/decompose.ML Tue Sep 22 13:52:19 2009 +1000
@@ -29,7 +29,7 @@
fun prove_chain c1 c2 D =
if is_some (Termination.get_chain D c1 c2) then D else
let
- val goal = HOLogic.mk_eq (HOLogic.mk_binop @{const_name "Relation.rel_comp"} (c1, c2),
+ val goal = HOLogic.mk_eq (HOLogic.mk_binop @{const_name Relation.rel_comp} (c1, c2),
Const (@{const_name Set.empty}, fastype_of c1))
|> HOLogic.mk_Trueprop (* "C1 O C2 = {}" *)
--- a/src/HOL/Tools/Function/fundef_common.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/Function/fundef_common.ML Tue Sep 22 13:52:19 2009 +1000
@@ -16,7 +16,7 @@
fun PROFILE msg = if !profile then timeap_msg msg else I
-val acc_const_name = @{const_name "accp"}
+val acc_const_name = @{const_name accp}
fun mk_acc domT R =
Const (acc_const_name, (domT --> domT --> HOLogic.boolT) --> domT --> HOLogic.boolT) $ R
--- a/src/HOL/Tools/Function/fundef_core.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/Function/fundef_core.ML Tue Sep 22 13:52:19 2009 +1000
@@ -769,7 +769,7 @@
val Rrel = Free ("R", HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT)))
val inrel_R = Const (@{const_name FunDef.in_rel}, HOLogic.mk_setT (HOLogic.mk_prodT (domT, domT)) --> fastype_of R) $ Rrel
- val wfR' = cterm_of thy (HOLogic.mk_Trueprop (Const (@{const_name "Wellfounded.wfP"}, (domT --> domT --> boolT) --> boolT) $ R')) (* "wf R'" *)
+ val wfR' = cterm_of thy (HOLogic.mk_Trueprop (Const (@{const_name Wellfounded.wfP}, (domT --> domT --> boolT) --> boolT) $ R')) (* "wf R'" *)
(* Inductive Hypothesis: !!z. (z,x):R' ==> z : acc R *)
val ihyp = Term.all domT $ Abs ("z", domT,
--- a/src/HOL/Tools/Function/induction_scheme.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/Function/induction_scheme.ML Tue Sep 22 13:52:19 2009 +1000
@@ -152,7 +152,7 @@
end
fun mk_wf ctxt R (IndScheme {T, ...}) =
- HOLogic.Trueprop $ (Const (@{const_name "wf"}, mk_relT T --> HOLogic.boolT) $ R)
+ HOLogic.Trueprop $ (Const (@{const_name wf}, mk_relT T --> HOLogic.boolT) $ R)
fun mk_ineqs R (IndScheme {T, cases, branches}) =
let
--- a/src/HOL/Tools/Function/lexicographic_order.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/Function/lexicographic_order.ML Tue Sep 22 13:52:19 2009 +1000
@@ -26,7 +26,7 @@
val mlexT = (domT --> HOLogic.natT) --> relT --> relT
fun mk_ms [] = Const (@{const_name Set.empty}, relT)
| mk_ms (f::fs) =
- Const (@{const_name "mlex_prod"}, mlexT) $ f $ mk_ms fs
+ Const (@{const_name mlex_prod}, mlexT) $ f $ mk_ms fs
in
mk_ms mfuns
end
--- a/src/HOL/Tools/Function/measure_functions.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/Function/measure_functions.ML Tue Sep 22 13:52:19 2009 +1000
@@ -22,7 +22,7 @@
val description = "Rules that guide the heuristic generation of measure functions"
);
-fun mk_is_measures t = Const (@{const_name "is_measure"}, fastype_of t --> HOLogic.boolT) $ t
+fun mk_is_measures t = Const (@{const_name is_measure}, fastype_of t --> HOLogic.boolT) $ t
fun find_measures ctxt T =
DEPTH_SOLVE (resolve_tac (Measure_Heuristic_Rules.get ctxt) 1)
--- a/src/HOL/Tools/Function/sum_tree.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/Function/sum_tree.ML Tue Sep 22 13:52:19 2009 +1000
@@ -17,22 +17,22 @@
(* Sum types *)
fun mk_sumT LT RT = Type ("+", [LT, RT])
-fun mk_sumcase TL TR T l r = Const (@{const_name "sum.sum_case"}, (TL --> T) --> (TR --> T) --> mk_sumT TL TR --> T) $ l $ r
+fun mk_sumcase TL TR T l r = Const (@{const_name sum.sum_case}, (TL --> T) --> (TR --> T) --> mk_sumT TL TR --> T) $ l $ r
val App = curry op $
fun mk_inj ST n i =
access_top_down
{ init = (ST, I : term -> term),
- left = (fn (T as Type ("+", [LT, RT]), inj) => (LT, inj o App (Const (@{const_name "Inl"}, LT --> T)))),
- right =(fn (T as Type ("+", [LT, RT]), inj) => (RT, inj o App (Const (@{const_name "Inr"}, RT --> T))))} n i
+ left = (fn (T as Type ("+", [LT, RT]), inj) => (LT, inj o App (Const (@{const_name Inl}, LT --> T)))),
+ right =(fn (T as Type ("+", [LT, RT]), inj) => (RT, inj o App (Const (@{const_name Inr}, RT --> T))))} n i
|> snd
fun mk_proj ST n i =
access_top_down
{ init = (ST, I : term -> term),
- left = (fn (T as Type ("+", [LT, RT]), proj) => (LT, App (Const (@{const_name "Datatype.Projl"}, T --> LT)) o proj)),
- right =(fn (T as Type ("+", [LT, RT]), proj) => (RT, App (Const (@{const_name "Datatype.Projr"}, T --> RT)) o proj))} n i
+ left = (fn (T as Type ("+", [LT, RT]), proj) => (LT, App (Const (@{const_name Datatype.Projl}, T --> LT)) o proj)),
+ right =(fn (T as Type ("+", [LT, RT]), proj) => (RT, App (Const (@{const_name Datatype.Projr}, T --> RT)) o proj))} n i
|> snd
fun mk_sumcases T fs =
--- a/src/HOL/Tools/Function/termination.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/Function/termination.ML Tue Sep 22 13:52:19 2009 +1000
@@ -79,14 +79,14 @@
(* concrete versions for sum types *)
-fun is_inj (Const ("Sum_Type.Inl", _) $ _) = true
- | is_inj (Const ("Sum_Type.Inr", _) $ _) = true
+fun is_inj (Const (@{const_name Sum_Type.Inl}, _) $ _) = true
+ | is_inj (Const (@{const_name Sum_Type.Inr}, _) $ _) = true
| is_inj _ = false
-fun dest_inl (Const ("Sum_Type.Inl", _) $ t) = SOME t
+fun dest_inl (Const (@{const_name Sum_Type.Inl}, _) $ t) = SOME t
| dest_inl _ = NONE
-fun dest_inr (Const ("Sum_Type.Inr", _) $ t) = SOME t
+fun dest_inr (Const (@{const_name Sum_Type.Inr}, _) $ t) = SOME t
| dest_inr _ = NONE
@@ -145,8 +145,8 @@
fun mk_sum_skel rel =
let
- val cs = FundefLib.dest_binop_list @{const_name union} rel
- fun collect_pats (Const ("Collect", _) $ Abs (_, _, c)) =
+ val cs = FundefLib.dest_binop_list @{const_name Set.union} rel
+ fun collect_pats (Const (@{const_name Collect}, _) $ Abs (_, _, c)) =
let
val (Const ("op &", _) $ (Const ("op =", _) $ _ $ (Const ("Pair", _) $ r $ l)) $ Gam)
= Term.strip_qnt_body "Ex" c
@@ -179,7 +179,7 @@
fun get_descent (_, _, _, _, D) c m1 m2 =
Term3tab.lookup D (c, (m1, m2))
-fun dest_call D (Const ("Collect", _) $ Abs (_, _, c)) =
+fun dest_call D (Const (@{const_name Collect}, _) $ Abs (_, _, c)) =
let
val n = get_num_points D
val (sk, _, _, _, _) = D
@@ -233,13 +233,13 @@
fun CALLS tac i st =
if Thm.no_prems st then all_tac st
else case Thm.term_of (Thm.cprem_of st i) of
- (_ $ (_ $ rel)) => tac (FundefLib.dest_binop_list @{const_name union} rel, i) st
+ (_ $ (_ $ rel)) => tac (FundefLib.dest_binop_list @{const_name Set.union} rel, i) st
|_ => no_tac st
type ttac = (data -> int -> tactic) -> (data -> int -> tactic) -> data -> int -> tactic
fun TERMINATION ctxt tac =
- SUBGOAL (fn (_ $ (Const (@{const_name "wf"}, wfT) $ rel), i) =>
+ SUBGOAL (fn (_ $ (Const (@{const_name wf}, wfT) $ rel), i) =>
let
val (T, _) = HOLogic.dest_prodT (HOLogic.dest_setT (domain_type wfT))
in
@@ -293,7 +293,7 @@
if null ineqs then
Const (@{const_name Set.empty}, fastype_of rel)
else
- foldr1 (HOLogic.mk_binop @{const_name union}) (map mk_compr ineqs)
+ foldr1 (HOLogic.mk_binop @{const_name Set.union}) (map mk_compr ineqs)
fun solve_membership_tac i =
(EVERY' (replicate (i - 2) (rtac @{thm UnI2})) (* pick the right component of the union *)
--- a/src/HOL/Tools/Qelim/cooper.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/Qelim/cooper.ML Tue Sep 22 13:52:19 2009 +1000
@@ -81,7 +81,7 @@
else if term_of x aconv z then Ge (Thm.dest_arg1 ct) else Nox
| Const (@{const_name Ring_and_Field.dvd},_)$_$(Const(@{const_name HOL.plus},_)$y$_) =>
if term_of x aconv y then Dvd (Thm.dest_binop ct ||> Thm.dest_arg) else Nox
-| Const (@{const_name Not},_) $ (Const (@{const_name Ring_and_Field.dvd},_)$_$(Const(@{const_name "HOL.plus"},_)$y$_)) =>
+| Const (@{const_name Not},_) $ (Const (@{const_name Ring_and_Field.dvd},_)$_$(Const(@{const_name HOL.plus},_)$y$_)) =>
if term_of x aconv y then
NDvd (Thm.dest_binop (Thm.dest_arg ct) ||> Thm.dest_arg) else Nox
| _ => Nox)
--- a/src/HOL/Tools/Qelim/presburger.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/Qelim/presburger.ML Tue Sep 22 13:52:19 2009 +1000
@@ -52,18 +52,18 @@
local
fun isnum t = case t of
- Const(@{const_name "HOL.zero"},_) => true
- | Const(@{const_name "HOL.one"},_) => true
+ Const(@{const_name HOL.zero},_) => true
+ | Const(@{const_name HOL.one},_) => true
| @{term "Suc"}$s => isnum s
| @{term "nat"}$s => isnum s
| @{term "int"}$s => isnum s
- | Const(@{const_name "HOL.uminus"},_)$s => isnum s
- | Const(@{const_name "HOL.plus"},_)$l$r => isnum l andalso isnum r
- | Const(@{const_name "HOL.times"},_)$l$r => isnum l andalso isnum r
- | Const(@{const_name "HOL.minus"},_)$l$r => isnum l andalso isnum r
- | Const(@{const_name "Power.power"},_)$l$r => isnum l andalso isnum r
- | Const(@{const_name "Divides.mod"},_)$l$r => isnum l andalso isnum r
- | Const(@{const_name "Divides.div"},_)$l$r => isnum l andalso isnum r
+ | Const(@{const_name HOL.uminus},_)$s => isnum s
+ | Const(@{const_name HOL.plus},_)$l$r => isnum l andalso isnum r
+ | Const(@{const_name HOL.times},_)$l$r => isnum l andalso isnum r
+ | Const(@{const_name HOL.minus},_)$l$r => isnum l andalso isnum r
+ | Const(@{const_name Power.power},_)$l$r => isnum l andalso isnum r
+ | Const(@{const_name Divides.mod},_)$l$r => isnum l andalso isnum r
+ | Const(@{const_name Divides.div},_)$l$r => isnum l andalso isnum r
| _ => can HOLogic.dest_number t orelse can HOLogic.dest_nat t
fun ty cts t =
--- a/src/HOL/Tools/Qelim/qelim.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/Qelim/qelim.ML Tue Sep 22 13:52:19 2009 +1000
@@ -29,8 +29,8 @@
@{const_name "op -->"}, @{const_name "op ="}] s
then binop_conv (conv env) p
else atcv env p
- | Const(@{const_name "Not"},_)$_ => arg_conv (conv env) p
- | Const(@{const_name "Ex"},_)$Abs(s,_,_) =>
+ | Const(@{const_name Not},_)$_ => arg_conv (conv env) p
+ | Const(@{const_name Ex},_)$Abs(s,_,_) =>
let
val (e,p0) = Thm.dest_comb p
val (x,p') = Thm.dest_abs (SOME s) p0
@@ -41,8 +41,8 @@
val (l,r) = Thm.dest_equals (cprop_of th')
in if Thm.is_reflexive th' then Thm.transitive th (qcv env (Thm.rhs_of th))
else Thm.transitive (Thm.transitive th th') (conv env r) end
- | Const(@{const_name "Ex"},_)$ _ => (Thm.eta_long_conversion then_conv conv env) p
- | Const(@{const_name "All"},_)$_ =>
+ | Const(@{const_name Ex},_)$ _ => (Thm.eta_long_conversion then_conv conv env) p
+ | Const(@{const_name All},_)$_ =>
let
val p = Thm.dest_arg p
val ([(_,T)],[]) = Thm.match (@{cpat "All"}, Thm.dest_fun p)
--- a/src/HOL/Tools/TFL/rules.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/TFL/rules.ML Tue Sep 22 13:52:19 2009 +1000
@@ -456,7 +456,7 @@
fun is_cong thm =
case (Thm.prop_of thm)
of (Const("==>",_)$(Const("Trueprop",_)$ _) $
- (Const("==",_) $ (Const (@{const_name "Recdef.cut"},_) $ f $ R $ a $ x) $ _)) => false
+ (Const("==",_) $ (Const (@{const_name Recdef.cut},_) $ f $ R $ a $ x) $ _)) => false
| _ => true;
@@ -659,7 +659,7 @@
end;
fun restricted t = isSome (S.find_term
- (fn (Const(@{const_name "Recdef.cut"},_)) =>true | _ => false)
+ (fn (Const(@{const_name Recdef.cut},_)) =>true | _ => false)
t)
fun CONTEXT_REWRITE_RULE (func, G, cut_lemma, congs) th =
--- a/src/HOL/Tools/TFL/usyntax.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/TFL/usyntax.ML Tue Sep 22 13:52:19 2009 +1000
@@ -398,7 +398,7 @@
end handle Bind => raise USYN_ERR "dest_relation" "unexpected term structure"
else raise USYN_ERR "dest_relation" "not a boolean term";
-fun is_WFR (Const(@{const_name "Wellfounded.wf"},_)$_) = true
+fun is_WFR (Const(@{const_name Wellfounded.wf},_)$_) = true
| is_WFR _ = false;
fun ARB ty = mk_select{Bvar=Free("v",ty),
--- a/src/HOL/Tools/float_syntax.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/float_syntax.ML Tue Sep 22 13:52:19 2009 +1000
@@ -27,10 +27,10 @@
fun mk_frac str =
let
val {mant=i, exp = n} = Syntax.read_float str;
- val exp = Syntax.const @{const_name "Power.power"};
+ val exp = Syntax.const @{const_name Power.power};
val ten = mk_number 10;
val exp10 = if n=1 then ten else exp $ ten $ (mk_number n);
- in (Syntax.const @{const_name "divide"}) $ (mk_number i) $ exp10 end
+ in (Syntax.const @{const_name divide}) $ (mk_number i) $ exp10 end
in
fun float_tr (*"_Float"*) [t as Const (str, _)] = mk_frac str
--- a/src/HOL/Tools/inductive.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/inductive.ML Tue Sep 22 13:52:19 2009 +1000
@@ -86,13 +86,13 @@
(** theory context references **)
val inductive_forall_name = "HOL.induct_forall";
-val inductive_forall_def = thm "induct_forall_def";
+val inductive_forall_def = @{thm induct_forall_def};
val inductive_conj_name = "HOL.induct_conj";
-val inductive_conj_def = thm "induct_conj_def";
-val inductive_conj = thms "induct_conj";
-val inductive_atomize = thms "induct_atomize";
-val inductive_rulify = thms "induct_rulify";
-val inductive_rulify_fallback = thms "induct_rulify_fallback";
+val inductive_conj_def = @{thm induct_conj_def};
+val inductive_conj = @{thms induct_conj};
+val inductive_atomize = @{thms induct_atomize};
+val inductive_rulify = @{thms induct_rulify};
+val inductive_rulify_fallback = @{thms induct_rulify_fallback};
val notTrueE = TrueI RSN (2, notE);
val notFalseI = Seq.hd (atac 1 notI);
@@ -103,6 +103,7 @@
"(P & True) = P" "(True & P) = P"
by (fact simp_thms)+};
+val simp_thms'' = inf_fun_eq :: inf_bool_eq :: simp_thms';
(** context data **)
@@ -176,7 +177,7 @@
case concl of
Const ("==", _) $ _ $ _ => eq2mono (thm RS meta_eq_to_obj_eq)
| _ $ (Const ("op =", _) $ _ $ _) => eq2mono thm
- | _ $ (Const ("HOL.ord_class.less_eq", _) $ _ $ _) =>
+ | _ $ (Const (@{const_name HOL.less_eq}, _) $ _ $ _) =>
[dest_less_concl (Seq.hd (REPEAT (FIRSTGOAL
(resolve_tac [le_funI, le_boolI'])) thm))]
| _ => [thm]
@@ -559,7 +560,7 @@
[rewrite_goals_tac [inductive_conj_def],
DETERM (rtac raw_fp_induct 1),
REPEAT (resolve_tac [le_funI, le_boolI] 1),
- rewrite_goals_tac (inf_fun_eq :: inf_bool_eq :: simp_thms'),
+ rewrite_goals_tac simp_thms'',
(*This disjE separates out the introduction rules*)
REPEAT (FIRSTGOAL (eresolve_tac [disjE, exE, FalseE])),
(*Now break down the individual cases. No disjE here in case
@@ -568,7 +569,7 @@
REPEAT (FIRSTGOAL
(resolve_tac [conjI, impI] ORELSE' (etac notE THEN' atac))),
EVERY (map (fn prem => DEPTH_SOLVE_1 (ares_tac [rewrite_rule
- (inductive_conj_def :: rec_preds_defs @ simp_thms') prem,
+ (inductive_conj_def :: rec_preds_defs @ simp_thms'') prem,
conjI, refl] 1)) prems)]);
val lemma = SkipProof.prove ctxt'' [] []
--- a/src/HOL/Tools/inductive_set.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/inductive_set.ML Tue Sep 22 13:52:19 2009 +1000
@@ -74,8 +74,8 @@
in Drule.instantiate' [] (rev (map (SOME o cterm_of thy o Var) vs))
(p (fold (Logic.all o Var) vs t) f)
end;
- fun mkop "op &" T x = SOME (Const (@{const_name inter}, T --> T --> T), x)
- | mkop "op |" T x = SOME (Const (@{const_name union}, T --> T --> T), x)
+ fun mkop "op &" T x = SOME (Const (@{const_name Set.inter}, T --> T --> T), x)
+ | mkop "op |" T x = SOME (Const (@{const_name Set.union}, T --> T --> T), x)
| mkop _ _ _ = NONE;
fun mk_collect p T t =
let val U = HOLogic.dest_setT T
--- a/src/HOL/Tools/int_arith.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/int_arith.ML Tue Sep 22 13:52:19 2009 +1000
@@ -49,13 +49,13 @@
make_simproc {lhss = lhss1, name = "one_to_of_int_one_simproc",
proc = proc1, identifier = []};
-fun check (Const (@{const_name "HOL.one"}, @{typ int})) = false
- | check (Const (@{const_name "HOL.one"}, _)) = true
+fun check (Const (@{const_name HOL.one}, @{typ int})) = false
+ | check (Const (@{const_name HOL.one}, _)) = true
| check (Const (s, _)) = member (op =) [@{const_name "op ="},
- @{const_name "HOL.times"}, @{const_name "HOL.uminus"},
- @{const_name "HOL.minus"}, @{const_name "HOL.plus"},
- @{const_name "HOL.zero"},
- @{const_name "HOL.less"}, @{const_name "HOL.less_eq"}] s
+ @{const_name HOL.times}, @{const_name HOL.uminus},
+ @{const_name HOL.minus}, @{const_name HOL.plus},
+ @{const_name HOL.zero},
+ @{const_name HOL.less}, @{const_name HOL.less_eq}] s
| check (a $ b) = check a andalso check b
| check _ = false;
--- a/src/HOL/Tools/lin_arith.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Tools/lin_arith.ML Tue Sep 22 13:52:19 2009 +1000
@@ -51,7 +51,7 @@
atomize (thm RS conjunct1) @ atomize (thm RS conjunct2)
| _ => [thm];
-fun neg_prop ((TP as Const("Trueprop", _)) $ (Const (@{const_name "Not"}, _) $ t)) = TP $ t
+fun neg_prop ((TP as Const("Trueprop", _)) $ (Const (@{const_name Not}, _) $ t)) = TP $ t
| neg_prop ((TP as Const("Trueprop", _)) $ t) = TP $ (HOLogic.Not $t)
| neg_prop t = raise TERM ("neg_prop", [t]);
--- a/src/HOL/Transitive_Closure.thy Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/Transitive_Closure.thy Tue Sep 22 13:52:19 2009 +1000
@@ -77,7 +77,7 @@
subsection {* Reflexive-transitive closure *}
lemma reflcl_set_eq [pred_set_conv]: "(sup (\<lambda>x y. (x, y) \<in> r) op =) = (\<lambda>x y. (x, y) \<in> r Un Id)"
- by (simp add: expand_fun_eq)
+ by (simp add: expand_fun_eq sup2_iff)
lemma r_into_rtrancl [intro]: "!!p. p \<in> r ==> p \<in> r^*"
-- {* @{text rtrancl} of @{text r} contains @{text r} *}
--- a/src/HOL/UNITY/ProgressSets.thy Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/UNITY/ProgressSets.thy Tue Sep 22 13:52:19 2009 +1000
@@ -534,7 +534,7 @@
subsubsection{*Commutativity of Functions and Relation*}
text{*Thesis, page 109*}
-(*FIXME: this proof is an ungodly mess*)
+(*FIXME: this proof is still an ungodly mess*)
text{*From Meier's thesis, section 4.5.6*}
lemma commutativity2_lemma:
assumes dcommutes:
@@ -548,36 +548,35 @@
and TL: "T \<in> L"
and Fstable: "F \<in> stable T"
shows "commutes F T B L"
-apply (simp add: commutes_def del: Int_subset_iff, clarify)
-apply (rename_tac t)
-apply (subgoal_tac "\<exists>s. (s,t) \<in> relcl L & s \<in> T \<inter> wp act M")
- prefer 2
- apply (force simp add: cl_eq_Collect_relcl [OF lattice], simp, clarify)
-apply (subgoal_tac "\<forall>u\<in>L. s \<in> u --> t \<in> u")
- prefer 2
- apply (intro ballI impI)
- apply (subst cl_ident [symmetric], assumption)
- apply (simp add: relcl_def)
- apply (blast intro: cl_mono [THEN [2] rev_subsetD])
-apply (subgoal_tac "funof act s \<in> T\<inter>M")
- prefer 2
- apply (cut_tac Fstable)
- apply (force intro!: funof_in
- simp add: wp_def stable_def constrains_def determ total)
-apply (subgoal_tac "s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L")
- prefer 2
- apply (rule dcommutes [rule_format], assumption+)
-apply (subgoal_tac "t \<in> B | funof act t \<in> cl L (T\<inter>M)")
- prefer 2
- apply (simp add: relcl_def)
- apply (blast intro: BL cl_mono [THEN [2] rev_subsetD])
-apply (subgoal_tac "t \<in> B | t \<in> wp act (cl L (T\<inter>M))")
- prefer 2
- apply (blast intro: funof_imp_wp determ)
-apply (blast intro: TL cl_mono [THEN [2] rev_subsetD])
-done
-
-
+apply (simp add: commutes_def del: Int_subset_iff le_inf_iff, clarify)
+proof -
+ fix M and act and t
+ assume 1: "B \<subseteq> M" "act \<in> Acts F" "t \<in> cl L (T \<inter> wp act M)"
+ then have "\<exists>s. (s,t) \<in> relcl L \<and> s \<in> T \<inter> wp act M"
+ by (force simp add: cl_eq_Collect_relcl [OF lattice])
+ then obtain s where 2: "(s, t) \<in> relcl L" "s \<in> T" "s \<in> wp act M"
+ by blast
+ then have 3: "\<forall>u\<in>L. s \<in> u --> t \<in> u"
+ apply (intro ballI impI)
+ apply (subst cl_ident [symmetric], assumption)
+ apply (simp add: relcl_def)
+ apply (blast intro: cl_mono [THEN [2] rev_subsetD])
+ done
+ with 1 2 Fstable have 4: "funof act s \<in> T\<inter>M"
+ by (force intro!: funof_in
+ simp add: wp_def stable_def constrains_def determ total)
+ with 1 2 3 have 5: "s \<in> B | t \<in> B | (funof act s, funof act t) \<in> relcl L"
+ by (intro dcommutes [rule_format]) assumption+
+ with 1 2 3 4 have "t \<in> B | funof act t \<in> cl L (T\<inter>M)"
+ by (simp add: relcl_def) (blast intro: BL cl_mono [THEN [2] rev_subsetD])
+ with 1 2 3 4 5 have "t \<in> B | t \<in> wp act (cl L (T\<inter>M))"
+ by (blast intro: funof_imp_wp determ)
+ with 2 3 have "t \<in> T \<and> (t \<in> B \<or> t \<in> wp act (cl L (T \<inter> M)))"
+ by (blast intro: TL cl_mono [THEN [2] rev_subsetD])
+ then show "t \<in> T \<inter> (B \<union> wp act (cl L (T \<inter> M)))"
+ by simp
+qed
+
text{*Version packaged with @{thm progress_set_Union}*}
lemma commutativity2:
assumes leadsTo: "F \<in> A leadsTo B"
--- a/src/HOL/UNITY/ROOT.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/UNITY/ROOT.ML Tue Sep 22 13:52:19 2009 +1000
@@ -1,50 +1,13 @@
-(* Title: HOL/UNITY/ROOT
- ID: $Id$
- Author: Lawrence C Paulson, Cambridge University Computer Laboratory
+(* Author: Lawrence C Paulson, Cambridge University Computer Laboratory
Copyright 1998 University of Cambridge
-Root file for UNITY proofs.
*)
(*Verifying security protocols using UNITY*)
no_document use_thy "../Auth/Public";
-use_thys [
- (*Basic meta-theory*)
- "UNITY_Main",
-
- (*Simple examples: no composition*)
- "Simple/Deadlock",
- "Simple/Common",
- "Simple/Network",
- "Simple/Token",
- "Simple/Channel",
- "Simple/Lift",
- "Simple/Mutex",
- "Simple/Reach",
- "Simple/Reachability",
-
- (*Verifying security protocols using UNITY*)
- "Simple/NSP_Bad",
+(*Basic meta-theory*)
+use_thy "UNITY_Main";
- (*Example of composition*)
- "Comp/Handshake",
-
- (*Universal properties examples*)
- "Comp/Counter",
- "Comp/Counterc",
- "Comp/Priority",
-
- "Comp/TimerArray",
- "Comp/Progress",
-
- (*obsolete*)
- "ELT"
-];
-
-(*Allocator example*)
-(* FIXME some parts no longer work -- had been commented out for a long time *)
-setmp_noncritical quick_and_dirty true
- use_thy "Comp/Alloc";
-
-use_thys ["Comp/AllocImpl", "Comp/Client"];
+(*Examples*)
+use_thy "UNITY_Examples";
--- a/src/HOL/UNITY/Simple/Common.thy Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/UNITY/Simple/Common.thy Tue Sep 22 13:52:19 2009 +1000
@@ -83,19 +83,24 @@
(*** Progress under weak fairness ***)
-declare atMost_Int_atLeast [simp]
-
lemma leadsTo_common_lemma:
- "[| \<forall>m. F \<in> {m} Co (maxfg m);
- \<forall>m \<in> lessThan n. F \<in> {m} LeadsTo (greaterThan m);
- n \<in> common |]
- ==> F \<in> (atMost n) LeadsTo common"
-apply (rule LeadsTo_weaken_R)
-apply (rule_tac f = id and l = n in GreaterThan_bounded_induct)
-apply (simp_all (no_asm_simp) del: Int_insert_right_if1)
-apply (rule_tac [2] subset_refl)
-apply (blast dest: PSP_Stable2 intro: common_stable LeadsTo_weaken_R)
-done
+ assumes "\<forall>m. F \<in> {m} Co (maxfg m)"
+ and "\<forall>m \<in> lessThan n. F \<in> {m} LeadsTo (greaterThan m)"
+ and "n \<in> common"
+ shows "F \<in> (atMost n) LeadsTo common"
+proof (rule LeadsTo_weaken_R)
+ show "F \<in> {..n} LeadsTo {..n} \<inter> id -` {n..} \<union> common"
+ proof (induct rule: GreaterThan_bounded_induct [of n _ _ id])
+ case 1
+ from assms have "\<forall>m\<in>{..<n}. F \<in> {..n} \<inter> {m} LeadsTo {..n} \<inter> {m<..} \<union> common"
+ by (blast dest: PSP_Stable2 intro: common_stable LeadsTo_weaken_R)
+ then show ?case by simp
+ qed
+next
+ from `n \<in> common`
+ show "{..n} \<inter> id -` {n..} \<union> common \<subseteq> common"
+ by (simp add: atMost_Int_atLeast)
+qed
(*The "\<forall>m \<in> -common" form echoes CMT6.*)
lemma leadsTo_common:
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/UNITY/UNITY_Examples.thy Tue Sep 22 13:52:19 2009 +1000
@@ -0,0 +1,45 @@
+(* Author: Lawrence C Paulson Cambridge University Computer Laboratory
+ Copyright 1998 University of Cambridge
+*)
+
+header {* Various examples for UNITY *}
+
+theory UNITY_Examples
+imports
+ UNITY_Main
+
+ (*Simple examples: no composition*)
+ "Simple/Deadlock"
+ "Simple/Common"
+ "Simple/Network"
+ "Simple/Token"
+ "Simple/Channel"
+ "Simple/Lift"
+ "Simple/Mutex"
+ "Simple/Reach"
+ "Simple/Reachability"
+
+ (*Verifying security protocols using UNITY*)
+ "Simple/NSP_Bad"
+
+ (*Example of composition*)
+ "Comp/Handshake"
+
+ (*Universal properties examples*)
+ "Comp/Counter"
+ "Comp/Counterc"
+ "Comp/Priority"
+
+ "Comp/TimerArray"
+ "Comp/Progress"
+
+ "Comp/Alloc"
+ "Comp/AllocImpl"
+ "Comp/Client"
+
+ (*obsolete*)
+ "ELT"
+
+begin
+
+end
--- a/src/HOL/ex/ROOT.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/HOL/ex/ROOT.ML Tue Sep 22 13:52:19 2009 +1000
@@ -68,8 +68,7 @@
"Landau"
];
-Future.shutdown ();
-(setmp_noncritical proofs 2 (setmp_noncritical Multithreading.max_threads 1 use_thy))
+(setmp_noncritical proofs 2 (setmp_noncritical Goal.parallel_proofs 0 use_thy))
"Hilbert_Classical";
use_thy "SVC_Oracle";
--- a/src/Pure/Concurrent/future.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/Pure/Concurrent/future.ML Tue Sep 22 13:52:19 2009 +1000
@@ -237,7 +237,7 @@
val total = length (! workers);
val active = count_active ();
in
- "SCHEDULE " ^ string_of_int (Time.toMilliseconds now) ^ ": " ^
+ "SCHEDULE " ^ Time.toString now ^ ": " ^
string_of_int ready ^ " ready, " ^
string_of_int pending ^ " pending, " ^
string_of_int running ^ " running; " ^
@@ -257,7 +257,7 @@
"SCHEDULE: disposed " ^ string_of_int (length dead) ^ " dead worker threads")));
val m = if ! do_shutdown then 0 else Multithreading.max_threads_value ();
- val mm = (m * 3) div 2;
+ val mm = if m = 9999 then 1 else (m * 3) div 2;
val l = length (! workers);
val _ = excessive := l - mm;
val _ =
--- a/src/Pure/Concurrent/par_list.ML Thu Sep 17 14:17:37 2009 +1000
+++ b/src/Pure/Concurrent/par_list.ML Tue Sep 22 13:52:19 2009 +1000
@@ -27,8 +27,10 @@
struct
fun raw_map f xs =
- let val group = Task_Queue.new_group (Future.worker_group ())
- in Future.join_results (map (fn x => Future.fork_group group (fn () => f x)) xs) end;
+ if Multithreading.enabled () then
+ let val group = Task_Queue.new_group (Future.worker_group ())
+ in Future.join_results (map (fn x => Future.fork_group group (fn () => f x)) xs) end
+ else map (Exn.capture f) xs;
fun map f xs = Exn.release_first (raw_map f xs);