Theory utp_concurrency

section ‹ Concurrent Programming ›

theory utp_concurrency
  imports
    utp_hoare
    utp_rel
    utp_tactics
    utp_theory
begin

text ‹ In this theory we describe the UTP scheme for concurrency, \emph{parallel-by-merge},
  which provides a general parallel operator parametrised by a ``merge predicate'' that explains
  how to merge the after states of the composed predicates. It can thus be applied to many languages
  and concurrency schemes, with this theory providing a number of generic laws. The operator is
  explained in more detail in Chapter 7 of the UTP book~\<^cite>‹"Hoare&98"›. ›
  
subsection ‹ Variable Renamings ›

text ‹ In parallel-by-merge constructions, a merge predicate defines the behaviour following execution of
  of parallel processes, $P \parallel Q$, as a relation that merges the output of $P$ and $Q$. In order 
  to achieve this we need to separate the variable values output from $P$ and $Q$, and in addition the 
  variable values before execution. The following three constructs do these separations. The initial
  state-space before execution is @{typ "'α"}, the final state-space after the first parallel process
  is @{typ "'β⇩0"}, and the final state-space for the second is @{typ "'β⇩1"}. These three functions
  lift variables on these three state-spaces, respectively.
›

alphabet ('α, 'β⇩0, 'β⇩1) mrg =
  mrg_prior :: "'α"
  mrg_left  :: "'β⇩0"
  mrg_right  :: "'β⇩1"
    
definition pre_uvar :: "('a ⟹ 'α) ⇒ ('a ⟹ ('α, 'β⇩0, 'β⇩1) mrg)" where
[upred_defs]: "pre_uvar x = x ;⇩L mrg_prior"
  
definition left_uvar :: "('a ⟹ 'β⇩0) ⇒ ('a ⟹ ('α, 'β⇩0, 'β⇩1) mrg)" where
[upred_defs]: "left_uvar x = x ;⇩L mrg_left"

definition right_uvar :: "('a ⟹ 'β⇩1) ⇒ ('a ⟹ ('α, 'β⇩0, 'β⇩1) mrg)" where
[upred_defs]: "right_uvar x = x ;⇩L mrg_right"

text ‹ We set up syntax for the three variable classes using a subscript $<$, $0$-$x$, and $1$-$x$,
  respectively. › 

syntax
  "_svarpre"   :: "svid ⇒ svid" (‹_⇩<› [995] 995)
  "_svarleft"  :: "svid ⇒ svid" (‹0-_› [995] 995)
  "_svarright" :: "svid ⇒ svid" (‹1-_› [995] 995)

syntax_consts
  "_svarpre" ⇌ pre_uvar and
  "_svarleft" ⇌ left_uvar and
  "_svarright" ⇌ right_uvar

translations
  "_svarpre x"   == "CONST pre_uvar x"
  "_svarleft x"  == "CONST left_uvar x"
  "_svarright x" == "CONST right_uvar x"
  "_svarpre Σ"   <= "CONST pre_uvar 1⇩L"
  "_svarleft Σ"  <= "CONST left_uvar 1⇩L"
  "_svarright Σ" <= "CONST right_uvar 1⇩L"  
  
text ‹ We proved behavedness closure properties about the lenses. ›
  
lemma left_uvar [simp]: "vwb_lens x ⟹ vwb_lens (left_uvar x)"
  by (simp add: left_uvar_def )

lemma right_uvar [simp]: "vwb_lens x ⟹ vwb_lens (right_uvar x)"
  by (simp add: right_uvar_def)

lemma pre_uvar [simp]: "vwb_lens x ⟹ vwb_lens (pre_uvar x)"
  by (simp add: pre_uvar_def)

lemma left_uvar_mwb [simp]: "mwb_lens x ⟹ mwb_lens (left_uvar x)"
  by (simp add: left_uvar_def )

lemma right_uvar_mwb [simp]: "mwb_lens x ⟹ mwb_lens (right_uvar x)"
  by (simp add: right_uvar_def)

lemma pre_uvar_mwb [simp]: "mwb_lens x ⟹ mwb_lens (pre_uvar x)"
  by (simp add: pre_uvar_def)
  
text ‹ We prove various independence laws about the variable classes. ›
  
lemma left_uvar_indep_right_uvar [simp]:
  "left_uvar x ⨝ right_uvar y"
  by (simp add: left_uvar_def right_uvar_def lens_comp_assoc[THEN sym])

lemma left_uvar_indep_pre_uvar [simp]:
  "left_uvar x ⨝ pre_uvar y"
  by (simp add: left_uvar_def pre_uvar_def)

lemma left_uvar_indep_left_uvar [simp]:
  "x ⨝ y ⟹ left_uvar x ⨝ left_uvar y"
  by (simp add: left_uvar_def)

lemma right_uvar_indep_left_uvar [simp]:
  "right_uvar x ⨝ left_uvar y"
  by (simp add: lens_indep_sym)

lemma right_uvar_indep_pre_uvar [simp]:
  "right_uvar x ⨝ pre_uvar y"
  by (simp add: right_uvar_def pre_uvar_def)

lemma right_uvar_indep_right_uvar [simp]:
  "x ⨝ y ⟹ right_uvar x ⨝ right_uvar y"
  by (simp add: right_uvar_def)

lemma pre_uvar_indep_left_uvar [simp]:
  "pre_uvar x ⨝ left_uvar y"
  by (simp add: lens_indep_sym)

lemma pre_uvar_indep_right_uvar [simp]:
  "pre_uvar x ⨝ right_uvar y"
  by (simp add: lens_indep_sym)

lemma pre_uvar_indep_pre_uvar [simp]:
  "x ⨝ y ⟹ pre_uvar x ⨝ pre_uvar y"
  by (simp add: pre_uvar_def)

subsection ‹ Merge Predicates ›

text ‹ A merge predicate is a relation whose input has three parts: the prior variables, the output
  variables of the left predicate, and the output of the right predicate. ›
  
type_synonym 'α merge = "(('α, 'α, 'α) mrg, 'α) urel"
  
text ‹ skip is the merge predicate which ignores the output of both parallel predicates ›

definition skip⇩m :: "'α merge" where
[upred_defs]: "skip⇩m = ($❙v´ =⇩u $❙v⇩<)"

text ‹ swap is a predicate that the swaps the left and right indices; it is used to specify
        commutativity of the parallel operator ›

definition swap⇩m :: "(('α, 'β, 'β) mrg) hrel" where
[upred_defs]: "swap⇩m = (0-❙v,1-❙v) := (&1-❙v,&0-❙v)"

text ‹ A symmetric merge is one for which swapping the order of the merged concurrent predicates
  has no effect. We represent this by the following healthiness condition that states that
  @{term "swap⇩m"} is a left-unit. ›

abbreviation SymMerge :: "'α merge ⇒ 'α merge" where
"SymMerge(M) ≡ (swap⇩m ;; M)"

subsection ‹ Separating Simulations ›

text ‹ U0 and U1 are relations modify the variables of the input state-space such that they become 
  indexed with $0$ and $1$, respectively. ›

definition U0 :: "('β⇩0, ('α, 'β⇩0, 'β⇩1) mrg) urel" where
[upred_defs]: "U0 = ($0-❙v´ =⇩u $❙v)"

definition U1 :: "('β⇩1, ('α, 'β⇩0, 'β⇩1) mrg) urel" where
[upred_defs]: "U1 = ($1-❙v´ =⇩u $❙v)"

lemma U0_swap: "(U0 ;; swap⇩m) = U1"
  by (rel_auto)

lemma U1_swap: "(U1 ;; swap⇩m) = U0"
  by (rel_auto)

text ‹ As shown below, separating simulations can also be expressed using the following two 
  alphabet extrusions ›

definition U0α where [upred_defs]: "U0α = (1⇩L ×⇩L mrg_left)"

definition U1α where [upred_defs]: "U1α = (1⇩L ×⇩L mrg_right)"

text ‹ We then create the following intuitive syntax for separating simulations. ›
  
abbreviation U0_alpha_lift (‹⌈_⌉⇩0›) where "⌈P⌉⇩0 ≡ P ⊕⇩p U0α"

abbreviation U1_alpha_lift (‹⌈_⌉⇩1›) where "⌈P⌉⇩1 ≡ P ⊕⇩p U1α"
  
text ‹ @{term "⌈P⌉⇩0"} is predicate $P$ where all variables are indexed by $0$, and 
  @{term "⌈P⌉⇩1"} is where all variables are indexed by $1$. We can thus equivalently express separating 
  simulations using alphabet extrusion. ›
  
lemma U0_as_alpha: "(P ;; U0) = ⌈P⌉⇩0"
  by (rel_auto)

lemma U1_as_alpha: "(P ;; U1) = ⌈P⌉⇩1"
  by (rel_auto)

lemma U0α_vwb_lens [simp]: "vwb_lens U0α"
  by (simp add: U0α_def id_vwb_lens prod_vwb_lens)

lemma U1α_vwb_lens [simp]: "vwb_lens U1α"
  by (simp add: U1α_def id_vwb_lens prod_vwb_lens)

lemma U0α_indep_right_uvar [simp]: "vwb_lens x ⟹ U0α ⨝ out_var (right_uvar x)"
  by (force intro: plus_pres_lens_indep fst_snd_lens_indep lens_indep_left_comp
            simp add: U0α_def right_uvar_def out_var_def prod_as_plus lens_comp_assoc[THEN sym])

lemma U1α_indep_left_uvar [simp]: "vwb_lens x ⟹ U1α ⨝ out_var (left_uvar x)"
  by (force intro: plus_pres_lens_indep fst_snd_lens_indep lens_indep_left_comp
            simp add: U1α_def left_uvar_def out_var_def prod_as_plus lens_comp_assoc[THEN sym])

lemma U0_alpha_lift_bool_subst [usubst]:
  "σ($0-x´ ↦⇩s true) † ⌈P⌉⇩0 = σ † ⌈P⟦true/$x´⟧⌉⇩0"
  "σ($0-x´ ↦⇩s false) † ⌈P⌉⇩0 = σ † ⌈P⟦false/$x´⟧⌉⇩0"
  by (pred_auto+)

lemma U1_alpha_lift_bool_subst [usubst]:
  "σ($1-x´ ↦⇩s true) † ⌈P⌉⇩1 = σ † ⌈P⟦true/$x´⟧⌉⇩1"
  "σ($1-x´ ↦⇩s false) † ⌈P⌉⇩1 = σ † ⌈P⟦false/$x´⟧⌉⇩1"
  by (pred_auto+)

lemma U0_alpha_out_var [alpha]: "⌈$x´⌉⇩0 = $0-x´"
  by (rel_auto)

lemma U1_alpha_out_var [alpha]: "⌈$x´⌉⇩1 = $1-x´"
  by (rel_auto)

lemma U0_skip [alpha]: "⌈II⌉⇩0 = ($0-❙v´ =⇩u $❙v)"
  by (rel_auto)

lemma U1_skip [alpha]: "⌈II⌉⇩1 = ($1-❙v´ =⇩u $❙v)"
  by (rel_auto)

lemma U0_seqr [alpha]: "⌈P ;; Q⌉⇩0 = P ;; ⌈Q⌉⇩0"
  by (rel_auto)

lemma U1_seqr [alpha]: "⌈P ;; Q⌉⇩1 = P ;; ⌈Q⌉⇩1"
  by (rel_auto)

lemma U0α_comp_in_var [alpha]: "(in_var x) ;⇩L U0α = in_var x"
  by (simp add: U0α_def alpha_in_var in_var_prod_lens pre_uvar_def)

lemma U0α_comp_out_var [alpha]: "(out_var x) ;⇩L U0α = out_var (left_uvar x)"
  by (simp add: U0α_def alpha_out_var id_wb_lens left_uvar_def out_var_prod_lens)

lemma U1α_comp_in_var [alpha]: "(in_var x) ;⇩L U1α = in_var x"
  by (simp add: U1α_def alpha_in_var in_var_prod_lens pre_uvar_def)

lemma U1α_comp_out_var [alpha]: "(out_var x) ;⇩L U1α = out_var (right_uvar x)"
  by (simp add: U1α_def alpha_out_var id_wb_lens right_uvar_def out_var_prod_lens)

subsection ‹ Associative Merges ›
  
text ‹ Associativity of a merge means that if we construct a three way merge from a two way merge
  and then rotate the three inputs of the merge to the left, then we get exactly the same three
  way merge back. 

  We first construct the operator that constructs the three way merge by effectively wiring up
  the two way merge in an appropriate way.
›
  
definition ThreeWayMerge :: "'α merge ⇒ (('α, 'α, ('α, 'α, 'α) mrg) mrg, 'α) urel" (‹❙M3'(_')›) where
[upred_defs]: "ThreeWayMerge M = (($0-❙v´ =⇩u $0-❙v ∧ $1-❙v´ =⇩u $1-0-❙v ∧ $❙v⇩<´ =⇩u $❙v⇩<) ;; M ;; U0 ∧ $1-❙v´ =⇩u $1-1-❙v ∧ $❙v⇩<´ =⇩u $❙v⇩<) ;; M"
  
text ‹ The next definition rotates the inputs to a three way merge to the left one place. ›

abbreviation rotate⇩m where "rotate⇩m ≡ (0-❙v,1-0-❙v,1-1-❙v) := (&1-0-❙v,&1-1-❙v,&0-❙v)"

text ‹ Finally, a merge is associative if rotating the inputs does not effect the output. ›
  
definition AssocMerge :: "'α merge ⇒ bool" where
[upred_defs]: "AssocMerge M = (rotate⇩m ;; ❙M3(M) = ❙M3(M))"
    
subsection ‹ Parallel Operators ›

text ‹ We implement the following useful abbreviation for separating of two parallel processes and
  copying of the before variables, all to act as input to the merge predicate. ›

abbreviation par_sep (infixr ‹∥⇩s› 85) where
"P ∥⇩s Q ≡ (P ;; U0) ∧ (Q ;; U1) ∧ $❙v⇩<´ =⇩u $❙v"

text ‹ The following implementation of parallel by merge is less general than the book version, in
  that it does not properly partition the alphabet into two disjoint segments. We could actually
  achieve this specifying lenses into the larger alphabet, but this would complicate the definition
  of programs. May reconsider later. ›

definition 
  par_by_merge :: "('α, 'β) urel ⇒ (('α, 'β, 'γ) mrg, 'δ) urel ⇒ ('α, 'γ) urel ⇒ ('α, 'δ) urel" 
  (‹_ ∥⇘_⇙ _› [85,0,86] 85)
where [upred_defs]: "P ∥⇘M⇙ Q = (P ∥⇩s Q ;; M)"

lemma par_by_merge_alt_def: "P ∥⇘M⇙ Q = (⌈P⌉⇩0 ∧ ⌈Q⌉⇩1 ∧ $❙v⇩<´ =⇩u $❙v) ;; M"
  by (simp add: par_by_merge_def U0_as_alpha U1_as_alpha)

lemma shEx_pbm_left: "((❙∃ x ∙ P x) ∥⇘M⇙ Q) = (❙∃ x ∙ (P x ∥⇘M⇙ Q))"
  by (rel_auto)

lemma shEx_pbm_right: "(P ∥⇘M⇙ (❙∃ x ∙ Q x)) = (❙∃ x ∙ (P ∥⇘M⇙ Q x))"
  by (rel_auto)

subsection ‹ Unrestriction Laws ›
  
lemma unrest_in_par_by_merge [unrest]:
  "⟦ $x ♯ P; $x⇩< ♯ M; $x ♯ Q ⟧ ⟹ $x ♯ P ∥⇘M⇙ Q"
  by (rel_auto, fastforce+)

lemma unrest_out_par_by_merge [unrest]:
  "⟦ $x´ ♯ M ⟧ ⟹ $x´ ♯ P ∥⇘M⇙ Q"
  by (rel_auto)
    
subsection ‹ Substitution laws ›

text ‹ Substitution is a little tricky because when we push the expression through the composition
  operator the alphabet of the expression must also change. Consequently for now we only support
  literal substitution, though this could be generalised with suitable alphabet coercsions. We
  need quite a number of variants to support this which are below. ›

lemma U0_seq_subst: "(P ;; U0)⟦«v»/$0-x´⟧ = (P⟦«v»/$x´⟧ ;; U0)"
  by (rel_auto)

lemma U1_seq_subst: "(P ;; U1)⟦«v»/$1-x´⟧ = (P⟦«v»/$x´⟧ ;; U1)"
  by (rel_auto)

lemma lit_pbm_subst [usubst]:
  fixes x :: "(_ ⟹ 'α)"
  shows
    "⋀ P Q M σ. σ($x ↦⇩s «v») † (P ∥⇘M⇙ Q) = σ † ((P⟦«v»/$x⟧) ∥⇘M⟦«v»/$x⇩<⟧⇙ (Q⟦«v»/$x⟧))"
    "⋀ P Q M σ. σ($x´ ↦⇩s «v») † (P ∥⇘M⇙ Q) = σ † (P ∥⇘M⟦«v»/$x´⟧⇙ Q)"
  by (rel_auto)+

lemma bool_pbm_subst [usubst]:
  fixes x :: "(_ ⟹ 'α)"
  shows
    "⋀ P Q M σ. σ($x ↦⇩s false) † (P ∥⇘M⇙ Q) = σ † ((P⟦false/$x⟧) ∥⇘M⟦false/$x⇩<⟧⇙ (Q⟦false/$x⟧))"
    "⋀ P Q M σ. σ($x ↦⇩s true) † (P ∥⇘M⇙ Q) = σ † ((P⟦true/$x⟧) ∥⇘M⟦true/$x⇩<⟧⇙ (Q⟦true/$x⟧))"
    "⋀ P Q M σ. σ($x´ ↦⇩s false) † (P ∥⇘M⇙ Q) = σ † (P ∥⇘M⟦false/$x´⟧⇙ Q)"
    "⋀ P Q M σ. σ($x´ ↦⇩s true) † (P ∥⇘M⇙ Q) = σ † (P ∥⇘M⟦true/$x´⟧⇙ Q)"
  by (rel_auto)+

lemma zero_one_pbm_subst [usubst]:
  fixes x :: "(_ ⟹ 'α)"
  shows
    "⋀ P Q M σ. σ($x ↦⇩s 0) † (P ∥⇘M⇙ Q) = σ † ((P⟦0/$x⟧) ∥⇘M⟦0/$x⇩<⟧⇙ (Q⟦0/$x⟧))"
    "⋀ P Q M σ. σ($x ↦⇩s 1) † (P ∥⇘M⇙ Q) = σ † ((P⟦1/$x⟧) ∥⇘M⟦1/$x⇩<⟧⇙ (Q⟦1/$x⟧))"
    "⋀ P Q M σ. σ($x´ ↦⇩s 0) † (P ∥⇘M⇙ Q) = σ † (P ∥⇘M⟦0/$x´⟧⇙ Q)"
    "⋀ P Q M σ. σ($x´ ↦⇩s 1) † (P ∥⇘M⇙ Q) = σ † (P ∥⇘M⟦1/$x´⟧⇙ Q)"
  by (rel_auto)+

lemma numeral_pbm_subst [usubst]:
  fixes x :: "(_ ⟹ 'α)"
  shows
    "⋀ P Q M σ. σ($x ↦⇩s numeral n) † (P ∥⇘M⇙ Q) = σ † ((P⟦numeral n/$x⟧) ∥⇘M⟦numeral n/$x⇩<⟧⇙ (Q⟦numeral n/$x⟧))"
    "⋀ P Q M σ. σ($x´ ↦⇩s numeral n) † (P ∥⇘M⇙ Q) = σ † (P ∥⇘M⟦numeral n/$x´⟧⇙ Q)"
  by (rel_auto)+

subsection ‹ Parallel-by-merge laws ›

lemma par_by_merge_false [simp]:
  "P ∥⇘false⇙ Q = false"
  by (rel_auto)

lemma par_by_merge_left_false [simp]:
  "false ∥⇘M⇙ Q = false"
  by (rel_auto)

lemma par_by_merge_right_false [simp]:
  "P ∥⇘M⇙ false = false"
  by (rel_auto)

lemma par_by_merge_seq_add: "(P ∥⇘M⇙ Q) ;; R = (P ∥⇘M ;; R⇙ Q)"
  by (simp add: par_by_merge_def seqr_assoc)

text ‹ A skip parallel-by-merge yields a skip whenever the parallel predicates are both feasible. ›

lemma par_by_merge_skip:
  assumes "P ;; true = true" "Q ;; true = true"
  shows "P ∥⇘skip⇩m⇙ Q = II"
  using assms by (rel_auto)

lemma skip_merge_swap: "swap⇩m ;; skip⇩m = skip⇩m"
  by (rel_auto)

lemma par_sep_swap: "P ∥⇩s Q ;; swap⇩m = Q ∥⇩s P"
  by (rel_auto)
        
text ‹ Parallel-by-merge commutes when the merge predicate is unchanged by swap ›

lemma par_by_merge_commute_swap:
  shows "P ∥⇘M⇙ Q = Q ∥⇘swap⇩m ;; M⇙ P"
proof -
  have "Q ∥⇘swap⇩m ;; M⇙ P = ((((Q ;; U0) ∧ (P ;; U1) ∧ $❙v⇩<´ =⇩u $❙v) ;; swap⇩m) ;; M)"
    by (simp add: par_by_merge_def seqr_assoc)
  also have "... = (((Q ;; U0 ;; swap⇩m) ∧ (P ;; U1 ;; swap⇩m) ∧ $❙v⇩<´ =⇩u $❙v) ;; M)"
    by (rel_auto)
  also have "... = (((Q ;; U1) ∧ (P ;; U0) ∧ $❙v⇩<´ =⇩u $❙v) ;; M)"
    by (simp add: U0_swap U1_swap)
  also have "... = P ∥⇘M⇙ Q"
    by (simp add: par_by_merge_def utp_pred_laws.inf.left_commute)
  finally show ?thesis ..
qed

theorem par_by_merge_commute:
  assumes "M is SymMerge"
  shows "P ∥⇘M⇙ Q = Q ∥⇘M⇙ P"
  by (metis Healthy_if assms par_by_merge_commute_swap)
    
lemma par_by_merge_mono_1:
  assumes "P⇩1 ⊑ P⇩2"
  shows "P⇩1 ∥⇘M⇙ Q ⊑ P⇩2 ∥⇘M⇙ Q"
  using assms by (rel_auto)

lemma par_by_merge_mono_2:
  assumes "Q⇩1 ⊑ Q⇩2"
  shows "(P ∥⇘M⇙ Q⇩1) ⊑ (P ∥⇘M⇙ Q⇩2)"
  using assms by (rel_blast)

lemma par_by_merge_mono:
  assumes "P⇩1 ⊑ P⇩2" "Q⇩1 ⊑ Q⇩2"
  shows "P⇩1 ∥⇘M⇙ Q⇩1 ⊑ P⇩2 ∥⇘M⇙ Q⇩2"
  by (meson assms dual_order.trans par_by_merge_mono_1 par_by_merge_mono_2)

theorem par_by_merge_assoc: 
  assumes "M is SymMerge" "AssocMerge M"
  shows "(P ∥⇘M⇙ Q) ∥⇘M⇙ R = P ∥⇘M⇙ (Q ∥⇘M⇙ R)"
proof -
  have "(P ∥⇘M⇙ Q) ∥⇘M⇙ R = ((P ;; U0) ∧ (Q ;; U0 ;; U1) ∧ (R ;; U1 ;; U1) ∧ $❙v⇩<´ =⇩u $❙v) ;; ❙M3(M)"
    by (rel_blast)
  also have "... = ((P ;; U0) ∧ (Q ;; U0 ;; U1) ∧ (R ;; U1 ;; U1) ∧ $❙v⇩<´ =⇩u $❙v) ;; rotate⇩m ;; ❙M3(M)"
    using AssocMerge_def assms(2) by force
  also have "... = ((Q ;; U0) ∧ (R ;; U0 ;; U1) ∧ (P ;; U1 ;; U1) ∧ $❙v⇩<´ =⇩u $❙v) ;; ❙M3(M)"
    by (rel_blast)
  also have "... = (Q ∥⇘M⇙ R) ∥⇘M⇙ P"
    by (rel_blast)
  also have "... = P ∥⇘M⇙ (Q ∥⇘M⇙ R)"
    by (simp add: assms(1) par_by_merge_commute)
  finally show ?thesis .
qed
        
theorem par_by_merge_choice_left:
  "(P ⊓ Q) ∥⇘M⇙ R = (P ∥⇘M⇙ R) ⊓ (Q ∥⇘M⇙ R)"
  by (rel_auto)
  
theorem par_by_merge_choice_right:
  "P ∥⇘M⇙ (Q ⊓ R) = (P ∥⇘M⇙ Q) ⊓ (P ∥⇘M⇙ R)"
  by (rel_auto)

theorem par_by_merge_or_left:
  "(P ∨ Q) ∥⇘M⇙ R = (P ∥⇘M⇙ R ∨ Q ∥⇘M⇙ R)"
  by (rel_auto)
  
theorem par_by_merge_or_right:
  "P ∥⇘M⇙ (Q ∨ R) = (P ∥⇘M⇙ Q ∨ P ∥⇘M⇙ R)"
  by (rel_auto)
    
theorem par_by_merge_USUP_mem_left:
  "(⨅ i∈I ∙ P(i)) ∥⇘M⇙ Q = (⨅ i∈I ∙ P(i) ∥⇘M⇙ Q)"
  by (rel_auto)

theorem par_by_merge_USUP_ind_left:
  "(⨅ i ∙ P(i)) ∥⇘M⇙ Q = (⨅ i ∙ P(i) ∥⇘M⇙ Q)"
  by (rel_auto)
    
theorem par_by_merge_USUP_mem_right:
  "P ∥⇘M⇙ (⨅ i∈I ∙ Q(i)) = (⨅ i∈I ∙ P ∥⇘M⇙ Q(i))"
  by (rel_auto)

theorem par_by_merge_USUP_ind_right:
  "P ∥⇘M⇙ (⨅ i ∙ Q(i)) = (⨅ i ∙ P ∥⇘M⇙ Q(i))"
  by (rel_auto)
   
subsection ‹ Example: Simple State-Space Division ›
  
text ‹ The following merge predicate divides the state space using a pair of independent lenses. ›
  
definition StateMerge :: "('a ⟹ 'α) ⇒ ('b ⟹ 'α) ⇒ 'α merge" (‹M[_|_]⇩σ›) where
[upred_defs]: "M[a|b]⇩σ = ($❙v´ =⇩u ($❙v⇩< ⊕ $0-❙v on &a) ⊕ $1-❙v on &b)"

lemma swap_StateMerge: "a ⨝ b ⟹ (swap⇩m ;; M[a|b]⇩σ) = M[b|a]⇩σ"
  by (rel_auto, simp_all add: lens_indep_comm)
   
abbreviation StateParallel :: "'α hrel ⇒ ('a ⟹ 'α) ⇒ ('b ⟹ 'α) ⇒ 'α hrel ⇒ 'α hrel" (‹_ |_|_|⇩σ _› [85,0,0,86] 86)
where "P |a|b|⇩σ Q ≡ P ∥⇘M[a|b]⇩σ⇙ Q"
    
lemma StateParallel_commute: "a ⨝ b ⟹ P |a|b|⇩σ Q = Q |b|a|⇩σ P"
  by (metis par_by_merge_commute_swap swap_StateMerge)
        
lemma StateParallel_form: 
  "P |a|b|⇩σ Q = (❙∃ (st⇩0, st⇩1) ∙ P⟦«st⇩0»/$❙v´⟧ ∧ Q⟦«st⇩1»/$❙v´⟧ ∧ $❙v´ =⇩u ($❙v ⊕ «st⇩0» on &a) ⊕ «st⇩1» on &b)"
  by (rel_auto)

lemma StateParallel_form':
  assumes "vwb_lens a" "vwb_lens b" "a ⨝ b"
  shows "P |a|b|⇩σ Q = {&a,&b}:[(P ↾⇩v {$❙v,$a´}) ∧ (Q ↾⇩v {$❙v,$b´})]"
  using assms
  apply (simp add: StateParallel_form, rel_auto)
     apply (metis vwb_lens_wb wb_lens_axioms_def wb_lens_def)
    apply (metis vwb_lens_wb wb_lens.get_put)
   apply (simp add: lens_indep_comm)
  apply (metis (no_types, opaque_lifting) lens_indep_comm vwb_lens_wb wb_lens_def weak_lens.put_get)
  done  
  
text ‹ We can frame all the variables that the parallel operator refers to ›
    
lemma StateParallel_frame:
  assumes "vwb_lens a" "vwb_lens b" "a ⨝ b"
  shows "{&a,&b}:[P |a|b|⇩σ Q] = P |a|b|⇩σ Q"
  using assms
  apply (simp add: StateParallel_form, rel_auto)
  using lens_indep_comm apply fastforce+
  done

text ‹ Parallel Hoare logic rule. This employs something similar to separating conjunction in
  the postcondition, but we explicitly require that the two conjuncts only refer to variables
  on the left and right of the parallel composition explicitly. ›
  
theorem StateParallel_hoare [hoare]:
  assumes "⦃c⦄P⦃d⇩1⦄⇩u" "⦃c⦄Q⦃d⇩2⦄⇩u" "a ⨝ b" "a ♮ d⇩1" "b ♮ d⇩2"
  shows "⦃c⦄P |a|b|⇩σ Q⦃d⇩1 ∧ d⇩2⦄⇩u"
proof -
  ― ‹ Parallelise the specification ›
  from assms(4,5)
  have 1:"(⌈c⌉⇩< ⇒ ⌈d⇩1 ∧ d⇩2⌉⇩>) ⊑ (⌈c⌉⇩< ⇒ ⌈d⇩1⌉⇩>) |a|b|⇩σ (⌈c⌉⇩< ⇒ ⌈d⇩2⌉⇩>)" (is "?lhs ⊑ ?rhs")
    by (simp add: StateParallel_form, rel_auto, metis assms(3) lens_indep_comm)
  ― ‹ Prove Hoare rule by monotonicity of parallelism ›
  have 2:"?rhs ⊑ P |a|b|⇩σ Q"
  proof (rule par_by_merge_mono)
    show "(⌈c⌉⇩< ⇒ ⌈d⇩1⌉⇩>) ⊑ P"
      using assms(1) hoare_r_def by auto
    show "(⌈c⌉⇩< ⇒ ⌈d⇩2⌉⇩>) ⊑ Q"
      using assms(2) hoare_r_def by auto
  qed
  show ?thesis
    unfolding hoare_r_def using 1 2 order_trans by auto
qed

text ‹ Specialised version of the above law where an invariant expression referring to variables
  outside the frame is preserved. ›
  
theorem StateParallel_frame_hoare [hoare]:
  assumes "vwb_lens a" "vwb_lens b" "a ⨝ b" "a ♮ d⇩1" "b ♮ d⇩2" "a ♯ c⇩1" "b ♯ c⇩1" "⦃c⇩1 ∧ c⇩2⦄P⦃d⇩1⦄⇩u" "⦃c⇩1 ∧ c⇩2⦄Q⦃d⇩2⦄⇩u"
  shows "⦃c⇩1 ∧ c⇩2⦄P |a|b|⇩σ Q⦃c⇩1 ∧ d⇩1 ∧ d⇩2⦄⇩u"
proof -
  have "⦃c⇩1 ∧ c⇩2⦄{&a,&b}:[P |a|b|⇩σ Q]⦃c⇩1 ∧ d⇩1 ∧ d⇩2⦄⇩u"
    by (auto intro!: frame_hoare_r' StateParallel_hoare simp add: assms unrest plus_vwb_lens)
  thus ?thesis
    by (simp add: StateParallel_frame assms)
qed
      
end