(* Author: Tobias Nipkow *)

theory Abs_Int_den1
imports Abs_Int_den0_const
begin

subsection "Backward Analysis of Expressions"

class L_top_bot = SL_top +
fixes meet :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<sqinter>" 65)
and Bot :: "'a"
assumes meet_le1 [simp]: "x \<sqinter> y \<sqsubseteq> x"
and meet_le2 [simp]: "x \<sqinter> y \<sqsubseteq> y"
and meet_greatest: "x \<sqsubseteq> y \<Longrightarrow> x \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<sqinter> z"
assumes bot[simp]: "Bot \<sqsubseteq> x"

locale Rep1 = Rep rep for rep :: "'a::L_top_bot \<Rightarrow> 'b set" +
assumes inter_rep_subset_rep_meet: "rep a1 \<inter> rep a2 \<subseteq> rep(a1 \<sqinter> a2)"
and rep_Bot: "rep Bot = {}"
begin

lemma in_rep_meet: "x <: a1 \<Longrightarrow> x <: a2 \<Longrightarrow> x <: a1 \<sqinter> a2"
by (metis IntI inter_rep_subset_rep_meet set_mp)

lemma rep_meet[simp]: "rep(a1 \<sqinter> a2) = rep a1 \<inter> rep a2"
by (metis equalityI inter_rep_subset_rep_meet le_inf_iff le_rep meet_le1 meet_le2)

end

locale Val_abs1 = Val_abs rep num' plus' + Rep1 rep
  for rep :: "'a::L_top_bot \<Rightarrow> int set" and num' plus' +
fixes filter_plus' :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a * 'a"
and filter_less' :: "bool \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a * 'a"
assumes filter_plus': "filter_plus' a a1 a2 = (a1',a2') \<Longrightarrow>
  n1 <: a1 \<Longrightarrow> n2 <: a2 \<Longrightarrow> n1+n2 <: a \<Longrightarrow> n1 <: a1' \<and> n2 <: a2'"
and filter_less': "filter_less' (n1<n2) a1 a2 = (a1',a2') \<Longrightarrow>
  n1 <: a1 \<Longrightarrow> n2 <: a2 \<Longrightarrow> n1 <: a1' \<and> n2 <: a2'"

datatype 'a up = bot | Up 'a

instantiation up :: (SL_top)SL_top
begin

fun le_up where
"Up x \<sqsubseteq> Up y = (x \<sqsubseteq> y)" |
"bot \<sqsubseteq> y = True" |
"Up _ \<sqsubseteq> bot = False"

lemma [simp]: "(Up x \<sqsubseteq> u) = (EX y. u = Up y & x \<sqsubseteq> y)"
by (cases u) auto

fun join_up where
"Up x \<squnion> Up y = Up(x \<squnion> y)" |
"bot \<squnion> y = y" |
"x \<squnion> bot = x"

lemma [simp]: "x \<squnion> bot = x"
by (cases x) simp_all

definition "Top = Up Top"

instance proof
  case goal1 show ?case by(cases x, simp_all)
next
  case goal2 thus ?case
    by(cases z, simp, cases y, simp, cases x, auto intro: le_trans)
next
  case goal3 thus ?case by(cases x, simp, cases y, simp_all)
next
  case goal4 thus ?case by(cases y, simp, cases x, simp_all)
next
  case goal5 thus ?case by(cases z, simp, cases y, simp, cases x, simp_all)
next
  case goal6 thus ?case by(cases x, simp_all add: Top_up_def)
qed

end

locale Abs_Int1 = Val_abs1 +
fixes pfp :: "('a astate up \<Rightarrow> 'a astate up) \<Rightarrow> 'a astate up \<Rightarrow> 'a astate up"
assumes pfp: "f(pfp f x0) \<sqsubseteq> pfp f x0"
assumes above: "x0 \<sqsubseteq> pfp f x0"
begin

(* FIXME avoid duplicating this defn *)
abbreviation astate_in_rep (infix "<:" 50) where
"s <: S == ALL x. s x <: lookup S x"

abbreviation in_rep_up :: "state \<Rightarrow> 'a astate up \<Rightarrow> bool"  (infix "<::" 50) where
"s <:: S == EX S0. S = Up S0 \<and> s <: S0"

lemma in_rep_up_trans: "(s::state) <:: S \<Longrightarrow> S \<sqsubseteq> T \<Longrightarrow> s <:: T"
apply auto
by (metis in_mono le_astate_def le_rep lookup_def top)

lemma in_rep_join_UpI: "s <:: S1 | s <:: S2 \<Longrightarrow> s <:: S1 \<squnion> S2"
by (metis in_rep_up_trans SL_top_class.join_ge1 SL_top_class.join_ge2)

fun aval' :: "aexp \<Rightarrow> 'a astate up \<Rightarrow> 'a" ("aval\<^sup>#") where
"aval' _ bot = Bot" |
"aval' (N n) _ = num' n" |
"aval' (V x) (Up S) = lookup S x" |
"aval' (Plus a1 a2) S = plus' (aval' a1 S) (aval' a2 S)"

lemma aval'_sound: "s <:: S \<Longrightarrow> aval a s <: aval' a S"
by (induct a) (auto simp: rep_num' rep_plus')

fun afilter :: "aexp \<Rightarrow> 'a \<Rightarrow> 'a astate up \<Rightarrow> 'a astate up" where
"afilter (N n) a S = (if n <: a then S else bot)" |
"afilter (V x) a S = (case S of bot \<Rightarrow> bot | Up S \<Rightarrow>
  let a' = lookup S x \<sqinter> a in
  if a' \<sqsubseteq> Bot then bot else Up(update S x a'))" |
"afilter (Plus e1 e2) a S =
 (let (a1,a2) = filter_plus' a (aval' e1 S) (aval' e2 S)
  in afilter e1 a1 (afilter e2 a2 S))"

text{* The test for @{const Bot} in the @{const V}-case is important: @{const
Bot} indicates that a variable has no possible values, i.e.\ that the current
program point is unreachable. But then the abstract state should collapse to
@{const bot}. Put differently, we maintain the invariant that in an abstract
state all variables are mapped to non-@{const Bot} values. Otherwise the
(pointwise) join of two abstract states, one of which contains @{const Bot}
values, may produce too large a result, thus making the analysis less
precise. *}

fun bfilter :: "bexp \<Rightarrow> bool \<Rightarrow> 'a astate up \<Rightarrow> 'a astate up" where
"bfilter (Bc v) res S = (if v=res then S else bot)" |
"bfilter (Not b) res S = bfilter b (\<not> res) S" |
"bfilter (And b1 b2) res S =
  (if res then bfilter b1 True (bfilter b2 True S)
   else bfilter b1 False S \<squnion> bfilter b2 False S)" |
"bfilter (Less e1 e2) res S =
  (let (res1,res2) = filter_less' res (aval' e1 S) (aval' e2 S)
   in afilter e1 res1 (afilter e2 res2 S))"

lemma afilter_sound: "s <:: S \<Longrightarrow> aval e s <: a \<Longrightarrow> s <:: afilter e a S"
proof(induction e arbitrary: a S)
  case N thus ?case by simp
next
  case (V x)
  obtain S' where "S = Up S'" and "s <: S'" using `s <:: S` by auto
  moreover hence "s x <: lookup S' x" by(simp)
  moreover have "s x <: a" using V by simp
  ultimately show ?case using V(1)
    by(simp add: lookup_update Let_def)
       (metis le_rep emptyE in_rep_meet rep_Bot subset_empty)
next
  case (Plus e1 e2) thus ?case
    using filter_plus'[OF _ aval'_sound[OF Plus(3)] aval'_sound[OF Plus(3)]]
    by (auto split: prod.split)
qed

lemma bfilter_sound: "s <:: S \<Longrightarrow> bv = bval b s \<Longrightarrow> s <:: bfilter b bv S"
proof(induction b arbitrary: S bv)
  case Bc thus ?case by simp
next
  case (Not b) thus ?case by simp
next
  case (And b1 b2) thus ?case by (auto simp: in_rep_join_UpI)
next
  case (Less e1 e2) thus ?case
    apply hypsubst_thin
    apply (auto split: prod.split)
    apply (metis afilter_sound filter_less' aval'_sound Less)
    done
qed

fun AI :: "com \<Rightarrow> 'a astate up \<Rightarrow> 'a astate up" where
"AI SKIP S = S" |
"AI (x ::= a) S =
  (case S of bot \<Rightarrow> bot | Up S \<Rightarrow> Up(update S x (aval' a (Up S))))" |
"AI (c1;;c2) S = AI c2 (AI c1 S)" |
"AI (IF b THEN c1 ELSE c2) S =
  AI c1 (bfilter b True S) \<squnion> AI c2 (bfilter b False S)" |
"AI (WHILE b DO c) S =
  bfilter b False (pfp (\<lambda>S. AI c (bfilter b True S)) S)"

lemma AI_sound: "(c,s) \<Rightarrow> t \<Longrightarrow> s <:: S \<Longrightarrow> t <:: AI c S"
proof(induction c arbitrary: s t S)
  case SKIP thus ?case by fastforce
next
  case Assign thus ?case
    by (auto simp: lookup_update aval'_sound)
next
  case Seq thus ?case by fastforce
next
  case If thus ?case by (auto simp: in_rep_join_UpI bfilter_sound)
next
  case (While b c)
  let ?P = "pfp (\<lambda>S. AI c (bfilter b True S)) S"
  { fix s t
    have "(WHILE b DO c,s) \<Rightarrow> t \<Longrightarrow> s <:: ?P \<Longrightarrow>
          t <:: bfilter b False ?P"
    proof(induction "WHILE b DO c" s t rule: big_step_induct)
      case WhileFalse thus ?case by(metis bfilter_sound)
    next
      case WhileTrue show ?case
        by(rule WhileTrue, rule in_rep_up_trans[OF _ pfp],
           rule While.IH[OF WhileTrue(2)],
           rule bfilter_sound[OF WhileTrue.prems], simp add: WhileTrue(1))
    qed
  }
  with in_rep_up_trans[OF `s <:: S` above] While(2,3) AI.simps(5)
  show ?case by simp
qed

end

end


section \<open> Find and Replace Algorithm \<close>

theory find_replace
  imports "UTP.utp"
begin

utp_lit_vars

alphabet ss = arr::"nat \<Rightarrow> string" occ::"nat" i::"nat"

definition find_replace ::
  "(nat \<Rightarrow> string) \<Rightarrow> nat \<Rightarrow> string \<Rightarrow> string \<Rightarrow> ss hrel" where
"find_replace A len mtc rpl =
  arr := A ;; i := 0 ;; occ := 0 ;;
  while i < len
  invr arr = (\<lambda> k. if k < i \<and> A k = mtc then rpl else A k)
     \<and> occ = length (filter ((=) mtc) (map A [0..<i])) \<and> i \<le> len
  do
    if (arr i = mtc) then arr[i] := rpl ;; occ := occ + 1
    else arr[i] := arr i
    fi ;; i := i + 1
  od"

lemma find_replace_inv:
  "\<^bold>{true\<^bold>}
    find_replace A len mtc rpl
   \<^bold>{arr = (\<lambda> k. if k < i \<and> A k = mtc then rpl else A k)\<^bold>}"
  unfolding find_replace_def
  by (hoare_split, rel_auto', metis less_Suc_eq)

lemma find_replace_prop1:
  "\<^bold>{true\<^bold>} find_replace A len mtc rpl \<^bold>{\<forall> i < len. arr(i) = (rpl \<triangleleft> A(i) = mtc \<triangleright> A(i)) \<^bold>}"
  unfolding find_replace_def by (hoare_auto, metis less_Suc_eq)

lemma find_replace_prop2:
  "\<^bold>{true\<^bold>} find_replace A len mtc rpl \<^bold>{occ = length (filter ((=) mtc) (map A [0..<len]))\<^bold>}"
  unfolding find_replace_def by (hoare_auto, metis less_Suc_eq)

end


theory negation_properties_infinitary
  imports negation_properties "../boolean_algebra/boolean_algebra_infinitary"
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format=3] (*default Nitpick settings*)

subsection \<open>Definitions and interrelations (infinitary case)\<close>

(**We define and interrelate infinitary variants for some previously introduced ('negative') conditions
on operations. We show how they relate to quantifiers as previously defined.*)

(**iDM: infinitary De Morgan laws.*)
abbreviation riDM1 ("iDM1\<^sup>_ _") where "iDM1\<^sup>S \<eta> \<equiv> \<eta>(\<^bold>\<Or>S) \<^bold>\<preceq> \<^bold>\<And>Ra[\<eta>|S]"
abbreviation riDM2 ("iDM2\<^sup>_ _") where "iDM2\<^sup>S \<eta> \<equiv> \<^bold>\<Or>Ra[\<eta>|S] \<^bold>\<preceq> \<eta>(\<^bold>\<And>S)"
abbreviation riDM3 ("iDM3\<^sup>_ _") where "iDM3\<^sup>S \<eta> \<equiv> \<eta>(\<^bold>\<And>S) \<^bold>\<preceq> \<^bold>\<Or>Ra[\<eta>|S]"
abbreviation riDM4 ("iDM4\<^sup>_ _") where "iDM4\<^sup>S \<eta> \<equiv> \<^bold>\<And>Ra[\<eta>|S] \<^bold>\<preceq> \<eta>(\<^bold>\<Or>S)"
definition "iDM1 \<eta> \<equiv> \<forall>S. iDM1\<^sup>S \<eta>"
definition "iDM2 \<eta> \<equiv> \<forall>S. iDM2\<^sup>S \<eta>"
definition "iDM3 \<eta> \<equiv> \<forall>S. iDM3\<^sup>S \<eta>"
definition "iDM4 \<eta> \<equiv> \<forall>S. iDM4\<^sup>S \<eta>"
declare iDM1_def[Defs] iDM2_def[Defs] iDM3_def[Defs] iDM4_def[Defs]

lemma CoPw_iDM1: "CoPw \<eta> \<Longrightarrow> iDM1 \<eta>" unfolding Defs by (smt Ra_restr_all sup_char)
lemma CoPw_iDM2: "CoPw \<eta> \<Longrightarrow> iDM2 \<eta>" unfolding Defs by (smt Ra_restr_ex inf_char)
lemma CoP2_iDM3: "CoP2 \<eta> \<Longrightarrow> iDM3 \<eta>" by (smt CoP2_def Ra_restr_ex iDM3_def inf_char)
lemma CoP1_iDM4: "CoP1 \<eta> \<Longrightarrow> iDM4 \<eta>" by (smt CoP1_def Ra_restr_all iDM4_def sup_char)
lemma "XCoP \<eta> \<Longrightarrow> iDM3 \<eta>" nitpick oops
lemma "XCoP \<eta> \<Longrightarrow> iDM4 \<eta>" nitpick oops

(**DM1, DM2, iDM1, iDM2 & CoPw are equivalent.*)
lemma iDM1_rel: "iDM1 \<eta> \<Longrightarrow> DM1 \<eta>" proof -
  assume idm1: "iDM1 \<eta>"
   { fix a::"\<sigma>" and b::"\<sigma>"
     let ?S="\<lambda>Z. Z=a \<or> Z=b"
     have "\<^bold>\<And>Ra[\<eta>|?S] = \<^bold>\<forall>\<^sup>R\<lparr>?S\<rparr> \<eta>" using Ra_restr_all by blast
     moreover have "\<^bold>\<forall>\<^sup>R\<lparr>?S\<rparr> \<eta> = (\<eta> a) \<^bold>\<and> (\<eta> b)" using meet_def by auto
     ultimately have "\<^bold>\<And>Ra[\<eta>|?S] = (\<eta> a) \<^bold>\<and> (\<eta> b)" by simp
     moreover have "\<^bold>\<Or>?S = a \<^bold>\<or> b" using supremum_def join_def by auto
     moreover from idm1 have "\<eta>(\<^bold>\<Or>?S) \<^bold>\<preceq> \<^bold>\<And>Ra[\<eta>|?S]" by (simp add: iDM1_def)
     ultimately have "\<eta>(a \<^bold>\<or> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<and> (\<eta> b)" by simp
   } thus ?thesis by (simp add: DM1_def)
 qed
lemma iDM2_rel: "iDM2 \<eta> \<Longrightarrow> DM2 \<eta>" proof -
  assume idm2: "iDM2 \<eta>"
   { fix a::"\<sigma>" and b::"\<sigma>"
     let ?S="\<lambda>Z. Z=a \<or> Z=b"
     have "\<^bold>\<Or>Ra[\<eta>|?S] = \<^bold>\<exists>\<^sup>R\<lparr>?S\<rparr> \<eta>" using Ra_restr_ex by blast
     moreover have "\<^bold>\<exists>\<^sup>R\<lparr>?S\<rparr> \<eta> = (\<eta> a) \<^bold>\<or> (\<eta> b)" using join_def by auto
     ultimately have "\<^bold>\<Or>Ra[\<eta>|?S] = (\<eta> a) \<^bold>\<or> (\<eta> b)" by simp
     moreover have "\<^bold>\<And>?S = a \<^bold>\<and> b" using infimum_def meet_def by auto
     moreover from idm2 have "\<^bold>\<Or>Ra[\<eta>|?S] \<^bold>\<preceq> \<eta>(\<^bold>\<And>?S)" by (simp add: iDM2_def)
     ultimately have "(\<eta> a) \<^bold>\<or> (\<eta> b) \<^bold>\<preceq> \<eta>(a \<^bold>\<and> b)" by auto
   } thus ?thesis by (simp add: DM2_def)
qed
lemma "DM1 \<eta> = iDM1 \<eta>" using CoPw_iDM1 DM1_CoPw iDM1_rel by blast
lemma "DM2 \<eta> = iDM2 \<eta>" using CoPw_iDM2 DM2_CoPw iDM2_rel by blast
lemma "iDM1 \<eta> = iDM2 \<eta>" using CoPw_iDM1 CoPw_iDM2 DM1_CoPw DM2_CoPw iDM1_rel iDM2_rel by blast

(**iDM3/4 entail their finitary variants but not the other way round.*)
lemma iDM3_rel: "iDM3 \<eta> \<Longrightarrow> DM3 \<eta>" proof -
  assume idm3: "iDM3 \<eta>"
   { fix a::"\<sigma>" and b::"\<sigma>"
     let ?S="\<lambda>Z. Z=a \<or> Z=b"
     have "\<^bold>\<Or>Ra[\<eta>|?S] = \<^bold>\<exists>\<^sup>R\<lparr>?S\<rparr> \<eta>" using Ra_restr_ex by blast
     moreover have "\<^bold>\<exists>\<^sup>R\<lparr>?S\<rparr> \<eta> = (\<eta> a) \<^bold>\<or> (\<eta> b)" using join_def by auto
     ultimately have "\<^bold>\<Or>Ra[\<eta>|?S] = (\<eta> a) \<^bold>\<or> (\<eta> b)" by simp
     moreover have "\<^bold>\<And>?S = a \<^bold>\<and> b" using infimum_def meet_def by auto
     moreover from idm3 have "\<eta>(\<^bold>\<And>?S) \<^bold>\<preceq> \<^bold>\<Or>Ra[\<eta>|?S]" by (simp add: iDM3_def)
     ultimately have "\<eta>(a \<^bold>\<and> b) \<^bold>\<preceq> (\<eta> a) \<^bold>\<or> (\<eta> b)" by auto
   } thus ?thesis by (simp add: DM3_def)
qed
lemma iDM4_rel: "iDM4 \<eta> \<Longrightarrow> DM4 \<eta>" proof -
  assume idm4: "iDM4 \<eta>"
   { fix a::"\<sigma>" and b::"\<sigma>"
     let ?S="\<lambda>Z. Z=a \<or> Z=b"
     have "\<^bold>\<And>Ra[\<eta>|?S] = \<^bold>\<forall>\<^sup>R\<lparr>?S\<rparr> \<eta>" using Ra_restr_all by blast
     moreover have "\<^bold>\<forall>\<^sup>R\<lparr>?S\<rparr> \<eta> = (\<eta> a) \<^bold>\<and> (\<eta> b)" using meet_def by auto
     ultimately have "\<^bold>\<And>Ra[\<eta>|?S] = (\<eta> a) \<^bold>\<and> (\<eta> b)" by simp
     moreover have "\<^bold>\<Or>?S = a \<^bold>\<or> b" using supremum_def join_def by auto
     moreover from idm4 have "\<^bold>\<And>Ra[\<eta>|?S] \<^bold>\<preceq> \<eta>(\<^bold>\<Or>?S)" by (simp add: iDM4_def)
     ultimately have "(\<eta> a) \<^bold>\<and> (\<eta> b) \<^bold>\<preceq> \<eta>(a \<^bold>\<or> b)" by simp
   } thus ?thesis by (simp add: DM4_def)
 qed
lemma "DM3 \<eta> \<Longrightarrow> iDM3 \<eta>" nitpick oops
lemma "DM4 \<eta> \<Longrightarrow> iDM4 \<eta>" nitpick oops

(**Indeed the previous characterization of the infinitary De Morgan laws is fairly general and entails
the traditional version employing quantifiers (though not the other way round).*)
(**The first two variants DM1/2 follow easily from DM1/2, iDM1/2 or CoPw (all of them equivalent).*)
lemma iDM1_trad: "iDM1 \<eta> \<Longrightarrow> \<forall>\<pi>. \<eta>(\<^bold>\<exists>x. \<pi> x)  \<^bold>\<preceq>  (\<^bold>\<forall>x. \<eta>(\<pi> x))" by (metis (mono_tags, lifting) CoPw_def DM1_CoPw iDM1_rel)
lemma iDM2_trad: "iDM2 \<eta> \<Longrightarrow> \<forall>\<pi>. (\<^bold>\<exists>x. \<eta>(\<pi> x)) \<^bold>\<preceq> \<eta>(\<^bold>\<forall>x. \<pi> x)" by (metis (mono_tags, lifting) CoPw_def DM2_CoPw iDM2_rel)

(**An analogous relationship holds for variants DM3/4, though the proof is less trivial.
To see how let us first consider an intermediate version of the De Morgan laws, obtained as a
particular case of the general variant above, with S as the range of a propositional function.*)
abbreviation "piDM1 \<pi> \<eta> \<equiv> \<eta>(\<^bold>\<Or>Ra(\<pi>)) \<^bold>\<preceq> \<^bold>\<And>Ra[\<eta>|Ra(\<pi>)]"
abbreviation "piDM2 \<pi> \<eta> \<equiv> \<^bold>\<Or>Ra[\<eta>|Ra(\<pi>)] \<^bold>\<preceq> \<eta>(\<^bold>\<And>Ra(\<pi>))"
abbreviation "piDM3 \<pi> \<eta> \<equiv> \<eta>(\<^bold>\<And>Ra(\<pi>)) \<^bold>\<preceq> \<^bold>\<Or>Ra[\<eta>|Ra(\<pi>)]"
abbreviation "piDM4 \<pi> \<eta> \<equiv> \<^bold>\<And>Ra[\<eta>|Ra(\<pi>)] \<^bold>\<preceq> \<eta>(\<^bold>\<Or>Ra(\<pi>))"

(**They are entailed (unidirectionally) by the general De Morgan laws.*)
lemma "iDM1 \<eta> \<Longrightarrow> \<forall>\<pi>. piDM1 \<pi> \<eta>" by (simp add: iDM1_def)
lemma "iDM2 \<eta> \<Longrightarrow> \<forall>\<pi>. piDM2 \<pi> \<eta>" by (simp add: iDM2_def)
lemma "iDM3 \<eta> \<Longrightarrow> \<forall>\<pi>. piDM3 \<pi> \<eta>" by (simp add: iDM3_def)
lemma "iDM4 \<eta> \<Longrightarrow> \<forall>\<pi>. piDM4 \<pi> \<eta>" by (simp add: iDM4_def)

(**Drawing upon the relationships shown previously we can rewrite the latter two as:*)
lemma iDM3_aux: "piDM3 \<pi> \<eta> \<equiv> \<eta>(\<^bold>\<forall>\<pi>) \<^bold>\<preceq> \<^bold>\<exists>[\<eta>|\<lparr>Ra \<pi>\<rparr>]\<^sup>N" unfolding Ra_all Ra_ex_restr by simp
lemma iDM4_aux: "piDM4 \<pi> \<eta> \<equiv> \<^bold>\<forall>[\<eta>|\<lparr>Ra \<pi>\<rparr>]\<^sup>P \<^bold>\<preceq> \<eta>(\<^bold>\<exists>\<pi>)" unfolding Ra_ex Ra_all_restr by simp

(**and thus finally obtain the desired formulas.*)
lemma iDM3_trad: "iDM3 \<eta> \<Longrightarrow> \<forall>\<pi>. \<eta>(\<^bold>\<forall>x. \<pi> x)  \<^bold>\<preceq>  (\<^bold>\<exists>x. \<eta>(\<pi> x))" by (metis Ra_ex_comp2 iDM3_def iDM3_aux comp_apply)
lemma iDM4_trad: "iDM4 \<eta> \<Longrightarrow> \<forall>\<pi>. (\<^bold>\<forall>x. \<eta>(\<pi> x)) \<^bold>\<preceq> \<eta>(\<^bold>\<exists>x. \<pi> x)" by (metis Ra_all_comp1 iDM4_def iDM4_aux comp_apply)

end


section \<open>Parallel Operator \label{S:parallel}\<close>

theory Parallel
imports Refinement_Lattice
begin

subsection \<open>Basic parallel operator\<close>

text \<open>
  The parallel operator is associative, commutative and has unit skip
  and has as an annihilator the lattice bottom.
\<close>

locale skip =
  fixes skip :: "'a::refinement_lattice"  ("skip")

locale par =
  fixes par :: "'a::refinement_lattice \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<parallel>" 75)
  assumes abort_par:   "\<bottom> \<parallel> c = \<bottom>"    (* ++ *)

locale parallel = par + skip + par: comm_monoid par skip
begin

lemmas [algebra_simps, field_simps] =
  par.assoc
  par.commute
  par.left_commute

lemmas par_assoc = par.assoc            (* 36 *)
lemmas par_commute = par.commute        (* 37 *)
lemmas par_skip = par.right_neutral     (* 38 *)
lemmas par_skip_left = par.left_neutral (* 38 + 37 *)

end

subsection \<open>Distributed parallel\<close>

text \<open>
  The parallel operator distributes across arbitrary non-empty infima.
\<close>
locale par_distrib = parallel +
  assumes par_Inf_distrib: "D \<noteq> {} \<Longrightarrow> c \<parallel> (\<Sqinter> D) = (\<Sqinter>d\<in>D. c \<parallel> d)"    (* 39+ *)

begin

lemma Inf_par_distrib: "D \<noteq> {} \<Longrightarrow> (\<Sqinter> D) \<parallel> c = (\<Sqinter>d\<in>D. d \<parallel> c)"
  using par_Inf_distrib par_commute by simp

lemma par_INF_distrib: "X \<noteq> {} \<Longrightarrow> c \<parallel> (\<Sqinter>x\<in>X. d x) = (\<Sqinter>x\<in>X. c \<parallel> d x)"
  using par_Inf_distrib by (auto simp add: image_comp)

lemma INF_par_distrib: "X \<noteq> {} \<Longrightarrow> (\<Sqinter>x\<in>X. d x) \<parallel> c = (\<Sqinter>x\<in>X. d x \<parallel> c)"
  using par_INF_distrib par_commute by (metis (mono_tags, lifting) INF_cong)

lemma INF_INF_par_distrib:
    "X \<noteq> {} \<Longrightarrow> Y \<noteq> {} \<Longrightarrow> (\<Sqinter>x\<in>X. c x) \<parallel> (\<Sqinter>y\<in>Y. d y) = (\<Sqinter>x\<in>X. \<Sqinter>y\<in>Y. c x \<parallel> d y)"
proof -
  assume nonempty_X: "X \<noteq> {}"
  assume nonempty_Y: "Y \<noteq> {}"
  have "(\<Sqinter>x\<in>X. c x) \<parallel> (\<Sqinter>y\<in>Y. d y) = (\<Sqinter>x\<in>X. c x \<parallel> (\<Sqinter>y\<in>Y. d y))"
    using INF_par_distrib by (metis nonempty_X)
  also have "\<dots> = (\<Sqinter>x\<in>X. \<Sqinter>y\<in>Y. c x \<parallel> d y)" using par_INF_distrib by (metis nonempty_Y)
  thus ?thesis by (simp add: calculation)
qed

lemma inf_par_distrib: "(c\<^sub>0 \<sqinter> c\<^sub>1) \<parallel> d = (c\<^sub>0 \<parallel> d) \<sqinter> (c\<^sub>1 \<parallel> d)"
proof -
  have "(c\<^sub>0 \<sqinter> c\<^sub>1) \<parallel> d = (\<Sqinter> {c\<^sub>0, c\<^sub>1}) \<parallel> d" by simp
  also have "... = (\<Sqinter>c \<in> {c\<^sub>0, c\<^sub>1}. c \<parallel> d)" using Inf_par_distrib by (meson insert_not_empty)
  also have "... = c\<^sub>0 \<parallel> d \<sqinter> c\<^sub>1 \<parallel> d" by simp
  finally show ?thesis .
qed

lemma inf_par_distrib2: "d \<parallel> (c\<^sub>0 \<sqinter> c\<^sub>1) = (d \<parallel> c\<^sub>0) \<sqinter> (d \<parallel> c\<^sub>1)"
  using inf_par_distrib par_commute by auto

lemma inf_par_product: "(a \<sqinter> b) \<parallel> (c \<sqinter> d) = (a \<parallel> c) \<sqinter> (a \<parallel> d) \<sqinter> (b \<parallel> c) \<sqinter> (b \<parallel> d)"
  by (simp add: inf_commute inf_par_distrib inf_par_distrib2 inf_sup_aci(3))

lemma par_mono: "c\<^sub>1 \<sqsubseteq> d\<^sub>1 \<Longrightarrow> c\<^sub>2 \<sqsubseteq> d\<^sub>2 \<Longrightarrow> c\<^sub>1 \<parallel> c\<^sub>2 \<sqsubseteq> d\<^sub>1 \<parallel> d\<^sub>2"
  by (metis inf.orderE le_inf_iff order_refl inf_par_distrib par_commute)

end
end