header {* Resumption-Based Noninterference *}

theory Resumption_Based
imports Language_Semantics
begin

(* We introduce the resumption based notions: strong probabilistic bisimilarity \<approx>s and
01- probabilistic bisimilarity \<approx>01, and prove their basic properties.  E.g., we prove that
\<approx>s is symmetric and transitive.
*)

type_synonym 'a rel = "('a \<times>'a) set"

subsection {* Preliminaries *}

lemma int_emp[simp]:
assumes "i > 0"
shows "{..<i} \<noteq> {}"
by (metis assms emptyE lessThan_iff)

lemma inj_on_inv_into[simp]:
assumes "inj_on F P"
shows "inv_into P F ` (F ` P) = P"
using assms by auto

lemma inj_on_inv_into2[simp]:
"inj_on (inv_into P F) (F ` P)"
by (metis Hilbert_Choice.inj_on_inv_into subset_refl)

lemma refl_gfp:
assumes 1: "mono Retr" and 2: "\<And> theta. refl theta \<Longrightarrow> refl (Retr theta)"
shows "refl (gfp Retr)"
proof-
  def bis \<equiv> "gfp Retr"
  def th \<equiv> "Id Un bis"
  have "bis \<subseteq> Retr bis"
  using 1 unfolding bis_def by (metis gfp_unfold subset_refl)
  also have "... \<subseteq> Retr th" using 1 unfolding mono_def th_def by auto
  finally have "bis \<subseteq> Retr th" .
  moreover
  {have "refl th" unfolding th_def by (metis Un_commute refl_reflcl)
   hence "refl (Retr th)" using 2 by simp
  }
  ultimately have "Id \<subseteq> Retr th" unfolding th_def refl_on_def by auto
  hence "Id \<subseteq> bis" using 1 coinduct unfolding th_def bis_def by blast
  thus ?thesis unfolding bis_def refl_on_def by auto
qed

lemma sym_gfp:
assumes 1: "mono Retr" and 2: "\<And> theta. sym theta \<Longrightarrow> sym (Retr theta)"
shows "sym (gfp Retr)"
proof-
  def bis \<equiv> "gfp Retr"
  def th \<equiv> "bis ^-1 Un bis"
  have "bis \<subseteq> Retr bis"
  using 1 unfolding bis_def by (metis gfp_unfold subset_refl)
  also have "... \<subseteq> Retr th" using 1 unfolding mono_def th_def by auto
  finally have "bis \<subseteq> Retr th" .
  moreover
  {have "sym th" unfolding th_def by (metis Un_commute sym_Un_converse)
   hence "sym (Retr th)" using 2 by simp
  }
  ultimately have "bis ^-1 \<subseteq> Retr th"
  by (metis Un_absorb2 Un_commute Un_upper1 converse_Un sym_conv_converse_eq)
  hence "bis ^-1 \<subseteq> bis" using 1 coinduct[of Retr "bis ^-1"] unfolding th_def bis_def by blast
  thus ?thesis unfolding bis_def sym_def by blast
qed

lemma trancl_trans[simp]:
assumes "trans R"
shows "P ^+ \<subseteq> R \<longleftrightarrow> P \<subseteq> R"
proof-
  {assume "P \<subseteq> R"
   hence "P ^+ \<subseteq> R ^+" using trancl_mono by auto
   also have "R ^+ = R" using assms trans_trancl by auto
   finally have "P ^+ \<subseteq> R" .
  }
  thus ?thesis by auto
qed

lemma trans_gfp:
assumes 1: "mono Retr" and 2: "\<And> theta. trans theta \<Longrightarrow> trans (Retr theta)"
shows "trans (gfp Retr)"
proof-
  def bis \<equiv> "gfp Retr"
  def th \<equiv> "bis ^+"
  have "bis \<subseteq> Retr bis"
  using 1 unfolding bis_def by (metis gfp_unfold subset_refl)
  also have "... \<subseteq> Retr th" using 1 unfolding mono_def th_def
    by (metis trancl_trans order_refl trans_trancl)
  finally have "bis \<subseteq> Retr th" .
  moreover
  {have "trans th" unfolding th_def by (metis th_def trans_trancl)
   hence "trans (Retr th)" using 2 by simp
  }
  ultimately have "bis ^+ \<subseteq> Retr th" by simp
  hence "bis ^+ \<subseteq> bis" using 1 coinduct unfolding th_def bis_def
  by (metis bis_def gfp_upperbound th_def)
  thus ?thesis unfolding bis_def trans_def by auto
qed

lemma O_subset_trans:
assumes "r O r \<subseteq> r"
shows "trans r"
using assms unfolding trans_def by blast

lemma trancl_imp_trans:
assumes "r ^+ \<subseteq> r"
shows "trans r"
by (metis Int_absorb1 Int_commute trancl_trans assms subset_refl trans_trancl)

lemma sym_trans_gfp:
assumes 1: "mono Retr" and 2: "\<And> theta. sym theta \<and> trans theta \<Longrightarrow> sym (Retr theta) \<and> trans (Retr theta)"
shows "sym (gfp Retr) \<and> trans (gfp Retr)"
proof-
  def bis \<equiv> "gfp Retr"
  def th \<equiv> "(bis Un bis ^-1) ^+"
  have "bis \<subseteq> Retr bis"
  using 1 unfolding bis_def by (metis gfp_unfold subset_refl)
  also have "... \<subseteq> Retr th" using 1 unfolding mono_def th_def
    by (metis inf_sup_absorb le_iff_inf sup_aci(2) trancl_unfold)
  finally have "bis \<subseteq> Retr th" .
  hence "(bis Un bis ^-1) ^+ \<subseteq> ((Retr th) Un (Retr th) ^-1) ^+" by auto
  moreover
  {have "sym th" unfolding th_def by (metis sym_Un_converse sym_trancl)
   moreover have "trans th" unfolding th_def by (metis th_def trans_trancl)
   ultimately have "sym (Retr th) \<and> trans (Retr th)" using 2 by simp
   hence "((Retr th) Un (Retr th) ^-1) ^+ \<subseteq> Retr th"
   by (metis Un_absorb subset_refl sym_conv_converse_eq trancl_id)
  }
  ultimately have "(bis Un bis ^-1) ^+ \<subseteq> Retr th" by blast
  hence "(bis Un bis ^-1) ^+ \<subseteq> bis" using 1 coinduct unfolding th_def bis_def
  by (metis bis_def gfp_upperbound th_def)
  hence "bis ^-1 \<subseteq> bis" and "bis ^+ \<subseteq> bis"
  apply(metis equalityI gfp_upperbound le_supI1 subset_refl sym_Un_converse sym_conv_converse_eq th_def trancl_id trancl_imp_trans)
  by (metis Un_absorb `(bis \<union> bis\<inverse>)\<^sup>+ \<subseteq> bis` less_supI1 psubset_eq sym_Un_converse sym_conv_converse_eq sym_trancl trancl_id trancl_imp_trans)
  thus ?thesis unfolding bis_def sym_def using trancl_imp_trans by auto
qed

subsection {* Infrastructure for partitions *}

(* Being a partition *)
definition part where
"part J P \<equiv>
 Union P = J \<and>
 (\<forall> J1 J2. J1 \<in> P \<and> J2 \<in> P \<and> J1 \<noteq> J2 \<longrightarrow> J1 \<inter> J2 = {})"

(* gen P I is the set generated from I using intersections with sets of P  *)
inductive_set gen
for P :: "'a set set" and I :: "'a set" where
 incl[simp]: "i \<in> I \<Longrightarrow> i \<in> gen P I"
|ext[simp]: "\<lbrakk>J \<in> P; j0 \<in> J; j0 \<in> gen P I; j \<in> J\<rbrakk> \<Longrightarrow> j \<in> gen P I"

(* Partition generated by a set *)
definition partGen where
"partGen P \<equiv> {gen P I | I . I \<in> P}"

(* finer P Q means: as a partition, P is finer than Q;
   regarding P and Q as equivalence relations, we have Q included in P *)
definition finer where
"finer P Q \<equiv>
 (\<forall> J \<in> Q. J = Union {I \<in> P . I \<subseteq> J}) \<and>
 (P \<noteq> {} \<longrightarrow> Q \<noteq> {})"

(* The join of two partitions; in terms of equivalence relations,
   this is the smallest equivalence containing both *)
definition partJoin where
"partJoin P Q \<equiv> partGen (P \<union> Q)"

(* Compatibility of a function f w.r.t. a set I versus a relation theta *)
definition compat where
"compat I theta f \<equiv> \<forall> i j. {i, j} \<subseteq> I \<and> i \<noteq> j \<longrightarrow> (f i, f j) \<in> theta"

(* Compatibility of a function f w.r.t. a partition P versus a relation theta;
if P is regarded as an equivalence class, we have the standard notion of compatibility *)
definition partCompat where
"partCompat P theta f \<equiv>
 \<forall> I \<in> P. compat I theta f"

(* Lifting a function F on a partition P to elements II of a potentially coarser partition *)
definition lift where
"lift P F II \<equiv> Union {F I | I . I \<in> P \<and> I \<subseteq> II}"

text{* part: *}

lemma part_emp[simp]:
"part J (insert {} P) = part J P"
unfolding part_def by auto

lemma finite_part[simp]:
assumes "finite I" and "part I P"
shows "finite P"
using assms finite_UnionD unfolding part_def by auto

lemma part_setsum:
  assumes P: "part {..<n::nat} P"
  shows "(\<Sum>i<n. f i) = (\<Sum>p\<in>P. \<Sum>i\<in>p. f i)"
proof (subst setsum.Union_disjoint [symmetric, simplified])
  show "\<forall>p\<in>P. finite p"
  proof
    fix p assume "p \<in> P"
    with P have "p \<subseteq> {0..<n}" by (auto simp: part_def)
    then show "finite p" by (rule finite_subset) simp
  qed
  show "\<forall>A\<in>P. \<forall>B\<in>P. A \<noteq> B \<longrightarrow> A \<inter> B = {}"
    using P by (auto simp: part_def)
  show "setsum f {..<n} = setsum f (\<Union>P)"
    using P by (auto simp: part_def atLeast0LessThan)
qed

lemma part_Un[simp]:
assumes "part I1 P1" and "part I2 P2" and "I1 Int I2 = {}"
shows "part (I1 Un I2) (P1 Un P2)"
  using assms unfolding part_def
  by (metis Collect_empty_eq Union_Un_distrib Union_disjoint all_not_in_conv empty_Collect_eq
            equals0D inf_aci(1) inf_idem mem_simps(3) mem_simps(4))

lemma part_Un_singl[simp]:
assumes "part K P" and "\<And> I. I \<in> P \<Longrightarrow> I0 Int I = {}"
shows "part (I0 Un K) ({I0} Un P)"
using assms unfolding part_def by blast

lemma part_Un_singl2:
assumes "K01 = I0 Un K1"
and "part K1 P" and "\<And> I. I \<in> P \<Longrightarrow> I0 Int I = {}"
shows "part K01 ({I0} Un P)"
using assms part_Un_singl by blast

lemma part_UN:
assumes "\<And> n. n \<in> N \<Longrightarrow> part (I n) (P n)"
and "\<And> n1 n2. {n1,n2} \<subseteq> N \<and> n1 \<noteq> n2 \<Longrightarrow> I n1 \<inter> I n2 = {}"
shows "part (UN n : N. I n) (UN n : N. P n)"
using assms unfolding part_def apply auto
apply (metis UnionE)
apply (metis Union_upper disjoint_iff_not_equal insert_absorb insert_subset)
by (metis UnionI disjoint_iff_not_equal)

text{* gen: *}

lemma incl_gen[simp]:
"I \<subseteq> gen P I"
by auto

lemma gen_incl_Un:
"gen P I \<subseteq> I \<union> (Union P)"
proof
  fix j assume "j \<in> gen P I"
  thus "j \<in> I \<union> \<Union>P" apply induct by blast+
qed

lemma gen_incl:
assumes "I \<in> P"
shows "gen P I \<subseteq> Union P"
using assms gen_incl_Un[of P I] by blast

lemma finite_gen:
assumes "finite P" and "\<And> J. J \<in> P \<Longrightarrow> finite J" and "finite I"
shows "finite (gen P I)"
by (metis assms finite_Union gen_incl_Un infinite_Un infinite_super)

lemma subset_gen[simp]:
assumes "J \<in> P" and "gen P I \<inter> J \<noteq> {}"
shows "J \<subseteq> gen P I"
using assms gen.ext[of J P _ I] by blast

lemma gen_subset_gen[simp]:
assumes "J \<in> P" and "gen P I \<inter> J \<noteq> {}"
shows "gen P J \<subseteq> gen P I"
proof-
  have J: "J \<subseteq> gen P I" using assms by auto
  show ?thesis proof
    fix i assume "i \<in> gen P J"
    thus "i \<in> gen P I"
    proof induct
      case (ext J' j0 j)
      thus ?case
      using gen.ext[of J' P j0 I j] by blast
    qed (insert J, auto)
  qed
qed

lemma gen_mono[simp]:
assumes "I \<subseteq> J"
shows "gen P I \<subseteq> gen P J"
proof
  fix i assume "i \<in> gen P I" thus "i \<in> gen P J"
  proof induct
    case (ext I' j0 j)
    thus ?case
    using gen.ext[of I' P j0 J j] by blast
  qed (insert assms, auto)
qed

lemma gen_idem[simp]:
"gen P (gen P I) = gen P I"
proof-
  def J \<equiv> "gen P I"
  have "I \<subseteq> J" unfolding J_def by auto
  hence "gen P I \<subseteq> gen P J" by simp
  moreover have "gen P J \<subseteq> gen P I" proof
  fix i assume "i \<in> gen P J"
    thus "i \<in> gen P I"
    proof induct
      case (ext J' j0 j)
      thus ?case
      using gen.ext[of J' P j0 I j] by blast
    qed (unfold J_def, auto)
  qed
  ultimately show ?thesis unfolding J_def by auto
qed

lemma gen_nchotomy:
assumes "J \<in> P"
shows "J \<subseteq> gen P I \<or> gen P I \<inter> J = {}"
using assms subset_gen[of J P I] by blast

lemma gen_Union:
assumes "I \<in> P"
shows "gen P I = Union {J \<in> P . J \<subseteq> gen P I}"
proof safe
  fix i assume i: "i \<in> gen P I"
  then obtain J where J: "J \<in> P"  "i \<in> J" using assms gen_incl by blast
  hence "J \<subseteq> gen P I" using assms i gen_nchotomy by auto
  thus "i \<in> \<Union>{J \<in> P. J \<subseteq> gen P I}" using J by auto
qed auto

lemma subset_gen2:
assumes *: "{I,J} \<subseteq> P" and **: "gen P I \<inter> gen P J \<noteq> {}"
shows "I \<subseteq> gen P J"
proof-
  {fix i0 i assume i0: "i0 \<in> I \<and> i0 \<notin> gen P J"
   assume "i \<in> gen P I"
   hence "i \<notin> gen P J"
   proof induct
     case (incl i)
     thus ?case using i0 gen_nchotomy[of I P J] * by blast
   next
     case (ext I' j0 j)
     thus ?case
     using gen.ext[of I' P j0 J j] gen_nchotomy[of I' P J] by blast
   qed
  }
  thus ?thesis using assms by auto
qed

lemma gen_subset_gen2[simp]:
assumes "{I,J} \<subseteq> P" and "gen P I \<inter> gen P J \<noteq> {}"
shows "gen P I \<subseteq> gen P J"
proof
  fix i assume "i \<in> gen P I"
  thus "i \<in> gen P J"
  proof induct
    case (incl i)
    thus ?case
    using assms subset_gen2 by auto
  next
    case (ext I' j0 j)
    thus ?case
    using gen.ext[of I' P j0 J j] by blast
  qed
qed

lemma gen_eq_gen:
assumes "{I,J} \<subseteq> P" and "gen P I \<inter> gen P J \<noteq> {}"
shows "gen P I = gen P J"
using assms gen_subset_gen2[of I J P] gen_subset_gen2[of J I P] by blast

lemma gen_empty[simp]:
"gen P {} = {}"
proof-
  {fix j assume "j \<in> gen P {}" hence False
   apply induct by auto
  }
  thus ?thesis by auto
qed

lemma gen_empty2[simp]:
"gen {} I = I"
proof-
  {fix j assume "j \<in> gen {} I" hence "j \<in> I"
   apply induct by auto
  }
  thus ?thesis by auto
qed

lemma emp_gen[simp]:
assumes "gen P I = {}"
shows "I = {}"
by (metis all_not_in_conv assms gen.incl)

text{* partGen: *}

lemma partGen_ex:
assumes "I \<in> P"
shows "\<exists> J \<in> partGen P. I \<subseteq> J"
using assms unfolding partGen_def
apply(intro bexI[of _ "gen P I"]) by auto

lemma ex_partGen:
assumes "J \<in> partGen P" and j: "j \<in> J"
shows "\<exists> I \<in> P. j \<in> I"
proof-
  obtain I0 where I0: "I0 \<in> P" and J: "J = gen P I0"
  using assms unfolding partGen_def by auto
  thus ?thesis using j gen_incl[of I0 P] by auto
qed

lemma Union_partGen: "\<Union> partGen P = \<Union> P"
using ex_partGen[of _ P] partGen_ex[of _ P] by fastforce

lemma Int_partGen:
assumes *: "{I,J} \<subseteq> partGen P" and **: "I \<inter> J \<noteq> {}"
shows "I = J"
proof-
  obtain I0 where I0: "I0 \<in> P" and I: "I = gen P I0"
  using assms unfolding partGen_def by auto
  obtain J0 where J0: "J0 \<in> P" and J: "J = gen P J0"
  using assms unfolding partGen_def by auto
  show ?thesis using gen_eq_gen[of I0 J0 P] I0 J0 ** unfolding I J by blast
qed

lemma part_partGen:
"part (Union P) (partGen P)"
unfolding part_def apply(intro conjI allI impI)
apply (metis Union_partGen)
using Int_partGen by blast

lemma finite_partGen[simp]:
assumes "finite P"
shows "finite (partGen P)"
using assms unfolding partGen_def by auto

lemma emp_partGen[simp]:
assumes "{} \<notin> P"
shows "{} \<notin> partGen P"
using assms unfolding partGen_def using emp_gen[of P] by blast

text{* finer: *}

lemma finer_partGen:
"finer P (partGen P)"
unfolding finer_def partGen_def using gen_Union by auto

lemma finer_nchotomy:
assumes P: "part I0 P" and Q: "part I0 Q" and PQ: "finer P Q"
and I: "I \<in> P" and II: "II \<in> Q"
shows "I \<subseteq> II \<or> (I \<inter> II = {})"
proof(cases "I \<inter> II = {}")
  case False
  then obtain i where i: "i \<in> I \<and> i \<in> II" by auto
  then obtain I' where "i \<in> I'" and I': "I' \<in> P \<and> I' \<subseteq> II"
  using PQ II unfolding finer_def by blast
  hence "I Int I' \<noteq> {}" using i by blast
  hence "I = I'" using I I' P unfolding part_def by auto
  hence "I \<subseteq> II" using I' by simp
  thus ?thesis by auto
qed auto

lemma finer_ex:
assumes P: "part I0 P" and Q: "part I0 Q" and PQ: "finer P Q"
and I: "I \<in> P"
shows "\<exists> II. II \<in> Q \<and> I \<subseteq> II"
proof(cases "I = {}")
  case True
  have "Q \<noteq> {}" using I PQ unfolding finer_def by auto
  then obtain JJ where "JJ \<in> Q" by auto
  with True show ?thesis by blast
next
  case False
  then obtain i where i: "i \<in> I" by auto
  hence "i \<in> I0" using I P unfolding part_def by auto
  then obtain II where II: "II \<in> Q" and "i \<in> II" using Q unfolding part_def by auto
  hence "I Int II \<noteq> {}" using i by auto
  thus ?thesis using assms I II finer_nchotomy[of I0 P Q I II] by auto
qed

text{* partJoin: *}

lemma partJoin_commute:
"partJoin P Q = partJoin Q P"
unfolding partJoin_def partGen_def
using Un_commute by metis

lemma Union_partJoin_L:
"Union P \<subseteq> Union (partJoin P Q)"
unfolding partJoin_def partGen_def by auto

lemma Union_partJoin_R:
"Union Q \<subseteq> Union (partJoin P Q)"
unfolding partJoin_def partGen_def by auto

lemma part_partJoin[simp]:
assumes "part I P" and "part I Q"
shows "part I (partJoin P Q)"
proof-
  have 1: "Union (P Un Q) = I"
  using assms unfolding part_def by auto
  show ?thesis using part_partGen[of "P Un Q"]
  unfolding 1 partJoin_def by auto
qed

lemma finer_partJoin_L[simp]:
assumes *: "part I P" and **: "part I Q"
shows "finer P (partJoin P Q)"
proof-
  have 1: "part I (partJoin P Q)" using assms by simp
  {fix J j assume J: "J \<in> partJoin P Q" and j: "j \<in> J"
   hence "J \<subseteq> I" using 1 by (metis Union_upper part_def)
   with j have "j \<in> I" by auto
   then obtain J' where jJ': "j \<in> J'" and J': "J' \<in> P"
   using * unfolding part_def by auto
   hence "J \<inter> J' \<noteq> {}" using j by auto
   moreover obtain J0 where "J = gen (P Un Q) J0"
   and "J0 \<in> P Un Q"
   using J unfolding partJoin_def partGen_def by blast
   ultimately have "J' \<subseteq> J"
   using J' gen_nchotomy[of J' "P Un Q" J0] by blast
   hence "j \<in> \<Union>{J' \<in> P. J' \<subseteq> J}" using J' jJ' by blast
  }
  thus ?thesis unfolding finer_def
  unfolding partJoin_def partGen_def by blast
qed

lemma finer_partJoin_R[simp]:
assumes *: "part I P" and **: "part I Q"
shows "finer Q (partJoin P Q)"
using assms finer_partJoin_L[of I Q P] partJoin_commute[of P Q] by auto

lemma finer_emp[simp]:
assumes "finer {} Q"
shows "Q \<subseteq> { {} }"
using assms unfolding finer_def by auto

text{* compat: *}

lemma part_emp_R[simp]:
"part I {} \<longleftrightarrow> I = {}"
using assms unfolding part_def by auto

lemma part_emp_L[simp]:
"part {} P \<Longrightarrow> P \<subseteq> { {} }"
using assms unfolding part_def by auto

lemma finite_partJoin[simp]:
assumes "finite P" and "finite Q"
shows "finite (partJoin P Q)"
using assms unfolding partJoin_def by auto

lemma emp_partJoin[simp]:
assumes "{} \<notin> P" and "{} \<notin> Q"
shows "{} \<notin> partJoin P Q"
using assms unfolding partJoin_def by auto

text{* partCompat: *}

lemma partCompat_Un[simp]:
"partCompat (P Un Q) theta f \<longleftrightarrow>
 partCompat P theta f \<and> partCompat Q theta f"
unfolding partCompat_def by auto

lemma partCompat_gen_aux:
assumes theta: "sym theta" "trans theta"
and fP: "partCompat P theta f" and I: "I \<in> P"
and i: "i \<in> I" and j: "j \<in> gen P I" and ij: "i \<noteq> j"
shows "(f i, f j) \<in> theta"
using j ij proof induct
  case (incl j)
  thus ?case
  using fP I i unfolding partCompat_def compat_def by blast
next
  case (ext J j0 j)
  show ?case
  proof(cases "i = j0")
    case False note case_i = False
    hence 1: "(f i, f j0) \<in> theta" using ext by blast
    show ?thesis
    proof(cases "j = j0")
      case True
      thus ?thesis using case_i 1 by simp
    next
      case False
      hence "(f j, f j0) \<in> theta" using `j0 \<in> J` `j \<in> J` `J \<in> P`
      using fP unfolding partCompat_def compat_def by auto
      hence "(f j0, f j) \<in> theta" using theta unfolding sym_def by simp
      thus ?thesis using 1 theta unfolding trans_def by blast
    qed
  next
    case True note case_i = True
    hence "j0 \<noteq> j" using `i \<noteq> j` by auto
    hence "(f j0, f j) \<in> theta" using `j0 \<in> J` `j \<in> J` `J \<in> P`
    using fP unfolding partCompat_def compat_def by auto
    thus ?thesis unfolding case_i .
  qed
qed

lemma partCompat_gen:
assumes theta: "sym theta" "trans theta"
and fP: "partCompat P theta f" and I: "I \<in> P"
shows "compat (gen P I) theta f"
unfolding compat_def proof clarify
  fix i j assume ij: "{i, j} \<subseteq> gen P I"  "i \<noteq> j"
  show "(f i, f j) \<in> theta"
  proof(cases "i \<in> I")
    case True note i = True
    show ?thesis
    proof(cases "j \<in> I")
      case True
      thus ?thesis using i ij I fP unfolding partCompat_def compat_def by blast
    next
      case False
      hence "i \<noteq> j" using i by auto
      thus ?thesis using assms partCompat_gen_aux i ij by auto
    qed
  next
    case False note i = False
    show ?thesis
    proof(cases "j \<in> I")
      case True
      hence "j \<noteq> i" using i by auto
      hence "(f j, f i) \<in> theta" using assms partCompat_gen_aux[of theta P f I j i] True ij by auto
      thus ?thesis using theta unfolding sym_def by auto
    next
      case False note j = False
      show ?thesis
      proof(cases "I = {}")
        case True
        hence False using ij by simp
        thus ?thesis by simp
      next
        case False
        then obtain i0 where i0: "i0 \<in> I" by auto
        hence i0_not: "i0 \<notin> {i,j}" using i j by auto
        have "(f i0, f i) \<in> theta"
        using assms i0 i0_not ij partCompat_gen_aux[of theta P f I i0 i] by blast
        hence "(f i, f i0) \<in> theta" using theta unfolding sym_def by auto
        moreover have "(f i0, f j) \<in> theta"
        using assms i0 i0_not ij partCompat_gen_aux[of theta P f I i0 j] by blast
        ultimately show ?thesis using theta unfolding trans_def by blast
      qed
    qed
  qed
qed

lemma partCompat_partGen:
assumes "sym theta" and "trans theta"
and "partCompat P theta f"
shows "partCompat (partGen P) theta f"
unfolding partCompat_def partGen_def
using assms partCompat_gen[of theta P f] by auto

lemma partCompat_partJoin[simp]:
assumes "sym theta" and "trans theta"
and "partCompat P theta f" and "partCompat Q theta f"
shows "partCompat (partJoin P Q) theta f"
by (metis assms partCompat_Un partCompat_partGen partJoin_def)

text{* lift: *}

lemma inj_on_lift:
assumes P: "part I0 P" and Q: "part I0 Q" and PQ: "finer P Q"
and F: "inj_on F P" and FP: "part J0 (F ` P)" and emp: "{} \<notin> F ` P"
shows "inj_on (lift P F) Q"
unfolding inj_on_def proof clarify
  fix II II' assume II: "II \<in> Q" and II': "II' \<in> Q" and eq: "lift P F II = lift P F II'"
  have 1: "II = Union {I \<in> P . I \<subseteq> II}" using PQ II unfolding finer_def by auto
  have 2: "II' = Union {I \<in> P . I \<subseteq> II'}" using PQ II' unfolding finer_def by auto
  {fix I
   assume I: "I \<in> P"  "I \<subseteq> II"
   hence "F I \<subseteq> lift P F II" unfolding lift_def[abs_def] by blast
   hence 3: "F I \<subseteq> lift P F II'" unfolding eq .
   have "F I \<noteq> {}" using emp I FP by auto
   then obtain j where j: "j \<in> F I" by auto
   with 3 obtain I' where I': "I' \<in> P \<and> I' \<subseteq> II'" and "j \<in> F I'" unfolding lift_def [abs_def] by auto
   hence "F I Int F I' \<noteq> {}" using j by auto
   hence "F I = F I'" using FP I I' unfolding part_def by auto
   hence "I = I'" using F I I' unfolding inj_on_def by auto
   hence "I \<subseteq> II'" using I' by auto
  }
  hence a: "II \<subseteq> II'" using 1 2 by blast
  (*  *)
  {fix I
   assume I: "I \<in> P"  "I \<subseteq> II'"
   hence "F I \<subseteq> lift P F II'" unfolding lift_def [abs_def] by blast
   hence 3: "F I \<subseteq> lift P F II" unfolding eq .
   have "F I \<noteq> {}" using emp I FP by auto
   then obtain j where j: "j \<in> F I" by auto
   with 3 obtain I' where I': "I' \<in> P \<and> I' \<subseteq> II" and "j \<in> F I'" unfolding lift_def [abs_def] by auto
   hence "F I Int F I' \<noteq> {}" using j by auto
   hence "F I = F I'" using FP I I' unfolding part_def by auto
   hence "I = I'" using F I I' unfolding inj_on_def by auto
   hence "I \<subseteq> II" using I' by auto
  }
  hence "II' \<subseteq> II" using 1 2 by blast
  with a show "II = II'" by auto
qed

lemma part_lift:
assumes P: "part I0 P" and Q: "part I0 Q" and PQ: "finer P Q"
and F: "inj_on F P" and FP: "part J0 (F ` P)" and emp: "{} \<notin> P" "{} \<notin> F ` P"
shows "part J0 (lift P F ` Q)"
unfolding part_def proof (intro conjI allI impI)
  show "\<Union>(lift P F ` Q) = J0"
  proof safe
    fix j II assume "j \<in> lift P F II" and II: "II \<in> Q"
    then obtain I where "j \<in> F I" and "I \<in> P" and "I \<subseteq> II"
    unfolding lift_def by auto
    thus "j \<in> J0" using FP unfolding part_def by auto
  next
    fix j assume "j \<in> J0"
    then obtain J where J: "J \<in> F ` P" and j: "j \<in> J" using FP unfolding part_def by auto
    def I \<equiv> "inv_into P F J"
    have j: "j \<in> F I" unfolding I_def using j J F by auto
    have I: "I \<in> P" unfolding I_def using F J by auto
    obtain II where "I \<subseteq> II" and "II \<in> Q" using P Q PQ I finer_ex[of I0 P Q I] by auto
    thus "j \<in> \<Union> (lift P F ` Q)" unfolding lift_def [abs_def] using j I by auto
  qed
next
  fix JJ1 JJ2 assume JJ12: "JJ1 \<in> lift P F ` Q \<and> JJ2 \<in> lift P F ` Q \<and> JJ1 \<noteq> JJ2"
  then obtain II1 II2 where II12: "{II1,II2} \<subseteq> Q" and JJ1: "JJ1 = lift P F II1"
  and JJ2: "JJ2 = lift P F II2" by auto
  have "II1 \<noteq> II2" using JJ12 unfolding JJ1 JJ2 using II12 assms
  using inj_on_lift[of I0 P Q F] by auto
  hence 4: "II1 Int II2 = {}" using II12 Q unfolding part_def by auto
  show "JJ1 \<inter> JJ2 = {}"
  proof(rule ccontr)
    assume "JJ1 \<inter> JJ2 \<noteq> {}"
    then obtain j where j: "j \<in> JJ1" "j \<in> JJ2" by auto
    from j obtain I1 where "j \<in> F I1" and I1: "I1 \<in> P" "I1 \<subseteq> II1"
    unfolding JJ1 lift_def [abs_def] by auto
    moreover from j obtain I2 where "j \<in> F I2" and I2: "I2 \<in> P" "I2 \<subseteq> II2"
    unfolding JJ2 lift_def [abs_def] by auto
    ultimately have "F I1 Int F I2 \<noteq> {}" by blast
    hence "F I1 = F I2" using I1 I2 FP unfolding part_def by blast
    hence "I1 = I2" using I1 I2 F unfolding inj_on_def by auto
    moreover have "I1 \<noteq> {}" using I1 emp by auto
    ultimately have "II1 Int II2 \<noteq> {}" using I1 I2 by auto
    thus False using 4 by simp
  qed
qed

lemma finer_lift:
assumes "finer P Q"
shows "finer (F ` P) (lift P F ` Q)"
unfolding finer_def proof (intro conjI ballI impI)
  fix JJ assume JJ: "JJ \<in> lift P F ` Q"
  show "JJ = \<Union> {J \<in> F ` P. J \<subseteq> JJ}"
  proof safe
    fix j assume j: "j \<in> JJ"
    obtain II where II: "II \<in> Q" and JJ: "JJ = lift P F II" using JJ by auto
    then obtain I where j: "j \<in> F I" and I: "I \<in> P \<and> I \<subseteq> II" and "F I \<subseteq> JJ"
    using j unfolding lift_def [abs_def] by auto
    thus "j \<in> \<Union>{J \<in> F ` P. J \<subseteq> JJ}" using I j by auto
  qed auto
next
  assume "F ` P \<noteq> {}"
  thus "lift P F ` Q \<noteq> {}"
  using assms unfolding lift_def [abs_def] finer_def by simp
qed

subsection {* Basic setting for bisimilarity *}

locale PL_Indis =
  PL aval tval cval
  for aval :: "'atom \<Rightarrow> 'state \<Rightarrow> 'state" and
      tval :: "'test \<Rightarrow> 'state \<Rightarrow> bool" and
      cval :: "'choice \<Rightarrow> 'state \<Rightarrow> real" +
  fixes
    indis :: "'state rel"
  assumes
    equiv_indis: "equiv UNIV indis"

(*******************************************)
context PL_Indis
begin

abbreviation indisAbbrev (infix "\<approx>" 50)
where "s1 \<approx> s2 \<equiv> (s1, s2) \<in> indis"

lemma refl_indis: "refl indis"
and trans_indis: "trans indis"
and sym_indis: "sym indis"
using equiv_indis unfolding equiv_def by auto

lemma indis_refl[intro]: "s \<approx> s"
using refl_indis unfolding refl_on_def by simp

lemma indis_trans[trans]: "\<lbrakk>s \<approx> s'; s' \<approx> s''\<rbrakk> \<Longrightarrow> s \<approx> s''"
using trans_indis unfolding trans_def by blast

lemma indis_sym[sym]: "s \<approx> s' \<Longrightarrow> s' \<approx> s"
using sym_indis unfolding sym_def by blast

subsection{* Discreetness *}

coinductive discr where
intro:
"(\<And> s i. i < brn c \<longrightarrow> s \<approx> eff c s i \<and> discr (cont c s i))
 \<Longrightarrow> discr c"

definition discrL where
"discrL cl \<equiv> \<forall> c \<in> set cl. discr c"

lemma discrL_intro[intro]:
assumes "\<And> c. c \<in> set cl \<Longrightarrow> discr c"
shows "discrL cl"
using assms unfolding discrL_def by auto

lemma discrL_discr[simp]:
assumes "discrL cl" and "c \<in> set cl"
shows "discr c"
using assms unfolding discrL_def by simp

lemma discrL_update[simp]:
assumes cl: "discrL cl" and c': "discr c'"
shows "discrL (cl[n := c'])"
proof(cases "n < length cl")
  case True
  show ?thesis
  unfolding discrL_def proof safe
    fix c assume "c \<in> set (cl[n := c'])"
    hence "c \<in> insert c' (set cl)" using set_update_subset_insert by fastforce
    thus "discr c" using assms by (cases "c = c'") auto
  qed
qed (insert cl, auto)

text{* Coinduction for discreetness: *}

lemma discr_coind[consumes 1, case_names Hyp, induct pred: discr]:
assumes *: "phi c" and
**: "\<And> c s i. \<lbrakk> phi c ; i < brn c\<rbrakk>
       \<Longrightarrow> s \<approx> eff c s i \<and> (phi (cont c s i) \<or> discr (cont c s i))"
shows "discr c"
using * apply(induct rule: discr.coinduct) using ** by auto

lemma discr_raw_coind[consumes 1, case_names Hyp]:
assumes *: "phi c" and
**: "\<And> c s i. \<lbrakk>i < brn c; phi c\<rbrakk> \<Longrightarrow> s \<approx> eff c s i \<and> phi (cont c s i)"
shows "discr c"
using * apply(induct) using ** by blast

text{* Discreetness versus transition: *}

lemma discr_cont[simp]:
assumes *: "discr c" and **: "i < brn c"
shows "discr (cont c s i)"
using * apply(cases rule: discr.cases) using ** by blast

lemma discr_eff_indis[simp]:
assumes *: "discr c" and **: "i < brn c"
shows "s \<approx> eff c s i"
using * apply(cases rule: discr.cases) using ** by blast

subsection{* Self-isomorphism *}

coinductive siso where
intro:
"\<lbrakk>\<And> s i. i < brn c \<Longrightarrow> siso (cont c s i);
  \<And> s t i.
     i < brn c \<and> s \<approx> t \<Longrightarrow>
     eff c s i \<approx> eff c t i \<and> wt c s i = wt c t i \<and> cont c s i = cont c t i\<rbrakk>
  \<Longrightarrow> siso c"

definition sisoL where
"sisoL cl \<equiv> \<forall> c \<in> set cl. siso c"

lemma sisoL_intro[intro]:
assumes "\<And> c. c \<in> set cl \<Longrightarrow> siso c"
shows "sisoL cl"
using assms unfolding sisoL_def by auto

lemma sisoL_siso[simp]:
assumes "sisoL cl" and "c \<in> set cl"
shows "siso c"
using assms unfolding sisoL_def by simp

lemma sisoL_update[simp]:
assumes cl: "sisoL cl" and c': "siso c'"
shows "sisoL (cl[n := c'])"
proof(cases "n < length cl")
  case True
  show ?thesis
  unfolding sisoL_def proof safe
    fix c assume "c \<in> set (cl[n := c'])"
    hence "c \<in> insert c' (set cl)" using set_update_subset_insert by fastforce
    thus "siso c" using assms by (cases "c = c'") auto
  qed
qed (insert cl, auto)

text{* Coinduction for self-isomorphism: *}

lemma siso_coind[consumes 1, case_names Obs Cont, induct pred: siso]:
assumes *: "phi c" and
**: "\<And> c s t i. \<lbrakk>i < brn c; phi c; s \<approx> t\<rbrakk> \<Longrightarrow>
                 eff c s i \<approx> eff c t i \<and> wt c s i = wt c t i \<and> cont c s i = cont c t i" and
***: "\<And> c s i. \<lbrakk>i < brn c; phi c\<rbrakk> \<Longrightarrow> phi (cont c s i) \<or> siso (cont c s i)"
shows "siso c"
using * apply(induct rule: siso.coinduct) using ** *** by auto

lemma siso_raw_coind[consumes 1, case_names Obs Cont]:
assumes *: "phi c" and
***: "\<And> c s t i. \<lbrakk>i < brn c; phi c; s \<approx> t\<rbrakk> \<Longrightarrow>
                  eff c s i \<approx> eff c t i \<and> wt c s i = wt c t i \<and> cont c s i = cont c t i" and
**: "\<And> c s i. \<lbrakk>i < brn c; phi c\<rbrakk> \<Longrightarrow> phi (cont c s i)"
shows "siso c"
using * apply induct using ** *** by blast+

text{* Self-Isomorphism versus transition: *}

lemma siso_cont[simp]:
assumes *: "siso c" and **: "i < brn c"
shows "siso (cont c s i)"
using * apply(cases rule: siso.cases) using ** by blast

lemma siso_cont_indis[simp]:
assumes *: "siso c" and **: "s \<approx> t" "i < brn c"
shows "eff c s i \<approx> eff c t i \<and> wt c s i = wt c t i \<and> cont c s i = cont c t i"
using * apply(cases rule: siso.cases) using ** by blast

subsection{* Notions of bisimilarity *}

text{* Matchers *}

(* The notations are essentially the ones from the paper, except that,
   instead the paper's "Q" (which is redundant), we write "F P".
   Also, for the proper management of the proof, we have some intermediate
   predicates that compose the matchers.
*)

definition mC_C_part where
"mC_C_part c d P F \<equiv>
 {} \<notin> P \<and> {} \<notin> F ` P \<and>
 part {..< brn c} P \<and> part {..< brn d} (F ` P)"

definition mC_C_wt where
"mC_C_wt c d s t P F \<equiv> \<forall> I \<in> P. setsum (wt c s) I = setsum (wt d t) (F I)"

definition mC_C_eff_cont where
"mC_C_eff_cont theta c d s t P F \<equiv>
 \<forall> I i j.
   I \<in> P \<and> i \<in> I \<and> j \<in> F I \<longrightarrow>
   eff c s i \<approx> eff d t j \<and> (cont c s i, cont d t j) \<in> theta"

definition mC_C where
"mC_C theta c d s t P F \<equiv>
 mC_C_part c d P F \<and> inj_on F P \<and> mC_C_wt c d s t P F \<and> mC_C_eff_cont theta c d s t P F"

definition matchC_C where
"matchC_C theta c d \<equiv> \<forall> s t. s \<approx> t \<longrightarrow> (\<exists> P F. mC_C theta c d s t P F)"

(*  *)
definition mC_ZOC_part where
"mC_ZOC_part c d s t I0 P F \<equiv>
 {} \<notin> P - {I0} \<and> {} \<notin> F ` (P - {I0}) \<and> I0 \<in> P \<and>
 part {..< brn c} P \<and> part {..< brn d} (F ` P)"

definition mC_ZOC_wt where
"mC_ZOC_wt c d s t I0 P F \<equiv>
 setsum (wt c s) I0 < 1 \<and> setsum (wt d t) (F I0) < 1 \<longrightarrow>
 (\<forall> I \<in> P - {I0}.
    setsum (wt c s) I / (1 - setsum (wt c s) I0) =
    setsum (wt d t) (F I) / (1 - setsum (wt d t) (F I0)))"
(* Note: In case either setsum is 1, the above condition
   holds vacously. *)

definition mC_ZOC_eff_cont0 where
"mC_ZOC_eff_cont0 theta c d s t I0 F \<equiv>
 (\<forall> i \<in> I0. s \<approx> eff c s i \<and> (cont c s i, d) \<in> theta) \<and>
 (\<forall> j \<in> F I0. t \<approx> eff d t j \<and> (c, cont d t j) \<in> theta)"

definition mC_ZOC_eff_cont where
"mC_ZOC_eff_cont theta c d s t I0 P F \<equiv>
 \<forall> I i j.
   I \<in> P - {I0} \<and> i \<in> I \<and> j \<in> F I \<longrightarrow>
   eff c s i \<approx> eff d t j \<and>
   (cont c s i, cont d t j) \<in> theta"

definition mC_ZOC where
"mC_ZOC theta c d s t I0 P F \<equiv>
 mC_ZOC_part c d s t I0 P F \<and>
 inj_on F P \<and>
 mC_ZOC_wt c d s t I0 P F \<and>
 mC_ZOC_eff_cont0 theta c d s t I0 F \<and>
 mC_ZOC_eff_cont theta c d s t I0 P F"

definition matchC_LC where
"matchC_LC theta c d \<equiv>
 \<forall> s t. s \<approx> t \<longrightarrow> (\<exists> I0 P F. mC_ZOC theta c d s t I0 P F)"

lemmas m_defs = mC_C_def mC_ZOC_def

lemmas m_defsAll =
mC_C_def mC_C_part_def mC_C_wt_def mC_C_eff_cont_def
mC_ZOC_def mC_ZOC_part_def mC_ZOC_wt_def mC_ZOC_eff_cont0_def mC_ZOC_eff_cont_def

lemmas match_defs =
matchC_C_def matchC_LC_def

lemma mC_C_mono:
assumes "mC_C theta c d s t P F" and "theta \<subseteq> theta'"
shows "mC_C theta' c d s t P F"
using assms unfolding m_defsAll by fastforce+

lemma matchC_C_mono:
assumes "matchC_C theta c d" and "theta \<subseteq> theta'"
shows "matchC_C theta' c d"
using assms mC_C_mono unfolding matchC_C_def by blast

lemma matchC_LC_mono:
assumes "matchC_LC theta c d" and "theta \<subseteq> theta'"
shows "matchC_LC theta' c d"
using assms mC_ZOC_mono unfolding matchC_LC_def
by metis

lemma Int_not_in_eq_emp:
"P \<inter> {I. I \<notin> P} = {}"
by blast

lemma mC_C_mC_ZOC:
assumes "mC_C theta c d s t P F"
shows "mC_ZOC theta c d s t {} (P Un { {} }) (%I. if I \<in> P then F I else {})"
(is "mC_ZOC theta c d s t ?I0 ?Q ?G")
unfolding mC_ZOC_def proof(intro conjI)
  show "mC_ZOC_part c d s t ?I0 ?Q ?G"
  unfolding mC_ZOC_part_def using assms unfolding mC_C_def mC_C_part_def
  by (auto simp add: Int_not_in_eq_emp)
next
  show "inj_on ?G ?Q"
  unfolding inj_on_def proof clarify
    fix I1 I2 assume I12: "I1 \<in> ?Q" "I2 \<in> ?Q"
    and G: "?G I1 = ?G I2"
    show "I1 = I2"
    proof(cases "I1 \<in> P")
      case True
      hence I2: "I2 \<in> P" apply(rule_tac ccontr)
      using G assms unfolding mC_C_def mC_C_part_def by auto
      with True G have "F I1 = F I2" by simp
      thus ?thesis using True I2 I12 assms unfolding mC_C_def inj_on_def by blast
    next
      case False note case1 = False
      hence I1: "I1 = {}" using I12 by blast
      show ?thesis
      proof(cases "I2 \<in> P")
        case False
        hence "I2 = {}" using I12 by blast
        thus ?thesis using I1 by blast
      next
        case True
        hence "I1 \<in> P" apply(rule_tac ccontr)
        using G assms unfolding mC_C_def mC_C_part_def by auto
        thus ?thesis using case1 by simp
      qed
    qed
  qed
qed(insert assms, unfold m_defsAll, fastforce+)

lemma matchC_C_matchC_LC:
assumes "matchC_C theta c d"
shows "matchC_LC theta c d"
using assms mC_C_mC_ZOC unfolding match_defs by blast

text{* Retracts: *}

(* Strong retract: *)
definition Sretr where
"Sretr theta \<equiv>
 {(c, d). matchC_C theta c d}"

(* Zero-One retract: *)
definition ZOretr where
"ZOretr theta \<equiv>
 {(c,d). matchC_LC theta c d}"

lemmas Retr_defs =
Sretr_def
ZOretr_def

lemma mono_Retr:
"mono Sretr"
"mono ZOretr"
unfolding mono_def Retr_defs
by (auto simp add: matchC_C_mono matchC_LC_mono)

lemma Retr_incl:
"Sretr theta \<subseteq> ZOretr theta"
unfolding Retr_defs
using matchC_C_matchC_LC by blast+

text{* The associated bisimilarity relations: *}

definition Sbis where "Sbis \<equiv> gfp Sretr"
definition ZObis where "ZObis \<equiv> gfp ZOretr"

abbreviation Sbis_abbrev (infix "\<approx>s" 55) where "c \<approx>s d \<equiv> (c, d) : Sbis"
abbreviation ZObis_abbrev (infix "\<approx>01" 55) where "c \<approx>01 d \<equiv> (c, d) : ZObis"

lemmas bis_defs = Sbis_def ZObis_def

(* Inclusions between bisimilarities: *)
lemma bis_incl:
"Sbis \<le> ZObis"
unfolding bis_defs
using Retr_incl gfp_mono by blast+

lemma bis_imp[simp]:
"\<And> c1 c2. c1 \<approx>s c2 \<Longrightarrow> c1 \<approx>01 c2"
using bis_incl unfolding bis_defs by auto

(*  Sbis: *)

lemma Sbis_prefix:
"Sbis \<le> Sretr Sbis"
unfolding Sbis_def
by (metis gfp_lemma2 mono_Retr)

lemma Sbis_fix:
"Sretr Sbis = Sbis"
unfolding Sbis_def
by (metis def_gfp_unfold mono_Retr(1))

lemma Sbis_mC_C:
assumes "c \<approx>s d" and "s \<approx> t"
shows "\<exists>P F. mC_C Sbis c d s t P F"
using assms Sbis_prefix unfolding Sretr_def matchC_C_def by auto

lemma Sbis_coind:
assumes "theta \<le> Sretr (theta Un Sbis)"
shows "theta \<le> Sbis"
using assms unfolding Sbis_def
by (metis Sbis_def assms def_coinduct mono_Retr(1))

lemma Sbis_raw_coind:
assumes "theta \<le> Sretr theta"
shows "theta \<le> Sbis"
proof-
  have "Sretr theta \<subseteq> Sretr (theta Un Sbis)"
  by (metis Un_upper1 monoD mono_Retr(1))
  hence "theta \<subseteq> Sretr (theta Un Sbis)" using assms by blast
  thus ?thesis using Sbis_coind by blast
qed

(* Symmetry *)

lemma mC_C_sym:
assumes "mC_C theta c d s t P F"
shows "mC_C (theta ^-1) d c t s (F ` P) (inv_into P F)"
unfolding mC_C_def proof (intro conjI)
  show "mC_C_eff_cont (theta\<inverse>) d c t s (F ` P) (inv_into P F)"
  unfolding mC_C_eff_cont_def proof clarify
    fix i j I
    assume I: "I \<in> P" and j: "j \<in> F I" and "i \<in> inv_into P F (F I)"
    hence "i \<in> I" using assms unfolding mC_C_def by auto
    hence "eff c s i \<approx> eff d t j \<and> (cont c s i, cont d t j) \<in> theta"
    using assms I j unfolding mC_C_def mC_C_eff_cont_def by auto
    thus "eff d t j \<approx> eff c s i \<and> (cont d t j, cont c s i) \<in> theta\<inverse>"
    by (metis converseI indis_sym)
  qed
qed(insert assms, unfold m_defsAll, auto)

lemma matchC_C_sym:
assumes "matchC_C theta c d"
shows "matchC_C (theta ^-1) d c"
unfolding matchC_C_def proof clarify
  fix t s
  assume "t \<approx> s"  hence "s \<approx> t" by (metis indis_sym)
  then obtain P F where "mC_C theta c d s t P F"
  using assms unfolding matchC_C_def by blast
  hence "mC_C (theta\<inverse>) d c t s (F ` P) (inv_into P F)"
  using mC_C_sym by auto
  thus "\<exists>Q G. mC_C (theta\<inverse>) d c t s Q G" by blast
qed

lemma Sretr_sym:
assumes "sym theta"
shows "sym (Sretr theta)"
unfolding sym_def proof clarify
  fix c d assume "(c, d) \<in> Sretr theta"
  hence "(d, c) \<in> Sretr (theta ^-1)"
  unfolding Sretr_def using matchC_C_sym by simp
  thus "(d, c) \<in> Sretr theta"
  using assms by (metis sym_conv_converse_eq)
qed

lemma sym_Sbis: "sym Sbis"
by (metis Sbis_def Sretr_sym mono_Retr(1) sym_gfp)

lemma Sbis_sym: "c \<approx>s d \<Longrightarrow> d \<approx>s c"
using sym_Sbis unfolding sym_def by blast

(* Transitivity: *)

lemma mC_C_trans:
assumes *: "mC_C theta1 c d s t P F" and **: "mC_C theta2 d e t u (F ` P) G"
shows "mC_C (theta1 O theta2) c e s u P (G o F)"
unfolding mC_C_def proof (intro conjI)
  show "mC_C_part c e P (G \<circ> F)"
  using assms unfolding mC_C_def mC_C_part_def by (auto simp add: image_comp)
next
  show "inj_on (G \<circ> F) P"
  using assms unfolding mC_C_def by (auto simp add: comp_inj_on)
next
  show "mC_C_eff_cont (theta1 O theta2) c e s u P (G \<circ> F)"
  unfolding mC_C_eff_cont_def proof clarify
    fix I i k
    assume I: "I \<in> P" and i: "i \<in> I" and k: "k \<in> (G \<circ> F) I"
    have "F I \<noteq> {}" using * I unfolding mC_C_def mC_C_part_def by auto
    then obtain j where j: "j \<in> F I" by auto
    have "eff c s i \<approx> eff d t j \<and> (cont c s i, cont d t j) \<in> theta1"
    using I i j * unfolding mC_C_def mC_C_eff_cont_def by auto
    moreover
    have "eff d t j \<approx> eff e u k \<and> (cont d t j, cont e u k) \<in> theta2"
    using I j k ** unfolding mC_C_def mC_C_eff_cont_def by auto
    ultimately
    show "eff c s i \<approx> eff e u k \<and> (cont c s i, cont e u k) \<in> theta1 O theta2"
    using indis_trans by blast
  qed
qed(insert assms, unfold m_defsAll, auto)

lemma mC_C_finer:
assumes *: "mC_C theta c d s t P F"
and theta: "trans theta"
and Q: "finer P Q" "finite Q" "{} \<notin> Q" "part {..<brn c} Q"
and c: "partCompat Q indis (eff c s)" "partCompat Q theta (cont c s)"
shows "mC_C theta c d s t Q (lift P F)"
unfolding mC_C_def proof (intro conjI)
  show "mC_C_part c d Q (lift P F)"
  unfolding mC_C_part_def proof(intro conjI)
    show "{} \<notin> lift P F ` Q" unfolding lift_def [abs_def] proof clarify
     fix II assume 1: "{} = \<Union>{F I |I. I \<in> P \<and> I \<subseteq> II}" and II: "II \<in> Q"
      hence "II \<noteq> {}" using Q by auto
      then obtain I where I: "I \<in> P" and "I \<subseteq> II"
      using Q II unfolding finer_def by blast
      hence "F I = {}" using 1 by auto
      thus False using * I unfolding mC_C_def mC_C_part_def by auto
    qed
  next
    show "part {..<brn d} (lift P F ` Q)"
    using Q * part_lift[of "{..<brn c}" P Q F "{..<brn d}"]
    unfolding mC_C_def mC_C_part_def by auto
  qed (insert Q, auto)
next
  show "inj_on (lift P F) Q"
  using Q * inj_on_lift[of "{..<brn c}" P Q F "{..<brn d}"]
  unfolding mC_C_def mC_C_part_def by auto
next
  show "mC_C_wt c d s t Q (lift P F)"
  unfolding mC_C_wt_def proof clarify
    fix II assume II: "II \<in> Q"
    def S \<equiv> "{I \<in> P . I \<subseteq> II}"
    have II: "II = (UN I : S . id I)" using II Q unfolding finer_def S_def by auto
    have S: "\<And> I J. \<lbrakk>I : S; J : S; I \<noteq> J\<rbrakk> \<Longrightarrow> id I Int id J = {}" "finite S"
    unfolding S_def using * finite_part[of "{..<brn c}" P] unfolding mC_C_def mC_C_part_def part_def by auto
    have SS: "\<forall>I\<in>S. finite I" "\<forall>i\<in>S. finite (F i)"
    unfolding S_def using * unfolding mC_C_def mC_C_part_def part_def apply simp_all
    apply (metis complete_lattice_class.Sup_upper finite_lessThan finite_subset)
    by (metis finite_UN finite_UnionD finite_lessThan)
    have SSS: "\<forall>i\<in>S. \<forall>j\<in>S. i \<noteq> j \<longrightarrow> F i \<inter> F j = {}"
    proof clarify
      fix I J assume "I \<in> S" and "J \<in> S" and diff: "I \<noteq> J"
      hence IJ: "{I,J} \<subseteq> P" unfolding S_def by simp
      hence "F I \<noteq> F J" using * diff unfolding mC_C_def inj_on_def by auto
      thus "F I \<inter> F J = {}" using * IJ unfolding mC_C_def mC_C_part_def part_def by auto
    qed
    have "setsum (wt c s) II = setsum (setsum (wt c s)) S"
    unfolding II using S SS setsum.UNION_disjoint[of S id "wt c s"] by simp
    also have "... = setsum (% I. setsum (wt d t) (F I)) S"
    apply(rule setsum.cong)
    using S apply force
    unfolding S_def using * unfolding mC_C_def mC_C_part_def mC_C_wt_def by auto
    also have "... = setsum (wt d t) (UN I : S . F I)"
    unfolding lift_def using S setsum.UNION_disjoint[of S F "wt d t"] S SS SSS by simp
    also have "(UN I : S . F I) = lift P F II" unfolding lift_def S_def by auto
    finally show "setsum (wt c s) II = setsum (wt d t) (lift P F II)" .
  qed
next
  show "mC_C_eff_cont theta c d s t Q (lift P F)"
  unfolding mC_C_eff_cont_def proof clarify
    fix II i j
    assume II: "II \<in> Q" and i: "i \<in> II" and "j \<in> lift P F II"
    then obtain I where j: "j \<in> F I" and I: "I \<in> P \<and> I \<subseteq> II" unfolding lift_def by auto
    hence "I \<noteq> {}" using * unfolding mC_C_def mC_C_part_def by auto
    then obtain i' where i': "i' \<in> I" by auto
    hence 1: "eff c s i' \<approx> eff d t j \<and> (cont c s i', cont d t j) \<in> theta"
    using * j I unfolding mC_C_def mC_C_eff_cont_def by auto
    show "eff c s i \<approx> eff d t j \<and> (cont c s i, cont d t j) \<in> theta"
    proof(cases "i' = i")
      case True show ?thesis using 1 unfolding True .
    next
      case False
      moreover have "i' \<in> II" using I i' by auto
      ultimately have "eff c s i \<approx> eff c s i' \<and> (cont c s i, cont c s i') \<in> theta"
      using i II c unfolding partCompat_def compat_def by auto
      thus ?thesis using 1 indis_trans theta unfolding trans_def by blast
    qed
  qed
qed

lemma mC_C_partCompat_eff:
assumes *: "mC_C theta c d s t P F"
shows "partCompat P indis (eff c s)"
unfolding partCompat_def compat_def proof clarify
  fix I i i' assume I: "I \<in> P" and ii': "{i, i'} \<subseteq> I" "i \<noteq> i'"
  hence "F I \<noteq> {}" using * unfolding m_defsAll by blast
  then obtain j where j: "j \<in> F I" by auto
  from ii' j I have 1: "eff c s i \<approx> eff d t j"
  using * unfolding m_defsAll by blast
  from ii' j I have 2: "eff c s i' \<approx> eff d t j"
  using * unfolding m_defsAll by blast
  from 1 2 show "eff c s i \<approx> eff c s i'"
  using indis_trans indis_sym by blast
qed

lemma mC_C_partCompat_cont:
assumes *: "mC_C theta c d s t P F"
and theta: "sym theta" "trans theta"
shows "partCompat P theta (cont c s)"
unfolding partCompat_def compat_def proof clarify
  fix I i i' assume I: "I \<in> P" and ii': "{i, i'} \<subseteq> I" "i \<noteq> i'"
  hence "F I \<noteq> {}" using * unfolding m_defsAll by blast
  then obtain j where j: "j \<in> F I" by auto
  from ii' j I have 1: "(cont c s i, cont d t j) \<in> theta"
  using * unfolding m_defsAll by blast
  from ii' j I have 2: "(cont c s i', cont d t j) \<in> theta"
  using * unfolding m_defsAll by blast
  from 1 2 show "(cont c s i, cont c s i')  \<in> theta"
  using theta unfolding trans_def sym_def by blast
qed

lemma matchC_C_sym_trans:
assumes *: "matchC_C theta c1 c" and **: "matchC_C theta c c2"
and theta: "sym theta" "trans theta"
shows "matchC_C theta c1 c2"
unfolding matchC_C_def proof clarify
  fix s1 s2 assume s1s2: "s1 \<approx> s2"
  def s \<equiv> "s1"
  have s: "s \<approx> s1 \<and> s \<approx> s2" unfolding s_def using s1s2 by auto
  have th: "theta ^-1 = theta" "theta O theta \<subseteq> theta" using theta
  by (metis sym_conv_converse_eq trans_O_subset)+
  hence *: "matchC_C theta c c1" by (metis * matchC_C_sym)
  from s * obtain P1 F1 where m1: "mC_C theta c c1 s s1 P1 F1"
  unfolding matchC_C_def by blast
  from s ** obtain P2 F2 where m2: "mC_C theta c c2 s s2 P2 F2"
  unfolding matchC_C_def by blast
  def P \<equiv> "partJoin P1 P2"
  (*  *)
  have P:
  "finer P1 P \<and> finer P2 P \<and>
   finite P \<and> {} \<notin> P \<and> part {..< brn c} P"
  using m1 m2 finer_partJoin_L finite_partJoin emp_partJoin part_partJoin finite_part[of "{..< brn c}" P]
  unfolding P_def mC_C_def mC_C_part_def by force
  (*  *)
  have "mC_C theta c c1 s s1 P (lift P1 F1)"
  proof(rule mC_C_finer)
    show "partCompat P indis (eff c s)"
    unfolding P_def apply(rule partCompat_partJoin)
    using m1 m2 sym_indis trans_indis mC_C_partCompat_eff by auto
  next
    show "partCompat P theta (cont c s)"
    unfolding P_def apply(rule partCompat_partJoin)
    using m1 m2 theta mC_C_partCompat_cont by auto
  qed(insert P m1 theta, auto)
  hence A: "mC_C theta c1 c s1 s (lift P1 F1 ` P) (inv_into P (lift P1 F1))"
  using mC_C_sym[of theta c c1 s s1 P "lift P1 F1"] unfolding th by blast
  (*  *)
  have B: "mC_C theta c c2 s s2 P (lift P2 F2)"
  proof(rule mC_C_finer)
    show "partCompat P indis (eff c s)"
    unfolding P_def apply(rule partCompat_partJoin)
    using m1 m2 sym_indis trans_indis mC_C_partCompat_eff by auto
  next
    show "partCompat P theta (cont c s)"
    unfolding P_def apply(rule partCompat_partJoin)
    using m1 m2 theta mC_C_partCompat_cont by auto
  qed(insert P m2 theta, auto)
  (*  *)
  have "inj_on (lift P1 F1) P"
  apply(rule inj_on_lift) using m1 m2 P unfolding m_defsAll by auto
  hence "inv_into P (lift P1 F1) ` lift P1 F1 ` P = P"
  by (metis inj_on_inv_into)
  hence "mC_C (theta O theta) c1 c2 s1 s2 (lift P1 F1 ` P) (lift P2 F2 o (inv_into P (lift P1 F1)))"
  apply - apply(rule mC_C_trans[of theta c1 c s1 s _ _ theta c2 s2])
  using A B by auto
  hence "mC_C theta c1 c2 s1 s2 (lift P1 F1 ` P) (lift P2 F2 o (inv_into P (lift P1 F1)))"
  using th mC_C_mono by blast
  thus "\<exists>R H. mC_C theta c1 c2 s1 s2 R H" by blast
qed

lemma Sretr_sym_trans:
assumes "sym theta \<and> trans theta"
shows "trans (Sretr theta)"
unfolding trans_def proof clarify
  fix c d e assume "(c, d) \<in> Sretr theta" and "(d, e) \<in> Sretr theta"
  thus "(c, e) \<in> Sretr theta"
  unfolding Sretr_def using assms matchC_C_sym_trans by blast
qed

lemma trans_Sbis: "trans Sbis"
by (metis Sbis_def Sretr_sym Sretr_sym_trans mono_Retr sym_trans_gfp)

lemma Sbis_trans: "\<lbrakk>c \<approx>s d; d \<approx>s e\<rbrakk> \<Longrightarrow> c \<approx>s e"
using trans_Sbis unfolding trans_def by blast

(* ZObis: *)

lemma ZObis_prefix:
"ZObis \<le> ZOretr ZObis"
unfolding ZObis_def
by (metis gfp_lemma2 mono_Retr)

lemma ZObis_fix:
"ZOretr ZObis = ZObis"
unfolding ZObis_def
by (metis def_gfp_unfold mono_Retr(2))

lemma ZObis_mC_ZOC:
assumes "c \<approx>01 d" and "s \<approx> t"
shows "\<exists>I0  P F. mC_ZOC ZObis c d s t I0 P F"
using assms ZObis_prefix unfolding ZOretr_def matchC_LC_def by blast

lemma ZObis_coind:
assumes "theta \<le> ZOretr (theta Un ZObis)"
shows "theta \<le> ZObis"
using assms unfolding ZObis_def
by (metis ZObis_def assms def_coinduct mono_Retr(2))

lemma ZObis_raw_coind:
assumes "theta \<le> ZOretr theta"
shows "theta \<le> ZObis"
proof-
  have "ZOretr theta \<subseteq> ZOretr (theta Un ZObis)"
  by (metis Un_upper1 monoD mono_Retr)
  hence "theta \<subseteq> ZOretr (theta Un ZObis)" using assms by blast
  thus ?thesis using ZObis_coind by blast
qed

(* Symmetry *)

lemma mC_ZOC_sym:
assumes theta: "sym theta" and *: "mC_ZOC theta c d s t I0 P F"
shows "mC_ZOC theta d c t s (F I0) (F ` P) (inv_into P F)"
unfolding mC_ZOC_def proof (intro conjI)
  show "mC_ZOC_part d c t s (F I0) (F ` P) (inv_into P F)"
  unfolding mC_ZOC_part_def proof(intro conjI)
    have 0: "inj_on F P" "I0 \<in> P" using * unfolding mC_ZOC_def mC_ZOC_part_def by blast+
    have "inv_into P F ` (F ` P - {F I0}) = inv_into P F ` (F ` (P - {I0}))"
    using 0 inj_on_image_set_diff[of F P P "{I0}"] by simp
    also have "... = P - {I0}" using 0 by (metis Diff_subset inv_into_image_cancel)
    finally have "inv_into P F ` (F ` P - {F I0}) = P - {I0}" .
    thus "{} \<notin> inv_into P F ` (F ` P - {F I0})"
    using * unfolding mC_ZOC_def mC_ZOC_part_def by simp
  (*  *)
    have "part {..<brn c} P" using * unfolding mC_ZOC_def mC_ZOC_part_def by blast
    thus "part {..<brn c} (inv_into P F ` F ` P)" using 0 by auto
  qed(insert *, unfold mC_ZOC_def mC_ZOC_part_def, blast+)
next
  have 0: "inj_on F P" "I0 \<in> P" using * unfolding mC_ZOC_def mC_ZOC_part_def by blast+
  show "mC_ZOC_wt d c t s (F I0) (F ` P) (inv_into P F)"
  unfolding mC_ZOC_wt_def proof(intro conjI ballI impI)
    fix J assume "J \<in> F ` P - {F I0}" and le_1: "setsum (wt d t) (F I0) < 1 \<and> setsum (wt c s) (inv_into P F (F I0)) < 1"
    then obtain I where I: "I \<in> P - {I0}" and J: "J = F I"
      by (metis image_iff member_remove remove_def)
    have 2: "inv_into P F J = I" unfolding J using 0 I by simp
    have 3: "inv_into P F (F I0) = I0" using 0 by simp
    show
    "setsum (wt d t) J / (1 - setsum (wt d t) (F I0)) =
     setsum (wt c s) (inv_into P F J) / (1 - setsum (wt c s) (inv_into P F (F I0)))"
    unfolding 2 3 unfolding J
    using * I le_1 unfolding mC_ZOC_def mC_ZOC_wt_def by (metis 3 J)
  qed
next
  show "mC_ZOC_eff_cont theta d c t s (F I0) (F ` P) (inv_into P F)"
  unfolding mC_ZOC_eff_cont_def proof(intro allI impI, elim conjE)
    fix i j J
    assume "J \<in> F ` P - {F I0}" and j: "j \<in> J" and i: "i \<in> inv_into P F J"
    then obtain I where J: "J = F I" and I: "I \<in> P - {I0}"
      by (metis image_iff member_remove remove_def)
    hence "i \<in> I" using assms i unfolding mC_ZOC_def by auto
    hence "eff c s i \<approx> eff d t j \<and> (cont c s i, cont d t j) \<in> theta"
    using assms I j unfolding mC_ZOC_def mC_ZOC_eff_cont_def J by auto
    thus "eff d t j \<approx> eff c s i \<and> (cont d t j, cont c s i) \<in> theta"
    by (metis assms indis_sym sym_def)
  qed
qed(insert assms, unfold sym_def m_defsAll, auto)

lemma matchC_LC_sym:
assumes *: "sym theta" and "matchC_LC theta c d"
shows "matchC_LC theta d c"
unfolding matchC_LC_def proof clarify
  fix t s
  assume "t \<approx> s"  hence "s \<approx> t" by (metis indis_sym)
  then obtain I0 P F where "mC_ZOC theta c d s t I0 P F"
  using assms unfolding matchC_LC_def by blast
  hence "mC_ZOC theta d c t s (F I0) (F ` P) (inv_into P F)"
  using mC_ZOC_sym * by auto
  thus "\<exists>I0 Q G. mC_ZOC theta d c t s I0 Q G" by blast
qed

lemma ZOretr_sym:
assumes "sym theta"
shows "sym (ZOretr theta)"
unfolding sym_def proof clarify
  fix c d assume "(c, d) \<in> ZOretr theta"
  hence "(d, c) \<in> ZOretr theta"
  unfolding ZOretr_def using assms matchC_LC_sym by simp
  thus "(d, c) \<in> ZOretr theta"
  using assms by (metis sym_conv_converse_eq)
qed

lemma sym_ZObis: "sym ZObis"
by (metis ZObis_def ZOretr_sym mono_Retr sym_gfp)

lemma ZObis_sym: "c \<approx>01 d \<Longrightarrow> d \<approx>01 c"
using sym_ZObis unfolding sym_def by blast

subsection {* List versions of the bisimilarities *}

(* For Sbis: *)

definition SbisL where
"SbisL cl dl \<equiv>
 length cl = length dl \<and> (\<forall> n < length cl. cl ! n \<approx>s dl ! n)"

lemma SbisL_intro[intro]:
assumes "length cl = length dl" and
"\<And> n. \<lbrakk>n < length cl; n < length dl\<rbrakk> \<Longrightarrow> cl ! n \<approx>s dl ! n"
shows "SbisL cl dl"
using assms unfolding SbisL_def by auto

lemma SbisL_length[simp]:
assumes "SbisL cl dl"
shows "length cl = length dl"
using assms unfolding SbisL_def by simp

lemma SbisL_Sbis[simp]:
assumes "SbisL cl dl" and "n < length cl \<or> n < length dl"
shows "cl ! n \<approx>s dl ! n"
using assms unfolding SbisL_def by simp

lemma SbisL_update[simp]:
assumes cldl: "SbisL cl dl" and c'd': "c' \<approx>s d'"
shows "SbisL (cl [n := c']) (dl [n := d'])" (is "SbisL ?cl' ?dl'")
proof(cases "n < length cl")
  case True
  show ?thesis proof
    fix m assume m: "m < length ?cl'" "m < length ?dl'"
    thus "?cl' ! m \<approx>s ?dl' ! m" using assms by (cases "m = n") auto
  qed (insert cldl, simp)
qed (insert cldl, simp)

lemma SbisL_update_L[simp]:
assumes "SbisL cl dl" and "c' \<approx>s dl!n"
shows "SbisL (cl[n := c']) dl"
proof-
  let ?d' = "dl!n"
  have "SbisL (cl[n := c']) (dl[n := ?d'])"
  apply(rule SbisL_update) using assms by auto
  thus ?thesis by simp
qed

lemma SbisL_update_R[simp]:
assumes "SbisL cl dl" and "cl!n \<approx>s d'"
shows "SbisL cl (dl[n := d'])"
proof-
  let ?c' = "cl!n"
  have "SbisL (cl[n := ?c']) (dl[n := d'])"
  apply(rule SbisL_update) using assms by auto
  thus ?thesis by simp
qed

(* For ZObis: *)

definition ZObisL where
"ZObisL cl dl \<equiv>
 length cl = length dl \<and> (\<forall> n < length cl. cl ! n \<approx>01 dl ! n)"

lemma ZObisL_intro[intro]:
assumes "length cl = length dl" and
"\<And> n. \<lbrakk>n < length cl; n < length dl\<rbrakk> \<Longrightarrow> cl ! n \<approx>01 dl ! n"
shows "ZObisL cl dl"
using assms unfolding ZObisL_def by auto

lemma ZObisL_length[simp]:
assumes "ZObisL cl dl"
shows "length cl = length dl"
using assms unfolding ZObisL_def by simp

lemma ZObisL_ZObis[simp]:
assumes "ZObisL cl dl" and "n < length cl \<or> n < length dl"
shows "cl ! n \<approx>01 dl ! n"
using assms unfolding ZObisL_def by simp

lemma ZObisL_update[simp]:
assumes cldl: "ZObisL cl dl" and c'd': "c' \<approx>01 d'"
shows "ZObisL (cl [n := c']) (dl [n := d'])" (is "ZObisL ?cl' ?dl'")
proof(cases "n < length cl")
  case True
  show ?thesis proof
    fix m assume m: "m < length ?cl'" "m < length ?dl'"
    thus "?cl' ! m \<approx>01 ?dl' ! m" using assms by (cases "m = n") auto
  qed (insert cldl, simp)
qed (insert cldl, simp)

lemma ZObisL_update_L[simp]:
assumes "ZObisL cl dl" and "c' \<approx>01 dl!n"
shows "ZObisL (cl[n := c']) dl"
proof-
  let ?d' = "dl!n"
  have "ZObisL (cl[n := c']) (dl[n := ?d'])"
  apply(rule ZObisL_update) using assms by auto
  thus ?thesis by simp
qed

lemma ZObisL_update_R[simp]:
assumes "ZObisL cl dl" and "cl!n \<approx>01 d'"
shows "ZObisL cl (dl[n := d'])"
proof-
  let ?c' = "cl!n"
  have "ZObisL (cl[n := ?c']) (dl[n := d'])"
  apply(rule ZObisL_update) using assms by auto
  thus ?thesis by simp
qed

subsection{* Discreetness for configurations *}

coinductive discrCf where
intro:
"(\<And> i. i < brn (fst cf) \<longrightarrow>
       snd cf \<approx> snd (cont_eff cf i) \<and> discrCf (cont_eff cf i))
 \<Longrightarrow> discrCf cf"

text{* Coinduction for discrness: *}

lemma discrCf_coind[consumes 1, case_names Hyp, induct pred: discr]:
assumes *: "phi cf" and
**: "\<And> cf i.
       \<lbrakk>i < brn (fst cf); phi cf\<rbrakk> \<Longrightarrow>
        snd cf \<approx> snd (cont_eff cf i) \<and> (phi (cont_eff cf i) \<or> discrCf (cont_eff cf i))"
shows "discrCf cf"
using * apply(induct rule: discrCf.coinduct) using ** by auto

lemma discrCf_raw_coind[consumes 1, case_names Hyp]:
assumes *: "phi cf" and
**: "\<And> cf i. \<lbrakk>i < brn (fst cf); phi cf\<rbrakk> \<Longrightarrow>
              snd cf \<approx> snd (cont_eff cf i) \<and> phi (cont_eff cf i)"
shows "discrCf cf"
using * apply(induct) using ** by blast

text{* Discreetness versus transition: *}

lemma discrCf_cont[simp]:
assumes *: "discrCf cf" and **: "i < brn (fst cf)"
shows "discrCf (cont_eff cf i)"
using * apply(cases rule: discrCf.cases) using ** by blast

lemma discrCf_eff_indis[simp]:
assumes *: "discrCf cf" and **: "i < brn (fst cf)"
shows "snd cf \<approx> snd (cont_eff cf i)"
using * apply(cases rule: discrCf.cases) using ** by blast

lemma discr_discrCf:
assumes "discr c"
shows "discrCf (c, s)"
proof-
  {fix cf :: "('test, 'atom, 'choice) cmd \<times> 'state"
   assume "discr (fst cf)"
   hence "discrCf cf"
   apply (induct)
   using discr_eff_indis discr_cont unfolding eff_def cont_def cont_eff_def by auto
  }
  thus ?thesis using assms by auto
qed

lemma ZObis_pres_discrCfL:
assumes "fst cf \<approx>01 fst df" and "snd cf \<approx> snd df" and "discrCf df"
shows "discrCf cf"
proof-
  have "\<exists> df. fst cf \<approx>01 fst df \<and> snd cf \<approx> snd df \<and> discrCf df" using assms by blast
  thus ?thesis
  proof (induct rule: discrCf_raw_coind)
    case (Hyp cf i)
    then obtain df where i: "i < brn (fst cf)" and
    df: "discrCf df" and cf_df: "fst cf \<approx>01 fst df" "snd cf \<approx> snd df" by blast
    then obtain I0 P F where
    match: "mC_ZOC ZObis (fst cf) (fst df) (snd cf) (snd df) I0 P F"
    using ZObis_mC_ZOC by blast
    hence "\<Union>P = {..<brn (fst cf)}"
    using i unfolding mC_ZOC_def mC_ZOC_part_def part_def by simp
    then obtain I where I: "I \<in> P" and i: "i \<in> I" using i by auto
    show ?case
    proof(cases "I = I0")
      case False
      then obtain j where j: "j \<in> F I" using match I False unfolding m_defsAll by blast
      hence "j < brn (fst df)" using I match
      unfolding mC_ZOC_def mC_ZOC_part_def part_def apply simp by blast
      hence md: "discrCf (cont_eff df j)" and s: "snd df \<approx> snd (cont_eff df j)"
      using df discrCf_cont[of df j] discrCf_eff_indis[of df j] by auto
      have 0: "snd (cont_eff cf i) \<approx> snd (cont_eff df j)" and
      md2: "fst (cont_eff cf i) \<approx>01 fst (cont_eff df j)"
      using I i j match False unfolding mC_ZOC_def mC_ZOC_eff_cont_def
      unfolding eff_def cont_def cont_eff_def by auto
      hence "snd cf \<approx> snd (cont_eff cf i)" using s indis_sym indis_trans cf_df by blast
      thus ?thesis using md md2 0 by blast
    next
      case True
      hence "snd cf \<approx> snd (cont_eff cf i) \<and> fst (cont_eff cf i) \<approx>01 fst df"
      using match i ZObis_sym unfolding mC_ZOC_def mC_ZOC_eff_cont0_def
      unfolding cont_eff_def cont_def eff_def by blast
      moreover have "snd (cont_eff cf i) \<approx> snd df"
      using match i indis_sym indis_trans cf_df unfolding mC_ZOC_def mC_ZOC_eff_cont0_def
      unfolding cont_eff_def cont_def eff_def True by blast
      ultimately show ?thesis using df cf_df by blast
    qed
  qed
qed

corollary ZObis_pres_discrCfR:
assumes "discrCf cf" and "fst cf \<approx>01 fst df" and "snd cf \<approx> snd df"
shows "discrCf df"
using assms ZObis_pres_discrCfL ZObis_sym indis_sym by blast

end (* context PL_Indis *)
(*******************************************)

end


theory GodProof imports Main

abbrevs
 mneg="\<^bold>\<not>" mor="( \<^bold>\<or> )" mand="( \<^bold>\<and> )" mimpl="( \<^bold>\<rightarrow> )" mequ="( \<^bold>\<leftrightarrow> )"
 mor="\<^bold>\<or>" mand="\<^bold>\<and>" mimpl="\<^bold>\<rightarrow>" mequ="\<^bold>\<leftrightarrow>"
 mequpred="\<^sup>\<not>" mequal="( \<^bold>= )" mequal="\<^bold>=" mequal="( \<^bold>=L )" mequal="\<^bold>=L"
 malli="(\<^bold>\<forall>\<^sup>ix. )" mallp="(\<^bold>\<forall>\<^sup>p\<Phi>. )" mexii="(\<^bold>\<exists>\<^sup>ix. )" mexip="(\<^bold>\<exists>\<^sup>p\<Phi>. )"
 malli="\<^bold>\<forall>\<^sup>i" mallp="\<^bold>\<forall>\<^sup>p" maxii="\<^bold>\<exists>\<^sup>i" mexip="\<^bold>\<exists>\<^sup>p"
 mbox="(\<^bold>\<box> )" mdia="(\<^bold>\<diamond> )"
 mbox="\<^bold>\<box>" media="\<^bold>\<diamond>"
 mvalid="\<lfloor>\<rfloor>"  mvalid="\"\<lfloor>\<rfloor>\""
 P="P()"  G="G()"  ess="( ess )"  NE="NE()" d="\<Phi>" d="\<Psi>"

begin
 declare [[smt_solver = cvc4, smt_timeout = 200]]

 typedecl i -- "type for possible worlds"
 typedecl \<mu> -- "type for individuals"
 type_synonym \<sigma> = "(i\<Rightarrow>bool)"

(* Shallow embedding modal logic connectives in HOL *)
 abbreviation mneg ("\<^bold>\<not>_"[52]53)    where "\<^bold>\<not>\<phi>   \<equiv> \<lambda>w. \<not>\<phi>(w)"
 abbreviation mand (infixr"\<^bold>\<and>"51)   where "\<phi>\<^bold>\<and>\<psi>  \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
 abbreviation mor (infixr"\<^bold>\<or>"50)    where "\<phi>\<^bold>\<or>\<psi>  \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
 abbreviation mimp (infixr"\<^bold>\<rightarrow>"49)   where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
 abbreviation mequ (infixr"\<^bold>\<leftrightarrow>"48)   where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"
 abbreviation mnegpred ("\<^sup>\<not>_"[52]53) where "\<^sup>\<not>\<Phi>   \<equiv> \<lambda>x.\<lambda>w. \<not>\<Phi>(x)(w)"

(* Generic box and diamond operators *)
 abbreviation mboxgen ("\<box>") where "\<box>r \<phi> \<equiv> \<lambda>w. \<forall>v.  r w v \<longrightarrow> \<phi>(v)"
 abbreviation mdiagen ("\<diamond>") where "\<diamond>r \<phi> \<equiv> \<lambda>w. \<exists>v. r w v \<and> \<phi>(v)"

(* Shallow embedding of constant domain quantifiers in HOL *)
 abbreviation mall_const ("\<^bold>\<forall>c") where "\<^bold>\<forall>c \<Phi> \<equiv> \<lambda>w.\<forall>x. \<Phi>(x)(w)"
 abbreviation mallB_const (binder"\<^bold>\<forall>c"[8]9) where "\<^bold>\<forall>c x. \<phi>(x) \<equiv> \<^bold>\<forall>c \<phi>"
 abbreviation mexi_const ("\<^bold>\<exists>c") where "\<^bold>\<exists>c \<Phi> \<equiv> \<lambda>w.\<exists>x. \<Phi>(x)(w)"
 abbreviation mexiB_const (binder"\<^bold>\<exists>c"[8]9) where "\<^bold>\<exists>c x. \<phi>(x) \<equiv> \<^bold>\<exists>c \<phi>"

(* Global validity: truth in all possible worlds *)
 abbreviation mvalid :: "\<sigma> \<Rightarrow> bool" ("\<lfloor>_\<rfloor>"[7]110) where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"

(* Shallow embedding of varying domain quantifiers in HOL *)
 consts eiw :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
 axiomatization where nonempty: "\<forall>w. \<exists>x. eiw w x"
 abbreviation mall_var ("\<^bold>\<forall>v")
  where "\<^bold>\<forall>v \<Phi> \<equiv> \<lambda>w.\<forall>x. eiw(w)(x) \<longrightarrow> \<Phi>(x)(w)"
 abbreviation mallB_var (binder"\<^bold>\<forall>v"[8]9)
  where "\<^bold>\<forall>v x. \<phi>(x) \<equiv> \<^bold>\<forall>v \<phi>"
 abbreviation mexi_var ("\<^bold>\<exists>v")
  where "\<^bold>\<exists>v \<Phi> \<equiv> \<lambda>w.\<exists>x. eiw(w)(x) \<and> \<Phi>(x)(w)"
 abbreviation mexiB_var (binder"\<^bold>\<exists>v"[8]9)
  where "\<^bold>\<exists>v x. \<phi>(x) \<equiv> \<^bold>\<exists>v \<phi>"

(* Reflexivity, symmetry and transitivity of relations *)
 abbreviation ref
  where "ref r \<equiv> \<forall>x. r x x"
 abbreviation sym
  where "sym r \<equiv> \<forall>x y. r x y \<longrightarrow> r y x"
 abbreviation trans
  where "trans r \<equiv> \<forall>x y z. r x y \<and> r y z \<longrightarrow> r x z"

(* Different accessibility relations for different modal logics *)
 consts
   K :: "i\<Rightarrow>i\<Rightarrow>bool"
   KB :: "i\<Rightarrow>i\<Rightarrow>bool"
   S4 :: "i\<Rightarrow>i\<Rightarrow>bool"
   S5 :: "i\<Rightarrow>i\<Rightarrow>bool"
 axiomatization where
   KB: "sym KB" and
   S4: "ref S4 \<and> trans S4" and
   S5: "ref S5 \<and> sym S5 \<and> trans S5"

(* **************************************************************** *)

(* Setting Parameters for Experimentation with Ontological Argument *)
(* Default: Second-Order S5 with constant domain quantifiers *)

 abbreviation mbox  ("\<^bold>\<box>")
   where "\<^bold>\<box> \<equiv> \<box>S5"
 abbreviation mdia  ("\<^bold>\<diamond>")
  where "\<^bold>\<diamond> \<equiv> \<diamond>S5"

 abbreviation mall_ind :: "(\<mu>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" (binder"\<^bold>\<forall>\<^sup>i"[8]9)
  where "\<^bold>\<forall>\<^sup>ix. \<phi>(x) \<equiv> \<^bold>\<forall>c \<phi>"
 abbreviation mexi_ind :: "(\<mu>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" (binder"\<^bold>\<exists>\<^sup>i"[8]9)
  where "\<^bold>\<exists>\<^sup>ix. \<phi>(x) \<equiv> \<^bold>\<exists>c \<phi>"

 abbreviation mall_prop :: "((\<mu>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" (binder"\<^bold>\<forall>\<^sup>p"[8]9)
  where "\<^bold>\<forall>\<^sup>px. \<phi>(x) \<equiv> \<^bold>\<forall>c \<phi>"
 abbreviation mexi_prop :: "(\<mu>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>" (binder"\<^bold>\<exists>\<^sup>p"[8]9)
  where "\<^bold>\<exists>\<^sup>px. \<phi>(x) \<equiv> \<^bold>\<exists>c \<phi>"

(* **************************************************************** *)
(* Analysis of Gödel's Ontological Argument (in Scott's version) *)

(* Positiveness *)
 consts P :: "(\<mu>\<Rightarrow>\<sigma>)\<Rightarrow>\<sigma>"

 axiomatization where
(* A1: Either a property or its negation is positive, but not both *)
   A1a: "\<lfloor>\<^bold>\<forall>\<^sup>p\<Phi>. P(\<^sup>\<not>\<Phi>) \<^bold>\<rightarrow> \<^bold>\<not>P(\<Phi>)\<rfloor>" and
   A1b: "\<lfloor>\<^bold>\<forall>\<^sup>p\<Phi>. \<^bold>\<not>P(\<Phi>) \<^bold>\<rightarrow> P(\<^sup>\<not>\<Phi>)\<rfloor>" and
(* A2: A property necessarily implied by a positive property is positive *)
   A2: "\<lfloor>\<^bold>\<forall>\<^sup>p\<Phi> \<Psi>. P(\<Phi>) \<^bold>\<and> \<^bold>\<box>(\<^bold>\<forall>\<^sup>ix. \<Phi>(x) \<^bold>\<rightarrow> \<Psi>(x)) \<^bold>\<rightarrow> P(\<Psi>)\<rfloor>"

(* T1: Positive properties are possibly exemplified *)
 theorem T1: "\<lfloor>\<^bold>\<forall>\<^sup>p\<Phi>. P(\<Phi>) \<^bold>\<rightarrow> \<^bold>\<diamond>(\<^bold>\<exists>\<^sup>ix. \<Phi>(x))\<rfloor>"
  using A1a A2 by blast

(* God: A God-like being possesses all positive properties *)
 definition G where "G(x) = (\<^bold>\<forall>\<^sup>p\<Phi>. P(\<Phi>) \<^bold>\<rightarrow> \<Phi>(x))"

(* A3: The property of being God-like is positive *)
 axiomatization where A3: "\<lfloor>P(G)\<rfloor>"

(* C: Possibly, God exists *)
 corollary C: "\<lfloor>\<^bold>\<diamond>(\<^bold>\<exists>\<^sup>ix. G(x))\<rfloor>" by (simp add: A3 T1)

(* A4: Positive properties are necessarily positive *)
 axiomatization where A4: "\<lfloor>\<^bold>\<forall>\<^sup>p\<Phi>. P(\<Phi>) \<^bold>\<rightarrow> \<^bold>\<box>(P(\<Phi>))\<rfloor>"

(* Ess: An essence of an individual is a property possessed by
        it and necessarily implying any of its properties: *)
 definition ess (infixr "ess" 85) where
    "\<Phi> ess x = \<Phi> x \<^bold>\<and> (\<^bold>\<forall>\<^sup>p\<Psi>. \<Psi>(x) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>iy. \<Phi>(y) \<^bold>\<rightarrow> \<Psi>(y)))"

(* T2: Being God-like is an essence of any God-like being *)
 theorem T2: "\<lfloor>\<^bold>\<forall>\<^sup>ix. G(x) \<^bold>\<rightarrow> G ess x\<rfloor>" by (metis A1b A4 G_def ess_def)

(* NE: Necessary existence of an individual is the necessary
       exemplification of all its￼essences *)
 definition NE where "NE(x) = (\<^bold>\<forall>\<^sup>p\<Phi>. \<Phi> ess x \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<exists>\<^sup>iy. \<Phi>(y)))"

(* A5: Necessary existence is a positive property *)
 axiomatization where A5:  "\<lfloor>P(NE)\<rfloor>"

(* T3: Necessarily, God exists *)
 theorem T3: "\<lfloor>\<^bold>\<box>(\<^bold>\<exists>\<^sup>ix. G(x))\<rfloor>"
  sledgehammer
  sledgehammer [remote_leo2 remote_satallax]
  by (metis A3 A5 G_def NE_def S5 T1 T2)

(* Consistency is confirmed by Nitpick *)
 lemma True nitpick [satisfy,user_axioms,show_all] nunchaku [satisfy]  oops

 lemma False sledgehammer [remote_leo2,verbose] oops

end


theory NumberWang_IPv6
imports
  Word_Lib.Word_Lemmas
  Word_Lib.Word_Syntax
  Word_Lib.Reversed_Bit_Lists
begin

section\<open>Helper Lemmas for Low-Level Operations on Machine Words\<close>
text\<open>Needed for IPv6 Syntax\<close>

lemma length_drop_bl: "length (dropWhile Not (to_bl (of_bl bs))) \<le> length bs"
proof -
  have length_takeWhile_Not_replicate_False:
    "length (takeWhile Not (replicate n False @ ls)) = n + length (takeWhile Not ls)"
  for n ls by(subst takeWhile_append2) simp+
  show ?thesis by(simp add: word_rep_drop dropWhile_eq_drop length_takeWhile_Not_replicate_False)
qed

lemma bl_drop_leading_zeros:
      "(of_bl:: bool list \<Rightarrow> 'a::len word) (dropWhile Not bs) =
       (of_bl:: bool list \<Rightarrow> 'a::len word) bs"
by(induction bs) simp_all

lemma bl_length_drop_bound: assumes "length (dropWhile Not bs) \<le> n"
  shows "length (dropWhile Not (to_bl ((of_bl:: bool list \<Rightarrow> 'a::len word) bs))) \<le> n"
proof -
  have bl_length_drop_twice:
      "length (dropWhile Not (to_bl ((of_bl:: bool list \<Rightarrow> 'a::len word) (dropWhile Not bs)))) =
       length (dropWhile Not (to_bl ((of_bl:: bool list \<Rightarrow> 'a::len word) bs)))"
    by(simp add: bl_drop_leading_zeros)
  from length_drop_bl
  have *: "length (dropWhile Not (to_bl ((of_bl:: bool list \<Rightarrow> 'a::len word) bs))) \<le> length (dropWhile Not bs)"
   apply(rule dual_order.trans)
   apply(subst bl_length_drop_twice)
   ..
  show ?thesis
  apply(rule order.trans, rule *)
  using assms by(simp)
qed

context
  includes bit_operations_syntax
begin

lemma length_drop_mask_outer: fixes ip::"'a::len word"
  shows "LENGTH('a) - n' = len \<Longrightarrow> length (dropWhile Not (to_bl (ip AND (mask n << n') >> n'))) \<le> len"
  apply(subst word_and_mask_shiftl)
  apply(subst shiftl_shiftr1)
   apply(simp; fail)
  apply(simp)
  apply(subst and_mask)
  apply(simp add: word_size)
  apply(simp add: length_drop_mask)
  done

lemma length_drop_mask_inner: fixes ip::"'a::len word"
  shows "n \<le> LENGTH('a) - n' \<Longrightarrow> length (dropWhile Not (to_bl (ip AND (mask n << n') >> n'))) \<le> n"
  apply(subst word_and_mask_shiftl)
  apply(subst shiftl_shiftr3)
   apply(simp; fail)
  apply(simp)
  apply(simp add: word_size)
  apply(simp add: mask_twice)
  apply(simp add: length_drop_mask)
  done

end

lemma mask128: "0xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF = (mask 128 :: 'a::len word)"
  by (simp add: mask_numeral)

(*-------------- things for ipv6 syntax round trip property two ------------------*)

(*n small, m large*)
lemma helper_masked_ucast_generic:
  fixes b::"16 word"
  assumes "n + 16 \<le> m" and "m < 128"
  shows "((ucast:: 16 word \<Rightarrow> 128 word) b << n) && (mask 16 << m) = 0"
proof -
  have "x < 2 ^ (m - n)" if mnh2: "x < 0x10000"
    for x::"128 word"
  proof -
    from assms(1) have mnh3: "16 \<le> m - n" by fastforce
    have power_2_16_nat: "(16::nat) \<le> n \<Longrightarrow> (65535::nat) < 2 ^ n" if a:"16 \<le> n"for n
    proof -
      have power2_rule: "a \<le> b \<Longrightarrow> (2::nat)^a \<le> 2 ^ b" for a b by fastforce
      show ?thesis
       apply(subgoal_tac "65536 \<le> 2 ^ n")
        apply(subst Nat.less_eq_Suc_le)
        apply(simp; fail)
       apply(subgoal_tac "(65536::nat) = 2^16")
        subgoal using power2_rule \<open>16 \<le> n\<close> by presburger
       by(simp)
    qed
    have "65536 = unat (65536::128 word)" by auto
    moreover from mnh2 have "unat x <  unat (65536::128 word)" by(rule Word.unat_mono)
    ultimately have x: "unat x < 65536" by simp
    with mnh3 have "unat x < 2 ^ (m - n)"
      using power_2_16_nat [of \<open>m - n\<close>] by simp
    with assms(2) show ?thesis by(subst word_less_nat_alt) simp
  qed
  hence mnhelper2: "(of_bl::bool list \<Rightarrow> 128 word) (to_bl b) < 2 ^ (m - n)"
    apply(subgoal_tac "(of_bl::bool list \<Rightarrow> 128 word) (to_bl b) < 2^(LENGTH(16))")
     apply(simp; fail)
    by(rule of_bl_length_less) simp+
  have mnhelper3: "(of_bl::bool list \<Rightarrow> 128 word) (to_bl b) * 2 ^ n < 2 ^ m"
    apply(rule div_lt_mult)
     apply(rule word_less_two_pow_divI)
       using assms by(simp_all add: mnhelper2 p2_gt_0)

     show ?thesis
       apply (rule bit_word_eqI)
       apply (simp only: bit_simps)
       using assms(1)
       apply auto
       apply (transfer fixing: m n)
       apply auto
       done
qed

lemma unat_of_bl_128_16_less_helper:
  fixes b::"16 word"
  shows "unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) < 2^16"
proof -
  from word_bl_Rep' have 1: "length (to_bl b) = 16" by simp
  have "unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) < 2^(length (to_bl b))"
    by(fact unat_of_bl_length)
  with 1 show ?thesis by auto
qed
lemma unat_of_bl_128_16_le_helper: "unat ((of_bl:: bool list \<Rightarrow> 128 word) (to_bl (b::16 word))) \<le> 65535"
proof -
  from unat_of_bl_128_16_less_helper[of b] have
    "unat ((of_bl:: bool list \<Rightarrow> 128 word) (to_bl b)) < 65536" by simp
  from Suc_leI[OF this] show ?thesis by simp
qed

(*reverse*)
 lemma helper_masked_ucast_reverse_generic:
   fixes b::"16 word"
   assumes "m + 16 \<le> n" and "n \<le> 128 - 16"
   shows "((ucast:: 16 word \<Rightarrow> 128 word) b << n) && (mask 16 << m) = 0"
 proof -

   have power_less_128_helper: "2 ^ n * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) < 2 ^ LENGTH(128)"
     if n: "n \<le> 128 - 16" for n
   proof -
     have help_mult: "n \<le> l \<Longrightarrow> 2 ^ n * x < 2 ^ l \<longleftrightarrow> x < 2 ^ (l - n)" for x::nat and l
       by (simp add: nat_mult_power_less_eq semiring_normalization_rules(7))
     from n show ?thesis
       apply(subst help_mult)
        subgoal by (simp)
       apply(rule order_less_le_trans)
        apply(rule unat_of_bl_128_16_less_helper)
       apply(rule Power.power_increasing)
        apply(simp_all)
       done
   qed

   have *: "2 ^ m * (2 ^ (n - m) * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b))) =
            2 ^ n * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b))"
   proof(cases "unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) = 0")
   case True thus ?thesis by simp
   next
   case False
    have help_mult: "x \<noteq> 0 \<Longrightarrow> b * (c * x) = a * (x::nat)  \<longleftrightarrow> b * c = a" for x a b c by simp
    from assms show ?thesis
     apply(subst help_mult[OF False])
     apply(subst Power.monoid_mult_class.power_add[symmetric])
     apply(simp)
     done
   qed

  from assms have "unat ((2 ^ n)::128 word) * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) mod 2 ^ LENGTH(128) =
        2 ^ m * (2 ^ (n - m) * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) mod 2 ^ LENGTH(128))"
     apply(subst nat_mod_eq')
      subgoal apply(subst unat_power_lower)
       subgoal by(simp; fail)
      subgoal by (rule power_less_128_helper) simp
      done
     apply(subst nat_mod_eq')
      subgoal by(rule power_less_128_helper) simp
     apply(subst unat_power_lower)
      apply(simp; fail)
     apply(simp only: *)
     done
   hence ex_k: "\<exists>k. unat ((2 ^ n)::128 word) * unat ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b)) mod 2 ^ LENGTH(128) = 2 ^ m * k"
     by blast

   hence aligned: "is_aligned ((of_bl::bool list \<Rightarrow> 128 word) (to_bl b) << n) m"
     unfolding is_aligned_iff_dvd_nat
     unfolding dvd_def
     unfolding shiftl_t2n
     unfolding Word.unat_word_ariths(2)
     by assumption

   from assms have of_bl_to_bl_shift_mask: "((of_bl::bool list \<Rightarrow> 128 word) (to_bl b) << n) && mask (16 + m) = 0"
    using is_aligned_mask is_aligned_shiftl by force (*sledgehammer*)

   show ?thesis
    apply(subst ucast_bl)+
    apply(subst word_and_mask_shiftl)
    apply(subst aligned_shiftr_mask_shiftl)
     subgoal by (fact aligned)
    subgoal by (fact of_bl_to_bl_shift_mask)
    done
qed

lemma helper_masked_ucast_equal_generic:
  fixes b::"16 word"
  assumes "n \<le> 128 - 16"
  shows "ucast (((ucast:: 16 word \<Rightarrow> 128 word) b << n) && (mask 16 << n) >> n) = b"
proof -
  have ucast_mask: "(ucast:: 16 word \<Rightarrow> 128 word) b && mask 16 = ucast b"
    by (simp only: flip: take_bit_eq_mask unsigned_take_bit_eq) (simp add: take_bit_word_eq_self)
  from assms have "ucast (((ucast:: 16 word \<Rightarrow> 128 word) b && mask (128 - n) && mask 16) && mask (128 - n)) = b"
    by (simp only: take_bit_of_mask flip: take_bit_eq_mask unsigned_take_bit_eq)
      (simp add: unsigned_ucast_eq take_bit_word_eq_self)
  thus ?thesis
  apply(subst word_and_mask_shiftl)
  apply(subst shiftl_shiftr3)
   apply(simp; fail)
  apply(simp)
  apply(subst shiftl_shiftr3)
    apply(simp_all add: word_size and.assoc)
  done
qed

end


\<^marker>\<open>creator Bernhard Pöttinger\<close>

chapter \<open>Edge Local Flow\<close>
theory Edge_Local
imports Flow_Base
begin

abbreviation "const E \<equiv> \<forall>e \<in> E. \<exists>a. e = (\<lambda>_. a)"

lemma edge_local:
  assumes "const E" "\<forall>x y. e x y \<in> E" "N \<noteq> {}" "finite N"
  shows "\<exists>f. flow_eq (fg N e f) i \<and> (\<forall>f'. flow_eq (fg N e f') i \<longrightarrow> f = f' on N)"
proof -
  let ?f = "\<lambda>n. i n + (\<Sum>n' \<in> N. (THE a. e n' n = (\<lambda>_. a)))"
  let ?e = "\<lambda>n n' m. (THE a. e n n' = (\<lambda>_. a))"

  have *: "e = ?e"
    by (intro ext, smt assms the_equality)

  have "flow_eq (fg N e ?f) i"
    apply (rule flow_eqI)
    apply (subst (2) *)
    using assms by blast+
  moreover have "\<forall>f'. flow_eq (fg N e f') i \<longrightarrow> ?f = f' on N"
  proof (safe, goal_cases)
    case (1 f' n)
    then have "f' n = i n + (\<Sum>n'\<in>N. e n' n (f' n'))"
      using fgE''[OF 1(1) assms(3)] by simp
    then have "f' n = i n + (\<Sum>n'\<in>N. ?e n' n (f' n'))"
      apply (subst (asm) *) by simp
    then show ?case by simp
  qed
  ultimately show ?thesis
    by blast
qed

end


(* Author: Tobias Nipkow *)

theory Abs_Int0_ITP
imports "~~/src/Tools/Permanent_Interpretation"
        "~~/src/HOL/Library/While_Combinator"
        "Collecting_ITP"
begin

subsection "Orderings"

class preord =
fixes le :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
assumes le_refl[simp]: "x \<sqsubseteq> x"
and le_trans: "x \<sqsubseteq> y \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> z"
begin

definition mono where "mono f = (\<forall>x y. x \<sqsubseteq> y \<longrightarrow> f x \<sqsubseteq> f y)"

lemma monoD: "mono f \<Longrightarrow> x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y" by(simp add: mono_def)

lemma mono_comp: "mono f \<Longrightarrow> mono g \<Longrightarrow> mono (g o f)"
by(simp add: mono_def)

declare le_trans[trans]

end

text{* Note: no antisymmetry. Allows implementations where some abstract
element is implemented by two different values @{prop "x \<noteq> y"}
such that @{prop"x \<sqsubseteq> y"} and @{prop"y \<sqsubseteq> x"}. Antisymmetry is not
needed because we never compare elements for equality but only for @{text"\<sqsubseteq>"}.
*}

class SL_top = preord +
fixes join :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<squnion>" 65)
fixes Top :: "'a" ("\<top>")
assumes join_ge1 [simp]: "x \<sqsubseteq> x \<squnion> y"
and join_ge2 [simp]: "y \<sqsubseteq> x \<squnion> y"
and join_least: "x \<sqsubseteq> z \<Longrightarrow> y \<sqsubseteq> z \<Longrightarrow> x \<squnion> y \<sqsubseteq> z"
and top[simp]: "x \<sqsubseteq> \<top>"
begin

lemma join_le_iff[simp]: "x \<squnion> y \<sqsubseteq> z \<longleftrightarrow> x \<sqsubseteq> z \<and> y \<sqsubseteq> z"
by (metis join_ge1 join_ge2 join_least le_trans)

lemma le_join_disj: "x \<sqsubseteq> y \<or> x \<sqsubseteq> z \<Longrightarrow> x \<sqsubseteq> y \<squnion> z"
by (metis join_ge1 join_ge2 le_trans)

end

instantiation "fun" :: (type, SL_top) SL_top
begin

definition "f \<sqsubseteq> g = (ALL x. f x \<sqsubseteq> g x)"
definition "f \<squnion> g = (\<lambda>x. f x \<squnion> g x)"
definition "\<top> = (\<lambda>x. \<top>)"

lemma join_apply[simp]: "(f \<squnion> g) x = f x \<squnion> g x"
by (simp add: join_fun_def)

instance
proof
  case goal2 thus ?case by (metis le_fun_def preord_class.le_trans)
qed (simp_all add: le_fun_def Top_fun_def)

end

instantiation acom :: (preord) preord
begin

fun le_acom :: "('a::preord)acom \<Rightarrow> 'a acom \<Rightarrow> bool" where
"le_acom (SKIP {S}) (SKIP {S'}) = (S \<sqsubseteq> S')" |
"le_acom (x ::= e {S}) (x' ::= e' {S'}) = (x=x' \<and> e=e' \<and> S \<sqsubseteq> S')" |
"le_acom (c1;;c2) (c1';;c2') = (le_acom c1 c1' \<and> le_acom c2 c2')" |
"le_acom (IF b THEN c1 ELSE c2 {S}) (IF b' THEN c1' ELSE c2' {S'}) =
  (b=b' \<and> le_acom c1 c1' \<and> le_acom c2 c2' \<and> S \<sqsubseteq> S')" |
"le_acom ({Inv} WHILE b DO c {P}) ({Inv'} WHILE b' DO c' {P'}) =
  (b=b' \<and> le_acom c c' \<and> Inv \<sqsubseteq> Inv' \<and> P \<sqsubseteq> P')" |
"le_acom _ _ = False"

lemma [simp]: "x ::= e {S} \<sqsubseteq> c \<longleftrightarrow> (\<exists>S'. c = x ::= e {S'} \<and> S \<sqsubseteq> S')"
by (cases c) auto

lemma [simp]: "c1;;c2 \<sqsubseteq> c \<longleftrightarrow> (\<exists>c1' c2'. c = c1';;c2' \<and> c1 \<sqsubseteq> c1' \<and> c2 \<sqsubseteq> c2')"
by (cases c) auto

lemma [simp]: "IF b THEN c1 ELSE c2 {S} \<sqsubseteq> c \<longleftrightarrow>
  (\<exists>c1' c2' S'. c = IF b THEN c1' ELSE c2' {S'} \<and> c1 \<sqsubseteq> c1' \<and> c2 \<sqsubseteq> c2' \<and> S \<sqsubseteq> S')"
by (cases c) auto

lemma [simp]: "{Inv} WHILE b DO c {P} \<sqsubseteq> w \<longleftrightarrow>
  (\<exists>Inv' c' P'. w = {Inv'} WHILE b DO c' {P'} \<and> c \<sqsubseteq> c' \<and> Inv \<sqsubseteq> Inv' \<and> P \<sqsubseteq> P')"
by (cases w) auto

instance
proof
  case goal1 thus ?case by (induct x) auto
next
  case goal2 thus ?case
  apply(induct x y arbitrary: z rule: le_acom.induct)
  apply (auto intro: le_trans)
  done
qed

end

subsubsection "Lifting"

instantiation option :: (preord)preord
begin

fun le_option where
"Some x \<sqsubseteq> Some y = (x \<sqsubseteq> y)" |
"None \<sqsubseteq> y = True" |
"Some _ \<sqsubseteq> None = False"

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

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

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)
qed

end

instantiation option :: (SL_top)SL_top
begin

fun join_option where
"Some x \<squnion> Some y = Some(x \<squnion> y)" |
"None \<squnion> y = y" |
"x \<squnion> None = x"

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

definition "\<top> = Some \<top>"

instance proof
  case goal1 thus ?case by(cases x, simp, cases y, simp_all)
next
  case goal2 thus ?case by(cases y, simp, cases x, simp_all)
next
  case goal3 thus ?case by(cases z, simp, cases y, simp, cases x, simp_all)
next
  case goal4 thus ?case by(cases x, simp_all add: Top_option_def)
qed

end

definition bot_acom :: "com \<Rightarrow> ('a::SL_top)option acom" ("\<bottom>\<^sub>c") where
"\<bottom>\<^sub>c = anno None"

lemma strip_bot_acom[simp]: "strip(\<bottom>\<^sub>c c) = c"
by(simp add: bot_acom_def)

lemma bot_acom[rule_format]: "strip c' = c \<longrightarrow> \<bottom>\<^sub>c c \<sqsubseteq> c'"
apply(induct c arbitrary: c')
apply (simp_all add: bot_acom_def)
 apply(induct_tac c')
  apply simp_all
 apply(induct_tac c')
  apply simp_all
 apply(induct_tac c')
  apply simp_all
 apply(induct_tac c')
  apply simp_all
 apply(induct_tac c')
  apply simp_all
done

subsubsection "Post-fixed point iteration"

definition
  pfp :: "(('a::preord) \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a option" where
"pfp f = while_option (\<lambda>x. \<not> f x \<sqsubseteq> x) f"

lemma pfp_pfp: assumes "pfp f x0 = Some x" shows "f x \<sqsubseteq> x"
using while_option_stop[OF assms[simplified pfp_def]] by simp

lemma pfp_least:
assumes mono: "\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y"
and "f p \<sqsubseteq> p" and "x0 \<sqsubseteq> p" and "pfp f x0 = Some x" shows "x \<sqsubseteq> p"
proof-
  { fix x assume "x \<sqsubseteq> p"
    hence  "f x \<sqsubseteq> f p" by(rule mono)
    from this `f p \<sqsubseteq> p` have "f x \<sqsubseteq> p" by(rule le_trans)
  }
  thus "x \<sqsubseteq> p" using assms(2-) while_option_rule[where P = "%x. x \<sqsubseteq> p"]
    unfolding pfp_def by blast
qed

definition
 lpfp\<^sub>c :: "(('a::SL_top)option acom \<Rightarrow> 'a option acom) \<Rightarrow> com \<Rightarrow> 'a option acom option" where
"lpfp\<^sub>c f c = pfp f (\<bottom>\<^sub>c c)"

lemma lpfpc_pfp: "lpfp\<^sub>c f c0 = Some c \<Longrightarrow> f c \<sqsubseteq> c"
by(simp add: pfp_pfp lpfp\<^sub>c_def)

lemma strip_pfp:
assumes "\<And>x. g(f x) = g x" and "pfp f x0 = Some x" shows "g x = g x0"
using assms while_option_rule[where P = "%x. g x = g x0" and c = f]
unfolding pfp_def by metis

lemma strip_lpfpc: assumes "\<And>c. strip(f c) = strip c" and "lpfp\<^sub>c f c = Some c'"
shows "strip c' = c"
using assms(1) strip_pfp[OF _ assms(2)[simplified lpfp\<^sub>c_def]]
by(metis strip_bot_acom)

lemma lpfpc_least:
assumes mono: "\<And>x y. x \<sqsubseteq> y \<Longrightarrow> f x \<sqsubseteq> f y"
and "strip p = c0" and "f p \<sqsubseteq> p" and lp: "lpfp\<^sub>c f c0 = Some c" shows "c \<sqsubseteq> p"
using pfp_least[OF _ _ bot_acom[OF `strip p = c0`] lp[simplified lpfp\<^sub>c_def]]
  mono `f p \<sqsubseteq> p`
by blast

subsection "Abstract Interpretation"

definition \<gamma>_fun :: "('a \<Rightarrow> 'b set) \<Rightarrow> ('c \<Rightarrow> 'a) \<Rightarrow> ('c \<Rightarrow> 'b)set" where
"\<gamma>_fun \<gamma> F = {f. \<forall>x. f x \<in> \<gamma>(F x)}"

fun \<gamma>_option :: "('a \<Rightarrow> 'b set) \<Rightarrow> 'a option \<Rightarrow> 'b set" where
"\<gamma>_option \<gamma> None = {}" |
"\<gamma>_option \<gamma> (Some a) = \<gamma> a"

text{* The interface for abstract values: *}

locale Val_abs =
fixes \<gamma> :: "'av::SL_top \<Rightarrow> val set"
  assumes mono_gamma: "a \<sqsubseteq> b \<Longrightarrow> \<gamma> a \<subseteq> \<gamma> b"
  and gamma_Top[simp]: "\<gamma> \<top> = UNIV"
fixes num' :: "val \<Rightarrow> 'av"
and plus' :: "'av \<Rightarrow> 'av \<Rightarrow> 'av"
  assumes gamma_num': "n : \<gamma>(num' n)"
  and gamma_plus':
 "n1 : \<gamma> a1 \<Longrightarrow> n2 : \<gamma> a2 \<Longrightarrow> n1+n2 : \<gamma>(plus' a1 a2)"

type_synonym 'av st = "(vname \<Rightarrow> 'av)"

locale Abs_Int_Fun = Val_abs \<gamma> for \<gamma> :: "'av::SL_top \<Rightarrow> val set"
begin

fun aval' :: "aexp \<Rightarrow> 'av st \<Rightarrow> 'av" where
"aval' (N n) S = num' n" |
"aval' (V x) S = S x" |
"aval' (Plus a1 a2) S = plus' (aval' a1 S) (aval' a2 S)"

fun step' :: "'av st option \<Rightarrow> 'av st option acom \<Rightarrow> 'av st option acom"
 where
"step' S (SKIP {P}) = (SKIP {S})" |
"step' S (x ::= e {P}) =
  x ::= e {case S of None \<Rightarrow> None | Some S \<Rightarrow> Some(S(x := aval' e S))}" |
"step' S (c1;; c2) = step' S c1;; step' (post c1) c2" |
"step' S (IF b THEN c1 ELSE c2 {P}) =
   IF b THEN step' S c1 ELSE step' S c2 {post c1 \<squnion> post c2}" |
"step' S ({Inv} WHILE b DO c {P}) =
  {S \<squnion> post c} WHILE b DO (step' Inv c) {Inv}"

definition AI :: "com \<Rightarrow> 'av st option acom option" where
"AI = lpfp\<^sub>c (step' \<top>)"

lemma strip_step'[simp]: "strip(step' S c) = strip c"
by(induct c arbitrary: S) (simp_all add: Let_def)

abbreviation \<gamma>\<^sub>f :: "'av st \<Rightarrow> state set"
where "\<gamma>\<^sub>f == \<gamma>_fun \<gamma>"

abbreviation \<gamma>\<^sub>o :: "'av st option \<Rightarrow> state set"
where "\<gamma>\<^sub>o == \<gamma>_option \<gamma>\<^sub>f"

abbreviation \<gamma>\<^sub>c :: "'av st option acom \<Rightarrow> state set acom"
where "\<gamma>\<^sub>c == map_acom \<gamma>\<^sub>o"

lemma gamma_f_Top[simp]: "\<gamma>\<^sub>f Top = UNIV"
by(simp add: Top_fun_def \<gamma>_fun_def)

lemma gamma_o_Top[simp]: "\<gamma>\<^sub>o Top = UNIV"
by (simp add: Top_option_def)

(* FIXME (maybe also le \<rightarrow> sqle?) *)

lemma mono_gamma_f: "f \<sqsubseteq> g \<Longrightarrow> \<gamma>\<^sub>f f \<subseteq> \<gamma>\<^sub>f g"
by(auto simp: le_fun_def \<gamma>_fun_def dest: mono_gamma)

lemma mono_gamma_o:
  "sa \<sqsubseteq> sa' \<Longrightarrow> \<gamma>\<^sub>o sa \<subseteq> \<gamma>\<^sub>o sa'"
by(induction sa sa' rule: le_option.induct)(simp_all add: mono_gamma_f)

lemma mono_gamma_c: "ca \<sqsubseteq> ca' \<Longrightarrow> \<gamma>\<^sub>c ca \<le> \<gamma>\<^sub>c ca'"
by (induction ca ca' rule: le_acom.induct) (simp_all add:mono_gamma_o)

text{* Soundness: *}

lemma aval'_sound: "s : \<gamma>\<^sub>f S \<Longrightarrow> aval a s : \<gamma>(aval' a S)"
by (induct a) (auto simp: gamma_num' gamma_plus' \<gamma>_fun_def)

lemma in_gamma_update:
  "\<lbrakk> s : \<gamma>\<^sub>f S; i : \<gamma> a \<rbrakk> \<Longrightarrow> s(x := i) : \<gamma>\<^sub>f(S(x := a))"
by(simp add: \<gamma>_fun_def)

lemma step_preserves_le:
  "\<lbrakk> S \<subseteq> \<gamma>\<^sub>o S'; c \<le> \<gamma>\<^sub>c c' \<rbrakk> \<Longrightarrow> step S c \<le> \<gamma>\<^sub>c (step' S' c')"
proof(induction c arbitrary: c' S S')
  case SKIP thus ?case by(auto simp:SKIP_le map_acom_SKIP)
next
  case Assign thus ?case
    by (fastforce simp: Assign_le  map_acom_Assign intro: aval'_sound in_gamma_update
      split: option.splits del:subsetD)
next
  case Seq thus ?case apply (auto simp: Seq_le map_acom_Seq)
    by (metis le_post post_map_acom)
next
  case (If b c1 c2 P)
  then obtain c1' c2' P' where
      "c' = IF b THEN c1' ELSE c2' {P'}"
      "P \<subseteq> \<gamma>\<^sub>o P'" "c1 \<le> \<gamma>\<^sub>c c1'" "c2 \<le> \<gamma>\<^sub>c c2'"
    by (fastforce simp: If_le map_acom_If)
  moreover have "post c1 \<subseteq> \<gamma>\<^sub>o(post c1' \<squnion> post c2')"
    by (metis (no_types) `c1 \<le> \<gamma>\<^sub>c c1'` join_ge1 le_post mono_gamma_o order_trans post_map_acom)
  moreover have "post c2 \<subseteq> \<gamma>\<^sub>o(post c1' \<squnion> post c2')"
    by (metis (no_types) `c2 \<le> \<gamma>\<^sub>c c2'` join_ge2 le_post mono_gamma_o order_trans post_map_acom)
  ultimately show ?case using `S \<subseteq> \<gamma>\<^sub>o S'` by (simp add: If.IH subset_iff)
next
  case (While I b c1 P)
  then obtain c1' I' P' where
    "c' = {I'} WHILE b DO c1' {P'}"
    "I \<subseteq> \<gamma>\<^sub>o I'" "P \<subseteq> \<gamma>\<^sub>o P'" "c1 \<le> \<gamma>\<^sub>c c1'"
    by (fastforce simp: map_acom_While While_le)
  moreover have "S \<union> post c1 \<subseteq> \<gamma>\<^sub>o (S' \<squnion> post c1')"
    using `S \<subseteq> \<gamma>\<^sub>o S'` le_post[OF `c1 \<le> \<gamma>\<^sub>c c1'`, simplified]
    by (metis (no_types) join_ge1 join_ge2 le_sup_iff mono_gamma_o order_trans)
  ultimately show ?case by (simp add: While.IH subset_iff)
qed

lemma AI_sound: "AI c = Some c' \<Longrightarrow> CS c \<le> \<gamma>\<^sub>c c'"
proof(simp add: CS_def AI_def)
  assume 1: "lpfp\<^sub>c (step' \<top>) c = Some c'"
  have 2: "step' \<top> c' \<sqsubseteq> c'" by(rule lpfpc_pfp[OF 1])
  have 3: "strip (\<gamma>\<^sub>c (step' \<top> c')) = c"
    by(simp add: strip_lpfpc[OF _ 1])
  have "lfp (step UNIV) c \<le> \<gamma>\<^sub>c (step' \<top> c')"
  proof(rule lfp_lowerbound[simplified,OF 3])
    show "step UNIV (\<gamma>\<^sub>c (step' \<top> c')) \<le> \<gamma>\<^sub>c (step' \<top> c')"
    proof(rule step_preserves_le[OF _ _])
      show "UNIV \<subseteq> \<gamma>\<^sub>o \<top>" by simp
      show "\<gamma>\<^sub>c (step' \<top> c') \<le> \<gamma>\<^sub>c c'" by(rule mono_gamma_c[OF 2])
    qed
  qed
  with 2 show "lfp (step UNIV) c \<le> \<gamma>\<^sub>c c'"
    by (blast intro: mono_gamma_c order_trans)
qed

end

subsubsection "Monotonicity"

lemma mono_post: "c \<sqsubseteq> c' \<Longrightarrow> post c \<sqsubseteq> post c'"
by(induction c c' rule: le_acom.induct) (auto)

locale Abs_Int_Fun_mono = Abs_Int_Fun +
assumes mono_plus': "a1 \<sqsubseteq> b1 \<Longrightarrow> a2 \<sqsubseteq> b2 \<Longrightarrow> plus' a1 a2 \<sqsubseteq> plus' b1 b2"
begin

lemma mono_aval': "S \<sqsubseteq> S' \<Longrightarrow> aval' e S \<sqsubseteq> aval' e S'"
by(induction e)(auto simp: le_fun_def mono_plus')

lemma mono_update: "a \<sqsubseteq> a' \<Longrightarrow> S \<sqsubseteq> S' \<Longrightarrow> S(x := a) \<sqsubseteq> S'(x := a')"
by(simp add: le_fun_def)

lemma mono_step': "S \<sqsubseteq> S' \<Longrightarrow> c \<sqsubseteq> c' \<Longrightarrow> step' S c \<sqsubseteq> step' S' c'"
apply(induction c c' arbitrary: S S' rule: le_acom.induct)
apply (auto simp: Let_def mono_update mono_aval' mono_post le_join_disj
            split: option.split)
done

end

text{* Problem: not executable because of the comparison of abstract states,
i.e. functions, in the post-fixedpoint computation. *}

end