(*  Title:      HOL/Library/Extended_Nat.thy
    Author:     David von Oheimb, TU Muenchen;  Florian Haftmann, TU Muenchen
    Contributions: David Trachtenherz, TU Muenchen
*)

section \<open>Extended natural numbers (i.e. with infinity)\<close>

theory Extended_Nat
imports Main Countable Order_Continuity
begin

class infinity =
  fixes infinity :: "'a"  ("\<infinity>")

context
  fixes f :: "nat \<Rightarrow> 'a::{canonically_ordered_monoid_add, linorder_topology, complete_linorder}"
begin

lemma sums_SUP[simp, intro]: "f sums (SUP n. \<Sum>i<n. f i)"
  unfolding sums_def by (intro LIMSEQ_SUP monoI sum_mono2 zero_le) auto

lemma suminf_eq_SUP: "suminf f = (SUP n. \<Sum>i<n. f i)"
  using sums_SUP by (rule sums_unique[symmetric])

end

subsection \<open>Type definition\<close>

text \<open>
  We extend the standard natural numbers by a special value indicating
  infinity.
\<close>

typedef enat = "UNIV :: nat option set" ..

text \<open>TODO: introduce enat as coinductive datatype, enat is just @{const of_nat}\<close>

definition enat :: "nat \<Rightarrow> enat" where
  "enat n = Abs_enat (Some n)"

instantiation enat :: infinity
begin

definition "\<infinity> = Abs_enat None"
instance ..

end

instance enat :: countable
proof
  show "\<exists>to_nat::enat \<Rightarrow> nat. inj to_nat"
    by (rule exI[of _ "to_nat \<circ> Rep_enat"]) (simp add: inj_on_def Rep_enat_inject)
qed

old_rep_datatype enat "\<infinity> :: enat"
proof -
  fix P i assume "\<And>j. P (enat j)" "P \<infinity>"
  then show "P i"
  proof induct
    case (Abs_enat y) then show ?case
      by (cases y rule: option.exhaust)
         (auto simp: enat_def infinity_enat_def)
  qed
qed (auto simp add: enat_def infinity_enat_def Abs_enat_inject)

declare [[coercion "enat::nat\<Rightarrow>enat"]]

lemmas enat2_cases = enat.exhaust[case_product enat.exhaust]
lemmas enat3_cases = enat.exhaust[case_product enat.exhaust enat.exhaust]

lemma not_infinity_eq [iff]: "(x \<noteq> \<infinity>) = (\<exists>i. x = enat i)"
  by (cases x) auto

lemma not_enat_eq [iff]: "(\<forall>y. x \<noteq> enat y) = (x = \<infinity>)"
  by (cases x) auto

lemma enat_ex_split: "(\<exists>c::enat. P c) \<longleftrightarrow> P \<infinity> \<or> (\<exists>c::nat. P c)"
  by (metis enat.exhaust)

primrec the_enat :: "enat \<Rightarrow> nat"
  where "the_enat (enat n) = n"

subsection \<open>Constructors and numbers\<close>

instantiation enat :: zero_neq_one
begin

definition
  "0 = enat 0"

definition
  "1 = enat 1"

instance
  proof qed (simp add: zero_enat_def one_enat_def)

end

definition eSuc :: "enat \<Rightarrow> enat" where
  "eSuc i = (case i of enat n \<Rightarrow> enat (Suc n) | \<infinity> \<Rightarrow> \<infinity>)"

lemma enat_0 [code_post]: "enat 0 = 0"
  by (simp add: zero_enat_def)

lemma enat_1 [code_post]: "enat 1 = 1"
  by (simp add: one_enat_def)

lemma enat_0_iff: "enat x = 0 \<longleftrightarrow> x = 0" "0 = enat x \<longleftrightarrow> x = 0"
  by (auto simp add: zero_enat_def)

lemma enat_1_iff: "enat x = 1 \<longleftrightarrow> x = 1" "1 = enat x \<longleftrightarrow> x = 1"
  by (auto simp add: one_enat_def)

lemma one_eSuc: "1 = eSuc 0"
  by (simp add: zero_enat_def one_enat_def eSuc_def)

lemma infinity_ne_i0 [simp]: "(\<infinity>::enat) \<noteq> 0"
  by (simp add: zero_enat_def)

lemma i0_ne_infinity [simp]: "0 \<noteq> (\<infinity>::enat)"
  by (simp add: zero_enat_def)

lemma zero_one_enat_neq:
  "\<not> 0 = (1::enat)"
  "\<not> 1 = (0::enat)"
  unfolding zero_enat_def one_enat_def by simp_all

lemma infinity_ne_i1 [simp]: "(\<infinity>::enat) \<noteq> 1"
  by (simp add: one_enat_def)

lemma i1_ne_infinity [simp]: "1 \<noteq> (\<infinity>::enat)"
  by (simp add: one_enat_def)

lemma eSuc_enat: "eSuc (enat n) = enat (Suc n)"
  by (simp add: eSuc_def)

lemma eSuc_infinity [simp]: "eSuc \<infinity> = \<infinity>"
  by (simp add: eSuc_def)

lemma eSuc_ne_0 [simp]: "eSuc n \<noteq> 0"
  by (simp add: eSuc_def zero_enat_def split: enat.splits)

lemma zero_ne_eSuc [simp]: "0 \<noteq> eSuc n"
  by (rule eSuc_ne_0 [symmetric])

lemma eSuc_inject [simp]: "eSuc m = eSuc n \<longleftrightarrow> m = n"
  by (simp add: eSuc_def split: enat.splits)

lemma eSuc_enat_iff: "eSuc x = enat y \<longleftrightarrow> (\<exists>n. y = Suc n \<and> x = enat n)"
  by (cases y) (auto simp: enat_0 eSuc_enat[symmetric])

lemma enat_eSuc_iff: "enat y = eSuc x \<longleftrightarrow> (\<exists>n. y = Suc n \<and> enat n = x)"
  by (cases y) (auto simp: enat_0 eSuc_enat[symmetric])

subsection \<open>Addition\<close>

instantiation enat :: comm_monoid_add
begin

definition [nitpick_simp]:
  "m + n = (case m of \<infinity> \<Rightarrow> \<infinity> | enat m \<Rightarrow> (case n of \<infinity> \<Rightarrow> \<infinity> | enat n \<Rightarrow> enat (m + n)))"

lemma plus_enat_simps [simp, code]:
  fixes q :: enat
  shows "enat m + enat n = enat (m + n)"
    and "\<infinity> + q = \<infinity>"
    and "q + \<infinity> = \<infinity>"
  by (simp_all add: plus_enat_def split: enat.splits)

instance
proof
  fix n m q :: enat
  show "n + m + q = n + (m + q)"
    by (cases n m q rule: enat3_cases) auto
  show "n + m = m + n"
    by (cases n m rule: enat2_cases) auto
  show "0 + n = n"
    by (cases n) (simp_all add: zero_enat_def)
qed

end

lemma eSuc_plus_1:
  "eSuc n = n + 1"
  by (cases n) (simp_all add: eSuc_enat one_enat_def)

lemma plus_1_eSuc:
  "1 + q = eSuc q"
  "q + 1 = eSuc q"
  by (simp_all add: eSuc_plus_1 ac_simps)

lemma iadd_Suc: "eSuc m + n = eSuc (m + n)"
  by (simp_all add: eSuc_plus_1 ac_simps)

lemma iadd_Suc_right: "m + eSuc n = eSuc (m + n)"
  by (simp only: add.commute[of m] iadd_Suc)

subsection \<open>Multiplication\<close>

instantiation enat :: "{comm_semiring_1, semiring_no_zero_divisors}"
begin

definition times_enat_def [nitpick_simp]:
  "m * n = (case m of \<infinity> \<Rightarrow> if n = 0 then 0 else \<infinity> | enat m \<Rightarrow>
    (case n of \<infinity> \<Rightarrow> if m = 0 then 0 else \<infinity> | enat n \<Rightarrow> enat (m * n)))"

lemma times_enat_simps [simp, code]:
  "enat m * enat n = enat (m * n)"
  "\<infinity> * \<infinity> = (\<infinity>::enat)"
  "\<infinity> * enat n = (if n = 0 then 0 else \<infinity>)"
  "enat m * \<infinity> = (if m = 0 then 0 else \<infinity>)"
  unfolding times_enat_def zero_enat_def
  by (simp_all split: enat.split)

instance
proof
  fix a b c :: enat
  show "(a * b) * c = a * (b * c)"
    unfolding times_enat_def zero_enat_def
    by (simp split: enat.split)
  show comm: "a * b = b * a"
    unfolding times_enat_def zero_enat_def
    by (simp split: enat.split)
  show "1 * a = a"
    unfolding times_enat_def zero_enat_def one_enat_def
    by (simp split: enat.split)
  show distr: "(a + b) * c = a * c + b * c"
    unfolding times_enat_def zero_enat_def
    by (simp split: enat.split add: distrib_right)
  show "0 * a = 0"
    unfolding times_enat_def zero_enat_def
    by (simp split: enat.split)
  show "a * 0 = 0"
    unfolding times_enat_def zero_enat_def
    by (simp split: enat.split)
  show "a * (b + c) = a * b + a * c"
    by (cases a b c rule: enat3_cases) (auto simp: times_enat_def zero_enat_def distrib_left)
  show "a \<noteq> 0 \<Longrightarrow> b \<noteq> 0 \<Longrightarrow> a * b \<noteq> 0"
    by (cases a b rule: enat2_cases) (auto simp: times_enat_def zero_enat_def)
qed

end

lemma mult_eSuc: "eSuc m * n = n + m * n"
  unfolding eSuc_plus_1 by (simp add: algebra_simps)

lemma mult_eSuc_right: "m * eSuc n = m + m * n"
  unfolding eSuc_plus_1 by (simp add: algebra_simps)

lemma of_nat_eq_enat: "of_nat n = enat n"
  apply (induct n)
  apply (simp add: enat_0)
  apply (simp add: plus_1_eSuc eSuc_enat)
  done

instance enat :: semiring_char_0
proof
  have "inj enat" by (rule injI) simp
  then show "inj (\<lambda>n. of_nat n :: enat)" by (simp add: of_nat_eq_enat)
qed

lemma imult_is_infinity: "((a::enat) * b = \<infinity>) = (a = \<infinity> \<and> b \<noteq> 0 \<or> b = \<infinity> \<and> a \<noteq> 0)"
  by (auto simp add: times_enat_def zero_enat_def split: enat.split)

subsection \<open>Numerals\<close>

lemma numeral_eq_enat:
  "numeral k = enat (numeral k)"
  using of_nat_eq_enat [of "numeral k"] by simp

lemma enat_numeral [code_abbrev]:
  "enat (numeral k) = numeral k"
  using numeral_eq_enat ..

lemma infinity_ne_numeral [simp]: "(\<infinity>::enat) \<noteq> numeral k"
  by (simp add: numeral_eq_enat)

lemma numeral_ne_infinity [simp]: "numeral k \<noteq> (\<infinity>::enat)"
  by (simp add: numeral_eq_enat)

lemma eSuc_numeral [simp]: "eSuc (numeral k) = numeral (k + Num.One)"
  by (simp only: eSuc_plus_1 numeral_plus_one)

subsection \<open>Subtraction\<close>

instantiation enat :: minus
begin

definition diff_enat_def:
"a - b = (case a of (enat x) \<Rightarrow> (case b of (enat y) \<Rightarrow> enat (x - y) | \<infinity> \<Rightarrow> 0)
          | \<infinity> \<Rightarrow> \<infinity>)"

instance ..

end

lemma idiff_enat_enat [simp, code]: "enat a - enat b = enat (a - b)"
  by (simp add: diff_enat_def)

lemma idiff_infinity [simp, code]: "\<infinity> - n = (\<infinity>::enat)"
  by (simp add: diff_enat_def)

lemma idiff_infinity_right [simp, code]: "enat a - \<infinity> = 0"
  by (simp add: diff_enat_def)

lemma idiff_0 [simp]: "(0::enat) - n = 0"
  by (cases n, simp_all add: zero_enat_def)

lemmas idiff_enat_0 [simp] = idiff_0 [unfolded zero_enat_def]

lemma idiff_0_right [simp]: "(n::enat) - 0 = n"
  by (cases n) (simp_all add: zero_enat_def)

lemmas idiff_enat_0_right [simp] = idiff_0_right [unfolded zero_enat_def]

lemma idiff_self [simp]: "n \<noteq> \<infinity> \<Longrightarrow> (n::enat) - n = 0"
  by (auto simp: zero_enat_def)

lemma eSuc_minus_eSuc [simp]: "eSuc n - eSuc m = n - m"
  by (simp add: eSuc_def split: enat.split)

lemma eSuc_minus_1 [simp]: "eSuc n - 1 = n"
  by (simp add: one_enat_def eSuc_enat[symmetric] zero_enat_def[symmetric])

(*lemmas idiff_self_eq_0_enat = idiff_self_eq_0[unfolded zero_enat_def]*)

subsection \<open>Ordering\<close>

instantiation enat :: linordered_ab_semigroup_add
begin

definition [nitpick_simp]:
  "m \<le> n = (case n of enat n1 \<Rightarrow> (case m of enat m1 \<Rightarrow> m1 \<le> n1 | \<infinity> \<Rightarrow> False)
    | \<infinity> \<Rightarrow> True)"

definition [nitpick_simp]:
  "m < n = (case m of enat m1 \<Rightarrow> (case n of enat n1 \<Rightarrow> m1 < n1 | \<infinity> \<Rightarrow> True)
    | \<infinity> \<Rightarrow> False)"

lemma enat_ord_simps [simp]:
  "enat m \<le> enat n \<longleftrightarrow> m \<le> n"
  "enat m < enat n \<longleftrightarrow> m < n"
  "q \<le> (\<infinity>::enat)"
  "q < (\<infinity>::enat) \<longleftrightarrow> q \<noteq> \<infinity>"
  "(\<infinity>::enat) \<le> q \<longleftrightarrow> q = \<infinity>"
  "(\<infinity>::enat) < q \<longleftrightarrow> False"
  by (simp_all add: less_eq_enat_def less_enat_def split: enat.splits)

lemma numeral_le_enat_iff[simp]:
  shows "numeral m \<le> enat n \<longleftrightarrow> numeral m \<le> n"
by (auto simp: numeral_eq_enat)

lemma numeral_less_enat_iff[simp]:
  shows "numeral m < enat n \<longleftrightarrow> numeral m < n"
by (auto simp: numeral_eq_enat)

lemma enat_ord_code [code]:
  "enat m \<le> enat n \<longleftrightarrow> m \<le> n"
  "enat m < enat n \<longleftrightarrow> m < n"
  "q \<le> (\<infinity>::enat) \<longleftrightarrow> True"
  "enat m < \<infinity> \<longleftrightarrow> True"
  "\<infinity> \<le> enat n \<longleftrightarrow> False"
  "(\<infinity>::enat) < q \<longleftrightarrow> False"
  by simp_all

instance
  by standard (auto simp add: less_eq_enat_def less_enat_def plus_enat_def split: enat.splits)

end

instance enat :: dioid
proof
  fix a b :: enat show "(a \<le> b) = (\<exists>c. b = a + c)"
    by (cases a b rule: enat2_cases) (auto simp: le_iff_add enat_ex_split)
qed

instance enat :: "{linordered_nonzero_semiring, strict_ordered_comm_monoid_add}"
proof
  fix a b c :: enat
  show "a \<le> b \<Longrightarrow> 0 \<le> c \<Longrightarrow>c * a \<le> c * b"
    unfolding times_enat_def less_eq_enat_def zero_enat_def
    by (simp split: enat.splits)
  show "a < b \<Longrightarrow> c < d \<Longrightarrow> a + c < b + d" for a b c d :: enat
    by (cases a b c d rule: enat2_cases[case_product enat2_cases]) auto
qed (simp add: zero_enat_def one_enat_def)

(* BH: These equations are already proven generally for any type in
class linordered_semidom. However, enat is not in that class because
it does not have the cancellation property. Would it be worthwhile to
a generalize linordered_semidom to a new class that includes enat? *)

lemma enat_ord_number [simp]:
  "(numeral m :: enat) \<le> numeral n \<longleftrightarrow> (numeral m :: nat) \<le> numeral n"
  "(numeral m :: enat) < numeral n \<longleftrightarrow> (numeral m :: nat) < numeral n"
  by (simp_all add: numeral_eq_enat)

lemma infinity_ileE [elim!]: "\<infinity> \<le> enat m \<Longrightarrow> R"
  by (simp add: zero_enat_def less_eq_enat_def split: enat.splits)

lemma infinity_ilessE [elim!]: "\<infinity> < enat m \<Longrightarrow> R"
  by simp

lemma eSuc_ile_mono [simp]: "eSuc n \<le> eSuc m \<longleftrightarrow> n \<le> m"
  by (simp add: eSuc_def less_eq_enat_def split: enat.splits)

lemma eSuc_mono [simp]: "eSuc n < eSuc m \<longleftrightarrow> n < m"
  by (simp add: eSuc_def less_enat_def split: enat.splits)

lemma ile_eSuc [simp]: "n \<le> eSuc n"
  by (simp add: eSuc_def less_eq_enat_def split: enat.splits)

lemma not_eSuc_ilei0 [simp]: "\<not> eSuc n \<le> 0"
  by (simp add: zero_enat_def eSuc_def less_eq_enat_def split: enat.splits)

lemma i0_iless_eSuc [simp]: "0 < eSuc n"
  by (simp add: zero_enat_def eSuc_def less_enat_def split: enat.splits)

lemma iless_eSuc0[simp]: "(n < eSuc 0) = (n = 0)"
  by (simp add: zero_enat_def eSuc_def less_enat_def split: enat.split)

lemma ileI1: "m < n \<Longrightarrow> eSuc m \<le> n"
  by (simp add: eSuc_def less_eq_enat_def less_enat_def split: enat.splits)

lemma Suc_ile_eq: "enat (Suc m) \<le> n \<longleftrightarrow> enat m < n"
  by (cases n) auto

lemma iless_Suc_eq [simp]: "enat m < eSuc n \<longleftrightarrow> enat m \<le> n"
  by (auto simp add: eSuc_def less_enat_def split: enat.splits)

lemma imult_infinity: "(0::enat) < n \<Longrightarrow> \<infinity> * n = \<infinity>"
  by (simp add: zero_enat_def less_enat_def split: enat.splits)

lemma imult_infinity_right: "(0::enat) < n \<Longrightarrow> n * \<infinity> = \<infinity>"
  by (simp add: zero_enat_def less_enat_def split: enat.splits)

lemma enat_0_less_mult_iff: "(0 < (m::enat) * n) = (0 < m \<and> 0 < n)"
  by (simp only: zero_less_iff_neq_zero mult_eq_0_iff, simp)

lemma mono_eSuc: "mono eSuc"
  by (simp add: mono_def)

lemma min_enat_simps [simp]:
  "min (enat m) (enat n) = enat (min m n)"
  "min q 0 = 0"
  "min 0 q = 0"
  "min q (\<infinity>::enat) = q"
  "min (\<infinity>::enat) q = q"
  by (auto simp add: min_def)

lemma max_enat_simps [simp]:
  "max (enat m) (enat n) = enat (max m n)"
  "max q 0 = q"
  "max 0 q = q"
  "max q \<infinity> = (\<infinity>::enat)"
  "max \<infinity> q = (\<infinity>::enat)"
  by (simp_all add: max_def)

lemma enat_ile: "n \<le> enat m \<Longrightarrow> \<exists>k. n = enat k"
  by (cases n) simp_all

lemma enat_iless: "n < enat m \<Longrightarrow> \<exists>k. n = enat k"
  by (cases n) simp_all

lemma iadd_le_enat_iff:
  "x + y \<le> enat n \<longleftrightarrow> (\<exists>y' x'. x = enat x' \<and> y = enat y' \<and> x' + y' \<le> n)"
by(cases x y rule: enat.exhaust[case_product enat.exhaust]) simp_all

lemma chain_incr: "\<forall>i. \<exists>j. Y i < Y j \<Longrightarrow> \<exists>j. enat k < Y j"
apply (induct_tac k)
 apply (simp (no_asm) only: enat_0)
 apply (fast intro: le_less_trans [OF zero_le])
apply (erule exE)
apply (drule spec)
apply (erule exE)
apply (drule ileI1)
apply (rule eSuc_enat [THEN subst])
apply (rule exI)
apply (erule (1) le_less_trans)
done

lemma eSuc_max: "eSuc (max x y) = max (eSuc x) (eSuc y)"
  by (simp add: eSuc_def split: enat.split)

lemma eSuc_Max:
  assumes "finite A" "A \<noteq> {}"
  shows "eSuc (Max A) = Max (eSuc ` A)"
using assms proof induction
  case (insert x A)
  thus ?case by(cases "A = {}")(simp_all add: eSuc_max)
qed simp

instantiation enat :: "{order_bot, order_top}"
begin

definition bot_enat :: enat where "bot_enat = 0"
definition top_enat :: enat where "top_enat = \<infinity>"

instance
  by standard (simp_all add: bot_enat_def top_enat_def)

end

lemma finite_enat_bounded:
  assumes le_fin: "\<And>y. y \<in> A \<Longrightarrow> y \<le> enat n"
  shows "finite A"
proof (rule finite_subset)
  show "finite (enat ` {..n})" by blast
  have "A \<subseteq> {..enat n}" using le_fin by fastforce
  also have "\<dots> \<subseteq> enat ` {..n}"
    apply (rule subsetI)
    subgoal for x by (cases x) auto
    done
  finally show "A \<subseteq> enat ` {..n}" .
qed

subsection \<open>Cancellation simprocs\<close>

lemma enat_add_left_cancel: "a + b = a + c \<longleftrightarrow> a = (\<infinity>::enat) \<or> b = c"
  unfolding plus_enat_def by (simp split: enat.split)

lemma enat_add_left_cancel_le: "a + b \<le> a + c \<longleftrightarrow> a = (\<infinity>::enat) \<or> b \<le> c"
  unfolding plus_enat_def by (simp split: enat.split)

lemma enat_add_left_cancel_less: "a + b < a + c \<longleftrightarrow> a \<noteq> (\<infinity>::enat) \<and> b < c"
  unfolding plus_enat_def by (simp split: enat.split)

ML \<open>
structure Cancel_Enat_Common =
struct
  (* copied from src/HOL/Tools/nat_numeral_simprocs.ML *)
  fun find_first_t _    _ []         = raise TERM("find_first_t", [])
    | find_first_t past u (t::terms) =
          if u aconv t then (rev past @ terms)
          else find_first_t (t::past) u terms

  fun dest_summing (Const (@{const_name Groups.plus}, _) $ t $ u, ts) =
        dest_summing (t, dest_summing (u, ts))
    | dest_summing (t, ts) = t :: ts

  val mk_sum = Arith_Data.long_mk_sum
  fun dest_sum t = dest_summing (t, [])
  val find_first = find_first_t []
  val trans_tac = Numeral_Simprocs.trans_tac
  val norm_ss =
    simpset_of (put_simpset HOL_basic_ss @{context}
      addsimps @{thms ac_simps add_0_left add_0_right})
  fun norm_tac ctxt = ALLGOALS (simp_tac (put_simpset norm_ss ctxt))
  fun simplify_meta_eq ctxt cancel_th th =
    Arith_Data.simplify_meta_eq [] ctxt
      ([th, cancel_th] MRS trans)
  fun mk_eq (a, b) = HOLogic.mk_Trueprop (HOLogic.mk_eq (a, b))
end

structure Eq_Enat_Cancel = ExtractCommonTermFun
(open Cancel_Enat_Common
  val mk_bal = HOLogic.mk_eq
  val dest_bal = HOLogic.dest_bin @{const_name HOL.eq} @{typ enat}
  fun simp_conv _ _ = SOME @{thm enat_add_left_cancel}
)

structure Le_Enat_Cancel = ExtractCommonTermFun
(open Cancel_Enat_Common
  val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less_eq}
  val dest_bal = HOLogic.dest_bin @{const_name Orderings.less_eq} @{typ enat}
  fun simp_conv _ _ = SOME @{thm enat_add_left_cancel_le}
)

structure Less_Enat_Cancel = ExtractCommonTermFun
(open Cancel_Enat_Common
  val mk_bal = HOLogic.mk_binrel @{const_name Orderings.less}
  val dest_bal = HOLogic.dest_bin @{const_name Orderings.less} @{typ enat}
  fun simp_conv _ _ = SOME @{thm enat_add_left_cancel_less}
)
\<close>

simproc_setup enat_eq_cancel
  ("(l::enat) + m = n" | "(l::enat) = m + n") =
  \<open>fn phi => fn ctxt => fn ct => Eq_Enat_Cancel.proc ctxt (Thm.term_of ct)\<close>

simproc_setup enat_le_cancel
  ("(l::enat) + m \<le> n" | "(l::enat) \<le> m + n") =
  \<open>fn phi => fn ctxt => fn ct => Le_Enat_Cancel.proc ctxt (Thm.term_of ct)\<close>

simproc_setup enat_less_cancel
  ("(l::enat) + m < n" | "(l::enat) < m + n") =
  \<open>fn phi => fn ctxt => fn ct => Less_Enat_Cancel.proc ctxt (Thm.term_of ct)\<close>

text \<open>TODO: add regression tests for these simprocs\<close>

text \<open>TODO: add simprocs for combining and cancelling numerals\<close>

subsection \<open>Well-ordering\<close>

lemma less_enatE:
  "[| n < enat m; !!k. n = enat k ==> k < m ==> P |] ==> P"
by (induct n) auto

lemma less_infinityE:
  "[| n < \<infinity>; !!k. n = enat k ==> P |] ==> P"
by (induct n) auto

lemma enat_less_induct:
  assumes prem: "!!n. \<forall>m::enat. m < n --> P m ==> P n" shows "P n"
proof -
  have P_enat: "!!k. P (enat k)"
    apply (rule nat_less_induct)
    apply (rule prem, clarify)
    apply (erule less_enatE, simp)
    done
  show ?thesis
  proof (induct n)
    fix nat
    show "P (enat nat)" by (rule P_enat)
  next
    show "P \<infinity>"
      apply (rule prem, clarify)
      apply (erule less_infinityE)
      apply (simp add: P_enat)
      done
  qed
qed

instance enat :: wellorder
proof
  fix P and n
  assume hyp: "(\<And>n::enat. (\<And>m::enat. m < n \<Longrightarrow> P m) \<Longrightarrow> P n)"
  show "P n" by (blast intro: enat_less_induct hyp)
qed

subsection \<open>Complete Lattice\<close>

instantiation enat :: complete_lattice
begin

definition inf_enat :: "enat \<Rightarrow> enat \<Rightarrow> enat" where
  "inf_enat = min"

definition sup_enat :: "enat \<Rightarrow> enat \<Rightarrow> enat" where
  "sup_enat = max"

definition Inf_enat :: "enat set \<Rightarrow> enat" where
  "Inf_enat A = (if A = {} then \<infinity> else (LEAST x. x \<in> A))"

definition Sup_enat :: "enat set \<Rightarrow> enat" where
  "Sup_enat A = (if A = {} then 0 else if finite A then Max A else \<infinity>)"
instance
proof
  fix x :: "enat" and A :: "enat set"
  { assume "x \<in> A" then show "Inf A \<le> x"
      unfolding Inf_enat_def by (auto intro: Least_le) }
  { assume "\<And>y. y \<in> A \<Longrightarrow> x \<le> y" then show "x \<le> Inf A"
      unfolding Inf_enat_def
      by (cases "A = {}") (auto intro: LeastI2_ex) }
  { assume "x \<in> A" then show "x \<le> Sup A"
      unfolding Sup_enat_def by (cases "finite A") auto }
  { assume "\<And>y. y \<in> A \<Longrightarrow> y \<le> x" then show "Sup A \<le> x"
      unfolding Sup_enat_def using finite_enat_bounded by auto }
qed (simp_all add:
 inf_enat_def sup_enat_def bot_enat_def top_enat_def Inf_enat_def Sup_enat_def)
end

instance enat :: complete_linorder ..

lemma eSuc_Sup: "A \<noteq> {} \<Longrightarrow> eSuc (Sup A) = Sup (eSuc ` A)"
  by(auto simp add: Sup_enat_def eSuc_Max inj_on_def dest: finite_imageD)

lemma sup_continuous_eSuc: "sup_continuous f \<Longrightarrow> sup_continuous (\<lambda>x. eSuc (f x))"
  using  eSuc_Sup[of "_ ` UNIV"] by (auto simp: sup_continuous_def)

subsection \<open>Traditional theorem names\<close>

lemmas enat_defs = zero_enat_def one_enat_def eSuc_def
  plus_enat_def less_eq_enat_def less_enat_def

lemma iadd_is_0: "(m + n = (0::enat)) = (m = 0 \<and> n = 0)"
  by (rule add_eq_0_iff_both_eq_0)

lemma i0_lb : "(0::enat) \<le> n"
  by (rule zero_le)

lemma ile0_eq: "n \<le> (0::enat) \<longleftrightarrow> n = 0"
  by (rule le_zero_eq)

lemma not_iless0: "\<not> n < (0::enat)"
  by (rule not_less_zero)

lemma i0_less[simp]: "(0::enat) < n \<longleftrightarrow> n \<noteq> 0"
  by (rule zero_less_iff_neq_zero)

lemma imult_is_0: "((m::enat) * n = 0) = (m = 0 \<or> n = 0)"
  by (rule mult_eq_0_iff)

end


theory More_List_Lexord
  imports Main "HOL-Library.List_Lexorder" More_List
begin

subsection \<open>Additional lemmas about list lexorder\<close>

lemma lexord_right_append:
  assumes "(xs, ys) \<in> lexord R" "length xs = length ys"
  shows "(xs @ xs', ys @ ys') \<in> lexord R"
  using assms
  unfolding lexord_def
  by auto blast+

lemma list_less_right_append:
  assumes "length xs = length ys" "xs < ys"
  shows "xs @ xs' < ys @ ys'"
  using assms
  by (simp add: list_less_def lexord_right_append)

lemma lexord_prefix_same_length:
  assumes "(xs1 @ ys1, xs2 @ ys2) \<in> lexord R" "length xs1 = length xs2"
  shows "(xs1, xs2) \<in> lexord R \<or> xs1 = xs2"
  using assms
  by (induct xs1 arbitrary: xs2 ys1 ys2) (auto, smt Suc_length_conv append_Cons lexord_cons_cons)

lemma list_prefix_same_length:
  assumes "xs1 @ ys1 < xs2 @ ys2" "length xs1 = length xs2"
  shows "xs1 \<le> xs2"
  using assms
  by (simp add: list_less_def list_le_def lexord_prefix_same_length)

lemma list_less_append:
  assumes "ys1 < ys2"
  shows "xs @ ys1 < xs @ ys2"
  using assms
  unfolding list_less_def lexord_def
  by (smt append_assoc case_prodD case_prodI mem_Collect_eq)

lemma map_mono:
  assumes "length a = length b"
    "\<forall> x \<in> set a \<union> set b. \<forall> y \<in> set a \<union> set b. x < y \<longleftrightarrow> f x < f y"
    "\<forall> x \<in> set a \<union> set b. \<forall> y \<in> set a \<union> set b. f x = f y \<longrightarrow> x = y"
  shows "a < b \<longleftrightarrow> map f a < map f b"
proof
  assume "a < b"
  then obtain u xa xb va vb where *: "a = u @ xa # va" "b = u @ xb # vb" "xa < xb"
    using `length a = length b`
    unfolding list_less_def lexord_def
    by auto
  hence "map f a = map f u @ f xa # map f va" "map f b = map f u @ f xb # map f vb" "f xa < f xb"
    using assms(1-2)
    by auto
  thus "map f a < map f b"
    unfolding list_less_def lexord_def
    by blast
next
  have "length (map f a) = length (map f b)"
    using assms
    by auto
  assume "map f a < map f b"
  then obtain u xa xb va vb where *: "map f a = u @ xa # va" "map f b = u @ xb # vb" "xa < xb"
    unfolding list_less_def lexord_def
    using \<open>length (map f a) = length (map f b)\<close> case_prodD lexord_take_index_conv mem_Collect_eq min_less_iff_conj
    by fastforce
  hence "xa = f (a ! (length u))" "xb = f (b ! (length u))"
    by (metis One_nat_def add_diff_cancel_left' diff_is_0_eq' length_append length_map less_or_eq_imp_le list.size(4) not_le not_one_le_zero nth_append_length nth_map zero_eq_add_iff_both_eq_0)+
  hence "a ! length u < b ! length u"
    using `xa < xb` assms(2)[rule_format, of "a ! length u" "b ! length u"]
    by (metis "*"(1) One_nat_def Un_iff \<open>length (map f a) = length (map f b)\<close> add_diff_cancel_left' diff_is_0_eq' length_append length_map less_or_eq_imp_le list.size(4) not_le not_one_le_zero nth_mem zero_eq_add_iff_both_eq_0)
  moreover
  have "take (length u) a = take (length u) b"
  proof (rule nth_equalityI)
    show "length (take (length u) a) = length (take (length u) b)"
      using * assms(1)
      by simp
  next
    fix i
    assume **: "i < length (take (length u) a)"
    hence "map f a ! i = map f b ! i"
      using *
      by (simp add: nth_append)
    hence "f (a ! i) = f (b ! i)"
      using * **
      by (metis assms(1) length_take min_less_iff_conj nth_map)
    hence "a ! i = b ! i"
      using assms(3)[rule_format, of "a ! i" "b ! i"]
      using "**" assms(1) by auto
    thus "take (length u) a ! i = take (length u) b ! i"
      using * **
      by simp
  qed
  ultimately
  show "a < b"
    using * assms(1)
    unfolding list_less_def lexord_def
    by (smt add_diff_cancel_left' case_prodI diff_is_0_eq' id_take_nth_drop length_append length_map list.size(4) mem_Collect_eq nat.simps(3) not_le zero_eq_add_iff_both_eq_0)
qed

lemma map_mono':
  assumes "length a = length b"
    "\<forall> x \<in> set a \<union> set b. \<forall> y \<in> set a \<union> set b. x < y \<longleftrightarrow> f x > f y"
    "\<forall> x \<in> set a \<union> set b. \<forall> y \<in> set a \<union> set b. f x = f y \<longrightarrow> x = y"
  shows "a < b \<longleftrightarrow> map f a > map f b"
proof
  assume "a < b"
  then obtain u xa xb va vb where *: "a = u @ xa # va" "b = u @ xb # vb" "xa < xb"
    using `length a = length b`
    unfolding list_less_def lexord_def
    by auto
  hence "map f a = map f u @ f xa # map f va" "map f b = map f u @ f xb # map f vb" "f xa > f xb"
    using assms(1-2)
    by auto
  thus "map f a > map f b"
    unfolding list_less_def lexord_def
    by blast
next
  have "length (map f a) = length (map f b)"
    using assms
    by auto
  assume "map f b < map f a"
  then obtain u xa xb va vb where *: "map f a = u @ xa # va" "map f b = u @ xb # vb" "xa > xb"
    unfolding list_less_def lexord_def
    using \<open>length (map f a) = length (map f b)\<close> case_prodD lexord_take_index_conv mem_Collect_eq min_less_iff_conj
    by fastforce
  hence "xa = f (a ! (length u))" "xb = f (b ! (length u))"
    by (metis One_nat_def add_diff_cancel_left' diff_is_0_eq' length_append length_map less_or_eq_imp_le list.size(4) not_le not_one_le_zero nth_append_length nth_map zero_eq_add_iff_both_eq_0)+
  hence "a ! length u < b ! length u"
    using `xa > xb` assms(2)[rule_format, of "a ! length u" "b ! length u"]
    by (metis "*"(1) One_nat_def Un_iff \<open>length (map f a) = length (map f b)\<close> add_diff_cancel_left' diff_is_0_eq' length_append length_map less_or_eq_imp_le list.size(4) not_le not_one_le_zero nth_mem zero_eq_add_iff_both_eq_0)
  moreover
  have "take (length u) a = take (length u) b"
  proof (rule nth_equalityI)
    show "length (take (length u) a) = length (take (length u) b)"
      using * assms(1)
      by simp
  next
    fix i
    assume **: "i < length (take (length u) a)"
    hence "map f a ! i = map f b ! i"
      using *
      by (simp add: nth_append)
    hence "f (a ! i) = f (b ! i)"
      using * **
      by (metis assms(1) length_take min_less_iff_conj nth_map)
    hence "a ! i = b ! i"
      using assms(3)[rule_format, of "a ! i" "b ! i"]
      using "**" assms(1) by auto
    thus "take (length u) a ! i = take (length u) b ! i"
      using * **
      by simp
  qed
  ultimately
  show "a < b"
    using * assms(1)
    unfolding list_less_def lexord_def
    by (smt add_diff_cancel_left' case_prodI diff_is_0_eq' id_take_nth_drop length_append length_map list.size(4) mem_Collect_eq nat.simps(3) not_le zero_eq_add_iff_both_eq_0)
qed

lemma map_filter_less_list:
  assumes "length (filter P1 [0..<n]) = length (filter P2 [0..<n])"
  shows "rev (map P1 [0..<n]) < rev (map P2 [0..<n]) \<longleftrightarrow>
         rev (filter P1 [0..<n]) < rev (filter P2 [0..<n])" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then obtain u v w
    where uvw: "rev (map P1 [0..<n]) = u @ False # v" "rev (map P2 [0..<n]) = u @ True # w"
    unfolding list_less_def lexord_def
    by auto

  moreover
  hence *: "length u + 1 + length v = n" "length u + 1 + length w = n"
    by (metis One_nat_def add.assoc add.commute diff_zero length_append length_map length_rev length_upt list.size(4))+

  moreover

  let ?F = "\<lambda> l1 l2. map snd (filter fst (zip l1 l2))"

  have P1: "filter P1 [0..<n] = ?F (map P1 [0..<n]) [0..<n]"
    by (induction n, auto)
  moreover
  have P2: "filter P2 [0..<n] = ?F (map P2 [0..<n]) [0..<n]"
    by (induction n, auto)
  moreover

  let ?i1 = "take (length u) (rev [0..<n])"
  let ?i = "rev [0..<n] ! length u"
  let ?i2 = "drop (length u + 1) (rev [0..<n])"

  have ii: "rev [0..<n] = ?i1 @ [?i] @ ?i2"
    by (metis One_nat_def add.right_neutral add_Suc_right add_diff_cancel_left' append_Cons append_Nil calculation(1) calculation(3) diff_is_0_eq' diff_zero id_take_nth_drop length_append length_map length_rev length_upt less_add_one linorder_not_le not_add_less1)

  have "zip (u @ False # v) (rev [0..<n]) = zip u ?i1 @ [(False, ?i)] @ zip v ?i2"
    using ii
    by (metis append_Cons append_Nil append_take_drop_id same_append_eq zip_Cons_Cons zip_append1)

  moreover

  have z2: "zip (u @ True # w) (rev [0..<n]) = zip u ?i1 @ [(True, ?i)] @ zip w ?i2"
    using ii
    by (metis append_Cons append_Nil append_take_drop_id same_append_eq zip_Cons_Cons zip_append1)

  ultimately
  have rf: "rev (filter P1 [0..<n]) = ?F u ?i1 @ ?F v ?i2 "
           "rev (filter P2 [0..<n]) = ?F u ?i1 @ [?i] @ ?F w ?i2 "
    using zip_rev[of "map P1 [0..<n]" "[0..<n]", symmetric]
    using zip_rev[of "map P2 [0..<n]" "[0..<n]", symmetric]
    by (auto simp add: rev_map rev_filter)

  moreover

  have "?F v ?i2 < ?i # ?F w ?i2"
  proof-
    have "length (?F v ?i2) = length (?i # ?F w ?i2)"
      using rf assms
      by (smt add_left_cancel append_Cons append_Nil length_append length_rev)
    hence "?F v ?i2 \<noteq> []"
      by auto
    moreover
    have "\<forall> x \<in> set (?F v ?i2). x < ?i"
      using *
      by (auto simp add: set_zip nth_rev)
    ultimately
    show ?thesis
      by (metis (no_types, opaque_lifting) Cons_less_Cons One_nat_def add.commute add.right_neutral Cons_less_Cons One_nat_def add.commute add.right_neutral add_Suc_right list.set_intros(1) max_list.cases)
  qed
  ultimately
  show ?rhs
    using zip_rev[of "map P1 [0..<n]" "[0..<n]", symmetric]
    using zip_rev[of "map P2 [0..<n]" "[0..<n]", symmetric]
    by (simp add: rev_map rev_filter nth_rev list_less_append)
next
  assume ?rhs
  then obtain u a b v w
    where *: "a < b"  "rev (filter P1 [0..<n]) = u @ a # v" "rev (filter P2 [0..<n]) = u @ b # w"
    using assms
    unfolding list_less_def lexord_def
    by auto (metis append_Cons append_assoc append_eq_append_conv assms length_rev list.discI)

  hence **: "filter P1 [0..<n] = rev (u @ a # v)" "filter P2 [0..<n] = rev (u @ b # w)"
    by (metis rev_rev_ident)+

  have "sorted (filter P1 [0..<n])" "sorted (filter P2 [0..<n])"
       "distinct (filter P1 [0..<n])" "distinct (filter P2 [0..<n])"
    by auto
  hence "sorted (rev (u @ a # v))"  "sorted (rev (u @ b # w))"
        "distinct (rev (u @ a # v))"  "distinct (rev (u @ b # w))"
    using **
    by auto

  have "\<forall> i. i \<in> set u \<longleftrightarrow> b < i \<and> i < n \<and> P1 i"
  proof safe
    fix i
    assume "i \<in> set u"
    thus "b < i"
      using `sorted (rev (u @ b # w))` `distinct (rev (u @ b # w))`
      by (metis distinct_append distinct_rev le_neq_implies_less list.set_intros(1) not_distinct_conv_prefix rev_append set_rev sorted_append)
  next
    fix i
    assume "i \<in> set u"
    hence "i \<in> set (filter P1 [0..<n])"
      using **
      by simp
    thus "i < n" "P1 i"
      by auto
  next
    fix i
    assume "b < i" "i < n" "P1 i"
    hence "i \<in> set (filter P1 [0..<n])"
      by auto
    hence "i \<in> set (rev (u @ a # v))"
      using **
      by simp
    thus "i \<in> set u"
      using `a < b` `b < i` `sorted (rev (u @ a # v))`
      by (auto simp add: sorted_append)
  qed

  moreover

  have "\<forall> i. i \<in> set u \<longleftrightarrow> b < i \<and> i < n \<and> P2 i"
  proof safe
    fix i
    assume "i \<in> set u"
    thus "b < i"
      using `sorted (rev (u @ b # w))` `distinct (rev (u @ b # w))`
      by (metis distinct_append distinct_rev le_neq_implies_less list.set_intros(1) not_distinct_conv_prefix rev_append set_rev sorted_append)
  next
    fix i
    assume "i \<in> set u"
    hence "i \<in> set (filter P2 [0..<n])"
      using **
      by simp
    thus "i < n" "P2 i"
      by auto
  next
    fix i
    assume "b < i" "i < n" "P2 i"
    hence "i \<in> set (filter P2 [0..<n])"
      by auto
    hence "i \<in> set (rev (u @ b # w))"
      using **
      by simp
    thus "i \<in> set u"
      using `b < i` `sorted (rev (u @ b # w))`
      by (auto simp add: sorted_append)
  qed

  ultimately

  have "\<forall> i. b < i \<and> i < n \<longrightarrow> P1 i \<longleftrightarrow> P2 i"
    by auto
  hence "rev (map P1 [b+1..<n]) = rev (map P2 [b+1..<n]) "
    by auto
  moreover
  have "b \<in> set (filter P2 [0..<n])"
    using **
    by simp
  hence "P2 b" "b < n"
    by simp_all

  moreover

  have "b \<notin> set (filter P1 [0..<n])"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    hence "b \<in> set (rev (u @ a # v))"
      using **
      by simp
    thus False
      using `sorted (rev (u @ a # v))` `a < b` `distinct (rev (u @ b # w))`
      by (auto simp add: sorted_append)
  qed
  hence "\<not> P1 b"
    using `b < n`
    by auto

  moreover
  have "[0..<n] = [0..<b] @ [b] @ [b+1..<n]"
    using `b < n`
    by (metis One_nat_def add.right_neutral add_Suc_right append_Cons append_Nil less_imp_add_positive upt_add_eq_append upt_conv_Cons zero_le)
  hence "rev (map P1 [0..<n]) = rev (map P1 [b+1..<n]) @ [P1 b] @ rev (map P1 [0..<b])"
        "rev (map P2 [0..<n]) = rev (map P2 [b+1..<n]) @ [P2 b] @ rev (map P2 [0..<b])"
    by auto
  ultimately
  show ?lhs
    unfolding list_less_def lexord_def
    by fastforce
qed

lemma map_less:
  shows "map f1 I < map f2 I \<longleftrightarrow> (\<exists> i < length I. f1 (I ! i) < f2 (I ! i) \<and> (\<forall> j < i. f1 (I ! j) = f2 (I ! j)))" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  then obtain a b u v w where *: "a < b" "map f1 I = u @ a # v" "map f2 I = u @ b # w"
    unfolding list_less_def lexord_def
    by auto
  let ?i = "length u"
  have "?i < length I"
    using *
    by (metis One_nat_def add_diff_cancel_left' diff_is_0_eq' le_eq_less_or_eq length_append length_map linorder_neqE_nat list.size(4) not_one_le_zero zero_eq_add_iff_both_eq_0)
  moreover
  have "map f1 I ! ?i = a" "map f2 I ! ?i = b"
    using *
    by auto
  hence "f1 (I ! ?i) < f2 (I ! ?i)"
    using `a < b` `?i < length I`
    by simp
  moreover
  have "\<forall> j < ?i. map f1 I ! j = map f2 I ! j"
    using * `?i < length I`
    by (auto simp add: nth_append)
  hence "\<forall> j < ?i. f1 (I ! j) = f2 (I ! j)"
    using `?i < length I`
    by simp
  ultimately
  show ?rhs
    using *
    by (rule_tac x="?i" in exI) auto
next
  assume ?rhs
  then obtain i where
    i: "i<length I" "f1 (I ! i) < f2 (I ! i)" "(\<forall>j<i. f1 (I ! j) = f2 (I ! j))"
    by auto
  hence "take i (map f2 I) =  take i (map f1 I)"
    by (simp add: i(1) less_imp_le less_le_trans nth_take_lemma)
  hence "\<exists>u a b. a < b \<and> (\<exists>v. map f1 I = u @ a # v) \<and> (\<exists>w. map f2 I = u @ b # w)"
    using i
    apply (rule_tac x="take i (map f1 I)" in exI, rule_tac x="f1 (I ! i)" in exI, rule_tac x="f2 (I ! i)" in exI)
    apply auto
    apply (metis id_take_nth_drop length_map nth_map)
    apply (metis id_take_nth_drop length_map nth_map)
    done
  thus ?lhs
    unfolding list_less_def lexord_def
    by auto
qed

end


(*  Title:      HOL/Hahn_Banach/Zorn_Lemma.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>Zorn's Lemma\<close>

theory Zorn_Lemma
imports Main
begin

text \<open>
  Zorn's Lemmas states: if every linear ordered subset of an ordered
  set @{text S} has an upper bound in @{text S}, then there exists a
  maximal element in @{text S}.  In our application, @{text S} is a
  set of sets ordered by set inclusion. Since the union of a chain of
  sets is an upper bound for all elements of the chain, the conditions
  of Zorn's lemma can be modified: if @{text S} is non-empty, it
  suffices to show that for every non-empty chain @{text c} in @{text
  S} the union of @{text c} also lies in @{text S}.
\<close>

theorem Zorn's_Lemma:
  assumes r: "\<And>c. c \<in> chains S \<Longrightarrow> \<exists>x. x \<in> c \<Longrightarrow> \<Union>c \<in> S"
    and aS: "a \<in> S"
  shows "\<exists>y \<in> S. \<forall>z \<in> S. y \<subseteq> z \<longrightarrow> z = y"
proof (rule Zorn_Lemma2)
  show "\<forall>c \<in> chains S. \<exists>y \<in> S. \<forall>z \<in> c. z \<subseteq> y"
  proof
    fix c assume "c \<in> chains S"
    show "\<exists>y \<in> S. \<forall>z \<in> c. z \<subseteq> y"
    proof cases

      txt \<open>If @{text c} is an empty chain, then every element in
        @{text S} is an upper bound of @{text c}.\<close>

      assume "c = {}"
      with aS show ?thesis by fast

      txt \<open>If @{text c} is non-empty, then @{text "\<Union>c"} is an upper
        bound of @{text c}, lying in @{text S}.\<close>

    next
      assume "c \<noteq> {}"
      show ?thesis
      proof
        show "\<forall>z \<in> c. z \<subseteq> \<Union>c" by fast
        show "\<Union>c \<in> S"
        proof (rule r)
          from \<open>c \<noteq> {}\<close> show "\<exists>x. x \<in> c" by fast
          show "c \<in> chains S" by fact
        qed
      qed
    qed
  qed
qed

end


(*  Authors:    Christophe Tabacznyj, Lawrence C. Paulson, Amine Chaieb,
                Thomas M. Rasmussen, Jeremy Avigad, Tobias Nipkow,
                Manuel Eberl

This file deals with properties of primes. Definitions and lemmas are
proved uniformly for the natural numbers and integers.

This file combines and revises a number of prior developments.

The original theories "GCD" and "Primes" were by Christophe Tabacznyj
and Lawrence C. Paulson, based on @{cite davenport92}. They introduced
gcd, lcm, and prime for the natural numbers.

The original theory "IntPrimes" was by Thomas M. Rasmussen, and
extended gcd, lcm, primes to the integers. Amine Chaieb provided
another extension of the notions to the integers, and added a number
of results to "Primes" and "GCD". IntPrimes also defined and developed
the congruence relations on the integers. The notion was extended to
the natural numbers by Chaieb.

Jeremy Avigad combined all of these, made everything uniform for the
natural numbers and the integers, and added a number of new theorems.

Tobias Nipkow cleaned up a lot.

Florian Haftmann and Manuel Eberl put primality and prime factorisation
onto an algebraic foundation and thus generalised these concepts to
other rings, such as polynomials. (see also the Factorial_Ring theory).

There were also previous formalisations of unique factorisation by
Thomas Marthedal Rasmussen, Jeremy Avigad, and David Gray.
*)

section \<open>Primes\<close>

theory Primes
imports "~~/src/HOL/Binomial" Euclidean_Algorithm
begin

(* As a simp or intro rule,

     prime p \<Longrightarrow> p > 0

   wreaks havoc here. When the premise includes \<forall>x \<in># M. prime x, it
   leads to the backchaining

     x > 0
     prime x
     x \<in># M   which is, unfortunately,
     count M x > 0
*)

declare [[coercion int]]
declare [[coercion_enabled]]

lemma prime_elem_nat_iff:
  "prime_elem (n :: nat) \<longleftrightarrow> (1 < n \<and> (\<forall>m. m dvd n \<longrightarrow> m = 1 \<or> m = n))"
proof safe
  assume *: "prime_elem n"
  from * have "n \<noteq> 0" "n \<noteq> 1" by (intro notI, simp del: One_nat_def)+
  thus "n > 1" by (cases n) simp_all
  fix m assume m: "m dvd n" "m \<noteq> n"
  from * \<open>m dvd n\<close> have "n dvd m \<or> is_unit m"
    by (intro irreducibleD' prime_elem_imp_irreducible)
  with m show "m = 1" by (auto dest: dvd_antisym)
next
  assume "n > 1" "\<forall>m. m dvd n \<longrightarrow> m = 1 \<or> m = n"
  thus "prime_elem n"
    by (auto simp: prime_elem_iff_irreducible irreducible_altdef)
qed

lemma prime_nat_iff_prime_elem: "prime (n :: nat) \<longleftrightarrow> prime_elem n"
  by (simp add: prime_def)

lemma prime_nat_iff:
  "prime (n :: nat) \<longleftrightarrow> (1 < n \<and> (\<forall>m. m dvd n \<longrightarrow> m = 1 \<or> m = n))"
  by (simp add: prime_nat_iff_prime_elem prime_elem_nat_iff)

lemma prime_elem_int_nat_transfer: "prime_elem (n::int) \<longleftrightarrow> prime_elem (nat (abs n))"
proof
  assume "prime_elem n"
  thus "prime_elem (nat (abs n))" by (auto simp: prime_elem_def nat_dvd_iff)
next
  assume "prime_elem (nat (abs n))"
  thus "prime_elem n"
    by (auto simp: dvd_int_unfold_dvd_nat prime_elem_def abs_mult nat_mult_distrib)
qed

lemma prime_elem_nat_int_transfer [simp]: "prime_elem (int n) \<longleftrightarrow> prime_elem n"
  by (auto simp: prime_elem_int_nat_transfer)

lemma prime_nat_int_transfer [simp]: "prime (int n) \<longleftrightarrow> prime n"
  by (auto simp: prime_elem_int_nat_transfer prime_def)

lemma prime_int_nat_transfer: "prime (n::int) \<longleftrightarrow> n \<ge> 0 \<and> prime (nat n)"
  by (auto simp: prime_elem_int_nat_transfer prime_def)

lemma prime_int_iff:
  "prime (n::int) \<longleftrightarrow> (1 < n \<and> (\<forall>m. m \<ge> 0 \<and> m dvd n \<longrightarrow> m = 1 \<or> m = n))"
proof (intro iffI conjI allI impI; (elim conjE)?)
  assume *: "prime n"
  hence irred: "irreducible n" by (simp add: prime_elem_imp_irreducible)
  from * have "n \<ge> 0" "n \<noteq> 0" "n \<noteq> 1"
    by (auto simp: prime_def zabs_def not_less split: if_splits)
  thus "n > 1" by presburger
  fix m assume "m dvd n" \<open>m \<ge> 0\<close>
  with irred have "m dvd 1 \<or> n dvd m" by (auto simp: irreducible_altdef)
  with \<open>m dvd n\<close> \<open>m \<ge> 0\<close> \<open>n > 1\<close> show "m = 1 \<or> m = n"
    using associated_iff_dvd[of m n] by auto
next
  assume n: "1 < n" "\<forall>m. m \<ge> 0 \<and> m dvd n \<longrightarrow> m = 1 \<or> m = n"
  hence "nat n > 1" by simp
  moreover have "\<forall>m. m dvd nat n \<longrightarrow> m = 1 \<or> m = nat n"
  proof (intro allI impI)
    fix m assume "m dvd nat n"
    with \<open>n > 1\<close> have "int m dvd n" by (auto simp: int_dvd_iff)
    with n(2) have "int m = 1 \<or> int m = n" by auto
    thus "m = 1 \<or> m = nat n" by auto
  qed
  ultimately show "prime n"
    unfolding prime_int_nat_transfer prime_nat_iff by auto
qed

lemma prime_nat_not_dvd:
  assumes "prime p" "p > n" "n \<noteq> (1::nat)"
  shows   "\<not>n dvd p"
proof
  assume "n dvd p"
  from assms(1) have "irreducible p" by (simp add: prime_elem_imp_irreducible)
  from irreducibleD'[OF this \<open>n dvd p\<close>] \<open>n dvd p\<close> \<open>p > n\<close> assms show False
    by (cases "n = 0") (auto dest!: dvd_imp_le)
qed

lemma prime_int_not_dvd:
  assumes "prime p" "p > n" "n > (1::int)"
  shows   "\<not>n dvd p"
proof
  assume "n dvd p"
  from assms(1) have "irreducible p" by (simp add: prime_elem_imp_irreducible)
  from irreducibleD'[OF this \<open>n dvd p\<close>] \<open>n dvd p\<close> \<open>p > n\<close> assms show False
    by (auto dest!: zdvd_imp_le)
qed

lemma prime_odd_nat: "prime p \<Longrightarrow> p > (2::nat) \<Longrightarrow> odd p"
  by (intro prime_nat_not_dvd) auto

lemma prime_odd_int: "prime p \<Longrightarrow> p > (2::int) \<Longrightarrow> odd p"
  by (intro prime_int_not_dvd) auto

lemma prime_ge_0_int: "prime p \<Longrightarrow> p \<ge> (0::int)"
  unfolding prime_int_iff by auto

lemma prime_gt_0_nat: "prime p \<Longrightarrow> p > (0::nat)"
  unfolding prime_nat_iff by auto

lemma prime_gt_0_int: "prime p \<Longrightarrow> p > (0::int)"
  unfolding prime_int_iff by auto

lemma prime_ge_1_nat: "prime p \<Longrightarrow> p \<ge> (1::nat)"
  unfolding prime_nat_iff by auto

lemma prime_ge_Suc_0_nat: "prime p \<Longrightarrow> p \<ge> Suc 0"
  unfolding prime_nat_iff by auto

lemma prime_ge_1_int: "prime p \<Longrightarrow> p \<ge> (1::int)"
  unfolding prime_int_iff by auto

lemma prime_gt_1_nat: "prime p \<Longrightarrow> p > (1::nat)"
  unfolding prime_nat_iff by auto

lemma prime_gt_Suc_0_nat: "prime p \<Longrightarrow> p > Suc 0"
  unfolding prime_nat_iff by auto

lemma prime_gt_1_int: "prime p \<Longrightarrow> p > (1::int)"
  unfolding prime_int_iff by auto

lemma prime_ge_2_nat: "prime p \<Longrightarrow> p \<ge> (2::nat)"
  unfolding prime_nat_iff by auto

lemma prime_ge_2_int: "prime p \<Longrightarrow> p \<ge> (2::int)"
  unfolding prime_int_iff by auto

lemma prime_int_altdef:
  "prime p = (1 < p \<and> (\<forall>m::int. m \<ge> 0 \<longrightarrow> m dvd p \<longrightarrow>
    m = 1 \<or> m = p))"
  unfolding prime_int_iff by blast

lemma not_prime_eq_prod_nat:
  assumes "m > 1" "\<not>prime (m::nat)"
  shows   "\<exists>n k. n = m * k \<and> 1 < m \<and> m < n \<and> 1 < k \<and> k < n"
  using assms irreducible_altdef[of m]
  by (auto simp: prime_elem_iff_irreducible prime_def irreducible_altdef)

subsubsection \<open>Make prime naively executable\<close>

lemma Suc_0_not_prime_nat [simp]: "~prime (Suc 0)"
  unfolding One_nat_def [symmetric] by (rule not_prime_1)

lemma prime_nat_iff':
  "prime (p :: nat) \<longleftrightarrow> p > 1 \<and> (\<forall>n \<in> {1<..<p}. ~ n dvd p)"
proof safe
  assume "p > 1" and *: "\<forall>n\<in>{1<..<p}. \<not>n dvd p"
  show "prime p" unfolding prime_nat_iff
  proof (intro conjI allI impI)
    fix m assume "m dvd p"
    with \<open>p > 1\<close> have "m \<noteq> 0" by (intro notI) auto
    hence "m \<ge> 1" by simp
    moreover from \<open>m dvd p\<close> and * have "m \<notin> {1<..<p}" by blast
    with \<open>m dvd p\<close> and \<open>p > 1\<close> have "m \<le> 1 \<or> m = p" by (auto dest: dvd_imp_le)
    ultimately show "m = 1 \<or> m = p" by simp
  qed fact+
qed (auto simp: prime_nat_iff)

lemma prime_nat_code [code_unfold]:
  "(prime :: nat \<Rightarrow> bool) = (\<lambda>p. p > 1 \<and> (\<forall>n \<in> {1<..<p}. ~ n dvd p))"
  by (rule ext, rule prime_nat_iff')

lemma prime_int_iff':
  "prime (p :: int) \<longleftrightarrow> p > 1 \<and> (\<forall>n \<in> {1<..<p}. ~ n dvd p)" (is "?lhs = ?rhs")
proof
  assume "?lhs"
  thus "?rhs" by (auto simp: prime_int_nat_transfer dvd_int_unfold_dvd_nat prime_nat_code)
next
  assume "?rhs"
  thus "?lhs" by (auto simp: prime_int_nat_transfer zdvd_int prime_nat_code)
qed

lemma prime_int_code [code_unfold]:
  "(prime :: int \<Rightarrow> bool) = (\<lambda>p. p > 1 \<and> (\<forall>n \<in> {1<..<p}. ~ n dvd p))"
  by (rule ext, rule prime_int_iff')

lemma prime_nat_simp:
    "prime p \<longleftrightarrow> p > 1 \<and> (\<forall>n \<in> set [2..<p]. \<not> n dvd p)"
  by (auto simp add: prime_nat_code)

lemma prime_int_simp:
    "prime (p::int) \<longleftrightarrow> p > 1 \<and> (\<forall>n \<in> {2..<p}. \<not> n dvd p)"
  by (auto simp add: prime_int_code)

lemmas prime_nat_simp_numeral [simp] = prime_nat_simp [of "numeral m"] for m

lemma two_is_prime_nat [simp]: "prime (2::nat)"
  by simp

declare prime_int_nat_transfer[of "numeral m" for m, simp]

text\<open>A bit of regression testing:\<close>

lemma "prime(97::nat)" by simp
lemma "prime(997::nat)" by eval
lemma "prime(97::int)" by simp
lemma "prime(997::int)" by eval

lemma prime_factor_nat:
  "n \<noteq> (1::nat) \<Longrightarrow> \<exists>p. prime p \<and> p dvd n"
  using prime_divisor_exists[of n]
  by (cases "n = 0") (auto intro: exI[of _ "2::nat"])

subsection \<open>Infinitely many primes\<close>

lemma next_prime_bound: "\<exists>p::nat. prime p \<and> n < p \<and> p \<le> fact n + 1"
proof-
  have f1: "fact n + 1 \<noteq> (1::nat)" using fact_ge_1 [of n, where 'a=nat] by arith
  from prime_factor_nat [OF f1]
  obtain p :: nat where "prime p" and "p dvd fact n + 1" by auto
  then have "p \<le> fact n + 1" apply (intro dvd_imp_le) apply auto done
  { assume "p \<le> n"
    from \<open>prime p\<close> have "p \<ge> 1"
      by (cases p, simp_all)
    with \<open>p <= n\<close> have "p dvd fact n"
      by (intro dvd_fact)
    with \<open>p dvd fact n + 1\<close> have "p dvd fact n + 1 - fact n"
      by (rule dvd_diff_nat)
    then have "p dvd 1" by simp
    then have "p <= 1" by auto
    moreover from \<open>prime p\<close> have "p > 1"
      using prime_nat_iff by blast
    ultimately have False by auto}
  then have "n < p" by presburger
  with \<open>prime p\<close> and \<open>p <= fact n + 1\<close> show ?thesis by auto
qed

lemma bigger_prime: "\<exists>p. prime p \<and> p > (n::nat)"
  using next_prime_bound by auto

lemma primes_infinite: "\<not> (finite {(p::nat). prime p})"
proof
  assume "finite {(p::nat). prime p}"
  with Max_ge have "(EX b. (ALL x : {(p::nat). prime p}. x <= b))"
    by auto
  then obtain b where "ALL (x::nat). prime x \<longrightarrow> x <= b"
    by auto
  with bigger_prime [of b] show False
    by auto
qed

subsection\<open>Powers of Primes\<close>

text\<open>Versions for type nat only\<close>

lemma prime_product:
  fixes p::nat
  assumes "prime (p * q)"
  shows "p = 1 \<or> q = 1"
proof -
  from assms have
    "1 < p * q" and P: "\<And>m. m dvd p * q \<Longrightarrow> m = 1 \<or> m = p * q"
    unfolding prime_nat_iff by auto
  from \<open>1 < p * q\<close> have "p \<noteq> 0" by (cases p) auto
  then have Q: "p = p * q \<longleftrightarrow> q = 1" by auto
  have "p dvd p * q" by simp
  then have "p = 1 \<or> p = p * q" by (rule P)
  then show ?thesis by (simp add: Q)
qed

(* TODO: Generalise? *)
lemma prime_power_mult_nat:
  fixes p::nat
  assumes p: "prime p" and xy: "x * y = p ^ k"
  shows "\<exists>i j. x = p ^i \<and> y = p^ j"
using xy
proof(induct k arbitrary: x y)
  case 0 thus ?case apply simp by (rule exI[where x="0"], simp)
next
  case (Suc k x y)
  from Suc.prems have pxy: "p dvd x*y" by auto
  from prime_dvd_multD [OF p pxy] have pxyc: "p dvd x \<or> p dvd y" .
  from p have p0: "p \<noteq> 0" by - (rule ccontr, simp)
  {assume px: "p dvd x"
    then obtain d where d: "x = p*d" unfolding dvd_def by blast
    from Suc.prems d  have "p*d*y = p^Suc k" by simp
    hence th: "d*y = p^k" using p0 by simp
    from Suc.hyps[OF th] obtain i j where ij: "d = p^i" "y = p^j" by blast
    with d have "x = p^Suc i" by simp
    with ij(2) have ?case by blast}
  moreover
  {assume px: "p dvd y"
    then obtain d where d: "y = p*d" unfolding dvd_def by blast
    from Suc.prems d  have "p*d*x = p^Suc k" by (simp add: mult.commute)
    hence th: "d*x = p^k" using p0 by simp
    from Suc.hyps[OF th] obtain i j where ij: "d = p^i" "x = p^j" by blast
    with d have "y = p^Suc i" by simp
    with ij(2) have ?case by blast}
  ultimately show ?case  using pxyc by blast
qed

lemma prime_power_exp_nat:
  fixes p::nat
  assumes p: "prime p" and n: "n \<noteq> 0"
    and xn: "x^n = p^k" shows "\<exists>i. x = p^i"
  using n xn
proof(induct n arbitrary: k)
  case 0 thus ?case by simp
next
  case (Suc n k) hence th: "x*x^n = p^k" by simp
  {assume "n = 0" with Suc have ?case by simp (rule exI[where x="k"], simp)}
  moreover
  {assume n: "n \<noteq> 0"
    from prime_power_mult_nat[OF p th]
    obtain i j where ij: "x = p^i" "x^n = p^j"by blast
    from Suc.hyps[OF n ij(2)] have ?case .}
  ultimately show ?case by blast
qed

lemma divides_primepow_nat:
  fixes p::nat
  assumes p: "prime p"
  shows "d dvd p^k \<longleftrightarrow> (\<exists> i. i \<le> k \<and> d = p ^i)"
proof
  assume H: "d dvd p^k" then obtain e where e: "d*e = p^k"
    unfolding dvd_def  apply (auto simp add: mult.commute) by blast
  from prime_power_mult_nat[OF p e] obtain i j where ij: "d = p^i" "e=p^j" by blast
  from e ij have "p^(i + j) = p^k" by (simp add: power_add)
  hence "i + j = k" using p prime_gt_1_nat power_inject_exp[of p "i+j" k] by simp
  hence "i \<le> k" by arith
  with ij(1) show "\<exists>i\<le>k. d = p ^ i" by blast
next
  {fix i assume H: "i \<le> k" "d = p^i"
    then obtain j where j: "k = i + j"
      by (metis le_add_diff_inverse)
    hence "p^k = p^j*d" using H(2) by (simp add: power_add)
    hence "d dvd p^k" unfolding dvd_def by auto}
  thus "\<exists>i\<le>k. d = p ^ i \<Longrightarrow> d dvd p ^ k" by blast
qed

subsection \<open>Chinese Remainder Theorem Variants\<close>

lemma bezout_gcd_nat:
  fixes a::nat shows "\<exists>x y. a * x - b * y = gcd a b \<or> b * x - a * y = gcd a b"
  using bezout_nat[of a b]
by (metis bezout_nat diff_add_inverse gcd_add_mult gcd.commute
  gcd_nat.right_neutral mult_0)

lemma gcd_bezout_sum_nat:
  fixes a::nat
  assumes "a * x + b * y = d"
  shows "gcd a b dvd d"
proof-
  let ?g = "gcd a b"
    have dv: "?g dvd a*x" "?g dvd b * y"
      by simp_all
    from dvd_add[OF dv] assms
    show ?thesis by auto
qed

text \<open>A binary form of the Chinese Remainder Theorem.\<close>

(* TODO: Generalise? *)
lemma chinese_remainder:
  fixes a::nat  assumes ab: "coprime a b" and a: "a \<noteq> 0" and b: "b \<noteq> 0"
  shows "\<exists>x q1 q2. x = u + q1 * a \<and> x = v + q2 * b"
proof-
  from bezout_add_strong_nat[OF a, of b] bezout_add_strong_nat[OF b, of a]
  obtain d1 x1 y1 d2 x2 y2 where dxy1: "d1 dvd a" "d1 dvd b" "a * x1 = b * y1 + d1"
    and dxy2: "d2 dvd b" "d2 dvd a" "b * x2 = a * y2 + d2" by blast
  then have d12: "d1 = 1" "d2 =1"
    by (metis ab coprime_nat)+
  let ?x = "v * a * x1 + u * b * x2"
  let ?q1 = "v * x1 + u * y2"
  let ?q2 = "v * y1 + u * x2"
  from dxy2(3)[simplified d12] dxy1(3)[simplified d12]
  have "?x = u + ?q1 * a" "?x = v + ?q2 * b"
    by algebra+
  thus ?thesis by blast
qed

text \<open>Primality\<close>

lemma coprime_bezout_strong:
  fixes a::nat assumes "coprime a b"  "b \<noteq> 1"
  shows "\<exists>x y. a * x = b * y + 1"
by (metis assms bezout_nat gcd_nat.left_neutral)

lemma bezout_prime:
  assumes p: "prime p" and pa: "\<not> p dvd a"
  shows "\<exists>x y. a*x = Suc (p*y)"
proof -
  have ap: "coprime a p"
    by (metis gcd.commute p pa prime_imp_coprime)
  moreover from p have "p \<noteq> 1" by auto
  ultimately have "\<exists>x y. a * x = p * y + 1"
    by (rule coprime_bezout_strong)
  then show ?thesis by simp
qed
(* END TODO *)

subsection \<open>Multiplicity and primality for natural numbers and integers\<close>

lemma prime_factors_gt_0_nat:
  "p \<in> prime_factors x \<Longrightarrow> p > (0::nat)"
  by (simp add: in_prime_factors_imp_prime prime_gt_0_nat)

lemma prime_factors_gt_0_int:
  "p \<in> prime_factors x \<Longrightarrow> p > (0::int)"
  by (simp add: in_prime_factors_imp_prime prime_gt_0_int)

lemma prime_factors_ge_0_int [elim]: (* FIXME !? *)
  fixes n :: int
  shows "p \<in> prime_factors n \<Longrightarrow> p \<ge> 0"
  by (drule prime_factors_gt_0_int) simp

lemma prod_mset_prime_factorization_int:
  fixes n :: int
  assumes "n > 0"
  shows   "prod_mset (prime_factorization n) = n"
  using assms by (simp add: prod_mset_prime_factorization)

lemma prime_factorization_exists_nat:
  "n > 0 \<Longrightarrow> (\<exists>M. (\<forall>p::nat \<in> set_mset M. prime p) \<and> n = (\<Prod>i \<in># M. i))"
  using prime_factorization_exists[of n] by (auto simp: prime_def)

lemma prod_mset_prime_factorization_nat [simp]:
  "(n::nat) > 0 \<Longrightarrow> prod_mset (prime_factorization n) = n"
  by (subst prod_mset_prime_factorization) simp_all

lemma prime_factorization_nat:
    "n > (0::nat) \<Longrightarrow> n = (\<Prod>p \<in> prime_factors n. p ^ multiplicity p n)"
  by (simp add: prod_prime_factors)

lemma prime_factorization_int:
    "n > (0::int) \<Longrightarrow> n = (\<Prod>p \<in> prime_factors n. p ^ multiplicity p n)"
  by (simp add: prod_prime_factors)

lemma prime_factorization_unique_nat:
  fixes f :: "nat \<Rightarrow> _"
  assumes S_eq: "S = {p. 0 < f p}"
    and "finite S"
    and S: "\<forall>p\<in>S. prime p" "n = (\<Prod>p\<in>S. p ^ f p)"
  shows "S = prime_factors n \<and> (\<forall>p. prime p \<longrightarrow> f p = multiplicity p n)"
  using assms by (intro prime_factorization_unique'') auto

lemma prime_factorization_unique_int:
  fixes f :: "int \<Rightarrow> _"
  assumes S_eq: "S = {p. 0 < f p}"
    and "finite S"
    and S: "\<forall>p\<in>S. prime p" "abs n = (\<Prod>p\<in>S. p ^ f p)"
  shows "S = prime_factors n \<and> (\<forall>p. prime p \<longrightarrow> f p = multiplicity p n)"
  using assms by (intro prime_factorization_unique'') auto

lemma prime_factors_characterization_nat:
  "S = {p. 0 < f (p::nat)} \<Longrightarrow>
    finite S \<Longrightarrow> \<forall>p\<in>S. prime p \<Longrightarrow> n = (\<Prod>p\<in>S. p ^ f p) \<Longrightarrow> prime_factors n = S"
  by (rule prime_factorization_unique_nat [THEN conjunct1, symmetric])

lemma prime_factors_characterization'_nat:
  "finite {p. 0 < f (p::nat)} \<Longrightarrow>
    (\<forall>p. 0 < f p \<longrightarrow> prime p) \<Longrightarrow>
      prime_factors (\<Prod>p | 0 < f p. p ^ f p) = {p. 0 < f p}"
  by (rule prime_factors_characterization_nat) auto

lemma prime_factors_characterization_int:
  "S = {p. 0 < f (p::int)} \<Longrightarrow> finite S \<Longrightarrow>
    \<forall>p\<in>S. prime p \<Longrightarrow> abs n = (\<Prod>p\<in>S. p ^ f p) \<Longrightarrow> prime_factors n = S"
  by (rule prime_factorization_unique_int [THEN conjunct1, symmetric])

(* TODO Move *)
lemma abs_prod: "abs (prod f A :: 'a :: linordered_idom) = prod (\<lambda>x. abs (f x)) A"
  by (cases "finite A", induction A rule: finite_induct) (simp_all add: abs_mult)

lemma primes_characterization'_int [rule_format]:
  "finite {p. p \<ge> 0 \<and> 0 < f (p::int)} \<Longrightarrow> \<forall>p. 0 < f p \<longrightarrow> prime p \<Longrightarrow>
      prime_factors (\<Prod>p | p \<ge> 0 \<and> 0 < f p. p ^ f p) = {p. p \<ge> 0 \<and> 0 < f p}"
  by (rule prime_factors_characterization_int) (auto simp: abs_prod prime_ge_0_int)

lemma multiplicity_characterization_nat:
  "S = {p. 0 < f (p::nat)} \<Longrightarrow> finite S \<Longrightarrow> \<forall>p\<in>S. prime p \<Longrightarrow> prime p \<Longrightarrow>
    n = (\<Prod>p\<in>S. p ^ f p) \<Longrightarrow> multiplicity p n = f p"
  by (frule prime_factorization_unique_nat [of S f n, THEN conjunct2, rule_format, symmetric]) auto

lemma multiplicity_characterization'_nat: "finite {p. 0 < f (p::nat)} \<longrightarrow>
    (\<forall>p. 0 < f p \<longrightarrow> prime p) \<longrightarrow> prime p \<longrightarrow>
      multiplicity p (\<Prod>p | 0 < f p. p ^ f p) = f p"
  by (intro impI, rule multiplicity_characterization_nat) auto

lemma multiplicity_characterization_int: "S = {p. 0 < f (p::int)} \<Longrightarrow>
    finite S \<Longrightarrow> \<forall>p\<in>S. prime p \<Longrightarrow> prime p \<Longrightarrow> n = (\<Prod>p\<in>S. p ^ f p) \<Longrightarrow> multiplicity p n = f p"
  by (frule prime_factorization_unique_int [of S f n, THEN conjunct2, rule_format, symmetric])
     (auto simp: abs_prod power_abs prime_ge_0_int intro!: prod.cong)

lemma multiplicity_characterization'_int [rule_format]:
  "finite {p. p \<ge> 0 \<and> 0 < f (p::int)} \<Longrightarrow>
    (\<forall>p. 0 < f p \<longrightarrow> prime p) \<Longrightarrow> prime p \<Longrightarrow>
      multiplicity p (\<Prod>p | p \<ge> 0 \<and> 0 < f p. p ^ f p) = f p"
  by (rule multiplicity_characterization_int) (auto simp: prime_ge_0_int)

lemma multiplicity_one_nat [simp]: "multiplicity p (Suc 0) = 0"
  unfolding One_nat_def [symmetric] by (rule multiplicity_one)

lemma multiplicity_eq_nat:
  fixes x and y::nat
  assumes "x > 0" "y > 0" "\<And>p. prime p \<Longrightarrow> multiplicity p x = multiplicity p y"
  shows "x = y"
  using multiplicity_eq_imp_eq[of x y] assms by simp

lemma multiplicity_eq_int:
  fixes x y :: int
  assumes "x > 0" "y > 0" "\<And>p. prime p \<Longrightarrow> multiplicity p x = multiplicity p y"
  shows "x = y"
  using multiplicity_eq_imp_eq[of x y] assms by simp

lemma multiplicity_prod_prime_powers:
  assumes "finite S" "\<And>x. x \<in> S \<Longrightarrow> prime x" "prime p"
  shows   "multiplicity p (\<Prod>p \<in> S. p ^ f p) = (if p \<in> S then f p else 0)"
proof -
  define g where "g = (\<lambda>x. if x \<in> S then f x else 0)"
  define A where "A = Abs_multiset g"
  have "{x. g x > 0} \<subseteq> S" by (auto simp: g_def)
  from finite_subset[OF this assms(1)] have [simp]: "g :  multiset"
    by (simp add: multiset_def)
  from assms have count_A: "count A x = g x" for x unfolding A_def
    by simp
  have set_mset_A: "set_mset A = {x\<in>S. f x > 0}"
    unfolding set_mset_def count_A by (auto simp: g_def)
  with assms have prime: "prime x" if "x \<in># A" for x using that by auto
  from set_mset_A assms have "(\<Prod>p \<in> S. p ^ f p) = (\<Prod>p \<in> S. p ^ g p) "
    by (intro prod.cong) (auto simp: g_def)
  also from set_mset_A assms have "\<dots> = (\<Prod>p \<in> set_mset A. p ^ g p)"
    by (intro prod.mono_neutral_right) (auto simp: g_def set_mset_A)
  also have "\<dots> = prod_mset A"
    by (auto simp: prod_mset_multiplicity count_A set_mset_A intro!: prod.cong)
  also from assms have "multiplicity p \<dots> = sum_mset (image_mset (multiplicity p) A)"
    by (subst prime_elem_multiplicity_prod_mset_distrib) (auto dest: prime)
  also from assms have "image_mset (multiplicity p) A = image_mset (\<lambda>x. if x = p then 1 else 0) A"
    by (intro image_mset_cong) (auto simp: prime_multiplicity_other dest: prime)
  also have "sum_mset \<dots> = (if p \<in> S then f p else 0)" by (simp add: sum_mset_delta count_A g_def)
  finally show ?thesis .
qed

lemma prime_factorization_prod_mset:
  assumes "0 \<notin># A"
  shows "prime_factorization (prod_mset A) = \<Union>#(image_mset prime_factorization A)"
  using assms by (induct A) (auto simp add: prime_factorization_mult)

lemma prime_factors_prod:
  assumes "finite A" and "0 \<notin> f ` A"
  shows "prime_factors (prod f A) = UNION A (prime_factors \<circ> f)"
  using assms by (simp add: prod_unfold_prod_mset prime_factorization_prod_mset)

lemma prime_factors_fact:
  "prime_factors (fact n) = {p \<in> {2..n}. prime p}" (is "?M = ?N")
proof (rule set_eqI)
  fix p
  { fix m :: nat
    assume "p \<in> prime_factors m"
    then have "prime p" and "p dvd m" by auto
    moreover assume "m > 0"
    ultimately have "2 \<le> p" and "p \<le> m"
      by (auto intro: prime_ge_2_nat dest: dvd_imp_le)
    moreover assume "m \<le> n"
    ultimately have "2 \<le> p" and "p \<le> n"
      by (auto intro: order_trans)
  } note * = this
  show "p \<in> ?M \<longleftrightarrow> p \<in> ?N"
    by (auto simp add: fact_prod prime_factors_prod Suc_le_eq dest!: prime_prime_factors intro: *)
qed

lemma prime_dvd_fact_iff:
  assumes "prime p"
  shows "p dvd fact n \<longleftrightarrow> p \<le> n"
  using assms
  by (auto simp add: prime_factorization_subset_iff_dvd [symmetric]
    prime_factorization_prime prime_factors_fact prime_ge_2_nat)

(* TODO Legacy names *)
lemmas prime_imp_coprime_nat = prime_imp_coprime[where ?'a = nat]
lemmas prime_imp_coprime_int = prime_imp_coprime[where ?'a = int]
lemmas prime_dvd_mult_nat = prime_dvd_mult_iff[where ?'a = nat]
lemmas prime_dvd_mult_int = prime_dvd_mult_iff[where ?'a = int]
lemmas prime_dvd_mult_eq_nat = prime_dvd_mult_iff[where ?'a = nat]
lemmas prime_dvd_mult_eq_int = prime_dvd_mult_iff[where ?'a = int]
lemmas prime_dvd_power_nat = prime_dvd_power[where ?'a = nat]
lemmas prime_dvd_power_int = prime_dvd_power[where ?'a = int]
lemmas prime_dvd_power_nat_iff = prime_dvd_power_iff[where ?'a = nat]
lemmas prime_dvd_power_int_iff = prime_dvd_power_iff[where ?'a = int]
lemmas prime_imp_power_coprime_nat = prime_imp_power_coprime[where ?'a = nat]
lemmas prime_imp_power_coprime_int = prime_imp_power_coprime[where ?'a = int]
lemmas primes_coprime_nat = primes_coprime[where ?'a = nat]
lemmas primes_coprime_int = primes_coprime[where ?'a = nat]
lemmas prime_divprod_pow_nat = prime_elem_divprod_pow[where ?'a = nat]
lemmas prime_exp = prime_elem_power_iff[where ?'a = nat]

end


theory Refinement imports Main
begin
  section\<open>Monotonic Predicate Transformers\<close>
text\<open>
  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.
\<close>

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

  subsection\<open>Basic predicate transformers\<close>

  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::{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\<open>Conjunctive predicate transformers\<close>

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

  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 image_def cong: INF_cong_simp, 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 x\<in>Q. 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 x\<in>Q. p \<sqinter> x) \<le> p"
        by (simp only: image_def)
   next
      fix Q :: "'a set"
      show "(INF x\<in>Q. 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 x\<in>Q. p \<sqinter> x) \<le> x"
            by (simp only: image_def)
       qed
   qed

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

  lemma sconjunctive_INF_simp: "x \<in> X \<Longrightarrow> sconjunctive S \<Longrightarrow> S (Inf (Q ` X)) = Inf (S ` (Q ` X))"
    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) = Inf (S' ` X)"
        by (rule_tac x = a in sconjunctive_simp, auto)
      also have B: "S (Inf (S' ` X)) = Inf (S ` (S' ` X))"
        by (rule_tac x = "S' a" in sconjunctive_simp, auto)
      finally show "(S o S') (Inf X) = Inf ((S \<circ> S') ` X)" by (simp add: image_comp)
    qed

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

  lemma conjunctive_simp: "conjunctive S \<Longrightarrow>  S (Inf Q) = Inf (S ` Q)"
    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)
      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\<open>Fusion of predicate transformers\<close>

  text\<open>
  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$.
\<close>

  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