theory frac
imports AutoCorres
  GCD "~~/src/HOL/Number_Theory/Primes"
begin

install_C_file "frac.c"

context frac
begin

  thm abs_body_def

end

autocorres [ ts_force pure = , ts_force nondet =  abs add gcd, unsigned_word_abs = gcd ] "frac.c"

context frac
begin

  thm abs'_def
  thm add'_def
  thm frac'_def
  thm gcd'_def

  section "the abs function"

  thm abs'_def

  term "abs'"

  lemma "\<lbrace> %s. True \<rbrace> func \<lbrace> % rv s. rv = 0 \<rbrace>!"
    oops

  lemma "\<lbrace> %s. abs a \<le> INT_MAX   \<rbrace> abs' a  \<lbrace> %r s. r = abs a \<rbrace>!"
    unfolding abs'_def
    apply wp
    apply simp
    apply safe
    proof -
      fix a
      assume A: "\<bar>a\<bar> \<le> INT_MAX"
      assume al0: "a < 0"
      have "-a = \<bar>a\<bar>" using al0 by auto
    also
      have "\<dots> \<le> INT_MAX" by fact
    finally
      show "-a \<le> INT_MAX" .

      have "- INT_MAX - 1 \<le> - INT_MAX" by simp
    also
      have "- INT_MAX \<le> - \<bar>a\<bar>" using A by fastforce
    also
      have " - \<bar>a\<bar> = a" using al0 by simp
    also
      have "a \<le> -a" using al0 by simp
    finally
      show "- INT_MAX - 1 \<le> - a" .
    qed

    thm abs'_def
  lemma abs_wp: (* [wp] *)
    "\<lbrace> %s. INT_MIN < a \<and> a \<le> INT_MAX  \<rbrace> abs' a  \<lbrace> %r s. r = abs a  \<rbrace>!"
    unfolding abs'_def
    apply wp by (auto simp add: INT_MAX_def INT_MIN_def)

  section "the gcd function"

  thm gcd'_def

  text " a suggested correctness property of gcd"
  lemma gcd_wp: (* [wp]: *)
    "\<lbrace> P (gcd a b) \<rbrace> gcd' a b \<lbrace> P \<rbrace>!" sorry

  section "the frac function"

  thm frac'_def

  term frac_t_C (* a constructor for the frac structure, but it takes two '32 signed word' not ints! *)

  lemma frac_wp:
    "\<lbrace> %s. True \<rbrace> frac' a b \<lbrace> %rv s. (\<exists>x y.  y>0 \<and> gcd x y = 1 \<and> a*y=b*x \<and> rv = frac_t_C (of_int x) (of_int y) ) \<rbrace>!" sorry

  section "the add function"

  thm add'_def

  (* TODO: formulate correctness properties of add *)

end

end


(*<*)
theory GoedelProof_P2
imports IHOML
begin
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 3,  atoms e = a b c d, timeout=60]
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>\<open>"Fitting"\<close>, 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>\<open>C55 and C60\<close> \<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>\<open>"sobel2004logic"\<close>, 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
(*>*)


(*  Title:      HOL/UNITY/Constrains.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Weak safety relations: restricted to the set of reachable states.
*)

section{*Weak Safety*}

theory Constrains imports UNITY begin

  (*Initial states and program => (final state, reversed trace to it)...
    Arguments MUST be curried in an inductive definition*)

inductive_set
  traces :: "['a set, ('a * 'a)set set] => ('a * 'a list) set"
  for init :: "'a set" and acts :: "('a * 'a)set set"
  where
         (*Initial trace is empty*)
    Init:  "s \<in> init ==> (s,[]) \<in> traces init acts"

  | Acts:  "[| act: acts;  (s,evs) \<in> traces init acts;  (s,s'): act |]
            ==> (s', s#evs) \<in> traces init acts"

inductive_set
  reachable :: "'a program => 'a set"
  for F :: "'a program"
  where
    Init:  "s \<in> Init F ==> s \<in> reachable F"

  | Acts:  "[| act: Acts F;  s \<in> reachable F;  (s,s'): act |]
            ==> s' \<in> reachable F"

definition Constrains :: "['a set, 'a set] => 'a program set" (infixl "Co" 60) where
    "A Co B == {F. F \<in> (reachable F \<inter> A)  co  B}"

definition Unless  :: "['a set, 'a set] => 'a program set" (infixl "Unless" 60) where
    "A Unless B == (A-B) Co (A \<union> B)"

definition Stable     :: "'a set => 'a program set" where
    "Stable A == A Co A"

  (*Always is the weak form of "invariant"*)
definition Always :: "'a set => 'a program set" where
    "Always A == {F. Init F \<subseteq> A} \<inter> Stable A"

  (*Polymorphic in both states and the meaning of \<le> *)
definition Increasing :: "['a => 'b::{order}] => 'a program set" where
    "Increasing f == \<Inter>z. Stable {s. z \<le> f s}"

subsection{*traces and reachable*}

lemma reachable_equiv_traces:
     "reachable F = {s. \<exists>evs. (s,evs) \<in> traces (Init F) (Acts F)}"
apply safe
apply (erule_tac [2] traces.induct)
apply (erule reachable.induct)
apply (blast intro: reachable.intros traces.intros)+
done

lemma Init_subset_reachable: "Init F \<subseteq> reachable F"
by (blast intro: reachable.intros)

lemma stable_reachable [intro!,simp]:
     "Acts G \<subseteq> Acts F ==> G \<in> stable (reachable F)"
by (blast intro: stableI constrainsI reachable.intros)

(*The set of all reachable states is an invariant...*)
lemma invariant_reachable: "F \<in> invariant (reachable F)"
apply (simp add: invariant_def)
apply (blast intro: reachable.intros)
done

(*...in fact the strongest invariant!*)
lemma invariant_includes_reachable: "F \<in> invariant A ==> reachable F \<subseteq> A"
apply (simp add: stable_def constrains_def invariant_def)
apply (rule subsetI)
apply (erule reachable.induct)
apply (blast intro: reachable.intros)+
done

subsection{*Co*}

(*F \<in> B co B' ==> F \<in> (reachable F \<inter> B) co (reachable F \<inter> B')*)
lemmas constrains_reachable_Int =
    subset_refl [THEN stable_reachable [unfolded stable_def], THEN constrains_Int]

(*Resembles the previous definition of Constrains*)
lemma Constrains_eq_constrains:
     "A Co B = {F. F \<in> (reachable F  \<inter>  A) co (reachable F  \<inter>  B)}"
apply (unfold Constrains_def)
apply (blast dest: constrains_reachable_Int intro: constrains_weaken)
done

lemma constrains_imp_Constrains: "F \<in> A co A' ==> F \<in> A Co A'"
apply (unfold Constrains_def)
apply (blast intro: constrains_weaken_L)
done

lemma stable_imp_Stable: "F \<in> stable A ==> F \<in> Stable A"
apply (unfold stable_def Stable_def)
apply (erule constrains_imp_Constrains)
done

lemma ConstrainsI:
    "(!!act s s'. [| act: Acts F;  (s,s') \<in> act;  s \<in> A |] ==> s': A')
     ==> F \<in> A Co A'"
apply (rule constrains_imp_Constrains)
apply (blast intro: constrainsI)
done

lemma Constrains_empty [iff]: "F \<in> {} Co B"
by (unfold Constrains_def constrains_def, blast)

lemma Constrains_UNIV [iff]: "F \<in> A Co UNIV"
by (blast intro: ConstrainsI)

lemma Constrains_weaken_R:
    "[| F \<in> A Co A'; A'<=B' |] ==> F \<in> A Co B'"
apply (unfold Constrains_def)
apply (blast intro: constrains_weaken_R)
done

lemma Constrains_weaken_L:
    "[| F \<in> A Co A'; B \<subseteq> A |] ==> F \<in> B Co A'"
apply (unfold Constrains_def)
apply (blast intro: constrains_weaken_L)
done

lemma Constrains_weaken:
   "[| F \<in> A Co A'; B \<subseteq> A; A'<=B' |] ==> F \<in> B Co B'"
apply (unfold Constrains_def)
apply (blast intro: constrains_weaken)
done

(** Union **)

lemma Constrains_Un:
    "[| F \<in> A Co A'; F \<in> B Co B' |] ==> F \<in> (A \<union> B) Co (A' \<union> B')"
apply (unfold Constrains_def)
apply (blast intro: constrains_Un [THEN constrains_weaken])
done

lemma Constrains_UN:
  assumes Co: "!!i. i \<in> I ==> F \<in> (A i) Co (A' i)"
  shows "F \<in> (\<Union>i \<in> I. A i) Co (\<Union>i \<in> I. A' i)"
apply (unfold Constrains_def)
apply (rule CollectI)
apply (rule Co [unfolded Constrains_def, THEN CollectD, THEN constrains_UN,
                THEN constrains_weaken],   auto)
done

(** Intersection **)

lemma Constrains_Int:
    "[| F \<in> A Co A'; F \<in> B Co B' |] ==> F \<in> (A \<inter> B) Co (A' \<inter> B')"
apply (unfold Constrains_def)
apply (blast intro: constrains_Int [THEN constrains_weaken])
done

lemma Constrains_INT:
  assumes Co: "!!i. i \<in> I ==> F \<in> (A i) Co (A' i)"
  shows "F \<in> (\<Inter>i \<in> I. A i) Co (\<Inter>i \<in> I. A' i)"
apply (unfold Constrains_def)
apply (rule CollectI)
apply (rule Co [unfolded Constrains_def, THEN CollectD, THEN constrains_INT,
                THEN constrains_weaken],   auto)
done

lemma Constrains_imp_subset: "F \<in> A Co A' ==> reachable F \<inter> A \<subseteq> A'"
by (simp add: constrains_imp_subset Constrains_def)

lemma Constrains_trans: "[| F \<in> A Co B; F \<in> B Co C |] ==> F \<in> A Co C"
apply (simp add: Constrains_eq_constrains)
apply (blast intro: constrains_trans constrains_weaken)
done

lemma Constrains_cancel:
     "[| F \<in> A Co (A' \<union> B); F \<in> B Co B' |] ==> F \<in> A Co (A' \<union> B')"
apply (simp add: Constrains_eq_constrains constrains_def)
apply best
done

subsection{*Stable*}

(*Useful because there's no Stable_weaken.  [Tanja Vos]*)
lemma Stable_eq: "[| F \<in> Stable A; A = B |] ==> F \<in> Stable B"
by blast

lemma Stable_eq_stable: "(F \<in> Stable A) = (F \<in> stable (reachable F \<inter> A))"
by (simp add: Stable_def Constrains_eq_constrains stable_def)

lemma StableI: "F \<in> A Co A ==> F \<in> Stable A"
by (unfold Stable_def, assumption)

lemma StableD: "F \<in> Stable A ==> F \<in> A Co A"
by (unfold Stable_def, assumption)

lemma Stable_Un:
    "[| F \<in> Stable A; F \<in> Stable A' |] ==> F \<in> Stable (A \<union> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Un)
done

lemma Stable_Int:
    "[| F \<in> Stable A; F \<in> Stable A' |] ==> F \<in> Stable (A \<inter> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Int)
done

lemma Stable_Constrains_Un:
    "[| F \<in> Stable C; F \<in> A Co (C \<union> A') |]
     ==> F \<in> (C \<union> A) Co (C \<union> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Un [THEN Constrains_weaken])
done

lemma Stable_Constrains_Int:
    "[| F \<in> Stable C; F \<in> (C \<inter> A) Co A' |]
     ==> F \<in> (C \<inter> A) Co (C \<inter> A')"
apply (unfold Stable_def)
apply (blast intro: Constrains_Int [THEN Constrains_weaken])
done

lemma Stable_UN:
    "(!!i. i \<in> I ==> F \<in> Stable (A i)) ==> F \<in> Stable (\<Union>i \<in> I. A i)"
by (simp add: Stable_def Constrains_UN)

lemma Stable_INT:
    "(!!i. i \<in> I ==> F \<in> Stable (A i)) ==> F \<in> Stable (\<Inter>i \<in> I. A i)"
by (simp add: Stable_def Constrains_INT)

lemma Stable_reachable: "F \<in> Stable (reachable F)"
by (simp add: Stable_eq_stable)

subsection{*Increasing*}

lemma IncreasingD:
     "F \<in> Increasing f ==> F \<in> Stable {s. x \<le> f s}"
by (unfold Increasing_def, blast)

lemma mono_Increasing_o:
     "mono g ==> Increasing f \<subseteq> Increasing (g o f)"
apply (simp add: Increasing_def Stable_def Constrains_def stable_def
                 constrains_def)
apply (blast intro: monoD order_trans)
done

lemma strict_IncreasingD:
     "!!z::nat. F \<in> Increasing f ==> F \<in> Stable {s. z < f s}"
by (simp add: Increasing_def Suc_le_eq [symmetric])

lemma increasing_imp_Increasing:
     "F \<in> increasing f ==> F \<in> Increasing f"
apply (unfold increasing_def Increasing_def)
apply (blast intro: stable_imp_Stable)
done

lemmas Increasing_constant = increasing_constant [THEN increasing_imp_Increasing, iff]

subsection{*The Elimination Theorem*}

(*The "free" m has become universally quantified! Should the premise be !!m
instead of \<forall>m ?  Would make it harder to use in forward proof.*)

lemma Elimination:
    "[| \<forall>m. F \<in> {s. s x = m} Co (B m) |]
     ==> F \<in> {s. s x \<in> M} Co (\<Union>m \<in> M. B m)"
by (unfold Constrains_def constrains_def, blast)

(*As above, but for the trivial case of a one-variable state, in which the
  state is identified with its one variable.*)
lemma Elimination_sing:
    "(\<forall>m. F \<in> {m} Co (B m)) ==> F \<in> M Co (\<Union>m \<in> M. B m)"
by (unfold Constrains_def constrains_def, blast)

subsection{*Specialized laws for handling Always*}

(** Natural deduction rules for "Always A" **)

lemma AlwaysI: "[| Init F \<subseteq> A;  F \<in> Stable A |] ==> F \<in> Always A"
by (simp add: Always_def)

lemma AlwaysD: "F \<in> Always A ==> Init F \<subseteq> A & F \<in> Stable A"
by (simp add: Always_def)

lemmas AlwaysE = AlwaysD [THEN conjE]
lemmas Always_imp_Stable = AlwaysD [THEN conjunct2]

(*The set of all reachable states is Always*)
lemma Always_includes_reachable: "F \<in> Always A ==> reachable F \<subseteq> A"
apply (simp add: Stable_def Constrains_def constrains_def Always_def)
apply (rule subsetI)
apply (erule reachable.induct)
apply (blast intro: reachable.intros)+
done

lemma invariant_imp_Always:
     "F \<in> invariant A ==> F \<in> Always A"
apply (unfold Always_def invariant_def Stable_def stable_def)
apply (blast intro: constrains_imp_Constrains)
done

lemmas Always_reachable = invariant_reachable [THEN invariant_imp_Always]

lemma Always_eq_invariant_reachable:
     "Always A = {F. F \<in> invariant (reachable F \<inter> A)}"
apply (simp add: Always_def invariant_def Stable_def Constrains_eq_constrains
                 stable_def)
apply (blast intro: reachable.intros)
done

(*the RHS is the traditional definition of the "always" operator*)
lemma Always_eq_includes_reachable: "Always A = {F. reachable F \<subseteq> A}"
by (auto dest: invariant_includes_reachable simp add: Int_absorb2 invariant_reachable Always_eq_invariant_reachable)

lemma Always_UNIV_eq [simp]: "Always UNIV = UNIV"
by (auto simp add: Always_eq_includes_reachable)

lemma UNIV_AlwaysI: "UNIV \<subseteq> A ==> F \<in> Always A"
by (auto simp add: Always_eq_includes_reachable)

lemma Always_eq_UN_invariant: "Always A = (\<Union>I \<in> Pow A. invariant I)"
apply (simp add: Always_eq_includes_reachable)
apply (blast intro: invariantI Init_subset_reachable [THEN subsetD]
                    invariant_includes_reachable [THEN subsetD])
done

lemma Always_weaken: "[| F \<in> Always A; A \<subseteq> B |] ==> F \<in> Always B"
by (auto simp add: Always_eq_includes_reachable)

subsection{*"Co" rules involving Always*}

lemma Always_Constrains_pre:
     "F \<in> Always INV ==> (F \<in> (INV \<inter> A) Co A') = (F \<in> A Co A')"
by (simp add: Always_includes_reachable [THEN Int_absorb2] Constrains_def
              Int_assoc [symmetric])

lemma Always_Constrains_post:
     "F \<in> Always INV ==> (F \<in> A Co (INV \<inter> A')) = (F \<in> A Co A')"
by (simp add: Always_includes_reachable [THEN Int_absorb2]
              Constrains_eq_constrains Int_assoc [symmetric])

(* [| F \<in> Always INV;  F \<in> (INV \<inter> A) Co A' |] ==> F \<in> A Co A' *)
lemmas Always_ConstrainsI = Always_Constrains_pre [THEN iffD1]

(* [| F \<in> Always INV;  F \<in> A Co A' |] ==> F \<in> A Co (INV \<inter> A') *)
lemmas Always_ConstrainsD = Always_Constrains_post [THEN iffD2]

(*The analogous proof of Always_LeadsTo_weaken doesn't terminate*)
lemma Always_Constrains_weaken:
     "[| F \<in> Always C;  F \<in> A Co A';
         C \<inter> B \<subseteq> A;   C \<inter> A' \<subseteq> B' |]
      ==> F \<in> B Co B'"
apply (rule Always_ConstrainsI, assumption)
apply (drule Always_ConstrainsD, assumption)
apply (blast intro: Constrains_weaken)
done

(** Conjoining Always properties **)

lemma Always_Int_distrib: "Always (A \<inter> B) = Always A \<inter> Always B"
by (auto simp add: Always_eq_includes_reachable)

lemma Always_INT_distrib: "Always (INTER I A) = (\<Inter>i \<in> I. Always (A i))"
by (auto simp add: Always_eq_includes_reachable)

lemma Always_Int_I:
     "[| F \<in> Always A;  F \<in> Always B |] ==> F \<in> Always (A \<inter> B)"
by (simp add: Always_Int_distrib)

(*Allows a kind of "implication introduction"*)
lemma Always_Compl_Un_eq:
     "F \<in> Always A ==> (F \<in> Always (-A \<union> B)) = (F \<in> Always B)"
by (auto simp add: Always_eq_includes_reachable)

(*Delete the nearest invariance assumption (which will be the second one
  used by Always_Int_I) *)
lemmas Always_thin = thin_rl [of "F \<in> Always A"]

subsection{*Totalize*}

lemma reachable_imp_reachable_tot:
      "s \<in> reachable F ==> s \<in> reachable (totalize F)"
apply (erule reachable.induct)
 apply (rule reachable.Init)
 apply simp
apply (rule_tac act = "totalize_act act" in reachable.Acts)
apply (auto simp add: totalize_act_def)
done

lemma reachable_tot_imp_reachable:
      "s \<in> reachable (totalize F) ==> s \<in> reachable F"
apply (erule reachable.induct)
 apply (rule reachable.Init, simp)
apply (force simp add: totalize_act_def intro: reachable.Acts)
done

lemma reachable_tot_eq [simp]: "reachable (totalize F) = reachable F"
by (blast intro: reachable_imp_reachable_tot reachable_tot_imp_reachable)

lemma totalize_Constrains_iff [simp]: "(totalize F \<in> A Co B) = (F \<in> A Co B)"
by (simp add: Constrains_def)

lemma totalize_Stable_iff [simp]: "(totalize F \<in> Stable A) = (F \<in> Stable A)"
by (simp add: Stable_def)

lemma totalize_Always_iff [simp]: "(totalize F \<in> Always A) = (F \<in> Always A)"
by (simp add: Always_def)

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
Termination for recursive functions.
*)
theory Factorial
imports
  "../../AutoCorres"
  "../../../lib/Monad_WP/OptionMonadWP"
begin

(* Parse the input file. *)
install_C_file "factorial.c"

autocorres "factorial.c"

context factorial begin

(* Termination *)
thm factorial'.simps

lemma ovalidNF_grab_asm2:
  "ovalidNF (\<lambda>s. G \<and> P s) f Q \<Longrightarrow> G \<Longrightarrow> ovalidNF P f Q"
  by (auto simp: ovalidNF_def)

lemma ovalidNF_grab_asm_eq:
  "(G \<longrightarrow> ovalidNF P f Q) = ovalidNF (\<lambda>s. G \<and> P s) f Q"
  by (auto simp: ovalidNF_def)

lemma ovalid_post_triv:
  "(\<And>r s. Q r s) \<Longrightarrow> ovalid P f Q"
  by (simp add: ovalid_def)

lemma factorial'_terminates: "no_ofail (\<lambda>_. m > unat n) (factorial' m n)"
proof (induct n arbitrary: m rule: less_induct)
   fix x m
   assume induct_asm0: "(\<And>y m. y < x \<Longrightarrow> no_ofail (\<lambda>_. unat y < m) (factorial' m y))"
   have induct_asm: "(\<And>y m. no_ofail (\<lambda>_. y < x \<and> unat y < m) (factorial' m y))"
     apply (rule no_ofail_grab_asm)
     by (rule induct_asm0)

   show "no_ofail (\<lambda>_. unat x < m) (factorial' m x)"
     apply (subst factorial'.simps)
     apply (wp induct_asm ovalid_post_triv)
     apply unat_arith
    done
qed

lemma factorial'_terminates_old: "m > unat n \<longrightarrow> factorial' m n s \<noteq> None"
  apply (induct n arbitrary: m)
   apply (subst factorial'.simps, simp add: ocondition_def obind_def)
  apply (subst factorial'.simps, simp add: ocondition_def obind_def split: option.splits)
  apply (metis One_nat_def Suc_eq_plus1 less_diff_conv option.distinct(1) unatSuc)
  done

(* A fun fact *)
function fact :: "('n :: len) word \<Rightarrow> ('n :: len) word" where
  "fact n = (if n = 0 then 1 else n * fact (n - 1))"
  by auto
termination by (metis "termination" in_measure measure_unat wf_measure)
declare fact.simps [simp del]

(* Termination & correctness *)
lemma factorial'_correct: "ovalidNF (\<lambda>_. m > unat n) (factorial' m n) (\<lambda>r _. r = fact n)"
proof (induct n arbitrary: m)
   fix n m
   show "ovalidNF (\<lambda>_. unat 0 < m) (factorial' m 0) (\<lambda>r _. r = fact 0)"
     apply (subst factorial'.simps)
     apply (simp add: ovalidNF_def ocondition_def ofail_def oreturn_def obind_def fact.simps)
     done

   assume induct_asm0: "\<And>m. ovalidNF (\<lambda>_. unat n < m) (factorial' m n) (\<lambda>r _. r = fact n)"
   have induct_asm: "\<And>m. 1 + n \<noteq> 0 \<Longrightarrow> ovalidNF (\<lambda>_. unat n < m) (factorial' m n) (\<lambda>r _. (1 + n) * r = fact (1 + n))"
     apply (subst fact.simps)
     apply simp
     apply (insert induct_asm0)
     apply (unfold ovalidNF_def)
     apply simp
     done

   show "\<lbrakk> 1 + n \<noteq> 0 \<rbrakk>
          \<Longrightarrow> ovalidNF (\<lambda>_. unat (1 + n) < m) (factorial' m (1 + n))
              (\<lambda>r _. r = fact (1 + n))"
     apply (subst factorial'.simps)
     apply (rule_tac G = "1 + n \<noteq> 0" in ovalidNF_grab_asm2)
      apply wp
       apply (simp del: One_nat_def)
       apply (wp induct_asm)
      apply unat_arith
     apply assumption
    done
qed

lemma factorial'_correct_old: "m > unat n \<longrightarrow> factorial' m n s = Some (fact n)"
  apply (induct n arbitrary: m)
   apply (subst factorial'.simps, subst fact.simps, simp add: ocondition_def obind_def)
  apply (subst factorial'.simps, subst fact.simps, simp add: ocondition_def obind_def)
  apply (clarsimp split: option.splits)
  apply (intro conjI impI)
    apply unat_arith
   apply (metis (hide_lams, no_types) Nat.add_0_right le_iff_add Suc_eq_plus1_left Suc_pred factorial.factorial'_terminates_old less_nat_zero_code nat_add_left_cancel_less nat_less_le)
  apply (unat_arith, force)
  done

(* Termination & correctness of call_factorial *)
thm call_factorial'_def

lemma "\<lbrace> \<top> \<rbrace> call_factorial' \<lbrace> \<lambda>r s. r = fact 42 \<rbrace>!"
  unfolding call_factorial'_def
  apply wp
   using factorial'_correct_old
   apply force
  apply (force simp: option_monad_mono_eq (* factorial'_mono *))
  done

end

end


theory If_Else_Continuity
imports HOLCF  SetPcpo
begin

lemma bool_cont_implies_lub : "cont pred \<Longrightarrow> chain Y \<Longrightarrow> (\<And>i. pred (Y i)) \<Longrightarrow> pred (Lub Y)" by (smt cont_def fun.set_map imageE lub_const lub_eq lub_eqI)

lemma bool_cont_implies_not_lub : "cont pred \<Longrightarrow> chain Y \<Longrightarrow> (\<And>i. \<not> pred (Y i)) \<Longrightarrow> \<not> pred (Lub Y)" by (simp add: cont2contlubE is_lub_const is_lub_rangeD1 lub_chain_maxelem)

lemma bool_mono_implies_adm : "monofun pred \<Longrightarrow> adm pred"
proof -
  assume asm : "monofun pred"
  have "\<And>Y. chain Y \<Longrightarrow> (\<forall>i. pred (Y i)) \<Longrightarrow> pred (Lub Y)"
  proof -
    fix Y :: "nat \<Rightarrow> 'a"
    assume chainY : "chain Y"
    and "(\<forall>i. pred (Y i))"
    then obtain true_i where true_i_def : "pred (Y true_i)" by simp
    hence "Y true_i \<sqsubseteq> Lub Y" using chainY is_ub_thelub by blast
    hence "pred (Y true_i) \<sqsubseteq> pred (Lub Y)" by (simp add: asm monofunE)
    thus "pred (Lub Y)" by (simp add: SetPcpo.less_bool_def true_i_def)
  qed
  thus "adm pred" by (simp add: adm_def)
qed

lemma bool_cont_implies_adm : "cont pred \<Longrightarrow> adm pred" by (simp add: bool_mono_implies_adm cont2mono)

instantiation nat :: po
begin

definition below_nat :: "nat \<Rightarrow> nat \<Rightarrow> bool"  where
"below_nat \<equiv> (\<le>)"

instance by intro_classes (simp_all add: below_nat_def)
end

definition set_below :: "'a::po set \<Rightarrow> 'a set \<Rightarrow> bool" where
"set_below S1 S2 = (\<forall>x\<in>S1. \<forall>y\<in>S2. x \<sqsubseteq> y)"

lemma ubS2_is_ubS1 : "\<lbrakk>set_below S1 S2; \<exists>x. x \<in> S2; S2 <| l\<rbrakk> \<Longrightarrow> S1 <| l"
proof (rule ccontr)
  assume below : "set_below S1 S2"
  and S2_not_empty : "\<exists>x. x \<in> S2"
  and ubS2 : "S2 <| l"
  and contr : "\<not> S1 <| l"
  then obtain greater_x where greater_x_def : "greater_x \<in> S1 \<and> \<not> greater_x \<sqsubseteq> l" using is_ubI by blast
  obtain inS2 where inS2_def : "inS2 \<in> S2" using S2_not_empty by auto
  hence "greater_x \<sqsubseteq> inS2" using below greater_x_def set_below_def by blast
  thus False using box_below greater_x_def inS2_def is_ubD ubS2 by blast
qed

lemma lubS2_is_lub_union : "\<lbrakk>set_below S1 S2; \<exists>x. x \<in> S2; S2 <<| x\<rbrakk> \<Longrightarrow> S1 \<union> S2 <<| x"
by (smt HOLCF_trans_rules(1) Un_iff is_lub_def is_ub_def set_below_def)

primrec restr :: "(nat \<Rightarrow> 'a::cpo) \<Rightarrow> 'a set \<Rightarrow> nat \<Rightarrow> 'a" where
"restr Y S 0 = Y (LEAST i. Y i \<in> S)" |
"restr Y S (Suc n) = (if Y (Suc n) \<in> S then Y (Suc n) else restr Y S n)"

lemma restr_unchanged_on_S : "Y j \<in> S \<Longrightarrow> restr Y S j = Y j" by (metis Least_eq_0 old.nat.exhaust restr.simps(1) restr.simps(2))

theorem restr_ends_in_Y : "chain Y \<Longrightarrow> (\<And>i. \<exists>j. restr Y S i = Y j)"
proof -
  assume chainY : "chain Y"
  fix i :: nat
  show "\<exists>j. restr Y S i = Y j"
  proof (induct i)
    show "\<exists>j. restr Y S 0 = Y j" by auto
    show "\<And>i. \<exists>j. restr Y S i = Y j \<Longrightarrow> \<exists>j. restr Y S (Suc i) = Y j" by auto
  qed
qed

theorem restr_ends_in_S : "chain Y \<Longrightarrow> \<exists>x. x \<in> range Y \<inter> S \<Longrightarrow> range (restr Y S) \<subseteq> S"
proof -
  assume chainY : "chain Y"
  and intersection_not_empty : " \<exists>x. x \<in> range Y \<inter> S "
  have "\<And>i. (restr Y S) i \<in> S"
  proof -
    fix i :: nat
    show "restr Y S i \<in> S"
    proof (induct i)
      show "restr Y S 0 \<in> S"  by (metis restr.simps(1) Int_iff LeastI imageE intersection_not_empty)

      fix i :: nat
      show "restr Y S i \<in> S \<Longrightarrow> restr Y S (Suc i) \<in> S"
      proof (cases "Y i \<in> S")
        case True
        thus ?thesis by (simp add: restr_unchanged_on_S)
        next

        assume inductive_asm : "restr Y S i \<in> S"
        case False
        thus ?thesis by (simp add: inductive_asm)
      qed
    qed
  qed
  thus ?thesis by blast
qed

lemma restr_range : "chain Y \<Longrightarrow> \<exists>x. x \<in> range Y \<inter> S \<Longrightarrow> range (restr Y S) = range Y \<inter> S"
proof -
  assume chainY : "chain Y"
  and intersection_not_empty : " \<exists>x. x \<in> range Y \<inter> S "
  have restr_subs_inter : "range (restr Y S) \<subseteq> range Y \<inter> S" using chainY intersection_not_empty restr_ends_in_S restr_ends_in_Y by fastforce
  have "range Y \<inter> S \<subseteq> range (restr Y S)" by (smt image_iff inf_le1 inf_le2 restr_unchanged_on_S subsetCE subsetI)
  thus ?thesis using restr_subs_inter by blast
qed

theorem below_least : "chain Y \<Longrightarrow> i \<sqsubseteq> (LEAST i. Y i \<in> S) \<Longrightarrow> restr Y S i = restr Y S 0"
proof (induct i)
  show "chain Y \<Longrightarrow> 0 \<sqsubseteq> (LEAST i. Y i \<in> S) \<Longrightarrow> restr Y S 0 = restr Y S 0" by blast

  fix i :: nat
  assume inductive_asm : "chain Y \<Longrightarrow> i \<sqsubseteq> (LEAST i. Y i \<in> S) \<Longrightarrow> restr Y S i = restr Y S 0"
  show "chain Y \<Longrightarrow> Suc i \<sqsubseteq> (LEAST i. Y i \<in> S) \<Longrightarrow> restr Y S (Suc i) = restr Y S 0"
  proof (cases "Y (Suc i) \<in> S")
    assume chainY : "chain Y"
    and least : "Suc i \<sqsubseteq> (LEAST i. Y i \<in> S)"
    case True
    hence "Suc i = (LEAST i. Y i \<in> S)" using least by (simp add: Least_le below_nat_def po_eq_conv)
    thus ?thesis by (metis True restr.simps(1) restr.simps(2))
    next

    assume chainY : "chain Y"
    and least : "Suc i \<sqsubseteq> (LEAST i. Y i \<in> S)"
    case False
    thus ?thesis using below_nat_def below_refl below_trans chainY inductive_asm le_Suc_eq local.least restr.simps(2) by auto
  qed
qed

theorem above_least :
  assumes "chain Y" and "\<exists>x. x \<in> (range Y) \<inter> S"
  shows "(LEAST i. Y i \<in> S) \<sqsubseteq> i \<Longrightarrow> restr Y S i \<sqsubseteq> Y i"
proof (induct i)
  show "(LEAST i. Y i \<in> S) \<sqsubseteq> 0 \<Longrightarrow> restr Y S 0 \<sqsubseteq> Y 0" by (simp add: below_nat_def)

  fix i :: nat
  assume inductive_asm : "((LEAST i. Y i \<in> S) \<sqsubseteq> i \<Longrightarrow> restr Y S i \<sqsubseteq> Y i)"
  show "(LEAST i. Y i \<in> S) \<sqsubseteq> Suc i \<Longrightarrow> restr Y S (Suc i) \<sqsubseteq> Y (Suc i)"
  proof (cases "Y (Suc i) \<in> S")
    assume asm : "(LEAST i. Y i \<in> S) \<sqsubseteq> Suc i"
    case False
    hence "(LEAST i. Y i \<in> S) \<sqsubseteq> i" by (metis Int_iff LeastI asm assms(2) below_nat_def imageE le_Suc_eq)
    thus ?thesis using assms(1) box_below inductive_asm po_class.chainE by fastforce
    next

    case True
    thus ?thesis by (simp add: po_eq_conv restr_unchanged_on_S)
  qed
qed

theorem restr_increases :
  assumes "chain Y" and "\<exists>x. x \<in> (range Y) \<inter> S"
  shows "Y j \<sqsubseteq> restr Y S i \<Longrightarrow> Y j \<sqsubseteq> restr Y S (Suc i)"
proof (induct i)
  show "Y j \<sqsubseteq> restr Y S 0 \<Longrightarrow> Y j \<sqsubseteq> restr Y S (Suc 0)" by (smt assms(1) below_least below_nat_def below_trans nat_le_linear po_class.chain_mono restr.simps(1) restr.simps(2))

  fix i :: nat
  assume inductive_asm : "Y j \<sqsubseteq> restr Y S i \<Longrightarrow> Y j \<sqsubseteq> restr Y S (Suc i)"
  show "Y j \<sqsubseteq> restr Y S (Suc i) \<Longrightarrow> Y j \<sqsubseteq> restr Y S (Suc (Suc i))"
  proof (cases "(LEAST i. Y i \<in> S) \<sqsubseteq> (Suc (Suc i))")
    assume asm : "Y j \<sqsubseteq> restr Y S (Suc i)"
    case True
    show ?thesis
    proof (cases "Y (Suc (Suc i)) \<in> S")
      case True
      thus ?thesis by (smt above_least asm assms(1) assms(2) below_least below_nat_def box_below nat_le_linear po_class.chainE po_class.chain_mono restr.simps(1) restr.simps(2))
      next

      case False
      thus ?thesis using asm restr.simps(2) by auto
    qed
    next

    assume asm : "Y j \<sqsubseteq> restr Y S (Suc i)"
    case False
    show ?thesis
    proof (cases "Y (Suc (Suc i)) \<in> S")
      case True
      thus ?thesis using False Least_le below_nat_def by fastforce
      next

      case False
      thus ?thesis using asm restr.simps(2) by auto
    qed
  qed
qed

lemma restr_is_chain :
  assumes "chain Y" and "\<exists>x. x \<in> (range Y) \<inter> S"
  shows "chain (restr Y S)"
by (metis assms(1) assms(2) below_refl po_class.chainI restr_ends_in_Y restr_increases)

lemma restr_finite_is_finite : "finite_chain Y \<Longrightarrow> \<exists>x. x \<in> (range Y) \<inter> S \<Longrightarrow> finite_chain (restr Y S)"
by (metis finch_imp_finite_range finite_Int finite_chain_def finite_range_imp_finch restr_is_chain restr_range)

definition non_finite_subchain :: "(nat \<Rightarrow> 'a::cpo) \<Rightarrow> (nat \<Rightarrow> 'a::cpo) \<Rightarrow> bool" where
"non_finite_subchain X Y \<equiv> chain X \<and> chain Y \<and> (range X \<subseteq> range Y) \<and> \<not> finite_chain X"

definition unbounded_subchain :: "(nat \<Rightarrow> 'a::cpo) \<Rightarrow> (nat \<Rightarrow> 'a::cpo) \<Rightarrow> bool" where
"unbounded_subchain X Y \<equiv> chain X \<and> chain Y \<and> (range X \<subseteq> range Y) \<and> (\<forall>i. \<exists>j. Y i \<sqsubseteq> X j)"

lemma "chain X \<and> \<not> finite_chain X \<Longrightarrow> (\<And>i. \<exists>j. X i \<noteq> X j \<and> X i \<sqsubseteq> X j)"
using finite_chain_def max_in_chain_def po_class.chain_mono by blast

theorem non_finite_is_unbounded_subchain : "non_finite_subchain X Y \<Longrightarrow> unbounded_subchain X Y"
proof -
  assume asm : "non_finite_subchain X Y"
  have "\<forall>i. \<exists>j. Y i \<sqsubseteq> X j"
  proof (rule allI)
    fix i :: nat
    show  "\<exists>j. Y i \<sqsubseteq> X j"
    proof (induct i)
      show "\<exists>j. Y 0 \<sqsubseteq> X j" by (metis (mono_tags, hide_lams) asm le0 non_finite_subchain_def po_class.chain_mono rangeE rangeI subsetCE)

      fix i :: nat
      assume inductive_asm : "\<exists>j. Y i \<sqsubseteq> X j"
      have "(\<And>i. \<exists>j. X i \<noteq> X j \<and> X i \<sqsubseteq> X j)" by (metis asm finite_chain_def max_in_chain_def non_finite_subchain_def po_class.chain_mono)
      then obtain larger_j where larger_j_def :  "Y i \<noteq> X larger_j \<and> Y i \<sqsubseteq> X larger_j" using inductive_asm by metis
      then obtain larger_i where "Y larger_i = X larger_j" by (meson UNIV_I asm f_inv_into_f image_subset_iff non_finite_subchain_def)
      thus "\<exists>j. Y (Suc i) \<sqsubseteq> X j" by (metis Suc_leI asm below_antisym chain_mono_less larger_j_def linorder_neqE_nat non_finite_subchain_def po_class.chain_mono)
    qed
  qed
  thus ?thesis by (meson asm non_finite_subchain_def unbounded_subchain_def)
qed

lemma unbounded_subchain_same_lub : "unbounded_subchain X Y \<Longrightarrow> Lub X = Lub Y"
by (meson below_antisym below_lub lub_below lub_range_mono unbounded_subchain_def)

lemma non_finite_subchain_same_lub : "non_finite_subchain X Y \<Longrightarrow> Lub X = Lub Y"
by (simp add: non_finite_is_unbounded_subchain unbounded_subchain_same_lub)

definition monotone_on_sets :: "('a::cpo \<Rightarrow> 'b::cpo) \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
"monotone_on_sets f S1 S2 \<equiv> set_below S1 S2 \<and> (\<forall>x\<in>S1. \<forall>y\<in>S2. f x \<sqsubseteq> f y)"

lemma monotone_set_below : "monotone_on_sets f S1 S2 \<Longrightarrow> set_below (f ` S1) (f ` S2)"
by (simp add: monotone_on_sets_def set_below_def)

definition cont_at :: "('a::cpo \<Rightarrow> 'b::cpo) \<Rightarrow> 'a set \<Rightarrow> bool" where
"cont_at f S = (\<forall>Y. chain Y \<and> (\<forall>i. Y i \<in> S) \<longrightarrow> range (f \<circ> Y) <<| f (Lub Y))"

lemma cont_at_univ : "cont_at f (UNIV :: ('a::cpo) set) \<Longrightarrow> cont f"
by (metis UNIV_I cont_def cont_at_def fun.set_map range_composition)

theorem cont_union :
  fixes f :: "'a::cpo \<Rightarrow> 'b::cpo"
  assumes "cont_at f S1" and "cont_at f S2" and "monotone_on_sets f S1 S2"
  shows "cont_at f (S1 \<union> S2)" unfolding cont_at_def
proof (rule allI)
  fix Y :: "nat \<Rightarrow> 'a::cpo"
  have "chain Y \<and> (\<forall>i. Y i \<in> S1 \<union> S2) \<Longrightarrow> range (f \<circ> Y) <<| f (Lub Y)"
  proof (cases "range Y \<subseteq> S1")
    assume asm : "chain Y \<and> (\<forall>i. Y i \<in> S1 \<union> S2)"
    case True
    thus ?thesis by (meson True UNIV_I asm assms(1) cont_at_def image_subset_iff)
    next

    assume asm : "chain Y \<and> (\<forall>i. Y i \<in> S1 \<union> S2)"
    case False
    obtain YinS2 where YinS2_def:"YinS2 = restr Y S2" by simp
    hence chainYinS2 : "chain YinS2" using False Int_iff Un_iff asm image_subsetI rangeI restr_is_chain by fastforce

    have range_of_comp_is_intersection : "range (f \<circ> YinS2) = f ` (range Y \<inter> S2)" by (smt False Int_iff UnE YinS2_def asm fun.set_map imageE restr_range subsetI)

    have map_union_commutes : "f ` (range Y \<inter> S1) \<union> f ` (range Y \<inter> S2) = f ` range Y" using asm by blast

    have "set_below (range Y \<inter> S1) (range Y \<inter> S2)" by (meson Int_lower2 assms(3) monotone_on_sets_def set_below_def set_rev_mp)
    hence YinS1_below_YinS2 : "set_below (f ` (range Y \<inter> S1))  (f ` (range Y \<inter> S2))" by (meson assms(3) inf_sup_ord(2) monotone_on_sets_def monotone_set_below subset_iff)

    have intersection_not_empty : "\<exists>x. x \<in> range Y \<inter> S2" using False asm by blast

    hence YinS2_sub_S2 : "(\<forall>i. YinS2 i \<in> S2)" using YinS2_def asm restr_range by fastforce

    hence cont_at_subst : "range (f \<circ> YinS2) <<| f (Lub YinS2)" using assms(2) chainYinS2 cont_at_def by blast

    have ex_in_S2 : "\<exists>i. YinS2 i \<in> S2" by (metis False UnE YinS2_def asm image_subsetI restr_unchanged_on_S)

    show ?thesis
    proof (cases "finite_chain Y")
      case True
      hence "Lub Y \<in> S2" by (metis (no_types, lifting) UnE YinS2_def asm assms(3) below_antisym ex_in_S2 is_ub_thelub lub_eqI lub_finch2 monotone_on_sets_def restr_ends_in_Y set_below_def)
      hence "Lub YinS2 = Lub Y" by (smt Int_iff Int_lower1 True YinS2_def asm below_antisym chainYinS2 finch_imp_finite_range finite_range_imp_finch finite_subset is_lubD1 is_ubD lub_eqI lub_finch2 rangeI restr_range)
      thus ?thesis by (metis cont_at_subst YinS1_below_YinS2 fun.set_map lubS2_is_lub_union map_union_commutes rangeI range_of_comp_is_intersection)
      next

      case False
      have "\<not> finite_chain YinS2"
      proof (rule ccontr, simp)
        assume contr : "finite_chain YinS2"
        then obtain lubInS2 where lubInS2_def : "Y lubInS2 = Lub YinS2" by (metis YinS2_def asm lub_eqI lub_finch2 restr_ends_in_Y)
        hence "\<And>i. Y i \<sqsubseteq> Y lubInS2" by (metis UnE YinS2_def YinS2_sub_S2 asm assms(3) chainYinS2 contr is_ub_thelub lub_eqI lub_finch2 monotone_on_sets_def restr_unchanged_on_S set_below_def)
        hence "\<exists>i. \<forall>j. Y j \<sqsubseteq> Y i" by auto
        hence "finite_chain Y" by (metis asm below_antisym finite_chain_def max_in_chain_def po_class.chain_mono)
        thus False using False by auto
      qed
      hence "Lub YinS2 = Lub Y" by (metis YinS2_def asm chainYinS2 image_subsetI non_finite_subchain_def non_finite_subchain_same_lub rangeI restr_ends_in_Y)
      thus ?thesis by (metis cont_at_subst YinS1_below_YinS2 fun.set_map lubS2_is_lub_union map_union_commutes rangeI range_of_comp_is_intersection)
    qed
  qed
  thus "chain Y \<and> (\<forall>i. Y i \<in> S1 \<union> S2) \<longrightarrow> range (f \<circ> Y) <<| f (Lub Y)" by blast
qed

theorem if_else_cont :
  assumes "cont_at if_branch {x. pred x}"
  and "cont_at else_branch {x. \<not> pred x}"
  and "cont pred"
  and "\<And>x y. (\<not> pred x \<and> pred y) \<Longrightarrow> x \<sqsubseteq> y"
  and "\<And>x y. (\<not> pred x \<and> pred y) \<Longrightarrow>  else_branch x \<sqsubseteq> if_branch y"
  shows "cont (\<lambda>x. if pred x then if_branch x else else_branch x)" (is "cont ?f")
proof -
  have cont_true : "cont_at ?f {x. pred x}" unfolding cont_at_def by (smt assms(1) assms(3) bool_cont_implies_lub cont_at_def fun.map_cong0 imageE mem_Collect_eq)
  have cont_false : "cont_at ?f {x. \<not> pred x}" unfolding cont_at_def by (smt assms(2) assms(3) bool_cont_implies_not_lub cont_at_def fun.map_cong0 imageE mem_Collect_eq)
  have "set_below {x. \<not> pred x} {x. pred x}" by (simp add: assms(4) set_below_def)
  hence "monotone_on_sets ?f {x. \<not> pred x} {x. pred x} " by (simp add: assms(5) monotone_on_sets_def)
  hence cont_at_union : "cont_at ?f ({x. pred x} \<union> {x. \<not> pred x})"
    by (metis (no_types, lifting) cont_false cont_true cont_union sup_commute)
  have "{x. pred x} \<union> {x. \<not> pred x} = (UNIV :: 'a set)" by blast
  hence "cont_at ?f (UNIV :: 'a set)" using cont_at_union by simp
  thus ?thesis using cont_at_univ cont_def image_cong by blast
qed

theorem equalizing_pred_cont :
  assumes "cont_at if_branch {x. pred x}"
  and "cont_at else_branch {x. \<not> pred x}"
  and "\<And>x y. x \<sqsubseteq> y \<Longrightarrow> pred x = pred y"
  shows "cont (\<lambda>x. if pred x then if_branch x else else_branch x)" (is "cont ?f")
proof -
  have "\<And>Y. chain Y \<Longrightarrow> range (\<lambda>i. ?f (Y i)) <<| ?f (\<Squnion>i. Y i)"
  proof -
    fix Y :: "nat \<Rightarrow> 'a"
    assume chainY : "chain Y"
    show "range (\<lambda>i. ?f (Y i)) <<| ?f (\<Squnion>i. Y i)"
    proof (cases "\<forall>i. pred (Y i)")
      case True
      hence "range (if_branch \<circ> Y) <<| if_branch (Lub Y)" by (meson assms(1) chainY cont_at_def mem_Collect_eq)
      thus ?thesis by (metis (mono_tags, lifting) True assms(3) chainY comp_apply image_cong is_ub_thelub)
      next

      case False
      have all_false : "\<forall>i. \<not> pred (Y i)" using False assms(3) chainY is_ub_thelub by blast
      hence "range (else_branch \<circ> Y) <<| else_branch (Lub Y)" by (metis assms(2) chainY cont_at_def mem_Collect_eq)
      thus ?thesis by (metis (mono_tags, lifting) all_false assms(3) chainY comp_apply image_cong is_ub_thelub)
    qed
  qed
  thus ?thesis by (smt contI image_cong)
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_weird_nat_mul2_comm
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

fun mul2 :: "Nat => Nat => Nat" where
"mul2 (Z) y = Z"
| "mul2 (S z) (Z) = Z"
| "mul2 (S z) (S x2) = plus (S Z) (add3acc z x2 (mul2 z x2))"

theorem property0 :
  "((mul2 x y) = (mul2 y x))"
  oops

end


theory my_examples
imports Main
begin

thm impI
thm conjI

lemma trivial: "A \<longrightarrow> A"
apply (rule_tac impI)
apply assumption
done (* of lemma proof *)

thm trivial

(* introduction exmaple *)
lemma lec_A_B_implies_A_and_A: "A \<longrightarrow> (B \<longrightarrow> (A \<and> B))"
  apply (rule_tac impI)
  apply (rule_tac impI)
  apply (rule_tac conjI)
   apply assumption
   apply assumption
  done

lemma conj_rule: "\<lbrakk> P; Q \<rbrakk> \<Longrightarrow> P \<and> (Q \<and> P)"
  apply (rule conjI)
   apply assumption
  apply (rule conjI)
   apply assumption
  apply assumption
  done

lemma disj_swap: "P \<or> Q \<Longrightarrow> Q \<or> P"
  apply (erule disjE)
   apply (rule disjI2)
   apply assumption
  apply (rule disjI1)
  apply assumption
  done

lemma hw2_p2: "A \<or> A \<longrightarrow> B \<or> A"
  apply (rule impI)
  apply (rule disjI2)
  apply (erule disjE)
   apply assumption
  apply assumption
  done

end (* of theory file *)


theory BBI
  imports Quantale_Sup Fixpoint
begin

notation
  times (infixl "*" 70) and
  sup (infixl "\<squnion>" 65) and
  inf (infixl "\<sqinter>" 70) and
  Sup ("\<Squnion>_" [900] 900) and
  Inf ("\<Sqinter>_" [900] 900) and
  top ("\<top>") and
  bot ("\<bottom>") and
  one_class.one ("1")

class bbi = comm_quantale_Sup_unital + complete_boolean_algebra
begin

lemma qiso: "\<lbrakk>x \<le> z; y \<le> w\<rbrakk> \<Longrightarrow> x * y \<le> z * w"
  by (metis Sup.qisol Sup.qisor dual_order.trans)

lemma qmeet_subdistr: "(x \<sqinter> y) * z \<le> (x * z) \<sqinter> (y * z)"
  by (metis Sup.qisor inf_le1 inf_le2 le_inf_iff)

lemma qmeet_subdistl: "x * (y \<sqinter> z) \<le> (x * y) \<sqinter> (x * z)"
  by (metis mult_commute qmeet_subdistr)

lemma "(x * z) \<sqinter> (y * z) \<le> (x \<sqinter> y) * z"
  (* nitpick *) oops

lemma "x \<sqinter> (y * z) \<le> (x \<sqinter> y) * (x \<sqinter> z)"
  (* nitpick *) oops

lemma "(x * y) \<sqinter> z \<le> (x \<sqinter> z) * (y \<sqinter> z)"
  (* nitpick *) oops

lemma "(x \<sqinter> y) * (x \<sqinter> z) \<le> x \<sqinter> (y * z)"
  (* nitpick *) oops

lemma sep_conj_topl: "x \<le> \<top> * x"
  by (metis mult_1_left Sup.qisor top_greatest)

lemma sep_conj_topr: "x \<le> x * \<top>"
  by (metis mult_1_right Sup.qisol top_greatest)

lemma sep_conj_top [simp]: "\<top> * \<top> = \<top>"
  by (metis sep_conj_topl top_le)

definition sep_impl :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "-*" 55) where
  "(op -*) x \<equiv> THE f. endo_galois_connection ((op * x)) f"

lemma equality_by_ineq: "\<forall>x. x \<le> f \<longleftrightarrow> x \<le> g \<Longrightarrow> f = g"
  by (metis Sup.ineq order_refl)

lemma ex_sep_conj_conn: "\<exists>!x. endo_galois_connection (op * y) x"
  apply auto
  apply (fold endo_lower_adjoint_def)
  apply (subst endo_lower_is_jp)
  apply (simp add: endo_join_preserving_def)
  apply (metis Sup.SUP_def local.Sup.Join_distl)
  apply (unfold endo_galois_connection_def)
  apply (subgoal_tac "\<forall>b a. (a \<le> x b) = (a \<le> ya b)")
  prefer 2
  apply simp
  apply (rule ext)
  apply (erule_tac x=xa in allE) back back
  apply (rule equality_by_ineq)
  by simp

lemma sep_impl: "x * y \<le> z \<longleftrightarrow> x \<le> y -* z"
  apply (simp add: sep_impl_def)
  apply (rule the1I2 [of "endo_galois_connection (op * y)"])
  apply (metis ex_sep_conj_conn)
  by (metis endo_galois_connection_def mult_commute)

lemma sep_implI1: "x * y \<le> z \<Longrightarrow> x \<le> y -* z"
  by (simp add: sep_impl)

lemma sep_implI2: "x * y \<le> z \<Longrightarrow> y \<le> x -* z"
  by (metis mult_commute sep_implI1)

lemma sep_implE1: "x \<le> y -* z \<Longrightarrow> x * y \<le> z"
  by (simp add: sep_impl)

lemma sep_implE2: "x \<le> y -* z \<Longrightarrow> y * x \<le> z"
  by (simp add: sep_impl mult_commute)

lemma sep_impl_isoE: "\<lbrakk>x \<le> y -* z; w \<le> y\<rbrakk> \<Longrightarrow> x * w \<le> z"
  by (metis dual_order.trans sep_implE1 sep_implI2)

lemma sep_impl_annil1: "y * ( y -* x) \<le> x"
  by (metis eq_refl sep_implE2)

lemma sep_impl_annil2: "(y -* x) * y \<le> x"
  by (metis mult_commute sep_impl_annil1)

lemma sep_impl_annir1: "y \<le> (x -* (x * y))"
  by (metis order_refl sep_implI2)

lemma sep_impl_annir2: "y \<le> (x -* (y * x))"
  by (metis mult_commute sep_impl_annir1)

lemma sep_impl_annir2_iso: "x * z \<le> x * (y -* (y * z))"
  by (metis order_refl qiso sep_impl_annir1)

lemma reynolds28: "\<lbrakk>x \<le> y -* z; x' \<le> z -* w\<rbrakk> \<Longrightarrow> x' * x \<le> y -* w"
  by (metis mult_assoc sep_implE1 sep_implI1 sep_impl_isoE)

lemma sep_impl_cut: "(z -* y) * (y -* x) \<le> z -* x"
  by (metis order_refl reynolds28 mult_commute)

lemma sep_impl_iso: "\<lbrakk>x' \<le> x; y \<le> y'\<rbrakk> \<Longrightarrow> x -* y \<le> x' -* y'"
  by (metis (full_types) order_trans sep_implE1 sep_implI2 sep_impl_annil1)

lemma sep_impl_iso_var: "x \<le> y \<Longrightarrow> z -* x \<le> z -* y"
  by (metis order_refl sep_impl_iso)

lemma sep_impl_antitone: "x \<le> y \<Longrightarrow> y -* z \<le> x -* z"
  by (metis eq_refl sep_impl_iso)

lemma sep_impl_to_meet: "y * (y -* x) \<le> (y * \<top>) \<sqinter> x"
  by (metis le_inf_iff sep_impl_annil1 sep_impl_annir2 sep_impl_isoE top_greatest)

lemma sep_impl_top [simp]: "x -* \<top> = \<top>"
  by (metis sep_implI2 top_greatest top_le)

lemma sep_impl_top_x: "\<top> -* x \<le> x"
  by (metis order_trans sep_conj_topl sep_impl_annil1)

lemma sep_impl_bot [simp]: "\<bottom> -* x = \<top>"
  by (metis Sup.qannir bot_least sep_implI2 top_le)

lemma sep_impl_top_bot [simp]: "\<top> -* \<bottom> = \<bottom>"
  by (metis le_bot sep_impl_top_x)

lemma sep_impl_join_subdistr: "(x \<squnion> y) -* z \<le> (x -* z) \<squnion> (y -* z)"
  by (metis sep_impl_antitone sup.coboundedI1 sup_ge1)

lemma sep_impl_join_subdistl: "(x -* y) \<squnion> (x -* z) \<le> x -* (y \<squnion> z)"
  by (metis sep_impl_iso_var sup_ge1 sup_ge2 sup_least)

lemma sep_impl_meet_subdistr: "(x -* z) \<sqinter> (y -* z) \<le> (x \<sqinter> y) -* z"
  by (metis inf_le1 le_infI1 sep_impl_antitone)

lemma sep_impl_meet_subdistl: "x -* (y \<sqinter> z) \<le> (x -* y) \<sqinter> (x -* z)"
  by (metis inf_le1 inf_le2 le_infI sep_impl_iso_var)

(* Algebraic characterization of pure assertion by Dang *)
definition pure :: "'a \<Rightarrow> bool" where
  "pure x \<equiv> \<forall>y z. x * \<top> \<le> x \<and> (y * z) \<sqinter> x \<le> (y \<sqinter> x) * (z \<sqinter> x)"

lemma pure_top [simp]: "pure \<top>"
  by (metis inf_le1 inf_top_right pure_def top_greatest)

lemma pure_bot [simp]: "pure \<bottom>"
  by (metis Sup.qannir eq_refl inf_bot_left inf_commute pure_def)

lemma pure_upward_closure [simp]: "pure x \<Longrightarrow> x * \<top> = x"
  apply (rule antisym, metis pure_def)
  by (metis sep_conj_topr)

lemma pure_upward_closure_var: "pure x \<Longrightarrow> x * y \<le> x"
  by (metis (full_types) eq_refl pure_upward_closure qiso top_greatest)

lemma pure_meet_distl: "pure x \<Longrightarrow> (y * z) \<sqinter> x = (y \<sqinter> x) * (z \<sqinter> x)"
  apply (rule antisym, metis pure_def)
  by (metis inf_le1 inf_le2 le_inf_iff pure_upward_closure qiso top_greatest)

lemma pure_meet_distr: "pure x \<Longrightarrow> x \<sqinter> (y * z) = (x \<sqinter> y) * (x \<sqinter> z)"
  by (metis inf_commute pure_meet_distl)

lemma pure_downward_closure: "pure x \<Longrightarrow> x = (x \<sqinter> 1) * \<top>"
  by (metis inf.orderE inf_commute inf_top_left pure_meet_distl pure_upward_closure mult_commute qmeet_subdistl mult_1_right)

lemma pure_downward_closure_var: "pure x \<Longrightarrow> x * y = x \<sqinter> (y * \<top>)"
  by (metis inf_absorb2 inf_idem inf_top_right pure_meet_distr pure_upward_closure_var mult_commute)

lemma reynolds_pure1: "pure x \<Longrightarrow> x \<sqinter> y \<le> x * y"
proof -
  assume pure: "pure x"
  hence "x \<sqinter> y \<le> x \<sqinter> (y * \<top>)"
    by (metis (full_types) inf_mono order_refl mult_commute qiso mult_1_left top_greatest)
  thus ?thesis
  by (metis pure pure_downward_closure_var)
qed

lemma reynolds_pure2: "\<lbrakk>pure x; pure y\<rbrakk> \<Longrightarrow> x * y \<le> x \<sqinter> y"
  by (metis eq_refl pure_downward_closure_var pure_upward_closure)

lemma reynolds_pure2_corollary: "\<lbrakk>pure x; pure y\<rbrakk> \<Longrightarrow> x * y = x \<sqinter> y"
  by (metis dual_order.antisym reynolds_pure1 reynolds_pure2)

lemma pure_idem [simp]: "pure x \<Longrightarrow> x * x = x"
  by (metis inf_idem reynolds_pure2_corollary)

lemma reynolds_pure3: "pure y \<Longrightarrow> (x \<sqinter> y) * z = (x * z) \<sqinter> y"
  apply (rule antisym)
  apply (metis le_infI1 le_infI2 le_inf_iff pure_upward_closure_var sep_impl_annir2 sep_impl)
  by (metis dual_order.trans inf_le1 pure_meet_distl sep_implE2 sep_impl_annir1)

lemma pure_join_closure: "\<lbrakk>pure x; pure x'\<rbrakk> \<Longrightarrow> pure (x \<squnion> x')"
proof (subst pure_def, auto)
  fix y z assume px: "pure x" and py: "pure x'"
  thus "(x \<squnion> x') * \<top> \<le> x \<squnion> x'"
    by (metis Sup.qdistl eq_refl mult_commute pure_upward_closure)
  have "(x \<squnion> x') \<sqinter> (y * z) = (x \<sqinter> (y * z)) \<squnion> (x' \<sqinter> (y * z))"
    by (metis inf_sup_distrib2)
  also have "... \<le> ((x \<sqinter> y) * (x \<sqinter> z)) \<squnion> ((x' \<sqinter> y) * (x' \<sqinter> z))"
    by (metis pure_meet_distr px py sup.bounded_iff sup_ge1 sup_ge2)
  also have "... \<le> (((x \<squnion> x') \<sqinter> y) * ((x \<squnion> x') \<sqinter> z)) \<squnion> (((x \<squnion> x') \<sqinter> y) * ((x \<squnion> x') \<sqinter> z))"
    by (metis inf_mono qiso sup_ge1 sup_ge2 sup_idem sup_least)
  finally show "y * z \<sqinter> (x \<squnion> x') \<le> (y \<sqinter> (x \<squnion> x')) * (z \<sqinter> (x \<squnion> x'))"
    by (metis inf_commute sup_idem)
qed

lemma pure_meet_closure: "\<lbrakk>pure x; pure x'\<rbrakk> \<Longrightarrow> pure (x \<sqinter> x')"
proof (subst pure_def, auto)
  fix y z assume px: "pure x" and py: "pure x'"
  thus "(x \<sqinter> x') * \<top> \<le> x"
    by (metis inf_le1 pure_upward_closure reynolds_pure3)
  show "(x \<sqinter> x') * \<top> \<le> x'"
    by (metis inf_le2 py reynolds_pure3)
  show "y * z \<sqinter> (x \<sqinter> x') \<le> (y \<sqinter> (x \<sqinter> x')) * (z \<sqinter> (x \<sqinter> x'))"
    by (metis eq_iff inf_commute inf_left_commute pure_meet_distr px py)
qed

lemma pure_sep_conj_closure: "\<lbrakk>pure x; pure x'\<rbrakk> \<Longrightarrow> pure (x * x')"
  by (metis pure_meet_closure reynolds_pure2_corollary)

lemma pure_negation_closure: "pure x \<Longrightarrow> pure (-x)"
proof (subst pure_def, auto)
  fix y z assume px: "pure x"
  hence "(-x * \<top>) \<sqinter> x = \<bottom>"
    by (metis compl_inf_bot pure_bot pure_upward_closure reynolds_pure3)
  thus "- x * \<top> \<le> - x"
    by (metis compl_sup double_compl inf.orderI inf_sup_distrib1 inf_top_right sup_bot_left sup_compl_top)
  have "(y * z) \<sqinter> -x = ((y \<sqinter> x) * (z \<sqinter> x) \<squnion> (y \<sqinter> -x) * (z \<sqinter> x) \<squnion> (y \<sqinter> x) * (z \<sqinter> -x) \<squnion> (y \<sqinter> -x) * (z \<sqinter> -x)) \<sqinter> -x"
    by (metis inf_top_right sup_compl_top inf_sup_distrib1 Sup.qdistr Sup.qdistl sup_assoc sup_commute sup_left_commute)
  also have "... = (((y * z) \<sqinter> x) \<squnion> (y \<sqinter> -x) * (z \<sqinter> x) \<squnion> (y \<sqinter> x) * (z \<sqinter> -x) \<squnion> (y \<sqinter> -x) * (z \<sqinter> -x)) \<sqinter> -x"
    by (metis px reynolds_pure3 inf_absorb1 inf_le2 mult_commute)
  also have "... = (((y * z) \<sqinter> x) \<squnion> (((y \<sqinter> -x) * z) \<sqinter> x) \<squnion> (y \<sqinter> x) * (z \<sqinter> -x) \<squnion> (y \<sqinter> -x) * (z \<sqinter> -x)) \<sqinter> -x"
    by (metis px reynolds_pure3 mult_commute)
  also have "... = (((y * z) \<sqinter> x) \<squnion> (((y \<sqinter> -x) * z) \<sqinter> x) \<squnion> (((z \<sqinter> -x) * y) \<sqinter> x) \<squnion> (y \<sqinter> -x) * (z \<sqinter> -x)) \<sqinter> -x"
    by (metis px reynolds_pure3 mult_commute)
  finally show "y * z \<sqinter> - x \<le> (y \<sqinter> - x) * (z \<sqinter> - x)"
    by (metis inf_sup_distrib2 inf_assoc inf_compl_bot inf_bot_right sup_bot_left inf_le1)
qed

(* I couldn't prove nor disprove *)
lemma pure_sep_impl_closure: "\<lbrakk>pure p; pure q\<rbrakk> \<Longrightarrow> pure (p -* q)"
  apply (subst pure_def)
  apply auto
  apply (metis eq_refl pure_upward_closure reynolds28 mult_commute sep_impl_annir2)
  oops

lemma pure_annilation [simp]: "pure x \<Longrightarrow> x * (-x) = \<bottom>"
  by (metis inf_compl_bot pure_negation_closure reynolds_pure2_corollary)

lemma indirect_ineq: "(\<And>z. z \<le> x \<longrightarrow> z \<le> y) \<Longrightarrow> x \<le> y"
  by (metis (hide_lams, mono_tags) order_refl)

lemma "x \<squnion> y = y \<Longrightarrow> x \<le> y"
  by (metis le_iff_sup)

lemma join_meet_galois: "x \<sqinter> z \<le> y \<longleftrightarrow> z \<le> -x \<squnion> y"
proof
  assume "x \<sqinter> z \<le> y"
  hence "-x \<squnion> (x \<sqinter> z) \<le> -x \<squnion> y"
    by (metis le_iff_sup sup_idem sup_mono)
  thus "z \<le> -x \<squnion> y"
    by (metis compl_sup_top inf_top_left sup.boundedE sup_commute sup_inf_distrib2)
next
  assume "z \<le> -x \<squnion> y"
  thus "x \<sqinter> z \<le> y"
    by (metis inf_mono order_refl inf_sup_distrib1 inf_compl_bot sup_bot_left le_inf_iff)
qed

(* Reynolds uses implication x \<rightarrow> y \<equiv> - x \<squnion> y *)

lemma reynolds_pure4: "pure x \<Longrightarrow> x -* y \<le> -x \<squnion> y"
  apply (rule indirect_ineq)
  apply (rule impI)
  apply (drule sep_implE1)
  apply (subgoal_tac "x \<sqinter> z \<le> y")
  apply (metis join_meet_galois)
  by (metis order_trans reynolds_pure1 mult_commute)

lemma reynolds_pure5: "\<lbrakk>pure x; pure y\<rbrakk> \<Longrightarrow> -x \<squnion> y \<le> x -* y"
  apply (rule indirect_ineq)
  apply (rule impI)
  apply (rule sep_implI1)
  apply (subst (asm) join_meet_galois[symmetric])
  by (metis pure_downward_closure_var pure_meet_distr qiso top_greatest pure_upward_closure mult_commute)

definition intuitionistic :: "'a \<Rightarrow> bool" where
  "intuitionistic x \<equiv> x * \<top> \<le> x"

lemma pure_is_intuitionistic: "pure x \<Longrightarrow> intuitionistic x"
  by (metis intuitionistic_def pure_def)

lemma intuitionistic_top [simp]: "intuitionistic \<top>"
  by (metis pure_is_intuitionistic pure_top)

lemma intuitionistic_bot [simp]: "intuitionistic \<bottom>"
  by (metis pure_bot pure_is_intuitionistic)

lemma intuitionistic_upward_closure [simp]: "intuitionistic x \<Longrightarrow> x * \<top> = x"
  by (metis dual_order.antisym intuitionistic_def sep_conj_topr)

lemma intuitionistic_upward_closure_var: "intuitionistic x \<Longrightarrow> x * y \<le> x"
  by (metis (full_types) eq_refl intuitionistic_upward_closure qiso top_greatest)

lemma intuitionistic_downward_closure: "intuitionistic x \<Longrightarrow> (x \<sqinter> I) * \<top> \<le> x"
  by (metis dual_order.trans intuitionistic_def le_infE qmeet_subdistr)

lemma intuitionistic_downward_closure_var: "intuitionistic x \<Longrightarrow> x * y \<le> x \<sqinter> (y * \<top>)"
  by (metis Sup.qisor intuitionistic_upward_closure_var le_infI mult_commute top_greatest)

lemma reynolds_intuitionistic2: "\<lbrakk>intuitionistic x; intuitionistic y\<rbrakk> \<Longrightarrow> x * y \<le> x \<sqinter> y"
  by (metis intuitionistic_upward_closure_var le_infI mult_commute)

lemma reynolds_intuitionistic3: "intuitionistic y \<Longrightarrow> (x \<sqinter> y) * z \<le> (x * z) \<sqinter> y"
  by (metis inf_idem inf_le2 intuitionistic_upward_closure le_inf_iff qiso top_greatest)

lemma intuitionistic_sep_conj_closure: "\<lbrakk>intuitionistic x; intuitionistic y\<rbrakk> \<Longrightarrow> intuitionistic (x * y)"
  by (metis eq_refl intuitionistic_def intuitionistic_upward_closure mult_assoc)

lemma intuitionistic_sep_impl_closure: "\<lbrakk>intuitionistic x; intuitionistic y\<rbrakk> \<Longrightarrow> intuitionistic (x -* y)"
  by (metis intuitionistic_def sep_implI2 sep_impl_cut top_le)

lemma intuitionistic_join_closure: "\<lbrakk>intuitionistic x; intuitionistic y\<rbrakk> \<Longrightarrow> intuitionistic (x \<squnion> y)"
  by (metis eq_refl intuitionistic_def intuitionistic_upward_closure Sup.qdistr)

lemma intuitionistic_meet_closure: "\<lbrakk>intuitionistic x; intuitionistic y\<rbrakk> \<Longrightarrow> intuitionistic (x \<sqinter> y)"
  by (metis intuitionistic_def intuitionistic_upward_closure qmeet_subdistr)

lemma intuitionistic_sep_conj_top: "intuitionistic (x * \<top>)"
  by (metis eq_refl intuitionistic_def mult_assoc sep_conj_top)

lemma intuitionistic_sep_impl_top: "intuitionistic (\<top> -* x)"
  by (metis intuitionistic_def mult_commute sep_impl_cut sep_impl_top)

lemma strongest_intuitionistic: "\<not> (\<exists>y. intuitionistic y \<and> y \<le> x * \<top> \<and> y \<noteq> x * \<top> \<and> x \<le> y)"
  by (metis intuitionistic_upward_closure Sup.qdistr sup.orderE sup_absorb2)

lemma weakest_intuitionistic: "\<not> (\<exists>y. intuitionistic y \<and> \<top> -* x \<le> y \<and> y \<noteq> \<top> -* x \<and> y \<le> x)"
  by (metis dual_order.antisym intuitionistic_upward_closure sep_impl)

lemma sep_Sup: "\<Squnion> {x * p | x. x \<in> X} = \<Squnion> X * p"
  apply (rule Sup_eqI)
  apply (smt Sup_upper eq_refl mem_Collect_eq qiso)
  apply (rule sep_implE1)
  by (metis (lifting, full_types) Sup_least mem_Collect_eq sep_implI1)

lemma sep_Sup2: "\<Squnion> {p * x | x. x \<in> X} = p * \<Squnion> X"
  apply (rule Sup_eqI)
  apply (smt Sup_upper eq_refl mem_Collect_eq qiso)
  apply (rule sep_implE2)
oops

definition precise :: "'a \<Rightarrow> bool" where
  "precise p \<equiv> \<forall>X. \<Sqinter> {x * p | x. x \<in> X} = \<Sqinter> X * p"

lemma precise_charac: "precise p \<Longrightarrow> \<Sqinter> {x * p | x. x \<in> X} = \<Sqinter> X * p"
  by (simp add: precise_def)

lemma "precise p \<Longrightarrow> p * \<top> = \<top>"
  apply (simp add: precise_def)
  apply (erule allE [of _ "{}"], auto)
  by (metis mult_commute)

lemma precise_distl: "precise p \<Longrightarrow> (x \<sqinter> y) * p = (x * p) \<sqinter> (y * p)"
  apply (simp add: precise_def)
  apply (erule_tac x="{x, y}" in allE)
  apply auto
  apply (subgoal_tac "\<Sqinter> {xa * p |xa. xa = x \<or> xa = y} = (x * p) \<sqinter> (y * p)")
  apply simp
  apply (rule Inf_eqI)
  by auto

lemma precise_distr: "precise p \<Longrightarrow> p * (x \<sqinter> y) = (p * x) \<sqinter> (p * y)"
  by (metis precise_distl mult_commute)

lemma precise_sep_conj_closure: "\<lbrakk>precise p; precise q\<rbrakk> \<Longrightarrow> precise (p * q)"
proof (subst precise_def, auto)
  fix X assume pp: "precise p" and pq: "precise q"
  have "\<Sqinter> {x * (p * q) |x. x \<in> X} = \<Sqinter> {x * q |x. x \<in> {y * p | y. y \<in> X}}"
    apply (subst mem_Collect_eq)
    by (metis mult_assoc)
  also have "... = \<Sqinter> {y * p | y. y \<in> X} * q"
    by (metis pq precise_charac [of q "{y * p | y. y \<in> X}"])
  finally show "\<Sqinter>{x * (p * q) |x. x \<in> X} = \<Sqinter>X * (p * q)"
    by (metis (lifting, no_types) pp precise_charac mult_assoc)
qed

lemma precise_meet_closure: "\<lbrakk>precise p; precise q\<rbrakk> \<Longrightarrow> precise (p \<sqinter> q)"
  (* nitpick *) oops

lemma precise_join_closure: "\<lbrakk>precise p; precise q\<rbrakk> \<Longrightarrow> precise (p \<squnion> q)"
  (* nitpick *) oops

lemma precise_subset_closure: "\<lbrakk>p \<le> q; precise q\<rbrakk> \<Longrightarrow> precise p"
  (* nitpick *) oops

lemma "\<forall>x \<in> X. intuitionistic x \<Longrightarrow> intuitionistic (\<Squnion> X)"
proof (unfold intuitionistic_def)
  assume assm: "\<forall>x\<in>X. x * \<top> \<le> x"
  have "\<Squnion>X * \<top> = \<Squnion>{x * \<top> | x. x \<in> X}"
    by (metis sep_Sup)
  also have "... \<le> \<Squnion>X"
    apply (rule Sup_least, rule Sup_upper, auto)
    by (metis assm dual_order.antisym sep_conj_topr)
  finally show "\<Squnion>X * \<top> \<le> \<Squnion>X" .
qed

lemma "\<forall>x \<in> X. intuitionistic x \<Longrightarrow> intuitionistic (\<Sqinter> X)"
  by (metis intuitionistic_def Inf_greatest Inf_lower dual_order.antisym qiso sep_conj_top sep_conj_topr)

end

end


(*<*)
theory AdvancedInd imports Main begin
(*>*)

text{*\noindent
Now that we have learned about rules and logic, we take another look at the
finer points of induction.  We consider two questions: what to do if the
proposition to be proved is not directly amenable to induction
(\S\ref{sec:ind-var-in-prems}), and how to utilize (\S\ref{sec:complete-ind})
and even derive (\S\ref{sec:derive-ind}) new induction schemas. We conclude
with an extended example of induction (\S\ref{sec:CTL-revisited}).
*}

subsection{*Massaging the Proposition*}

text{*\label{sec:ind-var-in-prems}
Often we have assumed that the theorem to be proved is already in a form
that is amenable to induction, but sometimes it isn't.
Here is an example.
Since @{term"hd"} and @{term"last"} return the first and last element of a
non-empty list, this lemma looks easy to prove:
*}

lemma "xs \<noteq> [] \<Longrightarrow> hd(rev xs) = last xs"
apply(induct_tac xs)

txt{*\noindent
But induction produces the warning
\begin{quote}\tt
Induction variable occurs also among premises!
\end{quote}
and leads to the base case
@{subgoals[display,indent=0,goals_limit=1]}
Simplification reduces the base case to this:
\begin{isabelle}
\ 1.\ xs\ {\isasymnoteq}\ []\ {\isasymLongrightarrow}\ hd\ []\ =\ last\ []
\end{isabelle}
We cannot prove this equality because we do not know what @{term hd} and
@{term last} return when applied to @{term"[]"}.

We should not have ignored the warning. Because the induction
formula is only the conclusion, induction does not affect the occurrence of @{term xs} in the premises.
Thus the case that should have been trivial
becomes unprovable. Fortunately, the solution is easy:\footnote{A similar
heuristic applies to rule inductions; see \S\ref{sec:rtc}.}
\begin{quote}
\emph{Pull all occurrences of the induction variable into the conclusion
using @{text"\<longrightarrow>"}.}
\end{quote}
Thus we should state the lemma as an ordinary
implication~(@{text"\<longrightarrow>"}), letting
\attrdx{rule_format} (\S\ref{sec:forward}) convert the
result to the usual @{text"\<Longrightarrow>"} form:
*}
(*<*)oops(*>*)
lemma hd_rev [rule_format]: "xs \<noteq> [] \<longrightarrow> hd(rev xs) = last xs"
(*<*)
apply(induct_tac xs)
(*>*)

txt{*\noindent
This time, induction leaves us with a trivial base case:
@{subgoals[display,indent=0,goals_limit=1]}
And @{text"auto"} completes the proof.

If there are multiple premises $A@1$, \dots, $A@n$ containing the
induction variable, you should turn the conclusion $C$ into
\[ A@1 \longrightarrow \cdots A@n \longrightarrow C. \]
Additionally, you may also have to universally quantify some other variables,
which can yield a fairly complex conclusion.  However, @{text rule_format}
can remove any number of occurrences of @{text"\<forall>"} and
@{text"\<longrightarrow>"}.

\index{induction!on a term}%
A second reason why your proposition may not be amenable to induction is that
you want to induct on a complex term, rather than a variable. In
general, induction on a term~$t$ requires rephrasing the conclusion~$C$
as
\begin{equation}\label{eqn:ind-over-term}
\forall y@1 \dots y@n.~ x = t \longrightarrow C.
\end{equation}
where $y@1 \dots y@n$ are the free variables in $t$ and $x$ is a new variable.
Now you can perform induction on~$x$. An example appears in
\S\ref{sec:complete-ind} below.

The very same problem may occur in connection with rule induction. Remember
that it requires a premise of the form $(x@1,\dots,x@k) \in R$, where $R$ is
some inductively defined set and the $x@i$ are variables.  If instead we have
a premise $t \in R$, where $t$ is not just an $n$-tuple of variables, we
replace it with $(x@1,\dots,x@k) \in R$, and rephrase the conclusion $C$ as
\[ \forall y@1 \dots y@n.~ (x@1,\dots,x@k) = t \longrightarrow C. \]
For an example see \S\ref{sec:CTL-revisited} below.

Of course, all premises that share free variables with $t$ need to be pulled into
the conclusion as well, under the @{text"\<forall>"}, again using @{text"\<longrightarrow>"} as shown above.

Readers who are puzzled by the form of statement
(\ref{eqn:ind-over-term}) above should remember that the
transformation is only performed to permit induction. Once induction
has been applied, the statement can be transformed back into something quite
intuitive. For example, applying wellfounded induction on $x$ (w.r.t.\
$\prec$) to (\ref{eqn:ind-over-term}) and transforming the result a
little leads to the goal
\[ \bigwedge\overline{y}.\
   \forall \overline{z}.\ t\,\overline{z} \prec t\,\overline{y}\ \longrightarrow\ C\,\overline{z}
    \ \Longrightarrow\ C\,\overline{y} \]
where $\overline{y}$ stands for $y@1 \dots y@n$ and the dependence of $t$ and
$C$ on the free variables of $t$ has been made explicit.
Unfortunately, this induction schema cannot be expressed as a
single theorem because it depends on the number of free variables in $t$ ---
the notation $\overline{y}$ is merely an informal device.
*}
(*<*)by auto(*>*)

subsection{*Beyond Structural and Recursion Induction*}

text{*\label{sec:complete-ind}
So far, inductive proofs were by structural induction for
primitive recursive functions and recursion induction for total recursive
functions. But sometimes structural induction is awkward and there is no
recursive function that could furnish a more appropriate
induction schema. In such cases a general-purpose induction schema can
be helpful. We show how to apply such induction schemas by an example.

Structural induction on @{typ"nat"} is
usually known as mathematical induction. There is also \textbf{complete}
\index{induction!complete}%
induction, where you prove $P(n)$ under the assumption that $P(m)$
holds for all $m<n$. In Isabelle, this is the theorem \tdx{nat_less_induct}:
@{thm[display]"nat_less_induct"[no_vars]}
As an application, we prove a property of the following
function:
*}

axiomatization f :: "nat \<Rightarrow> nat"
  where f_ax: "f(f(n)) < f(Suc(n))" for n :: nat

text{*
\begin{warn}
We discourage the use of axioms because of the danger of
inconsistencies.  Axiom @{text f_ax} does
not introduce an inconsistency because, for example, the identity function
satisfies it.  Axioms can be useful in exploratory developments, say when
you assume some well-known theorems so that you can quickly demonstrate some
point about methodology.  If your example turns into a substantial proof
development, you should replace axioms by theorems.
\end{warn}\noindent
The axiom for @{term"f"} implies @{prop"n <= f n"}, which can
be proved by induction on \mbox{@{term"f n"}}. Following the recipe outlined
above, we have to phrase the proposition as follows to allow induction:
*}

lemma f_incr_lem: "\<forall>i. k = f i \<longrightarrow> i \<le> f i"

txt{*\noindent
To perform induction on @{term k} using @{thm[source]nat_less_induct}, we use
the same general induction method as for recursion induction (see
\S\ref{sec:fun-induction}):
*}

apply(induct_tac k rule: nat_less_induct)

txt{*\noindent
We get the following proof state:
@{subgoals[display,indent=0,margin=65]}
After stripping the @{text"\<forall>i"}, the proof continues with a case
distinction on @{term"i"}. The case @{prop"i = (0::nat)"} is trivial and we focus on
the other case:
*}

apply(rule allI)
apply(case_tac i)
 apply(simp)
txt{*
@{subgoals[display,indent=0]}
*}
by(blast intro!: f_ax Suc_leI intro: le_less_trans)

text{*\noindent
If you find the last step puzzling, here are the two lemmas it employs:
\begin{isabelle}
@{thm Suc_leI[no_vars]}
\rulename{Suc_leI}\isanewline
@{thm le_less_trans[no_vars]}
\rulename{le_less_trans}
\end{isabelle}
%
The proof goes like this (writing @{term"j"} instead of @{typ"nat"}).
Since @{prop"i = Suc j"} it suffices to show
\hbox{@{prop"j < f(Suc j)"}},
by @{thm[source]Suc_leI}\@.  This is
proved as follows. From @{thm[source]f_ax} we have @{prop"f (f j) < f (Suc j)"}
(1) which implies @{prop"f j <= f (f j)"} by the induction hypothesis.
Using (1) once more we obtain @{prop"f j < f(Suc j)"} (2) by the transitivity
rule @{thm[source]le_less_trans}.
Using the induction hypothesis once more we obtain @{prop"j <= f j"}
which, together with (2) yields @{prop"j < f (Suc j)"} (again by
@{thm[source]le_less_trans}).

This last step shows both the power and the danger of automatic proofs.  They
will usually not tell you how the proof goes, because it can be hard to
translate the internal proof into a human-readable format.  Automatic
proofs are easy to write but hard to read and understand.

The desired result, @{prop"i <= f i"}, follows from @{thm[source]f_incr_lem}:
*}

lemmas f_incr = f_incr_lem[rule_format, OF refl]

text{*\noindent
The final @{thm[source]refl} gets rid of the premise @{text"?k = f ?i"}.
We could have included this derivation in the original statement of the lemma:
*}

lemma f_incr[rule_format, OF refl]: "\<forall>i. k = f i \<longrightarrow> i \<le> f i"
(*<*)oops(*>*)

text{*
\begin{exercise}
From the axiom and lemma for @{term"f"}, show that @{term"f"} is the
identity function.
\end{exercise}

Method \methdx{induct_tac} can be applied with any rule $r$
whose conclusion is of the form ${?}P~?x@1 \dots ?x@n$, in which case the
format is
\begin{quote}
\isacommand{apply}@{text"(induct_tac"} $y@1 \dots y@n$ @{text"rule:"} $r$@{text")"}
\end{quote}
where $y@1, \dots, y@n$ are variables in the conclusion of the first subgoal.

A further useful induction rule is @{thm[source]length_induct},
induction on the length of a list\indexbold{*length_induct}
@{thm[display]length_induct[no_vars]}
which is a special case of @{thm[source]measure_induct}
@{thm[display]measure_induct[no_vars]}
where @{term f} may be any function into type @{typ nat}.
*}

subsection{*Derivation of New Induction Schemas*}

text{*\label{sec:derive-ind}
\index{induction!deriving new schemas}%
Induction schemas are ordinary theorems and you can derive new ones
whenever you wish.  This section shows you how, using the example
of @{thm[source]nat_less_induct}. Assume we only have structural induction
available for @{typ"nat"} and want to derive complete induction.  We
must generalize the statement as shown:
*}

lemma induct_lem: "(\<And>n::nat. \<forall>m<n. P m \<Longrightarrow> P n) \<Longrightarrow> \<forall>m<n. P m"
apply(induct_tac n)

txt{*\noindent
The base case is vacuously true. For the induction step (@{prop"m <
Suc n"}) we distinguish two cases: case @{prop"m < n"} is true by induction
hypothesis and case @{prop"m = n"} follows from the assumption, again using
the induction hypothesis:
*}
 apply(blast)
by(blast elim: less_SucE)

text{*\noindent
The elimination rule @{thm[source]less_SucE} expresses the case distinction:
@{thm[display]"less_SucE"[no_vars]}

Now it is straightforward to derive the original version of
@{thm[source]nat_less_induct} by manipulating the conclusion of the above
lemma: instantiate @{term"n"} by @{term"Suc n"} and @{term"m"} by @{term"n"}
and remove the trivial condition @{prop"n < Suc n"}. Fortunately, this
happens automatically when we add the lemma as a new premise to the
desired goal:
*}

theorem nat_less_induct: "(\<And>n::nat. \<forall>m<n. P m \<Longrightarrow> P n) \<Longrightarrow> P n"
by(insert induct_lem, blast)

text{*
HOL already provides the mother of
all inductions, well-founded induction (see \S\ref{sec:Well-founded}).  For
example theorem @{thm[source]nat_less_induct} is
a special case of @{thm[source]wf_induct} where @{term r} is @{text"<"} on
@{typ nat}. The details can be found in theory \isa{Wellfounded_Recursion}.
*}
(*<*)end(*>*)


(*  Title:      HOL/Hoare/Separation.thy
    Author:     Tobias Nipkow
    Copyright   2003 TUM

A first attempt at a nice syntactic embedding of separation logic.
Already builds on the theory for list abstractions.

If we suppress the H parameter for "List", we have to hardwired this
into parser and pretty printer, which is not very modular.
Alternative: some syntax like <P> which stands for P H. No more
compact, but avoids the funny H.

*)

theory Separation imports Hoare_Logic_Abort SepLogHeap begin

text{* The semantic definition of a few connectives: *}

definition ortho :: "heap \<Rightarrow> heap \<Rightarrow> bool" (infix "\<bottom>" 55)
  where "h1 \<bottom> h2 \<longleftrightarrow> dom h1 \<inter> dom h2 = {}"

definition is_empty :: "heap \<Rightarrow> bool"
  where "is_empty h \<longleftrightarrow> h = empty"

definition singl:: "heap \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
  where "singl h x y \<longleftrightarrow> dom h = {x} & h x = Some y"

definition star:: "(heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool)"
  where "star P Q = (\<lambda>h. \<exists>h1 h2. h = h1++h2 \<and> h1 \<bottom> h2 \<and> P h1 \<and> Q h2)"

definition wand:: "(heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> bool)"
  where "wand P Q = (\<lambda>h. \<forall>h'. h' \<bottom> h \<and> P h' \<longrightarrow> Q(h++h'))"

text{*This is what assertions look like without any syntactic sugar: *}

lemma "VARS x y z w h
 {star (%h. singl h x y) (%h. singl h z w) h}
 SKIP
 {x \<noteq> z}"
apply vcg
apply(auto simp:star_def ortho_def singl_def)
done

text{* Now we add nice input syntax.  To suppress the heap parameter
of the connectives, we assume it is always called H and add/remove it
upon parsing/printing. Thus every pointer program needs to have a
program variable H, and assertions should not contain any locally
bound Hs - otherwise they may bind the implicit H. *}

syntax
 "_emp" :: "bool" ("emp")
 "_singl" :: "nat \<Rightarrow> nat \<Rightarrow> bool" ("[_ \<mapsto> _]")
 "_star" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "**" 60)
 "_wand" :: "bool \<Rightarrow> bool \<Rightarrow> bool" (infixl "-*" 60)

(* FIXME does not handle "_idtdummy" *)
ML{*
(* free_tr takes care of free vars in the scope of sep. logic connectives:
   they are implicitly applied to the heap *)
fun free_tr(t as Free _) = t $ Syntax.free "H"
(*
  | free_tr((list as Free("List",_))$ p $ ps) = list $ Syntax.free "H" $ p $ ps
*)
  | free_tr t = t

fun emp_tr [] = Syntax.const @{const_syntax is_empty} $ Syntax.free "H"
  | emp_tr ts = raise TERM ("emp_tr", ts);
fun singl_tr [p, q] = Syntax.const @{const_syntax singl} $ Syntax.free "H" $ p $ q
  | singl_tr ts = raise TERM ("singl_tr", ts);
fun star_tr [P,Q] = Syntax.const @{const_syntax star} $
      absfree ("H", dummyT) (free_tr P) $ absfree ("H", dummyT) (free_tr Q) $
      Syntax.free "H"
  | star_tr ts = raise TERM ("star_tr", ts);
fun wand_tr [P, Q] = Syntax.const @{const_syntax wand} $
      absfree ("H", dummyT) P $ absfree ("H", dummyT) Q $ Syntax.free "H"
  | wand_tr ts = raise TERM ("wand_tr", ts);
*}

parse_translation {*
 [(@{syntax_const "_emp"}, K emp_tr),
  (@{syntax_const "_singl"}, K singl_tr),
  (@{syntax_const "_star"}, K star_tr),
  (@{syntax_const "_wand"}, K wand_tr)]
*}

text{* Now it looks much better: *}

lemma "VARS H x y z w
 {[x\<mapsto>y] ** [z\<mapsto>w]}
 SKIP
 {x \<noteq> z}"
apply vcg
apply(auto simp:star_def ortho_def singl_def)
done

lemma "VARS H x y z w
 {emp ** emp}
 SKIP
 {emp}"
apply vcg
apply(auto simp:star_def ortho_def is_empty_def)
done

text{* But the output is still unreadable. Thus we also strip the heap
parameters upon output: *}

ML {*
local

fun strip (Abs(_,_,(t as Const("_free",_) $ Free _) $ Bound 0)) = t
  | strip (Abs(_,_,(t as Free _) $ Bound 0)) = t
(*
  | strip (Abs(_,_,((list as Const("List",_))$ Bound 0 $ p $ ps))) = list$p$ps
*)
  | strip (Abs(_,_,(t as Const("_var",_) $ Var _) $ Bound 0)) = t
  | strip (Abs(_,_,P)) = P
  | strip (Const(@{const_syntax is_empty},_)) = Syntax.const @{syntax_const "_emp"}
  | strip t = t;

in

fun is_empty_tr' [_] = Syntax.const @{syntax_const "_emp"}
fun singl_tr' [_,p,q] = Syntax.const @{syntax_const "_singl"} $ p $ q
fun star_tr' [P,Q,_] = Syntax.const @{syntax_const "_star"} $ strip P $ strip Q
fun wand_tr' [P,Q,_] = Syntax.const @{syntax_const "_wand"} $ strip P $ strip Q

end
*}

print_translation {*
 [(@{const_syntax is_empty}, K is_empty_tr'),
  (@{const_syntax singl}, K singl_tr'),
  (@{const_syntax star}, K star_tr'),
  (@{const_syntax wand}, K wand_tr')]
*}

text{* Now the intermediate proof states are also readable: *}

lemma "VARS H x y z w
 {[x\<mapsto>y] ** [z\<mapsto>w]}
 y := w
 {x \<noteq> z}"
apply vcg
apply(auto simp:star_def ortho_def singl_def)
done

lemma "VARS H x y z w
 {emp ** emp}
 SKIP
 {emp}"
apply vcg
apply(auto simp:star_def ortho_def is_empty_def)
done

text{* So far we have unfolded the separation logic connectives in
proofs. Here comes a simple example of a program proof that uses a law
of separation logic instead. *}

(* a law of separation logic *)
lemma star_comm: "P ** Q = Q ** P"
  by(auto simp add:star_def ortho_def dest: map_add_comm)

lemma "VARS H x y z w
 {P ** Q}
 SKIP
 {Q ** P}"
apply vcg
apply(simp add: star_comm)
done

lemma "VARS H
 {p\<noteq>0 \<and> [p \<mapsto> x] ** List H q qs}
 H := H(p \<mapsto> q)
 {List H p (p#qs)}"
apply vcg
apply(simp add: star_def ortho_def singl_def)
apply clarify
apply(subgoal_tac "p \<notin> set qs")
 prefer 2
 apply(blast dest:list_in_heap)
apply simp
done

lemma "VARS H p q r
  {List H p Ps ** List H q Qs}
  WHILE p \<noteq> 0
  INV {\<exists>ps qs. (List H p ps ** List H q qs) \<and> rev ps @ qs = rev Ps @ Qs}
  DO r := p; p := the(H p); H := H(r \<mapsto> q); q := r OD
  {List H q (rev Ps @ Qs)}"
apply vcg
apply(simp_all add: star_def ortho_def singl_def)

apply fastforce

apply (clarsimp simp add:List_non_null)
apply(rename_tac ps')
apply(rule_tac x = ps' in exI)
apply(rule_tac x = "p#qs" in exI)
apply simp
apply(rule_tac x = "h1(p:=None)" in exI)
apply(rule_tac x = "h2(p\<mapsto>q)" in exI)
apply simp
apply(rule conjI)
 apply(rule ext)
 apply(simp add:map_add_def split:option.split)
apply(rule conjI)
 apply blast
apply(simp add:map_add_def split:option.split)
apply(rule conjI)
apply(subgoal_tac "p \<notin> set qs")
 prefer 2
 apply(blast dest:list_in_heap)
apply(simp)
apply fast

apply(fastforce)
done

end