(*
Author: Alexander Katovsky
*)

section "Category"

theory Category
imports "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:  "(case_prod (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 (case_prod (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


(* Title: Quantic Nuclei and Conuclei
   Author: Georg Struth
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
*)

section \<open>Quantic Nuclei and Conuclei\<close>

theory Quantic_Nuclei_Conuclei
  imports Quantale_Models

begin

text \<open>Quantic nuclei and conuclei are an important part of the structure theory of quantales. I formalise
the basics, following Rosenthal's book~\cite{Rosenthal90}. In the structure theorems, I collect all parts
of the proof, but do not present the theorems in compact form due to difficulties to speak about subalgebras
and homomorphic images without explicit carrier sets. Nuclei also arise in the context of complete Heyting algebras,
frames and locales~\cite{Johnstone82}. Their formalisation seems an interesting future task.\<close>

subsection \<open>Nuclei\<close>

definition nucleus :: "('a::quantale \<Rightarrow> 'a::quantale) \<Rightarrow> bool" where
  "nucleus f = (clop f \<and> (\<forall>x y. f x \<cdot> f y \<le> f (x \<cdot> y)))"

lemma nuc_lax: "nucleus f \<Longrightarrow> f x \<cdot> f y \<le> f (x \<cdot> y)"
  by (simp add: nucleus_def)

definition unucleus :: "('a::unital_quantale \<Rightarrow> 'a::unital_quantale) \<Rightarrow> bool" where
  "unucleus f = (nucleus f \<and> 1 \<le> f 1)"

lemma "nucleus f \<Longrightarrow> f \<bottom> = \<bottom>" (*nitpick*)
  oops

lemma "conucleus f \<Longrightarrow> f \<top> = \<top>" (*nitpick*)
  oops

lemma nuc_prop1: "nucleus f \<Longrightarrow> f (x \<cdot> y) = f (x \<cdot> f y)"
  apply (rule antisym)
   apply (simp add: clop_extensive_var clop_iso_var nucleus_def psrpq.mult_isol)
  by (metis clop_alt clop_extensive_var dual_order.trans nucleus_def psrpq.mult_isol_var)

lemma nuc_prop2: "nucleus f \<Longrightarrow> f (x \<cdot> y) = f (f x \<cdot> y)"
  apply (rule antisym)
  apply (simp add: clop_extensive_var clop_iso_var nsrnq.mult_isor nucleus_def)
  by (metis (mono_tags, hide_lams) clop_alt nuc_prop1 nucleus_def)

lemma nuc_comp_prop: "nucleus f \<Longrightarrow>  f (f x \<cdot> f y) = f (x \<cdot> y)"
  using nuc_prop1 nuc_prop2 by force

lemma nucleus_alt_def1: "nucleus f \<Longrightarrow> f x \<rightarrow> f y = x \<rightarrow> f y"
proof (rule antisym)
  assume h: "nucleus f"
  hence "x \<le> f x"
    by (simp add: clop_def nucleus_def clop_extensive_var)
  thus "f x \<rightarrow> f y \<le> x \<rightarrow> f y"
    by (simp add: bres_anti)
  have "f x \<cdot> (x \<rightarrow> f y) \<le> f x \<cdot> f (x \<rightarrow> f y)"
    using clop_extensive_var h nucleus_def proto_pre_quantale_class.mult_isol by blast
  also have "... \<le> f (x \<cdot> (x \<rightarrow> f y))"
    by (simp add: h nuc_lax)
  also have "... \<le> f (f y)"
    using h by (simp add: bres_canc1 nucleus_def clop_iso_var)
  finally have "f x \<cdot> (x \<rightarrow> f y) \<le> f y"
    using h by (metis clop_alt dual_order.trans nucleus_def order_refl)
  thus "x \<rightarrow> f y \<le> f x \<rightarrow> f y"
    by (simp add: bres_galois_imp)
qed

lemma nucleus_alt_def2: "nucleus f \<Longrightarrow> f y \<leftarrow> f x = f y \<leftarrow> x"
proof (rule antisym)
  assume h: "nucleus f"
  hence "x \<le> f x"
    by (simp add: clop_extensive_var nucleus_def)
  thus "f y \<leftarrow> f x \<le> f y \<leftarrow> x"
    by (simp add: fres_anti)
  have "(f y \<leftarrow> x) \<cdot> f x \<le> f (f y \<leftarrow> x) \<cdot> f x"
    using clop_extensive_var h nsrnq.mult_isor nucleus_def by blast
  also have "... \<le> f ((f y \<leftarrow> x) \<cdot> x)"
    by (simp add: h nuc_lax)
  also have "... \<le> f (f y)"
    using clop_iso_var fres_canc1 h nucleus_def by blast
  finally have "(f y \<leftarrow> x) \<cdot> f x \<le> f y"
    using h by (metis clop_alt dual_order.trans nucleus_def order_refl)
  thus "f y \<leftarrow> x \<le> f y \<leftarrow> f x"
    by (simp add: fres_galois)
qed

lemma nucleus_alt_def3:
  fixes f :: "'a::unital_quantale \<Rightarrow> 'a"
  shows "\<forall>x y. f x \<rightarrow> f y = x \<rightarrow> f y \<Longrightarrow> \<forall>x y. f y \<leftarrow> f x = f y \<leftarrow> x \<Longrightarrow> nucleus f"
proof-
  assume h1: "\<forall>x y. f x \<rightarrow> f y = x \<rightarrow> f y"
  and h2: "\<forall>x y. f y \<leftarrow> f x = f y \<leftarrow> x"
  hence ext: "\<forall>x. x \<le> f x"
    by (metis (full_types) fres_galois fres_one mult.left_neutral)
  have iso: "\<forall>x y. x \<le> y \<longrightarrow> f x \<le> f y"
    by (metis (full_types) bres_galois dual_order.trans h1 ext nsrnqo.mult_oner)
  have trans: "\<forall>x. f (f x) \<le> f x"
    by (metis fres_canc2 fres_galois h2 nsrnqo.mult_onel)
  have lax: "\<forall>x y. f x \<cdot> f y \<le> f (x \<cdot> y)"
    by (metis h1 h2 bres_galois ext fres_galois)
  show ?thesis
    by (simp add: clop_def iso lax le_funI ext trans monoI nucleus_def)
qed

lemma nucleus_alt_def:
  fixes f :: "'a::unital_quantale \<Rightarrow> 'a"
  shows "nucleus f = (\<forall> x y. f x \<rightarrow> f y = x \<rightarrow> f y \<and> f y \<leftarrow> f x = f y \<leftarrow> x)"
  using nucleus_alt_def1 nucleus_alt_def2 nucleus_alt_def3 by blast

lemma nucleus_alt_def_cor1: "nucleus f \<Longrightarrow> f (x \<rightarrow> y) \<le> x \<rightarrow> f y"
  by (metis bres_galois bres_iso clop_extensive_var fres_galois nucleus_alt_def2 nucleus_def)

lemma nucleus_alt_def_cor2: "nucleus f \<Longrightarrow> f (y \<leftarrow> x) \<le> f y \<leftarrow> x"
  by (metis bres_galois clop_extensive_var fres_galois fres_iso nucleus_alt_def1 nucleus_def)

lemma nucleus_ab_unital:
  fixes f :: "'a::ab_unital_quantale \<Rightarrow> 'a"
  shows "nucleus f = (\<forall>x y. f x \<rightarrow> f y = x \<rightarrow> f y)"
  by (simp add: bres_fres_eq nucleus_alt_def)

lemma nuc_comp_assoc: "nucleus f \<Longrightarrow> f (x \<cdot> f (y \<cdot> z)) = f (f (x \<cdot> y) \<cdot> z)"
  by (metis mult.assoc nuc_prop1 nuc_prop2)

lemma nuc_Sup_closed: "nucleus f \<Longrightarrow> f \<circ> Sup \<circ> (`) f = (f \<circ> Sup)"
  apply (simp add: nucleus_def fun_eq_iff, safe, rule antisym)
  apply (meson SUP_least Sup_upper clop_alt clop_def monoD)
  by (simp add: SUP_upper2 Sup_le_iff clop_extensive_var clop_iso_var)

lemma nuc_Sup_closed_var: "nucleus f \<Longrightarrow> f (\<Squnion>x \<in> X. f x) = f (\<Squnion>X)"
  by (metis nuc_Sup_closed o_apply)

lemma nuc_Inf_closed: "nucleus f \<Longrightarrow> Sup_closed_set (Fix f)" (* nitpick *)
  oops

lemma nuc_Inf_closed: "nucleus f \<Longrightarrow> Inf_closed_set (Fix f)"
  by (simp add: clop_Inf_closed nucleus_def)

lemma nuc_comp_distl: "nucleus f \<Longrightarrow> f (x \<cdot> f (\<Squnion>Y)) = f (\<Squnion>y \<in> Y. f (x \<cdot> y))"
  by (metis Sup_distl image_image nuc_Sup_closed_var nuc_prop1)

lemma nuc_comp_distr: "nucleus f \<Longrightarrow> f (f (\<Squnion>X) \<cdot> y) = f (\<Squnion>x \<in> X. f (x \<cdot> y))"
  by (metis image_image Sup_distr nuc_Sup_closed_var nuc_prop2)

lemma "nucleus f \<Longrightarrow> f (x \<cdot> y) = f x \<cdot> f y" (*nitpick*)
  oops

lemma nuc_bres_closed: "nucleus f \<Longrightarrow> f (f x \<rightarrow> f y) = f x \<rightarrow> f y"
  unfolding nucleus_def apply clarsimp
  by (smt clop_closure clop_extensive_var nucleus_alt_def_cor1 nucleus_def order_class.order.antisym rangeI)

lemma "nucleus f \<Longrightarrow> f (x \<rightarrow> y) = f x \<rightarrow> f y" (*nitpick*)
  oops

lemma nuc_fres_closed: "nucleus f \<Longrightarrow> f (f x \<leftarrow> f y) = f x \<leftarrow> f y"
  unfolding nucleus_def apply clarsimp
  by (smt clop_closure clop_extensive_var eq_iff nucleus_alt_def_cor2 nucleus_def rangeI)

lemma nuc_fres_closed: "nucleus f \<Longrightarrow> f (x \<leftarrow> y) = f x \<leftarrow> f y" (*nitpick*)
  oops

lemma nuc_inf_closed: "nucleus f \<Longrightarrow> inf_closed_set (Fix f)"
  by (simp add: Inf_inf_closed nuc_Inf_closed)

lemma nuc_inf_closed_var: "nucleus f \<Longrightarrow> f (f x \<sqinter> f y) = f x \<sqinter> f y"
  by (smt antisym_conv clop_alt clop_extensive_var inf_le2 inf_sup_ord(1) le_inf_iff nucleus_def)

text \<open>Taken together these facts show that, for $f:Q\to Q$, $f[Q]$ forms a quantale with
composition $f\, (-\cdot -)$ and sup $f\, (\bigsqcup -)$, and that $f:Q\to f[Q]$ is a quantale morphism.
This is the first part of Theorem 3.1.1 in Rosenthal's book.\<close>

class quantale_with_nuc = quantale + cl_op +
  assumes cl_op_nuc: "cl_op x \<cdot> cl_op y \<le> cl_op (x \<cdot> y)"

begin

subclass clattice_with_clop..

end

class unital_quantale_with_nuc = quantale_with_nuc + unital_quantale +
  assumes one_nuc: "1 \<le> cl_op 1"

lemma nucleus_cl_op: "nucleus (cl_op::'a::quantale_with_nuc \<Rightarrow> 'a)"
  by (simp add: cl_op_class.clop_iso cl_op_nuc  clop_def clop_ext le_funI monoI nucleus_def)

lemma unucleus_cl_op: "unucleus (cl_op::'a::unital_quantale_with_nuc \<Rightarrow> 'a)"
  by (simp add: nucleus_cl_op one_nuc unucleus_def)

instantiation cl_op_im :: (quantale_with_nuc) quantale
begin

lift_definition times_cl_op_im :: "'a::quantale_with_nuc cl_op_im \<Rightarrow> 'a cl_op_im \<Rightarrow> 'a cl_op_im" is "\<lambda>x y. cl_op (x \<cdot> y)"
  by simp

instance
  by (intro_classes; transfer, auto simp: nuc_comp_assoc nuc_comp_distr nucleus_cl_op nuc_comp_distl)

end

instantiation cl_op_im :: (unital_quantale_with_nuc) unital_quantale
begin

lift_definition one_cl_op_im :: "'a::unital_quantale_with_nuc cl_op_im" is "cl_op 1"
  by simp

instance
  by (intro_classes; transfer) (metis clop_closure nsrnqo.mult_onel nuc_prop2 nucleus_cl_op nucleus_def nsrnqo.mult_oner nuc_prop1)+

end

text \<open>The usefulness of these theorems remains unclear; it seems difficult to make them collaborate with concrete nuclei.\<close>

lemma nuc_hom: "Abs_cl_op_im \<circ> cl_op \<in> quantale_homset"
  unfolding quantale_homset_iff comp_def fun_eq_iff
  apply safe
  apply (metis (no_types, lifting) Abs_cl_op_im_inverse Rep_cl_op_im_inverse nuc_comp_prop nucleus_cl_op rangeI times_cl_op_im.rep_eq)
  unfolding Sup_cl_op_im_def by (smt Abs_cl_op_im_inverse SUP_cong image_image map_fun_apply nuc_Sup_closed_var nucleus_cl_op rangeI)

text \<open>This finishes the first statement of Theorem 3.1.1. The second part follows. It states that for every
surjective quantale homomorphism there is a nucleus such that the range of the nucleus is isomorphic to the range of the surjection.\<close>

lemma quant_morph_nuc:
  fixes f :: "'a::quantale_with_dual \<Rightarrow> 'b::quantale_with_dual"
  assumes "f \<in> quantale_homset"
  shows "nucleus ((radj f) \<circ> f)"
proof-
  let ?\<phi> = "(radj f) \<circ> f"
  have adj: "f \<stileturn> (radj f)"
    by (simp add: assms quantale_hom_radj)
  hence a: "clop ?\<phi>"
    by (simp add: clop_adj)
  {fix x y
    have "f (?\<phi> x \<cdot> ?\<phi> y) = (f \<circ> ?\<phi>) x \<cdot> (f \<circ> ?\<phi>) y"
      by (metis assms comp_eq_dest_lhs quantale_homset_iff)
  also have "... = f x \<cdot> f y"
    by (simp add: adj adj_cancel_eq1 fun.map_comp)
  also have "... = f (x \<cdot> y)"
    by (metis assms quantale_homset_iff)
  finally have "?\<phi> x \<cdot> ?\<phi> y \<le> ?\<phi> (x \<cdot> y)"
    by (metis adj adj_def comp_apply order_refl)}
  thus ?thesis
    by (simp add: a nucleus_def)
qed

lemma surj_quantale_hom_bij_on:
  fixes f :: "'a::quantale_with_dual \<Rightarrow> 'b::quantale_with_dual"
  assumes "surj f"
  and "f \<in> quantale_homset"
  shows "bij_betw f (range (radj f \<circ> f)) UNIV"
  using assms quantale_homset_iff surj_Sup_pres_bij_on by blast

text \<open>This establishes the bijection, extending a similar fact about closure operators and complete lattices (surj-Sup-pres-bij).
It remains to show that $f$ is a quantale morphism, that is, it preserves Sups and compositions of closed elements with operations
defined as in the previous instantiation statement. Sup-preservation holds already for closure operators on complete lattices (surj-Sup-pres-iso).
Hence it remains to prove preservation of compositions.\<close>

lemma surj_comp_pres_iso:
  fixes f :: "'a::quantale_with_dual \<Rightarrow> 'b::quantale_with_dual"
  assumes "f \<in> quantale_homset"
  shows "f ((radj f \<circ> f) (x \<cdot> y)) = f x \<cdot> f y"
proof-
  have "f \<stileturn> (radj f)"
    by (simp add: assms quantale_hom_radj)
  hence "f ((radj f \<circ> f) (x \<cdot> y)) = f (x \<cdot> y)"
    by (metis adj_cancel_eq1 comp_eq_dest_lhs)
  thus ?thesis
    using assms quantale_homset_iff by auto
qed

text \<open>This establishes the quantale isomorphism and finishes the proof of Theorem 3.1.1.\<close>

text \<open>Next I prove Theorem 3.1.2 in Rosenthal's book. nuc-Inf-closed shows that $\mathit{Fix}\, f$ is Inf-closed. Hence the two following
lemmas show one direction.\<close>

lemma nuc_bres_pres: "nucleus f \<Longrightarrow> y \<in> Fix f \<Longrightarrow> x \<rightarrow> y \<in> Fix f"
proof -
  assume a1: "nucleus f"
  assume a2: "y \<in> Fix f"
  have "clop f"
    using a1 by (simp add: nucleus_def)
  thus ?thesis
    using a2 a1
    by (metis clop_Fix_range clop_closure clop_extensive_var dual_order.antisym nucleus_alt_def_cor1)
qed

lemma nuc_fres_pres: "nucleus f \<Longrightarrow> y \<in> Fix f \<Longrightarrow> y \<leftarrow> x \<in> Fix f"
proof -
  assume a1: "nucleus f"
  assume a2: "y \<in> Fix f"
  have "clop f"
    using a1 by (simp add: nucleus_def)
  thus ?thesis
    using a2 a1 by (metis antisym_conv clop_Fix_range clop_closure clop_extensive_var nucleus_alt_def_cor2)
qed

lemma lax_aux:
  fixes X :: "'a::quantale set"
  assumes "\<forall>x.\<forall>y \<in> X. x \<rightarrow> y \<in> X"
  and "\<forall>x. \<forall>y \<in> X. y \<leftarrow> x \<in> X"
shows "\<Sqinter>{z \<in> X. x \<le> z} \<cdot> \<Sqinter>{z \<in> X. y \<le> z} \<le> \<Sqinter>{z \<in> X. x \<cdot> y \<le> z}"
proof-
  let ?\<phi> = "\<lambda>x. \<Sqinter>{w \<in> X. x \<le> w}"
  {fix z
  assume a: "x \<cdot> y \<le> z"
  and b: "z \<in> X"
  hence c: "x \<le> z \<leftarrow> y"
    by (simp add: fres_galois)
  hence "z \<leftarrow> y \<in> X"
    by (simp add: assms(2) b)
  hence "?\<phi> x \<le> z \<leftarrow> y"
    by (simp add: Inf_lower c)
  hence d: "y \<le> ?\<phi> x \<rightarrow> z"
    by (simp add: bres_galois_imp fres_galois)
  hence "?\<phi> x  \<rightarrow> z \<in> X"
    by (simp add: assms(1) b)
  hence "?\<phi> x \<cdot> ?\<phi> y \<le> z"
    by (simp add: Inf_lower d bres_galois)}
  thus ?thesis
    by (simp add: le_Inf_iff)
qed

lemma Inf_closed_res_nuc:
  fixes X :: "'a::quantale set"
  assumes "Inf_closed_set X"
  and  "\<forall>x. \<forall>y \<in> X. x \<rightarrow> y \<in> X"
  and "\<forall>x. \<forall>y \<in> X. y \<leftarrow> x \<in> X"
  shows "nucleus (\<lambda>y. \<Sqinter>{x \<in> X. y \<le> x})"
  unfolding nucleus_def by (simp add: Inf_closed_clop assms lax_aux)

lemma Inf_closed_res_Fix:
  fixes X :: "'a::quantale set"
  assumes "Inf_closed_set X"
  and  "\<forall>x. \<forall>y \<in> X. x \<rightarrow> y \<in> X"
  and "\<forall>x. \<forall>y \<in> X. y \<leftarrow> x \<in> X"
shows "X = Fix (\<lambda>y. \<Sqinter>{x \<in> X. y \<le> x})"
  unfolding Fix_def
  apply safe
   apply (rule antisym, simp_all add: Inf_lower le_Inf_iff)
  by (metis (no_types, lifting) Inf_closed_set_def assms(1) mem_Collect_eq subsetI)

text \<open>This finishes the proof of Theorem 3.1.2\<close>

subsection \<open>A Representation Theorem\<close>

text \<open>The final proofs for nuclei lead to Rosenthal's representation theorem for quantales (Theorem 3.1.2).\<close>

lemma down_set_lax_morph: "(\<down> \<circ> Sup) (X::'a::quantale set) \<cdot> (\<down> \<circ> Sup) Y \<subseteq> (\<down> \<circ> Sup) (X \<cdot> Y)"
proof-
  have "\<Squnion>((\<down> \<circ> Sup) X \<cdot> (\<down> \<circ> Sup) Y) = \<Squnion>(X \<cdot> Y)"
    by (smt Sup_downset_adj adj_cancel_eq1 comp_apply comp_dist_mix)
  thus ?thesis
    by (simp add: Sup_downset_adj_var eq_iff)
qed

lemma downset_Sup_nuc: "nucleus (\<down> \<circ> (Sup::'a::quantale set \<Rightarrow> 'a))"
  using Sup_downset_adj clop_adj down_set_lax_morph nucleus_def by blast

lemma downset_surj: "surj_on \<down> (range (\<down> \<circ> Sup))"
  using surj_on_def by fastforce

text \<open>In addition, $\downarrow$ is injective by Lemma downset-inj. Hence it is a bijection between the quantale and the powerset quantale.
It remains to show that $\downarrow$ is a quantale morphism.\<close>

lemma downset_Sup_pres_var: "\<down> (\<Squnion>X) = (\<down> \<circ> Sup) (\<Down> (X::'a::quantale set))"
  unfolding comp_def downset_prop downset_set_def
  apply safe
  apply (smt Sup_subset_mono dual_order.refl mem_Collect_eq order_subst1 subset_iff)
  by (smt Sup_mono le_iff_inf le_infI2 mem_Collect_eq)

lemma downset_Sup_pres: "\<down> (\<Squnion>X) = (\<down> \<circ> Sup) (\<Union> (\<down> ` (X::'a::quantale set)))"
  by (metis downset_Sup_pres_var downset_set_prop_var)

text \<open>This finishes the proof of Theorem 3.1.2.\<close>

subsection \<open>Conuclei\<close>

definition conucleus :: "('a::quantale \<Rightarrow> 'a::quantale) \<Rightarrow> bool" where
  "conucleus f = (coclop f \<and> (\<forall>x y. f x \<cdot> f y \<le> f (x \<cdot> y)))"

lemma conuc_lax: "conucleus f \<Longrightarrow> f x \<cdot> f y \<le> f (x \<cdot> y)"
  by (simp add: conucleus_def)

definition uconucleus :: "('a::unital_quantale \<Rightarrow> 'a::unital_quantale) \<Rightarrow> bool" where
  "uconucleus f = (conucleus f \<and> f 1 \<le> 1)"

text \<open>Next I prove Theorem 3.1.3.\<close>

lemma conuc_Sup_closed: "conucleus f \<Longrightarrow> f \<circ> Sup \<circ> (`) f = Sup \<circ> (`) f"
  unfolding conucleus_def fun_eq_iff comp_def
  by (smt coclop_coextensive_var coclop_idem coclop_iso image_comp image_image le_iff_sup mono_SUP sup.orderE)

lemma conuc_comp_closed: "conucleus f \<Longrightarrow> f (f x \<cdot> f y) = f x \<cdot> f y"
  unfolding conucleus_def by (metis antisym_conv coclop_coextensive_var coclop_idem_var)

text \<open>The sets of fixpoints of conuclei are closed under Sups and composition; hence they form subquantales.\<close>

lemma conuc_Sup_qclosed: "conucleus f \<Longrightarrow> Sup_closed_set (Fix f) \<and> comp_closed_set (Fix f)"
  apply safe
   apply (simp add: coclop_Sup_closed conucleus_def)
  unfolding conucleus_def comp_closed_set_def by (metis coclop_coclosure coclop_coclosure_set coclop_coextensive_var dual_order.antisym)

text \<open>This shows that the subset $\mathit{Fix} f$ of a quantale, for conucleus $f$, is closed under Sups and composition.
It is therefore a subquantale. $f:f[Q]\to Q$ is an embedding. As before, this could be shown by formalising a type class of quantales with a conucleus operation,
converting the range of the conucleus into a type and providing a sublocale proof. First, this would require showing that the coclosed
elements of a complete lattice form a complete sublattice. Relative to the proofs for closure operators and nuclei there is nothing to
be learned. I provide this proof in the section on left-sided elements, where the conucleus can be expressed within the language of quantales.\<close>

text \<open>The second part of Theorem 3.1.3 states that every subquantale of a given quantale is equal to $\mathit{Fix} f$ for some conucleus $f$.\<close>

lemma lax_aux2:
  fixes X :: "'a::quantale set"
  assumes "Sup_closed_set X"
  and "comp_closed_set X"
  shows "\<Squnion>{z \<in> X. z \<le> x} \<cdot> \<Squnion>{z \<in> X. z \<le> y} \<le> \<Squnion>{z \<in> X. z \<le> x \<cdot> y}"
proof-
  let ?\<phi> = "\<lambda>x. \<Squnion>{z \<in> X. z \<le> x}"
  have "?\<phi> x \<cdot> ?\<phi> y = \<Squnion>{\<Squnion>{v \<cdot> w |v. v \<in> X \<and> v \<le> x} |w. w \<in> X \<and> w \<le> y}"
    by (simp add: Sup_distr Sup_distl setcompr_eq_image)
  also have "... = \<Squnion>{v \<cdot> w |v w. v \<in> X \<and> v \<le> x \<and> w \<in> X \<and> w \<le> y}"
    apply (rule antisym)
    apply (rule Sup_least, clarsimp, smt Collect_mono_iff Sup_subset_mono)
    by (rule Sup_least, clarsimp, smt Sup_upper2 eq_iff mem_Collect_eq)
  also have "... \<le> ?\<phi> (x \<cdot> y)"
    by (smt Collect_mono_iff Sup_subset_mono assms(2) comp_closed_set_def psrpq.mult_isol_var)
  finally show ?thesis
    by force
qed

lemma subquantale_conucleus:
  fixes X :: "'a::quantale set"
  assumes "Sup_closed_set X"
  and "comp_closed_set X"
  shows "conucleus (\<lambda>x. \<Squnion>{y \<in> X. y \<le> x})"
  unfolding conucleus_def by (safe, simp_all add: Sup_closed_coclop assms(1) assms(2) lax_aux2)

lemma subquantale_Fix:
  fixes X :: "'a::quantale set"
  assumes "Sup_closed_set X"
  and "comp_closed_set X"
  shows "X = Fix (\<lambda>x. \<Squnion>{y \<in> X. y \<le> x})"
  unfolding Fix_def
  apply safe
  apply (metis (mono_tags, lifting) Sup_least Sup_upper antisym mem_Collect_eq order_refl)
  by (metis (no_types, lifting) Sup_closed_set_def assms(1) mem_Collect_eq subsetI)

text \<open>This finishes the proof of Theorem 3.1.3\<close>

end