diff --git a/thys/ConcurrentIMP/CIMP.thy b/thys/ConcurrentIMP/CIMP.thy
--- a/thys/ConcurrentIMP/CIMP.thy
+++ b/thys/ConcurrentIMP/CIMP.thy
@@ -1,134 +1,40 @@
 (*<*)
 (*
  * Copyright 2015, NICTA
  *
  * This software may be distributed and modified according to the terms of
  * the BSD 2-Clause license. Note that NO WARRANTY is provided.
  * See "LICENSE_BSD2.txt" for details.
  *
  * @TAG(NICTA_BSD)
  *)
 
 theory CIMP
 imports
   CIMP_pred
   CIMP_lang
   CIMP_vcg
-  "HOL-Library.Sublist"
+  CIMP_vcg_rules
 keywords
-  "inv_definition" "locset_definition" :: thy_defn
+      "locset_definition" :: thy_defn
+  and "intern_com" :: thy_decl
 begin
 
 text\<open>
 
 Infrastructure for reasoning about CIMP programs. See AFP entry \<open>ConcurrentGC\<close> for examples
 of use.
 
 \<close>
 
-named_theorems com "Command definitions"
-named_theorems inv "Location-sensitive invariant definitions"
-named_theorems loc "Location set membership cache"
-
-ML\<open>
-
-signature CIMP =
-sig
-    val com_locs_fold : (term -> 'b -> 'b) -> 'b -> term -> 'b
-    val com_locs_map : (term -> 'b) -> term -> 'b list
-    val com_locs_fold_no_response : (term -> 'b -> 'b) -> 'b -> term -> 'b
-    val com_locs_map_no_response : (term -> 'b) -> term -> 'b list
-    val def_inv : thm -> local_theory -> local_theory
-    val def_locset : thm -> local_theory -> local_theory
-end;
-
-structure Cimp : CIMP =
-struct
-
-fun com_locs_fold f x (Const (@{const_name Request}, _) $ l $ _ $ _ )    = f l x
-  | com_locs_fold f x (Const (@{const_name Response}, _) $ l $ _)        = f l x
-  | com_locs_fold f x (Const (@{const_name LocalOp}, _) $ l $ _)         = f l x
-  | com_locs_fold f x (Const (@{const_name Cond1}, _) $ l $ _ $ c)       = com_locs_fold f (f l x) c
-  | com_locs_fold f x (Const (@{const_name Cond2}, _) $ l $ _ $ c1 $ c2) = com_locs_fold f (com_locs_fold f (f l x) c1) c2
-  | com_locs_fold f x (Const (@{const_name Loop}, _) $ c)                = com_locs_fold f x c
-  | com_locs_fold f x (Const (@{const_name While}, _) $ l $ _ $ c)       = com_locs_fold f (f l x) c
-  | com_locs_fold f x (Const (@{const_name Seq}, _) $ c1 $ c2)           = com_locs_fold f (com_locs_fold f x c1) c2
-  | com_locs_fold f x (Const (@{const_name Choose}, _) $ c1 $ c2)        = com_locs_fold f (com_locs_fold f x c1) c2
-  | com_locs_fold _ x _ = x;
-
-fun com_locs_map f com = com_locs_fold (fn l => fn acc => f l :: acc) [] com
-
-fun com_locs_fold_no_response f x (Const (@{const_name Request}, _) $ l $ _ $ _ )    = f l x
-  | com_locs_fold_no_response _ x (Const (@{const_name Response}, _) $ _ $ _)        = x (* can often ignore \<open>Response\<close> *)
-  | com_locs_fold_no_response f x (Const (@{const_name LocalOp}, _) $ l $ _)         = f l x
-  | com_locs_fold_no_response f x (Const (@{const_name Cond1}, _) $ l $ _ $ c)       = com_locs_fold_no_response f (f l x) c
-  | com_locs_fold_no_response f x (Const (@{const_name Cond2}, _) $ l $ _ $ c1 $ c2) = com_locs_fold_no_response f (com_locs_fold_no_response f (f l x) c1) c2
-  | com_locs_fold_no_response f x (Const (@{const_name Loop}, _) $ c)                = com_locs_fold_no_response f x c
-  | com_locs_fold_no_response f x (Const (@{const_name While}, _) $ l $ _ $ c)       = com_locs_fold_no_response f (f l x) c
-  | com_locs_fold_no_response f x (Const (@{const_name Seq}, _) $ c1 $ c2)           = com_locs_fold_no_response f (com_locs_fold_no_response f x c1) c2
-  | com_locs_fold_no_response f x (Const (@{const_name Choose}, _) $ c1 $ c2)        = com_locs_fold_no_response f (com_locs_fold_no_response f x c1) c2
-  | com_locs_fold_no_response _ x _ = x;
-
-fun com_locs_map_no_response f com = com_locs_fold_no_response (fn l => fn acc => f l :: acc) [] com
-
-(* Cache location set membership facts.
-
-Decide membership in the given set for each label in the CIMP programs
-in the Named_Theorems "com".
+named_theorems locset_cache "Location set membership cache"
 
-If the label set and com types differ, we probably get a nasty error.
-
-*)
+lemmas cleanup_simps =
+  atomize_eq
+  simp_thms
 
-fun def_locset thm ctxt =
-  let
-    val set_name = thm
-                   |> Local_Defs.meta_rewrite_rule ctxt (* handle `=` or `\<equiv>` *)
-                   |> Thm.cprop_of |> Thm.dest_equals |> fst |> Thm.term_of
-    val set_typ = set_name |> type_of
-    val elt_typ = case set_typ of Type ("Set.set", [t]) => t | _ => raise Fail "thm should define a set"
-    val set_name_str = case set_name of Const (c, _) => c | Free (c, _) => c | _ => error ("Not an equation of the form x = set: " ^ Thm.string_of_thm ctxt thm)
-    val thm_name = Binding.qualify true set_name_str (Binding.name "memb")
-    fun mk_memb l = Thm.cterm_of ctxt (Const (@{const_name "Set.member"}, elt_typ --> set_typ --> @{typ "bool"}) $ l $ set_name)
-    val rewrite_tac = Simplifier.rewrite (ctxt addsimps ([thm] @ Named_Theorems.get ctxt @{named_theorems "loc"})) (* probably want the ambient simpset + some stuff *)
-    val coms = Named_Theorems.get ctxt @{named_theorems "com"} |> map (Thm.cprop_of #> Thm.dest_equals #> snd #> Thm.term_of)
-    val attrs = [(* Attrib.internal (K (Clasimp.iff_add)), *) Attrib.internal (K (Named_Theorems.add @{named_theorems "loc"}))]
-(* Parallel *)
-    fun mk_thms coms = Par_List.map rewrite_tac (maps (com_locs_map_no_response mk_memb) coms)
-(* Sequential *)
-(*    fun mk_thms coms = List.foldl (fn (c, thms) => com_locs_fold (fn l => fn thms => rewrite_tac (mk_memb l) :: thms) thms c) [] coms *)
-  in
-    ctxt
-    |> Local_Theory.note ((thm_name, attrs), mk_thms coms)
-    |> snd
-  end;
-
-(* FIXME later need to rewrite using interned labels (fold defs). *)
-fun def_inv thm ctxt : local_theory =
-  let
-    val attrs = [Attrib.internal (K (Named_Theorems.add @{named_theorems "inv"}))]
-  in
-    ctxt
-    |> Local_Theory.note ((Binding.empty, attrs), [thm])
-    |> snd
-  end;
-
-end;
-
-val _ =
-  Outer_Syntax.local_theory' \<^command_keyword>\<open>inv_definition\<close> "constant definition for invariants"
-    (Scan.option Parse_Spec.constdecl -- (Parse_Spec.opt_thm_name ":" -- Parse.prop) --
-      Parse_Spec.if_assumes -- Parse.for_fixes >> (fn (((decl, spec), prems), params) => fn b => fn lthy =>
-        Specification.definition_cmd decl params prems spec b lthy
-        |> (fn ((_, (_, thm)), lthy) => (thm, lthy)) |> uncurry Cimp.def_inv));
-
-val _ =
-  Outer_Syntax.local_theory' \<^command_keyword>\<open>locset_definition\<close> "constant definition for sets of locations"
-    (Scan.option Parse_Spec.constdecl -- (Parse_Spec.opt_thm_name ":" -- Parse.prop) --
-      Parse_Spec.if_assumes -- Parse.for_fixes >> (fn (((decl, spec), prems), params) => fn b => fn lthy =>
-        Specification.definition_cmd decl params prems spec b lthy
-        |> (fn ((_, (_, thm)), lthy) => (thm, lthy)) |> uncurry Cimp.def_locset));
-\<close>
+ML_file\<open>cimp.ML\<close>
+(*<*)
 
 end
 (*>*)
diff --git a/thys/ConcurrentIMP/CIMP_lang.thy b/thys/ConcurrentIMP/CIMP_lang.thy
--- a/thys/ConcurrentIMP/CIMP_lang.thy
+++ b/thys/ConcurrentIMP/CIMP_lang.thy
@@ -1,946 +1,510 @@
 (*<*)
 (*
  * Copyright 2015, NICTA
  *
  * This software may be distributed and modified according to the terms of
  * the BSD 2-Clause license. Note that NO WARRANTY is provided.
  * See "LICENSE_BSD2.txt" for details.
  *
  * @TAG(NICTA_BSD)
  *)
 
 theory CIMP_lang
 imports
   CIMP_pred
+  LTL
 begin
 
 (*>*)
-section\<open>CIMP syntax and semantics\<close>
+section\<open>CIMP syntax and semantics \label{sec:cimp-syntax-semantics}\<close>
 
 text\<open>
 
-\label{sec:cimp-syntax-semantics}
-
 We define a small sequential programming language with synchronous
 message passing primitives for describing the individual
 processes. This has the advantage over raw transition systems in that
 it is programmer-readable, includes sequential composition, supports a
 program logic and VCG (\S\ref{sec:cimp-vcg}), etc. These processes are
 composed in parallel at the top-level.
 
 CIMP is inspired by IMP, as presented by @{cite [cite_macro=citet]
 "Winskel:1993"} and @{cite [cite_macro=citet]
 "ConcreteSemantics:2014"}, and the classical process algebras CCS
 @{cite [cite_macro=citep] "Milner:1980" and "Milner:1989"} and CSP
 @{cite [cite_macro=citep] "Hoare:1985"}. Note that the algebraic
 properties of this language have not been developed.
 
 As we operate in a concurrent setting, we need to provide a small-step
 semantics (\S\ref{sec:cimp-semantics}), which we give in the style of
 \emph{structural operational semantics} (SOS) as popularised by @{cite
 [cite_macro=citet] "DBLP:journals/jlp/Plotkin04"}. The semantics of a
 complete system (\S\ref{sec:cimp-system-steps}) is presently taken
 simply to be the states reachable by interleaving the enabled steps of
 the individual processes, subject to message passing rendezvous. We
 leave a trace or branching semantics to future work.
 
+This theory contains all the trusted definitions. The soundness of the other
+theories supervenes upon this one.
+
 \<close>
 
+
 subsection\<open>Syntax\<close>
 
 text\<open>
 
 Programs are represented using an explicit (deep embedding) of their
 syntax, as the semantics needs to track the progress of multiple
 threads of control. Each (atomic) \emph{basic command}
 (\S\ref{sec:cimp-decompose}) is annotated with a @{typ "'location"},
 which we use in our assertions (\S\ref{sec:cimp-control-predicates}).
 These locations need not be unique, though in practice they likely
 will be.
 
 Processes maintain \emph{local states} of type @{typ "'state"}. These
 can be updated with arbitrary relations of @{typ "'state \<Rightarrow> 'state
 set"} with \<open>LocalOp\<close>, and conditions of type @{typ "'s \<Rightarrow>
 bool"} are similarly shallowly embedded. This arrangement allows the
 end-user to select their own level of atomicity.
 
 The sequential composition operator and control constructs are
 standard. We add the infinite looping construct \<open>Loop\<close> so we
 can construct single-state reactive systems; this has implications for
 fairness assertions.
 
 \<close>
 
 type_synonym 's bexp = "'s \<Rightarrow> bool"
 
 datatype ('answer, 'location, 'question, 'state) com
   = Request  "'location" "'state \<Rightarrow> 'question" "'answer \<Rightarrow> 'state \<Rightarrow> 'state set"        ("\<lbrace>_\<rbrace> Request _ _"  [0, 70, 70] 71)
   | Response "'location" "'question \<Rightarrow> 'state \<Rightarrow> ('state \<times> 'answer) set"               ("\<lbrace>_\<rbrace> Response _"  [0, 70] 71)
   | LocalOp  "'location" "'state \<Rightarrow> 'state set"                                       ("\<lbrace>_\<rbrace> LocalOp _" [0, 70] 71)
-  | Cond1    "'location" "'state bexp" "('answer, 'location, 'question, 'state) com" ("\<lbrace>_\<rbrace> IF _ THEN _ FI" [0, 0] 71)
+  | Cond1    "'location" "'state bexp" "('answer, 'location, 'question, 'state) com" ("\<lbrace>_\<rbrace> IF _ THEN _ FI" [0, 0, 0] 71)
   | Cond2    "'location" "'state bexp" "('answer, 'location, 'question, 'state) com"
-                           "('answer, 'location, 'question, 'state) com"             ("\<lbrace>_\<rbrace> IF _/ THEN _/ ELSE _/ FI"  [0, 0, 0] 71)
+                           "('answer, 'location, 'question, 'state) com"             ("\<lbrace>_\<rbrace> IF _/ THEN _/ ELSE _/ FI"  [0, 0, 0, 0] 71)
   | Loop     "('answer, 'location, 'question, 'state) com"                           ("LOOP DO _/ OD"  [0] 71)
   | While    "'location" "'state bexp" "('answer, 'location, 'question, 'state) com" ("\<lbrace>_\<rbrace> WHILE _/ DO _/ OD"  [0, 0, 0] 71)
   | Seq      "('answer, 'location, 'question, 'state) com"
               "('answer, 'location, 'question, 'state) com"                           (infixr ";;" 69)
   | Choose   "('answer, 'location, 'question, 'state) com"
-              "('answer, 'location, 'question, 'state) com"                           (infixl "\<squnion>" 68)
+              "('answer, 'location, 'question, 'state) com"                           (infixl "\<oplus>" 68)
 
 text\<open>
 
 We provide a one-armed conditional as it is the common form and avoids
 the need to discover a label for an internal \<open>SKIP\<close> and/or
 trickier proofs about the VCG.
 
 In contrast to classical process algebras, we have local state and
-distinct send and receive actions. These provide an interface to
+distinct request and response actions. These provide an interface to
 Isabelle/HOL's datatypes that avoids the need for binding (ala the
 $\pi$-calculus of @{cite [cite_macro=citet] "Milner:1989"}) or large
 non-deterministic sums (ala CCS @{cite [cite_macro=citep] \<open>\S2.8\<close>
-"Milner:1980"}). Intuitively the sender asks a @{typ "'question"} with
+"Milner:1980"}). Intuitively the requester poses a @{typ "'question"} with
 a \<open>Request\<close> command, which upon rendezvous with a
-receiver's \<open>Response\<close> command receives an @{typ
+responder's \<open>Response\<close> command receives an @{typ
 "'answer"}. The @{typ "'question"} is a deterministic function of the
-sender's local state, whereas a receiver can respond
-non-deterministically. Note that CIMP does not provide a notion of
+requester's local state, whereas responses can be
+non-deterministic. Note that CIMP does not provide a notion of
 channel; these can be modelled by a judicious choice of @{typ
 "'question"}.
 
-We also provide a binary external choice operator. Internal choice can
-be recovered in combination with local operations (see @{cite
-[cite_macro=citet] \<open>\S2.3\<close> "Milner:1980"}).
+We also provide a binary external choice operator @{term\<open>Choose\<close>} (infix @{term\<open>(\<oplus>)\<close>}).
+Internal choice can be recovered in combination with local operations
+(see @{cite [cite_macro=citet] \<open>\S2.3\<close> "Milner:1980"}).
 
 We abbreviate some common commands: \<open>SKIP\<close> is a local
 operation that does nothing, and the floor brackets simplify
 deterministic \<open>LocalOp\<close>s. We also adopt some syntax magic from
-Makarius's Hoare and Multiquote theories in the Isabelle/HOL
+Makarius's \<open>Hoare\<close> and \<open>Multiquote\<close> theories in the Isabelle/HOL
 distribution.
 
 \<close>
 
-abbreviation SKIP_syn ("\<lbrace>_\<rbrace>/ SKIP" 70) where
+abbreviation SKIP_syn ("\<lbrace>_\<rbrace>/ SKIP" [0] 71) where
   "\<lbrace>l\<rbrace> SKIP \<equiv> \<lbrace>l\<rbrace> LocalOp (\<lambda>s. {s})"
 
 abbreviation (input) DetLocalOp :: "'location \<Rightarrow> ('state \<Rightarrow> 'state)
-                                  \<Rightarrow> ('answer, 'location, 'question, 'state) com" ("\<lbrace>_\<rbrace> \<lfloor>_\<rfloor>") where
+                                  \<Rightarrow> ('answer, 'location, 'question, 'state) com" ("\<lbrace>_\<rbrace> \<lfloor>_\<rfloor>" [0, 0] 71) where
   "\<lbrace>l\<rbrace> \<lfloor>f\<rfloor> \<equiv> \<lbrace>l\<rbrace> LocalOp (\<lambda>s. {f s})"
 
 syntax
   "_quote"        :: "'b \<Rightarrow> ('a \<Rightarrow> 'b)" ("\<guillemotleft>_\<guillemotright>" [0] 1000)
   "_antiquote"    :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b" ("\<acute>_" [1000] 1000)
-  "_Assign"       :: "'location \<Rightarrow> idt \<Rightarrow> 'b \<Rightarrow> ('answer, 'location, 'question, 'state) com" ("(\<lbrace>_\<rbrace> \<acute>_ :=/ _)" [0, 0, 70] 71) (* FIXME precedence -- see massive ambiguities in the GC model *)
+  "_Assign"       :: "'location \<Rightarrow> idt \<Rightarrow> 'b \<Rightarrow> ('answer, 'location, 'question, 'state) com" ("(\<lbrace>_\<rbrace> \<acute>_ :=/ _)" [0, 0, 70] 71)
   "_NonDetAssign" :: "'location \<Rightarrow> idt \<Rightarrow> 'b set \<Rightarrow> ('answer, 'location, 'question, 'state) com" ("(\<lbrace>_\<rbrace> \<acute>_ :\<in>/ _)" [0, 0, 70] 71)
 
 abbreviation (input) NonDetAssign :: "'location \<Rightarrow> (('val \<Rightarrow> 'val) \<Rightarrow> 'state \<Rightarrow> 'state) \<Rightarrow> ('state \<Rightarrow> 'val set)
                                    \<Rightarrow> ('answer, 'location, 'question, 'state) com" where
   "NonDetAssign l upd es \<equiv> \<lbrace>l\<rbrace> LocalOp (\<lambda>s. { upd \<langle>e\<rangle> s |e. e \<in> es s })"
 
 translations
   "\<lbrace>l\<rbrace> \<acute>x := e" => "CONST DetLocalOp l \<guillemotleft>\<acute>(_update_name x (\<lambda>_. e))\<guillemotright>"
   "\<lbrace>l\<rbrace> \<acute>x :\<in> es" => "CONST NonDetAssign l (_update_name x) \<guillemotleft>es\<guillemotright>"
 
 parse_translation \<open>
   let
     fun antiquote_tr i (Const (@{syntax_const "_antiquote"}, _) $
           (t as Const (@{syntax_const "_antiquote"}, _) $ _)) = skip_antiquote_tr i t
       | antiquote_tr i (Const (@{syntax_const "_antiquote"}, _) $ t) =
           antiquote_tr i t $ Bound i
       | antiquote_tr i (t $ u) = antiquote_tr i t $ antiquote_tr i u
       | antiquote_tr i (Abs (x, T, t)) = Abs (x, T, antiquote_tr (i + 1) t)
       | antiquote_tr _ a = a
     and skip_antiquote_tr i ((c as Const (@{syntax_const "_antiquote"}, _)) $ t) =
           c $ skip_antiquote_tr i t
       | skip_antiquote_tr i t = antiquote_tr i t;
 
     fun quote_tr [t] = Abs ("s", dummyT, antiquote_tr 0 (Term.incr_boundvars 1 t))
       | quote_tr ts = raise TERM ("quote_tr", ts);
   in [(@{syntax_const "_quote"}, K quote_tr)] end
 \<close>
 
 
-subsection\<open>Process semantics\<close>
+subsection\<open>Process semantics \label{sec:cimp-semantics} \<close>
 
 text\<open>
 
-\label{sec:cimp-semantics}
-
 Here we define the semantics of a single process's program. We begin
 by defining the type of externally-visible behaviour:
 
 \<close>
 
 datatype ('answer, 'question) seq_label
   = sl_Internal ("\<tau>")
   | sl_Send 'question 'answer ("\<guillemotleft>_, _\<guillemotright>")
   | sl_Receive 'question 'answer ("\<guillemotright>_, _\<guillemotleft>")
 
 text\<open>
 
 We define a \emph{labelled transition system} (an LTS) using an
 execution-stack style of semantics that avoids special treatment of
 the \<open>SKIP\<close>s introduced by a traditional small step
 semantics (such as @{cite [cite_macro=citet] \<open>Chapter~14\<close>
 "Winskel:1993"}) when a basic command is executed. This was suggested
 by Thomas Sewell; @{cite [cite_macro=citet] "PittsAM:opespe"} gave a
 semantics to an ML-like language using this approach.
 
+We record the location of the command that was executed to support
+fairness constraints.
+
 \<close>
 
 type_synonym ('answer, 'location, 'question, 'state) local_state
-  = "('answer, 'location, 'question, 'state) com list \<times> 'state"
+  = "('answer, 'location, 'question, 'state) com list \<times> 'location option \<times> 'state"
 
 inductive
   small_step :: "('answer, 'location, 'question, 'state) local_state
                \<Rightarrow> ('answer, 'question) seq_label
                \<Rightarrow> ('answer, 'location, 'question, 'state) local_state \<Rightarrow> bool" ("_ \<rightarrow>\<^bsub>_\<^esub> _" [55, 0, 56] 55)
 where
-  Request:  "\<lbrakk> \<alpha> = action s; s' \<in> val \<beta> s \<rbrakk> \<Longrightarrow> (\<lbrace>l\<rbrace> Request action val # cs, s) \<rightarrow>\<^bsub>\<guillemotleft>\<alpha>, \<beta>\<guillemotright>\<^esub> (cs, s')"
-| Response: "(s', \<beta>) \<in> action \<alpha> s \<Longrightarrow> (\<lbrace>l\<rbrace> Response action # cs, s) \<rightarrow>\<^bsub>\<guillemotright>\<alpha>, \<beta>\<guillemotleft>\<^esub> (cs, s')"
-
-| LocalOp: "s' \<in> R s \<Longrightarrow> (\<lbrace>l\<rbrace> LocalOp R # cs, s) \<rightarrow>\<^bsub>\<tau>\<^esub> (cs, s')"
-
-| Cond1True:  "b s \<Longrightarrow> (\<lbrace>l\<rbrace> IF b THEN c FI # cs, s) \<rightarrow>\<^bsub>\<tau>\<^esub> (c # cs, s)"
-| Cond1False: "\<not>b s \<Longrightarrow> (\<lbrace>l\<rbrace> IF b THEN c FI # cs, s) \<rightarrow>\<^bsub>\<tau>\<^esub> (cs, s)"
+  "\<lbrakk> \<alpha> = action s; s' \<in> val \<beta> s \<rbrakk> \<Longrightarrow> (\<lbrace>l\<rbrace> Request action val # cs, _, s) \<rightarrow>\<^bsub>\<guillemotleft>\<alpha>, \<beta>\<guillemotright>\<^esub> (cs, Some l, s')"
+| "(s', \<beta>) \<in> action \<alpha> s \<Longrightarrow> (\<lbrace>l\<rbrace> Response action # cs, _, s) \<rightarrow>\<^bsub>\<guillemotright>\<alpha>, \<beta>\<guillemotleft>\<^esub> (cs, Some l, s')"
 
-| Cond2True:  "b s \<Longrightarrow> (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI # cs, s) \<rightarrow>\<^bsub>\<tau>\<^esub> (c1 # cs, s)"
-| Cond2False: "\<not>b s \<Longrightarrow> (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI # cs, s) \<rightarrow>\<^bsub>\<tau>\<^esub> (c2 # cs, s)"
-
-| Loop:       "(c # LOOP DO c OD # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s') \<Longrightarrow> (LOOP DO c OD # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s')"
+| "s' \<in> R s \<Longrightarrow> (\<lbrace>l\<rbrace> LocalOp R # cs, _, s) \<rightarrow>\<^bsub>\<tau>\<^esub> (cs, Some l, s')"
 
-| While:      "b s \<Longrightarrow> (\<lbrace>l\<rbrace> WHILE b DO c OD # cs, s) \<rightarrow>\<^bsub>\<tau>\<^esub> (c # \<lbrace>l\<rbrace> WHILE b DO c OD # cs, s)"
-| WhileFalse: "\<not> b s \<Longrightarrow> (\<lbrace>l\<rbrace> WHILE b DO c OD # cs, s) \<rightarrow>\<^bsub>\<tau>\<^esub> (cs, s)"
+| "b s \<Longrightarrow> (\<lbrace>l\<rbrace> IF b THEN c FI # cs, _, s) \<rightarrow>\<^bsub>\<tau>\<^esub> (c # cs, Some l, s)"
+| "\<not>b s \<Longrightarrow> (\<lbrace>l\<rbrace> IF b THEN c FI # cs, _, s) \<rightarrow>\<^bsub>\<tau>\<^esub> (cs, Some l, s)"
 
-| Seq:     "(c1 # c2 # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s') \<Longrightarrow> (c1;; c2 # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s')"
+| "b s \<Longrightarrow> (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI # cs, _, s) \<rightarrow>\<^bsub>\<tau>\<^esub> (c1 # cs, Some l, s)"
+| "\<not>b s \<Longrightarrow> (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI # cs, _, s) \<rightarrow>\<^bsub>\<tau>\<^esub> (c2 # cs, Some l, s)"
 
-| Choose1: "(c1 # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s') \<Longrightarrow> (c1 \<squnion> c2 # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s')"
-| Choose2: "(c2 # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s') \<Longrightarrow> (c1 \<squnion> c2 # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s')"
+| "(c # LOOP DO c OD # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s') \<Longrightarrow> (LOOP DO c OD # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s')"
+
+| "b s \<Longrightarrow> (\<lbrace>l\<rbrace> WHILE b DO c OD # cs, _, s) \<rightarrow>\<^bsub>\<tau>\<^esub> (c # \<lbrace>l\<rbrace> WHILE b DO c OD # cs, Some l, s)"
+| "\<not> b s \<Longrightarrow> (\<lbrace>l\<rbrace> WHILE b DO c OD # cs, _, s) \<rightarrow>\<^bsub>\<tau>\<^esub> (cs, Some l, s)"
+
+| "(c1 # c2 # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s') \<Longrightarrow> (c1;; c2 # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s')"
+
+| Choose1: "(c1 # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s') \<Longrightarrow> (c1 \<oplus> c2 # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s')"
+| Choose2: "(c2 # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s') \<Longrightarrow> (c1 \<oplus> c2 # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> (cs', s')"
 
 text\<open>
 
-The following projections operate on local states. These are internal
-to CIMP and should not appear to the end-user.
+The following projections operate on local states. These should not
+appear to the end-user.
 
 \<close>
 
 abbreviation cPGM :: "('answer, 'location, 'question, 'state) local_state \<Rightarrow> ('answer, 'location, 'question, 'state) com list" where
   "cPGM \<equiv> fst"
 
-abbreviation cLST :: "('answer, 'location, 'question, 'state) local_state \<Rightarrow> 'state" where
-  "cLST s \<equiv> snd s"
-(*<*)
-
-declare small_step.intros[intro]
-
-inductive_cases small_step_inv[elim]:
-  "(\<lbrace>l\<rbrace> Request action val # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
-  "(\<lbrace>l\<rbrace> Response action # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
-  "(\<lbrace>l\<rbrace> LocalOp R # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
-  "(\<lbrace>l\<rbrace> IF b THEN c FI # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
-  "(\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
-  "(\<lbrace>l\<rbrace> WHILE b DO c OD # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
-  "(LOOP DO c OD # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
-
-lemma small_step_impossible[iff]:
-  "\<not>(\<lbrace>l\<rbrace> Request action val # cs, ls) \<rightarrow>\<^bsub>\<tau>\<^esub> s'"
-  "\<not>(\<lbrace>l\<rbrace> Request action val # cs, ls) \<rightarrow>\<^bsub>\<guillemotright>\<alpha>, \<beta>\<guillemotleft>\<^esub> s'"
-  "\<not>(\<lbrace>l\<rbrace> Response action' # cs, ls) \<rightarrow>\<^bsub>\<tau>\<^esub> s'"
-  "\<not>(\<lbrace>l\<rbrace> Response action' # cs, ls) \<rightarrow>\<^bsub>\<guillemotleft>\<alpha>, \<beta>\<guillemotright>\<^esub> s'"
-  "\<not>(\<lbrace>l\<rbrace> LocalOp R # cs, ls) \<rightarrow>\<^bsub>\<guillemotright>\<alpha>, \<beta>\<guillemotleft>\<^esub> s'"
-  "\<not>(\<lbrace>l\<rbrace> LocalOp R # cs, ls) \<rightarrow>\<^bsub>\<guillemotleft>\<alpha>, \<beta>\<guillemotright>\<^esub> s'"
-  "\<not>(\<lbrace>l\<rbrace> IF b THEN c FI # cs, ls) \<rightarrow>\<^bsub>\<guillemotright>\<alpha>, \<beta>\<guillemotleft>\<^esub> s'"
-  "\<not>(\<lbrace>l\<rbrace> IF b THEN c FI # cs, ls) \<rightarrow>\<^bsub>\<guillemotleft>\<alpha>, \<beta>\<guillemotright>\<^esub> s'"
-  "\<not>(\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI # cs, ls) \<rightarrow>\<^bsub>\<guillemotright>\<alpha>, \<beta>\<guillemotleft>\<^esub> s'"
-  "\<not>(\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI # cs, ls) \<rightarrow>\<^bsub>\<guillemotleft>\<alpha>, \<beta>\<guillemotright>\<^esub> s'"
-  "\<not>(\<lbrace>l\<rbrace> WHILE b DO c OD # cs, ls) \<rightarrow>\<^bsub>\<guillemotright>\<alpha>, \<beta>\<guillemotleft>\<^esub> s'"
-  "\<not>(\<lbrace>l\<rbrace> WHILE b DO c OD # cs, ls) \<rightarrow>\<^bsub>\<guillemotleft>\<alpha>, \<beta>\<guillemotright>\<^esub> s'"
-by (auto elim: small_step.cases)
-
-lemma small_step_stuck[iff]:
-  "\<not> ([], l, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> c'"
-by (auto elim: small_step.cases)
-
-(*>*)
-text\<open>
-
-\label{sec:cimp-decompose}
-
-To reason about system transitions we need to identify which basic
-statement gets executed next. To that end we factor out the recursive
-cases of the @{term "small_step"} semantics into \emph{contexts},
-which identify the \<open>basic_com\<close> commands with immediate
-externally-visible behaviour. Note that non-determinism means that
-more than one \<open>basic_com\<close> can be enabled at a time.
-
-The representation of evaluation contexts follows @{cite
-[cite_macro=citet] "DBLP:journals/jar/Berghofer12"}. This style of
-operational semantics was originated by @{cite [cite_macro=citet]
-"DBLP:journals/tcs/FelleisenH92"}.
-
-\<close>
-
-type_synonym ('answer, 'location, 'question, 'state) ctxt
-  = "('answer, 'location, 'question, 'state) com \<Rightarrow> ('answer, 'location, 'question, 'state) com"
-
-inductive_set
-  ctxt :: "( ('answer, 'location, 'question, 'state) ctxt
-           \<times> (('answer, 'location, 'question, 'state) com \<Rightarrow> ('answer, 'location, 'question, 'state) com list) ) set"
-where
-  C_Hole: "(id, \<langle>[]\<rangle>) \<in> ctxt"
-| C_Loop: "(E, fctxt) \<in> ctxt \<Longrightarrow> (\<lambda>t. LOOP DO E t OD, \<lambda>t. fctxt t @ [LOOP DO E t OD]) \<in> ctxt"
-| C_Seq: "(E, fctxt) \<in> ctxt \<Longrightarrow> (\<lambda>t. E t;; u, \<lambda>t. fctxt t @ [u]) \<in> ctxt"
-| C_Choose1: "(E, fctxt) \<in> ctxt \<Longrightarrow> (\<lambda>t. E t \<squnion> u, fctxt) \<in> ctxt"
-| C_Choose2: "(E, fctxt) \<in> ctxt \<Longrightarrow> (\<lambda>t. u \<squnion> E t, fctxt) \<in> ctxt"
-
-inductive
-  basic_com :: "('answer, 'location, 'question, 'state) com \<Rightarrow> bool"
-where
-  "basic_com (\<lbrace>l\<rbrace> Request action val)"
-| "basic_com (\<lbrace>l\<rbrace> Response action)"
-| "basic_com (\<lbrace>l\<rbrace> LocalOp R)"
-| "basic_com (\<lbrace>l\<rbrace> IF b THEN c FI)"
-| "basic_com (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI)"
-| "basic_com (\<lbrace>l\<rbrace> WHILE b DO c OD)"
-(*<*)
-
-declare basic_com.intros[intro!] basic_com.cases[elim]
-
-(*>*)
-text\<open>
+abbreviation cTKN :: "('answer, 'location, 'question, 'state) local_state \<Rightarrow> 'location option" where
+  "cTKN s \<equiv> fst (snd s)"
 
-We can decompose a small step into a context and a @{term
-"basic_com"}.
-
-\<close>
-
-fun
-  decompose_com :: "('answer, 'location, 'question, 'state) com
-                      \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
-                        \<times> ('answer, 'location, 'question, 'state) ctxt
-                        \<times> (('answer, 'location, 'question, 'state) com \<Rightarrow> ('answer, 'location, 'question, 'state) com list) ) set"
-where
-  "decompose_com (LOOP DO c1 OD) = { (c, \<lambda>t. LOOP DO ictxt t OD, \<lambda>t. fctxt t @ [LOOP DO ictxt t OD]) |c fctxt ictxt. (c, ictxt, fctxt) \<in> decompose_com c1 }"
-| "decompose_com (c1;; c2) = { (c, \<lambda>t. ictxt t;; c2, \<lambda>t. fctxt t @ [c2]) |c fctxt ictxt. (c, ictxt, fctxt) \<in> decompose_com c1 }"
-| "decompose_com (c1 \<squnion> c2) = { (c, \<lambda>t. ictxt t \<squnion> c2, fctxt) |c fctxt ictxt. (c, ictxt, fctxt) \<in> decompose_com c1 }
-                           \<union> { (c, \<lambda>t. c1 \<squnion> ictxt t, fctxt) |c fctxt ictxt. (c, ictxt, fctxt) \<in> decompose_com c2 }"
-| "decompose_com c = {(c, id, \<langle>[]\<rangle>)}"
-
-definition
-  decomposeLS :: "('answer, 'location, 'question, 'state) local_state
-               \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
-                 \<times> (('answer, 'location, 'question, 'state) com \<Rightarrow> ('answer, 'location, 'question, 'state) com)
-                 \<times> (('answer, 'location, 'question, 'state) com \<Rightarrow> ('answer, 'location, 'question, 'state) com list) ) set"
-where
-  "decomposeLS s \<equiv> case cPGM s of c # _ \<Rightarrow> decompose_com c | _ \<Rightarrow> {}"
-
-(*<*)
-declare ctxt.intros[intro!]
-
-lemma ctxt_inj:
-  assumes "(E, fctxt) \<in> ctxt"
-  assumes "E x = E y"
-  shows "x = y"
-using assms by (induct set: ctxt) auto
-
-lemma decompose_ctxt:
-  assumes "(c', ictxt, fctxt) \<in> decompose_com c"
-  shows "(ictxt, fctxt) \<in> ctxt"
-using assms by (induct c arbitrary: c' ictxt fctxt) auto
+abbreviation cLST :: "('answer, 'location, 'question, 'state) local_state \<Rightarrow> 'state" where
+  "cLST s \<equiv> snd (snd s)"
 
-lemma decompose_ictxt:
-  assumes "(c', ictxt, fctxt) \<in> decompose_com c"
-  shows "c = ictxt c'"
-using assms by (induct c arbitrary: c' ictxt fctxt) auto
-(*>*)
 
-theorem context_decompose:
-  "s \<rightarrow>\<^bsub>\<alpha>\<^esub> s' \<longleftrightarrow> (\<exists>(c, ictxt, fctxt) \<in> decomposeLS s.
-                     cPGM s = ictxt c # tl (cPGM s)
-                   \<and> basic_com c
-                   \<and> (c # fctxt c @ tl (cPGM s), cLST s) \<rightarrow>\<^bsub>\<alpha>\<^esub> s')"
-(*<*)(is "?lhs = ?rhs")
-proof
-  assume ?lhs then show ?rhs
-    by (induct rule: small_step.induct)
-       (fastforce simp: decomposeLS_def)+
-next
-  have gen: "(c0 # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> s'"
-    if as: "(c # fctxt c @ cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> s'"
-   and ds: "(c, ictxt, fctxt) \<in> decompose_com c0"
-   for cs c c0 ictxt fctxt l s s'
-  proof -
-    from ds have ic: "(ictxt, fctxt) \<in> ctxt"
-      unfolding decomposeLS_def by (auto intro: decompose_ctxt split: list.splits)
-    from ic as decompose_ictxt[OF ds]
-    show "(c0 # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> s'"
-      by (induct ictxt fctxt arbitrary: c0 cs set: ctxt)
-         (cases s', fastforce simp: fun_eq_iff dest: ctxt_inj)+
-  qed
-  assume ?rhs then show ?lhs
-    by (cases s)
-       (auto simp: decomposeLS_def split: list.splits dest!: gen)
-qed
-
-(*>*)
-text\<open>
-
-While we only use this result left-to-right (to decompose a small step
-into a basic one), this equivalence shows that we lose no information
-in doing so.
-
-\<close>
-
-subsection\<open>System steps\<close>
+subsection\<open>System steps \label{sec:cimp-system-steps}\<close>
 
 text\<open>
 
-\label{sec:cimp-system-steps}
-
 A global state maps process names to process' local states. One might
 hope to allow processes to have distinct types of local state, but
 there remains no good solution yet in a simply-typed setting; see
 @{cite [cite_macro=citet] "DBLP:journals/entcs/SchirmerW09"}.
 
 \<close>
 
 type_synonym ('answer, 'location, 'proc, 'question, 'state) global_state
   = "'proc \<Rightarrow> ('answer, 'location, 'question, 'state) local_state"
 
 type_synonym ('proc, 'state) local_states
   = "'proc \<Rightarrow> 'state"
 
 text\<open>
 
 An execution step of the overall system is either any enabled internal
 @{term "\<tau>"} step of any process, or a communication rendezvous between
 two processes. For the latter to occur, a @{const "Request"} action
 must be enabled in process @{term "p1"}, and a @{const "Response"}
 action in (distinct) process @{term "p2"}, where the request/response
 labels @{term "\<alpha>"} and @{term "\<beta>"} (semantically) match.
 
 We also track global communication history here to support assertional
-reasoning (see \S\ref{sec:cimp-assertions}).
+reasoning (see \S\ref{sec:cimp-invariants}).
 
 \<close>
 
 type_synonym ('answer, 'question) event = "'question \<times> 'answer"
 type_synonym ('answer, 'question) history = "('answer, 'question) event list"
 
-type_synonym ('answer, 'location, 'proc, 'question, 'state) system_state
-  = "('answer, 'location, 'proc, 'question, 'state) global_state
-   \<times> ('answer, 'question) history"
-
-inductive_set
-  system_step :: "( ('answer, 'ls, 'proc, 'question, 'state) system_state
-                  \<times> ('answer, 'ls, 'proc, 'question, 'state) system_state ) set"
-where
-  LocalStep: "\<lbrakk> s p \<rightarrow>\<^bsub>\<tau>\<^esub> ls'; s' = s(p := ls'); h' = h \<rbrakk> \<Longrightarrow> ((s, h), (s', h')) \<in> system_step"
-| CommunicationStep: "\<lbrakk> s p1 \<rightarrow>\<^bsub>\<guillemotleft>\<alpha>, \<beta>\<guillemotright>\<^esub> ls1'; s p2 \<rightarrow>\<^bsub>\<guillemotright>\<alpha>, \<beta>\<guillemotleft>\<^esub> ls2'; p1 \<noteq> p2;
-                        s' = s(p1 := ls1', p2 := ls2'); h' = h @ [(\<alpha>, \<beta>)] \<rbrakk> \<Longrightarrow> ((s, h), (s', h')) \<in> system_step"
+record ('answer, 'location, 'proc, 'question, 'state) system_state =
+  GST :: "('answer, 'location, 'proc, 'question, 'state) global_state"
+  HST :: "('answer, 'question) history"
 
-abbreviation
-  system_step_syn :: "('answer, 'ls, 'proc, 'question, 'state) system_state
-                    \<Rightarrow> ('answer, 'ls, 'proc, 'question, 'state) system_state \<Rightarrow> bool" ("_ s\<Rightarrow> _" [55, 56] 55)
+inductive \<comment>\<open> This is a predicate of the current state, so the successor state comes first. \<close>
+  system_step :: "'proc set
+              \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) system_state
+              \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) system_state
+              \<Rightarrow> bool"
 where
-  "sh s\<Rightarrow> sh' \<equiv> (sh, sh') \<in> system_step"
+  LocalStep: "\<lbrakk> GST sh p \<rightarrow>\<^bsub>\<tau>\<^esub> ls'; GST sh' = (GST sh)(p := ls'); HST sh' = HST sh \<rbrakk> \<Longrightarrow> system_step {p} sh' sh"
+| CommunicationStep: "\<lbrakk> GST sh p \<rightarrow>\<^bsub>\<guillemotleft>\<alpha>, \<beta>\<guillemotright>\<^esub> ls1'; GST sh q \<rightarrow>\<^bsub>\<guillemotright>\<alpha>, \<beta>\<guillemotleft>\<^esub> ls2'; p \<noteq> q;
+                        GST sh' = (GST sh)(p := ls1', q := ls2'); HST sh' = HST sh @ [(\<alpha>, \<beta>)] \<rbrakk> \<Longrightarrow> system_step {p, q} sh' sh"
 
-abbreviation
-  system_steps_syn :: "('answer, 'ls, 'proc, 'question, 'state) system_state
-                     \<Rightarrow> ('answer, 'ls, 'proc, 'question, 'state) system_state \<Rightarrow> bool" ("_ s\<Rightarrow>\<^sup>* _" [55, 56] 55)
-where
-  "sh s\<Rightarrow>\<^sup>* sh' \<equiv> (sh, sh') \<in> system_step\<^sup>*"
-(*<*)
-
-(*>*)
 text\<open>
 
 In classical process algebras matching communication actions yield
 \<open>\<tau>\<close> steps, which aids nested parallel composition
 and the restriction operation @{cite [cite_macro=citep]
 \<open>\S2.2\<close> "Milner:1980"}. As CIMP does not provide either
 we do not need to hide communication labels. In CCS/CSP it is not
 clear how one reasons about the communication history, and it seems
 that assertional reasoning about these languages is not well
 developed.
 
 \<close>
 
-subsection\<open>Assertions\<close>
+text\<open>
+
+We define predicates over communication histories and system states. These are uncurried to ease composition.
+
+\<close>
+
+type_synonym ('answer, 'location, 'proc, 'question, 'state) state_pred
+  = "('answer, 'location, 'proc, 'question, 'state) system_state \<Rightarrow> bool"
 
 text\<open>
 
-\label{sec:cimp-assertions}
+The \<open>LST\<close> operator (written as a postfix \<open>\<down>\<close>) projects
+the local states of the processes from a \<^typ>\<open>('answer, 'location, 'proc, 'question, 'state) system_state\<close>, i.e. it
+discards control location information.
 
-We now develop a technique for showing that a CIMP system satisfies a
-single global invariant, following @{cite [cite_macro=citet]
-"DBLP:journals/acta/Lamport80" and "DBLP:journals/toplas/LamportS84"}
-(and the later @{cite [cite_macro=citet] "DBLP:books/aw/Lamport2002"})
-and closely related work by @{cite [cite_macro=citet]
-"AptFrancezDeRoever:1980"}, @{cite [cite_macro=citet]
-"CousotCousot:1980"} and @{cite [cite_macro=citet]
-"DBLP:journals/acta/LevinG81"}, which suggest the incorporation of a
-history variable. @{cite [cite_macro=citet] "CousotCousot:1980"}
-apparently contains a completeness proof.  Lamport mentions that this
-technique was well-known in the mid-80s when he proposed the use of
-prophecy variables (see his webpage bibliography). See also @{cite
-[cite_macro=citet] "DBLP:books/cu/RoeverBH2001"} for an extended
-discussion of some of this.
+Conversely the \<open>LSTP\<close> operator lifts predicates over
+local states into predicates over \<^typ>\<open>('answer, 'location, 'proc, 'question, 'state) system_state\<close>.
 
-Achieving the right level of abstraction is a bit fiddly; we want to
-avoid revealing too much of the program text as it
-executes. Intuitively we wish to expose the processes's present
-control locations and local states only. @{cite [cite_macro=citet]
-"DBLP:journals/acta/Lamport80"} avoids these issues by only providing
-an axiomatic semantics for his language.
+Predicates that do not depend on control locations were termed @{emph
+\<open>universal assertions\<close>} by @{cite [cite_macro=citet]
+\<open>\S3.6\<close> "DBLP:journals/acta/LevinG81"}.
 
 \<close>
 
-subsubsection\<open>Control predicates\<close>
+type_synonym ('proc, 'state) local_state_pred
+  = "('proc, 'state) local_states \<Rightarrow> bool"
+
+definition LST :: "('answer, 'location, 'proc, 'question, 'state) system_state
+                 \<Rightarrow> ('proc, 'state) local_states" ("_\<down>" [1000] 1000) where
+  "s\<down> = cLST \<circ> GST s"
+
+abbreviation (input) LSTP :: "('proc, 'state) local_state_pred
+                            \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred" where
+  "LSTP P \<equiv> \<lambda>s. P s\<down>"
+
+
+subsection\<open>Control predicates \label{sec:cimp-control-predicates}\<close>
 
 text\<open>
 
-\label{sec:cimp-control-predicates}
-
 Following @{cite [cite_macro=citet]
 "DBLP:journals/acta/Lamport80"}\footnote{@{cite [cite_macro=citet]
 "MannaPnueli:1995"} also develop a theory of locations. I think
 Lamport attributes control predicates to Owicki in her PhD thesis
 (under Gries). I did not find a treatment of procedures. @{cite
-[cite_macro=citet] "MannaPnueli:1991"} observe that a set notation for
-spreading assertions over sets of locations reduces clutter
+[cite_macro=citet] "MannaPnueli:1991"} observe that a notation for
+making assertions over sets of locations reduces clutter
 significantly.}, we define the \<open>at\<close> predicate, which
 holds of a process when control resides at that location. Due to
 non-determinism processes can be \<open>at\<close> a set of locations;
 it is more like ``a statement with this location is enabled'', which
 incidentally handles non-unique locations. Lamport's language is
 deterministic, so he doesn't have this problem. This also allows him
 to develop a stronger theory about his control predicates.
 
 \<close>
 
+type_synonym 'location label = "'location set"
+
 primrec
-  atC :: "('answer, 'location, 'question, 'state) com \<Rightarrow> 'location \<Rightarrow> bool"
+  atC :: "('answer, 'location, 'question, 'state) com \<Rightarrow> 'location label"
 where
-  "atC (\<lbrace>l'\<rbrace> Request action val) = (\<lambda>l. l = l')"
-| "atC (\<lbrace>l'\<rbrace> Response action) = (\<lambda>l. l = l')"
-| "atC (\<lbrace>l'\<rbrace> LocalOp f) = (\<lambda>l. l = l')"
-| "atC (\<lbrace>l'\<rbrace> IF _ THEN _ FI) = (\<lambda>l. l = l')"
-| "atC (\<lbrace>l'\<rbrace> IF _ THEN _ ELSE _ FI) = (\<lambda>l. l = l')"
-| "atC (\<lbrace>l'\<rbrace> WHILE _ DO _ OD) = (\<lambda>l. l = l')"
+  "atC (\<lbrace>l\<rbrace> Request action val) = {l}"
+| "atC (\<lbrace>l\<rbrace> Response action) = {l}"
+| "atC (\<lbrace>l\<rbrace> LocalOp f) = {l}"
+| "atC (\<lbrace>l\<rbrace> IF _ THEN _ FI) = {l}"
+| "atC (\<lbrace>l\<rbrace> IF _ THEN _ ELSE _ FI) = {l}"
+| "atC (\<lbrace>l\<rbrace> WHILE _ DO _ OD) = {l}"
 | "atC (LOOP DO c OD) = atC c"
 | "atC (c1;; c2) = atC c1"
-| "atC (c1 \<squnion> c2) = (atC c1 \<^bold>\<or> atC c2)"
-
-primrec atL :: "('answer, 'location, 'question, 'state) com list \<Rightarrow> 'location \<Rightarrow> bool" where
-  "atL [] = \<langle>False\<rangle>"
-| "atL (c # _) = atC c"
-
-abbreviation atLS :: "('answer, 'location, 'question, 'state) local_state \<Rightarrow> 'location \<Rightarrow> bool" where
-  "atLS \<equiv> \<lambda>s. atL (cPGM s)"
-(*<*)
-
-lemma at_decompose:
-  "(c, ictxt, fctxt) \<in> decompose_com c0 \<Longrightarrow> (\<forall>l. atC c l \<longrightarrow> atC c0 l)"
-by (induct c0 arbitrary: c ictxt fctxt) fastforce+
-
-lemma at_decomposeLS:
-  "(c, ictxt, fctxt) \<in> decomposeLS s \<Longrightarrow> (\<forall>l. atC c l \<longrightarrow> atLS s l)"
-by (auto simp: decomposeLS_def at_decompose split: list.splits)
-
-(*>*)
-text\<open>
+| "atC (c1 \<oplus> c2) = atC c1 \<union> atC c2"
 
-We define predicates over communication histories and a projection of
-global states. These are uncurried to ease composition.
-
-\<close>
-
-type_synonym ('location, 'proc, 'state) pred_local_state
-  = "'proc \<Rightarrow> (('location \<Rightarrow> bool) \<times> 'state)"
-
-record ('answer, 'location, 'proc, 'question, 'state) pred_state =
-  local_states :: "('location, 'proc, 'state) pred_local_state"
-  hist :: "('answer, 'question) history"
+primrec atCs :: "('answer, 'location, 'question, 'state) com list \<Rightarrow> 'location label" where
+  "atCs [] = {}"
+| "atCs (c # _) = atC c"
 
-type_synonym ('answer, 'location, 'proc, 'question, 'state) pred
-  = "('answer, 'location, 'proc, 'question, 'state) pred_state \<Rightarrow> bool"
-
-definition mkP :: "('answer, 'location, 'proc, 'question, 'state) system_state \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) pred_state" where
-  "mkP \<equiv> \<lambda>(s, h). \<lparr> local_states = \<lambda>p. case s p of (cs, ps) \<Rightarrow> (atL cs, ps), hist = h \<rparr>"
-(*<*)
-
-lemma hist_mkP[iff]:
-  "hist (mkP (s, h)) = h"
-by (simp add: mkP_def)
-
-(*>*)
 text\<open>
 
 We provide the following definitions to the end-user.
 
 \<open>AT\<close> maps process names to a predicate that is true of
-locations where control for that process resides. The abbreviation
-\<open>at\<close> shuffles its parameters; the former is
-simplifier-friendly and eta-reduced, while the latter is convenient
-for writing assertions.
-
-\<close>
-
-definition AT :: "('answer, 'location, 'proc, 'question, 'state) pred_state \<Rightarrow> 'proc \<Rightarrow> 'location \<Rightarrow> bool" where
-  "AT \<equiv> \<lambda>s p l. fst (local_states s p) l"
-
-abbreviation at :: "'proc \<Rightarrow> 'location \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) pred" where
-  "at p l s \<equiv> AT s p l"
-
-text\<open>
-
-Often we wish to talk about control residing at one of a set of
-locations. This stands in for, and generalises, the \<open>in\<close>
-predicate of @{cite [cite_macro=citet]
+locations where control for that process resides, and the abbreviation \<open>at\<close> provides a conventional
+way to use it. The constant \<open>atS\<close> specifies that control for process \<open>p\<close> resides at one of
+the given locations. This stands in for, and generalises, the \<open>in\<close> predicate of @{cite [cite_macro=citet]
 "DBLP:journals/acta/Lamport80"}.
 
 \<close>
 
-definition atS :: "'proc \<Rightarrow> 'location set \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) pred" where
-  "atS \<equiv> \<lambda>p ls s. \<exists>l\<in>ls. at p l s"
+definition AT :: "('answer, 'location, 'proc, 'question, 'state) system_state \<Rightarrow> 'proc \<Rightarrow> 'location label" where
+  "AT s p = atCs (cPGM (GST s p))"
+
+abbreviation at :: "'proc \<Rightarrow> 'location \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred" where
+  "at p l s \<equiv> l \<in> AT s p"
+
+definition atS :: "'proc \<Rightarrow> 'location set \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred" where
+  "atS p ls s = (\<exists>l\<in>ls. at p l s)"
+
+(* FIXME rename, document, rules. Identifies a process's control state label precisely as one element of a set. *)
+definition atLs :: "'proc \<Rightarrow> 'location label set \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred" where
+  "atLs p labels s = (AT s p \<in> labels)"
+
+(* FIXME rename, document. Identifies a process's control state label precisely. Relate atL to at/atS, ex/ *)
+abbreviation (input) atL :: "'proc \<Rightarrow> 'location label \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred" where
+  "atL p label \<equiv> atLs p {label}"
+
+(* FIXME rename, document. Processes are at the given labels. *)
+definition atPLs :: "('proc \<times> 'location label) set \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred" where
+  "atPLs pls = (\<^bold>\<forall>p label. \<langle>(p, label) \<in> pls\<rangle> \<^bold>\<longrightarrow> atL p label)"
 
 text\<open>
 
+The constant \<open>taken\<close> provides a way of identifying which transition was taken. It is somewhat like
+Lamport's \<open>after\<close>, but not quite due to the presence of non-determinism here. This does not work well
+for invariants or preconditions.
+
+\<close>
+
+definition taken :: "'proc \<Rightarrow> 'location \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred" where
+  "taken p l s \<longleftrightarrow> cTKN (GST s p) = Some l"
+
+text\<open>
+
+\label{sec:cimp-termination}
+
 A process is terminated if it not at any control location.
 
 \<close>
 
-abbreviation terminated :: "'proc \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) pred" where
-  "terminated p s \<equiv> \<forall>l. \<not>at p l s"
-
-text\<open>
-
-The \<open>LST\<close> operator (written as a postfix \<open>\<down>\<close>) projects
-the local states of the processes from a \<open>pred_state\<close>, i.e. it
-discards control location information.
-
-Conversely the \<open>LSTP\<close> operator lifts predicates over
-local states into predicates over \<open>pred_state\<close>.  @{cite
-[cite_macro=citet] \<open>\S3.6\<close> "DBLP:journals/acta/LevinG81"}
-call such predicates \emph{universal assertions}.
-
-\<close>
-
-type_synonym ('proc, 'state) state_pred
-  = "('proc, 'state) local_states \<Rightarrow> bool"
-
-definition LST :: "('answer, 'location, 'proc, 'question, 'state) pred_state
-                 \<Rightarrow> ('proc, 'state) local_states" ("_\<down>" [1000] 1000) where
-  "s\<down> \<equiv> snd \<circ> local_states s"
-
-abbreviation (input) LSTP :: "('proc, 'state) state_pred
-                            \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) pred" where
-  "LSTP P \<equiv> \<lambda>s. P (LST s)"
+abbreviation (input) terminated :: "'proc \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred" where
+  "terminated p \<equiv> atL p {}"
 
 text\<open>
 
-By default we ask the simplifier to rewrite @{const "atS"} using
-ambient @{const "AT"} information.
-
-\<close>
-
-lemma atS_state_cong[cong]:
-  "\<lbrakk> AT s p = AT s' p \<rbrakk> \<Longrightarrow> atS p ls s \<longleftrightarrow> atS p ls s'"
-by (auto simp: atS_def)
-
-text\<open>
-
-We provide an incomplete set of basic rules for label sets.
-
-\<close>
-
-lemma atS_simps:
-  "\<not>atS p {} s"
-  "atS p {l} s \<longleftrightarrow> at p l s"
-  "\<lbrakk> at p l s; l \<in> ls \<rbrakk> \<Longrightarrow> atS p ls s \<longleftrightarrow> True"
-  "(\<forall>l. at p l s \<longrightarrow> l \<notin> ls) \<Longrightarrow> atS p ls s \<longleftrightarrow> False"
-by (auto simp: atS_def)
-
-lemma atS_mono:
-  "\<lbrakk> atS p ls s; ls \<subseteq> ls' \<rbrakk> \<Longrightarrow> atS p ls' s"
-by (auto simp: atS_def)
-
-lemma atS_un:
-  "atS p (l \<union> l') s \<longleftrightarrow> atS p l s \<or> atS p l' s"
-by (auto simp: atS_def)
-
-subsubsection\<open>Invariants\<close>
-
-text\<open>
-
-\label{sec:cimp-invariants}
-
 A complete system consists of one program per process, and a (global)
 constraint on their initial local states. From these we can construct
 the set of initial global states and all those reachable by system
 steps (\S\ref{sec:cimp-system-steps}).
 
 \<close>
 
 type_synonym ('answer, 'location, 'proc, 'question, 'state) programs
   = "'proc \<Rightarrow> ('answer, 'location, 'question, 'state) com"
 
-type_synonym ('answer, 'location, 'proc, 'question, 'state) system
-  = "('answer, 'location, 'proc, 'question, 'state) programs
-   \<times> ('proc, 'state) state_pred"
+record ('answer, 'location, 'proc, 'question, 'state) pre_system =
+  PGMs :: "('answer, 'location, 'proc, 'question, 'state) programs"
+  INIT :: "('proc, 'state) local_state_pred"
 
 definition
-  initial_states :: "('answer, 'location, 'proc, 'question, 'state) system
-                   \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) global_state set"
+  initial_state :: "('answer, 'location, 'proc, 'question, 'state, 'ext) pre_system_ext
+                   \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) global_state
+                   \<Rightarrow> bool"
 where
-  "initial_states sys \<equiv>
-     { f . (\<forall>p. cPGM (f p) = [fst sys p]) \<and> snd sys (cLST \<circ> f) }"
-
-definition
-  reachable_states :: "('answer, 'location, 'proc, 'question, 'state) system
-                     \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) system_state set"
-where
-  "reachable_states sys \<equiv> system_step\<^sup>* `` (initial_states sys \<times> {[]})"
+  "initial_state sys s = ((\<forall>p. cPGM (s p) = [PGMs sys p] \<and> cTKN (s p) = None) \<and> INIT sys (cLST \<circ> s))"
 
 text\<open>
 
-The following is a slightly more convenient induction rule for the set
-of reachable states.
-
-\<close>
-
-lemma reachable_states_system_step_induct[consumes 1,
-                                          case_names init LocalStep CommunicationStep]:
-  assumes r: "(s, h) \<in> reachable_states sys"
-  assumes i: "\<And>s. s \<in> initial_states sys \<Longrightarrow> P s []"
-  assumes l: "\<And>s h ls' p. \<lbrakk> (s, h) \<in> reachable_states sys; P s h; s p \<rightarrow>\<^bsub>\<tau>\<^esub> ls' \<rbrakk>
-                    \<Longrightarrow> P (s(p := ls')) h"
-  assumes c: "\<And>s h ls1' ls2' p1 p2 \<alpha> \<beta>.
-                 \<lbrakk> (s, h) \<in> reachable_states sys; P s h;
-                 s p1 \<rightarrow>\<^bsub>\<guillemotleft>\<alpha>, \<beta>\<guillemotright>\<^esub> ls1'; s p2 \<rightarrow>\<^bsub>\<guillemotright>\<alpha>, \<beta>\<guillemotleft>\<^esub> ls2'; p1 \<noteq> p2 \<rbrakk>
-                    \<Longrightarrow> P (s(p1 := ls1', p2 := ls2')) (h @ [(\<alpha>, \<beta>)])"
-  shows "P s h"
-(*<*)
-proof -
-  have "P s' h'" if "(s, []) s\<Rightarrow>\<^sup>* (s', h')" "s \<in> initial_states sys" for s s' h'
-    using that
-    by (induct rule: rtrancl_induct2)
-       (fastforce simp: reachable_states_def elim: system_step.cases intro: i l c)+
-  with r show ?thesis by (clarsimp simp: reachable_states_def)
-qed
+We construct infinite runs of a system by allowing stuttering, i.e., arbitrary repetitions of states
+following @{cite [cite_macro=citet] \<open>Chapter~8\<close>"Lamport:2002"}, by taking the reflexive
+closure of the @{const system_step} relation. Therefore terminated
+programs infinitely repeat their final state (but note our definition
+of terminated processes in \S\ref{sec:cimp-termination}).
 
-lemma initial_statesD:
-  "s \<in> initial_states sys \<Longrightarrow> AT (mkP (s, [])) = atC \<circ> fst sys \<and> snd sys (mkP (s, []))\<down>"
-by (simp add: initial_states_def mkP_def split_def o_def LST_def AT_def)
-
-lemma initial_states_mkP[iff]:
-  "s \<in> initial_states sys \<Longrightarrow> at p l (mkP (s, [])) \<longleftrightarrow> atC (fst sys p) l"
-by (simp add: initial_states_def mkP_def split_def AT_def)
-
-(*>*)
-subsubsection\<open>Relating reachable states to the initial programs\<close>
-
-text\<open>
-
-\label{sec:cimp-decompose-small-step}
-
-To usefully reason about the control locations presumably embedded in
-the single global invariant, we need to link the programs we have in
-reachable state \<open>s\<close> to the programs in the initial states. The
-\<open>fragments\<close> function decomposes the program into statements
-that can be directly executed (\S\ref{sec:cimp-decompose}). We also
-compute the locations we could be at after executing that statement as
-a function of the process's local state.
-
-We could support Lamport's \<open>after\<close> control predicate with more
-syntactic analysis of this kind.
+Some accounts define stuttering as the @{emph \<open>finite\<close>} repetition of states. With or without this constraint
+\<open>prerun\<close> contains @{emph \<open>junk\<close>} in the form of unfair runs, where particular processes do not progress.
 
 \<close>
 
-fun
-  extract_cond :: "('answer, 'location, 'question, 'state) com \<Rightarrow> 'state bexp"
-where
-  "extract_cond (\<lbrace>l\<rbrace> IF b THEN c FI) = b"
-| "extract_cond (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI) = b"
-| "extract_cond (\<lbrace>l\<rbrace> WHILE b DO c OD) = b"
-| "extract_cond c = \<langle>False\<rangle>"
-
-type_synonym  ('answer, 'location, 'question, 'state) loc_comp
-  = "('answer, 'location, 'question, 'state) com
-   \<Rightarrow> 'state \<Rightarrow> 'location \<Rightarrow> bool"
-
-fun lconst :: "('location \<Rightarrow> bool) \<Rightarrow> ('answer, 'location, 'question, 'state) loc_comp" where
-  "lconst lp b s = lp"
-
-definition lcond :: "('location \<Rightarrow> bool) \<Rightarrow> ('location \<Rightarrow> bool)
-                   \<Rightarrow> ('answer, 'location, 'question, 'state) loc_comp" where
-  "lcond lp lp' c s \<equiv> if extract_cond c s then lp else lp'"
-(*<*)
-
-lemma lcond_split:
-  "Q (lcond lp lp' c s) \<longleftrightarrow> (extract_cond c s \<longrightarrow> Q lp) \<and> (\<not>extract_cond c s \<longrightarrow> Q lp')"
-by (simp add: lcond_def split: if_splits)
-
-lemma lcond_split_asm:
-  "Q (lcond lp lp' c s) \<longleftrightarrow> \<not> ((extract_cond c s \<and> \<not>Q lp) \<or> (\<not>extract_cond c s \<and> \<not> Q lp'))"
-by (simp add: lcond_def split: if_splits)
-
-lemmas lcond_splits = lcond_split lcond_split_asm
-(*>*)
-
-fun
-  fragments :: "('answer, 'location, 'question, 'state) com
-              \<Rightarrow> ('location \<Rightarrow> bool)
-              \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
-               \<times> ('answer, 'location, 'question, 'state) loc_comp ) set"
+definition
+  system_step_reflclp :: "('answer, 'location, 'proc, 'question, 'state) system_state seq_pred"
 where
-  "fragments (\<lbrace>l\<rbrace> IF b THEN c FI) ls
-       = { (\<lbrace>l\<rbrace> IF b THEN c' FI, lcond (atC c) ls) |c'. True }
-        \<union> fragments c ls"
-| "fragments (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI) ls
-       = { (\<lbrace>l\<rbrace> IF b THEN c1' ELSE c2' FI, lcond (atC c1) (atC c2)) |c1' c2'. True }
-        \<union> fragments c1 ls \<union> fragments c2 ls"
-| "fragments (LOOP DO c OD) ls = fragments c (atC c)"
-| "fragments (\<lbrace>l'\<rbrace> WHILE b DO c OD) ls
-       = { (\<lbrace>l'\<rbrace> WHILE b DO c' OD, lcond (atC c) ls) |c'. True } \<union> fragments c (\<lambda>l. l = l')"
-| "fragments (c1;; c2) ls = fragments c1 (atC c2) \<union> fragments c2 ls"
-| "fragments (c1 \<squnion> c2) ls = fragments c1 ls \<union> fragments c2 ls"
-| "fragments c ls = { (c, lconst ls) }"
+  "system_step_reflclp \<sigma> \<longleftrightarrow> (\<lambda>sh sh'. \<exists>pls. system_step pls sh' sh)\<^sup>=\<^sup>= (\<sigma> 0) (\<sigma> 1)"
 
-fun
-  fragmentsL :: "('answer, 'location, 'question, 'state) com list
-               \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
-                 \<times> ('answer, 'location, 'question, 'state) loc_comp ) set"
+definition
+  prerun :: "('answer, 'location, 'proc, 'question, 'state, 'ext) pre_system_ext
+         \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) system_state seq_pred"
 where
-  "fragmentsL [] = {}"
-| "fragmentsL [c] = fragments c \<langle>False\<rangle>"
-| "fragmentsL (c # c' # cs) = fragments c (atC c') \<union> fragmentsL (c' # cs)"
-
-abbreviation
-  fragmentsLS :: "('answer, 'location, 'question, 'state) local_state
-               \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
-                 \<times> ('answer, 'location, 'question, 'state) loc_comp ) set"
-where
-  "fragmentsLS s \<equiv> fragmentsL (cPGM s)"
-(*<*)
+  "prerun sys = ((\<lambda>\<sigma>. initial_state sys (GST (\<sigma> 0)) \<and> HST (\<sigma> 0) = []) \<^bold>\<and> \<box>system_step_reflclp)"
 
-lemma fragmentsL_mono_Cons[iff]:
-  "fragmentsL cs \<subseteq> fragmentsL (c # cs)"
-by (induct cs) auto
+definition \<comment>\<open> state-based invariants only \<close>
+  prerun_valid :: "('answer, 'location, 'proc, 'question, 'state, 'ext) pre_system_ext
+                   \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred \<Rightarrow> bool" ("_ \<Turnstile>\<^bsub>pre\<^esub> _" [11, 0] 11) (* FIXME priorities *)
+where
+  "(sys \<Turnstile>\<^bsub>pre\<^esub> \<phi>) \<longleftrightarrow> (\<forall>\<sigma>. prerun sys \<sigma> \<longrightarrow> (\<box>\<lceil>\<phi>\<rceil>) \<sigma>)"
 
-lemma small_step_fragmentsLS:
-  assumes "s \<rightarrow>\<^bsub>\<alpha>\<^esub> s'"
-  shows "fragmentsLS s' \<subseteq> fragmentsLS s"
-using assms by (induct rule: small_step.induct) (case_tac [!] cs, auto)
-
-lemmas small_step_fragmentsLS_mem = subsetD[OF small_step_fragmentsLS]
-
-(*>*)
 text\<open>
 
-Eliding the bodies of \<open>IF\<close> and \<open>WHILE\<close> statements
-yields smaller (but equivalent) proof obligations.
-
-We show that taking system steps preserves fragments.
+A \<open>run\<close> of a system is a @{const \<open>prerun\<close>} that satisfies the \<open>FAIR\<close> requirement.
+Typically this would include @{emph \<open>weak fairness\<close>} for every transition of every process.
 
 \<close>
 
-lemma reachable_states_fragmentsLS:
-  assumes "(s, h) \<in> reachable_states sys"
-  shows "fragmentsLS (s p) \<subseteq> fragments (fst sys p) \<langle>False\<rangle>"
-(*<*)
-using assms
-by (induct rule: reachable_states_system_step_induct)
-   (auto simp: initial_states_def dest: small_step_fragmentsLS_mem)
-(*>*)
-
-text\<open>
-
-Decomposing a compound command preserves fragments too.
-
-\<close>
-
-fun
-  extract_inner_locations :: "('answer, 'location, 'question, 'state) com
-                            \<Rightarrow> ('answer, 'location, 'question, 'state) com list
-                            \<Rightarrow> ('answer, 'location, 'question, 'state) loc_comp"
-where
-  "extract_inner_locations (\<lbrace>l\<rbrace> IF b THEN c FI) cs = lcond (atC c) (atL cs)"
-| "extract_inner_locations (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI) cs = lcond (atC c1) (atC c2)"
-| "extract_inner_locations (LOOP DO c OD) cs = lconst (atC c)"
-| "extract_inner_locations (\<lbrace>l\<rbrace> WHILE b DO c OD) cs = lcond (atC c) (atL cs)"
-| "extract_inner_locations c cs = lconst (atL cs)"
-
-(*<*)
-
-lemma decompose_fragments:
-  assumes "(c, ictxt, fctxt) \<in> decompose_com c0"
-  shows "(c, extract_inner_locations c (fctxt c @ cs)) \<in> fragments c0 (atL cs)"
-using assms
-proof(induct c0 arbitrary: c ictxt fctxt cs)
-  case (Loop c01 c ictxt fctxt cs)
-  from Loop.prems Loop.hyps(1)[where cs="ictxt c # cs"] show ?case by (auto simp: decompose_ictxt[symmetric])
-next
-  case (Seq c01 c02 c ictxt fctxt cs)
-  from Seq.prems Seq.hyps(1)[where cs="c02 # cs"] show ?case by auto
-qed auto
+record ('answer, 'location, 'proc, 'question, 'state) system =
+  "('answer, 'location, 'proc, 'question, 'state) pre_system"
++ FAIR :: "('answer, 'location, 'proc, 'question, 'state) system_state seq_pred"
 
-lemma decomposeLS_fragmentsLS:
-  assumes "(c, ictxt, fctxt) \<in> decomposeLS s"
-  shows "(c, extract_inner_locations c (fctxt c @ tl (cPGM s))) \<in> fragmentsLS s"
-using assms
-proof(cases "cPGM s")
-  case (Cons d ds)
-  with assms decompose_fragments[where cs="ds"]
-  show ?thesis by (cases ds) (auto simp: decomposeLS_def)
-qed (simp add: decomposeLS_def)
-(*>*)
-
-lemma small_step_extract_inner_locations:
-  assumes "basic_com c"
-  assumes "(c # cs, ls) \<rightarrow>\<^bsub>\<alpha>\<^esub> ls'"
-  shows "extract_inner_locations c cs c ls = atLS ls'"
-using assms by (fastforce split: lcond_splits)
-
-text\<open>
-
-The headline result allows us to constrain the initial and final states
-of a given small step in terms of the original programs, provided the
-initial state is reachable.
-
-\<close>
+definition
+  run :: "('answer, 'location, 'proc, 'question, 'state) system
+       \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) system_state seq_pred"
+where
+  "run sys = (prerun sys \<^bold>\<and> FAIR sys)"
 
-theorem decompose_small_step:
-  assumes "s p \<rightarrow>\<^bsub>\<alpha>\<^esub> ps'"
-  assumes "(s, h) \<in> reachable_states sys"
-  obtains c cs ls'
-    where "(c, ls') \<in> fragments (fst sys p) \<langle>False\<rangle>"
-      and "basic_com c"
-      and "\<forall>l. atC c l \<longrightarrow> atLS (s p) l"
-      and "ls' c (cLST (s p)) = atLS ps'"
-      and "(c # cs, cLST (s p)) \<rightarrow>\<^bsub>\<alpha>\<^esub> ps'"
-(*<*)
-using assms
-apply -
-apply (frule iffD1[OF context_decompose])
-apply clarsimp
-apply (frule decomposeLS_fragmentsLS)
-apply (frule at_decomposeLS)
-apply (frule (1) subsetD[OF reachable_states_fragmentsLS, rotated])
-apply (frule (1) small_step_extract_inner_locations[rotated])
-apply auto
-done
-
-(*>*)
-text\<open>
-
-Reasoning with @{thm [source] "reachable_states_system_step_induct"}
-and @{thm [source] "decompose_small_step"} is quite tedious. We
-provide a very simple VCG that generates friendlier local proof
-obligations.
-
-\<close>
+definition
+  valid :: "('answer, 'location, 'proc, 'question, 'state) system
+                   \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) system_state seq_pred \<Rightarrow> bool" ("_ \<Turnstile> _" [11, 0] 11) (* FIXME priorities *)
+where
+  "(sys \<Turnstile> \<phi>) \<longleftrightarrow> (\<forall>\<sigma>. run sys \<sigma> \<longrightarrow> \<phi> \<sigma>)"
 (*<*)
 
 end
 (*>*)
diff --git a/thys/ConcurrentIMP/CIMP_one_place_buffer_ex.thy b/thys/ConcurrentIMP/CIMP_one_place_buffer_ex.thy
deleted file mode 100644
--- a/thys/ConcurrentIMP/CIMP_one_place_buffer_ex.thy
+++ /dev/null
@@ -1,192 +0,0 @@
-(*<*)
-(*
- * Copyright 2015, NICTA
- *
- * This software may be distributed and modified according to the terms of
- * the BSD 2-Clause license. Note that NO WARRANTY is provided.
- * See "LICENSE_BSD2.txt" for details.
- *
- * @TAG(NICTA_BSD)
- *)
-
-theory CIMP_one_place_buffer_ex
-imports
-  CIMP
-begin
-
-(*>*)
-section\<open>One-place buffer example\<close>
-
-text\<open>
-
-\label{sec:one_place_buffer}
-
-To demonstrate the CIMP reasoning infrastructure, we treat the trivial
-one-place buffer example of @{cite [cite_macro=citet]
-\<open>\S3.3\<close> "DBLP:journals/toplas/LamportS84"}. Note that the
-semantics for our language is different to @{cite
-[cite_macro=citeauthor] "DBLP:journals/toplas/LamportS84"}'s, who
-treated a historical variant of CSP (i.e., not the one in @{cite
-"Hoare:1985"}).
-
-We introduce some syntax for fixed-topology (static channel-based)
-scenarios.
-
-\<close>
-
-abbreviation
-  Receive :: "'location \<Rightarrow> 'channel \<Rightarrow> ('val \<Rightarrow> 'state \<Rightarrow> 'state)
-             \<Rightarrow> (unit, 'location, 'channel \<times> 'val, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleright>_")
-where
-  "\<lbrace>l\<rbrace> ch\<triangleright>f \<equiv> \<lbrace>l\<rbrace> Response (\<lambda>quest s. if fst quest = ch then {(f (snd quest) s, ())} else {})"
-
-abbreviation
-  Send :: "'location \<Rightarrow> 'channel \<Rightarrow> ('state \<Rightarrow> 'val)
-          \<Rightarrow> (unit, 'location, 'channel \<times> 'val, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleleft>_")
-where
-  "\<lbrace>l\<rbrace> ch\<triangleleft>f \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (ch, f s)) (\<lambda>ans s. {s})"
-
-text\<open>
-
-We further specialise these for our particular example.
-
-\<close>
-
-abbreviation
-  Receive' :: "'location \<Rightarrow> 'channel \<Rightarrow> (unit, 'location, 'channel \<times> 'state, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleright>")
-where
-  "\<lbrace>l\<rbrace> ch\<triangleright> \<equiv> \<lbrace>l\<rbrace> ch\<triangleright>(\<lambda>v _. v)"
-
-abbreviation
-  Send' :: "'location \<Rightarrow> 'channel \<Rightarrow> (unit, 'location, 'channel \<times> 'state, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleleft>")
-where
- "\<lbrace>l\<rbrace> ch\<triangleleft> \<equiv> \<lbrace>l\<rbrace> ch\<triangleleft>id"
-
-text\<open>
-
-These definitions largely follow @{cite [cite_macro=citet]
-"DBLP:journals/toplas/LamportS84"}. We have three processes
-communicating over two channels. We enumerate program locations.
-
-\<close>
-
-datatype ex_chname = \<xi>12 | \<xi>23
-type_synonym ex_val = nat
-type_synonym ex_ch = "ex_chname \<times> ex_val"
-datatype ex_loc = r12 | r23 | s23 | s12
-datatype ex_proc = p1 | p2 | p3
-
-type_synonym ex_pgm = "(unit, ex_loc, ex_ch, ex_val) com"
-type_synonym ex_pred = "(unit, ex_loc, ex_proc, ex_ch, ex_val) pred"
-type_synonym ex_state = "(unit, ex_loc, ex_proc, ex_ch, ex_val) global_state"
-type_synonym ex_system = "(unit, ex_loc, ex_proc, ex_ch, ex_val) system"
-type_synonym ex_history = "(ex_ch \<times> unit) list"
-
-primrec
-  ex_pgms :: "ex_proc \<Rightarrow> ex_pgm"
-where
-  "ex_pgms p1 = \<lbrace>s12\<rbrace> \<xi>12\<triangleleft>"
-| "ex_pgms p2 = LOOP DO \<lbrace>r12\<rbrace> \<xi>12\<triangleright>;; \<lbrace>s23\<rbrace> \<xi>23\<triangleleft> OD"
-| "ex_pgms p3 = \<lbrace>r23\<rbrace> \<xi>23\<triangleright>"
-
-text\<open>
-
-Each process starts with an arbitrary initial local state.
-
-\<close>
-
-abbreviation ex_init :: "(ex_proc \<Rightarrow> ex_val) \<Rightarrow> bool" where
-  "ex_init \<equiv> \<langle>True\<rangle>"
-
-abbreviation ex_system :: "ex_system" where
-  "ex_system \<equiv> (ex_pgms, ex_init)"
-
-text\<open>
-
-The following adapts Kai Engelhardt's, from his notes titled
-\emph{Proving an Asynchronous Message Passing Program Correct},
-2011. The history variable tracks the causality of the system, which I
-feel is missing in Lamport's treatment. We tack on Lamport's invariant
-so we can establish \<open>Etern_pred\<close>.
-
-\<close>
-
-abbreviation
-  filter_on_channel :: "ex_chname \<Rightarrow> ex_history \<Rightarrow> ex_val list"
-where
-  "filter_on_channel ch \<equiv> map (snd \<circ> fst) \<circ> filter ((=) ch \<circ> fst \<circ> fst)"
-
-definition Ip1_0 :: ex_pred where
-  "Ip1_0 \<equiv> at p1 s12 \<^bold>\<longrightarrow> (\<lambda>s. filter_on_channel \<xi>12 (hist s) = [])"
-definition Ip1_1 :: ex_pred where
-  "Ip1_1 \<equiv> terminated p1 \<^bold>\<longrightarrow> (\<lambda>s. filter_on_channel \<xi>12 (hist s) = [LST s p1])"
-
-definition Ip2_0 :: ex_pred where
-  "Ip2_0 \<equiv> at p2 r12 \<^bold>\<longrightarrow> (\<lambda>s. filter_on_channel \<xi>12 (hist s) = filter_on_channel \<xi>23 (hist s))"
-definition Ip2_1 :: ex_pred where
-  "Ip2_1 \<equiv> at p2 s23 \<^bold>\<longrightarrow> (\<lambda>s. filter_on_channel \<xi>12 (hist s) = filter_on_channel \<xi>23 (hist s) @ [LST s p2]
-                           \<and> LST s p1 = LST s p2)"
-
-definition Ip3_0 :: ex_pred where
-  "Ip3_0 \<equiv> at p3 r23 \<^bold>\<longrightarrow> (\<lambda>s. filter_on_channel \<xi>23 (hist s) = [])"
-definition Ip3_1 :: ex_pred where
-  "Ip3_1 \<equiv> terminated p3 \<^bold>\<longrightarrow> (\<lambda>s. filter_on_channel \<xi>23 (hist s) = [LST s p2]
-                                \<and> LST s p1 = LST s p3)"
-
-definition I_pred :: ex_pred where
-  "I_pred \<equiv> pred_conjoin [ Ip1_0, Ip1_1, Ip2_0, Ip2_1, Ip3_0, Ip3_1 ]"
-
-lemmas I_defs = Ip1_0_def Ip1_1_def Ip2_0_def Ip2_1_def Ip3_0_def Ip3_1_def
-
-text\<open>
-
-If process three terminates, then it has process one's value. This is
-stronger than @{cite [cite_macro=citeauthor]
-"DBLP:journals/toplas/LamportS84"}'s as we don't ask that the first
-process has also terminated.
-
-\<close>
-
-definition Etern_pred :: ex_pred where
-  "Etern_pred \<equiv> terminated p3 \<^bold>\<longrightarrow> (\<lambda>s. LST s p1 = LST s p3)"
-
-text\<open>
-
-Proofs from here down.
-
-\<close>
-
-lemma correct_system:
-  "I_pred sh \<Longrightarrow> Etern_pred sh"
-apply (clarsimp simp: Etern_pred_def I_pred_def I_defs)
-done
-
-lemma p1: "ex_pgms, p1, lconst \<langle>False\<rangle> \<Turnstile> \<lbrace>I_pred\<rbrace> \<lbrace>s12\<rbrace> \<xi>12\<triangleleft>\<lambda>s. s"
-apply (rule vcg.intros)
-apply (rename_tac p')
-apply (case_tac p')
-  apply (auto simp: I_pred_def I_defs atS_def)
-done
-
-lemma p2_1: "ex_pgms, p2, lconst (\<lambda>l. l = r12) \<Turnstile> \<lbrace>I_pred\<rbrace> \<lbrace>s23\<rbrace> \<xi>23\<triangleleft>\<lambda>s. s"
-apply (rule vcg.intros)
-apply (rename_tac p')
-apply (case_tac p')
-  apply (auto simp: I_pred_def I_defs atS_def)
-done
-
-lemma "(s, h) \<in> reachable_states ex_system \<Longrightarrow> I_pred (mkP (s, h))"
-apply (erule VCG)
- apply (clarsimp simp: I_pred_def I_defs atS_def)
-apply simp
-apply (rename_tac p)
-apply (case_tac p)
-  apply auto (* vcg_clarsimp_tac *)
-  apply (auto simp: p1 p2_1)
-done
-
-text\<open>\<close>
-(*<*)
-
-end
-(*>*)
diff --git a/thys/ConcurrentIMP/CIMP_pred.thy b/thys/ConcurrentIMP/CIMP_pred.thy
--- a/thys/ConcurrentIMP/CIMP_pred.thy
+++ b/thys/ConcurrentIMP/CIMP_pred.thy
@@ -1,138 +1,169 @@
 (*<*)
 (*
  * Copyright 2015, NICTA
  *
  * This software may be distributed and modified according to the terms of
  * the BSD 2-Clause license. Note that NO WARRANTY is provided.
  * See "LICENSE_BSD2.txt" for details.
  *
  * @TAG(NICTA_BSD)
  *)
 
 theory CIMP_pred
 imports
   Main
 begin
 
+(* Extra HOL *)
+
+lemma triv: "P \<Longrightarrow> P"
+by simp
+
+lemma always_eventually_pigeonhole:
+  "(\<forall>i. \<exists>n\<ge>i. \<exists>m\<le>k. P m n) \<longleftrightarrow> (\<exists>m\<le>k::nat. \<forall>i::nat. \<exists>n\<ge>i. P m n)"
+proof(induct k)
+  case (Suc k) then show ?case
+    apply (auto 8 0)
+    using le_SucI apply blast
+    apply (metis (full_types) le_Suc_eq nat_le_linear order_trans)
+    done
+qed simp
+
 (*>*)
 section\<open> Point-free notation \<close>
 
 text\<open>
 
 \label{sec:cimp-lifted-predicates}
 
 Typically we define predicates as functions of a state. The following
 provide a somewhat comfortable point-free imitation of Isabelle/HOL's
 operators.
 
 \<close>
 
 abbreviation (input)
   pred_K :: "'b \<Rightarrow> 'a \<Rightarrow> 'b" ("\<langle>_\<rangle>") where
   "\<langle>f\<rangle> \<equiv> \<lambda>s. f"
 
 abbreviation (input)
-  pred_not :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" ("\<^bold>\<not>") where
+  pred_not :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" ("\<^bold>\<not> _" [40] 40) where
   "\<^bold>\<not>a \<equiv> \<lambda>s. \<not>a s"
 
 abbreviation (input)
   pred_conj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (infixr "\<^bold>\<and>" 35) where
   "a \<^bold>\<and> b \<equiv> \<lambda>s. a s \<and> b s"
 
 abbreviation (input)
   pred_disj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (infixr "\<^bold>\<or>" 30) where
   "a \<^bold>\<or> b \<equiv> \<lambda>s. a s \<or> b s"
 
 abbreviation (input)
   pred_implies :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (infixr "\<^bold>\<longrightarrow>" 25) where
   "a \<^bold>\<longrightarrow> b \<equiv> \<lambda>s. a s \<longrightarrow> b s"
 
 abbreviation (input)
+  pred_iff :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (infixr "\<^bold>\<longleftrightarrow>" 25) where
+  "a \<^bold>\<longleftrightarrow> b \<equiv> \<lambda>s. a s \<longleftrightarrow> b s"
+
+abbreviation (input)
   pred_eq :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold>=" 40) where
   "a \<^bold>= b \<equiv> \<lambda>s. a s = b s"
 
 abbreviation (input)
   pred_member :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold>\<in>" 40) where
   "a \<^bold>\<in> b \<equiv> \<lambda>s. a s \<in> b s"
 
 abbreviation (input)
   pred_neq :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold>\<noteq>" 40) where
   "a \<^bold>\<noteq> b \<equiv> \<lambda>s. a s \<noteq> b s"
 
 abbreviation (input)
   pred_If :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" ("(If (_)/ Then (_)/ Else (_))" [0, 0, 10] 10)
   where "If P Then x Else y \<equiv> \<lambda>s. if P s then x s else y s"
 
 abbreviation (input)
   pred_less :: "('a \<Rightarrow> 'b::ord) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold><" 40) where
   "a \<^bold>< b \<equiv> \<lambda>s. a s < b s"
 
 abbreviation (input)
   pred_le :: "('a \<Rightarrow> 'b::ord) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold>\<le>" 40) where
   "a \<^bold>\<le> b \<equiv> \<lambda>s. a s \<le> b s"
 
 abbreviation (input)
   pred_plus :: "('a \<Rightarrow> 'b::plus) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" (infixl "\<^bold>+" 65) where
   "a \<^bold>+ b \<equiv> \<lambda>s. a s + b s"
 
 abbreviation (input)
   pred_minus :: "('a \<Rightarrow> 'b::minus) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" (infixl "\<^bold>-" 65) where
   "a \<^bold>- b \<equiv> \<lambda>s. a s - b s"
 
 abbreviation (input)
   fun_fanout :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<times> 'c" (infix "\<^bold>\<bowtie>" 35) where
   "f \<^bold>\<bowtie> g \<equiv> \<lambda>x. (f x, g x)"
 
 abbreviation (input)
   pred_all :: "('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (binder "\<^bold>\<forall>" 10) where
   "\<^bold>\<forall>x. P x \<equiv> \<lambda>s. \<forall>x. P x s"
 
 abbreviation (input)
   pred_ex :: "('b \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool" (binder "\<^bold>\<exists>" 10) where
   "\<^bold>\<exists>x. P x \<equiv> \<lambda>s. \<exists>x. P x s"
 
 abbreviation (input)
   pred_app :: "('b \<Rightarrow> 'a \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c" (infixl "\<^bold>$" 100) where
   "f \<^bold>$ g \<equiv> \<lambda>s. f (g s) s"
 
 abbreviation (input)
   pred_subseteq :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<^bold>\<subseteq>" 50) where
   "A \<^bold>\<subseteq> B \<equiv> \<lambda>s. A s \<subseteq> B s"
 
 abbreviation (input)
   pred_union :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'a \<Rightarrow> 'b set" (infixl "\<^bold>\<union>" 65) where
   "a \<^bold>\<union> b \<equiv> \<lambda>s. a s \<union> b s"
 
+abbreviation (input)
+  pred_inter :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('a \<Rightarrow> 'b set) \<Rightarrow> 'a \<Rightarrow> 'b set" (infixl "\<^bold>\<inter>" 65) where
+  "a \<^bold>\<inter> b \<equiv> \<lambda>s. a s \<inter> b s"
+
 text\<open>
 
 More application specific.
 
 \<close>
 
 abbreviation (input)
   pred_conjoin :: "('a \<Rightarrow> bool) list \<Rightarrow> 'a \<Rightarrow> bool" where
   "pred_conjoin xs \<equiv> foldr (\<^bold>\<and>) xs \<langle>True\<rangle>"
 
 abbreviation (input)
+  pred_disjoin :: "('a \<Rightarrow> bool) list \<Rightarrow> 'a \<Rightarrow> bool" where
+  "pred_disjoin xs \<equiv> foldr (\<^bold>\<or>) xs \<langle>False\<rangle>"
+
+abbreviation (input)
   pred_is_none :: "('a \<Rightarrow> 'b option) \<Rightarrow> 'a \<Rightarrow> bool" ("NULL _" [40] 40) where
   "NULL a \<equiv> \<lambda>s. a s = None"
 
 abbreviation (input)
   pred_empty :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'a \<Rightarrow> bool" ("EMPTY _" [40] 40) where
   "EMPTY a \<equiv> \<lambda>s. a s = {}"
 
 abbreviation (input)
   pred_list_null :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a \<Rightarrow> bool" ("LIST'_NULL _" [40] 40) where
   "LIST_NULL a \<equiv> \<lambda>s. a s = []"
 
 abbreviation (input)
+  pred_list_append :: "('a \<Rightarrow> 'b list) \<Rightarrow> ('a \<Rightarrow> 'b list) \<Rightarrow> 'a \<Rightarrow> 'b list" (infixr "\<^bold>@" 65) where
+  "xs \<^bold>@ ys \<equiv> \<lambda>s. xs s @ ys s"
+
+abbreviation (input)
   pred_pair :: "('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<times> 'c" (infixr "\<^bold>\<otimes>" 60) where
   "a \<^bold>\<otimes> b \<equiv> \<lambda>s. (a s, b s)"
 
 abbreviation (input)
   pred_singleton :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b set" where
   "pred_singleton x \<equiv> \<lambda>s. {x s}"
 (*<*)
 
 end
 (*>*)
diff --git a/thys/ConcurrentIMP/CIMP_unbounded_buffer_ex.thy b/thys/ConcurrentIMP/CIMP_unbounded_buffer_ex.thy
deleted file mode 100644
--- a/thys/ConcurrentIMP/CIMP_unbounded_buffer_ex.thy
+++ /dev/null
@@ -1,168 +0,0 @@
-(*<*)
-(*
- * Copyright 2015, NICTA
- *
- * This software may be distributed and modified according to the terms of
- * the BSD 2-Clause license. Note that NO WARRANTY is provided.
- * See "LICENSE_BSD2.txt" for details.
- *
- * @TAG(NICTA_BSD)
- *)
-
-theory CIMP_unbounded_buffer_ex
-imports
-  CIMP
-  "HOL-Library.Prefix_Order"
-begin
-
-abbreviation
-  Receive :: "'location \<Rightarrow> 'channel \<Rightarrow> ('val \<Rightarrow> 'state \<Rightarrow> 'state)
-             \<Rightarrow> (unit, 'location, 'channel \<times> 'val, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleright>_")
-where
-  "\<lbrace>l\<rbrace> ch\<triangleright>f \<equiv> \<lbrace>l\<rbrace> Response (\<lambda>quest s. if fst quest = ch then {(f (snd quest) s, ())} else {})"
-
-abbreviation
-  Send :: "'location \<Rightarrow> 'channel \<Rightarrow> ('state \<Rightarrow> 'val)
-          \<Rightarrow> (unit, 'location, 'channel \<times> 'val, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleleft>_")
-where
-  "\<lbrace>l\<rbrace> ch\<triangleleft>f \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (ch, f s)) (\<lambda>ans s. {s})"
-
-lemma butlastE:
-  "\<lbrakk> butlast xs = ys; xs \<noteq> []; \<And>z. xs = ys @ [z] \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
-by (induct xs rule: rev_induct) auto
-
-(*>*)
-section\<open>Unbounded buffer example\<close>
-
-text\<open>
-
-\label{sec:unbounded_place_buffer}
-
-This is more literally Kai's example from his notes titled
-\emph{Proving an Asynchronous Message Passing Program Correct}, 2011.
-
-\<close>
-
-datatype ex_chname = \<xi>12 | \<xi>23
-type_synonym ex_val = nat
-type_synonym ex_ls = "ex_val list"
-type_synonym ex_ch = "ex_chname \<times> ex_val"
-datatype ex_loc = \<pi>4 | \<pi>5 | c1 | r12 | r23 | s23 | s12
-datatype ex_proc = p1 | p2 | p3
-
-type_synonym ex_pgm = "(unit, ex_loc, ex_ch, ex_ls) com"
-type_synonym ex_pred = "(unit, ex_loc, ex_proc, ex_ch, ex_ls) pred"
-type_synonym ex_state = "(unit, ex_loc, ex_proc, ex_ch, ex_ls) global_state"
-type_synonym ex_system = "(unit, ex_loc, ex_proc, ex_ch, ex_ls) system"
-type_synonym ex_history = "(ex_ch \<times> unit) list"
-
-text\<open>
-
-FIXME a bit fake: the local state for the producer process contains
-all values produced.
-
-\<close>
-
-primrec ex_pgms :: "ex_proc \<Rightarrow> ex_pgm" where
-  "ex_pgms p1 = LOOP DO \<lbrace>c1\<rbrace> LocalOp (\<lambda>xs. { xs @ [x] |x. True }) ;; \<lbrace>s12\<rbrace> \<xi>12\<triangleleft>last OD"
-| "ex_pgms p2 = LOOP DO \<lbrace>r12\<rbrace> \<xi>12\<triangleright>(\<lambda>x xs. xs @ [x])
-                           \<squnion> \<lbrace>\<pi>4\<rbrace> IF (\<lambda>s. length s > 0) THEN \<lbrace>s23\<rbrace> Request (\<lambda>s. (\<xi>23, hd s)) (\<lambda>ans s. {tl s}) FI
-                          OD"
-| "ex_pgms p3 = LOOP DO \<lbrace>r23\<rbrace> \<xi>23\<triangleright>(\<lambda>x xs. xs @ [x]) OD"
-
-abbreviation ex_init :: "(ex_proc \<Rightarrow> ex_ls) \<Rightarrow> bool" where
-  "ex_init f \<equiv> \<forall>p. f p = []"
-
-abbreviation ex_system :: "ex_system" where
-  "ex_system \<equiv> (ex_pgms, ex_init)"
-
-definition filter_on_channel :: "ex_chname \<Rightarrow> ex_history \<Rightarrow> ex_val list" where
-  "filter_on_channel ch \<equiv> map (snd \<circ> fst) \<circ> filter ((=) ch \<circ> fst \<circ> fst)"
-
-lemma filter_on_channel_simps [simp]:
-  "filter_on_channel ch [] = []"
-  "filter_on_channel ch (xs @ ys) = filter_on_channel ch xs @ filter_on_channel ch ys"
-  "filter_on_channel ch (((ch', v), resp) # vals) = (if ch' = ch then [v] else []) @ filter_on_channel ch vals"
-by (simp_all add: filter_on_channel_def)
-
-definition Ip1_0 :: ex_pred where
-  "Ip1_0 \<equiv> \<lambda>s. at p1 c1 s \<longrightarrow> filter_on_channel \<xi>12 (hist s) = s\<down> p1"
-definition Ip1_1 :: ex_pred where
-  "Ip1_1 \<equiv> \<lambda>s. at p1 s12 s \<longrightarrow> length (s\<down> p1) > 0 \<and> butlast (s\<down> p1) = filter_on_channel \<xi>12 (hist s)"
-definition Ip1_2 :: ex_pred where
-  "Ip1_2 \<equiv> \<lambda>s. filter_on_channel \<xi>12 (hist s) \<le> s\<down> p1"
-
-definition Ip2_0 :: ex_pred where
-  "Ip2_0 \<equiv> \<lambda>s. filter_on_channel \<xi>12 (hist s) = filter_on_channel \<xi>23 (hist s) @ s\<down> p2"
-(* We would get this for free from a proper VCG. *)
-definition Ip2_1 :: ex_pred where
-  "Ip2_1 \<equiv> \<lambda>s. at p2 s23 s \<longrightarrow> length (s\<down> p2) > 0"
-
-definition Ip3_0 :: ex_pred where
-  "Ip3_0 \<equiv> \<lambda>s. s\<down> p3 = filter_on_channel \<xi>23 (hist s)"
-
-definition I_pred :: ex_pred where
-  "I_pred \<equiv> pred_conjoin [ Ip1_0, Ip1_1, Ip1_2, Ip2_0, Ip2_1, Ip3_0 ]"
-
-lemmas I_defs = I_pred_def Ip1_0_def Ip1_1_def Ip1_2_def Ip2_0_def Ip2_1_def Ip3_0_def
-
-text\<open>
-
-The local state of @{const "p3"} is some prefix of the local state of
-@{const "p1"}.
-
-\<close>
-
-definition Etern_pred :: ex_pred where
-  "Etern_pred \<equiv> \<lambda>s. s\<down> p3 \<le> s\<down> p1"
-
-lemma correct_system:
-  "I_pred s \<Longrightarrow> Etern_pred s"
-(*<*)
-by (clarsimp simp: Etern_pred_def I_defs less_eq_list_def prefix_def)
-
-lemma p1_c1[simplified, intro]:
-  "ex_pgms, p1, lconst (\<lambda>l. l = s12) \<Turnstile> \<lbrace>I_pred\<rbrace> \<lbrace>c1\<rbrace> LocalOp (\<lambda>xs. { xs @ [x] |x. True })"
-apply (rule vcg.intros)
-apply (clarsimp simp: I_defs atS_def)
-done
-
-lemma p1_s12[intro]:
-  "ex_pgms, p1, lconst (\<lambda>l. l = c1) \<Turnstile> \<lbrace>I_pred\<rbrace> \<lbrace>s12\<rbrace> \<xi>12\<triangleleft>last"
-apply (rule vcg.intros)
-apply (rename_tac p')
-apply (case_tac p', simp_all)
-apply (clarsimp simp: I_defs atS_def elim!: butlastE)
-done
-
-lemma p2_s23[intro]:
-  "ex_pgms, p2, lconst (\<lambda>l. l = r12 \<or> l = \<pi>4) \<Turnstile> \<lbrace>I_pred\<rbrace> \<lbrace>s23\<rbrace> Request (\<lambda>s. (\<xi>23, hd s)) (\<lambda>ans s. {tl s})"
-apply (rule vcg.intros)
-apply (rename_tac p')
-apply (case_tac p', simp_all)
-apply (clarsimp simp: I_defs atS_def)
-done
-
-lemma p2_pi4[intro]:
-  "ex_pgms, p2, lcond (\<lambda>l. l = s23) (\<lambda>l. l = r12 \<or> l = \<pi>4) \<Turnstile> \<lbrace>I_pred\<rbrace> \<lbrace>\<pi>4\<rbrace> IF \<lambda>s. s \<noteq> [] THEN c' FI"
-apply (rule vcg.intros)
-apply (clarsimp simp: I_defs atS_def split: lcond_splits)
-done
-
-(*>*)
-text\<open>\<close>
-
-lemma "s \<in> reachable_states ex_system \<Longrightarrow> I_pred (mkP s)"
-(*<*)
-apply (erule VCG)
- apply (clarsimp dest!: initial_statesD simp: I_defs atS_def)
-apply simp
-apply (rename_tac p)
-apply (case_tac p)
- apply auto
-done
-(*>*)
-(*<*)
-
-end
-(*>*)
diff --git a/thys/ConcurrentIMP/CIMP_vcg.thy b/thys/ConcurrentIMP/CIMP_vcg.thy
--- a/thys/ConcurrentIMP/CIMP_vcg.thy
+++ b/thys/ConcurrentIMP/CIMP_vcg.thy
@@ -1,436 +1,793 @@
 (*<*)
 (*
  * Copyright 2015, NICTA
  *
  * This software may be distributed and modified according to the terms of
  * the BSD 2-Clause license. Note that NO WARRANTY is provided.
  * See "LICENSE_BSD2.txt" for details.
  *
  * @TAG(NICTA_BSD)
  *)
 
 theory CIMP_vcg
 imports
   CIMP_lang
 begin
 
 (*>*)
-subsection\<open>Simple-minded Hoare Logic/VCG for CIMP\<close>
+section\<open> State-based invariants \label{sec:cimp-invariants} \<close>
+
+text\<open>
+
+We provide a simple-minded verification condition generator (VCG) for this language, providing
+support for establishing state-based invariants. It is just one way of reasoning about CIMP programs
+and is proven sound wrt to the CIMP semantics.
+
+Our approach follows @{cite [cite_macro=citet]
+"DBLP:journals/acta/Lamport80" and "DBLP:journals/toplas/LamportS84"}
+(and the later @{cite [cite_macro=citet] "Lamport:2002"}) and closely
+related work by @{cite [cite_macro=citet] "AptFrancezDeRoever:1980"},
+@{cite [cite_macro=citet] "CousotCousot:1980"} and @{cite
+[cite_macro=citet] "DBLP:journals/acta/LevinG81"}, who suggest the
+incorporation of a history variable. @{cite [cite_macro=citet]
+"CousotCousot:1980"} apparently contains a completeness proof.
+Lamport mentions that this technique was well-known in the mid-80s
+when he proposed the use of prophecy variables\footnote{@{url
+"https://lamport.azurewebsites.net/pubs/pubs.html"}}. See also @{cite
+[cite_macro=citet] "deRoeverEtAl:2001"} for an extended discussion of
+some of this.
+
+\<close>
+
+declare small_step.intros[intro]
+
+inductive_cases small_step_inv:
+  "(\<lbrace>l\<rbrace> Request action val # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
+  "(\<lbrace>l\<rbrace> Response action # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
+  "(\<lbrace>l\<rbrace> LocalOp R # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
+  "(\<lbrace>l\<rbrace> IF b THEN c FI # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
+  "(\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
+  "(\<lbrace>l\<rbrace> WHILE b DO c OD # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
+  "(LOOP DO c OD # cs, ls) \<rightarrow>\<^bsub>a\<^esub> s'"
+
+lemma small_step_stuck:
+  "\<not> ([], s) \<rightarrow>\<^bsub>\<alpha>\<^esub> c'"
+by (auto elim: small_step.cases)
+
+declare system_step.intros[intro]
+
+text\<open>
+
+By default we ask the simplifier to rewrite @{const "atS"} using
+ambient @{const "AT"} information.
+
+\<close>
+
+lemma atS_state_weak_cong[cong]:
+  "AT s p = AT s' p \<Longrightarrow> atS p ls s \<longleftrightarrow> atS p ls s'"
+by (auto simp: atS_def)
+
+text\<open>
+
+We provide an incomplete set of basic rules for label sets.
+
+\<close>
+
+lemma atS_simps:
+  "\<not>atS p {} s"
+  "atS p {l} s \<longleftrightarrow> at p l s"
+  "\<lbrakk>at p l s; l \<in> ls\<rbrakk> \<Longrightarrow> atS p ls s"
+  "(\<forall>l. at p l s \<longrightarrow> l \<notin> ls) \<Longrightarrow> \<not>atS p ls s"
+by (auto simp: atS_def)
+
+lemma atS_mono:
+  "\<lbrakk>atS p ls s; ls \<subseteq> ls'\<rbrakk> \<Longrightarrow> atS p ls' s"
+by (auto simp: atS_def)
+
+lemma atS_un:
+  "atS p (l \<union> l') s \<longleftrightarrow> atS p l s \<or> atS p l' s"
+by (auto simp: atS_def)
+
+lemma atLs_disj_union[simp]:
+  "(atLs p label0 \<^bold>\<or> atLs p label1) = atLs p (label0 \<union> label1)"
+unfolding atLs_def by simp
+
+lemma atLs_insert_disj:
+  "atLs p (insert l label0) = (atL p l \<^bold>\<or> atLs p label0)"
+by simp
+
+lemma small_step_terminated:
+  "s \<rightarrow>\<^bsub>x\<^esub> s' \<Longrightarrow> atCs (fst s) = {} \<Longrightarrow> atCs (fst s') = {}"
+by (induct pred: small_step) auto
+
+lemma atC_not_empty:
+  "atC c \<noteq> {}"
+by (induct c) auto
+
+lemma atCs_empty:
+  "atCs cs = {} \<longleftrightarrow> cs = []"
+by (induct cs) (auto simp: atC_not_empty)
+
+lemma terminated_no_commands:
+  assumes "terminated p sh"
+  shows "\<exists>s. GST sh p = ([], s)"
+using assms unfolding atLs_def AT_def by (metis atCs_empty prod.collapse singletonD)
+
+lemma terminated_GST_stable:
+  assumes "system_step q sh' sh"
+  assumes "terminated p sh"
+  shows "GST sh p = GST sh' p"
+using assms by (auto dest!: terminated_no_commands simp: small_step_stuck elim!: system_step.cases)
+
+lemma terminated_stable:
+  assumes "system_step q sh' sh"
+  assumes "terminated p sh"
+  shows "terminated p sh'"
+using assms unfolding atLs_def AT_def
+by (fastforce split: if_splits prod.splits
+               dest: small_step_terminated
+              elim!: system_step.cases)
+
+lemma system_step_pls_nonempty:
+  assumes "system_step pls sh' sh"
+  shows "pls \<noteq> {}"
+using assms by cases simp_all
+
+lemma system_step_no_change:
+  assumes "system_step ps sh' sh"
+  assumes "p \<notin> ps"
+  shows "GST sh' p = GST sh p"
+using assms by cases simp_all
+
+lemma initial_stateD:
+  assumes "initial_state sys s"
+  shows "AT (\<lparr>GST = s, HST = []\<rparr>) = atC \<circ> PGMs sys \<and> INIT sys (\<lparr>GST = s, HST = []\<rparr>)\<down> \<and> (\<forall>p l. \<not>taken p l \<lparr>GST = s, HST = []\<rparr>)"
+using assms unfolding initial_state_def split_def o_def LST_def AT_def taken_def by simp
+
+lemma initial_states_initial[iff]:
+  assumes "initial_state sys s"
+  shows "at p l (\<lparr>GST = s, HST = []\<rparr>) \<longleftrightarrow> l \<in> atC (PGMs sys p)"
+using assms unfolding initial_state_def split_def AT_def by simp
+
+definition
+  reachable_state :: "('answer, 'location, 'proc, 'question, 'state, 'ext) pre_system_ext
+                    \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred"
+where
+  "reachable_state sys s \<longleftrightarrow> (\<exists>\<sigma> i. prerun sys \<sigma> \<and> \<sigma> i = s)"
+
+lemma reachable_stateE:
+  assumes "reachable_state sys sh"
+  assumes "\<And>\<sigma> i. prerun sys \<sigma> \<Longrightarrow> P (\<sigma> i)"
+  shows "P sh"
+using assms unfolding reachable_state_def by blast
+
+lemma prerun_reachable_state:
+  assumes "prerun sys \<sigma>"
+  shows "reachable_state sys (\<sigma> i)"
+using assms unfolding prerun_def LTL.defs system_step_reflclp_def reachable_state_def by auto
+
+lemma reachable_state_induct[consumes 1, case_names init LocalStep CommunicationStep, induct set: reachable_state]:
+  assumes r: "reachable_state sys sh"
+  assumes i: "\<And>s. initial_state sys s \<Longrightarrow> P \<lparr>GST = s, HST = []\<rparr>"
+  assumes l: "\<And>sh ls' p. \<lbrakk>reachable_state sys sh; P sh; GST sh p \<rightarrow>\<^bsub>\<tau>\<^esub> ls'\<rbrakk> \<Longrightarrow> P \<lparr>GST = (GST sh)(p := ls'), HST = HST sh\<rparr>"
+  assumes c: "\<And>sh ls1' ls2' p1 p2 \<alpha> \<beta>.
+                 \<lbrakk>reachable_state sys sh; P sh;
+                 GST sh p1 \<rightarrow>\<^bsub>\<guillemotleft>\<alpha>, \<beta>\<guillemotright>\<^esub> ls1'; GST sh p2 \<rightarrow>\<^bsub>\<guillemotright>\<alpha>, \<beta>\<guillemotleft>\<^esub> ls2'; p1 \<noteq> p2 \<rbrakk>
+                    \<Longrightarrow> P \<lparr>GST = (GST sh)(p1 := ls1', p2 := ls2'), HST = HST sh @ [(\<alpha>, \<beta>)]\<rparr>"
+  shows "P sh"
+using r
+proof(rule reachable_stateE)
+  fix \<sigma> i assume "prerun sys \<sigma>" show "P (\<sigma> i)"
+  proof(induct i)
+    case 0 from \<open>prerun sys \<sigma>\<close> show ?case
+      unfolding prerun_def by (metis (full_types) i old.unit.exhaust system_state.surjective)
+  next
+    case (Suc i) with \<open>prerun sys \<sigma>\<close> show ?case
+unfolding prerun_def LTL.defs system_step_reflclp_def reachable_state_def
+apply clarsimp
+apply (drule_tac x=i in spec)
+apply (erule disjE; clarsimp)
+apply (erule system_step.cases; clarsimp)
+ apply (metis (full_types) \<open>prerun sys \<sigma>\<close> l old.unit.exhaust prerun_reachable_state system_state.surjective)
+apply (metis (full_types) \<open>prerun sys \<sigma>\<close> c old.unit.exhaust prerun_reachable_state system_state.surjective)
+done
+  qed
+qed
+
+lemma prerun_valid_TrueI:
+  shows "sys \<Turnstile>\<^bsub>pre\<^esub> \<langle>True\<rangle>"
+unfolding prerun_valid_def by simp
+
+lemma prerun_valid_conjI:
+  assumes "sys \<Turnstile>\<^bsub>pre\<^esub> P"
+  assumes "sys \<Turnstile>\<^bsub>pre\<^esub> Q"
+  shows "sys \<Turnstile>\<^bsub>pre\<^esub> P \<^bold>\<and> Q"
+using assms unfolding prerun_valid_def always_def by simp
+
+lemma valid_prerun_lift:
+  assumes "sys \<Turnstile>\<^bsub>pre\<^esub> I"
+  shows "sys \<Turnstile> \<box>\<lceil>I\<rceil>"
+using assms unfolding prerun_valid_def valid_def run_def by blast
+
+lemma prerun_valid_induct:
+  assumes "\<And>\<sigma>. prerun sys \<sigma> \<Longrightarrow> \<lceil>I\<rceil> \<sigma>"
+  assumes "\<And>\<sigma>. prerun sys \<sigma> \<Longrightarrow> (\<lceil>I\<rceil> \<^bold>\<hookrightarrow> (\<circle>\<lceil>I\<rceil>)) \<sigma>"
+  shows "sys \<Turnstile>\<^bsub>pre\<^esub> I"
+unfolding prerun_valid_def using assms by (simp add: always_induct)
+
+lemma prerun_validI:
+  assumes "\<And>s. reachable_state sys s \<Longrightarrow> I s"
+  shows "sys \<Turnstile>\<^bsub>pre\<^esub> I"
+unfolding prerun_valid_def using assms by (simp add: alwaysI prerun_reachable_state)
+
+lemma prerun_validE:
+  assumes "reachable_state sys s"
+  assumes "sys \<Turnstile>\<^bsub>pre\<^esub> I"
+  shows "I s"
+using assms unfolding prerun_valid_def
+by (metis alwaysE reachable_stateE suffix_state_prop)
+
+
+subsubsection\<open>Relating reachable states to the initial programs \label{sec:cimp-decompose-small-step}\<close>
+
+text\<open>
+
+To usefully reason about the control locations presumably embedded in
+the single global invariant, we need to link the programs we have in
+reachable state \<open>s\<close> to the programs in the initial states. The
+\<open>fragments\<close> function decomposes the program into statements
+that can be directly executed (\S\ref{sec:cimp-decompose}). We also
+compute the locations we could be at after executing that statement as
+a function of the process's local state.
+
+Eliding the bodies of \<open>IF\<close> and \<open>WHILE\<close> statements
+yields smaller (but equivalent) proof obligations.
+
+\<close>
+
+type_synonym  ('answer, 'location, 'question, 'state) loc_comp
+  = "'state \<Rightarrow> 'location set"
+
+fun lconst :: "'location set \<Rightarrow> ('answer, 'location, 'question, 'state) loc_comp" where
+  "lconst lp s = lp"
+
+definition lcond :: "'location set \<Rightarrow> 'location set \<Rightarrow> 'state bexp
+                   \<Rightarrow> ('answer, 'location, 'question, 'state) loc_comp" where
+  "lcond lp lp' b s = (if b s then lp else lp')"
+
+lemma lcond_split:
+  "Q (lcond lp lp' b s) \<longleftrightarrow> (b s \<longrightarrow> Q lp) \<and> (\<not>b s \<longrightarrow> Q lp')"
+unfolding lcond_def by (simp split: if_splits)
+
+lemma lcond_split_asm:
+  "Q (lcond lp lp' b s) \<longleftrightarrow> \<not> ((b s \<and> \<not>Q lp) \<or> (\<not>b s \<and> \<not> Q lp'))"
+unfolding lcond_def by (simp split: if_splits)
+
+lemmas lcond_splits = lcond_split lcond_split_asm
+
+fun
+  fragments :: "('answer, 'location, 'question, 'state) com
+              \<Rightarrow> 'location set
+              \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
+               \<times> ('answer, 'location, 'question, 'state) loc_comp ) set"
+where
+  "fragments (\<lbrace>l\<rbrace> IF b THEN c FI) aft
+       = { (\<lbrace>l\<rbrace> IF b THEN c' FI, lcond (atC c) aft b) |c'. True }
+        \<union> fragments c aft"
+| "fragments (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI) aft
+       = { (\<lbrace>l\<rbrace> IF b THEN c1' ELSE c2' FI, lcond (atC c1) (atC c2) b) |c1' c2'. True }
+        \<union> fragments c1 aft \<union> fragments c2 aft"
+| "fragments (LOOP DO c OD) aft = fragments c (atC c)"
+| "fragments (\<lbrace>l\<rbrace> WHILE b DO c OD) aft
+       =  fragments c {l} \<union> { (\<lbrace>l\<rbrace> WHILE b DO c' OD, lcond (atC c) aft b) |c'. True }"
+| "fragments (c1;; c2) aft = fragments c1 (atC c2) \<union> fragments c2 aft"
+| "fragments (c1 \<oplus> c2) aft = fragments c1 aft \<union> fragments c2 aft"
+| "fragments c aft = { (c, lconst aft) }"
+
+fun
+  fragmentsL :: "('answer, 'location, 'question, 'state) com list
+               \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
+                 \<times> ('answer, 'location, 'question, 'state) loc_comp ) set"
+where
+  "fragmentsL [] = {}"
+| "fragmentsL [c] = fragments c {}"
+| "fragmentsL (c # c' # cs) = fragments c (atC c') \<union> fragmentsL (c' # cs)"
+
+abbreviation
+  fragmentsLS :: "('answer, 'location, 'question, 'state) local_state
+               \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
+                 \<times> ('answer, 'location, 'question, 'state) loc_comp ) set"
+where
+  "fragmentsLS s \<equiv> fragmentsL (cPGM s)"
+
+text\<open>
+
+We show that taking system steps preserves fragments.
+
+\<close>
+
+lemma small_step_fragmentsLS:
+  assumes "s \<rightarrow>\<^bsub>\<alpha>\<^esub> s'"
+  shows "fragmentsLS s' \<subseteq> fragmentsLS s"
+using assms by induct (case_tac [!] cs, auto)
+
+lemma reachable_state_fragmentsLS:
+  assumes "reachable_state sys sh"
+  shows "fragmentsLS (GST sh p) \<subseteq> fragments (PGMs sys p) {}"
+using assms
+by (induct rule: reachable_state_induct)
+   (auto simp: initial_state_def dest: subsetD[OF small_step_fragmentsLS])
+
+inductive
+  basic_com :: "('answer, 'location, 'question, 'state) com \<Rightarrow> bool"
+where
+  "basic_com (\<lbrace>l\<rbrace> Request action val)"
+| "basic_com (\<lbrace>l\<rbrace> Response action)"
+| "basic_com (\<lbrace>l\<rbrace> LocalOp R)"
+| "basic_com (\<lbrace>l\<rbrace> IF b THEN c FI)"
+| "basic_com (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI)"
+| "basic_com (\<lbrace>l\<rbrace> WHILE b DO c OD)"
+
+lemma fragments_basic_com:
+  assumes "(c', aft') \<in> fragments c aft"
+  shows "basic_com c'"
+using assms by (induct c arbitrary: aft) (auto intro: basic_com.intros)
+
+lemma fragmentsL_basic_com:
+  assumes "(c', aft') \<in> fragmentsL cs"
+  shows "basic_com c'"
+using assms
+apply (induct cs)
+ apply simp
+apply (case_tac cs)
+ apply (auto simp: fragments_basic_com)
+done
+
+text\<open>
+
+To reason about system transitions we need to identify which basic
+statement gets executed next. To that end we factor out the recursive
+cases of the @{term "small_step"} semantics into \emph{contexts},
+which isolate the \<open>basic_com\<close> commands with immediate
+externally-visible behaviour. Note that non-determinism means that
+more than one \<open>basic_com\<close> can be enabled at a time.
+
+The representation of evaluation contexts follows @{cite
+[cite_macro=citet] "DBLP:journals/jar/Berghofer12"}. This style of
+operational semantics was originated by @{cite [cite_macro=citet]
+"FelleisenHieb:1992"}.
+
+\<close>
+
+type_synonym ('answer, 'location, 'question, 'state) ctxt
+  = "(('answer, 'location, 'question, 'state) com \<Rightarrow> ('answer, 'location, 'question, 'state) com)
+   \<times> (('answer, 'location, 'question, 'state) com \<Rightarrow> ('answer, 'location, 'question, 'state) com list)"
+
+inductive_set
+  ctxt :: "('answer, 'location, 'question, 'state) ctxt set"
+where
+  C_Hole: "(id, \<langle>[]\<rangle>) \<in> ctxt"
+| C_Loop: "(E, fctxt) \<in> ctxt \<Longrightarrow> (\<lambda>c1. LOOP DO E c1 OD, \<lambda>c1. fctxt c1 @ [LOOP DO E c1 OD]) \<in> ctxt"
+| C_Seq: "(E, fctxt) \<in> ctxt \<Longrightarrow> (\<lambda>c1. E c1;; c2, \<lambda>c1. fctxt c1 @ [c2]) \<in> ctxt"
+| C_Choose1: "(E, fctxt) \<in> ctxt \<Longrightarrow> (\<lambda>c1. E c1 \<oplus> c2, fctxt) \<in> ctxt"
+| C_Choose2: "(E, fctxt) \<in> ctxt \<Longrightarrow> (\<lambda>c2. c1 \<oplus> E c2, fctxt) \<in> ctxt"
+
+text\<open>
+
+We can decompose a small step into a context and a @{const "basic_com"}.
+
+\<close>
+
+fun
+  decompose_com :: "('answer, 'location, 'question, 'state) com
+                      \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
+                        \<times> ('answer, 'location, 'question, 'state) ctxt ) set"
+where
+  "decompose_com (LOOP DO c1 OD) = { (c, \<lambda>t. LOOP DO ictxt t OD, \<lambda>t. fctxt t @ [LOOP DO ictxt t OD]) |c fctxt ictxt. (c, ictxt, fctxt) \<in> decompose_com c1 }"
+| "decompose_com (c1;; c2) = { (c, \<lambda>t. ictxt t;; c2, \<lambda>t. fctxt t @ [c2]) |c fctxt ictxt. (c, ictxt, fctxt) \<in> decompose_com c1 }"
+| "decompose_com (c1 \<oplus> c2) = { (c, \<lambda>t. ictxt t \<oplus> c2, fctxt) |c fctxt ictxt. (c, ictxt, fctxt) \<in> decompose_com c1 }
+                           \<union> { (c, \<lambda>t. c1 \<oplus> ictxt t, fctxt) |c fctxt ictxt. (c, ictxt, fctxt) \<in> decompose_com c2 }"
+| "decompose_com c = {(c, id, \<langle>[]\<rangle>)}"
+
+definition
+  decomposeLS :: "('answer, 'location, 'question, 'state) local_state
+               \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
+                 \<times> (('answer, 'location, 'question, 'state) com \<Rightarrow> ('answer, 'location, 'question, 'state) com)
+                 \<times> (('answer, 'location, 'question, 'state) com \<Rightarrow> ('answer, 'location, 'question, 'state) com list) ) set"
+where
+  "decomposeLS s = (case cPGM s of c # _ \<Rightarrow> decompose_com c | _ \<Rightarrow> {})"
+
+lemma ctxt_inj:
+  assumes "(E, fctxt) \<in> ctxt"
+  assumes "E x = E y"
+  shows "x = y"
+using assms by (induct set: ctxt) auto
+
+lemma decompose_com_non_empty: "decompose_com c \<noteq> {}"
+by (induct c) auto
+
+lemma decompose_com_basic_com:
+  assumes "(c', ctxts) \<in> decompose_com c"
+  shows "basic_com c'"
+using assms by (induct c arbitrary: c' ctxts) (auto intro: basic_com.intros)
+
+lemma decomposeLS_basic_com:
+  assumes "(c', ctxts) \<in> decomposeLS s"
+  shows "basic_com c'"
+using assms unfolding decomposeLS_def by (simp add: decompose_com_basic_com split: list.splits)
+
+lemma decompose_com_ctxt:
+  assumes "(c', ctxts) \<in> decompose_com c"
+  shows "ctxts \<in> ctxt"
+using assms by (induct c arbitrary: c' ctxts) (auto intro: ctxt.intros)
+
+lemma decompose_com_ictxt:
+  assumes "(c', ictxt, fctxt) \<in> decompose_com c"
+  shows "ictxt c' = c"
+using assms by (induct c arbitrary: c' ictxt fctxt) auto
+
+lemma decompose_com_small_step:
+  assumes as: "(c' # fctxt c' @ cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> s'"
+  assumes ds: "(c', ictxt, fctxt) \<in> decompose_com c"
+  shows "(c # cs, s) \<rightarrow>\<^bsub>\<alpha>\<^esub> s'"
+using decompose_com_ctxt[OF ds] as decompose_com_ictxt[OF ds]
+by (induct ictxt fctxt arbitrary: c cs)
+   (cases s', fastforce simp: fun_eq_iff dest: ctxt_inj)+
+
+theorem context_decompose:
+  "s \<rightarrow>\<^bsub>\<alpha>\<^esub> s' \<longleftrightarrow> (\<exists>(c, ictxt, fctxt) \<in> decomposeLS s.
+                     cPGM s = ictxt c # tl (cPGM s)
+                   \<and> (c # fctxt c @ tl (cPGM s), cTKN s, cLST s) \<rightarrow>\<^bsub>\<alpha>\<^esub> s'
+                   \<and> (\<forall>l\<in>atC c. cTKN s' = Some l))" (is "?lhs = ?rhs")
+proof(rule iffI)
+  assume ?lhs then show ?rhs
+  unfolding decomposeLS_def
+  proof(induct rule: small_step.induct)
+    case (Choose1 c1 cs s \<alpha> cs' s' c2) then show ?case
+      apply clarsimp
+      apply (rename_tac c ictxt fctxt)
+      apply (rule_tac x="(c, \<lambda>t. ictxt t \<oplus> c2, fctxt)" in bexI)
+      apply auto
+      done
+  next
+    case (Choose2 c2 cs s \<alpha> cs' s' c1) then show ?case
+      apply clarsimp
+      apply (rename_tac c ictxt fctxt)
+      apply (rule_tac x="(c, \<lambda>t. c1 \<oplus> ictxt t, fctxt)" in bexI)
+      apply auto
+      done
+  qed fastforce+
+next
+  assume ?rhs then show ?lhs
+    unfolding decomposeLS_def
+    by (cases s) (auto split: list.splits dest: decompose_com_small_step)
+qed
+
+text\<open>
+
+While we only use this result left-to-right (to decompose a small step
+into a basic one), this equivalence shows that we lose no information
+in doing so.
+
+Decomposing a compound command preserves @{const \<open>fragments\<close>} too.
+
+\<close>
+
+fun
+  loc_compC :: "('answer, 'location, 'question, 'state) com
+                            \<Rightarrow> ('answer, 'location, 'question, 'state) com list
+                            \<Rightarrow> ('answer, 'location, 'question, 'state) loc_comp"
+where
+  "loc_compC (\<lbrace>l\<rbrace> IF b THEN c FI) cs = lcond (atC c) (atCs cs) b"
+| "loc_compC (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI) cs = lcond (atC c1) (atC c2) b"
+| "loc_compC (LOOP DO c OD) cs = lconst (atC c)"
+| "loc_compC (\<lbrace>l\<rbrace> WHILE b DO c OD) cs = lcond (atC c) (atCs cs) b"
+| "loc_compC c cs = lconst (atCs cs)"
+
+lemma decompose_fragments:
+  assumes "(c, ictxt, fctxt) \<in> decompose_com c0"
+  shows "(c, loc_compC c (fctxt c @ cs)) \<in> fragments c0 (atCs cs)"
+using assms
+proof(induct c0 arbitrary: c ictxt fctxt cs)
+  case (Loop c01 c ictxt fctxt cs)
+  from Loop.prems Loop.hyps(1)[where cs="ictxt c # cs"] show ?case by (auto simp: decompose_com_ictxt)
+next
+  case (Seq c01 c02 c ictxt fctxt cs)
+  from Seq.prems Seq.hyps(1)[where cs="c02 # cs"] show ?case by auto
+qed auto
+
+lemma at_decompose:
+  assumes "(c, ictxt, fctxt) \<in> decompose_com c0"
+  shows "atC c \<subseteq> atC c0"
+using assms by (induct c0 arbitrary: c ictxt fctxt; fastforce)
+
+lemma at_decomposeLS:
+  assumes "(c, ictxt, fctxt) \<in> decomposeLS s"
+  shows "atC c \<subseteq> atCs (cPGM s)"
+using assms unfolding decomposeLS_def by (auto simp: at_decompose split: list.splits)
+
+lemma decomposeLS_fragmentsLS:
+  assumes "(c, ictxt, fctxt) \<in> decomposeLS s"
+  shows "(c, loc_compC c (fctxt c @ tl (cPGM s))) \<in> fragmentsLS s"
+using assms
+proof(cases "cPGM s")
+  case (Cons d ds)
+  with assms decompose_fragments[where cs="ds"] show ?thesis
+    by (cases ds) (auto simp: decomposeLS_def)
+qed (simp add: decomposeLS_def)
+
+lemma small_step_loc_compC:
+  assumes "basic_com c"
+  assumes "(c # cs, ls) \<rightarrow>\<^bsub>\<alpha>\<^esub> ls'"
+  shows "loc_compC c cs (snd ls) = atCs (cPGM ls')"
+using assms by (fastforce elim: basic_com.cases elim!: small_step_inv split: lcond_splits)
+
+text\<open>
+
+The headline result allows us to constrain the initial and final states
+of a given small step in terms of the original programs, provided the
+initial state is reachable.
+
+\<close>
+
+theorem decompose_small_step:
+  assumes "GST sh p \<rightarrow>\<^bsub>\<alpha>\<^esub> ps'"
+  assumes "reachable_state sys sh"
+  obtains c cs aft
+    where "(c, aft) \<in> fragments (PGMs sys p) {}"
+      and "atC c \<subseteq> atCs (cPGM (GST sh p))"
+      and "aft (cLST (GST sh p)) = atCs (cPGM ps')"
+      and "(c # cs, cTKN (GST sh p), cLST (GST sh p)) \<rightarrow>\<^bsub>\<alpha>\<^esub> ps'"
+      and "\<forall>l\<in>atC c. cTKN ps' = Some l"
+using assms
+apply -
+apply (frule iffD1[OF context_decompose])
+apply clarsimp
+apply (frule decomposeLS_fragmentsLS)
+apply (frule at_decomposeLS)
+apply (frule (1) subsetD[OF reachable_state_fragmentsLS])
+apply (frule decomposeLS_basic_com)
+apply (frule (1) small_step_loc_compC)
+apply simp
+done
+
+text\<open>
+
+Reasoning by induction over the reachable states
+with @{thm [source] "decompose_small_step"} is quite tedious. We
+provide a very simple VCG that generates friendlier local proof
+obligations in \S\ref{sec:vcg}.
+
+\<close>
+
+
+subsection\<open>Simple-minded Hoare Logic/VCG for CIMP \label{sec:vcg}\<close>
 
 text\<open>
 
 \label{sec:cimp-vcg}
 
 We do not develop a proper Hoare logic or full VCG for CIMP: this
 machinery merely packages up the subgoals that arise from induction
 over the reachable states (\S\ref{sec:cimp-invariants}). This is
 somewhat in the spirit of @{cite [cite_macro=citet] "Ridge:2009"}.
 
 Note that this approach is not compositional: it consults the original
 system to find matching communicating pairs, and \<open>aft\<close>
 tracks the labels of possible successor statements. More serious Hoare
 logics are provided by @{cite [cite_macro=citet]
 "DBLP:journals/acta/Lamport80" and "DBLP:journals/toplas/LamportS84"
 and "CousotCousot89-IC"}.
 
 Intuitively we need to discharge a proof obligation for either @{const
 "Request"}s or @{const "Response"}s but not both. Here we choose to
 focus on @{const "Request"}s as we expect to have more local
 information available about these.
 
 \<close>
 
 inductive
   vcg :: "('answer, 'location, 'proc, 'question, 'state) programs
         \<Rightarrow> 'proc
         \<Rightarrow> ('answer, 'location, 'question, 'state) loc_comp
-        \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) pred
+        \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred
         \<Rightarrow> ('answer, 'location, 'question, 'state) com
-        \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) pred
-        \<Rightarrow> bool" ("_, _, _ \<Turnstile>/ \<lbrace>_\<rbrace>/ _/ \<lbrace>_\<rbrace>")
+        \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred
+        \<Rightarrow> bool" ("_, _, _ \<turnstile>/ \<lbrace>_\<rbrace>/ _/ \<lbrace>_\<rbrace>" [11,0,0,0,0,0] 11)
 where
-  Request: "\<lbrakk> \<And>aft' action' s ps' p's' l' \<beta> s' p'.
-                 \<lbrakk> pre s; (\<lbrace>l'\<rbrace> Response action', aft') \<in> fragments (pgms p') \<langle>False\<rangle>; p \<noteq> p';
-                   ps' \<in> val \<beta> (LST s p); (p's', \<beta>) \<in> action' (action (LST s p)) (LST s p');
-                   at p l s; at p' l' s;
-                   AT s' = (AT s)(p := aft (\<lbrace>l\<rbrace> Request action val) (LST s p),
-                                  p' := aft' (\<lbrace>l'\<rbrace> Response action') (LST s p'));
-                   LST s' = (LST s)(p := ps', p' := p's');
-                   hist s' = hist s @ [(action (LST s p), \<beta>)]
-                 \<rbrakk> \<Longrightarrow> post s'
-            \<rbrakk> \<Longrightarrow> pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> Request action val \<lbrace>post\<rbrace>"
-| LocalOp: "\<lbrakk> \<And>s ps' s'. \<lbrakk> pre s; ps' \<in> f (LST s p);
-                           at p l s;
-                           AT s' = (AT s)(p := aft (\<lbrace>l\<rbrace> LocalOp f) (LST s p));
-                           LST s' = (LST s)(p := ps');
-                           hist s' = hist s
-                         \<rbrakk> \<Longrightarrow> post s'
-            \<rbrakk> \<Longrightarrow> pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> LocalOp f \<lbrace>post\<rbrace>"
-| Cond1: "\<lbrakk> \<And>s s'. \<lbrakk> pre s;
-                     at p l s;
-                     AT s' = (AT s)(p := aft (\<lbrace>l\<rbrace> IF b THEN t FI) (LST s p));
-                     LST s' = LST s;
-                     hist s' = hist s
-                   \<rbrakk> \<Longrightarrow> post s'
-       \<rbrakk> \<Longrightarrow> pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> IF b THEN t FI \<lbrace>post\<rbrace>"
-| Cond2: "\<lbrakk> \<And>s s'. \<lbrakk> pre s;
-                     at p l s;
-                     AT s' = (AT s)(p := aft (\<lbrace>l\<rbrace> IF b THEN t ELSE e FI) (LST s p));
-                     LST s' = LST s;
-                     hist s' = hist s
-                   \<rbrakk> \<Longrightarrow> post s'
-       \<rbrakk> \<Longrightarrow> pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> IF b THEN t ELSE e FI \<lbrace>post\<rbrace>"
-| While: "\<lbrakk> \<And>s s'. \<lbrakk> pre s;
-                     at p l s;
-                     AT s' = (AT s)(p := aft (\<lbrace>l\<rbrace> WHILE b DO c OD) (LST s p));
-                     LST s' = LST s;
-                     hist s' = hist s
-                   \<rbrakk> \<Longrightarrow> post s'
-          \<rbrakk> \<Longrightarrow> pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> WHILE b DO c OD \<lbrace>post\<rbrace>"
-\<comment> \<open>There are no proof obligations for the following commands.\<close>
-| Response: "pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> Response action \<lbrace>post\<rbrace>"
-| Seq: "pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> c1 ;; c2 \<lbrace>post\<rbrace>"
-| Loop: "pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> LOOP DO c OD \<lbrace>post\<rbrace>"
-| Choose: "pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> c1 \<squnion> c2 \<lbrace>post\<rbrace>"
+  "\<lbrakk> \<And>aft' action' s ps' p's' l' \<beta> s' p'.
+      \<lbrakk> pre s; (\<lbrace>l'\<rbrace> Response action', aft') \<in> fragments (coms p') {}; p \<noteq> p';
+        ps' \<in> val \<beta> (s\<down> p); (p's', \<beta>) \<in> action' (action (s\<down> p)) (s\<down> p');
+        at p l s; at p' l' s;
+        AT s' = (AT s)(p := aft (s\<down> p), p' := aft' (s\<down> p'));
+        s'\<down> = s\<down>(p := ps', p' := p's');
+        taken p l s';
+        HST s' = HST s @ [(action (s\<down> p), \<beta>)];
+        \<forall>p''\<in>-{p,p'}. GST s' p'' = GST s p''
+      \<rbrakk> \<Longrightarrow> post s'
+   \<rbrakk> \<Longrightarrow> coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> Request action val \<lbrace>post\<rbrace>"
+| "\<lbrakk> \<And>s ps' s'.
+      \<lbrakk> pre s; ps' \<in> f (s\<down> p);
+        at p l s;
+        AT s' = (AT s)(p := aft (s\<down> p));
+        s'\<down> = s\<down>(p := ps');
+        taken p l s';
+        HST s' = HST s;
+        \<forall>p''\<in>-{p}. GST s' p'' = GST s p''
+      \<rbrakk> \<Longrightarrow> post s'
+   \<rbrakk> \<Longrightarrow> coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> LocalOp f \<lbrace>post\<rbrace>"
+| "\<lbrakk> \<And>s s'.
+      \<lbrakk> pre s;
+        at p l s;
+        AT s' = (AT s)(p := aft (s\<down> p));
+        s'\<down> = s\<down>;
+        taken p l s';
+        HST s' = HST s;
+        \<forall>p''\<in>-{p}. GST s' p'' = GST s p''
+      \<rbrakk> \<Longrightarrow> post s'
+   \<rbrakk> \<Longrightarrow> coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> IF b THEN t FI \<lbrace>post\<rbrace>"
+| "\<lbrakk> \<And>s s'.
+      \<lbrakk> pre s;
+        at p l s;
+        AT s' = (AT s)(p := aft (s\<down> p));
+        s'\<down> = s\<down>;
+        taken p l s';
+        HST s' = HST s;
+        \<forall>p''\<in>-{p}. GST s' p'' = GST s p''
+      \<rbrakk> \<Longrightarrow> post s'
+   \<rbrakk> \<Longrightarrow> coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> IF b THEN t ELSE e FI \<lbrace>post\<rbrace>"
+| "\<lbrakk> \<And>s s'.
+      \<lbrakk> pre s;
+        at p l s;
+        AT s' = (AT s)(p := aft (s\<down> p));
+        s'\<down> = s\<down>;
+        taken p l s';
+        HST s' = HST s;
+        \<forall>p''\<in>-{p}. GST s' p'' = GST s p''
+      \<rbrakk> \<Longrightarrow> post s'
+   \<rbrakk> \<Longrightarrow> coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> WHILE b DO c OD \<lbrace>post\<rbrace>"
+\<comment> \<open>There are no proof obligations for the following commands, but including them makes some basic rules hold (\S\ref{sec:cimp:vcg_rules}):\<close>
+| "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> Response action \<lbrace>post\<rbrace>"
+| "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> c1 ;; c2 \<lbrace>post\<rbrace>"
+| "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> LOOP DO c OD \<lbrace>post\<rbrace>"
+| "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> c1 \<oplus> c2 \<lbrace>post\<rbrace>"
 
 text\<open>
 
 We abbreviate invariance with one-sided validity syntax.
 
 \<close>
 
-abbreviation valid_inv ("_, _, _ \<Turnstile>/ \<lbrace>_\<rbrace>/ _") where
-  "pgms, p, aft \<Turnstile> \<lbrace>I\<rbrace> c \<equiv> pgms, p, aft \<Turnstile> \<lbrace>I\<rbrace> c \<lbrace>I\<rbrace>"
-(*<*)
+abbreviation valid_inv ("_, _, _ \<turnstile>/ \<lbrace>_\<rbrace>/ _" [11,0,0,0,0] 11) where
+  "coms, p, aft \<turnstile> \<lbrace>I\<rbrace> c \<equiv> coms, p, aft \<turnstile> \<lbrace>I\<rbrace> c \<lbrace>I\<rbrace>"
 
 inductive_cases vcg_inv:
-  "pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> Request action val \<lbrace>post\<rbrace>"
-  "pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> LocalOp f \<lbrace>post\<rbrace>"
-  "pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> IF b THEN t FI \<lbrace>post\<rbrace>"
-  "pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> IF b THEN t ELSE e FI \<lbrace>post\<rbrace>"
-  "pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> LOOP DO c OD \<lbrace>post\<rbrace>"
-  "pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> WHILE b DO c OD \<lbrace>post\<rbrace>"
-  "pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> Response action \<lbrace>post\<rbrace>"
-  "pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> c1 ;; c2 \<lbrace>post\<rbrace>"
-  "pgms, p, aft \<Turnstile> \<lbrace>pre\<rbrace> c1 \<squnion> c2 \<lbrace>post\<rbrace>"
+  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> Request action val \<lbrace>post\<rbrace>"
+  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> LocalOp f \<lbrace>post\<rbrace>"
+  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> IF b THEN t FI \<lbrace>post\<rbrace>"
+  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> IF b THEN t ELSE e FI \<lbrace>post\<rbrace>"
+  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> WHILE b DO c OD \<lbrace>post\<rbrace>"
+  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> LOOP DO c OD \<lbrace>post\<rbrace>"
+  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> \<lbrace>l\<rbrace> Response action \<lbrace>post\<rbrace>"
+  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> c1 ;; c2 \<lbrace>post\<rbrace>"
+  "coms, p, aft \<turnstile> \<lbrace>pre\<rbrace> Choose c1 c2 \<lbrace>post\<rbrace>"
 
-lemma vcg_precond_cong:
-  "P = P' \<Longrightarrow> (pgms, p, aft \<Turnstile> \<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace>) \<longleftrightarrow> (pgms, p, aft \<Turnstile> \<lbrace>P'\<rbrace> c \<lbrace>Q\<rbrace>)"
-by simp
-
-lemma vcg_postcond_cong:
-  "Q = Q' \<Longrightarrow> (pgms, p, aft \<Turnstile> \<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace>) \<longleftrightarrow> (pgms, p, aft \<Turnstile> \<lbrace>P\<rbrace> c \<lbrace>Q'\<rbrace>)"
-by simp
-
-(*>*)
 text\<open>
 
 We tweak @{const "fragments"} by omitting @{const "Response"}s,
-yielding fewer obligations.
+yielding fewer obligations
 
 \<close>
 
 fun
   vcg_fragments' :: "('answer, 'location, 'question, 'state) com
-               \<Rightarrow> ('location \<Rightarrow> bool)
+               \<Rightarrow> 'location set
                \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
                  \<times> ('answer, 'location, 'question, 'state) loc_comp ) set"
 where
-  "vcg_fragments' (\<lbrace>l\<rbrace> Response action) ls = {}"
-| "vcg_fragments' (\<lbrace>l\<rbrace> IF b THEN c FI) ls
-       = vcg_fragments' c ls
-       \<union> { (\<lbrace>l\<rbrace> IF b THEN c' FI, lcond (atC c) ls) |c'. True }"
-| "vcg_fragments' (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI) ls
-       = vcg_fragments' c2 ls \<union> vcg_fragments' c1 ls
-       \<union> { (\<lbrace>l\<rbrace> IF b THEN c1' ELSE c2' FI, lcond (atC c1) (atC c2)) |c1' c2'. True }"
-| "vcg_fragments' (LOOP DO c OD) ls = vcg_fragments' c (atC c)"
-| "vcg_fragments' (\<lbrace>l'\<rbrace> WHILE b DO c OD) ls
-       = vcg_fragments' c (\<lambda>l. l = l') \<union> { (\<lbrace>l'\<rbrace> WHILE b DO c' OD, lcond (atC c) ls) |c'. True }"
-| "vcg_fragments' (c1 ;; c2) ls = vcg_fragments' c2 ls \<union> vcg_fragments' c1 (atC c2)"
-| "vcg_fragments' (c1 \<squnion> c2) ls = vcg_fragments' c1 ls \<union> vcg_fragments' c2 ls"
-| "vcg_fragments' c ls = {(c, lconst ls)}"
+  "vcg_fragments' (\<lbrace>l\<rbrace> Response action) aft = {}"
+| "vcg_fragments' (\<lbrace>l\<rbrace> IF b THEN c FI) aft
+       = vcg_fragments' c aft
+       \<union> { (\<lbrace>l\<rbrace> IF b THEN c' FI, lcond (atC c) aft b) |c'. True }"
+| "vcg_fragments' (\<lbrace>l\<rbrace> IF b THEN c1 ELSE c2 FI) aft
+       = vcg_fragments' c2 aft \<union> vcg_fragments' c1 aft
+       \<union> { (\<lbrace>l\<rbrace> IF b THEN c1' ELSE c2' FI, lcond (atC c1) (atC c2) b) |c1' c2'. True }"
+| "vcg_fragments' (LOOP DO c OD) aft = vcg_fragments' c (atC c)"
+| "vcg_fragments' (\<lbrace>l\<rbrace> WHILE b DO c OD) aft
+       = vcg_fragments' c {l} \<union> { (\<lbrace>l\<rbrace> WHILE b DO c' OD, lcond (atC c) aft b) |c'. True }"
+| "vcg_fragments' (c1 ;; c2) aft = vcg_fragments' c2 aft \<union> vcg_fragments' c1 (atC c2)"
+| "vcg_fragments' (c1 \<oplus> c2) aft = vcg_fragments' c1 aft \<union> vcg_fragments' c2 aft"
+| "vcg_fragments' c aft = {(c, lconst aft)}"
 
 abbreviation
   vcg_fragments :: "('answer, 'location, 'question, 'state) com
                   \<Rightarrow> ( ('answer, 'location, 'question, 'state) com
                     \<times> ('answer, 'location, 'question, 'state) loc_comp ) set"
 where
-  "vcg_fragments c \<equiv> vcg_fragments' c \<langle>False\<rangle>"
-(*<*)
+  "vcg_fragments c \<equiv> vcg_fragments' c {}"
 
-lemma vcg_fragments'_inc:
-  "\<lbrakk> (c', lp) \<in> fragments c ls; \<And>l action. c' \<noteq> \<lbrace>l\<rbrace> Response action \<rbrakk> \<Longrightarrow> (c', lp) \<in> vcg_fragments' c ls"
-by (induct c arbitrary: ls) (auto split: if_splits)
+fun isResponse :: "('answer, 'location, 'question, 'state) com \<Rightarrow> bool" where
+  "isResponse (\<lbrace>l\<rbrace> Response action) \<longleftrightarrow> True"
+| "isResponse _ \<longleftrightarrow> False"
+
+lemma fragments_vcg_fragments':
+  "\<lbrakk> (c, aft) \<in> fragments c' aft'; \<not>isResponse c \<rbrakk> \<Longrightarrow> (c, aft) \<in> vcg_fragments' c' aft'"
+by (induct c' arbitrary: aft') auto
+
+lemma vcg_fragments'_fragments:
+  "vcg_fragments' c' aft' \<subseteq> fragments c' aft'" 
+by (induct c' arbitrary: aft') (auto 10 0)
 
 lemma VCG_step:
-  assumes V: "\<And>p. \<forall>(c, afts) \<in> vcg_fragments (fst sys p). ((fst sys), p, afts \<Turnstile> \<lbrace>pre\<rbrace> c \<lbrace>post\<rbrace>)"
-  assumes S: "(s, h) s\<Rightarrow> (s', h')"
-  assumes R: "(s, h) \<in> reachable_states sys"
-  assumes P: "pre (mkP (s, h))"
-  shows "post (mkP (s', h'))"
+  assumes V: "\<And>p. \<forall>(c, aft) \<in> vcg_fragments (PGMs sys p). PGMs sys, p, aft \<turnstile> \<lbrace>pre\<rbrace> c \<lbrace>post\<rbrace>"
+  assumes S: "system_step p sh' sh"
+  assumes R: "reachable_state sys sh"
+  assumes P: "pre sh"
+  shows "post sh'"
 using S
 proof cases
-  case (LocalStep p ps') with P show ?thesis
+  case LocalStep with P show ?thesis
     apply -
     apply (erule decompose_small_step[OF _ R])
-    apply (elim basic_com.cases, simp_all)
-    apply (fastforce dest!: V[rule_format] vcg_fragments'_inc
-                     elim!: small_step_inv vcg_inv
-                      simp: fun_eq_iff LST_def AT_def mkP_def split_def)+
+    apply (frule fragments_basic_com)
+    apply (erule basic_com.cases)
+    apply (fastforce dest!: fragments_vcg_fragments' V[rule_format]
+                      elim: vcg_inv elim!: small_step_inv
+                      simp: LST_def AT_def taken_def fun_eq_iff)+
     done
 next
-  case (CommunicationStep p1 \<alpha> \<beta> ls1' p2 ls2) with P show ?thesis
+  case CommunicationStep with P show ?thesis
     apply -
     apply (erule decompose_small_step[OF _ R])
     apply (erule decompose_small_step[OF _ R])
-    apply (elim basic_com.cases, simp_all)
-    apply (drule vcg_fragments'_inc, simp)
-    apply (drule V[rule_format])
-    apply clarsimp
-    apply (erule vcg_inv)
-    apply (elim small_step_inv)
-    apply (fastforce simp add: fun_eq_iff LST_def AT_def mkP_def split_def)
+    subgoal for c cs aft c' cs' aft'
+    apply (frule fragments_basic_com[where c'=c])
+    apply (frule fragments_basic_com[where c'=c'])
+    apply (elim basic_com.cases; clarsimp elim!: small_step_inv)
+    apply (drule fragments_vcg_fragments')
+    apply (fastforce dest!: V[rule_format]
+                      elim: vcg_inv elim!: small_step_inv
+                      simp: LST_def AT_def taken_def fun_eq_iff)+
+    done
     done
 qed
 
-(*>*)
 text\<open>
 
-The user sees the conclusion of \<open>V\<close> for each element of \<open>vcg_fragments\<close>.
-
-\<close>
-
-lemma VCG:
-  assumes R: "s \<in> reachable_states sys"
-  assumes I: "\<forall>s \<in> initial_states sys. I (mkP (s, []))"
-  assumes V: "\<And>p. \<forall>(c, afts) \<in> vcg_fragments (fst sys p). ((fst sys), p, afts \<Turnstile> \<lbrace>I\<rbrace> c)"
-  shows "I (mkP s)"
-(*<*)
-proof -
-  have "I (mkP (s', h'))" if B: "s0 \<in> initial_states sys" and S: "(s0, []) s\<Rightarrow>\<^sup>* (s', h')" for s0 s' h'
-  using S
-  proof(induct rule: rtrancl_induct2)
-    case refl with B show ?case by (rule I[rule_format])
-  next
-    case (step s' h' s'' h'') with B V show ?case
-      by - (erule (1) VCG_step; auto simp: reachable_states_def)
-  qed
-  with I R show ?thesis by (cases s) (clarsimp simp: reachable_states_def)
-qed
-(*>*)
-
-subsubsection\<open>VCG rules\<close>
-
-text\<open>
-
-We can develop some (but not all) of the familiar Hoare rules; see
-@{cite [cite_macro=citet] "DBLP:journals/acta/Lamport80"} and the
-seL4/l4.verified lemma buckets for inspiration. We avoid many of the
-issues Lamport mentions as we only treat basic (atomic) commands.
+The user sees the conclusion of \<open>V\<close> for each element of @{const \<open>vcg_fragments\<close>}.
 
 \<close>
 
-context
-  fixes pgms :: "('answer, 'location, 'proc, 'question, 'state) programs"
-  fixes p :: "'proc"
-  fixes afts :: "('answer, 'location, 'question, 'state) loc_comp"
-begin
-
-abbreviation
-  valid_syn :: "('answer, 'location, 'proc, 'question, 'state) pred
-             \<Rightarrow> ('answer, 'location, 'question, 'state) com
-             \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) pred \<Rightarrow> bool" where
-  "valid_syn P c Q \<equiv> pgms, p, afts \<Turnstile> \<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace>"
-notation valid_syn ("\<lbrace>_\<rbrace>/ _/ \<lbrace>_\<rbrace>")
-
-abbreviation
-  valid_inv_syn :: "('answer, 'location, 'proc, 'question, 'state) pred
-                  \<Rightarrow> ('answer, 'location, 'question, 'state) com \<Rightarrow> bool" where
-  "valid_inv_syn P c \<equiv> \<lbrace>P\<rbrace> c \<lbrace>P\<rbrace>"
-notation valid_inv_syn ("\<lbrace>_\<rbrace>/ _")
-
-lemma vcg_True:
-  "\<lbrace>P\<rbrace> c \<lbrace>\<langle>True\<rangle>\<rbrace>"
-by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
-
-lemma vcg_conj:
-  "\<lbrakk> \<lbrace>I\<rbrace> c \<lbrace>Q\<rbrace>; \<lbrace>I\<rbrace> c \<lbrace>R\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>I\<rbrace> c \<lbrace>Q \<^bold>\<and> R\<rbrace>"
-by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
-
-lemma vcg_pre_imp:
-  "\<lbrakk> \<And>s. P s \<Longrightarrow> Q s; \<lbrace>Q\<rbrace> c \<lbrace>R\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> c \<lbrace>R\<rbrace>"
-by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
-
-lemmas vcg_pre = vcg_pre_imp[rotated]
-
-lemma vcg_post_imp:
-  "\<lbrakk> \<And>s. Q s \<Longrightarrow> R s; \<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> c \<lbrace>R\<rbrace>"
-by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
-
-lemma vcg_prop[intro]:
-  "\<lbrace>\<langle>P\<rangle>\<rbrace> c"
-by (cases c) (fastforce intro: vcg.intros)+
-
-lemma vcg_drop_imp:
-  assumes "\<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace>"
-  shows "\<lbrace>P\<rbrace> c \<lbrace>R \<^bold>\<longrightarrow> Q\<rbrace>"
-using assms
-by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
-
-lemma vcg_conj_lift:
-  assumes x: "\<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace>"
-  assumes y: "\<lbrace>P'\<rbrace> c \<lbrace>Q'\<rbrace>"
-  shows      "\<lbrace>P \<^bold>\<and> P'\<rbrace> c \<lbrace>Q \<^bold>\<and> Q'\<rbrace>"
-apply (rule vcg_conj)
- apply (rule vcg_pre[OF x], simp)
-apply (rule vcg_pre[OF y], simp)
+lemma VCG_step_inv_stable:
+  assumes V: "\<And>p. \<forall>(c, aft) \<in> vcg_fragments (PGMs sys p). PGMs sys, p, aft \<turnstile> \<lbrace>I\<rbrace> c"
+  assumes "prerun sys \<sigma>"
+  shows "(\<lceil>I\<rceil> \<^bold>\<hookrightarrow> \<circle>\<lceil>I\<rceil>) \<sigma>"
+apply (rule alwaysI)
+apply clarsimp
+apply (rule nextI)
+apply clarsimp
+using assms(2) unfolding prerun_def
+apply clarsimp
+apply (erule_tac i=i in alwaysE)
+unfolding system_step_reflclp_def
+apply clarsimp
+apply (erule disjE; clarsimp)
+using VCG_step[where pre=I and post=I] V assms(2) prerun_reachable_state
+apply blast
 done
 
-lemma vcg_disj_lift:
-  assumes x: "\<lbrace>P\<rbrace>  c \<lbrace>Q\<rbrace>"
-  assumes y: "\<lbrace>P'\<rbrace> c \<lbrace>Q'\<rbrace>"
-  shows      "\<lbrace>P \<^bold>\<or> P'\<rbrace> c \<lbrace>Q \<^bold>\<or> Q'\<rbrace>"
-using assms
-by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
-
-lemma vcg_imp_lift:
-  assumes "\<lbrace>P'\<rbrace> c \<lbrace>\<^bold>\<not> P\<rbrace>"
-  assumes "\<lbrace>Q'\<rbrace> c \<lbrace>Q\<rbrace>"
-  shows "\<lbrace>P' \<^bold>\<or> Q'\<rbrace> c \<lbrace>P \<^bold>\<longrightarrow> Q\<rbrace>"
-by (simp only: imp_conv_disj vcg_disj_lift[OF assms])
-
-lemma vcg_ex_lift:
-  assumes "\<And>x. \<lbrace>P x\<rbrace> c \<lbrace>Q x\<rbrace>"
-  shows "\<lbrace>\<lambda>s. \<exists>x. P x s\<rbrace> c \<lbrace>\<lambda>s. \<exists>x. Q x s\<rbrace>"
-using assms
-by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
-
-lemma vcg_all_lift:
-  assumes "\<And>x. \<lbrace>P x\<rbrace> c \<lbrace>Q x\<rbrace>"
-  shows "\<lbrace>\<lambda>s. \<forall>x. P x s\<rbrace> c \<lbrace>\<lambda>s. \<forall>x. Q x s\<rbrace>"
-using assms
-by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
-
-lemma vcg_name_pre_state:
-  assumes "\<And>s. P s \<Longrightarrow> \<lbrace>(=) s\<rbrace> c \<lbrace>Q\<rbrace>"
-  shows "\<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace>"
-using assms
-by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
-
-lemma vcg_lift_comp:
-  assumes f: "\<And>P. \<lbrace>\<lambda>s. P (f s :: 'a :: type)\<rbrace> c"
-  assumes P: "\<And>x. \<lbrace>Q x\<rbrace> c \<lbrace>P x\<rbrace>"
-  shows "\<lbrace>\<lambda>s. Q (f s) s\<rbrace> c \<lbrace>\<lambda>s. P (f s) s\<rbrace>"
-  apply (rule vcg_name_pre_state)
-  apply (rename_tac s)
-  apply (rule vcg_pre)
-   apply (rule vcg_post_imp[rotated])
-    apply (rule vcg_conj_lift)
-     apply (rule_tac x="f s" in P)
-    apply (rule_tac P="\<lambda>fs. fs = f s" in f)
-   apply simp
-  apply simp
-  done
-
-(* **************************************** *)
-
-subsubsection\<open>Cheap non-interference rules\<close>
-
-text\<open>
-
-These rules magically construct VCG lifting rules from the easier to
-prove \<open>eq_imp\<close> facts. We don't actually use these in the GC,
-but we do derive @{const "fun_upd"} equations using the same
-mechanism. Thanks to Thomas Sewell for the requisite syntax magic.
-
-As these \<open>eq_imp\<close> facts do not usefully compose, we make the
-definition asymmetric (i.e., \<open>g\<close> does not get a bundle of
-parameters).
-
-\<close>
-
-definition eq_imp :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'e) \<Rightarrow> bool" where
-  "eq_imp f g \<equiv> (\<forall>s s'. (\<forall>x. f x s = f x s') \<longrightarrow> (g s = g s'))"
-
-lemma eq_impD:
-  "\<lbrakk> eq_imp f g; \<forall>x. f x s = f x s' \<rbrakk> \<Longrightarrow> g s = g s'"
-by (simp add: eq_imp_def)
-
-lemma eq_imp_vcg:
-  assumes g: "eq_imp f g"
-  assumes f: "\<forall>x P. \<lbrace>P \<circ> (f x)\<rbrace> c"
-  shows "\<lbrace>P \<circ> g\<rbrace> c"
-  apply (rule vcg_name_pre_state)
-  apply (rename_tac s)
-  apply (rule vcg_pre)
-   apply (rule vcg_post_imp[rotated])
-    apply (rule vcg_all_lift[where 'a='a])
-    apply (rule_tac x=x and P="\<lambda>fs. fs = f x s" in f[rule_format])
-   apply simp
-   apply (frule eq_impD[where f=f, OF g])
-   apply simp
-  apply simp
-  done
-
-lemma eq_imp_vcg_LST:
-  assumes g: "eq_imp f g"
-  assumes f: "\<forall>x P. \<lbrace>P \<circ> (f x) \<circ> LST\<rbrace> c"
-  shows "\<lbrace>P \<circ> g \<circ> LST\<rbrace> c"
-  apply (rule vcg_name_pre_state)
-  apply (rename_tac s)
-  apply (rule vcg_pre)
-   apply (rule vcg_post_imp[rotated])
-    apply (rule vcg_all_lift[where 'a='a])
-    apply (rule_tac x=x and P="\<lambda>fs. fs = f x s\<down>" in f[rule_format])
-   apply simp
-   apply (frule eq_impD[where f=f, OF g])
-   apply simp
-  apply simp
-  done
-
-lemma eq_imp_fun_upd:
-  assumes g: "eq_imp f g"
-  assumes f: "\<forall>x. f x (s(fld := val)) = f x s"
-  shows "g (s(fld := val)) = g s"
-apply (rule eq_impD[OF g])
-apply (rule f)
+lemma VCG:
+  assumes I: "\<forall>s. initial_state sys s \<longrightarrow> I (\<lparr>GST = s, HST = []\<rparr>)"
+  assumes V: "\<And>p. \<forall>(c, aft) \<in> vcg_fragments (PGMs sys p). PGMs sys, p, aft \<turnstile> \<lbrace>I\<rbrace> c"
+  shows "sys \<Turnstile>\<^bsub>pre\<^esub> I"
+apply (rule prerun_valid_induct)
+ apply (clarsimp simp: prerun_def state_prop_def)
+ apply (metis (full_types) I old.unit.exhaust system_state.surjective)
+using VCG_step_inv_stable[OF V] apply blast
 done
 
-lemma curry_forall_eq:
-  "(\<forall>f. P f) = (\<forall>f. P (case_prod f))"
-  apply safe
-   apply simp_all
-  apply (rename_tac f)
-  apply (drule_tac x="\<lambda>x y. f (x, y)" in spec)
-  apply simp
-  done
-
-lemma pres_tuple_vcg:
-  "(\<forall>P. \<lbrace>P \<circ> (\<lambda>s. (f s, g s))\<rbrace> c)
-    \<longleftrightarrow> ((\<forall>P. \<lbrace>P \<circ> f\<rbrace> c) \<and> (\<forall>P. \<lbrace>P \<circ> g\<rbrace> c))"
-  apply (simp add: curry_forall_eq o_def)
-  apply safe
-    apply fast
-   apply fast
-  apply (rename_tac P)
-  apply (rule_tac f="f" and P="\<lambda>fs s. P fs (g s)" in vcg_lift_comp, simp, simp)
-  done
-
-lemma pres_tuple_vcg_LST:
-  "(\<forall>P. \<lbrace>P \<circ> (\<lambda>s. (f s, g s)) \<circ> LST\<rbrace> c)
-    \<longleftrightarrow> ((\<forall>P. \<lbrace>P \<circ> f \<circ> LST\<rbrace> c) \<and> (\<forall>P. \<lbrace>P \<circ> g \<circ> LST\<rbrace> c))"
-  apply (simp add: curry_forall_eq o_def)
-  apply safe
-    apply fast
-   apply fast
-  apply (rename_tac P)
-  apply (rule_tac f="\<lambda>s. f s\<down>" and P="\<lambda>fs s. P fs (g s)" for g in vcg_lift_comp, simp, simp)
-  done
-
-lemmas conj_explode = conj_imp_eq_imp_imp
-
-end
+lemmas VCG_valid = valid_prerun_lift[OF VCG, of sys I] for sys I
 (*<*)
 
 end
 (*>*)
diff --git a/thys/ConcurrentIMP/CIMP_vcg_rules.thy b/thys/ConcurrentIMP/CIMP_vcg_rules.thy
new file mode 100644
--- /dev/null
+++ b/thys/ConcurrentIMP/CIMP_vcg_rules.thy
@@ -0,0 +1,229 @@
+(*<*)
+(*
+ * Copyright 2015, NICTA
+ *
+ * This software may be distributed and modified according to the terms of
+ * the BSD 2-Clause license. Note that NO WARRANTY is provided.
+ * See "LICENSE_BSD2.txt" for details.
+ *
+ * @TAG(NICTA_BSD)
+ *)
+
+theory CIMP_vcg_rules
+imports
+  CIMP_vcg
+begin
+
+(*>*)
+subsubsection\<open> VCG rules \label{sec:cimp:vcg_rules} \<close>
+
+text\<open>
+
+We can develop some (but not all) of the familiar Hoare rules; see
+@{cite [cite_macro=citet] "DBLP:journals/acta/Lamport80"} and the
+seL4/l4.verified lemma buckets for inspiration. We avoid many of the
+issues Lamport mentions as we only treat basic (atomic) commands.
+
+\<close>
+
+context
+  fixes coms :: "('answer, 'location, 'proc, 'question, 'state) programs"
+  fixes p :: "'proc"
+  fixes aft :: "('answer, 'location, 'question, 'state) loc_comp"
+begin
+
+abbreviation
+  valid_syn :: "('answer, 'location, 'proc, 'question, 'state) state_pred
+             \<Rightarrow> ('answer, 'location, 'question, 'state) com
+             \<Rightarrow> ('answer, 'location, 'proc, 'question, 'state) state_pred \<Rightarrow> bool" where
+  "valid_syn P c Q \<equiv> coms, p, aft \<turnstile> \<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace>"
+notation valid_syn ("\<lbrace>_\<rbrace>/ _/ \<lbrace>_\<rbrace>")
+
+abbreviation
+  valid_inv_syn :: "('answer, 'location, 'proc, 'question, 'state) state_pred
+                  \<Rightarrow> ('answer, 'location, 'question, 'state) com \<Rightarrow> bool" where
+  "valid_inv_syn P c \<equiv> \<lbrace>P\<rbrace> c \<lbrace>P\<rbrace>"
+notation valid_inv_syn ("\<lbrace>_\<rbrace>/ _")
+
+lemma vcg_True:
+  "\<lbrace>P\<rbrace> c \<lbrace>\<langle>True\<rangle>\<rbrace>"
+by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
+
+lemma vcg_conj:
+  "\<lbrakk> \<lbrace>I\<rbrace> c \<lbrace>Q\<rbrace>; \<lbrace>I\<rbrace> c \<lbrace>R\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>I\<rbrace> c \<lbrace>Q \<^bold>\<and> R\<rbrace>"
+by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
+
+lemma vcg_pre_imp:
+  "\<lbrakk> \<And>s. P s \<Longrightarrow> Q s; \<lbrace>Q\<rbrace> c \<lbrace>R\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> c \<lbrace>R\<rbrace>"
+by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
+
+lemmas vcg_pre = vcg_pre_imp[rotated]
+
+lemma vcg_post_imp:
+  "\<lbrakk> \<And>s. Q s \<Longrightarrow> R s; \<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace> \<rbrakk> \<Longrightarrow> \<lbrace>P\<rbrace> c \<lbrace>R\<rbrace>"
+by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
+
+lemma vcg_prop[intro]:
+  "\<lbrace>\<langle>P\<rangle>\<rbrace> c"
+by (cases c) (fastforce intro: vcg.intros)+
+
+lemma vcg_drop_imp:
+  assumes "\<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace>"
+  shows "\<lbrace>P\<rbrace> c \<lbrace>R \<^bold>\<longrightarrow> Q\<rbrace>"
+using assms
+by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
+
+lemma vcg_conj_lift:
+  assumes x: "\<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace>"
+  assumes y: "\<lbrace>P'\<rbrace> c \<lbrace>Q'\<rbrace>"
+  shows      "\<lbrace>P \<^bold>\<and> P'\<rbrace> c \<lbrace>Q \<^bold>\<and> Q'\<rbrace>"
+apply (rule vcg_conj)
+ apply (rule vcg_pre[OF x], simp)
+apply (rule vcg_pre[OF y], simp)
+done
+
+lemma vcg_disj_lift:
+  assumes x: "\<lbrace>P\<rbrace>  c \<lbrace>Q\<rbrace>"
+  assumes y: "\<lbrace>P'\<rbrace> c \<lbrace>Q'\<rbrace>"
+  shows      "\<lbrace>P \<^bold>\<or> P'\<rbrace> c \<lbrace>Q \<^bold>\<or> Q'\<rbrace>"
+using assms
+by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
+
+lemma vcg_imp_lift:
+  assumes "\<lbrace>P'\<rbrace> c \<lbrace>\<^bold>\<not> P\<rbrace>"
+  assumes "\<lbrace>Q'\<rbrace> c \<lbrace>Q\<rbrace>"
+  shows "\<lbrace>P' \<^bold>\<or> Q'\<rbrace> c \<lbrace>P \<^bold>\<longrightarrow> Q\<rbrace>"
+by (simp only: imp_conv_disj vcg_disj_lift[OF assms])
+
+lemma vcg_ex_lift:
+  assumes "\<And>x. \<lbrace>P x\<rbrace> c \<lbrace>Q x\<rbrace>"
+  shows "\<lbrace>\<lambda>s. \<exists>x. P x s\<rbrace> c \<lbrace>\<lambda>s. \<exists>x. Q x s\<rbrace>"
+using assms
+by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
+
+lemma vcg_all_lift:
+  assumes "\<And>x. \<lbrace>P x\<rbrace> c \<lbrace>Q x\<rbrace>"
+  shows "\<lbrace>\<lambda>s. \<forall>x. P x s\<rbrace> c \<lbrace>\<lambda>s. \<forall>x. Q x s\<rbrace>"
+using assms
+by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
+
+lemma vcg_name_pre_state:
+  assumes "\<And>s. P s \<Longrightarrow> \<lbrace>(=) s\<rbrace> c \<lbrace>Q\<rbrace>"
+  shows "\<lbrace>P\<rbrace> c \<lbrace>Q\<rbrace>"
+using assms
+by (cases c) (fastforce elim!: vcg_inv intro: vcg.intros)+
+
+lemma vcg_lift_comp:
+  assumes f: "\<And>P. \<lbrace>\<lambda>s. P (f s :: 'a :: type)\<rbrace> c"
+  assumes P: "\<And>x. \<lbrace>Q x\<rbrace> c \<lbrace>P x\<rbrace>"
+  shows "\<lbrace>\<lambda>s. Q (f s) s\<rbrace> c \<lbrace>\<lambda>s. P (f s) s\<rbrace>"
+apply (rule vcg_name_pre_state)
+apply (rename_tac s)
+apply (rule vcg_pre)
+ apply (rule vcg_post_imp[rotated])
+  apply (rule vcg_conj_lift)
+   apply (rule_tac x="f s" in P)
+  apply (rule_tac P="\<lambda>fs. fs = f s" in f)
+ apply simp
+apply simp
+done
+
+
+subsubsection\<open>Cheap non-interference rules\<close>
+
+text\<open>
+
+These rules magically construct VCG lifting rules from the easier to
+prove \<open>eq_imp\<close> facts. We don't actually use these in the GC,
+but we do derive @{const "fun_upd"} equations using the same
+mechanism. Thanks to Thomas Sewell for the requisite syntax magic.
+
+As these \<open>eq_imp\<close> facts do not usefully compose, we make the
+definition asymmetric (i.e., \<open>g\<close> does not get a bundle of
+parameters).
+
+Note that these are effectively parametricity rules.
+
+\<close>
+
+definition eq_imp :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'e) \<Rightarrow> bool" where
+  "eq_imp f g \<equiv> (\<forall>s s'. (\<forall>x. f x s = f x s') \<longrightarrow> (g s = g s'))"
+
+lemma eq_impD:
+  "\<lbrakk> eq_imp f g; \<forall>x. f x s = f x s' \<rbrakk> \<Longrightarrow> g s = g s'"
+by (simp add: eq_imp_def)
+
+lemma eq_imp_vcg:
+  assumes g: "eq_imp f g"
+  assumes f: "\<forall>x P. \<lbrace>P \<circ> (f x)\<rbrace> c"
+  shows "\<lbrace>P \<circ> g\<rbrace> c"
+apply (rule vcg_name_pre_state)
+apply (rename_tac s)
+apply (rule vcg_pre)
+ apply (rule vcg_post_imp[rotated])
+  apply (rule vcg_all_lift[where 'a='a])
+  apply (rule_tac x=x and P="\<lambda>fs. fs = f x s" in f[rule_format])
+ apply simp
+ apply (frule eq_impD[where f=f, OF g])
+ apply simp
+apply simp
+done
+
+lemma eq_imp_vcg_LST:
+  assumes g: "eq_imp f g"
+  assumes f: "\<forall>x P. \<lbrace>P \<circ> (f x) \<circ> LST\<rbrace> c"
+  shows "\<lbrace>P \<circ> g \<circ> LST\<rbrace> c"
+apply (rule vcg_name_pre_state)
+apply (rename_tac s)
+apply (rule vcg_pre)
+ apply (rule vcg_post_imp[rotated])
+  apply (rule vcg_all_lift[where 'a='a])
+  apply (rule_tac x=x and P="\<lambda>fs. fs = f x s\<down>" in f[rule_format])
+ apply simp
+ apply (frule eq_impD[where f=f, OF g])
+ apply simp
+apply simp
+done
+
+lemma eq_imp_fun_upd:
+  assumes g: "eq_imp f g"
+  assumes f: "\<forall>x. f x (s(fld := val)) = f x s"
+  shows "g (s(fld := val)) = g s"
+apply (rule eq_impD[OF g])
+apply (rule f)
+done
+
+lemma curry_forall_eq:
+  "(\<forall>f. P f) = (\<forall>f. P (case_prod f))"
+by (metis case_prod_curry)
+
+lemma pres_tuple_vcg:
+  "(\<forall>P. \<lbrace>P \<circ> (\<lambda>s. (f s, g s))\<rbrace> c)
+    \<longleftrightarrow> ((\<forall>P. \<lbrace>P \<circ> f\<rbrace> c) \<and> (\<forall>P. \<lbrace>P \<circ> g\<rbrace> c))"
+apply (simp add: curry_forall_eq o_def)
+apply safe
+  apply fast
+ apply fast
+apply (rename_tac P)
+apply (rule_tac f="f" and P="\<lambda>fs s. P fs (g s)" in vcg_lift_comp; simp)
+done
+
+lemma pres_tuple_vcg_LST:
+  "(\<forall>P. \<lbrace>P \<circ> (\<lambda>s. (f s, g s)) \<circ> LST\<rbrace> c)
+    \<longleftrightarrow> ((\<forall>P. \<lbrace>P \<circ> f \<circ> LST\<rbrace> c) \<and> (\<forall>P. \<lbrace>P \<circ> g \<circ> LST\<rbrace> c))"
+apply (simp add: curry_forall_eq o_def)
+apply safe
+  apply fast
+ apply fast
+apply (rename_tac P)
+apply (rule_tac f="\<lambda>s. f s\<down>" and P="\<lambda>fs s. P fs (g s)" for g in vcg_lift_comp; simp)
+done
+
+no_notation valid_syn ("\<lbrace>_\<rbrace>/ _/ \<lbrace>_\<rbrace>")
+
+end
+
+(*<*)
+
+end
+(*>*)
diff --git a/thys/ConcurrentIMP/Infinite_Sequences.thy b/thys/ConcurrentIMP/Infinite_Sequences.thy
new file mode 100644
--- /dev/null
+++ b/thys/ConcurrentIMP/Infinite_Sequences.thy
@@ -0,0 +1,333 @@
+(*<*)
+theory Infinite_Sequences
+imports
+  CIMP_pred
+begin
+
+(*>*)
+section\<open> Infinite Sequences \label{sec:infinite_sequences}\<close>
+
+text\<open>
+
+Infinite sequences and some operations on them.
+
+We use the customary function-based representation.
+
+\<close>
+
+type_synonym 'a seq = "nat \<Rightarrow> 'a"
+type_synonym 'a seq_pred = "'a seq \<Rightarrow> bool"
+
+definition suffix :: "'a seq \<Rightarrow> nat \<Rightarrow> 'a seq" (infixl "|\<^sub>s" 60) where
+  "\<sigma> |\<^sub>s i \<equiv> \<lambda>j. \<sigma> (j + i)"
+
+primrec stake :: "nat \<Rightarrow> 'a seq \<Rightarrow> 'a list" where
+  "stake 0 \<sigma> = []"
+| "stake (Suc n) \<sigma> = \<sigma> 0 # stake n (\<sigma> |\<^sub>s 1)"
+
+primrec shift :: "'a list \<Rightarrow> 'a seq \<Rightarrow> 'a seq" (infixr \<open>@-\<close> 65) where
+  "shift [] \<sigma> = \<sigma>"
+| "shift (x # xs) \<sigma> = (\<lambda>i. case i of 0 \<Rightarrow> x | Suc i \<Rightarrow> shift xs \<sigma> i)"
+
+(* FIXME misleading: this is \<sigma>(i, i+j). Use a bundle for this notation. FIXME move *)
+abbreviation interval_syn ("_'(_ \<rightarrow> _')" [69, 0, 0] 70) where (* FIXME priorities *)
+  "\<sigma>(i \<rightarrow> j) \<equiv> stake j (\<sigma> |\<^sub>s i)"
+
+lemma suffix_eval: "(\<sigma> |\<^sub>s i) j = \<sigma> (j + i)"
+unfolding suffix_def by simp
+
+lemma suffix_plus: "\<sigma> |\<^sub>s n |\<^sub>s m = \<sigma> |\<^sub>s (m + n)"
+unfolding suffix_def by (simp add: add.assoc)
+
+lemma suffix_commute: "((\<sigma> |\<^sub>s n) |\<^sub>s m) = ((\<sigma> |\<^sub>s m) |\<^sub>s n)"
+by (simp add: suffix_plus add.commute)
+
+lemma suffix_plus_com: "\<sigma> |\<^sub>s m |\<^sub>s n = \<sigma> |\<^sub>s (m + n)"
+proof -
+  have "\<sigma> |\<^sub>s n |\<^sub>s m = \<sigma> |\<^sub>s (m + n)" by (rule suffix_plus)
+  then show "\<sigma> |\<^sub>s m |\<^sub>s n = \<sigma> |\<^sub>s (m + n)" by (simp add: suffix_commute)
+qed
+
+lemma suffix_zero: "\<sigma> |\<^sub>s 0 = \<sigma>"
+unfolding suffix_def by simp
+
+lemma comp_suffix: "f \<circ> \<sigma> |\<^sub>s i = (f \<circ> \<sigma>) |\<^sub>s i"
+unfolding suffix_def comp_def by simp
+
+lemmas suffix_simps[simp] =
+  comp_suffix
+  suffix_eval
+  suffix_plus_com
+  suffix_zero
+
+lemma length_stake[simp]: "length (stake n s) = n"
+by (induct n arbitrary: s) auto
+
+lemma shift_simps[simp]:
+   "(xs @- \<sigma>) 0 = (if xs = [] then \<sigma> 0 else hd xs)"
+   "(xs @- \<sigma>) |\<^sub>s Suc 0 = (if xs = [] then \<sigma> |\<^sub>s Suc 0 else tl xs @- \<sigma>)"
+by (induct xs) auto
+
+lemma stake_nil[simp]:
+  "stake i \<sigma> = [] \<longleftrightarrow> i = 0"
+by (cases i; clarsimp)
+
+lemma stake_shift:
+  "stake i (w @- \<sigma>) = take i w @ stake (i - length w) \<sigma>"
+by (induct i arbitrary: w) (auto simp: neq_Nil_conv)
+
+lemma shift_snth_less[simp]:
+  assumes "i < length xs"
+  shows "(xs @- \<sigma>) i = xs ! i"
+using assms
+proof(induct i arbitrary: xs)
+  case (Suc i xs) then show ?case by (cases xs) simp_all
+qed (simp add: hd_conv_nth nth_tl)
+
+lemma shift_snth_ge[simp]:
+  assumes "i \<ge> length xs"
+  shows "(xs @- \<sigma>) i = \<sigma> (i - length xs)"
+using assms
+proof(induct i arbitrary: xs)
+  case (Suc i xs) then show ?case by (cases xs) simp_all
+qed simp
+
+lemma shift_snth:
+  "(xs @- \<sigma>) i = (if i < length xs then xs ! i else \<sigma> (i - length xs))"
+by simp
+
+lemma suffix_shift:
+  "(xs @- \<sigma>) |\<^sub>s i = drop i xs @- (\<sigma> |\<^sub>s i - length xs)"
+proof(induct i arbitrary: xs)
+  case (Suc i xs) then show ?case by (cases xs) simp_all
+qed simp
+
+lemma stake_nth[simp]:
+  assumes "i < j"
+  shows "stake j s ! i = s i"
+using assms by (induct j arbitrary: s i) (simp_all add: nth_Cons')
+
+lemma stake_suffix_id:
+  "stake i \<sigma> @- (\<sigma> |\<^sub>s i) = \<sigma>"
+by (induct i) (simp_all add: fun_eq_iff shift_snth split: nat.splits)
+
+lemma id_stake_snth_suffix:
+  "\<sigma> = (stake i \<sigma> @ [\<sigma> i]) @- (\<sigma> |\<^sub>s Suc i)"
+using stake_suffix_id
+apply (metis Suc_diff_le append_Nil2 diff_is_0_eq length_stake lessI nat.simps(3) nat_le_linear shift_snth stake_nil stake_shift take_Suc_conv_app_nth)
+done
+
+lemma stake_add[simp]:
+  "stake i \<sigma> @ stake j (\<sigma> |\<^sub>s i) = stake (i + j) \<sigma>"
+apply (induct i arbitrary: \<sigma>)
+ apply simp
+apply auto
+apply (metis One_nat_def plus_1_eq_Suc suffix_plus_com)
+done
+
+lemma stake_append: "stake n (u @- s) = take (min (length u) n) u @ stake (n - length u) s"
+proof (induct n arbitrary: u)
+  case (Suc n) then show ?case
+    apply clarsimp
+    apply (cases u)
+    apply auto
+    done
+qed auto
+
+lemma stake_shift_stake_shift:
+  "stake i \<sigma> @- stake j (\<sigma> |\<^sub>s i) @- \<beta> = stake (i + j) \<sigma> @- \<beta>"
+apply (induct i arbitrary: \<sigma>)
+ apply simp
+apply auto
+apply (metis One_nat_def plus_1_eq_Suc suffix_plus_com)
+done
+
+lemma stake_suffix_drop:
+  "stake i (\<sigma> |\<^sub>s j) = drop j (stake (i + j) \<sigma>)"
+by (metis append_eq_conv_conj length_stake semiring_normalization_rules(24) stake_add)
+
+lemma stake_suffix:
+  assumes "i \<le> j"
+  shows "stake j \<sigma> @- u |\<^sub>s i = \<sigma>(i \<rightarrow> j - i) @- u"
+by (simp add: assms stake_suffix_drop suffix_shift)
+
+
+subsection\<open>Decomposing safety and liveness \label{sec:infinite_sequences-safety-liveness}\<close>
+
+text\<open>
+
+Famously properties on infinite sequences can be decomposed into
+@{emph \<open>safety\<close>} and @{emph \<open>liveness\<close>}
+properties @{cite "AlpernSchneider:1985" and "Schneider:1987"}. See
+@{cite [cite_macro=citet] "Kindler:1994"} for an overview.
+
+\<close>
+
+definition safety :: "'a seq_pred \<Rightarrow> bool" where
+  "safety P \<longleftrightarrow> (\<forall>\<sigma>. \<not>P \<sigma> \<longrightarrow> (\<exists>i. \<forall>\<beta>. \<not>P (stake i \<sigma> @- \<beta>)))"
+
+lemma safety_def2: \<comment> \<open>Contraposition gives the customary prefix-closure definition\<close>
+  "safety P \<longleftrightarrow> (\<forall>\<sigma>. (\<forall>i. \<exists>\<beta>. P (stake i \<sigma> @- \<beta>)) \<longrightarrow> P \<sigma>)"
+unfolding safety_def by blast
+
+definition liveness :: "'a seq_pred \<Rightarrow> bool" where
+  "liveness P \<longleftrightarrow> (\<forall>\<alpha>. \<exists>\<sigma>. P (\<alpha> @- \<sigma>))"
+
+lemmas safetyI = iffD2[OF safety_def, rule_format]
+lemmas safetyI2 = iffD2[OF safety_def2, rule_format]
+lemmas livenessI = iffD2[OF liveness_def, rule_format]
+
+lemma safety_False:
+  shows "safety (\<lambda>\<sigma>. False)"
+by (rule safetyI) simp
+
+lemma safety_True:
+  shows "safety (\<lambda>\<sigma>. True)"
+by (rule safetyI) simp
+
+lemma safety_state_prop:
+  shows "safety (\<lambda>\<sigma>. P (\<sigma> 0))"
+by (rule safetyI) auto
+
+lemma safety_invariant:
+  shows "safety (\<lambda>\<sigma>. \<forall>i. P (\<sigma> i))"
+apply (rule safetyI)
+apply clarsimp
+apply (metis length_stake lessI shift_snth_less stake_nth)
+done
+
+lemma safety_transition_relation:
+  shows "safety (\<lambda>\<sigma>. \<forall>i. (\<sigma> i, \<sigma> (i + 1)) \<in> R)"
+apply (rule safetyI)
+apply clarsimp
+apply (metis (no_types, hide_lams) Suc_eq_plus1 add.left_neutral add_Suc_right add_diff_cancel_left' le_add1 list.sel(1) list.simps(3) shift_simps(1) stake.simps(2) stake_suffix suffix_def)
+done
+
+lemma safety_conj:
+  assumes "safety P"
+  assumes "safety Q"
+  shows "safety (P \<^bold>\<and> Q)"
+using assms unfolding safety_def by blast
+
+lemma safety_always_eventually[simplified]:
+  assumes "safety P"
+  assumes "\<forall>i. \<exists>j\<ge>i. \<exists>\<beta>. P (\<sigma>(0 \<rightarrow> j) @- \<beta>)"
+  shows "P \<sigma>"
+using assms unfolding safety_def2
+apply -
+apply (drule_tac x=\<sigma> in spec)
+apply clarsimp
+apply (drule_tac x=i in spec)
+apply clarsimp
+apply (rule_tac x="(stake j \<sigma> @- \<beta>) |\<^sub>s i" in exI)
+apply (simp add: stake_shift_stake_shift stake_suffix)
+done
+
+lemma safety_disj:
+  assumes "safety P"
+  assumes "safety Q"
+  shows "safety (P \<^bold>\<or> Q)"
+unfolding safety_def2 using assms
+by (metis safety_always_eventually add_diff_cancel_right' diff_le_self le_add_same_cancel2)
+
+text\<open>
+
+The decomposition is given by a form of closure.
+
+\<close>
+
+definition M\<^sub>p :: "'a seq_pred \<Rightarrow> 'a seq_pred" where
+  "M\<^sub>p P = (\<lambda>\<sigma>. \<forall>i. \<exists>\<beta>. P (stake i \<sigma> @- \<beta>))"
+
+definition Safe :: "'a seq_pred \<Rightarrow> 'a seq_pred" where
+  "Safe P = (P \<^bold>\<or> M\<^sub>p P)"
+
+definition Live :: "'a seq_pred \<Rightarrow> 'a seq_pred" where
+  "Live P = (P \<^bold>\<or> \<^bold>\<not>M\<^sub>p P)"
+
+lemma decomp:
+  "P = (Safe P \<^bold>\<and> Live P)"
+unfolding Safe_def Live_def by blast
+
+lemma safe:
+  "safety (Safe P)"
+unfolding Safe_def safety_def M\<^sub>p_def
+apply clarsimp
+apply (simp add: stake_shift)
+apply (rule_tac x=i in exI)
+apply clarsimp
+apply (rule_tac x=i in exI)
+apply clarsimp
+done
+
+lemma live:
+  "liveness (Live P)"
+proof(rule livenessI)
+  fix \<alpha>
+  have "(\<exists>\<beta>. P (\<alpha> @- \<beta>)) \<or> \<not>(\<exists>\<beta>. P (\<alpha> @- \<beta>))" by blast
+  also have "?this \<longleftrightarrow> (\<exists>\<beta>. P (\<alpha> @- \<beta>) \<or> (\<forall>\<gamma>. \<not>P (\<alpha> @- \<gamma>)))" by blast
+  also have "\<dots> \<longleftrightarrow> (\<exists>\<beta>. P (\<alpha> @- \<beta>) \<or> (\<exists>i. i = length \<alpha> \<and> (\<forall>\<gamma>. \<not>P (stake i (\<alpha> @- \<beta>) @- \<gamma>))))" by (simp add: stake_shift)
+  also have "\<dots> \<longrightarrow> (\<exists>\<beta>. P (\<alpha> @- \<beta>) \<or> (\<exists>i. (\<forall>\<gamma>. \<not>P (stake i (\<alpha> @- \<beta>) @- \<gamma>))))" by blast
+  finally have "\<exists>\<beta>. P (\<alpha> @- \<beta>) \<or> (\<exists>i. \<forall>\<gamma>. \<not> P (stake i (\<alpha> @- \<beta>) @- \<gamma>))" .
+  then show "\<exists>\<sigma>. Live P (\<alpha> @- \<sigma>)" unfolding Live_def M\<^sub>p_def by simp
+qed
+
+text\<open>
+
+@{cite "Sistla:1994"} proceeds to give a topological analysis of fairness. An \<^emph>\<open>absolute\<close>
+liveness property is a liveness property whose complement is stable.
+
+\<close>
+
+definition absolute_liveness :: "'a seq_pred \<Rightarrow> bool" where \<comment> \<open> closed under prepending any finite sequence \<close>
+  "absolute_liveness P \<longleftrightarrow> (\<exists>\<sigma>. P \<sigma>) \<and> (\<forall>\<sigma> \<alpha>. P \<sigma> \<longrightarrow> P (\<alpha> @- \<sigma>))"
+
+definition stable :: "'a seq_pred \<Rightarrow> bool" where \<comment> \<open> closed under suffixes \<close>
+  "stable P \<longleftrightarrow> (\<exists>\<sigma>. P \<sigma>) \<and> (\<forall>\<sigma> i. P \<sigma> \<longrightarrow> P (\<sigma> |\<^sub>s i))"
+
+lemma absolute_liveness_liveness:
+  assumes "absolute_liveness P"
+  shows "liveness P"
+using assms unfolding absolute_liveness_def liveness_def by blast
+
+lemma stable_absolute_liveness:
+  assumes "P \<sigma>"
+  assumes "\<not>P \<sigma>'" \<comment>\<open> extra hypothesis \<close>
+  shows "stable P \<longleftrightarrow> absolute_liveness (\<^bold>\<not> P)"
+using assms unfolding stable_def absolute_liveness_def
+apply auto
+ apply (metis cancel_comm_monoid_add_class.diff_cancel drop_eq_Nil order_refl shift.simps(1) suffix_shift suffix_zero)
+apply (metis stake_suffix_id)
+done
+
+(*
+text\<open>
+
+Fairness ala Sistla. Unmotivated.
+
+FIXME safety properties are insensitive to fairness.
+FIXME typically we prove \<open>sys \<longrightarrow> safety\<close>. The result below doesn't appear strong enough.
+FIXME observe fairness is a special liveness property.
+
+\<close>
+*)
+
+definition fairness :: "'a seq_pred \<Rightarrow> bool" where
+  "fairness P \<longleftrightarrow> stable P \<and> absolute_liveness P"
+
+lemma fairness_safety:
+  assumes "safety P"
+  assumes "fairness F"
+  shows "(\<forall>\<sigma>. F \<sigma> \<longrightarrow> P \<sigma>) \<longleftrightarrow> (\<forall>\<sigma>. P \<sigma>)"
+apply rule
+using assms
+apply clarsimp
+unfolding safety_def fairness_def stable_def absolute_liveness_def
+apply clarsimp
+apply blast+
+done
+
+(*<*)
+
+end
+(*>*)
diff --git a/thys/ConcurrentIMP/LTL.thy b/thys/ConcurrentIMP/LTL.thy
new file mode 100644
--- /dev/null
+++ b/thys/ConcurrentIMP/LTL.thy
@@ -0,0 +1,828 @@
+(*<*)
+theory LTL
+imports
+  CIMP_pred
+  Infinite_Sequences
+begin
+
+(*>*)
+section\<open> Linear Temporal Logic \label{sec:ltl}\<close>
+
+text\<open>
+
+To talk about liveness we need to consider infinitary behaviour on
+sequences. Traditionally future-time linear temporal logic (LTL) is used to do
+this @{cite "MannaPnueli:1991" and "OwickiLamport:1982"}.
+
+The following is a straightforward shallow embedding of the
+now-traditional anchored semantics of LTL @{cite "MannaPnueli:1988"}. Some of it is adapted
+from the sophisticated TLA development in the AFP due to @{cite [cite_macro=citet] "TLA-AFP"}.
+
+Unlike @{cite [cite_macro=citet] "Lamport:2002"}, include the
+next operator, which is convenient for stating rules. Sometimes it allows us to
+ignore the system, i.e. to state rules as temporally valid
+(LTL-valid) rather than just temporally program valid (LTL-cimp-), in Jackson's terminology.
+
+\<close>
+
+definition state_prop :: "('a \<Rightarrow> bool) \<Rightarrow> 'a seq_pred" ("\<lceil>_\<rceil>") where
+  "\<lceil>P\<rceil> = (\<lambda>\<sigma>. P (\<sigma> 0))"
+
+definition "next" :: "'a seq_pred \<Rightarrow> 'a seq_pred" ("\<circle>_" [80] 80) where
+  "(\<circle>P) = (\<lambda>\<sigma>. P (\<sigma> |\<^sub>s 1))"
+
+definition always :: "'a seq_pred \<Rightarrow> 'a seq_pred" ("\<box>_" [80] 80) where
+  "(\<box>P) = (\<lambda>\<sigma>. \<forall>i. P (\<sigma> |\<^sub>s i))"
+
+definition until :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" (infixr "\<U>" 30) where (* FIXME priority, binds tighter than \<^bold>\<longrightarrow> *)
+  "(P \<U> Q) = (\<lambda>\<sigma>. \<exists>i. Q (\<sigma> |\<^sub>s i) \<and> (\<forall>k<i. P (\<sigma> |\<^sub>s k)))"
+
+definition eventually :: "'a seq_pred \<Rightarrow> 'a seq_pred" ("\<diamond>_" [80] 80) where (* FIXME priority, consider making an abbreviation *)
+  "(\<diamond>P) = (\<langle>True\<rangle> \<U> P)"
+
+definition release :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" (infixr "\<R>" 30) where (* FIXME priority, dual of Until *)
+  "(P \<R> Q) = (\<^bold>\<not>(\<^bold>\<not>P \<U> \<^bold>\<not>Q))"
+
+definition unless :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" (infixr "\<W>" 30) where (* FIXME priority, aka weak until *)
+  "(P \<W> Q) = ((P \<U> Q) \<^bold>\<or> \<box>P)"
+
+abbreviation (input)
+  pred_always_imp_syn :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" (infixr "\<^bold>\<hookrightarrow>" 25) where
+  "P \<^bold>\<hookrightarrow> Q \<equiv> \<box>(P \<^bold>\<longrightarrow> Q)"
+
+lemmas defs =
+  state_prop_def
+  always_def
+  eventually_def
+  next_def
+  release_def
+  unless_def
+  until_def
+
+lemma suffix_state_prop[simp]:
+  shows "\<lceil>P\<rceil> (\<sigma> |\<^sub>s i) = P (\<sigma> i)"
+unfolding defs by simp
+
+lemma alwaysI[intro]:
+  assumes "\<And>i. P (\<sigma> |\<^sub>s i)"
+  shows "(\<box>P) \<sigma>"
+unfolding defs using assms by blast
+
+lemma alwaysD:
+  assumes "(\<box>P) \<sigma>"
+  shows "P (\<sigma> |\<^sub>s i)"
+using assms unfolding defs by blast
+
+lemma alwaysE: "\<lbrakk>(\<box>P) \<sigma>; P (\<sigma> |\<^sub>s i) \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
+unfolding defs by blast
+
+lemma always_induct:
+  assumes "P \<sigma>"
+  assumes "(\<box>(P \<^bold>\<longrightarrow> \<circle>P)) \<sigma>"
+  shows "(\<box>P) \<sigma>"
+proof(rule alwaysI)
+  fix i from assms show "P (\<sigma> |\<^sub>s i)"
+    unfolding defs by (induct i) simp_all
+qed
+
+lemma seq_comp:
+  fixes \<sigma> :: "'a seq"
+  fixes P :: "'b seq_pred"
+  fixes f :: "'a \<Rightarrow> 'b"
+  shows
+    "(\<box>P) (f \<circ> \<sigma>) \<longleftrightarrow> (\<box>(\<lambda>\<sigma>. P (f \<circ> \<sigma>))) \<sigma>"
+    "(\<diamond>P) (f \<circ> \<sigma>) \<longleftrightarrow> (\<diamond>(\<lambda>\<sigma>. P (f \<circ> \<sigma>))) \<sigma>"
+    "(P \<U> Q) (f \<circ> \<sigma>) \<longleftrightarrow> ((\<lambda>\<sigma>. P (f \<circ> \<sigma>)) \<U> (\<lambda>\<sigma>. Q (f \<circ> \<sigma>))) \<sigma>"
+    "(P \<W> Q) (f \<circ> \<sigma>) \<longleftrightarrow> ((\<lambda>\<sigma>. P (f \<circ> \<sigma>)) \<W> (\<lambda>\<sigma>. Q (f \<circ> \<sigma>))) \<sigma>"
+unfolding defs by simp_all
+
+lemma nextI[intro]:
+  assumes "P (\<sigma> |\<^sub>s Suc 0)"
+  shows "(\<circle>P) \<sigma>"
+using assms unfolding defs by simp
+
+lemma untilI[intro]:
+  assumes "Q (\<sigma> |\<^sub>s i)"
+  assumes "\<forall>k<i. P (\<sigma> |\<^sub>s k)"
+  shows "(P \<U> Q) \<sigma>"
+unfolding defs using assms by blast
+
+lemma untilE:
+  assumes "(P \<U> Q) \<sigma>"
+  obtains i where "Q (\<sigma> |\<^sub>s i)" and "\<forall>k<i. P (\<sigma> |\<^sub>s k)"
+using assms unfolding until_def by blast
+
+lemma eventuallyI[intro]:
+  assumes "P (\<sigma> |\<^sub>s i)"
+  shows "(\<diamond>P) \<sigma>"
+unfolding eventually_def using assms by blast
+
+lemma eventuallyE[elim]:
+  assumes "(\<diamond>P) \<sigma>"
+  obtains i where "P (\<sigma> |\<^sub>s i)"
+using assms unfolding defs by (blast elim: untilE)
+
+lemma unless_alwaysI:
+  assumes "(\<box> P) \<sigma>"
+  shows "(P \<W> Q) \<sigma>"
+using assms unfolding defs by blast
+
+lemma unless_untilI:
+  assumes "Q (\<sigma> |\<^sub>s j)"
+  assumes "\<And>i. i < j \<Longrightarrow> P (\<sigma> |\<^sub>s i)"
+  shows "(P \<W> Q) \<sigma>"
+unfolding defs using assms by blast
+
+lemma always_imp_refl[iff]:
+  shows "(P \<^bold>\<hookrightarrow> P) \<sigma>"
+unfolding defs by blast
+
+lemma always_imp_trans:
+  assumes "(P \<^bold>\<hookrightarrow> Q) \<sigma>"
+  assumes "(Q \<^bold>\<hookrightarrow> R) \<sigma>"
+  shows "(P \<^bold>\<hookrightarrow> R) \<sigma>"
+using assms unfolding defs by blast
+
+lemma always_imp_mp:
+  assumes "(P \<^bold>\<hookrightarrow> Q) \<sigma>"
+  assumes "P \<sigma>"
+  shows "Q \<sigma>"
+using assms unfolding defs by (metis suffix_zero)
+
+lemma always_imp_mp_suffix:
+  assumes "(P \<^bold>\<hookrightarrow> Q) \<sigma>"
+  assumes "P (\<sigma> |\<^sub>s i)"
+  shows "Q (\<sigma> |\<^sub>s i)"
+using assms unfolding defs by metis
+
+text\<open>
+
+Some basic facts and equivalences, mostly sanity.
+
+\<close>
+
+lemma necessitation:
+  "(\<And>s. P s) \<Longrightarrow> (\<box>P) \<sigma>"
+  "(\<And>s. P s) \<Longrightarrow> (\<diamond>P) \<sigma>"
+  "(\<And>s. P s) \<Longrightarrow> (P \<W> Q) \<sigma>"
+  "(\<And>s. Q s) \<Longrightarrow> (P \<U> Q) \<sigma>"
+unfolding defs by auto
+
+lemma cong:
+  "(\<And>s. P s = P' s) \<Longrightarrow> \<lceil>P\<rceil> = \<lceil>P'\<rceil>"
+  "(\<And>\<sigma>. P \<sigma> = P' \<sigma>) \<Longrightarrow> (\<box>P) = (\<box>P')"
+  "(\<And>\<sigma>. P \<sigma> = P' \<sigma>) \<Longrightarrow> (\<diamond>P) = (\<diamond>P')"
+  "(\<And>\<sigma>. P \<sigma> = P' \<sigma>) \<Longrightarrow> (\<circle>P) = (\<circle>P')"
+  "\<lbrakk>\<And>\<sigma>. P \<sigma> = P' \<sigma>; \<And>\<sigma>. Q \<sigma> = Q' \<sigma>\<rbrakk> \<Longrightarrow> (P \<U> Q) = (P' \<U> Q')"
+  "\<lbrakk>\<And>\<sigma>. P \<sigma> = P' \<sigma>; \<And>\<sigma>. Q \<sigma> = Q' \<sigma>\<rbrakk> \<Longrightarrow> (P \<W> Q) = (P' \<W> Q')"
+unfolding defs by auto
+
+lemma norm[simp]:
+  "\<lceil>\<langle>False\<rangle>\<rceil> = \<langle>False\<rangle>"
+  "\<lceil>\<langle>True\<rangle>\<rceil> = \<langle>True\<rangle>"
+  "(\<^bold>\<not>\<lceil>p\<rceil>) = \<lceil>\<^bold>\<not>p\<rceil>"
+  "(\<lceil>p\<rceil> \<^bold>\<and> \<lceil>q\<rceil>) = \<lceil>p \<^bold>\<and> q\<rceil>"
+  "(\<lceil>p\<rceil> \<^bold>\<or> \<lceil>q\<rceil>) = \<lceil>p \<^bold>\<or> q\<rceil>"
+  "(\<lceil>p\<rceil> \<^bold>\<longrightarrow> \<lceil>q\<rceil>) = \<lceil>p \<^bold>\<longrightarrow> q\<rceil>"
+  "(\<lceil>p\<rceil> \<sigma> \<and> \<lceil>q\<rceil> \<sigma>) = \<lceil>p \<^bold>\<and> q\<rceil> \<sigma>"
+  "(\<lceil>p\<rceil> \<sigma> \<or> \<lceil>q\<rceil> \<sigma>) = \<lceil>p \<^bold>\<or> q\<rceil> \<sigma>"
+  "(\<lceil>p\<rceil> \<sigma> \<longrightarrow> \<lceil>q\<rceil> \<sigma>) = \<lceil>p \<^bold>\<longrightarrow> q\<rceil> \<sigma>"
+
+  "(\<circle>\<langle>False\<rangle>) = \<langle>False\<rangle>"
+  "(\<circle>\<langle>True\<rangle>) = \<langle>True\<rangle>"
+
+  "(\<box>\<langle>False\<rangle>) = \<langle>False\<rangle>"
+  "(\<box>\<langle>True\<rangle>) = \<langle>True\<rangle>"
+  "(\<^bold>\<not>\<box> P) \<sigma> = (\<diamond> (\<^bold>\<not> P)) \<sigma>"
+  "(\<box>\<box> P) = (\<box> P)"
+
+  "(\<diamond>\<langle>False\<rangle>) = \<langle>False\<rangle>"
+  "(\<diamond>\<langle>True\<rangle>) = \<langle>True\<rangle>"
+  "(\<^bold>\<not>\<diamond> P) = (\<box> (\<^bold>\<not> P))"
+  "(\<diamond>\<diamond> P) = (\<diamond> P)"
+
+  "(P \<W> \<langle>False\<rangle>) = (\<box> P)"
+
+  "(\<^bold>\<not>(P \<U> Q)) \<sigma> = (\<^bold>\<not>P \<R> \<^bold>\<not>Q) \<sigma>"
+  "(\<langle>False\<rangle> \<U> P) = P"
+  "(P \<U> \<langle>False\<rangle>) = \<langle>False\<rangle>"
+  "(P \<U> \<langle>True\<rangle>) = \<langle>True\<rangle>"
+  "(\<langle>True\<rangle> \<U> P) = (\<diamond> P)"
+  "(P \<U> (P \<U> Q)) = (P \<U> Q)"
+
+  "(\<^bold>\<not>(P \<R> Q)) \<sigma> = (\<^bold>\<not>P \<U> \<^bold>\<not>Q) \<sigma>"
+  "(\<langle>False\<rangle> \<R> P) = (\<box>P)"
+  "(P \<R> \<langle>False\<rangle>) = \<langle>False\<rangle>"
+  "(\<langle>True\<rangle> \<R> P) = P"
+  "(P \<R> \<langle>True\<rangle>) = \<langle>True\<rangle>"
+(*
+  "(P \<U> (P \<U> Q)) \<sigma> = (P \<U> Q) \<sigma>" FIXME for Release
+*)
+unfolding defs
+apply (auto simp: fun_eq_iff)
+apply (metis suffix_plus suffix_zero)
+apply (metis suffix_plus suffix_zero)
+  apply fastforce
+  apply force
+apply (metis add.commute add_diff_inverse_nat less_diff_conv2 not_le)
+apply (metis add.right_neutral not_less0)
+  apply force
+  apply fastforce
+done
+
+lemma always_conj_distrib: "(\<box>(P \<^bold>\<and> Q)) = (\<box>P \<^bold>\<and> \<box>Q)"
+unfolding defs by auto
+
+lemma eventually_disj_distrib: "(\<diamond>(P \<^bold>\<or> Q)) = (\<diamond>P \<^bold>\<or> \<diamond>Q)"
+unfolding defs by auto
+
+lemma always_eventually[elim!]:
+  assumes "(\<box>P) \<sigma>"
+  shows "(\<diamond>P) \<sigma>"
+using assms unfolding defs by auto
+
+lemma eventually_imp_conv_disj: "(\<diamond>(P \<^bold>\<longrightarrow> Q)) = (\<diamond>(\<^bold>\<not>P) \<^bold>\<or> \<diamond>Q)"
+unfolding defs by auto
+
+lemma eventually_imp_distrib:
+  "(\<diamond>(P \<^bold>\<longrightarrow> Q)) = (\<box>P \<^bold>\<longrightarrow> \<diamond>Q)"
+unfolding defs by auto
+
+lemma unfold:
+  "(\<box> P) \<sigma> = (P \<^bold>\<and> \<circle>\<box>P) \<sigma>"
+  "(\<diamond> P) \<sigma> = (P \<^bold>\<or> \<circle>\<diamond>P) \<sigma>"
+  "(P \<W> Q) \<sigma> = (Q \<^bold>\<or> (P \<^bold>\<and> \<circle>(P \<W> Q))) \<sigma>"
+  "(P \<U> Q) \<sigma> = (Q \<^bold>\<or> (P \<^bold>\<and> \<circle>(P \<U> Q))) \<sigma>"
+  "(P \<R> Q) \<sigma> = (Q \<^bold>\<and> (P \<^bold>\<or> \<circle>(P \<R> Q))) \<sigma>"
+unfolding defs
+apply -
+apply (metis (full_types) add.commute add_diff_inverse_nat less_one suffix_plus suffix_zero)
+apply (metis (full_types) One_nat_def add.right_neutral add_Suc_right lessI less_Suc_eq_0_disj suffix_plus suffix_zero)
+
+apply auto
+  apply fastforce
+  apply (metis gr0_conv_Suc nat_neq_iff not_less_eq suffix_zero)
+  apply (metis suffix_zero)
+  apply force
+  using less_Suc_eq_0_disj apply fastforce
+  apply (metis gr0_conv_Suc nat_neq_iff not_less0 suffix_zero)
+
+  apply fastforce
+  apply (case_tac i; auto)
+  apply force
+  using less_Suc_eq_0_disj apply force
+
+  apply force
+  using less_Suc_eq_0_disj apply fastforce
+  apply fastforce
+  apply (case_tac i; auto)
+done
+
+lemma mono:
+  "\<lbrakk>(\<box>P) \<sigma>; \<And>\<sigma>. P \<sigma> \<Longrightarrow>  P' \<sigma>\<rbrakk> \<Longrightarrow> (\<box>P') \<sigma>"
+  "\<lbrakk>(\<diamond>P) \<sigma>; \<And>\<sigma>. P \<sigma> \<Longrightarrow>  P' \<sigma>\<rbrakk> \<Longrightarrow> (\<diamond>P') \<sigma>"
+  "\<lbrakk>(P \<U> Q) \<sigma>; \<And>\<sigma>. P \<sigma> \<Longrightarrow> P' \<sigma>; \<And>\<sigma>. Q \<sigma> \<Longrightarrow> Q' \<sigma>\<rbrakk> \<Longrightarrow> (P' \<U> Q') \<sigma>"
+  "\<lbrakk>(P \<W> Q) \<sigma>; \<And>\<sigma>. P \<sigma> \<Longrightarrow> P' \<sigma>; \<And>\<sigma>. Q \<sigma> \<Longrightarrow> Q' \<sigma>\<rbrakk> \<Longrightarrow> (P' \<W> Q') \<sigma>"
+unfolding defs by force+
+
+lemma always_imp_mono:
+  "\<lbrakk>(\<box>P) \<sigma>; (P \<^bold>\<hookrightarrow> P') \<sigma>\<rbrakk> \<Longrightarrow> (\<box>P') \<sigma>"
+  "\<lbrakk>(\<diamond>P) \<sigma>; (P \<^bold>\<hookrightarrow> P') \<sigma>\<rbrakk> \<Longrightarrow> (\<diamond>P') \<sigma>"
+  "\<lbrakk>(P \<U> Q) \<sigma>; (P \<^bold>\<hookrightarrow> P') \<sigma>; (Q \<^bold>\<hookrightarrow> Q') \<sigma>\<rbrakk> \<Longrightarrow> (P' \<U> Q') \<sigma>"
+  "\<lbrakk>(P \<W> Q) \<sigma>; (P \<^bold>\<hookrightarrow> P') \<sigma>; (Q \<^bold>\<hookrightarrow> Q') \<sigma>\<rbrakk> \<Longrightarrow> (P' \<W> Q') \<sigma>"
+unfolding defs by force+
+
+lemma next_conj_distrib:
+  "(\<circle>(P \<^bold>\<and> Q)) = (\<circle>P \<^bold>\<and> \<circle>Q)"
+unfolding defs by auto
+
+lemma next_disj_distrib:
+  "(\<circle>(P \<^bold>\<or> Q)) = (\<circle>P \<^bold>\<or> \<circle>Q)"
+unfolding defs by auto
+
+lemma until_next_distrib:
+  "(\<circle>(P \<U> Q)) = (\<circle>P \<U> \<circle>Q)"
+unfolding defs by (auto simp: fun_eq_iff)
+
+lemma until_imp_eventually:
+  "((P \<U> Q) \<^bold>\<longrightarrow> \<diamond>Q) \<sigma>"
+unfolding defs by auto
+
+lemma until_until_disj:
+  assumes "(P \<U> Q \<U> R) \<sigma>"
+  shows "((P \<^bold>\<or> Q) \<U> R) \<sigma>"
+using assms unfolding defs
+apply clarsimp
+apply (metis (full_types) add_diff_inverse_nat nat_add_left_cancel_less)
+done
+
+lemma unless_unless_disj:
+  assumes "(P \<W> Q \<W> R) \<sigma>"
+  shows "((P \<^bold>\<or> Q) \<W> R) \<sigma>"
+using assms unfolding defs
+apply auto
+ apply (metis add.commute add_diff_inverse_nat leI less_diff_conv2)
+apply (metis add_diff_inverse_nat)
+done
+
+lemma until_conj_distrib:
+  "((P \<^bold>\<and> Q) \<U> R) = ((P \<U> R) \<^bold>\<and> (Q \<U> R))"
+unfolding defs
+apply (auto simp: fun_eq_iff)
+apply (metis dual_order.strict_trans nat_neq_iff)
+done
+
+lemma until_disj_distrib:
+  "(P \<U> (Q \<^bold>\<or> R)) = ((P \<U> Q) \<^bold>\<or> (P \<U> R))"
+unfolding defs by (auto simp: fun_eq_iff)
+
+lemma eventually_until:
+  "(\<diamond>P) = (\<^bold>\<not>P \<U> P)"
+unfolding defs
+apply (auto simp: fun_eq_iff)
+apply (case_tac "P (x |\<^sub>s 0)")
+ apply blast
+apply (drule (1) ex_least_nat_less)
+apply (metis le_simps(2))
+done
+
+lemma eventually_until_eventually:
+  "(\<diamond>(P \<U> Q)) = (\<diamond>Q)"
+unfolding defs by force
+
+lemma eventually_unless_until:
+  "((P \<W> Q) \<^bold>\<and> \<diamond>Q) = (P \<U> Q)"
+unfolding defs by force
+
+lemma eventually_always_imp_always_eventually:
+  assumes "(\<diamond>\<box>P) \<sigma>"
+  shows "(\<box>\<diamond>P) \<sigma>"
+using assms unfolding defs by (metis suffix_commute)
+
+lemma eventually_always_next_stable:
+  assumes "(\<diamond>P) \<sigma>"
+  assumes "(P \<^bold>\<hookrightarrow> \<circle>P) \<sigma>"
+  shows "(\<diamond>\<box>P) \<sigma>"
+using assms by (metis (no_types) eventuallyI alwaysD always_induct eventuallyE norm(15))
+
+lemma next_stable_imp_eventually_always:
+  assumes "(P \<^bold>\<hookrightarrow> \<circle>P) \<sigma>"
+  shows "(\<diamond>P \<^bold>\<longrightarrow> \<diamond>\<box>P) \<sigma>"
+using assms eventually_always_next_stable by blast
+
+lemma always_eventually_always:
+  "\<diamond>\<box>\<diamond>P = \<box>\<diamond>P"
+unfolding defs by (clarsimp simp: fun_eq_iff) (metis add.left_commute semiring_normalization_rules(25))
+
+(* FIXME define "stable", develop more rules for it *)
+lemma stable_unless:
+  assumes "(P \<^bold>\<hookrightarrow> \<circle>(P \<^bold>\<or> Q)) \<sigma>"
+  shows "(P \<^bold>\<hookrightarrow> (P \<W> Q)) \<sigma>"
+using assms unfolding defs
+apply -
+apply (rule ccontr)
+apply clarsimp
+apply (drule (1) ex_least_nat_less[where P="\<lambda>j. \<not>P (\<sigma> |\<^sub>s i + j)" for i, simplified])
+apply clarsimp
+apply (metis add_Suc_right le_less less_Suc_eq)
+done
+
+lemma unless_induct: \<comment>\<open> Rule \texttt{WAIT} from @{cite [cite_macro=citet] \<open>Fig~3.3\<close> "MannaPnueli:1995"}\<close>
+  assumes I: "(I \<^bold>\<hookrightarrow> \<circle>(I \<^bold>\<or> R)) \<sigma>"
+  assumes P: "(P \<^bold>\<hookrightarrow> I \<^bold>\<or> R) \<sigma>"
+  assumes Q: "(I \<^bold>\<hookrightarrow> Q) \<sigma>"
+  shows "(P \<^bold>\<hookrightarrow> Q \<W> R) \<sigma>"
+apply (intro alwaysI impI)
+apply (erule impE[OF alwaysD[OF P]])
+apply (erule disjE)
+ apply (rule always_imp_mono(4)[where P=I and Q=R])
+   apply (erule mp[OF alwaysD[OF stable_unless[OF I]]])
+  apply (simp add: Q alwaysD)
+ apply blast
+apply (simp add: unfold)
+done
+
+
+subsection\<open> Leads-to and leads-to-via \label{sec:leads-to} \<close>
+
+text\<open>
+
+Most of our assertions will be of the form @{term "A \<^bold>\<longrightarrow> \<diamond>C"} (pronounced ``\<open>A\<close> leads to \<open>C\<close>'')
+or @{term "A \<^bold>\<longrightarrow> B \<U> C"} (``\<open>A\<close> leads to \<open>C\<close> via \<open>B\<close>'').
+
+Most of these rules are due to @{cite [cite_macro=citet]
+"Jackson:1998"} who used leads-to-via in a sequential setting. Others
+are due to @{cite [cite_macro=citet] "MannaPnueli:1991"}.
+
+The leads-to-via connective is similar to the ``ensures'' modality of @{cite [cite_macro=citet] \<open>\S3.4.4\<close> "ChandyMisra:1989"}.
+
+\<close>
+
+abbreviation (input)
+  leads_to :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" (infixr "\<^bold>\<leadsto>" 25) where (* FIXME priority *)
+  "P \<^bold>\<leadsto> Q \<equiv> P \<^bold>\<hookrightarrow> \<diamond>Q"
+
+lemma leads_to_refl:
+  shows "(P \<^bold>\<leadsto> P) \<sigma>"
+by (metis (no_types, lifting) necessitation(1) unfold(2))
+
+lemma leads_to_trans:
+  assumes "(P \<^bold>\<leadsto> Q) \<sigma>"
+  assumes "(Q \<^bold>\<leadsto> R) \<sigma>"
+  shows "(P \<^bold>\<leadsto> R) \<sigma>"
+using assms unfolding defs by clarsimp (metis semiring_normalization_rules(25))
+
+lemma leads_to_eventuallyE:
+  assumes "(P \<^bold>\<leadsto> Q) \<sigma>"
+  assumes "(\<diamond>P) \<sigma>"
+  shows "(\<diamond>Q) \<sigma>"
+using assms unfolding defs by auto
+
+lemma leads_to_mono:
+  assumes "(P' \<^bold>\<hookrightarrow> P) \<sigma>"
+  assumes "(Q \<^bold>\<hookrightarrow> Q') \<sigma>"
+  assumes "(P \<^bold>\<leadsto> Q) \<sigma>"
+  shows "(P' \<^bold>\<leadsto> Q') \<sigma>"
+using assms unfolding defs by clarsimp blast
+
+lemma leads_to_eventually:
+  shows "(P \<^bold>\<leadsto> Q \<^bold>\<longrightarrow> \<diamond>P \<^bold>\<longrightarrow> \<diamond>Q) \<sigma>"
+by (metis (no_types, lifting) alwaysI unfold(2))
+
+lemma leads_to_disj:
+  assumes "(P \<^bold>\<leadsto> R) \<sigma>"
+  assumes "(Q \<^bold>\<leadsto> R) \<sigma>"
+  shows "((P \<^bold>\<or> Q) \<^bold>\<leadsto> R) \<sigma>"
+using assms unfolding defs by simp
+
+lemma leads_to_leads_to_viaE:
+  shows "((P \<^bold>\<hookrightarrow> P \<U> Q) \<^bold>\<longrightarrow> P \<^bold>\<leadsto> Q) \<sigma>"
+unfolding defs by clarsimp blast
+
+lemma leads_to_via_concl_weaken:
+  assumes "(R \<^bold>\<hookrightarrow> R') \<sigma>"
+  assumes "(P \<^bold>\<hookrightarrow> Q \<U> R) \<sigma>"
+  shows "(P \<^bold>\<hookrightarrow> Q \<U> R') \<sigma>"
+using assms unfolding LTL.defs by force
+
+lemma leads_to_via_trans:
+  assumes "(A \<^bold>\<hookrightarrow> B \<U> C) \<sigma>"
+  assumes "(C \<^bold>\<hookrightarrow> D \<U> E) \<sigma>"
+  shows "(A \<^bold>\<hookrightarrow> (B \<^bold>\<or> D) \<U> E) \<sigma>"
+proof(rule alwaysI, rule impI)
+  fix i assume "A (\<sigma> |\<^sub>s i)" with assms show "((B \<^bold>\<or> D) \<U> E) (\<sigma> |\<^sub>s i)"
+    apply -
+    apply (erule alwaysE[where i=i])
+    apply clarsimp
+    apply (erule untilE)
+    apply clarsimp (* suffix *)
+    apply (drule (1) always_imp_mp_suffix)
+    apply (erule untilE)
+    apply clarsimp (* suffix *)
+    apply (rule_tac i="ia + iaa" in untilI; simp add: ac_simps)
+    apply (metis (full_types) add.assoc leI le_Suc_ex nat_add_left_cancel_less) (* arithmetic *)
+    done
+qed
+
+lemma leads_to_via_disj: \<comment> \<open> useful for case distinctions \<close>
+  assumes "(P \<^bold>\<hookrightarrow> Q \<U> R) \<sigma>"
+  assumes "(P' \<^bold>\<hookrightarrow> Q' \<U> R) \<sigma>"
+  shows "(P \<^bold>\<or> P' \<^bold>\<hookrightarrow> (Q \<^bold>\<or> Q') \<U> R) \<sigma>"
+using assms unfolding defs by (auto 10 0)
+
+lemma leads_to_via_disj': \<comment> \<open> more like a chaining rule \<close>
+  assumes "(A \<^bold>\<hookrightarrow> B \<U> C) \<sigma>"
+  assumes "(C \<^bold>\<hookrightarrow> D \<U> E) \<sigma>"
+  shows "(A \<^bold>\<or> C \<^bold>\<hookrightarrow> (B \<^bold>\<or> D) \<U> E) \<sigma>"
+proof(rule alwaysI, rule impI, erule disjE)
+  fix i assume "A (\<sigma> |\<^sub>s i)" with assms show "((B \<^bold>\<or> D) \<U> E) (\<sigma> |\<^sub>s i)"
+    apply -
+    apply (erule alwaysE[where i=i])
+    apply clarsimp
+    apply (erule untilE)
+    apply clarsimp (* suffix *)
+    apply (drule (1) always_imp_mp_suffix)
+    apply (erule untilE)
+    apply clarsimp (* suffix *)
+    apply (rule_tac i="ia + iaa" in untilI; simp add: ac_simps)
+    apply (metis (full_types) add.assoc leI le_Suc_ex nat_add_left_cancel_less) (* arithmetic *)
+    done
+next
+  fix i assume "C (\<sigma> |\<^sub>s i)" with assms(2) show "((B \<^bold>\<or> D) \<U> E) (\<sigma> |\<^sub>s i)"
+    apply -
+    apply (erule alwaysE[where i=i])
+    apply (simp add: mono)
+    done
+qed
+
+lemma leads_to_via_stable_augmentation:
+  assumes stable: "(P \<^bold>\<and> Q \<^bold>\<hookrightarrow> \<circle>Q) \<sigma>"
+  assumes U: "(A \<^bold>\<hookrightarrow> P \<U> C) \<sigma>"
+  shows "((A \<^bold>\<and> Q) \<^bold>\<hookrightarrow> P \<U> (C \<^bold>\<and> Q)) \<sigma>"
+proof(intro alwaysI impI, elim conjE)
+  fix i assume AP: "A (\<sigma> |\<^sub>s i)" "Q (\<sigma> |\<^sub>s i)"
+  have "Q (\<sigma> |\<^sub>s (j + i))" if "Q (\<sigma> |\<^sub>s i)" and "\<forall>k<j. P (\<sigma> |\<^sub>s (k + i))" for j
+    using that stable by (induct j; force simp: defs)
+  with U AP show "(P \<U> (\<lambda>\<sigma>. C \<sigma> \<and> Q \<sigma>)) (\<sigma> |\<^sub>s i)"
+    unfolding defs by clarsimp (metis (full_types) add.commute)
+qed
+
+lemma leads_to_via_wf:
+  assumes "wf R"
+  assumes indhyp: "\<And>t. (A \<^bold>\<and> \<lceil>\<delta> \<^bold>= \<langle>t\<rangle>\<rceil> \<^bold>\<hookrightarrow> B \<U> (A \<^bold>\<and> \<lceil>\<delta> \<^bold>\<otimes> \<langle>t\<rangle> \<^bold>\<in> \<langle>R\<rangle>\<rceil> \<^bold>\<or> C)) \<sigma>"
+  shows "(A \<^bold>\<hookrightarrow> B \<U> C) \<sigma>"
+proof(intro alwaysI impI)
+  fix i assume "A (\<sigma> |\<^sub>s i)" with \<open>wf R\<close> show "(B \<U> C) (\<sigma> |\<^sub>s i)"
+  proof(induct "\<delta> (\<sigma> i)" arbitrary: i)
+    case (less i) with indhyp[where t="\<delta> (\<sigma> i)"] show ?case
+      apply -
+      apply (drule alwaysD[where i=i])
+      apply clarsimp
+      apply (erule untilE)
+      apply (rename_tac j)
+       apply (erule disjE; clarsimp)
+       apply (drule_tac x="i + j" in meta_spec; clarsimp)
+       apply (erule untilE; clarsimp)
+       apply (rename_tac j k)
+       apply (rule_tac i="j + k" in untilI)
+        apply (simp add: add.assoc)
+       apply clarsimp
+       apply (metis add.assoc add.commute add_diff_inverse_nat less_diff_conv2 not_le)
+      apply auto
+      done
+  qed
+qed
+
+text\<open>
+
+The well-founded response rule due to @{cite [cite_macro=citet] \<open>Fig~1.23: \texttt{WELL} (well-founded response)\<close>"MannaPnueli:2010"},
+generalised to an arbitrary set of assertions and sequence predicates.
+\<^item> \<open>W1\<close> generalised to be contingent.
+\<^item> \<open>W2\<close> is a well-founded set of assertions that by \<open>W1\<close> includes \<open>P\<close>
+
+\<close>
+
+(* FIXME: Does \<open>Is\<close> need to be consistent? *)
+lemma leads_to_wf:
+  fixes Is :: "('a seq_pred \<times> ('a \<Rightarrow> 'b)) set"
+  assumes "wf (R :: 'b rel)"
+  assumes W1: "(\<box>(\<^bold>\<exists>\<phi>. \<lceil>\<langle>\<phi>\<in>fst ` Is\<rangle>\<rceil> \<^bold>\<and> (P \<^bold>\<longrightarrow> \<phi>))) \<sigma>"
+  assumes W2: "\<forall>(\<phi>, \<delta>)\<in>Is. \<exists>(\<phi>', \<delta>')\<in>insert (Q, \<delta>0) Is. \<forall>t. (\<phi> \<^bold>\<and> \<lceil>\<delta> \<^bold>= \<langle>t\<rangle>\<rceil> \<^bold>\<leadsto> \<phi>' \<^bold>\<and> \<lceil>\<delta>' \<^bold>\<otimes> \<langle>t\<rangle> \<^bold>\<in> \<langle>R\<rangle>\<rceil>) \<sigma>"
+  shows "(P \<^bold>\<leadsto> Q) \<sigma>"
+proof -
+  have "(\<phi> \<^bold>\<and> \<lceil>\<delta> \<^bold>= \<langle>t\<rangle>\<rceil> \<^bold>\<leadsto> Q) \<sigma>" if "(\<phi>, \<delta>) \<in> Is" for \<phi> \<delta> t
+    using \<open>wf R\<close> that W2
+    apply (induct t arbitrary: \<phi> \<delta>)
+    unfolding LTL.defs split_def
+    apply clarsimp
+    apply (metis (no_types, hide_lams) ab_semigroup_add_class.add_ac(1) fst_eqD snd_conv surjective_pairing)
+    done
+  with W1 show ?thesis
+    apply -
+    apply (rule alwaysI)
+    apply clarsimp
+    apply (erule_tac i=i in alwaysE)
+    apply clarsimp
+    using alwaysD suffix_state_prop apply blast
+    done
+qed
+
+
+subsection\<open>Fairness\<close>
+
+text\<open>
+
+A few renderings of weak fairness. @{cite [cite_macro=citet] "vanGlabbeekHofner:2019"} call this
+"response to insistence" as a generalisation of weak fairness.
+
+\<close>
+
+definition weakly_fair :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" where
+  "weakly_fair enabled taken = (\<box>enabled \<^bold>\<hookrightarrow> \<diamond>taken)"
+
+lemma weakly_fair_def2:
+  shows "weakly_fair enabled taken = \<box>(\<^bold>\<not>\<box>(enabled \<^bold>\<and> \<^bold>\<not>taken))"
+unfolding weakly_fair_def by (metis (full_types) always_conj_distrib norm(18))
+
+lemma weakly_fair_def3:
+  shows "weakly_fair enabled taken = (\<diamond>\<box>enabled \<^bold>\<longrightarrow> \<box>\<diamond>taken)"
+unfolding weakly_fair_def2
+apply (clarsimp simp: fun_eq_iff)
+
+unfolding defs (* True, but can we get there deductively? *)
+apply auto
+apply (metis (full_types) add.left_commute semiring_normalization_rules(25))
+done
+
+lemma weakly_fair_def4:
+  shows "weakly_fair enabled taken = \<box>\<diamond>(enabled \<^bold>\<longrightarrow> taken)"
+using weakly_fair_def2 by force
+
+lemma mp_weakly_fair:
+  assumes "weakly_fair enabled taken \<sigma>"
+  assumes "(\<box>enabled) \<sigma>"
+  shows "(\<diamond>taken) \<sigma>"
+using assms unfolding weakly_fair_def using always_imp_mp by blast
+
+lemma always_weakly_fair:
+  shows "\<box>(weakly_fair enabled taken) = weakly_fair enabled taken"
+unfolding weakly_fair_def by simp
+
+lemma eventually_weakly_fair:
+  shows "\<diamond>(weakly_fair enabled taken) = weakly_fair enabled taken"
+unfolding weakly_fair_def2 by (simp add: always_eventually_always)
+
+lemma weakly_fair_weaken:
+  assumes "(enabled' \<^bold>\<hookrightarrow> enabled) \<sigma>"
+  assumes "(taken \<^bold>\<hookrightarrow> taken') \<sigma>"
+  shows "(weakly_fair enabled taken \<^bold>\<hookrightarrow>  weakly_fair enabled' taken') \<sigma>"
+using assms unfolding weakly_fair_def defs by simp blast
+
+lemma weakly_fair_unless_until:
+  shows "(weakly_fair enabled taken \<^bold>\<and> (enabled \<^bold>\<hookrightarrow> enabled \<W> taken)) = (enabled \<^bold>\<hookrightarrow> enabled \<U> taken)"
+unfolding defs weakly_fair_def
+apply (auto simp: fun_eq_iff)
+apply (metis add.right_neutral)
+done
+
+lemma stable_leads_to_eventually:
+  assumes "(enabled \<^bold>\<hookrightarrow> \<circle>(enabled \<^bold>\<or> taken)) \<sigma>"
+  shows "(enabled \<^bold>\<hookrightarrow> (\<box>enabled \<^bold>\<or> \<diamond>taken)) \<sigma>"
+using assms unfolding defs
+apply -
+apply (rule ccontr)
+apply clarsimp
+apply (drule (1) ex_least_nat_less[where P="\<lambda>j. \<not> enabled (\<sigma> |\<^sub>s i + j)" for i, simplified])
+apply clarsimp
+apply (metis add_Suc_right leI less_irrefl_nat)
+done
+
+lemma weakly_fair_stable_leads_to:
+  assumes "(weakly_fair enabled taken) \<sigma>"
+  assumes "(enabled \<^bold>\<hookrightarrow> \<circle>(enabled \<^bold>\<or> taken)) \<sigma>"
+  shows "(enabled \<^bold>\<leadsto> taken) \<sigma>"
+using stable_leads_to_eventually[OF assms(2)] assms(1) unfolding defs weakly_fair_def
+by (auto simp: fun_eq_iff)
+
+lemma weakly_fair_stable_leads_to_via:
+  assumes "(weakly_fair enabled taken) \<sigma>"
+  assumes "(enabled \<^bold>\<hookrightarrow> \<circle>(enabled \<^bold>\<or> taken)) \<sigma>"
+  shows "(enabled \<^bold>\<hookrightarrow> enabled \<U> taken) \<sigma>"
+using stable_unless[OF assms(2)] assms(1) by (metis (mono_tags) weakly_fair_unless_until)
+
+text\<open>
+
+Similarly for strong fairness. @{cite [cite_macro=citet] "vanGlabbeekHofner:2019"} call this
+"response to persistence" as a generalisation of strong fairness.
+
+\<close>
+
+definition strongly_fair :: "'a seq_pred \<Rightarrow> 'a seq_pred \<Rightarrow> 'a seq_pred" where
+  "strongly_fair enabled taken = (\<box>\<diamond>enabled \<^bold>\<hookrightarrow> \<diamond>taken)"
+
+lemma strongly_fair_def2:
+  "strongly_fair enabled taken = \<box>(\<^bold>\<not>\<box>(\<diamond>enabled \<^bold>\<and> \<^bold>\<not>taken))"
+unfolding strongly_fair_def by (metis weakly_fair_def weakly_fair_def2)
+
+lemma strongly_fair_def3:
+  "strongly_fair enabled taken = (\<box>\<diamond>enabled \<^bold>\<longrightarrow> \<box>\<diamond>taken)"
+unfolding strongly_fair_def2 by (metis (full_types) always_eventually_always weakly_fair_def2 weakly_fair_def3)
+
+lemma always_strongly_fair:
+  "\<box>(strongly_fair enabled taken) = strongly_fair enabled taken"
+unfolding strongly_fair_def by simp
+
+lemma eventually_strongly_fair:
+  "\<diamond>(strongly_fair enabled taken) = strongly_fair enabled taken"
+unfolding strongly_fair_def2 by (simp add: always_eventually_always)
+
+lemma strongly_fair_disj_distrib: \<comment> \<open>not true for \<open>weakly_fair\<close>\<close>
+  "strongly_fair (enabled1 \<^bold>\<or> enabled2) taken = (strongly_fair enabled1 taken \<^bold>\<and> strongly_fair enabled2 taken)"
+unfolding strongly_fair_def defs
+apply (auto simp: fun_eq_iff)
+  apply blast
+  apply blast
+  apply (metis (full_types) semiring_normalization_rules(25))
+done
+
+lemma strongly_fair_imp_weakly_fair:
+  assumes "strongly_fair enabled taken \<sigma>"
+  shows "weakly_fair enabled taken \<sigma>"
+using assms unfolding strongly_fair_def3 weakly_fair_def3 by (simp add: eventually_always_imp_always_eventually)
+
+lemma always_enabled_weakly_fair_strongly_fair:
+  assumes "(\<box>enabled) \<sigma>"
+  shows "weakly_fair enabled taken \<sigma> = strongly_fair enabled taken \<sigma>"
+using assms by (metis strongly_fair_def3 strongly_fair_imp_weakly_fair unfold(2) weakly_fair_def3)
+
+
+subsection\<open>Safety and liveness \label{sec:ltl-safety-liveness}\<close>
+
+text\<open>
+
+@{cite [cite_macro=citet] "Sistla:1994"} shows some characterisations
+of LTL formulas in terms of safety and liveness. Note his @{term
+"(\<U>)"} is actually @{term "(\<W>)"}.
+
+See also @{cite [cite_macro=citet] "ChangMannaPnueli:1992"}.
+
+\<close>
+
+lemma safety_state_prop:
+  shows "safety \<lceil>P\<rceil>"
+unfolding defs by (rule safety_state_prop)
+
+lemma safety_Next:
+  assumes "safety P"
+  shows "safety (\<circle>P)"
+using assms unfolding defs safety_def
+apply clarsimp
+apply (metis (mono_tags) One_nat_def list.sel(3) nat.simps(3) stake.simps(2))
+done
+
+lemma safety_unless:
+  assumes "safety P"
+  assumes "safety Q"
+  shows "safety (P \<W> Q)"
+proof(rule safetyI2)
+  fix \<sigma> assume X: "\<exists>\<beta>. (P \<W> Q) (stake i \<sigma> @- \<beta>)" for i
+  then show "(P \<W> Q) \<sigma>"
+  proof(cases "\<forall>i j. \<exists>\<beta>. P (\<sigma>(i \<rightarrow> j) @- \<beta>)")
+    case True
+    with \<open>safety P\<close> have "\<forall>i. P (\<sigma> |\<^sub>s i)" unfolding safety_def2 by blast
+    then show ?thesis by (blast intro: unless_alwaysI)
+  next
+    case False
+    then obtain k k' where "\<forall>\<beta>. \<not> P (\<sigma>(k \<rightarrow> k') @- \<beta>)" by clarsimp
+    then have "\<forall>i u. k + k' \<le> i \<longrightarrow> \<not>P ((stake i \<sigma> @- u) |\<^sub>s k)"
+      by (metis add.commute diff_add stake_shift_stake_shift stake_suffix_drop suffix_shift)
+    then have "\<forall>i u. k + k' \<le> i \<and> (P \<W> Q) (stake i \<sigma> @- u) \<longrightarrow> (\<exists>m\<le>k. Q ((stake i \<sigma> @- u) |\<^sub>s m) \<and> (\<forall>p<m. P ((stake i \<sigma> @- u) |\<^sub>s p)))"
+      unfolding defs using leI by blast
+    then have "\<forall>i u. k + k' \<le> i \<and> (P \<W> Q) (stake i \<sigma> @- u) \<longrightarrow> (\<exists>m\<le>k. Q (\<sigma>(m \<rightarrow> i - m) @- u) \<and> (\<forall>p<m. P (\<sigma>(p \<rightarrow> i - p) @- u)))"
+      by (metis stake_suffix add_leE nat_less_le order_trans)
+    then have "\<forall>i. \<exists>n\<ge>i. \<exists>m\<le>k. \<exists>u. Q (\<sigma>(m \<rightarrow> n - m) @- u) \<and> (\<forall>p<m. P (\<sigma>(p \<rightarrow> n - p) @- u))"
+      using X by (metis add.commute le_add1)
+    then have "\<exists>m\<le>k. \<forall>i. \<exists>n\<ge>i. \<exists>u. Q (\<sigma>(m \<rightarrow> n - m) @- u) \<and> (\<forall>p<m. P (\<sigma>(p \<rightarrow> n - p) @- u))"
+      by (simp add: always_eventually_pigeonhole)
+    with \<open>safety P\<close> \<open>safety Q\<close> show "(P \<W> Q) \<sigma>"
+        unfolding defs by (metis Nat.le_diff_conv2 add_leE safety_always_eventually)
+  qed
+qed
+
+lemma safety_always:
+  assumes "safety P"
+  shows "safety (\<box>P)"
+using assms by (metis norm(20) safety_def safety_unless)
+
+lemma absolute_liveness_eventually:
+  shows "absolute_liveness P \<longleftrightarrow> (\<exists>\<sigma>. P \<sigma>) \<and> P = \<diamond>P"
+unfolding absolute_liveness_def defs
+by (metis cancel_comm_monoid_add_class.diff_cancel drop_eq_Nil order_refl shift.simps(1) stake_suffix_id suffix_shift suffix_zero)
+
+lemma stable_always:
+  shows "stable P \<longleftrightarrow> (\<exists>\<sigma>. P \<sigma>) \<and> P = \<box>P"
+unfolding stable_def defs by (metis suffix_zero)
+
+(* FIXME Sistla's examples of stable properties are boring and follow directly from this lemma.
+   FIXME the fairness "type of formulas" follow from the above and the fairness def. *)
+
+text\<open>
+
+To show that @{const \<open>weakly_fair\<close>} is a @{const \<open>fairness\<close>} property requires some constraints on \<open>enabled\<close> and \<open>taken\<close>:
+\<^item> it is reasonable to assume they are state formulas
+\<^item> \<open>taken\<close> must be satisfiable
+
+\<close>
+
+lemma fairness_weakly_fair:
+  assumes "\<exists>s. taken s"
+  shows "fairness (weakly_fair \<lceil>enabled\<rceil> \<lceil>taken\<rceil>)"
+unfolding fairness_def stable_def absolute_liveness_def weakly_fair_def
+using assms
+apply auto
+   apply (rule_tac x="\<lambda>_ .s" in exI)
+   apply fastforce
+  apply (simp add: alwaysD)
+ apply (rule_tac x="\<lambda>_ .s" in exI)
+ apply fastforce
+apply (metis (full_types) absolute_liveness_def absolute_liveness_eventually eventually_weakly_fair weakly_fair_def)
+done
+
+lemma fairness_strongly_fair:
+  assumes "\<exists>s. taken s"
+  shows "fairness (strongly_fair \<lceil>enabled\<rceil> \<lceil>taken\<rceil>)"
+unfolding fairness_def stable_def absolute_liveness_def strongly_fair_def
+using assms
+apply auto
+   apply (rule_tac x="\<lambda>_ .s" in exI)
+   apply fastforce
+  apply (simp add: alwaysD)
+ apply (rule_tac x="\<lambda>_ .s" in exI)
+ apply fastforce
+apply (metis (full_types) absolute_liveness_def absolute_liveness_eventually eventually_weakly_fair weakly_fair_def)
+done
+
+(*<*)
+
+end
+(*>*)
diff --git a/thys/ConcurrentIMP/ROOT b/thys/ConcurrentIMP/ROOT
--- a/thys/ConcurrentIMP/ROOT
+++ b/thys/ConcurrentIMP/ROOT
@@ -1,11 +1,14 @@
 chapter AFP
 
 session ConcurrentIMP (AFP) = "HOL-Library" +
   options [timeout = 300]
+  directories
+    "ex"
   theories [show_question_marks = false, names_short]
     CIMP
-    CIMP_one_place_buffer_ex
-    CIMP_unbounded_buffer_ex
+    "ex/CIMP_locales"
+    "ex/CIMP_one_place_buffer"
+    "ex/CIMP_unbounded_buffer"
   document_files
     "root.bib"
     "root.tex"
diff --git a/thys/ConcurrentIMP/cimp.ML b/thys/ConcurrentIMP/cimp.ML
new file mode 100644
--- /dev/null
+++ b/thys/ConcurrentIMP/cimp.ML
@@ -0,0 +1,140 @@
+(* Pollutes the global namespace, but we use them everywhere *)
+fun ss_only thms ctxt = clear_simpset (put_simpset HOL_basic_ss ctxt) addsimps thms;
+fun HOL_ss_only thms ctxt = clear_simpset (put_simpset HOL_ss ctxt) addsimps thms;
+
+signature CIMP =
+sig
+    val com_locs_fold : (term * 'b -> 'b) -> 'b -> term -> 'b
+    val com_locs_map : (term -> 'b) -> term -> 'b list
+    val com_locs_fold_no_response : (term * 'b -> 'b) -> 'b -> term -> 'b
+    val com_locs_map_no_response : (term -> 'b) -> term -> 'b list
+    val intern_com : Facts.ref -> local_theory -> local_theory
+    val def_locset : thm -> local_theory -> local_theory
+end;
+
+structure Cimp : CIMP =
+struct
+
+fun com_locs_fold f x (Const (@{const_name Request}, _) $ l $ _ $ _ )    = f (l, x)
+  | com_locs_fold f x (Const (@{const_name Response}, _) $ l $ _)        = f (l, x)
+  | com_locs_fold f x (Const (@{const_name LocalOp}, _) $ l $ _)         = f (l, x)
+  | com_locs_fold f x (Const (@{const_name Cond1}, _) $ l $ _ $ c)       = com_locs_fold f (f (l, x)) c
+  | com_locs_fold f x (Const (@{const_name Cond2}, _) $ l $ _ $ c1 $ c2) = com_locs_fold f (com_locs_fold f (f (l, x)) c1) c2
+  | com_locs_fold f x (Const (@{const_name Loop}, _) $ c)                = com_locs_fold f x c
+  | com_locs_fold f x (Const (@{const_name While}, _) $ l $ _ $ c)       = com_locs_fold f (f (l, x)) c
+  | com_locs_fold f x (Const (@{const_name Seq}, _) $ c1 $ c2)           = com_locs_fold f (com_locs_fold f x c1) c2
+  | com_locs_fold f x (Const (@{const_name Choose}, _) $ c1 $ c2)        = com_locs_fold f (com_locs_fold f x c1) c2
+  | com_locs_fold _ x _ = x;
+
+fun com_locs_map f com = com_locs_fold (fn (l, acc) => f l :: acc) [] com
+
+fun com_locs_fold_no_response f x (Const (@{const_name Request}, _) $ l $ _ $ _ )    = f (l, x)
+  | com_locs_fold_no_response _ x (Const (@{const_name Response}, _) $ _ $ _)        = x (* can often ignore \<open>Response\<close> *)
+  | com_locs_fold_no_response f x (Const (@{const_name LocalOp}, _) $ l $ _)         = f (l, x)
+  | com_locs_fold_no_response f x (Const (@{const_name Cond1}, _) $ l $ _ $ c)       = com_locs_fold_no_response f (f (l, x)) c
+  | com_locs_fold_no_response f x (Const (@{const_name Cond2}, _) $ l $ _ $ c1 $ c2) = com_locs_fold_no_response f (com_locs_fold_no_response f (f (l, x)) c1) c2
+  | com_locs_fold_no_response f x (Const (@{const_name Loop}, _) $ c)                = com_locs_fold_no_response f x c
+  | com_locs_fold_no_response f x (Const (@{const_name While}, _) $ l $ _ $ c)       = com_locs_fold_no_response f (f (l, x)) c
+  | com_locs_fold_no_response f x (Const (@{const_name Seq}, _) $ c1 $ c2)           = com_locs_fold_no_response f (com_locs_fold_no_response f x c1) c2
+  | com_locs_fold_no_response f x (Const (@{const_name Choose}, _) $ c1 $ c2)        = com_locs_fold_no_response f (com_locs_fold_no_response f x c1) c2
+  | com_locs_fold_no_response _ x _ = x;
+
+fun com_locs_map_no_response f com = com_locs_fold_no_response (fn (l, acc) => f l :: acc) [] com
+
+fun cprop_of_equality ctxt : thm -> cterm =
+  Local_Defs.meta_rewrite_rule ctxt (* handle `=` or `\<equiv>` *)
+  #> Thm.cprop_of
+
+fun equality_lhs ctxt : thm -> term =
+  cprop_of_equality ctxt #> Thm.dest_equals_lhs #> Thm.term_of
+
+fun equality_rhs ctxt : thm -> term =
+  cprop_of_equality ctxt #> Thm.dest_equals_rhs #> Thm.term_of
+
+(* Intern all labels mentioned in CIMP programs \<open>facts\<close>
+
+FIXME can only use \<open>com_intern\<close> once per locale
+FIXME forces all labels to be unique and distinct from other constants in the locale.
+FIXME assumes the labels are character strings
+*)
+fun intern_com facts ctxt : local_theory =
+  let
+    val thms = Proof_Context.get_fact ctxt facts
+    (* Define constants with defs of the form loc.XXX_def: "XXX \<equiv> ''XXX''. *)
+    val attrs = []
+    fun add_literal_def (literal, (loc_defs, ctxt)) : thm list * local_theory =
+      let
+        val literal_name = HOLogic.dest_string literal (* FIXME might not be a nice name, but the error is readable so shrug. FIXME generalise to other label types *)
+        val literal_def_binding = Binding.empty (* Binding.qualify true "loc" (Binding.name (Thm.def_name literal_name)) No need to name individual defs *)
+        val ((_, (_, loc_def)), ctxt) = Local_Theory.define ((Binding.name literal_name, Mixfix.NoSyn), ((literal_def_binding, attrs), literal)) ctxt
+      in
+        (loc_def :: loc_defs, ctxt)
+      end;
+    val (loc_defs, ctxt) = List.foldl (fn (com, acc) => com_locs_fold add_literal_def acc (equality_rhs ctxt com)) ([], ctxt) thms
+
+    val coms_interned = List.map (Local_Defs.fold ctxt loc_defs) thms
+    val attrs = []
+    val (_, ctxt) = Local_Theory.note ((@{binding "loc_defs"}, attrs), loc_defs) ctxt
+    val (_, ctxt) = Local_Theory.note ((@{binding "com_interned"}, attrs), coms_interned) ctxt
+  in
+    ctxt
+  end;
+
+(* Cache location set membership facts.
+
+Decide membership in the given set for each label in the CIMP programs
+in the Named_Theorems "com".
+
+If the label set and com types differ, we probably get a nasty error.
+
+*)
+
+fun def_locset thm ctxt =
+  let
+    val set_name = equality_lhs ctxt thm
+    val set_name_str = case set_name of Const (c, _) => c | Free (c, _) => c | _ => error ("Not an equation of the form x = set: " ^ Thm.string_of_thm ctxt thm)
+    val memb_thm_name = Binding.qualify true set_name_str (Binding.name "memb")
+    fun mk_memb l = Thm.cterm_of ctxt (HOLogic.mk_mem (l, set_name))
+(*
+1. solve atomic membership yielding \<open>''label'' \<in> set\<close> or \<open>''label'' \<notin> set\<close>.
+2. fold \<open>loc_defs\<close>
+3. cleanup with the existing \<open>locset_cache\<close>.
+FIXME trim simpsets: 1: sets 2: not much 3: not much
+*)
+    val loc_defs = Proof_Context.get_fact ctxt (Facts.named "loc_defs")
+    val membership_ctxt = ctxt addsimps ([thm] @ loc_defs)
+    val cleanup_ctxt = HOL_ss_only (@{thms cleanup_simps} @ Named_Theorems.get ctxt \<^named_theorems>\<open>locset_cache\<close>) ctxt
+    val rewrite_tac =
+          Simplifier.rewrite membership_ctxt
+          #> Local_Defs.fold ctxt loc_defs
+          #> Simplifier.simplify cleanup_ctxt
+    val coms = Proof_Context.get_fact ctxt (Facts.named "com_interned")
+(* Parallel *)
+    fun mk_thms coms : thm list = Par_List.map rewrite_tac (maps (equality_rhs ctxt #> com_locs_map_no_response mk_memb) coms)
+(* Sequential *)
+(*    fun mk_thms coms = List.foldl (fn (c, thms) => com_locs_fold (fn l => fn thms => rewrite_tac (mk_memb l) :: thms) thms c) [] coms *)
+    val attrs = []
+    val (_, ctxt) = ctxt |> Local_Theory.note ((memb_thm_name, attrs), mk_thms coms)
+(* Add \<open>memb_thms\<close> to the global (and inherited by locales) \<open>locset_cache\<close> *)
+    val memb_thm_full_name = Local_Theory.full_name ctxt memb_thm_name
+    val (finish, ctxt) = Target_Context.switch_named_cmd (SOME ("-", Position.none)) (Context.Proof ctxt) (* switch to the "root" local theory *)
+    val memb_thms = Proof_Context.get_fact ctxt (Facts.named memb_thm_full_name)
+    val attrs = [Attrib.internal (K (Named_Theorems.add \<^named_theorems>\<open>locset_cache\<close>))]
+    val (_, ctxt) = ctxt |> Local_Theory.note ((Binding.empty, attrs), memb_thms)
+    val ctxt = case finish ctxt of Context.Proof ctxt => ctxt | _ => error "Context.generic failure" (* Return to the locale we were in *)
+  in
+    ctxt
+  end;
+
+end;
+
+val _ =
+  Outer_Syntax.local_theory \<^command_keyword>\<open>intern_com\<close> "intern labels in CIMP commands"
+    (Parse.thms1 >> (fn facts => fn ctxt => List.foldl (fn ((f, _), ctxt) => Cimp.intern_com f ctxt) ctxt facts));
+
+val _ =
+  Outer_Syntax.local_theory' \<^command_keyword>\<open>locset_definition\<close> "constant definition for sets of locations"
+    (Scan.option Parse_Spec.constdecl -- (Parse_Spec.opt_thm_name ":" -- Parse.prop) --
+      Parse_Spec.if_assumes -- Parse.for_fixes >> (fn (((decl, spec), prems), params) => fn b => fn lthy =>
+        Specification.definition_cmd decl params prems spec b lthy
+        |> (fn ((_, (_, thm)), lthy) => (thm, lthy)) |> uncurry Cimp.def_locset));
diff --git a/thys/ConcurrentIMP/document/root.bib b/thys/ConcurrentIMP/document/root.bib
--- a/thys/ConcurrentIMP/document/root.bib
+++ b/thys/ConcurrentIMP/document/root.bib
@@ -1,533 +1,656 @@
 @STRING{cacm="Communications of the ACM"}
+@STRING{csur="{ACM} Computing Surveys"}
+@STRING{fac="Formal Aspects of Computing"}
+@STRING{ipl="Information Processing Letters"}
+@STRING{lncs="LNCS"}
+@STRING{tcs="Theoretical Computer Science"}
 
 @article{AptFrancezDeRoever:1980,
   author =       {K. R. Apt and Francez, N. and de Roever, W. P.},
   title =        {A Proof System for Communicating Sequential
                   Processes},
   journal =      toplas,
   year =         1980,
   volume =       2,
   number =       3,
   pages =        {359--385},
   doi =          {10.1145/357103.357110}
 }
 
 @TechReport{LynchTuttle:1989,
   author =       "Lynch, N. A and Tuttle, M. R.",
-  title =        "An introduction to
- input/output automata",
+  title =        "An introduction to input/output automata",
   institution =  "CWI",
   year =         1989,
   month =     sep,
   annote =    "CWI Quarterly 2 (3): 219–246",
   url = "http://www.markrtuttle.com/data/papers/lt89-cwi.pdf"
 }
 
 @book{Lynch:1996,
  author = {N. A. Lynch},
  title = {Distributed Algorithms},
- year = {1996},
+ year = 1996,
  publisher = {Morgan Kaufmann Publishers Inc.},
 }
 
 @InProceedings{PrenEsp00,
   author =    {Prensa Nieto, L. and J. 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},
+  publisher = {Springer},
+  series =    lncs,
   volume =    1893,
   pages =     {619--628},
   year =      2000
 }
 
-@PhdThesis{Prensa-PhD,author={Prensa Nieto, L.},
-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}
+@PhdThesis{Prensa-PhD,
+  author={Prensa Nieto, L.},
+  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, L.},
-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}
+@inproceedings{Prensa-ESOP03,
+  author={Prensa Nieto, L.},
+  title={The {Rely-Guarantee} Method in {Isabelle/HOL}},
+  booktitle={ESOP'2003},
+  editor={P. Degano},
+  publisher="Springer",
+  series=lncs,volume=2618,
+  pages={348--362},
+  year=2003
+}
 
 @book{Winskel:1993,
  author = {Winskel, G.},
  title = {The Formal Semantics of Programming Languages},
- year = {1993},
+ year = 1993,
  publisher = {MIT Press},
  address = "Cambridge, MA"
 }
 
 @article{DBLP:journals/cacm/DijkstraLMSS78,
   author    = {E. W. Dijkstra and
                L. Lamport and
                A. J. Martin and
                C. S. Scholten and
                E. F. M. Steffens},
   title     = {On-the-Fly Garbage Collection: An Exercise in Cooperation},
   journal   = cacm,
-  volume    = {21},
-  number    = {11},
-  year      = {1978},
+  volume    = 21,
+  number    = 11,
+  year      = 1978,
   pages     = {966-975},
   ee        = {http://doi.acm.org/10.1145/359642.359655},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 @inproceedings{DBLP:conf/lpar/Schirmer04,
   author    = {N. Schirmer},
   title     = {A Verification Environment for Sequential Imperative Programs
                in Isabelle/HOL},
   booktitle = {LPAR},
-  year      = {2004},
+  year      = 2004,
   pages     = {398-414},
   ee        = {https://doi.org/10.1007/978-3-540-32275-7_26},
   crossref  = {DBLP:conf/lpar/2004},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 %  isbn      = {3-540-25236-3},
 @proceedings{DBLP:conf/lpar/2004,
   editor    = {F. Baader and
                A. Voronkov},
   title     = {Logic for Programming, Artificial Intelligence, and Reasoning,
                11th International Conference, LPAR 2004, Montevideo, Uruguay,
                March 14-18, 2005, Proceedings},
   booktitle = {LPAR},
   publisher = {Springer},
   series    = lncs,
   volume    = {3452},
   year      = {2005},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 @article{DBLP:journals/cacm/SewellSONM10,
   author    = {P. Sewell and
                S. Sarkar and
                S. Owens and
                F. Zappa Nardelli and
                M. O. Myreen},
   title     = {{x86-TSO}: a rigorous and usable programmer's model for x86
                multiprocessors},
   journal   = cacm,
   volume    = {53},
   number    = {7},
   year      = {2010},
   pages     = {89-97},
   ee        = {http://doi.acm.org/10.1145/1785414.1785443},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 @inproceedings{DBLP:conf/mfcs/BoerRH99,
   author    = {de Boer, F. S. and
                de Roever, W. P. and
                U. Hannemann},
   title     = {The Semantic Foundations of a Compositional Proof Method
                for Synchronously Communicating Processes},
   booktitle = {MFCS},
   year      = {1999},
   pages     = {343-353},
   ee        = {https://doi.org/10.1007/3-540-48340-3_31},
   crossref  = {DBLP:conf/mfcs/1999},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 %  isbn      = {3-540-66408-4},
 @proceedings{DBLP:conf/mfcs/1999,
   editor    = {M. Kutylowski and
                L. Pacholski and
                T. Wierzbicki},
   title     = {Mathematical Foundations of Computer Science 1999, 24th
                International Symposium, MFCS'99, Szklarska Poreba, Poland,
                September 6-10, 1999, Proceedings},
   booktitle = {MFCS},
   publisher = {Springer},
   series    = lncs,
   volume    = {1672},
   year      = {1999},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 %  isbn      = {0-521-80608-9},
-@book{DBLP:books/cu/RoeverBH2001,
+@book{deRoeverEtAl:2001,
   author    = {de Roever, W. P. and
                de Boer, F. S. and
                U. Hannemann and
                J. Hooman and
                Y. Lakhnech and
                M. Poel and
                J. Zwiers},
   title     = {Concurrency Verification: Introduction to Compositional
                and Noncompositional Methods},
   publisher = {Cambridge University Press},
   series    = {Cambridge Tracts in Theoretical Computer Science},
-  volume    = {54},
-  year      = {2001},
-  bibsource = {DBLP, http://dblp.uni-trier.de}
+  volume    = 54,
+  year      = 2001,
 }
 
 @InProceedings{Pizlo+2010PLDI,
 author =	 {F. Pizlo and L. Ziarek and P. Maj and A.
                 L. Hosking and E. Blanton and J. Vitek},
 title =	 {Schism: Fragmentation-Tolerant Real-Time Garbage Collection},
 booktitle =	 {Proceedings of the ACM SIGPLAN Conference on Programming
                 Language Design and Implementation},
 year =	 2010,
 pages =	 "146--159",
 month =	 jun,
 address =	 {Toronto, Canada},
 doi =		 {10.1145/1806596.1806615}
 }
 
 @PhdThesis{Pizlo201xPhd,
 author =	 {F. Pizlo},
 title =	 {Fragmentation Tolerant Real Time Garbage Collection},
 school =	 {Purdue University},
 year =	 {201x}
 }
 
 @article{DBLP:journals/toplas/LamportS84,
-  author    = {L. Lamport and
-               F. B. Schneider},
+  author    = {L. Lamport and F. B. Schneider},
   title     = {The ``{Hoare Logic}'' of {CSP}, and All That},
   journal   = toplas,
   volume    = {6},
   number    = {2},
   year      = {1984},
   pages     = {281-296},
   ee        = {http://doi.acm.org/10.1145/2993.357247},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 @article{DBLP:journals/acta/Lamport80,
   author    = {L. Lamport},
   title     = {The ``{Hoare Logic}'' of Concurrent Programs},
   journal   = {Acta Informatica},
   volume    = {14},
   year      = {1980},
   pages     = {21-37},
   ee        = {https://doi.org/10.1007/BF00289062},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 @article{DBLP:journals/jar/Berghofer12,
   author    = {S. Berghofer},
   title     = {A Solution to the {PoplMark} Challenge Using {de Bruijn} Indices
                in {Isabelle/HOL}},
   journal   = {J. Autom. Reasoning},
   volume    = {49},
   number    = {3},
   year      = {2012},
   pages     = {303-326},
   ee        = {https://doi.org/10.1007/s10817-011-9231-4},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 %  isbn =	 {3-540-44044-5}
 @InCollection{PittsAM:opespe,
   author =	 {A. M. Pitts},
   title =	 {Operational Semantics and Program Equivalence},
   booktitle =	 {Applied Semantics, Advanced Lectures},
   pages =	 {378--412},
-  publisher =	 {Springer-Verlag},
+  publisher =	 {Springer},
   year =	 2002,
   editor =	 {G. Barthe and P. Dybjer and J. Saraiva},
   volume =	 2395,
   series =	 lncs,
   note =	 {International Summer School, {APPSEM} 2000, Caminha,
                   Portugal, September 9--15, 2000},
 }
 
+@InCollection{MannaPnueli:1991,
+  author =       "Z. Manna and A. Pnueli",
+  title =        "Tools and rules for the practicing verifier",
+  booktitle =    "CMU Computer Science: A 25th Anniversary Commemorative",
+  pages =     "121–-156",
+  publisher = "ACM Press and Addison-Wesley",
+  year =      1991,
+  editor =    "R. F. Rashid",
+  note = "Also Technical Report STAN-CS-90-1321"
+}
+
 %  isbn      = {978-0-387-94459-3},
 @book{MannaPnueli:1995,
   author    = {Z. Manna and A. Pnueli},
-  title     = {Temporal verification of reactive systems - safety},
+  title     = {Temporal verification of reactive systems - {Safety}},
   publisher = {Springer},
   year      = 1995,
   pages     = {I-XV, 1-512},
 }
 
+@inproceedings{MannaPnueli:2010,
+  author    = {Z. Manna and A. Pnueli},
+  title     = {Temporal Verification of Reactive Systems: Response},
+  booktitle = {Time for Verification, Essays in Memory of Amir Pnueli},
+  series    = lncs,
+  volume    = 6200,
+  publisher = {Springer},
+  pages     = {279--361},
+  year      = 2010,
+  doi       = {10.1007/978-3-642-13754-9\_13},
+}
+
 @article{DBLP:journals/acta/LevinG81,
   author    = {G. Levin and
                D. Gries},
   title     = {A Proof Technique for Communicating Sequential Processes},
   journal   = {Acta Inf.},
   volume    = {15},
   year      = {1981},
   pages     = {281-302},
   ee        = {https://doi.org/10.1007/BF00289266},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 @inproceedings{CousotCousot:1980,
   author    = {P. Cousot and R. Cousot},
   title     = "Semantic Analysis of {Communicating Sequential Processes}
                (Shortened Version)",
   booktitle = {ICALP},
   series    = lncs,
   volume    = {85},
   publisher = {Springer},
   year      = 1980,
   pages     = {119-133},
   ee        = {https://doi.org/10.1007/3-540-10003-2_65},
 }
 
-@InCollection{MannaPnueli:1991,
-  author =       "Z. Manna and A. Pnueli",
-  title =        "Tools and rules for the practicing verifier",
-  booktitle =    "CMU Computer Science: A 25th Anniversary Commemorative",
-  pages =     "121–-156",
-  publisher = "ACM Press and Addison-Wesley",
-  year =      1991,
-  editor =    "R. F. Rashid"
-}
-
 %  isbn      = {0-3211-4306-X},
-@book{DBLP:books/aw/Lamport2002,
+@book{Lamport:2002,
   author    = {L. Lamport},
   title     = {Specifying Systems, The TLA+ Language and Tools for Hardware
                and Software Engineers},
   publisher = {Addison-Wesley},
-  year      = {2002},
-  bibsource = {DBLP, http://dblp.uni-trier.de}
+  year      = 2002
 }
 
 @article{TLA-AFP,
   author  = {G. Grov and S. Merz},
   title   = {A Definitional Encoding of TLA* in Isabelle/HOL},
   journal = {Archive of Formal Proofs},
   month   = nov,
   year    = 2011,
   note    = {\url{http://isa-afp.org/entries/TLA},
             Formal proof development},
   ISSN    = {2150-914x},
 }
 
 @inproceedings{DBLP:conf/itp/CohenS10,
   author    = {E. Cohen and
                B. Schirmer},
   title     = {From Total Store Order to Sequential Consistency: A Practical
                Reduction Theorem},
   booktitle = {ITP},
   year      = {2010},
   pages     = {403-418},
   ee        = {https://doi.org/10.1007/978-3-642-14052-5_28},
   crossref  = {DBLP:conf/itp/2010},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 %  isbn      = {978-3-642-14051-8},
 @proceedings{DBLP:conf/itp/2010,
   editor    = {M. Kaufmann and
                L. C. Paulson},
   title     = {Interactive Theorem Proving, First International Conference,
                ITP 2010, Edinburgh, UK, July 11-14, 2010. Proceedings},
   booktitle = {ITP},
   publisher = {Springer},
   series    = lncs,
   volume    = {6172},
   year      = {2010},
   ee        = {https://doi.org/10.1007/978-3-642-14052-5},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 @inproceedings{DBLP:conf/fase/NipkowN99,
   author    = {T. Nipkow and
                Prensa Nieto, L.},
   title     = "{Owicki/Gries} in {Isabelle/HOL}",
   booktitle = {FASE},
   year      = {1999},
   pages     = {188-203},
   ee        = {https://doi.org/10.1007/978-3-540-49020-3_13},
   crossref  = {DBLP:conf/fase/1999},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 %  isbn      = {3-540-65718-5},
 @proceedings{DBLP:conf/fase/1999,
   editor    = {J.-P. Finance},
   title     = {Fundamental Approaches to Software Engineering, Second Internationsl
                Conference, FASE'99, Held as Part of the European Joint
                Conferences on the Theory and Practice of Software, ETAPS'99,
                Amsterdam, The Netherlands, March 22-28, 1999, Proceedings},
   booktitle = {FASE},
   publisher = {Springer},
   series    = lncs,
   volume    = {1577},
   year      = {1999},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 @article{CousotCousot89-IC,
    author =  {Cousot, P. and Cousot, R.},
    title =   {A language independent proof of the soundness
               and completeness of generalized {H}oare logic},
    journal = {Information and Computation},
    volume =  80,
    number =  2,
    pages =   {165--191},
    month =   feb,
    year =    1989,
 }
 
-@inproceedings{DBLP:conf/popl/DoligezG94,
-  author    = {D. Doligez and
-               G. Gonthier},
-  title     = {Portable, Unobtrusive Garbage Collection for Multiprocessor
-               Systems},
-  booktitle = {POPL},
-  year      = {1994},
-  pages     = {70-83},
-  ee        = {http://doi.acm.org/10.1145/174675.174673},
-  crossref  = {DBLP:conf/popl/1994},
-  bibsource = {DBLP, http://dblp.uni-trier.de}
-}
-
-%  isbn      = {0-89791-636-0},
-@proceedings{DBLP:conf/popl/1994,
-  editor    = {Boehm, H.-J. and
-               B. Lang and
-               D. M. Yellin},
-  title     = {Conference Record of POPL'94: 21st ACM SIGPLAN-SIGACT Symposium
-               on Principles of Programming Languages, Portland, Oregon,
-               USA, January 17-21, 1994},
-  booktitle = popl,
-  publisher = {ACM Press},
-  year      = {1994},
-  ee        = {http://dl.acm.org/citation.cfm?id=174675},
-  bibsource = {DBLP, http://dblp.uni-trier.de}
-}
-
 @article{DBLP:journals/jlp/Plotkin04,
   author    = {G. D. Plotkin},
   title     = {The origins of structural operational semantics},
   journal   = {Journal of Logic and Algebraic Programming},
   volume    = {60-61},
   year      = {2004},
   pages     = {3-15},
   ee        = {https://doi.org/10.1016/j.jlap.2004.03.009},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 @Book{ConcreteSemantics:2014,
-  author =    "T. Nipkow and G. Klein",
+  author =       "T. Nipkow and G. Klein",
   title =        "Concrete Semantics: A Proof Assistant Approach",
-  publisher =    Springer,
+  publisher =    "Springer",
   year =         2014,
   url = "http://www.in.tum.de/~nipkow/Concrete-Semantics/"
 }
 
 @Book{Hoare:1985,
   author       = {C.A.R. Hoare},
   title        = "{Communicating Sequential Processes}",
   publisher    = {Prentice-Hall},
-  year 	       = 1985,
+  year         = 1985,
   series       = {International Series In Computer Science},
   url = "http://www.usingcsp.com/"
 }
 
 @Book{Milner:1980,
-  author =    "R. Milner",
+  author =       "R. Milner",
   title =        "A Calculus of Communicating Systems",
-  publisher =    Springer,
+  publisher =    "Springer",
   year =         1980
 }
 
 @book{Milner:1989,
  author = {R. Milner},
  title = "Communication and Concurrency",
  year = {1989},
  publisher = {Prentice-Hall},
  address = "Englewood Cliffs, NJ",
 }
 
-@article{DBLP:journals/tcs/FelleisenH92,
+@article{FelleisenHieb:1992,
   author    = {M. Felleisen and
                R. Hieb},
   title     = {The Revised Report on the Syntactic Theories of Sequential
                Control and State},
-  journal   = {Theor. Comput. Sci.},
-  volume    = {103},
-  number    = {2},
-  year      = {1992},
+  journal   = tcs,
+  volume    = 103,
+  number    = 2,
+  year      = 1992,
   pages     = {235-271},
-  ee        = {https://doi.org/10.1016/0304-3975(92)90014-7},
-  bibsource = {DBLP, http://dblp.uni-trier.de}
+  doi       = {10.1016/0304-3975(92)90014-7},
 }
 
-@inproceedings{DBLP:conf/tphol/Jackson98,
-  author    = {Paul B. Jackson},
+@inproceedings{Jackson:1998,
+  author    = {P. B. Jackson},
   title     = {Verifying a Garbage Collection Algorithm},
   booktitle = {TPHOLs},
-  year      = {1998},
-  pages     = {225-244},
-  ee        = {https://doi.org/10.1007/BFb0055139},
-  crossref  = {DBLP:conf/tphol/1998},
-  bibsource = {DBLP, http://dblp.uni-trier.de}
-}
-
-@proceedings{DBLP:conf/tphol/1998,
-  editor    = {Jim Grundy and
-               Malcolm C. Newey},
-  title     = {Theorem Proving in Higher Order Logics, 11th International
-               Conference, TPHOLs'98, Canberra, Australia, September 27
-               - October 1, 1998, Proceedings},
-  booktitle = {TPHOLs},
   publisher = {Springer},
-  series    = {Lecture Notes in Computer Science},
+  series    = lncs,
   volume    = {1479},
-  year      = {1998},
-  isbn      = {3-540-64987-5},
-  bibsource = {DBLP, http://dblp.uni-trier.de}
+  year      = 1998,
+  pages     = {225-244},
+  doi       = {10.1007/BFb0055139},
 }
 
-@article{DBLP:journals/logcom/Coupet-GrimalN03,
-  author    = {Coupet-Grimal, S. and
-               Nouvet, C.},
-  title     = {Formal Verification of an Incremental Garbage Collector},
-  journal   = {J. Log. Comput.},
-  volume    = {13},
-  number    = {6},
-  year      = {2003},
-  pages     = {815-833},
-  ee        = {https://doi.org/10.1093/logcom/13.6.815},
-  bibsource = {DBLP, http://dblp.uni-trier.de}
-}
-
-@article{DBLP:journals/logcom/Coupet-Grimal03,
+@article{CoupetGrimal:2003,
   author    = {Coupet-Grimal, S.},
-  title     = {An Axiomatization of Linear Temporal Logic in the Calculus
-               of Inductive Constructions},
-  journal   = {J. Log. Comput.},
-  volume    = {13},
-  number    = {6},
-  year      = {2003},
+  title     = {An Axiomatization of {Linear Temporal Logic} in the {Calculus
+               of Inductive Constructions}},
+  journal   = {Journal of Logic and Computation},
+  volume    = 13,
+  number    = 6,
+  year      = 2003,
   pages     = {801-813},
-  ee        = {https://doi.org/10.1093/logcom/13.6.801},
-  bibsource = {DBLP, http://dblp.uni-trier.de}
+  doi       = {10.1093/logcom/13.6.801},
 }
 
 @article{DBLP:journals/entcs/SchirmerW09,
   author    = {N. Schirmer and
                M. Wenzel},
   title     = {State Spaces - The Locale Way},
   journal   = {Electr. Notes Theor. Comput. Sci.},
   volume    = {254},
   year      = {2009},
   pages     = {161-179},
   ee        = {https://doi.org/10.1016/j.entcs.2009.09.065},
   bibsource = {DBLP, http://dblp.uni-trier.de}
 }
 
 @inproceedings{Ridge:2009,
   author    = {T. Ridge},
   title     = {Verifying distributed systems: the operational approach},
   booktitle = {POPL'2009},
   pages     = {429--440},
   publisher = {{ACM}},
   year      = 2009,
   doi       = {10.1145/1480881.1480934},
 }
+
+@book{ChandyMisra:1989,
+  author    = {Chandy, K. M. and Misra, J.},
+  title     = {Parallel program design - a foundation},
+  publisher = {Addison-Wesley},
+  year      = 1989,
+  isbn      = {978-0-201-05866-6},
+}
+
+% 2019-06 FIXME not yet published?
+@Article{vanGlabbeekHofner:2019,
+  author =       {van Glabbeek, R. J. and H\"{o}fner, P.},
+  title =        {Progress, Justness and Fairness},
+  journal =      csur,
+  year =         2019,
+  url = {http://arxiv.org/abs/1810.07414v1}
+}
+
+@article{AptDelporteGallet:1986,
+  author    = {Krzysztof R. Apt and
+               Carole Delporte{-}Gallet},
+  title     = {Syntax Directed Analysis of Liveness Properties},
+  journal   = {Information and Control},
+  volume    = 68,
+  number    = {1-3},
+  pages     = {223--253},
+  year      = 1986,
+  doi       = {10.1016/S0019-9958(86)80037-7},
+}
+
+@inproceedings{MisraChandySmith:1982,
+  author    = {J. Misra and
+               K. M. Chandy and
+               T. Smith},
+  title     = {Proving Safety and Liveness of Communicating Processes with Examples},
+  booktitle = {PODC'1982},
+  publisher = {{ACM}},
+  pages     = {201--208},
+  year      = 1982,
+  doi       = {10.1145/800220.806698},
+}
+
+@article{AlpernSchneider:1985,
+  author    = {B. Alpern and
+               F. B. Schneider},
+  title     = {Defining Liveness},
+  journal   = ipl,
+  volume    = 21,
+  number    = 4,
+  pages     = {181--185},
+  year      = 1985,
+  doi       = {10.1016/0020-0190(85)90056-0},
+}
+
+@TechReport{Schneider:1987,
+  author =       {F. B. Schneider},
+  title =        {Decomposing Properties into Safety and Liveness using Predicate Logic},
+  institution =  {Department of Computer Science, Cornell University},
+  year =         1987,
+  number =    {87-874},
+  month =     oct
+}
+
+% FIXME guesswork on some of the biblio data
+@article{Kindler:1994,
+  author =       {E. Kindler},
+  title =        {Safety and liveness properties: A survey},
+  journal =      {Bulletin of the European Association for Theoretical Computer Science},
+  year =         1994,
+  volume =    53,
+  number =    30,
+  pages =     {268--272},
+  month =     6,
+  url = "http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.43.8206&rep=rep1&type=pdf",
+}
+
+@article{Sistla:1994,
+  author    = {Sistla, A. P.},
+  title     = {Safety, Liveness and Fairness in Temporal Logic},
+  journal   = fac,
+  volume    = 6,
+  number    = 5,
+  pages     = {495--512},
+  year      = 1994,
+  doi       = {10.1007/BF01211865},
+}
+
+@article{OwickiLamport:1982,
+  author    = {S. S. Owicki and
+               L. Lamport},
+  title     = {Proving Liveness Properties of Concurrent Programs},
+  journal   = toplas,
+  volume    = 4,
+  number    = 3,
+  pages     = {455--495},
+  year      = 1982,
+  doi       = {10.1145/357172.357178},
+}
+
+@inproceedings{ChangMannaPnueli:1992,
+  author    = {E. Y. Chang and
+               Z. Manna and
+               A. Pnueli},
+  title     = {Characterization of Temporal Property Classes},
+  booktitle = {ICALP'1992},
+  pages     = {474--486},
+  year      = 1992,
+  series    = lncs,
+  volume    = 623,
+  publisher = {Springer},
+  doi       = {10.1007/3-540-55719-9\_97},
+}
+
+@inproceedings{MannaPnueli:1988,
+  author    = {Z. Manna and
+               A. Pnueli},
+  title     = {The anchored version of the temporal framework},
+  booktitle = {Linear Time, Branching Time and Partial Order in Logics and Models
+               for Concurrency, School/Workshop, Noordwijkerhout, The Netherlands,
+               May 30 - June 3, 1988, Proceedings},
+  editor    = {de Bakker, J. W. and
+               de Roever, W. P. and
+               Rozenberg, G.},
+  pages     = {201--284},
+  year      = 1988,
+  doi       = {10.1007/BFb0013024},
+  volume    = 354,
+  publisher = {Springer},
+  series    = lncs,
+}
+
+@inproceedings{PnueliArons:2003,
+  author="Pnueli, A. and Arons, T.",
+  title="{TLPVS}: A {PVS}-Based {LTL} Verification System",
+  bookTitle="Verification: Theory and Practice: Essays Dedicated to Zohar Manna on the Occasion of His 64th Birthday",
+  year=2003,
+  publisher="Springer",
+  series=lncs,
+  volume=2772,
+  address="Berlin, Heidelberg",
+  pages="598--625",
+  abstract="In this paper we present our pvs implementation of a linear temporal logic verification system. The system includes a set of theories defining a temporal logic, a number of proof rules for proving soundness and response properties, and strategies which aid in conducting the proofs. In addition to implementing a framework for existing rules, we have also derived new methods which are particularly useful in a deductive ltl system. A distributed rank rule for the verification of response properties in parameterized systems is presented, and a methodology is detailed for reducing compassion requirements to justice requirements (strong fairness to weak fairness). Special attention has been paid to the verification of unbounded systems --- systems in which the number of processes is unbounded --- and our verification rules are appropriate to such systems.",
+  isbn="978-3-540-39910-0",
+  doi="10.1007/978-3-540-39910-0_26",
+}
+
+@article{AbadiPlotkin:1993,
+  author    = {Mart{\'{\i}}n Abadi and
+               Gordon D. Plotkin},
+  title     = {A Logical View of Composition},
+  journal   = tcs,
+  volume    = 114,
+  number    = 1,
+  pages     = {3--30},
+  year      = 1993,
+  doi       = {10.1016/0304-3975(93)90151-I},
+  note = {Journal version of FIXME Abadi, Plotkin (POPL, 1991)}
+}
diff --git a/thys/ConcurrentIMP/document/root.tex b/thys/ConcurrentIMP/document/root.tex
--- a/thys/ConcurrentIMP/document/root.tex
+++ b/thys/ConcurrentIMP/document/root.tex
@@ -1,87 +1,88 @@
 \documentclass[11pt,a4paper]{article}
 \usepackage[a4paper,margin=1cm,footskip=.5cm]{geometry}
 
 \usepackage{isabelle,isabellesym}
 
 \usepackage{amssymb}
+\usepackage{wasysym}
 
 \usepackage[english]{babel}
 
 % lifted composition.
 \newcommand{\isasymbigcirc}{\isamath{\circ}}
 
 % Bibliography
 \usepackage[authoryear,longnamesfirst,sort]{natbib}
 \bibpunct();A{},
 
 % this should be the last package used
 \usepackage{pdfsetup}
 
 % urls in roman style, theory text in math-similar italics
 \urlstyle{rm}
 \isabellestyle{it}
 \renewcommand{\ttdefault}{cmtt} % CM rather than courier for \tt
 
 % for uniform font size
 \renewcommand{\isastyle}{\isastyleminor}
 
 % Abstract various things that might change.
 \newcommand{\ccode}[1]{\texttt{#1}}
 \newcommand{\isabelletype}[1]{\emph{#1}}
 \newcommand{\isabelleterm}[1]{\emph{#1}}
 
 \begin{document}
 
 \title{CIMP}
 \author{Peter Gammie}
 \maketitle
 
 \begin{abstract}
   CIMP extends the small imperative language IMP with control
   non-determinism and constructs for synchronous message passing.
 \end{abstract}
 
 \tableofcontents
 
 % sane default for proof documents
 \parindent 0pt\parskip 0.5ex
 
 % generated text of all theories
 \input{session}
 
 \section{Concluding remarks}
 
 Previously
 \citet{DBLP:conf/fase/NipkowN99,Prensa-PhD,Prensa-ESOP03}\footnote{The
   theories are in \texttt{\$ISABELLE/src/HOL/Hoare\_Parallel}.} have
 developed the classical Owicki/Gries and Rely-Guarantee paradigms for
 the verification of shared-variable concurrent programs in
 Isabelle/HOL. These have been used to show the correctness of a
 garbage collector \citep{PrenEsp00}.
 
 We instead use synchronous message passing, which is significantly
 less explored.
 \citet{DBLP:conf/mfcs/BoerRH99,DBLP:books/cu/RoeverBH2001} provide
 compositional systems for \emph{terminating} systems. We have instead
 adopted Lamport's paradigm of a single global invariant and local
 proof obligations as the systems we have in mind are tightly coupled
 and it is not obvious that the proofs would be easier on a decomposed
 system; see \citet[\S1.6.6]{DBLP:books/cu/RoeverBH2001} for a
 concurring opinion.
 
 Unlike the generic sequential program verification framework Simpl
 \citep{DBLP:conf/lpar/Schirmer04}, we do not support function calls,
 or a sophisticated account of state spaces. Moreover we do no
 meta-theory beyond showing the simple VCG is sound
 (\S\ref{sec:cimp-vcg}).
 
 \bibliographystyle{plainnat}
 \bibliography{root}
 \addcontentsline{toc}{section}{References}
 
 \end{document}
 
 %%% Local Variables:
 %%% mode: latex
 %%% TeX-master: t
 %%% End:
diff --git a/thys/ConcurrentIMP/ex/CIMP_locales.thy b/thys/ConcurrentIMP/ex/CIMP_locales.thy
new file mode 100644
--- /dev/null
+++ b/thys/ConcurrentIMP/ex/CIMP_locales.thy
@@ -0,0 +1,60 @@
+(*<*)
+theory CIMP_locales
+imports
+ "../CIMP"
+begin
+
+(*>*)
+section\<open> One locale per process \<close>
+
+text\<open>
+
+A sketch of what we're doing in \<open>ConcurrentGC\<close>, for quicker testing.
+
+FIXME write some lemmas that further exercise the generated thms.
+
+\<close>
+
+locale P1
+begin
+
+definition com :: "(unit, string, unit, nat) com" where
+  "com = \<lbrace>''A''\<rbrace> WHILE ((<) 0) DO \<lbrace>''B''\<rbrace> \<lfloor>\<lambda>s. s - 1\<rfloor> OD"
+
+intern_com com_def
+print_theorems (* P1.com_interned, P1.loc_defs *)
+
+locset_definition "loop = {B}"
+print_theorems (* P1.loop.memb, P1.loop_def *)
+thm locset_cache (* the two facts in P1.loop.memb *)
+
+definition "assertion = atS False loop"
+
+end
+
+thm locset_cache (* the two facts in P1.loop.memb *)
+
+locale P2
+begin
+
+thm locset_cache (* the two facts in P1.loop.memb *)
+
+definition com :: "(unit, string, unit, nat) com" where
+  "com = \<lbrace>''C''\<rbrace> WHILE ((<) 0) DO \<lbrace>''A''\<rbrace> \<lfloor>Suc\<rfloor> OD"
+
+intern_com com_def
+locset_definition "loop = {A}"
+print_theorems
+
+end
+
+thm locset_cache (* four facts: P1.loop.memb, P2.loop.memb *)
+
+primrec coms :: "bool \<Rightarrow> (unit, string, unit, nat) com" where
+  "coms False = P1.com"
+| "coms True = P2.com"
+
+(*<*)
+
+end
+(*>*)
diff --git a/thys/ConcurrentIMP/ex/CIMP_one_place_buffer.thy b/thys/ConcurrentIMP/ex/CIMP_one_place_buffer.thy
new file mode 100644
--- /dev/null
+++ b/thys/ConcurrentIMP/ex/CIMP_one_place_buffer.thy
@@ -0,0 +1,165 @@
+(*<*)
+(*
+ * Copyright 2015, NICTA
+ *
+ * This software may be distributed and modified according to the terms of
+ * the BSD 2-Clause license. Note that NO WARRANTY is provided.
+ * See "LICENSE_BSD2.txt" for details.
+ *
+ * @TAG(NICTA_BSD)
+ *)
+
+theory CIMP_one_place_buffer
+imports
+  "../CIMP"
+begin
+
+(*>*)
+section\<open>Example: a one-place buffer \label{sec:one_place_buffer}\<close>
+
+text\<open>
+
+To demonstrate the CIMP reasoning infrastructure, we treat the trivial
+one-place buffer example of @{cite [cite_macro=citet]
+\<open>\S3.3\<close> "DBLP:journals/toplas/LamportS84"}. Note that the
+semantics for our language is different to @{cite
+[cite_macro=citeauthor] "DBLP:journals/toplas/LamportS84"}'s, who
+treated a historical variant of CSP (i.e., not the one in @{cite
+"Hoare:1985"}).
+
+We introduce some syntax for fixed-topology (static channel-based)
+scenarios.
+
+\<close>
+
+abbreviation
+  rcv_syn :: "'location \<Rightarrow> 'channel \<Rightarrow> ('val \<Rightarrow> 'state \<Rightarrow> 'state)
+           \<Rightarrow> (unit, 'location, 'channel \<times> 'val, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleright>_" [0,0,81] 81)
+where
+  "\<lbrace>l\<rbrace> ch\<triangleright>f \<equiv> \<lbrace>l\<rbrace> Response (\<lambda>q s. if fst q = ch then {(f (snd q) s, ())} else {})"
+
+abbreviation
+  snd_syn :: "'location \<Rightarrow> 'channel \<Rightarrow> ('state \<Rightarrow> 'val)
+          \<Rightarrow> (unit, 'location, 'channel \<times> 'val, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleleft>_" [0,0,81] 81)
+where
+  "\<lbrace>l\<rbrace> ch\<triangleleft>f \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (ch, f s)) (\<lambda>ans s. {s})"
+
+text\<open>
+
+These definitions largely follow @{cite [cite_macro=citet]
+"DBLP:journals/toplas/LamportS84"}. We have three processes
+communicating over two channels. We enumerate program locations.
+
+\<close>
+
+datatype ex_chname = \<xi>12 | \<xi>23
+type_synonym ex_val = nat
+type_synonym ex_ch = "ex_chname \<times> ex_val"
+datatype ex_loc = r12 | r23 | s23 | s12
+datatype ex_proc = p1 | p2 | p3
+
+type_synonym ex_pgm = "(unit, ex_loc, ex_ch, ex_val) com"
+type_synonym ex_pred = "(unit, ex_loc, ex_proc, ex_ch, ex_val) state_pred"
+type_synonym ex_state = "(unit, ex_loc, ex_proc, ex_ch, ex_val) system_state"
+type_synonym ex_sys = "(unit, ex_loc, ex_proc, ex_ch, ex_val) system"
+type_synonym ex_history = "(ex_ch \<times> unit) list"
+
+text\<open>
+
+We further specialise these for our particular example.
+
+\<close>
+
+primrec
+  ex_coms :: "ex_proc \<Rightarrow> ex_pgm"
+where
+  "ex_coms p1 = \<lbrace>s12\<rbrace> \<xi>12\<triangleleft>id"
+| "ex_coms p2 = LOOP DO \<lbrace>r12\<rbrace> \<xi>12\<triangleright>(\<lambda>v _. v) ;; \<lbrace>s23\<rbrace> \<xi>23\<triangleleft>id OD"
+| "ex_coms p3 = \<lbrace>r23\<rbrace> \<xi>23\<triangleright>(\<lambda>v _. v)"
+
+text\<open>
+
+Each process starts with an arbitrary initial local state.
+
+\<close>
+
+abbreviation ex_init :: "(ex_proc \<Rightarrow> ex_val) \<Rightarrow> bool" where
+  "ex_init \<equiv> \<langle>True\<rangle>"
+
+abbreviation sys :: ex_sys where
+  "sys \<equiv> \<lparr>PGMs = ex_coms, INIT = ex_init, FAIR = \<langle>True\<rangle>\<rparr>" (* FIXME add fairness hypotheses *)
+
+text\<open>
+
+The following adapts Kai Engelhardt's, from his notes titled
+\emph{Proving an Asynchronous Message Passing Program Correct},
+2011. The history variable tracks the causality of the system, which I
+feel is missing in Lamport's treatment. We tack on Lamport's invariant
+so we can establish \<open>Etern_pred\<close>.
+
+\<close>
+
+abbreviation
+  filter_on_channel :: "ex_chname \<Rightarrow> ex_state \<Rightarrow> ex_val list" ("\<downharpoonright>_" [100] 101)
+where
+  "\<downharpoonright>ch \<equiv> map (snd \<circ> fst) \<circ> filter ((=) ch \<circ> fst \<circ> fst) \<circ> HST"
+
+definition IL :: ex_pred where
+  "IL = pred_conjoin [
+       at p1 s12 \<^bold>\<longrightarrow> LIST_NULL \<downharpoonright>\<xi>12
+     , terminated p1 \<^bold>\<longrightarrow> \<downharpoonright>\<xi>12 \<^bold>= (\<lambda>s. [s\<down> p1])
+     , at p2 r12 \<^bold>\<longrightarrow> \<downharpoonright>\<xi>12 \<^bold>= \<downharpoonright>\<xi>23
+     , at p2 s23 \<^bold>\<longrightarrow> \<downharpoonright>\<xi>12 \<^bold>= \<downharpoonright>\<xi>23 \<^bold>@ (\<lambda>s. [s\<down> p2]) \<^bold>\<and> (\<lambda>s. s\<down> p1 = s\<down> p2)
+     , at p3 r23 \<^bold>\<longrightarrow> LIST_NULL \<downharpoonright>\<xi>23
+     , terminated p3 \<^bold>\<longrightarrow> \<downharpoonright>\<xi>23 \<^bold>= (\<lambda>s. [s\<down> p2]) \<^bold>\<and> (\<lambda>s. s\<down> p1 = s\<down> p3)
+     ]"
+
+text\<open>
+
+If @{const p3} terminates, then it has @{const p1}'s value. This is
+stronger than @{cite [cite_macro=citeauthor]
+"DBLP:journals/toplas/LamportS84"}'s as we don't ask that the first
+process has also terminated.
+
+\<close>
+
+definition Etern_pred :: ex_pred where
+  "Etern_pred = (terminated p3 \<^bold>\<longrightarrow> (\<lambda>s. s\<down> p1 = s\<down> p3))"
+
+text\<open>
+
+Proofs from here down.
+
+\<close>
+
+lemma correct_system:
+  assumes "IL sh"
+  shows "Etern_pred sh"
+using assms unfolding Etern_pred_def IL_def by simp
+
+lemma IL_p1: "ex_coms, p1, lconst {} \<turnstile> \<lbrace>IL\<rbrace> \<lbrace>s12\<rbrace> \<xi>12\<triangleleft>(\<lambda>s. s)"
+apply (rule vcg.intros)
+apply (rename_tac p')
+apply (case_tac p'; clarsimp simp: IL_def atLs_def)
+done
+
+lemma IL_p2: "ex_coms, p2, lconst {r12} \<turnstile> \<lbrace>IL\<rbrace> \<lbrace>s23\<rbrace> \<xi>23\<triangleleft>(\<lambda>s. s)"
+apply (rule vcg.intros)
+apply (rename_tac p')
+apply (case_tac p'; clarsimp simp: IL_def)
+done
+
+lemma IL: "sys \<Turnstile>\<^bsub>pre\<^esub> IL"
+apply (rule VCG)
+ apply (clarsimp simp: IL_def atLs_def dest!: initial_stateD)
+apply (rename_tac p)
+apply (case_tac p; clarsimp simp: IL_p1 IL_p2)
+done
+
+lemma IL_valid: "sys \<Turnstile> \<box>\<lceil>IL\<rceil>"
+by (rule valid_prerun_lift[OF IL])
+
+(*<*)
+
+end
+(*>*)
diff --git a/thys/ConcurrentIMP/ex/CIMP_unbounded_buffer.thy b/thys/ConcurrentIMP/ex/CIMP_unbounded_buffer.thy
new file mode 100644
--- /dev/null
+++ b/thys/ConcurrentIMP/ex/CIMP_unbounded_buffer.thy
@@ -0,0 +1,145 @@
+(*<*)
+(*
+ * Copyright 2015, NICTA
+ *
+ * This software may be distributed and modified according to the terms of
+ * the BSD 2-Clause license. Note that NO WARRANTY is provided.
+ * See "LICENSE_BSD2.txt" for details.
+ *
+ * @TAG(NICTA_BSD)
+ *)
+
+theory CIMP_unbounded_buffer
+imports
+  "../CIMP"
+  "HOL-Library.Prefix_Order"
+begin
+
+abbreviation (input)
+  Receive :: "'location \<Rightarrow> 'channel \<Rightarrow> ('val \<Rightarrow> 'state \<Rightarrow> 'state)
+             \<Rightarrow> (unit, 'location, 'channel \<times> 'val, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleright>_" [0,0,81] 81)
+where
+  "\<lbrace>l\<rbrace> ch\<triangleright>f \<equiv> \<lbrace>l\<rbrace> Response (\<lambda>q s. if fst q = ch then {(f (snd q) s, ())} else {})"
+
+abbreviation (input)
+  Send :: "'location \<Rightarrow> 'channel \<Rightarrow> ('state \<Rightarrow> 'val) \<times> ('state \<Rightarrow> 'state)
+          \<Rightarrow> (unit, 'location, 'channel \<times> 'val, 'state) com" ("\<lbrace>_\<rbrace>/ _\<triangleleft>_" [0,0,81] 81)
+where
+  "\<lbrace>l\<rbrace> ch\<triangleleft>f \<equiv> \<lbrace>l\<rbrace> Request (\<lambda>s. (ch, fst f s)) (\<lambda>ans s. {snd f s})"
+
+(*>*)
+section\<open>Example: an unbounded buffer \label{sec:unbounded_buffer}\<close>
+
+text\<open>
+
+This is more literally Kai Engelhardt's example from his notes titled
+\emph{Proving an Asynchronous Message Passing Program Correct}, 2011.
+
+\<close>
+
+datatype ex_chname = \<xi>12 | \<xi>23
+type_synonym ex_val = nat
+type_synonym ex_ls = "ex_val list"
+type_synonym ex_ch = "ex_chname \<times> ex_val"
+datatype ex_loc = c1 | r12 | r23 | s23 | s12
+datatype ex_proc = p1 | p2 | p3
+
+type_synonym ex_pgm = "(unit, ex_loc, ex_ch, ex_ls) com"
+type_synonym ex_pred = "(unit, ex_loc, ex_proc, ex_ch, ex_ls) state_pred"
+type_synonym ex_state = "(unit, ex_loc, ex_proc, ex_ch, ex_ls) system_state"
+type_synonym ex_sys = "(unit, ex_loc, ex_proc, ex_ch, ex_ls) system"
+type_synonym ex_history = "(ex_ch \<times> unit) list"
+
+text\<open>
+
+The local state for the producer process contains all values produced; consider that ghost state.
+
+\<close>
+
+abbreviation (input) snoc :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where "snoc x xs \<equiv> xs @ [x]"
+
+primrec ex_coms :: "ex_proc \<Rightarrow> ex_pgm" where
+  "ex_coms p1 = LOOP DO \<lbrace>c1\<rbrace> LocalOp (\<lambda>xs. {snoc x xs |x. True}) ;; \<lbrace>s12\<rbrace> \<xi>12\<triangleleft>(last, id) OD"
+| "ex_coms p2 = LOOP DO \<lbrace>r12\<rbrace> \<xi>12\<triangleright>snoc
+                      \<oplus> \<lbrace>c1\<rbrace> IF (\<lambda>s. length s > 0) THEN \<lbrace>s23\<rbrace> \<xi>12\<triangleleft>(hd, tl) FI
+                     OD"
+| "ex_coms p3 = LOOP DO \<lbrace>r23\<rbrace> \<xi>23\<triangleright>snoc OD"
+
+abbreviation ex_init :: "(ex_proc \<Rightarrow> ex_ls) \<Rightarrow> bool" where
+  "ex_init s \<equiv> \<forall>p. s p = []"
+
+abbreviation sys :: ex_sys where
+  "sys \<equiv> \<lparr>PGMs = ex_coms, INIT = ex_init, FAIR = \<langle>True\<rangle>\<rparr>" (* FIXME add fairness hypotheses *)
+
+abbreviation
+  filter_on_channel :: "ex_chname \<Rightarrow> ex_state \<Rightarrow> ex_val list" ("\<downharpoonright>_" [100] 101)
+where
+  "\<downharpoonright>ch \<equiv> map (snd \<circ> fst) \<circ> filter ((=) ch \<circ> fst \<circ> fst) \<circ> HST"
+
+definition I_pred :: ex_pred where
+  "I_pred = pred_conjoin [
+       at p1 c1 \<^bold>\<longrightarrow> \<downharpoonright>\<xi>12 \<^bold>= (\<lambda>s. s\<down> p1)
+     , at p1 s12 \<^bold>\<longrightarrow> (\<lambda>s. length (s\<down> p1) > 0 \<and> butlast (s\<down> p1) = (\<downharpoonright>\<xi>12) s)
+     , \<downharpoonright>\<xi>12 \<^bold>\<le> (\<lambda>s. s\<down> p1)
+     , \<downharpoonright>\<xi>12 \<^bold>= \<downharpoonright>\<xi>23 \<^bold>@ (\<lambda>s. s\<down> p2)
+     , at p2 s23 \<^bold>\<longrightarrow> (\<lambda>s. length (s\<down> p2) > 0)
+     , (\<lambda>s. s\<down> p3) \<^bold>= \<downharpoonright>\<xi>23
+     ]"
+
+text\<open>
+
+The local state of @{const "p3"} is some prefix of the local state of
+@{const "p1"}.
+
+\<close>
+
+definition Etern_pred :: ex_pred where
+  "Etern_pred \<equiv> \<lambda>s. s\<down> p3 \<le> s\<down> p1"
+
+lemma correct_system:
+  assumes "I_pred s"
+  shows "Etern_pred s"
+using assms unfolding Etern_pred_def I_pred_def less_eq_list_def prefix_def by clarsimp
+
+lemma p1_c1[simplified, intro]:
+  "ex_coms, p1, lconst {s12} \<turnstile> \<lbrace>I_pred\<rbrace> \<lbrace>c1\<rbrace> LocalOp (\<lambda>xs. { snoc x xs |x. True })"
+apply (rule vcg.intros)
+apply (clarsimp simp: I_pred_def atS_def)
+done
+
+lemma p1_s12[simplified, intro]:
+  "ex_coms, p1, lconst {c1} \<turnstile> \<lbrace>I_pred\<rbrace> \<lbrace>s12\<rbrace> \<xi>12\<triangleleft>(last, id)"
+apply (rule vcg.intros)
+apply (rename_tac p')
+apply (case_tac p'; clarsimp)
+apply (clarsimp simp: I_pred_def atS_def)
+apply (metis Prefix_Order.prefix_snoc append.assoc append_butlast_last_id)
+done
+
+lemma p2_s23[simplified, intro]:
+  "ex_coms, p2, lconst {c1, r12} \<turnstile> \<lbrace>I_pred\<rbrace> \<lbrace>s23\<rbrace> \<xi>12\<triangleleft>(hd, tl)"
+apply (rule vcg.intros)
+apply (rename_tac p')
+apply (case_tac p'; clarsimp)
+done
+
+lemma p2_pi4[intro]:
+  "ex_coms, p2, lcond {s23} {c1, r12} (\<lambda>s. s \<noteq> []) \<turnstile> \<lbrace>I_pred\<rbrace> \<lbrace>c1\<rbrace> IF (\<lambda>s. s \<noteq> []) THEN c' FI"
+apply (rule vcg.intros)
+apply (clarsimp simp: I_pred_def atS_def split: lcond_splits)
+done
+
+lemma I: "sys \<Turnstile>\<^bsub>pre\<^esub> I_pred"
+apply (rule VCG)
+ apply (clarsimp dest!: initial_stateD simp: I_pred_def atS_def)
+apply (rename_tac p)
+apply (case_tac p; auto)
+done
+
+lemma I_valid: "sys \<Turnstile> \<box>\<lceil>I_pred\<rceil>"
+by (rule valid_prerun_lift[OF I])
+
+(*<*)
+
+end
+(*>*)