header {* Ribbon proof interfaces *}

theory Ribbons_Interfaces imports
  Ribbons_Basic
  Proofchain
  "~~/src/HOL/Library/FSet"
begin

text {* Interfaces are the top and bottom boundaries through which diagrams
  can be connected into a surrounding context. For instance, when composing two
  diagrams vertically, the bottom interface of the upper diagram must match the
  top interface of the lower diagram.

  We define a datatype of concrete interfaces. We then quotient by the
  associativity, commutativity and unity properties of our
  horizontal-composition operator. *}

subsection {* Syntax of interfaces *}

datatype conc_interface =
  Ribbon_conc "assertion"
| HComp_int_conc "conc_interface" "conc_interface" (infix "\<otimes>\<^sub>c" 50)
| Emp_int_conc ("\<epsilon>\<^sub>c")
| Exists_int_conc "string" "conc_interface"

text {* We define an equivalence on interfaces. The first three rules make this
  an equivalence relation. The next three make it a congruence. The next two
  identify interfaces up to associativity and commutativity of @{term "op \<otimes>\<^sub>c"}
  The final two make @{term "\<epsilon>\<^sub>c"} the left and right unit of @{term "op \<otimes>\<^sub>c"}.
  *}
inductive
  equiv_int :: "conc_interface \<Rightarrow> conc_interface \<Rightarrow> bool" (infix "\<simeq>" 45)
where
  refl: "P \<simeq> P"
| sym: "P \<simeq> Q \<Longrightarrow> Q \<simeq> P"
| trans: "\<lbrakk>P \<simeq> Q; Q \<simeq> R\<rbrakk> \<Longrightarrow> P \<simeq> R"
| cong_hcomp1: "P \<simeq> Q \<Longrightarrow> P' \<otimes>\<^sub>c P \<simeq> P' \<otimes>\<^sub>c Q"
| cong_hcomp2: "P \<simeq> Q \<Longrightarrow> P \<otimes>\<^sub>c P' \<simeq> Q \<otimes>\<^sub>c P'"
| cong_exists: "P \<simeq> Q \<Longrightarrow> Exists_int_conc x P \<simeq> Exists_int_conc x Q"
| hcomp_conc_assoc: "P \<otimes>\<^sub>c (Q \<otimes>\<^sub>c R) \<simeq> (P \<otimes>\<^sub>c Q) \<otimes>\<^sub>c R"
| hcomp_conc_comm: "P \<otimes>\<^sub>c Q \<simeq> Q \<otimes>\<^sub>c P"
| hcomp_conc_unit1: "\<epsilon>\<^sub>c \<otimes>\<^sub>c P \<simeq> P"
| hcomp_conc_unit2: "P \<otimes>\<^sub>c \<epsilon>\<^sub>c \<simeq> P"

lemma equiv_int_cong_hcomp:
  "\<lbrakk> P \<simeq> Q ; P' \<simeq> Q' \<rbrakk> \<Longrightarrow> P \<otimes>\<^sub>c P' \<simeq> Q \<otimes>\<^sub>c Q'"
by (metis cong_hcomp1 cong_hcomp2 equiv_int.trans)

quotient_type interface = "conc_interface" / "equiv_int"
apply (intro equivpI)
apply (intro reflpI, simp add: equiv_int.refl)
apply (intro sympI, simp add: equiv_int.sym)
apply (intro transpI, elim equiv_int.trans, simp add: equiv_int.refl)
done

lift_definition
  Ribbon :: "assertion \<Rightarrow> interface"
is "Ribbon_conc" .

lift_definition
  Emp_int :: "interface" ("\<epsilon>")
is "\<epsilon>\<^sub>c" .

lift_definition
  Exists_int :: "string \<Rightarrow> interface \<Rightarrow> interface"
is "Exists_int_conc"
by (rule equiv_int.cong_exists)

lift_definition
  HComp_int :: "interface \<Rightarrow> interface \<Rightarrow> interface" (infix "\<otimes>" 50)
is "HComp_int_conc" by (rule equiv_int_cong_hcomp)

lemma hcomp_comm:
  "(P \<otimes> Q) = (Q \<otimes> P)"
by (rule hcomp_conc_comm[Transfer.transferred])

lemma hcomp_assoc:
  "(P \<otimes> (Q \<otimes> R)) = ((P \<otimes> Q) \<otimes> R)"
by (rule hcomp_conc_assoc[Transfer.transferred])

lemma emp_hcomp:
  "\<epsilon> \<otimes> P = P"
by (rule hcomp_conc_unit1[Transfer.transferred])

lemma hcomp_emp:
  "P \<otimes> \<epsilon> = P"
by (rule hcomp_conc_unit2[Transfer.transferred])

lemma comp_fun_commute_hcomp:
  "comp_fun_commute (op \<otimes>)"
by default (simp add: hcomp_assoc fun_eq_iff, metis hcomp_comm)

subsection {* An iterated horizontal-composition operator *}

definition iter_hcomp :: "('a fset) \<Rightarrow> ('a \<Rightarrow> interface) \<Rightarrow> interface"
where
  "iter_hcomp X f \<equiv> ffold (op \<otimes> \<circ> f) \<epsilon> X"

syntax "iter_hcomp_syntax" ::
  "'a \<Rightarrow> ('a fset) \<Rightarrow> ('a \<Rightarrow> interface) \<Rightarrow> interface"
      ("(\<Otimes>_|\<in>|_. _)" [0,0,10] 10)
translations "\<Otimes>x|\<in>|M. e" == "CONST iter_hcomp M (\<lambda>x. e)"

term "\<Otimes>P|\<in>|Ps. f P" -- "this is eta-expanded, so prints in expanded form"
term "\<Otimes>P|\<in>|Ps. f" -- "this isn't eta-expanded, so prints as written"

lemma iter_hcomp_cong:
  assumes "\<forall>v \<in> fset vs. \<phi> v = \<phi>' v"
  shows "(\<Otimes>v|\<in>|vs. \<phi> v) = (\<Otimes>v|\<in>|vs. \<phi>' v)"
using assms unfolding iter_hcomp_def
by (auto simp add: fmember.rep_eq comp_fun_commute.comp_comp_fun_commute comp_fun_commute_hcomp
  intro: ffold_cong)

lemma iter_hcomp_empty:
  shows "(\<Otimes>x |\<in>| {||}. p x) = \<epsilon>"
by (metis comp_fun_commute.ffold_empty comp_fun_commute_hcomp iter_hcomp_def)

lemma iter_hcomp_insert:
  assumes "v |\<notin>| ws"
  shows "(\<Otimes>x |\<in>| finsert v ws. p x) = (p v \<otimes> (\<Otimes>x |\<in>| ws. p x))"
proof -
  interpret comp_fun_commute "(op \<otimes> \<circ> p)"
  by (metis comp_fun_commute.comp_comp_fun_commute comp_fun_commute_hcomp)
  from assms show ?thesis unfolding iter_hcomp_def by auto
qed

lemma iter_hcomp_union:
  assumes "vs |\<inter>| ws = {||}"
  shows "(\<Otimes>x |\<in>| vs |\<union>| ws. p x) = ((\<Otimes>x |\<in>| vs. p x) \<otimes> (\<Otimes>x |\<in>| ws. p x))"
using assms
by (induct vs) (auto simp add: emp_hcomp iter_hcomp_empty iter_hcomp_insert hcomp_assoc)

subsection {* Semantics of interfaces *}

text {* The semantics of an interface is an assertion. *}
fun
  conc_asn :: "conc_interface \<Rightarrow> assertion"
where
  "conc_asn (Ribbon_conc p) = p"
| "conc_asn (P \<otimes>\<^sub>c Q) = (conc_asn P) \<star> (conc_asn Q)"
| "conc_asn (\<epsilon>\<^sub>c) = Emp"
| "conc_asn (Exists_int_conc x P) = Exists x (conc_asn P)"

lift_definition
  asn :: "interface \<Rightarrow> assertion"
is "conc_asn"
by (induct_tac rule:equiv_int.induct) (auto simp add: star_assoc star_comm star_rot emp_star)

lemma asn_simps [simp]:
  "asn (Ribbon p) = p"
  "asn (P \<otimes> Q) = (asn P) \<star> (asn Q)"
  "asn \<epsilon> = Emp"
  "asn (Exists_int x P) = Exists x (asn P)"
by (transfer, simp)+

subsection {* Program variables mentioned in an interface. *}

fun
  rd_conc_int :: "conc_interface \<Rightarrow> string set"
where
  "rd_conc_int (Ribbon_conc p) = rd_ass p"
| "rd_conc_int (P \<otimes>\<^sub>c Q) = rd_conc_int P \<union> rd_conc_int Q"
| "rd_conc_int (\<epsilon>\<^sub>c) = {}"
| "rd_conc_int (Exists_int_conc x P) = rd_conc_int P"

lift_definition
  rd_int :: "interface \<Rightarrow> string set"
is "rd_conc_int"
by (induct_tac rule: equiv_int.induct) auto

text {* The program variables read by an interface are the same as those read
  by its corresponding assertion. *}

lemma rd_int_is_rd_ass:
  "rd_ass (asn P) = rd_int P"
by (transfer, induct_tac P, auto simp add: rd_star rd_exists rd_emp)

text {* Here is an iterated version of the Hoare logic sequencing rule. *}

lemma seq_fold:
  "\<And>\<Pi>. \<lbrakk> length cs = chainlen \<Pi> ; p1 = asn (pre \<Pi>) ; p2 = asn (post \<Pi>) ;
  \<And>i. i < chainlen \<Pi> \<Longrightarrow> prov_triple
  (asn (fst3 (nthtriple \<Pi> i)), cs ! i, asn (thd3 (nthtriple \<Pi> i))) \<rbrakk>
  \<Longrightarrow> prov_triple (p1, foldr (op ;;) cs Skip, p2)"
proof (induct cs arbitrary: p1 p2)
  case Nil
  thus ?case
  by (cases \<Pi>, auto simp add: prov_triple.skip)
next
  case (Cons c cs)
  obtain p x \<Pi>' where \<Pi>_def: "\<Pi> = \<lbrace> p \<rbrace> \<cdot> x \<cdot> \<Pi>'"
  by (metis Cons.prems(1) chain.exhaust chainlen.simps(1) impossible_Cons le0)
  show ?case
  apply (unfold foldr_Cons o_def)
  apply (rule prov_triple.seq[where q = "asn (pre \<Pi>')"])
  apply (unfold Cons.prems(2) Cons.prems(3) \<Pi>_def pre.simps post.simps)
  apply (subst nth_Cons_0[of c cs, symmetric])
  apply (subst fst3_simp[of p x "pre \<Pi>'", symmetric])
  apply (subst(2) thd3_simp[of p x "pre \<Pi>'", symmetric])
  apply (subst(1 2) nthtriple.simps(1)[of p x "\<Pi>'", symmetric])
  apply (fold \<Pi>_def, intro Cons.prems(4), simp add: \<Pi>_def)
  apply (intro Cons.hyps, insert \<Pi>_def Cons.prems(1), auto)
  apply (fold nth_Cons_Suc[of c cs] nthtriple.simps(2)[of p x "\<Pi>'"])
  apply (fold \<Pi>_def, intro Cons.prems(4), simp add: \<Pi>_def)
  done
qed

end


(* Title: Kleene Algebra with Tests
   Author: Peixin You
*)

section \<open>Kleene Algebra with Tests\<close>

theory KAT
  imports KA

begin

subsection \<open>Definitions and Basic Properties\<close>

class kat = kleene_algebra +
  fixes atest :: "'a \<Rightarrow> 'a" ("\<alpha>")
  assumes test_one [simp]: "\<alpha> (\<alpha> 1) = 1"
  and test_mult [simp]: "\<alpha> (\<alpha> (\<alpha> (\<alpha> x) \<cdot> \<alpha> (\<alpha> y))) = \<alpha> (\<alpha> y) \<cdot> \<alpha> (\<alpha> x)"
  and test_mult_comp [simp]: "\<alpha> x \<cdot> \<alpha> (\<alpha> x) = 0"
  and test_de_morgan: "\<alpha> (\<alpha> (\<alpha> x) \<cdot> \<alpha> (\<alpha> y)) = \<alpha> x + \<alpha> y"

begin

definition test :: "'a \<Rightarrow> 'a"  ("\<tau>") where
  "\<tau> x = \<alpha> (\<alpha> x)"

lemma a_a [simp]: "\<alpha> \<circ> \<alpha> = \<tau>"
  unfolding fun_eq_iff comp_def test_def by simp

lemma t_a [simp]: "\<tau> \<circ> \<alpha> = \<alpha>"
  unfolding fun_eq_iff comp_def test_def
  by (metis add_idem test_de_morgan test_mult)

lemma t_a_var [simp]: "\<tau> (\<alpha> x) = \<alpha> x"
  by (metis comp_def t_a)

lemma a_t [simp]: "\<alpha> \<circ> \<tau> = \<alpha>"
  by (metis a_a fun.map_comp t_a)

lemma a_t_var [simp]: "\<alpha> (\<tau> x) = \<alpha> x"
  using t_a_var test_def by force

lemma t_t [simp]: "\<tau> \<circ> \<tau> = \<tau>"
  by (metis a_a comp_assoc t_a)

lemma t_t_var [simp]: "\<tau> (\<tau> x) = \<tau> x"
  using a_t_var test_def by auto

lemma a_comm: "\<alpha> x \<cdot> \<alpha> y = \<alpha> y \<cdot> \<alpha> x"
  by (metis test_mult t_a_var test_def)

lemma a_idem [simp]: "\<alpha> x \<cdot> \<alpha> x = \<alpha> x"
  by (metis add_idem test_de_morgan test_mult)

lemma t_add_closed [simp]: "\<tau> (\<alpha> x + \<alpha> y) = \<alpha> x + \<alpha> y"
  by (metis test_de_morgan t_a_var)

lemma t_mult_closed [simp]: "\<tau> (\<alpha> x \<cdot> \<alpha> y) = \<alpha> x \<cdot> \<alpha> y"
  by (metis a_t comp_eq_dest_lhs test_mult test_def)

lemma t_at_compl1 [simp]: "\<tau> x + \<alpha> x = 1"
  by (metis mult_1_left test_de_morgan test_mult_comp test_one a_t_var test_def)

lemma t_at_compl2 [simp]: "\<tau> x \<cdot> \<alpha> x = 0"
  by (simp add: a_comm test_def)

lemma a_absorb1 [simp]: "\<alpha> x \<cdot> (\<alpha> x + \<alpha> y) = \<alpha> x"
  by (metis a_idem add_commute add_ubl distl mult_1_right order_def t_at_compl1)

lemma a_absorb2 [simp]: "\<alpha> x + \<alpha> x \<cdot> \<alpha> y = \<alpha> x"
  using a_absorb1 distl test_def by auto

lemma t_distl2: "\<alpha> x + \<alpha> y \<cdot> \<alpha> z = (\<alpha> x + \<alpha> y) \<cdot> (\<alpha> x + \<alpha> z)"
  by (smt a_absorb1 a_comm a_idem abel_semigroup.commute abel_semigroup.left_commute add.abel_semigroup_axioms distr test_de_morgan)

lemma a_de_morgan2: "\<alpha> (\<alpha> x + \<alpha> y) = \<tau> x \<cdot> \<tau> y"
  by (metis test_de_morgan t_mult_closed test_def)

lemma a_de_morgan3: "\<alpha> (\<alpha> x \<cdot> \<alpha> y) = \<tau> x + \<tau> y"
  by (metis a_t_var test_de_morgan test_def)

lemma a_lbl: "\<alpha> x \<cdot> \<alpha> y \<le> \<alpha> x"
  by (simp add: add_commute order_def)

lemma a_lbr: "\<alpha> x \<cdot> \<alpha> y \<le> \<alpha> y"
  using a_comm a_lbl by fastforce

lemma a_upper: "\<alpha> z \<le> \<alpha> x \<Longrightarrow> \<alpha> z \<le> \<alpha> y \<Longrightarrow> \<alpha> z \<le> \<alpha> x \<cdot> \<alpha> y"
  by (simp add: order_def t_distl2)

lemma a_glb: "(\<tau> z \<le> \<tau> x \<cdot> \<tau> y) = (\<tau> z \<le> \<tau> x \<and> \<tau> z \<le> \<tau> y)"
  by (smt a_lbl a_lbr a_upper dual_order.trans test_def)

lemma t_subid: "\<tau> x \<le> 1"
  using add_ubl t_at_compl1 by fastforce

lemma a_subid: "\<alpha> x \<le> 1"
  by (metis t_a_var t_subid)

lemma a_comp_ord_def: "(\<alpha> x \<le> \<alpha> y) = (\<alpha> x \<cdot> \<alpha> y = \<alpha> x)"
  by (metis a_absorb1 a_lbr order_def)

lemma t_le_antitone: "(\<tau> x \<le> \<tau> y) = (\<alpha> y \<le> \<alpha> x)"
  by (metis a_de_morgan2 a_lbl a_t_var order_def test_def)

lemma at_shunt: "(\<alpha> x \<cdot> \<alpha> y \<le> \<alpha> z) = (\<alpha> x \<le> \<tau> y + \<alpha> z)"
proof
  assume h1: "\<alpha> x \<cdot> \<alpha> y \<le> \<alpha> z"
  have "\<alpha> x = \<alpha> x \<cdot> (\<tau> y + \<alpha> y)"
    using t_at_compl1 by auto
  also have "\<dots> = \<alpha> x \<cdot> \<tau> y + \<alpha> x \<cdot> \<alpha> y"
    using distl by blast
  also have "\<dots> \<le> \<tau> y + \<alpha> z"
    by (simp add: a_lbr h1 add_iso test_def)
  finally show "\<alpha> x \<le> \<tau> y + \<alpha> z".
next
  assume "\<alpha> x \<le> \<tau> y + \<alpha> z"
  hence "\<alpha> x \<cdot> \<alpha> y \<le> (\<tau> y + \<alpha> z) \<cdot> \<alpha> y"
    by (simp add: add_ubr mult_isor)
  also have "\<dots> = \<tau> y \<cdot> \<alpha> y + \<alpha> z \<cdot> \<alpha> y"
    by (simp add: distr)
  also have "\<dots> = \<alpha> z \<cdot> \<alpha> y"
    using t_at_compl2 by auto
  also have "\<dots> \<le> \<alpha> z"
    by (simp add: a_lbl)
  finally show "\<alpha> x \<cdot> \<alpha> y \<le> \<alpha> z".
qed

end

subsection \<open>Boolean Subalgebra of Tests\<close>

typedef (overloaded) 'a test_alg = "{x::'a::kat. \<tau> x = x}"
  by (meson CollectI t_a_var)

setup_lifting type_definition_test_alg

instantiation test_alg :: (kat) boolean_algebra
begin

lift_definition minus_test_alg :: "'a test_alg \<Rightarrow> 'a test_alg \<Rightarrow> 'a test_alg" is "\<lambda>x y. x \<cdot> \<alpha> y"
  by (metis t_mult_closed test_def)

lift_definition uminus_test_alg :: "'a test_alg \<Rightarrow> 'a test_alg" is "\<alpha>"
  by simp

lift_definition bot_test_alg :: "'a test_alg" is "0"
  by (metis t_mult_closed test_mult_comp)

lift_definition top_test_alg :: "'a test_alg" is "1"
  by (simp add: test_def)

lift_definition inf_test_alg :: "'a test_alg \<Rightarrow> 'a test_alg \<Rightarrow> 'a test_alg" is "(\<cdot>)"
  by (metis t_mult_closed test_def)

lift_definition sup_test_alg :: "'a test_alg \<Rightarrow> 'a test_alg \<Rightarrow> 'a test_alg" is "(+)"
  by (metis t_add_closed test_def)

lift_definition less_eq_test_alg :: "'a test_alg \<Rightarrow> 'a test_alg \<Rightarrow> bool" is "(\<le>)".

lift_definition less_test_alg :: "'a test_alg \<Rightarrow> 'a test_alg \<Rightarrow> bool" is "(<)".

instance
  apply (intro_classes; transfer)
                 apply (simp_all add: less_le_not_le add_ubl add_ubr add_lub zero_least test_def)
        apply (metis a_lbl)
       apply (metis a_lbr)
      apply (metis a_upper)
     apply (metis a_subid)
    apply (metis t_distl2)
   apply (metis test_mult_comp)
  by (metis t_a_var t_at_compl1)

end

text \<open>Unfortunately, this theorem must be given outside of the context of the Kleene algebra with tests class.
We can therefore not use its results within this context. This means in particular that theorems from
Isabelle's boolean algebra component are not within scope within this context.\<close>

subsection \<open>Properties Helpful for Propositional Hoare Logic\<close>

context kat
begin

lemma pcorrect_if1: "\<alpha> p \<cdot> x \<le> x \<cdot> \<alpha> q \<Longrightarrow> \<alpha> p \<cdot> x \<cdot> \<tau> q = 0"
proof-
  assume "\<alpha> p \<cdot> x \<le> x \<cdot> \<alpha> q"
  hence "\<alpha> p \<cdot> x \<cdot> \<tau> q \<le> x \<cdot> \<alpha> q \<cdot> \<tau> q"
    by (metis mult_isor)
  thus ?thesis
    by (simp add: antisym mult_assoc test_def zero_least)
qed

lemma pcorrect_if1_op: "x \<cdot> \<alpha> q \<le> \<alpha> p \<cdot> x \<Longrightarrow> \<tau> p \<cdot> x \<cdot> \<alpha> q = 0"
proof-
  assume "x \<cdot> \<alpha> q \<le> \<alpha> p \<cdot> x"
  hence "\<tau> p \<cdot> x \<cdot> \<alpha> q \<le> \<tau> p \<cdot> \<alpha> p \<cdot> x"
    using mult_assoc mult_isol by presburger
  thus ?thesis
    by (simp add: order_def)
qed

lemma pcorrect_if2: "\<alpha> p \<cdot> x \<cdot> \<tau> q = 0 \<Longrightarrow> \<alpha> p \<cdot> x \<cdot> \<alpha> q = \<alpha> p \<cdot> x"
proof-
  assume "\<alpha> p \<cdot> x \<cdot> \<tau> q = 0"
  hence "\<alpha> p \<cdot> x \<cdot> \<alpha> q = \<alpha> p \<cdot> x \<cdot> \<alpha> q + \<alpha> p \<cdot> x \<cdot> \<tau> q"
    by simp
  also have "\<dots> = \<alpha> p \<cdot> x \<cdot> (\<tau> q + \<alpha> q)"
    by (simp add: add_commute distl)
  finally show ?thesis
    by simp
qed

lemma pcorrect_if2_op: "\<tau> p \<cdot> x \<cdot> \<alpha> q = 0 \<Longrightarrow> \<alpha> p \<cdot> x \<cdot> \<alpha> q = x \<cdot> \<alpha> q"
proof-
  assume "\<tau> p \<cdot> x \<cdot> \<alpha> q = 0"
  hence "\<alpha> p \<cdot> x \<cdot> \<alpha> q = \<alpha> p \<cdot> x \<cdot> \<alpha> q + \<tau> p \<cdot> x \<cdot> \<alpha> q"
    by simp
  also have "\<dots> = (\<tau> p + \<alpha> p) \<cdot> x \<cdot> \<alpha> q"
    by (simp add: add_commute distr)
  finally show ?thesis
    by simp
qed

lemma pcorrect_if3: "\<alpha> p \<cdot> x = \<alpha> p \<cdot> x \<cdot> \<alpha> q \<Longrightarrow> \<alpha> p \<cdot> x \<le> x \<cdot> \<alpha> q"
  by (metis a_subid mult_1_left mult_isor)

lemma pcorrect_if3_op: "\<alpha> p \<cdot> x \<cdot> \<alpha> q = x \<cdot> \<alpha> q \<Longrightarrow> x \<cdot> \<alpha> q \<le> \<alpha> p \<cdot>  x"
  by (metis a_subid mult_1_right mult_isol)

lemma pcorrect_iff1: "(\<alpha> p \<cdot> x \<le> x \<cdot> \<alpha> q) = (\<alpha> p \<cdot> x \<cdot> \<tau> q = 0)"
  by (metis pcorrect_if1 pcorrect_if2 pcorrect_if3)

lemma pcorrect_iff1_op: "(x \<cdot> \<alpha> q \<le> \<alpha> p \<cdot> x) = (\<tau> p \<cdot> x \<cdot> \<alpha> q = 0)"
   by (metis pcorrect_if1_op pcorrect_if2_op pcorrect_if3_op)

lemma pcorrect_iff2: "(\<alpha> p \<cdot> x \<cdot> \<tau> q = 0) = (\<alpha> p \<cdot> x \<cdot> \<alpha> q = \<alpha> p \<cdot> x)"
  by (metis pcorrect_if1 pcorrect_if2 pcorrect_if3)

lemma pcorrect_iff2_op: "(\<tau> p \<cdot> x \<cdot> \<alpha> q = 0) = (\<alpha> p \<cdot> x \<cdot> \<alpha> q  = x \<cdot> \<alpha> q)"
  by (metis pcorrect_if1_op pcorrect_if2_op pcorrect_if3_op)

lemma pcorrect_op: "(\<alpha> p \<cdot> x \<le> x \<cdot> \<alpha> q) = (x \<cdot> \<tau> q \<le> \<tau> p \<cdot> x)"
proof-
  have "(\<alpha> p \<cdot> x \<le> x \<cdot> \<alpha> q) = (\<alpha> p \<cdot> x \<cdot> \<tau> q = 0)"
    by (simp add: pcorrect_iff1)
  also have "\<dots> = (\<tau> (\<alpha> p) \<cdot> x \<cdot> \<alpha> (\<alpha> q) = 0)"
    using local.t_a_var local.test_def by auto
  also have "\<dots> = (x \<cdot> (\<alpha> (\<alpha> q)) \<le> \<alpha> (\<alpha> p) \<cdot> x)"
    by (simp add: pcorrect_iff1_op)
  finally show ?thesis
    by (simp add: local.test_def)
qed

lemma pcorrect: "(\<tau> p \<cdot> x \<le> x \<cdot> \<tau> q) = (x \<cdot> \<alpha> q \<le> \<alpha> p \<cdot> x)"
  using local.t_a_var local.test_def pcorrect_op by auto

subsection  \<open>Conditionals and while-Loops.\<close>

definition cond :: "'a \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" ("if _ then _ else _ fi" [64,64,64] 63) where
  "if p then x else y fi = \<tau> p \<cdot> x + \<alpha> p \<cdot> y"

definition while :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" ("while _ do _ od" [64,64] 63) where
  "while p do x od = (\<tau> p \<cdot> x)\<^sup>\<star> \<cdot> \<alpha> p"

subsection \<open>Program Equivalences and Transformations\<close>

lemma while_rec: "while p do x od = if p then x \<cdot> (while p do x od) else 1 fi"
proof-
  have "if p then x \<cdot> (while p do x od) else 1 fi = \<tau> p \<cdot> x \<cdot> (\<tau> p \<cdot> x)\<^sup>\<star> \<cdot> \<alpha> p + \<alpha> p \<cdot> 1"
    by (simp add: cond_def mult_assoc while_def)
  also have "\<dots> = (\<tau> p \<cdot> x \<cdot> (\<tau> p \<cdot> x)\<^sup>\<star> + 1) \<cdot> \<alpha> p"
    by (simp add: distr)
  also have "\<dots> = (\<tau> p \<cdot> x)\<^sup>\<star> \<cdot> \<alpha> p"
    by (simp add: add_commute)
  also have "\<dots> = while p do x od"
    by (simp add: while_def)
  finally show ?thesis..
qed

lemma while_rec_least: "if p then x \<cdot> y else 1 fi = y \<Longrightarrow> while p do x od \<le> y"
  by (simp add: add_commute cond_def local.mult.semigroup_axioms local.star_inductl semigroup.assoc while_def)

lemma cond_merge_aux: "(\<tau> p \<cdot> x = x \<cdot> \<tau> p) = (\<alpha> p \<cdot> x = x \<cdot> \<alpha> p)"
proof-
  have "(\<tau> p \<cdot> x = x \<cdot> \<tau> p) = (\<tau> p \<cdot> x \<le> x \<cdot> \<tau> p \<and> x \<cdot> \<tau> p \<le> \<tau> p \<cdot> x)"
    by force
  also have "\<dots> = (\<tau> p \<cdot> x \<cdot> \<alpha> p = 0 \<and> \<alpha> p \<cdot> x \<cdot> \<tau> p = 0)"
    using local.t_a_var local.test_def pcorrect pcorrect_iff1_op by auto
  also have "\<dots> = (\<alpha> p \<cdot> x  \<le> x \<cdot> \<alpha> p \<and> x \<cdot> \<alpha> p \<le> \<alpha> p \<cdot> x)"
    using pcorrect_iff1 pcorrect_iff1_op by auto
  finally show ?thesis
    by fastforce
qed

lemma cond_merge:
  assumes "\<tau> p \<cdot> x = x \<cdot> \<tau> p"
  shows "if p then (x \<cdot> y) else (x \<cdot> z) fi = x \<cdot> (if p then y else z fi)"
proof-
  have "if p then (x \<cdot> y) else (x \<cdot> z) fi = \<tau> p \<cdot> x \<cdot> y + \<alpha> p \<cdot> x \<cdot> z"
    by (simp add: cond_def mult_assoc)
  also have "\<dots> = x \<cdot> \<tau> p \<cdot> y + x \<cdot> \<alpha> p \<cdot> z"
    using assms cond_merge_aux by force
 also have "\<dots> = x \<cdot> (\<tau> p \<cdot> y + \<alpha> p \<cdot> z)"
   by (simp add: distl mult_assoc)
  also have "\<dots> = x \<cdot> (if p then y else z fi)"
    by (simp add: cond_def)
  finally show ?thesis.
qed

lemma loop_denest: "while p do (x \<cdot> (while q do y od)) od = if p then (x \<cdot> (while (\<tau> p + \<tau> q) do (if q then y else x fi) od)) else 1 fi"
proof-
  have "while (\<tau> p + \<tau> q) do (if q then y else x fi) od = ((\<tau> p + \<tau> q) \<cdot> (\<tau> q \<cdot> y + \<alpha> q \<cdot> x))\<^sup>\<star> \<cdot> \<alpha> q \<cdot> \<alpha> p"
    unfolding while_def cond_def
    using a_comm a_de_morgan3 mult_assoc t_mult_closed test_def by simp
  also have "\<dots> = (\<alpha> q \<cdot> \<tau> p \<cdot> x + \<tau> q \<cdot> y)\<^sup>\<star> \<cdot> \<alpha> q \<cdot> \<alpha> p"
    by (smt add_commute cond_merge_aux a_absorb2 a_comm a_idem distl distr mult_assoc test_def pcorrect_iff2)
  also have "\<dots> = (\<tau> q \<cdot> y)\<^sup>\<star> \<cdot> (\<alpha> q \<cdot> \<tau> p \<cdot> x \<cdot> (\<tau> q \<cdot> y)\<^sup>\<star>)\<^sup>\<star> \<cdot> \<alpha> q \<cdot> \<alpha> p"
    by (simp add: add_commute star_denest)
  also have "\<dots> = (\<tau> q \<cdot> y)\<^sup>\<star> \<cdot> \<alpha> q \<cdot> (\<tau> p \<cdot> x \<cdot> (\<tau> q \<cdot> y)\<^sup>\<star> \<cdot> \<alpha> q)\<^sup>\<star> \<cdot> \<alpha> p"
    by (simp add: mult_assoc star_slide)
  finally have "while (\<tau> p + \<tau> q) do (if q then y else x fi) od = (\<tau> q \<cdot> y)\<^sup>\<star> \<cdot> \<alpha> q \<cdot> (\<tau> p \<cdot> x \<cdot> (\<tau> q \<cdot> y)\<^sup>\<star> \<cdot> \<alpha> q)\<^sup>\<star> \<cdot> \<alpha> p".
  hence "if p then (x \<cdot> (while (\<tau> p + \<tau> q) do (if q then y else x fi) od)) else 1 fi = \<tau> p \<cdot> x \<cdot> (\<tau> q \<cdot> y)\<^sup>\<star> \<cdot> \<alpha> q \<cdot> (\<tau> p \<cdot> x \<cdot> (\<tau> q \<cdot> y)\<^sup>\<star> \<cdot> \<alpha> q)\<^sup>\<star> \<cdot> \<alpha> p  + \<alpha> p"
    by (simp add: cond_def mult_assoc)
  also have "\<dots> = (1 + \<tau> p \<cdot> x \<cdot> (\<tau> q \<cdot> y)\<^sup>\<star> \<cdot> \<alpha> q \<cdot> (\<tau> p \<cdot> x \<cdot> (\<tau> q \<cdot> y)\<^sup>\<star> \<cdot> \<alpha> q)\<^sup>\<star>) \<cdot> \<alpha> p"
    using add_commute distr mult_1_left by presburger
  also have "\<dots> = (\<tau> p \<cdot> x \<cdot> (\<tau> q \<cdot> y)\<^sup>\<star> \<cdot> \<alpha> q)\<^sup>\<star> \<cdot> \<alpha> p"
    by simp
  also have "\<dots> = while p do x \<cdot> (while q do y od) od"
    by (simp add: mult_assoc while_def)
  finally show ?thesis..
qed

end

subsection \<open>A Locale for KAT\<close>

locale katloc =
  fixes test :: "'a::boolean_algebra \<Rightarrow> 'b::kleene_algebra" ("\<iota>")
  and not :: "'b::kleene_algebra \<Rightarrow> 'b::kleene_algebra" ("!")
  assumes test_sup: "\<iota> (sup p q) = \<iota> p + \<iota> q"
  and test_inf: "\<iota> (inf p q) = \<iota> p \<cdot> \<iota> q"
  and test_top: "\<iota> top = 1"
  and test_bot: "\<iota> bot = 0"
  and test_not: "\<iota> (- p) = ! (\<iota> p)"
  and test_iso_eq: "p \<le> q \<longleftrightarrow> \<iota> p \<le> \<iota> q"

begin

lemma test_eq: "p = q \<longleftrightarrow> \<iota> p = \<iota> q"
  by (metis eq_iff test_iso_eq)

lemma test_iso: "p \<le> q \<Longrightarrow> \<iota> p \<le> \<iota> q"
  by (simp add: test_iso_eq)

lemma test_meet_comm: "\<iota> p \<cdot> \<iota> q = \<iota> q \<cdot> \<iota> p"
  by (metis inf.commute test_inf)

lemma [simp]: "\<iota> p + \<iota> (-p) = 1"
  by (metis sup_compl_top test_sup test_top)

lemma [simp]: "\<iota> (-p) \<cdot> \<iota> p = 0"
  by (metis compl_inf_bot test_bot test_inf)

lemma [simp]: "\<iota> p \<cdot> ! (\<iota> p) = 0"
  by (metis inf_compl_bot test_bot test_inf test_not)

end

subsection \<open>Relational and State Transformer Model\<close>

definition rel_atest :: "'a rel \<Rightarrow> 'a rel" ("\<alpha>\<^sub>r") where
  "\<alpha>\<^sub>r R = Id \<inter> -R"

interpretation rel_kat: kat "(\<union>)" "{}" Id "(;)" "(\<subseteq>)" "(\<subset>)" rtrancl "\<alpha>\<^sub>r"
  by unfold_locales (auto simp: rel_atest_def)

definition sta_atest :: "'a sta \<Rightarrow> 'a sta" ("\<alpha>\<^sub>s") where
  "\<alpha>\<^sub>s f x = \<eta> x - f x"

lemma katest_iff: "y \<in> \<alpha>\<^sub>s f x \<longleftrightarrow> y \<in> \<eta> x \<and> \<not> y \<in> f x"
  unfolding sta_atest_def by simp

declare katest_iff [sta_unfolds]

interpretation sta_kat: kat "(+\<^sub>K)" "\<nu>" "\<eta>" "(\<circ>\<^sub>K)" "(\<sqsubseteq>)" "(\<sqsubset>)" kstar "\<alpha>\<^sub>s"
  by unfold_locales (auto simp: sta_unfolds)

lemma r2s_atest: "\<S> (\<alpha>\<^sub>r R) = \<alpha>\<^sub>s (\<S> R)"
  unfolding sta_unfolds s2r_def rel_atest_def

  by (metis ComplD ComplI IntE IntI r2s_iff  s2r_id)

lemma s2r_atest: "\<R> (\<alpha>\<^sub>s f) = \<alpha>\<^sub>r (\<R> f)"
  by (metis r2s2r_galois r2s_atest)

lemma p2r_atest [simp]: "\<alpha>\<^sub>r \<lceil>P\<rceil>\<^sub>r = \<lceil>\<lambda>x. \<not> P x\<rceil>\<^sub>r"
  unfolding p2r_def rel_atest_def by force

lemma p2r_test [simp]: "rel_kat.test \<lceil>P\<rceil>\<^sub>r = \<lceil>P\<rceil>\<^sub>r"
  unfolding rel_kat.test_def by force

lemma p2s_atest [simp]: "\<alpha>\<^sub>s \<lceil>P\<rceil>\<^sub>s = \<lceil>\<lambda>x. \<not> P x\<rceil>\<^sub>s"
  unfolding  p2s_def s2p_def sta_atest_def fun_eq_iff by force

lemma p2s_test [simp]: "sta_kat.test \<lceil>P\<rceil>\<^sub>s = \<lceil>P\<rceil>\<^sub>s"
  unfolding sta_kat.test_def by force

end


(*  Title:      HOL/Quotient_Examples/Quotient_Rat.thy
    Author:     Cezary Kaliszyk

Rational numbers defined with the quotient package, based on 'HOL/Rat.thy' by Makarius.
*)

theory Quotient_Rat imports Archimedean_Field
  "~~/src/HOL/Library/Quotient_Product"
begin

definition
  ratrel :: "(int \<times> int) \<Rightarrow> (int \<times> int) \<Rightarrow> bool" (infix "\<approx>" 50)
where
  [simp]: "x \<approx> y \<longleftrightarrow> snd x \<noteq> 0 \<and> snd y \<noteq> 0 \<and> fst x * snd y = fst y * snd x"

lemma ratrel_equivp:
  "part_equivp ratrel"
proof (auto intro!: part_equivpI reflpI sympI transpI exI[of _ "1 :: int"])
  fix a b c d e f :: int
  assume nz: "d \<noteq> 0" "b \<noteq> 0"
  assume y: "a * d = c * b"
  assume x: "c * f = e * d"
  then have "c * b * f = e * d * b" using nz by simp
  then have "a * d * f = e * d * b" using y by simp
  then show "a * f = e * b" using nz by simp
qed

quotient_type rat = "int \<times> int" / partial: ratrel
 using ratrel_equivp .

instantiation rat :: "{zero, one, plus, uminus, minus, times, ord, abs_if, sgn_if}"
begin

quotient_definition
  "0 \<Colon> rat" is "(0\<Colon>int, 1\<Colon>int)" by simp

quotient_definition
  "1 \<Colon> rat" is "(1\<Colon>int, 1\<Colon>int)" by simp

fun times_rat_raw where
  "times_rat_raw (a :: int, b :: int) (c, d) = (a * c, b * d)"

quotient_definition
  "(op *) :: (rat \<Rightarrow> rat \<Rightarrow> rat)" is times_rat_raw by (auto simp add: mult.assoc mult.left_commute)

fun plus_rat_raw where
  "plus_rat_raw (a :: int, b :: int) (c, d) = (a * d + c * b, b * d)"

quotient_definition
  "(op +) :: (rat \<Rightarrow> rat \<Rightarrow> rat)" is plus_rat_raw
  by (auto simp add: mult.commute mult.left_commute int_distrib(2))

fun uminus_rat_raw where
  "uminus_rat_raw (a :: int, b :: int) = (-a, b)"

quotient_definition
  "(uminus \<Colon> (rat \<Rightarrow> rat))" is "uminus_rat_raw" by fastforce

definition
  minus_rat_def: "a - b = a + (-b\<Colon>rat)"

fun le_rat_raw where
  "le_rat_raw (a :: int, b) (c, d) \<longleftrightarrow> (a * d) * (b * d) \<le> (c * b) * (b * d)"

quotient_definition
  "(op \<le>) :: rat \<Rightarrow> rat \<Rightarrow> bool" is "le_rat_raw"
proof -
  {
    fix a b c d e f g h :: int
    assume "a * f * (b * f) \<le> e * b * (b * f)"
    then have le: "a * f * b * f \<le> e * b * b * f" by simp
    assume nz: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0" "h \<noteq> 0"
    then have b2: "b * b > 0"
      by (metis linorder_neqE_linordered_idom mult_eq_0_iff not_square_less_zero)
    have f2: "f * f > 0" using nz(3)
      by (metis linorder_neqE_linordered_idom mult_eq_0_iff not_square_less_zero)
    assume eq: "a * d = c * b" "e * h = g * f"
    have "a * f * b * f * d * d \<le> e * b * b * f * d * d" using le nz(2)
      by (metis linorder_le_cases mult_right_mono mult_right_mono_neg)
    then have "c * f * f * d * (b * b) \<le> e * f * d * d * (b * b)" using eq
      by (metis (no_types) mult.assoc mult.commute)
    then have "c * f * f * d \<le> e * f * d * d" using b2
      by (metis leD linorder_le_less_linear mult_strict_right_mono)
    then have "c * f * f * d * h * h \<le> e * f * d * d * h * h" using nz(4)
      by (metis linorder_le_cases mult_right_mono mult_right_mono_neg)
    then have "c * h * (d * h) * (f * f) \<le> g * d * (d * h) * (f * f)" using eq
      by (metis (no_types) mult.assoc mult.commute)
    then have "c * h * (d * h) \<le> g * d * (d * h)" using f2
      by (metis leD linorder_le_less_linear mult_strict_right_mono)
  }
  then show "\<And>x y xa ya. x \<approx> y \<Longrightarrow> xa \<approx> ya \<Longrightarrow> le_rat_raw x xa = le_rat_raw y ya" by auto
qed

definition
  less_rat_def: "(z\<Colon>rat) < w = (z \<le> w \<and> z \<noteq> w)"

definition
  rabs_rat_def: "\<bar>i\<Colon>rat\<bar> = (if i < 0 then - i else i)"

definition
  sgn_rat_def: "sgn (i\<Colon>rat) = (if i = 0 then 0 else if 0 < i then 1 else - 1)"

instance by intro_classes
  (auto simp add: rabs_rat_def sgn_rat_def)

end

definition
  Fract_raw :: "int \<Rightarrow> int \<Rightarrow> (int \<times> int)"
where [simp]: "Fract_raw a b = (if b = 0 then (0, 1) else (a, b))"

quotient_definition "Fract :: int \<Rightarrow> int \<Rightarrow> rat" is
  Fract_raw by simp

lemmas [simp] = Respects_def

(* FIXME: (partiality_)descending raises exception TYPE_MATCH

instantiation rat :: comm_ring_1
begin

instance proof
  fix a b c :: rat
  show "a * b * c = a * (b * c)"
    by partiality_descending auto
  show "a * b = b * a"
    by partiality_descending auto
  show "1 * a = a"
    by partiality_descending auto
  show "a + b + c = a + (b + c)"
    by partiality_descending (auto simp add: mult.commute distrib_left)
  show "a + b = b + a"
    by partiality_descending auto
  show "0 + a = a"
    by partiality_descending auto
  show "- a + a = 0"
    by partiality_descending auto
  show "a - b = a + - b"
    by (simp add: minus_rat_def)
  show "(a + b) * c = a * c + b * c"
    by partiality_descending (auto simp add: mult.commute distrib_left)
  show "(0 :: rat) \<noteq> (1 :: rat)"
    by partiality_descending auto
qed

end

lemma add_one_Fract: "1 + Fract (int k) 1 = Fract (1 + int k) 1"
  by descending auto

lemma of_nat_rat: "of_nat k = Fract (of_nat k) 1"
  apply (induct k)
  apply (simp add: zero_rat_def Fract_def)
  apply (simp add: add_one_Fract)
  done

lemma of_int_rat: "of_int k = Fract k 1"
  apply (cases k rule: int_diff_cases)
  apply (auto simp add: of_nat_rat minus_rat_def)
  apply descending
  apply auto
  done

instantiation rat :: field_inverse_zero begin

fun rat_inverse_raw where
  "rat_inverse_raw (a :: int, b :: int) = (if a = 0 then (0, 1) else (b, a))"

quotient_definition
  "inverse :: rat \<Rightarrow> rat" is rat_inverse_raw by (force simp add: mult.commute)

definition
  divide_rat_def: "q / r = q * inverse (r::rat)"

instance proof
  fix q :: rat
  assume "q \<noteq> 0"
  then show "inverse q * q = 1"
    by partiality_descending auto
next
  fix q r :: rat
  show "q / r = q * inverse r" by (simp add: divide_rat_def)
next
  show "inverse 0 = (0::rat)" by partiality_descending auto
qed

end

instantiation rat :: linorder
begin

instance proof
  fix q r s :: rat
  {
    assume "q \<le> r" and "r \<le> s"
    then show "q \<le> s"
    proof (partiality_descending, auto simp add: mult.assoc[symmetric])
      fix a b c d e f :: int
      assume nz: "b \<noteq> 0" "d \<noteq> 0" "f \<noteq> 0"
      then have d2: "d * d > 0"
        by (metis linorder_neqE_linordered_idom mult_eq_0_iff not_square_less_zero)
      assume le: "a * d * b * d \<le> c * b * b * d" "c * f * d * f \<le> e * d * d * f"
      then have a: "a * d * b * d * f * f \<le> c * b * b * d * f * f" using nz(3)
        by (metis linorder_le_cases mult_right_mono mult_right_mono_neg)
      have "c * f * d * f * b * b \<le> e * d * d * f * b * b" using nz(1) le
        by (metis linorder_le_cases mult_right_mono mult_right_mono_neg)
      then have "a * f * b * f * (d * d) \<le> e * b * b * f * (d * d)" using a
        by (simp add: algebra_simps)
      then show "a * f * b * f \<le> e * b * b * f" using d2
        by (metis leD linorder_le_less_linear mult_strict_right_mono)
    qed
  next
    assume "q \<le> r" and "r \<le> q"
    then show "q = r"
      apply (partiality_descending, auto)
      apply (case_tac "b > 0", case_tac [!] "ba > 0")
      apply simp_all
      done
  next
    show "q \<le> q" by partiality_descending auto
    show "(q < r) = (q \<le> r \<and> \<not> r \<le> q)"
      unfolding less_rat_def
      by partiality_descending (auto simp add: le_less mult.commute)
    show "q \<le> r \<or> r \<le> q"
      by partiality_descending (auto simp add: mult.commute linorder_linear)
  }
qed

end

instance rat :: archimedean_field
proof
  fix q r s :: rat
  show "q \<le> r ==> s + q \<le> s + r"
  proof (partiality_descending, auto simp add: algebra_simps, simp add: mult.assoc[symmetric])
    fix a b c d e :: int
    assume "e \<noteq> 0"
    then have e2: "e * e > 0"
      by (metis linorder_neqE_linordered_idom mult_eq_0_iff not_square_less_zero)
      assume "a * b * d * d \<le> b * b * c * d"
      then show "a * b * d * d * e * e * e * e \<le> b * b * c * d * e * e * e * e"
        using e2 by (metis comm_mult_left_mono mult.commute linorder_le_cases
          mult_left_mono_neg)
    qed
  show "q < r ==> 0 < s ==> s * q < s * r" unfolding less_rat_def
    proof (partiality_descending, auto simp add: algebra_simps, simp add: mult.assoc[symmetric])
    fix a b c d e f :: int
    assume a: "e \<noteq> 0" "f \<noteq> 0" "0 \<le> e * f" "a * b * d * d \<le> b * b * c * d"
    have "a * b * d * d * (e * f) \<le> b * b * c * d * (e * f)" using a
      by (simp add: mult_right_mono)
    then show "a * b * d * d * e * f * f * f \<le> b * b * c * d * e * f * f * f"
      by (simp add: mult.assoc[symmetric]) (metis a(3) comm_mult_left_mono
        mult.commute mult_left_mono_neg zero_le_mult_iff)
  qed
  show "\<exists>z. r \<le> of_int z"
    unfolding of_int_rat
  proof (partiality_descending, auto)
    fix a b :: int
    assume "b \<noteq> 0"
    then have "a * b \<le> (a div b + 1) * b * b"
      by (metis mult.commute div_mult_self1_is_id less_int_def linorder_le_cases zdiv_mono1 zdiv_mono1_neg zle_add1_eq_le)
    then show "\<exists>z\<Colon>int. a * b \<le> z * b * b" by auto
  qed
qed
*)

end


(*  Title:      ZF/Induct/ListN.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>Lists of n elements\<close>

theory ListN imports Main begin

text \<open>
  Inductive definition of lists of \<open>n\<close> elements; see
  @{cite "paulin-tlca"}.
\<close>

consts listn :: "i=>i"
inductive
  domains "listn(A)" \<subseteq> "nat \<times> list(A)"
  intros
    NilI: "<0,Nil> \<in> listn(A)"
    ConsI: "[| a \<in> A; <n,l> \<in> listn(A) |] ==> <succ(n), Cons(a,l)> \<in> listn(A)"
  type_intros nat_typechecks list.intros

lemma list_into_listn: "l \<in> list(A) ==> <length(l),l> \<in> listn(A)"
  by (induct set: list) (simp_all add: listn.intros)

lemma listn_iff: "<n,l> \<in> listn(A) \<longleftrightarrow> l \<in> list(A) & length(l)=n"
  apply (rule iffI)
   apply (erule listn.induct)
    apply auto
  apply (blast intro: list_into_listn)
  done

lemma listn_image_eq: "listn(A)``{n} = {l \<in> list(A). length(l)=n}"
  apply (rule equality_iffI)
  apply (simp add: listn_iff separation image_singleton_iff)
  done

lemma listn_mono: "A \<subseteq> B ==> listn(A) \<subseteq> listn(B)"
  apply (unfold listn.defs)
  apply (rule lfp_mono)
    apply (rule listn.bnd_mono)+
  apply (assumption | rule univ_mono Sigma_mono list_mono basic_monos)+
  done

lemma listn_append:
    "[| <n,l> \<in> listn(A); <n',l'> \<in> listn(A) |] ==> <n#+n', l@l'> \<in> listn(A)"
  apply (erule listn.induct)
   apply (frule listn.dom_subset [THEN subsetD])
   apply (simp_all add: listn.intros)
  done

inductive_cases
      Nil_listn_case: "<i,Nil> \<in> listn(A)"
  and Cons_listn_case: "<i,Cons(x,l)> \<in> listn(A)"

inductive_cases
      zero_listn_case: "<0,l> \<in> listn(A)"
  and succ_listn_case: "<succ(i),l> \<in> listn(A)"

end


(*  Title:      HOL/Algebra/Sylow.thy
    Author:     Florian Kammueller, with new proofs by L C Paulson
*)

theory Sylow
  imports Coset Exponent
begin

text \<open>See also \<^cite>\<open>"Kammueller-Paulson:1999"\<close>.\<close>

text \<open>The combinatorial argument is in theory \<open>Exponent\<close>.\<close>

lemma le_extend_mult: "\<lbrakk>0 < c; a \<le> b\<rbrakk> \<Longrightarrow> a \<le> b * c"
  for c :: nat
  by (metis divisors_zero dvd_triv_left leI less_le_trans nat_dvd_not_less zero_less_iff_neq_zero)

locale sylow = group +
  fixes p and a and m and calM and RelM
  assumes prime_p: "prime p"
    and order_G: "order G = (p^a) * m"
    and finite_G[iff]: "finite (carrier G)"
  defines "calM \<equiv> {s. s \<subseteq> carrier G \<and> card s = p^a}"
    and "RelM \<equiv> {(N1, N2). N1 \<in> calM \<and> N2 \<in> calM \<and> (\<exists>g \<in> carrier G. N1 = N2 #> g)}"
begin

lemma RelM_refl_on: "refl_on calM RelM"
  by (auto simp: refl_on_def RelM_def calM_def) (blast intro!: coset_mult_one [symmetric])

lemma RelM_sym: "sym RelM"
proof (unfold sym_def RelM_def, clarify)
  fix y g
  assume "y \<in> calM"
    and g: "g \<in> carrier G"
  then have "y = y #> g #> (inv g)"
    by (simp add: coset_mult_assoc calM_def)
  then show "\<exists>g'\<in>carrier G. y = y #> g #> g'"
    by (blast intro: g)
qed

lemma RelM_trans: "trans RelM"
  by (auto simp add: trans_def RelM_def calM_def coset_mult_assoc)

lemma RelM_equiv: "equiv calM RelM"
  unfolding equiv_def by (blast intro: RelM_refl_on RelM_sym RelM_trans)

lemma M_subset_calM_prep: "M' \<in> calM // RelM  \<Longrightarrow> M' \<subseteq> calM"
  unfolding RelM_def by (blast elim!: quotientE)

end

subsection \<open>Main Part of the Proof\<close>

locale sylow_central = sylow +
  fixes H and M1 and M
  assumes M_in_quot: "M \<in> calM // RelM"
    and not_dvd_M: "\<not> (p ^ Suc (multiplicity p m) dvd card M)"
    and M1_in_M: "M1 \<in> M"
  defines "H \<equiv> {g. g \<in> carrier G \<and> M1 #> g = M1}"
begin

lemma M_subset_calM: "M \<subseteq> calM"
  by (rule M_in_quot [THEN M_subset_calM_prep])

lemma card_M1: "card M1 = p^a"
  using M1_in_M M_subset_calM calM_def by blast

lemma exists_x_in_M1: "\<exists>x. x \<in> M1"
  using prime_p [THEN prime_gt_Suc_0_nat] card_M1
  by (metis Suc_lessD card_eq_0_iff empty_subsetI equalityI gr_implies_not0 nat_zero_less_power_iff subsetI)

lemma M1_subset_G [simp]: "M1 \<subseteq> carrier G"
  using M1_in_M M_subset_calM calM_def mem_Collect_eq subsetCE by blast

lemma M1_inj_H: "\<exists>f \<in> H\<rightarrow>M1. inj_on f H"
proof -
  from exists_x_in_M1 obtain m1 where m1M: "m1 \<in> M1"..
  have m1: "m1 \<in> carrier G"
    by (simp add: m1M M1_subset_G [THEN subsetD])
  show ?thesis
  proof
    show "inj_on (\<lambda>z\<in>H. m1 \<otimes> z) H"
      by (simp add: H_def inj_on_def m1)
    show "restrict ((\<otimes>) m1) H \<in> H \<rightarrow> M1"
    proof (rule restrictI)
      fix z
      assume zH: "z \<in> H"
      show "m1 \<otimes> z \<in> M1"
      proof -
        from zH
        have zG: "z \<in> carrier G" and M1zeq: "M1 #> z = M1"
          by (auto simp add: H_def)
        show ?thesis
          by (rule subst [OF M1zeq]) (simp add: m1M zG rcosI)
      qed
    qed
  qed
qed

end

subsection \<open>Discharging the Assumptions of \<open>sylow_central\<close>\<close>

context sylow
begin

lemma EmptyNotInEquivSet: "{} \<notin> calM // RelM"
  by (blast elim!: quotientE dest: RelM_equiv [THEN equiv_class_self])

lemma existsM1inM: "M \<in> calM // RelM \<Longrightarrow> \<exists>M1. M1 \<in> M"
  using RelM_equiv equiv_Eps_in by blast

lemma zero_less_o_G: "0 < order G"
  by (simp add: order_def card_gt_0_iff carrier_not_empty)

lemma zero_less_m: "m > 0"
  using zero_less_o_G by (simp add: order_G)

lemma card_calM: "card calM = (p^a) * m choose p^a"
  by (simp add: calM_def n_subsets order_G [symmetric] order_def)

lemma zero_less_card_calM: "card calM > 0"
  by (simp add: card_calM zero_less_binomial le_extend_mult zero_less_m)

lemma max_p_div_calM: "\<not> (p ^ Suc (multiplicity p m) dvd card calM)"
proof
  assume "p ^ Suc (multiplicity p m) dvd card calM"
  with zero_less_card_calM prime_p
  have "Suc (multiplicity p m) \<le> multiplicity p (card calM)"
    by (intro multiplicity_geI) auto
  then have "multiplicity p m < multiplicity p (card calM)" by simp
  also have "multiplicity p m = multiplicity p (card calM)"
    by (simp add: const_p_fac prime_p zero_less_m card_calM)
  finally show False by simp
qed

lemma finite_calM: "finite calM"
  unfolding calM_def by (rule finite_subset [where B = "Pow (carrier G)"]) auto

lemma lemma_A1: "\<exists>M \<in> calM // RelM. \<not> (p ^ Suc (multiplicity p m) dvd card M)"
  using RelM_equiv equiv_imp_dvd_card finite_calM max_p_div_calM by blast

end

subsubsection \<open>Introduction and Destruct Rules for \<open>H\<close>\<close>

context sylow_central
begin

lemma H_I: "\<lbrakk>g \<in> carrier G; M1 #> g = M1\<rbrakk> \<Longrightarrow> g \<in> H"
  by (simp add: H_def)

lemma H_into_carrier_G: "x \<in> H \<Longrightarrow> x \<in> carrier G"
  by (simp add: H_def)

lemma in_H_imp_eq: "g \<in> H \<Longrightarrow> M1 #> g = M1"
  by (simp add: H_def)

lemma H_m_closed: "\<lbrakk>x \<in> H; y \<in> H\<rbrakk> \<Longrightarrow> x \<otimes> y \<in> H"
  by (simp add: H_def coset_mult_assoc [symmetric])

lemma H_not_empty: "H \<noteq> {}"
  by (force simp add: H_def intro: exI [of _ \<one>])

lemma H_is_subgroup: "subgroup H G"
proof (rule subgroupI)
  show "H \<subseteq> carrier G"
    using H_into_carrier_G by blast
  show "\<And>a. a \<in> H \<Longrightarrow> inv a \<in> H"
    by (metis H_I H_into_carrier_G H_m_closed M1_subset_G Units_eq Units_inv_closed Units_inv_inv coset_mult_inv1 in_H_imp_eq)
  show "\<And>a b. \<lbrakk>a \<in> H; b \<in> H\<rbrakk> \<Longrightarrow> a \<otimes> b \<in> H"
    by (blast intro: H_m_closed)
qed (use H_not_empty in auto)

lemma rcosetGM1g_subset_G: "\<lbrakk>g \<in> carrier G; x \<in> M1 #> g\<rbrakk> \<Longrightarrow> x \<in> carrier G"
  by (blast intro: M1_subset_G [THEN r_coset_subset_G, THEN subsetD])

lemma finite_M1: "finite M1"
  by (rule finite_subset [OF M1_subset_G finite_G])

lemma finite_rcosetGM1g: "g \<in> carrier G \<Longrightarrow> finite (M1 #> g)"
  using rcosetGM1g_subset_G finite_G M1_subset_G cosets_finite rcosetsI by blast

lemma M1_cardeq_rcosetGM1g: "g \<in> carrier G \<Longrightarrow> card (M1 #> g) = card M1"
  by (metis M1_subset_G card_rcosets_equal rcosetsI)

lemma M1_RelM_rcosetGM1g:
  assumes "g \<in> carrier G"
  shows "(M1, M1 #> g) \<in> RelM"
proof -
  have "M1 #> g \<subseteq> carrier G"
    by (simp add: assms r_coset_subset_G)
  moreover have "card (M1 #> g) = p ^ a"
    using assms by (simp add: card_M1 M1_cardeq_rcosetGM1g)
  moreover have "\<exists>h\<in>carrier G. M1 = M1 #> g #> h"
    by (metis assms M1_subset_G coset_mult_assoc coset_mult_one r_inv_ex)
  ultimately show ?thesis
    by (simp add: RelM_def calM_def card_M1)
qed

end

subsection \<open>Equal Cardinalities of \<open>M\<close> and the Set of Cosets\<close>

text \<open>Injections between \<^term>\<open>M\<close> and \<^term>\<open>rcosets\<^bsub>G\<^esub> H\<close> show that
 their cardinalities are equal.\<close>

lemma ElemClassEquiv: "\<lbrakk>equiv A r; C \<in> A // r\<rbrakk> \<Longrightarrow> \<forall>x \<in> C. \<forall>y \<in> C. (x, y) \<in> r"
  unfolding equiv_def quotient_def sym_def trans_def by blast

context sylow_central
begin

lemma M_elem_map: "M2 \<in> M \<Longrightarrow> \<exists>g. g \<in> carrier G \<and> M1 #> g = M2"
  using M1_in_M M_in_quot [THEN RelM_equiv [THEN ElemClassEquiv]]
  by (simp add: RelM_def) (blast dest!: bspec)

lemmas M_elem_map_carrier = M_elem_map [THEN someI_ex, THEN conjunct1]

lemmas M_elem_map_eq = M_elem_map [THEN someI_ex, THEN conjunct2]

lemma M_funcset_rcosets_H:
  "(\<lambda>x\<in>M. H #> (SOME g. g \<in> carrier G \<and> M1 #> g = x)) \<in> M \<rightarrow> rcosets H"
  by (metis (lifting) H_is_subgroup M_elem_map_carrier rcosetsI restrictI subgroup.subset)

lemma inj_M_GmodH: "\<exists>f \<in> M \<rightarrow> rcosets H. inj_on f M"
proof
  let ?inv = "\<lambda>x. SOME g. g \<in> carrier G \<and> M1 #> g = x"
  show "inj_on (\<lambda>x\<in>M. H #> ?inv x) M"
  proof (rule inj_onI, simp)
    fix x y
    assume eq: "H #> ?inv x = H #> ?inv y" and xy: "x \<in> M" "y \<in> M"
    have "x = M1 #> ?inv x"
      by (simp add: M_elem_map_eq \<open>x \<in> M\<close>)
    also have "... = M1 #> ?inv y"
    proof (rule coset_mult_inv1 [OF in_H_imp_eq [OF coset_join1]])
      show "H #> ?inv x \<otimes> inv (?inv y) = H"
        by (simp add: H_into_carrier_G M_elem_map_carrier xy coset_mult_inv2 eq subsetI)
    qed (simp_all add: H_is_subgroup M_elem_map_carrier xy)
    also have "... = y"
      using M_elem_map_eq \<open>y \<in> M\<close> by simp
    finally show "x=y" .
  qed
  show "(\<lambda>x\<in>M. H #> ?inv x) \<in> M \<rightarrow> rcosets H"
    by (rule M_funcset_rcosets_H)
qed

end

subsubsection \<open>The Opposite Injection\<close>

context sylow_central
begin

lemma H_elem_map: "H1 \<in> rcosets H \<Longrightarrow> \<exists>g. g \<in> carrier G \<and> H #> g = H1"
  by (auto simp: RCOSETS_def)

lemmas H_elem_map_carrier = H_elem_map [THEN someI_ex, THEN conjunct1]

lemmas H_elem_map_eq = H_elem_map [THEN someI_ex, THEN conjunct2]

lemma rcosets_H_funcset_M:
  "(\<lambda>C \<in> rcosets H. M1 #> (SOME g. g \<in> carrier G \<and> H #> g = C)) \<in> rcosets H \<rightarrow> M"
  using in_quotient_imp_closed [OF RelM_equiv M_in_quot _  M1_RelM_rcosetGM1g]
  by (simp add: M1_in_M H_elem_map_carrier RCOSETS_def)

lemma inj_GmodH_M: "\<exists>g \<in> rcosets H\<rightarrow>M. inj_on g (rcosets H)"
proof
  let ?inv = "\<lambda>x. SOME g. g \<in> carrier G \<and> H #> g = x"
  show "inj_on (\<lambda>C\<in>rcosets H. M1 #> ?inv C) (rcosets H)"
  proof (rule inj_onI, simp)
    fix x y
    assume eq: "M1 #> ?inv x = M1 #> ?inv y" and xy: "x \<in> rcosets H" "y \<in> rcosets H"
    have "x = H #> ?inv x"
      by (simp add: H_elem_map_eq \<open>x \<in> rcosets H\<close>)
    also have "... = H #> ?inv y"
    proof (rule coset_mult_inv1 [OF coset_join2])
      show "?inv x \<otimes> inv (?inv y) \<in> carrier G"
        by (simp add: H_elem_map_carrier \<open>x \<in> rcosets H\<close> \<open>y \<in> rcosets H\<close>)
      then show "(?inv x) \<otimes> inv (?inv y) \<in> H"
        by (simp add: H_I H_elem_map_carrier xy coset_mult_inv2 eq)
      show "H \<subseteq> carrier G"
        by (simp add: H_is_subgroup subgroup.subset)
    qed (simp_all add: H_is_subgroup H_elem_map_carrier xy)
    also have "... = y"
      by (simp add: H_elem_map_eq \<open>y \<in> rcosets H\<close>)
    finally show "x=y" .
  qed
  show "(\<lambda>C\<in>rcosets H. M1 #> ?inv C) \<in> rcosets H \<rightarrow> M"
    using rcosets_H_funcset_M by blast
qed

lemma calM_subset_PowG: "calM \<subseteq> Pow (carrier G)"
  by (auto simp: calM_def)

lemma finite_M: "finite M"
  by (metis M_subset_calM finite_calM rev_finite_subset)

lemma cardMeqIndexH: "card M = card (rcosets H)"
  using inj_M_GmodH inj_GmodH_M
  by (blast intro: card_bij finite_M H_is_subgroup rcosets_subset_PowG [THEN finite_subset])

lemma index_lem: "card M * card H = order G"
  by (simp add: cardMeqIndexH lagrange H_is_subgroup)

lemma card_H_eq: "card H = p^a"
proof (rule antisym)
  show "p^a \<le> card H"
  proof (rule dvd_imp_le)
    show "p ^ a dvd card H"
      apply (rule div_combine [OF prime_imp_prime_elem[OF prime_p] not_dvd_M])
      by (simp add: index_lem multiplicity_dvd order_G power_add)
    show "0 < card H"
      by (blast intro: subgroup.finite_imp_card_positive H_is_subgroup)
  qed
next
  show "card H \<le> p^a"
    using M1_inj_H card_M1 card_inj finite_M1 by fastforce
qed

end

lemma (in sylow) sylow_thm: "\<exists>H. subgroup H G \<and> card H = p^a"
proof -
  obtain M where M: "M \<in> calM // RelM" "\<not> (p ^ Suc (multiplicity p m) dvd card M)"
    using lemma_A1 by blast
  then obtain M1 where "M1 \<in> M"
    by (metis existsM1inM)
  define H where "H \<equiv> {g. g \<in> carrier G \<and> M1 #> g = M1}"
  with M \<open>M1 \<in> M\<close>
  interpret sylow_central G p a m calM RelM H M1 M
    by unfold_locales (auto simp add: H_def calM_def RelM_def)
  show ?thesis
    using H_is_subgroup card_H_eq by blast
qed

text \<open>Needed because the locale's automatic definition refers to
  \<^term>\<open>semigroup G\<close> and \<^term>\<open>group_axioms G\<close> rather than
  simply to \<^term>\<open>group G\<close>.\<close>
lemma sylow_eq: "sylow G p a m \<longleftrightarrow> group G \<and> sylow_axioms G p a m"
  by (simp add: sylow_def group_def)

subsection \<open>Sylow's Theorem\<close>

theorem sylow_thm:
  "\<lbrakk>prime p; group G; order G = (p^a) * m; finite (carrier G)\<rbrakk>
    \<Longrightarrow> \<exists>H. subgroup H G \<and> card H = p^a"
  by (rule sylow.sylow_thm [of G p a m]) (simp add: sylow_eq sylow_axioms_def)

end


(*  Title:      HOL/Algebra/RingHom.thy
    Author:     Stephan Hohe, TU Muenchen
*)

theory RingHom
imports Ideal
begin

section {* Homomorphisms of Non-Commutative Rings *}

text {* Lifting existing lemmas in a @{text ring_hom_ring} locale *}
locale ring_hom_ring = R: ring R + S: ring S
    for R (structure) and S (structure) +
  fixes h
  assumes homh: "h \<in> ring_hom R S"
  notes hom_mult [simp] = ring_hom_mult [OF homh]
    and hom_one [simp] = ring_hom_one [OF homh]

sublocale ring_hom_cring \<subseteq> ring: ring_hom_ring
  by default (rule homh)

sublocale ring_hom_ring \<subseteq> abelian_group: abelian_group_hom R S
apply (rule abelian_group_homI)
  apply (rule R.is_abelian_group)
 apply (rule S.is_abelian_group)
apply (intro group_hom.intro group_hom_axioms.intro)
  apply (rule R.a_group)
 apply (rule S.a_group)
apply (insert homh, unfold hom_def ring_hom_def)
apply simp
done

lemma (in ring_hom_ring) is_ring_hom_ring:
  "ring_hom_ring R S h"
  by (rule ring_hom_ring_axioms)

lemma ring_hom_ringI:
  fixes R (structure) and S (structure)
  assumes "ring R" "ring S"
  assumes (* morphism: "h \<in> carrier R \<rightarrow> carrier S" *)
          hom_closed: "!!x. x \<in> carrier R ==> h x \<in> carrier S"
      and compatible_mult: "!!x y. [| x : carrier R; y : carrier R |] ==> h (x \<otimes> y) = h x \<otimes>\<^bsub>S\<^esub> h y"
      and compatible_add: "!!x y. [| x : carrier R; y : carrier R |] ==> h (x \<oplus> y) = h x \<oplus>\<^bsub>S\<^esub> h y"
      and compatible_one: "h \<one> = \<one>\<^bsub>S\<^esub>"
  shows "ring_hom_ring R S h"
proof -
  interpret ring R by fact
  interpret ring S by fact
  show ?thesis apply unfold_locales
apply (unfold ring_hom_def, safe)
   apply (simp add: hom_closed Pi_def)
  apply (erule (1) compatible_mult)
 apply (erule (1) compatible_add)
apply (rule compatible_one)
done
qed

lemma ring_hom_ringI2:
  assumes "ring R" "ring S"
  assumes h: "h \<in> ring_hom R S"
  shows "ring_hom_ring R S h"
proof -
  interpret R: ring R by fact
  interpret S: ring S by fact
  show ?thesis apply (intro ring_hom_ring.intro ring_hom_ring_axioms.intro)
    apply (rule R.is_ring)
    apply (rule S.is_ring)
    apply (rule h)
    done
qed

lemma ring_hom_ringI3:
  fixes R (structure) and S (structure)
  assumes "abelian_group_hom R S h" "ring R" "ring S"
  assumes compatible_mult: "!!x y. [| x : carrier R; y : carrier R |] ==> h (x \<otimes> y) = h x \<otimes>\<^bsub>S\<^esub> h y"
      and compatible_one: "h \<one> = \<one>\<^bsub>S\<^esub>"
  shows "ring_hom_ring R S h"
proof -
  interpret abelian_group_hom R S h by fact
  interpret R: ring R by fact
  interpret S: ring S by fact
  show ?thesis apply (intro ring_hom_ring.intro ring_hom_ring_axioms.intro, rule R.is_ring, rule S.is_ring)
    apply (insert group_hom.homh[OF a_group_hom])
    apply (unfold hom_def ring_hom_def, simp)
    apply safe
    apply (erule (1) compatible_mult)
    apply (rule compatible_one)
    done
qed

lemma ring_hom_cringI:
  assumes "ring_hom_ring R S h" "cring R" "cring S"
  shows "ring_hom_cring R S h"
proof -
  interpret ring_hom_ring R S h by fact
  interpret R: cring R by fact
  interpret S: cring S by fact
  show ?thesis by (intro ring_hom_cring.intro ring_hom_cring_axioms.intro)
    (rule R.is_cring, rule S.is_cring, rule homh)
qed

subsection {* The Kernel of a Ring Homomorphism *}

--"the kernel of a ring homomorphism is an ideal"
lemma (in ring_hom_ring) kernel_is_ideal:
  shows "ideal (a_kernel R S h) R"
apply (rule idealI)
   apply (rule R.is_ring)
  apply (rule additive_subgroup.a_subgroup[OF additive_subgroup_a_kernel])
 apply (unfold a_kernel_def', simp+)
done

text {* Elements of the kernel are mapped to zero *}
lemma (in abelian_group_hom) kernel_zero [simp]:
  "i \<in> a_kernel R S h \<Longrightarrow> h i = \<zero>\<^bsub>S\<^esub>"
by (simp add: a_kernel_defs)

subsection {* Cosets *}

text {* Cosets of the kernel correspond to the elements of the image of the homomorphism *}
lemma (in ring_hom_ring) rcos_imp_homeq:
  assumes acarr: "a \<in> carrier R"
      and xrcos: "x \<in> a_kernel R S h +> a"
  shows "h x = h a"
proof -
  interpret ideal "a_kernel R S h" "R" by (rule kernel_is_ideal)

  from xrcos
      have "\<exists>i \<in> a_kernel R S h. x = i \<oplus> a" by (simp add: a_r_coset_defs)
  from this obtain i
      where iker: "i \<in> a_kernel R S h"
        and x: "x = i \<oplus> a"
      by fast+
  note carr = acarr iker[THEN a_Hcarr]

  from x
      have "h x = h (i \<oplus> a)" by simp
  also from carr
      have "\<dots> = h i \<oplus>\<^bsub>S\<^esub> h a" by simp
  also from iker
      have "\<dots> = \<zero>\<^bsub>S\<^esub> \<oplus>\<^bsub>S\<^esub> h a" by simp
  also from carr
      have "\<dots> = h a" by simp
  finally
      show "h x = h a" .
qed

lemma (in ring_hom_ring) homeq_imp_rcos:
  assumes acarr: "a \<in> carrier R"
      and xcarr: "x \<in> carrier R"
      and hx: "h x = h a"
  shows "x \<in> a_kernel R S h +> a"
proof -
  interpret ideal "a_kernel R S h" "R" by (rule kernel_is_ideal)

  note carr = acarr xcarr
  note hcarr = acarr[THEN hom_closed] xcarr[THEN hom_closed]

  from hx and hcarr
      have a: "h x \<oplus>\<^bsub>S\<^esub> \<ominus>\<^bsub>S\<^esub>h a = \<zero>\<^bsub>S\<^esub>" by algebra
  from carr
      have "h x \<oplus>\<^bsub>S\<^esub> \<ominus>\<^bsub>S\<^esub>h a = h (x \<oplus> \<ominus>a)" by simp
  from a and this
      have b: "h (x \<oplus> \<ominus>a) = \<zero>\<^bsub>S\<^esub>" by simp

  from carr have "x \<oplus> \<ominus>a \<in> carrier R" by simp
  from this and b
      have "x \<oplus> \<ominus>a \<in> a_kernel R S h"
      unfolding a_kernel_def'
      by fast

  from this and carr
      show "x \<in> a_kernel R S h +> a" by (simp add: a_rcos_module_rev)
qed

corollary (in ring_hom_ring) rcos_eq_homeq:
  assumes acarr: "a \<in> carrier R"
  shows "(a_kernel R S h) +> a = {x \<in> carrier R. h x = h a}"
apply rule defer 1
apply clarsimp defer 1
proof
  interpret ideal "a_kernel R S h" "R" by (rule kernel_is_ideal)

  fix x
  assume xrcos: "x \<in> a_kernel R S h +> a"
  from acarr and this
      have xcarr: "x \<in> carrier R"
      by (rule a_elemrcos_carrier)

  from xrcos
      have "h x = h a" by (rule rcos_imp_homeq[OF acarr])
  from xcarr and this
      show "x \<in> {x \<in> carrier R. h x = h a}" by fast
next
  interpret ideal "a_kernel R S h" "R" by (rule kernel_is_ideal)

  fix x
  assume xcarr: "x \<in> carrier R"
     and hx: "h x = h a"
  from acarr xcarr hx
      show "x \<in> a_kernel R S h +> a" by (rule homeq_imp_rcos)
qed

end


(*  Title       : HyperNat.thy
    Author      : Jacques D. Fleuriot
    Copyright   : 1998  University of Cambridge

Converted to Isar and polished by lcp
*)

section{*Hypernatural numbers*}

theory HyperNat
imports StarDef
begin

type_synonym hypnat = "nat star"

abbreviation
  hypnat_of_nat :: "nat => nat star" where
  "hypnat_of_nat == star_of"

definition
  hSuc :: "hypnat => hypnat" where
  hSuc_def [transfer_unfold]: "hSuc = *f* Suc"

subsection{*Properties Transferred from Naturals*}

lemma hSuc_not_zero [iff]: "\<And>m. hSuc m \<noteq> 0"
by transfer (rule Suc_not_Zero)

lemma zero_not_hSuc [iff]: "\<And>m. 0 \<noteq> hSuc m"
by transfer (rule Zero_not_Suc)

lemma hSuc_hSuc_eq [iff]: "\<And>m n. (hSuc m = hSuc n) = (m = n)"
by transfer (rule nat.inject)

lemma zero_less_hSuc [iff]: "\<And>n. 0 < hSuc n"
by transfer (rule zero_less_Suc)

lemma hypnat_minus_zero [simp]: "!!z. z - z = (0::hypnat)"
by transfer (rule diff_self_eq_0)

lemma hypnat_diff_0_eq_0 [simp]: "!!n. (0::hypnat) - n = 0"
by transfer (rule diff_0_eq_0)

lemma hypnat_add_is_0 [iff]: "!!m n. (m+n = (0::hypnat)) = (m=0 & n=0)"
by transfer (rule add_is_0)

lemma hypnat_diff_diff_left: "!!i j k. (i::hypnat) - j - k = i - (j+k)"
by transfer (rule diff_diff_left)

lemma hypnat_diff_commute: "!!i j k. (i::hypnat) - j - k = i-k-j"
by transfer (rule diff_commute)

lemma hypnat_diff_add_inverse [simp]: "!!m n. ((n::hypnat) + m) - n = m"
by transfer (rule diff_add_inverse)

lemma hypnat_diff_add_inverse2 [simp]:  "!!m n. ((m::hypnat) + n) - n = m"
by transfer (rule diff_add_inverse2)

lemma hypnat_diff_cancel [simp]: "!!k m n. ((k::hypnat) + m) - (k+n) = m - n"
by transfer (rule diff_cancel)

lemma hypnat_diff_cancel2 [simp]: "!!k m n. ((m::hypnat) + k) - (n+k) = m - n"
by transfer (rule diff_cancel2)

lemma hypnat_diff_add_0 [simp]: "!!m n. (n::hypnat) - (n+m) = (0::hypnat)"
by transfer (rule diff_add_0)

lemma hypnat_diff_mult_distrib: "!!k m n. ((m::hypnat) - n) * k = (m * k) - (n * k)"
by transfer (rule diff_mult_distrib)

lemma hypnat_diff_mult_distrib2: "!!k m n. (k::hypnat) * (m - n) = (k * m) - (k * n)"
by transfer (rule diff_mult_distrib2)

lemma hypnat_le_zero_cancel [iff]: "!!n. (n \<le> (0::hypnat)) = (n = 0)"
by transfer (rule le_0_eq)

lemma hypnat_mult_is_0 [simp]: "!!m n. (m*n = (0::hypnat)) = (m=0 | n=0)"
by transfer (rule mult_is_0)

lemma hypnat_diff_is_0_eq [simp]: "!!m n. ((m::hypnat) - n = 0) = (m \<le> n)"
by transfer (rule diff_is_0_eq)

lemma hypnat_not_less0 [iff]: "!!n. ~ n < (0::hypnat)"
by transfer (rule not_less0)

lemma hypnat_less_one [iff]:
      "!!n. (n < (1::hypnat)) = (n=0)"
by transfer (rule less_one)

lemma hypnat_add_diff_inverse: "!!m n. ~ m<n ==> n+(m-n) = (m::hypnat)"
by transfer (rule add_diff_inverse)

lemma hypnat_le_add_diff_inverse [simp]: "!!m n. n \<le> m ==> n+(m-n) = (m::hypnat)"
by transfer (rule le_add_diff_inverse)

lemma hypnat_le_add_diff_inverse2 [simp]: "!!m n. n\<le>m ==> (m-n)+n = (m::hypnat)"
by transfer (rule le_add_diff_inverse2)

declare hypnat_le_add_diff_inverse2 [OF order_less_imp_le]

lemma hypnat_le0 [iff]: "!!n. (0::hypnat) \<le> n"
by transfer (rule le0)

lemma hypnat_le_add1 [simp]: "!!x n. (x::hypnat) \<le> x + n"
by transfer (rule le_add1)

lemma hypnat_add_self_le [simp]: "!!x n. (x::hypnat) \<le> n + x"
by transfer (rule le_add2)

lemma hypnat_add_one_self_less [simp]: "(x::hypnat) < x + (1::hypnat)"
by (insert add_strict_left_mono [OF zero_less_one], auto)

lemma hypnat_neq0_conv [iff]: "!!n. (n \<noteq> 0) = (0 < (n::hypnat))"
by transfer (rule neq0_conv)

lemma hypnat_gt_zero_iff: "((0::hypnat) < n) = ((1::hypnat) \<le> n)"
by (auto simp add: linorder_not_less [symmetric])

lemma hypnat_gt_zero_iff2: "(0 < n) = (\<exists>m. n = m + (1::hypnat))"
apply safe
 apply (rule_tac x = "n - (1::hypnat) " in exI)
 apply (simp add: hypnat_gt_zero_iff)
apply (insert add_le_less_mono [OF _ zero_less_one, of 0], auto)
done

lemma hypnat_add_self_not_less: "~ (x + y < (x::hypnat))"
by (simp add: linorder_not_le [symmetric] add.commute [of x])

lemma hypnat_diff_split:
    "P(a - b::hypnat) = ((a<b --> P 0) & (ALL d. a = b + d --> P d))"
    -- {* elimination of @{text -} on @{text hypnat} *}
proof (cases "a<b" rule: case_split)
  case True
    thus ?thesis
      by (auto simp add: hypnat_add_self_not_less order_less_imp_le
                         hypnat_diff_is_0_eq [THEN iffD2])
next
  case False
    thus ?thesis
      by (auto simp add: linorder_not_less dest: order_le_less_trans)
qed

subsection{*Properties of the set of embedded natural numbers*}

lemma of_nat_eq_star_of [simp]: "of_nat = star_of"
proof
  fix n :: nat
  show "of_nat n = star_of n" by transfer simp
qed

lemma Nats_eq_Standard: "(Nats :: nat star set) = Standard"
by (auto simp add: Nats_def Standard_def)

lemma hypnat_of_nat_mem_Nats [simp]: "hypnat_of_nat n \<in> Nats"
by (simp add: Nats_eq_Standard)

lemma hypnat_of_nat_one [simp]: "hypnat_of_nat (Suc 0) = (1::hypnat)"
by transfer simp

lemma hypnat_of_nat_Suc [simp]:
     "hypnat_of_nat (Suc n) = hypnat_of_nat n + (1::hypnat)"
by transfer simp

lemma of_nat_eq_add [rule_format]:
     "\<forall>d::hypnat. of_nat m = of_nat n + d --> d \<in> range of_nat"
apply (induct n)
apply (auto simp add: add.assoc)
apply (case_tac x)
apply (auto simp add: add.commute [of 1])
done

lemma Nats_diff [simp]: "[|a \<in> Nats; b \<in> Nats|] ==> (a-b :: hypnat) \<in> Nats"
by (simp add: Nats_eq_Standard)

subsection{*Infinite Hypernatural Numbers -- @{term HNatInfinite}*}

definition
  (* the set of infinite hypernatural numbers *)
  HNatInfinite :: "hypnat set" where
  "HNatInfinite = {n. n \<notin> Nats}"

lemma Nats_not_HNatInfinite_iff: "(x \<in> Nats) = (x \<notin> HNatInfinite)"
by (simp add: HNatInfinite_def)

lemma HNatInfinite_not_Nats_iff: "(x \<in> HNatInfinite) = (x \<notin> Nats)"
by (simp add: HNatInfinite_def)

lemma star_of_neq_HNatInfinite: "N \<in> HNatInfinite \<Longrightarrow> star_of n \<noteq> N"
by (auto simp add: HNatInfinite_def Nats_eq_Standard)

lemma star_of_Suc_lessI:
  "\<And>N. \<lbrakk>star_of n < N; star_of (Suc n) \<noteq> N\<rbrakk> \<Longrightarrow> star_of (Suc n) < N"
by transfer (rule Suc_lessI)

lemma star_of_less_HNatInfinite:
  assumes N: "N \<in> HNatInfinite"
  shows "star_of n < N"
proof (induct n)
  case 0
  from N have "star_of 0 \<noteq> N" by (rule star_of_neq_HNatInfinite)
  thus "star_of 0 < N" by simp
next
  case (Suc n)
  from N have "star_of (Suc n) \<noteq> N" by (rule star_of_neq_HNatInfinite)
  with Suc show "star_of (Suc n) < N" by (rule star_of_Suc_lessI)
qed

lemma star_of_le_HNatInfinite: "N \<in> HNatInfinite \<Longrightarrow> star_of n \<le> N"
by (rule star_of_less_HNatInfinite [THEN order_less_imp_le])

subsubsection {* Closure Rules *}

lemma Nats_less_HNatInfinite: "\<lbrakk>x \<in> Nats; y \<in> HNatInfinite\<rbrakk> \<Longrightarrow> x < y"
by (auto simp add: Nats_def star_of_less_HNatInfinite)

lemma Nats_le_HNatInfinite: "\<lbrakk>x \<in> Nats; y \<in> HNatInfinite\<rbrakk> \<Longrightarrow> x \<le> y"
by (rule Nats_less_HNatInfinite [THEN order_less_imp_le])

lemma zero_less_HNatInfinite: "x \<in> HNatInfinite \<Longrightarrow> 0 < x"
by (simp add: Nats_less_HNatInfinite)

lemma one_less_HNatInfinite: "x \<in> HNatInfinite \<Longrightarrow> 1 < x"
by (simp add: Nats_less_HNatInfinite)

lemma one_le_HNatInfinite: "x \<in> HNatInfinite \<Longrightarrow> 1 \<le> x"
by (simp add: Nats_le_HNatInfinite)

lemma zero_not_mem_HNatInfinite [simp]: "0 \<notin> HNatInfinite"
by (simp add: HNatInfinite_def)

lemma Nats_downward_closed:
  "\<lbrakk>x \<in> Nats; (y::hypnat) \<le> x\<rbrakk> \<Longrightarrow> y \<in> Nats"
apply (simp only: linorder_not_less [symmetric])
apply (erule contrapos_np)
apply (drule HNatInfinite_not_Nats_iff [THEN iffD2])
apply (erule (1) Nats_less_HNatInfinite)
done

lemma HNatInfinite_upward_closed:
  "\<lbrakk>x \<in> HNatInfinite; x \<le> y\<rbrakk> \<Longrightarrow> y \<in> HNatInfinite"
apply (simp only: HNatInfinite_not_Nats_iff)
apply (erule contrapos_nn)
apply (erule (1) Nats_downward_closed)
done

lemma HNatInfinite_add: "x \<in> HNatInfinite \<Longrightarrow> x + y \<in> HNatInfinite"
apply (erule HNatInfinite_upward_closed)
apply (rule hypnat_le_add1)
done

lemma HNatInfinite_add_one: "x \<in> HNatInfinite \<Longrightarrow> x + 1 \<in> HNatInfinite"
by (rule HNatInfinite_add)

lemma HNatInfinite_diff:
  "\<lbrakk>x \<in> HNatInfinite; y \<in> Nats\<rbrakk> \<Longrightarrow> x - y \<in> HNatInfinite"
apply (frule (1) Nats_le_HNatInfinite)
apply (simp only: HNatInfinite_not_Nats_iff)
apply (erule contrapos_nn)
apply (drule (1) Nats_add, simp)
done

lemma HNatInfinite_is_Suc: "x \<in> HNatInfinite ==> \<exists>y. x = y + (1::hypnat)"
apply (rule_tac x = "x - (1::hypnat) " in exI)
apply (simp add: Nats_le_HNatInfinite)
done

subsection{*Existence of an infinite hypernatural number*}

definition
  (* omega is in fact an infinite hypernatural number = [<1,2,3,...>] *)
  whn :: hypnat where
  hypnat_omega_def: "whn = star_n (%n::nat. n)"

lemma hypnat_of_nat_neq_whn: "hypnat_of_nat n \<noteq> whn"
by (simp add: hypnat_omega_def star_of_def star_n_eq_iff)

lemma whn_neq_hypnat_of_nat: "whn \<noteq> hypnat_of_nat n"
by (simp add: hypnat_omega_def star_of_def star_n_eq_iff)

lemma whn_not_Nats [simp]: "whn \<notin> Nats"
by (simp add: Nats_def image_def whn_neq_hypnat_of_nat)

lemma HNatInfinite_whn [simp]: "whn \<in> HNatInfinite"
by (simp add: HNatInfinite_def)

lemma lemma_unbounded_set [simp]: "{n::nat. m < n} \<in> FreeUltrafilterNat"
apply (insert finite_atMost [of m])
apply (drule FreeUltrafilterNat.finite)
apply (drule FreeUltrafilterNat.not_memD)
apply (simp add: Collect_neg_eq [symmetric] linorder_not_le atMost_def)
done

lemma Compl_Collect_le: "- {n::nat. N \<le> n} = {n. n < N}"
by (simp add: Collect_neg_eq [symmetric] linorder_not_le)

lemma hypnat_of_nat_eq:
     "hypnat_of_nat m  = star_n (%n::nat. m)"
by (simp add: star_of_def)

lemma SHNat_eq: "Nats = {n. \<exists>N. n = hypnat_of_nat N}"
by (simp add: Nats_def image_def)

lemma Nats_less_whn: "n \<in> Nats \<Longrightarrow> n < whn"
by (simp add: Nats_less_HNatInfinite)

lemma Nats_le_whn: "n \<in> Nats \<Longrightarrow> n \<le> whn"
by (simp add: Nats_le_HNatInfinite)

lemma hypnat_of_nat_less_whn [simp]: "hypnat_of_nat n < whn"
by (simp add: Nats_less_whn)

lemma hypnat_of_nat_le_whn [simp]: "hypnat_of_nat n \<le> whn"
by (simp add: Nats_le_whn)

lemma hypnat_zero_less_hypnat_omega [simp]: "0 < whn"
by (simp add: Nats_less_whn)

lemma hypnat_one_less_hypnat_omega [simp]: "1 < whn"
by (simp add: Nats_less_whn)

subsubsection{*Alternative characterization of the set of infinite hypernaturals*}

text{* @{term "HNatInfinite = {N. \<forall>n \<in> Nats. n < N}"}*}

(*??delete? similar reasoning in hypnat_omega_gt_SHNat above*)
lemma HNatInfinite_FreeUltrafilterNat_lemma:
  assumes "\<forall>N::nat. {n. f n \<noteq> N} \<in> FreeUltrafilterNat"
  shows "{n. N < f n} \<in> FreeUltrafilterNat"
apply (induct N)
using assms
apply (drule_tac x = 0 in spec, simp)
using assms
apply (drule_tac x = "Suc N" in spec)
apply (elim ultra, auto)
done

lemma HNatInfinite_iff: "HNatInfinite = {N. \<forall>n \<in> Nats. n < N}"
apply (safe intro!: Nats_less_HNatInfinite)
apply (auto simp add: HNatInfinite_def)
done

subsubsection{*Alternative Characterization of @{term HNatInfinite} using
Free Ultrafilter*}

lemma HNatInfinite_FreeUltrafilterNat:
     "star_n X \<in> HNatInfinite ==> \<forall>u. {n. u < X n}:  FreeUltrafilterNat"
apply (auto simp add: HNatInfinite_iff SHNat_eq)
apply (drule_tac x="star_of u" in spec, simp)
apply (simp add: star_of_def star_less_def starP2_star_n)
done

lemma FreeUltrafilterNat_HNatInfinite:
     "\<forall>u. {n. u < X n}:  FreeUltrafilterNat ==> star_n X \<in> HNatInfinite"
by (auto simp add: star_less_def starP2_star_n HNatInfinite_iff SHNat_eq hypnat_of_nat_eq)

lemma HNatInfinite_FreeUltrafilterNat_iff:
     "(star_n X \<in> HNatInfinite) = (\<forall>u. {n. u < X n}:  FreeUltrafilterNat)"
by (rule iffI [OF HNatInfinite_FreeUltrafilterNat
                 FreeUltrafilterNat_HNatInfinite])

subsection {* Embedding of the Hypernaturals into other types *}

definition
  of_hypnat :: "hypnat \<Rightarrow> 'a::semiring_1_cancel star" where
  of_hypnat_def [transfer_unfold]: "of_hypnat = *f* of_nat"

lemma of_hypnat_0 [simp]: "of_hypnat 0 = 0"
by transfer (rule of_nat_0)

lemma of_hypnat_1 [simp]: "of_hypnat 1 = 1"
by transfer (rule of_nat_1)

lemma of_hypnat_hSuc: "\<And>m. of_hypnat (hSuc m) = 1 + of_hypnat m"
by transfer (rule of_nat_Suc)

lemma of_hypnat_add [simp]:
  "\<And>m n. of_hypnat (m + n) = of_hypnat m + of_hypnat n"
by transfer (rule of_nat_add)

lemma of_hypnat_mult [simp]:
  "\<And>m n. of_hypnat (m * n) = of_hypnat m * of_hypnat n"
by transfer (rule of_nat_mult)

lemma of_hypnat_less_iff [simp]:
  "\<And>m n. (of_hypnat m < (of_hypnat n::'a::linordered_semidom star)) = (m < n)"
by transfer (rule of_nat_less_iff)

lemma of_hypnat_0_less_iff [simp]:
  "\<And>n. (0 < (of_hypnat n::'a::linordered_semidom star)) = (0 < n)"
by transfer (rule of_nat_0_less_iff)

lemma of_hypnat_less_0_iff [simp]:
  "\<And>m. \<not> (of_hypnat m::'a::linordered_semidom star) < 0"
by transfer (rule of_nat_less_0_iff)

lemma of_hypnat_le_iff [simp]:
  "\<And>m n. (of_hypnat m \<le> (of_hypnat n::'a::linordered_semidom star)) = (m \<le> n)"
by transfer (rule of_nat_le_iff)

lemma of_hypnat_0_le_iff [simp]:
  "\<And>n. 0 \<le> (of_hypnat n::'a::linordered_semidom star)"
by transfer (rule of_nat_0_le_iff)

lemma of_hypnat_le_0_iff [simp]:
  "\<And>m. ((of_hypnat m::'a::linordered_semidom star) \<le> 0) = (m = 0)"
by transfer (rule of_nat_le_0_iff)

lemma of_hypnat_eq_iff [simp]:
  "\<And>m n. (of_hypnat m = (of_hypnat n::'a::linordered_semidom star)) = (m = n)"
by transfer (rule of_nat_eq_iff)

lemma of_hypnat_eq_0_iff [simp]:
  "\<And>m. ((of_hypnat m::'a::linordered_semidom star) = 0) = (m = 0)"
by transfer (rule of_nat_eq_0_iff)

lemma HNatInfinite_of_hypnat_gt_zero:
  "N \<in> HNatInfinite \<Longrightarrow> (0::'a::linordered_semidom star) < of_hypnat N"
by (rule ccontr, simp add: linorder_not_less)

end


theory Refinement imports Main
begin
  section{*Monotonic Predicate Transformers*}
text{*
  In this section we introduce the basics of refinement calculus \cite{back-wright-98}.
  Part of this theory is a reformulation of some definitions from \cite{preoteasa:back:2010a},
  but here they are given for predicates, while \cite{preoteasa:back:2010a} uses
  sets.
*}

  notation
    bot ("\<bottom>") and
    top ("\<top>") and
    inf (infixl "\<sqinter>" 70)
    and sup (infixl "\<squnion>" 65)

  subsection{*Basic predicate transformers*}

  definition
    demonic :: "('a => 'b::lattice) => 'b => 'a \<Rightarrow> bool" ("[: _ :]" [0] 1000) where
    "[:Q:] p s = (Q s \<le> p)"

  definition
    assert::"'a::semilattice_inf => 'a => 'a" ("{. _ .}" [0] 1000) where
    "{.p.} q \<equiv>  p \<sqinter> q"

  definition
    "assume"::"('a::boolean_algebra) => 'a => 'a" ("[. _ .]" [0] 1000) where
    "[.p.] q \<equiv>  (-p \<squnion> q)"

  definition
    angelic :: "('a \<Rightarrow> 'b\<Colon>{semilattice_inf,order_bot}) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> bool" ("{: _ :}" [0] 1000) where
    "{:Q:} p s = (Q s \<sqinter> p \<noteq> \<bottom>)"

  syntax
    "_assert" :: "patterns => logic => logic"    ("(1{._./ _.})")
  translations
    "_assert (_patterns x xs) P" == "CONST assert (CONST id (_abs (_pattern x xs) P))"
    "_assert x P" == "CONST assert (CONST id (_abs x P))"

  term "{.x,z . P x y.}"

  syntax "_update" :: "patterns => patterns => logic => logic" ("_ \<leadsto> _ . _" 0)
  translations
    "_update (_patterns x xs) (_patterns y ys) t" == "CONST id (_abs
         (_pattern x xs) (CONST id (_abs (_pattern y ys) t)))"
    "_update x y t" == "CONST id (_abs x (CONST id (_abs y t)))"

  term "[: x \<leadsto> z . (P::'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool) x y y' z :]"
  term "[: x, y \<leadsto> y', z . (P::'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool) x y y' z :]"
  term "{: x, y \<leadsto> y', z . (P::'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> bool) x y y' z :}"

  lemma demonic_demonic: "[:r:] o [:r':] = [:r OO r':]"
    by (simp add: fun_eq_iff le_fun_def demonic_def, auto)

  lemma assert_demonic_comp: "{.p.} o [:r:] o {.p'.} o [:r':] =
      {.x . p x \<and> (\<forall> y . r x y \<longrightarrow> p' y).} o [:r OO r':]"
      by (auto simp add: fun_eq_iff le_fun_def assert_def demonic_def)

  lemma demonic_assert_comp: "[:r:] o {.p.} = {.x.(\<forall> y . r x y \<longrightarrow> p y).} o [:r:]"
      by (auto simp add: fun_eq_iff le_fun_def assert_def demonic_def)

  lemma assert_assert_comp: "{.p::'a::lattice.} o {.p'.} = {.p \<sqinter> p'.}"
      by (simp add: fun_eq_iff le_fun_def assert_def demonic_def inf_assoc)

  definition "inpt r x = (\<exists> y . r x y)"

  definition "trs r = {. inpt r.} o [:r:]"

  lemma "trs (\<lambda> x y . x = y) q x = q x"
    by (simp add: trs_def fun_eq_iff assert_def demonic_def inpt_def bot_fun_def le_fun_def)

  lemma assert_demonic_prop: "{.p.} o [:r:] = {.p.} o [:(\<lambda> x y . p x) \<sqinter> r:]"
    by (auto simp add: fun_eq_iff assert_def demonic_def)

  lemma relcompp_exists: "relcompp r r' x y = (\<exists> u . r x u \<and> r' u y)"
    by auto

  lemma trs_trs: "(trs r) o (trs r') = trs ((\<lambda> s t. (\<forall> s' . r s s' \<longrightarrow> (inpt r' s'))) \<sqinter> (r OO r'))" (is "?S = ?T")
    proof -
      have [simp]: "(\<lambda>x. inpt r x \<and> (\<forall>y. r x y \<longrightarrow> inpt r' y)) = inpt ((\<lambda>s t. \<forall>s'. r s s' \<longrightarrow> inpt r' s') \<sqinter> r OO r')"
        by (auto simp add: fun_eq_iff inpt_def relcompp_exists, blast)
      have [simp]: "(\<lambda>x y. inpt r x \<and> (\<forall>y. r x y \<longrightarrow> inpt r' y)) \<sqinter> r OO r' = (\<lambda>s t. \<forall>s'. r s s' \<longrightarrow> inpt r' s') \<sqinter> r OO r'"
        by (auto simp add: fun_eq_iff inpt_def)
      have "?S = {. inpt r .} \<circ> [: r :] \<circ> {. inpt r' .} \<circ> [: r' :]"
        by (simp add: trs_def comp_assoc[symmetric])
      also have "... = {. \<lambda>x. inpt r x \<and> (\<forall>y. r x y \<longrightarrow> inpt r' y) .} \<circ> [: r OO r' :]"
        by (simp add: assert_demonic_comp)
      also have "... =  {. \<lambda>x. inpt r x \<and> (\<forall>y. r x y \<longrightarrow> inpt r' y) .} o [:(\<lambda> x y . inpt r x \<and> (\<forall>y. r x y \<longrightarrow> inpt r' y))  \<sqinter> (r OO r'):]"
        by (subst assert_demonic_prop, simp)
      also have "... = ?T"
        by (simp add: trs_def)
      finally show ?thesis by simp
    qed

  lemma assert_demonic_refinement: "({.p.} o [:r:] \<le> {.p'.} o [:r':]) = (p \<le> p' \<and> (\<forall> x . p x \<longrightarrow> r' x \<le> r x))"
    by  (auto simp add: le_fun_def assert_def demonic_def)

  lemma trs_refinement: "(trs r \<le> trs r') = ((\<forall> x . inpt r x \<longrightarrow> inpt r' x) \<and> (\<forall> x . inpt r x \<longrightarrow> r' x \<le> r x))"
    by (simp add: trs_def assert_demonic_refinement, simp add: le_fun_def)

  lemma "trs (\<lambda> x y . x \<ge> 0) \<le> trs (\<lambda> x y . x = y)"
    by (simp add: trs_def le_fun_def assert_def demonic_def inpt_def)

  lemma "trs (\<lambda> x y . x \<ge> 0) q x = (if q = \<top> then x \<ge> 0 else False)"
     by (auto simp add: trs_def fun_eq_iff assert_def demonic_def inpt_def bot_fun_def)

  lemma "[:r:] \<sqinter> [:r':] = [:r \<squnion> r':]"
    by (simp add: fun_eq_iff demonic_def)

  lemma spec_demonic_choice: "({.p.} o [:r:]) \<sqinter> ({.p'.} o [:r':]) = ({.p \<sqinter> p'.} o [:r \<squnion> r':])"
    by (auto simp add: fun_eq_iff demonic_def assert_def)

  lemma trs_demonic_choice: "trs r \<sqinter> trs r' = trs ((\<lambda> x y . inpt r x \<and> inpt r' x) \<sqinter> (r \<squnion> r'))"
    proof -
      have [simp]: "inpt ((\<lambda>x y. inpt r x \<and> inpt r' x) \<sqinter> (r \<squnion> r')) = inpt r \<sqinter> inpt r'"
        by (auto simp add: fun_eq_iff inpt_def)
      have "trs r \<sqinter> trs r' = {. inpt r \<sqinter> inpt r' .} \<circ> [: r \<squnion> r' :]"
        by (simp add: trs_def spec_demonic_choice)
      also have "... = {. inpt r \<sqinter> inpt r' .} \<circ> [: (\<lambda> x y . inpt r x \<and> inpt r' x) \<sqinter> (r \<squnion> r') :]"
        by (subst assert_demonic_prop, simp)
      also have "... = trs ((\<lambda> x y . inpt r x \<and> inpt r' x) \<sqinter> (r \<squnion> r'))"
        by (simp add: trs_def)
      finally show ?thesis by simp
    qed

  lemma "p \<sqinter> p' = \<bottom> \<Longrightarrow> ({.p.} o [:r:]) \<squnion> ({.p'.} o [:r':]) = {.p \<squnion> p'.} o [:(\<lambda> x y . p x \<longrightarrow> r x y) \<sqinter> ((\<lambda> x y . p' x \<longrightarrow> r' x y)):]"
    by (simp add: fun_eq_iff assert_def demonic_def, auto)

  subsection{*Conjunctive predicate transformers*}

  definition "conjunctive (S::'a::complete_lattice \<Rightarrow> 'b::complete_lattice) = (\<forall> Q . S (Inf Q) = INFIMUM Q S)"
  definition "sconjunctive (S::'a::complete_lattice \<Rightarrow> 'b::complete_lattice) = (\<forall> Q . (\<exists> x . x \<in> Q) \<longrightarrow> S (Inf Q) = INFIMUM Q S)"

  lemma [simp]: "conjunctive \<top>"
    by (simp add: conjunctive_def)

  lemma conjuncive_demonic [simp]: "conjunctive [:r:]"
    proof (auto simp add: conjunctive_def fun_eq_iff demonic_def)
      fix Q:: "'a set" fix y::'a fix x :: 'b
      assume A: "y \<in> Q"
      assume "r x \<le> Inf Q"
      also from A have "Inf Q \<le> y"
        by (rule Inf_lower)
      finally show "r x \<le> y" by simp
    next
      fix Q:: "'a set" fix x :: 'b
      assume A : "\<forall>y\<in>Q. r x \<le> y"
      show "r x \<le> Inf Q"
        by (rule Inf_greatest, simp add: A)
    qed

  lemma sconjunctive_assert [simp]: "sconjunctive {.p.}"
    proof (auto simp add: sconjunctive_def assert_def INF_def image_def, rule antisym, auto)
      fix Q :: "'a set"
      have [simp]: "\<And> x . x \<in> Q \<Longrightarrow> Inf Q \<le> x"
        by (rule Inf_lower, simp)
      have A: "\<And> x . x \<in> Q \<Longrightarrow> p \<sqinter> Inf Q \<le> p \<sqinter> x"
        by (simp, rule_tac y = "Inf Q" in order_trans, simp_all)
      show "p \<sqinter> Inf Q \<le> Inf {y. \<exists>x\<in>Q. y = p \<sqinter> x}"
        by (rule Inf_greatest, safe, rule A, simp)
    next
      fix Q :: "'a set"
      fix x :: 'a
      assume A: "x \<in> Q"
      have "Inf {y. \<exists>x\<in>Q. y = p \<sqinter> x} \<le> p \<sqinter> x"
        by (rule Inf_lower, cut_tac A, auto)
      also have "... \<le> p"
        by simp
      finally show "Inf {y. \<exists>x\<in>Q. y = p \<sqinter> x} \<le> p"
        by simp
   next
      fix Q :: "'a set"
      show "Inf {y. \<exists>x\<in>Q. y = p \<sqinter> x} \<le> Inf Q"
        proof (rule Inf_greatest)
          fix x::'a
          assume A: "x \<in> Q"
          have "Inf {y. \<exists>x\<in>Q. y = p \<sqinter> x} \<le> p \<sqinter> x"
            by (cut_tac A, rule Inf_lower, blast)
          also have "... \<le> x"
            by simp
         finally show "Inf {y. \<exists>x\<in>Q. y = p \<sqinter> x} \<le> x" by simp
       qed
   qed

  lemma sconjunctive_simp: "x \<in> Q \<Longrightarrow> sconjunctive S \<Longrightarrow> S (Inf Q) = INFIMUM Q S"
    by (auto simp add: sconjunctive_def)

  lemma sconjunctive_INF_simp: "x \<in> X \<Longrightarrow> sconjunctive S \<Longrightarrow> S (INFIMUM X Q) = INFIMUM (Q`X) S"
    by (cut_tac x = "Q x" and Q = "Q ` X" in sconjunctive_simp, auto)

  lemma demonic_comp [simp]: "sconjunctive S \<Longrightarrow> sconjunctive S' \<Longrightarrow> sconjunctive (S o S')"
    proof (subst sconjunctive_def, safe)
      fix X :: "'c set"
      fix a :: 'c
      assume [simp]: "sconjunctive S"
      assume [simp]: "sconjunctive S'"
      assume [simp]: "a \<in> X"
      have A: "S' (Inf X) = INFIMUM X S'"
        by (rule_tac x = a in sconjunctive_simp, auto)
      also have B: "S (INFIMUM X S') = INFIMUM (S' ` X) S"
        by (subst INF_def, rule_tac x = "S' a" in sconjunctive_simp, auto)
      finally show "(S o S') (Inf X) = INFIMUM X (S \<circ> S')" by simp
    qed

  lemma [simp]:"conjunctive S \<Longrightarrow> S (INFIMUM X Q) = (INFIMUM X (S o Q))"
    by (metis INF_image Inf_image_eq conjunctive_def)

  lemma conjunctive_simp: "conjunctive S \<Longrightarrow>  S (Inf Q) = INFIMUM Q S"
    by (metis conjunctive_def)

  lemma conjunctive_monotonic: "sconjunctive S \<Longrightarrow> mono S"
    proof (rule monoI)
      fix a b :: 'a
      assume [simp]: "a \<le> b"
      assume [simp]: "sconjunctive S"
      have [simp]: "a \<sqinter> b = a"
        by (rule antisym, auto)
      have A: "S a = S a \<sqinter> S b"
        by (cut_tac S = S and x = a and Q = "{a, b}" in sconjunctive_simp, auto simp add: INF_def)
      show "S a \<le> S b"
        by (subst A, simp)
    qed

  definition "grd S = - S \<bottom>"

  lemma "grd [:r:] = inpt r"
    by (simp add: fun_eq_iff grd_def demonic_def le_fun_def inpt_def)

  definition "fail S = -(S \<top>)"
  definition "term S = (S \<top>)"

  lemma "fail ({.p.} o [:r :: 'a \<Rightarrow> 'b \<Rightarrow> bool:]) = -p"
    by (simp add: fail_def fun_eq_iff assert_def demonic_def le_fun_def top_fun_def)

  definition "Fail = \<bottom>"

  lemma "mono (S::'a::boolean_algebra \<Rightarrow> 'b::boolean_algebra) \<Longrightarrow> (S = Fail) = (fail S = \<top>)"
    proof auto
      show "fail (Fail::'a \<Rightarrow> 'b) = \<top>"
        by (metis Fail_def bot_apply compl_bot_eq fail_def)
    next
      assume A: "mono S"
      assume B: "fail S = \<top>"
      show "S = Fail"
        proof (rule antisym)
          show "S \<le> Fail"
            by (metis (hide_lams, no_types) A B bot.extremum_unique compl_le_compl_iff fail_def le_fun_def monoD top_greatest)
          next
            show "Fail \<le> S"
              by (metis Fail_def bot.extremum)
        qed
   qed

  definition "Skip = id"

  lemma [simp]: "{.\<top>::'a::bounded_lattice.} = Skip"
    by (simp add: fun_eq_iff assert_def Skip_def)

  lemma [simp]:"Skip o S = S"
    by (simp add: fun_eq_iff assert_def Skip_def)

  lemma [simp]:"S o Skip = S"
    by (simp add: fun_eq_iff assert_def Skip_def)

  lemma [simp]: "mono S \<Longrightarrow> mono S' \<Longrightarrow> mono (S o S')"
    by (simp add: mono_def)

  lemma [simp]: "mono {.p::('a \<Rightarrow> bool).}"
    by (simp add: conjunctive_monotonic)

  lemma [simp]: "mono [:r::('a \<Rightarrow> 'b \<Rightarrow> bool):]"
    by (simp add: conjunctive_monotonic)

  lemma [simp]:"{. \<lambda> x . True .} = Skip"
    by (simp add: fun_eq_iff assert_def Skip_def)

  lemma [simp]: "\<bottom> o S = \<bottom>"
    by (simp add: fun_eq_iff)

  lemma [simp]: "{.\<bottom>::'a::boolean_algebra.}  = \<bottom>"
    by (simp add: fun_eq_iff assert_def)

  lemma [simp]: "\<top> o S = \<top>"
    by (simp add: fun_eq_iff)

  lemma left_comp: "T o U = T' o U' \<Longrightarrow> S o T o U = S o T' o U'"
    by (simp add: comp_assoc)

  lemma assert_demonic: "{.p.} o [:r:] = {.p.} o [:\<lambda> x y . p x \<and> r x y:]"
    by (auto simp add: fun_eq_iff assert_def demonic_def le_fun_def)

  lemma "trs r \<sqinter> trs r' = trs (\<lambda> x y . inpt r x \<and> inpt r' x \<and> (r x y \<or> r' x y))"
    by (auto simp add: fun_eq_iff trs_def assert_def demonic_def inpt_def)

  subsection{*Fusion of predicate transformers*}

  text{*
  In this section we define the fusion operator from \cite{back:butler:1995}. The fusion
  of two programs $S$ and $T$ is intuitively equivalent with the parallel execution of the two
  programs. If $S$ and $T$ assign nondeterministically some value to some program variable
  $x$, then the fusion of $S$ and $T$ will assign a value to $x$ which can be assigned by
  both $S$ and $T$.
*}

  definition fusion :: "(('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool)) \<Rightarrow> (('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool)) \<Rightarrow> (('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool))" (infixl "\<parallel>" 70) where
    "(S \<parallel> S') q x = (\<exists> (p::'a\<Rightarrow>bool) p' . p \<sqinter> p' \<le> q \<and> S p x \<and> S' p' x)"

  lemma fusion_spec: "({.p.} \<circ> [:r:]) \<parallel> ({.p'.} \<circ> [:r':]) = ({.p \<sqinter> p'.} \<circ> [:r \<sqinter> r':])"
    by (auto simp add: fun_eq_iff fusion_def assert_def demonic_def le_fun_def)

  lemma fusion_assoc: "S \<parallel> (T \<parallel> U) = (S \<parallel> T) \<parallel> U"
    proof (rule antisym, auto simp add: fusion_def)
      fix p p' q s s' :: "'a \<Rightarrow> bool"
      fix a
      assume A: "p \<sqinter> p' \<le> q" and B: "s \<sqinter> s' \<le> p'"
      assume C: "S p a" and D: "T s a" and E: "U s' a"
      from A and B  have F: "(p \<sqinter> s) \<sqinter> s' \<le> q"
        by (simp add: le_fun_def)
      have "(\<exists>v v'. v \<sqinter> v' \<le> (p \<sqinter> s) \<and> S v a \<and> T v' a)"
        by (metis C D order_refl)
      show "\<exists>u u' . u \<sqinter> u' \<le> q \<and> (\<exists>v v'. v \<sqinter> v' \<le> u \<and> S v a \<and> T v' a) \<and> U u' a"
        by (metis F C D E order_refl)
    next
      fix p p' q s s' :: "'a \<Rightarrow> bool"
      fix a
      assume A: "p \<sqinter> p' \<le> q" and B: "s \<sqinter> s' \<le> p"
      assume C: "S s a" and D: "T s' a" and E: "U p' a"
      from A and B  have F: "s \<sqinter> (s' \<sqinter> p')  \<le> q"
        by (simp add: le_fun_def)
      have "(\<exists>v v'. v \<sqinter> v' \<le> s' \<sqinter> p' \<and> T v a \<and> U v' a)"
        by (metis D E eq_iff)
      show "\<exists>u u'. u \<sqinter> u' \<le> q \<and> S u a \<and> (\<exists>v v'. v \<sqinter> v' \<le> u' \<and> T v a \<and> U v' a)"
        by (metis F C D E order_refl)
    qed

  lemma "P \<le> Q \<Longrightarrow> P' \<le> Q' \<Longrightarrow> P \<parallel> P' \<le> Q \<parallel> Q'"
    by (simp add: le_fun_def fusion_def, metis)

  lemma "conjunctive S \<Longrightarrow> S \<parallel> \<top> = \<top>"
    by (auto simp add: fun_eq_iff fusion_def le_fun_def conjunctive_def)

  lemma fusion_spec_local: "a \<in> init \<Longrightarrow> ([:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.p.} \<circ> [:r:]) \<parallel> ({.p'.} \<circ> [:r':])
      = [:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.u,x . p (u, x) \<and> p' x.} \<circ> [:u, x \<leadsto> y . r (u, x) y \<and> r' x y:]" (is "?p \<Longrightarrow> ?S = ?T")
    proof -
      assume "?p"
      from this have [simp]: "(\<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x) \<and> p' x) = (\<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x)) \<sqinter> p'"
         by auto
      have [simp]: "(\<lambda>x (u, y). u \<in> init \<and> x = y) OO (\<lambda>(u, x) y. r (u, x) y \<and> r' x y) = (\<lambda>x (u, y). u \<in> init \<and> x = y) OO r \<sqinter> r'"
        by auto
      have "?S =
        ({. \<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x) .} \<circ> [: \<lambda>x (u, y). u \<in> init \<and> x = y :] \<circ> [: r :]) \<parallel> ({. p' .} \<circ> [: r' :])"
        by (simp add: demonic_assert_comp)
      also have "... =  {. (\<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x)) \<sqinter> p' .} \<circ> [: (\<lambda>x (u, y). u \<in> init \<and> x = y) OO r \<sqinter> r' :]"
        by (simp add: comp_assoc demonic_demonic fusion_spec)
      also have "... = ?T"
        by (simp add: demonic_assert_comp comp_assoc demonic_demonic fusion_spec)
      finally show ?thesis by simp
    qed

  lemma fusion_spec_local_a: "a \<in> init \<Longrightarrow> ([:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.p.} \<circ> [:r:]) \<parallel> [:r':]
      = ([:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.p.} \<circ> [:u, x \<leadsto> y . r (u, x) y \<and> r' x y:])"
    by (cut_tac p' = "\<top>" and init = init and p = p and r = r and r' = r' in fusion_spec_local, auto)

  lemma fusion_local_refinement:
    "a \<in> init \<Longrightarrow> (\<And> x u y . u \<in> init \<Longrightarrow> p' x \<Longrightarrow> r (u, x) y \<Longrightarrow> r' x y) \<Longrightarrow>
      {.p'.} o (([:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.p.} \<circ> [:r:]) \<parallel> [:r':]) \<le> [:x \<leadsto> u, y . u \<in> init \<and> x = y:] \<circ> {.p.} \<circ> [:r:]"
    proof -
     assume A: "a \<in> init"
     assume [simp]: "(\<And> x u y . u \<in> init \<Longrightarrow> p' x \<Longrightarrow> r (u, x) y \<Longrightarrow> r' x y)"
     have " {. x. p' x \<and> (\<forall>a. a \<in> init \<longrightarrow> p (a, x)) .} \<circ> [: (\<lambda>x (u, y). u \<in> init \<and> x = y) OO (\<lambda>(u, x) y. r (u, x) y \<and> r' x y) :]
              \<le> {. \<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x) .} \<circ> [: (\<lambda>x (u, y). u \<in> init \<and> x = y) OO r :]"
      by (auto simp add: assert_demonic_refinement)
    from this have " {. x. p' x \<and> (\<forall>a. a \<in> init \<longrightarrow> p (a, x)) .} \<circ> [: (\<lambda>x (u, y). u \<in> init \<and> x = y) OO (\<lambda>(u, x) y. r (u, x) y \<and> r' x y) :]
            \<le> {. \<lambda>x. \<forall>a. a \<in> init \<longrightarrow> p (a, x) .} \<circ> [: \<lambda>x (u, y). u \<in> init \<and> x = y :] \<circ> [: r :]"
      by (simp add: comp_assoc demonic_demonic)
    from this have "{. p' .} \<circ> [: \<lambda>x (u, y). u \<in> init \<and> x = y :] \<circ> {. p .} \<circ> [: \<lambda>(u, x) y. r (u, x) y \<and> r' x y :]
            \<le> [: x \<leadsto> u, y. u \<in> init \<and> x = y :] \<circ> {. p .} \<circ> [: r :]"
      by (simp add: demonic_assert_comp assert_demonic_comp)
    from this have "{. p' .} \<circ> ([: x \<leadsto> (u, y) . u \<in> init \<and> x = y :] \<circ> {. p .} \<circ> [: (u, x) \<leadsto> y . r (u, x) y \<and> r' x y :])
          \<le> [: x \<leadsto> (u, y) . u \<in> init \<and> x = y :] \<circ> {. p .} \<circ> [: r :]"
      by (simp add: comp_assoc [THEN sym])
    from A and this show ?thesis
      by  (unfold fusion_spec_local_a, simp)
  qed
end