(*<*)
theory GoedelProof_P2
imports IHOML
begin
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3,  atoms e = a b c d]
sledgehammer_params[verbose=true]
(*>*)

subsection \<open>Part II - God's Existence is Necessary if Possible\<close>

text\<open>  We show here that God's necessary existence follows from its possible existence by adding some
 additional (potentially controversial) assumptions including an \emph{essentialist} premise
 and the \emph{S5} axioms.
 Further results like monotheism and the rejection of free will (\emph{modal collapse}) are also proved.
  \<close>

subsubsection \<open>General Definitions\<close>

abbreviation existencePredicate::"\<up>\<langle>\<zero>\<rangle>" ("E!") where
  "E! x  \<equiv> (\<lambda>w. (\<^bold>\<exists>\<^sup>Ey. y\<^bold>\<approx>x) w)"

consts positiveProperty::"\<up>\<langle>\<up>\<langle>\<zero>\<rangle>\<rangle>" ("\<P>")

abbreviation God::"\<up>\<langle>\<zero>\<rangle>" ("G") where "G \<equiv> (\<lambda>x. \<^bold>\<forall>Y. \<P> Y \<^bold>\<rightarrow> Y x)"
abbreviation God_star::"\<up>\<langle>\<zero>\<rangle>" ("G*") where
  "G* \<equiv> (\<lambda>x. \<^bold>\<forall>Y. \<P> Y \<^bold>\<leftrightarrow> Y x)"

abbreviation Entailment::"\<up>\<langle>\<up>\<langle>\<zero>\<rangle>,\<up>\<langle>\<zero>\<rangle>\<rangle>" (infix "\<Rrightarrow>" 60) where
  "X \<Rrightarrow> Y \<equiv>  \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. X z \<^bold>\<rightarrow> Y z)"

subsubsection \<open>Results from Part I\<close>

text\<open>  Note that the only use G\"odel makes of axiom A3 is to show that being Godlike is a positive property (\emph{T2}).
 We follow therefore Scott's proposal and take (\emph{T2}) directly as an axiom:  \<close>
axiomatization where
  A1a:"\<lfloor>\<^bold>\<forall>X. \<P> (\<^bold>\<rightharpoondown>X) \<^bold>\<rightarrow> \<^bold>\<not>(\<P> X) \<rfloor>" and          \<comment> \<open>axiom 11.3A\<close>
  A1b:"\<lfloor>\<^bold>\<forall>X. \<^bold>\<not>(\<P> X) \<^bold>\<rightarrow> \<P> (\<^bold>\<rightharpoondown>X)\<rfloor>" and           \<comment> \<open>axiom 11.3B\<close>
  A2: "\<lfloor>\<^bold>\<forall>X Y. (\<P> X \<^bold>\<and> (X \<Rrightarrow> Y)) \<^bold>\<rightarrow> \<P> Y\<rfloor>" and    \<comment> \<open>axiom 11.5\<close>
  T2: "\<lfloor>\<P> G\<rfloor>"                                  \<comment> \<open>proposition 11.16\<close>

lemma True nitpick[satisfy] oops \<comment> \<open>model found: axioms are consistent\<close>

lemma "\<lfloor>D\<rfloor>"  using A1a A1b A2 by blast \<comment> \<open>axioms already imply \emph{D} axiom\<close>

lemma GodDefsAreEquivalent: "\<lfloor>\<^bold>\<forall>x. G x \<^bold>\<leftrightarrow> G* x\<rfloor>" using A1b by fastforce

theorem T1: "\<lfloor>\<^bold>\<forall>X. \<P> X \<^bold>\<rightarrow> \<^bold>\<diamond>\<^bold>\<exists>\<^sup>E X\<rfloor>"
  using A1a A2 by blast  \<comment> \<open>positive properties are possibly instantiated\<close>
theorem T3: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists>\<^sup>E G\<rfloor>" using T1 T2 by simp  \<comment> \<open>God exists possibly\<close>

subsubsection \<open>Axioms\<close>

text\<open>  \<open>\<P>\<close> satisfies the so-called stability conditions (see @{cite "Fitting"}, p. 124), which means
 it designates rigidly (note that this makes for an \emph{essentialist} assumption). \<close>
axiomatization where
      A4a: "\<lfloor>\<^bold>\<forall>X. \<P> X \<^bold>\<rightarrow> \<^bold>\<box>(\<P> X)\<rfloor>"      \<comment> \<open>axiom 11.11\<close>
lemma A4b: "\<lfloor>\<^bold>\<forall>X. \<^bold>\<not>(\<P> X) \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<not>(\<P> X)\<rfloor>" using A1a A1b A4a by blast

abbreviation rigidPred::"('t\<Rightarrow>io)\<Rightarrow>io" where
 "rigidPred \<tau> \<equiv> (\<lambda>\<beta>. \<^bold>\<box>((\<lambda>z. \<beta> \<^bold>\<approx> z) \<^bold>\<down>\<tau>)) \<^bold>\<down>\<tau>"

lemma "\<lfloor>rigidPred \<P>\<rfloor>"
  using A4a A4b by blast \<comment> \<open>@{term "\<P>"} is therefore rigid\<close>

lemma True nitpick[satisfy] oops \<comment> \<open>model found: so far all axioms A1-4 consistent\<close>
text\<open> \bigbreak \<close>

subsubsection \<open>Theorems\<close>
text\<open>  Remark: Essence is defined here (and in Fitting's variant) in the version of Scott; G\"odel's original version leads to the inconsistency
 reported in @{cite C55 and C60} \<close>

abbreviation essenceOf::"\<up>\<langle>\<up>\<langle>\<zero>\<rangle>,\<zero>\<rangle>" ("\<E>") where
  "\<E> Y x \<equiv> (Y x) \<^bold>\<and> (\<^bold>\<forall>Z. Z x \<^bold>\<rightarrow> Y \<Rrightarrow> Z)"
abbreviation beingIdenticalTo::"\<zero>\<Rightarrow>\<up>\<langle>\<zero>\<rangle>" ("id") where
  "id x  \<equiv> (\<lambda>y. y\<^bold>\<approx>x)"  \<comment> \<open>note that \emph{id} is a rigid predicate\<close>

text\<open>  Theorem 11.20 - Informal Proposition 5  \<close>
theorem GodIsEssential: "\<lfloor>\<^bold>\<forall>x. G x \<^bold>\<rightarrow> (\<E> G x)\<rfloor>" using A1b A4a by metis

text\<open>  Theorem 11.21  \<close>
theorem "\<lfloor>\<^bold>\<forall>x. G* x \<^bold>\<rightarrow> (\<E> G* x)\<rfloor>" using A4a by meson

text\<open>  Theorem 11.22 - Something can have only one essence:  \<close>
theorem "\<lfloor>\<^bold>\<forall>X Y z. (\<E> X z \<^bold>\<and> \<E> Y z) \<^bold>\<rightarrow> (X \<Rrightarrow> Y)\<rfloor>" by meson

text\<open>  Theorem 11.23 - An essence is a complete characterization of an individual:  \<close>
theorem EssencesCharacterizeCompletely: "\<lfloor>\<^bold>\<forall>X y. \<E> X y \<^bold>\<rightarrow> (X \<Rrightarrow> (id y))\<rfloor>"
proof (rule ccontr)
  assume "\<not> \<lfloor>\<^bold>\<forall>X y. \<E> X y \<^bold>\<rightarrow> (X \<Rrightarrow> (id y))\<rfloor>"
  hence "\<exists>w. \<not>(( \<^bold>\<forall>X y. \<E> X y \<^bold>\<rightarrow> X \<Rrightarrow> id y) w)" by simp
  then obtain w where "\<not>(( \<^bold>\<forall>X y. \<E> X y \<^bold>\<rightarrow> X \<Rrightarrow> id y) w)" ..
  hence "(\<^bold>\<exists>X y. \<E> X y \<^bold>\<and> \<^bold>\<not>(X \<Rrightarrow> id y)) w" by simp
  hence "\<exists>X y. \<E> X y w \<and> (\<^bold>\<not>(X \<Rrightarrow> id y)) w" by simp
  then obtain P where "\<exists>y. \<E> P y w \<and> (\<^bold>\<not>(P \<Rrightarrow> id y)) w" ..
  then obtain a where 1: "\<E> P a w \<and> (\<^bold>\<not>(P \<Rrightarrow> id a)) w" ..
  hence 2: "\<E> P a w" by (rule conjunct1)
  from 1 have "(\<^bold>\<not>(P \<Rrightarrow> id a)) w" by (rule conjunct2)
  hence "\<exists>x. \<exists>z. w r x \<and>  existsAt z x \<and> P z x \<and> \<not>(a = z)" by blast
  then obtain w1 where "\<exists>z. w r w1 \<and>  existsAt z w1 \<and> P z w1 \<and> \<not>(a = z)" ..
  then obtain b where 3: "w r w1 \<and>  existsAt b w1 \<and> P b w1 \<and> \<not>(a = b)" ..
  hence "w r w1" by simp
  from 3 have "existsAt b w1" by simp
  from 3 have "P b w1" by simp
  from 3 have 4: " \<not>(a = b)" by simp
  from 2 have "P a w" by simp
  from 2 have "\<forall>Y. Y a w \<longrightarrow> ((P \<Rrightarrow> Y) w)" by auto
  hence "(\<^bold>\<rightharpoondown>(id b)) a w \<longrightarrow> (P \<Rrightarrow> (\<^bold>\<rightharpoondown>(id b))) w" by (rule allE)
  hence "\<not>(\<^bold>\<rightharpoondown>(id b)) a w \<or> ((P \<Rrightarrow> (\<^bold>\<rightharpoondown>(id b))) w)" by blast
  then show False proof
    assume "\<not>(\<^bold>\<rightharpoondown>(id b)) a w"
    hence "a = b" by simp
    thus False using 4 by auto
    next
    assume "((P \<Rrightarrow> (\<^bold>\<rightharpoondown>(id b))) w)"
    hence "\<forall>x. \<forall>z. (w r x \<and> existsAt z x \<and> P z x) \<longrightarrow> (\<^bold>\<rightharpoondown>(id b)) z x" by blast
    hence "\<forall>z. (w r w1 \<and> existsAt z w1 \<and> P z w1) \<longrightarrow> (\<^bold>\<rightharpoondown>(id b)) z w1"
        by (rule allE)
    hence "(w r w1 \<and> existsAt b w1 \<and> P b w1) \<longrightarrow> (\<^bold>\<rightharpoondown>(id b)) b w1" by (rule allE)
    hence  "\<not>(w r w1 \<and> existsAt b w1 \<and> P b w1) \<or> (\<^bold>\<rightharpoondown>(id b)) b w1" by simp
    hence "(\<^bold>\<rightharpoondown>(id b)) b w" using 3 by simp
    hence "\<not>(b=b)" by simp
    thus False by simp
  qed
qed

text\<open>  Definition 11.24 - Necessary Existence (Informal Definition 6):  \<close>
abbreviation necessaryExistencePred::"\<up>\<langle>\<zero>\<rangle>" ("NE")
  where "NE x  \<equiv> (\<lambda>w. (\<^bold>\<forall>Y.  \<E> Y x \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E Y) w)"

text\<open>  Axiom 11.25 (Informal Axiom 5) \<close>
axiomatization where
 A5: "\<lfloor>\<P> NE\<rfloor>"

lemma True nitpick[satisfy] oops \<comment> \<open>model found: so far all axioms consistent\<close>

text\<open>  Theorem 11.26 (Informal Proposition 7) - Possibilist existence of God implies necessary actualist existence:  \<close>
theorem GodExistenceImpliesNecExistence: "\<lfloor>\<^bold>\<exists> G \<^bold>\<rightarrow>  \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>"
proof -
{
  fix w
  {
    assume "\<exists>x. G x w"
    then obtain g where 1: "G g w" ..
    hence "NE g w" using A5 by auto                     \<comment> \<open>axiom 11.25\<close>
    hence "\<forall>Y. (\<E> Y g w) \<longrightarrow> (\<^bold>\<box>\<^bold>\<exists>\<^sup>E Y) w" by simp
    hence 2: "(\<E> G g w) \<longrightarrow> (\<^bold>\<box>\<^bold>\<exists>\<^sup>E G) w" by (rule allE)
    have  "(\<^bold>\<forall>x. G x \<^bold>\<rightarrow> (\<E> G x)) w" using GodIsEssential
      by (rule allE)     \<comment> \<open>GodIsEssential follows from Axioms 11.11 and 11.3B\<close>
    hence  "(G g \<^bold>\<rightarrow> (\<E> G g)) w" by (rule allE)
    hence  "G g w \<longrightarrow> \<E> G g w" by simp
    from this 1 have 3: "\<E> G g w" by (rule mp)
    from 2 3 have "(\<^bold>\<box>\<^bold>\<exists>\<^sup>E G) w" by (rule mp)
  }
  hence "(\<exists>x. G x w) \<longrightarrow> (\<^bold>\<box>\<^bold>\<exists>\<^sup>E G) w" by (rule impI)
  hence "((\<^bold>\<exists>x. G x) \<^bold>\<rightarrow>  \<^bold>\<box>\<^bold>\<exists>\<^sup>E G) w" by simp
}
 thus ?thesis by (rule allI)
qed

text\<open>  \emph{Modal collapse} is countersatisfiable (unless we introduce S5 axioms): \<close>
lemma "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> (\<^bold>\<box> \<Phi>))\<rfloor>" nitpick oops

text\<open>  We postulate semantic frame conditions for some modal logics. Taken together, reflexivity, transitivity and symmetry
 make for an equivalence relation and therefore an \emph{S5} logic (via \emph{Sahlqvist correspondence}).
 We prefer to postulate them individually here in order to get more detailed information about their relevance
 in the proofs presented below. \<close>
axiomatization where
 refl: "reflexive aRel" and
 tran: "transitive aRel" and
 symm: "symmetric aRel"

lemma True nitpick[satisfy] oops \<comment> \<open>model found: axioms still consistent\<close>
text\<open>  Using an \emph{S5} logic, \emph{modal collapse} (\<open>\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> (\<^bold>\<box> \<Phi>))\<rfloor>\<close>) is actually valid (see `More Objections' some pages below) \<close>

text\<open>  We prove some useful inference rules: \<close>
lemma modal_distr: "\<lfloor>\<^bold>\<box>(\<phi> \<^bold>\<rightarrow> \<psi>)\<rfloor> \<Longrightarrow> \<lfloor>(\<^bold>\<diamond>\<phi> \<^bold>\<rightarrow> \<^bold>\<diamond>\<psi>)\<rfloor>" by blast
lemma modal_trans: "(\<lfloor>\<phi> \<^bold>\<rightarrow> \<psi>\<rfloor> \<and> \<lfloor>\<psi> \<^bold>\<rightarrow> \<chi>\<rfloor>) \<Longrightarrow> \<lfloor>\<phi> \<^bold>\<rightarrow> \<chi>\<rfloor>" by simp

text\<open>  Theorem 11.27 - Informal Proposition 8. Note that only symmetry and transitivity for the accessibility relation are used. \<close>
theorem possExistenceImpliesNecEx: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists> G \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" \<comment> \<open>local consequence\<close>
proof -
  have "\<lfloor>\<^bold>\<exists> G \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" using GodExistenceImpliesNecExistence
    by simp \<comment> \<open>follows from Axioms 11.11, 11.25 and 11.3B\<close>
  hence "\<lfloor>\<^bold>\<box>(\<^bold>\<exists> G \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G)\<rfloor>" using NEC by simp
  hence 1: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists> G \<^bold>\<rightarrow> \<^bold>\<diamond>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" by (rule modal_distr)
  have 2: "\<lfloor>\<^bold>\<diamond>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" using symm tran by metis \<comment> \<open>frame conditions\<close>
  from 1 2 have "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists> G \<^bold>\<rightarrow> \<^bold>\<diamond>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor> \<and> \<lfloor>\<^bold>\<diamond>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" by simp
  thus ?thesis by (rule modal_trans)
qed

lemma T4: "\<lfloor>\<^bold>\<diamond>\<^bold>\<exists> G\<rfloor> \<longrightarrow> \<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" using possExistenceImpliesNecEx
    by (rule localImpGlobalCons)  \<comment> \<open>global consequence\<close>

text\<open>  Corollary 11.28 - Necessary (actualist) existence of God (for both definitions); reflexivity is still not used:  \<close>
lemma GodNecExists: "\<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G\<rfloor>" using T3 T4 by metis
lemma God_starNecExists: "\<lfloor>\<^bold>\<box>\<^bold>\<exists>\<^sup>E G*\<rfloor>"
  using GodNecExists GodDefsAreEquivalent by simp

subsubsection \<open>Monotheism\<close>

text\<open>  Monotheism for non-normal models (with Leibniz equality) follows directly from God having all and only positive properties:  \<close>
theorem Monotheism_LeibnizEq: "\<lfloor>\<^bold>\<forall>x. G x \<^bold>\<rightarrow> (\<^bold>\<forall>y. G y \<^bold>\<rightarrow> (x  \<^bold>\<approx>\<^sup>L y))\<rfloor>"
  using GodDefsAreEquivalent by simp

text\<open>  Monotheism for normal models is trickier. We need to consider some previous results (p. 162): \<close>

lemma GodExistenceIsValid: "\<lfloor>\<^bold>\<exists>\<^sup>E G\<rfloor>" using GodNecExists refl
  by auto \<comment> \<open>reflexivity is now required by the solver\<close>

text\<open>  Proposition 11.29:  \<close>
theorem Monotheism_normalModel: "\<lfloor>\<^bold>\<exists>x.\<^bold>\<forall>y. G y \<^bold>\<leftrightarrow> x \<^bold>\<approx> y\<rfloor>"
proof -
{
  fix w
  have "\<lfloor>\<^bold>\<exists>\<^sup>E G\<rfloor>" using GodExistenceIsValid by simp \<comment> \<open>follows from corollary 11.28\<close>
  hence "(\<^bold>\<exists>\<^sup>E G) w" by (rule allE)
  then obtain g where 1: "existsAt g w \<and> G g w" ..
  hence 2: "\<E> G g w" using GodIsEssential by blast \<comment> \<open>follows from ax. 11.11/11.3B\<close>
  {
    fix y
    have "G y w \<longleftrightarrow> (g \<^bold>\<approx> y) w" proof
      assume "G y w"
      hence 3: "\<E> G y w" using GodIsEssential by blast
      have "(\<E> G y \<^bold>\<rightarrow> (G \<Rrightarrow> id y)) w" using EssencesCharacterizeCompletely
        by simp \<comment> \<open>follows from theorem 11.23\<close>
      hence "\<E> G y w \<longrightarrow> ((G \<Rrightarrow> id y) w)" by simp
      from this 3 have "(G \<Rrightarrow> id y) w" by (rule mp)
      hence "(\<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. G z \<^bold>\<rightarrow> z \<^bold>\<approx> y)) w" by simp
      hence "\<forall>x. w r x \<longrightarrow> ((\<forall>z. (existsAt z x \<and> G z x) \<longrightarrow> z = y))" by auto
      hence "w r w \<longrightarrow> ((\<forall>z. (existsAt z w \<and> G z w) \<longrightarrow> z = y))" by (rule allE)
      hence "\<forall>z. (w r w \<and> existsAt z w \<and> G z w) \<longrightarrow> z = y" by auto
      hence 4: "(w r w \<and> existsAt g w \<and> G g w) \<longrightarrow> g = y" by (rule allE)
      have "w r w" using refl
        by simp \<comment> \<open>using frame reflexivity (Axiom M)\<close>
      hence  "w r w \<and> (existsAt g w \<and> G g w)" using 1 by (rule conjI)
      from 4 this have "g = y" by (rule mp)
      thus "(g \<^bold>\<approx> y) w" by simp
    next
      assume "(g \<^bold>\<approx> y) w"
      from this 2 have "\<E> G y w" by simp
      thus "G y w " by (rule conjunct1)
    qed
  }
  hence "\<forall>y. G y w \<longleftrightarrow> (g \<^bold>\<approx> y) w" by (rule allI)
  hence "\<exists>x. (\<forall>y. G y w \<longleftrightarrow> (x \<^bold>\<approx> y) w)" by (rule exI)
  hence "(\<^bold>\<exists>x. (\<^bold>\<forall>y. G y \<^bold>\<leftrightarrow> (x \<^bold>\<approx> y))) w" by simp
}
thus ?thesis by (rule allI)
qed
text\<open> \bigbreak \<close>
text\<open> Corollary 11.30:  \<close>
lemma GodImpliesExistence: "\<lfloor>\<^bold>\<forall>x. G x \<^bold>\<rightarrow> E! x\<rfloor>"
  using GodExistenceIsValid Monotheism_normalModel by metis

subsubsection \<open>Positive Properties are Necessarily Instantiated\<close>

lemma PosPropertiesNecExist: "\<lfloor>\<^bold>\<forall>Y. \<P> Y \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<exists>\<^sup>E Y\<rfloor>" using GodNecExists A4a
  by meson \<comment> \<open>proposition 11.31: follows from corollary 11.28 and axiom A4a\<close>

subsubsection \<open>More Objections\<close>
text\<open>  Fitting discusses the objection raised by Sobel @{cite "sobel2004logic"}, who argues that G\"odel's axiom system
 is too strong: it implies that whatever is the case is so necessarily, i.e. the modal system collapses (\<open>\<phi> \<longrightarrow> \<box>\<phi>\<close>).
 The \emph{modal collapse} has been philosophically interpreted as implying the absence of free will. \<close>

text\<open>  We start by proving an useful FOL lemma: \<close>
lemma useful: "(\<forall>x. \<phi> x \<longrightarrow> \<psi>) \<Longrightarrow> ((\<exists>x. \<phi> x) \<longrightarrow> \<psi>)" by simp

text\<open>  In the context of our S5 axioms, the \emph{modal collapse} becomes valid (pp. 163-4):  \<close>
lemma ModalCollapse: "\<lfloor>\<^bold>\<forall>\<Phi>.(\<Phi> \<^bold>\<rightarrow> (\<^bold>\<box> \<Phi>))\<rfloor>"
proof -
  {
  fix w
   {
    fix Q
    have "(\<^bold>\<forall>x. G x \<^bold>\<rightarrow> (\<E> G x)) w" using GodIsEssential
      by (rule allE) \<comment> \<open>follows from Axioms 11.11 and 11.3B\<close>
    hence "\<forall>x. G x w \<longrightarrow> \<E> G x w" by simp
    hence "\<forall>x. G x w \<longrightarrow> (\<^bold>\<forall>Z. Z x \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. G z \<^bold>\<rightarrow> Z z)) w" by force
    hence "\<forall>x. G x w \<longrightarrow> ((\<lambda>y. Q) x \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. G z \<^bold>\<rightarrow> (\<lambda>y. Q) z)) w" by force
    hence "\<forall>x. G x w \<longrightarrow> (Q \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. G z \<^bold>\<rightarrow> Q)) w" by simp
    hence 1: "(\<exists>x. G x w) \<longrightarrow> ((Q \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. G z \<^bold>\<rightarrow> Q)) w)" by (rule useful)
    have "\<exists>x. G x w" using GodExistenceIsValid by auto
    from 1 this have "(Q \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>\<^sup>Ez. G z \<^bold>\<rightarrow> Q)) w" by (rule mp)
    hence "(Q \<^bold>\<rightarrow> \<^bold>\<box>((\<^bold>\<exists>\<^sup>Ez. G z) \<^bold>\<rightarrow> Q)) w" using useful by blast
    hence "(Q \<^bold>\<rightarrow> (\<^bold>\<box>(\<^bold>\<exists>\<^sup>Ez. G z) \<^bold>\<rightarrow> \<^bold>\<box>Q)) w" by simp
    hence "(Q \<^bold>\<rightarrow> \<^bold>\<box>Q) w" using GodNecExists by simp
   }
  hence "(\<^bold>\<forall>\<Phi>. \<Phi> \<^bold>\<rightarrow> \<^bold>\<box> \<Phi>) w" by (rule allI)
  }
  thus ?thesis by (rule allI)
qed
  text\<open>  \pagebreak \<close>

(*<*)
end
(*>*)


subsection "Examples for quantitative Hoare logic"
theory QuantK_Examples
imports QuantK_VCG
begin

fun sum :: "int \<Rightarrow> int" where
"sum i = (if i \<le> 0 then 0 else sum (i - 1) + i)"

abbreviation "wsum ==
  WHILE Less (N 0) (V ''x'')
  DO (''y'' ::= Plus (V ''y'') (V ''x'');;
      ''x'' ::= Plus (V ''x'') (N (- 1)))"

lemma example: "\<turnstile>\<^sub>2\<^sub>' {\<lambda>s. enat (2 + 3*n) + emb (s ''x'' = int n)} ''y'' ::= N 0;; wsum {\<lambda>s. 0 }"
apply(rule Seq)
 prefer 2
 apply(rule conseq')
 apply(rule While[where I="\<lambda>s. enat (3 * nat (s ''x''))"])
  apply(rule Seq)
   prefer 2
      apply(rule Assign)
      apply(rule Assign')
     apply(simp)
     apply(safe) subgoal for s apply(cases "0 < s ''x''") apply(simp)
    apply (smt Suc_eq_plus1 Suc_nat_eq_nat_zadd1 distrib_left_numeral eSuc_numeral enat_numeral eq_iff iadd_Suc_right nat_mult_1_right one_add_one plus_1_eSuc(1) plus_enat_simps(1) semiring_norm(5))
    apply(simp) done
    apply blast
  apply simp
apply(rule Assign')
apply simp
  apply(safe) subgoal for s apply(cases "s ''x'' = int n") apply(simp)
     apply (simp add: eSuc_enat plus_1_eSuc(2))
    apply simp
    done
  done

end


theory Extended_CJ_DDL                    (*David Fuenmayor and C. Benzmüller, 2019*)
  imports CJ_DDLplus
begin
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3]

section \<open>Extending the Carmo and Jones DDL Logical Framework\<close>

subsection \<open>Context Features\<close>

(**To keep things simple (and relevant for our task) we restrict ourselves to representing a context c as the pair: @{text "\<langle>Agent(c), World(c)\<rangle>"}.
For this purpose we represent the functional concepts "Agent" and "World" as logical constants.*)
consts Agent::"c\<Rightarrow>e"  (**function retrieving the agent corresponding to context c*)
consts World::"c\<Rightarrow>w"  (**function retrieving the world corresponding to context c*)

subsection \<open>Logical Validity\<close>

(**Kaplan's notion of (context-dependent) logical truth for a sentence corresponds to its (context-sensitive) formula
(of type @{text "c\<Rightarrow>w\<Rightarrow>bool"} i.e. m) being true in the given context and at its corresponding world.*)
abbreviation ldtruectx::"m\<Rightarrow>c\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>_") where "\<lfloor>\<phi>\<rfloor>\<^sub>c \<equiv> \<phi> c (World c)"

(**Kaplan's LD notion of logical validity for a sentence corresponds to its being true in all contexts.
This notion is also known as indexical validity.*)
abbreviation ldvalid::"m\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sup>D") where "\<lfloor>\<phi>\<rfloor>\<^sup>D \<equiv> \<forall>c. \<lfloor>\<phi>\<rfloor>\<^sub>c"

(**Here we show that indexical validity is indeed weaker than its classical modal counterpart (truth at all worlds for all contexts):*)
lemma "\<lfloor>A\<rfloor> \<Longrightarrow> \<lfloor>A\<rfloor>\<^sup>D" by simp
lemma "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>A\<rfloor>" nitpick oops (**countermodel found*)

(**Here we show that the interplay between indexical validity and the DDL modal and deontic operators does not
result in modal collapse.*)
lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>O\<^sub>aP\<rfloor>\<^sup>D" nitpick oops
lemma "\<lfloor>P \<^bold>\<rightarrow> \<^bold>\<box>\<^sub>aP\<rfloor>\<^sup>D" nitpick oops

(**Next we show that the necessitation rule does not work for indexical validity (in contrast to classical modal validity as defined for DDL).*)
lemma "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>aA\<rfloor>\<^sup>D"  nitpick oops
lemma "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sub>pA\<rfloor>\<^sup>D" nitpick oops

(**The following operator above is not part of the original Kaplan's LD and has been added
by us in order to better highlight some semantic features of our formalisation of Gewirth's argument in the next section and to being able to
use the necessitation rule for some inference steps. This is used to model a kind of logical-indexical necessity in contrast
to the alethic necessity shown above.*)
abbreviation ldvalidbox :: "m\<Rightarrow>m" ("\<^bold>\<box>\<^sup>D_" [52]53) where "\<^bold>\<box>\<^sup>D\<phi> \<equiv> \<lambda>c w. \<lfloor>\<phi>\<rfloor>\<^sup>D" (**note the D superscript*)
lemma "\<lfloor>\<^bold>\<box>\<^sup>D\<phi>\<rfloor>\<^sub>C \<equiv> \<forall>c.\<lfloor>\<phi>\<rfloor>\<^sub>c" by simp (**works analogously to the box operator in modal logic S5*)

(**The necessitation rule works for the combination of indexical validity with the previous operator, as intended.*)
lemma "\<lfloor>A\<rfloor>\<^sup>D \<Longrightarrow> \<lfloor>\<^bold>\<box>\<^sup>DA\<rfloor>\<^sup>D"  by simp

subsection \<open>Quantification\<close>
(** We also enrich our logic with (higher-order) quantifiers (using parameterized types).*)
abbreviation mforall::"('t\<Rightarrow>m)\<Rightarrow>m" ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>c w.\<forall>x. (\<Phi> x c w)"
abbreviation mexists::"('t\<Rightarrow>m)\<Rightarrow>m" ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>c w.\<exists>x. (\<Phi> x c w)"
abbreviation mforallBinder::"('t\<Rightarrow>m)\<Rightarrow>m" (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. (\<phi> x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation mexistsBinder::"('t\<Rightarrow>m)\<Rightarrow>m" (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. (\<phi> x) \<equiv> \<^bold>\<exists>\<phi>"

(*<*)
end
(*>*)


(***********************************************************************
* HiVe theory files
*
* Copyright (C) 2015 Commonwealth of Australia as represented by Defence Science and Technology
* Group (DST Group)
*
* All rights reserved.
*
* The HiVe theory files are free software: released for redistribution and use, and/or modification,
* under the BSD License, details of which can be found in the LICENSE file included in the
* distribution.
************************************************************************)

theory Order_Morphism

imports
  Order_Locale
  xHOL_TypeDef

begin

section {* Congruence and monotonicity *}

text {*

Consider @{text "\<^setrel>{:X:}{:BS_leq_d_X:}"} and @{text "\<^setrel>{:Y:}{:BS_leq_d_Y:}"}, we say
that a function @{text "f \<in> X \<ztfun> Y"} is {\em order-preserving} if

*}

locale carrier_tfun =
  X_carrier X +
  Y_carrier Y
for
  X::"'a set" and
  Y::"'b set" +
fixes
  f::"('a \<leftrightarrow> 'b)"
assumes
  f_tfun: "f \<in> X \<ztfun> Y"

locale rel_tfun =
  X_setrel +
  carrier_tfun

locale po_tfun =
  X_partial_order +
  carrier_tfun

sublocale po_tfun \<subseteq> rel_tfun
  by (unfold_locales)

locale order_tfun =
  X_order +
  carrier_tfun

sublocale order_tfun \<subseteq> po_tfun
  by (unfold_locales)

locale rel_rel_tfun =
  Y_setrel Y s +
  rel_tfun X r Y f
for
  X::"'a set" and
  r::"'a orderT" and
  Y::"'b set" and
  s::"'b orderT" and
  f :: "('a \<leftrightarrow> 'b)"

locale po_rel_tfun =
  X_partial_order +
  rel_rel_tfun

sublocale po_rel_tfun \<subseteq> po_tfun
  by (unfold_locales)

locale order_rel_tfun =
  X_order +
  po_rel_tfun

sublocale order_rel_tfun \<subseteq> order_tfun
  by (unfold_locales)

locale rel_preserving =
  rel_rel_tfun +
assumes
  preserves: "(\<forall> x y | \<lch> x, y \<chIn> X \<rch> \<bullet> x \<hookrightarrow>\<^sub>X y \<Rightarrow> f\<cdot>x \<hookrightarrow>\<^sub>Y f\<cdot>y)"

begin

lemma  rel_preservesD:
  assumes
    a1: "x \<in> X" and
    a2: "y \<in> X" and
    a3: "x \<hookrightarrow>\<^sub>X y"
  shows
    "f\<cdot>x \<hookrightarrow>\<^sub>Y f\<cdot>y"
  apply (rule preserves [rule_format])
  apply (auto simp add: a1 a2 a3)
  done

end

locale po_preserving =
  rel_preserving +
  po_rel_tfun

term "po_preserving"

abbreviation (zed)
  po_preserving_set :: "['a set, 'a orderT, 'b set, 'b orderT] \<rightarrow> ('a \<leftrightarrow> 'b) set" ("\<^oprefun>{:_:}{:_:}{:_:}{:_:}")
where
  "\<^oprefun>{:X:}{:BS_leq_d_X:}{:Y:}{:BS_leq_d_Y:} \<defs> Collect (po_preserving X BS_leq_d_X Y BS_leq_d_Y)"
(*
notation (zed)
  po_preserving ("\<^oprefun>{:_:}{:_:}{:_:}{:_:}")
*)

locale order_preserving =
  rel_preserving +
  order_rel_tfun

text {*

and an {\em embedding} if

*}

locale rel_embedding =
  rel_rel_tfun +
assumes
  embeds: "(\<forall> x y | \<lch> x, y \<chIn> X \<rch> \<bullet> x \<hookrightarrow>\<^sub>X y \<Leftrightarrow> f\<cdot>x \<hookrightarrow>\<^sub>Y f\<cdot>y)"

begin

lemma  rel_embedsD:
  assumes
    a1: "x \<in> X" and
    a2: "y \<in> X"
  shows
    "x \<hookrightarrow>\<^sub>X y \<Leftrightarrow> f\<cdot>x \<hookrightarrow>\<^sub>Y f\<cdot>y"
  apply (rule embeds [rule_format])
  apply (auto simp add: a1 a2)
  done

end

sublocale rel_embedding \<subseteq> rel_preserving
  apply (unfold_locales)
  apply (simp add: embeds [rule_format])
  done

locale po_embedding =
  rel_embedding +
  po_rel_tfun

abbreviation (zed)
  po_embedding_set :: "['a set, 'a orderT, 'b set, 'b orderT] \<rightarrow> ('a \<leftrightarrow> 'b) set" ("\<^oembfun>{:_:}{:_:}{:_:}{:_:}")
where
  "\<^oembfun>{:X:}{:BS_leq_d_X:}{:Y:}{:BS_leq_d_Y:} \<defs> Collect (po_embedding X BS_leq_d_X Y BS_leq_d_Y)"
(*
notation (zed)
  po_embedding ("\<^oembfun>{:_:}{:_:}{:_:}{:_:}")
*)

locale order_embedding =
  rel_embedding +
  order_rel_tfun

text {*

If the source and target preorders in question are partial orders,
we use the term monotonic for order-preserving, and
if they are equivalences, we use the term congruence for order embeddings.

*}

locale po_morphism =
  Y_partial_order +
  po_rel_tfun

locale monotonic =
  po_preserving +
  po_morphism

locale congruence =
  po_embedding +
  po_morphism

abbreviation (zed)
  monotonic_set :: "['a set, 'a orderT, 'b set, 'b orderT] \<rightarrow> ('a \<leftrightarrow> 'b) set" ("\<^monofun>{:_:}{:_:}{:_:}{:_:}")
where
  "\<^monofun>{:X:}{:BS_leq_d_X:}{:Y:}{:BS_leq_d_Y:} \<defs> Collect (monotonic X BS_leq_d_X Y BS_leq_d_Y)"

abbreviation (zed)
  congruence_set :: "['a set, 'a orderT, 'b set, 'b orderT] \<rightarrow> ('a \<leftrightarrow> 'b) set" ("\<^ucongfun>{:_:}{:_:}{:_:}{:_:}")
where
  "\<^ucongfun>{:X:}{:BS_leq_d_X:}{:Y:}{:BS_leq_d_Y:} \<defs> Collect (congruence X BS_leq_d_X Y BS_leq_d_Y)"
(*
notation (zed)
  monotonic ("\<^monofun>{:_:}{:_:}{:_:}{:_:}") and
  congruence ("\<^ucongfun>{:_:}{:_:}{:_:}{:_:}")
*)

locale order_morphism =
  Y_order +
  order_rel_tfun

text {*

A relation is said to be congruent if it is congruent in both its arguments.

*}

definition
  r_congruent :: "['a orderT, 'a orderT] \<rightarrow> \<bool>"
where
  r_congruent_def:
    "r_congruent BS_sim BS_leq \<defs>
      (\<forall> x_d_1 x_d_2 y_d_1 y_d_2 \<bullet> \<^infopa>{:x_d_1:}{:BS_sim:}{:x_d_2:} \<and> \<^infopa>{:y_d_1:}{:BS_sim:}{:y_d_2:} \<Rightarrow> (\<^infopa>{:x_d_1:}{:BS_leq:}{:y_d_1:} \<Leftrightarrow> \<^infopa>{:x_d_2:}{:BS_leq:}{:y_d_2:}))"

text {*

If an order-embedding from a poset
@{text "\<^setrel>{:X:}{:BS_leq_d_X:}"} to @{text "\<^setrel>{:Y:}{:BS_leq_d_Y:}"} is bijective,
then @{text "\<^setrel>{:Y:}{:BS_leq_d_Y:}"} is also a poset.

*}

locale carrier_bij =
  carrier_tfun +
assumes
  f_bij: "f \<in> X \<zbij> Y"

locale rel_bij =
  rel_tfun +
  carrier_bij

locale po_bij =
  po_tfun +
  carrier_bij

sublocale po_bij \<subseteq> rel_bij
  by (unfold_locales)

locale order_bij =
  order_tfun +
  carrier_bij

sublocale order_bij \<subseteq> po_bij
  by (unfold_locales)

locale po_bij_embedding =
  po_embedding +
  po_bij

begin

lemma finv_embeds:
    "(\<forall> x y | \<lch> x, y \<chIn> Y \<rch> \<bullet> x \<hookrightarrow>\<^sub>Y y \<Leftrightarrow> (f\<^sup>\<sim>)\<cdot>x \<preceq>\<^sub>X (f\<^sup>\<sim>)\<cdot>y)"
proof (intro allI impI)
  fix x y
  assume
    b1: "\<lch> x, y \<chIn> Y \<rch>"
  have
    b3: "\<zdom> (f\<^sup>\<sim>) = Y"
    by (rule tfun_dom [of _ Y X], auto intro: f_bij)
  from b1 b3 have
    b4: "x \<in> \<zdom> (f\<^sup>\<sim>)"
    by (simp)
  from b1 b3 have
    b5: "y \<in> \<zdom> (f\<^sup>\<sim>)"
    by (simp)
  from b4 have
    b6: "(f\<^sup>\<sim>)\<cdot>x \<in> X"
    apply (intro pfun_range [of _ Y X])
    apply (auto intro: f_bij)
    done
  from b5 have
    b7: "(f\<^sup>\<sim>)\<cdot>y \<in> X"
    apply (intro pfun_range [of _ Y X])
    apply (auto intro: f_bij)
    done
  from f_bij b1 have
      "x \<hookrightarrow>\<^sub>Y y
      \<Leftrightarrow> f\<cdot>((f\<^sup>\<sim>)\<cdot>x) \<hookrightarrow>\<^sub>Y f\<cdot>((f\<^sup>\<sim>)\<cdot>y)"
    by (simp)
  also from b1 embeds have "\<dots>
      \<Leftrightarrow> (f\<^sup>\<sim>)\<cdot>x \<preceq>\<^sub>X (f\<^sup>\<sim>)\<cdot>y"
    by (auto intro: f_bij b6 b7)
  finally show
      "x \<hookrightarrow>\<^sub>Y y \<Leftrightarrow> (f\<^sup>\<sim>)\<cdot>x \<preceq>\<^sub>X (f\<^sup>\<sim>)\<cdot>y"
    by (this)
qed

lemma embed_ord:
    "x \<hookrightarrow>\<^sub>Y y \<Leftrightarrow> x \<in> Y \<and> y \<in> Y \<and> (f\<^sup>\<sim>)\<cdot>x \<preceq>\<^sub>X (f\<^sup>\<sim>)\<cdot>y"
  using finv_embeds Y.rel
  by (auto simp add: rel_def op2rel_def eind_def)

theorem iso_poI:
    "\<^poset>{:Y:}{:(op \<hookrightarrow>\<^sub>Y):}"
proof -
  have
    a1: "f \<in> X \<ztfun> Y"
    by (auto intro: f_bij)
  have
    a2: "f\<^sup>\<sim> \<in> Y \<ztfun> X"
    by (auto intro: f_bij)
  from a1 a2 have
    a3: "((f\<^sup>\<sim>) \<zfcomp> f) \<in> Y \<ztfun> Y"
    by (auto)
  from f_bij have
    a6: "\<forall> y \<bullet> y \<in> Y \<Rightarrow> (f\<^sup>\<sim>)\<cdot>y \<in> X"
    by (auto)
  show
      ?thesis
  proof (rule partial_orderI)
    from non_empty obtain x where
      c1: "x \<in> X"
      by (auto)
    with f_bij have
        "f\<cdot>x \<in> Y"
      by (auto)
    then show
        "Y \<noteq> \<emptyset>"
      by (auto)
  next
    from Y.rel show
        "\<^oprel>{:(op \<hookrightarrow>\<^sub>Y):} \<in> Y \<zrel> Y"
      by (this)
  next
    fix y assume
        "y \<in> Y"
    with reflD embed_ord a6 show
        "y \<hookrightarrow>\<^sub>Y y"
      by (auto)
  next
    fix x y z
    assume
      c1: "x \<in> Y \<and> y \<in> Y \<and> z \<in> Y" and
      c2: "x \<hookrightarrow>\<^sub>Y y" "y \<hookrightarrow>\<^sub>Y z"
    with embed_ord a6 show
        "x \<hookrightarrow>\<^sub>Y z"
      by (auto intro: transD)
  next
    fix x y
    assume
      c1: "x \<in> Y \<and> y \<in> Y" and
      c2: "x \<hookrightarrow>\<^sub>Y y" "y \<hookrightarrow>\<^sub>Y x"
    with embed_ord a6 show
        "x = y"
    proof (auto)
      assume
          "(f\<^sup>\<sim>)\<cdot>x \<preceq>\<^sub>X (f\<^sup>\<sim>)\<cdot>y" "(f\<^sup>\<sim>)\<cdot>y \<preceq>\<^sub>X (f\<^sup>\<sim>)\<cdot>x"
      then have
          "(f\<^sup>\<sim>)\<cdot>x = (f\<^sup>\<sim>)\<cdot>y"
        by (rule antisymD)
      then have
          "f\<cdot>((f\<^sup>\<sim>)\<cdot>x) = f\<cdot>((f\<^sup>\<sim>)\<cdot>y)"
        by (simp)
      with f_bij c1 show
          "x = y"
        by (simp)
    qed
  qed
qed

end (* po_bij_embedding *)

sublocale po_bij_embedding \<subseteq> Y_partial_order Y
  apply (rule Y_partial_order.intro)
  apply (rule iso_poI)
  done

locale order_bij_embedding =
  X_order +
  po_bij_embedding

begin

theorem iso_orderI:
    "\<^order>{:Y:}{:(op \<preceq>\<^sub>Y):}"
proof (rule Y.orderIa)
  fix
    x y
  assume
    b1: "x \<in> Y" "y \<in> Y"
  with f_bij have
      "(f\<^sup>\<sim>)\<cdot>x \<in> X" "(f\<^sup>\<sim>)\<cdot>y \<in> X"
    by (auto)
  then have
      "(f\<^sup>\<sim>)\<cdot>x \<preceq>\<^sub>X (f\<^sup>\<sim>)\<cdot>y \<or> (f\<^sup>\<sim>)\<cdot>y \<preceq>\<^sub>X (f\<^sup>\<sim>)\<cdot>x"
    by (rule linD)
  with b1 show
      "x \<preceq>\<^sub>Y y \<or> y \<preceq>\<^sub>Y x"
    by (simp add: embed_ord)
qed

end

sublocale order_bij_embedding \<subseteq> Y_order
  apply (rule Y_order.intro)
  apply (rule iso_orderI)
  done

text {*

An isomorphism can also be used to induce an order on a set.

*}

definition
  image_ord :: "['a orderT, ('a \<times> 'b) set] \<rightarrow> 'b orderT"
where
  image_ord_def: "image_ord BS_leq f \<defs> \<^relop>{:{a b | \<^infopa>{:a:}{:BS_leq:}{:b:} \<bullet> f\<cdot>a \<mapsto> f\<cdot>b}:}"

notation (zed)
  image_ord ("\<^imgord>{:_:}{:_:}")

context rel_tfun

begin

abbreviation
  Y_image_ord :: "'b orderT" (infixl "\<hookrightarrow>\<^sub>f" 50)
where
  "Y_image_ord \<defs> \<^imgord>{:(op \<hookrightarrow>\<^sub>X):}{:f:}"

end

lemma (in rel_tfun) image_rel:
    "rel_preserving X (op \<hookrightarrow>\<^sub>X) Y (op \<hookrightarrow>\<^sub>f) f"
proof (unfold_locales)
  show
      "\<^oprel>{:(op \<hookrightarrow>\<^sub>f):} \<in> Y \<zrel> Y"
    by (auto simp add: image_ord_def op2rel_def rel2op_def rel_def tfun_range [OF f_tfun] X.relD1 X.relD2)
next
  show
      "(\<forall> x y \<bullet> \<lch> x, y \<chIn> X \<rch> \<Rightarrow> (x \<hookrightarrow>\<^sub>X y \<Rightarrow> f\<cdot>x \<hookrightarrow>\<^sub>f f\<cdot>y))"
    by (auto simp add: image_ord_def rel2op_def)
qed

lemma (in rel_bij) image_bij:
    "rel_embedding X (op \<hookrightarrow>\<^sub>X) Y (op \<hookrightarrow>\<^sub>f) f"
proof (unfold_locales)
  from image_rel interpret image_rel: rel_preserving X "(op \<hookrightarrow>\<^sub>X)" Y "(op \<hookrightarrow>\<^sub>f)" f
    by (this)
  show
      "\<^oprel>{:(op \<hookrightarrow>\<^sub>f):} \<in> Y \<zrel> Y"
    by (rule image_rel.Y.rel)
  show
      "(\<forall> x y \<bullet> \<lch> x, y \<chIn> X \<rch> \<Rightarrow> (x \<hookrightarrow>\<^sub>X y \<Leftrightarrow> f\<cdot>x \<hookrightarrow>\<^sub>f f\<cdot>y))"
  proof (auto simp add: image_ord_def rel2op_def)
    fix
      x y a b
    assume
      c1: "x \<in> X" and
      c2: "y \<in> X" and
      c3: "f\<cdot>x = f\<cdot>a" and
      c4: "f\<cdot>y = f\<cdot>b" and
      c5: "a \<hookrightarrow>\<^sub>X b"
    have
        "x = a"
      apply (rule bij_inj [OF f_bij, OF c1 _ c3])
      apply (rule X.relD1 [OF c5])
      done
    moreover have
        "y = b"
      apply (rule bij_inj [OF f_bij, OF c2 _ c4])
      apply (rule X.relD2 [OF c5])
      done
    ultimately show
        "x \<hookrightarrow>\<^sub>X y"
      by (simp add: c5)
  qed
qed

lemma (in po_bij) image_po:
    "po_bij_embedding X (op \<hookrightarrow>\<^sub>X) Y (op \<hookrightarrow>\<^sub>f) f"
proof -
  from image_bij interpret image_bij: rel_embedding X "(op \<hookrightarrow>\<^sub>X)" Y "(op \<hookrightarrow>\<^sub>f)" f
    by (this)
  show "po_bij_embedding X (op \<hookrightarrow>\<^sub>X) Y (op \<hookrightarrow>\<^sub>f) f"
    by (unfold_locales)
qed

(*
lemma (in setrel) image_embed:
  assumes a1: "f \<in> X \<zbij> Y"
  shows "f \<in> \<^oembfun>{:X:}{:r:}{:Y:}{:\<^imgord>{:r:}{:f:}:}"
proof (auto intro: relD1 relD2 simp add:
  image_ord_def po_embeds_def rel2op_def del: ex_simps)
  from a1 show "f \<in> X \<ztfun> Y" by (auto)
next
  fix x y a b
  assume a2: "x \<in> X" and a3: "y \<in> X" and
    a4a: "f\<cdot>x = f\<cdot>a" and a4b: "f\<cdot>y = f\<cdot>b" and
    a5: "\<^infop>{:a:}{:r:}{:b:}"
  note a4a
  also have "f\<cdot>x = f\<cdot>a \<Leftrightarrow> x = a"
    by (rule bij_1to1 [OF a1 a2 relD1 [OF a5]])
  finally have a6a: "x = a" by (this)
  note a4b
  also have "f\<cdot>y = f\<cdot>b \<Leftrightarrow> y = b"
    by (rule bij_1to1 [OF a1 a3 relD2 [OF a5]])
  finally have a6b: "y = b" by (this)
  from a5 a6a a6b show "\<^infop>{:x:}{:r:}{:y:}"
    by (simp)
qed
*)

lemma (in partial_order) image_poI:
  assumes
    f_bij: "f \<in> X \<zbij> Y"
  shows
    "\<^poset>{:Y:}{:\<^imgord>{:(op \<preceq>):}{:f:}:}"
  apply (rule po_bij_embedding.iso_poI [of X "(op \<preceq>)"])
  apply (rule po_bij.image_po)
  apply (unfold_locales)
  using non_empty f_bij tfun_range [of f X Y]
  apply (auto)
  done

theorem (in order_bij) image_order:
    "order_bij_embedding X (op \<preceq>\<^sub>X) Y (op \<hookrightarrow>\<^sub>f) f"
proof -
  from image_po interpret image_po: po_bij_embedding X "(op \<hookrightarrow>\<^sub>X)" Y "(op \<hookrightarrow>\<^sub>f)" f
    by (this)
  show
      ?thesis
    by (unfold_locales)
qed

lemma (in order) image_orderI:
  assumes
    f_bij: "f \<in> X \<zbij> Y"
  shows
    "\<^order>{:Y:}{:\<^imgord>{:(op \<preceq>):}{:f:}:}"
  apply (rule order_bij_embedding.iso_orderI [of X "(op \<preceq>)"])
  apply (rule order_bij.image_order)
  apply (unfold_locales)
  using non_empty f_bij tfun_range [of f X Y]
  apply (auto)
  done

section {* Inducing orders on typedefs *}

text {*

Typedefs are new types introduced as isomorphic images of existing
representation sets.
The definition of a type via a typedef not only introduces a new type,
but also injective mappings to and from its representation set.
If the representation set is ordered, these injections can be used to
induce an ordering on the new type which is isomorphic to that on the
representation set.

*}

definition
  induce_ord :: "['b \<rightarrow> 'a, 'a orderT] \<rightarrow> 'b orderT"
where
  induce_ord_def: "induce_ord Rep BS_leq \<defs> (\<olambda> x y \<bullet> BS_leq (Rep x) (Rep y))"

text {*

We observe that the abstraction function from a representation
set to its defined type is a bijection.
And that the induced order is the corresponding
image order.

*}

lemma (in type_definition) Abs_graph_bij:
    "A \<zdres> (\<graphof> Abs) \<in> A \<zbij> \<univ>"
proof (auto intro!: in_tfunI in_pfunI in_relI
  simp add: bij_tfun_conv dres_def graph_of_def glambda_def Domain_iff Range_iff)
  fix x y
  assume
    "x \<in> A" "y \<in> A" "Abs x = Abs y"
  then show
      "x = y"
    by (simp add: Abs_inject)
next
  fix x
  from Abs_onto_on show
      "\<exists> y \<bullet> y \<in> A \<and> x = Abs y"
    by (auto)
qed

lemma (in type_definition) induce_image_ord:
  assumes
    a1: "setrel A BS_leq"
  shows
    "induce_ord Rep BS_leq = \<^imgord>{:BS_leq:}{:A \<zdres> (\<graphof> Abs):}"
proof -
  from a1 interpret
    b1: setrel A BS_leq
    by (auto simp add: setrel_def)
  show
      ?thesis
    by (auto
          intro!: ext exI
          simp add:
            image_ord_def induce_ord_def rel2op_def graph_of_def glambda_dres
            glambda_beta b1.relD1 b1.relD2 Abs_inverse Rep_inverse)
qed

text {*

Thus we can immediately deduce that the default order on the set @{text A}
will induce an order on the type @{text A}.
More generally,
we can deduce that any poset structure on the set @{text A} will
also induce an order structure on the type @{text A}.

*}

lemma typedefs_order_classI:
  assumes
    a1: "type_definition (Rep::('a::ord) \<rightarrow> 'b) Abs (A::'b set)" and
    a2: "\<^poset>{:A:}{:BS_leq_d_A:}" and
    a3: "((op \<le>)::('a::ord) orderT) = induce_ord Rep BS_leq_d_A" and
    a4: "((op <)::('a::ord) orderT) = derefl (op \<le>)"
  shows
    "OFCLASS('a::ord, order_class)"
proof -
  from a1 interpret
    b1: type_definition Rep Abs A
    by (auto simp add: type_definition_def)
  from a2 interpret
    b2: partial_order A BS_leq_d_A
    by (auto simp add: partial_order_def)
  show
      "OFCLASS('a::ord, order_class)"
    apply (rule order_classI)
    apply (simp add: a3 b1.induce_image_ord [OF b2.setrel])
    apply (rule b2.image_poI)
    apply (rule b1.Abs_graph_bij)
    apply (simp add: a4)
    done
qed

lemma typedefs_linorder_classI:
  assumes
    a1: "type_definition (Rep::('a::ord) \<rightarrow> 'b) Abs (A::'b set)" and
    a2: "\<^order>{:A:}{:BS_leq_d_A:}" and
    a3: "((op \<le>)::('a::ord) orderT) = induce_ord Rep BS_leq_d_A" and
    a4: "((op <)::('a::ord) orderT) = derefl (op \<le>)"
  shows
    "OFCLASS('a::ord, linorder_class)"
proof -
  from a1 interpret b1: type_definition Rep Abs A
    by (auto simp add: type_definition_def)
  from a2 interpret b2: order A BS_leq_d_A
    by (auto simp add: order_def)
  show "OFCLASS('a::ord, linorder_class)"
    apply (rule linorder_classI)
    apply (simp add: a3 b1.induce_image_ord [OF b2.setrel])
    apply (rule b2.image_orderI)
    apply (rule b1.Abs_graph_bij)
    apply (simp add: a4)
    done
qed

lemma epi_typedefs_order_classI:
  assumes
    a1: "epi_type_definition (Rep::('a::ord) \<rightarrow> 'b) Abs" and
    a2: "\<^poset>{:\<univ>-['b]:}{:BS_leq:}" and
    a3: "((op \<le>)::('a::ord) orderT) = induce_ord Rep BS_leq" and
    a4: "((op <)::('a::ord) orderT) = derefl (op \<le>)"
  shows
    "OFCLASS('a::ord, order_class)"
proof -
  interpret ETD: epi_type_definition Rep Abs
    by (rule a1)
  show
    "OFCLASS('a, order_class)"
    apply (rule typedefs_order_classI)
    apply (rule ETD.type_definition_axioms)
    apply (simp_all add: a2 a3 a4 order_classD)
    done
qed

lemma epi_typedefs_linorder_classI:
  assumes
    a1: "epi_type_definition (Rep::('a::ord) \<rightarrow> 'b) Abs" and
    a2: "\<^order>{:\<univ>-['b]:}{:BS_leq:}" and
    a3: "((op \<le>)::('a::ord) orderT) = induce_ord Rep BS_leq" and
    a4: "((op <)::('a::ord) orderT) = derefl (op \<le>)"
  shows
    "OFCLASS('a::ord, linorder_class)"
proof -
  interpret ETD: epi_type_definition Rep Abs
    by (rule a1)
  show
    "OFCLASS('a, linorder_class)"
    apply (rule typedefs_linorder_classI)
    apply (rule ETD.type_definition_axioms)
    apply (simp_all add: a2 a3 a4 linorder_classD)
    done
qed

section {* Monotonicity and order classes*}

text {*

Monotonic functions preserve ordering.

*}

definition
  monotonic_ops :: "(('A::order) \<rightarrow> ('B::order)) set"
where
  monotonic_ops_def: "monotonic_ops \<defs> {p | mono p}"

notation (xsymbols output)
  monotonic_ops ("M")

notation (zed)
  monotonic_ops ("\<mh>")

lemma mhE:
  assumes
    a1: "p \<in> \<mh>" "(\<And> A B \<bullet> A \<le> B \<turnstile> p A \<le> p B) \<turnstile> R"
  shows
      "R"
  using a1
  by (auto simp add: monotonic_ops_def monoD)

lemma mhD:
    "p \<in> \<mh> \<turnstile> A \<le> B \<turnstile> p A \<le> p B"
  by (simp add: monotonic_ops_def monoD)

lemma mh_conv:
    "p \<in> \<mh> \<Leftrightarrow> mono p"
  by (simp add: monotonic_ops_def)

lemma mhI:
  assumes
    a1: "\<And> A B \<bullet> A \<le> B \<turnstile> p A \<le> p B"
  shows
      "p \<in> \<mh>"
  using a1
  by (simp add: monotonic_ops_def monoI)

text {*

Utility lemmas.

*}

lemma comp_mhI:
  assumes
    a1: "f \<in> \<mh>" and
    a2: "g \<in> \<mh>"
  shows
    "f \<circ> g \<in> \<mh>"
  apply (rule mhI)
  apply (auto simp add: mhD [OF a1] mhD [OF a2])
  done

lemma comp_mhI':
  assumes
    a1: "f \<in> \<mh>" and
    a2: "g \<in> \<mh>"
  shows
    "(\<olambda> x \<bullet> f (g x)) \<in> \<mh>"
  apply (rule mhI)
  apply (auto simp add: mhD [OF a1] mhD [OF a2])
  done

end


theory Tree
  imports Shortest_Path
begin

section \<open>Trees\<close>

locale tree = graph T for T +
  assumes unique_trail: "\<lbrakk> u \<in> vertices T; v \<in> vertices T \<rbrakk> \<Longrightarrow> \<exists>!p. trail T u p v"

theorem (in tree)
  shows "\<nexists>v c. closed_trail T v c"
proof (rule ccontr)
  assume "\<not> (\<nexists>v c. closed_trail T v c)"
  then obtain v c where
    c_closed_trail: "closed_trail T v c"
    by blast

  have v_in_vertices: "v \<in> vertices T"
    using c_closed_trail
    by (blast intro: trail_hd_in_vertices)
  have c_tl_hd_in_vertices: "hd (tl c) \<in> vertices T"
    using c_closed_trail
    by (rule closed_trail_tl_hd_in_vertices)

  have "trail T v [v, hd (tl c)] (hd (tl c))"
    using c_closed_trail
    by (rule closed_trail_hd_tl_hd_is_trail)
  moreover have "trail T v (rev (tl c)) (hd (tl c))"
    using c_closed_trail
    by (rule closed_trail_tl_rev_is_trail)
  moreover have "[v, hd (tl c)] \<noteq> rev (tl c)"
    using c_closed_trail
    by (rule closed_trail_hd_tl_hd_neq_tl_rev)
  ultimately show "False"
    using unique_trail[OF v_in_vertices c_tl_hd_in_vertices]
    by blast
qed

theorem (in tree) connected:
  shows "Walk.connected T"
  using unique_trail
  by (fastforce simp add: Walk.connected_def reachable_def trail_def)

section \<open>Rooted trees\<close>

locale rooted_tree = tree T for T +
  fixes root :: 'a
  assumes root_in_vertices: "root \<in> vertices T"

lemma (in rooted_tree) non_empty:
  shows "vertices T \<noteq> {}"
  using root_in_vertices
  by blast

section \<open>Spanning trees\<close>

locale spanning_tree = subgraph G T + tree T for G T +
  assumes spanning: "vertices T = vertices G"

section \<open>Rooted spanning trees\<close>

locale rooted_spanning_tree = spanning_tree G T + rooted_tree T root for G T root

lemmas (in rooted_spanning_tree) spanning = spanning

end


section "Splay Tree"

theory Splay_Tree
imports
  "HOL-Library.Tree"
  "HOL-Data_Structures.Set_Specs"
  "HOL-Data_Structures.Cmp"
begin

declare sorted_wrt.simps(2)[simp del]

text\<open>Splay trees were invented by Sleator and Tarjan~\<^cite>\<open>"SleatorT-JACM85"\<close>.\<close>

subsection "Function \<open>splay\<close>"

function splay :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"splay x Leaf = Leaf" |
"splay x (Node AB x CD) = Node AB x CD" |
"x<b \<Longrightarrow> splay x (Node (Node A x B) b CD) = Node A x (Node B b CD)" |
"x<b \<Longrightarrow> splay x (Node Leaf b CD) = Node Leaf b CD" |
"x<a \<Longrightarrow> x<b \<Longrightarrow> splay x (Node (Node Leaf a B) b CD) = Node Leaf a (Node B b CD)" |
"x<a \<Longrightarrow> x<b \<Longrightarrow> A \<noteq> Leaf \<Longrightarrow>
 splay x (Node (Node A a B) b CD) =
 (case splay x A of Node A1 a' A2 \<Rightarrow> Node A1 a' (Node A2 a (Node B b CD)))" |
"a<x \<Longrightarrow> x<b \<Longrightarrow> splay x (Node (Node A a Leaf) b CD) = Node A a (Node Leaf b CD)" |
"a<x \<Longrightarrow> x<b \<Longrightarrow> B \<noteq> Leaf \<Longrightarrow>
 splay x (Node (Node A a B) b CD) =
 (case splay x B of Node B1 b' B2 \<Rightarrow> Node (Node A a B1) b' (Node B2 b CD))" |
"b<x \<Longrightarrow> splay x (Node AB b (Node C x D)) = Node (Node AB b C) x D" |
"b<x \<Longrightarrow> splay x (Node AB b Leaf) = Node AB b Leaf" |
"b<x \<Longrightarrow> x<c \<Longrightarrow> C \<noteq> Leaf \<Longrightarrow>
 splay x (Node AB b (Node C c D)) =
 (case splay x C of Node C1 c' C \<Rightarrow> Node (Node AB b C1) c' (Node C c D))" |
"b<x \<Longrightarrow> x<c \<Longrightarrow> splay x (Node AB b (Node Leaf c D)) = Node (Node AB b Leaf) c D" |
"b<x \<Longrightarrow> c<x \<Longrightarrow> splay x (Node AB b (Node C c Leaf)) = Node (Node AB b C) c Leaf" |
"a<x \<Longrightarrow> c<x \<Longrightarrow> D \<noteq> Leaf \<Longrightarrow>
 splay x (Node AB a (Node C c D)) =
 (case splay x D of Node D1 d' D2 \<Rightarrow> Node (Node (Node AB a C) c D1) d' D2)"
apply(atomize_elim)
apply(auto)
(* 1 subgoal *)
apply (subst (asm) neq_Leaf_iff)
apply(auto)
apply (metis tree.exhaust le_less_linear less_linear)+
done

termination splay
by lexicographic_order

lemma splay_code: "splay x (Node AB b CD) =
  (case cmp x b of
   EQ \<Rightarrow> Node AB b CD |
   LT \<Rightarrow> (case AB of
          Leaf \<Rightarrow> Node AB b CD |
          Node A a B \<Rightarrow>
            (case cmp x a of EQ \<Rightarrow> Node A a (Node B b CD) |
             LT \<Rightarrow>  if A = Leaf then Node A a (Node B b CD)
                       else case splay x A of
                         Node A\<^sub>1 a' A\<^sub>2 \<Rightarrow> Node A\<^sub>1 a' (Node A\<^sub>2 a (Node B b CD)) |
             GT \<Rightarrow> if B = Leaf then Node A a (Node B b CD)
                       else case splay x B of
                         Node B\<^sub>1 b' B\<^sub>2 \<Rightarrow> Node (Node A a B\<^sub>1) b' (Node B\<^sub>2 b CD))) |
   GT \<Rightarrow> (case CD of
          Leaf \<Rightarrow> Node AB b CD |
          Node C c D \<Rightarrow>
            (case cmp x c of EQ \<Rightarrow> Node (Node AB b C) c D |
             LT \<Rightarrow> if C = Leaf then Node (Node AB b C) c D
                       else case splay x C of
                         Node C\<^sub>1 c' C\<^sub>2 \<Rightarrow> Node (Node AB b C\<^sub>1) c' (Node C\<^sub>2 c D) |
             GT \<Rightarrow> if D=Leaf then Node (Node AB b C) c D
                       else case splay x D of
                         Node D\<^sub>1 d D\<^sub>2 \<Rightarrow> Node (Node (Node AB b C) c D\<^sub>1) d D\<^sub>2)))"
by(auto split!: tree.split)

definition is_root :: "'a \<Rightarrow> 'a tree \<Rightarrow> bool" where
"is_root x t = (case t of Leaf \<Rightarrow> False | Node l a r \<Rightarrow> x = a)"

definition "isin t x = is_root x (splay x t)"

definition empty :: "'a tree" where
"empty = Leaf"

hide_const (open) insert

fun insert :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"insert x t =
  (if t = Leaf then Node Leaf x Leaf
   else case splay x t of
     Node l a r \<Rightarrow>
      case cmp x a of
        EQ \<Rightarrow> Node l a r |
        LT \<Rightarrow> Node l x (Node Leaf a r) |
        GT \<Rightarrow> Node (Node l a Leaf) x r)"

fun splay_max :: "'a tree \<Rightarrow> 'a tree" where
"splay_max Leaf = Leaf" |
"splay_max (Node A a Leaf) = Node A a Leaf" |
"splay_max (Node A a (Node B b CD)) =
  (if CD = Leaf then Node (Node A a B) b Leaf
   else case splay_max CD of
     Node C c D \<Rightarrow> Node (Node (Node A a B) b C) c D)"

lemma splay_max_code: "splay_max t = (case t of
  Leaf \<Rightarrow> t |
  Node la a ra \<Rightarrow> (case ra of
    Leaf \<Rightarrow> t |
    Node lb b rb \<Rightarrow>
      (if rb=Leaf then Node (Node la a lb) b rb
       else case splay_max rb of
              Node lc c rc \<Rightarrow> Node (Node (Node la a lb) b lc) c rc)))"
by(auto simp: neq_Leaf_iff split: tree.split)

definition delete :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"delete x t =
  (if t = Leaf then Leaf
   else case splay x t of Node l a r \<Rightarrow>
     if x \<noteq> a then Node l a r
     else if l = Leaf then r else case splay_max l of Node l' m r' \<Rightarrow> Node l' m r)"

subsection "Functional Correctness Proofs I"

text \<open>This subsection follows the automated method by Nipkow \<^cite>\<open>"Nipkow-ITP16"\<close>.\<close>

lemma splay_Leaf_iff[simp]: "(splay a t = Leaf) = (t = Leaf)"
by(induction a t rule: splay.induct) (auto split: tree.splits)

lemma splay_max_Leaf_iff[simp]: "(splay_max t = Leaf) = (t = Leaf)"
by(induction t rule: splay_max.induct)(auto split: tree.splits)

subsubsection "Verification of @{const isin}"

lemma splay_elemsD:
  "splay x t = Node l a r \<Longrightarrow> sorted(inorder t) \<Longrightarrow>
  x \<in> set (inorder t) \<longleftrightarrow> x=a"
by(induction x t arbitrary: l a r rule: splay.induct)
  (auto simp: isin_simps ball_Un split: tree.splits)

lemma isin_set: "sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> set (inorder t))"
by (auto simp: isin_def is_root_def dest: splay_elemsD split: tree.splits)

subsubsection "Verification of @{const insert}"

lemma inorder_splay: "inorder(splay x t) = inorder t"
by(induction x t rule: splay.induct)
  (auto simp: neq_Leaf_iff split: tree.split)

lemma sorted_splay:
  "sorted(inorder t) \<Longrightarrow> splay x t = Node l a r \<Longrightarrow>
  sorted(inorder l @ x # inorder r)"
unfolding inorder_splay[of x t, symmetric]
by(induction x t arbitrary: l a r rule: splay.induct)
  (auto simp: sorted_lems sorted_Cons_le sorted_snoc_le split: tree.splits)

lemma inorder_insert:
  "sorted(inorder t) \<Longrightarrow> inorder(insert x t) = ins_list x (inorder t)"
using inorder_splay[of x t, symmetric] sorted_splay[of t x]
by(auto simp: ins_list_simps ins_list_Cons ins_list_snoc neq_Leaf_iff split: tree.split)

subsubsection "Verification of @{const delete}"

lemma inorder_splay_maxD:
  "splay_max t = Node l a r \<Longrightarrow> sorted(inorder t) \<Longrightarrow>
  inorder l @ [a] = inorder t \<and> r = Leaf"
by(induction t arbitrary: l a r rule: splay_max.induct)
  (auto simp: sorted_lems split: tree.splits if_splits)

lemma inorder_delete:
  "sorted(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
using inorder_splay[of x t, symmetric] sorted_splay[of t x]
by (auto simp: del_list_simps del_list_sorted_app delete_def
  del_list_notin_Cons inorder_splay_maxD split: tree.splits)

subsubsection "Overall Correctness"

interpretation splay: Set_by_Ordered
where empty = empty and isin = isin and insert = insert
and delete = delete and inorder = inorder and inv = "\<lambda>_. True"
proof (standard, goal_cases)
  case 2 thus ?case by(simp add: isin_set)
next
  case 3 thus ?case by(simp add: inorder_insert del: insert.simps)
next
  case 4 thus ?case by(simp add: inorder_delete)
qed (auto simp: empty_def)

text \<open>Corollaries:\<close>

lemma bst_splay: "bst t \<Longrightarrow> bst (splay x t)"
by (simp add: bst_iff_sorted_wrt_less inorder_splay)

lemma bst_insert: "bst t \<Longrightarrow> bst(insert x t)"
using splay.invar_insert[of t x] by (simp add: bst_iff_sorted_wrt_less splay.invar_def)

lemma bst_delete: "bst t \<Longrightarrow> bst(delete x t)"
using splay.invar_delete[of t x] by (simp add: bst_iff_sorted_wrt_less splay.invar_def)

lemma splay_bstL: "bst t \<Longrightarrow> splay a t = Node l e r \<Longrightarrow> x \<in> set_tree l \<Longrightarrow> x < a"
by (metis bst_iff_sorted_wrt_less list.set_intros(1) set_inorder sorted_splay sorted_wrt_append)

lemma splay_bstR: "bst t \<Longrightarrow> splay a t = Node l e r \<Longrightarrow> x \<in> set_tree r \<Longrightarrow> a < x"
by (metis bst_iff_sorted_wrt_less sorted_Cons_iff set_inorder sorted_splay sorted_wrt_append)

subsubsection "Size lemmas"

lemma size_splay[simp]: "size (splay a t) = size t"
apply(induction a t rule: splay.induct)
apply auto
 apply(force split: tree.split)+
done

lemma size_if_splay: "splay a t = Node l u r \<Longrightarrow> size t = size l + size r + 1"
by (metis One_nat_def size_splay tree.size(4))

lemma splay_not_Leaf: "t \<noteq> Leaf \<Longrightarrow> \<exists>l x r. splay a t = Node l x r"
by (metis neq_Leaf_iff splay_Leaf_iff)

lemma size_splay_max: "size(splay_max t) = size t"
apply(induction t rule: splay_max.induct)
  apply(simp)
 apply(simp)
apply(clarsimp split: tree.split)
done

(*
subsection "Functional Correctness Proofs II"

text \<open>This subsection follows the traditional approach, is less automated
and is retained more for historic reasons.\<close>

lemma set_splay: "set_tree(splay a t) = set_tree t"
proof(induction a t rule: splay.induct)
  case (6 a)
  with splay_not_Leaf[OF 6(3), of a] show ?case by(fastforce)
next
  case (8 _ a)
  with splay_not_Leaf[OF 8(3), of a] show ?case by(fastforce)
next
  case (11 _ a)
  with splay_not_Leaf[OF 11(3), of a] show ?case by(fastforce)
next
  case (14 _ a)
  with splay_not_Leaf[OF 14(3), of a] show ?case by(fastforce)
qed auto

lemma splay_bstL: "bst t \<Longrightarrow> splay a t = Node l e r \<Longrightarrow> x \<in> set_tree l \<Longrightarrow> x < a"
apply(induction a t arbitrary: l x r rule: splay.induct)
apply (auto split: tree.splits)
apply auto
done

lemma splay_bstR: "bst t \<Longrightarrow> splay a t = Node l e r \<Longrightarrow> x \<in> set_tree r \<Longrightarrow> a < x"
apply(induction a t arbitrary: l e x r rule: splay.induct)
apply auto
apply (fastforce split!: tree.splits)+
done

lemma bst_splay: "bst t \<Longrightarrow> bst(splay a t)"
proof(induction a t rule: splay.induct)
  case (6 a _ _ ll)
  with splay_not_Leaf[OF 6(3), of a] set_splay[of a ll,symmetric]
  show ?case by (fastforce)
next
  case (8 _ a _ t)
  with splay_not_Leaf[OF 8(3), of a] set_splay[of a t,symmetric]
  show ?case by fastforce
next
  case (11 _ a _ t)
  with splay_not_Leaf[OF 11(3), of a] set_splay[of a t,symmetric]
  show ?case by fastforce
next
  case (14 _ a _ t)
  with splay_not_Leaf[OF 14(3), of a] set_splay[of a t,symmetric]
  show ?case by fastforce
qed auto

subsubsection "Verification of Is-in Test"

text\<open>To test if an element \<open>a\<close> is in \<open>t\<close>, first perform
@{term"splay a t"}, then check if the root is \<open>a\<close>. One could
put this into one function that returns both a new tree and the test result.\<close>

lemma is_root_splay: "bst t \<Longrightarrow> is_root a (splay a t) \<longleftrightarrow> a \<in> set_tree t"
by(auto simp add: is_root_def splay_to_root split: tree.split)

subsubsection "Verification of @{const insert}"

lemma set_insert: "set_tree(insert a t) = Set.insert a (set_tree t)"
apply(cases t)
 apply simp
using set_splay[of a t]
by(simp split: tree.split) fastforce

lemma bst_insert: "bst t \<Longrightarrow> bst(insert a t)"
apply(cases t)
 apply simp
using bst_splay[of t a] splay_bstL[of t a] splay_bstR[of t a]
by(auto simp: ball_Un split: tree.split)

subsubsection "Verification of \<open>splay_max\<close>"

lemma set_splay_max: "set_tree(splay_max t) = set_tree t"
apply(induction t rule: splay_max.induct)
   apply(simp)
  apply(simp)
apply(force split: tree.split)
done

lemma bst_splay_max: "bst t \<Longrightarrow> bst (splay_max t)"
proof(induction t rule: splay_max.induct)
  case (3 l b rl c rr)
  { fix rrl' d' rrr'
    have "splay_max rr = Node rrl' d' rrr'
       \<Longrightarrow> \<forall>x \<in> set_tree(Node rrl' d' rrr'). c < x"
      using "3.prems" set_splay_max[of rr]
      by (clarsimp split: tree.split simp: ball_Un)
  }
  with 3 show ?case by (fastforce split: tree.split simp: ball_Un)
qed auto

lemma splay_max_Leaf: "splay_max t = Node l a r \<Longrightarrow> r = Leaf"
by(induction t arbitrary: l rule: splay_max.induct)
  (auto split: tree.splits if_splits)

text\<open>For sanity purposes only:\<close>

lemma splay_max_eq_splay:
  "bst t \<Longrightarrow> \<forall>x \<in> set_tree t. x \<le> a \<Longrightarrow> splay_max t = splay a t"
proof(induction a t rule: splay.induct)
  case (2 a l r)
  show ?case
  proof (cases r)
    case Leaf with 2 show ?thesis by simp
  next
    case Node with 2 show ?thesis by(auto)
  qed
qed (auto simp: neq_Leaf_iff)

lemma splay_max_eq_splay_ex: assumes "bst t" shows "\<exists>a. splay_max t = splay a t"
proof(cases t)
  case Leaf thus ?thesis by simp
next
  case Node
  hence "splay_max t = splay (Max(set_tree t)) t"
    using assms by (auto simp: splay_max_eq_splay)
  thus ?thesis by auto
qed

subsubsection "Verification of @{const delete}"

lemma set_delete: assumes "bst t"
shows "set_tree (delete a t) = set_tree t - {a}"
proof(cases t)
  case Leaf thus ?thesis by(simp add: delete_def)
next
  case (Node l x r)
  obtain l' x' r' where sp[simp]: "splay a (Node l x r) = Node l' x' r'"
    by (metis neq_Leaf_iff splay_Leaf_iff)
  show ?thesis
  proof cases
    assume [simp]: "x' = a"
    show ?thesis
    proof cases
      assume "l' = Leaf"
      thus ?thesis
        using Node assms set_splay[of a "Node l x r"] bst_splay[of "Node l x r" a]
        by(simp add: delete_def split: tree.split prod.split)(fastforce)
    next
      assume "l' \<noteq> Leaf"
      moreover then obtain l'' m r'' where "splay_max l' = Node l'' m r''"
        using splay_max_Leaf_iff tree.exhaust by blast
      moreover have "a \<notin> set_tree l'"
        by (metis (no_types) Node assms less_irrefl sp splay_bstL)
      ultimately show ?thesis
        using Node assms set_splay[of a "Node l x r"] bst_splay[of "Node l x r" a]
          splay_max_Leaf[of l' l'' m r''] set_splay_max[of l']
        by(clarsimp simp: delete_def split: tree.split) auto
    qed
  next
    assume "x' \<noteq> a"
    thus ?thesis using Node assms set_splay[of a "Node l x r"] splay_to_root[OF _ sp]
      by (simp add: delete_def)
  qed
qed

lemma bst_delete: assumes "bst t" shows "bst (delete a t)"
proof(cases t)
  case Leaf thus ?thesis by(simp add: delete_def)
next
  case (Node l x r)
  obtain l' x' r' where sp[simp]: "splay a (Node l x r) = Node l' x' r'"
    by (metis neq_Leaf_iff splay_Leaf_iff)
  show ?thesis
  proof cases
    assume [simp]: "x' = a"
    show ?thesis
    proof cases
      assume "l' = Leaf"
      thus ?thesis using Node assms bst_splay[of "Node l x r" a]
        by(simp add: delete_def split: tree.split prod.split)
    next
      assume "l' \<noteq> Leaf"
      thus ?thesis
        using Node assms set_splay[of a "Node l x r"] bst_splay[of "Node l x r" a]
          bst_splay_max[of l'] set_splay_max[of l']
        by(clarsimp simp: delete_def split: tree.split)
          (metis (no_types) insertI1 less_trans)
    qed
  next
    assume "x' \<noteq> a"
    thus ?thesis using Node assms bst_splay[of "Node l x r" a]
      by(auto simp: delete_def split: tree.split prod.split)
  qed
qed
*)

end


(*
  File:    Linear_Inhomogenous_Recurrences.thy
  Author:  Manuel Eberl, TU München
*)
section \<open>Inhomogenous linear recurrences\<close>
theory Linear_Inhomogenous_Recurrences
imports
  Complex_Main
  Linear_Homogenous_Recurrences
  Eulerian_Polynomials
  RatFPS
begin

definition lir_fps_numerator where
  "lir_fps_numerator m cs f g = (let N = length cs - 1 in
      Poly [(\<Sum>i\<le>min N k. cs ! (N - i) * f (k - i)) - g k. k \<leftarrow> [0..<N+m]])"

lemma lir_fps_numerator_code [code abstract]:
  "coeffs (lir_fps_numerator m cs f g) = (let N = length cs - 1 in
     strip_while ((=) 0) [(\<Sum>i\<le>min N k. cs ! (N - i) * f (k - i)) - g k. k \<leftarrow> [0..<N+m]])"
  by (simp add: lir_fps_numerator_def Let_def)

locale linear_inhomogenous_recurrence =
  fixes f g :: "nat \<Rightarrow> 'a :: comm_ring" and cs fs :: "'a list"
  assumes base: "n < length fs \<Longrightarrow> f n = fs ! n"
  assumes cs_not_null [simp]: "cs \<noteq> []" and last_cs [simp]: "last cs \<noteq> 0"
      and hd_cs [simp]: "hd cs \<noteq> 0" and enough_base: "length fs + 1 \<ge> length cs"
  assumes rec:  "n \<ge> length fs + 1 - length cs \<Longrightarrow>
                     (\<Sum>k<length cs. cs ! k * f (n + k)) = g (n + length cs - 1)"
begin

lemma coeff_0_lr_fps_denominator [simp]: "coeff (lr_fps_denominator cs) 0 = last cs"
  by (auto simp: lr_fps_denominator_def nth_default_def nth_Cons hd_conv_nth [symmetric] hd_rev)

lemma lir_fps_numerator_altdef:
  "lir_fps_numerator (length fs + 1 - length cs) cs f g =
     lir_fps_numerator (length fs + 1 - length cs) cs ((!) fs) g"
proof -
  define N where "N = length cs - 1"
  define m where "m = length fs + 1 - length cs"
  have "lir_fps_numerator m cs f g =
          Poly (map (\<lambda>k. (\<Sum>i\<le>min N k. cs ! (N - i) * f (k - i)) - g k) [0..<N + m])"
    by (simp add: lir_fps_numerator_def Let_def N_def)
  also from enough_base have "N + m = length fs"
    by (cases cs) (simp_all add: N_def m_def algebra_simps)
  also {
    fix k assume k: "k \<in> {0..<length fs}"
    hence "f (k - i) = fs ! (k - i)" if "i \<le> min N k" for i
      using enough_base that by (intro base) (auto simp: Suc_le_eq N_def m_def algebra_simps)
    hence "(\<Sum>i\<le>min N k. cs ! (N - i) * f (k - i)) = (\<Sum>i\<le>min N k. cs ! (N - i) * fs ! (k - i))"
      by simp
  }
  hence "map (\<lambda>k. (\<Sum>i\<le>min N k. cs ! (N - i) * f (k - i)) - g k) [0..<length fs] =
           map (\<lambda>k. (\<Sum>i\<le>min N k. cs ! (N - i) * fs ! (k - i)) - g k) [0..<length fs]"
    by (intro map_cong) simp_all
  also have "Poly \<dots> = lir_fps_numerator m cs ((!) fs) g" using enough_base
    by (cases cs) (simp_all add: lir_fps_numerator_def Let_def m_def N_def)
  finally show ?thesis unfolding m_def .
qed

end

context
begin

private lemma lir_fps_aux:
  fixes f :: "nat \<Rightarrow> 'a :: field"
  assumes rec: "\<And>n. n \<ge> m \<Longrightarrow> (\<Sum>k\<le>N. c k * f (n + k)) = g (n + N)"
  assumes cN: "c N \<noteq> 0"
  defines "p \<equiv> Poly [c (N - k). k \<leftarrow> [0..<Suc N]]"
  defines "q \<equiv> Poly [(\<Sum>i\<le>min N k. c (N - i) * f (k - i)) - g k. k \<leftarrow> [0..<N+m]]"
  shows   "Abs_fps f = (fps_of_poly q + Abs_fps g) / fps_of_poly p"
proof -
  include fps_notation
  define F where "F = Abs_fps f"
  have [simp]: "F $ n = f n" for n by (simp add: F_def)
  have [simp]: "coeff p 0 = c N"
    by (simp add: p_def nth_default_def del: upt_Suc)

  have "(fps_of_poly p * F) $ n = coeff q n + g n" for n
  proof (cases "n \<ge> N + m")
    case True
    let ?f = "\<lambda>i. N - i"
    have "(fps_of_poly p * F) $ n = (\<Sum>i\<le>n. coeff p i * f (n - i))"
      by (simp add: fps_mult_nth atLeast0AtMost)
    also from True have "\<dots> = (\<Sum>i\<le>N. coeff p i * f (n - i))"
      by (intro sum.mono_neutral_right) (auto simp: nth_default_def p_def)
    also have "\<dots> = (\<Sum>i\<le>N. c (N - i) * f (n - i))"
      by (intro sum.cong) (auto simp: nth_default_def p_def simp del: upt_Suc)
    also from True have "\<dots> = (\<Sum>i\<le>N. c i * f (n - N + i))"
      by (intro sum.reindex_bij_witness[of _ ?f ?f]) auto
    also from True have "\<dots> = g (n - N + N)" by (intro rec) simp_all
    also from True have "\<dots> = coeff q n + g n"
      by (simp add: q_def nth_default_def del: upt_Suc)
    finally show ?thesis .
  next
    case False
    hence "(fps_of_poly p * F) $ n = (\<Sum>i\<le>n. coeff p i * f (n - i))"
      by (simp add: fps_mult_nth atLeast0AtMost)
    also have "\<dots> = (\<Sum>i\<le>min N n. coeff p i * f (n - i))"
      by (intro sum.mono_neutral_right)
         (auto simp: p_def nth_default_def simp del: upt_Suc)
    also have "\<dots> = (\<Sum>i\<le>min N n. c (N - i) * f (n - i))"
      by (intro sum.cong) (simp_all add: p_def nth_default_def del: upt_Suc)
    also from False have "\<dots> = coeff q n + g n" by (simp add: q_def nth_default_def)
    finally show ?thesis .
  qed
  hence "fps_of_poly p * F = fps_of_poly q + Abs_fps g"
    by (intro fps_ext) (simp add:)
  with cN show "F = (fps_of_poly q + Abs_fps g) / fps_of_poly p"
    by (subst unit_eq_div2) (simp_all add: mult_ac)
qed

lemma lir_fps:
  fixes f g :: "nat \<Rightarrow> 'a :: field" and cs :: "'a list"
  defines "N \<equiv> length cs - 1"
  assumes cs: "cs \<noteq> []"
  assumes "\<And>n. n \<ge> m \<Longrightarrow> (\<Sum>k\<le>N. cs ! k * f (n + k)) = g (n + N)"
  assumes cN: "last cs \<noteq> 0"
  shows   "Abs_fps f = (fps_of_poly (lir_fps_numerator m cs f g) + Abs_fps g) /
              fps_of_poly (lr_fps_denominator cs)"
proof -
  define p and q
    where "p = Poly [(\<Sum>i\<le>min N k. cs ! (N - i) * f (k - i)) - g k. k \<leftarrow> [0..<N+m]]"
      and "q = Poly (map (\<lambda>k. cs ! (N - k)) [0..<Suc N])"
  from assms have "Abs_fps f = (fps_of_poly p + Abs_fps g) / fps_of_poly q"
    unfolding p_def q_def by (intro lir_fps_aux) (simp_all add: last_conv_nth)
  also have "p = lir_fps_numerator m cs f g"
    unfolding p_def lir_fps_numerator_def by (auto simp: Let_def N_def)
  also from cN have "q = lr_fps_denominator cs"
    unfolding q_def lr_fps_denominator_def
    by (intro poly_eqI)
       (auto simp add: nth_default_def rev_nth N_def not_less cs simp del: upt_Suc)
  finally show ?thesis .
qed

end

type_synonym 'a polyexp = "('a \<times> nat \<times> 'a) list"

definition eval_polyexp :: "('a::semiring_1) polyexp \<Rightarrow> nat \<Rightarrow> 'a" where
  "eval_polyexp xs = (\<lambda>n. \<Sum>(a,k,b)\<leftarrow>xs. a * of_nat n ^ k * b ^ n)"

lemma eval_polyexp_Nil [simp]: "eval_polyexp [] = (\<lambda>_. 0)"
  by (simp add: eval_polyexp_def)

lemma eval_polyexp_Cons:
  "eval_polyexp (x#xs) = (\<lambda>n. (case x of (a,k,b) \<Rightarrow> a * of_nat n ^ k * b ^ n) + eval_polyexp xs n)"
  by (simp add: eval_polyexp_def)

definition polyexp_fps :: "('a :: field) polyexp \<Rightarrow> 'a fps" where
  "polyexp_fps xs =
     (\<Sum>(a,k,b)\<leftarrow>xs. fps_of_poly (Polynomial.smult a (fps_monom_poly b k)) /
                       (1 - fps_const b * fps_X) ^ (k + 1))"

lemma polyexp_fps_Nil [simp]: "polyexp_fps [] = 0"
  by (simp add: polyexp_fps_def)

lemma polyexp_fps_Cons:
  "polyexp_fps (x#xs) = (case x of (a,k,b) \<Rightarrow>
     fps_of_poly (Polynomial.smult a (fps_monom_poly b k)) / (1 - fps_const b * fps_X) ^ (k + 1)) +
     polyexp_fps xs"
  by (simp add: polyexp_fps_def)

definition polyexp_ratfps :: "('a :: field_gcd) polyexp \<Rightarrow> 'a ratfps" where
  "polyexp_ratfps xs =
     (\<Sum>(a,k,b)\<leftarrow>xs. ratfps_of_poly (Polynomial.smult a (fps_monom_poly b k)) /
                       ratfps_of_poly ([:1, -b:] ^ (k + 1)))"

lemma polyexp_ratfps_Nil [simp]: "polyexp_ratfps [] = 0"
  by (simp add: polyexp_ratfps_def)

lemma polyexp_ratfps_Cons: "polyexp_ratfps (x#xs) = (case x of (a,k,b) \<Rightarrow>
  ratfps_of_poly (Polynomial.smult a (fps_monom_poly b k)) /
     ratfps_of_poly ([:1, -b:] ^ (k + 1))) + polyexp_ratfps xs"
  by (simp add: polyexp_ratfps_def)

lemma polyexp_fps: "Abs_fps (eval_polyexp xs) = polyexp_fps xs"
proof (induction xs)
  case (Cons x xs)
  obtain a k b where [simp]: "x = (a, k, b)" by (metis prod.exhaust)
  have "Abs_fps (eval_polyexp (x#xs)) =
          fps_const a * Abs_fps (\<lambda>n. of_nat n ^ k * b ^ n) + Abs_fps (eval_polyexp xs)"
    by (simp add: eval_polyexp_Cons fps_plus_def mult_ac)
  also have "Abs_fps (\<lambda>n. of_nat n ^ k * b ^ n) =
               fps_of_poly (fps_monom_poly b k) / (1 - fps_const b * fps_X) ^ (k + 1)"
            (is "_ = ?A / ?B")
    by (rule fps_monom)
  also have "fps_const a * (?A / ?B) = (fps_const a * ?A) / ?B"
    by (intro unit_div_mult_swap) simp_all
  also have "fps_const a * ?A = fps_of_poly (Polynomial.smult a (fps_monom_poly b k))"
    by simp
  also note Cons.IH
  finally show ?case by (simp add: polyexp_fps_Cons)
qed (simp_all add: fps_zero_def)

lemma polyexp_ratfps [simp]: "fps_of_ratfps (polyexp_ratfps xs) = polyexp_fps xs"
  by (induction xs)
     (auto simp del: power_Suc fps_const_neg
           simp: coeff_0_power fps_of_poly_power fps_of_poly_smult fps_of_poly_pCons
                 fps_const_neg [symmetric] mult_ac polyexp_ratfps_Cons polyexp_fps_Cons)

definition lir_fps ::
    "'a :: field_gcd list \<Rightarrow> 'a list \<Rightarrow> 'a polyexp \<Rightarrow> ('a ratfps) option" where
  "lir_fps cs fs g = (if cs = [] \<or> length fs < length cs - 1 then None else
     let m = length fs + 1 - length cs;
         p = lir_fps_numerator m cs (\<lambda>n. fs ! n) (eval_polyexp g);
         q = lr_fps_denominator cs
     in  Some ((ratfps_of_poly p + polyexp_ratfps g) * inverse (ratfps_of_poly q)))"

lemma lir_fps_correct:
  fixes   f :: "nat \<Rightarrow> 'a :: field_gcd"
  assumes "linear_inhomogenous_recurrence f (eval_polyexp g) cs fs"
  shows   "map_option fps_of_ratfps (lir_fps cs fs g) = Some (Abs_fps f)"
proof -
  interpret linear_inhomogenous_recurrence f "eval_polyexp g" cs fs by fact
  define m where "m = length fs + 1 - length cs"
  let ?num = "lir_fps_numerator m cs f (eval_polyexp g)"
  let ?num' = "lir_fps_numerator m cs ((!) fs) (eval_polyexp g)"
  let ?denom = "lr_fps_denominator cs"

  have "{..length cs - 1} = {..<length cs}" by (cases cs) auto
  moreover have "length cs \<ge> 1" by (cases cs) auto
  ultimately have "Abs_fps f = (fps_of_poly ?num + Abs_fps (eval_polyexp g)) / fps_of_poly ?denom"
    by (intro lir_fps) (insert rec, simp_all add: m_def)
  also have "?num = ?num'" by (rule lir_fps_numerator_altdef [folded m_def])
  also have "(fps_of_poly ?num' + Abs_fps (eval_polyexp g)) / fps_of_poly ?denom =
                fps_of_ratfps ((ratfps_of_poly ?num' + polyexp_ratfps g) *
                  inverse (ratfps_of_poly ?denom))"
    by (simp add: polyexp_fps fps_divide_unit)
  also from enough_base have "Some \<dots> = map_option fps_of_ratfps (lir_fps cs fs g)"
    by (cases cs) (simp_all add: base fps_of_ratfps_def case_prod_unfold lir_fps_def m_def)
  finally show ?thesis ..
qed

end