theory PALandWiseMenPuzzle2021_4Agents imports Main    (* Sebastian Reiche and Christoph Benzmüller, 2021 *)

begin
 (* Parameter settings for Nitpick *) nitpick_params[user_axioms=true, format=4, show_all]

 typedecl i (* Type of possible worlds *)
 type_synonym \<sigma> = "i\<Rightarrow>bool" (* \<D> *)
 type_synonym \<tau> = "\<sigma>\<Rightarrow>i\<Rightarrow>bool" (* Type of world depended formulas (truth sets) *)
 type_synonym \<alpha> = "i\<Rightarrow>i\<Rightarrow>bool" (* Type of accessibility relations between world *)

 (* Some useful relations (for constraining accessibility relations) *)
 definition reflexive::"\<alpha>\<Rightarrow>bool" where "reflexive R \<equiv> \<forall>x. R x x"
 definition symmetric::"\<alpha>\<Rightarrow>bool" where "symmetric R \<equiv> \<forall>x y. R x y \<longrightarrow> R y x"
 definition transitive::"\<alpha>\<Rightarrow>bool" where "transitive R \<equiv> \<forall>x y z. R x y \<and> R y z \<longrightarrow> R x z"
 definition euclidean::"\<alpha>\<Rightarrow>bool" where "euclidean R \<equiv> \<forall>x y z. R x y \<and> R x z \<longrightarrow> R y z"
 definition intersection_rel::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>\<alpha>" where "intersection_rel R Q \<equiv> \<lambda>u v. R u v \<and> Q u v"
 definition union_rel::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>\<alpha>" where "union_rel R Q \<equiv> \<lambda>u v. R u v \<or> Q u v"
 definition sub_rel::"\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" where "sub_rel R Q \<equiv> \<forall>u v. R u v \<longrightarrow> Q u v"
 definition inverse_rel::"\<alpha>\<Rightarrow>\<alpha>" where "inverse_rel R \<equiv> \<lambda>u v. R v u"
 definition bigunion_rel::"(\<alpha>\<Rightarrow>bool)\<Rightarrow>\<alpha>" ("\<^bold>\<Union>_") where "\<^bold>\<Union> X \<equiv> \<lambda>u v. \<exists>R. (X R) \<and> (R u v)"
 definition bigintersection_rel::"(\<alpha>\<Rightarrow>bool)\<Rightarrow>\<alpha>" ("\<^bold>\<Inter>_") where "\<^bold>\<Inter> X \<equiv> \<lambda>u v. \<forall>R. (X R) \<longrightarrow> (R u v)"

 (*In HOL the transitive closure of a relation can be defined in a single line.*)
 definition tc::"\<alpha>\<Rightarrow>\<alpha>" where "tc R \<equiv> \<lambda>x y.\<forall>Q. transitive Q \<longrightarrow> (sub_rel R Q \<longrightarrow> Q x y)"

 (* Lifted HOMML connectives for PAL *)
 abbreviation patom::"\<sigma>\<Rightarrow>\<tau>" ("\<^sup>A_"[79]80) where "\<^sup>Ap \<equiv> \<lambda>W w. W w \<and> p w"
 abbreviation ptop::"\<tau>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>W w. True"
 abbreviation pneg::"\<tau>\<Rightarrow>\<tau>" ("\<^bold>\<not>_"[52]53) where "\<^bold>\<not>\<phi> \<equiv> \<lambda>W w. \<not>(\<phi> W w)"
 abbreviation pand::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<and> (\<psi> W w)"
 abbreviation por::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<or> (\<psi> W w)"
 abbreviation pimp::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<longrightarrow> (\<psi> W w)"
 abbreviation pequ::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<longleftrightarrow> (\<psi> W w)"
 abbreviation pknow::"\<alpha>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>K_ _") where "\<^bold>K r \<phi> \<equiv> \<lambda>W w.\<forall>v. (W v \<and> r w v) \<longrightarrow> (\<phi> W v)"
 abbreviation ppal::"\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>[\<^bold>!_\<^bold>]_") where "\<^bold>[\<^bold>!\<phi>\<^bold>]\<psi> \<equiv> \<lambda>W w. (\<phi> W w) \<longrightarrow> (\<psi> (\<lambda>z. W z \<and> \<phi> W z) w)"

 (* Validity of \<tau>-type lifted PAL formulas *)
 abbreviation pvalid::"\<tau> \<Rightarrow> bool" ("\<^bold>\<lfloor>_\<^bold>\<rfloor>"[7]8) where "\<^bold>\<lfloor>\<phi>\<^bold>\<rfloor> \<equiv> \<forall>W.\<forall>w. W w \<longrightarrow> \<phi> W w"

 (* Agent Knowledge, Mutual Knowledge, Common Knowledge *)
 abbreviation  "EVR A \<equiv> \<^bold>\<Union> A"
 abbreviation  "DIS A \<equiv> \<^bold>\<Inter> A"
 abbreviation agttknows::"\<alpha>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>K\<^sub>_ _") where "\<^bold>K\<^sub>r \<phi> \<equiv>  \<^bold>K r \<phi>"
 abbreviation evrknows::"(\<alpha>\<Rightarrow>bool)\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>E\<^sub>_ _") where "\<^bold>E\<^sub>A \<phi> \<equiv>  \<^bold>K (EVR A) \<phi>"
 abbreviation prck::"(\<alpha>\<Rightarrow>bool)\<Rightarrow>\<tau>\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>C\<^sub>_\<^bold>\<lparr>_\<^bold>|_\<^bold>\<rparr>")
   where "\<^bold>C\<^sub>A\<^bold>\<lparr>\<phi>\<^bold>|\<psi>\<^bold>\<rparr> \<equiv> \<lambda>W w. \<forall>v. \<not>(tc (intersection_rel (EVR A) (\<lambda>u v. W v \<and> \<phi> W v)) w v) \<or> (\<psi> W v)"
 abbreviation pcmn::"(\<alpha>\<Rightarrow>bool)\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>C\<^sub>_ _") where "\<^bold>C\<^sub>A \<phi> \<equiv>  \<^bold>C\<^sub>A\<^bold>\<lparr>\<^bold>\<top>\<^bold>|\<phi>\<^bold>\<rparr>"
 abbreviation disknows :: "(\<alpha>\<Rightarrow>bool)\<Rightarrow>\<tau>\<Rightarrow>\<tau>" ("\<^bold>D\<^sub>_ _") where "\<^bold>D\<^sub>A \<phi> \<equiv> \<^bold>K (DIS A) \<phi>"

 (* Introducing "Defs" as the set of the above definitions; useful for convenient unfolding *)
 named_theorems Defs
 declare reflexive_def[Defs] symmetric_def[Defs] transitive_def[Defs] euclidean_def[Defs]
   intersection_rel_def[Defs] union_rel_def[Defs] sub_rel_def[Defs] inverse_rel_def[Defs]
   bigunion_rel_def[Defs] tc_def[Defs]

 abbreviation "S5Agent i \<equiv> reflexive i \<and> transitive i \<and> euclidean i"
 abbreviation "S5Agents A \<equiv> \<forall>i. (A i \<longrightarrow> S5Agent i)"

 (***********************************************************************************************)
 (*****                         Wise Men Puzzle                                             *****)
 (***********************************************************************************************)
 (*** Encoding of the wise men puzzle in PAL ***)
 (* Agents *)
 consts a::"\<alpha>" b::"\<alpha>" c::"\<alpha>" d::"\<alpha>" (* Agents modeled as accessibility relations *)
 abbreviation  Agent::"\<alpha>\<Rightarrow>bool" ("\<A>") where "\<A> x \<equiv> x = a \<or> x = b \<or> x = c \<or> x = d"
 axiomatization where  group_S5: "S5Agents \<A>"

 (*** Encoding of the wise men puzzle in PAL ***)
 consts ws::"\<alpha>\<Rightarrow>\<sigma>"
 axiomatization where WM1: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^sup>Aws a \<^bold>\<or> \<^sup>Aws b \<^bold>\<or> \<^sup>Aws c \<^bold>\<or> \<^sup>Aws d)\<^bold>\<rfloor>"

 axiomatization where
   (* Common knowledge: If x not has a white spot then y know this *)
   WM2ab: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws a) \<^bold>\<rightarrow> (\<^bold>K\<^sub>b (\<^bold>\<not>(\<^sup>Aws a))))\<^bold>\<rfloor>" and
   WM2ac: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws a) \<^bold>\<rightarrow> (\<^bold>K\<^sub>c (\<^bold>\<not>(\<^sup>Aws a))))\<^bold>\<rfloor>" and
   WM2ad: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws a) \<^bold>\<rightarrow> (\<^bold>K\<^sub>d (\<^bold>\<not>(\<^sup>Aws a))))\<^bold>\<rfloor>" and
   WM2ba: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws b) \<^bold>\<rightarrow> (\<^bold>K\<^sub>a (\<^bold>\<not>(\<^sup>Aws b))))\<^bold>\<rfloor>" and
   WM2bc: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws b) \<^bold>\<rightarrow> (\<^bold>K\<^sub>c (\<^bold>\<not>(\<^sup>Aws b))))\<^bold>\<rfloor>" and
   WM2bd: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws b) \<^bold>\<rightarrow> (\<^bold>K\<^sub>d (\<^bold>\<not>(\<^sup>Aws b))))\<^bold>\<rfloor>" and
   WM2ca: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws c) \<^bold>\<rightarrow> (\<^bold>K\<^sub>a (\<^bold>\<not>(\<^sup>Aws c))))\<^bold>\<rfloor>" and
   WM2cb: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws c) \<^bold>\<rightarrow> (\<^bold>K\<^sub>b (\<^bold>\<not>(\<^sup>Aws c))))\<^bold>\<rfloor>" and
   WM2cd: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws c) \<^bold>\<rightarrow> (\<^bold>K\<^sub>d (\<^bold>\<not>(\<^sup>Aws c))))\<^bold>\<rfloor>" and
   WM2da: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws d) \<^bold>\<rightarrow> (\<^bold>K\<^sub>a (\<^bold>\<not>(\<^sup>Aws d))))\<^bold>\<rfloor>" and
   WM2db: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws d) \<^bold>\<rightarrow> (\<^bold>K\<^sub>b (\<^bold>\<not>(\<^sup>Aws d))))\<^bold>\<rfloor>" and
   WM2dc: "\<^bold>\<lfloor>\<^bold>C\<^sub>\<A> (\<^bold>\<not>(\<^sup>Aws d) \<^bold>\<rightarrow> (\<^bold>K\<^sub>c (\<^bold>\<not>(\<^sup>Aws d))))\<^bold>\<rfloor>"

 (* Automated solutions of the Wise Men Puzzle with 4 Agents*)

 theorem whitespot_c_1: "\<^bold>\<lfloor>\<^bold>[\<^bold>!\<^bold>\<not>\<^bold>K\<^sub>a(\<^sup>Aws a)\<^bold>](\<^bold>[\<^bold>!\<^bold>\<not>\<^bold>K\<^sub>b(\<^sup>Aws b)\<^bold>](\<^bold>[\<^bold>!\<^bold>\<not>\<^bold>K\<^sub>c(\<^sup>Aws c)\<^bold>](\<^bold>K\<^sub>d (\<^sup>Aws d))))\<^bold>\<rfloor>"
   using WM1 WM2ba WM2ca WM2cb WM2da WM2db WM2dc
   unfolding Defs
   by (smt (verit))

 theorem whitespot_c_2:
     "\<^bold>\<lfloor>\<^bold>[\<^bold>!\<^bold>\<not>((\<^bold>K\<^sub>a (\<^sup>Aws a)) \<^bold>\<or> (\<^bold>K\<^sub>a (\<^bold>\<not>\<^sup>Aws a)))\<^bold>](\<^bold>[\<^bold>!\<^bold>\<not>((\<^bold>K\<^sub>b (\<^sup>Aws b)) \<^bold>\<or> (\<^bold>K\<^sub>b (\<^bold>\<not>\<^sup>Aws b)))\<^bold>](\<^bold>[\<^bold>!\<^bold>\<not>((\<^bold>K\<^sub>c (\<^sup>Aws c)) \<^bold>\<or> (\<^bold>K\<^sub>c (\<^bold>\<not>\<^sup>Aws c)))\<^bold>](\<^bold>K\<^sub>d (\<^sup>Aws d))))\<^bold>\<rfloor>"
   using whitespot_c_1
   unfolding Defs sledgehammer[verbose]()
   oops

 (* Consistency confirmed by nitpick *)
 lemma True nitpick [satisfy] oops  (* model found *)

end


(*<*)
\<comment>\<open> ********************************************************************
 * Project         : AGM Theory
 * Version         : 1.0
 *
 * Authors         : Valentin Fouillard, Safouan Taha, Frederic Boulanger
                     and Nicolas Sabouret
 *
 * This file       : AGM Remainders
 *
 * Copyright (c) 2021 Université Paris Saclay, France
 *
 ******************************************************************************\<close>

theory AGM_Remainder

imports AGM_Logic

begin

(*>*)

section \<open>Remainders\<close>

text\<open>In AGM, one important feature is to eliminate some proposition from a set of propositions by ensuring
that the set of retained clauses is maximal and that nothing among these clauses allows to retrieve the eliminated proposition\<close>

subsection \<open>Remainders in a Tarskian logic\<close>
text \<open>In a general context of a Tarskian logic, we consider a descriptive definition (by comprehension)\<close>
context Tarskian_logic

begin
definition remainder::\<open>'a set \<Rightarrow> 'a \<Rightarrow> 'a set set\<close> (infix \<open>.\<bottom>.\<close> 55)
  where rem: \<open>A .\<bottom>. \<phi> \<equiv> {B. B \<subseteq> A \<and> \<not> B \<turnstile> \<phi> \<and> (\<forall>B'\<subseteq> A. B \<subset> B' \<longrightarrow> B' \<turnstile> \<phi>)}\<close>

lemma rem_inclusion: \<open>B \<in> A .\<bottom>. \<phi> \<Longrightarrow> B \<subseteq> A\<close>
  by (auto simp add:rem split:if_splits)

lemma rem_closure: "K = Cn(A) \<Longrightarrow> B \<in> K .\<bottom>. \<phi> \<Longrightarrow> B = Cn(B)"
  apply(cases \<open>K .\<bottom>. \<phi> = {}\<close>, simp)
  by (simp add:rem infer_def) (metis idempotency_L inclusion_L monotonicity_L psubsetI)

lemma remainder_extensionality: \<open>Cn({\<phi>}) = Cn({\<psi>}) \<Longrightarrow> A .\<bottom>. \<phi> = A .\<bottom>. \<psi>\<close>
  unfolding rem infer_def apply safe
  by (simp_all add: Cn_same) blast+

lemma nonconsequence_remainder: \<open>A .\<bottom>. \<phi> = {A} \<longleftrightarrow> \<not> A \<turnstile> \<phi>\<close>
  unfolding rem by auto

\<comment> \<open>As we will see further, the other direction requires compactness!\<close>
lemma taut2emptyrem: \<open>\<tturnstile> \<phi> \<Longrightarrow> A .\<bottom>. \<phi> = {}\<close>
  unfolding rem by (simp add: infer_def validD_L)

end

subsection \<open>Remainders in a supraclassical logic\<close>
text\<open>In case of a supraclassical logic, remainders get impressive properties\<close>
context Supraclassical_logic

begin

\<comment> \<open>As an effect of being maximal, a remainder keeps the eliminated proposition in its propositions hypothesis\<close>
lemma remainder_recovery: \<open>K = Cn(A) \<Longrightarrow> K \<turnstile> \<psi> \<Longrightarrow> B \<in> K .\<bottom>. \<phi> \<Longrightarrow> B \<turnstile> \<phi> .\<longrightarrow>. \<psi>\<close>
proof -
  { fix \<psi> and B
    assume  a:\<open>K = Cn(A)\<close> and c:\<open>\<psi> \<in> K\<close> and d:\<open>B \<in> K .\<bottom>. \<phi>\<close> and e:\<open>\<phi> .\<longrightarrow>. \<psi> \<notin> Cn(B)\<close>
    with a have f:\<open>\<phi> .\<longrightarrow>. \<psi> \<in> K\<close> using impI2 infer_def by blast
    with d e have \<open>\<phi> \<in> Cn(B \<union> {\<phi> .\<longrightarrow>. \<psi>})\<close>
      apply (simp add:rem, elim conjE)
      by (metis dual_order.order_iff_strict inclusion_L insert_subset)
    with d have False using rem imp_recovery1
      by (metis (no_types, lifting) CollectD infer_def)
  }
  thus \<open>K = Cn(A) \<Longrightarrow> K \<turnstile> \<psi> \<Longrightarrow> B \<in> K .\<bottom>. \<phi> \<Longrightarrow> B \<turnstile> \<phi> .\<longrightarrow>. \<psi>\<close>
    using idempotency_L by auto
qed

\<comment> \<open>When you remove some proposition \<open>\<phi>\<close> several other propositions can be lost.
An important lemma states that the resulting remainder is also a remainder of any lost proposition\<close>
lemma remainder_recovery_bis: \<open>K = Cn(A) \<Longrightarrow> K \<turnstile> \<psi> \<Longrightarrow> \<not> B \<turnstile> \<psi> \<Longrightarrow> B \<in> K .\<bottom>. \<phi> \<Longrightarrow> B \<in> K .\<bottom>. \<psi>\<close>
proof-
  assume a:\<open>K = Cn(A)\<close> and b:\<open>\<not> B \<turnstile> \<psi>\<close> and c:\<open>B \<in> K .\<bottom>. \<phi>\<close> and d:\<open>K \<turnstile> \<psi>\<close>
  hence d:\<open>B \<turnstile> \<phi> .\<longrightarrow>. \<psi>\<close> using remainder_recovery by simp
  with c show \<open>B \<in> K .\<bottom>. \<psi>\<close>
    by (simp add:rem) (meson b dual_order.trans infer_def insert_subset monotonicity_L mp_PL order_refl psubset_imp_subset)
qed

corollary remainder_recovery_imp: \<open>K = Cn(A) \<Longrightarrow> K \<turnstile> \<psi> \<Longrightarrow> \<tturnstile> (\<psi> .\<longrightarrow>. \<phi>) \<Longrightarrow> B \<in> K .\<bottom>. \<phi> \<Longrightarrow> B \<in> K .\<bottom>. \<psi>\<close>
  apply(rule remainder_recovery_bis, simp_all)
  by (simp add:rem) (meson infer_def mp_PL validD_L)

\<comment> \<open>If we integrate back the eliminated proposition into the remainder, we retrieve the original set!\<close>
lemma remainder_expansion: \<open>K = Cn(A) \<Longrightarrow> K \<turnstile> \<psi> \<Longrightarrow> \<not> B \<turnstile> \<psi> \<Longrightarrow> B \<in> K .\<bottom>. \<phi> \<Longrightarrow> B \<oplus> \<psi> = K\<close>
proof
  assume a:\<open>K = Cn(A)\<close> and b:\<open>K \<turnstile> \<psi>\<close> and c:\<open>\<not> B \<turnstile> \<psi>\<close> and d:\<open>B \<in> K .\<bottom>. \<phi>\<close>
  then show \<open>B \<oplus> \<psi> \<subseteq> K\<close>
    by (metis Un_insert_right expansion_def idempotency_L infer_def insert_subset
              monotonicity_L rem_inclusion sup_bot.right_neutral)
next
  assume a:\<open>K = Cn(A)\<close> and b:\<open>K \<turnstile> \<psi>\<close> and c:\<open>\<not> B \<turnstile> \<psi>\<close> and d:\<open>B \<in> K .\<bottom>. \<phi>\<close>
  { fix \<chi>
    assume \<open>\<chi> \<in> K\<close>
    hence e:\<open>B \<turnstile> \<phi> .\<longrightarrow>.\<chi>\<close> using remainder_recovery[OF a _ d, of \<chi>] assumption_L by blast
    have \<open>\<psi> \<in> K\<close> using a b idempotency_L infer_def by blast
    hence f:\<open>B \<union> {\<psi>} \<turnstile> \<phi>\<close> using b c d apply(simp add:rem)
      by (meson inclusion_L insert_iff insert_subsetI less_le_not_le subset_iff)
    from e f have \<open>B \<union> {\<psi>} \<turnstile> \<chi>\<close> using imp_PL imp_trans by blast
  }
  then show \<open>K \<subseteq> B \<oplus> \<psi>\<close>
    by (simp add: expansion_def subsetI)
qed

text\<open>To eliminate a conjunction, we only need to remove one side\<close>
lemma remainder_conj: \<open>K = Cn(A) \<Longrightarrow> K \<turnstile> \<phi> .\<and>. \<psi> \<Longrightarrow> K .\<bottom>. (\<phi> .\<and>. \<psi>) = (K .\<bottom>. \<phi>) \<union> (K .\<bottom>. \<psi>)\<close>
  apply(intro subset_antisym Un_least subsetI, simp add:rem)
    apply (meson conj_PL infer_def)
   using remainder_recovery_imp[of K A \<open>\<phi> .\<and>. \<psi>\<close> \<phi>]
   apply (meson assumption_L conjE1_PL singletonI subsetI valid_imp_PL)
  using remainder_recovery_imp[of K A \<open>\<phi> .\<and>. \<psi>\<close> \<psi>]
  by (meson assumption_L conjE2_PL singletonI subsetI valid_imp_PL)

end

subsection \<open>Remainders in a compact logic\<close>
text\<open>In case of a supraclassical logic, remainders get impressive properties\<close>
context Compact_logic
begin

text \<open>The following lemma is the Lindembaum's lemma requiring the Zorn's lemma (already available in standard Isabelle/HOL).
  For more details, please refer to the book "Theory of logical calculi" \<^cite>\<open>wojcicki2013theory\<close>.
This very important lemma states that we can get a maximal set (remainder \<open>B'\<close>) starting from any set
\<open>B\<close> if this latter does not infer the proposition \<open>\<phi>\<close> we want to eliminate\<close>
lemma upper_remainder: \<open>B \<subseteq> A \<Longrightarrow> \<not> B \<turnstile> \<phi> \<Longrightarrow> \<exists>B'. B \<subseteq> B' \<and>  B' \<in> A .\<bottom>. \<phi>\<close>
proof -
  assume a:\<open>B \<subseteq> A\<close> and b:\<open>\<not> B \<turnstile> \<phi>\<close>
  have c:\<open>\<not> \<tturnstile> \<phi>\<close>
    using b infer_def validD_L by blast
  define \<B> where "\<B> \<equiv> {B'. B \<subseteq> B' \<and> B' \<subseteq> A \<and> \<not> B' \<turnstile> \<phi>}"
  have d:\<open>subset.chain \<B> C \<Longrightarrow> subset.chain {B. \<not> B \<turnstile> \<phi>} C\<close> for C
    unfolding \<B>_def
    by (simp add: le_fun_def less_eq_set_def subset_chain_def)
  have e:\<open>C \<noteq> {} \<Longrightarrow> subset.chain \<B> C \<Longrightarrow> B \<subseteq> \<Union> C\<close> for C
    by (metis (no_types, lifting) \<B>_def subset_chain_def less_eq_Sup mem_Collect_eq subset_iff)
  { fix C
    assume f:\<open>C \<noteq> {}\<close> and g:\<open>subset.chain \<B> C\<close>
    have \<open>\<Union> C \<in> \<B>\<close>
      using \<B>_def  e[OF f g] chain_closure[OF c d[OF g]]
      by simp (metis (no_types, lifting) CollectD Sup_least Sup_subset_mono g subset.chain_def subset_trans)
  } note f=this
  have \<open>subset.chain \<B> C \<Longrightarrow> \<exists>U\<in>\<B>. \<forall>X\<in>C. X \<subseteq> U\<close> for C
    apply (cases \<open>C \<noteq> {}\<close>)
     apply (meson Union_upper f)
    using \<B>_def a b by blast
  with subset_Zorn[OF this, simplified] obtain B' where f:\<open>B'\<in> \<B> \<and> (\<forall>X\<in>\<B>. B' \<subseteq> X \<longrightarrow> X = B')\<close> by auto
  then show ?thesis
    by (simp add:rem \<B>_def, rule_tac x=B' in exI) (metis psubsetE subset_trans)
qed

\<comment> \<open>An immediate corollary ruling tautologies\<close>
corollary emptyrem2taut: \<open>A .\<bottom>. \<phi> = {} \<Longrightarrow> \<tturnstile> \<phi>\<close>
  by (metis bot.extremum empty_iff upper_remainder valid_def)

end

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.*)
  theory TIP_rotate_mod
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun rotate :: "Nat => 'a list => 'a list" where
"rotate (Z) z = z"
| "rotate (S z2) (nil2) = nil2"
| "rotate (S z2) (cons2 z22 xs1) =
     rotate z2 (x xs1 (cons2 z22 (nil2)))"

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

fun minus :: "Nat => Nat => Nat" where
"minus (Z) z = Z"
| "minus (S z2) (S y2) = minus z2 y2"

fun lt :: "Nat => Nat => bool" where
"lt y (Z) = False"
| "lt (Z) (S z2) = True"
| "lt (S n) (S z2) = lt n z2"

(*fun did not finish the proof*)
function mod2 :: "Nat => Nat => Nat" where
"mod2 y (Z) = Z"
| "mod2 y (S z2) =
     (if lt y (S z2) then y else mod2 (minus y (S z2)) (S z2))"
by pat_completeness auto

fun length :: "'a list => Nat" where
"length (nil2) = Z"
| "length (cons2 z l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
"le (Z) z = True"
| "le (S z2) (Z) = False"
| "le (S z2) (S x2) = le z2 x2"

fun take :: "Nat => 'a list => 'a list" where
"take y z =
   (if le y Z then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => (case y of S x2 => cons2 z2 (take x2 xs))))"

fun drop :: "Nat => 'a list => 'a list" where
"drop y z =
   (if le y Z then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => (case y of S x2 => drop x2 xs1)))"

theorem property0 :
  "((rotate n xs) =
      (x (drop (mod2 n (length xs)) xs) (take (mod2 n (length xs)) xs)))"
  oops

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_sort_TSortSorts
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Tree = TNode "Tree" "int" "Tree" | TNil

fun ordered :: "int list => bool" where
"ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

fun flatten :: "Tree => int list => int list" where
"flatten (TNode p z q) y = flatten p (cons2 z (flatten q y))"
| "flatten (TNil) y = y"

fun add :: "int => Tree => Tree" where
"add x (TNode p z q) =
   (if x <= z then TNode (add x p) z q else TNode p z (add x q))"
| "add x (TNil) = TNode TNil x TNil"

fun toTree :: "int list => Tree" where
"toTree (nil2) = TNil"
| "toTree (cons2 y xs) = add y (toTree xs)"

fun tsort :: "int list => int list" where
"tsort x = flatten (toTree x) (nil2)"

theorem property0 :
  "ordered (tsort xs)"
  oops

end


theory Chapter3Sols
imports Main Chapter3Defs
begin

(*  Exercise 3.1  *)
fun set :: "'a tree \<Rightarrow> 'a set" where
"set Tip = {}" |
"set (Node l a r) = {a} \<union> (set l) \<union> (set r)"

(* not complete *)

(*  Exercise 3.2  *)
inductive palindrome:: "'a list \<Rightarrow> bool" where
emptyP: "palindrome []" |
singlP: "palindrome [x]" |
indctP: "palindrome xs \<Longrightarrow> palindrome(a # xs @ [a])"

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
  apply(induction xs rule: palindrome.induct)
    apply(simp_all)
  done

(*  Exercise 3.3  *)
(* not complete *)

(*  Exercise 3.4  *)
(* not complete *)

(*  Exercise 3.5  *)
(* Adapted from: https://isabelle.in.tum.de/exercises/logic/parentheses/sol.pdf *)
datatype alpha = a | b

inductive S:: "alpha list \<Rightarrow> bool" where
S1: "S []" |
S2: "S [v] \<Longrightarrow> S (a # [v] @ [b])" |
S3: "S [v] \<Longrightarrow> S [w] \<Longrightarrow> S([v] @ [w])"

declare S1 [iff] S2 [intro!, simp]

inductive T:: "alpha list \<Rightarrow> bool" where
T1: "T []" |
T2: "T [v] \<Longrightarrow> T[w] \<Longrightarrow> T([v] @ a # [w] @ [b])"

declare T1 [iff]

lemma T2S:"T w \<Longrightarrow> S w"
  apply(erule T.induct)
   apply(simp)
  (* found by sledgehammer *)
  using S.cases by auto

lemma S2T:"S w \<Longrightarrow> T w"
  apply(erule S.induct)
    apply(simp)
  (* found by sledgehammer *)
  using S.cases by auto

lemma "S w == T w"
  by (smt (verit) S2T T2S)

end

github-repos/isabelle/mrtkp9993-Isabelle-HOL-Examples/Isabelle-HOL-Examples-37a31d2aefce20eb5c49d358c1ea236f5e693458/Programming and Proving in Isabelle-Hol Exercise Solutions/Chapter3Sols.thy


theory Ex3_2
  imports Main
begin

primrec sq :: "nat \<Rightarrow> nat" where
  "sq 0 = 0"|
  "sq (Suc n) = sq n + n + (Suc n)"

theorem "sq n = n * n" by (induction n ; simp)

definition mm2 ::"nat \<Rightarrow> nat \<Rightarrow> nat" where
  "mm2 base value \<equiv> let diff = value - base ; qdiff = diff * diff in (value + diff)  * base + qdiff"

declare mm2_def [simp]

theorem " n \<le> m   \<Longrightarrow>  mm2 n m = m * m"
proof (induction n arbitrary : m)
  case 0
  then show ?case by simp
next
  case (Suc n)
  assume hyp:"\<And>m . n \<le> m \<Longrightarrow> mm2 n m = m * m"
    and hyp2:"Suc n \<le> m"
  then show ?case
  proof (cases "m = 0")
    case True
    then show ?thesis using hyp2 by simp
  next
    case False
      assume c1:"m \<noteq> 0"

    from hyp[of "m - 1"] hyp2 have tmp':"mm2 n (m - 1) = (m - 1) * (m - 1)" by simp

    have "mm2 n (m - 1) = (let diff = (m-1) - n ; qdiff = diff * diff in ((m - 1) + diff)  * n + qdiff)" by simp
    also have " \<dots> = ((m - 1) + ((m - 1) - n)) * n + ((m -1) -n)* ((m - 1) -n)"  by (simp only : Let_def)
    also have "\<dots> = (m - 1 + (m  - Suc n)) * n + (m - Suc n)* (m  - Suc n)" by simp
    also have "\<dots> = (m - 1) * n + (m - Suc n)* n + (m - Suc n) * (m - Suc n)" using distrib_right by simp
    finally have tmp:"mm2 n (m - 1) =  (m - 1) * n + (m - Suc n)* n + (m - Suc n) * (m - Suc n)"  by assumption

    have tmp2:"m * m = m + (m - 1) + (m - 1) * (m - 1)" by (induction m; simp)

    have "mm2 (Suc n) m =(let diff = m - (Suc n) ; qdiff = diff * diff in (m + diff)  * (Suc n) + qdiff)" by simp
    also have "\<dots> = (m + (m- (Suc n))) * (Suc n) + (m - Suc n) * (m - Suc n)" by (simp only : Let_def)
    also have "\<dots> = (m + m- (Suc n)) * (Suc n) + (m - Suc n) * (m - Suc n)" using hyp2 by simp
    also have "\<dots> = (m + m - (Suc n)) + (m + m - (Suc n))* n + (m - Suc n) * (m - Suc n)" by simp
    also have "\<dots> = m + (m - 1) - n + (m + m - (Suc n))* n + (m - Suc n) * (m - Suc n)" by simp
    also have "\<dots> = m + (m - 1) - n + (m + (m - (Suc n)))* n + (m - Suc n) * (m - Suc n)" using hyp2 by simp
    also have "\<dots> = m + (m - 1) - n + m * n + (m - (Suc n))* n + (m - Suc n) * (m - Suc n) " by (simp add: distrib_right)
    also have "\<dots> =  m + (m - 1) +m * n - n + (m - (Suc n))* n + (m - Suc n) * (m - Suc n) " using Suc_leD hyp2 le_add1 order_trans ordered_cancel_comm_monoid_diff_class.add_diff_assoc2 by simp
    also have "\<dots> =  m + (m - 1) + (m  - 1)*n + (m - (Suc n))* n + (m - Suc n) * (m - Suc n)" by (simp add: c1 algebra_simps mult_eq_if)
    finally have tmp3:"mm2 (Suc n) m = m + (m - 1) + (m  - 1)*n + (m - (Suc n))* n + (m - Suc n) * (m - Suc n)" by assumption
    show ?thesis using tmp tmp2 tmp3 tmp' by simp
  qed
qed

lemma helper : "m \<le> n \<longrightarrow> sq n =  ((n + (n - m)) * m)  + sq (n - m)"
proof (induction n arbitrary : m)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case by (cases m ; simp)
qed

theorem "100 \<le> n \<Longrightarrow> sq n =  ((n + (n - 100)) * 100)  + sq (n - 100)"using helper by (induction n; simp)

definition "eq1 (n::nat) = (n -5)*(n-5 + 10) + 25"
definition "eq2 (n::nat) = (n div 10 )* (n div 10 + 1) * 100 + 25"

lemma helper2:"(n::nat) mod 10 = 5 \<Longrightarrow>  n div 10 * 10 = n - 5" by (metis minus_mod_eq_div_mult)

theorem "(n::nat) mod 10 = 5 \<Longrightarrow>  n*n  = (n div 10 )* (n div 10 + 1) * 100 + 25"
proof -
  assume hyp:"n mod 10 = 5"
  hence tmp:"5 \<le> n" by simp

  from tmp have tmp2:"(n - 5)*(n - 5) = n*n + 25 - 10*n"
  proof (induction n)
    case 0
    then show ?case by simp
  next
    case (Suc n)
    assume hyp1:"5 \<le> n \<Longrightarrow> (n - 5) * (n - 5) = n * n + 25 - 10 * n"
       and hyp2:"5 \<le> Suc n"
    then show ?case
    proof (cases "n = 4")
      case True
      then show ?thesis by simp
    next
      case False
      assume c1:"n \<noteq> 4"
      with hyp2 have tmp:"5 \<le> n" by simp
      with hyp1 have tmp2:" (n - 5) * (n - 5) = n * n + 25 - 10 * n" by simp

      have tmp3:"Suc n - 5 = Suc (n - 5)"
      proof -
        have "Suc n - 5 = 1 + n - 5" by simp
        also have "\<dots> = 1+ (n - 5)" using tmp by simp
        also have "\<dots> = Suc (n - 5)" by simp
        finally show ?thesis by assumption
      qed

      from tmp have h:"n * n + 25 \<ge> n*10"
      proof  (induction n)
        case 0
        then show ?case by simp
      next
        case (Suc n)
        assume a:"5 \<le> n \<Longrightarrow> n * 10 \<le> n * n + 25"
           and b:"5 \<le> Suc n"
        then show ?case
        proof (cases "n = 4")
          case True
          then show ?thesis by simp
        next
          case False
          with b have c:"5 \<le> n" by simp
          with a have d:"n * 10 \<le> n * n + 25" by simp
          have "Suc n + n  > 10" using c by simp
          with c d show ?thesis by simp
        qed
      qed

      have "(Suc n - 5) * (Suc n - 5) =  (n + 1 - 5)* ( n + 1 - 5)" using hyp2 by simp
      also have "\<dots> = Suc n * Suc n + 25 - 10*Suc n" using tmp tmp2 tmp3 algebra_simps h by simp
      finally show ?thesis by assumption
    qed
  qed

  from tmp have tmp3:"n*n + 25 \<ge> 10*n"
  proof (induction n)
    case 0
    then show ?case by simp
  next
    case (Suc n)
    assume a:"5 \<le> n \<Longrightarrow> 10 * n \<le> n * n + 25"
       and b:"5 \<le> Suc n"
    then show ?case
    proof (cases "n = 4")
      case True
      then show ?thesis by simp
    next
      case False
      assume c:"n \<noteq>4"
      from c and b have d:"5 \<le> n" by simp
      with a have e:"10 * n \<le> n * n + 25" by simp
      have "Suc n + n \<ge> 10" using d by simp
      with d e show ?thesis by simp
    qed
  qed

  from tmp have tmp4:"n*n \<ge> 25"
  proof (induction n )
    case 0
    then show ?case by simp
  next
    case (Suc n)
    assume a:"5 \<le> n \<Longrightarrow> 25 \<le> n * n"
       and b:"5 \<le> Suc n"
    then show ?case
    proof (cases "n = 4")
      case True
      then show ?thesis by simp
    next
      case False
      with b have "5 \<le> n" by simp
      with a have "25 \<le> n*n" by simp
      then show ?thesis by simp
    qed
  qed

  have "(n div 10 )* (n div 10 + 1) * 100 + 25 = (n div 10 )*  Suc (n div 10 ) * 100 + 25" by simp
  also have "\<dots> = n div 10 * 10 *10 + (n div 10 )*  (n div 10 ) * 100 + 25 " using algebra_simps  by simp
  also have "\<dots> = (n - 5 ) *10 + (n div 10 ) * (n div 10  ) * 10  * 10 + 25" using hyp  by (simp add : helper2 )
  also have "\<dots> = (n - 5 ) *10 + (n div 10  * 10)  * (n div 10 * 10)   + 25" by simp
  also have "\<dots> = n*n + 10*n -25 - 10*n + 25" using tmp tmp3 tmp2 hyp helper2 algebra_simps by simp
  also have "\<dots> = n*n " using tmp4 by simp
  finally show ?thesis by (rule sym)
qed

theorem "sq((10 * n) + 5) = ((n * (Suc n)) * 100) + 25"
proof (induction n)
case 0
  then show ?case by (simp add : sq_def)
next
  case (Suc n)
  then show ?case by (simp add: sq_def algebra_simps)
qed


theory Alg_Varieties_Theory
  imports Field_Theory

begin

(* We formalize below our blueprint, first with n=1, but this should be generalized.
If n=1 then the affine space is just carrier k. *)

context field
begin

(* def. 0.0.3 *)
definition zero_set :: "('a upoly) set \<Rightarrow> 'a set"
  where "zero_set T \<equiv> {p \<in> R. \<forall>f\<in>T. eval_poly f p = \<zero>}"

(* def 0.0.4 *)
definition algebraic :: "'a set \<Rightarrow> bool"
  where "algebraic Y \<equiv> (\<exists>T. Y = zero_set T)"

(* exercise 0.0.5 *)
lemma empty_set_is_algebraic:
  shows "algebraic empty" sorry

lemma whole_space_is_algebraic:
  shows "algebraic R"
  by (auto simp: algebraic_def zero_set_def)

(* exercise 0.0.6 *)
lemma inter_of_alg_family_is_algebraic:
  fixes f :: "'a set set"
  assumes "Y \<in> f \<Longrightarrow> algebraic Y"
  shows "algebraic (\<Inter>f)" sorry

(* exercise 0.0.7 *)
lemma union_of_two_algebraic_is_algebraic:
  assumes "algebraic Y" and "algebraic Z"
  shows "algebraic (Y \<union> Z)" sorry

(* def. 0.0.8 *)
definition zariski_open :: "'a set \<Rightarrow> bool"
  where "zariski_open S = (\<exists>Y. algebraic Y \<and> S = R - Y)"

(* exercise 0.0.9 *)
lemma zariski_topology_is_topology:
  shows "istopology zariski_open" sorry

definition  zariski_closed :: "'a set \<Rightarrow> bool"
  where "zariski_closed S \<equiv> zariski_open (R - S)"

(* def. 0.0.10 *)
definition irreducible :: "'a set \<Rightarrow> bool"
  where "irreducible S \<equiv> S \<subseteq> R \<and> S \<noteq> empty \<and> \<not>(\<exists>U V. S = U \<union> V \<and> zariski_closed U \<and>
zariski_closed V \<and> U \<subset> R \<and> V \<subset> R)"

(* def 0.0.11 *)
definition aff_alg_variety :: "'a set \<Rightarrow> bool"
  where "aff_alg_variety S \<equiv> irreducible S \<and> zariski_closed S"

(* def 0.0.12 *)
definition quasi_aff_variety :: "'a set \<Rightarrow> bool"
  where "quasi_aff_variety U \<equiv> \<exists>S Y. aff_alg_variety S \<and> zariski_open Y \<and> U = S \<inter> Y"

end

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.*)
  theory TIP_sort_SSortIsSort
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun ssortminimum1 :: "int => int list => int" where
  "ssortminimum1 x (nil2) = x"
| "ssortminimum1 x (cons2 y1 ys1) =
     (if y1 <= x then ssortminimum1 y1 ys1 else ssortminimum1 x ys1)"

fun insert :: "int => int list => int list" where
  "insert x (nil2) = cons2 x (nil2)"
| "insert x (cons2 z xs) =
     (if x <= z then cons2 x (cons2 z xs) else cons2 z (insert x xs))"

fun isort :: "int list => int list" where
  "isort (nil2) = nil2"
| "isort (cons2 y xs) = insert y (isort xs)"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy x y (nil2) = nil2"
| "deleteBy x y (cons2 y2 ys) =
     (if (x y) y2 then ys else cons2 y2 (deleteBy x y ys))"

(*fun did not finish the proof*)
function ssort :: "int list => int list" where
  "ssort (nil2) = nil2"
| "ssort (cons2 y ys) =
     (let m :: int = ssortminimum1 y ys
     in cons2
          m
          (ssort
             (deleteBy
                (% (z :: int) => % (x2 :: int) => (z = x2)) m (cons2 y ys))))"
  by pat_completeness auto

theorem property0 :
  "((ssort xs) = (isort xs))"
  oops

end


theory Isar_Induction_Demo
imports Main
begin

section{*Case distinction and induction*}

subsection{*Case distinction*}

text{* Explicit: *}

lemma "length(tl xs) = length xs - 1"
proof (cases xs)
  assume "xs = []" thus ?thesis by simp
next
  fix y ys assume "xs = y#ys"
  thus ?thesis by simp
qed

text{* Implicit: *}

lemma "length(tl xs) = length xs - 1"
proof (cases xs)
print_cases
  case Nil
thm Nil
  thus ?thesis by simp
next
  case (Cons y ys)
thm Cons
  thus ?thesis by simp
qed

subsection{*Structural induction for nat*}

text{* Explicit: *}

lemma "\<Sum>{0..n::nat} = n*(n+1) div 2" (is "?P n")
proof (induction n)
  show "?P 0" by simp
next
  fix n assume "?P n"
  thus "?P(Suc n)" by simp
qed

text{* Implicit: *}

lemma "\<Sum>{0..n::nat} = n*(n+1) div 2"
proof (induction n)
print_cases
  case 0
  show ?case by simp
next
  case (Suc n)
thm Suc
  thus ?case by simp
qed

text{* After the induction or cases step,
 the PG menu item Isabelle/Show me/cases displays
 the different cases. *}

text{* Induction with @{text "\<Longrightarrow>"} *}

lemma split_list: "x : set xs \<Longrightarrow> \<exists>ys zs. xs = ys @ x # zs"
proof (induction xs)
  case Nil thus ?case by simp
next
print_cases
  case (Cons a xs)
thm Cons.IH --"Induction hypothesis"
thm Cons.prems --"Premises of the step case"
thm Cons
  from Cons.prems have "x = a \<or> x : set xs" by simp
  thus ?case
  proof
    assume "x = a"
    hence "a#xs = [] @ x # xs" by simp
    thus ?thesis by blast
  next
    assume "x : set xs"
    then obtain ys zs where "xs = ys @ x # zs" using Cons.IH by auto
    hence "a#xs = (a#ys) @ x # zs" by simp
    thus ?thesis by blast
  qed
qed

subsection{*Rule induction*}

inductive ev :: "nat => bool" where
ev0:  "ev 0" |
evSS:  "ev n \<Longrightarrow> ev(Suc(Suc n))"

declare ev.intros [simp]

lemma "ev n \<Longrightarrow> \<exists>k. n = 2*k"
proof (induction rule: ev.induct)
  case ev0 show ?case by simp
next
  case evSS thus ?case by arith
qed

lemma "ev n \<Longrightarrow> \<exists>k. n = 2*k"
proof (induction rule: ev.induct)
  case ev0 show ?case by simp
next
  case (evSS m)
thm evSS
thm evSS.IH
thm evSS.hyps
  then obtain k where "m = 2*k" by blast
  hence "Suc(Suc m) = 2*(k+1)" by simp
  thus "\<exists>k. Suc(Suc m) = 2*k" by blast
qed

subsection{*Inductive definition of the reflexive transitive closure *}

consts step :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<rightarrow>" 55)

inductive steps :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<rightarrow>*" 55) where
refl: "x \<rightarrow>* x" |
step: "\<lbrakk> x \<rightarrow> y; y \<rightarrow>* z \<rbrakk> \<Longrightarrow> x \<rightarrow>* z"

declare refl[simp, intro]

text{* Explicit and by hand: *}

lemma "x \<rightarrow>* y  \<Longrightarrow>  y \<rightarrow>* z \<Longrightarrow> x \<rightarrow>* z"
proof(induction rule: steps.induct)
  fix x assume "x \<rightarrow>* z"
  thus "x \<rightarrow>* z" . --"by assumption"
next
  fix x' x y :: 'a
  assume "x' \<rightarrow> x" and "x \<rightarrow>* y"
  assume IH: "y \<rightarrow>* z \<Longrightarrow> x \<rightarrow>* z"
  assume "y \<rightarrow>* z"
  show "x' \<rightarrow>* z" by(rule step[OF `x' \<rightarrow> x` IH[OF `y\<rightarrow>*z`]])
qed

text{* Implicit and automatic: *}

lemma "x \<rightarrow>* y  \<Longrightarrow>  y \<rightarrow>* z \<Longrightarrow> x \<rightarrow>* z"
proof(induction rule: steps.induct)
  case refl thus ?case .
next
  case (step x' x y)
  --"x' x y not used in proof text, just for demo"
thm step
thm step.IH
thm step.hyps
thm step.prems
  show ?case
    by (metis step.hyps(1) step.IH step.prems steps.step)
qed

subsection{*Rule inversion*}

lemma assumes "ev n" shows "ev(n - 2)"
proof-
  from `ev n` show "ev(n - 2)"
  proof cases
    case ev0
thm ev0
    then show ?thesis by simp
  next
    case (evSS k)
thm evSS
    then show ?thesis by simp
  qed
qed

text{* Impossible cases are proved automatically: *}

lemma "\<not> ev(Suc 0)"
proof
  assume "ev(Suc 0)"
  then show False
  proof cases
  qed
qed

end


(* Author: Maximilian Schäffeler *)

theory Policy_Iteration
  imports "MDP-Rewards.MDP_reward"

begin

section \<open>Policy Iteration\<close>
text \<open>
The Policy Iteration algorithms provides another way to find optimal policies under the expected
total reward criterion.
It differs from Value Iteration in that it continuously improves an initial guess for an optimal
decision rule. Its execution can be subdivided into two alternating steps: policy evaluation and
policy improvement.

Policy evaluation means the calculation of the value of the current decision rule.

During the improvement phase, we choose the decision rule with the maximum value for L,
while we prefer to keep the old action selection in case of ties.
\<close>

context MDP_att_\<L> begin
definition "policy_eval d = \<nu>\<^sub>b (mk_stationary_det d)"
end

context MDP_act_disc
begin

definition "policy_improvement d v s = (
  if is_arg_max (\<lambda>a. L\<^sub>a a (apply_bfun v) s) (\<lambda>a. a \<in> A s) (d s)
  then d s
  else arb_act (opt_acts v s))"

definition "policy_step d = policy_improvement d (policy_eval d)"

(* todo: move check is_dec_det outside the recursion *)
function policy_iteration :: "('s \<Rightarrow> 'a) \<Rightarrow> ('s \<Rightarrow> 'a)" where
  "policy_iteration d = (
  let d' = policy_step d in
  if d = d' \<or> \<not>is_dec_det d then d else policy_iteration d')"
  by auto

text \<open>
The policy iteration algorithm as stated above does require that the supremum in @{const \<L>\<^sub>b} is
always attained.
\<close>

text \<open>
Each policy improvement returns a valid decision rule.
\<close>
lemma is_dec_det_pi: "is_dec_det (policy_improvement d v)"
  unfolding policy_improvement_def is_dec_det_def is_arg_max_def
  by (auto simp: some_opt_acts_in_A)

lemma policy_improvement_is_dec_det: "d \<in> D\<^sub>D \<Longrightarrow> policy_improvement d v \<in> D\<^sub>D"
  unfolding policy_improvement_def is_dec_det_def
  using some_opt_acts_in_A
  by auto

lemma policy_improvement_improving:
  assumes "d \<in> D\<^sub>D"
  shows "\<nu>_improving v (mk_dec_det (policy_improvement d v))"
proof -
  have "\<L>\<^sub>b v x = L (mk_dec_det (policy_improvement d v)) v x" for x
    using is_opt_act_some
    by (fastforce simp: \<L>\<^sub>b_eq_argmax_L\<^sub>a L_eq_L\<^sub>a_det is_opt_act_def policy_improvement_def arg_max_SUP)
  thus ?thesis
    using policy_improvement_is_dec_det assms by (auto simp: \<nu>_improving_alt)
qed

lemma eval_policy_step_L:
 "is_dec_det d \<Longrightarrow> L (mk_dec_det (policy_step d)) (policy_eval d) = \<L>\<^sub>b (policy_eval d)"
  by (auto simp: policy_step_def \<nu>_improving_imp_\<L>\<^sub>b[OF policy_improvement_improving])

text \<open> The sequence of policies generated by policy iteration has monotonically increasing
discounted reward.\<close>
lemma policy_eval_mon:
  assumes "is_dec_det d"
  shows "policy_eval d \<le> policy_eval (policy_step d)"
proof -
  let ?d' = "mk_dec_det (policy_step d)"
  let ?dp = "mk_stationary_det d"
  let ?P = "\<Sum>t. l ^ t *\<^sub>R \<P>\<^sub>1 ?d' ^^ t"

  have "L (mk_dec_det d) (policy_eval d) \<le> L ?d' (policy_eval d)"
    using assms by (auto simp: L_le_\<L>\<^sub>b eval_policy_step_L)
  hence "policy_eval d \<le> L ?d' (policy_eval d)"
    using L_\<nu>_fix policy_eval_def by auto
  hence "\<nu>\<^sub>b ?dp \<le> r_dec\<^sub>b ?d' + l *\<^sub>R \<P>\<^sub>1 ?d' (\<nu>\<^sub>b ?dp)"
    unfolding policy_eval_def L_def by auto
  hence "(id_blinfun - l *\<^sub>R \<P>\<^sub>1 ?d') (\<nu>\<^sub>b ?dp) \<le> r_dec\<^sub>b ?d'"
    by (simp add: blinfun.diff_left diff_le_eq scaleR_blinfun.rep_eq)
  hence "?P ((id_blinfun - l *\<^sub>R \<P>\<^sub>1 ?d') (\<nu>\<^sub>b ?dp)) \<le> ?P (r_dec\<^sub>b ?d')"
    using lemma_6_1_2_b by auto
  hence "\<nu>\<^sub>b ?dp \<le> ?P (r_dec\<^sub>b ?d')"
    using inv_norm_le'(2)[OF norm_\<P>\<^sub>1_l_less] by (auto simp: blincomp_scaleR_right)
  thus ?thesis
    by (auto simp: policy_eval_def \<nu>_stationary)
qed

text \<open>
If policy iteration terminates, i.e. @{term "d = policy_step d"}, then it does so with optimal value.
\<close>
lemma policy_step_eq_imp_opt:
  assumes "is_dec_det d" "d = policy_step d"
  shows "\<nu>\<^sub>b (mk_stationary_det d) = \<nu>\<^sub>b_opt"
  using L_\<nu>_fix assms eval_policy_step_L[unfolded policy_eval_def]
  by (fastforce intro: \<L>_fix_imp_opt)

end

text \<open>We prove termination of policy iteration only if both the state and action sets are finite.\<close>
locale MDP_PI_finite = MDP_act_disc arb_act A K r l
  for
    A and
    K :: "'s ::countable \<times> 'a ::countable \<Rightarrow> 's pmf" and r l arb_act +
  assumes fin_states: "finite (UNIV :: 's set)" and fin_actions: "\<And>s. finite (A s)"
begin

text \<open>If the state and action sets are both finite,
  then so is the set of deterministic decision rules @{const "D\<^sub>D"}\<close>
lemma finite_D\<^sub>D[simp]: "finite D\<^sub>D"
proof -
  let ?set = "{d. \<forall>x :: 's. (x \<in> UNIV \<longrightarrow> d x \<in> (\<Union>s. A s)) \<and> (x \<notin> UNIV \<longrightarrow> d x = undefined)}"
  have "finite (\<Union>s. A s)"
    using fin_actions fin_states by blast
  hence "finite ?set"
    using fin_states by (fastforce intro: finite_set_of_finite_funs)
  moreover have "D\<^sub>D \<subseteq> ?set"
    unfolding is_dec_det_def by auto
  ultimately show ?thesis
    using finite_subset by auto
qed

lemma finite_rel: "finite {(u, v). is_dec_det u \<and> is_dec_det v \<and> \<nu>\<^sub>b (mk_stationary_det u) >
  \<nu>\<^sub>b (mk_stationary_det v)}"
proof-
  have aux: "finite {(u, v). is_dec_det u \<and> is_dec_det v}"
    by auto
  show ?thesis
    by (auto intro: finite_subset[OF _ aux])
qed

text \<open>
This auxiliary lemma shows that policy iteration terminates if no improvement to the value of
the policy could be made, as then the policy remains unchanged.
\<close>
lemma eval_eq_imp_policy_eq:
  assumes "policy_eval d = policy_eval (policy_step d)" "is_dec_det d"
  shows "d = policy_step d"
proof -
  have "policy_eval d s = policy_eval (policy_step d) s" for s
    using assms by auto
  have "policy_eval d = L (mk_dec_det d) (policy_eval (policy_step d))"
    unfolding policy_eval_def
    using L_\<nu>_fix
    by (auto simp: assms(1)[symmetric, unfolded policy_eval_def])
  hence "policy_eval d = \<L>\<^sub>b (policy_eval d)"
    by (metis L_\<nu>_fix policy_eval_def assms eval_policy_step_L)
  hence "L (mk_dec_det d) (policy_eval d) s = \<L>\<^sub>b (policy_eval d) s" for s
    using \<open>policy_eval d = L (mk_dec_det d) (policy_eval (policy_step d))\<close> assms(1) by auto
  hence "is_arg_max (\<lambda>a. L\<^sub>a a (\<nu>\<^sub>b (mk_stationary (mk_dec_det d))) s) (\<lambda>a. a \<in> A s) (d s)" for s
    unfolding L_eq_L\<^sub>a_det
    unfolding policy_eval_def \<L>\<^sub>b.rep_eq \<L>_eq_SUP_det SUP_step_det_eq
    using assms(2) is_dec_det_def L\<^sub>a_le
    by (auto intro!: SUP_is_arg_max boundedI bounded_imp_bdd_above)
  thus ?thesis
    unfolding policy_eval_def policy_step_def policy_improvement_def
    by auto
qed

text \<open>
We are now ready to prove termination in the context of finite state-action spaces.
Intuitively, the algorithm terminates as there are only finitely many decision rules,
and in each recursive call the value of the decision rule increases.
\<close>
termination policy_iteration
proof (relation "{(u, v). u \<in> D\<^sub>D \<and> v \<in> D\<^sub>D \<and> \<nu>\<^sub>b (mk_stationary_det u) > \<nu>\<^sub>b (mk_stationary_det v)}")
  show "wf {(u, v). u \<in> D\<^sub>D \<and> v \<in> D\<^sub>D \<and> \<nu>\<^sub>b (mk_stationary_det v) < \<nu>\<^sub>b (mk_stationary_det u)}"
    using finite_rel by (auto intro!: finite_acyclic_wf acyclicI_order)
next
  fix d x
  assume h: "x = policy_step d" "\<not> (d = x \<or> \<not> is_dec_det d)"
  have "is_dec_det d \<Longrightarrow> \<nu>\<^sub>b (mk_stationary_det d) \<le> \<nu>\<^sub>b (mk_stationary_det (policy_step d))"
    using policy_eval_mon by (simp add: policy_eval_def)
  hence "is_dec_det d \<Longrightarrow> d \<noteq> policy_step d \<Longrightarrow>
    \<nu>\<^sub>b (mk_stationary_det d) < \<nu>\<^sub>b (mk_stationary_det (policy_step d))"
    using eval_eq_imp_policy_eq policy_eval_def
    by (force intro!: order.not_eq_order_implies_strict)
  thus "(x, d) \<in> {(u, v). u \<in> D\<^sub>D \<and> v \<in> D\<^sub>D \<and> \<nu>\<^sub>b (mk_stationary_det v) < \<nu>\<^sub>b (mk_stationary_det u)}"
    using is_dec_det_pi policy_step_def h by auto
qed

text \<open>
The termination proof gives us access to the induction rule/simplification lemmas associated
with the @{const policy_iteration} definition.
Thus we can prove that the algorithm finds an optimal policy.
\<close>

lemma is_dec_det_pi': "d \<in> D\<^sub>D \<Longrightarrow> is_dec_det (policy_iteration d)"
  using is_dec_det_pi
  by (induction d rule: policy_iteration.induct) (auto simp: Let_def policy_step_def)

lemma pi_pi[simp]: "d \<in> D\<^sub>D \<Longrightarrow> policy_step (policy_iteration d) = policy_iteration d"
  using is_dec_det_pi
  by (induction d rule: policy_iteration.induct) (auto simp: policy_step_def Let_def)

lemma policy_iteration_correct:
  "d \<in> D\<^sub>D \<Longrightarrow> \<nu>\<^sub>b (mk_stationary_det (policy_iteration d)) = \<nu>\<^sub>b_opt"
  by (induction d rule: policy_iteration.induct)
    (fastforce intro!: policy_step_eq_imp_opt is_dec_det_pi' simp del: policy_iteration.simps)
end

context MDP_finite_type begin
text \<open>
The following proofs concern code generation, i.e. how to represent @{const \<P>\<^sub>1} as a matrix.
\<close>

sublocale MDP_att_\<L>
  by (auto simp: A_ne finite_is_arg_max MDP_att_\<L>_def MDP_att_\<L>_axioms_def max_L_ex_def
      has_arg_max_def MDP_reward_disc_axioms)

definition "fun_to_matrix f = matrix (\<lambda>v. (\<chi> j. f (vec_nth v) j))"
definition "Ek_mat d = fun_to_matrix (\<lambda>v. ((\<P>\<^sub>1 d) (Bfun v)))"
definition "nu_inv_mat d = fun_to_matrix ((\<lambda>v. ((id_blinfun - l *\<^sub>R \<P>\<^sub>1 d) (Bfun v))))"
definition "nu_mat d = fun_to_matrix (\<lambda>v. ((\<Sum>i. (l *\<^sub>R \<P>\<^sub>1 d) ^^ i) (Bfun v)))"

lemma apply_nu_inv_mat:
  "(id_blinfun - l *\<^sub>R \<P>\<^sub>1 d) v = Bfun (\<lambda>i. ((nu_inv_mat d) *v (vec_lambda v)) $ i)"
proof -
  have eq_onpI: "P x \<Longrightarrow> eq_onp P x x" for P x
    by(simp add: eq_onp_def)

  have "Real_Vector_Spaces.linear (\<lambda>v. vec_lambda (((id_blinfun - l *\<^sub>R \<P>\<^sub>1 d) (bfun.Bfun (($) v)))))"
    by (auto simp del: real_scaleR_def intro: linearI
        simp: scaleR_vec_def eq_onpI plus_vec_def vec_lambda_inverse plus_bfun.abs_eq[symmetric]
        scaleR_bfun.abs_eq[symmetric] blinfun.scaleR_right blinfun.add_right)
  thus ?thesis
    unfolding Ek_mat_def fun_to_matrix_def nu_inv_mat_def
    by (auto simp: apply_bfun_inverse vec_lambda_inverse)
qed

lemma bounded_linear_vec_lambda: "bounded_linear (\<lambda>x. vec_lambda (x :: 's \<Rightarrow>\<^sub>b real))"
proof (intro bounded_linear_intro)
  fix x :: "'s \<Rightarrow>\<^sub>b real"
  have "sqrt (\<Sum> i \<in> UNIV . (apply_bfun x i)\<^sup>2) \<le> (\<Sum> i \<in> UNIV . \<bar>(apply_bfun x i)\<bar>)"
    using L2_set_le_sum_abs
    unfolding L2_set_def
    by auto
  also have "(\<Sum> i \<in> UNIV . \<bar>(apply_bfun x i)\<bar>) \<le> (card (UNIV :: 's set) * (\<Squnion>xa. \<bar>apply_bfun x xa\<bar>))"
    by (auto intro!: cSup_upper sum_bounded_above)
  finally show "norm (vec_lambda (apply_bfun x)) \<le> norm x * CARD('s)"
    unfolding norm_vec_def norm_bfun_def dist_bfun_def L2_set_def
    by (auto simp add: mult.commute)
qed (auto simp: plus_vec_def scaleR_vec_def)

lemma bounded_linear_vec_lambda_blinfun:
  fixes f :: "('s \<Rightarrow>\<^sub>b real) \<Rightarrow>\<^sub>L ('s \<Rightarrow>\<^sub>b real)"
  shows "bounded_linear (\<lambda>v. vec_lambda (apply_bfun (blinfun_apply f (bfun.Bfun (($) v)))))"
  using blinfun.bounded_linear_right
  by (fastforce intro: bounded_linear_compose[OF bounded_linear_vec_lambda]
      bounded_linear_bfun_nth bounded_linear_compose[of f])

lemma invertible_nu_inv_max: "invertible (nu_inv_mat d)"
  unfolding nu_inv_mat_def fun_to_matrix_def
  by (auto simp: matrix_invertible inv_norm_le' vec_lambda_inverse apply_bfun_inverse
      bounded_linear.linear[OF bounded_linear_vec_lambda_blinfun]
      intro!: exI[of _ "\<lambda>v. (\<chi> j. (\<lambda>v. (\<Sum>i. (l *\<^sub>R \<P>\<^sub>1 d) ^^ i) (Bfun v)) (vec_nth v) j)"])
end

locale MDP_ord = MDP_finite_type A K r l
  for A and
    K :: "'s :: {finite, wellorder} \<times> 'a :: {finite, wellorder} \<Rightarrow> 's pmf"
    and r l
begin

lemma \<L>_fin_eq_det: "\<L> v s = (\<Squnion>a \<in> A s. L\<^sub>a a v s)"
  by (simp add: SUP_step_det_eq \<L>_eq_SUP_det)

lemma \<L>\<^sub>b_fin_eq_det: "\<L>\<^sub>b v s = (\<Squnion>a \<in> A s. L\<^sub>a a v s)"
  by (simp add: SUP_step_det_eq \<L>\<^sub>b.rep_eq \<L>_eq_SUP_det)

sublocale MDP_PI_finite A K r l "\<lambda>X. Least (\<lambda>x. x \<in> X)"
  by unfold_locales (auto intro: LeastI)

end

end


(*
  File: Quicksort.thy
  Author: Bohua Zhan
*)

section \<open>Quicksort\<close>

theory Quicksort
  imports Arrays_Ex
begin

text \<open>
  Functional version of quicksort.

  Implementation of quicksort is largely based on theory
  Imperative\_Quicksort in HOL/Imperative\_HOL/ex in the Isabelle
  library.
\<close>

subsection \<open>Outer remains\<close>

definition outer_remains :: "'a list \<Rightarrow> 'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where [rewrite]:
  "outer_remains xs xs' l r \<longleftrightarrow> (length xs = length xs' \<and> (\<forall>i. i < l \<or> r < i \<longrightarrow> xs ! i = xs' ! i))"

lemma outer_remains_length [forward]:
  "outer_remains xs xs' l r \<Longrightarrow> length xs = length xs'" by auto2

lemma outer_remains_eq [rewrite_back]:
  "outer_remains xs xs' l r \<Longrightarrow> i < l \<Longrightarrow> xs ! i = xs' ! i"
  "outer_remains xs xs' l r \<Longrightarrow> r < i \<Longrightarrow> xs ! i = xs' ! i" by auto2+

lemma outer_remains_sublist [backward2]:
  "outer_remains xs xs' l r \<Longrightarrow> i < l \<Longrightarrow> take i xs = take i xs'"
  "outer_remains xs xs' l r \<Longrightarrow> r < i \<Longrightarrow> drop i xs = drop i xs'"
  "i \<le> j \<Longrightarrow> j \<le> length xs \<Longrightarrow> outer_remains xs xs' l r \<Longrightarrow> j \<le> l \<Longrightarrow> sublist i j xs = sublist i j xs'"
  "i \<le> j \<Longrightarrow> j \<le> length xs \<Longrightarrow> outer_remains xs xs' l r \<Longrightarrow> i > r \<Longrightarrow> sublist i j xs = sublist i j xs'" by auto2+
setup \<open>del_prfstep_thm_eqforward @{thm outer_remains_def}\<close>

subsection \<open>part1 function\<close>

function part1 :: "('a::linorder) list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> (nat \<times> 'a list)" where
  "part1 xs l r a = (
     if r \<le> l then (r, xs)
     else if xs ! l \<le> a then part1 xs (l + 1) r a
     else part1 (list_swap xs l r) l (r - 1) a)"
  by auto
  termination by (relation "measure (\<lambda>(_,l,r,_). r - l)") auto
setup \<open>register_wellform_data ("part1 xs l r a", ["r < length xs"])\<close>
setup \<open>add_prfstep_check_req ("part1 xs l r a", "r < length xs")\<close>

lemma part1_basic:
  "r < length xs \<Longrightarrow> l \<le> r \<Longrightarrow> (rs, xs') = part1 xs l r a \<Longrightarrow>
   outer_remains xs xs' l r \<and> mset xs' = mset xs \<and> l \<le> rs \<and> rs \<le> r"
@proof @fun_induct "part1 xs l r a" @unfold "part1 xs l r a" @qed
setup \<open>add_forward_prfstep_cond @{thm part1_basic} [with_term "part1 ?xs ?l ?r ?a"]\<close>

lemma part1_partitions1 [backward]:
  "r < length xs \<Longrightarrow> (rs, xs') = part1 xs l r a \<Longrightarrow> l \<le> i \<Longrightarrow> i < rs \<Longrightarrow> xs' ! i \<le> a"
@proof @fun_induct "part1 xs l r a" @unfold "part1 xs l r a" @qed

lemma part1_partitions2 [backward]:
  "r < length xs \<Longrightarrow> (rs, xs') = part1 xs l r a \<Longrightarrow> rs < i \<Longrightarrow> i \<le> r \<Longrightarrow> xs' ! i \<ge> a"
@proof @fun_induct "part1 xs l r a" @unfold "part1 xs l r a" @qed

subsection \<open>Paritition function\<close>

definition partition :: "('a::linorder list) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> 'a list)" where [rewrite]:
  "partition xs l r = (
    let p = xs ! r;
      (m, xs') = part1 xs l (r - 1) p;
      m' = if xs' ! m \<le> p then m + 1 else m
    in
      (m', list_swap xs' m' r))"
setup \<open>register_wellform_data ("partition xs l r", ["l < r", "r < length xs"])\<close>

lemma partition_basic:
  "l < r \<Longrightarrow> r < length xs \<Longrightarrow> (rs, xs') = partition xs l r \<Longrightarrow>
   outer_remains xs xs' l r \<and> mset xs' = mset xs \<and> l \<le> rs \<and> rs \<le> r" by auto2
setup \<open>add_forward_prfstep_cond @{thm partition_basic} [with_term "partition ?xs ?l ?r"]\<close>

lemma partition_partitions1 [forward]:
  "l < r \<Longrightarrow> r < length xs \<Longrightarrow> (rs, xs') = partition xs l r \<Longrightarrow>
   x \<in> set (sublist l rs xs') \<Longrightarrow> x \<le> xs' ! rs"
@proof @obtain i where "i \<ge> l" "i < rs" "x = xs' ! i" @qed

lemma partition_partitions2 [forward]:
  "l < r \<Longrightarrow> r < length xs \<Longrightarrow> (rs, xs'') = partition xs l r \<Longrightarrow>
   x \<in> set (sublist (rs + 1) (r + 1) xs'') \<Longrightarrow> x \<ge> xs'' ! rs"
@proof
  @obtain i where "i \<ge> rs + 1" "i < r + 1" "x = xs'' ! i"
  @let "p = xs ! r"
  @let "m = fst (part1 xs l (r - 1) p)"
  @let "xs' = snd (part1 xs l (r - 1) p)"
  @case "xs' ! m \<le> p"
@qed
setup \<open>del_prfstep_thm @{thm partition_def}\<close>

lemma quicksort_term1:
  "\<not>r \<le> l \<Longrightarrow> \<not> length xs \<le> r \<Longrightarrow> x = partition xs l r \<Longrightarrow> (p, xs1) = x \<Longrightarrow> p - Suc l < r - l"
@proof @have "fst (partition xs l r) - l - 1 < r - l" @qed

lemma quicksort_term2:
  "\<not>r \<le> l \<Longrightarrow> \<not> length xs \<le> r \<Longrightarrow> x = partition xs l r \<Longrightarrow> (p, xs2) = x \<Longrightarrow> r - Suc p < r - l"
@proof @have "r - fst (partition xs l r) - 1 < r - l" @qed

subsection \<open>Quicksort function\<close>

function quicksort :: "('a::linorder) list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list" where
  "quicksort xs l r = (
    if l \<ge> r then xs
    else if r \<ge> length xs then xs
    else let
      (p, xs1) = partition xs l r;
      xs2 = quicksort xs1 l (p - 1)
    in
      quicksort xs2 (p + 1) r)"
  by auto termination apply (relation "measure (\<lambda>(a, l, r). (r - l))")
  by (auto simp add: quicksort_term1 quicksort_term2)

lemma quicksort_basic [rewrite_arg]:
  "mset (quicksort xs l r) = mset xs \<and> outer_remains xs (quicksort xs l r) l r"
@proof @fun_induct "quicksort xs l r" @unfold "quicksort xs l r" @qed

lemma quicksort_trivial1 [rewrite]:
  "l \<ge> r \<Longrightarrow> quicksort xs l r = xs"
@proof @unfold "quicksort xs l r" @qed

lemma quicksort_trivial2 [rewrite]:
  "r \<ge> length xs \<Longrightarrow> quicksort xs l r = xs"
@proof @unfold "quicksort xs l r" @qed

lemma quicksort_permutes [resolve]:
  "xs' = quicksort xs l r \<Longrightarrow> set (sublist l (r + 1) xs') = set (sublist l (r + 1) xs)"
@proof
  @case "l \<ge> r" @case "r \<ge> length xs"
  @have "xs = take l xs @ sublist l (r + 1) xs @ drop (r + 1) xs"
  @have "xs' = take l xs' @ sublist l (r + 1) xs' @ drop (r + 1) xs'"
  @have "take l xs = take l xs'"
  @have "drop (r + 1) xs = drop (r + 1) xs'"
@qed

lemma quicksort_sorts [forward_arg]:
  "r < length xs \<Longrightarrow> sorted (sublist l (r + 1) (quicksort xs l r))"
@proof @fun_induct "quicksort xs l r"
  @case "l \<ge> r" @with @case "l = r" @end
  @case "r \<ge> length xs"
  @let "p = fst (partition xs l r)"
  @let "xs1 = snd (partition xs l r)"
  @let "xs2 = quicksort xs1 l (p - 1)"
  @let "xs3 = quicksort xs2 (p + 1) r"
  @have "sorted (sublist l (r + 1) xs3)" @with
    @have "l \<le> p" @have "p + 1 \<le> r + 1" @have "r + 1 \<le> length xs3"
    @have "sublist l p xs2 = sublist l p xs3"
    @have "set (sublist l p xs1) = set (sublist l p xs2)"
    @have "sublist (p + 1) (r + 1) xs1 = sublist (p + 1) (r + 1) xs2"
    @have "set (sublist (p + 1) (r + 1) xs2) = set (sublist (p + 1) (r + 1) xs3)"
    @have "\<forall>x\<in>set (sublist l p xs3). x \<le> xs3 ! p"
    @have "\<forall>x\<in>set (sublist (p + 1) (r + 1) xs3). x \<ge> xs3 ! p"
    @have "sorted (sublist l p xs3)"
    @have "sorted (sublist (p + 1) (r + 1) xs3)"
    @have "sublist l (r + 1) xs3 = sublist l p xs3 @ (xs3 ! p) # sublist (p + 1) (r + 1) xs3"
  @end
  @unfold "quicksort xs l r"
@qed

text \<open>Main result: correctness of functional quicksort.\<close>
theorem quicksort_sorts_all [rewrite]:
  "xs \<noteq> [] \<Longrightarrow> quicksort xs 0 (length xs - 1) = sort xs"
@proof
  @let "xs' = quicksort xs 0 (length xs - 1)"
  @have "sublist 0 (length xs - 1 + 1) xs' = xs'"
@qed

end


(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

header {* Fixed-points *}

theory OrdinalFix
imports OrdinalInverse
begin

primrec iter :: "nat \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)"
where
  "iter 0       F x = x"
| "iter (Suc n) F x = F (iter n F x)"

definition
  oFix :: "(ordinal \<Rightarrow> ordinal) \<Rightarrow> ordinal \<Rightarrow> ordinal" where
  "oFix F a = oLimit (\<lambda>n. iter n F a)"

lemma oFix_fixed:
"\<lbrakk>continuous F; a \<le> F a\<rbrakk> \<Longrightarrow> F (oFix F a) = oFix F a"
 apply (unfold oFix_def)
 apply (simp only: continuousD)
 apply (rule order_antisym)
  apply (rule oLimit_leI, clarify)
  apply (rule_tac n="Suc n" in le_oLimitI, simp)
 apply (rule oLimit_leI, clarify)
 apply (rule_tac n=n in le_oLimitI)
 apply (induct_tac n, simp)
 apply (simp add: continuous.monoD)
done

lemma oFix_least:
"\<lbrakk>mono F; F x = x; a \<le> x\<rbrakk> \<Longrightarrow> oFix F a \<le> x"
 apply (unfold oFix_def)
 apply (rule oLimit_leI, clarify)
 apply (induct_tac n, simp_all)
 apply (erule subst)
 apply (erule monoD, assumption)
done

lemma mono_oFix: "mono F \<Longrightarrow> mono (oFix F)"
 apply (rule monoI, unfold oFix_def)
 apply (subgoal_tac "\<forall>n. iter n F x \<le> iter n F y")
  apply (rule oLimit_leI, clarify)
  apply (rule_tac n=n in le_oLimitI, erule spec)
 apply (rule allI, induct_tac n)
  apply simp
 apply (simp add: monoD)
done

lemma less_oFixD:
"\<lbrakk>x < oFix F a; mono F; F x = x\<rbrakk> \<Longrightarrow> x < a"
 apply (simp add: linorder_not_le[symmetric])
 apply (erule contrapos_nn)
by (rule oFix_least)

lemma less_oFixI: "a < F a \<Longrightarrow> a < oFix F a"
 apply (unfold oFix_def)
 apply (erule order_less_le_trans)
 apply (rule_tac n=1 in le_oLimitI)
 apply simp
done

lemma le_oFix: "a \<le> oFix F a"
 apply (unfold oFix_def)
 apply (rule_tac n=0 in le_oLimitI)
 apply simp
done

lemma le_oFix1: "F a \<le> oFix F a"
 apply (unfold oFix_def)
 apply (rule_tac n=1 in le_oLimitI)
 apply simp
done

lemma less_oFix_0D:
"\<lbrakk>x < oFix F 0; mono F\<rbrakk> \<Longrightarrow> x < F x"
 apply (unfold oFix_def, drule less_oLimitD, clarify)
 apply (erule_tac P="x < iter n F 0" in rev_mp)
 apply (induct_tac n, auto simp add: linorder_not_less)
 apply (erule order_less_le_trans)
 apply (erule monoD, assumption)
done

lemma zero_less_oFix_eq: "(0 < oFix F 0) = (0 < F 0)"
 apply (safe)
  apply (erule contrapos_pp)
  apply (simp only: linorder_not_less oFix_def)
  apply (rule oLimit_leI[rule_format])
  apply (induct_tac n, simp, simp)
 apply (erule less_oFixI)
done

lemma oFix_eq_self: "F a = a \<Longrightarrow> oFix F a = a"
 apply (unfold oFix_def)
 apply (subgoal_tac "\<forall>n. iter n F a = a", simp)
 apply (rule allI, induct_tac n, simp_all)
done

subsection {* Derivatives of ordinal functions *}

text "The derivative of F enumerates all the fixed-points of F"

definition
  oDeriv :: "(ordinal \<Rightarrow> ordinal) \<Rightarrow> ordinal \<Rightarrow> ordinal" where
  "oDeriv F = ordinal_rec (oFix F 0) (\<lambda>p x. oFix F (oSuc x))"

lemma oDeriv_0 [simp]:
"oDeriv F 0 = oFix F 0"
by (simp add: oDeriv_def)

lemma oDeriv_oSuc [simp]:
"oDeriv F (oSuc x) = oFix F (oSuc (oDeriv F x))"
by (simp add: oDeriv_def)

lemma oDeriv_oLimit [simp]:
"oDeriv F (oLimit f) = oLimit (\<lambda>n. oDeriv F (f n))"
 apply (unfold oDeriv_def)
 apply (rule ordinal_rec_oLimit, clarify)
 apply (rule order_trans[OF order_less_imp_le[OF less_oSuc]])
 apply (rule le_oFix)
done

lemma oDeriv_fixed:
"normal F \<Longrightarrow> F (oDeriv F n) = oDeriv F n"
 apply (rule_tac a=n in oLimit_induct, simp_all)
   apply (rule oFix_fixed)
    apply (erule normal.continuous)
   apply simp
  apply (rule oFix_fixed)
   apply (erule normal.continuous)
  apply (erule normal.increasing)
 apply (simp add: normal.oLimit)
done

lemma oDeriv_fixedD:
"\<lbrakk>oDeriv F x = x; normal F\<rbrakk> \<Longrightarrow> F x = x"
by (erule subst, erule oDeriv_fixed)

lemma normal_oDeriv:
"normal (oDeriv F)"
 apply (rule normalI, simp_all)
 apply (rule order_less_le_trans[OF less_oSuc])
 apply (rule le_oFix)
done

lemma oDeriv_increasing:
"continuous F \<Longrightarrow> F x \<le> oDeriv F x"
 apply (rule_tac a=x in oLimit_induct)
   apply (simp add: le_oFix1)
  apply simp
  apply (rule order_trans[OF _ le_oFix1])
  apply (erule continuous.monoD)
  apply simp
  apply (rule normal.increasing)
  apply (rule normal_oDeriv)
 apply (simp add: continuousD)
 apply (rule oLimit_leI[rule_format])
 apply (rule_tac n=n in le_oLimitI)
 apply (erule spec)
done

lemma oDeriv_total:
"\<lbrakk>normal F; F x = x\<rbrakk> \<Longrightarrow> \<exists>n. x = oDeriv F n"
 apply (subgoal_tac "\<exists>n. oDeriv F n \<le> x \<and> x < oDeriv F (oSuc n)")
  apply clarsimp
  apply (drule less_oFixD)
    apply (erule normal.mono)
   apply assumption
  apply (rule_tac x=n in exI, simp add: less_oSuc_eq_le)
 apply (rule normal.oInv_ex[OF normal_oDeriv])
 apply (simp add: oFix_least normal.mono)
done

lemma range_oDeriv:
"normal F \<Longrightarrow> range (oDeriv F) = {x. F x = x}"
by (auto intro: oDeriv_fixed dest: oDeriv_total)

end


theory HSV_tasks_2022 imports Complex_Main begin

section {* Task 1: Full adders *}

fun fulladder :: "bool * bool * bool \<Rightarrow> bool * bool"
where
  "fulladder (a,b,cin) = (
   let (tmp1, tmp2) = halfadder(a,b) in
   let (tmp3, s) = halfadder(cin,tmp2) in
   let cout = tmp1 | tmp3 in
   (cout, s))"

section {* Task 2: Fifth powers *}

theorem "(n::nat) ^ 5 mod 10 = n mod 10"
  oops

section {* Task 3: Logic optimisation *}

(* Datatype for representing simple circuits. *)
datatype "circuit" =
  NOT "circuit"
| AND "circuit" "circuit"
| OR "circuit" "circuit"
| TRUE
| FALSE
| INPUT "int"

(* Simulates a circuit given a valuation for each input wire. *)
fun simulate where
  "simulate (AND c1 c2) \<rho> = ((simulate c1 \<rho>) \<and> (simulate c2 \<rho>))"
| "simulate (OR c1 c2) \<rho> = ((simulate c1 \<rho>) \<or> (simulate c2 \<rho>))"
| "simulate (NOT c) \<rho> = (\<not> (simulate c \<rho>))"
| "simulate TRUE \<rho> = True"
| "simulate FALSE \<rho> = False"
| "simulate (INPUT i) \<rho> = \<rho> i"

(* Equivalence between circuits. *)
fun circuits_equiv (infix "\<sim>" 50) (* the "50" indicates the operator precedence *) where
  "c1 \<sim> c2 = (\<forall>\<rho>. simulate c1 \<rho> = simulate c2 \<rho>)"

(* An optimisation that exploits the following Boolean identities:
  `a | a = a`
  `a & a = a`
 *)
fun opt_ident where
  "opt_ident (NOT c) = NOT (opt_ident c)"
| "opt_ident (AND c1 c2) = (
   let c1' = opt_ident c1 in
   let c2' = opt_ident c2 in
   if c1' = c2' then c1' else AND c1' c2')"
| "opt_ident (OR c1 c2) = (
   let c1' = opt_ident c1 in
   let c2' = opt_ident c2 in
   if c1' = c2' then c1' else OR c1' c2')"
| "opt_ident TRUE = TRUE"
| "opt_ident FALSE = FALSE"
| "opt_ident (INPUT i) = INPUT i"

lemma (* test case *)
  "opt_ident (AND (INPUT 1) (OR (INPUT 1) (INPUT 1))) = INPUT 1"
by eval

theorem opt_ident_is_sound: "opt_ident c \<sim> c"
  oops

fun area :: "circuit \<Rightarrow> nat" where
  "area (NOT c) = 1 + area c"
| "area (AND c1 c2) = 1 + area c1 + area c2"
| "area (OR c1 c2) = 1 + area c1 + area c2"
| "area _ = 0"

section {* Task 4: More logic optimisation *}

lemma (* test case *)
  "opt_redundancy (AND (INPUT 1) (OR (INPUT 1) (INPUT 2)))
   = INPUT 1"
  (* by eval *) oops
lemma (* test case *)
  "opt_redundancy (AND (AND (INPUT 1) (OR (INPUT 1) (INPUT 2)))
                       (OR (AND (INPUT 1) (OR (INPUT 1) (INPUT 2))) (INPUT 2)))
   = INPUT 1"
  (* by eval *) oops
lemma (* test case *)
  "opt_redundancy (AND (AND (INPUT 1) (OR (INPUT 1) (INPUT 2)))
                       (OR (INPUT 2) (AND (INPUT 1) (OR (INPUT 1) (INPUT 2)))))
   = INPUT 1"
  (* by eval *) oops
lemma (* test case *)
  "opt_redundancy (AND (AND (AND (INPUT 1) (OR (INPUT 1) (INPUT 2)))
                            (OR (INPUT 2) (AND (INPUT 1) (OR (INPUT 1) (INPUT 2)))))
                       (OR (INPUT 1) (INPUT 2)))
  = INPUT 1"
  (* by eval *) oops

end


theory Clauses imports
  Main
  Containers.Containers
begin

type_synonym literal = "nat \<times> bool"
type_synonym clause = "literal set"
type_synonym cnf = "clause set"

datatype bexp
  = Var nat
  | not bexp
  | Or bexp bexp (infixl "or" 110)
  | And bexp bexp (infixl "and" 120)

declare [[coercion Var]] [[coercion_enabled]]

declare SUP_cong_simp[fundef_cong del]
function cnf :: "bexp \<Rightarrow> cnf"
where
  "cnf v = {{(v, True)}}"
| "cnf (b and b') = cnf b \<union> cnf b'"
| "cnf (b or b') = (\<Union>c \<in> cnf b. (\<lambda>c'. c \<union> c') ` cnf b')"
| "cnf (not v) = {{(v, False)}}"
| "cnf (not (not b)) = cnf b"
| "cnf (not (b and b')) = cnf (not b or not b')"
| "cnf (not (b or b')) = cnf (not b and not b')"
by pat_completeness simp_all
termination by(relation "measure (rec_bexp (\<lambda>_. 1) (\<lambda>_ n. 3 * n + 1) (\<lambda>_ _ n m. n + m + 1) (\<lambda>_ _ n m. n + m + 1))") simp_all
declare SUP_cong_simp[fundef_cong]

definition test
where
  "test =
  (1 and 2) or (not 1 and not 2) or
  (3 and 4) or (not 3 and not 4) or
  (5 and 6) or (not 5 and not 6) or
  (7 and 8) or (not 7 and not 8) or
  (9 and 10) or (not 9 and not 10) or
  (11 and 12) or (not 11 and not 12) or
  (1 and 2) or (3 and 4) or
  (1 and 3) or (2 and 4)"

value "cnf test = {}"

text \<open>Sanity check for correctness\<close>

type_synonym env = "nat \<Rightarrow> bool"

primrec eval_bexp :: "env \<Rightarrow> bexp \<Rightarrow> bool" ("_ \<Turnstile> _" [100, 100] 70)
where
  "\<Phi> \<Turnstile> v \<longleftrightarrow> \<Phi> v"
| "\<Phi> \<Turnstile> not b \<longleftrightarrow> \<not> \<Phi> \<Turnstile> b"
| "\<Phi> \<Turnstile> b and b' \<longleftrightarrow> \<Phi> \<Turnstile> b \<and> \<Phi> \<Turnstile> b'"
| "\<Phi> \<Turnstile> b or b' \<longleftrightarrow> \<Phi> \<Turnstile> b \<or> \<Phi> \<Turnstile> b'"

definition eval_cnf :: "env \<Rightarrow> cnf \<Rightarrow> bool" ("_ \<turnstile> _" [100, 100] 70)
where "\<Phi> \<turnstile> F \<longleftrightarrow> (\<forall>C \<in> F. \<exists>(n, b) \<in> C. \<Phi> n = b)"

lemma cnf_correct: "\<Phi> \<turnstile> cnf b \<longleftrightarrow> \<Phi> \<Turnstile> b"
proof(rule sym, induction b rule: cnf.induct)
  case 2 show ?case by(simp add: "2.IH")(auto simp add: eval_cnf_def)
next
  case 3 then show ?case
    by (auto simp add: "3.IH" eval_cnf_def split_beta) blast+
qed(auto simp add: eval_cnf_def)

end


section \<open>Exponentiation of ordinals\<close>

theory Ordinal_Exp
  imports Kirby

begin

text \<open>Source: Schlöder, Julian.  Ordinal Arithmetic; available online at
    \url{http://www.math.uni-bonn.de/ag/logik/teaching/2012WS/Set%20theory/oa.pdf}\<close>

definition oexp :: "[V,V] \<Rightarrow> V" (infixr "\<up>" 80)
  where "oexp a b \<equiv> transrec (\<lambda>f x. if x=0 then 1
                                    else if Limit x then if a=0 then 0 else SUP \<xi> \<in> elts x. f \<xi>
                                    else f (\<Squnion>(elts x)) * a)  b"

text \<open>@{term "0\<up>\<omega> = 1"} if we don't make a special case for Limit ordinals and zero\<close>

lemma oexp_0_right [simp]: "\<alpha>\<up>0 = 1"
  by (simp add: def_transrec [OF oexp_def])

lemma oexp_succ [simp]: "Ord \<beta> \<Longrightarrow> \<alpha>\<up>(succ \<beta>) = \<alpha>\<up>\<beta> * \<alpha>"
  by (simp add: def_transrec [OF oexp_def])

lemma oexp_Limit: "Limit \<beta> \<Longrightarrow> \<alpha>\<up>\<beta> = (if \<alpha>=0 then 0 else SUP \<xi> \<in> elts \<beta>. \<alpha>\<up>\<xi>)"
  by (auto simp: def_transrec [OF oexp_def, of _ \<beta>])

lemma oexp_1_right [simp]: "\<alpha>\<up>1 = \<alpha>"
  using one_V_def oexp_succ by fastforce

lemma oexp_1 [simp]: "Ord \<alpha> \<Longrightarrow> 1\<up>\<alpha> = 1"
  by (induction rule: Ord_induct3) (use Limit_def oexp_Limit in auto)

lemma oexp_0 [simp]: "Ord \<alpha> \<Longrightarrow> 0\<up>\<alpha> = (if \<alpha> = 0 then 1 else 0)"
  by (induction rule: Ord_induct3) (use Limit_def oexp_Limit in auto)

lemma oexp_eq_0_iff [simp]:
  assumes "Ord \<beta>" shows "\<alpha>\<up>\<beta> = 0 \<longleftrightarrow> \<alpha>=0 \<and> \<beta>\<noteq>0"
  using \<open>Ord \<beta>\<close>
proof (induction rule: Ord_induct3)
  case (Limit \<mu>)
  then show ?case
    using Limit_def oexp_Limit by auto
qed auto

lemma oexp_gt_0_iff [simp]:
  assumes "Ord \<beta>" shows "\<alpha>\<up>\<beta> > 0 \<longleftrightarrow> \<alpha>>0 \<or> \<beta>=0"
  by (simp add: assms less_V_def)

lemma ord_of_nat_oexp: "ord_of_nat (m^n) = ord_of_nat m\<up>ord_of_nat n"
proof (induction n)
  case (Suc n)
  then show ?case
    by (simp add: mult.commute [of m]) (simp add: ord_of_nat_mult)
qed auto

lemma omega_closed_oexp [intro]:
  assumes "\<alpha> \<in> elts \<omega>" "\<beta> \<in> elts \<omega>" shows "\<alpha>\<up>\<beta> \<in> elts \<omega>"
proof -
  obtain m n where "\<alpha> = ord_of_nat m" "\<beta> = ord_of_nat n"
    using assms elts_\<omega> by auto
  then have "\<alpha>\<up>\<beta> = ord_of_nat (m^n)"
    by (simp add: ord_of_nat_oexp)
  then show ?thesis
    by (simp add: \<omega>_def)
qed

lemma Ord_oexp [simp]:
  assumes "Ord \<alpha>" "Ord \<beta>" shows "Ord (\<alpha>\<up>\<beta>)"
  using \<open>Ord \<beta>\<close>
proof (induction rule: Ord_induct3)
  case (Limit \<alpha>)
  then show ?case
    by (auto simp: oexp_Limit image_iff intro: Ord_Sup)
qed (auto intro: Ord_mult assms)

text \<open>Lemma 3.19\<close>
lemma le_oexp:
  assumes "Ord \<alpha>" "Ord \<beta>" "\<beta> \<noteq> 0" shows "\<alpha> \<le> \<alpha>\<up>\<beta>"
  using \<open>Ord \<beta>\<close> \<open>\<beta> \<noteq> 0\<close>
proof (induction rule: Ord_induct3)
  case (succ \<beta>)
  then show ?case
    by simp (metis \<open>Ord \<alpha>\<close> le_0 le_mult mult.left_neutral oexp_0_right order_refl order_trans)
next
  case (Limit \<mu>)
  then show ?case
    by (metis Limit_def Limit_eq_Sup_self ZFC_in_HOL.Sup_upper eq_iff image_eqI image_ident oexp_1_right oexp_Limit replacement small_elts one_V_def)
qed auto

text \<open>Lemma 3.20\<close>
lemma le_oexp':
  assumes "Ord \<alpha>" "1 < \<alpha>" "Ord \<beta>" shows "\<beta> \<le> \<alpha>\<up>\<beta>"
proof (cases "\<beta> = 0")
  case True
  then show ?thesis
    by auto
next
  case False
  show ?thesis
    using \<open>Ord \<beta>\<close>
  proof (induction rule: Ord_induct3)
    case 0
    then show ?case
      by auto
  next
    case (succ \<gamma>)
    then have "\<alpha>\<up>\<gamma> * 1 < \<alpha>\<up>\<gamma> * \<alpha>"
      using \<open>Ord \<alpha>\<close> \<open>1 < \<alpha>\<close>
      by (metis le_mult less_V_def mult.right_neutral mult_cancellation not_less_0 oexp_eq_0_iff succ.hyps)
    then have " \<gamma> < \<alpha>\<up>succ \<gamma>"
      using succ.IH succ.hyps by auto
    then show ?case
      using False \<open>Ord \<alpha>\<close> \<open>1 < \<alpha>\<close> succ
      by (metis Ord_mem_iff_lt Ord_oexp Ord_succ elts_succ insert_subset less_eq_V_def less_imp_le)
  next
    case (Limit \<mu>)
    with False \<open>1 < \<alpha>\<close> show ?case
      by (force simp: Limit_def oexp_Limit intro: elts_succ)
  qed
qed

lemma oexp_Limit_le:
  assumes "\<beta> < \<gamma>" "Limit \<gamma>" "Ord \<beta>" "\<alpha> > 0" shows "\<alpha>\<up>\<beta> \<le> \<alpha>\<up>\<gamma>"
proof -
  have "Ord \<gamma>"
    using Limit_def assms(2) by blast
  with assms show ?thesis
    using Ord_mem_iff_lt ZFC_in_HOL.Sup_upper oexp_Limit by auto
qed

proposition oexp_less:
  assumes \<beta>: "\<beta> \<in> elts \<gamma>" and "Ord \<gamma>" and \<alpha>: "\<alpha> > 1" "Ord \<alpha>" shows "\<alpha>\<up>\<beta> < \<alpha>\<up>\<gamma>"
proof -
  obtain "\<beta> < \<gamma>" "Ord \<beta>"
    using Ord_in_Ord OrdmemD assms by auto
  have gt0: "\<alpha>\<up>\<beta> > 0"
    using \<open>Ord \<beta>\<close> \<alpha> dual_order.order_iff_strict by auto
  show ?thesis
    using \<open>Ord \<gamma>\<close> \<beta>
  proof (induction rule: Ord_induct3)
    case 0
    then show ?case
      by auto
  next
    case (succ \<delta>)
    then consider "\<beta> = \<delta>" | "\<beta> < \<delta>"
      using OrdmemD elts_succ by blast
    then show ?case
    proof cases
      case 1
      then have "(\<alpha>\<up>\<beta>) * 1 < (\<alpha>\<up>\<delta>) * \<alpha>"
        using Ord_1 Ord_oexp \<alpha> gt0 mult_cancel_less_iff succ.hyps by metis
      then show ?thesis
        by (simp add: succ.hyps)
    next
      case 2
      then have "(\<alpha>\<up>\<delta>) * 1 < (\<alpha>\<up>\<delta>) * \<alpha>"
        by (meson Ord_1 Ord_mem_iff_lt Ord_oexp \<open>Ord \<beta>\<close> \<alpha> gt0 less_trans mult_cancel_less_iff succ)
      with 2 show ?thesis
        using Ord_mem_iff_lt \<open>Ord \<beta>\<close> succ by auto
    qed
  next
    case (Limit \<gamma>)
    then obtain "Ord \<gamma>" "succ \<beta> < \<gamma>"
      using Limit_def Ord_in_Ord OrdmemD assms by auto
    have "\<alpha>\<up>\<beta> = (\<alpha>\<up>\<beta>) * 1"
      by simp
    also have "\<dots> < (\<alpha>\<up>\<beta>) * \<alpha>"
      using Ord_oexp \<open>Ord \<beta>\<close> assms gt0 mult_cancel_less_iff by blast
    also have "\<dots> = \<alpha>\<up>succ \<beta>"
      by (simp add: \<open>Ord \<beta>\<close>)
    also have "\<dots> \<le> (SUP \<xi> \<in> elts \<gamma>. \<alpha>\<up>\<xi>)"
    proof -
      have "succ \<beta> \<in> elts \<gamma>"
        using Limit.hyps Limit.prems Limit_def by auto
      then show ?thesis
        by (simp add: ZFC_in_HOL.Sup_upper)
    qed
    finally
    have "\<alpha>\<up>\<beta> < (SUP \<xi> \<in> elts \<gamma>. \<alpha>\<up>\<xi>)" .
    then show ?case
      using Limit.hyps oexp_Limit \<open>\<alpha> > 1\<close> by auto
  qed
qed

corollary oexp_less_iff:
  assumes "\<alpha> > 0" "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>" shows "\<alpha>\<up>\<beta> < \<alpha>\<up>\<gamma> \<longleftrightarrow> \<beta> \<in> elts \<gamma> \<and> \<alpha> > 1"
proof safe
  show "\<beta> \<in> elts \<gamma>" "1 < \<alpha>"
    if "\<alpha>\<up>\<beta> < \<alpha>\<up>\<gamma>"
  proof -
    show "\<alpha> > 1"
    proof (rule ccontr)
      assume "\<not> \<alpha> > 1"
      then consider "\<alpha>=0" | "\<alpha>=1"
        using \<open>Ord \<alpha>\<close> less_V_def mem_0_Ord by fastforce
      then show False
        by cases (use that \<open>\<alpha> > 0\<close> \<open>Ord \<beta>\<close> \<open>Ord \<gamma>\<close> in \<open>auto split: if_split_asm\<close>)
    qed
    show \<beta>: "\<beta> \<in> elts \<gamma>"
    proof (rule ccontr)
      assume "\<beta> \<notin> elts \<gamma>"
      then have "\<gamma> \<le> \<beta>"
        by (meson Ord_linear_le Ord_mem_iff_lt assms less_le_not_le)
      then consider "\<gamma> = \<beta>" | "\<gamma> < \<beta>"
        using less_V_def by blast
      then show False
      proof cases
        case 1
        then show ?thesis
          using that by blast
      next
        case 2
        with \<open>\<alpha> > 1\<close> have "\<alpha>\<up>\<gamma> < \<alpha>\<up>\<beta>"
          by (simp add: Ord_mem_iff_lt assms oexp_less)
        with that show ?thesis
          by auto
      qed
    qed
  qed
  show "\<alpha>\<up>\<beta> < \<alpha>\<up>\<gamma>" if "\<beta> \<in> elts \<gamma>" "1 < \<alpha>"
    using that by (simp add: assms oexp_less)
qed

lemma \<omega>_oexp_iff [simp]: "\<lbrakk>Ord \<alpha>; Ord \<beta>\<rbrakk> \<Longrightarrow> \<omega>\<up>\<alpha> = \<omega>\<up>\<beta> \<longleftrightarrow> \<alpha>=\<beta>"
  by (metis Ord_\<omega> Ord_linear \<omega>_gt1 less_irrefl oexp_less)

lemma Limit_oexp:
  assumes "Limit \<gamma>" "Ord \<alpha>" "\<alpha> > 1" shows "Limit (\<alpha>\<up>\<gamma>)"
  unfolding Limit_def
proof safe
  show O\<alpha>\<gamma>: "Ord (\<alpha>\<up>\<gamma>)"
    using Limit_def Ord_oexp \<open>Limit \<gamma>\<close> assms(2) by blast
  show 0: "0 \<in> elts (\<alpha>\<up>\<gamma>)"
    using Limit_def oexp_Limit \<open>Limit \<gamma>\<close> \<open>\<alpha> > 1\<close> by fastforce
  have "Ord \<gamma>"
    using Limit_def \<open>Limit \<gamma>\<close> by blast
  fix x
  assume x: "x \<in> elts (\<alpha>\<up>\<gamma>)"
  with \<open>Limit \<gamma>\<close> \<open>\<alpha> > 1\<close>
  obtain \<beta> where "\<beta> < \<gamma>" "Ord \<beta>" "Ord x" and x\<beta>: "x \<in> elts (\<alpha>\<up>\<beta>)"
    apply (simp add: oexp_Limit split: if_split_asm)
    using Ord_in_Ord OrdmemD \<open>Ord \<gamma>\<close> O\<alpha>\<gamma> x by blast
  then have O\<alpha>\<beta>: "Ord (\<alpha>\<up>\<beta>)"
    using Ord_oexp assms(2) by blast
  have "\<beta> \<in> elts \<gamma>"
    by (simp add: Ord_mem_iff_lt \<open>Ord \<beta>\<close> \<open>Ord \<gamma>\<close> \<open>\<beta> < \<gamma>\<close>)
  moreover have "\<alpha> \<noteq> 0"
    using \<open>\<alpha> > 1\<close> by blast
  ultimately have \<alpha>\<beta>\<gamma>: "\<alpha>\<up>\<beta> \<le> \<alpha>\<up>\<gamma>"
    by (simp add: Sup_upper oexp_Limit \<open>Limit \<gamma>\<close>)
  have "succ x \<le> \<alpha>\<up>\<beta>"
    by (simp add: OrdmemD O\<alpha>\<beta> \<open>Ord x\<close> succ_le_iff x\<beta>)
  then consider "succ x < \<alpha>\<up>\<beta>" | "succ x = \<alpha>\<up>\<beta>"
    using le_neq_trans by blast
  then show "succ x \<in> elts (\<alpha>\<up>\<gamma>)"
  proof cases
    case 1
    with \<alpha>\<beta>\<gamma> show ?thesis
      using O\<alpha>\<beta> Ord_mem_iff_lt \<open>Ord x\<close> by blast
  next
    case 2
    then have "succ \<beta> < \<gamma>"
      using Limit_def OrdmemD \<open>\<beta> \<in> elts \<gamma>\<close> assms(1) by auto
    have ge1: "1 \<le> \<alpha>\<up>\<beta>"
      by (metis "2" Ord_0 \<open>Ord x\<close> le_0 le_succ_iff one_V_def)
    have "succ x < succ (\<alpha>\<up>\<beta>)"
      using "2" O\<alpha>\<beta> succ_le_iff by auto
    also have "\<dots> \<le> (\<alpha>\<up>\<beta>) + (\<alpha>\<up>\<beta>)"
      using ge1 by (simp add: succ_eq_add1)
    also have "\<dots> = (\<alpha>\<up>\<beta>) * succ (succ 0)"
      by (simp add: mult_succ)
    also have "\<dots> \<le> (\<alpha>\<up>\<beta>) * \<alpha>"
      using O\<alpha>\<beta> Ord_succ assms(2) assms(3) one_V_def succ_le_iff by auto
    also have "\<dots> = \<alpha>\<up>succ \<beta>"
      by (simp add: \<open>Ord \<beta>\<close>)
    also have "\<dots> \<le> \<alpha>\<up>\<gamma>"
      by (meson Limit_def \<open>\<beta> \<in> elts \<gamma>\<close> assms dual_order.order_iff_strict oexp_less)
  finally show ?thesis
    by (simp add: "2" O\<alpha>\<beta> O\<alpha>\<gamma> Ord_mem_iff_lt)
  qed
qed

lemma oexp_mono:
  assumes \<alpha>: "Ord \<alpha>" "\<alpha> \<noteq> 0" and \<beta>: "Ord \<beta>" "\<gamma> \<sqsubseteq> \<beta>" shows "\<alpha>\<up>\<gamma> \<le> \<alpha>\<up>\<beta>"
  using \<beta>
proof (induction rule: Ord_induct3)
  case 0
  then show ?case
    by simp
next
  case (succ \<beta>)
  with \<alpha> le_mult show ?case
    by (auto simp: le_TC_succ)
next
  case (Limit \<mu>)
  then have "\<alpha>\<up>\<gamma> \<le> \<Squnion> ((\<up>) \<alpha> ` elts \<mu>)"
    using Limit.hyps Ord_less_TC_mem \<open>\<alpha> \<noteq> 0\<close> le_TC_def by (auto simp: oexp_Limit Limit_def)
  then show ?case
    using \<alpha> by (simp add: oexp_Limit Limit.hyps)
qed

lemma oexp_mono_le:
  assumes "\<gamma> \<le> \<beta>" "\<alpha> \<noteq> 0" "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>" shows "\<alpha>\<up>\<gamma> \<le> \<alpha>\<up>\<beta>"
  by (simp add: assms oexp_mono vle2 vle_iff_le_Ord)

lemma oexp_sup:
  assumes "\<alpha> \<noteq> 0" "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>" shows "\<alpha>\<up>(\<beta> \<squnion> \<gamma>) = \<alpha>\<up>\<beta> \<squnion> \<alpha>\<up>\<gamma>"
  by (metis Ord_linear_le assms oexp_mono_le sup.absorb2 sup.orderE)

lemma oexp_Sup:
  assumes \<alpha>: "\<alpha> \<noteq> 0" "Ord \<alpha>" and X: "X \<subseteq> ON" "small X" "X \<noteq> {}" shows "\<alpha>\<up>\<Squnion> X = \<Squnion> ((\<up>) \<alpha> ` X)"
proof (rule order_antisym)
  show "\<Squnion> ((\<up>) \<alpha> ` X) \<le> \<alpha>\<up>\<Squnion> X"
    by (metis ON_imp_Ord Ord_Sup ZFC_in_HOL.Sup_upper assms cSUP_least oexp_mono_le)
next
  have "Ord (Sup X)"
    using Ord_Sup X by auto
  then show "\<alpha>\<up>\<Squnion> X \<le> \<Squnion> ((\<up>) \<alpha> ` X)"
  proof (cases rule: Ord_cases)
    case 0
    then show ?thesis
      using X dual_order.antisym by fastforce
  next
    case (succ \<beta>)
    then show ?thesis
      using ZFC_in_HOL.Sup_upper X succ_in_Sup_Ord by auto
  next
    case limit
    show ?thesis
    proof (clarsimp simp: assms oexp_Limit limit)
      fix x y z
      assume x: "x \<in> elts (\<alpha> \<up> y)" and "z \<in> X" "y \<in> elts z"
      then have "\<alpha> \<up> y \<le> \<alpha> \<up> z"
        by (meson ON_imp_Ord Ord_in_Ord OrdmemD \<alpha> \<open>X \<subseteq> ON\<close> le_less oexp_mono_le)
      with x have "x \<in> elts (\<alpha> \<up> z)" by blast
      then show "\<exists>u\<in>X. x \<in> elts (\<alpha> \<up> u)"
        using \<open>z \<in> X\<close> by blast
    qed
  qed
qed

lemma omega_le_Limit:
  assumes "Limit \<mu>" shows "\<omega> \<le> \<mu>"
proof
  fix \<rho>
  assume "\<rho> \<in> elts \<omega>"
  then obtain n where "\<rho> = ord_of_nat n"
    using elts_\<omega> by auto
  have "ord_of_nat n \<in> elts \<mu>"
    by (induction n) (use Limit_def assms in auto)
  then show "\<rho> \<in> elts \<mu>"
    using \<open>\<rho> = ord_of_nat n\<close> by auto
qed

lemma finite_omega_power [simp]:
  assumes "1 < n" "n \<in> elts \<omega>" shows "n\<up>\<omega> = \<omega>"
proof (rule order_antisym)
  have "\<Squnion> ((\<up>) (ord_of_nat k) ` elts \<omega>) \<le> \<omega>" for k
  proof (induction k)
    case 0
    then show ?case
      by auto
  next
    case (Suc k)
    then show ?case
      by (metis Ord_\<omega> OrdmemD Sup_eq_0_iff ZFC_in_HOL.SUP_le_iff le_0 le_less omega_closed_oexp ord_of_nat_\<omega>)
  qed
  then show "n\<up>\<omega> \<le> \<omega>"
    using assms
    by (simp add: elts_\<omega> oexp_Limit) metis
  show "\<omega> \<le> n\<up>\<omega>"
    using Ord_in_Ord assms le_oexp' by blast
qed

proposition oexp_add:
  assumes "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>" shows "\<alpha>\<up>(\<beta> + \<gamma>) = \<alpha>\<up>\<beta> * \<alpha>\<up>\<gamma>"
proof (cases \<open>\<alpha> = 0\<close>)
  case True
  then show ?thesis
    using assms by simp
next
  case False
  show ?thesis
    using \<open>Ord \<gamma>\<close>
  proof (induction rule: Ord_induct3)
    case 0
    then show ?case
      by auto
  next
    case (succ \<xi>)
    then show ?case
      using \<open>Ord \<beta>\<close> by (auto simp: plus_V_succ_right mult.assoc)
  next
    case (Limit \<mu>)
    have "\<alpha>\<up>(\<beta> + (SUP \<xi>\<in>elts \<mu>. \<xi>)) = (SUP \<xi>\<in>elts (\<beta> + \<mu>). \<alpha>\<up>\<xi>)"
      by (simp add: Limit.hyps oexp_Limit assms False)
    also have "\<dots> = (SUP \<xi> \<in> {\<xi>. Ord \<xi> \<and> \<beta> + \<xi> < \<beta> + \<mu>}. \<alpha>\<up>(\<beta> + \<xi>))"
    proof (rule Sup_eq_Sup)
      show "(\<lambda>\<xi>. \<alpha>\<up>(\<beta> + \<xi>)) ` {\<xi>. Ord \<xi> \<and> \<beta> + \<xi> < \<beta> + \<mu>} \<subseteq> (\<up>) \<alpha> ` elts (\<beta> + \<mu>)"
        using Limit.hyps Limit_def Ord_mem_iff_lt imageI by blast
      fix x
      assume "x \<in> (\<up>) \<alpha> ` elts (\<beta> + \<mu>)"
      then obtain \<xi> where \<xi>: "\<xi> \<in> elts (\<beta> + \<mu>)" and x: "x = \<alpha>\<up>\<xi>"
        by auto
      have "\<exists>\<gamma>. Ord \<gamma> \<and> \<gamma> < \<mu> \<and> \<alpha>\<up>\<xi> \<le> \<alpha>\<up>(\<beta> + \<gamma>)"
      proof (rule mem_plus_V_E [OF \<xi>])
        assume "\<xi> \<in> elts \<beta>"
        then have "\<alpha>\<up>\<xi> \<le> \<alpha>\<up>\<beta>"
          by (meson arg_subset_TC assms False le_TC_def less_TC_def oexp_mono vsubsetD)
        with zero_less_Limit [OF \<open>Limit \<mu>\<close>]
        show "\<exists>\<gamma>. Ord \<gamma> \<and> \<gamma> < \<mu> \<and> \<alpha>\<up>\<xi> \<le> \<alpha>\<up>(\<beta> + \<gamma>)"
          by force
      next
        fix \<delta>
        assume "\<delta> \<in> elts \<mu>" and "\<xi> = \<beta> + \<delta>"
        have "Ord \<delta>"
          using Limit.hyps Limit_def Ord_in_Ord \<open>\<delta> \<in> elts \<mu>\<close> by blast
        moreover have "\<delta> < \<mu>"
          using Limit.hyps Limit_def OrdmemD \<open>\<delta> \<in> elts \<mu>\<close> by auto
        ultimately show "\<exists>\<gamma>. Ord \<gamma> \<and> \<gamma> < \<mu> \<and> \<alpha>\<up>\<xi> \<le> \<alpha>\<up>(\<beta> + \<gamma>)"
          using \<open>\<xi> = \<beta> + \<delta>\<close> by blast
      qed
      then show "\<exists>y\<in>(\<lambda>\<xi>. \<alpha>\<up>(\<beta> + \<xi>)) ` {\<xi>. Ord \<xi> \<and> \<beta> + \<xi> < \<beta> + \<mu>}. x \<le> y"
        using x by auto
    qed auto
    also have "\<dots> = (SUP \<xi>\<in>elts \<mu>. \<alpha>\<up>(\<beta> + \<xi>))"
      using \<open>Limit \<mu>\<close>
      by (simp add: Ord_Collect_lt Limit_def)
    also have "\<dots> = (SUP \<xi>\<in>elts \<mu>. \<alpha>\<up>\<beta> * \<alpha>\<up>\<xi>)"
      using Limit.IH by auto
    also have "\<dots> = \<alpha>\<up>\<beta> * \<alpha>\<up>(SUP \<xi>\<in>elts \<mu>. \<xi>)"
      using \<open>\<alpha> \<noteq> 0\<close> Limit.hyps
      by (simp add: image_image oexp_Limit mult_Sup_distrib)
    finally show ?case .
  qed
qed

proposition oexp_mult:
  assumes "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>" shows "\<alpha>\<up>(\<beta> * \<gamma>) = (\<alpha>\<up>\<beta>)\<up>\<gamma>"
proof (cases "\<alpha> = 0 \<or> \<beta> = 0")
  case True
  then show ?thesis
    by (auto simp: \<open>Ord \<beta>\<close> \<open>Ord \<gamma>\<close>)
next
  case False
  show ?thesis
    using \<open>Ord \<gamma>\<close>
  proof (induction rule: Ord_induct3)
    case 0
    then show ?case
      by auto
  next
    case succ
    then show ?case
      using assms by (auto simp: mult_succ oexp_add)
  next
    case (Limit \<mu>)
    have Lim: "Limit (\<Squnion> ((*) \<beta> ` elts \<mu>))"
      unfolding Limit_def
    proof (intro conjI allI impI)
      show "Ord (\<Squnion> ((*) \<beta> ` elts \<mu>))"
        using Limit.hyps Limit_def Ord_in_Ord \<open>Ord \<beta>\<close> by (auto intro: Ord_Sup)
      have "succ 0 \<in> elts \<mu>"
        using Limit.hyps Limit_def by blast
      then show "0 \<in> elts (\<Squnion> ((*) \<beta> ` elts \<mu>))"
        using False \<open>Ord \<beta>\<close> mem_0_Ord by force
      show "succ y \<in> elts (\<Squnion> ((*) \<beta> ` elts \<mu>))"
        if "y \<in> elts (\<Squnion> ((*) \<beta> ` elts \<mu>))" for y
        using that False Limit.hyps
        apply (clarsimp simp: Limit_def)
        by (metis Ord_in_Ord Ord_linear Ord_mem_iff_lt Ord_mult Ord_succ assms(2) less_V_def mult_cancellation mult_succ not_add_mem_right succ_le_iff succ_ne_self)
    qed
    have "\<alpha>\<up>(\<beta> * (SUP \<xi>\<in>elts \<mu>. \<xi>)) = \<alpha>\<up>\<Squnion> ((*) \<beta> ` elts \<mu>)"
      by (simp add: mult_Sup_distrib)
    also have "\<dots> = \<Squnion> (\<Union>x\<in>elts \<mu>. (\<up>) \<alpha> ` elts (\<beta> * x))"
      using False Lim oexp_Limit by fastforce
    also have "\<dots> = (SUP x\<in>elts \<mu>. \<alpha>\<up>(\<beta> * x))"
    proof (rule Sup_eq_Sup)
      show "(\<lambda>x. \<alpha>\<up>(\<beta> * x)) ` elts \<mu> \<subseteq> (\<Union>x\<in>elts \<mu>. (\<up>) \<alpha> ` elts (\<beta> * x))"
        using \<open>Ord \<alpha>\<close> \<open>Ord \<beta>\<close> False Limit
        apply clarsimp
        by (metis Limit_def elts_succ imageI insertI1 mem_0_Ord mult_add_mem_0)
      show "\<exists>y\<in>(\<lambda>x. \<alpha>\<up>(\<beta> * x)) ` elts \<mu>. x \<le> y"
        if "x \<in> (\<Union>x\<in>elts \<mu>. (\<up>) \<alpha> ` elts (\<beta> * x))" for x
        using that \<open>Ord \<alpha>\<close> \<open>Ord \<beta>\<close> False Limit
        by clarsimp (metis Limit_def Ord_in_Ord Ord_mult VWO_TC_le mem_imp_VWO oexp_mono)
    qed auto
    also have "\<dots> = \<Squnion> ((\<up>) (\<alpha>\<up>\<beta>) ` elts (SUP \<xi>\<in>elts \<mu>. \<xi>))"
      using Limit.IH Limit.hyps by auto
    also have "\<dots> = (\<alpha>\<up>\<beta>)\<up>(SUP \<xi>\<in>elts \<mu>. \<xi>)"
      using False Limit.hyps oexp_Limit \<open>Ord \<beta>\<close> by auto
    finally show ?case .
  qed
qed

lemma Limit_omega_oexp:
  assumes "Ord \<delta>" "\<delta> \<noteq> 0"
  shows "Limit (\<omega>\<up>\<delta>)"
  using assms
proof (cases \<delta> rule: Ord_cases)
  case 0
  then show ?thesis
    using assms(2) by blast
next
  case (succ l)
  have *: "succ \<beta> \<in> elts (\<omega>\<up>l * n + \<omega>\<up>l)"
    if n: "n \<in> elts \<omega>" and \<beta>: "\<beta> \<in> elts (\<omega>\<up>l * n)" for n \<beta>
  proof -
    obtain "Ord n" "Ord \<beta>"
      by (meson Ord_\<omega> Ord_in_Ord Ord_mult Ord_oexp \<beta> n succ(1))
    obtain oo: "Ord (\<omega>\<up>l)" "Ord (\<omega>\<up>l * n)"
      by (simp add: \<open>Ord n\<close> succ(1))
    moreover have f4: "\<beta> < \<omega>\<up>l * n"
      using oo Ord_mem_iff_lt \<open>Ord \<beta>\<close> \<open>\<beta> \<in> elts (\<omega>\<up>l * n)\<close> by blast
    moreover have f5: "Ord (succ \<beta>)"
      using \<open>Ord \<beta>\<close> by blast
    moreover have "\<omega>\<up>l \<noteq> 0"
      using oexp_eq_0_iff omega_nonzero succ(1) by blast
    ultimately show ?thesis
      by (metis add_less_cancel_left Ord_\<omega> Ord_add Ord_mem_iff_lt OrdmemD \<open>Ord \<beta>\<close> add.right_neutral dual_order.strict_trans2 oexp_gt_0_iff succ(1) succ_le_iff zero_in_omega)
  qed
  show ?thesis
    using succ
    apply (clarsimp simp: Limit_def mem_0_Ord)
    apply (simp add: mult_Limit)
    by (metis * mult_succ succ_in_omega)
next
  case limit
  then show ?thesis
    by (metis Limit_oexp Ord_\<omega> OrdmemD one_V_def succ_in_omega zero_in_omega)
qed

lemma oexp_mult_commute:
  fixes j::nat
  assumes "Ord \<alpha>"
  shows "(\<alpha> \<up> j) * \<alpha> = \<alpha> * (\<alpha> \<up> j)"
proof -
  have "(\<alpha> \<up> j) * \<alpha> = \<alpha> \<up> (1 + ord_of_nat j)"
    by (simp add: one_V_def)
  also have "... = \<alpha> * (\<alpha> \<up> j)"
    by (simp add: assms oexp_add)
  finally show ?thesis .
qed

lemma oexp_\<omega>_Limit: "Limit \<beta> \<Longrightarrow> \<omega>\<up>\<beta> = (SUP \<xi> \<in> elts \<beta>. \<omega>\<up>\<xi>)"
  by (simp add: oexp_Limit)

lemma \<omega>_power_succ_gtr: "Ord \<alpha> \<Longrightarrow> \<omega> \<up> \<alpha> * ord_of_nat n < \<omega> \<up> succ \<alpha>"
  by (simp add: OrdmemD)

lemma countable_oexp:
  assumes \<nu>: "\<alpha> \<in> elts \<omega>1"
  shows "\<omega> \<up> \<alpha> \<in> elts \<omega>1"
proof -
  have "Ord \<alpha>"
    using Ord_\<omega>1 Ord_in_Ord assms by blast
  then show ?thesis
    using assms
  proof (induction rule: Ord_induct3)
    case 0
    then show ?case
      by (simp add: Ord_mem_iff_lt)
  next
    case (succ \<alpha>)
    then have "countable (elts (\<omega> \<up> \<alpha> * \<omega>))"
      by (simp add: succ_in_Limit_iff countable_mult less_\<omega>1_imp_countable)
    then show ?case
      using Ord_mem_iff_lt countable_iff_less_\<omega>1 succ.hyps by auto
  next
    case (Limit \<alpha>)
    with Ord_\<omega>1 have "countable (\<Union>\<beta>\<in>elts \<alpha>. elts (\<omega> \<up> \<beta>))" "Ord (\<omega> \<up> \<Squnion> (elts \<alpha>))"
      by (force simp: Limit_def intro: Ord_trans less_\<omega>1_imp_countable)+
    then have "\<omega> \<up> \<Squnion> (elts \<alpha>) < \<omega>1"
      using Limit.hyps countable_iff_less_\<omega>1 oexp_Limit by fastforce
    then show ?case
      using Limit.hyps Limit_def Ord_mem_iff_lt by auto
  qed
qed

end