(*
  Title:  Example Completeness Proof for a Propositional Tableau Calculus
  Author: Asta Halkjær From
*)

chapter \<open>Example: Propositional Tableau Calculus\<close>

theory Example_Propositional_Tableau imports Refutations begin

section \<open>Syntax\<close>

datatype 'p fm
  = Pro 'p (\<open>\<^bold>\<ddagger>\<close>)
  | Neg \<open>'p fm\<close> (\<open>\<^bold>\<not> _\<close> [70] 70)
  | Imp \<open>'p fm\<close> \<open>'p fm\<close> (infixr \<open>\<^bold>\<longrightarrow>\<close> 55)

section \<open>Semantics\<close>

type_synonym 'p model = \<open>'p \<Rightarrow> bool\<close>

fun semantics :: \<open>'p model \<Rightarrow> 'p fm \<Rightarrow> bool\<close> (\<open>\<lbrakk>_\<rbrakk>\<close>) where
  \<open>\<lbrakk>I\<rbrakk> (\<^bold>\<ddagger>P) \<longleftrightarrow> I P\<close>
| \<open>\<lbrakk>I\<rbrakk> (\<^bold>\<not> p) \<longleftrightarrow> \<not> \<lbrakk>I\<rbrakk> p\<close>
| \<open>\<lbrakk>I\<rbrakk> (p \<^bold>\<longrightarrow> q) \<longleftrightarrow> \<lbrakk>I\<rbrakk> p \<longrightarrow> \<lbrakk>I\<rbrakk> q\<close>

section \<open>Calculus\<close>

inductive Calculus :: \<open>'p fm list \<Rightarrow> bool\<close> (\<open>\<turnstile>\<^sub>T _\<close> [50] 50) where
  Axiom [intro]: \<open>\<turnstile>\<^sub>T \<^bold>\<ddagger>P # \<^bold>\<not> \<^bold>\<ddagger>P # A\<close>
| NegI [intro]: \<open>\<turnstile>\<^sub>T p # A \<Longrightarrow> \<turnstile>\<^sub>T \<^bold>\<not> \<^bold>\<not> p # A\<close>
| ImpP [intro]: \<open>\<turnstile>\<^sub>T \<^bold>\<not> p # A \<Longrightarrow> \<turnstile>\<^sub>T q # A \<Longrightarrow> \<turnstile>\<^sub>T (p \<^bold>\<longrightarrow> q) # A\<close>
| ImpN [intro]: \<open>\<turnstile>\<^sub>T p # \<^bold>\<not> q # A \<Longrightarrow> \<turnstile>\<^sub>T \<^bold>\<not> (p \<^bold>\<longrightarrow> q) # A\<close>
| Weaken: \<open>\<turnstile>\<^sub>T A \<Longrightarrow> set A \<subseteq> set B \<Longrightarrow> \<turnstile>\<^sub>T B\<close>

lemma Weaken2:
  assumes \<open>\<turnstile>\<^sub>T p # A\<close> \<open>\<turnstile>\<^sub>T q # B\<close>
  shows \<open>\<turnstile>\<^sub>T p # A @ B \<and> \<turnstile>\<^sub>T q # A @ B\<close>
  using assms Weaken[where A=\<open>_ # _\<close> and B=\<open>_ # A @ B\<close>] by fastforce

section \<open>Soundness\<close>

theorem soundness: \<open>\<turnstile>\<^sub>T A \<Longrightarrow> \<exists>p \<in> set A. \<not> \<lbrakk>I\<rbrakk> p\<close>
  by (induct A rule: Calculus.induct) auto

corollary soundness': \<open>\<turnstile>\<^sub>T [\<^bold>\<not> p] \<Longrightarrow> \<lbrakk>I\<rbrakk> p\<close>
  using soundness by fastforce

corollary \<open>\<not> (\<turnstile>\<^sub>T [])\<close>
  using soundness by fastforce

section \<open>Maximal Consistent Sets\<close>

definition consistent :: \<open>'p fm set \<Rightarrow> bool\<close> where
  \<open>consistent S \<equiv> \<nexists>S'. set S' \<subseteq> S \<and> \<turnstile>\<^sub>T S'\<close>

interpretation MCS_No_Saturation consistent
proof
  fix S S' :: \<open>'p fm set\<close>
  assume \<open>consistent S\<close> \<open>S' \<subseteq> S\<close>
  then show \<open>consistent S'\<close>
    unfolding consistent_def by fast
next
  fix S :: \<open>'p fm set\<close>
  assume \<open>\<not> consistent S\<close>
  then show \<open>\<exists>S'\<subseteq>S. finite S' \<and> \<not> consistent S'\<close>
    unfolding consistent_def by blast
next
  show \<open>infinite (UNIV :: 'p fm set)\<close>
    using infinite_UNIV_size[of \<open>\<lambda>p. p \<^bold>\<longrightarrow> p\<close>] by simp
qed

interpretation Refutations_MCS Calculus consistent
proof
  fix A B :: \<open>'p fm list\<close>
  assume \<open>\<turnstile>\<^sub>T A\<close> \<open>set A \<subseteq> set B\<close>
  then show \<open>\<turnstile>\<^sub>T B\<close>
    using Weaken by meson
next
  fix S :: \<open>'p fm set\<close>
  show \<open>consistent S \<longleftrightarrow> (\<nexists>S'. set S' \<subseteq> S \<and> \<turnstile>\<^sub>T S')\<close>
    unfolding consistent_def ..
qed

section \<open>Truth Lemma\<close>

abbreviation (input) hmodel :: \<open>'p fm set \<Rightarrow> 'p model\<close> where
  \<open>hmodel H \<equiv> \<lambda>P. \<^bold>\<ddagger>P \<in> H\<close>

locale Hintikka =
  fixes H :: \<open>'a fm set\<close>
  assumes AxiomH: \<open>\<And>P. \<^bold>\<ddagger>P \<in> H \<Longrightarrow> \<^bold>\<not> \<^bold>\<ddagger>P \<in> H \<Longrightarrow> False\<close>
    and NegIH: \<open>\<And>p. \<^bold>\<not> \<^bold>\<not> p \<in> H \<Longrightarrow> p \<in> H\<close>
    and ImpPH: \<open>\<And>p q. p \<^bold>\<longrightarrow> q \<in> H \<Longrightarrow> \<^bold>\<not> p \<in> H \<or> q \<in> H\<close>
    and ImpNH: \<open>\<And>p q. \<^bold>\<not> (p \<^bold>\<longrightarrow> q) \<in> H \<Longrightarrow> p \<in> H \<and> \<^bold>\<not> q \<in> H\<close>

lemma Hintikka_model:
  assumes \<open>Hintikka H\<close>
  shows \<open>(p \<in> H \<longrightarrow> \<lbrakk>hmodel H\<rbrakk> p) \<and> (\<^bold>\<not> p \<in> H \<longrightarrow> \<not> \<lbrakk>hmodel H\<rbrakk> p)\<close>
  using assms by (induct p) (unfold Hintikka_def semantics.simps; blast)+

lemma MCS_Hintikka:
  assumes \<open>consistent H\<close> \<open>maximal H\<close>
  shows \<open>Hintikka H\<close>
proof
  fix P
  assume \<open>\<^bold>\<ddagger>P \<in> H\<close> \<open>\<^bold>\<not> \<^bold>\<ddagger>P \<in> H\<close>
  then have \<open>set [\<^bold>\<ddagger>P, \<^bold>\<not> \<^bold>\<ddagger>P] \<subseteq> H\<close>
    by simp
  moreover have \<open>\<turnstile>\<^sub>T [\<^bold>\<ddagger>P, \<^bold>\<not> \<^bold>\<ddagger>P]\<close>
    by blast
  ultimately show False
    using assms unfolding consistent_def by blast
next
  fix p
  assume \<open>\<^bold>\<not> \<^bold>\<not> p \<in> H\<close>
  then show \<open>p \<in> H\<close>
    using assms MCS_refute by blast
next
  fix p q
  assume *: \<open>p \<^bold>\<longrightarrow> q \<in> H\<close>
  show \<open>\<^bold>\<not> p \<in> H \<or> q \<in> H\<close>
  proof (rule ccontr)
    assume \<open>\<not> (\<^bold>\<not> p \<in> H \<or> q \<in> H)\<close>
    then have \<open>\<^bold>\<not> p \<notin> H\<close> \<open>q \<notin> H\<close>
      by blast+
    then have \<open>\<exists>A. set A \<subseteq> H \<and> \<turnstile>\<^sub>T \<^bold>\<not> p # A\<close> \<open>\<exists>A. set A \<subseteq> H \<and> \<turnstile>\<^sub>T q # A\<close>
      using assms MCS_refute by blast+
    then have \<open>\<exists>A. set A \<subseteq> H \<and> \<turnstile>\<^sub>T \<^bold>\<not> p # A \<and> \<turnstile>\<^sub>T q # A\<close>
      using Weaken2[where p=\<open>\<^bold>\<not> p\<close> and q=q] by (metis Un_least set_append)
    then have \<open>\<exists>A. set A \<subseteq> H \<and> \<turnstile>\<^sub>T (p \<^bold>\<longrightarrow> q) # A\<close>
      by blast
    then have \<open>p \<^bold>\<longrightarrow> q \<notin> H\<close>
      using assms unfolding consistent_def by auto
    then show False
      using * ..
  qed
next
  fix p q
  assume *: \<open>\<^bold>\<not> (p \<^bold>\<longrightarrow> q) \<in> H\<close>
  show \<open>p \<in> H \<and> \<^bold>\<not> q \<in> H\<close>
  proof (rule ccontr)
    assume \<open>\<not> (p \<in> H \<and> \<^bold>\<not> q \<in> H)\<close>
    then consider \<open>p \<notin> H\<close> | \<open>\<^bold>\<not> q \<notin> H\<close>
      by blast
    then show False
    proof cases
      case 1
      then have \<open>\<exists>A. set A \<subseteq> H \<and> \<turnstile>\<^sub>T p # A\<close>
        using assms MCS_refute by blast
      then have \<open>\<exists>A. set A \<subseteq> H \<and> \<turnstile>\<^sub>T p # \<^bold>\<not> q # A\<close>
        using Weaken[where B=\<open>p # \<^bold>\<not> q # _\<close>] by fastforce
      then have \<open>\<exists>A. set A \<subseteq> H \<and> \<turnstile>\<^sub>T \<^bold>\<not> (p \<^bold>\<longrightarrow> q) # A\<close>
        by fast
      then have \<open>\<^bold>\<not> (p \<^bold>\<longrightarrow> q) \<notin> H\<close>
        using assms unfolding consistent_def by auto
      then show False
        using * ..
    next
      case 2
      then have \<open>\<exists>A. set A \<subseteq> H \<and> \<turnstile>\<^sub>T \<^bold>\<not> q # A\<close>
        using assms MCS_refute by blast
      then have \<open>\<exists>A. set A \<subseteq> H \<and> \<turnstile>\<^sub>T p # \<^bold>\<not> q # A\<close>
        using Weaken by (metis set_subset_Cons)
      then have \<open>\<exists>A. set A \<subseteq> H \<and> \<turnstile>\<^sub>T \<^bold>\<not> (p \<^bold>\<longrightarrow> q) # A\<close>
        by fast
      then have \<open>\<^bold>\<not> (p \<^bold>\<longrightarrow> q) \<notin> H\<close>
        using assms unfolding consistent_def by auto
      then show False
        using * ..
    qed
  qed
qed

lemma truth_lemma:
  assumes \<open>consistent H\<close> \<open>maximal H\<close> \<open>p \<in> H\<close>
  shows \<open>\<lbrakk>hmodel H\<rbrakk> p\<close>
  using Hintikka_model MCS_Hintikka assms by blast

section \<open>Completeness\<close>

theorem strong_completeness:
  assumes \<open>\<forall>M :: 'p model. (\<forall>q \<in> X. \<lbrakk>M\<rbrakk> q) \<longrightarrow> \<lbrakk>M\<rbrakk> p\<close>
  shows \<open>\<exists>A. set A \<subseteq> X \<and> \<turnstile>\<^sub>T \<^bold>\<not> p # A\<close>
proof (rule ccontr)
  assume \<open>\<nexists>A. set A \<subseteq> X \<and> \<turnstile>\<^sub>T \<^bold>\<not> p # A\<close>
  then have *: \<open>\<nexists>A. set A \<subseteq> {\<^bold>\<not> p} \<union> X \<and> \<turnstile>\<^sub>T A\<close>
    using refute_split1 by blast

  let ?S = \<open>{\<^bold>\<not> p} \<union> X\<close>
  let ?H = \<open>Extend ?S\<close>

  have \<open>consistent ?S\<close>
    unfolding consistent_def using * by blast
  then have \<open>consistent ?H\<close> \<open>maximal ?H\<close>
    using MCS_Extend' by blast+
  then have \<open>p \<in> ?H \<longrightarrow> \<lbrakk>hmodel ?H\<rbrakk> p\<close> for p
    using truth_lemma by fastforce
  then have \<open>p \<in> ?S \<longrightarrow> \<lbrakk>hmodel ?H\<rbrakk> p\<close> for p
    using Extend_subset by blast
  then have \<open>\<lbrakk>hmodel ?H\<rbrakk> (\<^bold>\<not> p)\<close> \<open>\<forall>q \<in> X. \<lbrakk>hmodel ?H\<rbrakk> q\<close>
    by blast+
  moreover from this have \<open>\<lbrakk>hmodel ?H\<rbrakk> p\<close>
    using assms(1) by blast
  ultimately show False
    by simp
qed

abbreviation valid :: \<open>'p fm \<Rightarrow> bool\<close> where
  \<open>valid p \<equiv> \<forall>M. \<lbrakk>M\<rbrakk> p\<close>

theorem completeness:
  assumes \<open>valid p\<close>
  shows \<open>\<turnstile>\<^sub>T [\<^bold>\<not> p]\<close>
  using assms strong_completeness[where X=\<open>{}\<close>] by auto

theorem main: \<open>valid p \<longleftrightarrow> \<turnstile>\<^sub>T [\<^bold>\<not> p]\<close>
  using completeness soundness' by blast

end


(*
   Title: The Calculus of Communicating Systems
   Author/Maintainer: Jesper Bengtson (jebe@itu.dk), 2012
*)
theory Weak_Cong
  imports Weak_Cong_Sim Weak_Bisim Strong_Bisim_SC
begin

definition weakCongruence :: "ccs \<Rightarrow> ccs \<Rightarrow> bool" ("_ \<cong> _" [70, 70] 65)
where
  "P \<cong> Q \<equiv> P \<leadsto><weakBisimulation> Q \<and> Q \<leadsto><weakBisimulation> P"

  assumes "P \<cong> Q"

  shows "P \<leadsto><weakBisimulation> Q"
  and   "Q \<leadsto><weakBisimulation> P"
using assms
by(auto simp add: weakCongruence_def)

lemma weakCongruenceI:
  fixes P :: "ccs"
  and   Q :: "ccs"

  assumes "P \<leadsto><weakBisimulation> Q"
  and     "Q \<leadsto><weakBisimulation> P"

  shows "P \<cong> Q"
using assms
by(auto simp add: weakCongruence_def)

lemma weakCongISym[consumes 1, case_names cSym cSim]:
  fixes P :: ccs
  and   Q :: ccs

  assumes "Prop P Q"
  and     "\<And>P Q. Prop P Q \<Longrightarrow> Prop Q P"
  and     "\<And>P Q. Prop P Q \<Longrightarrow> (F P) \<leadsto><weakBisimulation> (F Q)"

  shows "F P \<cong> F Q"
using assms
by(auto simp add: weakCongruence_def)

lemma weakCongISym2[consumes 1, case_names cSim]:
  fixes P :: ccs
  and   Q :: ccs

  assumes "P \<cong> Q"
  and     "\<And>P Q. P \<cong> Q \<Longrightarrow> (F P) \<leadsto><weakBisimulation> (F Q)"

  shows "F P \<cong> F Q"
using assms
by(auto simp add: weakCongruence_def)

lemma reflexive:
  fixes P :: ccs

  shows "P \<cong> P"
by(auto intro: weakCongruenceI Weak_Bisim.reflexive Weak_Cong_Sim.reflexive)

  assumes "P \<cong> Q"

  shows "Q \<cong> P"
using assms
by(auto simp add: weakCongruence_def)

  assumes "P \<cong> Q"
  and     "Q \<cong> R"

  shows "P \<cong> R"
proof -
  let ?Prop = "\<lambda>P R. \<exists>Q. P \<cong> Q \<and> Q \<cong> R"
  from assms have "?Prop P R" by auto
  thus ?thesis
  proof(induct rule: weakCongISym)
    case(cSym P R)
    thus ?case by(auto dest: symmetric)
  next
    case(cSim P R)
    from \<open>?Prop P R\<close> obtain Q where "P \<cong> Q" and "Q \<cong> R"
      by auto
    from \<open>P \<cong> Q\<close> have "P \<leadsto><weakBisimulation> Q" by(rule weakCongruenceE)
    moreover from \<open>Q \<cong> R\<close> have "Q \<leadsto><weakBisimulation> R" by(rule weakCongruenceE)
    moreover from Weak_Bisim.transitive have "weakBisimulation O weakBisimulation \<subseteq> weakBisimulation"
      by auto
    ultimately show ?case using weakBisimulationE(1)
      by(rule Weak_Cong_Sim.transitive)
  qed
qed

lemma bisimWeakCongruence:
  fixes P :: ccs
  and   Q :: ccs

  assumes "P \<sim> Q"

  shows "P \<cong> Q"
using assms
proof(induct rule: weakCongISym)
  case(cSym P Q)
  thus ?case by(rule bisimE)
next
  case(cSim P Q)
  from \<open>P \<sim> Q\<close> have "P \<leadsto>[bisim] Q" by(rule bisimE)
  hence "P \<leadsto>[weakBisimulation] Q" using bisimWeakBisimulation
    by(rule_tac monotonic) auto
  thus ?case by(rule simWeakSim)
qed

lemma structCongWeakCongruence:
  fixes P :: ccs
  and   Q :: ccs

  assumes "P \<equiv>\<^sub>s Q"

  shows "P \<cong> Q"
using assms
by(auto intro: bisimWeakCongruence bisimStructCong)

lemma weakCongruenceWeakBisimulation:
  fixes P :: ccs
  and   Q :: ccs

  assumes "P \<cong> Q"

  shows "P \<approx> Q"
proof -
  let ?X = "{(P, Q) | P Q. P \<cong> Q}"
  from assms have "(P, Q) \<in> ?X" by auto
  thus ?thesis
  proof(coinduct rule: weakBisimulationCoinduct)
    case(cSim P Q)
    from \<open>(P, Q) \<in> ?X\<close> have "P \<cong> Q" by auto
    hence "P \<leadsto><weakBisimulation> Q" by(rule Weak_Cong.weakCongruenceE)
    hence "P \<leadsto><(?X \<union> weakBisimulation)> Q" by(force intro: Weak_Cong_Sim.weakMonotonic)
    thus ?case by(rule weakCongSimWeakSim)
  next
    case(cSym P Q)
    from \<open>(P, Q) \<in> ?X\<close> show ?case by(blast dest: symmetric)
  qed
qed

end


text\<open>
Interpreter.thy defines a simple programming language over interval-valued variables and executable
semantics (interpreter) for that language. We then prove that the interpretation of interval terms
is a sound over-approximation of a real-valued semantics of the same language.

Our language is a version of first order dynamic logic-style regular programs.
We use a finite identifier space for compatibility with Differential-Dynamic-Logic, where identifier
finiteness is required to treat program states as Banach spaces to enable differentiation.
\<close>
(* Author:     Rose Bohrer *)
theory Interpreter
imports
  Complex_Main
  Finite_String
  Interval_Word32
begin

section\<open>Syntax\<close>
text\<open>Our term language supports variables, polynomial arithmetic, and extrema. This choice was made
   based on the needs of the original paper and could be extended if necessary.\<close>
datatype  trm =
  Var fin_string
| Const lit
| Plus trm trm
| Times trm trm
| Neg trm
| Max trm trm
| Min trm trm
| Abs trm

text\<open>Our statement language is nondeterministic first-order regular programs.
 This coincides with the discrete subset of hybrid programs from the dL entry.

Our assertion language are the formulas of first-order dynamic logic\<close>
datatype prog =
  Assign fin_string "trm"     (infixr ":=" 10)
| AssignAny fin_string
| Test "formula"              ("?")
| Choice "prog" "prog"        (infixl "\<union>\<union>" 10)
| Sequence "prog"  "prog"     (infixr ";;" 8)
| Loop "prog"                 ("_**")

and formula =
  Geq "trm" "trm"
| Not "formula"                        ("!")
| And "formula" "formula"              (infixl "&&" 8)
| Exists fin_string "formula"
| Diamond "prog" "formula"               ("(\<langle> _ \<rangle> _)" 10)

text\<open>Derived forms\<close>
definition Or :: "formula \<Rightarrow> formula \<Rightarrow> formula" (infixl "||" 7)
where or_simp[simp]:"Or P Q = Not (And (Not P) (Not Q))"

definition Equals :: "trm \<Rightarrow> trm \<Rightarrow> formula"
where equals_simp[simp]:"Equals \<theta> \<theta>' = (And (Geq \<theta> \<theta>') (Geq \<theta>' \<theta>))"

definition Greater :: "trm \<Rightarrow> trm \<Rightarrow> formula"
where greater_simp[simp]:"Greater \<theta> \<theta>' = Not (Geq \<theta>' \<theta>)"

definition Leq :: "trm \<Rightarrow> trm \<Rightarrow> formula"
where leq_simp[simp]:"Leq \<theta> \<theta>' = (Geq \<theta>' \<theta>)"

definition Less :: "trm \<Rightarrow> trm \<Rightarrow> formula"
where less_simp[simp]:"Less \<theta> \<theta>' = (Not (Geq \<theta> \<theta>'))"

section \<open>Semantics\<close>
text\<open> States over reals vs. word intervals which contain them\<close>
type_synonym rstate = "fin_string \<Rightarrow> real"
type_synonym wstate = "(fin_string + fin_string) \<Rightarrow> word"

definition wstate::"wstate \<Rightarrow> prop"
where wstate_def[simp]:"wstate \<nu> \<equiv> (\<And>i. word (\<nu> (Inl i)) \<and> word (\<nu> (Inr i)))"

text\<open>Interpretation of a term in a state\<close>
inductive rtsem :: "trm \<Rightarrow> rstate \<Rightarrow> real  \<Rightarrow> bool"  ("([_]_ \<down> _)" 10)
  where
  rtsem_Const:"Rep_bword w \<equiv>\<^sub>E r \<Longrightarrow> ([Const w]\<nu> \<down> r)"
| rtsem_Var:"([Var x]\<nu> \<down> \<nu> x)"
| rtsem_Plus:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> ([Plus \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> (r1 + r2))"
| rtsem_Times:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> ([Times \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> (r1 * r2))"
| rtsem_Max:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> ([Max \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> (max r1 r2))"
| rtsem_Min:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> ([Min \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> (min r1 r2))"
| rtsem_Abs:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1)\<rbrakk> \<Longrightarrow> ([Abs \<theta>\<^sub>1]\<nu> \<down> (abs r1))"
| rtsem_Neg:"([\<theta>]\<nu> \<down> r) \<Longrightarrow> ([Neg \<theta>]\<nu> \<down> -r)"

inductive_simps
    rtsem_Const_simps[simp] : "([(Const w)]\<nu> \<down> r)"
and rtsem_Var_simps[simp] : "([Var x]\<nu> \<down> r)"
and rtsem_PlusU_simps[simp] : "([Plus \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> r)"
and rtsem_TimesU_simps[simp] : "([Times \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<down> r)"
and rtsem_Max_simps[simp] : "([Max \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<down> r)"
and rtsem_Min_simps[simp] : "([Min \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<down> r)"
and rtsem_Abs_simps[simp] : "([Abs \<theta>] \<nu> \<down> r)"
and rtsem_Neg_simps[simp] : "([Neg \<theta>] \<nu> \<down> r)"

definition set_less :: "real set \<Rightarrow> real set \<Rightarrow> bool" (infix "<\<^sub>S" 10)
where "set_less A B \<equiv> (\<forall> x y. x \<in> A \<and> y \<in> B \<longrightarrow> x < y)"

definition set_geq :: "real set \<Rightarrow> real set \<Rightarrow> bool" (infix "\<ge>\<^sub>S" 10)
where "set_geq A B \<equiv> (\<forall> x y. x \<in> A \<and> y \<in> B \<longrightarrow> x \<ge> y)"

text\<open>Interpretation of an assertion in a state\<close>
inductive rfsem :: "formula \<Rightarrow> rstate \<Rightarrow> bool \<Rightarrow> bool" ("([_]_) \<downharpoonright> _" 20)
where
  rGreaterT:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r1 > r2 \<Longrightarrow> ([Greater \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> True)"
| rGreaterF:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r2 \<ge> r1 \<Longrightarrow> ([Greater \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> False)"
| rGeqT:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r1 \<ge> r2 \<Longrightarrow> ([Geq \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> True)"
| rGeqF:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r2 > r1 \<Longrightarrow> ([Geq \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> False)"
| rEqualsT:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r1 = r2 \<Longrightarrow> ([Equals \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> True)"
| rEqualsF:"\<lbrakk>([\<theta>\<^sub>1]\<nu> \<down> r1); ([\<theta>\<^sub>2]\<nu> \<down> r2)\<rbrakk> \<Longrightarrow> r1 \<noteq> r2 \<Longrightarrow> ([Equals \<theta>\<^sub>1 \<theta>\<^sub>2] \<nu> \<downharpoonright> False)"
| rAndT:"\<lbrakk>([\<phi>]\<nu> \<downharpoonright> True); ([\<psi>]\<nu> \<downharpoonright> True)\<rbrakk> \<Longrightarrow> ([And \<phi> \<psi>]\<nu> \<downharpoonright> True)"
| rAndF1:"([\<phi>]\<nu> \<downharpoonright> False) \<Longrightarrow> ([And \<phi> \<psi>]\<nu> \<downharpoonright> False)"
| rAndF2:"([\<psi>]\<nu> \<downharpoonright> False) \<Longrightarrow> ([And \<phi> \<psi>]\<nu> \<downharpoonright> False)"
| rOrT1:"([\<phi>]\<nu> \<downharpoonright> True) \<Longrightarrow> ([Or \<phi> \<psi>]\<nu> \<downharpoonright> True)"
| rOrT2:"([\<psi>]\<nu> \<downharpoonright> True) \<Longrightarrow> ([Or \<phi> \<psi>]\<nu> \<downharpoonright> True)"
| rOrF:"\<lbrakk>([\<phi>]\<nu> \<downharpoonright> False) ;([\<psi>]\<nu> \<downharpoonright> False)\<rbrakk> \<Longrightarrow> ([And \<phi> \<psi>]\<nu> \<downharpoonright> False)"
| rNotT:"([\<phi>]\<nu> \<downharpoonright> False) \<Longrightarrow> ([(Not \<phi>)]\<nu> \<downharpoonright> True)"
| rNotF:"([\<phi>]\<nu> \<downharpoonright> True) \<Longrightarrow> ([(Not \<phi>)]\<nu> \<downharpoonright> False)"

inductive_simps
    rfsem_Greater_simps[simp]: "([Greater \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<downharpoonright> b)"
and rfsem_Geq_simps[simp]: "([Geq \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<downharpoonright> b)"
and rfsem_Equals_simps[simp]: "([Equals \<theta>\<^sub>1 \<theta>\<^sub>2]\<nu> \<downharpoonright> b)"
and rfsem_And_simps[simp]: "([And \<phi>  \<psi>]\<nu> \<downharpoonright> b)"
and rfsem_Or_simps[simp]: "([(Or \<phi> \<psi>)]\<nu> \<downharpoonright> b)"
and rfsem_Not_simps[simp]: "([Not \<phi>]\<nu> \<downharpoonright> b)"

text\<open>Interpretation of a program is a transition relation on states\<close>
inductive rpsem :: "prog \<Rightarrow> rstate \<Rightarrow>  rstate \<Rightarrow> bool" ("([_]_) \<downharpoonleft> _" 20)
where
  rTest[simp]:"\<lbrakk>([\<phi>]\<nu> \<downharpoonright> True); \<nu> = \<omega>\<rbrakk> \<Longrightarrow> ([? \<phi>]\<nu> \<downharpoonleft> \<omega>)"
| rSeq[simp]:"\<lbrakk>([\<alpha>]\<nu> \<downharpoonleft> \<mu>); ([\<beta>]\<mu> \<downharpoonleft> \<omega>)\<rbrakk> \<Longrightarrow> ([\<alpha>;; \<beta>]\<nu> \<downharpoonleft> \<omega>)"
| rAssign[simp]:"\<lbrakk>([\<theta>]\<nu> \<down> r); \<omega> = (\<nu> (x := r))\<rbrakk> \<Longrightarrow> ([Assign x \<theta>]\<nu> \<downharpoonleft> \<omega>)"
| rChoice1[simp]:"([\<alpha>]\<nu> \<downharpoonleft> \<omega>) \<Longrightarrow> ([Choice \<alpha> \<beta>]\<nu> \<downharpoonleft> \<omega>)"
| rChoice2[simp]:"([\<beta>]\<nu> \<downharpoonleft> \<omega>) \<Longrightarrow> ([Choice \<alpha> \<beta>]\<nu> \<downharpoonleft> \<omega>)"

inductive_simps
    rpsem_Test_simps[simp]: "([? \<phi>]\<nu> \<downharpoonleft> b)"
and rpsem_Seq_simps[simp]: "([\<alpha>;; \<beta>]\<nu> \<downharpoonleft> b)"
and rpsem_Assign_simps[simp]: "([Assign x \<theta>]\<nu> \<downharpoonleft> b)"
and rpsem_Choice_simps[simp]: "([Choice \<alpha> \<beta>]\<nu> \<downharpoonleft> b)"

text\<open>Upper bound of arbitrary term\<close>
fun wtsemU :: "trm \<Rightarrow> wstate \<Rightarrow>  word * word " ("([_]<>_)" 20)
where "([Const r]<>\<nu>) = (Rep_bword r::word, Rep_bword r)"
| wVarU:"([Var x]<>\<nu>) = (\<nu> (Inl x), \<nu> (Inr x))"
| wPlusU:"([Plus \<theta>\<^sub>1 \<theta>\<^sub>2]<> \<nu>) =
  (let (l1, u1) = [\<theta>\<^sub>1]<> \<nu> in
   let (l2, u2) = [\<theta>\<^sub>2]<> \<nu> in
   (pl l1 l2, pu u1 u2))"
| wTimesU:"([(Times \<theta>\<^sub>1 \<theta>\<^sub>2)]<> \<nu>) =
  (let (l1, u1) = [\<theta>\<^sub>1]<> \<nu> in
   let (l2, u2) = [\<theta>\<^sub>2]<> \<nu> in
   (tl l1 u1 l2 u2, tu l1 u1 l2 u2))"
| wMaxU:"([(Max \<theta>\<^sub>1 \<theta>\<^sub>2)]<> \<nu>) =
  (let (l1, u1) = [\<theta>\<^sub>1]<> \<nu> in
   let (l2, u2) = [\<theta>\<^sub>2]<> \<nu> in
  (wmax l1 l2, wmax u1 u2))"
| wMinU:"([(Min \<theta>\<^sub>1 \<theta>\<^sub>2)]<> \<nu>) =
  (let (l1, u1) = [\<theta>\<^sub>1]<> \<nu> in
   let (l2, u2) = [\<theta>\<^sub>2]<> \<nu> in
  (wmin l1 l2, wmin u1 u2))"
| wNegU:"([(Neg \<theta>)]<> \<nu>) =
  (let (l, u) = [\<theta>]<> \<nu> in
   (wneg u, wneg l))"
| wAbsU:"([(Abs \<theta>\<^sub>1)]<> \<nu>) =
  (let (l1, u1) = [\<theta>\<^sub>1]<> \<nu> in
  (wmax l1 (wneg u1), wmax u1 (wneg l1)))"

inductive wfsem :: "formula \<Rightarrow> wstate \<Rightarrow> bool \<Rightarrow> bool" ("([[_]]_ \<down> _)" 20)
where
  wGreaterT:"wgreater (fst ([\<theta>\<^sub>1]<>\<nu>)) (snd ([\<theta>\<^sub>2]<>\<nu>)) \<Longrightarrow>  ([[(Greater \<theta>\<^sub>1 \<theta>\<^sub>2)]]\<nu> \<down> True)"
| wGreaterF:"wgeq (fst ([\<theta>\<^sub>2]<>\<nu>)) (snd ([\<theta>\<^sub>1]<>\<nu>)) \<Longrightarrow>  ([[(Greater \<theta>\<^sub>1 \<theta>\<^sub>2)]]\<nu> \<down> False)"
| wGeqT:"wgeq (fst ([\<theta>\<^sub>1]<> \<nu>)) (snd ([\<theta>\<^sub>2]<>\<nu>)) \<Longrightarrow>  ([[(Geq \<theta>\<^sub>1 \<theta>\<^sub>2)]]\<nu> \<down> True)"
| wGeqF:"wgreater (fst ([\<theta>\<^sub>2]<>\<nu>)) (snd ([\<theta>\<^sub>1]<>\<nu>)) \<Longrightarrow>  ([[(Geq \<theta>\<^sub>1 \<theta>\<^sub>2)]]\<nu> \<down> False)"
| wEqualsT:"\<lbrakk>(fst ([\<theta>\<^sub>2]<>\<nu>) = snd ([\<theta>\<^sub>2]<>\<nu>)); (snd ([\<theta>\<^sub>2]<>\<nu>) = snd ([\<theta>\<^sub>1]<>\<nu>));
             (snd ([\<theta>\<^sub>1]<>\<nu>) = fst ([\<theta>\<^sub>1]<>\<nu>)); (fst ([\<theta>\<^sub>2]<>\<nu>) \<noteq> NEG_INF);
             (fst ([\<theta>\<^sub>2]<>\<nu>) \<noteq> POS_INF)\<rbrakk>
         \<Longrightarrow> ([[Equals \<theta>\<^sub>1 \<theta>\<^sub>2]] \<nu> \<down> True)"
| wEqualsF1:"wgreater (fst ([\<theta>\<^sub>1]<> \<nu>)) (snd ([\<theta>\<^sub>2]<>\<nu>)) \<Longrightarrow>  ([[Equals \<theta>\<^sub>1 \<theta>\<^sub>2]] \<nu> \<down> False)"
| wEqualsF2:"wgreater (fst ([\<theta>\<^sub>2]<> \<nu>)) (snd ([\<theta>\<^sub>1]<>\<nu>)) \<Longrightarrow>  ([[Equals \<theta>\<^sub>1 \<theta>\<^sub>2]] \<nu> \<down> False)"
| wAndT:"\<lbrakk>[[\<phi>]]\<nu> \<down> True; [[\<psi>]]\<nu> \<down> True\<rbrakk> \<Longrightarrow> ([[And \<phi> \<psi>]]\<nu> \<down> True)"
| wAndF1:"[[\<phi>]]\<nu> \<down> False \<Longrightarrow> ([[And \<phi> \<psi>]]\<nu> \<down> False)"
| wAndF2:"[[\<psi>]]\<nu> \<down> False \<Longrightarrow> ([[And \<phi> \<psi>]]\<nu> \<down> False)"
| wOrT1:"([[\<phi>]]\<nu> \<down> True) \<Longrightarrow> ([[Or \<phi> \<psi>]]\<nu> \<down> True)"
| wOrT2:"([[\<psi>]]\<nu> \<down> True) \<Longrightarrow> ([[Or \<phi> \<psi>]]\<nu> \<down> True)"
| wOrF:"\<lbrakk>[[\<phi>]]\<nu> \<down> False; [[\<psi>]]\<nu> \<down> False\<rbrakk> \<Longrightarrow> ([[And \<phi> \<psi>]]\<nu> \<down> False)"
| wNotT:"([[\<phi>]]\<nu> \<down> False) \<Longrightarrow> ([[Not \<phi>]]\<nu> \<down> True)"
| wNotF:"([[\<phi>]]\<nu> \<down> True) \<Longrightarrow> ([[Not \<phi>]]\<nu> \<down> False)"

inductive_simps
    wfsem_Gr_simps[simp]: "([[Le \<theta>\<^sub>1 \<theta>\<^sub>2]]\<nu> \<down> b)"
and wfsem_And_simps[simp]: "([[And \<phi> \<psi>]]\<nu> \<down> b)"
and wfsem_Or_simps[simp]: "([[Or \<phi> \<psi>]]\<nu> \<down> b)"
and wfsem_Not_simps[simp]: "([[Not \<phi>]]\<nu> \<down> b)"
and wfsem_Equals_simps[simp]: "([[Equals \<theta>\<^sub>1 \<theta>\<^sub>2]]\<nu> \<down> b)"

text\<open>Program semantics\<close>
inductive wpsem :: "prog \<Rightarrow>  wstate \<Rightarrow> wstate \<Rightarrow> bool" ("([[_]]_ \<down> _)" 20)
where
  wTest:"([[\<phi>]]\<nu> \<down> True) \<Longrightarrow> \<nu> = \<omega> \<Longrightarrow> ([[? \<phi>]] \<nu> \<down> \<omega>)"
| wSeq:"([[\<alpha>]]\<nu> \<down> \<mu>) \<Longrightarrow> ([[\<beta>]] \<mu> \<down> \<omega>) \<Longrightarrow> ([[\<alpha>;; \<beta>]] \<nu> \<down> \<omega>)"
| wAssign:"\<omega> = ((\<nu> ((Inr x) := snd([\<theta>]<>\<nu>))) ((Inl x) := fst([\<theta>]<>\<nu>))) \<Longrightarrow> ([[Assign x \<theta>]] \<nu> \<down> \<omega>)"
| wChoice1[simp]:"([[\<alpha>]]\<nu> \<down> \<omega>) \<Longrightarrow> ([[Choice \<alpha> \<beta>]]\<nu> \<down> \<omega>)"
| wChoice2[simp]:"([[\<beta>]]\<nu> \<down> \<omega>) \<Longrightarrow> ([[Choice \<alpha> \<beta>]]\<nu> \<down> \<omega>)"

inductive_simps
    wpsem_Test_simps[simp]: "([[Test \<phi>]]\<nu> \<down> b)"
and wpsem_Seq_simps[simp]: "([[\<alpha>;; \<beta>]]\<nu> \<down> b)"
and wpsem_Assign_simps[simp]: "([[Assign x \<theta>]]\<nu> \<down> b)"
and wpsem_Choice_simps[simp]: "([[Choice \<alpha> \<beta>]]\<nu> \<down> b)"

lemmas real_max_mono =  Lattices.linorder_class.max.mono
lemmas real_minus_le_minus = Groups.ordered_ab_group_add_class.neg_le_iff_le

text\<open>Interval state consists of upper and lower bounds for each real variable\<close>
inductive represents_state::"wstate \<Rightarrow> rstate \<Rightarrow> bool" (infix "REP" 10)
where REPI:"(\<And>x. (\<nu> (Inl x) \<equiv>\<^sub>L \<nu>' x) \<and> (\<nu> (Inr x) \<equiv>\<^sub>U \<nu>' x)) \<Longrightarrow> (\<nu> REP \<nu>')"

inductive_simps repstate_simps:"\<nu> REP \<nu>'"

section\<open>Soundness proofs\<close>
text\<open>Interval term valuation soundly contains real valuation\<close>
lemma trm_sound:
  fixes \<theta>::"trm"
  shows "([\<theta>]\<nu>' \<down> r) \<Longrightarrow> (\<nu> REP \<nu>') \<Longrightarrow>   ([\<theta>]<>\<nu>) \<equiv>\<^sub>P r"
proof (induction rule: rtsem.induct)
 case rtsem_Const
   fix w r \<nu>'
   show "Rep_bword w \<equiv>\<^sub>E r \<Longrightarrow> \<nu> REP \<nu>' \<Longrightarrow> [Const w]<>\<nu> \<equiv>\<^sub>P r"
     using repU_def repL_def repP_def repe.simps rep_simps repstate_simps
     by auto
next
 case rtsem_Var
   fix x \<nu>'
   show "\<nu> REP \<nu>' \<Longrightarrow> [Var x]<>\<nu> \<equiv>\<^sub>P \<nu>' x"
   by(auto simp add: repU_def repL_def repP_def repe.simps rep_simps repstate_simps)
next
 case rtsem_Plus
   fix \<theta>\<^sub>1 :: "trm" and \<nu>':: "rstate" and r1 and \<theta>\<^sub>2 :: "trm" and  r2
   assume rep:"\<nu> REP \<nu>'"
   assume eval1:"[\<theta>\<^sub>1]\<nu>' \<down> r1"
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1)"
   then have IH1:"[\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1" using rep by auto
   assume eval2:"[\<theta>\<^sub>2]\<nu>' \<down> r2"
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2)"
   then have IH2:"[\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2" using rep by auto
   obtain l1 u1 l2 u2 where
        lu1:"(l1, u1) = ([\<theta>\<^sub>1]<> \<nu>)"
    and lu2:"(l2, u2) = ([\<theta>\<^sub>2]<> \<nu>)"
    using IH1 IH2 repP_def by auto
   from lu1 and lu2 have
        lu1':"([\<theta>\<^sub>1]<> \<nu>) = (l1, u1)"
    and lu2':"([\<theta>\<^sub>2]<> \<nu>) = (l2, u2)"
    by auto
  have l1:"l1 \<equiv>\<^sub>L r1" using IH1 lu1 unfolding repP_def by auto
  have u1:"u1 \<equiv>\<^sub>U r1" using IH1 lu1 unfolding repP_def by auto
  have l2:"l2 \<equiv>\<^sub>L r2" using IH2 lu2 unfolding repP_def by auto
  have u2:"u2 \<equiv>\<^sub>U r2" using IH2 lu2 unfolding repP_def by auto
  then have "([(Plus \<theta>\<^sub>1 \<theta>\<^sub>2)]<>\<nu>) = (pl l1 l2, pu u1 u2)"
   using lu1' lu2' by auto
  have lBound:"(pl l1 l2 \<equiv>\<^sub>L r1 + r2)"
    using l1 l2 pl_lemma by auto
  have uBound:"(pu u1 u2 \<equiv>\<^sub>U r1 + r2)"
    using pu_lemma[OF u1 u2] by auto
  have "(pl l1 l2, pu u1 u2) \<equiv>\<^sub>P (r1 + r2)"
    unfolding repP_def Let_def using lBound uBound by auto
  then show"[Plus \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r1 + r2"
    using lu1' lu2' by auto
next
 case rtsem_Times
   fix \<theta>\<^sub>1 :: "trm" and \<nu>' r1 and \<theta>\<^sub>2 :: "trm" and r2
   assume eval1:"[\<theta>\<^sub>1]\<nu>' \<down> r1"
   assume eval2:"[\<theta>\<^sub>2]\<nu>' \<down> r2"
   assume rep:"\<nu> REP \<nu>'"
   assume "(\<nu> REP \<nu>' \<Longrightarrow> ([\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1))"
   then have IH1:"[\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1" using rep by auto
   assume "(\<nu> REP \<nu>' \<Longrightarrow> ([\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2))"
   then have IH2:"[\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2" using rep by auto
    obtain l1 u1 l2 u2 where
        lu1:"([\<theta>\<^sub>1]<> \<nu>) = (l1, u1) "
    and lu2:"([\<theta>\<^sub>2]<> \<nu>) = (l2, u2)"
    using IH1 IH2 repP_def by auto
  have l1:"l1 \<equiv>\<^sub>L r1" using IH1 lu1 unfolding repP_def by auto
  have u1:"u1 \<equiv>\<^sub>U r1" using IH1 lu1 unfolding repP_def by auto
  have l2:"l2 \<equiv>\<^sub>L r2" using IH2 lu2 unfolding repP_def by auto
  have u2:"u2 \<equiv>\<^sub>U r2" using IH2 lu2 unfolding repP_def by auto
  then have "([(Times \<theta>\<^sub>1  \<theta>\<^sub>2)]<>\<nu>) = (tl l1 u1 l2 u2, tu l1 u1 l2 u2)"
   using lu1 lu2 unfolding wTimesU Let_def by auto
  have lBound:"(tl l1 u1 l2 u2 \<equiv>\<^sub>L r1 * r2)"
    using l1 u1 l2 u2 tl_lemma by auto
  have uBound:"(tu l1 u1 l2 u2 \<equiv>\<^sub>U r1 * r2)"
    using l1 u1 l2 u2 tu_lemma by auto
  have "(tl l1 u1 l2 u2, tu l1 u1 l2 u2) \<equiv>\<^sub>P (r1 * r2)"
    unfolding repP_def Let_def using lBound uBound by auto
  then show "[Times \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r1 * r2"
    using lu1 lu2 by auto
next
 case rtsem_Max
   fix \<theta>\<^sub>1 :: "trm" and \<nu>' r1 and \<theta>\<^sub>2 :: "trm" and  r2
   assume eval1:"([\<theta>\<^sub>1]\<nu>' \<down> r1)"
   assume eval2:"([\<theta>\<^sub>2]\<nu>' \<down> r2)"
   assume rep:"\<nu> REP \<nu>'"
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1)"
   then have IH1:"[\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1" using rep by auto
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2)"
   then have IH2:"[\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2" using rep by auto
   obtain l1 u1 l2 u2 where
        lu1:"([\<theta>\<^sub>1]<> \<nu>) = (l1, u1)"
    and lu2:"([\<theta>\<^sub>2]<> \<nu>) = (l2, u2)"
    using IH1 IH2 repP_def by auto
   from IH1 IH2
   obtain ub1 ub2 lb1 lb2:: real
   where urep1:"(ub1 \<ge> r1) \<and> (snd ([\<theta>\<^sub>1]<>\<nu>) \<equiv>\<^sub>E ub1)"
   and   urep2:"(ub2 \<ge> r2) \<and> (snd ([\<theta>\<^sub>2]<>\<nu>) \<equiv>\<^sub>E ub2)"
   and   lrep1:"(lb1 \<le> r1) \<and> (fst ([\<theta>\<^sub>1]<>\<nu>) \<equiv>\<^sub>E lb1)"
   and   lrep2:"(lb2 \<le> r2) \<and> (fst ([\<theta>\<^sub>2]<>\<nu>) \<equiv>\<^sub>E lb2)"
     using repP_def repU_def repL_def by auto
   have lbound:"wmax l1 l2 \<equiv>\<^sub>L max r1 r2"
     by (metis dual_order.trans fst_conv le_cases lrep1 lrep2 lu1 lu2 max_def repL_def wmax.elims)
   have ubound:"wmax u1 u2 \<equiv>\<^sub>U max r1 r2"
     by (metis real_max_mono lu1 lu2 repU_def snd_conv urep1 urep2 wmax_lemma)
   have "([trm.Max \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu>) = (wmax l1 l2, wmax u1 u2)"
     using lu1 lu2 unfolding wMaxU Let_def
     by (simp)
   then show "[trm.Max \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P max r1 r2"
    unfolding repP_def
    using lbound ubound lu1 lu2 by auto
next
  case rtsem_Min
    fix \<theta>\<^sub>1 :: "trm" and \<nu>' r1 and \<theta>\<^sub>2 :: "trm" and  r2
   assume eval1:"([\<theta>\<^sub>1]\<nu>' \<down> r1)"
   assume eval2:"([\<theta>\<^sub>2]\<nu>' \<down> r2)"
   assume rep:"\<nu> REP \<nu>'"
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1)"
   then have IH1:"[\<theta>\<^sub>1]<>\<nu> \<equiv>\<^sub>P r1" using rep by auto
   assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2)"
   then have IH2:"[\<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P r2" using rep by auto
   obtain l1 u1 l2 u2 where
        lu1:"([\<theta>\<^sub>1]<> \<nu>) = (l1, u1)"
    and lu2:"([\<theta>\<^sub>2]<> \<nu>) = (l2, u2)"
    using IH1 IH2 repP_def by auto
   from IH1 IH2
   obtain ub1 ub2 lb1 lb2:: real
   where urep1:"(ub1 \<ge> r1) \<and> (snd ([\<theta>\<^sub>1]<>\<nu>) \<equiv>\<^sub>E ub1)"
   and   urep2:"(ub2 \<ge> r2) \<and> (snd ([\<theta>\<^sub>2]<>\<nu>) \<equiv>\<^sub>E ub2)"
   and   lrep1:"(lb1 \<le> r1) \<and> (fst ([\<theta>\<^sub>1]<>\<nu>) \<equiv>\<^sub>E lb1)"
   and   lrep2:"(lb2 \<le> r2) \<and> (fst ([\<theta>\<^sub>2]<>\<nu>) \<equiv>\<^sub>E lb2)"
     using prod.case_eq_if repP_def  repU_def repL_def by auto
   have lbound:"wmin l1 l2 \<equiv>\<^sub>L min r1 r2"
     by (metis fst_conv lrep1 lrep2 lu1 lu2 min.mono repL_def wmin_lemma)
   have ubound:"wmin u1 u2 \<equiv>\<^sub>U min r1 r2"
     using lu1 lu2 min_le_iff_disj repU_def urep1 urep2 by auto
   have "([Min \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu>) = (wmin l1 l2, wmin u1 u2)"
     using lu1 lu2 unfolding wMinU Let_def by auto
  then show "[Min \<theta>\<^sub>1 \<theta>\<^sub>2]<>\<nu> \<equiv>\<^sub>P min r1 r2"
    unfolding repP_def
    using lbound ubound lu1 lu2 by auto
next
  case rtsem_Neg
  fix \<theta> :: "trm" and \<nu>' r
  assume eval:"[\<theta>]\<nu>' \<down> r"
  assume rep:"\<nu> REP \<nu>'"
  assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>]<>\<nu> \<equiv>\<^sub>P r)"
  then have IH:"[\<theta>]<>\<nu> \<equiv>\<^sub>P r" using rep by auto
  obtain l1 u1  where
        lu:"([\<theta>]<> \<nu>) = (l1, u1)"
    using IH repP_def by auto
  from IH
  obtain ub lb:: real
   where urep:"(ub \<ge> r) \<and> (snd ([\<theta>]<>\<nu>) \<equiv>\<^sub>E ub)"
   and   lrep:"(lb \<le> r) \<and> (fst ([\<theta>]<>\<nu>) \<equiv>\<^sub>E lb)"
    using  repP_def repU_def repL_def by auto
  have ubound:"((wneg u1) \<equiv>\<^sub>L (uminus r))"
    by (metis real_minus_le_minus lu repL_def snd_conv urep wneg_lemma)
  have lbound:"((wneg l1) \<equiv>\<^sub>U (uminus r))"
    using real_minus_le_minus lu repU_def lrep wneg_lemma
    by (metis fst_conv)
  show "[Neg \<theta>]<>\<nu> \<equiv>\<^sub>P - r"
    unfolding repP_def Let_def using ubound lbound lu
    by (auto)
next
  case rtsem_Abs
  fix \<theta> :: "trm" and \<nu>' r
  assume eval:"[\<theta>]\<nu>' \<down> r"
  assume rep:"\<nu> REP \<nu>'"
  assume "(\<nu> REP \<nu>' \<Longrightarrow> [\<theta>]<>\<nu> \<equiv>\<^sub>P r)"
  then have IH:"[\<theta>]<>\<nu> \<equiv>\<^sub>P r" using rep by auto
  obtain l1 u1  where
        lu:"([\<theta>]<> \<nu>) = (l1, u1)"
    using IH repP_def by auto
  from IH
  obtain ub lb:: real
   where urep:"(ub \<ge> r) \<and> (snd ([\<theta>]<>\<nu>) \<equiv>\<^sub>E ub)"
   and   lrep:"(lb \<le> r) \<and> (fst ([\<theta>]<>\<nu>) \<equiv>\<^sub>E lb)"
    using prod.case_eq_if repP_def  repU_def repL_def by auto
  have lbound:"wmax l1 (wneg u1) \<equiv>\<^sub>L (abs r)"
    apply(simp only: repL_def)
    apply(rule exI[where x="max lb (- ub)"])
    apply(rule conjI)
    using lrep wmax_lemma lu urep wneg_lemma by auto
  have ubound:"(wmax u1 (wneg l1) \<equiv>\<^sub>U (abs r))"
    apply(simp only: repU_def)
    apply(rule exI[where x="max ub (- lb)"])
    using lrep wmax_lemma lu urep wneg_lemma by auto
  show "[Abs \<theta>]<>\<nu> \<equiv>\<^sub>P abs r"
    using repP_def Let_def ubound lbound lu lu wAbsU by auto
qed

text\<open>Every word represents some real\<close>
lemma word_rep:"\<And>bw::bword. \<exists>r::real. Rep_bword bw \<equiv>\<^sub>E r"
proof -
  fix bw
  obtain w where weq:"w = Rep_bword bw" by auto
  have negInfCase:"w = NEG_INF \<Longrightarrow> ?thesis bw"
   apply(rule exI[where x="-((2 ^ 31) -1)"])
    using weq by (auto simp add: repe.simps)
  have posInfCase:"w = POS_INF \<Longrightarrow> ?thesis bw"
    apply(rule exI[where x="((2 ^ 31) -1)"])
    using weq by (auto simp add: repe.simps)
  have boundU:"w \<noteq> NEG_INF \<Longrightarrow> w \<noteq> POS_INF \<Longrightarrow> sint (Rep_bword bw) < sint POS_INF"
    using Rep_bword [of bw]
    by (auto simp: less_le weq [symmetric] dest: sint_dist)
  have boundL:"w \<noteq> NEG_INF \<Longrightarrow> w \<noteq> POS_INF \<Longrightarrow> sint NEG_INF < sint (Rep_bword bw)"
    using Rep_bword [of bw]
    by (auto simp: less_le weq [symmetric] dest: sint_dist)
  have intCase:"w \<noteq> NEG_INF \<Longrightarrow> w \<noteq> POS_INF \<Longrightarrow> ?thesis bw"
    apply(rule exI[where x=" (real_of_int (sint (Rep_bword bw)))"])
    apply(rule repINT)
    using boundU boundL by(auto)
  then show "?thesis bw"
    apply(cases "w = POS_INF")
     apply(cases "w = NEG_INF")
      using posInfCase intCase negInfCase by auto
  qed

text\<open>Every term has a value\<close>
lemma eval_tot:"(\<exists>r. ([\<theta>::trm]\<nu>' \<down> r))"
proof (induction "\<theta>")
qed (auto simp add: Min_def word_rep bword_neg_one_def, blast?)

text\<open>Interval formula semantics soundly implies real semantics\<close>
lemma fml_sound:
  fixes \<phi>::"formula" and \<nu>::"wstate"
  shows "(wfsem \<phi> \<nu> b) \<Longrightarrow>  (\<nu> REP \<nu>') \<Longrightarrow> (rfsem \<phi> \<nu>'  b)"
proof (induction arbitrary: \<nu>' rule: wfsem.induct)
case (wGreaterT t1 v t2 w)
  assume wle:"wgreater (fst ([t1]<>v)) (snd ([t2]<>v))"
  assume rep:"v REP w"
  obtain r1 and r2 where eval1:"[t1]w \<down> r1" and  eval2:"[t2]w \<down> r2"
    using eval_tot[of t1 w] eval_tot[of t2 w] by (auto)
  note rep1 = trm_sound[of t1 w r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 w r2, where \<nu>=v, OF eval2 rep]
  show "[Greater t1 t2]w \<downharpoonright> True"
    apply(rule rGreaterT[where ?r1.0 = r1, where ?r2.0 = r2])
    prefer 3
    apply(rule wgreater_lemma[where ?w1.0="fst([t1]<> v)", where ?w2.0="snd([t2]<> v)"])
    using rep1 rep2 wle repP_def repL_def repU_def  eval1 eval2
    by ((simp add: prod.case_eq_if | blast)+)
next
  case (wGreaterF t2 v t1 v')
  assume wl:"wgeq (fst ([t2]<>v)) (snd ([t1]<>v))"
  assume rep:"v REP v'"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
    eval2:"rtsem t2 v' r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v']  by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Greater t1 t2]v' \<downharpoonright> False"
    apply(rule rGreaterF [of t1 v' r1 t2 r2])
    apply(rule eval1)
     apply(rule eval2)
    apply(rule wgeq_lemma[where ?w1.0="fst([t2]<> v)", where ?w2.0="snd([t1]<> v)"])
    using rep1 rep2 repP_def wgeq_lemma wl rep
    by auto
next
  case (wGeqT t1 v t2 v')
  assume a1:"wgeq (fst ([t1]<>v)) (snd ([t2]<>v))"
  assume rep:"v REP v'"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
    eval2:"rtsem t2 v' r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v']  by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Geq t1 t2]v' \<downharpoonright> True"
    apply(rule rGeqT)
      apply(rule eval1)
    apply(rule eval2)
  using wgeq_lemma eval1 eval2 rep1 rep2 unfolding repP_def Let_def
  using wgreater_lemma prod.case_eq_if a1
  by auto
next
  case (wGeqF t2 v t1 v')
  assume a1:"wgreater (fst ([t2]<>v)) (snd ([t1]<>v))"
  assume rep:"v REP v'"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
    eval2:"rtsem t2 v'  r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v'] by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Geq t1 t2]v' \<downharpoonright> False"
    apply(rule rGeqF, rule eval1, rule eval2)
  using wgeq_lemma eval1 eval2 rep1 rep2 unfolding repP_def Let_def
  using wgreater_lemma rGreaterF prod.case_eq_if a1 rGreaterF by auto
next
  case (wEqualsT t2 v t1 v')
  assume eq1:"fst ([t2]<>v) = snd ([t2]<>v)"
  assume eq2:"snd ([t2]<>v) = snd ([t1]<>v)"
  assume eq3:"snd ([t1]<>v) = fst ([t1]<>v)"
  assume rep:"v REP v'"
  assume neq1:"fst ([t2]<>v) \<noteq> NEG_INF"
  assume neq2:"fst ([t2]<>v) \<noteq> POS_INF"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
        eval2:"rtsem t2 v'  r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v'] by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Equals t1 t2]v' \<downharpoonright> True"
    apply(rule rEqualsT, rule eval1, rule eval2)
    using eq1 eq2 eq3 eval1 eval2 rep1 rep2
    unfolding repP_def Let_def repL_def repU_def repe.simps using neq1 neq2 by auto
next
  case (wEqualsF1 t1 v t2 v')
  assume wle:"wgreater (fst ([t1]<>v)) (snd ([t2]<>v))"
  assume rep:"v REP v'"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
    eval2:"rtsem t2 v'  r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v'] by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Equals t1 t2]v' \<downharpoonright> False"
  apply(rule rEqualsF, rule eval1, rule eval2)
    using wgeq_lemma eval1 eval2 rep1 rep2 wgreater_lemma rGreaterF  prod.case_eq_if wle
    unfolding repP_def
    by (metis (no_types, lifting) less_irrefl)
next
  case (wEqualsF2 t2 v t1 v')
  assume wle:"wgreater (fst ([t2]<>v)) (snd ([t1]<>v))"
  assume rep:"v REP v'"
  obtain r1 r2:: real
  where eval1:"(rtsem t1 v' r1)" and
    eval2:"rtsem t2 v'  r2"
    using eval_tot[of t1 v'] eval_tot[of t2 v'] by (auto)
  note rep1 = trm_sound[of t1 v' r1, where \<nu>=v, OF eval1 rep]
  note rep2 = trm_sound[of t2 v' r2, where \<nu>=v, OF eval2 rep]
  show "[Equals t1 t2]v' \<downharpoonright> False"
    apply(rule rEqualsF, rule eval1, rule eval2)
    using wgeq_lemma eval1 eval2 rep1 rep2  wgreater_lemma rGreaterF prod.case_eq_if wle
    unfolding repP_def
    by (metis (no_types, lifting) less_irrefl)
qed (auto)

lemma rep_upd:"\<omega> = (\<nu>(Inr x := snd([\<theta>]<>\<nu>)))(Inl x := fst([\<theta>]<>\<nu>))
\<Longrightarrow> \<nu> REP \<nu>' \<Longrightarrow> ([\<theta>::trm]\<nu>' \<down> r) \<Longrightarrow> \<omega> REP \<nu>'(x := r)"
  apply(rule REPI)
  apply(rule conjI)
   apply(unfold repL_def)
   using trm_sound prod.case_eq_if repP_def repstate_simps repL_def
   apply(metis (no_types, lifting) Inl_Inr_False fun_upd_apply sum.inject(1))
  using repP_def repstate_simps repU_def
  apply(auto simp add: repU_def)
  by (metis (full_types) surjective_pairing trm_sound)

text\<open>Interval program semantics soundly contains real semantics existentially\<close>
theorem interval_program_sound:
  fixes \<alpha>::"prog"
  shows "([[\<alpha>]] \<nu> \<down> \<omega>)  \<Longrightarrow> \<nu> REP \<nu>' \<Longrightarrow> (\<exists>\<omega>'. (\<omega> REP \<omega>') \<and> ([\<alpha>] \<nu>' \<downharpoonleft> \<omega>'))"
proof (induction arbitrary: \<nu>' rule: wpsem.induct)
  case (wTest \<phi> \<nu> \<omega> \<nu>')
  assume sem:"[[\<phi>]]\<nu> \<down> True"
  and eq:"\<nu> = \<omega>"
  and rep:"\<nu> REP \<nu>'"
  show ?case
    apply(rule exI[where x=\<nu>'])
    using sem rep by (auto simp add: eq fml_sound rep)
next
  case (wAssign \<omega> \<nu> x \<theta> \<nu>')
  assume eq:"\<omega> = \<nu>(Inr x := snd ([\<theta>]<>\<nu>), Inl x := fst ([\<theta>]<>\<nu>))"
  and rep:"\<nu> REP \<nu>'"
  obtain r::real where eval:"([\<theta>::trm]\<nu>' \<down> r)" using eval_tot  by auto
  show ?case
    apply(rule exI[where x="\<nu>'(x := r)"])
    apply(rule conjI)
    apply(rule rep_upd[OF eq rep eval])
    apply auto
    apply(rule exI[where x=r])
    by (auto simp add: eval)
next case (wSeq \<alpha> \<nu> \<mu> \<beta> \<omega> \<nu>') then show ?case by (simp, blast)
next case (wChoice1 a v w b v') then show ?case by auto
next case (wChoice2 a v w b v') then show ?case by auto
qed

end


theory C
imports HOLCF "Mono-Nat-Fun"
begin

default_sort cpo

text \<open>
The initial solution to the domain equation $C = C_\bot$, i.e. the completion of the natural numbers.
\<close>

domain C = C (lazy "C")

lemma below_C: "x \<sqsubseteq> C\<cdot>x"
  by (induct x) auto

definition Cinf ("C\<^sup>\<infinity>") where "C\<^sup>\<infinity> = fix\<cdot>C"

lemma C_Cinf[simp]: "C\<cdot>C\<^sup>\<infinity> = C\<^sup>\<infinity>" unfolding Cinf_def by (rule fix_eq[symmetric])

abbreviation Cpow ("C\<^bsup>_\<^esup>") where "C\<^bsup>n\<^esup> \<equiv> iterate n\<cdot>C\<cdot>\<bottom>"

lemma C_below_C[simp]: "(C\<^bsup>i\<^esup> \<sqsubseteq> C\<^bsup>j\<^esup>) \<longleftrightarrow> i \<le> j"
  apply (induction i arbitrary: j)
  apply simp
  apply (case_tac j, auto)
  done

lemma below_Cinf[simp]: "r \<sqsubseteq> C\<^sup>\<infinity>"
  apply (induct r)
  apply simp_all[2]
  apply (metis (full_types) C_Cinf monofun_cfun_arg)
  done

lemma C_eq_Cinf[simp]: "C\<^bsup>i\<^esup> \<noteq> C\<^sup>\<infinity>"
  by (metis C_below_C Suc_n_not_le_n below_Cinf)

lemma Cinf_eq_C[simp]: "C\<^sup>\<infinity> = C \<cdot> r \<longleftrightarrow> C\<^sup>\<infinity> = r"
  by (metis C.injects C_Cinf)

lemma C_eq_C[simp]: "(C\<^bsup>i\<^esup> = C\<^bsup>j\<^esup>) \<longleftrightarrow> i = j"
  by (metis C_below_C le_antisym le_refl)

lemma case_of_C_below: "(case r of C\<cdot>y \<Rightarrow> x) \<sqsubseteq> x"
  by (cases r) auto

lemma C_case_below: "C_case \<cdot> f \<sqsubseteq> f"
  by (metis cfun_belowI C.case_rews(2) below_C monofun_cfun_arg)

lemma C_case_bot[simp]: "C_case \<cdot> \<bottom> = \<bottom>"
  apply (subst eq_bottom_iff)
  apply (rule C_case_below)
  done

lemma C_case_cong:
  assumes "\<And> r'. r = C\<cdot>r' \<Longrightarrow> f\<cdot>r' = g\<cdot>r'"
  shows "C_case\<cdot>f\<cdot>r = C_case\<cdot>g\<cdot>r"
using assms by (cases r) auto

lemma C_cases:
  obtains n where "r = C\<^bsup>n\<^esup>" | "r = C\<^sup>\<infinity>"
proof-
  { fix m
    have "\<exists> n. C_take m \<cdot> r = C\<^bsup>n\<^esup> "
    proof (rule C.finite_induct)
      have "\<bottom> = C\<^bsup>0\<^esup>" by simp
      thus "\<exists>n. \<bottom> = C\<^bsup>n\<^esup>"..
    next
      fix r
      show "\<exists>n. r = C\<^bsup>n\<^esup> \<Longrightarrow> \<exists>n. C\<cdot>r = C\<^bsup>n\<^esup>"
        by (auto simp del: iterate_Suc simp add: iterate_Suc[symmetric])
    qed
  }
  then obtain f where take: "\<And> m. C_take m \<cdot> r = C\<^bsup>f m\<^esup>" by metis
  have "chain (\<lambda> m. C\<^bsup>f m\<^esup>)" using ch2ch_Rep_cfunL[OF C.chain_take, where x=r, unfolded take].
  hence "mono f" by (auto simp add: mono_iff_le_Suc chain_def elim!:chainE)
  have r: "r = (\<Squnion> m. C\<^bsup>f m\<^esup>)"  by (metis (lifting) take C.reach lub_eq)
  from \<open>mono f\<close>
  show thesis
  proof(rule nat_mono_characterization)
    fix n
    assume n: "\<And> m. n \<le> m ==> f n = f m"
    have "max_in_chain n (\<lambda> m. C\<^bsup>f m\<^esup>)"
      apply (rule max_in_chainI)
      apply simp
      apply (erule n)
      done
    hence "(\<Squnion> m. C\<^bsup>f m\<^esup>) = C\<^bsup>f n\<^esup>" unfolding  maxinch_is_thelub[OF \<open>chain _\<close>].
    thus ?thesis using that unfolding r by blast
  next
    assume "\<And>m. \<exists>n. m \<le> f n"
    hence "\<And> n. C\<^bsup>n\<^esup> \<sqsubseteq> r" unfolding r by (fastforce intro: below_lub[OF \<open>chain _\<close>])
    hence "(\<Squnion> n. C\<^bsup>n\<^esup>) \<sqsubseteq> r"
      by (rule lub_below[OF chain_iterate])
    hence "C\<^sup>\<infinity> \<sqsubseteq> r" unfolding Cinf_def fix_def2.
    hence "C\<^sup>\<infinity> = r" using below_Cinf by (metis below_antisym)
    thus thesis using that by blast
  qed
qed

lemma C_case_Cinf[simp]: "C_case \<cdot> f \<cdot> C\<^sup>\<infinity> = f \<cdot> C\<^sup>\<infinity>"
  unfolding Cinf_def
  by (subst fix_eq) simp

end


theory DistributivityOfAnd
  imports Main
begin

lemma "A \<and> (B \<or> C) \<longleftrightarrow> (A \<and> B) \<or> (A \<and> C)"
proof -
  {
    assume a:"A \<and> (B \<or> C)"
    hence b:A ..
    from a have c:"B \<or> C" ..
    {
      assume B
      with b have "A \<and> B" ..
      hence " (A \<and> B) \<or> (A \<and> C)" ..
    }
    note tmp=this
    {
      assume C
      with b have "A \<and> C" ..
      hence "(A \<and> B) \<or> (A \<and> C)" ..
    }
    from c and tmp and this have "(A \<and> B) \<or> (A \<and> C)" ..
  }
  moreover
  {
    assume a:"(A \<and> B) \<or> (A \<and> C)"
    {
      assume b:"A \<and> B"
      hence c:A ..
      from b have B ..
      hence "B \<or> C" ..
      with c have "A \<and> (B \<or> C)" ..
    }
    note tmp=this
    {
      assume b:"A \<and> C"
      hence c:A ..
      from b have C ..
      hence "B \<or> C" ..
      with c have "A \<and> (B \<or> C)" ..
    }
    from a and tmp and this have "A \<and> (B \<or> C)" ..
  }
  ultimately show ?thesis ..
qed


(*  Title:      HOL/Unix/Nested_Environment.thy
    Author:     Markus Wenzel, TU Muenchen
*)

section \<open>Nested environments\<close>

theory Nested_Environment
imports Main
begin

text \<open>
  Consider a partial function @{term [source] "e :: 'a \<Rightarrow> 'b option"};
  this may be understood as an \emph{environment} mapping indexes
  @{typ 'a} to optional entry values @{typ 'b} (cf.\ the basic theory
  @{text Map} of Isabelle/HOL).  This basic idea is easily generalized
  to that of a \emph{nested environment}, where entries may be either
  basic values or again proper environments.  Then each entry is
  accessed by a \emph{path}, i.e.\ a list of indexes leading to its
  position within the structure.
\<close>

datatype (dead 'a, dead 'b, dead 'c) env =
    Val 'a
  | Env 'b  "'c \<Rightarrow> ('a, 'b, 'c) env option"

text \<open>
  \medskip In the type @{typ "('a, 'b, 'c) env"} the parameter @{typ
  'a} refers to basic values (occurring in terminal positions), type
  @{typ 'b} to values associated with proper (inner) environments, and
  type @{typ 'c} with the index type for branching.  Note that there
  is no restriction on any of these types.  In particular, arbitrary
  branching may yield rather large (transfinite) tree structures.
\<close>

subsection \<open>The lookup operation\<close>

text \<open>
  Lookup in nested environments works by following a given path of
  index elements, leading to an optional result (a terminal value or
  nested environment).  A \emph{defined position} within a nested
  environment is one where @{term lookup} at its path does not yield
  @{term None}.
\<close>

primrec lookup :: "('a, 'b, 'c) env \<Rightarrow> 'c list \<Rightarrow> ('a, 'b, 'c) env option"
  and lookup_option :: "('a, 'b, 'c) env option \<Rightarrow> 'c list \<Rightarrow> ('a, 'b, 'c) env option"
where
    "lookup (Val a) xs = (if xs = [] then Some (Val a) else None)"
  | "lookup (Env b es) xs =
      (case xs of
        [] \<Rightarrow> Some (Env b es)
      | y # ys \<Rightarrow> lookup_option (es y) ys)"
  | "lookup_option None xs = None"
  | "lookup_option (Some e) xs = lookup e xs"

hide_const lookup_option

text \<open>
  \medskip The characteristic cases of @{term lookup} are expressed by
  the following equalities.
\<close>

theorem lookup_nil: "lookup e [] = Some e"
  by (cases e) simp_all

theorem lookup_val_cons: "lookup (Val a) (x # xs) = None"
  by simp

theorem lookup_env_cons:
  "lookup (Env b es) (x # xs) =
    (case es x of
      None \<Rightarrow> None
    | Some e \<Rightarrow> lookup e xs)"
  by (cases "es x") simp_all

lemmas lookup.simps [simp del] lookup_option.simps [simp del]
  and lookup_simps [simp] = lookup_nil lookup_val_cons lookup_env_cons

theorem lookup_eq:
  "lookup env xs =
    (case xs of
      [] \<Rightarrow> Some env
    | x # xs \<Rightarrow>
      (case env of
        Val a \<Rightarrow> None
      | Env b es \<Rightarrow>
          (case es x of
            None \<Rightarrow> None
          | Some e \<Rightarrow> lookup e xs)))"
  by (simp split: list.split env.split)

text \<open>
  \medskip Displaced @{term lookup} operations, relative to a certain
  base path prefix, may be reduced as follows.  There are two cases,
  depending whether the environment actually extends far enough to
  follow the base path.
\<close>

theorem lookup_append_none:
  assumes "lookup env xs = None"
  shows "lookup env (xs @ ys) = None"
  using assms
proof (induct xs arbitrary: env)
  case Nil
  then have False by simp
  then show ?case ..
next
  case (Cons x xs)
  show ?case
  proof (cases env)
    case Val
    then show ?thesis by simp
  next
    case (Env b es)
    show ?thesis
    proof (cases "es x")
      case None
      with Env show ?thesis by simp
    next
      case (Some e)
      note es = \<open>es x = Some e\<close>
      show ?thesis
      proof (cases "lookup e xs")
        case None
        then have "lookup e (xs @ ys) = None" by (rule Cons.hyps)
        with Env Some show ?thesis by simp
      next
        case Some
        with Env es have False using Cons.prems by simp
        then show ?thesis ..
      qed
    qed
  qed
qed

theorem lookup_append_some:
  assumes "lookup env xs = Some e"
  shows "lookup env (xs @ ys) = lookup e ys"
  using assms
proof (induct xs arbitrary: env e)
  case Nil
  then have "env = e" by simp
  then show "lookup env ([] @ ys) = lookup e ys" by simp
next
  case (Cons x xs)
  note asm = \<open>lookup env (x # xs) = Some e\<close>
  show "lookup env ((x # xs) @ ys) = lookup e ys"
  proof (cases env)
    case (Val a)
    with asm have False by simp
    then show ?thesis ..
  next
    case (Env b es)
    show ?thesis
    proof (cases "es x")
      case None
      with asm Env have False by simp
      then show ?thesis ..
    next
      case (Some e')
      note es = \<open>es x = Some e'\<close>
      show ?thesis
      proof (cases "lookup e' xs")
        case None
        with asm Env es have False by simp
        then show ?thesis ..
      next
        case Some
        with asm Env es have "lookup e' xs = Some e"
          by simp
        then have "lookup e' (xs @ ys) = lookup e ys" by (rule Cons.hyps)
        with Env es show ?thesis by simp
      qed
    qed
  qed
qed

text \<open>
  \medskip Successful @{term lookup} deeper down an environment
  structure means we are able to peek further up as well.  Note that
  this is basically just the contrapositive statement of @{thm
  [source] lookup_append_none} above.
\<close>

theorem lookup_some_append:
  assumes "lookup env (xs @ ys) = Some e"
  shows "\<exists>e. lookup env xs = Some e"
proof -
  from assms have "lookup env (xs @ ys) \<noteq> None" by simp
  then have "lookup env xs \<noteq> None"
    by (rule contrapos_nn) (simp only: lookup_append_none)
  then show ?thesis by (simp)
qed

text \<open>
  The subsequent statement describes in more detail how a successful
  @{term lookup} with a non-empty path results in a certain situation
  at any upper position.
\<close>

theorem lookup_some_upper:
  assumes "lookup env (xs @ y # ys) = Some e"
  shows "\<exists>b' es' env'.
    lookup env xs = Some (Env b' es') \<and>
    es' y = Some env' \<and>
    lookup env' ys = Some e"
  using assms
proof (induct xs arbitrary: env e)
  case Nil
  from Nil.prems have "lookup env (y # ys) = Some e"
    by simp
  then obtain b' es' env' where
      env: "env = Env b' es'" and
      es': "es' y = Some env'" and
      look': "lookup env' ys = Some e"
    by (auto simp add: lookup_eq split: option.splits env.splits)
  from env have "lookup env [] = Some (Env b' es')" by simp
  with es' look' show ?case by blast
next
  case (Cons x xs)
  from Cons.prems
  obtain b' es' env' where
      env: "env = Env b' es'" and
      es': "es' x = Some env'" and
      look': "lookup env' (xs @ y # ys) = Some e"
    by (auto simp add: lookup_eq split: option.splits env.splits)
  from Cons.hyps [OF look'] obtain b'' es'' env'' where
      upper': "lookup env' xs = Some (Env b'' es'')" and
      es'': "es'' y = Some env''" and
      look'': "lookup env'' ys = Some e"
    by blast
  from env es' upper' have "lookup env (x # xs) = Some (Env b'' es'')"
    by simp
  with es'' look'' show ?case by blast
qed

subsection \<open>The update operation\<close>

text \<open>
  Update at a certain position in a nested environment may either
  delete an existing entry, or overwrite an existing one.  Note that
  update at undefined positions is simple absorbed, i.e.\ the
  environment is left unchanged.
\<close>

primrec update :: "'c list \<Rightarrow> ('a, 'b, 'c) env option \<Rightarrow>
    ('a, 'b, 'c) env \<Rightarrow> ('a, 'b, 'c) env"
  and update_option :: "'c list \<Rightarrow> ('a, 'b, 'c) env option \<Rightarrow>
    ('a, 'b, 'c) env option \<Rightarrow> ('a, 'b, 'c) env option"
where
  "update xs opt (Val a) =
    (if xs = [] then (case opt of None \<Rightarrow> Val a | Some e \<Rightarrow> e)
     else Val a)"
| "update xs opt (Env b es) =
    (case xs of
      [] \<Rightarrow> (case opt of None \<Rightarrow> Env b es | Some e \<Rightarrow> e)
    | y # ys \<Rightarrow> Env b (es (y := update_option ys opt (es y))))"
| "update_option xs opt None =
    (if xs = [] then opt else None)"
| "update_option xs opt (Some e) =
    (if xs = [] then opt else Some (update xs opt e))"

hide_const update_option

text \<open>
  \medskip The characteristic cases of @{term update} are expressed by
  the following equalities.
\<close>

theorem update_nil_none: "update [] None env = env"
  by (cases env) simp_all

theorem update_nil_some: "update [] (Some e) env = e"
  by (cases env) simp_all

theorem update_cons_val: "update (x # xs) opt (Val a) = Val a"
  by simp

theorem update_cons_nil_env:
    "update [x] opt (Env b es) = Env b (es (x := opt))"
  by (cases "es x") simp_all

theorem update_cons_cons_env:
  "update (x # y # ys) opt (Env b es) =
    Env b (es (x :=
      (case es x of
        None \<Rightarrow> None
      | Some e \<Rightarrow> Some (update (y # ys) opt e))))"
  by (cases "es x") simp_all

lemmas update.simps [simp del] update_option.simps [simp del]
  and update_simps [simp] = update_nil_none update_nil_some
    update_cons_val update_cons_nil_env update_cons_cons_env

lemma update_eq:
  "update xs opt env =
    (case xs of
      [] \<Rightarrow>
        (case opt of
          None \<Rightarrow> env
        | Some e \<Rightarrow> e)
    | x # xs \<Rightarrow>
        (case env of
          Val a \<Rightarrow> Val a
        | Env b es \<Rightarrow>
            (case xs of
              [] \<Rightarrow> Env b (es (x := opt))
            | y # ys \<Rightarrow>
                Env b (es (x :=
                  (case es x of
                    None \<Rightarrow> None
                  | Some e \<Rightarrow> Some (update (y # ys) opt e)))))))"
  by (simp split: list.split env.split option.split)

text \<open>
  \medskip The most basic correspondence of @{term lookup} and @{term
  update} states that after @{term update} at a defined position,
  subsequent @{term lookup} operations would yield the new value.
\<close>

theorem lookup_update_some:
  assumes "lookup env xs = Some e"
  shows "lookup (update xs (Some env') env) xs = Some env'"
  using assms
proof (induct xs arbitrary: env e)
  case Nil
  then have "env = e" by simp
  then show ?case by simp
next
  case (Cons x xs)
  note hyp = Cons.hyps
    and asm = \<open>lookup env (x # xs) = Some e\<close>
  show ?case
  proof (cases env)
    case (Val a)
    with asm have False by simp
    then show ?thesis ..
  next
    case (Env b es)
    show ?thesis
    proof (cases "es x")
      case None
      with asm Env have False by simp
      then show ?thesis ..
    next
      case (Some e')
      note es = \<open>es x = Some e'\<close>
      show ?thesis
      proof (cases xs)
        case Nil
        with Env show ?thesis by simp
      next
        case (Cons x' xs')
        from asm Env es have "lookup e' xs = Some e" by simp
        then have "lookup (update xs (Some env') e') xs = Some env'" by (rule hyp)
        with Env es Cons show ?thesis by simp
      qed
    qed
  qed
qed

text \<open>
  \medskip The properties of displaced @{term update} operations are
  analogous to those of @{term lookup} above.  There are two cases:
  below an undefined position @{term update} is absorbed altogether,
  and below a defined positions @{term update} affects subsequent
  @{term lookup} operations in the obvious way.
\<close>

theorem update_append_none:
  assumes "lookup env xs = None"
  shows "update (xs @ y # ys) opt env = env"
  using assms
proof (induct xs arbitrary: env)
  case Nil
  then have False by simp
  then show ?case ..
next
  case (Cons x xs)
  note hyp = Cons.hyps
    and asm = \<open>lookup env (x # xs) = None\<close>
  show "update ((x # xs) @ y # ys) opt env = env"
  proof (cases env)
    case (Val a)
    then show ?thesis by simp
  next
    case (Env b es)
    show ?thesis
    proof (cases "es x")
      case None
      note es = \<open>es x = None\<close>
      show ?thesis
        by (cases xs) (simp_all add: es Env fun_upd_idem_iff)
    next
      case (Some e)
      note es = \<open>es x = Some e\<close>
      show ?thesis
      proof (cases xs)
        case Nil
        with asm Env Some have False by simp
        then show ?thesis ..
      next
        case (Cons x' xs')
        from asm Env es have "lookup e xs = None" by simp
        then have "update (xs @ y # ys) opt e = e" by (rule hyp)
        with Env es Cons show "update ((x # xs) @ y # ys) opt env = env"
          by (simp add: fun_upd_idem_iff)
      qed
    qed
  qed
qed

theorem update_append_some:
  assumes "lookup env xs = Some e"
  shows "lookup (update (xs @ y # ys) opt env) xs = Some (update (y # ys) opt e)"
  using assms
proof (induct xs arbitrary: env e)
  case Nil
  then have "env = e" by simp
  then show ?case by simp
next
  case (Cons x xs)
  note hyp = Cons.hyps
    and asm = \<open>lookup env (x # xs) = Some e\<close>
  show "lookup (update ((x # xs) @ y # ys) opt env) (x # xs) =
      Some (update (y # ys) opt e)"
  proof (cases env)
    case (Val a)
    with asm have False by simp
    then show ?thesis ..
  next
    case (Env b es)
    show ?thesis
    proof (cases "es x")
      case None
      with asm Env have False by simp
      then show ?thesis ..
    next
      case (Some e')
      note es = \<open>es x = Some e'\<close>
      show ?thesis
      proof (cases xs)
        case Nil
        with asm Env es have "e = e'" by simp
        with Env es Nil show ?thesis by simp
      next
        case (Cons x' xs')
        from asm Env es have "lookup e' xs = Some e" by simp
        then have "lookup (update (xs @ y # ys) opt e') xs =
          Some (update (y # ys) opt e)" by (rule hyp)
        with Env es Cons show ?thesis by simp
      qed
    qed
  qed
qed

text \<open>
  \medskip Apparently, @{term update} does not affect the result of
  subsequent @{term lookup} operations at independent positions, i.e.\
  in case that the paths for @{term update} and @{term lookup} fork at
  a certain point.
\<close>

theorem lookup_update_other:
  assumes neq: "y \<noteq> (z::'c)"
  shows "lookup (update (xs @ z # zs) opt env) (xs @ y # ys) =
    lookup env (xs @ y # ys)"
proof (induct xs arbitrary: env)
  case Nil
  show ?case
  proof (cases env)
    case Val
    then show ?thesis by simp
  next
    case Env
    show ?thesis
    proof (cases zs)
      case Nil
      with neq Env show ?thesis by simp
    next
      case Cons
      with neq Env show ?thesis by simp
    qed
  qed
next
  case (Cons x xs)
  note hyp = Cons.hyps
  show ?case
  proof (cases env)
    case Val
    then show ?thesis by simp
  next
    case (Env y es)
    show ?thesis
    proof (cases xs)
      case Nil
      show ?thesis
      proof (cases "es x")
        case None
        with Env Nil show ?thesis by simp
      next
        case Some
        with neq hyp and Env Nil show ?thesis by simp
      qed
    next
      case (Cons x' xs')
      show ?thesis
      proof (cases "es x")
        case None
        with Env Cons show ?thesis by simp
      next
        case Some
        with neq hyp and Env Cons show ?thesis by simp
      qed
    qed
  qed
qed

subsection \<open>Code generation\<close>

lemma [code, code del]:
  "(HOL.equal :: (_, _, _) env \<Rightarrow> _) = HOL.equal" ..

lemma equal_env_code [code]:
  fixes x y :: "'a::equal"
    and f g :: "'c::{equal, finite} \<Rightarrow> ('b::equal, 'a, 'c) env option"
  shows
    "HOL.equal (Env x f) (Env y g) \<longleftrightarrow>
      HOL.equal x y \<and> (\<forall>z \<in> UNIV.
        case f z of
          None \<Rightarrow> (case g z of None \<Rightarrow> True | Some _ \<Rightarrow> False)
        | Some a \<Rightarrow> (case g z of None \<Rightarrow> False | Some b \<Rightarrow> HOL.equal a b))" (is ?env)
    and "HOL.equal (Val a) (Val b) \<longleftrightarrow> HOL.equal a b"
    and "HOL.equal (Val a) (Env y g) \<longleftrightarrow> False"
    and "HOL.equal (Env x f) (Val b) \<longleftrightarrow> False"
proof (unfold equal)
  have "f = g \<longleftrightarrow>
    (\<forall>z. case f z of
      None \<Rightarrow> (case g z of None \<Rightarrow> True | Some _ \<Rightarrow> False)
    | Some a \<Rightarrow> (case g z of None \<Rightarrow> False | Some b \<Rightarrow> a = b))" (is "?lhs = ?rhs")
  proof
    assume ?lhs
    then show ?rhs by (auto split: option.splits)
  next
    assume ?rhs (is "\<forall>z. ?prop z")
    show ?lhs
    proof
      fix z
      from \<open>?rhs\<close> have "?prop z" ..
      then show "f z = g z" by (auto split: option.splits)
    qed
  qed
  then show "Env x f = Env y g \<longleftrightarrow>
    x = y \<and> (\<forall>z \<in> UNIV.
      case f z of
        None \<Rightarrow> (case g z of None \<Rightarrow> True | Some _ \<Rightarrow> False)
      | Some a \<Rightarrow> (case g z of None \<Rightarrow> False | Some b \<Rightarrow> a = b))" by simp
qed simp_all

lemma [code nbe]: "HOL.equal (x :: (_, _, _) env) x \<longleftrightarrow> True"
  by (fact equal_refl)

end


(*  Title:       Coinductive natural numbers
    Author:      Andreas Lochbihler
    Maintainer:  Andreas Lochbihler
*)

header {* Extended natural numbers as a codatatype *}

theory Coinductive_Nat imports
  "~~/src/HOL/Library/Extended_Nat"
  Complete_Partial_Order2
begin

lemma inj_enat [simp]: "inj_on enat A"
by(simp add: inj_on_def)

lemma Sup_range_enat [simp]: "Sup (range enat) = \<infinity>"
by(auto dest: finite_imageD simp add: Sup_enat_def)

lemmas eSuc_plus = iadd_Suc

lemmas plus_enat_eq_0_conv = iadd_is_0

lemma enat_add_sub_same:
  fixes a b :: enat shows "a \<noteq> \<infinity> \<Longrightarrow> a + b - a = b"
by(cases b) auto

lemma enat_the_enat: "n \<noteq> \<infinity> \<Longrightarrow> enat (the_enat n) = n"
by auto

lemma enat_min_eq_0_iff:
  fixes a b :: enat
  shows "min a b = 0 \<longleftrightarrow> a = 0 \<or> b = 0"
by(auto simp add: min_def)

lemma enat_le_plus_same: "x \<le> (x :: enat) + y" "x \<le> y + x"
by(auto simp add: less_eq_enat_def plus_enat_def split: enat.split)

lemma the_enat_0 [simp]: "the_enat 0 = 0"
by(simp add: zero_enat_def)

lemma the_enat_eSuc: "n \<noteq> \<infinity> \<Longrightarrow> the_enat (eSuc n) = Suc (the_enat n)"
by(cases n)(simp_all add: eSuc_enat)

coinductive_set enat_set :: "enat set"
where "0 \<in> enat_set"
  | "n \<in> enat_set \<Longrightarrow> (eSuc n) \<in> enat_set"

lemma enat_set_eq_UNIV [simp]: "enat_set = UNIV"
proof
  show "enat_set \<subseteq> UNIV" by blast
  show "UNIV \<subseteq> enat_set"
  proof
    fix x :: enat
    assume "x \<in> UNIV"
    thus "x \<in> enat_set"
    proof coinduct
      case (enat_set x)
      show ?case
      proof(cases "x = 0")
        case True thus ?thesis by simp
      next
        case False
        then obtain n where "x = eSuc n"
          by(cases x)(fastforce simp add: eSuc_def zero_enat_def gr0_conv_Suc
                               split: enat.splits)+
        thus ?thesis by auto
      qed
    qed
  qed
qed

subsection {* Case operator *}

lemma enat_coexhaust:
  obtains (0) "n = 0"
     | (eSuc) n' where "n = eSuc n'"
proof -
  have "n \<in> enat_set" by auto
  thus thesis by cases (erule that)+
qed

locale co begin

free_constructors (plugins del: code) case_enat for
    "0::enat"
  | eSuc epred
where
  "epred 0 = 0"
  apply (erule enat_coexhaust, assumption)
 apply (rule eSuc_inject)
by (rule zero_ne_eSuc)

end

lemma enat_cocase_0 [simp]: "co.case_enat z s 0 = z"
by (rule co.enat.case(1))

lemma enat_cocase_eSuc [simp]: "co.case_enat z s (eSuc n) = s n"
by (rule co.enat.case(2))

lemma neq_zero_conv_eSuc: "n \<noteq> 0 \<longleftrightarrow> (\<exists>n'. n = eSuc n')"
by(cases n rule: enat_coexhaust) simp_all

lemma enat_cocase_cert:
  assumes "CASE \<equiv> co.case_enat c d"
  shows "(CASE 0 \<equiv> c) &&& (CASE (eSuc n) \<equiv> d n)"
  using assms by simp_all

lemma enat_cosplit_asm:
  "P (co.case_enat c d n) = (\<not> (n = 0 \<and> \<not> P c \<or> (\<exists>m. n = eSuc m \<and> \<not> P (d m))))"
by (rule co.enat.split_asm)

lemma enat_cosplit:
  "P (co.case_enat c d n) = ((n = 0 \<longrightarrow> P c) \<and> (\<forall>m. n = eSuc m \<longrightarrow> P (d m)))"
by (rule co.enat.split)

abbreviation epred :: "enat => enat" where "epred \<equiv> co.epred"

lemma epred_0 [simp]: "epred 0 = 0" by(rule co.enat.sel(1))
lemma epred_eSuc [simp]: "epred (eSuc n) = n" by(rule co.enat.sel(2))
declare co.enat.collapse[simp]
lemma epred_conv_minus: "epred n = n - 1"
by(cases n rule: co.enat.exhaust)(simp_all)

subsection {* Corecursion for @{typ enat} *}

lemma case_enat_numeral [simp]: "case_enat f i (numeral v) = (let n = numeral v in f n)"
by(simp add: numeral_eq_enat)

lemma case_enat_0 [simp]: "case_enat f i 0 = f 0"
by(simp add: zero_enat_def)

definition epred_numeral :: "num \<Rightarrow> enat"
where [code del]: "epred_numeral = enat \<circ> pred_numeral"

lemma numeral_eq_eSuc: "numeral k = eSuc (epred_numeral k)"
by(simp add: numeral_eq_Suc eSuc_def epred_numeral_def numeral_eq_enat)

lemma epred_numeral_simps [simp]:
  "epred_numeral num.One = 0"
  "epred_numeral (num.Bit0 k) = numeral (Num.BitM k)"
  "epred_numeral (num.Bit1 k) = numeral (num.Bit0 k)"
by(simp_all add: epred_numeral_def enat_numeral zero_enat_def)

lemma [simp]:
  shows eq_numeral_eSuc: "numeral k = eSuc n \<longleftrightarrow> epred_numeral k = n"
  and Suc_eq_numeral: "eSuc n = numeral k \<longleftrightarrow> n = epred_numeral k"
  and less_numeral_Suc: "numeral k < eSuc n \<longleftrightarrow> epred_numeral k < n"
  and less_eSuc_numeral: "eSuc n < numeral k \<longleftrightarrow> n < epred_numeral k"
  and le_numeral_eSuc: "numeral k \<le> eSuc n \<longleftrightarrow> epred_numeral k \<le> n"
  and le_eSuc_numeral: "eSuc n \<le> numeral k \<longleftrightarrow> n \<le> epred_numeral k"
  and diff_eSuc_numeral: "eSuc n - numeral k = n - epred_numeral k"
  and diff_numeral_eSuc: "numeral k - eSuc n = epred_numeral k - n"
  and max_eSuc_numeral: "max (eSuc n) (numeral k) = eSuc (max n (epred_numeral k))"
  and max_numeral_eSuc: "max (numeral k) (eSuc n) = eSuc (max (epred_numeral k) n)"
  and min_eSuc_numeral: "min (eSuc n) (numeral k) = eSuc (min n (epred_numeral k))"
  and min_numeral_eSuc: "min (numeral k) (eSuc n) = eSuc (min (epred_numeral k) n)"
by(simp_all add: numeral_eq_eSuc)

lemma enat_cocase_numeral [simp]:
  "co.case_enat a f (numeral v) = (let pv = epred_numeral v in f pv)"
by(simp add: numeral_eq_eSuc)

lemma enat_cocase_add_eq_if [simp]:
  "co.case_enat a f ((numeral v) + n) = (let pv = epred_numeral v in f (pv + n))"
by(simp add: numeral_eq_eSuc iadd_Suc)

lemma [simp]:
  shows epred_1: "epred 1 = 0"
  and epred_numeral: "epred (numeral i) = epred_numeral i"
  and epred_Infty: "epred \<infinity> = \<infinity>"
  and epred_enat: "epred (enat m) = enat (m - 1)"
by(simp_all add: epred_conv_minus one_enat_def zero_enat_def eSuc_def epred_numeral_def numeral_eq_enat split: enat.split)

lemmas epred_simps = epred_0 epred_1 epred_numeral epred_eSuc epred_Infty epred_enat

lemma epred_iadd1: "a \<noteq> 0 \<Longrightarrow> epred (a + b) = epred a + b"
apply(cases a b rule: enat.exhaust[case_product enat.exhaust])
apply(simp_all add: epred_conv_minus eSuc_def one_enat_def zero_enat_def split: enat.splits)
done

lemma epred_min [simp]: "epred (min a b) = min (epred a) (epred b)"
by(cases a b rule: enat_coexhaust[case_product enat_coexhaust]) simp_all

lemma epred_le_epredI: "n \<le> m \<Longrightarrow> epred n \<le> epred m"
by(cases m n rule: enat_coexhaust[case_product enat_coexhaust]) simp_all

lemma epred_minus_epred [simp]:
  "m \<noteq> 0 \<Longrightarrow> epred n - epred m = n - m"
by(cases n m rule: enat_coexhaust[case_product enat_coexhaust])(simp_all add: epred_conv_minus)

lemma eSuc_epred: "n \<noteq> 0 \<Longrightarrow> eSuc (epred n) = n"
by(cases n rule: enat_coexhaust) simp_all

lemma epred_inject: "\<lbrakk> x \<noteq> 0; y \<noteq> 0 \<rbrakk> \<Longrightarrow> epred x = epred y \<longleftrightarrow> x = y"
by(cases x y rule: enat.exhaust[case_product enat.exhaust])(auto simp add: zero_enat_def)

lemma monotone_fun_eSuc[partial_function_mono]:
    "monotone (fun_ord (\<lambda>y x. x \<le> y)) (\<lambda>y x. x \<le> y) (\<lambda>f. eSuc (f x))"
  by (auto simp: monotone_def fun_ord_def)

partial_function (gfp) enat_unfold :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> enat" where
  enat_unfold [code, nitpick_simp]:
  "enat_unfold stop next a = (if stop a then 0 else eSuc (enat_unfold stop next (next a)))"

lemma enat_unfold_stop [simp]: "stop a \<Longrightarrow> enat_unfold stop next a = 0"
by(simp add: enat_unfold)

lemma enat_unfold_next: "\<not> stop a \<Longrightarrow> enat_unfold stop next a = eSuc (enat_unfold stop next (next a))"
by(simp add: enat_unfold)

lemma enat_unfold_eq_0 [simp]:
  "enat_unfold stop next a = 0 \<longleftrightarrow> stop a"
by(simp add: enat_unfold)

lemma epred_max: "epred (max x y) = max (epred x) (epred y)"
by(cases x y rule: enat.exhaust[case_product enat.exhaust]) simp_all

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

lemma finite_imageD2: "\<lbrakk> finite (f ` A); inj_on f (A - B); finite B \<rbrakk> \<Longrightarrow> finite A"
by (metis Diff_subset finite_Diff2 image_mono inj_on_finite)

lemma epred_Sup: "epred (Sup A) = Sup (epred ` A)"
by(auto 4 4 simp add: bot_enat_def Sup_enat_def epred_Max inj_on_def neq_zero_conv_eSuc dest: finite_imageD2[where B="{0}"])

subsection {* Less as greatest fixpoint *}

coinductive_set Le_enat :: "(enat \<times> enat) set"
where
  Le_enat_zero: "(0, n) \<in> Le_enat"
| Le_enat_add: "\<lbrakk> (m, n) \<in> Le_enat; k \<noteq> 0 \<rbrakk> \<Longrightarrow> (eSuc m, n + k) \<in> Le_enat"

lemma ile_into_Le_enat:
  "m \<le> n \<Longrightarrow> (m, n) \<in> Le_enat"
proof -
  assume "m \<le> n"
  hence "(m, n) \<in> {(m, n)|m n. m \<le> n}" by simp
  thus ?thesis
  proof coinduct
    case (Le_enat m n)
    hence "m \<le> n" by simp
    show ?case
    proof(cases "m = 0")
      case True
      hence ?Le_enat_zero by simp
      thus ?thesis ..
    next
      case False
      with `m \<le> n` obtain m' n' where "m = eSuc m'" "n = n' + 1" "m' \<le> n'"
        by(cases m rule: enat_coexhaust, simp)
          (cases n rule: enat_coexhaust, auto simp add: eSuc_plus_1[symmetric])
      hence ?Le_enat_add by fastforce
      thus ?thesis ..
    qed
  qed
qed

lemma Le_enat_imp_ile_enat_k:
  "(m, n) \<in> Le_enat \<Longrightarrow> n < enat l \<Longrightarrow> m < enat l"
proof(induct l arbitrary: m n)
  case 0
  thus ?case by(simp add: zero_enat_def[symmetric])
next
  case (Suc l)
  from `(m, n) \<in> Le_enat` show ?case
  proof cases
    case Le_enat_zero
    with `n < enat (Suc l)` show ?thesis by auto
  next
    case (Le_enat_add M N K)
    from `n = N + K` `n < enat (Suc l)` `K \<noteq> 0`
    have "N < enat l" by(cases N)(cases K, auto simp add: zero_enat_def)
    with `(M, N) \<in> Le_enat` have "M < enat l" by(rule Suc)
    with `m = eSuc M` show ?thesis by(simp add: eSuc_enat[symmetric])
  qed
qed

lemma enat_less_imp_le:
  assumes k: "!!k. n < enat k \<Longrightarrow> m < enat k"
  shows "m \<le> n"
proof(cases n)
  case (enat n')
  with k[of "Suc n'"] show ?thesis by(cases m) simp_all
qed simp

lemma Le_enat_imp_ile:
  "(m, n) \<in> Le_enat \<Longrightarrow> m \<le> n"
by(rule enat_less_imp_le)(erule Le_enat_imp_ile_enat_k)

lemma Le_enat_eq_ile:
  "(m, n) \<in> Le_enat \<longleftrightarrow> m \<le> n"
by(blast intro: Le_enat_imp_ile ile_into_Le_enat)

lemma enat_leI [consumes 1, case_names Leenat, case_conclusion Leenat zero eSuc]:
  assumes major: "(m, n) \<in> X"
  and step:
    "\<And>m n. (m, n) \<in> X
     \<Longrightarrow> m = 0 \<or> (\<exists>m' n' k. m = eSuc m' \<and> n = n' + enat k \<and> k \<noteq> 0 \<and>
                           ((m', n') \<in> X \<or> m' \<le> n'))"
  shows "m \<le> n"
apply(rule Le_enat.coinduct[unfolded Le_enat_eq_ile, where X="\<lambda>x y. (x, y) \<in> X"])
apply(fastforce simp add: zero_enat_def dest: step intro: major)+
done

lemma enat_le_coinduct[consumes 1, case_names le, case_conclusion le 0 eSuc]:
  assumes P: "P m n"
  and step:
    "\<And>m n. P m n
     \<Longrightarrow> (n = 0 \<longrightarrow> m = 0) \<and>
         (m \<noteq> 0 \<longrightarrow> n \<noteq> 0 \<longrightarrow> (\<exists>k n'. P (epred m) n' \<and> epred n = n' + k) \<or> epred m \<le> epred n)"
  shows "m \<le> n"
proof -
  from P have "(m, n) \<in> {(m, n). P m n}" by simp
  thus ?thesis
  proof(coinduct rule: enat_leI)
    case (Leenat m n)
    hence "P m n" by simp
    show ?case
    proof(cases m rule: enat_coexhaust)
      case 0
      thus ?thesis by simp
    next
      case (eSuc m')
      with step[OF `P m n`]
      have "n \<noteq> 0" and disj: "(\<exists>k n'. P m' n' \<and> epred n = n' + k) \<or> m' \<le> epred n" by auto
      from `n \<noteq> 0` obtain n' where n': "n = eSuc n'"
        by(cases n rule: enat_coexhaust) auto
      from disj show ?thesis
      proof
        assume "m' \<le> epred n"
        with eSuc n' show ?thesis
          by(auto 4 3 intro: exI[where x="Suc 0"] simp add: eSuc_enat[symmetric] iadd_Suc_right zero_enat_def[symmetric])
      next
        assume "\<exists>k n'. P m' n' \<and> epred n = n' + k"
        then obtain k n'' where n'': "epred n = n'' + k" and k: "P m' n''" by blast
        show ?thesis using eSuc k n' n''
          by(cases k)(auto 4 3 simp add: iadd_Suc_right[symmetric] eSuc_enat intro: exI[where x=\<infinity>])
      qed
    qed
  qed
qed

subsection {* Equality as greatest fixpoint *}

lemma enat_equalityI [consumes 1, case_names Eq_enat,
                                  case_conclusion Eq_enat zero eSuc]:
  assumes major: "(m, n) \<in> X"
  and step:
    "\<And>m n. (m, n) \<in> X
     \<Longrightarrow> m = 0 \<and> n = 0 \<or> (\<exists>m' n'. m = eSuc m' \<and> n = eSuc n' \<and> ((m', n') \<in> X \<or> m' = n'))"
  shows "m = n"
proof(rule antisym)
  from major show "m \<le> n"
    by(coinduct rule: enat_leI)
      (drule step, auto simp add: eSuc_plus_1 enat_1[symmetric])

  from major have "(n, m) \<in> {(n, m). (m, n) \<in> X}" by simp
  thus "n \<le> m"
  proof(coinduct rule: enat_leI)
    case (Leenat n m)
    hence "(m, n) \<in> X" by simp
    from step[OF this] show ?case
      by(auto simp add: eSuc_plus_1 enat_1[symmetric])
  qed
qed

lemma enat_coinduct [consumes 1, case_names Eq_enat, case_conclusion Eq_enat zero eSuc]:
  assumes major: "P m n"
  and step: "\<And>m n. P m n
    \<Longrightarrow> (m = 0 \<longleftrightarrow> n = 0) \<and>
       (m \<noteq> 0 \<longrightarrow> n \<noteq> 0 \<longrightarrow> P (epred m) (epred n) \<or> epred m = epred n)"
  shows "m = n"
proof -
  from major have "(m, n) \<in> {(m, n). P m n}" by simp
  thus ?thesis
  proof(coinduct rule: enat_equalityI)
    case (Eq_enat m n)
    hence "P m n" by simp
    from step[OF this] show ?case
      by(cases m n rule: enat_coexhaust[case_product enat_coexhaust]) auto
  qed
qed

lemma enat_coinduct2 [consumes 1, case_names zero eSuc]:
  "\<lbrakk> P m n; \<And>m n. P m n \<Longrightarrow> m = 0 \<longleftrightarrow> n = 0;
     \<And>m n. \<lbrakk> P m n; m \<noteq> 0; n \<noteq> 0 \<rbrakk> \<Longrightarrow> P (epred m) (epred n) \<or> epred m = epred n \<rbrakk>
  \<Longrightarrow> m = n"
by(erule enat_coinduct) blast

subsection {* Uniqueness of corecursion *}

lemma enat_unfold_unique:
  assumes h: "!!x. h x = (if stop x then 0 else eSuc (h (next x)))"
  shows "h x = enat_unfold stop next x"
by(coinduction arbitrary: x rule: enat_coinduct)(subst (1 3) h, auto)

subsection {* Setup for partial\_function *}

lemma enat_diff_cancel_left: "\<lbrakk> m \<le> x; m \<le> y \<rbrakk> \<Longrightarrow> x - m = y - m \<longleftrightarrow> x = (y :: enat)"
by(cases x y m rule: enat.exhaust[case_product enat.exhaust[case_product enat.exhaust]])(simp_all, arith)

lemma finite_lessThan_enatI:
  assumes "m \<noteq> \<infinity>"
  shows "finite {..<m :: enat}"
proof -
  from assms obtain m' where m: "m = enat m'" by auto
  have "{..<enat m'} \<subseteq> enat ` {..<m'}"
    by(rule subsetI)(case_tac x, auto)
  thus ?thesis unfolding m by(rule finite_subset) simp
qed

lemma infinite_lessThan_infty: "\<not> finite {..<\<infinity> :: enat}"
proof
  have "range enat \<subseteq> {..<\<infinity>}" by auto
  moreover assume "finite {..<\<infinity> :: enat}"
  ultimately have "finite (range enat)" by(rule finite_subset)
  hence "finite (UNIV :: nat set)"
    by(rule finite_imageD)(simp add: inj_on_def)
  thus False by simp
qed

lemma finite_lessThan_enat_iff:
  "finite {..<m :: enat} \<longleftrightarrow> m \<noteq> \<infinity>"
by(cases m)(auto intro: finite_lessThan_enatI simp add: infinite_lessThan_infty)

lemma eSuc_max: "eSuc (max x y) = max (eSuc x) (eSuc y)"
by(cases x y rule: enat.exhaust[case_product enat.exhaust]) simp_all

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

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

lemma enat_minus_mono1: "x \<le> y \<Longrightarrow> x - m \<le> y - (m :: enat)"
by(cases m x y rule: enat.exhaust[case_product enat.exhaust[case_product enat.exhaust]]) simp_all

lemma max_enat_minus1: "max n m - k = max (n - k) (m - k :: enat)"
by(cases n m k rule: enat.exhaust[case_product enat.exhaust[case_product enat.exhaust]]) simp_all

lemma Max_enat_minus1:
  assumes "finite A" "A \<noteq> {}"
  shows "Max A - m = Max ((\<lambda>n :: enat. n - m) ` A)"
using assms proof induct
  case (insert x A)
  thus ?case by(cases "A = {}")(simp_all add: max_enat_minus1)
qed simp

lemma Sup_enat_minus1:
  assumes "m \<noteq> \<infinity>"
  shows "\<Squnion>A - m = \<Squnion>((\<lambda>n :: enat. n - m) ` A)"
proof -
  from assms obtain m' where "m = enat m'" by auto
  thus ?thesis
    by(auto simp add: Sup_enat_def Max_enat_minus1 finite_lessThan_enat_iff enat_diff_cancel_left inj_on_def dest!: finite_imageD2[where B="{..<enat m'}"])
qed

lemma Sup_image_eadd1:
  assumes "Y \<noteq> {}"
  shows "Sup ((\<lambda>y :: enat. x + y) ` Y) = x + Sup Y"
proof(cases "finite Y")
  case True
  have "op + x ` Y = {x + m |m. m \<in> Y}" by auto
  thus ?thesis using True by(simp add: Sup_enat_def add_Max_commute assms)
next
  case False
  thus ?thesis
  proof(cases x)
    case (enat x')
    hence "\<not> finite (op + x ` Y)" using False
      by(auto dest!: finite_imageD intro: inj_onI)
    with False show ?thesis by(simp add: Sup_enat_def assms)
  next
    case infinity
    hence "op + x ` Y = {\<infinity>}" using assms by auto
    thus ?thesis using infinity by(simp add: image_constant_conv assms)
  qed
qed

lemma Sup_image_eadd2:
  "Y \<noteq> {} \<Longrightarrow> Sup ((\<lambda>y :: enat. y + x) ` Y) = Sup Y + x"
by(subst (1 2) add.commute)(rule Sup_image_eadd1)

lemma mono2mono_eSuc [THEN lfp.mono2mono, cont_intro, simp]:
  shows monotone_eSuc: "monotone op \<le> op \<le> eSuc"
by(rule monotoneI) simp

lemma mcont2mcont_eSuc [THEN lfp.mcont2mcont, cont_intro, simp]:
  shows mcont_eSuc: "mcont Sup op \<le> Sup op \<le> eSuc"
by(intro mcontI contI)(simp_all add: monotone_eSuc eSuc_Sup)

lemma mono2mono_epred [THEN lfp.mono2mono, cont_intro, simp]:
  shows monotone_epred: "monotone op \<le> op \<le> epred"
by(rule monotoneI)(simp add: epred_le_epredI)

lemma mcont2mcont_epred [THEN lfp.mcont2mcont, cont_intro, simp]:
  shows mcont_epred: "mcont Sup op \<le> Sup op \<le> epred"
by(simp add: mcont_def monotone_epred cont_def epred_Sup)

lemma enat_cocase_mono [partial_function_mono, cont_intro]:
  "\<lbrakk> monotone orda ordb zero; \<And>n. monotone orda ordb (\<lambda>f. esuc f n) \<rbrakk>
  \<Longrightarrow> monotone orda ordb (\<lambda>f. co.case_enat (zero f) (esuc f) x)"
by(cases x rule: co.enat.exhaust)(simp_all add: assms)

lemma enat_cocase_mcont [cont_intro, simp]:
  "\<lbrakk> mcont luba orda lubb ordb zero; \<And>n. mcont luba orda lubb ordb (\<lambda>f. esuc f n) \<rbrakk>
  \<Longrightarrow> mcont luba orda lubb ordb (\<lambda>f. co.case_enat (zero f) (esuc f) x)"
by(cases x rule: co.enat.exhaust)(simp_all add: assms)

lemma eSuc_mono [partial_function_mono]:
  "monotone (fun_ord op \<le>) op \<le> f \<Longrightarrow> monotone (fun_ord op \<le>) op \<le> (\<lambda>x. eSuc (f x))"
by(rule mono2mono_eSuc)

lemma mono2mono_enat_minus1 [THEN lfp.mono2mono, cont_intro, simp]:
  shows monotone_enat_minus1: "monotone op \<le> op \<le> (\<lambda>n. n - m :: enat)"
by(rule monotoneI)(rule enat_minus_mono1)

lemma mcont2mcont_enat_minus [THEN lfp.mcont2mcont, cont_intro, simp]:
  shows mcont_enat_minus: "m \<noteq> \<infinity> \<Longrightarrow> mcont Sup op \<le> Sup op \<le> (\<lambda>n. n - m :: enat)"
by(rule mcontI)(simp_all add: monotone_enat_minus1 contI Sup_enat_minus1)

lemma monotone_eadd1: "monotone op \<le> op \<le> (\<lambda>x. x + y :: enat)"
by(auto intro!: monotoneI)

lemma monotone_eadd2: "monotone op \<le> op \<le> (\<lambda>y. x + y :: enat)"
by(auto intro!: monotoneI)

lemma mono2mono_eadd[THEN lfp.mono2mono2, cont_intro, simp]:
  shows monotone_eadd: "monotone (rel_prod op \<le> op \<le>) op \<le> (\<lambda>(x, y). x + y :: enat)"
by(simp add: monotone_eadd1 monotone_eadd2)

lemma mcont_eadd2: "mcont Sup op \<le> Sup op \<le> (\<lambda>y. x + y :: enat)"
by(auto intro: mcontI monotone_eadd2 contI Sup_image_eadd1[symmetric])

lemma mcont_eadd1: "mcont Sup op \<le> Sup op \<le> (\<lambda>x. x + y :: enat)"
by(auto intro: mcontI monotone_eadd1 contI Sup_image_eadd2[symmetric])

lemma mcont2mcont_eadd [cont_intro, simp]:
  "\<lbrakk> mcont lub ord Sup op \<le> (\<lambda>x. f x);
    mcont lub ord Sup op \<le> (\<lambda>x. g x) \<rbrakk>
  \<Longrightarrow> mcont lub ord Sup op \<le> (\<lambda>x. f x + g x :: enat)"
by(best intro: ccpo.mcont2mcont'[OF complete_lattice_ccpo] mcont_eadd1 mcont_eadd2 ccpo.mcont_const[OF complete_lattice_ccpo])

lemma eadd_partial_function_mono [partial_function_mono]:
  "\<lbrakk> monotone (fun_ord op \<le>) op \<le> f; monotone (fun_ord op \<le>) op \<le> g \<rbrakk>
  \<Longrightarrow> monotone (fun_ord op \<le>) op \<le> (\<lambda>x. f x + g x :: enat)"
by(rule mono2mono_eadd)

lemma monotone_max_enat1: "monotone op \<le> op \<le> (\<lambda>x. max x y :: enat)"
by(auto intro!: monotoneI simp add: max_def)

lemma monotone_max_enat2: "monotone op \<le> op \<le> (\<lambda>y. max x y :: enat)"
by(auto intro!: monotoneI simp add: max_def)

lemma mono2mono_max_enat[THEN lfp.mono2mono2, cont_intro, simp]:
  shows monotone_max_enat: "monotone (rel_prod op \<le> op \<le>) op \<le> (\<lambda>(x, y). max x y :: enat)"
by(simp add: monotone_max_enat1 monotone_max_enat2)

lemma max_Sup_enat2:
  assumes "Y \<noteq> {}"
  shows "max x (Sup Y) = Sup ((\<lambda>y :: enat. max x y) ` Y)"
proof(cases "finite Y")
  case True
  hence "max x (Max Y) = Max (max x ` Y)" using assms
  proof(induct)
    case (insert y Y)
    thus ?case
      by(cases "Y = {}")(simp_all, metis max.assoc max.left_commute max.left_idem)
  qed simp
  thus ?thesis using True by(simp add: Sup_enat_def assms)
next
  case False
  show ?thesis
  proof(cases x)
    case infinity
    hence "max x ` Y = {\<infinity>}" using assms by auto
    thus ?thesis using False by(simp add: Sup_enat_def assms)
  next
    case (enat x')
    { assume "finite (max x ` Y)"
      hence "finite (max x ` {y \<in> Y. y > x})"
        by(rule finite_subset[rotated]) auto
      hence "finite {y \<in> Y. y > x}"
        by(rule finite_imageD)(auto intro!: inj_onI simp add: max_def split: split_if_asm)
      moreover have "finite {y \<in> Y. y \<le> x}"
        by(rule finite_enat_bounded)(auto simp add: enat)
      ultimately have "finite ({y \<in> Y. y > x} \<union> {y \<in> Y. y \<le> x})" by simp
      also have "{y \<in> Y. y > x} \<union> {y \<in> Y. y \<le> x} = Y" by auto
      finally have "finite Y" . }
    thus ?thesis using False by(auto simp add: Sup_enat_def assms)
  qed
qed

lemma max_Sup_enat1:
  "Y \<noteq> {} \<Longrightarrow> max (Sup Y) x = Sup ((\<lambda>y :: enat. max y x) ` Y)"
by(subst (1 2) max.commute)(rule max_Sup_enat2)

lemma mcont_max_enat1: "mcont Sup op \<le> Sup op \<le> (\<lambda>x. max x y :: enat)"
by(auto intro!: mcontI contI max_Sup_enat1 simp add: monotone_max_enat1)

lemma mcont_max_enat2: "mcont Sup op \<le> Sup op \<le> (\<lambda>y. max x y :: enat)"
by(auto intro!: mcontI contI max_Sup_enat2 simp add: monotone_max_enat2)

lemma mcont2mcont_max_enat [cont_intro, simp]:
  "\<lbrakk> mcont lub ord Sup op \<le> (\<lambda>x. f x);
    mcont lub ord Sup op \<le> (\<lambda>x. g x) \<rbrakk>
  \<Longrightarrow> mcont lub ord Sup op \<le> (\<lambda>x. max (f x) (g x) :: enat)"
by(best intro: ccpo.mcont2mcont'[OF complete_lattice_ccpo] mcont_max_enat1 mcont_max_enat2 ccpo.mcont_const[OF complete_lattice_ccpo])

lemma max_enat_partial_function_mono [partial_function_mono]:
  "\<lbrakk> monotone (fun_ord op \<le>) op \<le> f; monotone (fun_ord op \<le>) op \<le> g \<rbrakk>
  \<Longrightarrow> monotone (fun_ord op \<le>) op \<le> (\<lambda>x. max (f x) (g x) :: enat)"
by(rule mono2mono_max_enat)

lemma chain_epredI:
  "Complete_Partial_Order.chain op \<le> Y
  \<Longrightarrow> Complete_Partial_Order.chain op \<le> (epred ` (Y \<inter> {x. x \<noteq> 0}))"
by(auto intro: chainI dest: chainD)

lemma monotone_enat_le_case:
  fixes bot
  assumes mono: "monotone op \<le> ord (\<lambda>x. f x (eSuc x))"
  and ord: "\<And>x. ord bot (f x (eSuc x))"
  and bot: "ord bot bot"
  shows "monotone op \<le> ord (\<lambda>x. case x of 0 \<Rightarrow> bot | eSuc x' \<Rightarrow> f x' x)"
proof -
  have "monotone op \<le> ord (\<lambda>x. if x \<le> 0 then bot else f (epred x) x)"
  proof(rule monotone_if_bot)
    fix x y :: enat
    assume "x \<le> y" "\<not> x \<le> 0"
    thus "ord (f (epred x) x) (f (epred y) y)"
      by(cases x y rule: co.enat.exhaust[case_product co.enat.exhaust])(auto intro: monotoneD[OF mono])
  next
    fix x :: enat
    assume "\<not> x \<le> 0"
    thus "ord bot (f (epred x) x)"
      by(cases x rule: co.enat.exhaust)(auto intro: ord)
  qed(rule bot)
  also have "(\<lambda>x. if x \<le> 0 then bot else f (epred x) x) = (\<lambda>x. case x of 0 \<Rightarrow> bot | eSuc x' \<Rightarrow> f x' x)"
    by(auto simp add: fun_eq_iff split: co.enat.split)
  finally show ?thesis .
qed

lemma mcont_enat_le_case:
  fixes bot
  assumes ccpo: "class.ccpo lub ord (mk_less ord)"
  and mcont: "mcont Sup op \<le> lub ord (\<lambda>x. f x (eSuc x))"
  and ord: "\<And>x. ord bot (f x (eSuc x))"
  shows "mcont Sup op \<le> lub ord (\<lambda>x. case x of 0 \<Rightarrow> bot | eSuc x' \<Rightarrow> f x' x)"
proof -
  from ccpo
  have "mcont Sup op \<le> lub ord (\<lambda>x. if x \<le> 0 then bot else f (epred x) x)"
  proof(rule mcont_if_bot)
    fix x y :: enat
    assume "x \<le> y" "\<not> x \<le> 0"
    thus "ord (f (epred x) x) (f (epred y) y)"
      by(cases x y rule: co.enat.exhaust[case_product co.enat.exhaust])(auto intro: mcont_monoD[OF mcont])
  next
    fix Y :: "enat set"
    assume chain: "Complete_Partial_Order.chain op \<le> Y"
      and Y: "Y \<noteq> {}" "\<And>x. x \<in> Y \<Longrightarrow> \<not> x \<le> 0"
    from Y have Y': "Y \<inter> {x. x \<noteq> 0} \<noteq> {}" by auto
    from Y(2) have eq: "Y = eSuc ` (epred ` (Y \<inter> {x. x \<noteq> 0}))"
      by(fastforce intro: rev_image_eqI)
    show "f (epred (Sup Y)) (Sup Y) = lub ((\<lambda>x. f (epred x) x) ` Y)"
      by(subst (1 2 3) eq)(simp add: mcont[THEN mcont_contD] mcont_eSuc[THEN mcont_contD, symmetric] Y' chain_epredI[OF chain] del: Sup_image_eq, simp add: image_image)
  next
    fix x :: enat
    assume "\<not> x \<le> 0"
    thus "ord bot (f (epred x) x)"
      by(cases x rule: co.enat.exhaust)(auto intro: ord)
  qed
  also have "(\<lambda>x. if x \<le> 0 then bot else f (epred x) x) = (\<lambda>x. case x of 0 \<Rightarrow> bot | eSuc x' \<Rightarrow> f x' x)"
    by(auto simp add: fun_eq_iff split: co.enat.split)
  finally show ?thesis .
qed

subsection {* Misc. *}

lemma enat_add_mono [simp]:
  "enat x + y < enat x + z \<longleftrightarrow> y < z"
by(cases y)(case_tac [!] z, simp_all)

lemma enat_add1_eq [simp]: "enat x + y = enat x + z \<longleftrightarrow> y = z"
by (metis enat_add_mono add.commute neq_iff)

lemma enat_add2_eq [simp]: "y + enat x = z + enat x \<longleftrightarrow> y = z"
by (metis enat_add1_eq add.commute)

lemma enat_less_enat_plusI: "x < y \<Longrightarrow> enat x < enat y + z"
by(cases z) simp_all

lemma enat_less_enat_plusI2:
  "enat y < z \<Longrightarrow> enat (x + y) < enat x + z"
by (metis enat_add_mono plus_enat_simps(1))

lemma min_enat1_conv_enat: "\<And>a b. min (enat a) b = enat (case b of enat b' \<Rightarrow> min a b' | \<infinity> \<Rightarrow> a)"
  and min_enat2_conv_enat: "\<And>a b. min a (enat b) = enat (case a of enat a' \<Rightarrow> min a' b | \<infinity> \<Rightarrow> b)"
by(simp_all split: enat.split)

lemma eSuc_le_iff: "eSuc x \<le> y \<longleftrightarrow> (\<exists>y'. y = eSuc y' \<and> x \<le> y')"
by(cases y rule: co.enat.exhaust) simp_all

lemma eSuc_eq_infinity_iff: "eSuc n = \<infinity> \<longleftrightarrow> n = \<infinity>"
by(cases n)(simp_all add: zero_enat_def eSuc_enat)

lemma infinity_eq_eSuc_iff: "\<infinity> = eSuc n \<longleftrightarrow> n = \<infinity>"
by(cases n)(simp_all add: zero_enat_def eSuc_enat)

lemma enat_cocase_inf: "(case \<infinity> of 0 \<Rightarrow> a | eSuc b \<Rightarrow> f b) = f \<infinity>"
by(auto split: co.enat.split simp add: infinity_eq_eSuc_iff)

end