section \<open>Addition and Multiplication of Sets\<close>

theory Kirby
  imports ZFC_Cardinals

begin

subsection \<open>Generalised Addition\<close>

text \<open>Source: Laurence Kirby, Addition and multiplication of sets
      Math. Log. Quart. 53, No. 1, 52-65 (2007) / DOI 10.1002/malq.200610026
      @{url "http://faculty.baruch.cuny.edu/lkirby/mlqarticlejan2007.pdf"}\<close>

subsubsection \<open>Addition is a monoid\<close>

instantiation V :: plus
begin

text\<open>This definition is credited to Tarski\<close>
definition plus_V :: "V \<Rightarrow> V \<Rightarrow> V"
  where "plus_V x \<equiv> transrec (\<lambda>f z. x \<squnion> set (f ` elts z))"

instance ..
end

definition lift :: "V \<Rightarrow> V \<Rightarrow> V"
  where "lift x y \<equiv> set (plus x ` elts y)"

lemma plus: "x + y = x \<squnion> set ((+)x ` elts y)"
  unfolding plus_V_def  by (subst transrec) auto

lemma plus_eq_lift: "x + y = x \<squnion> lift x y"
  unfolding lift_def  using plus by blast

text\<open>Lemma 3.2\<close>
lemma lift_sup_distrib: "lift x (a \<squnion> b) = lift x a \<squnion> lift x b"
  by (simp add: image_Un lift_def sup_V_def)

lemma lift_Sup_distrib: "small Y \<Longrightarrow> lift x (\<Squnion> Y) = \<Squnion> (lift x ` Y)"
  by (auto simp: lift_def Sup_V_def image_Union)

lemma add_Sup_distrib:
  fixes x::V shows "y \<noteq> 0 \<Longrightarrow> x + (SUP z\<in>elts y. f z) = (SUP z\<in>elts y. x + f z)"
  by (auto simp: plus_eq_lift SUP_sup_distrib lift_Sup_distrib image_image)

lemma Limit_add_Sup_distrib:
  fixes x::V shows "Limit \<alpha> \<Longrightarrow> x + (SUP z\<in>elts \<alpha>. f z) = (SUP z\<in>elts \<alpha>. x + f z)"
  using add_Sup_distrib by force

text\<open>Proposition 3.3(ii)\<close>
instantiation V :: monoid_add
begin
instance
proof
  show "a + b + c = a + (b + c)" for a b c :: V
  proof (induction c rule: eps_induct)
    case (step c)
    have "(a+b) + c = a + b \<squnion> set ((+) (a + b) ` elts c)"
      by (metis plus)
    also have "\<dots> = a \<squnion> lift a b \<squnion> set ((\<lambda>u. a + (b+u)) ` elts c)"
      using plus_eq_lift step.IH by auto
    also have "\<dots> = a \<squnion> lift a (b + c)"
    proof -
      have "lift a b \<squnion> set ((\<lambda>u. a + (b + u)) ` elts c) = lift a (b + c)"
        unfolding lift_def
        by (metis elts_of_set image_image lift_def lift_sup_distrib plus_eq_lift replacement small_elts)
      then show ?thesis
        by (simp add: sup_assoc)
    qed
    also have "\<dots> = a + (b + c)"
      using plus_eq_lift by auto
    finally show ?case .
  qed
  show "0 + x = x" for x :: V
  proof (induction rule: eps_induct)
    case (step x)
    then show ?case
      by (subst plus) auto
  qed
  show "x + 0 = x" for x :: V
    by (subst plus) auto
qed
end

lemma lift_0 [simp]: "lift 0 x = x"
  by (simp add: lift_def)

lemma lift_by0 [simp]: "lift x 0 = 0"
  by (simp add: lift_def)

lemma lift_by1 [simp]: "lift x 1 = set{x}"
  by (simp add: lift_def)

lemma add_eq_0_iff [simp]:
  fixes x y::V
  shows "x+y = 0 \<longleftrightarrow> x=0 \<and> y=0"
  proof safe
  show "x = 0" if "x + y = 0"
    by (metis that le_imp_less_or_eq not_less_0 plus sup_ge1)
  then show "y = 0" if "x + y = 0"
    using that by auto
qed auto

lemma plus_vinsert: "x + vinsert z y = vinsert (x+z) (x + y)"
proof -
  have f1: "elts (x + y) = elts x \<union> (+) x ` elts y"
    by (metis elts_of_set lift_def plus_eq_lift replacement small_Un small_elts sup_V_def)
  moreover have "lift x (vinsert z y) = set ((+) x ` elts (set (insert z (elts y))))"
    using vinsert_def lift_def by presburger
  ultimately show ?thesis
    by (simp add: vinsert_def plus_eq_lift sup_V_def)
qed

lemma plus_V_succ_right: "x + succ y = succ (x + y)"
  by (metis plus_vinsert succ_def)

lemma succ_eq_add1: "succ x = x + 1"
  by (simp add: plus_V_succ_right one_V_def)

lemma ord_of_nat_add: "ord_of_nat (m+n) = ord_of_nat m + ord_of_nat n"
  by (induction n) (auto simp: plus_V_succ_right)

lemma succ_0_plus_eq [simp]:
  assumes "\<alpha> \<in> elts \<omega>"
  shows "succ 0 + \<alpha> = succ \<alpha>"
proof -
  obtain n where "\<alpha> = ord_of_nat n"
    using assms elts_\<omega> by blast
  then show ?thesis
    by (metis One_nat_def ord_of_nat.simps ord_of_nat_add plus_1_eq_Suc)
qed

lemma omega_closed_add [intro]:
  assumes "\<alpha> \<in> elts \<omega>" "\<beta> \<in> elts \<omega>" shows "\<alpha>+\<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>+\<beta> = ord_of_nat (m+n)"
    using ord_of_nat_add by auto
  then show ?thesis
    by (simp add: \<omega>_def)
qed

lemma mem_plus_V_E:
  assumes l: "l \<in> elts (x + y)"
  obtains "l \<in> elts x" | z where "z \<in> elts y" "l = x + z"
  using l by (auto simp: plus [of x y] split: if_split_asm)

lemma not_add_less_right: assumes "Ord y" shows "\<not> (x + y < x)"
  using assms
proof (induction rule: Ord_induct)
  case (step i)
  then show ?case
    by (metis less_le_not_le plus sup_ge1)
qed

lemma not_add_mem_right: "\<not> (x + y \<in> elts x)"
  by (metis sup_ge1 mem_not_refl plus vsubsetD)

text\<open>Proposition 3.3(iii)\<close>
lemma add_not_less_TC_self: "\<not> x + y \<sqsubset> x"
proof (induction y arbitrary: x rule: eps_induct)
  case (step y)
  then show ?case
    using less_TC_imp_not_le plus_eq_lift by fastforce
qed

lemma TC_sup_lift: "TC x \<sqinter> lift x y = 0"
proof -
  have "elts (TC x) \<inter> elts (set ((+) x ` elts y)) = {}"
    using add_not_less_TC_self by (auto simp: less_TC_def)
  then have "TC x \<sqinter> set ((+) x ` elts y) = set {}"
    by (metis inf_V_def)
  then show ?thesis
    using lift_def by auto
qed

lemma lift_lift: "lift x (lift y z) = lift (x+y) z"
  using add.assoc  by (auto simp: lift_def)

lemma lift_self_disjoint: "x \<sqinter> lift x u = 0"
  by (metis TC_sup_lift arg_subset_TC inf.absorb_iff2 inf_assoc inf_sup_aci(3) lift_0)

lemma sup_lift_eq_lift:
  assumes "x \<squnion> lift x u = x \<squnion> lift x v"
  shows "lift x u = lift x v"
  by (metis (no_types) assms inf_sup_absorb inf_sup_distrib2 lift_self_disjoint sup_commute sup_inf_absorb)

subsubsection \<open>Deeper properties of addition\<close>

text\<open>Proposition 3.4(i)\<close>
proposition lift_eq_lift: "lift x y = lift x z \<Longrightarrow> y = z"
proof (induction y arbitrary: z rule: eps_induct)
  case (step y)
  show ?case
  proof (intro vsubsetI order_antisym)
    show "u \<in> elts z" if "u \<in> elts y" for u
    proof -
      have "x+u \<in> elts (lift x z)"
        using lift_def step.prems that by fastforce
      then obtain v where "v \<in> elts z" "x+u = x+v"
        using lift_def by auto
      then have "lift x u = lift x v"
        using sup_lift_eq_lift by (simp add: plus_eq_lift)
      then have "u=v"
        using step.IH that by blast
      then show ?thesis
        using \<open>v \<in> elts z\<close> by blast
    qed
    show "u \<in> elts y" if "u \<in> elts z" for u
    proof -
      have "x+u \<in> elts (lift x y)"
        using lift_def step.prems that by fastforce
      then obtain v where "v \<in> elts y" "x+u = x+v"
        using lift_def by auto
      then have "lift x u = lift x v"
        using sup_lift_eq_lift by (simp add: plus_eq_lift)
      then have "u=v"
        using step.IH by (metis \<open>v \<in> elts y\<close>)
      then show ?thesis
        using \<open>v \<in> elts y\<close> by auto
    qed
  qed
qed

corollary inj_lift: "inj_on (lift x) A"
  by (auto simp: inj_on_def dest: lift_eq_lift)

corollary add_right_cancel [iff]:
  fixes x y z::V shows "x+y = x+z \<longleftrightarrow> y=z"
  by (metis lift_eq_lift plus_eq_lift sup_lift_eq_lift)

corollary add_mem_right_cancel [iff]:
  fixes x y z::V shows "x+y \<in> elts (x+z) \<longleftrightarrow> y \<in> elts z"
  apply safe
   apply (metis mem_plus_V_E not_add_mem_right add_right_cancel)
  by (metis ZFC_in_HOL.ext dual_order.antisym elts_vinsert insert_subset order_refl plus_vinsert)

corollary add_le_cancel_left [iff]:
  fixes x y z::V shows "x+y \<le> x+z \<longleftrightarrow> y\<le>z"
  by auto (metis add_mem_right_cancel mem_plus_V_E plus sup_ge1 vsubsetD)

corollary add_less_cancel_left [iff]:
  fixes x y z::V shows "x+y < x+z \<longleftrightarrow> y<z"
  by (simp add: less_le_not_le)

corollary lift_le_self [simp]: "lift x y \<le> x \<longleftrightarrow> y = 0"
  by (auto simp: inf.absorb_iff2 lift_eq_lift lift_self_disjoint)

lemma succ_less_\<omega>_imp: "succ x < \<omega> \<Longrightarrow> x < \<omega>"
  by (metis add_le_cancel_left add.right_neutral le_0 le_less_trans succ_eq_add1)

text\<open>Proposition 3.5\<close>
lemma card_lift: "vcard (lift x y) = vcard y"
proof (rule cardinal_cong)
  have "bij_betw ((+)x) (elts y) (elts (lift x y))"
    unfolding bij_betw_def
    by (simp add: inj_on_def lift_def)
  then show "elts (lift x y) \<approx> elts y"
    using eqpoll_def eqpoll_sym by blast
qed

lemma eqpoll_lift: "elts (lift x y) \<approx> elts y"
  by (metis card_lift cardinal_eqpoll eqpoll_sym eqpoll_trans)

lemma countable_add:
  assumes "countable (elts A)" "countable (elts B)"
  shows "countable (elts (A+B))"
proof -
  have "vcard A \<le> \<aleph>0" "vcard B \<le> \<aleph>0"
    using assms countable_iff_le_Aleph0 by blast+
  then have "vcard (A+B) \<le> \<aleph>0"
    unfolding vcard_add
    by (metis Aleph_0 Card_\<omega> InfCard_cdouble_eq InfCard_def cadd_le_mono order_refl)
  then show ?thesis
    by (simp add: countable_iff_le_Aleph0)
qed

text\<open>Proposition 3.6\<close>
proposition TC_add: "TC (x + y) = TC x \<squnion> lift x (TC y)"
proof (induction y rule: eps_induct)
  case (step y)
  have *: "\<Squnion> (TC ` (+) x ` elts y) = TC x \<squnion> (SUP u\<in>elts y. TC (set ((+) x ` elts u)))"
    if "elts y \<noteq> {}"
  proof -
    obtain w where "w \<in> elts y"
      using \<open>elts y \<noteq> {}\<close> by blast
    then have "TC x \<le> TC (x + w)"
      by (simp add: step.IH)
    then have \<dagger>: "TC x \<le> (SUP w\<in>elts y. TC (x + w))"
      using \<open>w \<in> elts y\<close> by blast
    show ?thesis
      using that
      apply (intro conjI ballI impI order_antisym; clarsimp simp add: image_comp \<dagger>)
       apply(metis TC_sup_distrib Un_iff elts_sup_iff plus)
      by (metis TC_least Transset_TC arg_subset_TC le_sup_iff plus vsubsetD)
  qed
  have "TC (x + y) = (x + y) \<squnion> \<Squnion> (TC ` elts (x + y))"
    using TC by blast
  also have "\<dots> = x \<squnion> lift x y \<squnion> \<Squnion> (TC ` elts x) \<squnion> \<Squnion> ((\<lambda>u. TC (x+u)) ` elts y)"
    apply (simp add: plus_eq_lift image_Un Sup_Un_distrib sup.left_commute sup_assoc TC_sup_distrib SUP_sup_distrib)
    apply (simp add: lift_def sup.commute sup_aci *)
    done
  also have "\<dots> = x \<squnion> \<Squnion> (TC ` elts x) \<squnion> lift x y \<squnion> \<Squnion> ((\<lambda>u. TC x \<squnion> lift x (TC u)) ` elts y)"
    by (simp add: sup_aci step.IH)
  also have "\<dots> = TC x \<squnion> lift x y \<squnion> \<Squnion> ((\<lambda>u. lift x (TC u)) ` elts y)"
    by (simp add: sup_aci SUP_sup_distrib flip: TC [of x])
  also have "\<dots> = TC x \<squnion> lift x (y \<squnion> \<Squnion> (TC ` elts y))"
    by (metis (no_types) elts_of_set lift_Sup_distrib image_image lift_sup_distrib replacement small_elts sup_assoc)
  also have "\<dots> = TC x \<squnion> lift x (TC y)"
    by (simp add: TC [of y])
  finally show ?case .
qed

corollary TC_add': "z \<sqsubset> x + y \<longleftrightarrow> z \<sqsubset> x \<or> (\<exists>v. v \<sqsubset> y \<and> z = x + v)"
  using TC_add by (force simp: less_TC_def lift_def)

text\<open>Corollary 3.7\<close>
corollary vcard_TC_add: "vcard (TC (x+y)) = vcard (TC x) \<oplus> vcard (TC y)"
  by (simp add: TC_add TC_sup_lift card_lift vcard_disjoint_sup)

text\<open>Corollary 3.8\<close>
corollary TC_lift:
  assumes "y \<noteq> 0"
  shows "TC (lift x y) = TC x \<squnion> lift x (TC y)"
proof -
  have "TC (lift x y) = lift x y \<squnion> \<Squnion> ((\<lambda>u. TC(x+u)) ` elts y)"
    unfolding TC [of "lift x y"]  by (simp add: lift_def image_image)
  also have "\<dots> = lift x y \<squnion> (SUP u\<in>elts y. TC x \<squnion> lift x (TC u))"
    by (simp add: TC_add)
  also have "\<dots> = lift x y \<squnion> TC x \<squnion> (SUP u\<in>elts y. lift x (TC u))"
    using assms by (auto simp: SUP_sup_distrib)
  also have "\<dots> = TC x \<squnion> lift x (TC y)"
    by (simp add: TC [of y] sup_aci image_image lift_sup_distrib lift_Sup_distrib)
  finally show ?thesis .
qed

proposition rank_add_distrib: "rank (x+y) = rank x + rank y"
proof (induction y rule: eps_induct)
  case (step y)
  show ?case
  proof (cases "y=0")
    case False
    then obtain e where e: "e \<in> elts y"
      by fastforce
    have "rank (x+y) = (SUP u\<in>elts (x \<squnion> ZFC_in_HOL.set ((+) x ` elts y)). succ (rank u))"
      by (metis plus rank_Sup)
    also have "\<dots> = (SUP x\<in>elts x. succ (rank x)) \<squnion> (SUP z\<in>elts y. succ (rank x + rank z))"
      apply (simp add: Sup_Un_distrib image_Un image_image)
      apply (simp add: step cong: SUP_cong_simp)
      done
    also have "\<dots> = (SUP z \<in> elts y. rank x + succ (rank z))"
    proof -
      have "rank x \<le> (SUP z\<in>elts y. ZFC_in_HOL.succ (rank x + rank z))"
        using \<open>y \<noteq> 0\<close>
        by (auto simp: plus_eq_lift intro: order_trans [OF _ cSUP_upper [OF e]])
      then show ?thesis
        by (force simp: plus_V_succ_right simp flip: rank_Sup [of x] intro!: order_antisym)
    qed
    also have "\<dots> = rank x + (SUP z \<in> elts y. succ (rank z))"
      by (simp add: add_Sup_distrib False)
    also have "\<dots> = rank x + rank y"
      by (simp add: rank_Sup [of y])
    finally show ?thesis .
  qed auto
qed

lemma Ord_add [simp]: "\<lbrakk>Ord x; Ord y\<rbrakk> \<Longrightarrow> Ord (x+y)"
proof (induction y rule: eps_induct)
  case (step y)
  then show ?case
    by (metis Ord_rank rank_add_distrib rank_of_Ord)
qed

lemma add_Sup_distrib_id: "A \<noteq> 0 \<Longrightarrow> x + \<Squnion>(elts A) = (SUP z\<in>elts A. x + z)"
  by (metis add_Sup_distrib image_ident image_image)

lemma add_le_left:
  assumes "Ord \<alpha>" "Ord \<beta>" shows "\<beta> \<le> \<alpha>+\<beta>"
  using \<open>Ord \<beta>\<close>
proof (induction rule: Ord_induct3)
  case 0
  then show ?case
    by auto
next
  case (succ \<alpha>)
  then show ?case
    by (auto simp: plus_V_succ_right Ord_mem_iff_lt assms(1))
next
  case (Limit \<mu>)
  then have k: "\<mu> = (SUP \<beta> \<in> elts \<mu>. \<beta>)"
    by (simp add: Limit_eq_Sup_self)
  also have "\<dots>  \<le> (SUP \<beta> \<in> elts \<mu>. \<alpha> + \<beta>)"
    using Limit.IH by auto
  also have "\<dots> = \<alpha> + (SUP \<beta> \<in> elts \<mu>. \<beta>)"
    using Limit.hyps Limit_add_Sup_distrib by presburger
  finally show ?case
    using k by simp
qed

lemma plus_\<omega>_equals_\<omega>:
  assumes "\<alpha> \<in> elts \<omega>"  shows "\<alpha> + \<omega> = \<omega>"
proof (rule antisym)
  show "\<alpha> + \<omega> \<le> \<omega>"
    using Ord_trans assms by (auto simp: elim!: mem_plus_V_E)
  show "\<omega> \<le> \<alpha> + \<omega>"
    by (simp add: add_le_left assms)
qed

lemma one_plus_\<omega>_equals_\<omega> [simp]: "1 + \<omega> = \<omega>"
  by (simp add: one_V_def plus_\<omega>_equals_\<omega>)

subsubsection \<open>Cancellation / set subtraction\<close>

definition vle :: "V \<Rightarrow> V \<Rightarrow> bool" (infix "\<unlhd>" 50)
  where "x \<unlhd> y \<equiv> \<exists>z::V. x+z = y"

lemma vle_refl [iff]: "x \<unlhd> x"
  by (metis (no_types) add.right_neutral vle_def)

lemma vle_antisym: "\<lbrakk>x \<unlhd> y; y \<unlhd> x\<rbrakk> \<Longrightarrow> x = y"
  by (metis V_equalityI plus_eq_lift sup_ge1 vle_def vsubsetD)

lemma vle_trans [trans]: "\<lbrakk>x \<unlhd> y; y \<unlhd> z\<rbrakk> \<Longrightarrow> x \<unlhd> z"
  by (metis add.assoc vle_def)

definition vle_comparable :: "V \<Rightarrow> V \<Rightarrow> bool"
  where "vle_comparable x y \<equiv> x \<unlhd> y \<or> y \<unlhd> x"

text\<open>Lemma 3.13\<close>
lemma comparable:
  assumes "a+b = c+d"
  shows "vle_comparable a c"
unfolding vle_comparable_def
proof (rule ccontr)
  assume non: "\<not> (a \<unlhd> c \<or> c \<unlhd> a)"
  let ?\<phi> = "\<lambda>x. \<forall>z. a+x \<noteq> c+z"
  have "?\<phi> x" for x
  proof (induction x rule: eps_induct)
    case (step x)
    show ?case
    proof (cases "x=0")
      case True
      with non nonzero_less_TC show ?thesis
        using vle_def by auto
    next
      case False
      then obtain v where "v \<in> elts x"
        using trad_foundation by blast
      show ?thesis
      proof clarsimp
        fix z
        assume eq: "a + x = c + z"
        then have "z \<noteq> 0"
          using vle_def non by auto
        have av: "a+v \<in> elts (a+x)"
          by (simp add: \<open>v \<in> elts x\<close>)
        moreover have "a+x = c \<squnion> lift c z"
          using eq plus_eq_lift by fastforce
        ultimately have "a+v \<in> elts (c \<squnion> lift c z)"
          by simp
        moreover
        define u where "u \<equiv> set (elts x - {v})"
        have u: "v \<notin> elts u" and xeq: "x = vinsert v u"
          using \<open>v \<in> elts x\<close> by (auto simp: u_def intro: order_antisym)
        have case1: "a+v \<notin> elts c"
        proof
          assume avc: "a + v \<in> elts c"
          then have "a \<le> c"
            by clarify (metis Un_iff elts_sup_iff eq mem_not_sym mem_plus_V_E plus_eq_lift)
          moreover have "a \<squnion> lift a x = c \<squnion> lift c z"
            using eq by (simp add: plus_eq_lift)
          ultimately have "lift c z \<le> lift a x"
            by (metis inf.absorb_iff2 inf_commute inf_sup_absorb inf_sup_distrib2 lift_self_disjoint sup.commute)
          also have "\<dots> = vinsert (a+v) (lift a u)"
            by (simp add: lift_def vinsert_def xeq)
          finally have *: "lift c z \<le> vinsert (a + v) (lift a u)" .
          have "lift c z \<le> lift a u"
          proof -
            have "a + v \<notin> elts (lift c z)"
              using lift_self_disjoint [of c z] avc V_disjoint_iff by auto
            then show ?thesis
              using * less_eq_V_def by auto
          qed
          { fix e
            assume "e \<in> elts z"
            then have "c+e \<in> elts (lift c z)"
              by (simp add: lift_def)
            then have "c+e \<in> elts (lift a u)"
              using \<open>lift c z \<le> lift a u\<close> by blast
            then obtain y where "y \<in> elts u" "c+e = a+y"
              using lift_def by auto
            then have False
              by (metis elts_vinsert insert_iff step.IH xeq)
          }
          then show False
            using \<open>z \<noteq> 0\<close> by fastforce
        qed
        ultimately show False
          by (metis (no_types) \<open>v \<in> elts x\<close> av case1 eq mem_plus_V_E step.IH)
      qed
    qed
  qed
  then show False
    using assms by blast
qed

lemma vle1: "x \<unlhd> y \<Longrightarrow> x \<le> y"
  using vle_def plus_eq_lift by auto

lemma vle2: "x \<unlhd> y \<Longrightarrow> x \<sqsubseteq> y"
  by (metis (full_types) TC_add' add.right_neutral le_TC_def vle_def nonzero_less_TC)

lemma vle_iff_le_Ord:
  assumes "Ord \<alpha>" "Ord \<beta>"
  shows "\<alpha> \<unlhd> \<beta> \<longleftrightarrow> \<alpha> \<le> \<beta>"
proof
  show "\<alpha> \<le> \<beta>" if "\<alpha> \<unlhd> \<beta>"
    using that by (simp add: vle1)
  show "\<alpha> \<unlhd> \<beta>" if "\<alpha> \<le> \<beta>"
    using \<open>Ord \<alpha>\<close> \<open>Ord \<beta>\<close> that
  proof (induction \<alpha> arbitrary: \<beta> rule: Ord_induct)
    case (step \<gamma>)
    then show ?case
      unfolding vle_def
      by (metis Ord_add Ord_linear add_le_left mem_not_refl mem_plus_V_E vsubsetD)
  qed
qed

lemma add_le_cancel_left0 [iff]:
  fixes x::V shows "x \<le> x+z"
  by (simp add: vle1 vle_def)

lemma add_less_cancel_left0 [iff]:
  fixes x::V shows "x < x+z \<longleftrightarrow> 0<z"
  by (metis add_less_cancel_left add.right_neutral)

lemma le_Ord_diff:
  assumes "\<alpha> \<le> \<beta>" "Ord \<alpha>" "Ord \<beta>"
  obtains \<gamma> where "\<alpha>+\<gamma> = \<beta>" "\<gamma> \<le> \<beta>" "Ord \<gamma>"
proof -
  obtain \<gamma> where \<gamma>: "\<alpha>+\<gamma> = \<beta>" "\<gamma> \<le> \<beta>"
    by (metis add_le_cancel_left add_le_left assms vle_def vle_iff_le_Ord)
  then have "Ord \<gamma>"
    using Ord_def Transset_def \<open>Ord \<beta>\<close> by force
  with \<gamma> that show thesis by blast
qed

lemma plus_Ord_le:
  assumes "\<alpha> \<in> elts \<omega>" "Ord \<beta>" shows "\<alpha>+\<beta> \<le> \<beta>+\<alpha>"
proof (cases "\<beta> \<in> elts \<omega>")
  case True
  with assms have "\<alpha>+\<beta> = \<beta>+\<alpha>"
    by (auto simp: elts_\<omega> add.commute ord_of_nat_add [symmetric])
  then show ?thesis by simp
next
  case False
  then have "\<omega> \<le> \<beta>"
    using Ord_linear2 Ord_mem_iff_lt \<open>Ord \<beta>\<close> by auto
  then obtain \<gamma> where "\<omega>+\<gamma> = \<beta>" "\<gamma> \<le> \<beta>" "Ord \<gamma>"
    using \<open>Ord \<beta>\<close> le_Ord_diff by auto
  then have "\<alpha>+\<beta> = \<beta>"
    by (metis add.assoc assms(1) plus_\<omega>_equals_\<omega>)
  then show ?thesis
    by simp
qed

lemma add_right_mono: "\<lbrakk>\<alpha> \<le> \<beta>; Ord \<alpha>; Ord \<beta>; Ord \<gamma>\<rbrakk> \<Longrightarrow> \<alpha>+\<gamma> \<le> \<beta>+\<gamma>"
  by (metis add_le_cancel_left add.assoc add_le_left le_Ord_diff)

lemma add_strict_mono: "\<lbrakk>\<alpha> < \<beta>; \<gamma> < \<delta>; Ord \<alpha>; Ord \<beta>; Ord \<gamma>; Ord \<delta>\<rbrakk> \<Longrightarrow> \<alpha>+\<gamma> < \<beta>+\<delta>"
  by (metis order.strict_implies_order add_less_cancel_left add_right_mono le_less_trans)

lemma add_right_strict_mono: "\<lbrakk>\<alpha> \<le> \<beta>; \<gamma> < \<delta>; Ord \<alpha>; Ord \<beta>; Ord \<gamma>; Ord \<delta>\<rbrakk> \<Longrightarrow> \<alpha>+\<gamma> < \<beta>+\<delta>"
  using add_strict_mono le_imp_less_or_eq by blast

lemma Limit_add_Limit [simp]:
  assumes "Limit \<mu>" "Ord \<beta>" shows "Limit (\<beta> + \<mu>)"
  unfolding Limit_def
  proof (intro conjI allI impI)
  show "Ord (\<beta> + \<mu>)"
    using Limit_def assms by auto
  show "0 \<in> elts (\<beta> + \<mu>)"
    using Limit_def add_le_left assms by auto
next
  fix \<gamma>
  assume "\<gamma> \<in> elts (\<beta> + \<mu>)"
  then consider "\<gamma> \<in> elts \<beta>" | \<xi> where "\<xi> \<in> elts \<mu>" "\<gamma> = \<beta> + \<xi>"
    using mem_plus_V_E by blast
  then show "succ \<gamma> \<in> elts (\<beta> + \<mu>)"
  proof cases
    case 1
    then show ?thesis
      by (metis Kirby.add_strict_mono Limit_def Ord_add Ord_in_Ord Ord_mem_iff_lt assms one_V_def succ_eq_add1)
  next
    case 2
    then show ?thesis
      by (metis Limit_def add_mem_right_cancel assms(1) plus_V_succ_right)
  qed
qed

subsection \<open>Generalised Difference\<close>

definition odiff where "odiff y x \<equiv> THE z::V. (x+z = y) \<or> (z=0 \<and> \<not> x \<unlhd> y)"

lemma vle_imp_odiff_eq: "x \<unlhd> y \<Longrightarrow> x + (odiff y x) = y"
  by (auto simp: vle_def odiff_def)

lemma not_vle_imp_odiff_0: "\<not> x \<unlhd> y \<Longrightarrow> (odiff y x) = 0"
  by (auto simp: vle_def odiff_def)

lemma Ord_odiff_eq:
  assumes "\<alpha> \<le> \<beta>" "Ord \<alpha>" "Ord \<beta>"
  shows "\<alpha> + odiff \<beta> \<alpha> = \<beta>"
  by (simp add: assms vle_iff_le_Ord vle_imp_odiff_eq)

lemma Ord_odiff:
  assumes "Ord \<alpha>" "Ord \<beta>" shows "Ord (odiff \<beta> \<alpha>)"
proof (cases "\<alpha> \<unlhd> \<beta>")
  case True
  then show ?thesis
    by (metis add_right_cancel assms le_Ord_diff vle1 vle_imp_odiff_eq)
next
  case False
  then show ?thesis
    by (simp add: odiff_def vle_def)
qed

lemma Ord_odiff_le:
  assumes  "Ord \<alpha>" "Ord \<beta>" shows "odiff \<beta> \<alpha> \<le> \<beta>"
proof (cases "\<alpha> \<unlhd> \<beta>")
  case True
  then show ?thesis
    by (metis add_right_cancel assms le_Ord_diff vle1 vle_imp_odiff_eq)
next
  case False
  then show ?thesis
    by (simp add: odiff_def vle_def)
qed

lemma odiff_0_right [simp]: "odiff x 0 = x"
  by (metis add.left_neutral vle_def vle_imp_odiff_eq)

lemma odiff_succ: "y \<unlhd> x \<Longrightarrow> odiff (succ x) y = succ (odiff x y)"
  unfolding odiff_def
  by (metis add_right_cancel odiff_def plus_V_succ_right vle_def vle_imp_odiff_eq)

lemma odiff_eq_iff: "z \<unlhd> x \<Longrightarrow> odiff x z = y \<longleftrightarrow> x = z + y"
  by (auto simp: odiff_def vle_def)

lemma odiff_le_iff: "z \<unlhd> x \<Longrightarrow> odiff x z \<le> y \<longleftrightarrow> x \<le> z + y"
  by (auto simp: odiff_def vle_def)

lemma odiff_less_iff: "z \<unlhd> x \<Longrightarrow> odiff x z < y \<longleftrightarrow> x < z + y"
  by (auto simp: odiff_def vle_def)

lemma odiff_ge_iff: "z \<unlhd> x \<Longrightarrow> odiff x z \<ge> y \<longleftrightarrow> x \<ge> z + y"
  by (auto simp: odiff_def vle_def)

lemma Ord_odiff_le_iff: "\<lbrakk>\<alpha> \<le> x; Ord x; Ord \<alpha>\<rbrakk> \<Longrightarrow> odiff x \<alpha> \<le> y \<longleftrightarrow> x \<le> \<alpha> + y"
  by (simp add: odiff_le_iff vle_iff_le_Ord)

lemma odiff_le_odiff:
  assumes "x \<unlhd> y" shows "odiff x z \<le> odiff y z"
proof (cases "z \<unlhd> x")
  case True
  then show ?thesis
    using assms odiff_le_iff vle1 vle_imp_odiff_eq vle_trans by presburger
next
  case False
  then show ?thesis
    by (simp add: not_vle_imp_odiff_0)
qed

lemma Ord_odiff_le_odiff: "\<lbrakk>x \<le> y; Ord x; Ord y\<rbrakk> \<Longrightarrow> odiff x \<alpha> \<le> odiff y \<alpha>"
  by (simp add: odiff_le_odiff vle_iff_le_Ord)

lemma Ord_odiff_less_imp_less: "\<lbrakk>odiff x \<alpha> < odiff y \<alpha>; Ord x; Ord y\<rbrakk> \<Longrightarrow> x < y"
  by (meson Ord_linear2 leD odiff_le_odiff vle_iff_le_Ord)

lemma odiff_add_cancel [simp]: "odiff (x + y) x = y"
  by (simp add: odiff_eq_iff vle_def)

lemma odiff_add_cancel_0 [simp]: "odiff x x = 0"
  by (simp add: odiff_eq_iff)

lemma odiff_add_cancel_both [simp]: "odiff (x + y) (x + z) = odiff y z"
  by (simp add: add.assoc odiff_def vle_def)

subsection \<open>Generalised Multiplication\<close>

text \<open>Credited to Dana Scott\<close>

instantiation V :: times
begin

text\<open>This definition is credited to Tarski\<close>
definition times_V :: "V \<Rightarrow> V \<Rightarrow> V"
  where "times_V x \<equiv> transrec (\<lambda>f y. \<Squnion> ((\<lambda>u. lift (f u) x) ` elts y))"

instance ..
end

lemma mult: "x * y = (SUP u\<in>elts y. lift (x * u) x)"
  unfolding times_V_def  by (subst transrec) (force simp:)

text \<open>Lemma 4.2\<close>

lemma mult_zero_right [simp]:
  fixes x::V shows "x * 0 = 0"
  by (metis ZFC_in_HOL.Sup_empty elts_0 image_empty mult)

lemma mult_insert: "x * (vinsert y z) = x*z \<squnion> lift (x*y) x"
  by (metis (no_types, lifting) elts_vinsert image_insert replacement small_elts sup_commute mult Sup_V_insert)

lemma mult_succ: "x * succ y = x*y + x"
  by (simp add: mult_insert plus_eq_lift succ_def)

lemma ord_of_nat_mult: "ord_of_nat (m*n) = ord_of_nat m * ord_of_nat n"
proof (induction n)
  case (Suc n)
  then show ?case
    by (simp add: add.commute [of m]) (simp add: ord_of_nat_add mult_succ)
qed auto

lemma omega_closed_mult [intro]:
  assumes "\<alpha> \<in> elts \<omega>" "\<beta> \<in> elts \<omega>" shows "\<alpha>*\<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>*\<beta> = ord_of_nat (m*n)"
    by (simp add: ord_of_nat_mult)
  then show ?thesis
    by (simp add: \<omega>_def)
qed

lemma zero_imp_le_mult: "0 \<in> elts y \<Longrightarrow> x \<le> x*y"
  by (auto simp: mult [of x y])

subsubsection\<open>Proposition 4.3\<close>

lemma mult_zero_left [simp]:
  fixes x::V shows "0 * x = 0"
proof (induction x rule: eps_induct)
  case (step x)
  then show ?case
    by (subst mult) auto
qed

lemma mult_sup_distrib:
  fixes x::V shows "x * (y \<squnion> z) = x*y \<squnion> x*z"
  unfolding mult [of x "y \<squnion> z"] mult [of x y] mult [of x z]
  by (simp add: Sup_Un_distrib image_Un)

lemma mult_Sup_distrib: "small Y \<Longrightarrow> x * (\<Squnion>Y) = \<Squnion> ((*) x ` Y)" for Y:: "V set"
  unfolding mult [of x "\<Squnion>Y"]
  by (simp add: cSUP_UNION) (metis mult)

lemma mult_lift_imp_distrib: "x * (lift y z) = lift (x*y) (x*z) \<Longrightarrow> x * (y+z) = x*y + x*z"
  by (simp add: mult_sup_distrib plus_eq_lift)

lemma mult_lift: "x * (lift y z) = lift (x*y) (x*z)"
proof (induction z rule: eps_induct)
  case (step z)
  have "x * lift y z = (SUP u\<in>elts (lift y z). lift (x * u) x)"
    using mult by blast
  also have "\<dots> = (SUP v\<in>elts z. lift (x * (y + v)) x)"
    using lift_def by auto
  also have "\<dots> = (SUP v\<in>elts z. lift (x * y + x * v) x)"
    using mult_lift_imp_distrib step.IH by auto
  also have "\<dots> = (SUP v\<in>elts z. lift (x * y) (lift (x * v) x))"
    by (simp add: lift_lift)
  also have "\<dots> = lift (x * y) (SUP v\<in>elts z. lift (x * v) x)"
    by (simp add: image_image lift_Sup_distrib)
  also have "\<dots> = lift (x*y) (x*z)"
    by (metis mult)
  finally show ?case .
qed

lemma mult_Limit: "Limit \<gamma> \<Longrightarrow> x * \<gamma> = \<Squnion> ((*) x ` elts \<gamma>)"
  by (metis Limit_eq_Sup_self mult_Sup_distrib small_elts)

lemma add_mult_distrib: "x * (y+z) = x*y + x*z" for x::V
  by (simp add: mult_lift mult_lift_imp_distrib)

instantiation V :: monoid_mult
begin
instance
proof
  show "1 * x = x" for x :: V
  proof (induction x rule: eps_induct)
    case (step x)
    then show ?case
      by (subst mult) auto
  qed
  show "x * 1 = x" for x :: V
    by (subst mult) auto
  show "(x * y) * z = x * (y * z)" for x y z::V
  proof (induction z rule: eps_induct)
    case (step z)
    have "(x * y) * z = (SUP u\<in>elts z. lift (x * y * u) (x * y))"
      using mult by blast
    also have "\<dots> = (SUP u\<in>elts z. lift (x * (y * u)) (x * y))"
      using step.IH by auto
    also have "\<dots> = (SUP u\<in>elts z. x * lift (y * u) y)"
      using mult_lift by auto
    also have "\<dots> = x * (SUP u\<in>elts z. lift (y * u) y)"
      by (simp add: image_image mult_Sup_distrib)
    also have "\<dots> = x * (y * z)"
      by (metis mult)
    finally show ?case .
  qed
qed

end

lemma le_mult:
  assumes "Ord \<beta>" "\<beta> \<noteq> 0" shows "\<alpha> \<le> \<alpha> * \<beta>"
  using assms
proof (induction rule: Ord_induct3)
  case (succ \<alpha>)
  then show ?case
    using mult_insert succ_def by fastforce
next
  case (Limit \<mu>)
  have "\<alpha> \<in> (*) \<alpha> ` elts \<mu>"
    using Limit.hyps Limit_def one_V_def by (metis imageI mult.right_neutral)
  then have "\<alpha> \<le> \<Squnion> ((*) \<alpha> ` elts \<mu>)"
    by auto
  then show ?case
    by (simp add: Limit.hyps mult_Limit)
qed auto

lemma mult_sing_1 [simp]:
  fixes x::V shows "x * set{1} = lift x x"
  by (subst mult) auto

lemma mult_2_right [simp]:
  fixes x::V shows "x * set{0,1} = x+x"
  by (subst mult) (auto simp: Sup_V_insert plus_eq_lift)

lemma Ord_mult [simp]: "\<lbrakk>Ord y; Ord x\<rbrakk> \<Longrightarrow> Ord (x*y)"
proof (induction y rule: Ord_induct3)
  case 0
  then show ?case
    by auto
next
  case (succ k)
  then show ?case
    by (simp add: mult_succ)
next
  case (Limit k)
  then have "Ord (x * \<Squnion> (elts k))"
    by (metis Ord_Sup imageE mult_Sup_distrib small_elts)
  then show ?case
    using Limit.hyps Limit_eq_Sup_self by auto
qed

subsubsection \<open>Proposition 4.4-5\<close>
proposition rank_mult_distrib: "rank (x*y) = rank x * rank y"
proof (induction y rule: eps_induct)
  case (step y)
  have "rank (x*y) = (SUP y\<in>elts (SUP u\<in>elts y. lift (x * u) x). succ (rank y))"
    by (metis rank_Sup mult)
  also have "\<dots> = (SUP u\<in>elts y. SUP r\<in>elts x. succ (rank (x * u + r)))"
    apply (simp add: lift_def image_image image_UN)
    apply (simp add: Sup_V_def)
    done
  also have "\<dots> = (SUP u\<in>elts y. SUP r\<in>elts x. succ (rank (x * u) + rank r))"
    using rank_add_distrib by auto
  also have "\<dots> = (SUP u\<in>elts y. SUP r\<in>elts x. succ (rank x * rank u + rank r))"
    using step arg_cong [where f = Sup] by auto
  also have "\<dots> = (SUP u\<in>elts y. rank x * rank u + rank x)"
  proof (rule SUP_cong)
    show "(SUP r\<in>elts x. succ (rank x * rank u + rank r)) = rank x * rank u + rank x"
      if "u \<in> elts y" for u
    proof (cases "x=0")
      case False
      have "(SUP r\<in>elts x. succ (rank x * rank u + rank r)) = rank x * rank u + (SUP y\<in>elts x. succ (rank y))"
      proof (rule order_antisym)
        show "(SUP r\<in>elts x. succ (rank x * rank u + rank r)) \<le> rank x * rank u + (SUP y\<in>elts x. succ (rank y))"
          by (auto simp: Sup_le_iff simp flip: plus_V_succ_right)
        have "rank x * rank u + (SUP y\<in>elts x. succ (rank y)) = (SUP y\<in>elts x. rank x * rank u + succ (rank y))"
          by (simp add: add_Sup_distrib False)
        also have "\<dots> \<le> (SUP r\<in>elts x. succ (rank x * rank u + rank r))"
          using plus_V_succ_right by auto
        finally show "rank x * rank u + (SUP y\<in>elts x. succ (rank y)) \<le> (SUP r\<in>elts x. succ (rank x * rank u + rank r))" .
      qed
      also have "\<dots> = rank x * rank u + rank x"
        by (metis rank_Sup)
      finally show ?thesis .
    qed auto
  qed auto
  also have "\<dots> = rank x * rank y"
    by (simp add: rank_Sup [of y] mult_Sup_distrib mult_succ image_image)
  finally show ?case .
qed

lemma mult_le1:
  fixes y::V assumes "y \<noteq> 0" shows "x \<sqsubseteq> x * y"
proof (cases "x = 0")
  case False
  then obtain r where r: "r \<in> elts x"
    by fastforce
  from \<open>y \<noteq> 0\<close> show ?thesis
  proof (induction y rule: eps_induct)
    case (step y)
    show ?case
    proof (cases "y = 1")
      case False
      with \<open>y \<noteq> 0\<close> obtain p where p: "p \<in> elts y" "p \<noteq> 0"
        by (metis V_equalityI elts_1 insertI1 singletonD trad_foundation)
      then have "x*p + r \<in> elts (lift (x*p) x)"
        by (simp add: lift_def r)
      moreover have "lift (x*p) x \<le> x*y"
        by (metis bdd_above_iff_small cSUP_upper2 order_refl \<open>p \<in> elts y\<close> replacement small_elts mult)
      ultimately have "x*p + r \<in> elts (x*y)"
        by blast
      moreover have "x*p \<sqsubseteq> x*p + r"
        by (metis TC_add' V_equalityI add.right_neutral eps_induct le_TC_refl less_TC_iff less_imp_le_TC)
      ultimately show ?thesis
        using step.IH [OF p] le_TC_trans less_TC_iff by blast
    qed auto
  qed
qed auto

lemma mult_eq_0_iff [simp]:
  fixes y::V shows "x * y = 0 \<longleftrightarrow> x=0 \<or> y=0"
proof
  show "x = 0 \<or> y = 0" if "x * y = 0"
    by (metis le_0 le_TC_def less_TC_imp_not_le mult_le1 that)
qed auto

lemma lift_lemma:
  assumes "x \<noteq> 0" "y \<noteq> 0"  shows "\<not> lift (x * y) x \<le> x"
  using assms mult_le1 [of concl: x y]
  by (auto simp: le_TC_def TC_lift less_TC_def less_TC_imp_not_le)

lemma mult_le2:
  fixes y::V assumes "x \<noteq> 0" "y \<noteq> 0" "y \<noteq> 1" shows "x \<sqsubset> x * y"
proof -
  obtain v where v: "v \<in> elts y" "v \<noteq> 0"
    using assms by fastforce
  have "x \<noteq> x * y"
    using lift_lemma [of x v]
    by (metis \<open>x \<noteq> 0\<close> bdd_above_iff_small cSUP_upper2 order_refl replacement small_elts mult v)
  then show ?thesis
  using assms mult_le1 [of y x]
    by (auto simp: le_TC_def)
qed

lemma elts_mult_\<omega>E:
  assumes "x \<in> elts (y * \<omega>)"
  obtains n where "n \<noteq> 0" "x \<in> elts (y * ord_of_nat n)" "\<And>m. m < n \<Longrightarrow> x \<notin> elts (y * ord_of_nat m)"
proof -
  obtain k where k:  "k \<noteq> 0 \<and> x \<in> elts (y * ord_of_nat k)"
    using assms
    apply (simp add: mult_Limit elts_\<omega>)
    by (metis mult_eq_0_iff elts_0 ex_in_conv ord_of_eq_0_iff that)
  define n where "n \<equiv> (LEAST k. k \<noteq> 0 \<and> x \<in> elts (y * ord_of_nat k))"
  show thesis
  proof
    show "n \<noteq> 0" "x \<in> elts (y * ord_of_nat n)"
      unfolding n_def by (metis (mono_tags, lifting) LeastI_ex k)+
    show "\<And>m. m < n \<Longrightarrow> x \<notin> elts (y * ord_of_nat m)"
      by (metis (mono_tags, lifting) mult_eq_0_iff elts_0 empty_iff n_def not_less_Least ord_of_eq_0_iff)
  qed
qed

subsubsection\<open>Theorem 4.6\<close>

theorem mult_eq_imp_0:
  assumes "a*x = a*y + b" "b \<sqsubset> a"
  shows "b=0"
proof (cases "a=0 \<or> x=0")
  case True
  with assms show ?thesis
    by (metis add_le_cancel_left mult_eq_0_iff eq_iff le_0)
next
  case False
  then have "a\<noteq>0" "x\<noteq>0"
    by auto
  then show ?thesis
  proof (cases "y=0")
    case True
    then show ?thesis
      using assms less_asym_TC mult_le2 by force
  next
    case False
    have "b=0" if "Ord \<alpha>" "x \<in> elts (Vset \<alpha>)" "y \<in> elts (Vset \<alpha>)" for \<alpha>
      using that assms
    proof (induction \<alpha> arbitrary: x y b rule: Ord_induct3)
      case 0
      then show ?case by auto
    next
      case (succ k)
      define \<Phi> where "\<Phi> \<equiv> \<lambda>x y. \<exists>r. 0 \<sqsubset> r \<and> r \<sqsubset> a \<and> a*x = a*y + r"
      show ?case
      proof (rule ccontr)
        assume "b \<noteq> 0"
        then have "0 \<sqsubset> b"
          by (metis nonzero_less_TC)
        then have "\<Phi> x y"
          unfolding \<Phi>_def using succ.prems by blast
        then obtain x' where "\<Phi> x' y" "x' \<sqsubseteq> x" and min: "\<And>x''. x'' \<sqsubset> x' \<Longrightarrow> \<not> \<Phi> x'' y"
          using less_TC_minimal [of "\<lambda>x. \<Phi> x y" x] by blast
        then obtain b' where "0 \<sqsubset> b'" "b' \<sqsubset> a" and eq: "a*x' = a*y + b'"
          using \<Phi>_def by blast
        have "a*y \<sqsubset> a*x'"
          using TC_add' \<open>0 \<sqsubset> b'\<close> eq by auto
        then obtain p where "p \<in> elts (a * x')" "a * y \<sqsubseteq> p"
          using less_TC_iff by blast
        then have "p \<notin> elts (a * y)"
          using less_TC_iff less_irrefl_TC by blast
        then have "p \<in> \<Union> (elts ` (\<lambda>v. lift (a * v) a) ` elts x')"
          by (metis \<open>p \<in> elts (a * x')\<close> elts_Sup replacement small_elts mult)
        then obtain u c where "u \<in> elts x'" "c \<in> elts a" "p = a*u + c"
          using lift_def by auto
        then have "p \<in> elts (lift (a*y) b')"
          using \<open>p \<in> elts (a * x')\<close> \<open>p \<notin> elts (a * y)\<close> eq plus_eq_lift by auto
        then obtain d where d: "d \<in> elts b'" "p = a*y + d" "p = a*u + c"
          by (metis \<open>p = a * u + c\<close> \<open>p \<in> elts (a * x')\<close> \<open>p \<notin> elts (a * y)\<close> eq mem_plus_V_E)
        have noteq: "a*y \<noteq> a*u"
        proof
          assume "a*y = a*u"
          then have "lift (a*y) a = lift (a*u) a"
            by metis
          also have "\<dots> \<le> a*x'"
            unfolding mult [of _ x'] using \<open>u \<in> elts x'\<close> by (auto intro: cSUP_upper)
          also have "\<dots> = a*y \<squnion> lift (a*y) b'"
            by (simp add: eq plus_eq_lift)
          finally have "lift (a*y) a \<le> a*y \<squnion> lift (a*y) b'" .
          then have "lift (a*y) a \<le> lift (a*y) b'"
            using add_le_cancel_left less_TC_imp_not_le plus_eq_lift \<open>b' \<sqsubset> a\<close> by auto
          then have "a \<le> b'"
            by (simp add: le_iff_sup lift_eq_lift lift_sup_distrib)
          then show False
            using \<open>b' \<sqsubset> a\<close> less_TC_imp_not_le by auto
        qed
        consider "a*y \<unlhd> a*u" | "a*u \<unlhd> a*y"
          using d comparable vle_comparable_def by auto
        then show False
        proof cases
          case 1
          then obtain e where e: "a*u = a*y + e" "e \<noteq> 0"
            by (metis add.right_neutral noteq vle_def)
          moreover have "e + c = d"
            by (metis e add_right_cancel \<open>p = a * u + c\<close> \<open>p = a * y + d\<close> add.assoc)
          with \<open>d \<in> elts b'\<close> \<open>b' \<sqsubset> a\<close> have "e \<sqsubset> a"
            by (meson less_TC_iff less_TC_trans vle2 vle_def)
          ultimately show False
            \<comment>\<open>contradicts minimality of @{term x'}\<close>
            using min unfolding \<Phi>_def by (meson \<open>u \<in> elts x'\<close> le_TC_def less_TC_iff nonzero_less_TC)
        next
          case 2
          then obtain e where e: "a*y = a*u + e" "e \<noteq> 0"
            by (metis add.right_neutral noteq vle_def)
          moreover have "e + d = c"
            by (metis e add_right_cancel \<open>p = a * u + c\<close> \<open>p = a * y + d\<close> add.assoc)
          with \<open>d \<in> elts b'\<close> \<open>b' \<sqsubset> a\<close> have "e \<sqsubset> a"
            by (metis \<open>c \<in> elts a\<close> less_TC_iff vle2 vle_def)
          ultimately have "\<Phi> y u"
            unfolding \<Phi>_def using nonzero_less_TC by blast
          then obtain y' where "\<Phi> y' u" "y' \<sqsubseteq> y" and min: "\<And>x''. x'' \<sqsubset> y' \<Longrightarrow> \<not> \<Phi> x'' u"
            using less_TC_minimal [of "\<lambda>x. \<Phi> x u" y] by blast
          then obtain b' where "0 \<sqsubset> b'" "b' \<sqsubset> a" and eq: "a*y' = a*u + b'"
            using \<Phi>_def by blast
          have u_k: "u \<in> elts (Vset k)"
            using \<open>u \<in> elts x'\<close> \<open>x' \<sqsubseteq> x\<close> succ Vset_succ_TC less_TC_iff less_le_TC_trans by blast
          have "a*u \<sqsubset> a*y'"
            using TC_add' \<open>0 \<sqsubset> b'\<close> eq by auto
          then obtain p where "p \<in> elts (a * y')" "a * u \<sqsubseteq> p"
            using less_TC_iff by blast
          then have "p \<notin> elts (a * u)"
            using less_TC_iff less_irrefl_TC by blast
          then have "p \<in> \<Union> (elts ` (\<lambda>v. lift (a * v) a) ` elts y')"
            by (metis \<open>p \<in> elts (a * y')\<close> elts_Sup replacement small_elts mult)
          then obtain v c where "v \<in> elts y'" "c \<in> elts a" "p = a*v + c"
            using lift_def by auto
          then have "p \<in> elts (lift (a*u) b')"
            using \<open>p \<in> elts (a * y')\<close> \<open>p \<notin> elts (a * u)\<close> eq plus_eq_lift by auto
          then obtain d where d: "d \<in> elts b'" "p = a*u + d" "p = a*v + c"
            by (metis \<open>p = a * v + c\<close> \<open>p \<in> elts (a * y')\<close> \<open>p \<notin> elts (a * u)\<close> eq mem_plus_V_E)
          have v_k: "v \<in> elts (Vset k)"
            using Vset_succ_TC \<open>v \<in> elts y'\<close> \<open>y' \<sqsubseteq> y\<close> less_TC_iff less_le_TC_trans succ.hyps succ.prems(2) by blast
          have noteq: "a*u \<noteq> a*v"
            proof
              assume "a*u = a*v"
              then have "lift (a*v) a \<le> a*y'"
                unfolding mult [of _ y'] using \<open>v \<in> elts y'\<close> by (auto intro: cSUP_upper)
              also have "\<dots> = a*u \<squnion> lift (a*u) b'"
                by (simp add: eq plus_eq_lift)
              finally have "lift (a*v) a \<le> a*u \<squnion> lift (a*u) b'" .
              then have "lift (a*u) a \<le> lift (a*u) b'"
                by (metis \<open>a * u = a * v\<close> le_iff_sup lift_sup_distrib sup_left_commute sup_lift_eq_lift)
              then have "a \<le> b'"
                by (simp add: le_iff_sup lift_eq_lift lift_sup_distrib)
              then show False
                using \<open>b' \<sqsubset> a\<close> less_TC_imp_not_le by auto
            qed
          consider "a*u \<unlhd> a*v" | "a*v \<unlhd> a*u"
            using d comparable vle_comparable_def by auto
          then show False
          proof cases
            case 1
            then obtain e where e: "a*v = a*u + e" "e \<noteq> 0"
              by (metis add.right_neutral noteq vle_def)
            moreover have "e + c = d"
              by (metis add_right_cancel \<open>p = a * u + d\<close> \<open>p = a * v + c\<close> add.assoc e)
            with \<open>d \<in> elts b'\<close> \<open>b' \<sqsubset> a\<close> have "e \<sqsubset> a"
              by (meson less_TC_iff less_TC_trans vle2 vle_def)
            ultimately show False
              using succ.IH u_k v_k by blast
          next
            case 2
            then obtain e where e: "a*u = a*v + e" "e \<noteq> 0"
              by (metis add.right_neutral noteq vle_def)
            moreover have "e + d = c"
              by (metis add_right_cancel add.assoc d e)
            with \<open>d \<in> elts b'\<close> \<open>b' \<sqsubset> a\<close> have "e \<sqsubset> a"
              by (metis \<open>c \<in> elts a\<close> less_TC_iff vle2 vle_def)
           ultimately show False
             using succ.IH u_k v_k by blast
          qed
        qed
      qed
    next
      case (Limit k)
      obtain i j where k: "i \<in> elts k" "j \<in> elts k"
        and x: "x \<in> elts (Vset i)"
        and y: "y \<in> elts (Vset j)"
        using that Limit by (auto simp: Limit_Vfrom_eq)
      show ?case
      proof (rule Limit.IH [of "i \<squnion> j"])
        show "i \<squnion> j \<in> elts k"
          by (meson k x y Limit.hyps Limit_def Ord_in_Ord Ord_mem_iff_lt Ord_sup union_less_iff)
        show "x \<in> elts (Vset (i \<squnion> j))" "y \<in> elts (Vset (i \<squnion> j))"
          using x y by (auto simp: Vfrom_sup)
      qed (use Limit.prems in auto)
    qed
    then show ?thesis
      by (metis two_in_Vset Ord_rank Ord_VsetI rank_lt)
  qed
qed

subsubsection\<open>Theorem 4.7\<close>

lemma mult_cancellation_half:
  assumes "a*x + r = a*y + s" "r \<sqsubset> a" "s \<sqsubset> a"
  shows "x \<le> y"
proof -
  have "x \<le> y" if "Ord \<alpha>" "x \<in> elts (Vset \<alpha>)" "y \<in> elts (Vset \<alpha>)" for \<alpha>
    using that assms
  proof (induction \<alpha> arbitrary: x y r s rule: Ord_induct3)
    case 0
    then show ?case
      by auto
  next
    case (succ k)
    show ?case
    proof
      fix u
      assume u: "u \<in> elts x"
      have u_k: "u \<in> elts (Vset k)"
        using Vset_succ succ.hyps succ.prems(1) u by auto
      obtain r' where "r' \<in> elts a" "r \<sqsubseteq> r'"
        using less_TC_iff succ.prems(4) by blast
      have "a*u + r' \<in> elts (lift (a*u) a)"
        by (simp add: \<open>r' \<in> elts a\<close> lift_def)
      also have "\<dots> \<le> elts (a*x)"
        using u by (force simp: mult [of _ x])
      also have "\<dots> \<le> elts (a*y + s)"
        by (metis less_eq_V_def plus_eq_lift succ.prems(3) sup_ge1)
      also have "\<dots> = elts (a*y) \<union> elts (lift (a*y) s)"
        by (simp add: plus_eq_lift)
      finally have "a * u + r' \<in> elts (a * y) \<union> elts (lift (a * y) s)" .
      then show "u \<in> elts y"
      proof
        assume *: "a * u + r' \<in> elts (a * y)"
        show "u \<in> elts y"
        proof -
          obtain v e where v: "v \<in> elts y" "e \<in> elts a" "a * u + r' = a * v + e"
            using * by (auto simp: mult [of _ y] lift_def)
          then have v_k: "v \<in> elts (Vset k)"
            using Vset_succ_TC less_TC_iff succ.prems(2) by blast
          then have "u = v"
            by (metis succ.IH u_k V_equalityI \<open>r' \<in> elts a\<close> le_TC_refl less_TC_iff v(2) v(3) vsubsetD)
          then show ?thesis
            using \<open>v \<in> elts y\<close> by blast
        qed
      next
        assume "a * u + r' \<in> elts (lift (a * y) s)"
        then obtain t where "t \<in> elts s" and t: "a * u + r' = a * y + t"
          using lift_def by auto
        have noteq: "a*y \<noteq> a*u"
        proof
          assume "a*y = a*u"
          then have "lift (a*y) a = lift (a*u) a"
            by metis
          also have "\<dots> \<le> a*x"
            unfolding mult [of _ x] using \<open>u \<in> elts x\<close> by (auto intro: cSUP_upper)
          also have "\<dots> \<le> a*y \<squnion> lift (a*y) s"
            using \<open>elts (a * x) \<subseteq> elts (a * y + s)\<close> plus_eq_lift by auto
          finally have "lift (a*y) a \<le> a*y \<squnion> lift (a*y) s" .
          then have "lift (a*y) a \<le> lift (a*y) s"
            using add_le_cancel_left less_TC_imp_not_le plus_eq_lift \<open>s \<sqsubset> a\<close> by auto
          then have "a \<le> s"
            by (simp add: le_iff_sup lift_eq_lift lift_sup_distrib)
          then show False
            using \<open>s \<sqsubset> a\<close> less_TC_imp_not_le by auto
        qed
        consider "a * u \<unlhd> a * y" | "a * y \<unlhd> a * u"
          using t comparable vle_comparable_def by blast
        then have "False"
        proof cases
          case 1
          then obtain c where "a*y = a*u + c"
            by (metis vle_def)
          then have "c+t = r'"
            by (metis add_right_cancel add.assoc t)
          then have "c \<sqsubset> a"
            using \<open>r' \<in> elts a\<close> less_TC_iff vle2 vle_def by force
          moreover have "c \<noteq> 0"
            using \<open>a * y = a * u + c\<close> noteq by auto
          ultimately show ?thesis
            using \<open>a * y = a * u + c\<close> mult_eq_imp_0 by blast
        next
          case 2
          then obtain c where "a*u = a*y + c"
            by (metis vle_def)
          then have "c+r' = t"
            by (metis add_right_cancel add.assoc t)
          then have "c \<sqsubset> a"
            by (metis \<open>t \<in> elts s\<close> less_TC_iff less_TC_trans \<open>s \<sqsubset> a\<close> vle2 vle_def)
          moreover have "c \<noteq> 0"
            using \<open>a * u = a * y + c\<close> noteq by auto
          ultimately show ?thesis
            using \<open>a * u = a * y + c\<close> mult_eq_imp_0 by blast
        qed
        then show "u \<in> elts y" ..
      qed
    qed
  next
    case (Limit k)
    obtain i j where k: "i \<in> elts k" "j \<in> elts k"
      and x: "x \<in> elts (Vset i)" and y: "y \<in> elts (Vset j)"
      using that Limit by (auto simp: Limit_Vfrom_eq)
    show ?case
    proof (rule Limit.IH [of "i \<squnion> j"])
      show "i \<squnion> j \<in> elts k"
        by (meson k x y Limit.hyps Limit_def Ord_in_Ord Ord_mem_iff_lt Ord_sup union_less_iff)
      show "x \<in> elts (Vset (i \<squnion> j))" "y \<in> elts (Vset (i \<squnion> j))"
        using x y by (auto simp: Vfrom_sup)
      thm Limit.prems
    qed (auto intro: Limit.prems)
  qed
  then show ?thesis
    by (metis two_in_Vset Ord_rank Ord_VsetI rank_lt)
qed

theorem mult_cancellation_lemma:
  assumes "a*x + r = a*y + s" "r \<sqsubset> a" "s \<sqsubset> a"
  shows "x=y \<and> r=s"
  by (metis add_right_cancel mult_cancellation_half antisym assms)

corollary mult_cancellation [simp]:
  fixes a::V
  assumes "a \<noteq> 0"
  shows "a*x = a*y \<longleftrightarrow> x=y"
  by (metis assms nonzero_less_TC mult_cancellation_lemma)

corollary lift_mult_TC_disjoint:
  fixes x::V
  assumes "x \<noteq> y"
  shows "lift (a*x) (TC a) \<sqinter> lift (a*y) (TC a) = 0"
  apply (rule V_equalityI)
  using assms
  by (auto simp: less_TC_def inf_V_def lift_def image_iff dest: mult_cancellation_lemma)

corollary lift_mult_disjoint:
  fixes x::V
  assumes "x \<noteq> y"
  shows "lift (a*x) a \<sqinter> lift (a*y) a = 0"
proof -
  have "lift (a*x) a \<sqinter> lift (a*y) a \<le> lift (a*x) (TC a) \<sqinter> lift (a*y) (TC a)"
    by (metis TC' inf_mono lift_sup_distrib sup_ge1)
  then show ?thesis
    using assms lift_mult_TC_disjoint by auto
qed

lemma mult_add_mem:
  assumes "a*x + r \<in> elts (a*y)" "r \<sqsubset> a"
  shows "x \<in> elts y" "r \<in> elts a"
proof -
  obtain v s where v: "a * x + r = a * v + s" "v \<in> elts y" "s \<in> elts a"
    using assms unfolding mult [of a y] lift_def by auto
  then show "x \<in> elts y"
    by (metis arg_subset_TC assms(2) less_TC_def mult_cancellation_lemma vsubsetD)
  show "r \<in> elts a"
    by (metis arg_subset_TC assms(2) less_TC_def mult_cancellation_lemma v(1) v(3) vsubsetD)
qed

lemma zero_mem_mult_iff: "0 \<in> elts (x*y) \<longleftrightarrow> 0 \<in> elts x \<and> 0 \<in> elts y"
  by (metis Kirby.mult_zero_right mult_add_mem_0)

lemma zero_less_mult_iff [simp]: "0 < x*y \<longleftrightarrow> 0 < x \<and> 0 < y" if "Ord x"
  using Kirby.mult_eq_0_iff ZFC_in_HOL.neq0_conv by blast

lemma mult_cancel_less_iff [simp]:
  "\<lbrakk>Ord \<alpha>; Ord \<beta>; Ord \<gamma>\<rbrakk> \<Longrightarrow> \<alpha>*\<beta> < \<alpha>*\<gamma> \<longleftrightarrow> \<beta> < \<gamma> \<and> 0 < \<alpha>"
  using mult_add_mem_0 [of \<alpha> \<beta> \<gamma>]
  by (meson Ord_0 Ord_mem_iff_lt Ord_mult)

lemma mult_cancel_le_iff [simp]:
  "\<lbrakk>Ord \<alpha>; Ord \<beta>; Ord \<gamma>\<rbrakk> \<Longrightarrow> \<alpha>*\<beta> \<le> \<alpha>*\<gamma> \<longleftrightarrow> \<beta> \<le> \<gamma> \<or> \<alpha>=0"
  by (metis Ord_linear2 Ord_mult eq_iff leD mult_cancel_less_iff mult_cancellation)

lemma mult_Suc_add_less: "\<lbrakk>\<alpha> < \<gamma>; \<beta> < \<gamma>; Ord \<alpha>; Ord \<beta>; Ord \<gamma>\<rbrakk>  \<Longrightarrow> \<gamma> * ord_of_nat m + \<alpha> < \<gamma> * ord_of_nat (Suc m) + \<beta>"
  apply (simp add: mult_succ add.assoc)
  by (meson Ord_add Ord_linear2 le_less_trans not_add_less_right)

lemma mult_nat_less_add_less:
  assumes "m < n" "\<alpha> < \<gamma>" "\<beta> < \<gamma>" and ord: "Ord \<alpha>" "Ord \<beta>" "Ord \<gamma>"
    shows "\<gamma> * ord_of_nat m + \<alpha> < \<gamma> * ord_of_nat n + \<beta>"
proof -
  have "Suc m \<le> n"
    using \<open>m < n\<close> by auto
  have "\<gamma> * ord_of_nat m + \<alpha> < \<gamma> * ord_of_nat (Suc m) + \<beta>"
    using assms mult_Suc_add_less by blast
  also have "\<dots> \<le> \<gamma> * ord_of_nat n + \<beta>"
    using Ord_mult Ord_ord_of_nat add_right_mono \<open>Suc m \<le> n\<close> ord mult_cancel_le_iff ord_of_nat_mono_iff by presburger
  finally show ?thesis .
qed

lemma add_mult_less_add_mult:
  assumes "x < y" "x \<in> elts \<beta>" "y \<in> elts \<beta>" "\<mu> \<in> elts \<alpha>" "\<nu> \<in> elts \<alpha>" "Ord \<alpha>" "Ord \<beta>"
    shows "\<alpha>*x + \<mu> < \<alpha>*y + \<nu>"
proof -
  obtain "Ord x" "Ord y"
    using Ord_in_Ord assms by blast
  then obtain \<delta> where "0 \<in> elts \<delta>" "y = x + \<delta>"
    by (metis add.right_neutral \<open>x < y\<close> le_Ord_diff less_V_def mem_0_Ord)
  then show ?thesis
    apply (simp add: add_mult_distrib add.assoc)
    by (meson OrdmemD add_le_cancel_left0 \<open>\<mu> \<in> elts \<alpha>\<close> \<open>Ord \<alpha>\<close> less_le_trans zero_imp_le_mult)
qed

lemma add_mult_less:
  assumes "\<gamma> \<in> elts \<alpha>" "\<nu> \<in> elts \<beta>" "Ord \<alpha>" "Ord \<beta>"
    shows "\<alpha> * \<nu> + \<gamma> \<in> elts (\<alpha> * \<beta>)"
proof -
  have "Ord \<nu>"
    using Ord_in_Ord assms by blast
  with assms show ?thesis
    by (metis Ord_mem_iff_lt Ord_succ add_mem_right_cancel mult_cancel_le_iff mult_succ succ_le_iff vsubsetD)
qed

lemma vcard_mult: "vcard (x * y) = vcard x \<otimes> vcard y"
proof -
  have 1: "elts (lift (x * u) x) \<approx> elts x" if "u \<in> elts y" for u
    by (metis cardinal_eqpoll eqpoll_sym eqpoll_trans card_lift)
  have 2: "pairwise (\<lambda>u u'. disjnt (elts (lift (x * u) x)) (elts (lift (x * u') x)))  (elts y)"
    by (simp add: pairwise_def disjnt_def) (metis V_disjoint_iff lift_mult_disjoint)
  have "x * y = (SUP u\<in>elts y. lift (x * u) x)"
    using mult by blast
  then have "elts (x * y) \<approx> (\<Union>u\<in>elts y. elts (lift (x * u) x))"
    by simp
  also have "\<dots> \<approx> elts y \<times> elts x"
    using Union_eqpoll_Times [OF 1 2] .
  also have "\<dots> \<approx> elts x \<times> elts y"
    by (simp add: times_commute_eqpoll)
  also have "\<dots> \<approx> elts (vcard x) \<times> elts (vcard y)"
    using cardinal_eqpoll eqpoll_sym times_eqpoll_cong by blast
  also have "\<dots> \<approx> elts (vcard x \<otimes> vcard y)"
    by (simp add: cmult_def elts_vcard_VSigma_eqpoll eqpoll_sym)
  finally have "elts (x * y) \<approx> elts (vcard x \<otimes> vcard y)" .
  then show ?thesis
    by (metis cadd_cmult_distrib cadd_def cardinal_cong cardinal_idem vsum_0_eqpoll)
qed

proposition TC_mult: "TC(x * y) = (SUP r \<in> elts (TC x). SUP u \<in> elts (TC y). set{x * u + r})"
proof (cases "x = 0")
  case False
  have *: "TC(x * y) = (SUP u \<in> elts (TC y). lift (x * u) (TC x))" for y
  proof (induction y rule: eps_induct)
    case (step y)
    have "TC(x * y) = (SUP u \<in> elts y. TC (lift (x * u) x))"
      by (simp add: mult [of x y] TC_Sup_distrib image_image)
    also have "\<dots> = (SUP u \<in> elts y. TC(x * u) \<squnion> lift (x * u) (TC x))"
      by (simp add: TC_lift False)
    also have "\<dots> = (SUP u \<in> elts y. (SUP z \<in> elts (TC u). lift (x * z) (TC x)) \<squnion> lift (x * u) (TC x))"
      by (simp add: step)
    also have "\<dots> = (SUP u \<in> elts (TC y). lift (x * u) (TC x))"
      by (auto simp: TC' [of y] image_Un Sup_Un_distrib TC_Sup_distrib cSUP_UNION SUP_sup_distrib)
    finally show ?case .
  qed
  show ?thesis
    by (force simp: * lift_def)
qed auto

corollary vcard_TC_mult: "vcard (TC(x * y)) = vcard (TC x) \<otimes> vcard (TC y)"
proof -
  have "(\<Union>u\<in>elts (TC x). \<Union>v\<in>elts (TC y). {x * v + u}) = (\<Union>u\<in>elts (TC x). (\<lambda>v. x * v + u) ` elts (TC y))"
    by (simp add: UNION_singleton_eq_range)
  also have "\<dots> \<approx> (\<Union>x\<in>elts (TC x). elts (lift (TC y * x) (TC y)))"
  proof (rule UN_eqpoll_UN)
    show "(\<lambda>v. x * v + u) ` elts (TC y) \<approx> elts (lift (TC y * u) (TC y))"
      if "u \<in> elts (TC x)" for u
    proof -
      have "inj_on (\<lambda>v. x * v + u) (elts (TC y))"
        by (meson inj_onI less_TC_def mult_cancellation_lemma that)
      then have "(\<lambda>v. x * v + u) ` elts (TC y) \<approx> elts (TC y)"
        by (rule inj_on_image_eqpoll_self)
      also have "\<dots> \<approx> elts (lift (TC y * u) (TC y))"
        by (simp add: eqpoll_lift eqpoll_sym)
      finally show ?thesis .
    qed
    show "pairwise (\<lambda>u ya. disjnt ((\<lambda>v. x * v + u) ` elts (TC y)) ((\<lambda>v. x * v + ya) ` elts (TC y))) (elts (TC x))"
      apply (auto simp: pairwise_def disjnt_def)
      using less_TC_def mult_cancellation_lemma by blast
    show "pairwise (\<lambda>u ya. disjnt (elts (lift (TC y * u) (TC y))) (elts (lift (TC y * ya) (TC y)))) (elts (TC x))"
      apply (auto simp: pairwise_def disjnt_def)
      by (metis Int_iff V_disjoint_iff empty_iff lift_mult_disjoint)
  qed
  also have "\<dots> = elts (TC y * TC x)"
    by (metis elts_Sup image_image mult replacement small_elts)
  finally have "(\<Union>u\<in>elts (TC x). \<Union>v\<in>elts (TC y). {x * v + u}) \<approx> elts (TC y * TC x)" .
  then show ?thesis
    apply (subst cmult_commute)
    by (simp add: TC_mult cardinal_cong flip: vcard_mult)
qed

lemma countable_mult:
  assumes "countable (elts A)" "countable (elts B)"
  shows "countable (elts (A*B))"
proof -
  have "vcard A \<le> \<aleph>0" "vcard B \<le> \<aleph>0"
    using assms countable_iff_le_Aleph0 by blast+
  then have "vcard (A*B) \<le> \<aleph>0"
    unfolding vcard_mult
    by (metis InfCard_csquare_eq cmult_le_mono Aleph_0 Card_\<omega> InfCard_def order_refl)
  then show ?thesis
    by (simp add: countable_iff_le_Aleph0)
qed

subsection \<open>Ordertype properties\<close>

lemma ordertype_image_plus:
  assumes "Ord \<alpha>"
  shows "ordertype ((+) u ` elts \<alpha>) VWF = \<alpha>"
proof (subst ordertype_VWF_eq_iff)
    have 1: "(u + x, u + y) \<in> VWF" if "x \<in> elts \<alpha>" "y \<in> elts \<alpha>" "x < y" for x y
      using that
      by (meson Ord_in_Ord Ord_mem_iff_lt add_mem_right_cancel assms mem_imp_VWF)
  then have 2: "x < y"
    if "x \<in> elts \<alpha>" "y \<in> elts \<alpha>" "(u + x, u + y) \<in> VWF" for x y
    using that by (metis Ord_in_Ord Ord_linear_lt VWF_asym assms)
  show "\<exists>f. bij_betw f ((+) u ` elts \<alpha>) (elts \<alpha>) \<and> (\<forall>x\<in>(+) u ` elts \<alpha>. \<forall>y\<in>(+) u ` elts \<alpha>. (f x < f y) = ((x, y) \<in> VWF))"
    using 1 2 unfolding bij_betw_def inj_on_def
    by (rule_tac x="\<lambda>x. odiff x u" in exI) (auto simp: image_iff)
qed (use assms in auto)

lemma ordertype_diff:
  assumes "\<beta> + \<delta> = \<alpha>" and \<alpha>: "\<delta> \<in> elts \<alpha>" "Ord \<alpha>"
  shows "ordertype (elts \<alpha> - elts \<beta>) VWF = \<delta>"
proof -
  have *: "elts \<alpha> - elts \<beta> = ((+)\<beta>) ` elts \<delta>"
  proof
    show "elts \<alpha> - elts \<beta> \<subseteq> (+) \<beta> ` elts \<delta>"
      by clarsimp (metis assms(1) image_iff mem_plus_V_E)
    show "(+) \<beta> ` elts \<delta> \<subseteq> elts \<alpha> - elts \<beta>"
      using assms(1) not_add_mem_right by force
  qed
  have "ordertype ((+) \<beta> ` elts \<delta>) VWF = \<delta>"
  proof (subst ordertype_VWF_inc_eq)
    show "elts \<delta> \<subseteq> ON" "ordertype (elts \<delta>) VWF = \<delta>"
      using \<alpha> elts_subset_ON ordertype_eq_Ord by blast+
  qed (use "*" assms elts_subset_ON in auto)
  then show ?thesis
    by (simp add: *)
qed

lemma ordertype_interval_eq:
  assumes \<alpha>: "Ord \<alpha>" and \<beta>: "Ord \<beta>"
  shows "ordertype ({\<alpha> ..< \<alpha>+\<beta>} \<inter> ON) VWF = \<beta>"
proof -
  have ON: "(+) \<alpha> ` elts \<beta> \<subseteq> ON"
    using assms Ord_add Ord_in_Ord by blast
  have "({\<alpha> ..< \<alpha>+\<beta>} \<inter> ON) = (+) \<alpha> ` elts \<beta>"
    using assms
    apply (simp add: image_def set_eq_iff)
    by (metis add_less_cancel_left Ord_add Ord_in_Ord Ord_linear2 Ord_mem_iff_lt le_Ord_diff not_add_less_right)
  moreover have "ordertype (elts \<beta>) VWF = ordertype ((+) \<alpha> ` elts \<beta>) VWF"
    using ON \<beta> elts_subset_ON ordertype_VWF_inc_eq by auto
  ultimately show ?thesis
    using \<beta> by auto
qed

end


section "Algebraic Classes"

theory Derive_Algebra
imports Main "../Derive" Derive_Datatypes
begin

class semigroup =
  fixes mult :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<otimes>" 70)
(*  assumes assoc: "(x \<otimes> y) \<otimes> z = x \<otimes> (y \<otimes> z)" *)

class monoidl = semigroup +
fixes neutral :: 'a ("\<one>")
(* assumes neutl : "\<one> \<otimes> x = x" *)

class group = monoidl +
  fixes inverse :: "'a \<Rightarrow> 'a"
(* assumes invl: "x\<div> \<otimes> x = \<one>" *)

(* Manual instances for nat, unit, prod, and sum *)
instantiation nat and unit:: semigroup
begin
  definition mult_nat : "mult (x::nat) y = x + y"
  definition mult_unit_def: "mult (x::unit) y = x"
  instance ..
end
instantiation nat and unit:: monoidl
begin
  definition neutral_nat : "neutral = (0::nat)"
  definition neutral_unit_def: "neutral = ()"
  instance ..
end

instantiation nat and unit:: group
begin
  definition inverse_nat : "inverse (i::nat) = \<one> - i"
  definition inverse_unit_def: "inverse u = ()"
  instance ..
end

instantiation prod and sum :: (semigroup, semigroup) semigroup
begin
  definition mult_prod_def: "x \<otimes> y = (fst x \<otimes> fst y, snd x \<otimes> snd y)"
  definition mult_sum_def: "x \<otimes> y = (case x of Inl a \<Rightarrow> (case y of Inl b \<Rightarrow> Inl (a \<otimes> b) | Inr b \<Rightarrow> Inl a)
                                             | Inr a \<Rightarrow> (case y of Inl b \<Rightarrow> Inr a | Inr b \<Rightarrow> Inr (a \<otimes> b)))"
  instance ..
end

instantiation prod and sum :: (monoidl, monoidl) monoidl
begin
  definition neutral_prod_def: "neutral = (neutral,neutral)"
  definition neutral_sum_def: "neutral = Inl neutral"
  instance ..
end

instantiation prod and sum :: (group, group) group
begin
  definition inverse_prod_def: "inverse p = (inverse (fst p), inverse (snd p))"
  definition inverse_sum_def: "inverse x = (case x of Inl a \<Rightarrow> (Inl (inverse a))
                                                    | Inr b \<Rightarrow> Inr (inverse b))"
  instance ..
end

(* Simple test *)

derive_generic semigroup simple .
derive_generic monoidl simple .
derive_generic group simple .

lemma "(B \<one> 6) \<otimes> (B 4 5) = B 4 11" by eval
lemma "(A 2) \<otimes> (A 3) = A 5" by eval
lemma "(B \<one> 6) \<otimes> \<one> = B 0 6" by eval

(* type with parameter *)

derive_generic group either .

lemma "(L 3) \<otimes> ((L 4)::(nat,nat) either) = L 7" by eval
lemma "(R (2::nat)) \<otimes> (L (3::nat)) = R 2" by eval

(* recursive types *)

derive_generic semigroup list .
derive_generic monoidl list .
derive_generic group list .
derive_generic semigroup tree .
derive_generic monoidl tree .
derive_generic group tree .

lemma "[1,2,3,4::nat] \<otimes> [1,2,3] = [2,4,6,4]" by eval
lemma "inverse [1,2,3::nat] = [0,0,0]" by eval

(* mutually recursive types *)

derive_generic semigroup even_nat .
derive_generic monoidl even_nat .
derive_generic group even_nat .
derive_generic semigroup exp .

(* instantiate monoidl manually *)
instantiation exp and trm and fct  :: (monoidl,monoidl) monoidl
begin
  definition neutral_fct where "neutral_fct = Const neutral"
  definition neutral_trm where "neutral_trm = Factor neutral"
  definition neutral_exp where "neutral_exp = Term neutral"
  instance ..
end

(* Manually defined instances need to be added to the theory context *)
setup \<open>
(Derive.add_inst_info \<^class>\<open>monoidl\<close> \<^type_name>\<open>fct\<close> [@{thm neutral_fct_def}]) #>
(Derive.add_inst_info \<^class>\<open>monoidl\<close> \<^type_name>\<open>trm\<close> [@{thm neutral_trm_def}]) #>
(Derive.add_inst_info \<^class>\<open>monoidl\<close> \<^type_name>\<open>exp\<close> [@{thm neutral_exp_def}])
\<close>

derive_generic group exp .

lemma "(Odd_Succ (Even_Succ (Odd_Succ Even_Zero))) \<otimes> (Odd_Succ Even_Zero)
       = Odd_Succ (Even_Succ (Odd_Succ Even_Zero))" by eval
lemma "inverse (Odd_Succ Even_Zero) = Odd_Succ Even_Zero" by eval
lemma "(Term (Prod ((Const 1)::(nat, nat) fct) (Factor (Const (2::nat)))))
    \<otimes> (Term (Prod (Const (2::nat)) (Factor ((Const 2)::(nat, nat) fct))))
    = Term (Prod (Const 3) (Factor (Const 4)))" by eval

end


theory ArithVeri
  imports Main
begin

datatype Arith = Num nat
  | Plus Arith Arith
  | Minus Arith Arith
  | Times Arith Arith

datatype StackOp = SNum nat
  | SPlus
  | SMinus
  | STimes

fun eval :: "nat list \<Rightarrow> StackOp list \<Rightarrow> nat" where
"eval (n # _) [] = n" |
"eval ns (SNum n # xs) = eval (n # ns) xs" |
"eval (n1 # n2 # ns) (SPlus # xs) = eval ((n1+n2) # ns) xs" |
"eval (n1 # n2 # ns) (SMinus # xs) = eval ((n1-n2) # ns) xs" |
"eval (n1 # n2 # ns) (STimes # xs) = eval ((n1*n2) # ns) xs"

value "eval [] [SNum 1, SNum 2, SNum 4, STimes, SPlus]"

fun compile :: "Arith \<Rightarrow> StackOp list" where
"compile (Num n) = [SNum n]" |
"compile (Plus a1 a2) = compile a2 @ compile a1 @ [SPlus]" |
"compile (Minus a1 a2) = compile a2 @ compile a1 @ [SMinus]" |
"compile (Times a1 a2) = compile a2 @ compile a1 @ [STimes]"

value "compile (Plus (Num 1) (Times (Num 2) (Num 4)))"

fun eval' :: "Arith \<Rightarrow> nat" where
"eval' (Num n) = n" |
"eval' (Plus a1 a2) = (eval' a1) + (eval' a2)" |
"eval' (Minus a1 a2) = (eval' a1) - (eval' a2)" |
"eval' (Times a1 a2) = (eval' a1) * (eval' a2)"

value "eval' (Plus (Num 1) (Times (Num 2) (Num 4)))"

theorem compiler_correctness: "eval [] (compile a) = (eval' a)"
  sorry

end


theory prog_prov_ch03
imports Main
begin

text{*
  Section 3: Logic and Proof Beyond Equality
*}

datatype 'a tree = Tip | Node "'a tree" 'a "'a tree"

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

fun ord:: "int tree \<Rightarrow> bool" where
"ord Tip = True" |
"ord (Node l e r) = ((ord l) \<and> (ord r) \<and> (\<forall>x\<in> (set l). x<e) \<and> (\<forall>x\<in>(set r). e<x))"

fun ins:: "int \<Rightarrow> int tree \<Rightarrow> int tree" where
"ins a Tip = (Node Tip a Tip)"
| "ins a (Node l e r) = (if a < e then Node (ins a l) e r else if a=e then Node l e r else Node l e (ins a r))"

lemma ins_union: "set (ins x t) = {x} \<union> (set t)"
apply(induction t rule:ins.induct)
apply(auto)
done

lemma ins_ord: "ord t \<Longrightarrow> ord (ins x t)"
apply(induction t)
apply(auto simp add:ins_union)
done

lemma "\<forall> x. \<exists> y. x = y" by auto

lemma "A \<subseteq> B \<inter> C \<Longrightarrow> A \<subseteq> B \<union> C" by auto

lemma "A \<and> B \<Longrightarrow> B \<and> A"
apply (rule conjI)
apply simp_all
done

lemma "\<lbrakk>\<forall> xs \<in> A. \<exists> ys. xs = ys @ ys; us \<in> A \<rbrakk> \<Longrightarrow> \<exists> n. List.length us = n + n"
  by fastforce

lemma "\<lbrakk>\<forall> x y. T x y \<or> T y x; \<forall> x y. A x y \<and> A y x \<longrightarrow> x = y; \<forall> x y. T x y \<longrightarrow> A x y \<rbrakk> \<Longrightarrow>
\<forall> x y. A x y \<longrightarrow> T x y" by blast

lemma "\<lbrakk> xs @ ys = ys @ xs; length xs = length ys \<rbrakk> \<Longrightarrow> xs = ys"
by (metis append_eq_conv_conj)

lemma "\<lbrakk> (a::nat)\<le>x+b; 2*x < c\<rbrakk> \<Longrightarrow> 2*a +1 \<le> 2*b +c " by arith

lemma "\<lbrakk> (a::nat) \<le> b; b\<le>c; c\<le>d; d\<le>e\<rbrakk> \<Longrightarrow> a\<le>e"
apply (blast intro:le_trans)
done

thm conjI[OF refl[of "a"] refl[of "b"]]

lemma "Suc (Suc (Suc a)) \<le> b \<Longrightarrow> a \<le> b" by (blast dest:Suc_leD)

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

fun evn:: "nat\<Rightarrow>bool" where
"evn 0 = True" |
"evn (Suc 0) = False" |
"evn (Suc (Suc n)) = evn n"

lemma "ev (Suc (Suc (Suc (Suc 0))))"
apply (rule evSS)
apply (rule evSS)
apply (rule ev0)
done

lemma "ev n \<Longrightarrow> evn n"
apply(induction rule:ev.induct)
apply(auto)
done

lemma "evn n \<Longrightarrow> ev n"
apply(induction n rule: evn.induct)
apply(simp_all)
apply(rule ev0)
apply(rule evSS)
apply(simp)
done

inductive star:: "('a\<Rightarrow>'a\<Rightarrow>bool)\<Rightarrow>'a\<Rightarrow>'a\<Rightarrow>bool" for r where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
apply(induction rule:star.induct)
apply(assumption)
apply(metis step)
done

lemma star_rev: "star r x y \<Longrightarrow> r y z \<Longrightarrow> star r x z"
apply(induction rule:star.induct)
apply(rule step)
apply(simp_all)
apply(rule refl)
apply(rule step)
apply(simp_all)
done

(* exercise 3.2 *)

inductive palindrome:: "'a list \<Rightarrow> bool" where
empty_p: "palindrome []" |
single_p: "palindrome [x]" |
step_p: "palindrome xs \<Longrightarrow> palindrome (a # (xs@[a]))"

(* exercise 3.3 *)
inductive star':: "('a\<Rightarrow>'a\<Rightarrow>bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
refl': "star' r x x" |
step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

lemma "star' r x y \<Longrightarrow> star r x y"
apply(induction rule:star'.induct)
apply(rule refl)
apply(simp add:star_rev)
done

lemma star'_rev : "star' r y z  \<Longrightarrow>  r x y  \<Longrightarrow>  star' r x z"
apply(induction rule: star'.induct)
apply(auto intro: step' refl')
done

lemma "star r x y \<Longrightarrow> star' r x y"
apply(induction rule:star.induct)
apply(rule refl')
apply(auto simp add:star'_rev)
done

(* exercise 3.4 TODO *)
(* inductive iter:: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where *)

(* exercise 3.5 TODO *)

end


(*<*)
theory tmpl05
  imports
    Complex_Main
    "HOL-Library.Tree"
begin
(*>*)

text {* \ExerciseSheet{5}{11.~5.~2017} *}

text \<open>
  \<^item> Import \<open>Complex_Main\<close> and \<open>HOL-Library.Tree\<close>
  \<^item> For this exercise sheet (and Homework 1), you are not allowed to use sledgehammer!
    Proofs using the \<open>smt, metis, meson, or moura\<close> methods are forbidden!
\<close>

text \<open>
  \Exercise{Bounding power-of-two by factorial}
  Prove that, for all natural numbers $n>3$, we have $2^n < n!$.
  We have already prepared the proof skeleton for you.
\<close>
lemma exp_fact_estimate: "n>3 \<Longrightarrow> (2::nat)^n < fact n"
proof (induction n)
  case 0 then show ?case by auto
next
  case (Suc n)
  assume IH: "3 < n \<Longrightarrow> (2::nat) ^ n < fact n"
  assume PREM: "3 < Suc n"
  show "(2::nat) ^ Suc n < fact (Suc n)"
    text \<open>Fill in a proof here. Hint: Start with a case distinction
      whether \<open>n>3\<close> or \<open>n=3\<close>. \<close>
    sorry
qed

text \<open>
  \vspace{1em}
  {\bfseries Warning!}
  Make sure that your numerals have the right type, otherwise
  proofs will not work! To check the type of a numeral, hover the mouse over
  it with pressed CTRL (Mac: CMD) key. Example:
\<close>
lemma "2^n \<le> 2^Suc n"
  apply auto oops -- \<open>Leaves the subgoal \<open>2 ^ n \<le> 2 * 2 ^ n\<close>\<close>
  text \<open>You will find out that the numeral \<open>2\<close> has type @{typ 'a},
    for which you do not have any ordering laws. So you have to
    manually restrict the numeral's type to, e.g., @{typ nat}.\<close>
lemma "(2::nat)^n \<le> 2^Suc n" by simp -- \<open>Note: Type inference will
  infer \<open>nat\<close> for the unannotated numeral, too. Use CTRL+hover to double check!\<close>

text \<open>
  \vspace{1em}
\<close>

text \<open>\Exercise{Sum Squared is Sum of Cubes}
  \<^item> Define a recursive function $sumto~f~n = \sum_{i=0\ldots n} f(i)$.
  \<^item> Show that $\left(\sum_{i=0\ldots n}i\right)^2 = \sum_{i=0\ldots n} i^3$.
\<close>

fun sumto :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat"
where
"sumto f 0 = 0"

text \<open>You may need the following lemma:\<close>
lemma sum_of_naturals: "2 * sumto (\<lambda>x. x) n = n * Suc n"
  (*by (induction n) auto*) oops

lemma "sumto (\<lambda>x. x) n ^ 2 = sumto (\<lambda>x. x^3) n"
proof (induct n)
  case 0 show ?case by simp
next
  case (Suc n)
  assume IH: "(sumto (\<lambda>x. x) n)\<^sup>2 = sumto (\<lambda>x. x ^ 3) n"
  note [simp] = algebra_simps -- \<open>Extend the simpset only in this block\<close>
  show "(sumto (\<lambda>x. x) (Suc n))\<^sup>2 = sumto (\<lambda>x. x ^ 3) (Suc n)"
  text \<open>Insert a proof here\<close>
    sorry
qed

text \<open>
  \Exercise{Paths in Graphs}
  A graph is described by its adjacency matrix, i.e., \<open>G :: 'a \<Rightarrow> 'a \<Rightarrow> bool\<close>.

  Define a predicate \<open>path G u p v\<close> that is true if \<open>p\<close> is a path from
  \<open>u\<close> to \<open>v\<close>, i.e., \<open>p\<close> is a list of nodes, not including \<open>u\<close>, such that
  the nodes on the path are connected with edges.
  In other words, \<open>path G u (p\<^sub>1\<dots>p\<^sub>n) v\<close>, iff \<open>G u p\<^sub>1\<close>, \<open>G p\<^sub>i p\<^sub>i\<^sub>+\<^sub>1\<close>,
  and \<open>p\<^sub>n = v\<close>. For the empty path (\<open>n=0\<close>), we have \<open>u=v\<close>.
\<close>

fun path :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a \<Rightarrow> bool"
  where
  "path _ _ _ _ \<longleftrightarrow> False"

text \<open>Test cases\<close>
definition "nat_graph x y \<longleftrightarrow> y=Suc x"
value \<open>path nat_graph 2 [] 2\<close>
value \<open>path nat_graph 2 [3,4,5] 5\<close>
value \<open>\<not> path nat_graph 3 [3,4,5] 6\<close>
value \<open>\<not> path nat_graph 2 [3,4,5] 6\<close>

text \<open>Show the following lemma, that decomposes paths. Register it as simp-lemma.\<close>
lemma path_append[simp]: "path G u (p1@p2) v \<longleftrightarrow> (\<exists>w. path G u p1 w \<and> path G w p2 v)"
  oops

text \<open>
  Show that, for a non-distinct path from \<open>u\<close> to \<open>v\<close>,
  we find a longer non-distinct path from \<open>u\<close> to \<open>v\<close>.
  Note: This can be seen as a simple pumping-lemma,
  allowing to pump the length of the path.

  Hint: Theorem @{thm [source] not_distinct_decomp}.
\<close>
lemma pump_nondistinct_path:
  assumes P: "path G u p v"
  assumes ND: "\<not>distinct p"
  shows "\<exists>p'. length p' > length p \<and> \<not>distinct p' \<and> path G u p' v"
  oops

text \<open>
  \NumHomework{Split Lists}{May 18}
  Recall: Use Isar where appropriate, proofs using
    \<open>metis, smt, meson, or moura\<close> (as generated by sledgehammer) are forbidden!

  Show that every list can be split into a prefix and a suffix,
  such that the length of the prefix is \<open>1/n\<close> of the original lists's length.

\<close>

lemma
  assumes "n\<ge>0" -- \<open>Note: This assumption is actually not needed,
    as @{lemma "n div 0 = 0" by auto}, so don't be puzzled if you do
    not use it at all in your proof.\<close>
  shows "\<exists>ys zs. length ys = length xs div n \<and> xs=ys@zs"
  oops

text \<open>
  \NumHomework{Estimate Recursion Equation}{May 18}

  (Sledgehammer allowed again)

  Show that the function defined by \<open>a 0 = 0\<close> and \<open>a (n+1) = (a n)\<^sup>2 + 1\<close>
  is bounded by the double-exponential function \<open>2^(2^n)\<close>
\<close>

fun a :: "nat \<Rightarrow> int" where
"a 0 = 0" |
"a (Suc n) = a n ^ 2 + 1"

text \<open>
  We have given you a proof skeleton, setting up the induction.
  To complete your proof, you should come up with a chain of inequations.
  You may try to solve the intermediate steps with sledgehammer.

  Hint: It is a bit tricky to get the approximation right.
    We strongly recommend to sketch the inequations on paper first.

  Hint: Have a look at the lemma @{thm [source] power_mono}, in particular its
  instance for squares:
\<close>

thm power_mono[where n=2]

lemma "a n \<le> 2 ^ (2 ^ n) - 1"
proof(induction n)
  case 0 thus ?case by simp
next
  case (Suc n)
  assume IH: "a n \<le> 2 ^ 2 ^ n - 1"
    -- \<open>Refer to the induction hypothesis by name \<open>IH\<close> or \<open>Suc.IH\<close>\<close>
  show "a (Suc n) \<le> 2 ^ 2 ^ Suc n - 1"
  proof -
    text \<open>Insert your proof here\<close>
    show ?thesis sorry
  qed
qed

(*<*)
end
(*>*)


(*
    Author:      René Thiemann
    License:     BSD
*)
subsection \<open>Fundamental Theorem of Algebra for Factorizations\<close>

text \<open>Via the existing formulation of the fundamental theorem of algebra,
  we prove that we always get a linear factorization of a complex polynomial.
  Using this factorization we show that root-square-freeness of complex polynomial
  is identical to the statement that the cardinality of the set of all roots
  is equal to the degree of the polynomial.\<close>

theory Fundamental_Theorem_Algebra_Factorized
imports
  Order_Polynomial
  "HOL-Computational_Algebra.Fundamental_Theorem_Algebra"
begin

lemma fundamental_theorem_algebra_factorized: fixes p :: "complex poly"
  shows "\<exists> as. smult (coeff p (degree p)) (\<Prod> a \<leftarrow> as. [:- a, 1:]) = p \<and> length as = degree p"
proof -
  define n where "n = degree p"
  have "degree p = n" unfolding n_def by simp
  thus ?thesis
  proof (induct n arbitrary: p)
    case (0 p)
    hence "\<exists> c. p = [: c :]" by (cases p, auto split: if_splits)
    thus ?case by (intro exI[of _ Nil], auto)
  next
    case (Suc n p)
    have dp: "degree p = Suc n" by fact
    hence "\<not> constant (poly p)" by (simp add: constant_degree)
    from fundamental_theorem_of_algebra[OF this] obtain c where rt: "poly p c = 0" by auto
    hence "[:-c,1 :] dvd p" by (simp add: dvd_iff_poly_eq_0)
    then obtain q where p: "p = q * [: -c,1 :]" by (metis dvd_def mult.commute)
    from \<open>degree p = Suc n\<close> have dq: "degree q = n" using p
      by simp (metis add.right_neutral degree_synthetic_div diff_Suc_1 mult.commute mult_left_cancel p pCons_eq_0_iff rt synthetic_div_correct' zero_neq_one)
    from Suc(1)[OF this] obtain as where q: "[:coeff q (degree q):] * (\<Prod>a\<leftarrow>as. [:- a, 1:]) = q"
      and deg: "length as = degree q" by auto
    have dc: "degree p = degree q + degree [: -c, 1 :]" unfolding dq dp by simp
    have cq: "coeff q (degree q) = coeff p (degree p)" unfolding dc unfolding p coeff_mult_degree_sum unfolding dq by simp
    show ?case using p[unfolded q[unfolded cq, symmetric]]
      by (intro exI[of _ "c # as"], auto simp: ac_simps, insert deg dc, auto)
  qed
qed

lemma rsquarefree_card_degree: assumes p0: "(p :: complex poly) \<noteq> 0"
  shows "rsquarefree p = (card {x. poly p x = 0} = degree p)"
proof -
  from fundamental_theorem_algebra_factorized[of p] obtain c as
    where p: "p = smult c (\<Prod> a \<leftarrow> as. [:- a, 1:])" and pas: "degree p = length as"
    and c: "c = coeff p (degree p)" by metis
  let ?prod = "(\<Prod>a\<leftarrow>as. [:- a, 1:])"
  from p0 have c: "c \<noteq> 0" unfolding c by auto
  have roots: "{x. poly p x = 0} = set as" unfolding p poly_smult_zero_iff poly_prod_list prod_list_zero_iff
    using c by auto
  have idr: "(card {x. poly p x = 0} = degree p) = distinct as" unfolding roots pas
    using card_distinct distinct_card by blast
  have id: "\<And> q. (p \<noteq> 0 \<and> q) = q" using p0 by simp
  have dist: "distinct as = (\<forall>a. (\<Sum>x\<leftarrow>as. if x = a then 1 else 0) \<le> Suc 0)" (is "?l = (\<forall> a. ?r a)")
  proof (cases "distinct as")
    case False
    from not_distinct_decomp[OF this] obtain xs ys zs a where "as = xs @ [a] @ ys @ [a] @ zs" by auto
    hence "\<not> ?r a" by auto
    thus ?thesis using False by auto
  next
    case True
    {
      fix a
      from True have "?r a"
      proof (induct as)
        case (Cons b bs)
        show ?case
        proof (cases "a = b")
          case False
          with Cons show ?thesis by auto
        next
          case True
          with Cons(2) have "a \<notin> set bs" by auto
          hence "(\<Sum>x\<leftarrow> bs. if x = a then 1 else 0) = (0 :: nat)" by (induct bs, auto)
          thus ?thesis unfolding True by auto
        qed
      qed simp
    }
    thus ?thesis using True by auto
  qed
  have "rsquarefree p = distinct as" unfolding rsquarefree_def' id unfolding p order_smult[OF c]
    by (subst order_prod_list, auto simp: o_def order_linear' dist)
  thus ?thesis unfolding idr by simp
qed

end


theory Homework5_1sol
imports Main
begin

  (*
    ISSUED: Wednesday, October 18
    DUE: Wednesday, October 25, 11:59pm
    POINTS: 5
  *)

  (*
    Recall the LTS formalization from the tutorial.
    I copied the important parts here:
  *)

section \<open>Parts of LTS from Tutorial\<close>
type_synonym ('q,'a) lts = "'q \<Rightarrow> 'a \<Rightarrow> 'q \<Rightarrow> bool"

inductive word :: "('q,'a) lts \<Rightarrow> 'q \<Rightarrow> 'a list \<Rightarrow> 'q \<Rightarrow> bool"
  where
    empty: "word L q [] q"
  | cons: "\<lbrakk> L p a q; word L q as r \<rbrakk> \<Longrightarrow> word L p (a#as) r"

lemma word_Nil_conv: "word L p [] q \<longleftrightarrow> p=q"
  by (auto elim: word.cases intro: word.intros)

lemma word_Cons_conv: "word L p (a#bs) r \<longleftrightarrow> (\<exists>q. L p a q \<and> word L q bs r)"
  by (auto elim: word.cases intro: word.intros)

lemma word_append_conv: "word L p (as@bs) r \<longleftrightarrow> (\<exists>q. word L p as q \<and> word L q bs r)"
  (* Slightly changed proof compared to tutorial *)
  by (induction as arbitrary: p) (auto simp: word_Nil_conv word_Cons_conv)

section \<open>Product Construction\<close>
(* Here starts the homework assignment *)

(*
  For a labeled transition system, we define the language
  from state p to state q as the set of all words from p to q.
*)
definition "lang L p q = {w. word L p w q}"

(*
  The product "prod L1 L2" of two labeled transition systems L1 :: ('p,'a) lts
  and L2 :: ('q,'a) lts is a labeled transition system over states of
  type 'p\<times>'q. We define (prod L1 L2) (p1,q1) a (p2,q2) iff
  L1 p1 a p2 and L2 q1 a q2.
*)
definition L_prod :: "('p,'a) lts \<Rightarrow> ('q,'a) lts \<Rightarrow> ('p\<times>'q,'a) lts" where
  "L_prod L1 L2 \<equiv> \<lambda>(p1,p2) l (q1,q2). L1 p1 l q1 \<and> L2 p2 l q2"

(*
  Intuitively, a transition of the product corresponds to a transition
  of both components, with the same label.
*)

(*
  Show that the language of the product LTS corresponds to the
  intersection of the languages of the component LTSs.

  Proof sketch:
    assume we have a word w in the product language.
    hence, we have "word (L_prod L1 L2) (p1, p2) w (q1, q2)"
    by induction on w, we get word L1 p1 w q1 and word L2 p2 w q2
    from which, by definition of lang, we get the proposition.

    the proof of the other direction is symmetric.

  Use an Isar proof! Note: There is no notion of "symmetric" in Isar, so
    you will have to actually prove both directions.

  Hint: In the induction proofs, use the structural equations
     word_Cons_conv word_Nil_conv as simp rules, rather than
     the word.intros and word.cases rules.
     Don't forget to generalize over some variables!

*)

  lemma "lang (L_prod L1 L2) (p1,p2) (q1,q2) = (lang L1 p1 q1 \<inter> lang L2 p2 q2)"
  proof (intro equalityI subsetI)
    fix w
    assume "w \<in> lang (L_prod L1 L2) (p1, p2) (q1, q2)"
    hence "word (L_prod L1 L2) (p1, p2) w (q1, q2)" by (auto simp: lang_def)
    hence "word L1 p1 w q1 \<and> word L2 p2 w q2"
      by (induction w arbitrary: p1 p2) (auto simp: word_Cons_conv word_Nil_conv L_prod_def)
    thus "w \<in> lang L1 p1 q1 \<inter> lang L2 p2 q2"
      by (auto simp: lang_def)
  next
    fix w
    assume "w \<in> lang L1 p1 q1 \<inter> lang L2 p2 q2"
    hence "word L1 p1 w q1" "word L2 p2 w q2" by (auto simp: lang_def)
    hence "word (L_prod L1 L2) (p1, p2) w (q1, q2)"
      by (induction w arbitrary: p1 p2) (auto simp: word_Cons_conv word_Nil_conv L_prod_def)
    thus "w \<in> lang (L_prod L1 L2) (p1, p2) (q1, q2)" by (auto simp: lang_def)
  qed

end


theory AExp
imports Main
begin

subsection "Arithmetic Expressions"

type_synonym vname = string
type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

text_raw{*\snip{AExpaexpdef}{2}{1}{% *}
datatype aexp = N int | V vname | Plus aexp aexp
text_raw{*}%endsnip*}

text_raw{*\snip{AExpavaldef}{1}{2}{% *}
fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N n) s = n" |
"aval (V x) s = s x" |
"aval (Plus a\<^sub>1 a\<^sub>2) s = aval a\<^sub>1 s + aval a\<^sub>2 s"
text_raw{*}%endsnip*}

value "aval (Plus (V ''x'') (N 5)) (\<lambda>x. if x = ''x'' then 7 else 0)"

text {* The same state more concisely: *}
value "aval (Plus (V ''x'') (N 5)) ((\<lambda>x. 0) (''x'':= 7))"

text {* A little syntax magic to write larger states compactly: *}

definition null_state ("<>") where
  "null_state \<equiv> \<lambda>x. 0"
syntax
  "_State" :: "updbinds => 'a" ("<_>")
translations
  "_State ms" == "_Update <> ms"
  "_State (_updbinds b bs)" <= "_Update (_State b) bs"

text {* \noindent
  We can now write a series of updates to the function @{text "\<lambda>x. 0"} compactly:
*}
lemma "<a := 1, b := 2> = (<> (a := 1)) (b := (2::int))"
  by (rule refl)

value "aval (Plus (V ''x'') (N 5)) <''x'' := 7>"

text {* In  the @{term[source] "<a := b>"} syntax, variables that are not mentioned are 0 by default:
*}
value "aval (Plus (V ''x'') (N 5)) <''y'' := 7>"

text{* Note that this @{text"<\<dots>>"} syntax works for any function space
@{text"\<tau>\<^sub>1 \<Rightarrow> \<tau>\<^sub>2"} where @{text "\<tau>\<^sub>2"} has a @{text 0}. *}

subsection "Constant Folding"

text{* Evaluate constant subsexpressions: *}

text_raw{*\snip{AExpasimpconstdef}{0}{2}{% *}
fun asimp_const :: "aexp \<Rightarrow> aexp" where
"asimp_const (N n) = N n" |
"asimp_const (V x) = V x" |
"asimp_const (Plus a\<^sub>1 a\<^sub>2) =
  (case (asimp_const a\<^sub>1, asimp_const a\<^sub>2) of
    (N n\<^sub>1, N n\<^sub>2) \<Rightarrow> N(n\<^sub>1+n\<^sub>2) |
    (b\<^sub>1,b\<^sub>2) \<Rightarrow> Plus b\<^sub>1 b\<^sub>2)"
text_raw{*}%endsnip*}

theorem aval_asimp_const:
  "aval (asimp_const a) s = aval a s"
apply(induction a)
apply (auto split: aexp.split)
done

text{* Now we also eliminate all occurrences 0 in additions. The standard
method: optimized versions of the constructors: *}

text_raw{*\snip{AExpplusdef}{0}{2}{% *}
fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"plus (N i\<^sub>1) (N i\<^sub>2) = N(i\<^sub>1+i\<^sub>2)" |
"plus (N i) a = (if i=0 then a else Plus (N i) a)" |
"plus a (N i) = (if i=0 then a else Plus a (N i))" |
"plus a\<^sub>1 a\<^sub>2 = Plus a\<^sub>1 a\<^sub>2"
text_raw{*}%endsnip*}

lemma aval_plus[simp]:
  "aval (plus a1 a2) s = aval a1 s + aval a2 s"
apply(induction a1 a2 rule: plus.induct)
apply simp_all (* just for a change from auto *)
done

text_raw{*\snip{AExpasimpdef}{2}{0}{% *}
fun asimp :: "aexp \<Rightarrow> aexp" where
"asimp (N n) = N n" |
"asimp (V x) = V x" |
"asimp (Plus a\<^sub>1 a\<^sub>2) = plus (asimp a\<^sub>1) (asimp a\<^sub>2)"
text_raw{*}%endsnip*}

text{* Note that in @{const asimp_const} the optimized constructor was
inlined. Making it a separate function @{const plus} improves modularity of
the code and the proofs. *}

value "asimp (Plus (Plus (N 0) (N 0)) (Plus (V ''x'') (N 0)))"

theorem aval_asimp[simp]:
  "aval (asimp a) s = aval a s"
apply(induction a)
apply simp_all
done

end