(*  Title:       EpiMonoIso
    Author:      Eugene W. Stark <stark@cs.stonybrook.edu>, 2016
    Maintainer:  Eugene W. Stark <stark@cs.stonybrook.edu>
*)

chapter EpiMonoIso

theory EpiMonoIso
imports Category
begin

  text\<open>
    This theory defines and develops properties of epimorphisms, monomorphisms,
    isomorphisms, sections, and retractions.
\<close>

  context category
  begin

     definition epi
     where "epi f = (arr f \<and> inj_on (\<lambda>g. g \<cdot> f) {g. seq g f})"

     definition mono
     where "mono f = (arr f \<and> inj_on (\<lambda>g. f \<cdot> g) {g. seq f g})"

     lemma epiI [intro]:
     assumes "arr f" and "\<And>g g'. seq g f \<and> seq g' f \<and> g \<cdot> f = g' \<cdot> f \<Longrightarrow> g = g'"
     shows "epi f"
       using assms epi_def inj_on_def by blast

     lemma epi_implies_arr:
     assumes "epi f"
     shows "arr f"
       using assms epi_def by auto

     lemma epiE [elim]:
     assumes "epi f"
     and "seq g f" and "seq g' f" and "g \<cdot> f = g' \<cdot> f"
     shows "g = g'"
       using assms unfolding epi_def inj_on_def by blast

     lemma monoI [intro]:
     assumes "arr g" and "\<And>f f'. seq g f \<and> seq g f' \<and> g \<cdot> f = g \<cdot> f' \<Longrightarrow> f = f'"
     shows "mono g"
       using assms mono_def inj_on_def by blast

     lemma mono_implies_arr:
     assumes "mono f"
     shows "arr f"
       using assms mono_def by auto

     lemma monoE [elim]:
     assumes "mono g"
     and "seq g f" and "seq g f'" and "g \<cdot> f = g \<cdot> f'"
     shows "f' = f"
       using assms unfolding mono_def inj_on_def by blast

     definition inverse_arrows
     where "inverse_arrows f g \<equiv> ide (g \<cdot> f) \<and> ide (f \<cdot> g)"

     lemma inverse_arrowsI [intro]:
     assumes "ide (g \<cdot> f)" and "ide (f \<cdot> g)"
     shows "inverse_arrows f g"
       using assms inverse_arrows_def by blast

     lemma inverse_arrowsE [elim]:
     assumes "inverse_arrows f g"
     and "\<lbrakk> ide (g \<cdot> f); ide (f \<cdot> g) \<rbrakk> \<Longrightarrow> T"
     shows "T"
       using assms inverse_arrows_def by blast

     lemma inverse_arrows_sym:
       shows "inverse_arrows f g \<longleftrightarrow> inverse_arrows g f"
       using inverse_arrows_def by auto

     lemma ide_self_inverse:
     assumes "ide a"
     shows "inverse_arrows a a"
       using assms by auto

     lemma inverse_arrow_unique:
     assumes "inverse_arrows f g" and "inverse_arrows f g'"
     shows "g = g'"
       using assms apply (elim inverse_arrowsE)
       by (metis comp_cod_arr ide_compE comp_assoc seqE)

     lemma inverse_arrows_compose:
     assumes "seq g f" and "inverse_arrows f f'" and "inverse_arrows g g'"
     shows "inverse_arrows (g \<cdot> f) (f' \<cdot> g')"
       using assms apply (elim inverse_arrowsE, intro inverse_arrowsI)
        apply (metis seqE comp_arr_dom ide_compE comp_assoc)
       by (metis seqE comp_arr_dom ide_compE comp_assoc)

     definition "section"
     where "section f \<equiv> \<exists>g. ide (g \<cdot> f)"

     lemma sectionI [intro]:
     assumes "ide (g \<cdot> f)"
     shows "section f"
       using assms section_def by auto

     lemma sectionE [elim]:
     assumes "section f"
     obtains g where "ide (g \<cdot> f)"
       using assms section_def by blast

     definition retraction
     where "retraction g \<equiv> \<exists>f. ide (g \<cdot> f)"

     lemma retractionI [intro]:
     assumes "ide (g \<cdot> f)"
     shows "retraction g"
       using assms retraction_def by auto

     lemma retractionE [elim]:
     assumes "retraction g"
     obtains f where "ide (g \<cdot> f)"
       using assms retraction_def by blast

     lemma section_is_mono:
     assumes "section g"
     shows "mono g"
     proof
       show "arr g" using assms section_def by blast
       from assms obtain h where h: "ide (h \<cdot> g)" by blast
       have hg: "seq h g" using h by auto
       fix f f'
       assume "seq g f \<and> seq g f' \<and> g \<cdot> f = g \<cdot> f'"
       thus "f = f'"
         using hg h ide_compE seqE comp_assoc comp_cod_arr by metis
     qed

     lemma retraction_is_epi:
     assumes "retraction g"
     shows "epi g"
     proof
       show "arr g" using assms retraction_def by blast
       from assms obtain f where f: "ide (g \<cdot> f)" by blast
       have gf: "seq g f" using f by auto
       fix h h'
       assume "seq h g \<and> seq h' g \<and> h \<cdot> g = h' \<cdot> g"
       thus "h = h'"
         using gf f ide_compE seqE comp_assoc comp_arr_dom by metis
     qed

     lemma section_retraction_compose:
     assumes "ide (e \<cdot> m)" and "ide (e' \<cdot> m')" and "seq m' m"
     shows "ide ((e \<cdot> e') \<cdot> (m' \<cdot> m))"
       using assms seqI seqE ide_compE comp_assoc comp_arr_dom by metis

     lemma retractions_compose [intro]:
     assumes "retraction e" and "retraction e'" and "seq e' e"
     shows "retraction (e' \<cdot> e)"
     proof -
       from assms(1-2) obtain m m'
       where *: "ide (e \<cdot> m) \<and> ide (e' \<cdot> m')"
         using retraction_def by auto
       hence "seq m m'"
         using assms(3) by (metis seqE seqI ide_compE)
       with * show ?thesis
         using section_retraction_compose retractionI by blast
     qed

     lemma monos_compose [intro]:
     assumes "mono m" and "mono m'" and "seq m' m"
     shows "mono (m' \<cdot> m)"
     proof -
       have "inj_on (\<lambda>f. (m' \<cdot> m) \<cdot> f) {f. seq (m' \<cdot> m) f}"
         unfolding inj_on_def
         using assms
         by (metis CollectD seqE monoE comp_assoc)
       thus ?thesis using assms(3) mono_def by force
     qed

     lemma epis_compose [intro]:
     assumes "epi e" and "epi e'" and "seq e' e"
     shows "epi (e' \<cdot> e)"
     proof -
       have "inj_on (\<lambda>g. g \<cdot> (e' \<cdot> e)) {g. seq g (e' \<cdot> e)}"
         unfolding inj_on_def
         using assms by (metis CollectD epiE match_2 comp_assoc)
       thus ?thesis using assms(3) epi_def by force
     qed

     definition iso
     where "iso f \<equiv> \<exists>g. inverse_arrows f g"

     lemma isoI [intro]:
     assumes "inverse_arrows f g"
     shows "iso f"
       using assms iso_def by auto

     lemma isoE [elim]:
     assumes "iso f"
     obtains g where "inverse_arrows f g"
       using assms iso_def by blast

     lemma ide_is_iso [simp]:
     assumes "ide a"
     shows "iso a"
       using assms ide_self_inverse by auto

     lemma iso_is_arr:
     assumes "iso f"
     shows "arr f"
       using assms by blast

     lemma iso_is_section:
     assumes "iso f"
     shows "section f"
       using assms inverse_arrows_def by blast

     lemma iso_is_retraction:
     assumes "iso f"
     shows "retraction f"
       using assms inverse_arrows_def by blast

    lemma iso_iff_mono_and_retraction:
    shows "iso f \<longleftrightarrow> mono f \<and> retraction f"
    proof
      show "iso f \<Longrightarrow> mono f \<and> retraction f"
        by (simp add: iso_is_retraction iso_is_section section_is_mono)
      show "mono f \<and> retraction f \<Longrightarrow> iso f"
      proof -
        assume f: "mono f \<and> retraction f"
        from f obtain g where g: "ide (f \<cdot> g)" by blast
        have "inverse_arrows f g"
          using f g comp_arr_dom comp_cod_arr comp_assoc inverse_arrowsI
          by (metis ide_char' ide_compE monoE mono_implies_arr)
        thus "iso f" by auto
      qed
    qed

    lemma iso_iff_section_and_epi:
    shows "iso f \<longleftrightarrow> section f \<and> epi f"
    proof
      show "iso f \<Longrightarrow> section f \<and> epi f"
        by (simp add: iso_is_retraction iso_is_section retraction_is_epi)
      show "section f \<and> epi f \<Longrightarrow> iso f"
      proof -
        assume f: "section f \<and> epi f"
        from f obtain g where g: "ide (g \<cdot> f)" by blast
        have "inverse_arrows f g"
          using f g comp_arr_dom comp_cod_arr epi_implies_arr
                comp_assoc ide_compE inverse_arrowsI epiE ide_char'
          by metis
        thus "iso f" by auto
      qed
    qed

    lemma iso_iff_section_and_retraction:
    shows "iso f \<longleftrightarrow> section f \<and> retraction f"
      using iso_is_retraction iso_is_section iso_iff_mono_and_retraction section_is_mono
      by auto

    lemma isos_compose [intro]:
    assumes "iso f" and "iso f'" and "seq f' f"
    shows "iso (f' \<cdot> f)"
    proof -
      from assms(1) obtain g where g: "inverse_arrows f g" by blast
      from assms(2) obtain g' where g': "inverse_arrows f' g'" by blast
      have "inverse_arrows (f' \<cdot> f) (g \<cdot> g')"
        using assms g g inverse_arrowsI inverse_arrowsE section_retraction_compose
        by (simp add: g' inverse_arrows_compose)
      thus ?thesis using iso_def by auto
    qed

    definition isomorphic
    where "isomorphic a a' = (\<exists>f. \<guillemotleft>f : a \<rightarrow> a'\<guillemotright> \<and> iso f)"

    lemma isomorphicI [intro]:
    assumes "iso f"
    shows "isomorphic (dom f) (cod f)"
      using assms isomorphic_def iso_is_arr by blast

    lemma isomorphicE [elim]:
    assumes "isomorphic a a'"
    obtains f where "\<guillemotleft>f : a \<rightarrow> a'\<guillemotright> \<and> iso f"
      using assms isomorphic_def by meson

    definition inv
    where "inv f = (SOME g. inverse_arrows f g)"

    lemma inv_is_inverse:
    assumes "iso f"
    shows "inverse_arrows f (inv f)"
      using assms inv_def someI [of "inverse_arrows f"] by auto

    lemma iso_inv_iso:
    assumes "iso f"
    shows "iso (inv f)"
      using assms inv_is_inverse inverse_arrows_sym by blast

    lemma inverse_unique:
    assumes "inverse_arrows f g"
    shows "inv f = g"
      using assms inv_is_inverse inverse_arrow_unique isoI by auto

    lemma inv_ide [simp]:
    assumes "ide a"
    shows "inv a = a"
      using assms by (simp add: inverse_arrowsI inverse_unique)

    lemma inv_inv [simp]:
    assumes "iso f"
    shows "inv (inv f) = f"
      using assms inverse_arrows_sym inverse_unique by blast

    lemma comp_arr_inv:
    assumes "inverse_arrows f g"
    shows "f \<cdot> g = dom g"
      using assms by auto

    lemma comp_inv_arr:
    assumes "inverse_arrows f g"
    shows "g \<cdot> f = dom f"
      using assms by auto

    lemma comp_arr_inv':
    assumes "iso f"
    shows "f \<cdot> inv f = cod f"
      using assms inv_is_inverse by blast

    lemma comp_inv_arr':
    assumes "iso f"
    shows "inv f \<cdot> f = dom f"
      using assms inv_is_inverse by blast

    lemma inv_in_hom [simp]:
    assumes "iso f" and "\<guillemotleft>f : a \<rightarrow> b\<guillemotright>"
    shows "\<guillemotleft>inv f : b \<rightarrow> a\<guillemotright>"
      using assms inv_is_inverse seqE inverse_arrowsE
      by (metis ide_compE in_homE in_homI)

    lemma arr_inv [simp]:
    assumes "iso f"
    shows "arr (inv f)"
      using assms inv_in_hom by blast

    lemma dom_inv [simp]:
    assumes "iso f"
    shows "dom (inv f) = cod f"
      using assms inv_in_hom by blast

    lemma cod_inv [simp]:
    assumes "iso f"
    shows "cod (inv f) = dom f"
      using assms inv_in_hom by blast

    lemma inv_comp:
    assumes "iso f" and "iso g" and "seq g f"
    shows "inv (g \<cdot> f) = inv f \<cdot> inv g"
      using assms inv_is_inverse inverse_unique inverse_arrows_compose inverse_arrows_def
      by meson

    lemma isomorphic_reflexive:
    assumes "ide f"
    shows "isomorphic f f"
      unfolding isomorphic_def
      using assms ide_is_iso ide_in_hom by blast

    lemma isomorphic_symmetric:
    assumes "isomorphic f g"
    shows "isomorphic g f"
      using assms iso_inv_iso inv_in_hom by blast

    lemma isomorphic_transitive [trans]:
    assumes "isomorphic f g" and "isomorphic g h"
    shows "isomorphic f h"
      using assms isomorphic_def isos_compose by auto

    text \<open>
      A section or retraction of an isomorphism is in fact an inverse.
\<close>

    lemma section_retraction_of_iso:
    assumes "iso f"
    shows "ide (g \<cdot> f) \<Longrightarrow> inverse_arrows f g"
    and "ide (f \<cdot> g) \<Longrightarrow> inverse_arrows f g"
    proof -
      show "ide (g \<cdot> f) \<Longrightarrow> inverse_arrows f g"
        using assms
        by (metis comp_inv_arr' epiE ide_compE inv_is_inverse iso_iff_section_and_epi)
      show "ide (f \<cdot> g) \<Longrightarrow> inverse_arrows f g"
        using assms
        by (metis ide_compE comp_arr_inv' inv_is_inverse iso_iff_mono_and_retraction monoE)
    qed

    text \<open>
      A situation that occurs frequently is that we have a commuting triangle,
      but we need the triangle obtained by inverting one side that is an isomorphism.
      The following fact streamlines this derivation.
\<close>

    lemma invert_side_of_triangle:
    assumes "arr h" and "f \<cdot> g = h"
    shows "iso f \<Longrightarrow> seq (inv f) h \<and> g = inv f \<cdot> h"
    and "iso g \<Longrightarrow> seq h (inv g) \<and> f = h \<cdot> inv g"
    proof -
      show "iso f \<Longrightarrow> seq (inv f) h \<and> g = inv f \<cdot> h"
        by (metis assms seqE inv_is_inverse comp_cod_arr comp_inv_arr comp_assoc)
      show "iso g \<Longrightarrow> seq h (inv g) \<and> f = h \<cdot> inv g"
        by (metis assms seqE inv_is_inverse comp_arr_dom comp_arr_inv dom_inv comp_assoc)
    qed

    text \<open>
      A similar situation is where we have a commuting square and we want to
      invert two opposite sides.
\<close>

    lemma invert_opposite_sides_of_square:
    assumes "seq f g" and "f \<cdot> g = h \<cdot> k"
    shows "\<lbrakk> iso f; iso k \<rbrakk> \<Longrightarrow> seq g (inv k) \<and> seq (inv f) h \<and> g \<cdot> inv k = inv f \<cdot> h"
      by (metis assms invert_side_of_triangle comp_assoc)

  end

end


(*
  File: Set.thy
  Author: Bohua Zhan

  Basic axioms and constructions in set theory. The initial choices made in
  set theory largely follow that in Isabelle/ZF.
*)

theory Set
  imports Logic_FOL
begin

section \<open>Axiom of extension\<close>

axiomatization where
  extension: "\<forall>z. z \<in> x \<longleftrightarrow> z \<in> y \<Longrightarrow> x = y"
setup {* add_backward_prfstep_cond @{thm extension} [with_score 500] *}

section \<open>Axiom of empty set\<close>

axiomatization Empty_set :: "i"  ("\<emptyset>") where
  empty_set [resolve]: "x \<notin> \<emptyset>"

lemma nonempty_mem [backward]: "A \<noteq> \<emptyset> \<Longrightarrow> \<exists>x. x \<in> A" by auto2

section \<open>Axiom schema of specification\<close>

axiomatization Collect :: "[i, i \<Rightarrow> o] \<Rightarrow> i" where
  collect [rewrite]: "x \<in> Collect(A,P) \<longleftrightarrow> (x \<in> A \<and> P(x))"

syntax
  "_Collect" :: "[pttrn, i, o] \<Rightarrow> i"  ("(1{_ \<in> _ ./ _})")
translations
  "{x\<in>A. P}" \<rightleftharpoons> "CONST Collect(A, \<lambda>x. P)"

section \<open>Axiom of pairing\<close>

axiomatization Upair :: "[i, i] \<Rightarrow> i" where
  upair [rewrite]: "x \<in> Upair(y,z) \<longleftrightarrow> (x = y \<or> x = z)"

lemma Upair_nonempty [resolve]: "Upair(a,b) \<noteq> \<emptyset>"
@proof @have "a \<in> Upair(a,b)" @qed

section \<open>Axiom of union\<close>

axiomatization Union :: "i \<Rightarrow> i"  ("\<Union>_" [90] 90) where
  union [rewrite]: "x \<in> \<Union>C \<longleftrightarrow> (\<exists>A\<in>C. x\<in>A)"

section \<open>Subset, and standard properties\<close>

definition subset :: "i \<Rightarrow> i \<Rightarrow> o"  (infixl "\<subseteq>" 50) where [rewrite]:
  "A \<subseteq> B \<longleftrightarrow> (\<forall>x\<in>A. x\<in>B)"

lemma subset_refl [resolve]: "A \<subseteq> A" by auto2
lemma subsetD [forward]: "A \<subseteq> B \<Longrightarrow> c \<in> A \<Longrightarrow> c \<in> B" by auto2
lemma subsetI [forward]: "\<forall>x\<in>A. x \<in> B \<Longrightarrow> A \<subseteq> B" by auto2
setup {* add_backward_prfstep_cond @{thm subsetI} [with_score 500] *}
setup {* del_prfstep_thm @{thm subset_def} *}

lemma subset_trans [forward,backward1,backward2]:
  "A \<subseteq> B \<Longrightarrow> B \<subseteq> C \<Longrightarrow> A \<subseteq> C" by auto2
lemma extension_subset [forward,backward1,backward2]:
  "A \<subseteq> B \<Longrightarrow> B \<subseteq> A \<Longrightarrow> A = B" by auto2
lemma subset_nonempty [forward,backward2]:
  "A \<subseteq> B \<Longrightarrow> A \<noteq> \<emptyset> \<Longrightarrow> B \<noteq> \<emptyset>" by auto2

section \<open>Axiom of power set\<close>

axiomatization Pow :: "i \<Rightarrow> i" where
  power [rewrite]: "x \<in> Pow(S) \<longleftrightarrow> x \<subseteq> S"

lemma PowI [typing2]: "x \<subseteq> S \<Longrightarrow> x \<in> Pow(S)" by auto2

(* Cantor's theorem *)
lemma cantor: "\<exists>S \<in> Pow(A). \<forall>x\<in>A. b(x) \<noteq> S"
@proof
  @let "S = {x \<in> A. x \<notin> b(x)}"
  @have "\<forall>x\<in>A. b(x) \<noteq> S" @with @case "x \<in> b(x)" @end
@qed

section \<open>General intersection\<close>

definition Inter :: "i \<Rightarrow> i"  ("\<Inter>_" [90] 90) where [rewrite]:
  "\<Inter>(A) = { x \<in> \<Union>(A). \<forall>y\<in>A. x\<in>y}"
setup {* register_wellform_data ("\<Inter>(A)", ["A \<noteq> \<emptyset>"]) *}
setup {* add_prfstep_check_req ("\<Inter>(A)", "A \<noteq> \<emptyset>") *}

(* Inter really makes sense only if A \<noteq> \<emptyset>*)
lemma Inter_iff [rewrite]:
  "A \<noteq> \<emptyset> \<Longrightarrow> x \<in> \<Inter>(A) \<longleftrightarrow> (\<forall>y\<in>A. x\<in>y)" by auto2
setup {* del_prfstep_thm @{thm Inter_def} *}

section \<open>Binary union and intersection, subtraction on sets\<close>

definition Un :: "i \<Rightarrow> i \<Rightarrow> i"  (infixl "\<union>" 65) where [rewrite]:
  "A \<union> B = \<Union>(Upair(A,B))"

lemma Un_iff: "c \<in> A \<union> B \<longleftrightarrow> (c \<in> A \<or> c \<in> B)" by auto2
setup {* add_forward_prfstep_cond (equiv_forward_th @{thm Un_iff}) [with_score 500] *}
setup {* add_backward_prfstep (equiv_backward_th @{thm Un_iff}) *}
setup {* del_prfstep_thm @{thm Un_def} *}

lemma UnD1 [forward]: "c \<in> A \<union> B \<Longrightarrow> c \<notin> A \<Longrightarrow> c \<in> B" by auto2
lemma UnD2 [forward]: "c \<in> A \<union> B \<Longrightarrow> c \<notin> B \<Longrightarrow> c \<in> A" by auto2
lemma UnI1 [typing2]: "c \<in> A \<Longrightarrow> c \<in> A \<union> B" by auto2
lemma UnI2 [typing2]: "c \<in> B \<Longrightarrow> c \<in> A \<union> B" by auto2
lemma Un_empty [forward]: "A \<union> B = \<emptyset> \<Longrightarrow> A = \<emptyset>" by auto2
lemma Un_commute: "A \<union> B = B \<union> A" by auto2
lemma Un_assoc: "(A \<union> B) \<union> C = A \<union> (B \<union> C)" by auto2
lemma Un_least [backward]: "A \<subseteq> D \<Longrightarrow> B \<subseteq> D \<Longrightarrow> A \<union> B \<subseteq> D" by auto2

definition Int :: "i \<Rightarrow> i \<Rightarrow> i"  (infixl "\<inter>" 70) where [rewrite]:
  "A \<inter> B = \<Inter>(Upair(A,B))"

lemma Int_iff [rewrite]: "c \<in> A \<inter> B \<longleftrightarrow> (c \<in> A \<and> c \<in> B)" by auto2
setup {* del_prfstep_thm @{thm Int_def} *}
lemma Int_commute: "A \<inter> B = B \<inter> A" by auto2
lemma Int_assoc: "(A \<inter> B) \<inter> C = A \<inter> (B \<inter> C)" by auto2
lemma Int_id [rewrite]: "A \<inter> A = A" by auto2
lemma Int_lower1 [resolve]: "A \<inter> B \<subseteq> A" by auto2
lemma Int_lower2 [resolve]: "A \<inter> B \<subseteq> B" by auto2
lemma Int_subset1 [rewrite]: "A \<subseteq> B \<Longrightarrow> A \<inter> B = A" by auto2
lemma Int_subset2 [rewrite]: "A \<subseteq> B \<Longrightarrow> B \<inter> A = A" by auto2

definition Diff :: "i \<Rightarrow> i \<Rightarrow> i"  (infixl "\<midarrow>" 65) where Diff_def[rewrite]:
  "A \<midarrow> B = {x \<in> A. x \<notin> B}"
lemma Diff_iff [rewrite]: "c \<in> A \<midarrow> B \<longleftrightarrow> (c \<in> A \<and> c \<notin> B)" by auto2
setup {* del_prfstep_thm @{thm Diff_def} *}

lemma diff_subset [resolve]: "A \<midarrow> B \<subseteq> A" by auto2

lemma diff_empty [forward]: "A \<midarrow> B = \<emptyset> \<Longrightarrow> A \<subseteq> B"
@proof
  @have "\<forall>x\<in>A. x \<in> B" @with
    @contradiction @have "x \<in> A \<midarrow> B"
  @end
@qed

lemma diff_double [rewrite]: "B \<subseteq> A \<Longrightarrow> A \<midarrow> (A \<midarrow> B) = B" by auto2

lemma compl_eq: "E\<midarrow>A = E\<midarrow>B \<Longrightarrow> A \<subseteq> E \<Longrightarrow> B \<subseteq> E \<Longrightarrow> A = B"
@proof
  @have "\<forall>x. x \<in> A \<longleftrightarrow> x \<in> B" @with
    @case "x \<in> A" @with @have "x \<notin> E\<midarrow>A" @end
    @case "x \<in> B" @with @have "x \<notin> E\<midarrow>B" @end
  @end
@qed
setup {* add_forward_prfstep_cond @{thm compl_eq}
  [with_cond "?A \<noteq> ?B", with_filt (order_filter "A" "B")] *}

lemma inter_compl1 [rewrite]: "(X \<midarrow> A) \<inter> A = \<emptyset>" by auto2
lemma inter_compl2 [rewrite]: "A \<inter> (X \<midarrow> A) = \<emptyset>" by auto2
lemma union_compl1 [rewrite]: "A \<subseteq> X \<Longrightarrow> A \<union> (X \<midarrow> A) = X" by auto2
lemma union_compl2 [rewrite]: "A \<subseteq> X \<Longrightarrow> (X \<midarrow> A) \<union> A = X" by auto2
lemma Int_empty1 [forward]: "A \<inter> B = \<emptyset> \<Longrightarrow> x \<in> A \<Longrightarrow> x \<notin> B"
  @proof @contradiction @have "x \<in> A \<inter> B" @qed
lemma Int_empty2 [forward]: "A \<inter> B = \<emptyset> \<Longrightarrow> x \<in> B \<Longrightarrow> x \<notin> A" by auto2
lemma Int_diff_union [rewrite]: "(X \<inter> Y) \<union> (X \<midarrow> Y) = X" by auto2
lemma Int_diff_Int [rewrite]: "(X \<inter> Y) \<inter> (X \<midarrow> Y) = \<emptyset>" by auto2

section \<open>Strict subsets\<close>

definition strict_subset :: "i \<Rightarrow> i \<Rightarrow> o" (infixl "\<subset>" 50) where [rewrite]:
  "A \<subset> B \<longleftrightarrow> (A \<subseteq> B \<and> A \<noteq> B)"

section \<open>Cons, notation for finite sets\<close>

definition cons :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "cons(a, A) = Upair(a,a) \<union> A"

nonterminal "is"
syntax
  "" :: "i \<Rightarrow> is"  ("_")
  "_Enum" :: "[i, is] \<Rightarrow> is"  ("_,/ _")
  "_Finset" :: "is \<Rightarrow> i"  ("{(_)}")
translations
  "{x, xs}" == "CONST cons(x, {xs})"
  "{x}" == "CONST cons(x, \<emptyset>)"

lemma cons_iff: "a \<in> cons(b, A) \<longleftrightarrow> (a = b \<or> a \<in> A)" by auto2
setup {* add_rewrite_rule_cond @{thm cons_iff}
  [with_cond "?a \<noteq> ?b", with_cond "?A \<noteq> \<emptyset>"] *}
lemma mem_singleton [rewrite]: "a \<in> {b} \<longleftrightarrow> a = b" by auto2
lemma not_mem_singleton: "a \<noteq> b \<Longrightarrow> a \<notin> {b}" by auto2
setup {* add_forward_prfstep_cond @{thm not_mem_singleton} [with_term "{?b}"] *}
theorem mem_cons [typing2]: "a \<in> cons(a,S)" by auto2
setup {* del_prfstep_thm @{thm cons_def} *}

theorem subset_cons: "S \<subseteq> cons(a,S)" by auto2
setup {* add_forward_prfstep_cond @{thm subset_cons}
  [with_term "cons(?a,?S)", with_cond "?S \<noteq> \<emptyset>", with_cond "?S \<noteq> {?b}"] *}

theorem mem_cons2 [typing2]: "b \<in> {a,b}" by auto2

lemma Union_singleton [rewrite]: "\<Union>{a} = a" by auto2
lemma singleton_subset [backward]: "x \<in> X \<Longrightarrow> {x} \<subseteq> X" by auto2
lemma diff_singleton_not_mem [rewrite]: "a \<notin> X \<Longrightarrow> X \<midarrow> {a} = X" by auto2
lemma singleton_eq_iff [forward]: "{a} = {b} \<Longrightarrow> a = b" by auto2
lemma cons_nonempty [resolve]: "cons(a, b) \<noteq> \<emptyset>" by auto2
lemma sub_singleton_empty [forward]: "X \<noteq> \<emptyset> \<Longrightarrow> X \<subseteq> {a} \<Longrightarrow> X = {a}" by auto2
lemma cons_mem [rewrite]: "a \<in> X \<Longrightarrow> cons(a,X) = X" by auto2
lemma cons_minus [rewrite]: "a \<notin> S \<Longrightarrow> cons(a,S) \<midarrow> {a} = S" by auto2

definition succ :: "i \<Rightarrow> i" where [rewrite]:
  "succ(i) = cons(i, i)"

section \<open>Axiom of replacement\<close>

axiomatization Replace :: "[i, i \<Rightarrow> i \<Rightarrow> o] \<Rightarrow> i" where replacement [rewrite]:
  "\<forall>x\<in>A. \<forall>y z. P(x,y) \<and> P(x,z) \<longrightarrow> y = z \<Longrightarrow> b \<in> Replace(A,P) \<longleftrightarrow> (\<exists>x\<in>A. P(x,b))"
setup {* add_prfstep_check_req ("Replace(A,P)", "\<forall>x\<in>A. \<forall>y z. P(x,y) \<and> P(x,z) \<longrightarrow> y = z") *}

section \<open>Definite description\<close>

definition The :: "(i \<Rightarrow> o) \<Rightarrow> i"  (binder "THE " 10) where [rewrite]:
  "(THE x. P(x)) = \<Union>(Replace({\<emptyset>}, \<lambda>x y. P(y)))"

(* When encountering THE x. P(x), first show \<exists>!x. P(x), then can conclude
   THE x. P(x) satisfies P. *)
setup {* add_prfstep_check_req ("THE x. P(x)", "\<exists>!x. P(x)") *}
lemma theI' [forward]: "\<exists>!x. P(x) \<Longrightarrow> P (THE x. P(x))"
  @proof @obtain "a" where "P(a)" @have "(THE x. P(x)) = a" @qed

(* When trying to show (THE x. P(x)) = a, there is an alternative,
   since because we already know term a satisfies predicate P. *)
lemma the_equality [backward]: "\<forall>y. P(y) \<longrightarrow> y = a \<Longrightarrow> P(a) \<Longrightarrow> (THE x. P(x)) = a" by auto2
setup {* del_prfstep_thm @{thm The_def} *}

section \<open>Ordered pairs\<close>

definition Pair :: "[i, i] \<Rightarrow> i" where [rewrite]:
  "Pair(a,b) = {{a}, {a,b}}"

definition fst :: "i \<Rightarrow> i" where [rewrite]:
  "fst(p) = (THE a. \<exists>b. p = Pair(a, b))"

definition snd :: "i \<Rightarrow> i" where [rewrite]:
  "snd(p) = (THE b. \<exists>a. p = Pair(a, b))"

(* For pattern-matching *)
definition split :: "[[i, i] \<Rightarrow> 'a, i] \<Rightarrow> 'a::{}" where
  "split(c) \<equiv> \<lambda>p. c(fst(p), snd(p))"
setup {* Normalizer.add_rewr_normalizer ("rewr_split", @{thm split_def}) *}

(* Patterns -- extends pre-defined type "pttrn" used in abstractions *)
nonterminal patterns
syntax
  "_pattern"  :: "patterns => pttrn"         ("\<langle>_\<rangle>")
  ""          :: "pttrn => patterns"         ("_")
  "_patterns" :: "[pttrn, patterns] => patterns"  ("_,/_")
  "_Tuple"    :: "[i, is] => i"              ("\<langle>(_,/ _)\<rangle>")
translations
  "\<langle>x, y, z\<rangle>"   == "\<langle>x, \<langle>y, z\<rangle>\<rangle>"
  "\<langle>x, y\<rangle>"      == "CONST Pair(x, y)"
  "\<lambda>\<langle>x,y,zs\<rangle>.b" == "CONST split(\<lambda>x \<langle>y,zs\<rangle>.b)"
  "\<lambda>\<langle>x,y\<rangle>.b"    == "CONST split(\<lambda>x y. b)"

lemma pair_eqD [forward]: "\<langle>a, b\<rangle> = \<langle>c, d\<rangle> \<Longrightarrow> a = c \<and> b = d" by auto2
lemma pair_eqI_fst [backward]: "a = c \<Longrightarrow> \<langle>a,b\<rangle> = \<langle>c,b\<rangle>" by auto2
lemma pair_eqI_snd [backward]: "b = d \<Longrightarrow> \<langle>a,b\<rangle> = \<langle>a,d\<rangle>" by auto2

setup {* del_prfstep_thm @{thm Pair_def} *}

lemma fst_conv [rewrite]: "fst(\<langle>a, b\<rangle>) = a" by auto2
setup {* del_prfstep_thm @{thm fst_def} *}

lemma snd_conv [rewrite]: "snd(\<langle>a, b\<rangle>) = b" by auto2
setup {* del_prfstep_thm @{thm snd_def} *}

section \<open>If expressions\<close>

definition If :: "[o, i, i] \<Rightarrow> i"  ("(if (_)/ then (_)/ else (_))" [10] 10)  where [rewrite]:
  "(if P then a else b) = (THE z. P \<and> z=a \<or> \<not>P \<and> z=b)"

lemma If_eval:
  "P \<Longrightarrow> (if P then a else b) = a"
  "\<not>P \<Longrightarrow> (if P then a else b) = b"
  "P \<Longrightarrow> (if \<not>P then a else b) = b" by auto2+
setup {* fold (fn th => add_rewrite_rule_cond th [with_score 1]) @{thms If_eval} *}
setup {* del_prfstep_thm @{thm If_def} *}

setup {* add_gen_prfstep ("case_intro",
  [WithTerm @{term_pat "if ?cond then ?yes else ?no"},
   CreateCase @{term_pat "?cond::o"}]) *}

definition Ifb :: "[o, o, o] \<Rightarrow> o"  ("(ifb (_)/ then (_)/ else (_))" [10] 10)  where [rewrite]:
  "(ifb P then a else b) \<longleftrightarrow> (P \<and> a) \<or> (\<not>P \<and> b)"

lemma Ifb_eval:
  "P \<Longrightarrow> (ifb P then a else b) \<longleftrightarrow> a"
  "\<not>P \<Longrightarrow> (ifb P then a else b) \<longleftrightarrow> b"
  "P \<Longrightarrow> (ifb \<not>P then a else b) \<longleftrightarrow> b" by auto2+
setup {* fold (fn th => add_rewrite_rule_cond th [with_score 1]) @{thms Ifb_eval} *}
setup {* del_prfstep_thm @{thm Ifb_def} *}

setup {* add_gen_prfstep ("case_intro_bool1",
  [WithFact @{term_pat "ifb ?cond then ?yes else ?no"},
   CreateCase @{term_pat "?cond::o"}]) *}

setup {* add_gen_prfstep ("case_intro_bool2",
  [WithGoal @{term_pat "ifb ?cond then ?yes else ?no"},
   CreateCase @{term_pat "?cond::o"}]) *}

section \<open>Functional form of replacement\<close>

definition RepFun :: "[i, i \<Rightarrow> i] \<Rightarrow> i" where [rewrite]:
  "RepFun(A,f) = Replace(A, \<lambda>x y. y = f(x))"

lemma RepFun_iff [rewrite]:
  "y \<in> RepFun(A,f) \<longleftrightarrow> (\<exists>x\<in>A. y = f(x))" by auto2
setup {* del_prfstep_thm @{thm RepFun_def} *}

syntax
  "_RepFun" :: "[i, pttrn, i] => i"  ("(1{_ ./ _ \<in> _})" [51,0,51])
translations
  "{b. x\<in>A}" \<rightleftharpoons> "CONST RepFun(A, \<lambda>x. b)"

lemma repfun_nonempty [backward]: "A \<noteq> \<emptyset> \<Longrightarrow> {b(x). x\<in>A} \<noteq> \<emptyset>"
  @proof @obtain "a \<in> A" @have "b(a) \<in> {b(x). x\<in>A}" @qed

section \<open>Parametrized union and intersection\<close>

definition UnionS :: "i \<Rightarrow> [i \<Rightarrow> i] \<Rightarrow> i" where [rewrite]:
  "UnionS(I,X) = \<Union>{X(a). a\<in>I}"

definition InterS :: "i \<Rightarrow> [i \<Rightarrow> i] \<Rightarrow> i" where [rewrite]:
  "InterS(I,X) = \<Inter>{X(a). a\<in>I}"
setup {* register_wellform_data ("InterS(I,X)", ["I \<noteq> \<emptyset>"]) *}
setup {* add_prfstep_check_req ("InterS(I,X)", "I \<noteq> \<emptyset>") *}

syntax
  "_UNION" :: "[pttrn, i, i] => i"  ("(3\<Union>_\<in>_./ _)" 10)
  "_INTER" :: "[pttrn, i, i] => i"  ("(3\<Inter>_\<in>_./ _)" 10)
translations
  "\<Union>a\<in>I. X" == "CONST UnionS(I, \<lambda>a. X)"
  "\<Inter>a\<in>I. X" == "CONST InterS(I, \<lambda>a. X)"

lemma UnionS_iff [rewrite]:
  "x \<in> (\<Union>a\<in>I. X(a)) \<longleftrightarrow> (\<exists>a\<in>I. x\<in>X(a))" by auto2
lemma UnionSI [typing2]:
  "x \<in> X(a) \<Longrightarrow> a \<in> I \<Longrightarrow> x \<in> (\<Union>a\<in>I. X(a))" by auto2
lemma InterS_iff [rewrite]:
  "I \<noteq> \<emptyset> \<Longrightarrow> x \<in> (\<Inter>a\<in>I. X(a)) \<longleftrightarrow> (\<forall>a\<in>I. x\<in>X(a))" by auto2
setup {* del_prfstep_thm @{thm UnionS_def} *}
setup {* del_prfstep_thm @{thm InterS_def} *}

section \<open>Sigma\<close>

definition Sigma :: "[i, i \<Rightarrow> i] \<Rightarrow> i" where [rewrite]:
  "Sigma(A,B) = (\<Union>x\<in>A. \<Union>y\<in>B(x). {\<langle>x,y\<rangle>})"

lemma Sigma_iff [rewrite]:
  "p \<in> Sigma(A, B) \<longleftrightarrow> p = \<langle>fst(p),snd(p)\<rangle> \<and> fst(p) \<in> A \<and> snd(p) \<in> B(fst(p))" by auto2
setup {* del_prfstep_thm @{thm Sigma_def} *}

section \<open>Product set\<close>

definition cart_prod :: "[i, i] \<Rightarrow> i"  (infixr "\<times>" 80) where [rewrite]:
  "A \<times> B \<equiv> Sigma(A, \<lambda>_. B)"

lemma prod_memD [forward]:
  "p \<in> A \<times> B \<Longrightarrow> p = \<langle>fst(p),snd(p)\<rangle> \<and> fst(p) \<in> A \<and> snd(p) \<in> B" by auto2

lemma prod_memI: "a \<in> A \<Longrightarrow> \<forall>b\<in>B. \<langle>a,b\<rangle> \<in> A\<times>B" by auto2
setup {* add_forward_prfstep_cond @{thm prod_memI} [with_term "?A\<times>?B", with_score 500] *}
setup {* del_prfstep_thm @{thm cart_prod_def} *}

lemma prod_memI' [backward,backward1,backward2]:
  "a \<in> A \<Longrightarrow> b \<in> B \<Longrightarrow> \<langle>a,b\<rangle> \<in> A \<times> B" by auto2

(* Determining the two sets from the product set. *)
lemma prod_non_zero [forward]: "A \<times> B = \<emptyset> \<Longrightarrow> A = \<emptyset> \<or> B = \<emptyset>" by auto2

lemma prod_subset: "A \<subseteq> C \<Longrightarrow> B \<subseteq> D \<Longrightarrow> A \<times> B \<subseteq> C \<times> D" by auto2
setup {* add_backward_prfstep_cond @{thm prod_subset} [with_cond "?A \<noteq> ?C", with_cond "?B \<noteq> ?D"] *}
lemma prod_subset1 [backward]: "B \<subseteq> D \<Longrightarrow> A \<times> B \<subseteq> A \<times> D" by auto2
lemma prod_subset2 [backward]: "A \<subseteq> C \<Longrightarrow> A \<times> B \<subseteq> C \<times> B" by auto2

lemma product_eq: "A \<times> B = C \<times> D \<Longrightarrow> A \<noteq> \<emptyset> \<Longrightarrow> B \<noteq> \<emptyset> \<Longrightarrow> A = C \<and> B = D" by auto2
setup {* add_forward_prfstep_cond @{thm product_eq} [with_cond "?A \<noteq> ?C", with_cond "?B \<noteq> ?D"] *}
lemma product_eq1 [forward]: "A \<times> B = A \<times> D \<Longrightarrow> A \<noteq> \<emptyset> \<Longrightarrow> B = D" by auto2
lemma product_eq2 [forward]: "A \<times> B = C \<times> B \<Longrightarrow> B \<noteq> \<emptyset> \<Longrightarrow> A = C" by auto2

lemma prod_inter [rewrite_back]: "(X \<times> Y) \<inter> (A \<times> B) = (X \<inter> A) \<times> (Y \<inter> B)" by auto2
setup {* add_rewrite_rule_cond @{thm prod_inter} [with_cond "?X \<noteq> ?A", with_cond "?Y \<noteq> ?B"] *}
lemma prod_inter1 [rewrite]: "(X \<times> Y) \<inter> (X \<times> B) = X \<times> (Y \<inter> B)" by auto2
lemma prod_inter2 [rewrite]: "(X \<times> Y) \<inter> (A \<times> Y) = (X \<inter> A) \<times> Y" by auto2

lemma prod_empty1 [rewrite]: "\<emptyset> \<times> A = \<emptyset>" by auto2
lemma prod_empty2 [rewrite]: "A \<times> \<emptyset> = \<emptyset>" by auto2
lemma prod_union1 [rewrite_bidir]: "X \<times> A \<union> X \<times> B = X \<times> (A \<union> B)" by auto2
lemma prod_union2 [rewrite_bidir]: "A \<times> X \<union> B \<times> X = (A \<union> B) \<times> X" by auto2
lemma prod_diff1 [rewrite]: "X \<times> A \<midarrow> X \<times> B = X \<times> (A \<midarrow> B)" by auto2
lemma prod_diff2 [rewrite]: "A \<times> X \<midarrow> B \<times> X = (A \<midarrow> B) \<times> X" by auto2

section \<open>Axiom of Foundation\<close>

axiomatization where
  foundation [backward]: "x \<noteq> \<emptyset> \<Longrightarrow> \<exists>y\<in>x. y \<inter> x = \<emptyset>"

lemma no_mem_cycle1 [resolve]: "a \<notin> a"
@proof
  @obtain "x\<in>{a}" where "x \<inter> {a} = \<emptyset>"
@qed

lemma no_mem_cycle2 [resolve]: "x \<in> y \<Longrightarrow> y \<notin> x"
@proof
  @obtain "a \<in> {x,y}" where "a \<inter> {x,y} = \<emptyset>"
@qed

lemma succ_nonzero [resolve]: "succ(x) \<noteq> \<emptyset>" by auto2
lemma succ_inj [forward]: "succ(x) = succ(y) \<Longrightarrow> x = y" by auto2

end


theory ConcreteSemantics10_3_Live
  imports Main "~~/src/HOL/IMP/Big_Step"  "~~/src/HOL/IMP/Vars"
begin

subsection "Liveness Analysis"

fun L :: "com \<Rightarrow> vname set \<Rightarrow> vname set" where
"L SKIP X = X" |
"L (x ::= a) X = vars a \<union> (X - {x})" |
"L (c\<^sub>1;; c\<^sub>2) X = L c\<^sub>1 (L c\<^sub>2 X)" |
"L (IF b THEN c\<^sub>1 ELSE c\<^sub>2) X = vars b \<union> L c\<^sub>1 X \<union> L c\<^sub>2 X" |
"L (WHILE b DO c) X = vars b \<union> X \<union> L c X"

value "show (L (''y'' ::= V ''z'';; ''x'' ::= Plus (V ''y'') (V ''z'')) {''x''})"

value "show (L (WHILE Less (V ''x'') (V ''x'') DO ''y'' ::= V ''z'') {''x''})"

fun "kill" :: "com \<Rightarrow> vname set" where
"kill SKIP = {}" |
"kill (x ::= a) = {x}" |
"kill (c\<^sub>1;; c\<^sub>2) = kill c\<^sub>1 \<union> kill c\<^sub>2" |
"kill (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = kill c\<^sub>1 \<inter> kill c\<^sub>2" |
"kill (WHILE b DO c) = {}"

fun gen :: "com \<Rightarrow> vname set" where
"gen SKIP = {}" |
"gen (x ::= a) = vars a" |
"gen (c\<^sub>1;; c\<^sub>2) = gen c\<^sub>1 \<union> (gen c\<^sub>2 - kill c\<^sub>1)" |
"gen (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = vars b \<union> gen c\<^sub>1 \<union> gen c\<^sub>2" |
"gen (WHILE b DO c) = vars b \<union> gen c"

(* Lemma 10.15 (Liveness via gen/kill). *)
lemma L_gen_kill: "L c X = gen c \<union> (X - kill c)"
proof(induction c arbitrary:X)
  case SKIP
then show ?case by auto
next
  case (Assign x1 x2)
  then show ?case by auto
next
  case (Seq c1 c2)
  then show ?case by auto
next
  case (If x1 c1 c2)
  then show ?case by auto
next
  case (While x1 c)
  then show ?case by auto
qed

(*Lemma 10.15 (Liveness via gen/kill).*)
lemma L_While_pfp: "L c (L (WHILE b DO c) X) \<subseteq> L (WHILE b DO c) X"
  apply(auto simp add: L_gen_kill)
  done

lemma L_While_lpfp:
  "vars b \<union> X \<union> L c P \<subseteq> P \<Longrightarrow> L (WHILE b DO c) X \<subseteq> P"
by(simp add: L_gen_kill)

lemma L_While_vars: "vars b \<subseteq> L (WHILE b DO c) X"
by auto

lemma L_While_X: "X \<subseteq> L (WHILE b DO c) X"
by auto

text\<open>Disable L WHILE equation and reason only with L WHILE constraints\<close>
declare L.simps(5)[simp del]

subsection "Correctness"

theorem L_correct:
  "(c,s) \<Rightarrow> s'  \<Longrightarrow> s = t on L c X \<Longrightarrow>
  \<exists> t'. (c,t) \<Rightarrow> t' & s' = t' on X"
proof (induction arbitrary: X t rule: big_step_induct)
case (Skip s)
  then show ?case by auto
next
  case (Assign x a s)
  then show ?case by (auto simp add: ball_Un)
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
(*
       (c\<^sub>1, s\<^sub>1) \<Rightarrow> s\<^sub>2 \<Longrightarrow>
       (\<And>X t. s\<^sub>1 = t on L c\<^sub>1 X \<Longrightarrow> \<exists>t'. (c\<^sub>1, t) \<Rightarrow> t' \<and> s\<^sub>2 = t' on X) \<Longrightarrow>
       (c\<^sub>2, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<Longrightarrow>
       (\<And>X t. s\<^sub>2 = t on L c\<^sub>2 X \<Longrightarrow> \<exists>t'. (c\<^sub>2, t) \<Rightarrow> t' \<and> s\<^sub>3 = t' on X) \<Longrightarrow>
       s\<^sub>1 = t on L (c\<^sub>1;; c\<^sub>2) X \<Longrightarrow> \<exists>t'. (c\<^sub>1;; c\<^sub>2, t) \<Rightarrow> t' \<and> s\<^sub>3 = t' on X
*)
  from Seq.IH(1) Seq.prems obtain t2 where "(c\<^sub>1, t) \<Rightarrow> t2" and "s\<^sub>2 = t2 on L c\<^sub>2 X"
    by simp blast
  obtain t3 where "(c\<^sub>2, t2) \<Rightarrow> t3" and "s\<^sub>3 = t3 on X"
    using Seq.IH(2) \<open>s\<^sub>2 = t2 on L c\<^sub>2 X\<close> by blast
  then show ?case
    using \<open>(c\<^sub>1, t) \<Rightarrow> t2\<close> by blast
next
  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
(*
       bval b s \<Longrightarrow>
       (c\<^sub>1, s) \<Rightarrow> t \<Longrightarrow>
       (\<And>X ta. s = ta on L c\<^sub>1 X \<Longrightarrow> \<exists>t'. (c\<^sub>1, ta) \<Rightarrow> t' \<and> t = t' on X) \<Longrightarrow>
       s = ta on L (IF b THEN c\<^sub>1 ELSE c\<^sub>2) X \<Longrightarrow>
       \<exists>t'. (IF b THEN c\<^sub>1 ELSE c\<^sub>2, ta) \<Rightarrow> t' \<and> t = t' on X
*)
  then have "s = t on vars b" and "s = t on L c\<^sub>1 X " by auto
  have "bval b t"
    using IfTrue.hyps(1) \<open>s = t on vars b\<close> bval_eq_if_eq_on_vars by blast
 from IfTrue.IH[OF \<open>s = t on L c\<^sub>1 X\<close>] obtain t' where "s' = t' on X"  "(c\<^sub>1, t) \<Rightarrow> t'" by auto
  then show ?case
    using \<open>bval b t\<close> by blast
next
  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
  then have "s = t on vars b" and "s = t on L c\<^sub>2 X " by auto
  have "\<not> bval b t"
    using IfFalse.hyps(1) \<open>s = t on vars b\<close> bval_eq_if_eq_on_vars by blast
 from IfFalse.IH[OF \<open>s = t on L c\<^sub>2 X\<close>] obtain t' where "s' = t' on X"  "(c\<^sub>2, t) \<Rightarrow> t'" by auto
  then show ?case using \<open>\<not> bval b t\<close> by blast
next
  case (WhileFalse b s c)
(*
       \<not> bval b s \<Longrightarrow>
       s = t on L (WHILE b DO c) X \<Longrightarrow> \<exists>t'. (WHILE b DO c, t) \<Rightarrow> t' \<and> s = t' on X
*)
  then have "~ bval b t"
    by (metis L_While_vars bval_eq_if_eq_on_vars subsetD)
  thus ?case
    using L_While_X WhileFalse.prems by blast
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
(*
       bval b s\<^sub>1 \<Longrightarrow>
       (c, s\<^sub>1) \<Rightarrow> s\<^sub>2 \<Longrightarrow>
       (\<And>X t. s\<^sub>1 = t on L c X \<Longrightarrow> \<exists>t'. (c, t) \<Rightarrow> t' \<and> s\<^sub>2 = t' on X) \<Longrightarrow>
       (WHILE b DO c, s\<^sub>2) \<Rightarrow> s\<^sub>3 \<Longrightarrow>
       (\<And>X t. s\<^sub>2 = t on L (WHILE b DO c) X \<Longrightarrow>
               \<exists>t'. (WHILE b DO c, t) \<Rightarrow> t' \<and> s\<^sub>3 = t' on X) \<Longrightarrow>
       s\<^sub>1 = t on L (WHILE b DO c) X \<Longrightarrow> \<exists>t'. (WHILE b DO c, t) \<Rightarrow> t' \<and> s\<^sub>3 = t' on X
*)
  let ?w = "WHILE b DO c"
  have "bval b t"
    by (metis L_While_vars WhileTrue.hyps(1) WhileTrue.prems bval_eq_if_eq_on_vars subsetD)
  then have "s\<^sub>1 = t on L c (L ?w X)"
    using L_While_pfp WhileTrue.prems by blast
  obtain t2 where "(c, t) \<Rightarrow> t2" "s\<^sub>2 = t2 on L ?w X"
    using WhileTrue.IH(1) \<open>s\<^sub>1 = t on L c (L (WHILE b DO c) X)\<close> by blast
  obtain t3 where "(?w, t2) \<Rightarrow> t3" "s\<^sub>3 = t3 on X"
    using WhileTrue.IH(2) \<open>s\<^sub>2 = t2 on L (WHILE b DO c) X\<close> by blast
  then show ?case
    using \<open>(c, t) \<Rightarrow> t2\<close> \<open>bval b t\<close> by blast
qed

subsection "Program Optimization"

text\<open>Burying assignments to dead variables:\<close>
fun bury :: "com \<Rightarrow> vname set \<Rightarrow> com" where
"bury SKIP X = SKIP" |
"bury (x ::= a) X = (if x \<in> X then x ::= a else SKIP)" |
"bury (c\<^sub>1;; c\<^sub>2) X = (bury c\<^sub>1 (L c\<^sub>2 X);; bury c\<^sub>2 X)" |
"bury (IF b THEN c\<^sub>1 ELSE c\<^sub>2) X = IF b THEN bury c\<^sub>1 X ELSE bury c\<^sub>2 X" |
"bury (WHILE b DO c) X = WHILE b DO bury c (L (WHILE b DO c) X)"

(* Lemma 10.19 (Correctness of bury, part 1). *)
theorem bury_correct:
  "(c,s) \<Rightarrow> s'  \<Longrightarrow> s = t on L c X \<Longrightarrow>
  \<exists> t'. (bury c X,t) \<Rightarrow> t' & s' = t' on X"
proof (induction arbitrary: X t rule: big_step_induct)
case (Skip s)
then show ?case by auto
next
  case (Assign x a s)
  then show ?case by (auto simp add: ball_Un)
next
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  from Seq.IH(1) Seq.prems obtain t2 where "(bury c\<^sub>1 (L c\<^sub>2 X), t) \<Rightarrow> t2" and "s\<^sub>2 = t2 on L c\<^sub>2 X"
    by simp blast
  obtain t3 where "(bury c\<^sub>2 X, t2) \<Rightarrow> t3" and "s\<^sub>3 = t3 on X"
    by (metis Seq.IH(2) \<open>(bury c\<^sub>1 (L c\<^sub>2 X), t) \<Rightarrow> t2\<close> \<open>\<And>thesis. (\<And>t2. \<lbrakk>(bury c\<^sub>1 (L c\<^sub>2 X), t) \<Rightarrow> t2; s\<^sub>2 = t2 on L c\<^sub>2 X\<rbrakk> \<Longrightarrow> thesis) \<Longrightarrow> thesis\<close> big_step_determ)
  then show ?case
    using \<open>(bury c\<^sub>1 (L c\<^sub>2 X), t) \<Rightarrow> t2\<close> by auto
next
  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
  then have "s = t on vars b" and "s = t on L c\<^sub>1 X " by auto
  have "bval b t"
    using IfTrue.hyps(1) \<open>s = t on vars b\<close> bval_eq_if_eq_on_vars by blast
  from IfTrue.IH[OF \<open>s = t on L c\<^sub>1 X\<close>] obtain t' where
    "(bury c\<^sub>1 X, t) \<Rightarrow> t'" "s' =t' on X" by auto
  then show ?case
    using \<open>bval b t\<close> by auto
next
  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
  then have "s = t on vars b" and "s = t on L c\<^sub>2 X " by auto
  have "\<not> bval b t"
    using IfFalse.hyps(1) \<open>s = t on vars b\<close> bval_eq_if_eq_on_vars by blast
 from IfFalse.IH[OF \<open>s = t on L c\<^sub>2 X\<close>] obtain t' where "s' = t' on X"  "(bury c\<^sub>2 X, t) \<Rightarrow> t'" by auto
  then show ?case using \<open>\<not> bval b t\<close>
    by auto
next
  case (WhileFalse b s c)
  then have "\<not> bval b t"
    by (metis L_While_vars bval_eq_if_eq_on_vars subsetD)
  thus ?case
    using L_While_X WhileFalse.prems by fastforce
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  let ?w = "WHILE b DO c"
  have "bval b t"
    by (metis L_While_vars WhileTrue.hyps(1) WhileTrue.prems bval_eq_if_eq_on_vars subsetD)
  then have "s\<^sub>1 = t on L c (L ?w X)"
    using L_While_pfp WhileTrue.prems by blast
  obtain t2 where "(bury c (L ?w X), t) \<Rightarrow> t2" "s\<^sub>2 = t2 on L ?w X"
    using WhileTrue.IH(1) \<open>s\<^sub>1 = t on L c (L (WHILE b DO c) X)\<close> by blast
  obtain t3 where "(bury ?w X, t2) \<Rightarrow> t3" "s\<^sub>3 = t3 on X"
    using WhileTrue.IH(2) \<open>s\<^sub>2 = t2 on L (WHILE b DO c) X\<close> by blast
  then show ?case
    using \<open>(bury c (L (WHILE b DO c) X), t) \<Rightarrow> t2\<close> \<open>bval b t\<close> by auto
qed

(* Lemma 10.20 (Correctness of bury, part 2). *)

(* Corollary 10.21 (Correctness of bury). *)
corollary final_bury_correct: "(c,s) \<Rightarrow> s' \<Longrightarrow> (bury c UNIV,s) \<Rightarrow> s'"
using bury_correct[of c s s' UNIV]
  by (auto simp: fun_eq_iff[symmetric])

end


(*  Title:      HOL/Hahn_Banach/Vector_Space.thy
    Author:     Gertrud Bauer, TU Munich
*)

section \<open>Vector spaces\<close>

theory Vector_Space
imports Complex_Main Bounds
begin

subsection \<open>Signature\<close>

text \<open>
  For the definition of real vector spaces a type \<^typ>\<open>'a\<close> of the sort
  \<open>{plus, minus, zero}\<close> is considered, on which a real scalar multiplication
  \<open>\<cdot>\<close> is declared.
\<close>

consts
  prod :: "real \<Rightarrow> 'a::{plus,minus,zero} \<Rightarrow> 'a"  (infixr "\<cdot>" 70)

subsection \<open>Vector space laws\<close>

text \<open>
  A \<^emph>\<open>vector space\<close> is a non-empty set \<open>V\<close> of elements from \<^typ>\<open>'a\<close> with the
  following vector space laws: The set \<open>V\<close> is closed under addition and scalar
  multiplication, addition is associative and commutative; \<open>- x\<close> is the
  inverse of \<open>x\<close> wrt.\ addition and \<open>0\<close> is the neutral element of addition.
  Addition and multiplication are distributive; scalar multiplication is
  associative and the real number \<open>1\<close> is the neutral element of scalar
  multiplication.
\<close>

locale vectorspace =
  fixes V
  assumes non_empty [iff, intro?]: "V \<noteq> {}"
    and add_closed [iff]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + y \<in> V"
    and mult_closed [iff]: "x \<in> V \<Longrightarrow> a \<cdot> x \<in> V"
    and add_assoc: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (x + y) + z = x + (y + z)"
    and add_commute: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + y = y + x"
    and diff_self [simp]: "x \<in> V \<Longrightarrow> x - x = 0"
    and add_zero_left [simp]: "x \<in> V \<Longrightarrow> 0 + x = x"
    and add_mult_distrib1: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> a \<cdot> (x + y) = a \<cdot> x + a \<cdot> y"
    and add_mult_distrib2: "x \<in> V \<Longrightarrow> (a + b) \<cdot> x = a \<cdot> x + b \<cdot> x"
    and mult_assoc: "x \<in> V \<Longrightarrow> (a * b) \<cdot> x = a \<cdot> (b \<cdot> x)"
    and mult_1 [simp]: "x \<in> V \<Longrightarrow> 1 \<cdot> x = x"
    and negate_eq1: "x \<in> V \<Longrightarrow> - x = (- 1) \<cdot> x"
    and diff_eq1: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x - y = x + - y"
begin

lemma negate_eq2: "x \<in> V \<Longrightarrow> (- 1) \<cdot> x = - x"
  by (rule negate_eq1 [symmetric])

lemma negate_eq2a: "x \<in> V \<Longrightarrow> -1 \<cdot> x = - x"
  by (simp add: negate_eq1)

lemma diff_eq2: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + - y = x - y"
  by (rule diff_eq1 [symmetric])

lemma diff_closed [iff]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x - y \<in> V"
  by (simp add: diff_eq1 negate_eq1)

lemma neg_closed [iff]: "x \<in> V \<Longrightarrow> - x \<in> V"
  by (simp add: negate_eq1)

lemma add_left_commute:
  "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> x + (y + z) = y + (x + z)"
proof -
  assume xyz: "x \<in> V"  "y \<in> V"  "z \<in> V"
  then have "x + (y + z) = (x + y) + z"
    by (simp only: add_assoc)
  also from xyz have "\<dots> = (y + x) + z" by (simp only: add_commute)
  also from xyz have "\<dots> = y + (x + z)" by (simp only: add_assoc)
  finally show ?thesis .
qed

lemmas add_ac = add_assoc add_commute add_left_commute

text \<open>
  The existence of the zero element of a vector space follows from the
  non-emptiness of carrier set.
\<close>

lemma zero [iff]: "0 \<in> V"
proof -
  from non_empty obtain x where x: "x \<in> V" by blast
  then have "0 = x - x" by (rule diff_self [symmetric])
  also from x x have "\<dots> \<in> V" by (rule diff_closed)
  finally show ?thesis .
qed

lemma add_zero_right [simp]: "x \<in> V \<Longrightarrow>  x + 0 = x"
proof -
  assume x: "x \<in> V"
  from this and zero have "x + 0 = 0 + x" by (rule add_commute)
  also from x have "\<dots> = x" by (rule add_zero_left)
  finally show ?thesis .
qed

lemma mult_assoc2: "x \<in> V \<Longrightarrow> a \<cdot> b \<cdot> x = (a * b) \<cdot> x"
  by (simp only: mult_assoc)

lemma diff_mult_distrib1: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> a \<cdot> (x - y) = a \<cdot> x - a \<cdot> y"
  by (simp add: diff_eq1 negate_eq1 add_mult_distrib1 mult_assoc2)

lemma diff_mult_distrib2: "x \<in> V \<Longrightarrow> (a - b) \<cdot> x = a \<cdot> x - (b \<cdot> x)"
proof -
  assume x: "x \<in> V"
  have " (a - b) \<cdot> x = (a + - b) \<cdot> x"
    by simp
  also from x have "\<dots> = a \<cdot> x + (- b) \<cdot> x"
    by (rule add_mult_distrib2)
  also from x have "\<dots> = a \<cdot> x + - (b \<cdot> x)"
    by (simp add: negate_eq1 mult_assoc2)
  also from x have "\<dots> = a \<cdot> x - (b \<cdot> x)"
    by (simp add: diff_eq1)
  finally show ?thesis .
qed

lemmas distrib =
  add_mult_distrib1 add_mult_distrib2
  diff_mult_distrib1 diff_mult_distrib2

text \<open>\<^medskip> Further derived laws:\<close>

lemma mult_zero_left [simp]: "x \<in> V \<Longrightarrow> 0 \<cdot> x = 0"
proof -
  assume x: "x \<in> V"
  have "0 \<cdot> x = (1 - 1) \<cdot> x" by simp
  also have "\<dots> = (1 + - 1) \<cdot> x" by simp
  also from x have "\<dots> =  1 \<cdot> x + (- 1) \<cdot> x"
    by (rule add_mult_distrib2)
  also from x have "\<dots> = x + (- 1) \<cdot> x" by simp
  also from x have "\<dots> = x + - x" by (simp add: negate_eq2a)
  also from x have "\<dots> = x - x" by (simp add: diff_eq2)
  also from x have "\<dots> = 0" by simp
  finally show ?thesis .
qed

lemma mult_zero_right [simp]: "a \<cdot> 0 = (0::'a)"
proof -
  have "a \<cdot> 0 = a \<cdot> (0 - (0::'a))" by simp
  also have "\<dots> =  a \<cdot> 0 - a \<cdot> 0"
    by (rule diff_mult_distrib1) simp_all
  also have "\<dots> = 0" by simp
  finally show ?thesis .
qed

lemma minus_mult_cancel [simp]: "x \<in> V \<Longrightarrow> (- a) \<cdot> - x = a \<cdot> x"
  by (simp add: negate_eq1 mult_assoc2)

lemma add_minus_left_eq_diff: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> - x + y = y - x"
proof -
  assume xy: "x \<in> V"  "y \<in> V"
  then have "- x + y = y + - x" by (simp add: add_commute)
  also from xy have "\<dots> = y - x" by (simp add: diff_eq1)
  finally show ?thesis .
qed

lemma add_minus [simp]: "x \<in> V \<Longrightarrow> x + - x = 0"
  by (simp add: diff_eq2)

lemma add_minus_left [simp]: "x \<in> V \<Longrightarrow> - x + x = 0"
  by (simp add: diff_eq2 add_commute)

lemma minus_minus [simp]: "x \<in> V \<Longrightarrow> - (- x) = x"
  by (simp add: negate_eq1 mult_assoc2)

lemma minus_zero [simp]: "- (0::'a) = 0"
  by (simp add: negate_eq1)

lemma minus_zero_iff [simp]:
  assumes x: "x \<in> V"
  shows "(- x = 0) = (x = 0)"
proof
  from x have "x = - (- x)" by simp
  also assume "- x = 0"
  also have "- \<dots> = 0" by (rule minus_zero)
  finally show "x = 0" .
next
  assume "x = 0"
  then show "- x = 0" by simp
qed

lemma add_minus_cancel [simp]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x + (- x + y) = y"
  by (simp add: add_assoc [symmetric])

lemma minus_add_cancel [simp]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> - x + (x + y) = y"
  by (simp add: add_assoc [symmetric])

lemma minus_add_distrib [simp]: "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> - (x + y) = - x + - y"
  by (simp add: negate_eq1 add_mult_distrib1)

lemma diff_zero [simp]: "x \<in> V \<Longrightarrow> x - 0 = x"
  by (simp add: diff_eq1)

lemma diff_zero_right [simp]: "x \<in> V \<Longrightarrow> 0 - x = - x"
  by (simp add: diff_eq1)

lemma add_left_cancel:
  assumes x: "x \<in> V" and y: "y \<in> V" and z: "z \<in> V"
  shows "(x + y = x + z) = (y = z)"
proof
  from y have "y = 0 + y" by simp
  also from x y have "\<dots> = (- x + x) + y" by simp
  also from x y have "\<dots> = - x + (x + y)" by (simp add: add.assoc)
  also assume "x + y = x + z"
  also from x z have "- x + (x + z) = - x + x + z" by (simp add: add.assoc)
  also from x z have "\<dots> = z" by simp
  finally show "y = z" .
next
  assume "y = z"
  then show "x + y = x + z" by (simp only:)
qed

lemma add_right_cancel:
    "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> z \<in> V \<Longrightarrow> (y + x = z + x) = (y = z)"
  by (simp only: add_commute add_left_cancel)

lemma add_assoc_cong:
  "x \<in> V \<Longrightarrow> y \<in> V \<Longrightarrow> x' \<in> V \<Longrightarrow> y' \<in> V \<Longrightarrow> z \<in> V
    \<Longrightarrow> x + y = x' + y' \<Longrightarrow> x + (y + z) = x' + (y' + z)"
  by (simp only: add_assoc [symmetric])

lemma mult_left_commute: "x \<in> V \<Longrightarrow> a \<cdot> b \<cdot> x = b \<cdot> a \<cdot> x"
  by (simp add: mult.commute mult_assoc2)

lemma mult_zero_uniq:
  assumes x: "x \<in> V"  "x \<noteq> 0" and ax: "a \<cdot> x = 0"
  shows "a = 0"
proof (rule classical)
  assume a: "a \<noteq> 0"
  from x a have "x = (inverse a * a) \<cdot> x" by simp
  also from \<open>x \<in> V\<close> have "\<dots> = inverse a \<cdot> (a \<cdot> x)" by (rule mult_assoc)
  also from ax have "\<dots> = inverse a \<cdot> 0" by simp
  also have "\<dots> = 0" by simp
  finally have "x = 0" .
  with \<open>x \<noteq> 0\<close> show "a = 0" by contradiction
qed

lemma mult_left_cancel:
  assumes x: "x \<in> V" and y: "y \<in> V" and a: "a \<noteq> 0"
  shows "(a \<cdot> x = a \<cdot> y) = (x = y)"
proof
  from x have "x = 1 \<cdot> x" by simp
  also from a have "\<dots> = (inverse a * a) \<cdot> x" by simp
  also from x have "\<dots> = inverse a \<cdot> (a \<cdot> x)"
    by (simp only: mult_assoc)
  also assume "a \<cdot> x = a \<cdot> y"
  also from a y have "inverse a \<cdot> \<dots> = y"
    by (simp add: mult_assoc2)
  finally show "x = y" .
next
  assume "x = y"
  then show "a \<cdot> x = a \<cdot> y" by (simp only:)
qed

lemma mult_right_cancel:
  assumes x: "x \<in> V" and neq: "x \<noteq> 0"
  shows "(a \<cdot> x = b \<cdot> x) = (a = b)"
proof
  from x have "(a - b) \<cdot> x = a \<cdot> x - b \<cdot> x"
    by (simp add: diff_mult_distrib2)
  also assume "a \<cdot> x = b \<cdot> x"
  with x have "a \<cdot> x - b \<cdot> x = 0" by simp
  finally have "(a - b) \<cdot> x = 0" .
  with x neq have "a - b = 0" by (rule mult_zero_uniq)
  then show "a = b" by simp
next
  assume "a = b"
  then show "a \<cdot> x = b \<cdot> x" by (simp only:)
qed

lemma eq_diff_eq:
  assumes x: "x \<in> V" and y: "y \<in> V" and z: "z \<in> V"
  shows "(x = z - y) = (x + y = z)"
proof
  assume "x = z - y"
  then have "x + y = z - y + y" by simp
  also from y z have "\<dots> = z + - y + y"
    by (simp add: diff_eq1)
  also have "\<dots> = z + (- y + y)"
    by (rule add_assoc) (simp_all add: y z)
  also from y z have "\<dots> = z + 0"
    by (simp only: add_minus_left)
  also from z have "\<dots> = z"
    by (simp only: add_zero_right)
  finally show "x + y = z" .
next
  assume "x + y = z"
  then have "z - y = (x + y) - y" by simp
  also from x y have "\<dots> = x + y + - y"
    by (simp add: diff_eq1)
  also have "\<dots> = x + (y + - y)"
    by (rule add_assoc) (simp_all add: x y)
  also from x y have "\<dots> = x" by simp
  finally show "x = z - y" ..
qed

lemma add_minus_eq_minus:
  assumes x: "x \<in> V" and y: "y \<in> V" and xy: "x + y = 0"
  shows "x = - y"
proof -
  from x y have "x = (- y + y) + x" by simp
  also from x y have "\<dots> = - y + (x + y)" by (simp add: add_ac)
  also note xy
  also from y have "- y + 0 = - y" by simp
  finally show "x = - y" .
qed

lemma add_minus_eq:
  assumes x: "x \<in> V" and y: "y \<in> V" and xy: "x - y = 0"
  shows "x = y"
proof -
  from x y xy have eq: "x + - y = 0" by (simp add: diff_eq1)
  with _ _ have "x = - (- y)"
    by (rule add_minus_eq_minus) (simp_all add: x y)
  with x y show "x = y" by simp
qed

lemma add_diff_swap:
  assumes vs: "a \<in> V"  "b \<in> V"  "c \<in> V"  "d \<in> V"
    and eq: "a + b = c + d"
  shows "a - c = d - b"
proof -
  from assms have "- c + (a + b) = - c + (c + d)"
    by (simp add: add_left_cancel)
  also have "\<dots> = d" using \<open>c \<in> V\<close> \<open>d \<in> V\<close> by (rule minus_add_cancel)
  finally have eq: "- c + (a + b) = d" .
  from vs have "a - c = (- c + (a + b)) + - b"
    by (simp add: add_ac diff_eq1)
  also from vs eq have "\<dots>  = d + - b"
    by (simp add: add_right_cancel)
  also from vs have "\<dots> = d - b" by (simp add: diff_eq2)
  finally show "a - c = d - b" .
qed

lemma vs_add_cancel_21:
  assumes vs: "x \<in> V"  "y \<in> V"  "z \<in> V"  "u \<in> V"
  shows "(x + (y + z) = y + u) = (x + z = u)"
proof
  from vs have "x + z = - y + y + (x + z)" by simp
  also have "\<dots> = - y + (y + (x + z))"
    by (rule add_assoc) (simp_all add: vs)
  also from vs have "y + (x + z) = x + (y + z)"
    by (simp add: add_ac)
  also assume "x + (y + z) = y + u"
  also from vs have "- y + (y + u) = u" by simp
  finally show "x + z = u" .
next
  assume "x + z = u"
  with vs show "x + (y + z) = y + u"
    by (simp only: add_left_commute [of x])
qed

lemma add_cancel_end:
  assumes vs: "x \<in> V"  "y \<in> V"  "z \<in> V"
  shows "(x + (y + z) = y) = (x = - z)"
proof
  assume "x + (y + z) = y"
  with vs have "(x + z) + y = 0 + y" by (simp add: add_ac)
  with vs have "x + z = 0" by (simp only: add_right_cancel add_closed zero)
  with vs show "x = - z" by (simp add: add_minus_eq_minus)
next
  assume eq: "x = - z"
  then have "x + (y + z) = - z + (y + z)" by simp
  also have "\<dots> = y + (- z + z)" by (rule add_left_commute) (simp_all add: vs)
  also from vs have "\<dots> = y"  by simp
  finally show "x + (y + z) = y" .
qed

end

end


section \<open>Bernstein Polynomials over the interval [0, 1]\<close>

theory Bernstein_01
  imports "HOL-Computational_Algebra.Computational_Algebra"
    "Budan_Fourier.Budan_Fourier"
    "RRI_Misc"
begin

text \<open>
The theorem of three circles is a statement about the Bernstein coefficients of a polynomial, the
coefficients when a polynomial is expressed as a sum of Bernstein polynomials. These coefficients
behave nicely under translations and rescaling and are the coefficients of a particular polynomial
in the [0, 1] case. We shall define the [0, 1] case now and consider the general case later,
deriving all the results by rescaling.
\<close>

subsection \<open>Definition and basic results\<close>

definition Bernstein_Poly_01 :: "nat \<Rightarrow> nat \<Rightarrow> real poly" where
  "Bernstein_Poly_01 j p = (monom (p choose j) j)
                              * (monom 1 (p-j) \<circ>\<^sub>p [:1, -1:])"

lemma degree_Bernstein:
  assumes hb: "j \<le> p"
  shows "degree (Bernstein_Poly_01 j p) = p"
proof -
  have ha: "monom (p choose j) j \<noteq> (0::real poly)" using hb by force
  have hb: "monom 1 (p-j) \<circ>\<^sub>p [:1, -1:] \<noteq> (0::real poly)"
  proof
    assume "monom 1 (p-j) \<circ>\<^sub>p [:1, -1:] = (0::real poly)"
    hence "lead_coeff (monom 1 (p - j) \<circ>\<^sub>p [:1, -1:]) = (0::real)"
      apply (subst leading_coeff_0_iff)
      by simp
    moreover have "lead_coeff (monom (1::real) (p - j)
        \<circ>\<^sub>p [:1, -1:]) = (((- 1) ^ (p - j))::real)"
      by (subst lead_coeff_comp, auto simp: degree_monom_eq)
    ultimately show "False" by auto
  qed
  from ha hb show ?thesis
    by (auto simp add: Bernstein_Poly_01_def degree_mult_eq
          degree_monom_eq degree_pcompose)
qed

lemma coeff_gt:
  assumes hb: "j > p"
  shows "Bernstein_Poly_01 j p = 0"
  by (simp add: hb Bernstein_Poly_01_def)

lemma degree_Bernstein_le: "degree (Bernstein_Poly_01 j p) \<le> p"
  apply (cases "j \<le> p")
  by (simp_all add: degree_Bernstein coeff_gt)

lemma poly_Bernstein_nonneg:
  assumes "x \<ge> 0" and "1 \<ge> x"
  shows "poly (Bernstein_Poly_01 j p) x \<ge> 0"
  using assms by (simp add: poly_monom poly_pcompose Bernstein_Poly_01_def)

lemma Bernstein_symmetry:
  assumes "j \<le> p"
  shows "(Bernstein_Poly_01 j p) \<circ>\<^sub>p [:1, -1:] = Bernstein_Poly_01 (p-j) p"
proof -
  have "(Bernstein_Poly_01 j p) \<circ>\<^sub>p [:1, -1:]
         = ((monom (p choose j) j) * (monom 1 (p-j) \<circ>\<^sub>p [:1, -1:])) \<circ>\<^sub>p [:1, -1:]"
    by (simp add: Bernstein_Poly_01_def)
  also have "... = (monom (p choose (p-j)) j *
                    (monom 1 (p-j) \<circ>\<^sub>p [:1, -1:])) \<circ>\<^sub>p [:1, -1:]"
    by (fastforce simp: binomial_symmetric[OF assms])
  also have "... = monom (p choose (p-j)) j \<circ>\<^sub>p [:1, -1:] *
                   (monom 1 (p-j)) \<circ>\<^sub>p ([:1, -1:] \<circ>\<^sub>p [:1, -1:])"
    by (force simp: pcompose_mult pcompose_assoc)
  also have "... = (monom (p choose (p-j)) j \<circ>\<^sub>p [:1, -1:]) * monom 1 (p-j)"
    by (force simp: pcompose_pCons)
  also have "... = smult (p choose (p-j)) (monom 1 j \<circ>\<^sub>p [:1, -1:])
                    * monom 1 (p-j)"
    by (simp add: assms smult_monom pcompose_smult[symmetric])
  also have "... = (monom 1 j \<circ>\<^sub>p [:1, -1:]) * monom (p choose (p-j)) (p-j)"
    apply (subst mult_smult_left)
    apply (subst mult_smult_right[symmetric])
    apply (subst smult_monom)
    by force
  also have "... = Bernstein_Poly_01 (p-j) p" using assms
    by (auto simp: Bernstein_Poly_01_def)
  finally show ?thesis .
qed

subsection \<open>@{term Bernstein_Poly_01} and @{term reciprocal_poly}\<close>

lemma Bernstein_reciprocal:
  "reciprocal_poly p (Bernstein_Poly_01 i p)
    = smult (p choose i) ([:-1, 1:]^(p-i))"
proof cases
  assume "i \<le> p"
  hence "reciprocal_poly p (Bernstein_Poly_01 i p) =
         reciprocal_poly (degree (Bernstein_Poly_01 i p)) (Bernstein_Poly_01 i p)"
    by (auto simp: degree_Bernstein)
  also have "... = reflect_poly (Bernstein_Poly_01 i p)"
    by (rule reciprocal_degree)
  also have "... = smult (p choose i) ([:-1, 1:]^(p-i))"
    by (auto simp: Bernstein_Poly_01_def reflect_poly_simps monom_altdef
         pcompose_pCons reflect_poly_pCons' hom_distribs)
  finally show ?thesis .
next
  assume h:"\<not> i \<le> p"
  hence "reciprocal_poly p (Bernstein_Poly_01 i p) = (0::real poly)"
    by (auto simp: coeff_gt reciprocal_poly_def)
  also have "... = smult (p choose i) ([:-1, 1:]^(p - i))" using h
    by fastforce
  finally show ?thesis .
qed

lemma Bernstein_reciprocal_translate:
  "reciprocal_poly p (Bernstein_Poly_01 i p) \<circ>\<^sub>p [:1, 1:] =
   monom (p choose i) (p - i)"
  by (auto simp: Bernstein_reciprocal pcompose_smult pcompose_pCons monom_altdef hom_distribs)

lemma coeff_Bernstein_sum_01: fixes b::"nat \<Rightarrow> real" assumes hi: "p \<ge> i"
  shows
    "coeff (reciprocal_poly p
            (\<Sum>x = 0..p. smult (b x) (Bernstein_Poly_01 x p)) \<circ>\<^sub>p [:1, 1:])
      (p - i) = (p choose i) * (b i)" (is "?L = ?R")
proof -
  define P where "P \<equiv> (\<Sum>x = 0..p. (smult (b x) (Bernstein_Poly_01 x p)))"

  have "\<And>x. degree (smult (b x) (Bernstein_Poly_01 x p)) \<le> p"
  proof -
    fix x
    show "degree (smult (b x) (Bernstein_Poly_01 x p)) \<le> p"
      apply (cases "x \<le> p")
      by (auto simp: degree_Bernstein coeff_gt)
  qed
  hence "reciprocal_poly p P =
         (\<Sum>x = 0..p. reciprocal_poly p (smult (b x) (Bernstein_Poly_01 x p)))"
    apply (subst P_def)
    apply (rule reciprocal_sum)
    by presburger
  also have
    "... = (\<Sum>x = 0..p. (smult (b x * (p choose x)) ([:-1, 1:]^(p-x))))"
  proof (rule sum.cong)
    fix x assume "x \<in> {0..p}"
    hence "x \<le> p" by simp
    thus "reciprocal_poly p (smult (b x) (Bernstein_Poly_01 x p)) =
          smult ((b x) * (p choose x)) ([:-1, 1:]^(p-x))"
      by (auto simp add: reciprocal_smult degree_Bernstein Bernstein_reciprocal)
  qed (simp)
  finally have
    "reciprocal_poly p P =
     (\<Sum>x = 0..p. (smult ((b x) * (p choose x)) ([:-1, 1:]^(p-x))))" .
  hence
    "(reciprocal_poly p P) \<circ>\<^sub>p [:1, 1:] =
     (\<Sum>x = 0..p. (smult ((b x) * (p choose x)) ([:-1, 1:]^(p-x))) \<circ>\<^sub>p [:1, 1:])"
    by (simp add: pcompose_sum pcompose_add)
  also have "... = (\<Sum>x = 0..p. (monom ((b x) * (p choose x)) (p - x)))"
  proof (rule sum.cong)
    fix x assume "x \<in> {0..p}"
    hence "x \<le> p" by simp
    thus "smult (b x * (p choose x)) ([:- 1, 1:] ^ (p - x)) \<circ>\<^sub>p [:1, 1:] =
          monom (b x * (p choose x)) (p - x)"
      by (simp add: hom_distribs pcompose_smult pcompose_pCons monom_altdef)
  qed (simp)
  finally have "(reciprocal_poly p P) \<circ>\<^sub>p [:1, 1:] =
                (\<Sum>x = 0..p. (monom ((b x) * (p choose x)) (p - x)))" .
  hence "?L = (\<Sum>x = 0..p. if p - x = p - i then b x * real (p choose x) else 0)"
    by (auto simp add: P_def coeff_sum)
  also have "... = (\<Sum>x = 0..p. if x = i then b x * real (p choose x) else 0)"
  proof (rule sum.cong)
    fix x assume "x \<in> {0..p}"
    hence "x \<le> p" by simp
    thus "(if p - x = p - i then b x * real (p choose x) else 0) =
          (if x = i then b x * real (p choose x) else 0)" using hi
      by (auto simp add: leI)
  qed (simp)
  also have "... = ?R" by simp
  finally show ?thesis .
qed

lemma Bernstein_sum_01: assumes hP: "degree P \<le> p"
  shows
  "P = (\<Sum>j = 0..p. smult
     (inverse (real (p choose j)) *
      coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]) (p-j))
   (Bernstein_Poly_01 j p))"
proof -
  define Q where "Q \<equiv> reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]"
  from hP Q_def have hQ: "degree Q \<le> p"
    by (auto simp: degree_reciprocal degree_pcompose)
  have "reciprocal_poly p (\<Sum>j = 0..p.
        smult (inverse (real (p choose j)) * coeff Q (p-j))
        (Bernstein_Poly_01 j p)) \<circ>\<^sub>p [:1, 1:] = Q"
  proof (rule poly_eqI)
    fix n
    show "coeff (reciprocal_poly p (\<Sum>j = 0..p.
          smult (inverse (real (p choose j)) * coeff Q (p-j))
          (Bernstein_Poly_01 j p)) \<circ>\<^sub>p [:1, 1:]) n = coeff Q n"
      (is "?L = ?R")
    proof cases
      assume hn: "n \<le> p"
      hence "?L = coeff (reciprocal_poly p (\<Sum>j = 0..p.
             smult (inverse (real (p choose j)) * coeff Q (p-j))
             (Bernstein_Poly_01 j p)) \<circ>\<^sub>p [:1, 1:]) (p - (p - n))"
        by force
      also have "... = (p choose (p-n)) *
                       (inverse (real (p choose (p-n))) *
                        coeff Q (p-(p-n)))"
        apply (subst coeff_Bernstein_sum_01)
        by auto
      also have "... = ?R" using hn
        by fastforce
      finally show "?L = ?R" .
    next
      assume hn: "\<not> n \<le> p"
      have "degree (\<Sum>j = 0..p.
            smult (inverse (real (p choose j)) * coeff Q (p - j))
            (Bernstein_Poly_01 j p)) \<le> p"
      proof (rule degree_sum_le)
        fix q assume "q \<in> {0..p}"
        hence "q \<le> p" by fastforce
        thus "degree (smult (inverse (real (p choose q)) *
              coeff Q (p - q)) (Bernstein_Poly_01 q p)) \<le> p"
          by (auto simp add: degree_Bernstein degree_smult_le)
      qed simp
      hence "degree (reciprocal_poly p (\<Sum>j = 0..p.
            smult (inverse (real (p choose j)) * coeff Q (p - j))
            (Bernstein_Poly_01 j p)) \<circ>\<^sub>p [:1, 1:]) \<le> p"
        by (auto simp add: degree_pcompose degree_reciprocal)
      hence "?L = 0" using hn by (auto simp add: coeff_eq_0)
      thus "?L = ?R" using hQ hn by (simp add: coeff_eq_0)
    qed
  qed
  hence "reciprocal_poly p P \<circ>\<^sub>p [:1, 1:] =
         reciprocal_poly p (\<Sum>j = 0..p.
         smult (inverse (real (p choose j)) *
         coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]) (p-j))
         (Bernstein_Poly_01 j p)) \<circ>\<^sub>p [:1, 1:]"
    by (auto simp: degree_reciprocal degree_pcompose Q_def)
  hence "reciprocal_poly p P \<circ>\<^sub>p ([:1, 1:] \<circ>\<^sub>p [:-1, 1:]) =
         reciprocal_poly p (\<Sum>j = 0..p. smult (inverse (real (p choose j)) *
         coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]) (p-j))
         (Bernstein_Poly_01 j p)) \<circ>\<^sub>p ([:1, 1:] \<circ>\<^sub>p [:-1, 1:])"
    by (auto simp: pcompose_assoc)
  hence "reciprocal_poly p P = reciprocal_poly p (\<Sum>j = 0..p.
         smult (inverse (real (p choose j)) *
         coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]) (p-j)) (Bernstein_Poly_01 j p))"
    by (auto simp: pcompose_pCons)
  hence "reciprocal_poly p (reciprocal_poly p P) =
         reciprocal_poly p (reciprocal_poly p (\<Sum>j = 0..p.
         smult (inverse (real (p choose j)) *
         coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]) (p-j)) (Bernstein_Poly_01 j p)))"
    by argo
  thus "P = (\<Sum>j = 0..p. smult (inverse (real (p choose j)) *
        coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]) (p-j)) (Bernstein_Poly_01 j p))"
    using hP by (auto simp: reciprocal_reciprocal degree_sum_le degree_smult_le
                 degree_Bernstein degree_add_le)
qed

lemma Bernstein_Poly_01_span1:
  assumes hP: "degree P \<le> p"
  shows "P \<in> poly_vs.span {Bernstein_Poly_01 x p | x. x \<le> p}"
proof -
  have "Bernstein_Poly_01 x p
         \<in> poly_vs.span {Bernstein_Poly_01 x p |x. x \<le> p}"
    if "x \<in> {0..p}" for x
  proof -
    have "\<exists>n. Bernstein_Poly_01 x p = Bernstein_Poly_01 n p \<and> n \<le> p"
      using that by force
    then show
      "Bernstein_Poly_01 x p \<in> poly_vs.span {Bernstein_Poly_01 n p |n. n \<le> p}"
      by (simp add: poly_vs.span_base)
  qed
  thus ?thesis
    apply (subst Bernstein_sum_01[OF hP])
    apply (rule poly_vs.span_sum)
    apply (rule poly_vs.span_scale)
    by blast
qed

lemma Bernstein_Poly_01_span:
  "poly_vs.span {Bernstein_Poly_01 x p | x. x \<le> p}
      = {x. degree x \<le> p}"
  apply (subst monom_span[symmetric])
  apply (subst poly_vs.span_eq)
  by (auto simp: monom_span degree_Bernstein_le
      Bernstein_Poly_01_span1 degree_monom_eq)

subsection \<open>Bernstein coefficients and changes\<close>

definition Bernstein_coeffs_01 :: "nat \<Rightarrow> real poly \<Rightarrow> real list" where
  "Bernstein_coeffs_01 p P =
   [(inverse (real (p choose j)) *
    coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]) (p-j)). j \<leftarrow> [0..<(p+1)]]"

lemma length_Bernstein_coeffs_01: "length (Bernstein_coeffs_01 p P) = p + 1"
  by (auto simp: Bernstein_coeffs_01_def)

lemma nth_default_Bernstein_coeffs_01: assumes "degree P \<le> p"
  shows "nth_default 0 (Bernstein_coeffs_01 p P) i =
         inverse (p choose i) * coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]) (p-i)"
  apply (cases "p = i")
  using assms by (auto simp: Bernstein_coeffs_01_def nth_default_append
                  nth_default_Cons Nitpick.case_nat_unfold binomial_eq_0)

lemma Bernstein_coeffs_01_sum: assumes "degree P \<le> p"
  shows "P = (\<Sum>j = 0..p. smult (nth_default 0 (Bernstein_coeffs_01 p P) j)
             (Bernstein_Poly_01 j p))"
  apply (subst nth_default_Bernstein_coeffs_01[OF assms])
  apply (subst Bernstein_sum_01[OF assms])
  by argo

definition Bernstein_changes_01 :: "nat \<Rightarrow> real poly \<Rightarrow> int" where
  "Bernstein_changes_01 p P = nat (changes (Bernstein_coeffs_01 p P))"

lemma Bernstein_changes_01_def':
  "Bernstein_changes_01 p P = nat (changes [(inverse (real (p choose j)) *
     coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]) (p-j)). j \<leftarrow> [0..<p + 1]])"
  by (simp add: Bernstein_changes_01_def Bernstein_coeffs_01_def)

lemma Bernstein_changes_01_eq_changes:
  assumes hP: "degree P \<le> p"
  shows "Bernstein_changes_01 p P =
         changes (coeffs ((reciprocal_poly p P) \<circ>\<^sub>p [:1, 1:]))"
proof (subst Bernstein_changes_01_def')
  have h:
    "map (\<lambda>j. inverse (real (p choose j)) *
     coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]) (p - j)) [0..<p + 1] =
     map (\<lambda>j. inverse (real (p choose j)) *
     nth_default 0 [nth_default 0 (coeffs (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]))
                    (p - j). j \<leftarrow> [0..<p + 1]] j) [0..<p + 1]"
  proof (rule map_cong)
    fix x
    assume "x \<in> set [0..<p+1]"
    hence hx: "x \<le> p" by fastforce
    moreover have 1:
      "length (map (\<lambda>j. nth_default 0
       (coeffs (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) (p - j)) [0..<p + 1]) \<le> Suc p"
      by force
    moreover have "length (coeffs (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) \<le> Suc p"
    proof (cases "P=0")
      case False
      then have "reciprocal_poly p P \<circ>\<^sub>p [:1, 1:] \<noteq> 0"
        using hP by (simp add: Missing_Polynomial.pcompose_eq_0 reciprocal_0_iff)
      moreover have "Suc (degree (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) \<le> Suc p"
        using hP by (auto simp: degree_pcompose degree_reciprocal)
      ultimately show ?thesis
        using length_coeffs_degree by force
    qed (auto simp: reciprocal_0)
    ultimately have h:
      "nth_default 0 (map (\<lambda>j. nth_default 0 (coeffs
       (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) (p - j)) [0..<p + 1]) x =
       nth_default 0 (coeffs (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) (p - x)"
      (is "?L = ?R")
    proof -
      have "?L = (map (\<lambda>j. nth_default 0 (coeffs
            (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) (p - j)) [0..<p + 1]) ! x"
        using hx by (auto simp: nth_default_nth)
      also have "... =  nth_default 0
          (coeffs (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) (p - [0..<p + 1] ! x)"
        apply (subst nth_map)
        using hx by auto
      also have "... = ?R"
        apply (subst nth_upt)
        using hx by auto
      finally show ?thesis .
    qed
    show "inverse (real (p choose x)) *
          coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]) (p - x) =
          inverse (real (p choose x)) *
          nth_default 0 (map (\<lambda>j. nth_default 0
          (coeffs (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) (p - j)) [0..<p + 1]) x"
      apply (subst h)
      apply (subst nth_default_coeffs_eq)
      by blast
  qed auto

  have 1:
    "rev (map (\<lambda>j. nth_default 0 (coeffs (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]))
     (p - j)) [0..<p + 1]) = map (\<lambda>j. nth_default 0 (coeffs
     (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) j) [0..<p + 1]"
  proof (subst rev_map, rule map_cong')
    have "\<And>q. (q \<ge> p \<longrightarrow> rev [q-p..<q+1] = map ((-) q) [0..<p+1])"
    proof (induction p)
      case 0
      then show ?case by simp
    next
      case (Suc p)
      have IH: "\<And>q. (q \<ge> p \<longrightarrow> rev [q-p..<q+1] = map ((-) q) [0..<p+1])"
        using Suc.IH by blast
      show ?case
      proof
        assume hq: "Suc p \<le> q"
        then have h: "rev [q - p..<q + 1] = map ((-) (q)) [0..<p + 1]"
          apply (subst IH)
          using hq by auto
        have "[q - Suc p..<q + 1] = (q - Suc p) # [q - p..<q + 1]"
          by (simp add: Suc_diff_Suc Suc_le_lessD hq upt_conv_Cons)
        hence "rev [q - Suc p..<q + 1] = rev [q - p..<q + 1] @ [q - Suc p]"
          by force
        also have "... = map ((-) (q)) [0..<p + 1] @ [q - Suc p]"
          using h by blast
        also have "... = map ((-) q) [0..<Suc p + 1]"
          by force
        finally show "rev [q - Suc p..<q + 1] = map ((-) q) [0..<Suc p + 1]" .
      qed
    qed
    thus "rev [0..<p + 1] = map ((-) p) [0..<p + 1]"
      by force
  next
    fix y
    assume "y \<in> set [0..<p + 1]"
    hence "y \<le> p" by fastforce
    thus "nth_default 0 (coeffs (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) (p - (p - y)) =
          nth_default 0 (coeffs (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:])) y"
      by fastforce
  qed

  have 2: "\<And> f. f \<noteq> 0 \<longrightarrow> degree f \<le> p \<longrightarrow>
           map (nth_default 0 (coeffs f)) [0..<p + 1] =
           coeffs f @ replicate (p - degree f) 0"
  proof (induction p)
    case 0
    then show ?case by (auto simp: degree_0_iff)
  next
    fix f
    case (Suc p)
    hence IH: "(f \<noteq> 0 \<longrightarrow>
                degree f \<le> p \<longrightarrow>
                map (nth_default 0 (coeffs f)) [0..<p + 1] =
                coeffs f @ replicate (p - degree f) 0)" by blast
    then show ?case
    proof (cases)
      assume h': "Suc p = degree f"
      hence h: "[0..<Suc p + 1] = [0..<length (coeffs f)]"
        by (metis add_is_0 degree_0 length_coeffs plus_1_eq_Suc zero_neq_one)
      thus ?thesis
        apply (subst h)
        apply (subst map_nth_default)
        using h' by fastforce
    next
      assume h': "Suc p \<noteq> degree f"
      show ?thesis
      proof
        assume hf: "f \<noteq> 0"
        show "degree f \<le> Suc p \<longrightarrow>
            map (nth_default 0 (coeffs f)) [0..<Suc p + 1] =
            coeffs f @ replicate (Suc p - degree f) 0"
        proof
          assume "degree f \<le> Suc p"
          hence 1: "degree f \<le> p" using h' by fastforce
          hence 2: "map (nth_default 0 (coeffs f)) [0..<p + 1] =
                  coeffs f @ replicate (p - degree f) 0" using IH hf by blast
          have "map (nth_default 0 (coeffs f)) [0..<Suc p + 1] =
                map (nth_default 0 (coeffs f)) [0..<p + 1] @
                     [nth_default 0 (coeffs f) (Suc p)]"
            by fastforce
          also have
            "... = coeffs f @ replicate (p - degree f) 0 @ [coeff f (Suc p)]"
            using 2
            by (auto simp: nth_default_coeffs_eq)
          also have "... = coeffs f @ replicate (p - degree f) 0 @ [0]"
            using \<open>degree f \<le> Suc p\<close> h' le_antisym le_degree by blast
          also have "... = coeffs f @ replicate (Suc p - degree f) 0" using 1
            by (simp add: Suc_diff_le replicate_app_Cons_same)
          finally show "map (nth_default 0 (coeffs f)) [0..<Suc p + 1] =
                coeffs f @ replicate (Suc p - degree f) 0" .
        qed
      qed
    qed
  qed

  thus "int (nat (changes (map (\<lambda>j. inverse (real (p choose j)) *
        coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]) (p - j)) [0..<p + 1]))) =
        changes (coeffs (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]))"
  proof cases
    assume hP: "P = 0"
    show "int (nat (changes (map (\<lambda>j. inverse (real (p choose j)) *
          coeff (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]) (p - j)) [0..<p + 1]))) =
          changes (coeffs (reciprocal_poly p P \<circ>\<^sub>p [:1, 1:]))" (is "?L = ?R")
    proof -
      have "?L = int (nat (changes (map (\<lambda>j. 0::real) [0..<p+1])))"
        using hP by (auto simp: reciprocal_0 changes_nonneg)
      also have "... = 0"
        apply (induction p)
        by (auto simp: map_replicate_trivial changes_nonneg
            replicate_app_Cons_same)
      also have "0 = changes ([]::real list)" by simp
      also have "... = ?R" using hP by (auto simp: reciprocal_0)
      finally show ?thesis .
    qed
  next
    assume hP': "P \<noteq> 0"
    thus ?thesis
      apply (subst h)
      apply (subst changes_scale)
        apply auto[2]
      apply (subst changes_rev[symmetric])
      apply (subst 1)
      apply (subst 2)
      apply (simp add: pcompose_eq_0 hP reciprocal_0_iff)
      using assms apply (auto simp: degree_reciprocal)[1]
      by (auto simp: changes_append_replicate_0 changes_nonneg)
  qed
qed

lemma Bernstein_changes_01_test: fixes P::"real poly"
  assumes hP: "degree P \<le> p" and h0: "P \<noteq> 0"
  shows "proots_count P {x. 0 < x \<and> x < 1} \<le> Bernstein_changes_01 p P \<and>
        even (Bernstein_changes_01 p P - proots_count P {x. 0 < x \<and> x < 1})"
proof -
  let ?Q = "(reciprocal_poly p P) \<circ>\<^sub>p [:1, 1:]"

  have 1: "changes (coeffs ?Q) \<ge> proots_count ?Q {x. 0 < x} \<and>
        even (changes (coeffs ?Q) - proots_count ?Q {x. 0 < x})"
    apply (rule descartes_sign)
    by (simp add: Missing_Polynomial.pcompose_eq_0 h0 hP reciprocal_0_iff)

  have "((+) (1::real) ` Collect ((<) (0::real))) = {x. (1::real)<x}"
  proof
    show "{x::real. 1 < x} \<subseteq> (+) 1 ` Collect ((<) 0)"
    proof
      fix x::real assume "x \<in> {x. 1 < x}"
      hence "1 < x" by simp
      hence "-1 + x \<in> Collect ((<) 0)" by auto
      hence "1 + (-1 + x) \<in> (+) 1 ` Collect ((<) 0)" by blast
      thus "x \<in> (+) 1 ` Collect ((<) 0)" by argo
    qed
  qed auto
  hence 2:  "proots_count P {x. 0 < x \<and> x < 1} = proots_count ?Q {x. 0 < x}"
    using assms
    by (auto simp: proots_pcompose reciprocal_0_iff proots_count_reciprocal')

  show ?thesis
    apply (subst Bernstein_changes_01_eq_changes[OF hP])
    apply (subst Bernstein_changes_01_eq_changes[OF hP])
    apply (subst 2)
    apply (subst 2)
    by (rule 1)
qed

subsection \<open>Expression as a Bernstein sum\<close>

lemma Bernstein_coeffs_01_0: "Bernstein_coeffs_01 p 0 = replicate (p+1) 0"
  by (auto simp: Bernstein_coeffs_01_def reciprocal_0 map_replicate_trivial
      replicate_append_same)

lemma Bernstein_coeffs_01_1: "Bernstein_coeffs_01 p 1 = replicate (p+1) 1"
proof -
  have "Bernstein_coeffs_01 p 1 =
     map (\<lambda>j. inverse (real (p choose j)) *
     coeff (\<Sum>k\<le>p. smult (real (p choose k)) ([:0, 1:] ^ k)) (p - j)) [0..<(p+1)]"
    by (auto simp: Bernstein_coeffs_01_def reciprocal_1 monom_altdef
        hom_distribs pcompose_pCons poly_0_coeff_0[symmetric] poly_binomial)
  also have "... = map (\<lambda>j. inverse (real (p choose j)) *
             real (p choose (p - j))) [0..<(p+1)]"
    by (auto simp: monom_altdef[symmetric] coeff_sum binomial)
  also have "... = map (\<lambda>j. 1) [0..<(p+1)]"
    apply (rule map_cong)
    subgoal by argo
    subgoal apply (subst binomial_symmetric)
      by auto
    done
  also have "... = replicate (p+1) 1"
    by (auto simp: map_replicate_trivial replicate_append_same)
  finally show ?thesis .
qed

lemma Bernstein_coeffs_01_x: assumes "p \<noteq> 0"
  shows "Bernstein_coeffs_01 p (monom 1 1) = [i/p. i \<leftarrow> [0..<(p+1)]]"
proof -
  have
    "Bernstein_coeffs_01 p (monom 1 1) = map (\<lambda>j. inverse (real (p choose j)) *
     coeff (monom 1 (p - Suc 0) \<circ>\<^sub>p [:1, 1:]) (p - j)) [0..<(p+1)]"
    using assms by (auto simp: Bernstein_coeffs_01_def reciprocal_monom)
  also have
    "... = map (\<lambda>j. inverse (real (p choose j)) *
     (\<Sum>k\<le>p - Suc 0. coeff (monom (real (p -  1 choose k)) k) (p - j))) [0..<(p+1)]"
    by (auto simp: monom_altdef hom_distribs pcompose_pCons poly_binomial coeff_sum)
  also have"... = map (\<lambda>j. inverse (real (p choose j)) *
            real (p -  1 choose (p - j))) [0..<(p+1)]"
    by auto
  also have "... = map (\<lambda>j. j/p) [0..<(p+1)]"
  proof (rule map_cong)
    fix x assume "x \<in> set [0..<(p+1)]"
    hence "x \<le> p" by force
    thus "inverse (real (p choose x)) * real (p - 1 choose (p - x)) =
          real x / real p"
    proof (cases "x = 0")
      show "x = 0 \<Longrightarrow> ?thesis"
        using assms by fastforce
      assume 1: "x \<le> p" and 2: "x \<noteq> 0"
      hence "p - x \<le> p - 1" by force
      hence "(p - 1 choose (p - x)) = (p - 1 choose (x - 1))"
        apply (subst binomial_symmetric)
        using 1 2 by auto
      hence "x * (p choose x) = p * (p - 1 choose (p - x))"
         using 2 times_binomial_minus1_eq by simp
       hence "real x * real (p choose x) = real p * real (p - 1 choose (p - x))"
         by (metis of_nat_mult)
       thus ?thesis using 1 2
         by (auto simp: divide_simps)
    qed
  qed blast
  finally show ?thesis .
qed

lemma Bernstein_coeffs_01_add:
  assumes "degree P \<le> p" and "degree Q \<le> p"
  shows "nth_default 0 (Bernstein_coeffs_01 p (P + Q)) i =
    nth_default 0 (Bernstein_coeffs_01 p P) i +
    nth_default 0 (Bernstein_coeffs_01 p Q) i"
  using assms by (auto simp: nth_default_Bernstein_coeffs_01 degree_add_le
                    reciprocal_add pcompose_add algebra_simps)

lemma Bernstein_coeffs_01_smult:
  assumes "degree P \<le> p"
  shows "nth_default 0 (Bernstein_coeffs_01 p (smult a P)) i =
          a * nth_default 0 (Bernstein_coeffs_01 p P) i"
  using assms
  by (auto simp: nth_default_Bernstein_coeffs_01 reciprocal_smult
      pcompose_smult)

end


section \<open>Missing Matrix Operations\<close>

text \<open>In this theory we provide an operation that can change a single
  row in a matrix efficiently, and all other rows in the matrix implementation
  will be reused.\<close>

(* TODO: move this part into JNF-AFP-entry *)

theory Matrix_Change_Row
  imports
    Jordan_Normal_Form.Matrix_IArray_Impl
    Polynomial_Interpolation.Missing_Unsorted
begin

definition change_row :: "nat \<Rightarrow> (nat \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a mat \<Rightarrow> 'a mat" where
  "change_row k f A = mat (dim_row A) (dim_col A) (\<lambda> (i,j).
     if i = k then f j (A $$ (k,j)) else A $$ (i,j))"

lemma change_row_carrier[simp]:
  "(change_row k f A \<in> carrier_mat nr nc) = (A \<in> carrier_mat nr nc)"
  "dim_row (change_row k f A) = dim_row A"
  "dim_col (change_row k f A) = dim_col A"
  unfolding change_row_def carrier_mat_def by auto

lemma change_row_index[simp]: "A \<in> carrier_mat nr nc \<Longrightarrow> i < nr \<Longrightarrow> j < nc \<Longrightarrow>
  change_row k f A $$ (i,j) = (if i = k then f j (A $$ (k,j)) else A $$ (i,j))"
  "i < dim_row A \<Longrightarrow> j < dim_col A \<Longrightarrow> change_row k f A $$ (i,j) = (if i = k then f j (A $$ (k,j)) else A $$ (i,j))"
  unfolding change_row_def by auto

lift_definition change_row_impl :: "nat \<Rightarrow> (nat \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> 'a mat_impl \<Rightarrow> 'a mat_impl" is
  "\<lambda> k f (nr,nc,A). let Ak = IArray.sub A k; Arows = IArray.list_of A;
     Ak' = IArray.IArray (map (\<lambda> (i,c). f i c) (zip [0 ..< nc] (IArray.list_of Ak)));
     A' = IArray.IArray (Arows [k := Ak'])
     in (nr,nc,A')"
proof (auto, goal_cases)
  case (1 k f nc b row)
  show ?case
  proof (cases b)
    case (IArray rows)
    with 1 have "row \<in> set rows \<or> k < length rows
       \<and> row = IArray (map (\<lambda> (i,c). f i c) (zip [0 ..< nc] (IArray.list_of (rows ! k))))"
      by (cases "k < length rows", auto simp: set_list_update dest: in_set_takeD in_set_dropD)
    with 1 IArray show ?thesis by (cases, auto)
  qed
qed

lemma change_row_code[code]: "change_row k f (mat_impl A) = (if k < dim_row_impl A
  then mat_impl (change_row_impl k f A)
  else Code.abort (STR ''index out of bounds in change_row'') (\<lambda> _. change_row k f (mat_impl A)))"
  (is "?l = ?r")
proof (cases "k < dim_row_impl A")
  case True
  hence id: "?r = mat_impl (change_row_impl k f A)" by simp
  show ?thesis unfolding id unfolding change_row_def
  proof (rule eq_matI, goal_cases)
    case (1 i j)
    thus ?case using True
      by (transfer, auto simp: mk_mat_def)
  qed (transfer, auto)+
qed simp

end


section "Equality"

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

class eq =
  fixes eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool"

(* Manual instances for nat, unit, prod, and sum *)
instantiation nat and unit:: eq
begin
  definition eq_nat : "eq (x::nat) y \<longleftrightarrow> x = y"
  definition eq_unit_def: "eq (x::unit) y \<longleftrightarrow> True"
  instance ..
end

instantiation prod and sum :: (eq, eq) eq
begin
  definition eq_prod_def: "eq x y \<longleftrightarrow> (eq (fst x) (fst y)) \<and> (eq (snd x) (snd y))"
  definition eq_sum_def: "eq x y = (case x of Inl a \<Rightarrow> (case y of Inl b \<Rightarrow> eq a b | Inr b \<Rightarrow> False)
                                            | Inr a \<Rightarrow> (case y of Inl b \<Rightarrow> False | Inr b \<Rightarrow> eq a b))"

  instance ..
end

(* nonrecursive test *)

derive_generic eq simple .

(* some tests *)
lemma "eq (A 4) (A 4)" by eval
lemma "eq (A 6) (A 4) \<longleftrightarrow> False" by eval
lemma "eq C C" by eval
lemma "eq (B 4 5) (B 4 5)" by eval
lemma "eq (B 4 4) (A 3) \<longleftrightarrow> False" by eval
lemma "eq C (A 4) \<longleftrightarrow> False" by eval

(* type with parameter *)

derive_generic eq either .

lemma "eq (L (3::nat)) (R 3) \<longleftrightarrow> False" by code_simp
lemma "eq (L (3::nat)) (L 3)" by code_simp
lemma "eq (L (3::nat)) (L 4) \<longleftrightarrow> False" by code_simp

(* recursive types *)
derive_generic eq list .

lemma "eq ([]::(nat list)) []" by eval
lemma "eq ([1,2,3]:: (nat list)) [1,2,3]" by eval
lemma "eq [(1::nat)] [1,2] \<longleftrightarrow> False" by eval

derive_generic eq tree .

lemma "eq Leaf Leaf" by code_simp
lemma "eq (Node (1::nat) Leaf Leaf) Leaf \<longleftrightarrow> False" by eval
lemma "eq (Node (1::nat) Leaf Leaf) (Node (1::nat) Leaf Leaf)" by eval
lemma "eq (Node (1::nat) (Node 2 Leaf Leaf) (Node 3 Leaf Leaf)) (Node (1::nat) (Node 2 Leaf Leaf) (Node 4 Leaf Leaf))
    \<longleftrightarrow> False" by eval

(* mutually recursive types *)

derive_generic eq even_nat .
derive_generic eq exp .

lemma "eq Even_Zero Even_Zero" by eval
lemma "eq Even_Zero (Even_Succ (Odd_Succ Even_Zero)) \<longleftrightarrow> False" by eval
lemma "eq (Odd_Succ (Even_Succ (Odd_Succ Even_Zero))) (Odd_Succ (Even_Succ (Odd_Succ Even_Zero)))" by eval
lemma "eq (Odd_Succ (Even_Succ (Odd_Succ Even_Zero))) (Odd_Succ (Even_Succ (Odd_Succ (Even_Succ (Odd_Succ Even_Zero)))))
    \<longleftrightarrow> False" by eval

lemma "eq (Const (1::nat)) (Const (1::nat))" by code_simp
lemma "eq (Const (1::nat)) (Var (1::nat)) \<longleftrightarrow> False" by eval
lemma "eq (Term (Prod (Const (1::nat)) (Factor (Const (2::nat))))) (Term (Prod (Const (1::nat)) (Factor (Const (2::nat)))))"
    by code_simp
lemma "eq (Term (Prod (Const (1::nat)) (Factor (Const (2::nat))))) (Term (Prod (Const (1::nat)) (Factor (Const (3::nat)))))
    \<longleftrightarrow> False" by code_simp

end