section \<open>Separation Algebra\<close>

text \<open>In this section, we formalize the concept of a separation algebra~\<^cite>\<open>"Calcagno2007" and "Dockins2009"\<close>, on which our package logic is based.\<close>

theory SepAlgebra
  imports Main
begin

type_synonym 'a property = "'a \<Rightarrow> bool"

locale sep_algebra =

  fixes plus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a option" (infixl "\<oplus>" 63)

  fixes core :: "'a \<Rightarrow> 'a" (" |_| ")
  (* Largest duplicable part of a state *)

  assumes commutative: "a \<oplus> b = b \<oplus> a"
      and asso1: "a \<oplus> b = Some ab \<and> b \<oplus> c = Some bc \<Longrightarrow> ab \<oplus> c = a \<oplus> bc"
      and asso2: "a \<oplus> b = Some ab \<and> b \<oplus> c = None \<Longrightarrow> ab \<oplus> c = None"

(* The core of x is the max of { p | pure p \<and> x \<ge> p} *)
      and core_is_smaller: "Some x = x \<oplus> |x|"
      and core_is_pure: "Some |x| = |x| \<oplus> |x|"
      and core_max: "Some x = x \<oplus> c \<Longrightarrow> (\<exists>r. Some |x| = c \<oplus> r)"
      and core_sum: "Some c = a \<oplus> b \<Longrightarrow> Some |c| = |a| \<oplus> |b|"

      and positivity: "a \<oplus> b = Some c \<Longrightarrow> Some c = c \<oplus> c \<Longrightarrow> Some a = a \<oplus> a"
      and cancellative: "Some a = b \<oplus> x \<Longrightarrow> Some a = b \<oplus> y \<Longrightarrow> |x| = |y| \<Longrightarrow> x = y"

begin

lemma asso3:
  assumes "a \<oplus> b = None"
      and "b \<oplus> c = Some bc"
    shows "a \<oplus> bc = None"
  by (metis assms(1) assms(2) sep_algebra.asso2 sep_algebra.commutative sep_algebra_axioms)

subsection  \<open>Definitions\<close>

definition defined :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "##" 62) where
  "a ## b \<longleftrightarrow> a \<oplus> b \<noteq> None"

definition greater :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "\<succeq>" 50) where
  "a \<succeq> b \<longleftrightarrow> (\<exists>c. Some a = b \<oplus> c)"

definition pure :: "'a \<Rightarrow> bool" where
  "pure a \<longleftrightarrow> Some a = a \<oplus> a"

definition minus :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<ominus>" 63)
  where "b \<ominus> a = (THE_default b (\<lambda>x. Some b = a \<oplus> x \<and> x \<succeq> |b| ))"

definition add_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" (infixl "\<otimes>" 60) where
  "A \<otimes> B = { \<phi> | \<phi> a b. a \<in> A \<and> b \<in> B \<and> Some \<phi> = a \<oplus> b }"

definition greater_set :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "\<ggreater>" 50) where
  "A \<ggreater> B \<longleftrightarrow> (\<forall>a \<in> A. \<exists>b \<in> B. a \<succeq> b)"

definition up_closed :: "'a set \<Rightarrow> bool" where
  "up_closed A \<longleftrightarrow> (\<forall>\<phi>'. (\<exists>\<phi> \<in> A. \<phi>' \<succeq> \<phi>) \<longrightarrow> \<phi>' \<in> A)"

definition equiv :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" (infixl "\<sim>" 40) where
  "A \<sim> B \<longleftrightarrow> A \<ggreater> B \<and> B \<ggreater> A"

definition setify :: "'a property \<Rightarrow> ('a set \<Rightarrow> bool)" where
  "setify P A \<longleftrightarrow> (\<forall>x \<in> A. P x)"

definition mono_prop :: "'a property \<Rightarrow> bool" where
  "mono_prop P \<longleftrightarrow> (\<forall>x y. y \<succeq> x \<and> P x \<longrightarrow> P y)"

definition under :: "'a set \<Rightarrow> 'a \<Rightarrow> 'a set" where
  "under A \<omega> = { \<omega>' | \<omega>'. \<omega>' \<in> A \<and> \<omega> \<succeq> \<omega>'}"

definition max_projection_prop :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> bool" where
  "max_projection_prop P f \<longleftrightarrow> (\<forall>x. x \<succeq> f x \<and> P (f x) \<and>
  (\<forall>p. P p \<and> x \<succeq> p \<longrightarrow> f x \<succeq> p))"

inductive multi_plus :: "'a list \<Rightarrow> 'a \<Rightarrow> bool" where
  MPSingle: "multi_plus [a] a"
| MPConcat: "\<lbrakk> length la > 0 ; length lb > 0 ; multi_plus la a ; multi_plus lb b ; Some \<omega> = a \<oplus> b \<rbrakk> \<Longrightarrow> multi_plus (la @ lb)  \<omega>"

fun splus :: "'a option \<Rightarrow> 'a option \<Rightarrow> 'a option" where
  "splus None _ = None"
| "splus _ None = None"
| "splus (Some a) (Some b) = a \<oplus> b"

subsection \<open>First lemmata\<close>

lemma greater_equiv:
  "a \<succeq> b \<longleftrightarrow> (\<exists>c. Some a = c \<oplus> b)"
  using commutative greater_def by auto

lemma smaller_compatible:
  assumes "a' ## b"
      and "a' \<succeq> a"
    shows "a ## b"
  by (metis (full_types) assms(1) assms(2) asso3 commutative defined_def greater_def)

lemma bigger_sum_smaller:
  assumes "Some c = a \<oplus> b"
      and "a \<succeq> a'"
    shows "\<exists>b'. b' \<succeq> b \<and> Some c = a' \<oplus> b'"
proof -
  obtain r where "Some a = a' \<oplus> r"
    using assms(2) greater_def by auto
  then obtain br where "Some br = r \<oplus> b"
    by (metis assms(1) asso2 domD domIff option.discI)
  then have "Some c = a' \<oplus> br"
    by (metis \<open>Some a = a' \<oplus> r\<close> assms(1) asso1)
  then show ?thesis
    using \<open>Some br = r \<oplus> b\<close> commutative greater_def by force
qed

subsubsection \<open>splus\<close>

lemma splus_develop:
  assumes "Some a = b \<oplus> c"
  shows "a \<oplus> d = splus (splus (Some b) (Some c)) (Some d)"
  by (metis assms splus.simps(3))

lemma splus_comm:
  "splus a b = splus b a"
  apply (cases a)
   apply (cases b)
    apply simp_all
  apply (cases b)
  by (simp_all add: commutative)

lemma splus_asso:
  "splus (splus a b) c = splus a (splus b c)"
proof (cases a)
  case None
  then show ?thesis
    by simp
next
  case (Some a')
  then have "a = Some a'" by simp
  then show ?thesis
  proof (cases b)
    case None
    then show ?thesis by (simp add: Some)
  next
    case (Some b')
    then have "b = Some b'" by simp
    then show ?thesis
    proof (cases c)
      case None
      then show ?thesis by (simp add: splus_comm)
    next
      case (Some c')
      then have "c = Some c'" by simp
      then show ?thesis
      proof (cases "a' \<oplus> b'")
        case None
        then have "a' \<oplus> b' = None" by simp
        then show ?thesis
        proof (cases "b' \<oplus> c'")
          case None
          then show ?thesis
            by (simp add: Some \<open>a = Some a'\<close> \<open>a' \<oplus> b' = None\<close> \<open>b = Some b'\<close>)
        next
          case (Some bc)
          then show ?thesis
            by (metis (full_types) None \<open>a = Some a'\<close> \<open>b = Some b'\<close> \<open>c = Some c'\<close> sep_algebra.asso2 sep_algebra_axioms splus.simps(2) splus.simps(3) splus_comm)
        qed
      next
        case (Some ab)
        then have "Some ab = a' \<oplus> b'" by simp
        then show ?thesis
        proof (cases "b' \<oplus> c'")
          case None
          then show ?thesis
            by (metis Some \<open>a = Some a'\<close> \<open>b = Some b'\<close> \<open>c = Some c'\<close> asso2 splus.simps(2) splus.simps(3))
        next
          case (Some bc)
          then show ?thesis
            by (metis \<open>Some ab = a' \<oplus> b'\<close> \<open>a = Some a'\<close> \<open>b = Some b'\<close> \<open>c = Some c'\<close> sep_algebra.asso1 sep_algebra_axioms splus.simps(3))
        qed
      qed
    qed
  qed
qed

subsubsection \<open>Pure\<close>

(* Maybe need more *)
lemma pure_stable:
  assumes "pure a"
      and "pure b"
      and "Some c = a \<oplus> b"
    shows "pure c"
  by (metis assms asso1 commutative pure_def)

(* Specific to pure *)
lemma pure_smaller:
  assumes "pure a"
      and "a \<succeq> b"
    shows "pure b"
  by (metis assms greater_def positivity pure_def)

subsection \<open>Succ is an order\<close>

lemma succ_antisym:
  assumes "a \<succeq> b"
      and "b \<succeq> a"
    shows "a = b"
proof -
  obtain ra where "Some a = b \<oplus> ra"
    using assms(1) greater_def by auto
  obtain rb where "Some b = a \<oplus> rb"
    using assms(2) greater_def by auto
  then have "Some a = splus (Some a) (splus (Some ra) (Some rb))"
  proof -
    have "Some b = splus (Some a) (Some rb)"
      by (simp add: \<open>Some b = a \<oplus> rb\<close>)
    then show ?thesis
      by (metis (full_types) \<open>Some a = b \<oplus> ra\<close> sep_algebra.splus.simps(3) sep_algebra_axioms splus_asso splus_comm)
  qed
  moreover have "Some b = splus (Some b) (splus (Some ra) (Some rb))"
    by (metis \<open>Some a = b \<oplus> ra\<close> \<open>Some b = a \<oplus> rb\<close> sep_algebra.splus.simps(3) sep_algebra_axioms splus_asso)
  moreover have "pure ra \<and> pure rb"
  proof -
    obtain rab where "Some rab = ra \<oplus> rb"
      by (metis calculation(2) splus.elims splus.simps(3))
    then have "|a| \<succeq> rab"
      by (metis calculation(1) core_max greater_def splus.simps(3))
    then have "pure rab"
      using core_is_pure pure_def pure_smaller by blast
    moreover have "rab \<succeq> ra \<and> rab \<succeq> rb"
      using \<open>Some rab = ra \<oplus> rb\<close> greater_def greater_equiv by blast
    ultimately have "pure ra" using pure_smaller
      by blast
    moreover have "pure rb"
      using \<open>pure rab\<close> \<open>rab \<succeq> ra \<and> rab \<succeq> rb\<close> pure_smaller by blast
    ultimately show ?thesis
      by blast
  qed
  ultimately show ?thesis
    by (metis \<open>Some b = a \<oplus> rb\<close> option.inject pure_def sep_algebra.splus.simps(3) sep_algebra_axioms splus_asso)
qed

lemma succ_trans:
  assumes "a \<succeq> b"
      and "b \<succeq> c"
    shows "a \<succeq> c"
  using assms(1) assms(2) bigger_sum_smaller greater_def by blast

lemma succ_refl:
  "a \<succeq> a"
  using core_is_smaller greater_def by blast

subsection \<open>Core (pure) and stabilize (stable)\<close>

lemma max_projection_propI:
  assumes "\<And>x. x \<succeq> f x"
      and "\<And>x. P (f x)"
      and "\<And>x p. P p \<and> x \<succeq> p \<Longrightarrow> f x \<succeq> p"
    shows "max_projection_prop P f"
  by (simp add: assms(1) assms(2) assms(3) max_projection_prop_def)

lemma max_projection_propE:
  assumes "max_projection_prop P f"
    shows "\<And>x. x \<succeq> f x"
      and "\<And>x. P (f x)"
      and "\<And>x p. P p \<and> x \<succeq> p \<Longrightarrow> f x \<succeq> p"
  using assms max_projection_prop_def by auto

lemma max_projection_prop_pure_core:
  "max_projection_prop pure core"
proof (rule max_projection_propI)
  fix x
  show "x \<succeq> |x|"
    using core_is_smaller greater_equiv by blast
  show "pure |x|"
    by (simp add: core_is_pure pure_def)
  show "\<And>p. pure p \<and> x \<succeq> p \<Longrightarrow> |x| \<succeq> p"
  proof -
    fix p assume "pure p \<and> x \<succeq> p"
    then obtain r where "Some x = p \<oplus> r"
      using greater_def by blast
    then show "|x| \<succeq> p"
      by (metis \<open>pure p \<and> x \<succeq> p\<close> asso1 commutative core_max greater_equiv pure_def)
  qed
qed

lemma mpp_smaller:
  assumes "max_projection_prop P f"
  shows "x \<succeq> f x"
  using assms max_projection_propE(1) by auto

lemma mpp_compatible:
  assumes "max_projection_prop P f"
      and "a ## b"
    shows "f a ## f b"
  by (metis (mono_tags, opaque_lifting) assms(1) assms(2) commutative defined_def max_projection_prop_def smaller_compatible)

lemma mpp_prop:
  assumes "max_projection_prop P f"
  shows "P (f x)"
  by (simp add: assms max_projection_propE(2))

lemma mppI:
  assumes "max_projection_prop P f"
      and "a \<succeq> x"
      and "P x"
      and "x \<succeq> f a"
    shows "x = f a"
proof -
  have "f a \<succeq> x"
    using assms max_projection_propE(3) by auto
  then show ?thesis
    by (simp add: assms(4) succ_antisym)
qed

lemma mpp_invo:
  assumes "max_projection_prop P f"
  shows "f (f x) = f x"
  using assms max_projection_prop_def succ_antisym by auto

lemma mpp_mono:
  assumes "max_projection_prop P f"
      and "a \<succeq> b"
    shows "f a \<succeq> f b"
  by (metis assms max_projection_prop_def succ_trans)

subsection \<open>Subtraction\<close>

lemma addition_bigger:
  assumes "a' \<succeq> a"
      and "Some x' = a' \<oplus> b"
      and "Some x = a \<oplus> b"
    shows "x' \<succeq> x"
  by (metis assms asso1 bigger_sum_smaller greater_def)

lemma smaller_than_core:
  assumes "y \<succeq> x"
      and "Some z = x \<oplus> |y|"
    shows "|z| = |y|"
proof -
  have "Some |z| = |x| \<oplus> |y|"
    using assms(2) core_sum max_projection_prop_pure_core mpp_invo by fastforce
  then have "Some |z| = |x| \<oplus> |y|"
    by simp
  moreover have "|z| \<succeq> |y|"
    using calculation greater_equiv by blast
  ultimately show ?thesis
    by (meson addition_bigger assms(1) assms(2) core_is_smaller core_sum greater_def succ_antisym)
qed

lemma extract_core:
  assumes "Some b = a \<oplus> x \<and> x \<succeq> |b|"
  shows "|x| = |b|"
proof -
  obtain r where "Some x = r \<oplus> |b|"
    using assms greater_equiv by auto
  show ?thesis
  proof (rule smaller_than_core)
    show "Some x = r \<oplus> |b|"
      using \<open>Some x = r \<oplus> |b|\<close> by auto
    show "b \<succeq> r"
      by (metis \<open>Some x = r \<oplus> |b|\<close> assms commutative greater_def succ_trans)
  qed
qed

lemma minus_unique:
  assumes "Some b = a \<oplus> x \<and> x \<succeq> |b|"
      and "Some b = a \<oplus> y \<and> y \<succeq> |b|"
    shows "x = y"
proof -
  have "|x| = |b|"
    using assms(1) extract_core by blast
  moreover have "|y| = |b|"
    using assms(2) extract_core by blast
  ultimately show ?thesis
    using assms(1) assms(2) cancellative by auto
qed

lemma minus_exists:
  assumes "b \<succeq> a"
  shows "\<exists>x. Some b = a \<oplus> x \<and> x \<succeq> |b|"
  using assms bigger_sum_smaller core_is_smaller by blast

lemma minus_equiv_def:
  assumes "b \<succeq> a"
    shows "Some b = a \<oplus> (b \<ominus> a) \<and> (b \<ominus> a) \<succeq> |b|"
proof -
  let ?x = "THE_default b (\<lambda>x. Some b = a \<oplus> x \<and> x \<succeq> |b| )"
  have "(\<lambda>x. Some b = a \<oplus> x \<and> x \<succeq> |b| ) ?x"
  proof (rule THE_defaultI')
    show "\<exists>!x. Some b = a \<oplus> x \<and> x \<succeq> |b|"
      using assms local.minus_unique minus_exists by blast
  qed
  then show ?thesis by (metis minus_def)
qed

lemma minus_default:
  assumes "\<not> b \<succeq> a"
  shows "b \<ominus> a = b"
  using THE_default_none assms greater_def minus_def by fastforce

lemma minusI:
  assumes "Some b = a \<oplus> x"
      and "x \<succeq> |b|"
    shows "x = b \<ominus> a"
  using assms(1) assms(2) greater_def local.minus_unique minus_equiv_def by blast

lemma minus_core:
  "|a \<ominus> b| = |a|"
proof (cases "a \<succeq> b")
  case True
  then have "Some a = b \<oplus> (a \<ominus> b) \<and> a \<ominus> b \<succeq> |a|"
    using minus_equiv_def by auto
  then show ?thesis
    using extract_core by blast
next
  case False
  then show ?thesis by (simp add: minus_default)
qed

lemma minus_core_weaker:
  "|a \<ominus> b| = |a| \<ominus> |b|"
proof (cases "a \<succeq> b")
  case True
  then show ?thesis
    by (metis greater_equiv max_projection_prop_pure_core minus_core minus_default minus_equiv_def mpp_invo succ_antisym)
next
  case False
  then show ?thesis
    by (metis greater_equiv max_projection_prop_pure_core minus_default minus_equiv_def mpp_invo succ_antisym)
qed

lemma minus_equiv_def_any_elem:
  assumes "Some x = a \<oplus> b"
  shows "Some (x \<ominus> a) = b \<oplus> |x|"
proof -
  obtain r where "Some r = b \<oplus> |x|"
    by (metis assms core_is_smaller domD domIff option.simps(3) sep_algebra.asso2 sep_algebra_axioms)
  have "r = x \<ominus> a"
  proof (rule minusI)
    show "Some x = a \<oplus> r"
      by (metis \<open>Some r = b \<oplus> |x|\<close> assms asso1 core_is_smaller)
    moreover show "r \<succeq> |x|"
      using \<open>Some r = b \<oplus> |x|\<close> greater_equiv by blast
  qed
  then show ?thesis
    using \<open>Some r = b \<oplus> |x|\<close> by blast
qed

lemma minus_bigger:
  assumes "Some x = a \<oplus> b"
  shows "x \<ominus> a \<succeq> b"
  using assms greater_def minus_equiv_def_any_elem by blast

lemma minus_smaller:
  assumes "x \<succeq> a"
  shows "x \<succeq> x \<ominus> a"
  using assms greater_equiv minus_equiv_def by blast

lemma minus_sum:
  assumes "Some a = b \<oplus> c"
      and "x \<succeq> a"
    shows "x \<ominus> a = (x \<ominus> b) \<ominus> c"
proof (rule minusI)
  obtain r where "Some r = c \<oplus> (x \<ominus> a)"
    by (metis assms(1) assms(2) asso2 minus_equiv_def option.exhaust_sel)
  have "r = (x \<ominus> b)"
  proof (rule minusI)
    show "Some x = b \<oplus> r"
      by (metis \<open>Some r = c \<oplus> (x \<ominus> a)\<close> assms(1) assms(2) asso1 minus_equiv_def)
    moreover show "r \<succeq> |x|"
      by (meson \<open>Some r = c \<oplus> (x \<ominus> a)\<close> assms(2) greater_equiv sep_algebra.minus_equiv_def sep_algebra_axioms succ_trans)
  qed
  then show "Some (x \<ominus> b) = c \<oplus> (x \<ominus> a)"
    using \<open>Some r = c \<oplus> (x \<ominus> a)\<close> by blast
  moreover show "x \<ominus> a \<succeq> |x \<ominus> b|"
    by (simp add: assms(2) minus_core minus_equiv_def)
qed

lemma smaller_compatible_core:
  assumes "y \<succeq> x"
  shows "x ## |y|"
  by (metis assms asso2 core_is_smaller defined_def greater_equiv option.discI)

lemma smaller_pure_sum_smaller:
  assumes "y \<succeq> a"
      and "y \<succeq> b"
      and "Some x = a \<oplus> b"
      and "pure b"
    shows "y \<succeq> x"
proof -
  obtain r where "Some y = r \<oplus> b" "r \<succeq> a"
    by (metis assms(1) assms(2) assms(4) asso1 greater_equiv pure_def)
  then show ?thesis
    using addition_bigger assms(3) by blast
qed

lemma greater_minus_trans:
  assumes "y \<succeq> x"
      and "x \<succeq> a"
    shows "y \<ominus> a \<succeq> x \<ominus> a"
proof -
  obtain r where "Some y = x \<oplus> r"
    using assms(1) greater_def by blast
  then obtain ra where "Some x = a \<oplus> ra"
    using assms(2) greater_def by blast
  then have "Some (x \<ominus> a) = ra \<oplus> |x|"
    by (simp add: minus_equiv_def_any_elem)
  then obtain yy where "Some yy = (x \<ominus> a) \<oplus> r"
    by (metis (full_types) \<open>Some y = x \<oplus> r\<close> assms(2) asso3 commutative minus_equiv_def not_Some_eq)
  then obtain "Some x = a \<oplus> (x \<ominus> a)" "x \<ominus> a \<succeq>  |x|"
    by (simp_all add: assms(2) sep_algebra.minus_equiv_def sep_algebra_axioms)
  then obtain y' where "Some y' = a \<oplus> yy"
    using \<open>Some y = x \<oplus> r\<close> \<open>Some yy = x \<ominus> a \<oplus> r\<close> asso1
    by metis
  moreover have "y \<succeq> y'"
    by (metis \<open>Some x = a \<oplus> (x \<ominus> a)\<close> \<open>Some y = x \<oplus> r\<close> \<open>Some yy = x \<ominus> a \<oplus> r\<close> asso1 calculation option.inject succ_refl)
  moreover obtain x' where "Some x' = (x \<ominus> a) \<oplus> a"
    using assms(2) commutative minus_equiv_def by fastforce
  then have "y \<succeq> x'"
    by (metis assms(1) assms(2) commutative minus_equiv_def option.sel)
  moreover have "x' \<succeq> x \<ominus> a"
    using \<open>Some x' = x \<ominus> a \<oplus> a\<close> greater_def by auto
  ultimately show ?thesis
    using \<open>Some x' = x \<ominus> a \<oplus> a\<close> \<open>Some y = x \<oplus> r\<close> assms(2) asso1 commutative greater_equiv minus_bigger minus_equiv_def option.sel sep_algebra.succ_trans sep_algebra_axioms
  proof -
    have f1: "Some y' = a \<oplus> yy"
      by (simp add: \<open>Some y' = a \<oplus> yy\<close> commutative)
    then have "y = y'"
      by (metis \<open>Some y = x \<oplus> r\<close> \<open>Some yy = x \<ominus> a \<oplus> r\<close> \<open>x \<succeq> a\<close> asso1 minus_equiv_def option.sel)
    then show ?thesis
      using f1 by (metis (no_types) \<open>Some yy = x \<ominus> a \<oplus> r\<close> commutative greater_equiv minus_bigger sep_algebra.succ_trans sep_algebra_axioms)
  qed
qed

lemma minus_and_plus:
  assumes "Some \<omega>' = \<omega> \<oplus> r"
      and "\<omega> \<succeq> a"
    shows "Some (\<omega>' \<ominus> a) = (\<omega> \<ominus> a) \<oplus> r"
proof -
  have "\<omega> \<succeq> \<omega> \<ominus> a"
    by (simp add: assms(2) minus_smaller)
  then have "(\<omega> \<ominus> a) ## r"
    by (metis (full_types) assms(1) defined_def option.discI sep_algebra.smaller_compatible sep_algebra_axioms)
  then obtain x where "Some x = (\<omega> \<ominus> a) \<oplus> r"
    using defined_def by auto
  then have "Some \<omega>' = a \<oplus> x \<and> x \<succeq> |\<omega>'|"
    by (metis (no_types, lifting) assms asso1 core_sum max_projection_prop_pure_core minus_core minus_equiv_def mpp_smaller option.inject)
  then have "x = \<omega>' \<ominus> a"
    by (simp add: minusI)
  then show ?thesis
    using \<open>Some x = \<omega> \<ominus> a \<oplus> r\<close> by blast
qed

subsection \<open>Lifting the algebra to sets of states\<close>

lemma add_set_commm:
  "A \<otimes> B = B \<otimes> A"
proof
  show "A \<otimes> B \<subseteq> B \<otimes> A"
    using add_set_def sep_algebra.commutative sep_algebra_axioms by fastforce
  show "B \<otimes> A \<subseteq> A \<otimes> B"
    using add_set_def commutative by fastforce
qed

lemma x_elem_set_product:
  "x \<in> A \<otimes> B \<longleftrightarrow> (\<exists>a b. a \<in> A \<and> b \<in> B \<and> Some x = a \<oplus> b)"
  using sep_algebra.add_set_def sep_algebra_axioms by fastforce

lemma x_elem_set_product_splus:
  "x \<in> A \<otimes> B \<longleftrightarrow> (\<exists>a b. a \<in> A \<and> b \<in> B \<and> Some x = splus (Some a) (Some b))"
  using sep_algebra.add_set_def sep_algebra_axioms by fastforce

lemma add_set_asso:
  "(A \<otimes> B) \<otimes> C = A \<otimes> (B \<otimes> C)" (is "?A = ?B")
proof -
  have "?A \<subseteq> ?B"
  proof (rule subsetI)
    fix x assume "x \<in> ?A"
    then obtain ab c where "Some x = ab \<oplus> c" "ab \<in> A \<otimes> B" "c \<in> C"
      using x_elem_set_product by auto
    then obtain a b where "Some ab = a \<oplus> b" "a \<in> A" "b \<in> B"
      using x_elem_set_product by auto
    then obtain bc where "Some bc = b \<oplus> c"
      by (metis \<open>Some x = ab \<oplus> c\<close> asso2 option.exhaust)
    then show "x \<in> ?B"
      by (metis \<open>Some ab = a \<oplus> b\<close> \<open>Some x = ab \<oplus> c\<close> \<open>a \<in> A\<close> \<open>b \<in> B\<close> \<open>c \<in> C\<close> asso1 x_elem_set_product)
  qed
  moreover have "?B \<subseteq> ?A"
  proof (rule subsetI)
    fix x assume "x \<in> ?B"
    then obtain a bc where "Some x = a \<oplus> bc" "a \<in> A" "bc \<in> B \<otimes> C"
      using x_elem_set_product by auto
    then obtain b c where "Some bc = b \<oplus> c" "c \<in> C" "b \<in> B"
      using x_elem_set_product by auto
    then obtain ab where "Some ab = a \<oplus> b"
      by (metis \<open>Some x = a \<oplus> bc\<close> asso3 option.collapse)
    then show "x \<in> ?A"
      by (metis \<open>Some bc = b \<oplus> c\<close> \<open>Some x = a \<oplus> bc\<close> \<open>a \<in> A\<close> \<open>b \<in> B\<close> \<open>c \<in> C\<close> asso1 x_elem_set_product)
  qed
  ultimately show ?thesis by blast
qed

lemma up_closedI:
  assumes "\<And>\<phi>' \<phi>. (\<phi>' :: 'a) \<succeq> \<phi> \<and> \<phi> \<in> A \<Longrightarrow> \<phi>' \<in> A"
  shows "up_closed A"
  using assms up_closed_def by blast

lemma up_closed_plus_UNIV:
  "up_closed (A \<otimes> UNIV)"
proof (rule up_closedI)
  fix \<phi> \<phi>'
  assume asm: "\<phi>' \<succeq> \<phi> \<and> \<phi> \<in> A \<otimes> UNIV"
  then obtain r a b where "Some \<phi>' = \<phi> \<oplus> r" "Some \<phi> = a \<oplus> b" "a \<in> A"
    using greater_def x_elem_set_product by auto
  then obtain br where "Some br = b \<oplus> r"
    by (metis asso2 option.exhaust_sel)
  then have "Some \<phi>' = a \<oplus> br"
    by (metis \<open>Some \<phi> = a \<oplus> b\<close> \<open>Some \<phi>' = \<phi> \<oplus> r\<close> splus.simps(3) splus_asso)
  then show "\<phi>' \<in> A \<otimes> UNIV"
    using \<open>a \<in> A\<close> x_elem_set_product by auto
qed

lemma succ_set_trans:
  assumes "A \<ggreater> B"
      and "B \<ggreater> C"
    shows "A \<ggreater> C"
  by (meson assms(1) assms(2) greater_set_def succ_trans)

lemma greater_setI:
  assumes "\<And>a. a \<in> A \<Longrightarrow> (\<exists>b \<in> B. a \<succeq> b)"
    shows "A \<ggreater> B"
  by (simp add: assms greater_set_def)

lemma bigger_set:
  assumes "A' \<ggreater> A"
  shows "A' \<otimes> B \<ggreater> A \<otimes> B"
proof (rule greater_setI)
  fix x assume "x \<in> A' \<otimes> B"
  then obtain a' b where "Some x = a' \<oplus> b" "a' \<in> A'" "b \<in> B"
    using x_elem_set_product by auto
  then obtain a where "a' \<succeq> a" "a \<in> A"
    using assms greater_set_def by blast
  then obtain ab where "Some ab = a \<oplus> b"
    by (metis \<open>Some x = a' \<oplus> b\<close> asso2 domD domIff greater_equiv)
  then show "\<exists>ab\<in>A \<otimes> B. x \<succeq> ab"
    using \<open>Some x = a' \<oplus> b\<close> \<open>a \<in> A\<close> \<open>a' \<succeq> a\<close> \<open>b \<in> B\<close> addition_bigger x_elem_set_product by blast
qed

lemma bigger_singleton:
  assumes "\<phi>' \<succeq> \<phi>"
  shows "{\<phi>'} \<ggreater> {\<phi>}"
  by (simp add: assms greater_set_def)

lemma add_set_elem:
  "\<phi> \<in> A \<otimes> B \<longleftrightarrow> (\<exists>a b. Some \<phi> = a \<oplus> b \<and> a \<in> A \<and> b \<in> B)"
  using add_set_def by auto

lemma up_closed_sum:
  assumes "up_closed A"
    shows "up_closed (A \<otimes> B)"
proof (rule up_closedI)
  fix \<phi>' \<phi> assume asm: "\<phi>' \<succeq> \<phi> \<and> \<phi> \<in> A \<otimes> B"
  then obtain a b where "a \<in> A" "b \<in> B" "Some \<phi> = a \<oplus> b"
    using add_set_elem by auto
  moreover obtain r where "Some \<phi>' = \<phi> \<oplus> r"
    using asm greater_def by blast
  then obtain ar where "Some ar = a \<oplus> r"
    by (metis asso2 calculation(3) commutative option.exhaust_sel option.simps(3))
  then have "ar \<in> A"
    by (meson assms calculation(1) greater_def sep_algebra.up_closed_def sep_algebra_axioms)
  then show "\<phi>' \<in> A \<otimes> B"
    by (metis \<open>Some \<phi>' = \<phi> \<oplus> r\<close> \<open>Some ar = a \<oplus> r\<close> add_set_elem asso1 calculation(2) calculation(3) commutative)
qed

lemma up_closed_bigger_subset:
  assumes "up_closed B"
      and "A \<ggreater> B"
    shows "A \<subseteq> B"
  by (meson assms(1) assms(2) greater_set_def sep_algebra.up_closed_def sep_algebra_axioms subsetI)

lemma up_close_equiv:
  assumes "up_closed A"
      and "up_closed B"
    shows "A \<sim> B \<longleftrightarrow> A = B"
proof -
  have "A \<sim> B \<longleftrightarrow> A \<ggreater> B \<and> B \<ggreater> A"
    using local.equiv_def by auto
  also have "... \<longleftrightarrow> A \<subseteq> B \<and> B \<subseteq> A"
    by (metis assms(1) assms(2) greater_set_def set_eq_subset succ_refl up_closed_bigger_subset)
  ultimately show ?thesis
    by blast
qed

lemma equiv_stable_sum:
  assumes "A \<sim> B"
  shows "A \<otimes> C \<sim> B \<otimes> C"
  using assms bigger_set local.equiv_def by auto

lemma equiv_up_closed_subset:
  assumes "up_closed A"
      and "equiv B C"
    shows "B \<subseteq> A \<longleftrightarrow> C \<subseteq> A" (is "?B \<longleftrightarrow> ?C")
proof -
  have "?B \<Longrightarrow> ?C"
    by (meson greater_set_def up_closed_def equiv_def assms(1) assms(2) subsetD subsetI)
  moreover have "?C \<Longrightarrow> ?B"
    by (meson greater_set_def up_closed_def equiv_def assms(1) assms(2) subsetD subsetI)
  ultimately show ?thesis by blast
qed

lemma mono_propI:
  assumes "\<And>x y. y \<succeq> x \<and> P x \<Longrightarrow> P y"
  shows "mono_prop P"
  using assms mono_prop_def by blast

lemma mono_prop_set:
  assumes "A \<ggreater> B"
      and "setify P B"
      and "mono_prop P"
    shows "setify P A"
  using assms(1) assms(2) assms(3) greater_set_def local.setify_def mono_prop_def by auto

lemma mono_prop_set_equiv:
  assumes "mono_prop P"
      and "equiv A B"
    shows "setify P A \<longleftrightarrow> setify P B"
  by (meson assms(1) assms(2) local.equiv_def sep_algebra.mono_prop_set sep_algebra_axioms)

lemma setify_sum:
  "setify P (A \<otimes> B) \<longleftrightarrow> (\<forall>x \<in> A. setify P ({x} \<otimes> B))" (is "?A \<longleftrightarrow> ?B")
proof -
  have "?A \<Longrightarrow> ?B"
    using local.setify_def sep_algebra.add_set_elem sep_algebra_axioms singletonD by fastforce
  moreover have "?B \<Longrightarrow> ?A"
    using add_set_elem local.setify_def by fastforce
  ultimately show ?thesis by blast
qed

lemma setify_sum_image:
  "setify P ((Set.image f A) \<otimes> B) \<longleftrightarrow> (\<forall>x \<in> A. setify P ({f x} \<otimes> B))"
proof
  show "setify P (f ` A \<otimes> B) \<Longrightarrow> \<forall>x\<in>A. setify P ({f x} \<otimes> B)"
    by (meson rev_image_eqI sep_algebra.setify_sum sep_algebra_axioms)
  show "\<forall>x\<in>A. setify P ({f x} \<otimes> B) \<Longrightarrow> setify P (f ` A \<otimes> B)"
    by (metis (mono_tags, lifting) image_iff sep_algebra.setify_sum sep_algebra_axioms)
qed

lemma equivI:
  assumes "A \<ggreater> B"
    and "B \<ggreater> A"
    shows "equiv A B"
  by (simp add: assms(1) assms(2) local.equiv_def)

lemma sub_bigger:
  assumes "A \<subseteq> B"
  shows "A \<ggreater> B"
  by (meson assms greater_set_def in_mono succ_refl)

lemma larger_set_refl:
  "A \<ggreater> A"
  by (simp add: sub_bigger)

definition upper_closure where
  "upper_closure A = { \<phi>' |\<phi>' \<phi>. \<phi>' \<succeq> \<phi> \<and> \<phi> \<in> A }"

lemma upper_closure_up_closed:
  "up_closed (upper_closure A)"
proof (rule up_closedI)
  fix \<phi>' \<phi>
  assume asm0: "\<phi>' \<succeq> \<phi> \<and> \<phi> \<in> upper_closure A"
  then obtain a where "a \<in> A \<and> \<phi> \<succeq> a"
    using sep_algebra.upper_closure_def sep_algebra_axioms by fastforce
  then have "\<phi>' \<succeq> a"
    using asm0 succ_trans by blast
  then show "\<phi>' \<in> upper_closure A"
    using \<open>a \<in> A \<and> \<phi> \<succeq> a\<close> upper_closure_def by auto
qed

subsection \<open>Addition of more than two states\<close>

lemma multi_decompose:
  assumes "multi_plus l \<omega>"
    shows "length l \<ge> 2 \<Longrightarrow> (\<exists>a b la lb. l = la @ lb \<and> length la > 0 \<and> length lb > 0 \<and> multi_plus la a \<and> multi_plus lb b \<and> Some \<omega> = a \<oplus> b)"
  using assms
  apply (rule multi_plus.cases)
  by auto[2]

lemma multi_take_drop:
  assumes "multi_plus l \<omega>"
      and "length l \<ge> 2"
    shows "\<exists>n a b. n > 0 \<and> n < length l \<and> multi_plus (take n l) a \<and> multi_plus (drop n l) b \<and> Some \<omega> = a \<oplus> b"
proof -
  obtain a b la lb where asm0: "l = la @ lb \<and> length la > 0 \<and> length lb > 0 \<and> multi_plus la a \<and> multi_plus lb b \<and> Some \<omega> = a \<oplus> b"
    using assms(1) assms(2) multi_decompose by blast
  let ?n = "length la"
  have "la = take ?n l"
    by (simp add: asm0)
  moreover have "lb = drop ?n l"
    by (simp add: asm0)
  ultimately show ?thesis
    by (metis asm0 length_drop zero_less_diff)
qed

lemma multi_plus_single:
  assumes "multi_plus [v] a"
  shows "a = v"
  using assms
  apply (cases)
  apply simp
  by (metis (no_types, lifting) Nil_is_append_conv butlast.simps(2) butlast_append length_greater_0_conv)

lemma multi_plus_two:
  assumes "length l \<ge> 2"
  shows "multi_plus l \<omega> \<longleftrightarrow> (\<exists>a b la lb. l = (la @ lb) \<and> length la > 0 \<and> length lb > 0 \<and> multi_plus la a \<and> multi_plus lb b \<and> Some \<omega> = a \<oplus> b)" (is "?A \<longleftrightarrow> ?B")
  by (meson MPConcat assms multi_decompose)

lemma multi_plus_head_tail:
  "length l \<le> n \<and> length l \<ge> 2 \<longrightarrow> (multi_plus l \<omega> \<longleftrightarrow> (\<exists>r. Some \<omega> = (List.hd l) \<oplus> r \<and> multi_plus (List.tl l) r))"
proof (induction n arbitrary: l \<omega>)
  case 0
  then show ?case by auto
next
  case (Suc n)
  then have IH: "\<And>(l :: 'a list) \<omega>. length l \<le> n \<and> length l \<ge> 2 \<longrightarrow> multi_plus l \<omega> = (\<exists>r. Some \<omega> = hd l \<oplus> r \<and> multi_plus (tl l) r)"
    by blast
  then show ?case
  proof (cases "n = 0")
    case True
    then have "n = 0" by simp
    then show ?thesis by linarith
  next
    case False
    then have "length (l :: 'a list) \<ge> 2 \<and> length l \<le> n + 1 \<Longrightarrow> multi_plus l \<omega> \<longleftrightarrow> (\<exists>r. Some \<omega> = hd l \<oplus> r \<and> multi_plus (tl l) r)"
      (is "length l \<ge> 2  \<and> length l \<le> n + 1 \<Longrightarrow> ?A \<longleftrightarrow> ?B")
    proof -
      assume asm: "length (l :: 'a list) \<ge> 2 \<and> length l \<le> n + 1"
      have "?B \<Longrightarrow> ?A"
      proof -
        assume "?B"
        then obtain r where "Some \<omega> = hd l \<oplus> r \<and> multi_plus (tl l) r" by blast
        then have "multi_plus [hd l] (hd l)"
          using MPSingle by blast
        moreover have "[hd l] @ (tl l) = l"
          by (metis Suc_le_length_iff asm append_Cons list.collapse list.simps(3) numeral_2_eq_2 self_append_conv2)
        ultimately show ?A
          by (metis (no_types, lifting) MPConcat Suc_1 Suc_le_mono asm \<open>Some \<omega> = hd l \<oplus> r \<and> multi_plus (tl l) r\<close> append_Nil2 length_Cons length_greater_0_conv list.size(3) not_one_le_zero zero_less_Suc)
      qed
      moreover have "?A \<Longrightarrow> ?B"
      proof -
        assume ?A
        then obtain la lb a b where "l = la @ lb" "length la > 0" "length lb > 0" "multi_plus la a" "multi_plus lb b" "Some \<omega> = a \<oplus> b"
          using asm multi_decompose by blast
        then have r0: "length la \<le> n \<and> length la \<ge> 2 \<longrightarrow> multi_plus la a = (\<exists>r. Some a = hd la \<oplus> r \<and> multi_plus (tl la) r)"
          using IH by blast
        then show ?B
        proof (cases "length la \<ge> 2")
          case True
          then obtain ra where "Some a = (hd la) \<oplus> ra" "multi_plus (tl la) ra"
            by (metis Suc_eq_plus1 \<open>0 < length lb\<close> \<open>l = la @ lb\<close> r0 \<open>multi_plus la a\<close> append_eq_conv_conj asm drop_eq_Nil le_add1 le_less_trans length_append length_greater_0_conv less_Suc_eq_le order.not_eq_order_implies_strict)
          moreover obtain rab where "Some rab = ra \<oplus> b"
            by (metis \<open>Some \<omega> = a \<oplus> b\<close> calculation(1) asso2 option.exhaust_sel)
          then have "multi_plus ((tl la) @ lb) rab"
            by (metis (no_types, lifting) Nil_is_append_conv \<open>multi_plus lb b\<close> calculation(2) length_greater_0_conv list.simps(3) multi_plus.cases sep_algebra.MPConcat sep_algebra_axioms)
          moreover have "Some \<omega> = hd la \<oplus> rab"
            by (metis \<open>Some \<omega> = a \<oplus> b\<close> \<open>Some rab = ra \<oplus> b\<close> asso1 calculation(1))
          ultimately show ?B
            using \<open>0 < length la\<close> \<open>l = la @ lb\<close> by auto
        next
          case False
          then have "length la = 1"
            using \<open>0 < length la\<close> by linarith
          then have "la = [a]"
            by (metis Nitpick.size_list_simp(2) One_nat_def Suc_le_length_iff \<open>multi_plus la a\<close> diff_Suc_1 le_numeral_extra(4) length_0_conv list.sel(3) sep_algebra.multi_plus_single sep_algebra_axioms)
          then show ?thesis
            using \<open>Some \<omega> = a \<oplus> b\<close> \<open>l = la @ lb\<close> \<open>multi_plus lb b\<close> by auto
        qed
      qed
      then show ?thesis using calculation by blast
    qed
    then show ?thesis by (metis (no_types, lifting) Suc_eq_plus1)
  qed
qed

lemma not_multi_plus_empty:
  "\<not> multi_plus [] \<omega>"
  by (metis Nil_is_append_conv length_greater_0_conv list.simps(3) sep_algebra.multi_plus.simps sep_algebra_axioms)

lemma multi_plus_deter:
  "length l \<le> n \<Longrightarrow> multi_plus l \<omega> \<Longrightarrow> multi_plus l \<omega>' \<Longrightarrow> \<omega> = \<omega>'"
proof (induction n arbitrary: l \<omega> \<omega>')
  case 0
  then show ?case
    using multi_plus.cases by auto
next
  case (Suc n)
  then show ?case
  proof (cases "length l \<ge> 2")
    case True
    then obtain r where "Some \<omega> = (List.hd l) \<oplus> r \<and> multi_plus (List.tl l) r"
      using Suc.prems(2) multi_plus_head_tail by blast
    moreover obtain r' where "Some \<omega>' = (List.hd l) \<oplus> r' \<and> multi_plus (List.tl l) r'"
      using Suc.prems(3) True multi_plus_head_tail by blast
    ultimately have "r = r'"
      by (metis Suc.IH Suc.prems(1) drop_Suc drop_eq_Nil)
    then show ?thesis
      by (metis \<open>Some \<omega> = hd l \<oplus> r \<and> multi_plus (tl l) r\<close> \<open>Some \<omega>' = hd l \<oplus> r' \<and> multi_plus (tl l) r'\<close> option.inject)
  next
    case False
    then have "length l \<le> 1"
      by simp
    then show ?thesis
    proof (cases "length l = 0")
      case True
      then show ?thesis
        using Suc.prems(2) sep_algebra.not_multi_plus_empty sep_algebra_axioms by fastforce
    next
      case False
      then show ?thesis
        by (metis One_nat_def Suc.prems(2) Suc.prems(3) Suc_length_conv \<open>length l \<le> 1\<close> le_SucE le_zero_eq length_greater_0_conv less_numeral_extra(3) sep_algebra.multi_plus_single sep_algebra_axioms)
    qed
  qed
qed

lemma multi_plus_implies_multi_plus_of_drop:
  assumes "multi_plus l \<omega>"
      and "n < length l"
    shows "\<exists>a. multi_plus (drop n l) a \<and> \<omega> \<succeq> a"
  using assms
proof (induction n arbitrary: l \<omega>)
  case 0
  then show ?case using succ_refl by fastforce
next
  case (Suc n)
  then have "length l \<ge> 2"
    by linarith
  then obtain r where "Some \<omega> = (List.hd l) \<oplus> r \<and> multi_plus (List.tl l) r"
    using Suc.prems(1) multi_plus_head_tail by blast
  then obtain a where "multi_plus (drop n (List.tl l)) a \<and> r \<succeq> a"
    using Suc.IH Suc.prems(2) by fastforce
  then show ?case
    by (metis \<open>Some \<omega> = hd l \<oplus> r \<and> multi_plus (tl l) r\<close> bigger_sum_smaller commutative drop_Suc greater_def)
qed

lemma multi_plus_bigger_than_head:
  assumes "length l > 0"
      and "multi_plus l \<omega>"
    shows "\<omega> \<succeq> List.hd l"
proof (cases "length l \<ge> 2")
  case True
  then obtain r where "Some \<omega> = (List.hd l) \<oplus> r \<and> multi_plus (List.tl l) r"
    using assms(1) assms(2) multi_plus_head_tail by blast
  then show ?thesis
    using greater_def by blast
next
  case False
  then show ?thesis
    by (metis Cons_nth_drop_Suc MPSingle assms(1) assms(2) drop_0 drop_eq_Nil hd_conv_nth length_greater_0_conv not_less_eq_eq numeral_2_eq_2 sep_algebra.multi_plus_deter sep_algebra_axioms succ_refl)
qed

lemma multi_plus_bigger:
  assumes "i < length l"
      and "multi_plus l \<omega>"
    shows "\<omega> \<succeq> (l ! i)"
proof -
  obtain a where "multi_plus (drop i l) a \<and> \<omega> \<succeq> a"
    using assms(1) assms(2) multi_plus_implies_multi_plus_of_drop order.strict_trans by blast
  moreover have "List.hd (drop i l) = l ! i"
    by (simp add: assms(1) hd_drop_conv_nth)
  then show ?thesis
    by (metis (no_types, lifting) succ_trans assms(1) assms(2) drop_eq_Nil leD length_greater_0_conv multi_plus_bigger_than_head multi_plus_implies_multi_plus_of_drop)
qed

lemma sum_then_singleton:
  "Some a = b \<oplus> c \<longleftrightarrow> {a} = {b} \<otimes> {c}" (is "?A \<longleftrightarrow> ?B")
proof -
  have "?A \<Longrightarrow> ?B"
  proof -
    assume ?A
    then have "{a} \<subseteq> {b} \<otimes> {c}"
      using add_set_elem by auto
    moreover have "{b} \<otimes> {c} \<subseteq> {a}"
    proof (rule subsetI)
      fix x assume "x \<in> {b} \<otimes> {c}"
      then show "x \<in> {a}"
        by (metis \<open>Some a = b \<oplus> c\<close> option.sel sep_algebra.add_set_elem sep_algebra_axioms singleton_iff)
    qed
    ultimately show ?thesis by blast
  qed
  moreover have "?B \<Longrightarrow> ?A"
    using add_set_elem by auto
  ultimately show ?thesis by blast
qed

lemma empty_set_sum:
  "{} \<otimes> A = {}"
  by (simp add: add_set_def)

end

end


(*  Title:      HOL/Analysis/Extended_Real_Limits.thy
    Author:     Johannes Hölzl, TU München
    Author:     Robert Himmelmann, TU München
    Author:     Armin Heller, TU München
    Author:     Bogdan Grechuk, University of Edinburgh
*)

section \<open>Limits on the Extended real number line\<close>

theory Extended_Real_Limits
imports
  Topology_Euclidean_Space
  "~~/src/HOL/Library/Extended_Real"
  "~~/src/HOL/Library/Extended_Nonnegative_Real"
  "~~/src/HOL/Library/Indicator_Function"
begin

lemma compact_UNIV:
  "compact (UNIV :: 'a::{complete_linorder,linorder_topology,second_countable_topology} set)"
  using compact_complete_linorder
  by (auto simp: seq_compact_eq_compact[symmetric] seq_compact_def)

lemma compact_eq_closed:
  fixes S :: "'a::{complete_linorder,linorder_topology,second_countable_topology} set"
  shows "compact S \<longleftrightarrow> closed S"
  using closed_Int_compact[of S, OF _ compact_UNIV] compact_imp_closed
  by auto

lemma closed_contains_Sup_cl:
  fixes S :: "'a::{complete_linorder,linorder_topology,second_countable_topology} set"
  assumes "closed S"
    and "S \<noteq> {}"
  shows "Sup S \<in> S"
proof -
  from compact_eq_closed[of S] compact_attains_sup[of S] assms
  obtain s where S: "s \<in> S" "\<forall>t\<in>S. t \<le> s"
    by auto
  then have "Sup S = s"
    by (auto intro!: Sup_eqI)
  with S show ?thesis
    by simp
qed

lemma closed_contains_Inf_cl:
  fixes S :: "'a::{complete_linorder,linorder_topology,second_countable_topology} set"
  assumes "closed S"
    and "S \<noteq> {}"
  shows "Inf S \<in> S"
proof -
  from compact_eq_closed[of S] compact_attains_inf[of S] assms
  obtain s where S: "s \<in> S" "\<forall>t\<in>S. s \<le> t"
    by auto
  then have "Inf S = s"
    by (auto intro!: Inf_eqI)
  with S show ?thesis
    by simp
qed

instance enat :: second_countable_topology
proof
  show "\<exists>B::enat set set. countable B \<and> open = generate_topology B"
  proof (intro exI conjI)
    show "countable (range lessThan \<union> range greaterThan::enat set set)"
      by auto
  qed (simp add: open_enat_def)
qed

instance ereal :: second_countable_topology
proof (standard, intro exI conjI)
  let ?B = "(\<Union>r\<in>\<rat>. {{..< r}, {r <..}} :: ereal set set)"
  show "countable ?B"
    by (auto intro: countable_rat)
  show "open = generate_topology ?B"
  proof (intro ext iffI)
    fix S :: "ereal set"
    assume "open S"
    then show "generate_topology ?B S"
      unfolding open_generated_order
    proof induct
      case (Basis b)
      then obtain e where "b = {..<e} \<or> b = {e<..}"
        by auto
      moreover have "{..<e} = \<Union>{{..<x}|x. x \<in> \<rat> \<and> x < e}" "{e<..} = \<Union>{{x<..}|x. x \<in> \<rat> \<and> e < x}"
        by (auto dest: ereal_dense3
                 simp del: ex_simps
                 simp add: ex_simps[symmetric] conj_commute Rats_def image_iff)
      ultimately show ?case
        by (auto intro: generate_topology.intros)
    qed (auto intro: generate_topology.intros)
  next
    fix S
    assume "generate_topology ?B S"
    then show "open S"
      by induct auto
  qed
qed

text \<open>This is a copy from \<open>ereal :: second_countable_topology\<close>. Maybe find a common super class of
topological spaces where the rational numbers are densely embedded ?\<close>
instance ennreal :: second_countable_topology
proof (standard, intro exI conjI)
  let ?B = "(\<Union>r\<in>\<rat>. {{..< r}, {r <..}} :: ennreal set set)"
  show "countable ?B"
    by (auto intro: countable_rat)
  show "open = generate_topology ?B"
  proof (intro ext iffI)
    fix S :: "ennreal set"
    assume "open S"
    then show "generate_topology ?B S"
      unfolding open_generated_order
    proof induct
      case (Basis b)
      then obtain e where "b = {..<e} \<or> b = {e<..}"
        by auto
      moreover have "{..<e} = \<Union>{{..<x}|x. x \<in> \<rat> \<and> x < e}" "{e<..} = \<Union>{{x<..}|x. x \<in> \<rat> \<and> e < x}"
        by (auto dest: ennreal_rat_dense
                 simp del: ex_simps
                 simp add: ex_simps[symmetric] conj_commute Rats_def image_iff)
      ultimately show ?case
        by (auto intro: generate_topology.intros)
    qed (auto intro: generate_topology.intros)
  next
    fix S
    assume "generate_topology ?B S"
    then show "open S"
      by induct auto
  qed
qed

lemma ereal_open_closed_aux:
  fixes S :: "ereal set"
  assumes "open S"
    and "closed S"
    and S: "(-\<infinity>) \<notin> S"
  shows "S = {}"
proof (rule ccontr)
  assume "\<not> ?thesis"
  then have *: "Inf S \<in> S"

    by (metis assms(2) closed_contains_Inf_cl)
  {
    assume "Inf S = -\<infinity>"
    then have False
      using * assms(3) by auto
  }
  moreover
  {
    assume "Inf S = \<infinity>"
    then have "S = {\<infinity>}"
      by (metis Inf_eq_PInfty \<open>S \<noteq> {}\<close>)
    then have False
      by (metis assms(1) not_open_singleton)
  }
  moreover
  {
    assume fin: "\<bar>Inf S\<bar> \<noteq> \<infinity>"
    from ereal_open_cont_interval[OF assms(1) * fin]
    obtain e where e: "e > 0" "{Inf S - e<..<Inf S + e} \<subseteq> S" .
    then obtain b where b: "Inf S - e < b" "b < Inf S"
      using fin ereal_between[of "Inf S" e] dense[of "Inf S - e"]
      by auto
    then have "b: {Inf S - e <..< Inf S + e}"
      using e fin ereal_between[of "Inf S" e]
      by auto
    then have "b \<in> S"
      using e by auto
    then have False
      using b by (metis complete_lattice_class.Inf_lower leD)
  }
  ultimately show False
    by auto
qed

lemma ereal_open_closed:
  fixes S :: "ereal set"
  shows "open S \<and> closed S \<longleftrightarrow> S = {} \<or> S = UNIV"
proof -
  {
    assume lhs: "open S \<and> closed S"
    {
      assume "-\<infinity> \<notin> S"
      then have "S = {}"
        using lhs ereal_open_closed_aux by auto
    }
    moreover
    {
      assume "-\<infinity> \<in> S"
      then have "- S = {}"
        using lhs ereal_open_closed_aux[of "-S"] by auto
    }
    ultimately have "S = {} \<or> S = UNIV"
      by auto
  }
  then show ?thesis
    by auto
qed

lemma ereal_open_atLeast:
  fixes x :: ereal
  shows "open {x..} \<longleftrightarrow> x = -\<infinity>"
proof
  assume "x = -\<infinity>"
  then have "{x..} = UNIV"
    by auto
  then show "open {x..}"
    by auto
next
  assume "open {x..}"
  then have "open {x..} \<and> closed {x..}"
    by auto
  then have "{x..} = UNIV"
    unfolding ereal_open_closed by auto
  then show "x = -\<infinity>"
    by (simp add: bot_ereal_def atLeast_eq_UNIV_iff)
qed

lemma mono_closed_real:
  fixes S :: "real set"
  assumes mono: "\<forall>y z. y \<in> S \<and> y \<le> z \<longrightarrow> z \<in> S"
    and "closed S"
  shows "S = {} \<or> S = UNIV \<or> (\<exists>a. S = {a..})"
proof -
  {
    assume "S \<noteq> {}"
    { assume ex: "\<exists>B. \<forall>x\<in>S. B \<le> x"
      then have *: "\<forall>x\<in>S. Inf S \<le> x"
        using cInf_lower[of _ S] ex by (metis bdd_below_def)
      then have "Inf S \<in> S"
        apply (subst closed_contains_Inf)
        using ex \<open>S \<noteq> {}\<close> \<open>closed S\<close>
        apply auto
        done
      then have "\<forall>x. Inf S \<le> x \<longleftrightarrow> x \<in> S"
        using mono[rule_format, of "Inf S"] *
        by auto
      then have "S = {Inf S ..}"
        by auto
      then have "\<exists>a. S = {a ..}"
        by auto
    }
    moreover
    {
      assume "\<not> (\<exists>B. \<forall>x\<in>S. B \<le> x)"
      then have nex: "\<forall>B. \<exists>x\<in>S. x < B"
        by (simp add: not_le)
      {
        fix y
        obtain x where "x\<in>S" and "x < y"
          using nex by auto
        then have "y \<in> S"
          using mono[rule_format, of x y] by auto
      }
      then have "S = UNIV"
        by auto
    }
    ultimately have "S = UNIV \<or> (\<exists>a. S = {a ..})"
      by blast
  }
  then show ?thesis
    by blast
qed

lemma mono_closed_ereal:
  fixes S :: "real set"
  assumes mono: "\<forall>y z. y \<in> S \<and> y \<le> z \<longrightarrow> z \<in> S"
    and "closed S"
  shows "\<exists>a. S = {x. a \<le> ereal x}"
proof -
  {
    assume "S = {}"
    then have ?thesis
      apply (rule_tac x=PInfty in exI)
      apply auto
      done
  }
  moreover
  {
    assume "S = UNIV"
    then have ?thesis
      apply (rule_tac x="-\<infinity>" in exI)
      apply auto
      done
  }
  moreover
  {
    assume "\<exists>a. S = {a ..}"
    then obtain a where "S = {a ..}"
      by auto
    then have ?thesis
      apply (rule_tac x="ereal a" in exI)
      apply auto
      done
  }
  ultimately show ?thesis
    using mono_closed_real[of S] assms by auto
qed

lemma Liminf_within:
  fixes f :: "'a::metric_space \<Rightarrow> 'b::complete_lattice"
  shows "Liminf (at x within S) f = (SUP e:{0<..}. INF y:(S \<inter> ball x e - {x}). f y)"
  unfolding Liminf_def eventually_at
proof (rule SUP_eq, simp_all add: Ball_def Bex_def, safe)
  fix P d
  assume "0 < d" and "\<forall>y. y \<in> S \<longrightarrow> y \<noteq> x \<and> dist y x < d \<longrightarrow> P y"
  then have "S \<inter> ball x d - {x} \<subseteq> {x. P x}"
    by (auto simp: zero_less_dist_iff dist_commute)
  then show "\<exists>r>0. INFIMUM (Collect P) f \<le> INFIMUM (S \<inter> ball x r - {x}) f"
    by (intro exI[of _ d] INF_mono conjI \<open>0 < d\<close>) auto
next
  fix d :: real
  assume "0 < d"
  then show "\<exists>P. (\<exists>d>0. \<forall>xa. xa \<in> S \<longrightarrow> xa \<noteq> x \<and> dist xa x < d \<longrightarrow> P xa) \<and>
    INFIMUM (S \<inter> ball x d - {x}) f \<le> INFIMUM (Collect P) f"
    by (intro exI[of _ "\<lambda>y. y \<in> S \<inter> ball x d - {x}"])
       (auto intro!: INF_mono exI[of _ d] simp: dist_commute)
qed

lemma Limsup_within:
  fixes f :: "'a::metric_space \<Rightarrow> 'b::complete_lattice"
  shows "Limsup (at x within S) f = (INF e:{0<..}. SUP y:(S \<inter> ball x e - {x}). f y)"
  unfolding Limsup_def eventually_at
proof (rule INF_eq, simp_all add: Ball_def Bex_def, safe)
  fix P d
  assume "0 < d" and "\<forall>y. y \<in> S \<longrightarrow> y \<noteq> x \<and> dist y x < d \<longrightarrow> P y"
  then have "S \<inter> ball x d - {x} \<subseteq> {x. P x}"
    by (auto simp: zero_less_dist_iff dist_commute)
  then show "\<exists>r>0. SUPREMUM (S \<inter> ball x r - {x}) f \<le> SUPREMUM (Collect P) f"
    by (intro exI[of _ d] SUP_mono conjI \<open>0 < d\<close>) auto
next
  fix d :: real
  assume "0 < d"
  then show "\<exists>P. (\<exists>d>0. \<forall>xa. xa \<in> S \<longrightarrow> xa \<noteq> x \<and> dist xa x < d \<longrightarrow> P xa) \<and>
    SUPREMUM (Collect P) f \<le> SUPREMUM (S \<inter> ball x d - {x}) f"
    by (intro exI[of _ "\<lambda>y. y \<in> S \<inter> ball x d - {x}"])
       (auto intro!: SUP_mono exI[of _ d] simp: dist_commute)
qed

lemma Liminf_at:
  fixes f :: "'a::metric_space \<Rightarrow> 'b::complete_lattice"
  shows "Liminf (at x) f = (SUP e:{0<..}. INF y:(ball x e - {x}). f y)"
  using Liminf_within[of x UNIV f] by simp

lemma Limsup_at:
  fixes f :: "'a::metric_space \<Rightarrow> 'b::complete_lattice"
  shows "Limsup (at x) f = (INF e:{0<..}. SUP y:(ball x e - {x}). f y)"
  using Limsup_within[of x UNIV f] by simp

lemma min_Liminf_at:
  fixes f :: "'a::metric_space \<Rightarrow> 'b::complete_linorder"
  shows "min (f x) (Liminf (at x) f) = (SUP e:{0<..}. INF y:ball x e. f y)"
  unfolding inf_min[symmetric] Liminf_at
  apply (subst inf_commute)
  apply (subst SUP_inf)
  apply (intro SUP_cong[OF refl])
  apply (cut_tac A="ball x xa - {x}" and B="{x}" and M=f in INF_union)
  apply (drule sym)
  apply auto
  apply (metis INF_absorb centre_in_ball)
  done

subsection \<open>monoset\<close>

definition (in order) mono_set:
  "mono_set S \<longleftrightarrow> (\<forall>x y. x \<le> y \<longrightarrow> x \<in> S \<longrightarrow> y \<in> S)"

lemma (in order) mono_greaterThan [intro, simp]: "mono_set {B<..}" unfolding mono_set by auto
lemma (in order) mono_atLeast [intro, simp]: "mono_set {B..}" unfolding mono_set by auto
lemma (in order) mono_UNIV [intro, simp]: "mono_set UNIV" unfolding mono_set by auto
lemma (in order) mono_empty [intro, simp]: "mono_set {}" unfolding mono_set by auto

lemma (in complete_linorder) mono_set_iff:
  fixes S :: "'a set"
  defines "a \<equiv> Inf S"
  shows "mono_set S \<longleftrightarrow> S = {a <..} \<or> S = {a..}" (is "_ = ?c")
proof
  assume "mono_set S"
  then have mono: "\<And>x y. x \<le> y \<Longrightarrow> x \<in> S \<Longrightarrow> y \<in> S"
    by (auto simp: mono_set)
  show ?c
  proof cases
    assume "a \<in> S"
    show ?c
      using mono[OF _ \<open>a \<in> S\<close>]
      by (auto intro: Inf_lower simp: a_def)
  next
    assume "a \<notin> S"
    have "S = {a <..}"
    proof safe
      fix x assume "x \<in> S"
      then have "a \<le> x"
        unfolding a_def by (rule Inf_lower)
      then show "a < x"
        using \<open>x \<in> S\<close> \<open>a \<notin> S\<close> by (cases "a = x") auto
    next
      fix x assume "a < x"
      then obtain y where "y < x" "y \<in> S"
        unfolding a_def Inf_less_iff ..
      with mono[of y x] show "x \<in> S"
        by auto
    qed
    then show ?c ..
  qed
qed auto

lemma ereal_open_mono_set:
  fixes S :: "ereal set"
  shows "open S \<and> mono_set S \<longleftrightarrow> S = UNIV \<or> S = {Inf S <..}"
  by (metis Inf_UNIV atLeast_eq_UNIV_iff ereal_open_atLeast
    ereal_open_closed mono_set_iff open_ereal_greaterThan)

lemma ereal_closed_mono_set:
  fixes S :: "ereal set"
  shows "closed S \<and> mono_set S \<longleftrightarrow> S = {} \<or> S = {Inf S ..}"
  by (metis Inf_UNIV atLeast_eq_UNIV_iff closed_ereal_atLeast
    ereal_open_closed mono_empty mono_set_iff open_ereal_greaterThan)

lemma ereal_Liminf_Sup_monoset:
  fixes f :: "'a \<Rightarrow> ereal"
  shows "Liminf net f =
    Sup {l. \<forall>S. open S \<longrightarrow> mono_set S \<longrightarrow> l \<in> S \<longrightarrow> eventually (\<lambda>x. f x \<in> S) net}"
    (is "_ = Sup ?A")
proof (safe intro!: Liminf_eqI complete_lattice_class.Sup_upper complete_lattice_class.Sup_least)
  fix P
  assume P: "eventually P net"
  fix S
  assume S: "mono_set S" "INFIMUM (Collect P) f \<in> S"
  {
    fix x
    assume "P x"
    then have "INFIMUM (Collect P) f \<le> f x"
      by (intro complete_lattice_class.INF_lower) simp
    with S have "f x \<in> S"
      by (simp add: mono_set)
  }
  with P show "eventually (\<lambda>x. f x \<in> S) net"
    by (auto elim: eventually_mono)
next
  fix y l
  assume S: "\<forall>S. open S \<longrightarrow> mono_set S \<longrightarrow> l \<in> S \<longrightarrow> eventually  (\<lambda>x. f x \<in> S) net"
  assume P: "\<forall>P. eventually P net \<longrightarrow> INFIMUM (Collect P) f \<le> y"
  show "l \<le> y"
  proof (rule dense_le)
    fix B
    assume "B < l"
    then have "eventually (\<lambda>x. f x \<in> {B <..}) net"
      by (intro S[rule_format]) auto
    then have "INFIMUM {x. B < f x} f \<le> y"
      using P by auto
    moreover have "B \<le> INFIMUM {x. B < f x} f"
      by (intro INF_greatest) auto
    ultimately show "B \<le> y"
      by simp
  qed
qed

lemma ereal_Limsup_Inf_monoset:
  fixes f :: "'a \<Rightarrow> ereal"
  shows "Limsup net f =
    Inf {l. \<forall>S. open S \<longrightarrow> mono_set (uminus ` S) \<longrightarrow> l \<in> S \<longrightarrow> eventually (\<lambda>x. f x \<in> S) net}"
    (is "_ = Inf ?A")
proof (safe intro!: Limsup_eqI complete_lattice_class.Inf_lower complete_lattice_class.Inf_greatest)
  fix P
  assume P: "eventually P net"
  fix S
  assume S: "mono_set (uminus`S)" "SUPREMUM (Collect P) f \<in> S"
  {
    fix x
    assume "P x"
    then have "f x \<le> SUPREMUM (Collect P) f"
      by (intro complete_lattice_class.SUP_upper) simp
    with S(1)[unfolded mono_set, rule_format, of "- SUPREMUM (Collect P) f" "- f x"] S(2)
    have "f x \<in> S"
      by (simp add: inj_image_mem_iff) }
  with P show "eventually (\<lambda>x. f x \<in> S) net"
    by (auto elim: eventually_mono)
next
  fix y l
  assume S: "\<forall>S. open S \<longrightarrow> mono_set (uminus ` S) \<longrightarrow> l \<in> S \<longrightarrow> eventually  (\<lambda>x. f x \<in> S) net"
  assume P: "\<forall>P. eventually P net \<longrightarrow> y \<le> SUPREMUM (Collect P) f"
  show "y \<le> l"
  proof (rule dense_ge)
    fix B
    assume "l < B"
    then have "eventually (\<lambda>x. f x \<in> {..< B}) net"
      by (intro S[rule_format]) auto
    then have "y \<le> SUPREMUM {x. f x < B} f"
      using P by auto
    moreover have "SUPREMUM {x. f x < B} f \<le> B"
      by (intro SUP_least) auto
    ultimately show "y \<le> B"
      by simp
  qed
qed

lemma liminf_bounded_open:
  fixes x :: "nat \<Rightarrow> ereal"
  shows "x0 \<le> liminf x \<longleftrightarrow> (\<forall>S. open S \<longrightarrow> mono_set S \<longrightarrow> x0 \<in> S \<longrightarrow> (\<exists>N. \<forall>n\<ge>N. x n \<in> S))"
  (is "_ \<longleftrightarrow> ?P x0")
proof
  assume "?P x0"
  then show "x0 \<le> liminf x"
    unfolding ereal_Liminf_Sup_monoset eventually_sequentially
    by (intro complete_lattice_class.Sup_upper) auto
next
  assume "x0 \<le> liminf x"
  {
    fix S :: "ereal set"
    assume om: "open S" "mono_set S" "x0 \<in> S"
    {
      assume "S = UNIV"
      then have "\<exists>N. \<forall>n\<ge>N. x n \<in> S"
        by auto
    }
    moreover
    {
      assume "S \<noteq> UNIV"
      then obtain B where B: "S = {B<..}"
        using om ereal_open_mono_set by auto
      then have "B < x0"
        using om by auto
      then have "\<exists>N. \<forall>n\<ge>N. x n \<in> S"
        unfolding B
        using \<open>x0 \<le> liminf x\<close> liminf_bounded_iff
        by auto
    }
    ultimately have "\<exists>N. \<forall>n\<ge>N. x n \<in> S"
      by auto
  }
  then show "?P x0"
    by auto
qed

subsection "Relate extended reals and the indicator function"

lemma ereal_indicator_le_0: "(indicator S x::ereal) \<le> 0 \<longleftrightarrow> x \<notin> S"
  by (auto split: split_indicator simp: one_ereal_def)

lemma ereal_indicator: "ereal (indicator A x) = indicator A x"
  by (auto simp: indicator_def one_ereal_def)

lemma ereal_mult_indicator: "ereal (x * indicator A y) = ereal x * indicator A y"
  by (simp split: split_indicator)

lemma ereal_indicator_mult: "ereal (indicator A y * x) = indicator A y * ereal x"
  by (simp split: split_indicator)

lemma ereal_indicator_nonneg[simp, intro]: "0 \<le> (indicator A x ::ereal)"
  unfolding indicator_def by auto

lemma indicator_inter_arith_ereal: "indicator A x * indicator B x = (indicator (A \<inter> B) x :: ereal)"
  by (simp split: split_indicator)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Reflexive Relator\<close>
theory Reflexive_Relator
  imports
    HOL_Basics.Galois_Equivalences
    HOL_Basics.Galois_Relator
begin

definition "Refl_Rel R x y \<equiv> R x x \<and> R y y \<and> R x y"

bundle Refl_Rel_syntax begin notation Refl_Rel ("(_\<^sup>\<oplus>)" [1000]) end
bundle no_Refl_Rel_syntax begin no_notation Refl_Rel ("(_\<^sup>\<oplus>)" [1000]) end
unbundle Refl_Rel_syntax

lemma Refl_RelI [intro]:
  assumes "R x x"
  and "R y y"
  and "R x y"
  shows "R\<^sup>\<oplus> x y"
  using assms unfolding Refl_Rel_def by blast

lemma Refl_Rel_selfI [intro]:
  assumes "R x x"
  shows "R\<^sup>\<oplus> x x"
  using assms by blast

lemma Refl_RelE [elim]:
  assumes "R\<^sup>\<oplus> x y"
  obtains "R x x" "R y y" "R x y"
  using assms unfolding Refl_Rel_def by blast

lemma Refl_Rel_reflexive_on_in_field [iff]:
  "reflexive_on (in_field R\<^sup>\<oplus>) R\<^sup>\<oplus>"
  by (rule reflexive_onI) auto

lemma Refl_Rel_le_self [iff]: "R\<^sup>\<oplus> \<le> R" by blast

lemma Refl_Rel_eq_self_if_reflexive_on [simp]:
  assumes "reflexive_on (in_field R) R"
  shows "R\<^sup>\<oplus> = R"
  using assms by blast

lemma reflexive_on_in_field_if_Refl_Rel_eq_self:
  assumes "R\<^sup>\<oplus> = R"
  shows "reflexive_on (in_field R) R"
  by (fact Refl_Rel_reflexive_on_in_field[of R, simplified assms])

corollary Refl_Rel_eq_self_iff_reflexive_on:
  "R\<^sup>\<oplus> = R \<longleftrightarrow> reflexive_on (in_field R) R"
  using Refl_Rel_eq_self_if_reflexive_on reflexive_on_in_field_if_Refl_Rel_eq_self
  by blast

lemma Refl_Rel_Refl_Rel_eq [simp]: "(R\<^sup>\<oplus>)\<^sup>\<oplus> = R\<^sup>\<oplus>"
  by (intro ext) auto

lemma rel_inv_Refl_Rel_eq [simp]: "(R\<^sup>\<oplus>)\<inverse> = (R\<inverse>)\<^sup>\<oplus>"
  by (intro ext iffI Refl_RelI rel_invI) auto

lemma Refl_Rel_transitive_onI [intro]:
  assumes "transitive_on (P :: 'a \<Rightarrow> bool) (R :: 'a \<Rightarrow> _)"
  shows "transitive_on P R\<^sup>\<oplus>"
  using assms by (intro transitive_onI) (blast dest: transitive_onD)

corollary Refl_Rel_transitiveI [intro]:
  assumes "transitive R"
  shows "transitive R\<^sup>\<oplus>"
  using assms by blast

corollary Refl_Rel_preorder_onI:
  assumes "transitive_on P R"
  and "P \<le> in_field R\<^sup>\<oplus>"
  shows "preorder_on P R\<^sup>\<oplus>"
  using assms by (intro preorder_onI
    reflexive_on_if_le_pred_if_reflexive_on[where ?P="in_field R\<^sup>\<oplus>" and ?P'=P])
  auto

corollary Refl_Rel_preorder_on_in_fieldI [intro]:
  assumes "transitive R"
  shows "preorder_on (in_field R\<^sup>\<oplus>) R\<^sup>\<oplus>"
  using assms by (intro Refl_Rel_preorder_onI) auto

lemma Refl_Rel_symmetric_onI [intro]:
  assumes "symmetric_on (P :: 'a \<Rightarrow> bool) (R :: 'a \<Rightarrow> _)"
  shows "symmetric_on P R\<^sup>\<oplus>"
  using assms by (intro symmetric_onI) (auto dest: symmetric_onD)

lemma Refl_Rel_symmetricI [intro]:
  assumes "symmetric R"
  shows "symmetric R\<^sup>\<oplus>"
  using assms by (fold symmetric_on_in_field_iff_symmetric)
  (blast intro: symmetric_on_if_le_pred_if_symmetric_on)

lemma Refl_Rel_partial_equivalence_rel_onI [intro]:
  assumes "partial_equivalence_rel_on (P :: 'a \<Rightarrow> bool) (R :: 'a \<Rightarrow> _)"
  shows "partial_equivalence_rel_on P R\<^sup>\<oplus>"
  using assms by (intro partial_equivalence_rel_onI Refl_Rel_transitive_onI
    Refl_Rel_symmetric_onI) auto

lemma Refl_Rel_partial_equivalence_relI [intro]:
  assumes "partial_equivalence_rel R"
  shows "partial_equivalence_rel R\<^sup>\<oplus>"
  using assms
  by (intro partial_equivalence_relI Refl_Rel_transitiveI Refl_Rel_symmetricI) auto

lemma Refl_Rel_app_leftI:
  assumes "R (f x) y"
  and "in_field S\<^sup>\<oplus> x"
  and "in_field R\<^sup>\<oplus> y"
  and "(S \<Rrightarrow>\<^sub>m R) f"
  shows "R\<^sup>\<oplus> (f x) y"
proof (rule Refl_RelI)
  from \<open>in_field R\<^sup>\<oplus> y\<close> show "R y y" by blast
  from \<open>in_field S\<^sup>\<oplus> x\<close> have "S x x" by blast
  with \<open>(S \<Rrightarrow>\<^sub>m R) f\<close> show "R (f x) (f x)" by blast
qed fact

corollary Refl_Rel_app_rightI:
  assumes "R x (f y)"
  and "in_field S\<^sup>\<oplus> y"
  and "in_field R\<^sup>\<oplus> x"
  and "(S \<Rrightarrow>\<^sub>m R) f"
  shows "R\<^sup>\<oplus> x (f y)"
proof -
  from assms have "(R\<inverse>)\<^sup>\<oplus> (f y) x" by (intro Refl_Rel_app_leftI[where ?S="S\<inverse>"])
    (auto simp flip: rel_inv_Refl_Rel_eq)
  then show ?thesis by blast
qed

lemma mono_wrt_rel_Refl_Rel_Refl_Rel_if_mono_wrt_rel [intro]:
  assumes "(R \<Rrightarrow>\<^sub>m S) f"
  shows "(R\<^sup>\<oplus> \<Rrightarrow>\<^sub>m S\<^sup>\<oplus>) f"
  using assms by (intro dep_mono_wrt_relI) auto

context galois
begin

interpretation gR : galois "(\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus>" "(\<le>\<^bsub>R\<^esub>)\<^sup>\<oplus>" l r .

lemma Galois_Refl_RelI:
  assumes "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "in_field (\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus> x"
  and "in_field (\<le>\<^bsub>R\<^esub>)\<^sup>\<oplus> y"
  and "in_codom (\<le>\<^bsub>R\<^esub>) y \<Longrightarrow> x \<^bsub>L\<^esub>\<lessapprox> y"
  shows "(galois_rel.Galois ((\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus>) ((\<le>\<^bsub>R\<^esub>)\<^sup>\<oplus>) r) x y"
  using assms by (intro gR.GaloisI in_codomI Refl_Rel_app_rightI[where ?f=r])
  auto

lemma half_galois_prop_left_Refl_Rel_left_rightI:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "((\<le>\<^bsub>L\<^esub>) \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)) l r"
  shows "((\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus> \<^sub>h\<unlhd> (\<le>\<^bsub>R\<^esub>)\<^sup>\<oplus>) l r"
  using assms
  by (intro gR.half_galois_prop_leftI Refl_RelI) (auto elim!: in_codomE)

interpretation flip_inv : galois "(\<ge>\<^bsub>R\<^esub>)" "(\<ge>\<^bsub>L\<^esub>)" r l
  rewrites "((\<ge>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<ge>\<^bsub>L\<^esub>)) \<equiv> ((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>))"
  and "\<And>R. (R\<inverse>)\<^sup>\<oplus> \<equiv> (R\<^sup>\<oplus>)\<inverse>"
  and "\<And>R S f g. (R\<inverse> \<^sub>h\<unlhd> S\<inverse>) f g \<equiv> (S \<unlhd>\<^sub>h R) g f"
  by (simp_all add: galois_prop.half_galois_prop_left_rel_inv_iff_half_galois_prop_right)

lemma half_galois_prop_right_Refl_Rel_right_leftI:
  assumes "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "((\<le>\<^bsub>L\<^esub>) \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)) l r"
  shows "((\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus> \<unlhd>\<^sub>h (\<le>\<^bsub>R\<^esub>)\<^sup>\<oplus>) l r"
  using assms by (fact flip_inv.half_galois_prop_left_Refl_Rel_left_rightI)

corollary galois_prop_Refl_Rel_left_rightI:
  assumes "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  shows "((\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus> \<unlhd> (\<le>\<^bsub>R\<^esub>)\<^sup>\<oplus>) l r"
  using assms
  by (intro gR.galois_propI half_galois_prop_left_Refl_Rel_left_rightI
    half_galois_prop_right_Refl_Rel_right_leftI) auto

lemma galois_connection_Refl_Rel_left_rightI:
  assumes "((\<le>\<^bsub>L\<^esub>) \<stileturn> (\<le>\<^bsub>R\<^esub>)) l r"
  shows "((\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus> \<stileturn> (\<le>\<^bsub>R\<^esub>)\<^sup>\<oplus>) l r"
  using assms
  by (intro gR.galois_connectionI galois_prop_Refl_Rel_left_rightI) auto

lemma galois_equivalence_Refl_RelI:
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)) l r"
  shows "((\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus> \<equiv>\<^sub>G (\<le>\<^bsub>R\<^esub>)\<^sup>\<oplus>) l r"
proof -
  interpret flip : galois R L r l .
  show ?thesis using assms by (intro gR.galois_equivalenceI
    galois_connection_Refl_Rel_left_rightI flip.galois_prop_Refl_Rel_left_rightI)
  auto
qed

end

context order_functors
begin

lemma inflationary_on_in_field_Refl_Rel_left:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "inflationary_on (in_dom (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>) \<eta>"
  shows "inflationary_on (in_field (\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus>) (\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus> \<eta>"
  using assms
  by (intro inflationary_onI Refl_RelI) (auto elim!: in_fieldE Refl_RelE)

lemma inflationary_on_in_field_Refl_Rel_left':
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "inflationary_on (in_codom (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>) \<eta>"
  shows "inflationary_on (in_field (\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus>) (\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus> \<eta>"
  using assms
  by (intro inflationary_onI Refl_RelI) (auto elim!: in_fieldE Refl_RelE)

interpretation inv : galois "(\<ge>\<^bsub>L\<^esub>)" "(\<ge>\<^bsub>R\<^esub>)" l r
  rewrites "((\<ge>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<ge>\<^bsub>R\<^esub>)) \<equiv> ((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>))"
  and "((\<ge>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<ge>\<^bsub>L\<^esub>)) \<equiv> ((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>))"
  and "\<And>R. (R\<inverse>)\<^sup>\<oplus> \<equiv> (R\<^sup>\<oplus>)\<inverse>"
  and "\<And>R. in_dom R\<inverse> \<equiv> in_codom R"
  and "\<And>R. in_codom R\<inverse> \<equiv> in_dom R"
  and "\<And>R. in_field R\<inverse> \<equiv> in_field R"
  and "\<And>P R. inflationary_on P R\<inverse> \<equiv> deflationary_on P R"
  by simp_all

lemma deflationary_on_in_field_Refl_Rel_leftI:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "deflationary_on (in_dom (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>) \<eta>"
  shows "deflationary_on (in_field (\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus>) (\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus> \<eta>"
  using assms by (fact inv.inflationary_on_in_field_Refl_Rel_left')

lemma deflationary_on_in_field_Refl_RelI_left':
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "deflationary_on (in_codom (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>) \<eta>"
  shows "deflationary_on (in_field (\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus>) (\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus> \<eta>"
  using assms by (fact inv.inflationary_on_in_field_Refl_Rel_left)

lemma rel_equivalence_on_in_field_Refl_Rel_leftI:
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "rel_equivalence_on (in_dom (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>) \<eta>"
  shows "rel_equivalence_on (in_field (\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus>) (\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus> \<eta>"
  using assms by (intro rel_equivalence_onI
    inflationary_on_in_field_Refl_Rel_left
    deflationary_on_in_field_Refl_Rel_leftI)
  auto

lemma rel_equivalence_on_in_field_Refl_Rel_leftI':
  assumes "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  and "((\<le>\<^bsub>R\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>L\<^esub>)) r"
  and "rel_equivalence_on (in_codom (\<le>\<^bsub>L\<^esub>)) (\<le>\<^bsub>L\<^esub>) \<eta>"
  shows "rel_equivalence_on (in_field (\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus>) (\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus> \<eta>"
  using assms by (intro rel_equivalence_onI
    inflationary_on_in_field_Refl_Rel_left'
    deflationary_on_in_field_Refl_RelI_left')
  auto

interpretation oR : order_functors "(\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus>" "(\<le>\<^bsub>R\<^esub>)\<^sup>\<oplus>" l r .

lemma order_equivalence_Refl_RelI:
  assumes "((\<le>\<^bsub>L\<^esub>) \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)) l r"
  shows "((\<le>\<^bsub>L\<^esub>)\<^sup>\<oplus> \<equiv>\<^sub>o (\<le>\<^bsub>R\<^esub>)\<^sup>\<oplus>) l r"
proof -
  interpret flip : galois R L r l
    rewrites "flip.unit \<equiv> \<epsilon>"
    by (simp only: flip_unit_eq_counit)
  show ?thesis using assms by (intro oR.order_equivalenceI
    mono_wrt_rel_Refl_Rel_Refl_Rel_if_mono_wrt_rel
    rel_equivalence_on_in_field_Refl_Rel_leftI
    flip.rel_equivalence_on_in_field_Refl_Rel_leftI)
    (auto intro: rel_equivalence_on_if_le_pred_if_rel_equivalence_on
      in_field_if_in_dom)
qed

end

end


(* Title:      Demonic refinement algebra
   Author:     Alasdair Armstrong, Victor B. F. Gomes, Georg Struth
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
*)

section \<open>Demonic Refinement Algebra with Tests\<close>

theory DRAT
  imports KAT Kleene_Algebra.DRA
begin

text \<open>
  In this section, we define demonic refinement algebras with tests and prove the most important theorems from
  the literature. In this context, tests are also known as guards.
\<close>

class drat = dra + test_semiring_zerol
begin

subclass kat_zerol ..

text \<open>
  An assertion is a mapping from a guard to a subset similar to tests, but it aborts if the predicate does
  not hold.
\<close>

definition assertion :: "'a \<Rightarrow> 'a" ("_\<^sup>o" [101] 100) where
  "test p \<Longrightarrow> p\<^sup>o = !p\<cdot>\<top> + 1"

lemma asg: "\<lbrakk>test p; test q\<rbrakk> \<Longrightarrow> q \<le> 1 \<and> 1 \<le> p\<^sup>o"
  by (simp add: assertion_def local.test_subid)

lemma assertion_isol: "test p \<Longrightarrow> y \<le> p\<^sup>o\<cdot>x \<longleftrightarrow> p\<cdot>y \<le> x"
proof
  assume assms: "test p" "y \<le> p\<^sup>o\<cdot>x"
  hence "p\<cdot>y \<le> p\<cdot>!p\<cdot>\<top>\<cdot>x + p\<cdot>x"
    by (metis add_commute assertion_def local.distrib_left local.iteration_prod_unfold local.iteration_unfoldl_distr local.mult_isol local.top_mult_annil mult_assoc)
  also have "... \<le> x"
    by (simp add: assms(1) local.test_restrictl)
  finally show "p\<cdot>y \<le> x"
    by metis
next
  assume assms: "test p" "p\<cdot>y \<le> x"
  hence "p\<^sup>o\<cdot>p\<cdot>y = !p\<cdot>\<top>\<cdot>p\<cdot>y + p\<cdot>y"
    by (metis assertion_def distrib_right' mult_1_left mult.assoc)
  also have "... = !p\<cdot>\<top> + p\<cdot>y"
    by (metis mult.assoc top_mult_annil)
  moreover have "p\<^sup>o\<cdot>p\<cdot>y \<le> p\<^sup>o\<cdot>x"
    by (metis assms(2) mult.assoc mult_isol)
  moreover have "!p\<cdot>y + p\<cdot>y \<le> !p\<cdot>\<top> + p\<cdot>y"
    using local.add_iso local.top_elim by blast
  ultimately show "y \<le> p\<^sup>o\<cdot>x"
    by (metis add.commute assms(1) distrib_right' mult_1_left order_trans test_add_comp)
qed

lemma assertion_isor: "test p \<Longrightarrow> y \<le> x\<cdot>p \<longleftrightarrow> y\<cdot>p\<^sup>o \<le> x"
proof
  assume assms: "test p" "y \<le> x\<cdot>p"
  hence "y\<cdot>p\<^sup>o \<le> x\<cdot>p\<cdot>!p\<cdot>\<top> + x\<cdot>p"
    by (metis mult_isor assertion_def assms(1) distrib_left mult_1_right mult.assoc)
  also have "... \<le> x"
    by (metis assms(1) local.iteration_idep local.join.sup.absorb_iff1 local.join.sup_commute local.join.sup_ge2 local.mult_1_right local.mult_isol_var local.mult_isor local.mult_onel local.test_add_comp local.test_comp_mult2 mult_assoc)
  finally show "y\<cdot>p\<^sup>o \<le> x"
    by metis
next
  assume assms: "test p" "y\<cdot>p\<^sup>o \<le> x"
  have "y \<le> y\<cdot>(!p\<cdot>\<top> + p)"
    by (metis join.sup_mono mult_isol order_refl order_refl top_elim add.commute assms(1) mult_1_right test_add_comp)
  also have "... = y\<cdot>p\<^sup>o\<cdot>p"
    by (metis assertion_def assms(1) distrib_right' mult_1_left mult.assoc top_mult_annil)
  finally show "y \<le> x\<cdot>p"
    by (metis assms(2) mult_isor order_trans)
qed

lemma assertion_iso: "\<lbrakk>test p; test q\<rbrakk> \<Longrightarrow> x\<cdot>q\<^sup>o \<le> p\<^sup>o\<cdot>x \<longleftrightarrow> p\<cdot>x \<le> x\<cdot>q"
  by (metis assertion_isol assertion_isor mult.assoc)

lemma total_correctness: "\<lbrakk>test p; test q\<rbrakk> \<Longrightarrow> p\<cdot>x\<cdot>!q = 0 \<longleftrightarrow> x\<cdot>!q \<le> !p\<cdot>\<top>"
  apply standard
  apply (metis local.test_eq4 local.top_elim mult_assoc)
  by (metis annil antisym test_comp_mult2 join.bot_least mult_assoc mult_isol)

lemma test_iteration_annir: "test p \<Longrightarrow> !p\<cdot>(p\<cdot>x)\<^sup>\<infinity> = !p"
  by (metis annil test_comp_mult1 iteration_idep mult.assoc)

text \<open>Next we give an example of a program transformation from von Wright~\cite{Wright02}.\<close>

lemma loop_refinement: "\<lbrakk>test p; test q\<rbrakk> \<Longrightarrow> (p\<cdot>x)\<^sup>\<infinity>\<cdot>!p \<le> (p\<cdot>q\<cdot>x)\<^sup>\<infinity>\<cdot>!(p\<cdot>q)\<cdot>(p\<cdot>x)\<^sup>\<infinity>\<cdot>!p"
proof -
  assume assms: "test p" "test q"
  hence "(p\<cdot>x)\<^sup>\<infinity>\<cdot>!p = ((p\<cdot>q) + !(p\<cdot>q))\<cdot>(p\<cdot>x)\<^sup>\<infinity>\<cdot>!p"
    by (simp add: local.test_mult_closed)
  also have "... = (p\<cdot>q)\<cdot>(p\<cdot>x)\<^sup>\<infinity>\<cdot>!p + !(p\<cdot>q)\<cdot>(p\<cdot>x)\<^sup>\<infinity>\<cdot>!p"
    by (metis distrib_right')
  also have "... = (p\<cdot>q)\<cdot>!p + (p\<cdot>q)\<cdot>(p\<cdot>x)\<cdot>(p\<cdot>x)\<^sup>\<infinity>\<cdot>!p + !(p\<cdot>q)\<cdot>(p\<cdot>x)\<^sup>\<infinity>\<cdot>!p"
    by (metis iteration_unfoldr_distr mult.assoc iteration_unfold_eq distrib_left mult.assoc)
  also have "... = (p\<cdot>q)\<cdot>(p\<cdot>x)\<cdot>(p\<cdot>x)\<^sup>\<infinity>\<cdot>!p + !(p\<cdot>q)\<cdot>(p\<cdot>x)\<^sup>\<infinity>\<cdot>!p"
    by (metis assms less_eq_def test_preserve2 join.bot_least)
  finally have "(p\<cdot>x)\<^sup>\<infinity>\<cdot>!p \<le> p\<cdot>q\<cdot>x\<cdot>(p\<cdot>x)\<^sup>\<infinity>\<cdot>!p + !(p\<cdot>q)\<cdot>(p\<cdot>x)\<^sup>\<infinity>\<cdot>!p"
    by (metis assms(1) assms(2) local.eq_iff local.test_mult_comm_var local.test_preserve mult_assoc)
  thus ?thesis
    by (metis coinduction add.commute mult.assoc)
qed

text \<open>Finally, we prove different versions of Back's atomicity refinement theorem for action systems.\<close>

lemma atom_step1: "r\<cdot>b \<le> b\<cdot>r \<Longrightarrow> (a + b + r)\<^sup>\<infinity> = b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity>"
  apply (subgoal_tac "(a + b + r)\<^sup>\<infinity> = (b + r)\<^sup>\<infinity>\<cdot>(a\<cdot>(b + r)\<^sup>\<infinity>)\<^sup>\<infinity>")
  apply (metis iteration_sep mult.assoc)
  by (metis add_assoc' add.commute iteration_denest)

lemma atom_step2:
  assumes "s = s\<cdot>q" "q\<cdot>b = 0" "r\<cdot>q \<le> q\<cdot>r" "q\<cdot>l \<le> l\<cdot>q" "r\<^sup>\<infinity> = r\<^sup>\<star>" "test q"
  shows "s\<cdot>l\<^sup>\<infinity>\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q)\<^sup>\<infinity> \<le> s\<cdot>l\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity>"
proof -
  have "s\<cdot>l\<^sup>\<infinity>\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q)\<^sup>\<infinity> \<le> s\<cdot>l\<^sup>\<infinity>\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity>"
    by (metis assms(3) assms(5) star_sim1 mult.assoc mult_isol iteration_iso)
  also have "... \<le> s\<cdot>q\<cdot>l\<^sup>\<infinity>\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity>"
    using assms(1) assms(6) local.mult_isor local.test_restrictr by auto
  also have "... \<le> s\<cdot>l\<^sup>\<infinity>\<cdot>q\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity>"
    by (metis assms(4) iteration_sim mult.assoc mult_double_iso mult_double_iso)
  also have "... \<le> s\<cdot>l\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity>"
    by (metis assms(2) join.bot_least iteration_sim mult.assoc mult_double_iso)
  also have "... \<le> s\<cdot>l\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity>"
    by (metis assms(6) mult.assoc mult_isol test_restrictl iteration_idem mult.assoc)
  finally show "s\<cdot>l\<^sup>\<infinity>\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q)\<^sup>\<infinity> \<le> s\<cdot>l\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity>"
    by metis
qed

lemma atom_step3:
  assumes "r\<cdot>l \<le> l\<cdot>r" "a\<cdot>l \<le> l\<cdot>a" "b\<cdot>l \<le> l\<cdot>b" "q\<cdot>l \<le> l\<cdot>q" "b\<^sup>\<infinity> = b\<^sup>\<star>"
  shows "l\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity> = (a\<cdot>b\<^sup>\<infinity>\<cdot>q + l + r)\<^sup>\<infinity>"
proof -
  have "(a\<cdot>b\<^sup>\<infinity>\<cdot>q + r)\<cdot>l \<le> a\<cdot>b\<^sup>\<infinity>\<cdot>l\<cdot>q + l\<cdot>r"
    by (metis distrib_right join.sup_mono assms(1,4) mult.assoc mult_isol)
  also have "... \<le> a\<cdot>l\<cdot>b\<^sup>\<infinity>\<cdot>q + l\<cdot>r"
    by (metis assms(3) assms(5) star_sim1 add_iso mult.assoc mult_double_iso)
  also have "... \<le> l\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q + r)"
    by (metis add_iso assms(2) mult_isor distrib_left mult.assoc)
  finally have "(a\<cdot>b\<^sup>\<infinity>\<cdot>q + r)\<cdot>l \<le> l\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q + r)"
    by metis
  moreover have "l\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity> = l\<^sup>\<infinity>\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q + r)\<^sup>\<infinity>"
    by (metis add.commute mult.assoc iteration_denest)
  ultimately show ?thesis
    by (metis add.commute add.left_commute iteration_sep)
qed

text \<open>
  This is Back's atomicity refinement theorem, as specified by von Wright~\cite {Wright02}.
\<close>

theorem atom_ref_back:
  assumes "s = s\<cdot>q" "a = q\<cdot>a" "q\<cdot>b = 0"
          "r\<cdot>b \<le> b\<cdot>r" "r\<cdot>l \<le> l\<cdot>r" "r\<cdot>q \<le> q\<cdot>r"
          "a\<cdot>l \<le> l\<cdot>a" "b\<cdot>l \<le> l\<cdot>b" "q\<cdot>l \<le> l\<cdot>q"
          "r\<^sup>\<infinity> = r\<^sup>\<star>" "b\<^sup>\<infinity> = b\<^sup>\<star>" "test q"
  shows "s\<cdot>(a + b + r + l)\<^sup>\<infinity>\<cdot>q \<le> s\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q + r + l)\<^sup>\<infinity>"
proof -
  have "(a + b + r)\<cdot>l \<le> l\<cdot>(a + b + r)"
    by (metis join.sup_mono distrib_right' assms(5) assms(7) assms(8) distrib_left)
  hence "s\<cdot>(l + a + b + r)\<^sup>\<infinity>\<cdot>q = s\<cdot>l\<^sup>\<infinity>\<cdot>(a + b + r)\<^sup>\<infinity>\<cdot>q"
    by (metis add.commute add.left_commute mult.assoc iteration_sep)
  also have "... \<le> s\<cdot>l\<^sup>\<infinity>\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q)\<^sup>\<infinity>"
    by (metis assms(2,4,10,11) atom_step1 iteration_slide eq_refl mult.assoc)
  also have "... \<le> s\<cdot>l\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity>"
    by (metis assms(1) assms(10) assms(12) assms(3) assms(6) assms(9) atom_step2)
  also have "... \<le> s\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q + l + r)\<^sup>\<infinity>"
    by (metis assms(11) assms(5) assms(7) assms(8) assms(9) atom_step3 eq_refl mult.assoc)
  finally show ?thesis
    by (metis add.commute add.left_commute)
qed

text \<open>
  This variant is due to H\"ofner, Struth and Sutcliffe~\cite{HofnerSS09}.
\<close>

theorem atom_ref_back_struth:
  assumes "s \<le> s\<cdot>q" "a \<le> q\<cdot>a" "q\<cdot>b = 0"
          "r\<cdot>b \<le> b\<cdot>r" "r\<cdot>q \<le> q\<cdot>r"
          "(a + r + b)\<cdot>l \<le> l\<cdot>(a + r + b)" "q\<cdot>l \<le> l\<cdot>q"
          "r\<^sup>\<infinity> = r\<^sup>\<star>" "q \<le> 1"
  shows "s\<cdot>(a + b + r + l)\<^sup>\<infinity>\<cdot>q \<le> s\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q + r + l)\<^sup>\<infinity>"
proof -
  have "s\<cdot>(a + b + r + l)\<^sup>\<infinity>\<cdot>q = s\<cdot>l\<^sup>\<infinity>\<cdot>(a + b + r)\<^sup>\<infinity>\<cdot>q"
    by (metis add.commute add.left_commute assms(6) iteration_sep mult.assoc)
  also have "... = s\<cdot>l\<^sup>\<infinity>\<cdot>(b + r)\<^sup>\<infinity>\<cdot>(a\<cdot>(b + r)\<^sup>\<infinity>)\<^sup>\<infinity>\<cdot>q"
    by (metis add_assoc' add.commute iteration_denest add.commute mult.assoc)
  also have "... = s\<cdot>l\<^sup>\<infinity>\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity>\<cdot>q"
    by (metis assms(4) iteration_sep mult.assoc)
  also have "... \<le> s\<cdot>l\<^sup>\<infinity>\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>(q\<cdot>a\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity>\<cdot>q"
    by (metis assms(2) iteration_iso mult_isol_var eq_refl order_refl)
  also have "... = s\<cdot>l\<^sup>\<infinity>\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q)\<^sup>\<infinity>"
    by (metis iteration_slide mult.assoc)
  also have "... \<le> s\<cdot>q\<cdot>l\<^sup>\<infinity>\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q)\<^sup>\<infinity>"
    by (metis assms(1) mult_isor)
  also have "... \<le> s\<cdot>l\<^sup>\<infinity>\<cdot>q\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q)\<^sup>\<infinity>"
    by (metis assms(7) iteration_sim mult.assoc mult_double_iso)
  also have "... \<le> s\<cdot>l\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>\<cdot>q\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q)\<^sup>\<infinity>"
    by (metis assms(3) iteration_idep mult.assoc order_refl)
  also have "... \<le> s\<cdot>l\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>\<cdot>q\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>r\<^sup>\<star>\<cdot>q)\<^sup>\<infinity>"
    by (metis assms(8) eq_refl)
  also have "... \<le> s\<cdot>l\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>\<cdot>q\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<star>)\<^sup>\<infinity>"
    by (metis assms(5) iteration_iso mult.assoc mult_isol star_sim1)
  also have "... = s\<cdot>l\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>\<cdot>q\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity>"
    by (metis assms(8))
  also have "... \<le> s\<cdot>l\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>q\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity>"
    by (metis assms(9) mult_1_right mult_double_iso mult_isor)
  also have "... \<le> s\<cdot>l\<^sup>\<infinity>\<cdot>r\<^sup>\<infinity>\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q\<cdot>r\<^sup>\<infinity>)\<^sup>\<infinity>"
    by (metis assms(9) mult_1_right mult_double_iso)
  also have "... = s\<cdot>l\<^sup>\<infinity>\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q + r)\<^sup>\<infinity>"
    by (metis add.commute mult.assoc iteration_denest)
  also have "... \<le> s\<cdot>(a\<cdot>b\<^sup>\<infinity>\<cdot>q + r + l)\<^sup>\<infinity>"
    by (metis add.commute iteration_subdenest mult.assoc mult_isol)
  finally show ?thesis .
qed

text \<open>Finally, we prove Cohen's~\cite{Cohen00} variation of the atomicity refinement theorem.\<close>

lemma atom_ref_cohen:
  assumes "r\<cdot>p\<cdot>y \<le> y\<cdot>r" "y\<cdot>p\<cdot>l \<le> l\<cdot>y" "r\<cdot>p\<cdot>l \<le> l\<cdot>r"
          "p\<cdot>r\<cdot>!p = 0" "p\<cdot>l\<cdot>!p = 0" "!p\<cdot>l\<cdot>p = 0"
          "y\<cdot>0 = 0" "r\<cdot>0 = 0" "test p"
  shows "(y + r + l)\<^sup>\<infinity> = (p\<cdot>l)\<^sup>\<infinity>\<cdot>(y + !p\<cdot>l + r\<cdot>!p)\<^sup>\<infinity>\<cdot>(r\<cdot>p)\<^sup>\<infinity>"
proof -
  have "(y + r)\<cdot>p\<cdot>l \<le> l\<cdot>y + l\<cdot>r"
    by (metis distrib_right' join.sup_mono assms(2) assms(3))
  hence stepA: "(y + r)\<cdot>p\<cdot>l \<le> (p\<cdot>l + !p\<cdot>l)\<cdot>(y + r)\<^sup>\<star>"
    by (metis assms(9) distrib_left distrib_right' mult_1_left mult_isol order_trans star_ext test_add_comp)
  have subStepB: "(!p\<cdot>l + y + p\<cdot>r + !p\<cdot>r)\<^sup>\<infinity> = (!p\<cdot>l + y + r\<cdot>p + r\<cdot>!p)\<^sup>\<infinity>"
    by (metis add_assoc' annil assms(8) assms(9) distrib_left distrib_right' star_slide star_subid test_add_comp join.bot_least)
  have "r\<cdot>p\<cdot>(y + r\<cdot>!p + !p\<cdot>l) \<le> y\<cdot>(r\<cdot>p + r\<cdot>!p)"
    by (metis assms(1,4,9) distrib_left add_0_left add.commute annil mult.assoc test_comp_mult2 distrib_left mult_oner test_add_comp)
  also have "... \<le> (y + r\<cdot>!p + !p\<cdot>l)\<cdot>(r\<cdot>p + (y + r\<cdot>!p + !p\<cdot>l))"
    by (meson local.eq_refl local.join.sup_ge1 local.join.sup_ge2 local.join.sup_mono local.mult_isol_var local.order_trans)
  finally have "r\<cdot>p\<cdot>(y + r\<cdot>!p + !p\<cdot>l) \<le> (y + r\<cdot>!p + !p\<cdot>l)\<cdot>(y + r\<cdot>!p + !p\<cdot>l + r\<cdot>p)"
    by (metis add.commute)
  hence stepB: "(!p\<cdot>l + y + p\<cdot>r + !p\<cdot>r)\<^sup>\<infinity> = (y + !p\<cdot>l + r\<cdot>!p)\<^sup>\<infinity>\<cdot>(r\<cdot>p)\<^sup>\<infinity>"
    by (metis subStepB iteration_sep3[of "r\<cdot>p" "y + r\<cdot>!p + !p\<cdot>l"]  add_assoc' add.commute)
  have "(y + r + l)\<^sup>\<infinity> = (p\<cdot>l + !p\<cdot>l + y + r)\<^sup>\<infinity>"
    by (metis add_comm add.left_commute assms(9) distrib_right' mult_onel test_add_comp)
  also have "... = (p\<cdot>l)\<^sup>\<infinity>\<cdot>(!p\<cdot>l + y + r)\<^sup>\<infinity>" using stepA
    by (metis assms(6-8) annil add.assoc add_0_left distrib_right' add.commute mult.assoc iteration_sep4[of "y+r" "!p\<cdot>l" "p\<cdot>l"])
  also have "... = (p\<cdot>l)\<^sup>\<infinity>\<cdot>(!p\<cdot>l + y + p\<cdot>r + !p\<cdot>r)\<^sup>\<infinity>"
    by (metis add.commute assms(9) combine_common_factor mult_1_left test_add_comp)
  finally show ?thesis using stepB
    by (metis mult.assoc)
qed
end

end


theory Chapter16_5_Abbreviation
imports Chapter16_4_Evaluation
begin

definition Nat :: type
where "Nat = Rec (Sum Unit (Tyvar first))"

definition Zero :: expr
where "Zero = Fold (Sum Unit (Tyvar first)) (InL Unit Nat Triv)"

definition Suc :: "expr => expr"
where "Suc e = Fold (Sum Unit (Tyvar first)) (InR Unit Nat e)"

definition IsZ :: "expr => expr => expr => expr"
where "IsZ et e0 es = Case (Unfold et) (insert first e0) es"

lemma [simp]: "eval e e' ==> eval (Suc e) (Suc e')"
by (simp add: Suc_def)
lemma [simp]: "eval et et' ==> eval (IsZ et e0 es) (IsZ et' e0 es)"
by (simp add: IsZ_def)
lemma [simp]: "EX e'. eval (IsZ Zero e0 es) e' & eval e' e0"
proof (simp add: IsZ_def Zero_def)
  have "eval (Case (InL Unit Nat Triv) (insert first e0) es) (subst Triv first (insert first e0))"
  by (metis eval_case_2 is_val.simps(4))
  thus "EX e'. eval (Case (Unfold (Fold (Sum Unit (Tyvar first)) (InL Unit Nat Triv)))
                          (insert first e0) es) e' &
         eval e' e0 " by force
qed

lemma [simp]: "is_val et ==> EX e'. eval (IsZ (Suc et) e0 es) e' & eval e' (subst et first es)"
by (metis Suc_def IsZ_def eval_case_1 eval_case_3 eval_unfold_2 is_val.simps(11))

lemma canonical_nat_like: "typecheck env e t ==> is_val e ==>
    (t = Nat --> e = Zero | (EX v. typecheck env v Nat & is_val v & e = Suc v)) &
    (t = Sum Unit Nat --> e = InL Unit Nat Triv |
              (EX v. typecheck env v Nat & is_val v & e = InR Unit Nat v))"
proof (induction env e t rule: typecheck.induct)
case tc_var
  thus ?case by simp
next case tc_lam
  thus ?case by (simp add: Nat_def)
next case tc_appl
  thus ?case by simp
next case tc_triv
  thus ?case by (simp add: Nat_def)
next case tc_pair
  thus ?case by (simp add: Nat_def)
next case tc_projl
  thus ?case by simp
next case tc_projr
  thus ?case by simp
next case tc_abort
  thus ?case by simp
next case tc_case
  thus ?case by simp
next case (tc_inl gam e t1 t2)
  with canonical_unit have "t1 = Unit ==> e = Triv" by force
  thus ?case by (simp add: Nat_def canonical_unit)
next case (tc_inr gam e t1 t2)
  hence "t1 = Rec (Sum Unit (Tyvar first)) ==>
            typecheck gam e (Rec (Sum Unit (Tyvar first)))" by fast
  with tc_inr show ?case by (simp add: Nat_def)
next case tc_fix
  thus ?case by simp
next case (tc_fold gam e t)
  thus ?case by (auto simp add: Nat_def Zero_def Suc_def type_subst_def)
next case tc_unfold
  thus ?case by simp
qed

lemma canonical_nat: "is_val e ==> typecheck env e Nat ==>
            e = Zero | (EX v. typecheck env v Nat & is_val v & e = Suc v)"
by (simp add: canonical_nat_like)

end