(*
Author: Alexander Katovsky
*)

header "Category"

theory Category
imports "~~/src/HOL/Library/FuncSet"
begin

record ('o,'m) Category =
  Obj :: "'o set" ("obj\<index>" 70)
  Mor :: "'m set" ("mor\<index>" 70)
  Dom :: "'m \<Rightarrow> 'o" ("dom\<index> _" [80] 70)
  Cod :: "'m \<Rightarrow> 'o" ("cod\<index> _" [80] 70)
  Id  :: "'o \<Rightarrow> 'm" ("id\<index> _" [80] 75)
  Comp :: "'m \<Rightarrow> 'm \<Rightarrow> 'm" (infixl ";;\<index>" 70)

definition
  MapsTo :: "('o,'m,'a) Category_scheme \<Rightarrow> 'm \<Rightarrow> 'o \<Rightarrow> 'o \<Rightarrow> bool" ("_ maps\<index> _ to _" [60, 60, 60] 65) where
  "MapsTo CC f X Y \<equiv> f \<in> Mor CC \<and> Dom CC f = X \<and> Cod CC f = Y"

definition
  CompDefined :: "('o,'m,'a) Category_scheme \<Rightarrow> 'm \<Rightarrow> 'm \<Rightarrow> bool" (infixl "\<approx>>\<index>" 65) where
  "CompDefined CC f g \<equiv> f \<in> Mor CC \<and> g \<in> Mor CC \<and> Cod CC f = Dom CC g"

locale ExtCategory =
  fixes C :: "('o,'m,'a) Category_scheme" (structure)
  assumes CdomExt: "(Dom C) \<in> extensional (Mor C)"
  and     CcodExt: "(Cod C) \<in> extensional (Mor C)"
  and     CidExt:  "(Id C) \<in> extensional (Obj C)"
  and     CcompExt:  "(split (Comp C)) \<in> extensional ({(f,g) | f g . f \<approx>> g})"

locale Category = ExtCategory +
  assumes Cdom : "f \<in> mor \<Longrightarrow> dom f \<in> obj"
  and     Ccod : "f \<in> mor \<Longrightarrow> cod f \<in> obj"
  and     Cidm [dest]: "X \<in> obj \<Longrightarrow> (id X) maps X to X"
  and     Cidl : "f \<in> mor \<Longrightarrow> id (dom f) ;; f = f"
  and     Cidr : "f \<in> mor \<Longrightarrow> f ;; id (cod f) = f"
  and     Cassoc : "\<lbrakk>f \<approx>> g ; g \<approx>> h\<rbrakk> \<Longrightarrow> (f ;; g) ;; h = f ;; (g ;; h)"
  and     Ccompt : "\<lbrakk>f maps X to Y ; g maps Y to Z\<rbrakk> \<Longrightarrow> (f ;; g) maps X to Z"

definition
  MakeCat :: "('o,'m,'a) Category_scheme \<Rightarrow> ('o,'m,'a) Category_scheme" where
  "MakeCat C \<equiv> \<lparr>
      Obj = Obj C ,
      Mor = Mor C ,
      Dom = restrict (Dom C) (Mor C) ,
      Cod = restrict (Cod C) (Mor C) ,
      Id  = restrict (Id C) (Obj C) ,
      Comp = \<lambda> f g . (restrict (split (Comp C)) ({(f,g) | f g . f \<approx>>\<^bsub>C\<^esub> g})) (f,g),
      \<dots> = Category.more C
  \<rparr>"

lemma MakeCatMapsTo: "f maps\<^bsub>C\<^esub> X to Y \<Longrightarrow> f maps\<^bsub>MakeCat C\<^esub> X to Y"
by (auto simp add: MapsTo_def MakeCat_def)

lemma MakeCatComp: "f \<approx>>\<^bsub>C\<^esub> g \<Longrightarrow> f ;;\<^bsub>MakeCat C\<^esub> g = f ;;\<^bsub>C\<^esub> g"
by (auto simp add: MapsTo_def MakeCat_def)

lemma MakeCatId: "X \<in> obj\<^bsub>C\<^esub> \<Longrightarrow> id\<^bsub>C\<^esub> X = id\<^bsub>MakeCat C\<^esub> X"
by (auto simp add: MapsTo_def MakeCat_def)

lemma MakeCatObj: "obj\<^bsub>MakeCat C\<^esub> = obj\<^bsub>C\<^esub>"
by (simp add: MakeCat_def)

lemma MakeCatMor: "mor\<^bsub>MakeCat C\<^esub> = mor\<^bsub>C\<^esub>"
by (simp add: MakeCat_def)

lemma MakeCatDom: "f \<in> mor\<^bsub>C\<^esub> \<Longrightarrow> dom\<^bsub>C\<^esub> f = dom\<^bsub>MakeCat C\<^esub> f"
by (simp add: MakeCat_def)

lemma MakeCatCod: "f \<in> mor\<^bsub>C\<^esub> \<Longrightarrow> cod\<^bsub>C\<^esub> f = cod\<^bsub>MakeCat C\<^esub> f"
by (simp add: MakeCat_def)

lemma MakeCatCompDef: "f \<approx>>\<^bsub>MakeCat C\<^esub> g = f \<approx>>\<^bsub>C\<^esub> g"
by (auto simp add: CompDefined_def MakeCat_def)

lemma MakeCatComp2: "f \<approx>>\<^bsub>MakeCat C\<^esub> g \<Longrightarrow> f ;;\<^bsub>MakeCat C\<^esub> g = f ;;\<^bsub>C\<^esub> g"
by (simp add: MakeCatCompDef MakeCatComp)

lemma ExtCategoryMakeCat: "ExtCategory (MakeCat C)"
by (unfold_locales, simp_all add: MakeCat_def extensional_def CompDefined_def)

lemma MakeCat: "Category_axioms C \<Longrightarrow> Category (MakeCat C)"
apply(intro_locales, simp add: ExtCategoryMakeCat)
apply (simp add: Category_axioms_def)
apply (auto simp add: MakeCat_def CompDefined_def MapsTo_def)
done

lemma MapsToE[elim]: "\<lbrakk>f maps\<^bsub>C\<^esub> X to Y ; \<lbrakk>f \<in> mor\<^bsub>C\<^esub> ; dom\<^bsub>C\<^esub> f = X ; cod\<^bsub>C\<^esub> f = Y\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (auto simp add: MapsTo_def)

lemma MapsToI[intro]: "\<lbrakk>f \<in> mor\<^bsub>C\<^esub> ; dom\<^bsub>C\<^esub> f = X ; cod\<^bsub>C\<^esub> f = Y\<rbrakk> \<Longrightarrow> f maps\<^bsub>C\<^esub> X to Y"
  by (auto simp add: MapsTo_def)

lemma CompDefinedE[elim]: "\<lbrakk>f \<approx>>\<^bsub>C\<^esub> g ; \<lbrakk>f \<in> mor\<^bsub>C\<^esub> ; g \<in> mor\<^bsub>C\<^esub> ; cod\<^bsub>C\<^esub> f = dom\<^bsub>C\<^esub> g\<rbrakk> \<Longrightarrow> R\<rbrakk> \<Longrightarrow> R"
  by (auto simp add: CompDefined_def)

lemma CompDefinedI[intro]: "\<lbrakk>f \<in> mor\<^bsub>C\<^esub> ; g \<in> mor\<^bsub>C\<^esub> ; cod\<^bsub>C\<^esub> f = dom\<^bsub>C\<^esub> g\<rbrakk> \<Longrightarrow> f \<approx>>\<^bsub>C\<^esub> g"
  by (auto simp add: CompDefined_def)

lemma (in Category) MapsToCompI: assumes "f \<approx>> g" shows "(f ;; g) maps (dom f) to (cod g)"
proof-
  have "f maps (dom f) to (dom g)"
  and  "g maps (dom g) to (cod g)" using assms by auto
  thus ?thesis by (simp add: Ccompt[of f "dom f" "dom g" g "cod g"])
qed

lemma MapsToCompDef:
  assumes "f maps\<^bsub>C\<^esub> X to Y" and "g maps\<^bsub>C\<^esub> Y to Z"
  shows "f \<approx>>\<^bsub>C\<^esub> g"
proof(rule CompDefinedI)
  show "f \<in> mor\<^bsub>C\<^esub>" and "g \<in> mor\<^bsub>C\<^esub>" using assms by auto
  have "cod\<^bsub>C\<^esub> f = Y" and "dom\<^bsub>C\<^esub> g = Y" using assms by auto
  thus "cod\<^bsub>C\<^esub> f = dom\<^bsub>C\<^esub> g" by simp
qed

lemma (in Category) MapsToMorDomCod:
  assumes "f \<approx>> g"
  shows "f ;; g \<in> mor" and "dom (f ;; g) = dom f" and "cod (f ;; g) = cod g"
proof-
  have "(f ;; g) maps (dom f) to (cod g)" using assms by (simp add: MapsToCompI)
  thus "f ;; g \<in> mor" and "dom (f ;; g) = dom f" and "cod (f ;; g) = cod g" by auto
qed

lemma (in Category) MapsToObj:
  assumes "f maps X to Y"
  shows "X \<in> obj" and "Y \<in> obj"
proof-
  have "dom f = X" and "cod f = Y" and "f \<in> mor" using assms by auto
  thus "X \<in> obj" and "Y \<in> obj" by (auto simp add: Cdom Ccod)
qed

lemma (in Category) IdInj:
  assumes "X \<in> obj" and "Y \<in> obj" and "id X = id Y"
  shows   "X = Y"
proof-
  have "dom (id X) = dom (id Y)" using assms by simp
  moreover have "dom (id X) = X" and "dom (id Y) = Y" using assms by (auto simp add: MapsTo_def)
  ultimately show ?thesis by simp
qed

lemma (in Category) CompDefComp:
  assumes "f \<approx>> g" and "g \<approx>> h"
  shows "f \<approx>> (g ;; h)" and "(f ;; g) \<approx>> h"
proof(auto simp add: CompDefined_def)
  show "f \<in> mor" and "h \<in> mor" using assms by auto
  have  1: "g ;; h maps (dom g) to (cod h)"
    and 2: "f ;; g maps (dom f) to (cod g)" using assms by (simp add: MapsToCompI)+
  thus "g ;; h \<in> mor" and "f ;; g \<in> mor" by auto
  have "cod f = dom g" using assms by auto
  also have "... = dom (g ;; h)" using 1 by auto
  finally show "cod f = dom (g ;; h)" .
  have "dom h = cod g" using assms by auto
  also have "... = cod (f ;; g)" using 2 by auto
  finally show "cod (f ;; g) = dom h" by simp
qed

lemma (in Category) CatIdInMor: "X \<in> obj \<Longrightarrow> id X \<in> mor"
by (auto simp add: Cidm)

lemma (in Category) MapsToId: assumes "X \<in> obj" shows "id X \<approx>> id X"
proof(rule CompDefinedI)
  have "id X maps X to X" using assms by (simp add: Cidm)
  thus "id X \<in> mor" and "id X \<in> mor" and "cod (id X) = dom (id X)" by auto
qed

lemmas (in Category) Simps = Cdom Ccod Cidm Cidl Cidr MapsToCompI IdInj MapsToId

lemma (in Category) LeftRightInvUniq:
  assumes 0: "h \<approx>> f" and  z: "f \<approx>> g"
  assumes 1: "f ;; g = id (dom f)"
  and     2: "h ;; f = id (cod f)"
  shows   "h = g"
proof-
  have mor: "h \<in> mor \<and> g \<in> mor"
  and  dc : "dom f = cod h \<and> cod f = dom g" using 0 z by auto
  then have "h = h ;; id (dom f)" by (auto simp add: Simps)
  also have "... = h ;; (f ;; g)" using 1 by simp+
  also have "... = (h ;; f) ;; g" using 0 z by (simp add: Cassoc)
  also have "... = (id (cod f)) ;; g" using 2 by simp+
  also have "... = g" using mor dc by (auto simp add: Simps)
  finally show ?thesis .
qed

lemma (in Category) CatIdDomCod:
  assumes "X \<in> obj"
  shows "dom (id X) = X" and "cod (id X) = X"
proof-
  have "id X maps X to X" using assms
    by (simp add: Simps)
  thus "dom (id X) = X" and "cod (id X) = X" by auto
qed

lemma (in Category) CatIdCompId:
  assumes "X \<in> obj"
  shows   "id X ;; id X = id X"
proof-
  have 0: "id X \<in> mor" using assms by (auto simp add: Simps)
  moreover have "cod (id X) = X" using assms by auto
  moreover have "id X ;; id (cod (id X)) = id X" using 0 by (simp add: Simps)
  ultimately show ?thesis by simp
qed

(*lemmas (in Category) simps2 = simps CatIdCompId Cassoc CatIdDomCod*)

lemma (in Category) CatIdUniqR:
  assumes iota: "\<iota> maps X to X"
  and     rid:  "\<forall> f . f \<approx>> \<iota> \<longrightarrow> f ;; \<iota> = f"
  shows "id X = \<iota>"
proof(rule LeftRightInvUniq [of "id X" "id X" \<iota> ])
  have 0: "X \<in> obj" using iota by (auto simp add: Simps)
  hence "id X maps X to X" by (simp add: Cidm)
  thus 1: "id X \<approx>> \<iota>" using iota by (auto simp add: Simps)
  show    "id X \<approx>> id X" using 0 by (auto simp add: Simps)
  show    "(id X) ;; \<iota> = (id (dom (id X)))" using 0 1 rid by (auto simp add: Simps CompDefined_def MapsTo_def)
  show    "(id X) ;; (id X) = (id (cod (id X)))" using 0 by (auto simp add: CatIdCompId CompDefined_def MapsTo_def)
qed

definition
  inverse_rel :: "('o,'m,'a) Category_scheme \<Rightarrow> 'm \<Rightarrow> 'm \<Rightarrow> bool" ("cinv\<index> _ _" 60) where
  "inverse_rel C f g \<equiv> (f \<approx>>\<^bsub>C\<^esub> g) \<and> (f ;;\<^bsub>C\<^esub> g) = (id\<^bsub>C\<^esub> (dom\<^bsub>C\<^esub> f)) \<and> (g ;;\<^bsub>C\<^esub> f) = (id\<^bsub>C\<^esub> (cod\<^bsub>C\<^esub> f))"

definition
  isomorphism :: "('o,'m,'a) Category_scheme \<Rightarrow> 'm \<Rightarrow> bool" ("ciso\<index> _" [70]) where
  "isomorphism C f \<equiv> \<exists> g . inverse_rel C f g"

lemma (in Category) Inverse_relI: "\<lbrakk>f \<approx>> g ; f ;; g = id (dom f) ; g ;; f = id (cod f)\<rbrakk> \<Longrightarrow> (cinv f g)"
by (auto simp add: inverse_rel_def)

lemma (in Category) Inverse_relE[elim]: "\<lbrakk>cinv f g ; \<lbrakk>f \<approx>> g ; f ;; g = id (dom f) ; g ;; f = id (cod f)\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by (auto simp add: inverse_rel_def)

lemma (in Category) Inverse_relSym:
  assumes "cinv f g"
  shows   "cinv g f"
proof(rule Inverse_relI)
  have 1: "f \<approx>> g" using assms by auto
  show 2: "g \<approx>> f"
  proof(rule CompDefinedI)
    show "g \<in> mor" and 0: "f \<in> mor" using assms by auto
    have "f ;; g maps dom f to cod g" using 1 by (simp add: MapsToCompI)
    hence "cod g = cod (f ;; g)" by auto
    also have "... = cod (id (dom f))" using assms by (auto simp add: inverse_rel_def)
    also have "... = dom f"
    proof-
      have "dom f \<in> obj" using 0 by (simp add: Simps)
      hence "id (dom f) maps (dom f) to (dom f)" by (simp add: Simps)
      thus ?thesis by auto
    qed
    finally show 2: "cod g = dom f" by simp
  qed
  show "g ;; f = id (dom g)" using assms by (auto simp add: inverse_rel_def)
  show "f ;; g = id (cod g)"using assms 1 2 by (auto simp add: inverse_rel_def)
qed

lemma (in Category) InverseUnique:
  assumes 1: "cinv f g"
  and     2: "cinv f h"
  shows   "g = h"
proof(rule LeftRightInvUniq [of g f h])
  have "cinv g f" using 1 2 by (simp only: Inverse_relSym[of f g])
  thus "g \<approx>> f" and
    "g ;; f = id (cod f)" using 1 by auto
  show "f \<approx>> h" using 2 by auto
  show "f ;; h = id (dom f)" using 2 by auto
qed

lemma (in Category) InvId: assumes "X \<in> obj" shows "(cinv (id X) (id X))"
proof(rule Inverse_relI)
  show "id X \<approx>> id X" using assms by (simp add: Simps)
  have "dom (id X) = X" and "dom (id X) = X" using assms by (simp add: CatIdDomCod)+
  thus "id X ;; id X = id (dom (id X))" and "id X ;; id X = id (cod (id X))"
    using assms by (simp add: CatIdCompId CatIdDomCod)+
qed

definition
  inverse :: "('o,'m,'a) Category_scheme \<Rightarrow> 'm \<Rightarrow> 'm" ("Cinv\<index> _" [70]) where
  "inverse C f \<equiv> THE g . inverse_rel C f g"

lemma (in Category) inv2Inv:
  assumes "cinv f g"
  shows   "ciso f" and "Cinv f = g"
proof-
  show "ciso f" using assms by (auto simp add: isomorphism_def)
  hence "\<exists>! g . cinv f g" using assms by (auto simp add: InverseUnique)
  thus "Cinv f = g" using assms by (auto simp add: inverse_def)
qed

lemma (in Category) iso2Inv:
  assumes "ciso f"
  shows   "cinv f (Cinv f)"
proof-
  have "\<exists>! g . cinv f g" using assms by (auto simp add: InverseUnique isomorphism_def)
  thus ?thesis by (auto simp add:  inverse_def intro:theI')
qed

lemma (in Category) InvInv:
  assumes "ciso f"
  shows   "ciso (Cinv f)" and "(Cinv (Cinv f)) = f"
proof-
  have "cinv f (Cinv f)" using assms by (simp add: iso2Inv)
  hence "cinv (Cinv f) f" by (simp add: Inverse_relSym[of f])
  thus  "ciso (Cinv f)" and "Cinv (Cinv f) = f" by (auto simp add: inv2Inv)
qed

lemma (in Category) InvIsMor: "(cinv f g) \<Longrightarrow> (f \<in> mor \<and> g \<in> mor)"
  by (auto simp add: inverse_rel_def)

lemma (in Category) IsoIsMor: "ciso f \<Longrightarrow> f \<in> mor"
  by (auto simp add: InvIsMor dest: iso2Inv)

lemma (in Category) InvDomCod:
  assumes "ciso f"
  shows "dom (Cinv f) = cod f" and "cod (Cinv f) = dom f" and "Cinv f \<in> mor"
proof-
  have 1: "cinv f (Cinv f)" using assms by (auto simp add: iso2Inv)
  thus "dom (Cinv f) = cod f" by (auto simp add: inverse_rel_def)
  from 1 have "cinv (Cinv f) f" by (auto simp add: Inverse_relSym[of f])
  thus  "cod (Cinv f) = dom f" by (auto simp add: inverse_rel_def)
  show "Cinv f \<in> mor" using 1 by (auto simp add: inverse_rel_def)
qed

lemma (in Category) InvCompIso: "ciso f \<Longrightarrow> Cinv f \<approx>> f"
  by (auto simp add: IsoIsMor InvDomCod)

lemma (in Category) IsoInvId1 : "ciso f \<Longrightarrow> (Cinv f) ;; f = (id (cod f))"
by (auto dest: iso2Inv)

lemma (in Category) IsoInvId2 :  "ciso f \<Longrightarrow> f ;; (Cinv f) = (id (dom f))"
by (auto dest: iso2Inv)

lemma (in Category) IsoCompDef:
  assumes 1: "f \<approx>> g" and 2: "ciso f" and 3: "ciso g"
  shows "(Cinv g) \<approx>> (Cinv f)"
proof(rule CompDefinedI)
  show "Cinv g \<in> mor" and "Cinv f \<in> mor" using assms by (auto simp add: InvDomCod)
  have "cod (Cinv g) = dom g" using 3 by (simp add: InvDomCod)
  also have "... = cod f" using 1 by auto
  also have "... = dom (Cinv f)" using 2 by (simp add: InvDomCod)
  finally show "cod (Cinv g) = dom (Cinv f)" .
qed

lemma (in Category) IsoCompose:
  assumes 1: "f \<approx>> g" and 2: "ciso f" and 3: "ciso g"
  shows "ciso (f ;; g)" and "Cinv (f ;; g) = (Cinv g) ;; (Cinv f)"
proof-
  have  a: "(Cinv g) \<approx>> (Cinv f)" using assms by (simp add: IsoCompDef)
  hence b: "(Cinv g) ;; (Cinv f) maps (dom (Cinv g)) to (cod (Cinv f))" by (simp add: MapsToCompI)
  hence c: "(Cinv g) ;; (Cinv f) maps (cod g) to (dom f)" using 2 3 by (simp add: InvDomCod)
  have  d: "f ;; g maps (dom f) to (cod g)" using 1 by (simp add: Simps)
  have "cinv (f ;; g) ((Cinv g) ;; (Cinv f))"
  proof(auto simp add: inverse_rel_def)
    show "f ;; g \<approx>> (Cinv g) ;; (Cinv f)"
    proof(rule CompDefinedI)
      show "f ;; g \<in> mor" using d by auto
      show "(Cinv g) ;; (Cinv f) \<in> mor" using c by auto
      have "cod (f ;; g) = cod g" using d by auto
      also have "... = dom (Cinv g)" using assms by (simp add: InvDomCod)
      also have "... = dom ((Cinv g) ;; (Cinv f))" using b by auto
      finally show "cod (f ;; g) = dom ((Cinv g) ;; (Cinv f))" .
    qed
    show "f ;; g ;; ((Cinv g) ;; (Cinv f)) = id (dom (f ;; g))"
    proof-
      have e: "g \<approx>> (Cinv g)" using assms by (simp add: IsoCompInv)
      have f: "f \<in> mor" using 1 by auto
      have "(f ;; g) ;; ((Cinv g) ;; (Cinv f)) = (f ;; (g ;; (Cinv g))) ;; (Cinv f)"
        using 1 e a by (auto simp add: Cassoc CompDefComp)
      also have "... = f ;; (id (dom g)) ;; (Cinv f)" using 3 by (simp add: IsoInvId2)
      also have "... = f ;; id (cod f) ;; (Cinv f)" using 1 by (auto simp add: Simps)
      also have "... = f ;; (Cinv f)" using f by (auto simp add: Cidr)
      also have "... = id (dom f)" using 2 by (simp add: IsoInvId2)
      also have "... = id (dom (f ;; g))" using d by auto
      finally show ?thesis by simp
    qed
    show "((Cinv g) ;; (Cinv f)) ;; (f ;; g) = id (cod (f ;; g))"
    proof-
      have e: "(Cinv f) \<approx>> f" using assms by (simp add: InvCompIso)
      have f: "g \<in> mor" using 1 by auto
      have "((Cinv g) ;; (Cinv f)) ;; (f ;; g) = (Cinv g) ;; (((Cinv f) ;; f) ;; g)"
        using 1 e a by (auto simp add: Cassoc CompDefComp)
      also have "... = (Cinv g) ;; ((id (cod f)) ;; g)" using 2 by (simp add: IsoInvId1)
      also have "... = (Cinv g) ;; ((id (dom g)) ;; g)" using 1 by (auto simp add: Simps)
      also have "... = (Cinv g) ;; g" using f by (auto simp add: Cidl)
      also have "... = id (cod g)" using 3 by (simp add: IsoInvId1)
      also have "... = id (cod (f ;; g))" using d by auto
      finally show ?thesis by simp
    qed
  qed
  thus "ciso (f ;; g)" and "Cinv (f ;; g) = (Cinv g) ;; (Cinv f)" by (auto simp add: inv2Inv)
qed

definition "ObjIso C A B \<equiv> \<exists> k . (k maps\<^bsub>C\<^esub> A to B) \<and> ciso\<^bsub>C \<^esub>k"

definition
  UnitCategory :: "(unit, unit) Category" where
  "UnitCategory = MakeCat \<lparr>
      Obj = {()} ,
      Mor = {()} ,
      Dom = (\<lambda>f.()) ,
      Cod = (\<lambda>f.()) ,
      Id = (\<lambda>f.()) ,
      Comp = (\<lambda>f g. ())
  \<rparr>"

definition
  OppositeCategory :: "('o,'m,'a) Category_scheme \<Rightarrow> ('o,'m,'a) Category_scheme" ("Op _" [65] 65) where
  "OppositeCategory C \<equiv> \<lparr>
      Obj = Obj C ,
      Mor = Mor C ,
      Dom = Cod C ,
      Cod = Dom C ,
      Id  = Id C ,
      Comp = (\<lambda>f g. g ;;\<^bsub>C\<^esub> f),
      \<dots> = Category.more C
  \<rparr>"

lemma OpCatOpCat: "Op (Op C) = C"
  by (simp add: OppositeCategory_def)

lemma OpCatCatAx: "Category_axioms C \<Longrightarrow> Category_axioms (Op C)"
  by (simp add: OppositeCategory_def Category_axioms_def MapsTo_def CompDefined_def)

lemma OpCatCatExt: "ExtCategory C \<Longrightarrow> ExtCategory (Op C)"
  by (auto simp add: OppositeCategory_def ExtCategory_def MapsTo_def CompDefined_def extensional_def)

lemma OpCatCat: "Category C \<Longrightarrow> Category (Op C)"
  by (intro_locales, simp_all add: Category_def OpCatCatAx OpCatCatExt)

lemma MapsToOp: "f maps\<^bsub>C \<^esub>X to Y \<Longrightarrow> f maps\<^bsub>Op C \<^esub>Y to X"
by (simp add: MapsTo_def OppositeCategory_def)

lemma MapsToOpOp: "f maps\<^bsub>Op C \<^esub>X to Y \<Longrightarrow> f maps\<^bsub>C \<^esub>Y to X"
by (simp add: MapsTo_def OppositeCategory_def)

lemma CompDefOp: "f \<approx>>\<^bsub>C\<^esub> g \<Longrightarrow> g \<approx>>\<^bsub>Op C\<^esub> f"
by (simp add: CompDefined_def OppositeCategory_def)

end


(*
  File: CompleteOrder.thy
  Author: Bohua Zhan

  Results about Cauchy completeness and completeness of ordered fields.
*)

theory CompleteOrder
  imports SeqRing
begin

section \<open>Cauchy completeness\<close>

definition cauchy_complete_field :: "i \<Rightarrow> o" where [rewrite]:
  "cauchy_complete_field(R) \<longleftrightarrow> (is_ord_field(R) \<and> (\<forall>X\<in>seqs(R). cauchy(X) \<longrightarrow> converges(X)))"

lemma cauchy_completeD [forward]:
  "cauchy_complete_field(R) \<Longrightarrow> is_ord_field(R)"
  "is_sequence(X) \<Longrightarrow> cauchy(X) \<Longrightarrow> cauchy_complete_field(target_str(X)) \<Longrightarrow> converges(X)" by auto2+

lemma cauchy_completeI [forward]:
  "is_ord_field(R) \<Longrightarrow> \<forall>X\<in>seqs(R). cauchy(X) \<longrightarrow> converges(X) \<Longrightarrow> cauchy_complete_field(R)" by auto2
setup {* del_prfstep_thm @{thm cauchy_complete_field_def} *}

section \<open>Monotone convergence theorem\<close>

lemma seq_has_increment_induct [backward1]:
  "ord_ring_seq(X) \<Longrightarrow> R = target_str(X) \<Longrightarrow> k \<in>. \<nat> \<Longrightarrow> N \<in> nat \<Longrightarrow> a >\<^sub>R \<zero>\<^sub>R \<Longrightarrow>
   \<forall>k\<in>.\<nat>. \<exists>n\<ge>\<^sub>\<nat>k. X`n -\<^sub>R X`k \<ge>\<^sub>R a \<Longrightarrow> \<exists>n\<ge>\<^sub>\<nat>k. X`n -\<^sub>R X`k \<ge>\<^sub>R of_nat(R,N) *\<^sub>R a"
@proof
  @var_induct "N \<in> nat" arbitrary k @with
    @subgoal "N = N' +\<^sub>\<nat> 1"
      @obtain k1 where "k1\<ge>\<^sub>\<nat>k" "X`k1 -\<^sub>R X`k \<ge>\<^sub>R of_nat(R,N') *\<^sub>R a"
      @obtain k2 where "k2\<ge>\<^sub>\<nat>k1" "X`k2 -\<^sub>R X`k1 \<ge>\<^sub>R a"
      @have "X`k2 -\<^sub>R X`k = (X`k2 -\<^sub>R X`k1) +\<^sub>R (X`k1 -\<^sub>R X`k)"
      @have "(of_nat(R,N') +\<^sub>R 1\<^sub>R) *\<^sub>R a = a +\<^sub>R of_nat(R,N') *\<^sub>R a"
    @endgoal
  @end
@qed

lemma monotone_cauchy [forward]:
  "ord_field_seq(X) \<Longrightarrow> seq_incr(X) \<Longrightarrow> upper_bounded(X) \<Longrightarrow> R = target_str(X) \<Longrightarrow>
   is_archimedean(R) \<Longrightarrow> cauchy(X)"
@proof
  @contradiction
  @obtain a where "a >\<^sub>R \<zero>\<^sub>R" "\<forall>k\<in>.\<nat>. \<exists>n\<ge>\<^sub>\<nat>k. \<bar>X`n -\<^sub>R X`k\<bar>\<^sub>R \<ge>\<^sub>R a"
  @have "\<forall>k\<in>.\<nat>. \<exists>n\<ge>\<^sub>\<nat>k. X`n -\<^sub>R X`k \<ge>\<^sub>R a"
  @obtain "M\<in>.R" where "\<forall>n\<in>.\<nat>. X`n \<le>\<^sub>R M"
  @obtain "N\<in>nat" where "of_nat(R,N) *\<^sub>R a >\<^sub>R (M -\<^sub>R X`0)"
  @obtain n where "n \<ge>\<^sub>\<nat> 0" "X`n -\<^sub>R X`0 \<ge>\<^sub>R of_nat(R,N) *\<^sub>R a" @have "X`n \<le>\<^sub>R M"
@qed

lemma monotone_incr_converges [forward]:
  "is_sequence(X) \<Longrightarrow> seq_incr(X) \<Longrightarrow> upper_bounded(X) \<Longrightarrow> R = target_str(X) \<Longrightarrow>
   cauchy_complete_field(R) \<Longrightarrow> is_archimedean(R) \<Longrightarrow> converges(X)" by auto2

lemma monotone_decr_converges [forward]:
  "is_sequence(X) \<Longrightarrow> seq_decr(X) \<Longrightarrow> lower_bounded(X) \<Longrightarrow> R = target_str(X) \<Longrightarrow>
   cauchy_complete_field(R) \<Longrightarrow> is_archimedean(R) \<Longrightarrow> converges(X)"
@proof @have "upper_bounded(seq_neg(X))" @have "seq_incr(seq_neg(X))" @qed

section \<open>A simple test for vanishing of sequences\<close>

definition half_seq :: "i \<Rightarrow> o" where [rewrite]:
  "half_seq(X) \<longleftrightarrow> (let R = target_str(X) in \<forall>n\<in>.\<nat>. \<bar>X`(n +\<^sub>\<nat> 1)\<bar>\<^sub>R \<le>\<^sub>R \<bar>X`n\<bar>\<^sub>R /\<^sub>R 2\<^sub>R)"

lemma half_seqD:
  "half_seq(X) \<Longrightarrow> R = target_str(X) \<Longrightarrow> n \<in>. \<nat> \<Longrightarrow> \<bar>X`(n +\<^sub>\<nat> 1)\<bar>\<^sub>R \<le>\<^sub>R \<bar>X`n\<bar>\<^sub>R /\<^sub>R 2\<^sub>R" by auto2
setup {* add_forward_prfstep_cond @{thm half_seqD} [with_term "\<bar>?X`(?n +\<^sub>\<nat> 1)\<bar>\<^sub>target_str(?X)"] *}

lemma half_seqI [backward]:
  "R = target_str(X) \<Longrightarrow> \<forall>n\<in>.\<nat>. \<bar>X`(n +\<^sub>\<nat> 1)\<bar>\<^sub>R \<le>\<^sub>R \<bar>X`n\<bar>\<^sub>R /\<^sub>R 2\<^sub>R \<Longrightarrow> half_seq(X)" by auto2
setup {* del_prfstep_thm @{thm half_seq_def} *}

lemma ord_field_divide_le_trans1 [backward1]:
  "is_ord_field(R) \<Longrightarrow> d \<in>. R \<Longrightarrow> c >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> e >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> a \<le>\<^sub>R b /\<^sub>R c \<Longrightarrow>
   b \<le>\<^sub>R d /\<^sub>R e \<Longrightarrow> a \<le>\<^sub>R d /\<^sub>R (e *\<^sub>R c)"
@proof @have "a *\<^sub>R c \<le>\<^sub>R b" @have "a \<le>\<^sub>R d /\<^sub>R e /\<^sub>R c" @qed

lemma half_seq_induct [resolve]:
  "ord_field_seq(X) \<Longrightarrow> R = target_str(X) \<Longrightarrow> half_seq(X) \<Longrightarrow> n \<in> nat \<Longrightarrow>
   \<bar>X`n\<bar>\<^sub>R \<le>\<^sub>R \<bar>X`0\<bar>\<^sub>R /\<^sub>R (2\<^sub>R ^\<^sub>R n)"
@proof @var_induct "n \<in> nat" @qed
setup {* del_prfstep_thm @{thm ord_field_divide_le_trans1} *}

lemma half_seq_abs_decr [forward]:
  "ord_field_seq(X) \<Longrightarrow> R = target_str(X) \<Longrightarrow> half_seq(X) \<Longrightarrow> seq_abs_decr(X)"
@proof @have "\<forall>n\<in>.\<nat>. \<bar>X`(n +\<^sub>\<nat> 1)\<bar>\<^sub>R \<le>\<^sub>R \<bar>X`n\<bar>\<^sub>R" @qed

lemma ord_field_divide_le_trans2 [forward]:
  "is_ord_field(R) \<Longrightarrow> b \<in>. R \<Longrightarrow> a >\<^sub>R b /\<^sub>R c \<Longrightarrow> d \<le>\<^sub>R b /\<^sub>R a \<Longrightarrow> a >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> c >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> c >\<^sub>R d"
@proof
  @have "a *\<^sub>R c >\<^sub>R b" @have "d *\<^sub>R a \<le>\<^sub>R b" @have "a *\<^sub>R c >\<^sub>R a *\<^sub>R d"
@qed

lemma half_seq_vanishes [forward]:
  "ord_field_seq(X) \<Longrightarrow> R = target_str(X) \<Longrightarrow> half_seq(X) \<Longrightarrow> is_archimedean(R) \<Longrightarrow> vanishes(X)"
@proof
  @have "\<forall>r. r >\<^sub>R \<zero>\<^sub>R \<longrightarrow> (\<exists>k\<in>.\<nat>. \<forall>n\<ge>\<^sub>\<nat>k. \<bar>X`n\<bar>\<^sub>R <\<^sub>R r)" @with
    @obtain "k\<in>nat" where "2\<^sub>R ^\<^sub>R k >\<^sub>R \<bar>X`0\<bar>\<^sub>R /\<^sub>R r"
    @have "\<forall>n\<ge>\<^sub>\<nat>k. \<bar>X`n\<bar>\<^sub>R <\<^sub>R r" @with
      @have "\<bar>X`k\<bar>\<^sub>R \<le>\<^sub>R \<bar>X`0\<bar>\<^sub>R /\<^sub>R (2\<^sub>R ^\<^sub>R k)"
      @have "\<bar>X`n\<bar>\<^sub>R \<le>\<^sub>R \<bar>X`k\<bar>\<^sub>R" @end @end
@qed
setup {* del_prfstep_thm @{thm ord_field_divide_le_trans2} *}

section \<open>Dedekind cut\<close>

(* A dedekind cut is a set that is closed downward and has no greatest element *)
definition dedekind_cut :: "i \<Rightarrow> i \<Rightarrow> o" where [rewrite]:
  "dedekind_cut(R,U) \<longleftrightarrow> (U \<noteq> \<emptyset> \<and> U \<subset> carrier(R) \<and> (\<forall>a\<in>U. \<forall>b \<le>\<^sub>R a. b \<in> U) \<and> (\<forall>a\<in>U. \<exists>b >\<^sub>R a. b\<in>U))"

lemma dedekind_cutI1 [forward]:
  "dedekind_cut(R,U) \<Longrightarrow> a \<in> U \<Longrightarrow> \<forall>b \<le>\<^sub>R a. b \<in> U" by auto2

lemma dedekind_cutI2 [backward2]:
  "dedekind_cut(R,U) \<Longrightarrow> a \<in> U \<Longrightarrow> \<exists>b >\<^sub>R a. b \<in> U" by auto2

lemma dedekind_cutI_ex [resolve]:
  "dedekind_cut(R,U) \<Longrightarrow> \<exists>x\<in>.R. x \<in> U" by auto2

lemma dedekind_cutI_ex2 [resolve]:
  "dedekind_cut(R,U) \<Longrightarrow> \<exists>x\<in>.R. x \<notin> U" by auto2
setup {* del_prfstep_thm_eqforward @{thm dedekind_cut_def} *}

(* For any dedekind cut, we define two sequences converging to the boundary point. *)
definition DCSeqs :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "DCSeqs(R,U) = Seq_rec2(R,
    SOME a\<in>.R. a \<in> U, \<lambda>x p q. if avg(R,p,q) \<notin> U then p else avg(R,p,q),
    SOME b\<in>.R. b \<notin> U, \<lambda>x p q. if avg(R,p,q) \<notin> U then avg(R,p,q) else q)"

lemma DCSeqs_type [forward]:
  "is_ord_field(R) \<Longrightarrow> dedekind_cut(R,U) \<Longrightarrow> A = fst(DCSeqs(R,U)) \<Longrightarrow> B = snd(DCSeqs(R,U)) \<Longrightarrow>
   A \<in> seqs(R) \<and> B \<in> seqs(R) \<and> A`0 \<in> U \<and> B`0 \<notin> U" by auto2

lemma DCSeqs_eval1 [rewrite]:
  "is_ord_field(R) \<Longrightarrow> n \<in>. \<nat> \<Longrightarrow> dedekind_cut(R,U) \<Longrightarrow> A = fst(DCSeqs(R,U)) \<Longrightarrow> B = snd(DCSeqs(R,U)) \<Longrightarrow>
   A`(n +\<^sub>\<nat> 1) = (if avg(R,A`n,B`n) \<notin> U then A`n else avg(R,A`n,B`n))" by auto2

lemma DCSeqs_eval2 [rewrite]:
  "is_ord_field(R) \<Longrightarrow> n \<in>. \<nat> \<Longrightarrow> dedekind_cut(R,U) \<Longrightarrow> A = fst(DCSeqs(R,U)) \<Longrightarrow> B = snd(DCSeqs(R,U)) \<Longrightarrow>
   B`(n +\<^sub>\<nat> 1) = (if avg(R,A`n,B`n) \<notin> U then avg(R,A`n,B`n) else B`n)" by auto2
setup {* del_prfstep_thm @{thm DCSeqs_def} *}

lemma DCSeqs_le [backward]:
  "is_ord_field(R) \<Longrightarrow> is_archimedean(R) \<Longrightarrow> A = fst(DCSeqs(R,U)) \<Longrightarrow> B = snd(DCSeqs(R,U)) \<Longrightarrow>
   n \<in> source(A) \<Longrightarrow> n \<in> source(B) \<Longrightarrow> dedekind_cut(R,U) \<Longrightarrow> A`n \<le>\<^sub>R B`n"
@proof @var_induct "n \<in> nat" @qed

lemma dedekind_complete [resolve]:
  "cauchy_complete_field(R) \<Longrightarrow> is_archimedean(R) \<Longrightarrow> dedekind_cut(R,U) \<Longrightarrow> \<exists>x\<in>.R. \<forall>y\<in>.R. y <\<^sub>R x \<longleftrightarrow> y \<in> U"
@proof
  @let "A = fst(DCSeqs(R,U))" "B = snd(DCSeqs(R,U))"
  @have "converges(A)" @with
    @have "seq_incr(A)" @with @have "\<forall>n\<in>.\<nat>. A`(n +\<^sub>\<nat> 1) \<ge>\<^sub>R A`n" @end
    @have "upper_bounded(A)" @with
      @have "\<forall>n\<in>.\<nat>. A`n \<le>\<^sub>R B`0" @with @var_induct "n \<in>. \<nat>" @end @end @end
  @have "converges(B)" @with
    @have "seq_decr(B)" @with @have "\<forall>n\<in>.\<nat>. B`(n +\<^sub>\<nat> 1) \<le>\<^sub>R B`n" @end
    @have "lower_bounded(B)" @with
      @have "\<forall>n\<in>.\<nat>. B`n \<ge>\<^sub>R A`0" @with @var_induct "n \<in>. \<nat>" @end @end @end
  @obtain x where "converges_to(B,x)"
  @let "S = seq_ring(R)"
  @have "vanishes(B -\<^sub>S A)" @with @have "half_seq(B -\<^sub>S A)" @end
  @have (@rule) "\<forall>n\<in>nat. A`n \<in> U" @with @var_induct "n \<in> nat" @end
  @have (@rule) "\<forall>n\<in>nat. B`n \<notin> U" @with @var_induct "n \<in> nat" @end
  @have "\<forall>y\<in>.R. y <\<^sub>R x \<longleftrightarrow> y \<in> U" @with
    @case "y <\<^sub>R x" @with @obtain "n\<in>nat" where "y <\<^sub>R A`n" @end
    @case "y \<in> U" @with
      @have "x \<in> U" @obtain x' where "x' >\<^sub>R x" "x' \<in> U"
      @obtain "n\<in>nat" where "x' >\<^sub>R B`n" @have "B`n \<notin> U"
    @end
  @end
@qed

section \<open>Least upper bound property\<close>

lemma least_upper_bound_complete [forward]:
  "cauchy_complete_field(R) \<Longrightarrow> is_archimedean(R) \<Longrightarrow> S \<noteq> \<emptyset> \<Longrightarrow> upper_bound(R,S) \<noteq> \<emptyset> \<Longrightarrow> has_sup(R,S)"
@proof
  @let "U = carrier(R) \<midarrow> upper_bound(R,S)"
  @have "dedekind_cut(R,U)" @with
    @have "U \<noteq> \<emptyset>" @with
      @obtain "x \<in> S" @obtain y where "y <\<^sub>R x" @have "y \<in> U" @end
    @have "U \<noteq> carrier(R)" @with
      @obtain "z \<in> upper_bound(R,S)" @have "z \<notin> U" @end
    @have "\<forall>a\<in>U. \<exists>b >\<^sub>R a. b \<in> U" @with
      @obtain "c \<in> S" where "a <\<^sub>R c" @obtain b where "a <\<^sub>R b \<and> b <\<^sub>R c" @have "b \<in> U" @end @end
  @obtain "y\<in>.R" where "\<forall>z\<in>.R. z <\<^sub>R y \<longleftrightarrow> z \<in> U"
  @have "y \<notin> U" @have "y \<in> upper_bound(R,S)"
  @have "has_sup(R,S) \<and> sup(R,S) = y"
@qed

lemma complete_to_linear_continuum [forward]:
  "cauchy_complete_field(R) \<Longrightarrow> is_archimedean(R) \<Longrightarrow> linear_continuum(R)"
@proof @have "\<forall>S. S \<noteq> \<emptyset> \<longrightarrow> upper_bound(R,S) \<noteq> \<emptyset> \<longrightarrow> has_sup(R,S)" @qed

end


(*  Title:      HOL/Algebra/Ring.thy
    Author:     Clemens Ballarin, started 9 December 1996
    Copyright:  Clemens Ballarin
*)

theory Ring
imports FiniteProduct
begin

section {* The Algebraic Hierarchy of Rings *}

subsection {* Abelian Groups *}

record 'a ring = "'a monoid" +
  zero :: 'a ("\<zero>\<index>")
  add :: "['a, 'a] => 'a" (infixl "\<oplus>\<index>" 65)

text {* Derived operations. *}

definition
  a_inv :: "[('a, 'm) ring_scheme, 'a ] => 'a" ("\<ominus>\<index> _" [81] 80)
  where "a_inv R = m_inv \<lparr>carrier = carrier R, mult = add R, one = zero R\<rparr>"

definition
  a_minus :: "[('a, 'm) ring_scheme, 'a, 'a] => 'a" (infixl "\<ominus>\<index>" 65)
  where "[| x \<in> carrier R; y \<in> carrier R |] ==> x \<ominus>\<^bsub>R\<^esub> y = x \<oplus>\<^bsub>R\<^esub> (\<ominus>\<^bsub>R\<^esub> y)"

locale abelian_monoid =
  fixes G (structure)
  assumes a_comm_monoid:
     "comm_monoid \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"

definition
  finsum :: "[('b, 'm) ring_scheme, 'a => 'b, 'a set] => 'b" where
  "finsum G = finprod \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"

syntax
  "_finsum" :: "index => idt => 'a set => 'b => 'b"
      ("(3\<Oplus>__:_. _)" [1000, 0, 51, 10] 10)
syntax (xsymbols)
  "_finsum" :: "index => idt => 'a set => 'b => 'b"
      ("(3\<Oplus>__\<in>_. _)" [1000, 0, 51, 10] 10)
syntax (HTML output)
  "_finsum" :: "index => idt => 'a set => 'b => 'b"
      ("(3\<Oplus>__\<in>_. _)" [1000, 0, 51, 10] 10)
translations
  "\<Oplus>\<index>i:A. b" == "CONST finsum \<struct>\<index> (%i. b) A"
  -- {* Beware of argument permutation! *}

locale abelian_group = abelian_monoid +
  assumes a_comm_group:
     "comm_group \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"

subsection {* Basic Properties *}

lemma abelian_monoidI:
  fixes R (structure)
  assumes a_closed:
      "!!x y. [| x \<in> carrier R; y \<in> carrier R |] ==> x \<oplus> y \<in> carrier R"
    and zero_closed: "\<zero> \<in> carrier R"
    and a_assoc:
      "!!x y z. [| x \<in> carrier R; y \<in> carrier R; z \<in> carrier R |] ==>
      (x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
    and l_zero: "!!x. x \<in> carrier R ==> \<zero> \<oplus> x = x"
    and a_comm:
      "!!x y. [| x \<in> carrier R; y \<in> carrier R |] ==> x \<oplus> y = y \<oplus> x"
  shows "abelian_monoid R"
  by (auto intro!: abelian_monoid.intro comm_monoidI intro: assms)

lemma abelian_groupI:
  fixes R (structure)
  assumes a_closed:
      "!!x y. [| x \<in> carrier R; y \<in> carrier R |] ==> x \<oplus> y \<in> carrier R"
    and zero_closed: "zero R \<in> carrier R"
    and a_assoc:
      "!!x y z. [| x \<in> carrier R; y \<in> carrier R; z \<in> carrier R |] ==>
      (x \<oplus> y) \<oplus> z = x \<oplus> (y \<oplus> z)"
    and a_comm:
      "!!x y. [| x \<in> carrier R; y \<in> carrier R |] ==> x \<oplus> y = y \<oplus> x"
    and l_zero: "!!x. x \<in> carrier R ==> \<zero> \<oplus> x = x"
    and l_inv_ex: "!!x. x \<in> carrier R ==> EX y : carrier R. y \<oplus> x = \<zero>"
  shows "abelian_group R"
  by (auto intro!: abelian_group.intro abelian_monoidI
      abelian_group_axioms.intro comm_monoidI comm_groupI
    intro: assms)

lemma (in abelian_monoid) a_monoid:
  "monoid \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
by (rule comm_monoid.axioms, rule a_comm_monoid)

lemma (in abelian_group) a_group:
  "group \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
  by (simp add: group_def a_monoid)
    (simp add: comm_group.axioms group.axioms a_comm_group)

lemmas monoid_record_simps = partial_object.simps monoid.simps

text {* Transfer facts from multiplicative structures via interpretation. *}

sublocale abelian_monoid <
  add!: monoid "\<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
  where "carrier \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = carrier G"
    and "mult \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = add G"
    and "one \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = zero G"
  by (rule a_monoid) auto

context abelian_monoid begin

lemmas a_closed = add.m_closed
lemmas zero_closed = add.one_closed
lemmas a_assoc = add.m_assoc
lemmas l_zero = add.l_one
lemmas r_zero = add.r_one
lemmas minus_unique = add.inv_unique

end

sublocale abelian_monoid <
  add!: comm_monoid "\<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
  where "carrier \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = carrier G"
    and "mult \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = add G"
    and "one \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = zero G"
    and "finprod \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = finsum G"
  by (rule a_comm_monoid) (auto simp: finsum_def)

context abelian_monoid begin

lemmas a_comm = add.m_comm
lemmas a_lcomm = add.m_lcomm
lemmas a_ac = a_assoc a_comm a_lcomm

lemmas finsum_empty = add.finprod_empty
lemmas finsum_insert = add.finprod_insert
lemmas finsum_zero = add.finprod_one
lemmas finsum_closed = add.finprod_closed
lemmas finsum_Un_Int = add.finprod_Un_Int
lemmas finsum_Un_disjoint = add.finprod_Un_disjoint
lemmas finsum_addf = add.finprod_multf
lemmas finsum_cong' = add.finprod_cong'
lemmas finsum_0 = add.finprod_0
lemmas finsum_Suc = add.finprod_Suc
lemmas finsum_Suc2 = add.finprod_Suc2
lemmas finsum_add = add.finprod_mult

lemmas finsum_cong = add.finprod_cong
text {*Usually, if this rule causes a failed congruence proof error,
   the reason is that the premise @{text "g \<in> B -> carrier G"} cannot be shown.
   Adding @{thm [source] Pi_def} to the simpset is often useful. *}

lemmas finsum_reindex = add.finprod_reindex

(* The following would be wrong.  Needed is the equivalent of (^) for addition,
  or indeed the canonical embedding from Nat into the monoid.

lemma finsum_const:
  assumes fin [simp]: "finite A"
      and a [simp]: "a : carrier G"
    shows "finsum G (%x. a) A = a (^) card A"
  using fin apply induct
  apply force
  apply (subst finsum_insert)
  apply auto
  apply (force simp add: Pi_def)
  apply (subst m_comm)
  apply auto
done
*)

lemmas finsum_singleton = add.finprod_singleton

end

sublocale abelian_group <
  add!: group "\<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
  where "carrier \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = carrier G"
    and "mult \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = add G"
    and "one \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = zero G"
    and "m_inv \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = a_inv G"
  by (rule a_group) (auto simp: m_inv_def a_inv_def)

context abelian_group
begin

lemmas a_inv_closed = add.inv_closed

lemma minus_closed [intro, simp]:
  "[| x \<in> carrier G; y \<in> carrier G |] ==> x \<ominus> y \<in> carrier G"
  by (simp add: a_minus_def)

lemmas a_l_cancel = add.l_cancel
lemmas a_r_cancel = add.r_cancel
lemmas l_neg = add.l_inv [simp del]
lemmas r_neg = add.r_inv [simp del]
lemmas minus_zero = add.inv_one
lemmas minus_minus = add.inv_inv
lemmas a_inv_inj = add.inv_inj
lemmas minus_equality = add.inv_equality

end

sublocale abelian_group <
  add!: comm_group "\<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
  where "carrier \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = carrier G"
    and "mult \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = add G"
    and "one \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = zero G"
    and "m_inv \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = a_inv G"
    and "finprod \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr> = finsum G"
  by (rule a_comm_group) (auto simp: m_inv_def a_inv_def finsum_def)

lemmas (in abelian_group) minus_add = add.inv_mult

text {* Derive an @{text "abelian_group"} from a @{text "comm_group"} *}

lemma comm_group_abelian_groupI:
  fixes G (structure)
  assumes cg: "comm_group \<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
  shows "abelian_group G"
proof -
  interpret comm_group "\<lparr>carrier = carrier G, mult = add G, one = zero G\<rparr>"
    by (rule cg)
  show "abelian_group G" ..
qed

subsection {* Rings: Basic Definitions *}

locale ring = abelian_group R + monoid R for R (structure) +
  assumes l_distr: "[| x \<in> carrier R; y \<in> carrier R; z \<in> carrier R |]
      ==> (x \<oplus> y) \<otimes> z = x \<otimes> z \<oplus> y \<otimes> z"
    and r_distr: "[| x \<in> carrier R; y \<in> carrier R; z \<in> carrier R |]
      ==> z \<otimes> (x \<oplus> y) = z \<otimes> x \<oplus> z \<otimes> y"

locale cring = ring + comm_monoid R

locale "domain" = cring +
  assumes one_not_zero [simp]: "\<one> ~= \<zero>"
    and integral: "[| a \<otimes> b = \<zero>; a \<in> carrier R; b \<in> carrier R |] ==>
                  a = \<zero> | b = \<zero>"

locale field = "domain" +
  assumes field_Units: "Units R = carrier R - {\<zero>}"

subsection {* Rings *}

lemma ringI:
  fixes R (structure)
  assumes abelian_group: "abelian_group R"
    and monoid: "monoid R"
    and l_distr: "!!x y z. [| x \<in> carrier R; y \<in> carrier R; z \<in> carrier R |]
      ==> (x \<oplus> y) \<otimes> z = x \<otimes> z \<oplus> y \<otimes> z"
    and r_distr: "!!x y z. [| x \<in> carrier R; y \<in> carrier R; z \<in> carrier R |]
      ==> z \<otimes> (x \<oplus> y) = z \<otimes> x \<oplus> z \<otimes> y"
  shows "ring R"
  by (auto intro: ring.intro
    abelian_group.axioms ring_axioms.intro assms)

context ring begin

lemma is_abelian_group: "abelian_group R" ..

lemma is_monoid: "monoid R"
  by (auto intro!: monoidI m_assoc)

lemma is_ring: "ring R"
  by (rule ring_axioms)

end

lemmas ring_record_simps = monoid_record_simps ring.simps

lemma cringI:
  fixes R (structure)
  assumes abelian_group: "abelian_group R"
    and comm_monoid: "comm_monoid R"
    and l_distr: "!!x y z. [| x \<in> carrier R; y \<in> carrier R; z \<in> carrier R |]
      ==> (x \<oplus> y) \<otimes> z = x \<otimes> z \<oplus> y \<otimes> z"
  shows "cring R"
proof (intro cring.intro ring.intro)
  show "ring_axioms R"
    -- {* Right-distributivity follows from left-distributivity and
          commutativity. *}
  proof (rule ring_axioms.intro)
    fix x y z
    assume R: "x \<in> carrier R" "y \<in> carrier R" "z \<in> carrier R"
    note [simp] = comm_monoid.axioms [OF comm_monoid]
      abelian_group.axioms [OF abelian_group]
      abelian_monoid.a_closed

    from R have "z \<otimes> (x \<oplus> y) = (x \<oplus> y) \<otimes> z"
      by (simp add: comm_monoid.m_comm [OF comm_monoid.intro])
    also from R have "... = x \<otimes> z \<oplus> y \<otimes> z" by (simp add: l_distr)
    also from R have "... = z \<otimes> x \<oplus> z \<otimes> y"
      by (simp add: comm_monoid.m_comm [OF comm_monoid.intro])
    finally show "z \<otimes> (x \<oplus> y) = z \<otimes> x \<oplus> z \<otimes> y" .
  qed (rule l_distr)
qed (auto intro: cring.intro
  abelian_group.axioms comm_monoid.axioms ring_axioms.intro assms)

(*
lemma (in cring) is_comm_monoid:
  "comm_monoid R"
  by (auto intro!: comm_monoidI m_assoc m_comm)
*)

lemma (in cring) is_cring:
  "cring R" by (rule cring_axioms)

subsubsection {* Normaliser for Rings *}

lemma (in abelian_group) r_neg2:
  "[| x \<in> carrier G; y \<in> carrier G |] ==> x \<oplus> (\<ominus> x \<oplus> y) = y"
proof -
  assume G: "x \<in> carrier G" "y \<in> carrier G"
  then have "(x \<oplus> \<ominus> x) \<oplus> y = y"
    by (simp only: r_neg l_zero)
  with G show ?thesis
    by (simp add: a_ac)
qed

lemma (in abelian_group) r_neg1:
  "[| x \<in> carrier G; y \<in> carrier G |] ==> \<ominus> x \<oplus> (x \<oplus> y) = y"
proof -
  assume G: "x \<in> carrier G" "y \<in> carrier G"
  then have "(\<ominus> x \<oplus> x) \<oplus> y = y"
    by (simp only: l_neg l_zero)
  with G show ?thesis by (simp add: a_ac)
qed

context ring begin

text {*
  The following proofs are from Jacobson, Basic Algebra I, pp.~88--89.
*}

lemma l_null [simp]:
  "x \<in> carrier R ==> \<zero> \<otimes> x = \<zero>"
proof -
  assume R: "x \<in> carrier R"
  then have "\<zero> \<otimes> x \<oplus> \<zero> \<otimes> x = (\<zero> \<oplus> \<zero>) \<otimes> x"
    by (simp add: l_distr del: l_zero r_zero)
  also from R have "... = \<zero> \<otimes> x \<oplus> \<zero>" by simp
  finally have "\<zero> \<otimes> x \<oplus> \<zero> \<otimes> x = \<zero> \<otimes> x \<oplus> \<zero>" .
  with R show ?thesis by (simp del: r_zero)
qed

lemma r_null [simp]:
  "x \<in> carrier R ==> x \<otimes> \<zero> = \<zero>"
proof -
  assume R: "x \<in> carrier R"
  then have "x \<otimes> \<zero> \<oplus> x \<otimes> \<zero> = x \<otimes> (\<zero> \<oplus> \<zero>)"
    by (simp add: r_distr del: l_zero r_zero)
  also from R have "... = x \<otimes> \<zero> \<oplus> \<zero>" by simp
  finally have "x \<otimes> \<zero> \<oplus> x \<otimes> \<zero> = x \<otimes> \<zero> \<oplus> \<zero>" .
  with R show ?thesis by (simp del: r_zero)
qed

lemma l_minus:
  "[| x \<in> carrier R; y \<in> carrier R |] ==> \<ominus> x \<otimes> y = \<ominus> (x \<otimes> y)"
proof -
  assume R: "x \<in> carrier R" "y \<in> carrier R"
  then have "(\<ominus> x) \<otimes> y \<oplus> x \<otimes> y = (\<ominus> x \<oplus> x) \<otimes> y" by (simp add: l_distr)
  also from R have "... = \<zero>" by (simp add: l_neg)
  finally have "(\<ominus> x) \<otimes> y \<oplus> x \<otimes> y = \<zero>" .
  with R have "(\<ominus> x) \<otimes> y \<oplus> x \<otimes> y \<oplus> \<ominus> (x \<otimes> y) = \<zero> \<oplus> \<ominus> (x \<otimes> y)" by simp
  with R show ?thesis by (simp add: a_assoc r_neg)
qed

lemma r_minus:
  "[| x \<in> carrier R; y \<in> carrier R |] ==> x \<otimes> \<ominus> y = \<ominus> (x \<otimes> y)"
proof -
  assume R: "x \<in> carrier R" "y \<in> carrier R"
  then have "x \<otimes> (\<ominus> y) \<oplus> x \<otimes> y = x \<otimes> (\<ominus> y \<oplus> y)" by (simp add: r_distr)
  also from R have "... = \<zero>" by (simp add: l_neg)
  finally have "x \<otimes> (\<ominus> y) \<oplus> x \<otimes> y = \<zero>" .
  with R have "x \<otimes> (\<ominus> y) \<oplus> x \<otimes> y \<oplus> \<ominus> (x \<otimes> y) = \<zero> \<oplus> \<ominus> (x \<otimes> y)" by simp
  with R show ?thesis by (simp add: a_assoc r_neg )
qed

end

lemma (in abelian_group) minus_eq:
  "[| x \<in> carrier G; y \<in> carrier G |] ==> x \<ominus> y = x \<oplus> \<ominus> y"
  by (simp only: a_minus_def)

text {* Setup algebra method:
  compute distributive normal form in locale contexts *}

ML_file "ringsimp.ML"

attribute_setup algebra = {*
  Scan.lift ((Args.add >> K true || Args.del >> K false) --| Args.colon || Scan.succeed true)
    -- Scan.lift Args.name -- Scan.repeat Args.term
    >> (fn ((b, n), ts) => if b then Ringsimp.add_struct (n, ts) else Ringsimp.del_struct (n, ts))
*} "theorems controlling algebra method"

method_setup algebra = {*
  Scan.succeed (SIMPLE_METHOD' o Ringsimp.algebra_tac)
*} "normalisation of algebraic structure"

lemmas (in ring) ring_simprules
  [algebra ring "zero R" "add R" "a_inv R" "a_minus R" "one R" "mult R"] =
  a_closed zero_closed a_inv_closed minus_closed m_closed one_closed
  a_assoc l_zero l_neg a_comm m_assoc l_one l_distr minus_eq
  r_zero r_neg r_neg2 r_neg1 minus_add minus_minus minus_zero
  a_lcomm r_distr l_null r_null l_minus r_minus

lemmas (in cring)
  [algebra del: ring "zero R" "add R" "a_inv R" "a_minus R" "one R" "mult R"] =
  _

lemmas (in cring) cring_simprules
  [algebra add: cring "zero R" "add R" "a_inv R" "a_minus R" "one R" "mult R"] =
  a_closed zero_closed a_inv_closed minus_closed m_closed one_closed
  a_assoc l_zero l_neg a_comm m_assoc l_one l_distr m_comm minus_eq
  r_zero r_neg r_neg2 r_neg1 minus_add minus_minus minus_zero
  a_lcomm m_lcomm r_distr l_null r_null l_minus r_minus

lemma (in cring) nat_pow_zero:
  "(n::nat) ~= 0 ==> \<zero> (^) n = \<zero>"
  by (induct n) simp_all

context ring begin

lemma one_zeroD:
  assumes onezero: "\<one> = \<zero>"
  shows "carrier R = {\<zero>}"
proof (rule, rule)
  fix x
  assume xcarr: "x \<in> carrier R"
  from xcarr have "x = x \<otimes> \<one>" by simp
  with onezero have "x = x \<otimes> \<zero>" by simp
  with xcarr have "x = \<zero>" by simp
  then show "x \<in> {\<zero>}" by fast
qed fast

lemma one_zeroI:
  assumes carrzero: "carrier R = {\<zero>}"
  shows "\<one> = \<zero>"
proof -
  from one_closed and carrzero
      show "\<one> = \<zero>" by simp
qed

lemma carrier_one_zero: "(carrier R = {\<zero>}) = (\<one> = \<zero>)"
  apply rule
   apply (erule one_zeroI)
  apply (erule one_zeroD)
  done

lemma carrier_one_not_zero: "(carrier R \<noteq> {\<zero>}) = (\<one> \<noteq> \<zero>)"
  by (simp add: carrier_one_zero)

end

text {* Two examples for use of method algebra *}

lemma
  fixes R (structure) and S (structure)
  assumes "ring R" "cring S"
  assumes RS: "a \<in> carrier R" "b \<in> carrier R" "c \<in> carrier S" "d \<in> carrier S"
  shows "a \<oplus> \<ominus> (a \<oplus> \<ominus> b) = b & c \<otimes>\<^bsub>S\<^esub> d = d \<otimes>\<^bsub>S\<^esub> c"
proof -
  interpret ring R by fact
  interpret cring S by fact
  from RS show ?thesis by algebra
qed

lemma
  fixes R (structure)
  assumes "ring R"
  assumes R: "a \<in> carrier R" "b \<in> carrier R"
  shows "a \<ominus> (a \<ominus> b) = b"
proof -
  interpret ring R by fact
  from R show ?thesis by algebra
qed

subsubsection {* Sums over Finite Sets *}

lemma (in ring) finsum_ldistr:
  "[| finite A; a \<in> carrier R; f \<in> A -> carrier R |] ==>
   finsum R f A \<otimes> a = finsum R (%i. f i \<otimes> a) A"
proof (induct set: finite)
  case empty then show ?case by simp
next
  case (insert x F) then show ?case by (simp add: Pi_def l_distr)
qed

lemma (in ring) finsum_rdistr:
  "[| finite A; a \<in> carrier R; f \<in> A -> carrier R |] ==>
   a \<otimes> finsum R f A = finsum R (%i. a \<otimes> f i) A"
proof (induct set: finite)
  case empty then show ?case by simp
next
  case (insert x F) then show ?case by (simp add: Pi_def r_distr)
qed

subsection {* Integral Domains *}

context "domain" begin

lemma zero_not_one [simp]:
  "\<zero> ~= \<one>"
  by (rule not_sym) simp

lemma integral_iff: (* not by default a simp rule! *)
  "[| a \<in> carrier R; b \<in> carrier R |] ==> (a \<otimes> b = \<zero>) = (a = \<zero> | b = \<zero>)"
proof
  assume "a \<in> carrier R" "b \<in> carrier R" "a \<otimes> b = \<zero>"
  then show "a = \<zero> | b = \<zero>" by (simp add: integral)
next
  assume "a \<in> carrier R" "b \<in> carrier R" "a = \<zero> | b = \<zero>"
  then show "a \<otimes> b = \<zero>" by auto
qed

lemma m_lcancel:
  assumes prem: "a ~= \<zero>"
    and R: "a \<in> carrier R" "b \<in> carrier R" "c \<in> carrier R"
  shows "(a \<otimes> b = a \<otimes> c) = (b = c)"
proof
  assume eq: "a \<otimes> b = a \<otimes> c"
  with R have "a \<otimes> (b \<ominus> c) = \<zero>" by algebra
  with R have "a = \<zero> | (b \<ominus> c) = \<zero>" by (simp add: integral_iff)
  with prem and R have "b \<ominus> c = \<zero>" by auto
  with R have "b = b \<ominus> (b \<ominus> c)" by algebra
  also from R have "b \<ominus> (b \<ominus> c) = c" by algebra
  finally show "b = c" .
next
  assume "b = c" then show "a \<otimes> b = a \<otimes> c" by simp
qed

lemma m_rcancel:
  assumes prem: "a ~= \<zero>"
    and R: "a \<in> carrier R" "b \<in> carrier R" "c \<in> carrier R"
  shows conc: "(b \<otimes> a = c \<otimes> a) = (b = c)"
proof -
  from prem and R have "(a \<otimes> b = a \<otimes> c) = (b = c)" by (rule m_lcancel)
  with R show ?thesis by algebra
qed

end

subsection {* Fields *}

text {* Field would not need to be derived from domain, the properties
  for domain follow from the assumptions of field *}
lemma (in cring) cring_fieldI:
  assumes field_Units: "Units R = carrier R - {\<zero>}"
  shows "field R"
proof
  from field_Units have "\<zero> \<notin> Units R" by fast
  moreover have "\<one> \<in> Units R" by fast
  ultimately show "\<one> \<noteq> \<zero>" by force
next
  fix a b
  assume acarr: "a \<in> carrier R"
    and bcarr: "b \<in> carrier R"
    and ab: "a \<otimes> b = \<zero>"
  show "a = \<zero> \<or> b = \<zero>"
  proof (cases "a = \<zero>", simp)
    assume "a \<noteq> \<zero>"
    with field_Units and acarr have aUnit: "a \<in> Units R" by fast
    from bcarr have "b = \<one> \<otimes> b" by algebra
    also from aUnit acarr have "... = (inv a \<otimes> a) \<otimes> b" by simp
    also from acarr bcarr aUnit[THEN Units_inv_closed]
    have "... = (inv a) \<otimes> (a \<otimes> b)" by algebra
    also from ab and acarr bcarr aUnit have "... = (inv a) \<otimes> \<zero>" by simp
    also from aUnit[THEN Units_inv_closed] have "... = \<zero>" by algebra
    finally have "b = \<zero>" .
    then show "a = \<zero> \<or> b = \<zero>" by simp
  qed
qed (rule field_Units)

text {* Another variant to show that something is a field *}
lemma (in cring) cring_fieldI2:
  assumes notzero: "\<zero> \<noteq> \<one>"
  and invex: "\<And>a. \<lbrakk>a \<in> carrier R; a \<noteq> \<zero>\<rbrakk> \<Longrightarrow> \<exists>b\<in>carrier R. a \<otimes> b = \<one>"
  shows "field R"
  apply (rule cring_fieldI, simp add: Units_def)
  apply (rule, clarsimp)
  apply (simp add: notzero)
proof (clarsimp)
  fix x
  assume xcarr: "x \<in> carrier R"
    and "x \<noteq> \<zero>"
  then have "\<exists>y\<in>carrier R. x \<otimes> y = \<one>" by (rule invex)
  then obtain y where ycarr: "y \<in> carrier R" and xy: "x \<otimes> y = \<one>" by fast
  from xy xcarr ycarr have "y \<otimes> x = \<one>" by (simp add: m_comm)
  with ycarr and xy show "\<exists>y\<in>carrier R. y \<otimes> x = \<one> \<and> x \<otimes> y = \<one>" by fast
qed

subsection {* Morphisms *}

definition
  ring_hom :: "[('a, 'm) ring_scheme, ('b, 'n) ring_scheme] => ('a => 'b) set"
  where "ring_hom R S =
    {h. h \<in> carrier R -> carrier S &
      (ALL x y. x \<in> carrier R & y \<in> carrier R -->
        h (x \<otimes>\<^bsub>R\<^esub> y) = h x \<otimes>\<^bsub>S\<^esub> h y & h (x \<oplus>\<^bsub>R\<^esub> y) = h x \<oplus>\<^bsub>S\<^esub> h y) &
      h \<one>\<^bsub>R\<^esub> = \<one>\<^bsub>S\<^esub>}"

lemma ring_hom_memI:
  fixes R (structure) and S (structure)
  assumes hom_closed: "!!x. x \<in> carrier R ==> h x \<in> carrier S"
    and hom_mult: "!!x y. [| x \<in> carrier R; y \<in> carrier R |] ==>
      h (x \<otimes> y) = h x \<otimes>\<^bsub>S\<^esub> h y"
    and hom_add: "!!x y. [| x \<in> carrier R; y \<in> carrier R |] ==>
      h (x \<oplus> y) = h x \<oplus>\<^bsub>S\<^esub> h y"
    and hom_one: "h \<one> = \<one>\<^bsub>S\<^esub>"
  shows "h \<in> ring_hom R S"
  by (auto simp add: ring_hom_def assms Pi_def)

lemma ring_hom_closed:
  "[| h \<in> ring_hom R S; x \<in> carrier R |] ==> h x \<in> carrier S"
  by (auto simp add: ring_hom_def funcset_mem)

lemma ring_hom_mult:
  fixes R (structure) and S (structure)
  shows
    "[| h \<in> ring_hom R S; x \<in> carrier R; y \<in> carrier R |] ==>
    h (x \<otimes> y) = h x \<otimes>\<^bsub>S\<^esub> h y"
    by (simp add: ring_hom_def)

lemma ring_hom_add:
  fixes R (structure) and S (structure)
  shows
    "[| h \<in> ring_hom R S; x \<in> carrier R; y \<in> carrier R |] ==>
    h (x \<oplus> y) = h x \<oplus>\<^bsub>S\<^esub> h y"
    by (simp add: ring_hom_def)

lemma ring_hom_one:
  fixes R (structure) and S (structure)
  shows "h \<in> ring_hom R S ==> h \<one> = \<one>\<^bsub>S\<^esub>"
  by (simp add: ring_hom_def)

locale ring_hom_cring = R: cring R + S: cring S
    for R (structure) and S (structure) +
  fixes h
  assumes homh [simp, intro]: "h \<in> ring_hom R S"
  notes hom_closed [simp, intro] = ring_hom_closed [OF homh]
    and hom_mult [simp] = ring_hom_mult [OF homh]
    and hom_add [simp] = ring_hom_add [OF homh]
    and hom_one [simp] = ring_hom_one [OF homh]

lemma (in ring_hom_cring) hom_zero [simp]:
  "h \<zero> = \<zero>\<^bsub>S\<^esub>"
proof -
  have "h \<zero> \<oplus>\<^bsub>S\<^esub> h \<zero> = h \<zero> \<oplus>\<^bsub>S\<^esub> \<zero>\<^bsub>S\<^esub>"
    by (simp add: hom_add [symmetric] del: hom_add)
  then show ?thesis by (simp del: S.r_zero)
qed

lemma (in ring_hom_cring) hom_a_inv [simp]:
  "x \<in> carrier R ==> h (\<ominus> x) = \<ominus>\<^bsub>S\<^esub> h x"
proof -
  assume R: "x \<in> carrier R"
  then have "h x \<oplus>\<^bsub>S\<^esub> h (\<ominus> x) = h x \<oplus>\<^bsub>S\<^esub> (\<ominus>\<^bsub>S\<^esub> h x)"
    by (simp add: hom_add [symmetric] R.r_neg S.r_neg del: hom_add)
  with R show ?thesis by simp
qed

lemma (in ring_hom_cring) hom_finsum [simp]:
  "[| finite A; f \<in> A -> carrier R |] ==>
  h (finsum R f A) = finsum S (h o f) A"
proof (induct set: finite)
  case empty then show ?case by simp
next
  case insert then show ?case by (simp add: Pi_def)
qed

lemma (in ring_hom_cring) hom_finprod:
  "[| finite A; f \<in> A -> carrier R |] ==>
  h (finprod R f A) = finprod S (h o f) A"
proof (induct set: finite)
  case empty then show ?case by simp
next
  case insert then show ?case by (simp add: Pi_def)
qed

declare ring_hom_cring.hom_finprod [simp]

lemma id_ring_hom [simp]:
  "id \<in> ring_hom R R"
  by (auto intro!: ring_hom_memI)

end


(*
    Authors:      Jose Divasón
                  Sebastiaan Joosten
                  René Thiemann
                  Akihisa Yamada
*)
subsection \<open>Polynomials in a Finite Field\<close>
text \<open>We connect polynomials in a prime field with integer polynomials modulo some prime.\<close>

theory Poly_Mod_Finite_Field
  imports
  Finite_Field
  Polynomial_Interpolation.Ring_Hom_Poly
  "HOL-Types_To_Sets.Types_To_Sets"
  More_Missing_Multiset
  Poly_Mod
begin

(* TODO: Move -- General transfer rule *)
declare rel_mset_Zero[transfer_rule]

lemma mset_transfer[transfer_rule]: "(list_all2 rel ===> rel_mset rel) mset mset"
proof (intro rel_funI)
  show "list_all2 rel xs ys \<Longrightarrow> rel_mset rel (mset xs) (mset ys)" for xs ys
  proof (induct xs arbitrary: ys)
    case Nil
    then show ?case by auto
  next
    case IH: (Cons x xs)
    then show ?case by (auto dest!:msed_rel_invL simp: list_all2_Cons1 intro!:rel_mset_Plus)
  qed
qed

abbreviation to_int_poly :: "'a :: finite mod_ring poly \<Rightarrow> int poly" where
  "to_int_poly \<equiv> map_poly to_int_mod_ring"

interpretation to_int_poly_hom: map_poly_inj_zero_hom to_int_mod_ring ..

lemma irreducible\<^sub>d_def_0:
  fixes f :: "'a :: {comm_semiring_1,semiring_no_zero_divisors} poly"
  shows "irreducible\<^sub>d f = (degree f \<noteq> 0 \<and>
  (\<forall> g h. degree g \<noteq> 0 \<longrightarrow> degree h \<noteq> 0 \<longrightarrow> f \<noteq> g * h))"
proof-
  have "degree g \<noteq> 0 \<Longrightarrow> g \<noteq> 0" for g :: "'a poly" by auto
  note 1 = degree_mult_eq[OF this this, simplified]
  then show ?thesis by (force elim!: irreducible\<^sub>dE)
qed

subsection \<open>Transferring to class-based mod-ring\<close>

locale poly_mod_type = poly_mod m
  for m and ty :: "'a :: nontriv itself" +
  assumes m: "m = CARD('a)"
begin

lemma m1: "m > 1" using nontriv[where 'a = 'a] by (auto simp:m)

sublocale poly_mod_2 using m1 by unfold_locales

definition MP_Rel :: "int poly \<Rightarrow> 'a mod_ring poly \<Rightarrow> bool"
  where "MP_Rel f f' \<equiv> (Mp f = to_int_poly f')"

definition M_Rel :: "int \<Rightarrow> 'a mod_ring \<Rightarrow> bool"
  where "M_Rel x x' \<equiv> (M x = to_int_mod_ring x')"

definition "MF_Rel \<equiv> rel_prod M_Rel (rel_mset MP_Rel)"

lemma to_int_mod_ring_plus: "to_int_mod_ring ((x :: 'a mod_ring) + y) = M (to_int_mod_ring x + to_int_mod_ring y)"
  unfolding M_def using m by (transfer, auto)

lemma to_int_mod_ring_times: "to_int_mod_ring ((x :: 'a mod_ring) * y) = M (to_int_mod_ring x * to_int_mod_ring y)"
  unfolding M_def using m by (transfer, auto)

lemma degree_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) degree_m degree"
  unfolding MP_Rel_def rel_fun_def
  by (auto intro!: degree_map_poly)

lemma eq_M_Rel[transfer_rule]: "(M_Rel ===> M_Rel ===> (=)) (\<lambda> x y. M x = M y) (=)"
  unfolding M_Rel_def rel_fun_def by auto

interpretation to_int_mod_ring_hom: map_poly_inj_zero_hom to_int_mod_ring..

lemma eq_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> (=)) (=m) (=)"
  unfolding MP_Rel_def rel_fun_def by auto

lemma eq_Mf_Rel[transfer_rule]: "(MF_Rel ===> MF_Rel ===> (=)) (\<lambda> x y. Mf x = Mf y) (=)"
proof (intro rel_funI, goal_cases)
  case (1 cfs Cfs dgs Dgs)
  obtain c fs where cfs: "cfs = (c,fs)" by force
  obtain C Fs where Cfs: "Cfs = (C,Fs)" by force
  obtain d gs where dgs: "dgs = (d,gs)" by force
  obtain D Gs where Dgs: "Dgs = (D,Gs)" by force
  note pairs = cfs Cfs dgs Dgs
  from 1[unfolded pairs MF_Rel_def rel_prod.simps]
  have *[transfer_rule]: "M_Rel c C" "M_Rel d D" "rel_mset MP_Rel fs Fs" "rel_mset MP_Rel gs Gs"
    by auto
  have eq1: "(M c = M d) = (C = D)" by transfer_prover
  from *(3)[unfolded rel_mset_def] obtain fs' Fs' where fs_eq: "mset fs' = fs" "mset Fs' = Fs"
    and rel_f: "list_all2 MP_Rel fs' Fs'" by auto
  from *(4)[unfolded rel_mset_def] obtain gs' Gs' where gs_eq: "mset gs' = gs" "mset Gs' = Gs"
    and rel_g: "list_all2 MP_Rel gs' Gs'" by auto
  have eq2: "(image_mset Mp fs = image_mset Mp gs) = (Fs = Gs)"
    using *(3-4)
  proof (induct fs arbitrary: Fs gs Gs)
    case (empty Fs gs Gs)
    from empty(1) have Fs: "Fs = {#}" unfolding rel_mset_def by auto
    with empty show ?case by (cases gs; cases Gs; auto simp: rel_mset_def)
  next
    case (add f fs Fs' gs' Gs')
    note [transfer_rule] = add(3)
    from msed_rel_invL[OF add(2)]
    obtain Fs F where Fs': "Fs' = Fs + {#F#}" and rel[transfer_rule]:
      "MP_Rel f F" "rel_mset MP_Rel fs Fs" by auto
    note IH = add(1)[OF rel(2)]
    {
      from add(3)[unfolded rel_mset_def] obtain gs Gs where id: "mset gs = gs'" "mset Gs = Gs'"
        and rel: "list_all2 MP_Rel gs Gs" by auto
      have "Mp f \<in># image_mset Mp gs' \<longleftrightarrow> F \<in># Gs'"
      proof -
        have "?thesis = ((Mp f \<in> Mp ` set gs) = (F \<in> set Gs))"
          unfolding id[symmetric] by simp
        also have \<dots> using rel
        proof (induct gs Gs rule: list_all2_induct)
          case (Cons g gs G Gs)
          note [transfer_rule] = Cons(1-2)
          have id: "(Mp g = Mp f) = (F = G)" by (transfer, auto)
          show ?case using id Cons(3) by auto
        qed auto
        finally show ?thesis by simp
      qed
    } note id = this
    show ?case
    proof (cases "Mp f \<in># image_mset Mp gs'")
      case False
      have "Mp f \<in># image_mset Mp (fs + {#f#})" by auto
      with False have F: "image_mset Mp (fs + {#f#}) \<noteq> image_mset Mp gs'" by metis
      with False[unfolded id] show ?thesis unfolding Fs' by auto
    next
      case True
      then obtain g where fg: "Mp f = Mp g" and g: "g \<in># gs'" by auto
      from g obtain gs where gs': "gs' = add_mset g gs" by (rule mset_add)
      from msed_rel_invL[OF add(3)[unfolded gs']]
      obtain Gs G where Gs': "Gs' = Gs + {# G #}" and gG[transfer_rule]: "MP_Rel g G" and
        gsGs: "rel_mset MP_Rel gs Gs" by auto
      have FG: "F = G" by (transfer, simp add: fg)
      note IH = IH[OF gsGs]
      show ?thesis unfolding gs' Fs' Gs' by (simp add: fg IH FG)
    qed
  qed
  show "(Mf cfs = Mf dgs) = (Cfs = Dgs)" unfolding pairs Mf_def split
    by (simp add: eq1 eq2)
qed

lemmas coeff_map_poly_of_int = coeff_map_poly[of of_int, OF of_int_0]

lemma plus_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> MP_Rel) (+) (+)"
  unfolding MP_Rel_def
proof (intro rel_funI, goal_cases)
  case (1 x f y g)
  have "Mp (x + y) = Mp (Mp x + Mp y)" by simp
  also have "\<dots> = Mp (map_poly to_int_mod_ring f + map_poly to_int_mod_ring g)" unfolding 1 ..
  also have "\<dots> = map_poly to_int_mod_ring (f + g)" unfolding poly_eq_iff Mp_coeff
       by (auto simp: to_int_mod_ring_plus)
  finally show ?case .
qed

lemma times_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> MP_Rel) ((*)) ((*))"
  unfolding MP_Rel_def
proof (intro rel_funI, goal_cases)
  case (1 x f y g)
  have "Mp (x * y) = Mp (Mp x * Mp y)" by simp
  also have "\<dots> = Mp (map_poly to_int_mod_ring f * map_poly to_int_mod_ring g)" unfolding 1 ..
  also have "\<dots> = map_poly to_int_mod_ring (f * g)"
  proof -
    { fix n :: nat
      define A where "A = {.. n}"
      have "finite A" unfolding A_def by auto
      then have "M (\<Sum>i\<le>n. to_int_mod_ring (coeff f i) * to_int_mod_ring (coeff g (n - i))) =
           to_int_mod_ring (\<Sum>i\<le>n. coeff f i * coeff g (n - i))"
        unfolding A_def[symmetric]
      proof (induct A)
        case (insert a A)
        have "?case = ?case" (is "(?l = ?r) = _") by simp
        have "?r = to_int_mod_ring (coeff f a * coeff g (n - a) + (\<Sum>i\<in> A. coeff f i * coeff g (n - i)))"
          using insert(1-2) by auto
        note r = this[unfolded to_int_mod_ring_plus to_int_mod_ring_times]
        from insert(1-2) have "?l = M (to_int_mod_ring (coeff f a) * to_int_mod_ring (coeff g (n - a))
          + M (\<Sum>i\<in>A. to_int_mod_ring (coeff f i) * to_int_mod_ring (coeff g (n - i))))"
          by simp
        also have "M (\<Sum>i\<in>A. to_int_mod_ring (coeff f i) * to_int_mod_ring (coeff g (n - i))) = to_int_mod_ring (\<Sum>i\<in>A. coeff f i * coeff g (n - i))"
          unfolding insert ..
        finally
        show ?case unfolding r by simp
      qed auto
    }
    then show ?thesis by (auto intro!:poly_eqI simp: coeff_mult  Mp_coeff)
  qed
  finally show ?case .
qed

lemma smult_MP_Rel[transfer_rule]: "(M_Rel ===> MP_Rel ===> MP_Rel) smult smult"
  unfolding MP_Rel_def M_Rel_def
proof (intro rel_funI, goal_cases)
  case (1 x x' f f')
  thus ?case unfolding poly_eq_iff coeff Mp_coeff
    coeff_smult M_def
  proof (intro allI, goal_cases)
    case (1 n)
    have "x * coeff f n mod m = (x mod m) * (coeff f n mod m) mod m"
      by (simp add: mod_simps)
    also have "\<dots> = to_int_mod_ring x' * (to_int_mod_ring (coeff f' n)) mod m"
      using 1 by auto
    also have " \<dots> = to_int_mod_ring (x' * coeff f' n)"
      unfolding to_int_mod_ring_times M_def by simp
    finally show ?case by auto
  qed
qed

lemma one_M_Rel[transfer_rule]: "M_Rel 1 1"
  unfolding M_Rel_def M_def
  unfolding m by auto

lemma one_MP_Rel[transfer_rule]: "MP_Rel 1 1"
  unfolding MP_Rel_def poly_eq_iff Mp_coeff M_def
  unfolding m by auto

lemma zero_M_Rel[transfer_rule]: "M_Rel 0 0"
  unfolding M_Rel_def M_def
  unfolding m by auto

lemma zero_MP_Rel[transfer_rule]: "MP_Rel 0 0"
  unfolding MP_Rel_def poly_eq_iff Mp_coeff M_def
  unfolding m by auto

lemma listprod_MP_Rel[transfer_rule]: "(list_all2 MP_Rel ===> MP_Rel) prod_list prod_list"
proof (intro rel_funI, goal_cases)
  case (1 xs ys)
  thus ?case
  proof (induct xs ys rule: list_all2_induct)
    case (Cons x xs y ys)
    note [transfer_rule] = this
    show ?case by simp transfer_prover
  qed (simp add: one_MP_Rel)
qed

lemma prod_mset_MP_Rel[transfer_rule]: "(rel_mset MP_Rel ===> MP_Rel) prod_mset prod_mset"
proof (intro rel_funI, goal_cases)
  case (1 xs ys)
  have "(MP_Rel ===> MP_Rel ===> MP_Rel) ((*)) ((*))" "MP_Rel 1 1" by transfer_prover+
  from 1 this show ?case
  proof (induct xs ys rule: rel_mset_induct)
    case (add R x xs y ys)
    note [transfer_rule] = this
    show ?case by simp transfer_prover
  qed (simp add: one_MP_Rel)
qed

lemma right_unique_MP_Rel[transfer_rule]: "right_unique MP_Rel"
  unfolding right_unique_def MP_Rel_def by auto

lemma M_to_int_mod_ring: "M (to_int_mod_ring (x :: 'a mod_ring)) = to_int_mod_ring x"
  unfolding M_def unfolding m by (transfer, auto)

lemma Mp_to_int_poly: "Mp (to_int_poly (f :: 'a mod_ring poly)) = to_int_poly f"
  by (auto simp: poly_eq_iff Mp_coeff M_to_int_mod_ring)

lemma right_total_M_Rel[transfer_rule]: "right_total M_Rel"
  unfolding right_total_def M_Rel_def using M_to_int_mod_ring by blast

lemma left_total_M_Rel[transfer_rule]: "left_total M_Rel"
  unfolding left_total_def M_Rel_def[abs_def]
proof
  fix x
  show "\<exists> x' :: 'a mod_ring. M x = to_int_mod_ring x'"  unfolding M_def unfolding m
    by (rule exI[of _ "of_int x"], transfer, simp)
qed

lemma bi_total_M_Rel[transfer_rule]: "bi_total M_Rel"
  using right_total_M_Rel left_total_M_Rel by (metis bi_totalI)

lemma right_total_MP_Rel[transfer_rule]: "right_total MP_Rel"
  unfolding right_total_def MP_Rel_def
proof
  fix f :: "'a mod_ring poly"
  show "\<exists>x. Mp x = to_int_poly f"
    by (intro exI[of _ "to_int_poly f"], simp add: Mp_to_int_poly)
qed

lemma to_int_mod_ring_of_int_M: "to_int_mod_ring (of_int x :: 'a mod_ring) = M x" unfolding M_def
  unfolding m by transfer auto

lemma Mp_f_representative: "Mp f = to_int_poly (map_poly of_int f :: 'a mod_ring poly)"
  unfolding Mp_def by (auto intro: poly_eqI simp: coeff_map_poly to_int_mod_ring_of_int_M)

lemma left_total_MP_Rel[transfer_rule]: "left_total MP_Rel"
  unfolding left_total_def MP_Rel_def[abs_def] using Mp_f_representative by blast

lemma bi_total_MP_Rel[transfer_rule]: "bi_total MP_Rel"
  using right_total_MP_Rel left_total_MP_Rel by (metis bi_totalI)

lemma bi_total_MF_Rel[transfer_rule]: "bi_total MF_Rel"
  unfolding MF_Rel_def[abs_def]
  by (intro prod.bi_total_rel multiset.bi_total_rel bi_total_MP_Rel bi_total_M_Rel)

lemma right_total_MF_Rel[transfer_rule]: "right_total MF_Rel"
  using bi_total_MF_Rel unfolding bi_total_alt_def by auto

lemma left_total_MF_Rel[transfer_rule]: "left_total MF_Rel"
  using bi_total_MF_Rel unfolding bi_total_alt_def by auto

lemma domain_RT_rel[transfer_domain_rule]: "Domainp MP_Rel = (\<lambda> f. True)"
proof
  fix f :: "int poly"
  show "Domainp MP_Rel f = True" unfolding MP_Rel_def[abs_def] Domainp.simps
    by (auto simp: Mp_f_representative)
qed

lemma mem_MP_Rel[transfer_rule]: "(MP_Rel ===> rel_set MP_Rel ===> (=)) (\<lambda> x Y. \<exists>y \<in> Y. eq_m x y) (\<in>)"
proof (intro rel_funI iffI)
  fix x y X Y assume xy: "MP_Rel x y" and XY: "rel_set MP_Rel X Y"
  { assume "\<exists>x' \<in> X. x =m x'"
    then obtain x' where x'X: "x' \<in> X" and xx': "x =m x'" by auto
    with xy have x'y: "MP_Rel x' y" by (auto simp: MP_Rel_def)
    from rel_setD1[OF XY x'X] obtain y' where "MP_Rel x' y'" and "y' \<in> Y" by auto
    with x'y
    show "y \<in> Y" by (auto simp: MP_Rel_def)
  }
  assume "y \<in> Y"
  from rel_setD2[OF XY this] obtain x' where x'X: "x' \<in> X" and x'y: "MP_Rel x' y" by auto
  from xy x'y have "x =m x'" by (auto simp: MP_Rel_def)
  with x'X show "\<exists>x' \<in> X. x =m x'" by auto
qed

lemma conversep_MP_Rel_OO_MP_Rel [simp]: "MP_Rel\<inverse>\<inverse> OO MP_Rel = (=)"
  using Mp_to_int_poly by (intro ext, auto simp: OO_def MP_Rel_def)

lemma MP_Rel_OO_conversep_MP_Rel [simp]: "MP_Rel OO MP_Rel\<inverse>\<inverse> = eq_m"
  by (intro ext, auto simp: OO_def MP_Rel_def Mp_f_representative)

lemma conversep_MP_Rel_OO_eq_m [simp]: "MP_Rel\<inverse>\<inverse> OO eq_m = MP_Rel\<inverse>\<inverse>"
  by (intro ext, auto simp: OO_def MP_Rel_def)

lemma eq_m_OO_MP_Rel [simp]: "eq_m OO MP_Rel = MP_Rel"
  by (intro ext, auto simp: OO_def MP_Rel_def)

lemma eq_mset_MP_Rel [transfer_rule]: "(rel_mset MP_Rel ===> rel_mset MP_Rel ===> (=)) (rel_mset eq_m) (=)"
proof (intro rel_funI iffI)
  fix A B X Y
  assume AX: "rel_mset MP_Rel A X" and BY: "rel_mset MP_Rel B Y"
  {
    assume AB: "rel_mset eq_m A B"
    from AX have "rel_mset MP_Rel\<inverse>\<inverse> X A" by (simp add: multiset.rel_flip)
    note rel_mset_OO[OF this AB]
    note rel_mset_OO[OF this BY]
    then show "X = Y" by (simp add: multiset.rel_eq)
  }
  assume "X = Y"
  with BY have "rel_mset MP_Rel\<inverse>\<inverse> X B" by (simp add: multiset.rel_flip)
  from rel_mset_OO[OF AX this]
  show "rel_mset eq_m A B" by simp
qed

lemma dvd_MP_Rel[transfer_rule]: "(MP_Rel ===> MP_Rel ===> (=)) (dvdm) (dvd)"
  unfolding dvdm_def[abs_def] dvd_def[abs_def]
  by transfer_prover

lemma irreducible_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) irreducible_m irreducible"
  unfolding irreducible_m_def irreducible_def
  by transfer_prover

lemma irreducible\<^sub>d_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) irreducible\<^sub>d_m irreducible\<^sub>d"
  unfolding irreducible\<^sub>d_m_def[abs_def] irreducible\<^sub>d_def[abs_def]
  by transfer_prover

lemma UNIV_M_Rel[transfer_rule]: "rel_set M_Rel {0..<m} UNIV"
  unfolding rel_set_def M_Rel_def[abs_def] M_def
  by (auto simp: M_def m, goal_cases, metis to_int_mod_ring_of_int_mod_ring, (transfer, auto)+)

lemma coeff_MP_Rel [transfer_rule]: "(MP_Rel ===> (=) ===> M_Rel) coeff coeff"
  unfolding rel_fun_def M_Rel_def MP_Rel_def Mp_coeff[symmetric] by auto

lemma M_1_1: "M 1 = 1" unfolding M_def unfolding m by simp

lemma square_free_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) square_free_m square_free"
  unfolding square_free_m_def[abs_def] square_free_def[abs_def]
  by (transfer_prover_start, transfer_step+, auto)

lemma mset_factors_m_MP_Rel [transfer_rule]: "(rel_mset MP_Rel ===> MP_Rel ===> (=)) mset_factors_m mset_factors"
  unfolding mset_factors_def mset_factors_m_def
  by (transfer_prover_start, transfer_step+, auto dest:eq_m_irreducible_m)

lemma coprime_MP_Rel [transfer_rule]: "(MP_Rel ===> MP_Rel ===> (=)) coprime_m coprime"
  unfolding coprime_m_def[abs_def] coprime_def' [abs_def]
  by (transfer_prover_start, transfer_step+, auto)

lemma prime_elem_MP_Rel [transfer_rule]: "(MP_Rel ===> (=)) prime_elem_m prime_elem"
  unfolding prime_elem_m_def prime_elem_def by transfer_prover

end

context poly_mod_2 begin

lemma non_empty: "{0..<m} \<noteq> {}" using m1 by auto

lemma type_to_set:
  assumes type_def: "\<exists>(Rep :: 'b \<Rightarrow> int) Abs. type_definition Rep Abs {0 ..< m :: int}"
  shows "class.nontriv (TYPE('b))" (is ?a) and "m = int CARD('b)" (is ?b)
proof -
  from type_def obtain rep :: "'b \<Rightarrow> int" and abs :: "int \<Rightarrow> 'b" where t: "type_definition rep abs {0 ..< m}" by auto
  have "card (UNIV :: 'b set) = card {0 ..< m}" using t by (rule type_definition.card)
  also have "\<dots> = m" using m1 by auto
  finally show ?b ..
  then show ?a unfolding class.nontriv_def using m1 by auto
qed

end

locale poly_mod_prime_type = poly_mod_type m ty for m :: int and
  ty :: "'a :: prime_card itself"
begin

lemma factorization_MP_Rel [transfer_rule]:
  "(MP_Rel ===> MF_Rel ===> (=)) factorization_m (factorization Irr_Mon)"
  unfolding rel_fun_def
proof (intro allI impI, goal_cases)
  case (1 f F cfs Cfs)
  note [transfer_rule] = 1(1)
  obtain c fs where cfs: "cfs = (c,fs)" by force
  obtain C Fs where Cfs: "Cfs = (C,Fs)" by force
  from 1(2)[unfolded rel_prod.simps cfs Cfs MF_Rel_def]
  have tr[transfer_rule]: "M_Rel c C" "rel_mset MP_Rel fs Fs" by auto
  have eq: "(f =m smult c (prod_mset fs) = (F = smult C (prod_mset Fs)))"
    by transfer_prover
  have "set_mset Fs \<subseteq> Irr_Mon = (\<forall> x \<in># Fs. irreducible\<^sub>d x \<and> monic x)" unfolding Irr_Mon_def by auto
  also have "\<dots> = (\<forall>f\<in>#fs. irreducible\<^sub>d_m f \<and> monic (Mp f))"
  proof (rule sym, transfer_prover_start, transfer_step+)
    {
      fix f
      assume "f \<in># fs"
      have "monic (Mp f) \<longleftrightarrow> M (coeff f (degree_m f)) = M 1"
        unfolding Mp_coeff[symmetric] by simp
    }
    thus "(\<forall>f\<in>#fs. irreducible\<^sub>d_m f \<and> monic (Mp f)) =
      (\<forall>x\<in>#fs. irreducible\<^sub>d_m x \<and> M (coeff x (degree_m x)) = M 1)" by auto
  qed
  finally
  show "factorization_m f cfs = factorization Irr_Mon F Cfs" unfolding cfs Cfs
    factorization_m_def factorization_def split eq by simp
qed

lemma unique_factorization_MP_Rel [transfer_rule]: "(MP_Rel ===> MF_Rel ===> (=))
  unique_factorization_m (unique_factorization Irr_Mon)"
  unfolding rel_fun_def
proof (intro allI impI, goal_cases)
  case (1 f F cfs Cfs)
  note [transfer_rule] = 1(1,2)
  let ?F = "factorization Irr_Mon F"
  let ?f = "factorization_m f"
  let ?R = "Collect ?F"
  let ?L = "Mf ` Collect ?f"
  note X_to_x = right_total_MF_Rel[unfolded right_total_def, rule_format]
  {
    fix X
    assume "X \<in> ?R"
    hence F: "?F X" by simp
    from X_to_x[of X] obtain x where rel[transfer_rule]: "MF_Rel x X" by blast
    from F[untransferred] have "Mf x \<in> ?L" by blast
    with rel have "\<exists> x. Mf x \<in> ?L \<and> MF_Rel x X" by blast
  } note R_to_L = this
  show "unique_factorization_m f cfs = unique_factorization Irr_Mon F Cfs" unfolding
    unique_factorization_m_def unique_factorization_def
  proof -
    have fF: "?F Cfs = ?f cfs" by transfer simp
    have "(?L = {Mf cfs}) = (?L \<subseteq> {Mf cfs} \<and> Mf cfs \<in> ?L)" by blast
    also have "?L \<subseteq> {Mf cfs} = (\<forall> dfs. ?f dfs \<longrightarrow> Mf dfs = Mf cfs)" by blast
    also have "\<dots> = (\<forall> y. ?F y \<longrightarrow> y = Cfs)" (is "?left = ?right")
    proof (rule; intro allI impI)
      fix Dfs
      assume *: ?left and F: "?F Dfs"
      from X_to_x[of Dfs] obtain dfs where [transfer_rule]: "MF_Rel dfs Dfs" by auto
      from F[untransferred] have f: "?f dfs" .
      from *[rule_format, OF f] have eq: "Mf dfs = Mf cfs" by simp
      have "(Mf dfs = Mf cfs) = (Dfs = Cfs)" by (transfer_prover_start, transfer_step+, simp)
      thus "Dfs = Cfs" using eq by simp
    next
      fix dfs
      assume *: ?right and f: "?f dfs"
      from left_total_MF_Rel obtain Dfs where
        rel[transfer_rule]: "MF_Rel dfs Dfs" unfolding left_total_def by blast
      have "?F Dfs" by (transfer, rule f)
      from *[rule_format, OF this] have eq: "Dfs = Cfs" .
      have "(Mf dfs = Mf cfs) = (Dfs = Cfs)" by (transfer_prover_start, transfer_step+, simp)
      thus "Mf dfs = Mf cfs" using eq by simp
    qed
    also have "Mf cfs \<in> ?L = (\<exists> dfs. ?f dfs \<and> Mf cfs = Mf dfs)" by auto
    also have "\<dots> = ?F Cfs"  unfolding fF
    proof
      assume "\<exists> dfs. ?f dfs \<and> Mf cfs  = Mf dfs"
      then obtain dfs where f: "?f dfs" and id: "Mf dfs = Mf cfs" by auto
      from f have "?f (Mf dfs)" by simp
      from this[unfolded id] show "?f cfs" by simp
    qed blast
    finally show "(?L = {Mf cfs}) = (?R = {Cfs})" by auto
  qed
qed

end

context begin
private lemma 1: "poly_mod_type TYPE('a :: nontriv) m = (m = int CARD('a))"
  and 2: "class.nontriv TYPE('a) = (CARD('a) \<ge> 2)"
  unfolding poly_mod_type_def class.prime_card_def class.nontriv_def poly_mod_prime_type_def by auto

private lemma 3: "poly_mod_prime_type TYPE('b) m = (m = int CARD('b))"
  and 4: "class.prime_card TYPE('b :: prime_card) = prime CARD('b :: prime_card)"
  unfolding poly_mod_type_def class.prime_card_def class.nontriv_def poly_mod_prime_type_def by auto

lemmas poly_mod_type_simps = 1 2 3 4
end

lemma remove_duplicate_premise: "(PROP P \<Longrightarrow> PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP P \<Longrightarrow> PROP Q)" (is "?l \<equiv> ?r")
proof (intro Pure.equal_intr_rule)
  assume p: "PROP P" and ppq: "PROP ?l"
  from ppq[OF p p] show "PROP Q".
next
  assume p: "PROP P" and pq: "PROP ?r"
  from pq[OF p] show "PROP Q".
qed

context poly_mod_prime begin

lemma type_to_set:
  assumes type_def: "\<exists>(Rep :: 'b \<Rightarrow> int) Abs. type_definition Rep Abs {0 ..< p :: int}"
  shows "class.prime_card (TYPE('b))" (is ?a) and "p = int CARD('b)" (is ?b)
proof -
  from prime have p2: "p \<ge> 2" by (rule prime_ge_2_int)
  from type_def obtain rep :: "'b \<Rightarrow> int" and abs :: "int \<Rightarrow> 'b" where t: "type_definition rep abs {0 ..< p}" by auto
  have "card (UNIV :: 'b set) = card {0 ..< p}" using t by (rule type_definition.card)
  also have "\<dots> = p" using p2 by auto
  finally show ?b ..
  then show ?a unfolding class.prime_card_def using prime p2 by auto
qed
end

(* it will be nice to be able to automate this *)

lemmas (in poly_mod_type) prime_elem_m_dvdm_multD = prime_elem_dvd_multD
  [where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_2) prime_elem_m_dvdm_multD = poly_mod_type.prime_elem_m_dvdm_multD
  [unfolded poly_mod_type_simps, internalize_sort "'a :: nontriv", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas(in poly_mod_prime_type) degree_m_mult_eq = degree_mult_eq
  [where 'a = "'a mod_ring", untransferred]
lemmas(in poly_mod_prime) degree_m_mult_eq = poly_mod_prime_type.degree_m_mult_eq
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemma(in poly_mod_prime) irreducible\<^sub>d_lifting:
  assumes n: "n \<noteq> 0"
    and deg: "poly_mod.degree_m (p^n) f = degree_m f"
    and irr: "irreducible\<^sub>d_m f"
  shows "poly_mod.irreducible\<^sub>d_m (p^n) f"
proof -
  interpret q: poly_mod_2 "p^n" unfolding poly_mod_2_def using n m1 by auto
  show "q.irreducible\<^sub>d_m f"
  proof (rule q.irreducible\<^sub>d_mI)
    from deg irr show "q.degree_m f > 0" by (auto elim: irreducible\<^sub>d_mE)
    then have pdeg_f: "degree_m f \<noteq> 0" by (simp add: deg)
    note pMp_Mp = Mp_Mp_pow_is_Mp[OF n m1]
    fix g h
    assume deg_g: "degree g < q.degree_m f" and deg_h: "degree h < q.degree_m f"
      and eq: "q.eq_m f (g * h)"
    from eq have p_f: "f =m (g * h)" using pMp_Mp by metis
    have "\<not>g =m 0" and "\<not>h =m 0"
      apply (metis degree_0 mult_zero_left Mp_0 p_f pdeg_f poly_mod.mult_Mp(1))
      by (metis degree_0 mult_eq_0_iff Mp_0 mult_Mp(2) p_f pdeg_f)
    note [simp] = degree_m_mult_eq[OF this]
    from degree_m_le[of g] deg_g
    have 2: "degree_m g < degree_m f" by (fold deg, auto)
    from degree_m_le[of h] deg_h
    have 3: "degree_m h < degree_m f" by (fold deg, auto)
    from irreducible\<^sub>d_mD(2)[OF irr 2 3] p_f
    show False by auto
  qed
qed

(* Lifting UFD properties *)
lemmas (in poly_mod_prime_type) mset_factors_exist =
  mset_factors_exist[where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_prime) mset_factors_exist = poly_mod_prime_type.mset_factors_exist
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas (in poly_mod_prime_type) mset_factors_unique =
  mset_factors_unique[where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_prime) mset_factors_unique = poly_mod_prime_type.mset_factors_unique
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas (in poly_mod_prime_type) prime_elem_iff_irreducible =
  prime_elem_iff_irreducible[where 'a = "'a mod_ring poly",untransferred]
lemmas (in poly_mod_prime) prime_elem_iff_irreducible[simp] = poly_mod_prime_type.prime_elem_iff_irreducible
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas (in poly_mod_prime_type) irreducible_connect =
  irreducible_connect_field[where 'a = "'a mod_ring", untransferred]
lemmas (in poly_mod_prime) irreducible_connect[simp] = poly_mod_prime_type.irreducible_connect
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

lemmas (in poly_mod_prime_type) irreducible_degree =
  irreducible_degree_field[where 'a = "'a mod_ring", untransferred]
lemmas (in poly_mod_prime) irreducible_degree = poly_mod_prime_type.irreducible_degree
  [unfolded poly_mod_type_simps, internalize_sort "'a :: prime_card", OF type_to_set, unfolded remove_duplicate_premise, cancel_type_definition, OF non_empty]

end


theory Set_Auxiliaries
  imports Main Graph_Theory.Stuff
begin

section\<open>Set auxiliaries\<close>

lemmas [trans] = finite_subset

lemma card_greater_1_contains_two_elements:
  assumes "card S > 1"
  shows "\<exists>u v. v \<in> S \<and> u \<in> S \<and> u \<noteq> v"
  by (metis One_nat_def assms card_eq_0_iff card_le_Suc0_iff_eq le_eq_less_or_eq
        less_one not_less_iff_gr_or_eq)

lemma contains_two_card_greater_1:
  assumes "v \<in> S" "u \<in> S" "u \<noteq> v" "finite S"
  shows "1 < card S"
  using assms  by simp (meson card_le_Suc0_iff_eq not_le_imp_less)

lemma e_in_E_e_explicit:
  assumes "card e = 2"
  shows "\<exists>u v. e = {u ,v} \<and> u \<noteq> v"
proof -
  from assms have "finite e"
    using card.infinite by force
  then obtain xs where "distinct xs" "set xs = e" "length xs = card e"
    by (metis assms distinct_card finite_distinct_list)
  with assms show ?thesis
    by (metis card_eq_SucD numeral_2_eq_2 singleton_iff)
qed

lemma card_dep_on_other_set:
  assumes "finite T"
  shows "card {{u. f u j}|j. j \<in> T} \<le> card T"
  using assms by (simp add: Setcompr_eq_image card_image_le)

lemma finite_union_if_all_subset_fin:
  assumes "\<forall>S' \<in> S. finite S'" "finite S"
  shows "finite (\<Union> S)"
  using assms by auto

(* XXX Move to library *)
lemma card_UN_le_sum_cards:
  assumes "finite S"
  shows "card (\<Union> S) \<le> (\<Sum>S' \<in> S. card S')"
proof (cases "\<forall>S' \<in> S. finite S'")
  case True
  with assms show ?thesis
    by induction (auto intro: card_Un_le order.trans)
next
  case False
  then have "infinite (\<Union> S)"
    by (meson Sup_upper finite_subset)
  then show ?thesis
    by simp
qed

lemma card_union_if_all_subsets_card_i:
  assumes "\<forall>S' \<in> S. card S' \<le> i" "finite S"
  shows "card (\<Union> S) \<le> i * card S"
  using assms
  by (smt Groups.mult_ac(2) card_UN_le_sum_cards id_apply of_nat_eq_id order.trans sum_bounded_above)

lemma card_forall_for_elements:
  assumes "\<forall>j \<in> T. card {u. f u j} \<le> 1" "S = {{u. f u j}| j. j \<in> T}"
  shows "\<forall>S' \<in> S. card S' \<le> 1"
proof
  fix S' assume "S' \<in> S"
  then have "\<exists>j \<in> T. S' = {u. f u j}"
    using assms by blast
  then show "card S' \<le> 1"
    using assms by blast
qed

lemma card_union_if_all_subsets_card_1:
  assumes "\<forall>S' \<in> S. card S' \<le> 1" "finite S"
  shows "card (\<Union> S) \<le> card S"
  using assms card_union_if_all_subsets_card_i by fastforce

lemma card_leq_1_set_explicit:
  assumes "card S \<le> 1" "finite S"
  shows "(\<exists>x. S = {x}) \<or> S = {}"
  using assms card_0_eq card_1_singletonE le_eq_less_or_eq by auto

lemma two_elem_card_le:
  "card {a, b} \<le> 2"
  by (simp add: card_insert_le_m1)

lemma finite_ordered_pairs:
  assumes "finite E"
  shows "finite {(u, v). {u, v} \<in> E}" (is "finite ?S")
proof -
  let ?E = "{{u, v} | u v. {u, v} \<in> E}"
  have "?E \<subseteq> E"
    by auto
  also have "finite E"
    by (rule assms)
  finally have "finite ?E" .
  have "?S \<subseteq> (\<Union>?E) \<times> (\<Union>?E)"
    by auto
  also from \<open>finite ?E\<close> have "finite \<dots>"
    by auto
  finally show ?thesis .
qed

lemma card_ordered_pairs:
  assumes "finite E"
  shows "card {(u, v). {u, v} \<in> E} \<le> 2 * card E" (is "card ?S \<le> _")
  using assms
proof induction
  case empty
  then show ?case
    by simp
next
  case (insert x E)
  let ?E = "insert x E"
  let ?S = "{(u, v). {u, v} \<in> E}" and ?T = "{(u, v). {u, v} \<in> ?E}"
  from \<open>finite E\<close> have "finite ?S"
    by (rule finite_ordered_pairs)
  consider (same) "?T = ?S" | (new) a b where "x = {a, b}"
    by auto
  then show ?case
  proof cases
    case same
    with insert show ?thesis
      by simp
  next
    case new
    then have "?T \<subseteq> {(a, b), (b, a)} \<union> ?S"
      by fast
    with \<open>finite ?S\<close> have "card ?T \<le> card \<dots>"
      by (intro card_mono) auto
    also have "\<dots> \<le> 2 + card ?S"
      by (intro order.trans[OF card_Un_le], simp add: two_elem_card_le)
    also from insert have "\<dots> \<le> 2 * card (insert x E)"
      by simp
    finally show ?thesis .
  qed
qed

end