section \<open>The Median-of-Medians Selection Algorithm\<close>
theory Select
  imports "Median_Of_Medians_Selection.Median_Of_Medians_Selection"
begin

subsection \<open>Median-of-medians selection algorithm\<close>

text \<open>
  The fast selection function now simply computes the median-of-medians of the chopped-up list
  as a pivot, partitions the list into with respect to that pivot, and recurses into one of
  the resulting sublists.
\<close>
function fast_select where
  "fast_select l k xs = (
     if length xs \<le> max l 2 then
       sort xs ! k
     else
       let x = fast_select l (((length xs + 4) div 5 - 1) div 2) (map median (chop 5 xs));
           (ls, es, gs) = threeway_partition x xs
       in
         if k < length ls then fast_select l k ls
         else if k < length ls + length es then x
         else fast_select l (k - length ls - length es) gs
      )"
  by auto

text \<open>
  The correctness of this is obvious from the above theorems, but the proof is still
  somewhat complicated by the fact that termination depends on the correctness of the
  function.
\<close>
lemma fast_select_correct_aux:
  assumes "fast_select_dom (l, k, xs)" "k < length xs"
  shows   "fast_select l k xs = select k xs"
  using assms
proof induction
  case (1 l k xs)
  show ?case
  proof (cases "length xs \<le> max l 2")
    case True
    thus ?thesis using "1.prems" "1.hyps"
      by (subst fast_select.psimps) (auto simp: select_def)
  next
    case False
    define x where
      "x = fast_select l (((length xs + 4) div 5 - Suc 0) div 2) (map median (chop 5 xs))"
    define ls where "ls = filter (\<lambda>y. y < x) xs"
    define es where "es = filter (\<lambda>y. y = x) xs"
    define gs where "gs = filter (\<lambda>y. y > x) xs"
    define nl ne where "nl = length ls" and "ne = length es"
    note defs = nl_def ne_def x_def ls_def es_def gs_def
    have tw: "(ls, es, gs) = threeway_partition (fast_select l (((length xs + 4) div 5 - 1) div 2)
                               (map median (chop 5 xs))) xs"
      unfolding threeway_partition_def defs One_nat_def ..
    have tw': "(ls, es, gs) = threeway_partition x xs"
      by (simp add: tw x_def)

    have "fast_select l k xs = (if k < nl then fast_select l k ls else if k < nl + ne then x
                                else fast_select l (k - nl - ne) gs)" using "1.hyps" False
      apply (subst fast_select.psimps)
      by (simp_all add: threeway_partition_def defs [symmetric])
    also have "\<dots> = (if k < nl then select k ls else if k < nl + ne then x
                       else select (k - nl - ne) gs)"
    proof (intro if_cong refl)
      assume *: "k < nl"
      show "fast_select l k ls = select k ls"
        by (rule 1; (rule refl tw)?)
           (insert *, auto simp: False threeway_partition_def ls_def x_def nl_def)+
    next
      assume *: "\<not>k < nl" "\<not>k < nl + ne"
      have **: "length xs = length ls + length es + length gs"
        unfolding ls_def es_def gs_def by (induction xs) auto
      show "fast_select l (k - nl - ne) gs = select (k - nl - ne) gs"
        unfolding nl_def ne_def
        by (rule 1; (rule refl tw)?) (insert False * ** \<open>k < length xs\<close>, auto simp: nl_def ne_def)
    qed
    also have "\<dots> = select k xs" using \<open>k < length xs\<close>
      by (subst (3) select_rec_threeway_partition[of "5::nat" _ _ x])
         (unfold Let_def nl_def ne_def ls_def gs_def es_def x_def threeway_partition_def, simp_all)
    finally show ?thesis .
  qed
qed

text \<open>
  Termination of the algorithm is reasonably obvious because the lists that are recursed into
  never contain the pivot (the median-of-medians), while the original list clearly does.
  The proof is still somewhat technical though.
\<close>
lemma fast_select_termination: "All fast_select_dom"
proof (relation "measure (length \<circ> snd \<circ> snd)"; (safe)?, goal_cases)
  case (1 l k xs)
  thus ?case
    by (auto simp: length_chop nat_less_iff ceiling_less_iff)
next
  fix l k :: nat and xs ls es gs :: "'a list"
  define x where "x = fast_select l (((length xs + 4) div 5 - 1) div 2) (map median (chop 5 xs))"
  assume A: "\<not> length xs \<le> max l 2"
            "(ls, es, gs) = threeway_partition x xs"
            "fast_select_dom (l, ((length xs + 4) div 5 - 1) div 2,
                             map median (chop 5 xs))"
  from A have eq: "ls = filter (\<lambda>y. y < x) xs" "gs = filter (\<lambda>y. y > x) xs"
    by (simp_all add: x_def threeway_partition_def)
  have len: "(length xs + 4) div 5 = nat \<lceil>length xs / 5\<rceil>" by linarith
  have less: "(nat \<lceil>real (length xs) / 5\<rceil> - Suc 0) div 2 < nat \<lceil>real (length xs) / 5\<rceil>"
    using A(1) by linarith
  have "x = select (((length xs + 4) div 5 - 1) div 2) (map median (chop 5 xs))"
    using less unfolding x_def by (intro fast_select_correct_aux A) (auto simp: length_chop len)
  also have "\<dots> = median (map median (chop 5 xs))" by (simp add: median_def len length_chop)
  finally have x: "x = \<dots>" .
  moreover {
    have "x \<in> set (map median (chop 5 xs))"
      using A(1) unfolding x by (intro median_in_set) auto
    also have "\<dots> \<subseteq> (\<Union>ys\<in>set (chop 5 xs). {median ys})" by auto
    also have "\<dots> \<subseteq> (\<Union>ys\<in>set (chop 5 xs). set ys)" using A(1)
      by (intro UN_mono) (auto simp: median_in_set length_chop_part_le)
    also have "\<dots> = set xs" by (subst UN_sets_chop) auto
    finally have "x \<in> set xs" .
  }
  ultimately show "((l, k, ls), l, k, xs) \<in> measure (length \<circ> snd \<circ> snd)"
              and "((l, k - length ls - length es, gs), l, k, xs) \<in> measure (length \<circ> snd \<circ> snd)"
    using A(1) by (auto simp: eq intro!: length_filter_less[of x])
qed

termination by (rule fast_select_termination)
lemma max23_2: "max 23 (2::nat) = 23" by simp
lemma fast_select_code [code]:
  "fast_select 23 k xs = (
     if length xs \<le> 23 then
       fold insort xs [] ! k
     else
       let x = fast_select 23 (((length xs + 4) div 5 - 1) div 2) (map median (chop 5 xs));
           (ls, es, gs) = threeway_partition x xs;
           nl = length ls; ne = nl + length es
       in
         if k < nl then fast_select 23 k ls
         else if k < ne then x
         else fast_select 23 (k - ne) gs
      )"
  by (subst fast_select.simps) (simp_all only: Let_def algebra_simps sort_conv_fold max23_2)

theorem fast_select_correct: "k < length xs \<Longrightarrow> fast_select l k xs = select k xs"
  using fast_select_termination by (intro fast_select_correct_aux) auto

lemma select_code [code]:
  "select k xs = (if k < length xs then fast_select 23 k xs
                    else Code.abort (STR ''Selection index out of bounds.'') (\<lambda>_. select k xs))"
proof (cases "k < length xs")
  case True
  thus ?thesis by (simp only: if_True fast_select_correct)
qed (simp_all only: Code.abort_def if_False)

end


(*
  Authors: Asta Halkjær From, Agnes Moesgård Eschen & Jørgen Villadsen, DTU Compute
*)

theory LT4 imports System_L1 begin

text \<open>System from Jan Lukasiewicz and Alfred Tarski (1930): Untersuchungen über den Aussagenkalkül\<close>

text \<open>Inspired by Shotaro Tanaka (1965): On Axiom Systems of Propositional Calculi. XIII\<close>

inductive LT (\<open>\<tturnstile>\<close>) where
  LT_MP: \<open>\<tturnstile> q\<close> if \<open>\<tturnstile> p\<close> and \<open>\<tturnstile> (p \<rightarrow> q)\<close> |
  LT_3: \<open>\<tturnstile> (p \<rightarrow> (q \<rightarrow> p))\<close> |
  LT_4: \<open>\<tturnstile> ((\<sim> r \<rightarrow> (s \<rightarrow> \<sim> t)) \<rightarrow> ((r \<rightarrow> (s \<rightarrow> u)) \<rightarrow> ((t \<rightarrow> s) \<rightarrow> (t \<rightarrow> u))))\<close>

lemma LT_5: \<open>\<tturnstile> ((p \<rightarrow> (q \<rightarrow> r)) \<rightarrow> ((p \<rightarrow> q) \<rightarrow> (p \<rightarrow> r)))\<close>
  using LT_3 LT_4 LT_MP by metis

lemma LT_15: \<open>\<tturnstile> (((p \<rightarrow> q) \<rightarrow> r) \<rightarrow> (q \<rightarrow> r))\<close>
  using LT_3 LT_5 LT_MP by metis

lemma LT_11: \<open>\<tturnstile> ((p \<rightarrow> q) \<rightarrow> ((q \<rightarrow> r) \<rightarrow> (p \<rightarrow> r)))\<close>
  using LT_3 LT_5 LT_MP by metis

lemma LT_20: \<open>\<tturnstile> ((\<sim> p \<rightarrow> p) \<rightarrow> p)\<close>
  using LT_4 LT_15 LT_MP by metis

lemma LT_21: \<open>\<tturnstile> (p \<rightarrow> (\<sim> p \<rightarrow> q))\<close>
  using LT_4 LT_15 LT_MP by metis

theorem LT_iff_L1: \<open>\<tturnstile> p \<longleftrightarrow> \<turnstile> p\<close>
proof
  have L1_LT_3: \<open>\<turnstile> (p \<rightarrow> (q \<rightarrow> p))\<close> for p q
    using L1_completeness by simp
  have L1_LT_4: \<open>\<turnstile> ((\<sim> r \<rightarrow> (s \<rightarrow> \<sim> t)) \<rightarrow> ((r \<rightarrow> (s \<rightarrow> u)) \<rightarrow> ((t \<rightarrow> s) \<rightarrow> (t \<rightarrow> u))))\<close> for r s t u
    using L1_completeness by simp
  show \<open>\<turnstile> p\<close> if \<open>\<tturnstile> p\<close>
    using that by (induct) (metis MP, metis L1_LT_3, metis L1_LT_4)
  show \<open>\<tturnstile> p\<close> if \<open>\<turnstile> p\<close>
    using that by (induct) (metis LT_MP, metis LT_11, metis LT_20, metis LT_21)
qed

theorem LT_soundness: \<open>\<tturnstile> p \<Longrightarrow> I \<Turnstile> p\<close>
  by (induct rule: LT.induct) auto

theorem LT_completeness: \<open>\<forall>I. (I \<Turnstile> p) \<Longrightarrow> \<tturnstile> p\<close>
  using LT_iff_L1 by (simp add: L1_completeness)

section \<open>Soundness and Completeness\<close>

theorem main: \<open>valid p = \<tturnstile> p\<close>
  unfolding valid_def using LT_soundness LT_completeness by blast

lemmas LT = LT.intros main

end


theory Practical
  imports Main
begin

(***************************First-order logic*************************************)

(*1 mark*)
lemma "A∨A ⟶ A"
  apply (rule impI)
  apply (erule disjE)
   apply assumption+
  done

(*1 mark*)
lemma "(P⟶R)⟶(¬P∨R)"
  apply (rule impI)
  apply (rule classical)
  apply (rule disjI1)
  apply (rule notI)
  apply (erule notE)
  apply (rule disjI2)
  apply (erule impE)
   apply assumption+
  done

(*1 mark*)
lemma "(P∧Q⟶R)⟶P⟶Q⟶R"
  apply (rule impI)+
  apply (erule impE)
   apply (rule conjI)
    apply assumption+
  done

(*3 marks*)
lemma "¬¬P ∨ ¬P"
  apply (rule classical)
  apply (rule disjI1)
  apply (rule notI)
  apply (erule notE)
  apply (rule disjI2)
  apply assumption
  done

(*4 marks*)
lemma "(P∨R)⟷(¬(¬P∧ ¬R))"
  apply (rule iffI)
   apply (erule disjE)
    apply (rule notI)
    apply (erule conjE)
    apply (erule notE)
    apply assumption
   apply (rule notI)
   apply (erule conjE)
   apply (erule notE)+
   apply assumption

  apply (rule classical)
  apply (erule notE)
  apply (rule conjI)
   apply (rule notI)
   apply (erule notE)
   apply (rule disjI1)
   apply assumption
  apply (rule notI)
  apply (erule notE)
  apply (rule disjI2)
  apply assumption
  done

(*1 mark*)
lemma "(∀ x . F x ⟶ G x ) ⟶ ¬ (∃ x . F x ∧ ¬ G x )"
  apply (rule impI)
  apply (rule classical)
  apply (drule notnotD)
  apply (erule exE)
  apply (erule allE)
  apply (erule conjE)
  apply (erule impE)
   apply assumption
  apply (erule notE)
  apply assumption
  done

(*1 mark*)
lemma "(∀ x y. R x y) ⟶ (∀ x . R x x )"
  apply (rule impI)
  apply (rule allI)
  apply (erule allE)+
  apply assumption
  done

(*3 marks*)
lemma "(∀x. P x)∨(∃x.¬P x)"
  apply (rule classical)
  apply (rule disjI1 notI)+
  apply (rule allI)
  apply (rule classical)
  apply (erule notE)
  apply (rule disjI2)
  apply (rule exI)
  apply assumption
  done

(*3 marks*)
lemma "(∀x. ¬ (P x ⟶ Q x)) ⟶ ¬(∃x. ¬P x ∧ Q x)"
  apply (rule impI)
  apply (rule classical)
  apply (drule notnotD)
  apply (erule exE)
  apply (erule allE)
  apply (erule conjE)
  apply (erule notE)
  apply (rule impI)
  apply assumption
  done

(*3 marks*)
lemma "∃Bob. (drunk Bob ⟶ (∀x. drunk x))"
  apply (rule classical)
  apply (rule exI)
  apply (rule impI)
  apply (rule allI)
  apply (rule ccontr)
  apply (erule notE)
  apply (rule exI)
  apply (rule impI)
  apply (erule notE)
  apply assumption
  done

(*4 marks*)
lemma "¬ (∃barber. man barber ∧ (∀x. man x ∧ ¬shaves x x ⟷ shaves barber x ))"
  apply (rule notI)
  apply (erule exE)
  apply (erule conjE)
  apply (erule allE)
  apply (erule iffE)
  apply (erule impE)
   apply (rule conjI)
    apply assumption
   apply (rule notI)
   apply (erule impE, assumption, erule conjE, erule notE, assumption)+
  done

locale incidence =
  fixes incidence_points_on_sections :: "'point ⇒ 'section ⇒ bool" (infix " ι⇩p⇩o⇩i⇩n⇩t " 80)
  fixes region_to_section :: "'region ⇒ 'section"
  assumes section_nonempty: "∀s. ∃p. p ι⇩p⇩o⇩i⇩n⇩t s"
    (*Write here your axiom stating that every section has
                                            a point incident to it*) (*2 marks*)
    and section_uniqueness: "∀s l. (∀p. p ι⇩p⇩o⇩i⇩n⇩t s ⟷ p ι⇩p⇩o⇩i⇩n⇩t l) ⟶ s = l"
    (*Write here your axiom stating that ANY two sections are the same
                                      if ANY of the same points are incident to each*) (*2 marks*)
begin

definition isPartOf ::"'section ⇒ 'section ⇒ bool" (infix "isPartOf" 80) where
  "a isPartOf b = (∀p. p ι⇩p⇩o⇩i⇩n⇩t a ⟶ p ι⇩p⇩o⇩i⇩n⇩t b)"
  (*write your formalisation of definition D1 here*) (*1 mark*)

definition inclusion ::"'region ⇒ 'section ⇒ bool"(infix "isIncludedIn" 80) where
  (*write your formalisation of definition D2 here*) (*1 mark*)
  "a isIncludedIn b = (region_to_section a) isPartOf b"

definition overlaps ::"'region ⇒ 'section ⇒ bool"(infix "overlaps" 80) where
  (*write your formalisation of definition D3 here*) (*1 mark*)
  "a overlaps b = (∃p. p ι⇩p⇩o⇩i⇩n⇩t (region_to_section a) ∧ p ι⇩p⇩o⇩i⇩n⇩t b)"

lemma region_overlaps_itself: "R overlaps (region_to_section R)"
  (*Write your structured proof here*) (*2 marks*)
proof (unfold overlaps_def)
  from section_nonempty obtain p where "p ι⇩p⇩o⇩i⇩n⇩t region_to_section R" by blast
  then show "∃p. p  ι⇩p⇩o⇩i⇩n⇩t region_to_section R ∧ p  ι⇩p⇩o⇩i⇩n⇩t region_to_section R"
    by blast
qed

(*Formalise and prove that isPartOf is reflexive, transitive and antisymmetric*) (*3 marks*)
lemma isPartOf_reflexive: "a isPartOf a"
  by (simp add: isPartOf_def)

lemma isPartOf_transitive:
  assumes ab: "a isPartOf b" and bc: "b isPartOf c"
  shows ac: "a isPartOf c"
proof (unfold isPartOf_def)
  show "∀p. p  ι⇩p⇩o⇩i⇩n⇩t  a ⟶ p  ι⇩p⇩o⇩i⇩n⇩t  c"
    using ab bc isPartOf_def by blast
qed

lemma isPartOf_antisymmetric:
  assumes ab: "a isPartOf b" and ba: "b isPartOf a"
  shows "a = b"
proof -
  show "a = b"
    using ab ba isPartOf_def section_uniqueness by blast
qed

end

locale section_bundles =  incidence incidence_points_on_sections region_to_section
  for  incidence_points_on_sections :: "'point ⇒ 'section ⇒ bool"
    and region_to_section :: "'region ⇒ 'section" +
  fixes crossing :: "'region ⇒ 'section ⇒ bool" (infix "crosses" 80)
    and incidence_sections_on_bundles :: "'section ⇒ 'bundle ⇒ bool" (infix "ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n" 80)
  assumes SC1:"∀s r. r crosses s ⟶ r overlaps s" (*Write your formalisation of Axiom SC1 here*) (*1 mark*)
    and SI1: "∀a b. (∀s. s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n a ⟷ s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b) ⟶ a = b" (*Write your formalisation of Axiom SI1 here*)     (*1 mark*)
begin

definition atLeastAsRestrictiveAs :: "'section ⇒ 'bundle ⇒ 'section ⇒ bool" where
  (*Write your formalisation of atLeastAsRestrictiveAs here*) (*1 mark*)
  "atLeastAsRestrictiveAs s b s' = (s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ s isPartOf s')"

notation
  atLeastAsRestrictiveAs ("_ ≤⇩_ _" [80, 80, 80] 80)

(*Formalise and prove that atLeastAsRestrictiveAs is reflexive, transitive and antisymmetric*) (*2 marks*)

(*Kulik and Eschenbach say 'The relation ≥ is reflexive, transitive and antisymmetric for a given
sector bundle.' So, do they mean, given that the sections under consideration are in the bundle?
This is what we assume for reflexivity.*)
lemma atLeastAsRestrictiveAs_reflexive:
  assumes "s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b"  shows "s ≤⇩b s" (* given: DO NOT REMOVE! *)
proof (unfold atLeastAsRestrictiveAs_def)
  show "s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ s isPartOf s"
    by (simp add: assms isPartOf_reflexive)
qed

lemma atLeastAsRestrictiveAs_transitive:
  (*Formalise and prove that atLeastAsRestrictiveAs is transitive*)
  assumes xy: "x ≤⇩b y" and yz: "y ≤⇩b z"
  shows "x ≤⇩b z"
proof (unfold atLeastAsRestrictiveAs_def)
  show "x ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ z ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ x isPartOf z"
    using atLeastAsRestrictiveAs_def isPartOf_transitive xy yz by blast
qed

lemma atLeastAsRestrictiveAs_antisymmetric:
  (*Formalise and prove that atLeastAsRestrictiveAs is antisymmetric*)
  assumes xy: "x ≤⇩b y" and yx: "y ≤⇩b x"
  shows "x = y"
proof -
  show "x = y"
    using atLeastAsRestrictiveAs_def isPartOf_antisymmetric xy yx by auto
qed

end

locale comparison = section_bundles incidence_points_on_sections region_to_section
  crossing incidence_sections_on_bundles
  for  incidence_points_on_sections :: "'point ⇒ 'section ⇒ bool" (infix "ι⇩p⇩o⇩i⇩n⇩t" 80)
    and region_to_section :: "'region ⇒ 'section"
    and crossing :: "'region ⇒ 'section ⇒ bool" (infix "crosses" 80)
    and incidence_sections_on_bundles :: "'section ⇒ 'bundle ⇒ bool" (infix "ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n" 80)+
  assumes SB2: "∀b s s'. (s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b) ⟶ (s ≤⇩b s' ∨ s' ≤⇩b s)"
    (*Write your formalisation of Axiom SB2 here*) (*1 mark*)

begin

lemma T1:(*Write your formalisation and proof of Theorem T1 here*) (*1 mark*)
  assumes r_overlaps_s: "r overlaps s"
  shows "∀s'. (s ≤⇩b s' ⟶ r overlaps s')"
proof -
  show  "∀s'. (s ≤⇩b s' ⟶ r overlaps s')"
    using atLeastAsRestrictiveAs_def isPartOf_def overlaps_def r_overlaps_s by auto
qed

lemma T2: (*Write your formalisation and proof of Theorem T2 here*) (*1 mark*)
  assumes r_isincludedin_s: "r isIncludedIn s"
  shows "∀s'. (s ≤⇩b s' ⟶ r isIncludedIn s')"
proof -
  show "∀s'. s ≤⇩b s' ⟶ r isIncludedIn s'"
    using atLeastAsRestrictiveAs_def inclusion_def isPartOf_transitive r_isincludedin_s by blast
qed

definition isCore (infix "isCoreOf" 80) where
  "s isCoreOf b = (s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ (∀s'. s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ s ≤⇩b s'))"

(*Write your definition of hull here*) (*1 mark*)
definition isHull (infix "isHullOf" 80) where
  "s isHullOf b = (s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ (∀s'. s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ s' ≤⇩b s))"

end

locale crossing_sector = comparison incidence_points_on_sections
  region_to_section crossing incidence_sections_on_bundles
  for incidence_points_on_sections :: "'point ⇒ 'section ⇒ bool" (infix "ι⇩p⇩o⇩i⇩n⇩t" 80)
    and region_to_section :: "'region ⇒ 'section"
    and crossing :: "'region ⇒ 'section ⇒ bool" (infix "crosses" 80)
    and incidence_sections_on_bundles :: "'section ⇒ 'bundle ⇒ bool" (infix "ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n" 80) +
  assumes SC2: "∀b S R. (R crosses S ⟶ (∀S'. (S' ≤⇩b S ⟶ R crosses S')))"
    (*Write your formalisation of Axiom SC2 here*) (*1 mark*)
begin

lemma overlaps_core: (*Write your formalisation and structured proof of the remark `If a region
overlaps the core of a section bundle then it overlaps every section of the section bundle'*)
  (*4 marks*)
  assumes r_overlaps_s: "r overlaps s" and s_isCoreOf_b: "s isCoreOf b"
  shows "∀s'. s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ r overlaps s'"
proof (rule allI, rule impI)
  fix s'
  assume s_incidence_b: "s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b"
  have s_isC_b: "s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ (∀s'. s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ s ≤⇩b s')"
    using isCore_def s_isCoreOf_b by blast
  have s_atleastasrestrictiveas_s': "s ≤⇩b s'"
    by (simp add: s_incidence_b s_isC_b)
  show "r overlaps s'"
    using T1 r_overlaps_s s_atleastasrestrictiveas_s' by blast
qed

lemma crosses_hull: (*Write your formalisation and structured proof of the remark `If a region
crosses the hull of a section bundle then it crosses every sector of the section bundle'*)
  (*4 marks*)
  assumes r_crosses_s: "r crosses s" and s_isHullOf_b: "s isHullOf b"
  shows "∀s'. s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ r crosses s'"
proof (rule allI, rule impI)
  fix s'
  assume s'_incidence_b: "s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b"
  have s_isH_b: "s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ (∀s'. s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ s' ≤⇩b s)"
    using isHull_def s_isHullOf_b by blast
  have s'_atleastasrestrictiveas_s: "s' ≤⇩b s"
    by (simp add: s'_incidence_b s_isH_b)
  show "r crosses s'"
    using SC2 r_crosses_s s'_atleastasrestrictiveas_s by blast
qed

lemma not_overlap_hull:  (*Write your formalisation and structured proof of the remark `If a region
does not overlap the hull of a section bundle, it does not overlap any of its sections'*)
  (*4 marks*)
  assumes r_not_overlaps_s: "¬(r overlaps s)" and s_isHullOf_b: "s isHullOf b"
  shows "∀s'. s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ ¬(r overlaps s')"
proof (rule allI, rule impI)
  fix s'
  assume s'_incidence_b: "s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b"
  have s_isH_b: "s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ (∀s'. s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ s' ≤⇩b s)"
    using isHull_def s_isHullOf_b by blast
  have s'_atleastasrestrictiveas_s: "s' ≤⇩b s"
    by (simp add: s'_incidence_b s_isH_b)
  show "¬(r overlaps s')"
    using T1 r_not_overlaps_s s'_atleastasrestrictiveas_s by blast
qed

definition overlapsAsMuchAs :: "'region ⇒ 'bundle ⇒ 'region ⇒ bool"  where
  "overlapsAsMuchAs R b R' == (∀s. s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ R' overlaps s ⟶ R overlaps s)"

notation
  overlapsAsMuchAs ("_ ≥⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩_ _" [80, 80, 80] 80)

definition eq_overlapsAsMuchAs :: "'region ⇒ 'bundle ⇒ 'region ⇒ bool"  where
  "eq_overlapsAsMuchAs R b R' == R ≥⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R' ∧ R' ≥⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R"

notation
  eq_overlapsAsMuchAs ("_ ≅⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩_ _" [80, 80, 80] 80)

abbreviation
  rev_overlapsAsMuchAs :: "'region ⇒ 'bundle ⇒ 'region ⇒ bool"  ("_ ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩_ _" [80, 80, 80] 80)
  where"rev_overlapsAsMuchAs R b R' == overlapsAsMuchAs R' b R"

definition more_overlapsAsMuchAs :: "'region ⇒ 'bundle ⇒ 'region ⇒ bool"  where
  "more_overlapsAsMuchAs R b R' == R ≥⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R' ∧ ¬(R' ≥⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R)"

notation
  more_overlapsAsMuchAs ("_ >⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩_ _" [80, 80, 80] 80)

abbreviation
  less_overlapsAsMuchAs :: "'region ⇒ 'bundle ⇒ 'region ⇒ bool"  ("_ <⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩_ _" [80, 80, 80] 80)
  where"less_overlapsAsMuchAs R b R' == more_overlapsAsMuchAs R' b R"

(*Formalise and prove that overlapsAsMuchAs is reflexive and transitive*) (*2 marks*)

lemma overlapsAsMuchAs_reflexive:
  (*Write your formalisation and proof that overlapsAsMuchAs is reflexive here*)
  assumes "(region_to_section R) ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b"
  shows "R ≥⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R"
proof -
  show "R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R"
    by (simp add: overlapsAsMuchAs_def)
qed

lemma overlapsAsMuchAs_transitive:
  (*Write your formalisation and proof that overlapsAsMuchAs is transitive here*)
  assumes xy: "X ≥⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b Y" and yz: "Y ≥⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b Z"
  shows xz: "X ≥⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b Z"
proof -
  show "X ≥⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b Z"
    using overlapsAsMuchAs_def xy yz by auto
qed

(*Write your formalisation and structured proof of Theorem T3 here. You must attempt to
formalise Kulik et al.'s reasoning*) (*11 marks*)
lemma T3: "∀b R R'.  R >⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R' ⟷ (∃s. s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ R overlaps s ∧ ¬( R' overlaps s))"

proof ((rule allI)+, rule iffI)

(* DIRECTION ← *)
  fix b R R'

  assume rhs: "∃s. s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧  R overlaps s ∧ ¬ R' overlaps s"
  from rhs obtain s where s_inbundle_b: "s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b" and r_overlaps_s: "R overlaps s"
    and r'_notoverlaps_s: "¬( R' overlaps s)"
    by blast

  (* This is where we diverge from Kulik et al's proof *)

  have isPartOf_disj: "∀s'. s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ s isPartOf s' ∨ s' isPartOf s"
    using SB2 atLeastAsRestrictiveAs_def s_inbundle_b by auto

  have fromSB2: "∀s'. s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ s ≤⇩b s' ∨ s' ≤⇩b s"
    (* this is the intermediate step Kulik skipped *)
    by (simp add: atLeastAsRestrictiveAs_def isPartOf_disj s_inbundle_b)

  have r_overlaps_s': "∀s'. s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ s ≤⇩b s' ⟶ R overlaps s'"
    using T1 r_overlaps_s by blast

  have r'_not_overlaps_s': "∀s'. s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ s' ≤⇩b s ⟶ ¬R' overlaps s'"
    using T1 r'_notoverlaps_s by blast

  from r_overlaps_s' and r'_not_overlaps_s' have r_oama_r': "R ≥⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'"
    using fromSB2 overlapsAsMuchAs_def by blast

  have r_moreoverlaps_r': "R >⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'"
    using more_overlapsAsMuchAs_def overlapsAsMuchAs_def r_oama_r' rhs by blast

  show "∃s. s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ R overlaps s ∧ ¬ R' overlaps s ⟹ R >⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'"
    using r_moreoverlaps_r' by blast

next

(* DIRECTION ⟶ *)
  fix b R R'
  assume lhs: "R' <⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R"

    have r'r_and_not_r_r': "R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ∧ ¬ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'"
      using lhs more_overlapsAsMuchAs_def by auto

    have r_novb_r': "¬ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'"
      by (simp add: r'r_and_not_r_r')

    (*"¬(∀s. s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ R overlaps s ∧ R' overlaps s)
              ⟶ (∃s. s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ R overlaps s ∧ ¬ R' overlaps s)"*)

    have imp_statement: "∃s. s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ R overlaps s ∧ ¬ R' overlaps s"
      using overlapsAsMuchAs_def r_novb_r' by blast

    show "R' <⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ⟹ ∃s. s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ R overlaps s ∧ ¬ R' overlaps s"
      by (simp add: imp_statement)
qed

(*In under 200 words, compare and contrast the mechanical proof that you produced with the
pen-and-paper proof by Kulik et al.\. In particular, indicate any reasoning, proof parts, and/or
useful lemmas that you had to make explicit during the mechanisation but may have been glossed over
 or assumed by the pen-and-paper proof. Also highlight any inaccuracies in their language or
notation. Note any parts where you had to diverge from their reasoning, and why.
Write your answer in a comment here.

====================================================================================================

In Kulik et al.'s proof, it seemed like it was sufficient to say that for every s' where
s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b, if s isPartOf s' holds then we get R overlaps s', otherwise if s' isPartOf s holds
then ¬R' overlaps s'. In Kulik's case, it seemed quite trivial to mention that s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b as well,
however in Isabelle I had to mention it explicitly,  i.e. saying s isPartOf s' only is insufficient
to prove R overlaps s' -- I had to also state that s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∧ s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b as well.
The same case holds for s' isPartOf s. This means that I had to say

  "∀s'. s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ s ≤⇩b s' ⟶ R overlaps s'"

instead of the statement obtained from the direct translation from the paper

  "∀s'. s' ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ s isPartOf s' ⟶ R overlaps s'"

Essentially what I'm trying to say is that Kulik skipped proving "s isPartOf s' ∨ s' isPartOf s"
and all the previous assumptions made yield "s ≤⇩b s' ∨ s' ≤⇩b s", which I did explicitly. Then I
used "s ≤⇩b s' ∨ s' ≤⇩b s" as the 'missing' intermediate step to prove that "s isPartOf s' ∨
s' isPartOf s" implies R overlaps s' or R overlaps s'.

====================================================================================================

*) (*4 marks*)

(*Write your formalisation and proof of Theorem T4 here*) (*1 mark*)
lemma T4: "∀b R R'.  R >⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R' ∨ R ≅⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R' ∨ R <⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'"
proof -
  show "∀b R R'.  R >⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R' ∨ R ≅⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R' ∨ R <⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'"
    using T3 eq_overlapsAsMuchAs_def overlapsAsMuchAs_def by auto
qed

lemma T5: "∀b R R'.  R ≥⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R' ∨ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'"
proof (rule allI)+
  fix b R R'
  have "R' <⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ∨  R ≅⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R' ∨ R <⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'"
    by (simp add: T4)
  from this consider "R' <⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R" | "R ≅⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'" | "R <⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'"
    by blast
  then have final: "(R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ∧ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R') ∨ (R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ∧ ¬ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R') ∨
      (R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R' ∧ ¬ R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R)"

  proof (cases)

    assume "R' <⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R"
    have "(R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ∧ ¬ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R')"
      using ‹R' <⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R› more_overlapsAsMuchAs_def by blast
    show "(R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ∧ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R') ∨ (R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ∧ ¬ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R') ∨ (R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R' ∧ ¬ R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R)"
      by (simp add: ‹R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ∧ ¬ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'›)

  next

    assume "R ≅⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'"
    have "(R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ∧ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R')"
      using ‹R ≅⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'› eq_overlapsAsMuchAs_def by auto
    show "(R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ∧ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R') ∨ (R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ∧ ¬ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R') ∨ (R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R' ∧ ¬ R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R)"
      by (simp add: ‹R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ∧ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'›)

  next

    assume "R <⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'"
    have "(R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R' ∧ ¬ R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R)"
      using ‹R <⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'› more_overlapsAsMuchAs_def by blast
    show "(R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ∧ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R') ∨ (R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ∧ ¬ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R') ∨ (R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R' ∧ ¬ R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R)"
      using ‹R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R' ∧ ¬ R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R› by blast
  qed

  show "R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R ∨ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'"
    using final by blast

qed

(********************Challenge problem****************************************)

(*Write your definition of `a region crosses or is included in a section.` here*) (*2 marks*)
definition crossesOrIncludedIn :: "'region ⇒ 'section ⇒ bool" (infix "ci" 80) where
  "R ci S = (R crosses S ∨ R isIncludedIn S)"

(*Write your definition of `crosses or is included in as much as' here*) (*2 marks*)
(*If a region crosses a section or is included in a section, R ci S*)
definition crossesIncludedInAsMuchAs :: "'region ⇒ 'bundle ⇒ 'region ⇒ bool" where
  "crossesIncludedInAsMuchAs R b R' = (∀s. s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ⟶ R' ci s ⟶ R ci s)"

notation
  crossesIncludedInAsMuchAs ("_ ≥⇩c⇩i ⇩_ _" [80, 80, 80] 80)

(*Write your definition of `belongs as much as here: definition D8 in the paper.*) (*2 marks*)
definition belongsAsMuchAs :: "'region ⇒ 'bundle ⇒ 'region ⇒ bool" where
  "belongsAsMuchAs R b R' = (R ≥⇩c⇩i ⇩b R' ∧ R ≥⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R')"

notation
  belongsAsMuchAs ("_ ≥⇩_ _" [80, 80, 80] 80)

(*Formalise and write structured proofs of Theorems T6-T8 for both crossesIncludedInAsMuchAs and
belongsAsMuchAs*) (*14 marks*)

(* Kulik et. al's paper says that only (T7) and (T8) holds for the relation ≥⇩c⇩i so I'm not entirely
sure whether or not this is provable. *)
lemma T6_crossesIncludedInAsMuchAs: "∀b R. ¬(R overlaps s) ∧ s isHullOf b ⟶ (∀R'. R' ≥⇩c⇩i ⇩b R)"
proof ((rule allI)+, rule impI, rule allI)
  fix b R R'
  assume assm: "¬ R overlaps s ∧ s isHullOf b"
  show "R' ≥⇩c⇩i ⇩b R"
  proof (unfold crossesIncludedInAsMuchAs_def, rule allI, (rule impI)+)
    fix s
    assume s_inbundle_b: "s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b" and r_ci_s: "R ci s"
    show r'_co_s: "R' ci s"
    proof (unfold crossesOrIncludedIn_def)
      show "R' crosses s ∨ R' isIncludedIn s"
        by (meson SC1 T1 assm crossesOrIncludedIn_def inclusion_def isHull_def isPartOf_def overlaps_def r_ci_s s_inbundle_b section_nonempty)
    qed
  qed
qed

lemma T6_belongsAsMuchAs: "∀b R. ¬(R overlaps s) ∧ (s isHullOf b) ⟶ (∀R'. R' ≥⇩b R)"
proof ( (rule allI)+, rule impI, rule allI, unfold belongsAsMuchAs_def)
  fix b R R'
  assume assm: "¬(R overlaps s) ∧ s isHullOf b"
  have a: "R' ≥⇩c⇩i ⇩b R"
    using T6_crossesIncludedInAsMuchAs assm by blast
  have b: "R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'"
  proof (unfold overlapsAsMuchAs_def, rule allI, (rule impI)+)
    fix s
    assume s_inbundle_b: "s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b" and r_ov_s: "R overlaps s"
    show r'_ov_s: "R' overlaps s"
      using assm not_overlap_hull r_ov_s s_inbundle_b by blast
  qed
  from a and b have "R' ≥⇩c⇩i ⇩b R ∧ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'"
    by simp
  show "¬ R overlaps s ∧ s isHullOf b ⟹ R' ≥⇩c⇩i ⇩b R ∧ R ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R'" using a b by blast
qed

lemma T7_crossesIncludedInAsMuchAs: "∀b R. R isIncludedIn s ∧ s isCoreOf b ⟶ (∀R'. R ≥⇩c⇩i ⇩b R')"
proof ((rule allI)+, rule impI, rule allI)
  fix b R R'
  assume assm: "R isIncludedIn s ∧ s isCoreOf b"
  show "R ≥⇩c⇩i ⇩b R'"
  proof (unfold crossesIncludedInAsMuchAs_def, rule allI, (rule impI)+)
    fix s
    assume s_inbundle_b: "s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b" and r'_ci_s: "R' ci s"
    have disj: "R crosses s ∨ R isIncludedIn s"
      using T2 assm isCore_def s_inbundle_b by blast
    show "R ci s"
      by (simp add: crossesOrIncludedIn_def disj)
  qed
qed

lemma T7_belongsAsMuchAs: "∀b R. R isIncludedIn s ∧ s isCoreOf b ⟶ (∀R'. R ≥⇩b R')"
proof ((rule allI)+, rule impI, rule allI)
  fix b R R'
  assume assm: "R isIncludedIn s ∧ s isCoreOf b"
  show "R ≥⇩b R'"
  proof (unfold belongsAsMuchAs_def)
    have r_cib_r': "R ≥⇩c⇩i ⇩b R'"
      using T7_crossesIncludedInAsMuchAs assm by blast
    have r'_ovb_r: "R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R"
    proof (unfold overlapsAsMuchAs_def, rule allI, (rule impI)+)
      fix s
      assume s_inbundle_b: "s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b" and r'_ov_s: "R' overlaps s"
      show "R overlaps s"
      proof -
        have f: "region_to_section R isPartOf s"
          using T2 assm inclusion_def isCore_def s_inbundle_b by blast
        show "R overlaps s"
          using f isPartOf_def overlaps_def region_overlaps_itself by blast
      qed
    qed
    show "R ≥⇩c⇩i ⇩b R' ∧  R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R"
      by (simp add: r'_ovb_r r_cib_r')
  qed
qed

lemma T8_crossesIncludedInAsMuchAs: "∀b R. R crosses s ∧ s isHullOf b ⟶ (∀R'. R ≥⇩c⇩i ⇩b R')"
proof ((rule allI)+, rule impI, rule allI)
  fix b R R'
  assume assm: "R crosses s ∧ s isHullOf b"
  show "R ≥⇩c⇩i ⇩b R'"
  proof (unfold crossesIncludedInAsMuchAs_def, rule allI, (rule impI)+)
    fix s
    assume s_in_b: "s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b" and r'_ci_s: "R' ci s"
    show "R ci s"
    proof (unfold crossesOrIncludedIn_def)
      show "R crosses s ∨ R isIncludedIn s"
      proof -
        have contr: "¬ s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b ∨ R crosses s"
          using assm crosses_hull by blast
        show "R crosses s ∨ R isIncludedIn s"
          using contr s_in_b by blast
      qed
    qed
  qed
qed

lemma T8_belongsAsMuchAs: "∀b R. R crosses s ∧ s isHullOf b ⟶ (∀R'. R ≥⇩b R')"
proof ((rule allI)+, rule impI, rule allI)
  fix b R R'
  assume assm: "R crosses s ∧ s isHullOf b"
  show "R ≥⇩b R'"
  proof (unfold belongsAsMuchAs_def)
    have r_cib_r': "R ≥⇩c⇩i ⇩b R'"
      using T8_crossesIncludedInAsMuchAs assm by blast
    have r'_ob_r: "R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R"
    proof (unfold overlapsAsMuchAs_def, rule allI, (rule impI)+)
      fix s
      assume s_in_b: "s ι⇩s⇩e⇩c⇩t⇩i⇩o⇩n b" and r'_o_s: "R' overlaps s"
      have r_c_s: "R crosses s"
        using assm crosses_hull s_in_b by blast
      show "R overlaps s"
        using SC1 r_c_s by blast
    qed
    show "R ≥⇩c⇩i ⇩b R' ∧ R' ≤⇩o⇩v⇩e⇩r⇩l⇩a⇩p⇩s ⇩b R"
      using r'_ob_r r_cib_r' by blast
  qed
qed

end

end


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

section \<open>Veblen Hierarchies\<close>

theory OrdinalVeblen
imports OrdinalOmega
begin

subsection \<open>Closed, unbounded sets\<close>

locale normal_set =
fixes A :: "ordinal set"
assumes closed:    "\<And>g. \<forall>n. g n \<in> A \<Longrightarrow> oLimit g \<in> A"
    and unbounded: "\<And>x. \<exists>y\<in>A. x < y"

lemma (in normal_set) less_next: "x < (LEAST z. z \<in> A \<and> x < z)"
  by (metis (no_types, lifting) LeastI unbounded)

lemma (in normal_set) mem_next: "(LEAST z. z \<in> A \<and> x < z) \<in> A"
  by (metis (no_types, lifting) LeastI unbounded)

lemma (in normal) normal_set_range: "normal_set (range F)"
proof (rule normal_set.intro)
  fix g :: "nat \<Rightarrow> ordinal"
  assume "\<forall>n. g n \<in> range F"
  then have "\<And>n. g n = F (LEAST z. g n = F z)"
    by (meson LeastI rangeE)
  then have "oLimit g = F (oLimit (\<lambda>n. LEAST z. g n = F z))"
    by (simp add: continuousD continuous_axioms)
  then show "oLimit g \<in> range F"
    by simp
next
  show "\<And>x. \<exists>y\<in>range F. x < y"
    using oInv_bound2 by blast
qed

lemma oLimit_mem_INTER:
  assumes norm: "\<forall>n. normal_set (A n)"
    and A: "\<forall>n. A (Suc n) \<subseteq> A n" "\<forall>n. f n \<in> A n" and "mono f"
  shows "oLimit f \<in> (\<Inter>n. A n)"
proof
  fix k
  have "f (n + k) \<in> A k" for n
    using A le_add2 lift_Suc_antimono_le by blast
  then have "oLimit (\<lambda>n. f (n + k)) \<in> A k"
    by (simp add: norm normal_set.closed)
  then show "oLimit f \<in> A k"
    by (simp add: \<open>mono f\<close> oLimit_shift_mono)
qed

lemma normal_set_INTER:
  assumes norm: "\<forall>n. normal_set (A n)"  and A: "\<forall>n. A (Suc n) \<subseteq> A n"
  shows "normal_set (\<Inter>n. A n)"
proof (rule normal_set.intro)
  fix g :: "nat \<Rightarrow> ordinal"
  assume "\<forall>n. g n \<in> \<Inter> (range A)"
  then show "oLimit g \<in> \<Inter> (range A)"
    using norm normal_set.closed by force
next
  fix x
  define F where "F \<equiv> \<lambda>n. LEAST y. y \<in> A n \<and> x < y"
  have "x < oLimit F"
    by (simp add: F_def less_oLimitI norm normal_set.less_next)
  moreover
  have \<section>: "F n \<in> A n" for n
    by (simp add: F_def norm normal_set.mem_next)
  then have "F n \<le> F (Suc n)" for n
    unfolding F_def
    by (metis (no_types, lifting) A LeastI Least_le norm normal_set_def subsetD)
  then have "oLimit F \<in> \<Inter> (range A)"
    by (meson "\<section>" A mono_natI norm oLimit_mem_INTER)
  ultimately show "\<exists>y\<in>\<Inter> (range A). x < y"
    by blast
qed

subsection \<open>Ordering functions\<close>

text "There is a one-to-one correspondence between closed,
unbounded sets of ordinals and normal functions on ordinals."

definition
  ordering  :: "(ordinal set) \<Rightarrow> (ordinal \<Rightarrow> ordinal)" where
  "ordering A = ordinal_rec (LEAST z. z \<in> A) (\<lambda>p x. LEAST z. z \<in> A \<and> x < z)"

lemma ordering_0:
  "ordering A 0 = (LEAST z. z \<in> A)"
  by (simp add: ordering_def)

lemma ordering_oSuc:
  "ordering A (oSuc x) = (LEAST z. z \<in> A \<and> ordering A x < z)"
  by (simp add: ordering_def)

lemma (in normal_set) normal_ordering: "normal (ordering A)"
  by (simp add: OrdinalVeblen.ordering_def normal_ordinal_rec normal_set.less_next normal_set_axioms)

lemma (in normal_set) ordering_oLimit: "ordering A (oLimit f) = oLimit (\<lambda>n. ordering A (f n))"
  by (simp add: normal.oLimit normal_ordering)

lemma (in normal) ordering_range: "ordering (range F) = F"
proof
  fix x
  show "ordering (range F) x = F x"
  proof (induction x rule: oLimit_induct)
    case zero
    have "(LEAST z. z \<in> range F) = F 0"
      by (metis Least_equality Least_mono UNIV_I mono ordinal_0_le)
    then show ?case
      by (simp add: ordering_0)
  next
    case (suc x)
    have "ordering (range F) (oSuc x) = (LEAST z. z \<in> range F \<and> F x < z)"
      by (simp add: ordering_oSuc suc)
    also have "\<dots> = F (oSuc x)"
      using cancel_less less_oInvD oInv_inverse
      by (bestsimp intro!: Least_equality local.strict_monoD)
    finally show ?case .
  next
    case (lim f)
    then show ?case
      using oLimit by (simp add: normal_set_range normal_set.ordering_oLimit)
  qed
qed

lemma (in normal_set) ordering_mem: "ordering A x \<in> A"
proof (induction x rule: oLimit_induct)
  case zero
  then show ?case
    by (metis LeastI ordering_0 unbounded)
 next
  case (suc x)
  then show ?case
    by (simp add: mem_next ordering_oSuc)
next
  case (lim f)
  then show ?case
    by (simp add: closed normal.oLimit normal_ordering)
qed

lemma (in normal_set) range_ordering: "range (ordering A) = A"
proof -
  have "\<forall>y. y \<in> A \<longrightarrow> y < ordering A x \<longrightarrow> y \<in> range (ordering A)" for x
  proof (induction x rule: oLimit_induct)
    case zero
    then show ?case
      using not_less_Least ordering_0 by auto
  next
    case (suc x)
    then show ?case
      using not_less_Least ordering_oSuc by fastforce
  next
    case (lim f)
    then show ?case
      by (metis less_oLimitD ordering_oLimit)
  qed
  then show ?thesis
    using normal.oInv_bound2 normal_ordering ordering_mem by fastforce
qed

lemma ordering_INTER_0:
  assumes norm: "\<forall>n. normal_set (A n)"  and A: "\<forall>n. A (Suc n) \<subseteq> A n"
  shows "ordering (\<Inter>n. A n) 0 = oLimit (\<lambda>n. ordering (A n) 0)"
proof -
  have "oLimit (\<lambda>n. OrdinalVeblen.ordering (A n) 0) \<in> \<Inter> (range A)"
    using assms
    by (metis (mono_tags, lifting) Least_le mono_natI normal_set.ordering_mem oLimit_mem_INTER ordering_0 subsetD)
  moreover have "\<And>y. y \<in> \<Inter> (range A) \<Longrightarrow> oLimit (\<lambda>n. ordering (A n) 0) \<le> y"
  by (simp add: Least_le oLimit_def ordering_0)
  ultimately show ?thesis
    by (metis LeastI Least_le nle_le ordering_0)
qed

subsection \<open>Critical ordinals\<close>

definition
  critical_set :: "ordinal set \<Rightarrow> ordinal \<Rightarrow> ordinal set" where
  "critical_set A =
     ordinal_rec0 A (\<lambda>p x. x \<inter> range (oDeriv (ordering x))) (\<lambda>f. \<Inter>n. f n)"

lemma critical_set_0 [simp]: "critical_set A 0 = A"
  by (simp add: critical_set_def)

lemma critical_set_oSuc_lemma:
  "critical_set A (oSuc n) = critical_set A n \<inter> range (oDeriv (ordering (critical_set A n)))"
  by (simp add: critical_set_def ordinal_rec0_oSuc)

lemma omega_complete_INTER: "omega_complete (\<lambda>x y. y \<subseteq> x) (\<lambda>f. \<Inter> (range f))"
  by (simp add: INF_greatest Inf_lower omega_complete_axioms_def omega_complete_def porder.flip porder_order)

lemma critical_set_oLimit: "critical_set A (oLimit f) = (\<Inter>n. critical_set A (f n))"
  unfolding critical_set_def
  by (best intro!: omega_complete.ordinal_rec0_oLimit omega_complete_INTER)

lemma critical_set_mono: "x \<le> y \<Longrightarrow> critical_set A y \<subseteq> critical_set A x"
  unfolding critical_set_def
  by (intro omega_complete.ordinal_rec0_mono [OF omega_complete_INTER]) force

lemma (in normal_set) range_oDeriv_subset: "range (oDeriv (ordering A)) \<subseteq> A"
  by (metis image_subsetI normal_ordering oDeriv_fixed rangeI range_ordering)

lemma normal_set_critical_set: "normal_set A \<Longrightarrow> normal_set (critical_set A x)"
proof (induction x rule: oLimit_induct)
  case zero
  then show ?case
    by simp
next
  case (suc x)
  then show ?case
    by (simp add: Int_absorb1 critical_set_oSuc_lemma normal.normal_set_range normal_oDeriv normal_set.range_oDeriv_subset)
next
  case (lim f)
  then show ?case
    unfolding critical_set_oLimit
    by (meson critical_set_mono lessI normal_set_INTER order_le_less strict_mono.strict_mono)
qed

lemma critical_set_oSuc:
  "normal_set A \<Longrightarrow> critical_set A (oSuc x) = range (oDeriv (ordering (critical_set A x)))"
  by (metis critical_set_oSuc_lemma inf.absorb_iff2 normal_set.range_oDeriv_subset normal_set_critical_set)

subsection \<open>Veblen hierarchy over a normal function\<close>

definition
  oVeblen :: "(ordinal \<Rightarrow> ordinal) \<Rightarrow> ordinal \<Rightarrow> ordinal \<Rightarrow> ordinal" where
  "oVeblen F = (\<lambda>x. ordering (critical_set (range F) x))"

lemma (in normal) oVeblen_0: "oVeblen F 0 = F"
  by (simp add: normal.ordering_range normal_axioms oVeblen_def)

lemma (in normal) oVeblen_oSuc: "oVeblen F (oSuc x) = oDeriv (oVeblen F x)"
  using critical_set_oSuc normal.normal_set_range normal.ordering_range normal_axioms normal_oDeriv oVeblen_def by presburger

lemma (in normal) oVeblen_oLimit:
"oVeblen F (oLimit f) = ordering (\<Inter>n. range (oVeblen F (f n)))"
 unfolding oVeblen_def
  using critical_set_oLimit normal_set.range_ordering normal_set_critical_set normal_set_range by presburger

lemma (in normal) normal_oVeblen: "normal (oVeblen F x)"
 unfolding oVeblen_def
  by (simp add: normal_set.normal_ordering normal_set_critical_set normal_set_range)

lemma (in normal) continuous_oVeblen_0: "continuous (\<lambda>x. oVeblen F x 0)"
proof (rule continuousI)
  fix f:: "nat \<Rightarrow> ordinal"
  assume f: "OrdinalInduct.strict_mono f"
  have "normal_set (critical_set (range F) (f n))" for n
    using normal_set_critical_set normal_set_range by blast
  moreover
  have "critical_set (range F) (f (Suc n)) \<subseteq> critical_set (range F) (f n)" for n
    by (simp add: f critical_set_mono strict_mono_monoD)
  ultimately show "oVeblen F (oLimit f) 0 = oLimit (\<lambda>n. oVeblen F (f n) 0)"
    using ordering_INTER_0 by (simp add: oVeblen_def critical_set_oLimit)
next
  show "\<And>x. oVeblen F x 0 \<le> oVeblen F (oSuc x) 0"
    by (simp add: le_oFix1 oVeblen_oSuc)
qed

lemma (in normal) oVeblen_oLimit_0:
  "oVeblen F (oLimit f) 0 = oLimit (\<lambda>n. oVeblen F (f n) 0)"
  by (rule continuousD[OF continuous_oVeblen_0])

lemma (in normal) normal_oVeblen_0:
  assumes "0 < F 0" shows "normal (\<lambda>x. oVeblen F x 0)"
proof -
  { fix x
    have "0 < oVeblen F x 0"
      by (metis leD ordinal_0_le ordinal_neq_0 continuous.monoD continuous_oVeblen_0 oVeblen_0 assms)
    then have "oVeblen F x 0 < oVeblen F x (oDeriv (oVeblen F x) 0)"
      by (simp add: normal.strict_monoD normal_oVeblen zero_less_oFix_eq)
    then have "oVeblen F x 0 < oVeblen F (oSuc x) 0"
      by (metis normal_oVeblen oDeriv_fixed oVeblen_oSuc)
  }
  then show ?thesis
    using continuous_def continuous_oVeblen_0 normalI by blast
qed

lemma (in normal) range_oVeblen:
  "range (oVeblen F x) = critical_set (range F) x"
  unfolding oVeblen_def
  using normal_set.range_ordering normal_set_critical_set normal_set_range by blast

lemma (in normal) range_oVeblen_subset:
  "x \<le> y \<Longrightarrow> range (oVeblen F y) \<subseteq> range (oVeblen F x)"
  using critical_set_mono range_oVeblen by presburger

lemma (in normal) oVeblen_fixed:
  assumes "x<y"
  shows "oVeblen F x (oVeblen F y a) = oVeblen F y a"
  using assms
proof (induction y arbitrary: x a rule: oLimit_induct)
  case zero
  then show ?case
    by auto
next
  case (suc u)
  then show ?case
    by (metis antisym_conv3 leD normal_oVeblen oDeriv_fixed oSuc_le_eq_less oVeblen_oSuc)
next
  case (lim f x a)
  then obtain n where "x < f n"
    using less_oLimitD by blast
  have "oVeblen F (oLimit f) a \<in> range (oVeblen F (f n))"
    by (simp add: range_oVeblen_subset range_subsetD)
  then show ?case
    using lim.IH \<open>x < f n\<close> by force
qed

lemma (in normal) critical_set_fixed:
  assumes "0 < z"
  shows "range (oVeblen F z) = {x. \<forall>y<z. oVeblen F y x = x}" (is "?L = ?R")
proof
  show "?L \<subseteq> ?R"
    using oVeblen_fixed by auto
  have "{x. \<forall>y<z. oVeblen F y x = x} \<subseteq> range (oVeblen F z)"
    using assms
  proof (induction z rule: oLimit_induct)
    case zero
    then show ?case by auto
  next
    case (suc x)
    then show ?case
      by (force simp: normal_oVeblen oVeblen_oSuc range_oDeriv)
  next
    case (lim f)
    show ?case
    proof clarsimp
      fix x
      assume "\<forall>y<oLimit f. oVeblen F y x = x"
      then have "x \<in> critical_set (range F) (f n)" for n
        by (metis lim.hyps rangeI range_oVeblen strict_mono_less_oLimit)
      then show "x \<in> range (oVeblen F (oLimit f))"
        by (simp add: range_oVeblen critical_set_oLimit)
    qed
  qed
  then show "?R \<subseteq> ?L"
    by blast
qed

subsection \<open>Veblen hierarchy over $\lambda x.\ 1 + x$\<close>

lemma oDeriv_id: "oDeriv id = id"
proof
  fix x show "oDeriv id x = id x"
    by (induction x rule: oLimit_induct) (auto simp add: oFix_eq_self)
qed

lemma oFix_plus: "oFix (\<lambda>x. a + x) 0 = a * \<omega>"
proof -
  have "iter n ((+) a) 0 = a * ordinal_of_nat n" for n
  proof (induction n)
    case 0
    then show ?case by auto
  next
    case (Suc n)
    have "a + a * ordinal_of_nat n = a * ordinal_of_nat n + a" for n
      by (induction n) (simp_all flip: ordinal_plus_assoc)
    with Suc show ?case by simp
  qed
  then show ?thesis
    by (simp add: oFix_def omega_def)
qed

lemma oDeriv_plus: "oDeriv ((+) a) = ((+) (a * \<omega>))"
proof
  show "oDeriv ((+) a) x = a * \<omega> + x" for x
  proof (induction x rule: oLimit_induct)
    case (suc x)
    then show ?case
      by (simp add: oFix_eq_self ordinal_plus_absorb)
  qed (auto simp: oFix_plus)
qed

lemma oVeblen_1_plus: "oVeblen ((+) 1) x = ((+) (\<omega> ** x))"
  using wf
proof (induction x rule: wf_induct_rule)
  case (less x)
  have "oVeblen ((+) (oSuc 0)) x = (+) (\<omega> ** x)"
  proof (cases x rule: ordinal_cases)
    case zero
    then show ?thesis
      by (simp add: normal.oVeblen_0 normal_plus)
  next
    case (suc y)
    with less show ?thesis
      by (simp add: normal.oVeblen_oSuc[OF normal_plus] oDeriv_plus)
  next
    case (lim f)
    show ?thesis
    proof (rule normal_range_eq)
      show "normal (oVeblen ((+) (oSuc 0)) x)"
        using normal.normal_oVeblen normal_plus by blast
      show "normal ((+) (\<omega> ** x))"
        using normal_plus by blast
      have "\<forall>y<oLimit f. \<omega> ** y + u = u \<Longrightarrow> u \<in> range ((+) (oLimit (\<lambda>n. \<omega> ** f n)))" for u
        by (metis rangeI lim oLimit_leI ordinal_le_plusR strict_mono_less_oLimit ordinal_plus_minus2)
      moreover
      have "\<omega> ** y + (oLimit (\<lambda>n. \<omega> ** f n) + u) = oLimit (\<lambda>n. \<omega> ** f n) + u"
        if "y < oLimit f" for u y
        by (metis absorb_omega_exp2 ordinal_exp_oLimit ordinal_plus_assoc that zero_less_omega)
      ultimately show "range (oVeblen ((+) (oSuc 0)) x) = range ((+) (\<omega> ** x))"
        using less lim
        by (force simp add: strict_mono_limit_ordinal normal.critical_set_fixed[OF normal_plus])
    qed
  qed
  then show ?case
    by simp
qed

end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Number Partitions\<close>

theory Number_Partition
imports Additions_to_Main
begin

subsection \<open>Number Partitions as @{typ "nat => nat"} Functions\<close>

definition partitions :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> bool" (infix "partitions" 50)
where
  "p partitions n = ((\<forall>i. p i \<noteq> 0 \<longrightarrow> 1 \<le> i \<and> i \<le> n) \<and> (\<Sum>i\<le>n. p i * i) = n)"

lemma partitionsI:
  assumes "\<And>i. p i \<noteq> 0 \<Longrightarrow> 1 \<le> i \<and> i \<le> n"
  assumes "(\<Sum>i\<le>n. p i * i) = n"
  shows "p partitions n"
using assms unfolding partitions_def by auto

lemma partitionsE:
  assumes "p partitions n"
  obtains "\<And>i. p i \<noteq> 0 \<Longrightarrow> 1 \<le> i \<and> i \<le> n" "(\<Sum>i\<le>n. p i * i) = n"
using assms unfolding partitions_def by auto

lemma partitions_zero:
  "p partitions 0 \<longleftrightarrow> p = (\<lambda>i. 0)"
unfolding partitions_def by auto

lemma partitions_one:
  "p partitions (Suc 0) \<longleftrightarrow> p = (\<lambda>i. 0)(1 := 1)"
unfolding partitions_def
by (auto split: if_split_asm) (auto simp add: fun_eq_iff)

subsection \<open>Bounds and Finiteness of Number Partitions\<close>

lemma partitions_imp_finite_elements:
  assumes "p partitions n"
  shows "finite {i. 0 < p i}"
proof -
  from assms have "{i. 0 < p i} \<subseteq> {..n}" by (auto elim: partitionsE)
  from this show ?thesis
    using rev_finite_subset by blast
qed

lemma partitions_bounds:
  assumes "p partitions n"
  shows "p i \<le> n"
proof -
  from assms have index_bounds: "(\<forall>i. p i \<noteq> 0 \<longrightarrow> 1 \<le> i \<and> i \<le> n)"
    and sum: "(\<Sum>i\<le>n. p i * i) = n"
    unfolding partitions_def by auto
  show ?thesis
  proof (cases "1 \<le> i \<and> i \<le> n")
    case True
    from True have "{..n} = insert i {i'. i' \<le> n \<and> i' \<noteq> i}" by blast
    from sum[unfolded this] have "p i * i + (\<Sum>i\<in>{i'. i' \<le> n \<and> i' \<noteq> i}. p i * i) = n" by auto
    from this have "p i * i \<le> n" by linarith
    from this True show ?thesis using dual_order.trans by fastforce
  next
    case False
    from this index_bounds show ?thesis by fastforce
  qed
qed

lemma partitions_parts_bounded:
  assumes "p partitions n"
  shows "sum p {..n} \<le> n"
proof -
  {
    fix i
    assume "i \<le> n"
    from assms have "p i \<le> p i * i"
      by (auto elim!: partitionsE)
  }
  from this have "sum p {..n} \<le> (\<Sum>i\<le>n. p i * i)"
    by (auto intro: sum_mono)
  also from assms have n: "(\<Sum>i\<le>n. p i * i) = n"
    by (auto elim!: partitionsE)
  finally show ?thesis .
qed

lemma finite_partitions:
  "finite {p. p partitions n}"
proof -
  have "{p. p partitions n} \<subseteq> {f. (\<forall>i. f i \<le> n) \<and> (\<forall>i. n + 1 \<le> i \<longrightarrow> f i = 0)}"
    by (auto elim: partitions_bounds) (auto simp add: partitions_def)
  from this bound_domain_and_range_impl_finitely_many_functions[of n "n + 1"] show ?thesis
    by (simp add: finite_subset)
qed

lemma finite_partitions_k_parts:
  "finite {p. p partitions n \<and> sum p {..n} = k}"
by (simp add: finite_partitions)

lemma partitions_remaining_Max_part:
  assumes "p partitions n"
  assumes "0 < p k"
  shows "\<forall>i. n - k < i \<and> i \<noteq> k \<longrightarrow> p i = 0"
proof (clarify)
  fix i
  assume "n - k < i" "i \<noteq> k"
  show "p i = 0"
  proof (cases "i \<le> n")
    assume "i \<le> n"
    from assms have n: "(\<Sum>i\<le>n. p i * i) = n" and "k \<le> n"
      by (auto elim: partitionsE)
    have "(\<Sum>i\<le>n. p i * i) = p k * k + (\<Sum>i\<in>{..n}-{k}. p i * i)"
      using \<open>k \<le> n\<close> sum_atMost_remove_nat by blast
    also have "... = p i * i + p k * k + (\<Sum>i\<in>{..n}-{i, k}. p i * i)"
      using \<open>i \<le> n\<close> \<open>i \<noteq> k\<close>
      by (auto simp add: sum.remove[where x="i"]) (metis Diff_insert)
    finally have eq: "(\<Sum>i\<le>n. p i * i) = p i * i + p k * k + (\<Sum>i\<in>{..n} - {i, k}. p i * i)" .
    show "p i = 0"
    proof (rule ccontr)
      assume "p i \<noteq> 0"
      have upper_bound: "p i * i + p k * k \<le> n"
        using eq n by auto
      have lower_bound: "p i * i + p k * k > n"
        using \<open>n - k < i\<close> \<open>0 < p k\<close> \<open>k \<le> n\<close> \<open>p i \<noteq> 0\<close> mult_eq_if not_less by auto
      from upper_bound lower_bound show False by simp
    qed
  next
    assume "\<not> (i \<le> n)"
    from this show "p i = 0"
      using assms(1) by (auto elim: partitionsE)
  qed
qed

subsection \<open>Operations of Number Partitions\<close>

lemma partitions_remove1_bounds:
  assumes partitions: "p partitions n"
  assumes gr0: "0 < p k"
  assumes neq: "(p(k := p k - 1)) i \<noteq> 0"
  shows "1 \<le> i \<and> i \<le> n - k"
proof
    from partitions neq show "1 \<le> i"
      by (auto elim!: partitionsE split: if_split_asm)
next
  from partitions gr0 have n: "(\<Sum>i\<le>n. p i * i) = n" and "k \<le> n"
    by (auto elim: partitionsE)
  show "i \<le> n - k"
  proof cases
    assume "k \<le> n - k"
    from \<open>k \<le> n - k\<close> neq show ?thesis
      using  partitions_remaining_Max_part[OF partitions gr0] not_le by force
  next
    assume "\<not> k \<le> n - k"
    from this have "2 * k > n" by auto
    have "p k = 1"
    proof (rule ccontr)
      assume "p k \<noteq> 1"
      with gr0 have "p k \<ge> 2" by auto
      from this have "p k * k \<ge> 2 * k" by simp
      with \<open>2 * k > n\<close> have "p k * k > n" by linarith
      from \<open>k \<le> n\<close> this have "(\<Sum>i\<le>n. p i * i) > n"
        by (simp add: sum_atMost_remove_nat[of k])
      from this n show "False" by auto
    qed
    from neq this show ?thesis
      using partitions_remaining_Max_part[OF partitions gr0] leI
      by (auto split: if_split_asm) force
  qed
qed

lemma partitions_remove1:
  assumes partitions: "p partitions n"
  assumes gr0: "0 < p k"
  shows "p(k := p k - 1) partitions (n - k)"
proof (rule partitionsI)
  fix i
  assume "(p(k := p k - 1)) i \<noteq> 0"
  from this show "1 \<le> i \<and> i \<le> n - k" using partitions_remove1_bounds partitions gr0 by blast
next
  from partitions gr0 have "k \<le> n" by (auto elim: partitionsE)
  have "(\<Sum>i\<le>n - k. (p(k := p k - 1)) i * i) = (\<Sum>i\<le>n. (p(k := p k - 1)) i * i)"
    using partitions_remove1_bounds partitions gr0 by (auto intro!: sum.mono_neutral_left)
  also have "... = (p k - 1) * k + (\<Sum>i\<in>{..n} - {k}. (p(k := p k - 1)) i * i)"
    using \<open>k \<le> n\<close> by (simp add: sum_atMost_remove_nat[where k="k"])
  also have "... = p k * k + (\<Sum>i\<in>{..n} - {k}. p i * i) - k"
    using gr0 by (simp add: diff_mult_distrib)
  also have "... = (\<Sum>i\<le>n. p i * i) - k"
    using \<open>k \<le> n\<close> by (simp add: sum_atMost_remove_nat[of k])
  also from partitions have "... = n - k"
    by (auto elim: partitionsE)
  finally show "(\<Sum>i\<le>n - k. (p(k := p k - 1)) i * i) = n - k" .
qed

lemma partitions_insert1:
  assumes p: "p partitions n"
  assumes "k > 0"
  shows "(p(k := p k + 1)) partitions (n + k)"
proof (rule partitionsI)
  fix i
  assume "(p(k := p k + 1)) i \<noteq> 0"
  from p this \<open>k > 0\<close> show "1 \<le> i \<and> i \<le> n + k"
    by (auto elim!: partitionsE)
next
  have "(\<Sum>i\<le>n + k. (p(k := p k + 1)) i * i) = p k * k + (\<Sum>i\<in>{..n + k} - {k}. p i * i) + k"
    by (simp add: sum_atMost_remove_nat[of k])
  also have "... = p k * k + (\<Sum>i\<in>{..n} - {k}. p i * i) + k"
    using p by (auto intro!: sum.mono_neutral_right elim!: partitionsE)
  also have "... = (\<Sum>i\<le>n. p i * i) + k"
    using p by (cases "k \<le> n") (auto simp add: sum_atMost_remove_nat[of k] elim: partitionsE)
  also have "... = n + k"
    using p by (auto elim: partitionsE)
  finally show "(\<Sum>i\<le>n + k. (p(k := p k + 1)) i * i) = n + k" .
qed

lemma count_remove1:
  assumes "p partitions n"
  assumes "0 < p k"
  shows "(\<Sum>i\<le>n - k. (p(k := p k - 1)) i) = (\<Sum>i\<le>n. p i) - 1"
proof -
  have "k \<le> n" using assms by (auto elim: partitionsE)
  have "(\<Sum>i\<le>n - k. (p(k := p k - 1)) i) = (\<Sum>i\<le>n. (p(k := p k - 1)) i)"
    using partitions_remove1_bounds assms by (auto intro!: sum.mono_neutral_left)
  also have "(\<Sum>i\<le>n. (p(k := p k - 1)) i) = p k + (\<Sum>i\<in>{..n} - {k}. p i) - 1"
    using \<open>0 < p k\<close> \<open>k \<le> n\<close> by (simp add: sum_atMost_remove_nat[of k])
  also have "... = (\<Sum>i\<in>{..n}. p i) - 1"
    using \<open>k \<le> n\<close> by (simp add: sum_atMost_remove_nat[of k])
  finally show ?thesis .
qed

lemma count_insert1:
  assumes "p partitions n"
  shows "sum (p(k := p k + 1)) {..n + k} = (\<Sum>i\<le>n. p i) + 1"
proof -
  have "(\<Sum>i\<le>n + k. (p(k := p k + 1)) i) = p k + (\<Sum>i\<in>{..n + k} - {k}. p i) + 1"
    by (simp add: sum_atMost_remove_nat[of k])
  also have "... = p k + (\<Sum>i\<in>{..n} - {k}. p i) + 1"
    using assms by (auto intro!: sum.mono_neutral_right elim!: partitionsE)
  also have "... = (\<Sum>i\<le>n. p i) + 1"
    using assms by (cases "k \<le> n") (auto simp add: sum_atMost_remove_nat[of k] elim: partitionsE)
  finally show ?thesis .
qed

lemma partitions_decrease1:
  assumes p: "p partitions m"
  assumes sum: "sum p {..m} = k"
  assumes "p 1 = 0"
  shows "(\<lambda>i. p (i + 1)) partitions m - k"
proof -
  from p have "p 0 = 0" by (auto elim!: partitionsE)
  {
    fix i
    assume neq: "p (i + 1) \<noteq> 0"
    from p this \<open>p 1 = 0\<close> have "1 \<le> i"
      by (fastforce elim!: partitionsE simp add: le_Suc_eq)
    moreover have "i \<le> m - k"
    proof (rule ccontr)
      assume i_greater: "\<not> i \<le> m - k"
      from p have s: "(\<Sum>i\<le>m. p i * i) = m"
        by (auto elim!: partitionsE)
      from p sum have "k \<le> m"
        using partitions_parts_bounded by fastforce
      from neq p have "i + 1 \<le> m" by (auto elim!: partitionsE)
      from i_greater have "i > m - k" by simp
      have ineq1: "i + 1 > (m - k) + 1"
        using i_greater by simp
      have ineq21: "(\<Sum>j\<le>m. (p(i + 1 := p (i + 1) - 1)) j * j) \<ge> (\<Sum>j\<le>m. (p(i + 1 := p (i + 1) - 1)) j)"
        using \<open>p 0 = 0\<close> not_less by (fastforce intro!: sum_mono)
      have ineq22a: "(\<Sum>j\<le>m. (p(i + 1 := p (i + 1) - 1)) j) = (\<Sum>j\<le>m. p j) - 1"
        using \<open>i + 1 \<le> m\<close> neq by (simp add: sum.remove[where x="i + 1"])
      have ineq22: "(\<Sum>j\<le>m. (p(i + 1 := p (i + 1) - 1)) j) \<ge> k - 1"
        using sum neq ineq22a by auto
      have ineq2: "(\<Sum>j\<le>m. (p(i + 1 := p (i + 1) - 1)) j * j) \<ge> k - 1"
        using ineq21 ineq22 by auto
      have "(\<Sum>i\<le>m. p i * i) = p (i + 1) * (i + 1) + (\<Sum>i\<in>{..m} - {i + 1}. p i * i)"
        using \<open>i + 1 \<le> m\<close> neq
        by (subst sum.remove[where x="i + 1"]) auto
      also have "... = (i + 1) + (\<Sum>j\<le>m. (p(i + 1 := p (i + 1) - 1)) j * j)"
        using \<open>i + 1 \<le> m\<close> neq
        by (subst sum.remove[where x="i + 1" and g="\<lambda>j. (p(i + 1 := p (i + 1) - 1)) j * j"])
          (auto simp add: mult_eq_if)
      finally have "(\<Sum>i\<le>m. p i * i) = i + 1 + (\<Sum>j\<le>m. (p(i + 1 := p (i + 1) - 1)) j * j)" .
      moreover have "... > m" using ineq1 ineq2 \<open>k \<le> m\<close> \<open>p (i + 1) \<noteq> 0\<close> by linarith
      ultimately have "(\<Sum>i\<le>m. p i * i) > m" by simp
      from s this show False by simp
    qed
    ultimately have "1 \<le> i \<and> i \<le> m - k" ..
  } note bounds = this
  show "(\<lambda>i. p (i + 1)) partitions m - k"
  proof (rule partitionsI)
    fix i
    assume "p (i + 1) \<noteq> 0"
    from bounds this show "1 \<le> i \<and> i \<le> m - k" .
  next
    have geq: "\<forall>i. p i * i \<ge> p i"
      using \<open>p 0 = 0\<close> not_less by fastforce
    have "(\<Sum>i\<le>m - k. p (i + 1) * i) = (\<Sum>i\<le>m. p (i + 1) * i)"
      using bounds by (auto intro: sum.mono_neutral_left)
    also have "... = (\<Sum>i\<in>Suc ` {..m}. p i * (i - 1))"
      by (auto simp add: sum.reindex)
    also have "... = (\<Sum>i\<le>Suc m. p i * (i - 1))"
      using \<open>p 0 = 0\<close>
      by (simp add: atMost_Suc_eq_insert_0)
    also have "... = (\<Sum>i\<le>m. p i * (i - 1))"
      using p by (auto elim!: partitionsE)
    also have "... = (\<Sum>i\<le>m. p i * i - p i)"
      by (simp add: diff_mult_distrib2)
    also have "... = (\<Sum>i\<le>m. p i * i) - (\<Sum>i\<le>m. p i)"
      using geq by (simp only: sum_subtractf_nat)
    also have "... = m - k" using sum p by (auto elim!: partitionsE)
    finally show "(\<Sum>i\<le>m - k. p (i + 1) * i) = m - k" .
  qed
qed

lemma partitions_increase1:
  assumes partitions: "p partitions m - k"
  assumes k: "sum p {..m - k} = k"
  shows "(\<lambda>i. p (i - 1)) partitions m"
proof (rule partitionsI)
  fix i
  assume "p (i - 1) \<noteq> 0"
  from partitions this k show "1 \<le> i \<and> i \<le> m"
    by (cases k) (auto elim!: partitionsE)
next
  from k partitions have "k \<le> m"
    using linear partitions_zero by force
  have eq_0: "\<forall>i>m - k. p i = 0" using partitions by (auto elim!: partitionsE)
  from partitions have s: "(\<Sum>i\<le>m - k. p i * i) = m - k" by (auto elim!: partitionsE)
  have "(\<Sum>i\<le>m. p (i - 1) * i) = (\<Sum>i\<le>Suc m. p (i - 1) * i)"
    using partitions k by (cases k) (auto elim!: partitionsE)
  also have "(\<Sum>i\<le>Suc m. p (i - 1) * i) = (\<Sum>i\<le>m. p i * (i + 1))"
    by (subst sum.atMost_Suc_shift) simp
  also have "... = (\<Sum>i\<le>m - k. p i * (i + 1))"
    using eq_0 by (auto intro: sum.mono_neutral_right)
  also have "... = (\<Sum>i\<le>m - k. p i * i) + (\<Sum>i\<le>m - k. p i)" by (simp add: sum.distrib)
  also have "... = m - k + k" using s k by simp
  also have "... = m" using \<open>k \<le> m\<close> by simp
  finally show "(\<Sum>i\<le>m. p (i - 1) * i) = m" .
qed

lemma count_decrease1:
  assumes p: "p partitions m"
  assumes sum: "sum p {..m} = k"
  assumes "p 1 = 0"
  shows "sum (\<lambda>i. p (i + 1)) {..m - k} = k"
proof -
  from p have "p 0 = 0" by (auto elim!: partitionsE)
  have "sum (\<lambda>i. p (i + 1)) {..m - k} = sum (\<lambda>i. p (i + 1)) {..m}"
    using partitions_decrease1[OF assms]
    by (auto intro: sum.mono_neutral_left elim!: partitionsE)
  also have "\<dots> = sum (\<lambda>i. p (i + 1)) {0..m}" by (simp add: atLeast0AtMost)
  also have "\<dots> = sum (\<lambda>i. p i) {Suc 0.. Suc m}"
    by (simp only: One_nat_def add_Suc_right add_0_right sum.shift_bounds_cl_Suc_ivl)
  also have "\<dots> = sum (\<lambda>i. p i) {.. Suc m}"
    using \<open>p 0 = 0\<close> by (simp add: atLeast0AtMost sum_shift_lb_Suc0_0)
  also have "\<dots> = sum (\<lambda>i. p i) {.. m}"
    using p by (auto elim!: partitionsE)
  also have "\<dots> = k"
    using sum by simp
  finally show ?thesis .
qed

lemma count_increase1:
  assumes partitions: "p partitions m - k"
  assumes k: "sum p {..m - k} = k"
  shows "(\<Sum>i\<le>m. p (i - 1)) = k"
proof -
  have "p 0 = 0" using partitions by (auto elim!: partitionsE)
  have "(\<Sum>i\<le>m. p (i - 1)) = (\<Sum>i\<in>{1..m}. p (i - 1))"
    using \<open>p 0 = 0\<close> by (auto intro: sum.mono_neutral_cong_right)
  also have "(\<Sum>i\<in>{1..m}. p (i - 1)) = (\<Sum>i\<le>m - 1. p i)"
  proof (cases m)
    case 0
    from this show ?thesis using \<open>p 0 = 0\<close> by simp
  next
    case (Suc m')
    {
      fix x assume "Suc 0 \<le> x" "x \<le> m"
      from this Suc have "x \<in> Suc ` {..m'}"
        by (auto intro!: image_eqI[where x="x - 1"])
    }
    from this Suc show ?thesis
      by (intro sum.reindex_cong[of Suc]) auto
  qed
  also have "(\<Sum>i\<le>m - 1. p i) = (\<Sum>i\<le>m. p i)"
  proof -
    {
      fix i
      assume "0 < p i" "i \<le> m"
      from assms this have "i \<le> m - 1"
        using \<open>p 0 = 0\<close> partitions_increase1 by (cases k) (auto elim!: partitionsE)
    }
    from this show ?thesis
      by (auto intro: sum.mono_neutral_cong_left)
  qed
  also have "... = (\<Sum>i\<le>m - k. p i)"
    using partitions by (auto intro: sum.mono_neutral_right elim!: partitionsE)
  also have "... = k" using k by auto
  finally show ?thesis .
qed

subsection \<open>Number Partitions as Multisets on Natural Numbers\<close>

definition number_partition :: "nat \<Rightarrow> nat multiset \<Rightarrow> bool"
where
  "number_partition n N = (sum_mset N = n \<and> 0 \<notin># N)"

subsubsection \<open>Relationship to Definition on Functions\<close>

lemma count_partitions_iff:
  "count N partitions n \<longleftrightarrow> number_partition n N"
proof
  assume "count N partitions n"
  from this have "(\<forall>i. count N i \<noteq> 0 \<longrightarrow> 1 \<le> i \<and> i \<le> n)" "(\<Sum>i\<le>n. count N i * i) = n"
    unfolding Number_Partition.partitions_def by auto
  moreover from this have "set_mset N \<subseteq> {..n}" by auto
  moreover have "finite {..n}" by auto
  ultimately have "sum_mset N = n"
    using sum_mset_sum_count sum_mset_eq_sum_on_supersets by presburger
  moreover have "0 \<notin># N"
    using \<open>\<forall>i. count N i \<noteq> 0 \<longrightarrow> 1 \<le> i \<and> i \<le> n\<close> by auto
  ultimately show "number_partition n N"
    unfolding number_partition_def by auto
next
  assume "number_partition n N"
  from this have "sum_mset N = n" and "0 \<notin># N"
    unfolding number_partition_def by auto
  {
    fix i
    assume "count N i \<noteq> 0"
    have "1 \<le> i \<and> i \<le> n"
    proof
      from \<open>0 \<notin># N\<close> \<open>count N i \<noteq> 0\<close> show "1 \<le> i"
        using Suc_le_eq by auto
      from \<open>sum_mset N = n\<close> \<open>count N i \<noteq> 0\<close> show "i \<le> n"
        using multi_member_split by fastforce
    qed
  }
  moreover from \<open>sum_mset N = n\<close> have "(\<Sum>i\<le>n. count N i * i) = n"
    by (metis atMost_iff calculation finite_atMost not_in_iff subsetI sum_mset_eq_sum_on_supersets sum_mset_sum_count)
  ultimately show "count N partitions n"
    by (rule partitionsI) auto
qed

lemma partitions_iff_Abs_multiset:
  "p partitions n \<longleftrightarrow> finite {x. 0 < p x} \<and> number_partition n (Abs_multiset p)"
proof
  assume "p partitions n"
  from this have bounds: "(\<forall>i. p i \<noteq> 0 \<longrightarrow> 1 \<le> i \<and> i \<le> n)"
    and sum: "(\<Sum>i\<le>n. p i * i) = n"
  unfolding partitions_def by auto
  from \<open>p partitions n\<close> have "finite {x. 0 < p x}"
    by (rule partitions_imp_finite_elements)
  moreover from \<open>finite {x. 0 < p x}\<close> bounds have "\<not> 0 \<in># Abs_multiset p"
    using count_eq_zero_iff by force
  moreover from \<open>finite {x. 0 < p x}\<close> this sum have "sum_mset (Abs_multiset p) = n"
  proof -
    have "(\<Sum>i\<in>{x. 0 < p x}. p i * i) = (\<Sum>i\<le>n. p i * i)"
      using bounds by (auto intro: sum.mono_neutral_cong_left)
    from \<open>finite {x. 0 < p x}\<close> this sum show "sum_mset (Abs_multiset p) = n"
      by (simp add: sum_mset_sum_count set_mset_Abs_multiset)
  qed
  ultimately show "finite {x. 0 < p x} \<and> number_partition n (Abs_multiset p)"
    unfolding number_partition_def by auto
next
  assume "finite {x. 0 < p x} \<and> number_partition n (Abs_multiset p)"
  from this have "finite {x. 0 < p x}" "0 \<notin># Abs_multiset p" "sum_mset (Abs_multiset p) = n"
    unfolding number_partition_def by auto
  from \<open>finite {x. 0 < p x}\<close> have "(\<Sum>i\<in>{x. 0 < p x}. p i * i) = n"
    using \<open> sum_mset (Abs_multiset p) = n\<close>
    by (simp add: sum_mset_sum_count set_mset_Abs_multiset)
  have bounds: "\<And>i. p i \<noteq> 0 \<Longrightarrow> 1 \<le> i \<and> i \<le> n"
  proof
    fix i
    assume "p i \<noteq> 0"
    from \<open>\<not> 0 \<in># Abs_multiset p\<close> \<open>finite {x. 0 < p x}\<close> have "p 0 = 0"
      using count_inI by force
    from this \<open>p i \<noteq> 0\<close> show "1 \<le> i"
      by (metis One_nat_def leI less_Suc0)
    show "i \<le> n"
    proof (rule ccontr)
      assume "\<not> i \<le> n"
      from this have "i > n"
        using le_less_linear by blast
      from this \<open>p i \<noteq> 0\<close> have "p i * i > n"
        by (auto simp add: less_le_trans)
      from \<open>p i \<noteq> 0\<close> have "(\<Sum>i\<in>{x. 0 < p x}. p i * i) = p i * i + (\<Sum>i\<in>{x. 0 < p x} - {i}. p i * i)"
        using \<open>finite {x. 0 < p x}\<close>
        by (subst sum.insert_remove[symmetric]) (auto simp add: insert_absorb)
      also from \<open>p i * i > n\<close> have "\<dots> > n" by auto
      finally show False using \<open>(\<Sum>i\<in>{x. 0 < p x}. p i * i) = n\<close> by blast
    qed
  qed
  moreover have "(\<Sum>i\<le>n. p i * i) = n"
  proof -
    have "(\<Sum>i\<le>n. p i * i) = (\<Sum>i\<in>{x. 0 < p x}. p i * i)"
      using bounds by (auto intro: sum.mono_neutral_cong_right)
    from this show ?thesis
      using \<open>(\<Sum>i\<in>{x. 0 < p x}. p i * i) = n\<close> by simp
  qed
  ultimately show "p partitions n" by (auto intro: partitionsI)
qed

lemma size_nat_multiset_eq:
  fixes N :: "nat multiset"
  assumes "number_partition n N"
  shows "size N = sum (count N) {..n}"
proof -
  have "set_mset N \<subseteq> {..sum_mset N}"
    by (auto dest: multi_member_split)
  have "size N = sum (count N) (set_mset N)"
    by (rule size_multiset_overloaded_eq)
  also have "\<dots> = sum (count N) {..sum_mset N}"
    using \<open>set_mset N \<subseteq> {..sum_mset N}\<close>
    by (auto intro: sum.mono_neutral_cong_left count_inI)
  finally show ?thesis
    using \<open>number_partition n N\<close>
    unfolding number_partition_def by auto
qed

end


theory Types
  imports Main HOL.Real
begin

subsection \<open>datatype\<close>

datatype ITree = Leaf int | Node ITree int ITree

term Leaf
term Node

primrec ITreeSum :: "ITree \<Rightarrow> int"
  where "ITreeSum (Leaf v) = v" |
        "ITreeSum (Node left v right) = ITreeSum left + v + ITreeSum right"

definition "ITree1 \<equiv> Node (Node (Leaf 4) 5 (Node (Leaf 1) 8 (Leaf 2))) 10 (Node (Leaf 7) 9 (Leaf 15))"

value "ITreeSum ITree1"

datatype Fruit = APPLE | ORANGE | BANANA

term APPLE

value APPLE

lemma "APPLE \<noteq> ORANGE" by simp

primrec showfruit :: "Fruit \<Rightarrow> string"
  where "showfruit APPLE = ''it is an apple''" |
        "showfruit ORANGE = ''it is an orange''" |
        "showfruit BANANA = ''it is a banana''"

datatype Exp = B bool | I int | N nat

term B
term I
term N

datatype Type = Bool | Integer | Nature

value "B True"

primrec type :: "Exp \<Rightarrow> Type"
  where "type (B a) = Bool" |
        "type (I a) = Integer" |
        "type (N a) = Nature"

value "type (B a)"

datatype boolex = Const bool | Var nat | Neg boolex | And boolex boolex | Or boolex boolex
type_synonym env = "nat \<Rightarrow> bool"

primrec eval :: "boolex \<Rightarrow> env \<Rightarrow> bool"
  where "eval (Const a) ev = a" |
        "eval (Var v) ev = ev v" |
        "eval (Neg e) ev = (\<not> eval e ev)" |
        "eval (And e1 e2) ev = (eval e1 ev \<and> eval e2 ev)" |
        "eval (Or e1 e2) ev = (eval e1 ev \<or> eval e2 ev)"

definition env1 :: "env"
  where "env1 n \<equiv> (if n mod 2 = 0 then True else False)"

value "eval (Var 1) env1"

value "eval (And (Var 2) (Var 4)) env1"

value "eval (And (Or (Const True) (Var 1)) (Neg (Var 4))) env1"

subsubsection \<open>mutual recursion\<close>

datatype aexp = IF bexp aexp aexp | Add aexp aexp | Sub aexp aexp | Num nat
   and   bexp = Less aexp aexp | And bexp bexp | Neg bexp

primrec evala :: "aexp \<Rightarrow> nat" and
        evalb :: "bexp \<Rightarrow> bool" where
  "evala (IF b a1 a2) = (if (evalb b) then evala a1 else evala a2)" |
  "evala (Add a1 a2) = (evala a1) + (evala a2)" |
  "evala (Sub a1 a2) = (evala a1) - (evala a2)" |
  "evala (Num a) = a" |
  "evalb (Less a1 a2) = (evala a1 < evala a2)" |
  "evalb (And b1 b2) = (evalb b1 \<and> evalb b2)" |
  "evalb (Neg b) = (\<not> evalb b)"

value "evala (IF (Less (Num 10) (Num 20)) (Num 1) (Num 2))"

value "evalb (Less (Num 50) (Num 100))"

subsection \<open>product, pair and tuple\<close>

typedecl Vertex

record Vert = xpos :: int
              ypos :: int

axiomatization v1 :: Vertex
        and    v2 :: Vertex
        and    v3 :: Vertex
        and    v4 :: Vertex
        and    v5 :: Vertex
        and    v6 :: Vertex
        and    v7 :: Vertex
        where assum: "distinct [v1,v2,v3,v4,v5,v6,v7]"

definition rel1 :: "Vertex \<times> Vertex"
  where "rel1 \<equiv> (v1,v2)"

definition Agraph :: "(Vertex \<times> Vertex) set"
  where "Agraph \<equiv> {(v1, v2), (v1, v3), (v2, v4), (v4, v3), (v4, v5), (v3, v6), (v5, v7), (v6, v7)}"

term "()"

term "(v1, v2)"

term "Pair v1 v2"

term Pair

lemma "(v1, v2) = Pair v1 v2" by simp

definition "conn1 \<equiv> (v1, v2)"

lemma "fst conn1 = v1" by (simp add:conn1_def)

lemma "snd conn1 = v2" by (simp add:conn1_def)

lemma "(v1, v2) \<noteq> (v2, v1)"
  using assum by auto

lemma "(x,y) = (a,b) \<longleftrightarrow> x = a \<and> y = b"
  by auto

definition h :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where "h x y \<equiv> x + y"

term h

definition h2 :: "(nat \<times> nat) \<Rightarrow> nat"
  where "h2 \<equiv> \<lambda>(x,y). x + y"

lemma "case_prod h = h2"
  unfolding h_def h2_def by simp

lemma "curry h2 = h"
  unfolding h_def h2_def by simp

value "h2 (Pair 1 2)"
value "h2 (1,2)"
value "h 1 2"

lemma "(a,b,c) = (a,(b,c))" by simp

term "((a,b),c)"

term "(a,b,c)"

value "fst ((a,b),c)"
value "fst (a,b,c)"
value "snd ((a,b),c)"
value "snd (a,b,c)"
value "fst (fst ((a,b),c))"
value "snd (fst ((a,b),c))"

subsection \<open>record\<close>

record coord2d = Xpt :: int
                 Ypt :: int

term Xpt
term Ypt

print_record coord2d

definition coord1 :: "coord2d"
  where "coord1 \<equiv> \<lparr>Xpt = 20, Ypt = 30\<rparr>"

value "Xpt coord1"

definition coord1' :: "coord2d"
  where "coord1' \<equiv> coord1\<lparr>Ypt := 50\<rparr>"

value "coord1'"

definition incX :: "coord2d \<Rightarrow> coord2d"
  where "incX r \<equiv> r\<lparr>Xpt := Xpt r + 1\<rparr>"

value "incX coord1"

lemma "coord1\<lparr>Ypt := 50\<rparr> = \<lparr>Xpt = 20, Ypt = 50\<rparr>"
  unfolding coord1_def by simp

record coord3d = coord2d +
                  Zpt :: int

definition coord3 :: "coord3d"
  where "coord3 \<equiv> \<lparr>Xpt = 20, Ypt = 30, Zpt = 40\<rparr>"

value "Xpt coord3"
value "Zpt coord3"

definition coord3' :: "coord3d"
  where "coord3' \<equiv> coord3\<lparr>Zpt := 50\<rparr>"

value "coord3'"

value "coord2d.more coord3"

term "\<lparr>Xpt = 20, Ypt = 30, Zpt = 40\<rparr>"

record coord4d = coord3d +
                 Time :: int

definition coord4 :: "coord4d"
  where "coord4 \<equiv> \<lparr>Xpt = 20, Ypt = 30, Zpt = 40, Time = 1000\<rparr>"

value "\<lparr>Xpt = 20, Ypt = 30, Zpt = 40, Time = 1000\<rparr>"
value "coord4d.make 20 30 40 1000"

type_synonym recT1 = "\<lparr>Xpt :: int, Ypt :: int, Time :: int\<rparr>"

print_record recT1

type_synonym recT2 = "\<lparr>Xpt :: int, Ypt :: int, Zpt :: int, Time :: int\<rparr>"

print_record recT2

value "coord2d.more coord4"

lemma "\<lparr>Xpt = a1, Ypt = b1\<rparr> = \<lparr>Xpt = a2, Ypt = b2\<rparr> \<longleftrightarrow> a1 = a2 \<and> b1 = b2"
  by simp

lemma "r = \<lparr>Xpt = Xpt r, Ypt = Ypt r, \<dots> = coord2d.more r\<rparr>"
  by simp

value "coord2d.Xpt coord1"

value "coord2d.make 5 5"

term Time

definition "coord5 \<equiv> coord4d.extend coord4 (True)"
value "coord5"
value "\<lparr>Xpt = 20, Ypt = 30, Zpt = 40, Time = 1000, \<dots> = True\<rparr>"
value "more coord5"

value "coord2d.more coord4"

value "coord2d.truncate \<lparr>Xpt = Xpt coord1, Ypt = Ypt coord1, \<dots> = 50::int\<rparr>"

term "\<lparr>Xpt = 10, Ypt = 20, \<dots> = 40::int \<rparr>"

value "Xpt \<lparr>Xpt = 10, Ypt = 20, \<dots> = p\<rparr>"

value "coord2d.truncate coord3"

value "coord3d.fields 100"
value "coord4d.fields 200"
value "coord2d.more coord4"
value "coord3d.more coord4"
term "coord4d.fields"
term "coord3d.more"
value "coord3d.more (coord3d.extend coord3 ''hello'')"

value "coord2d.extend coord1 (coord3d.fields 50)"

subsection \<open>parameteric types\<close>

record 'a Coord3d = xpos :: 'a
                    ypos :: 'a
                    zpos :: 'a

record 'a Coord4d = "'a Coord3d " +
                    Time :: 'a

definition coord6 :: "int Coord3d"
  where "coord6 \<equiv> \<lparr>xpos = 10, ypos = 20, zpos = 30\<rparr>"

definition coord7 :: "real Coord3d"
  where "coord7 \<equiv> \<lparr>xpos = 10.3::real, ypos = 20.3, zpos = 30.5\<rparr>"

definition "coord9 \<equiv> \<lparr>xpos = 10.3::real, ypos = 20.3, zpos = 30.5, Time = 1000.0\<rparr>"

value "Coord3d.extend coord6 ''hello''"
value "Coord3d.extend coord7 ''good''"

value "truncate coord9"

record ('a, 'b, 'c) COORD3d = Xp :: 'a
                              Yp :: 'b
                              Zp :: 'c

definition coord10 :: "(int, string, real) COORD3d"
  where "coord10 \<equiv> \<lparr>Xp = 10, Yp = ''20w'', Zp = 30.5\<rparr>"

datatype 'a Tree = Leaf 'a | Node "'a Tree" 'a "'a Tree"

type_synonym itree = "int Tree"
type_synonym stree = "string Tree"

primrec count :: "'a Tree \<Rightarrow> nat"
  where "count (Leaf _) = 1" |
        "count (Node l _ r) = count l + count r + 1"

definition Tree1 :: "int Tree"
  where "Tree1 \<equiv> Node (Node (Leaf 4) 5 (Node (Leaf 1) 8 (Leaf 2))) 10 (Node (Leaf 7) 9 (Leaf 15))"

definition Tree2 :: "string Tree"
  where "Tree2 \<equiv> Node (Leaf ''a'') ''b'' (Leaf ''c'')"

value "count Tree1"
value "count Tree2"

datatype 'a array = Null | Conn 'a "'a array" ("_,_")

primrec length :: "'a array \<Rightarrow> nat"
  where "length Null = 0" |
        "length (Conn a arr) = 1 + length arr"

primrec nth :: "'a array \<Rightarrow> nat \<Rightarrow> 'a" ("_[_]")
  where "nth (Conn a arr) i = (case i of 0 \<Rightarrow> a | Suc k \<Rightarrow> nth arr k)"

primrec array_update :: "'a array \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a array" ("_[_] := _")
  where "array_update (Conn a arr) i v =
          (case i of 0 \<Rightarrow> Conn v arr | Suc j \<Rightarrow> Conn a (array_update arr j v))"

definition arr1 :: "int array"
  where "arr1 \<equiv> (1,2,3,Null)"

value "arr1[2]"
value "length arr1"

value "arr1[2] := 10"

definition arr2 :: "string array"
  where "arr2 \<equiv>(''hello'', ''world'', ''next'', ''word'', Null)"

value "arr2[1]"
value "arr2[0]"

value "arr2[0] := ''hi''"

subsection \<open>type declare, synonym, typedef\<close>
type_synonym mynat = nat

definition nat1 :: "mynat \<Rightarrow> mynat"
  where "nat1 n \<equiv> n + 1"

value "nat1 15"

type_synonym 'a array_alias = "'a array"
type_synonym 'a array_synonym = "'a array"

type_synonym coord3d_t = coord3d

definition coord8 :: "coord3d_t"
  where "coord8 \<equiv> coord3"

value "coord8"

typedecl BOOL

axiomatization T :: BOOL and F :: BOOL
  and AND :: "BOOL \<Rightarrow> BOOL \<Rightarrow> BOOL"
  and OR :: "BOOL \<Rightarrow> BOOL \<Rightarrow> BOOL"
  and NOT :: "BOOL \<Rightarrow> BOOL"
  where ANDs: "AND a b = (if (a = T \<and> b = T) then T else F)"
   and  ORs: "OR a b = (if (a = T \<or> b = T) then T else F)"
   and  NOTs: "NOT a \<equiv> (if a = T then F else T)"
   (* and TF: "T \<noteq> F" *)

definition xorBOOL :: "BOOL \<Rightarrow> BOOL \<Rightarrow> BOOL"
  where "xorBOOL a b \<equiv> OR (AND a (NOT b)) (AND (NOT a) b)"

(* value T *)

lemma "xorBOOL T F = T"
  unfolding xorBOOL_def using ANDs NOTs ORs by simp

lemma "xorBOOL T T = F"
  unfolding xorBOOL_def using ANDs NOTs ORs by auto

lemma "xorBOOL F F = F"
  unfolding xorBOOL_def using ANDs NOTs ORs by auto

lemma "xorBOOL F T = T"
  unfolding xorBOOL_def using ANDs NOTs ORs by simp

typedef Even = "{x::nat. x mod 2 = 0}"
(*  morphisms rep abs *)
proof -
  have "(2::nat) mod 2 = 0" by simp
  hence "2\<in>{x::nat. x mod 2 = 0}" by simp
  thus ?thesis by meson
qed

term Rep_Even
thm Rep_Even
term Abs_Even
thm Abs_Even_inject
thm Abs_Even_inverse
thm Rep_Even_inject
thm Rep_Even_inverse

(*
lemma "(rep n) mod 2 = 0"
  using rep by auto

lemma "rep (abs x) mod 2 = 0"
  using rep abs_inverse by auto

lemma "m\<in>{x. x mod 2 = 0} \<Longrightarrow> n\<in>{x. x mod 2 = 0} \<Longrightarrow> abs m = abs n \<longleftrightarrow> m = n"
  using abs_inject by simp
*)

instantiation Even :: zero
begin
definition Zero_even_def: "0 = Abs_Even 0"
instance ..
end
term "0::Even"

instantiation Even :: one
begin
definition One_even_def: "1 = Abs_Even 2"
instance ..
end
term "1::Even"

definition SUC :: "Even \<Rightarrow> Even"
  where "SUC n \<equiv> Abs_Even (Suc (Suc (Rep_Even n)))"

lemma "SUC 0 = 1"
  using SUC_def Zero_even_def One_even_def Rep_Even Abs_Even_inverse Abs_Even_inject
  by (metis (mono_tags, lifting) Suc_eq_plus1_left mem_Collect_eq mod_0
        numeral_1_eq_Suc_0 numeral_One one_add_one)

definition ADD :: "Even \<Rightarrow> Even \<Rightarrow> Even"
  where "ADD m n \<equiv> Abs_Even ((Rep_Even m) + (Rep_Even n))"

lemma "ADD (SUC 0) (SUC 0) = SUC (SUC 0)"
  unfolding SUC_def ADD_def using Rep_Even Abs_Even_inverse
  by (metis (mono_tags, lifting) Suc_eq_plus1_left Zero_even_def add_Suc_shift
        mem_Collect_eq mod_0 mod_add_self1 numeral_1_eq_Suc_0 numeral_One one_add_one)

typedef three = "{(True, True), (True, False), (False, True)}"
  by blast

term Abs_three
term Rep_three
thm Abs_three_inject
thm Abs_three_inverse

definition "One = Abs_three (True, True)"
definition "Two = Abs_three (True, False)"
definition "Three = Abs_three (False, True)"
lemma three_distinct: "One \<noteq> Two" "One \<noteq> Three" "Two \<noteq> Three"
  by (simp_all add: One_def Two_def Three_def Abs_three_inject)

lemma three_cases:
fixes x :: three obtains "x = One | x = Two | x = Three"
  by (cases x) (auto simp: One_def Two_def Three_def Abs_three_inject)

end