Theory Power_Allegories_Properties

section ‹Properties of Power Allegories›

theory Power_Allegories_Properties

imports Relational_Properties

begin

subsection ‹Power transpose, epsilon, epsiloff›

definition Lambda :: "('a,'b) rel  ('a,'b set) rel" ("Λ") where
  "Λ R = {(a,B) |a B. B = {b. (a,b)  R}}"

definition epsilon :: "('a,'a set) rel" where
  "epsilon = {(a,A). a  A}"

definition "epsiloff = {(A,a). a  A}"

definition alpha :: "('a,'b set) rel  ('a,'b) rel" ("α") where
  "α R = R ; epsiloff"

text ‹alpha can be seen as a relational approximation of a multirelation.
The next lemma provides a relational definition of Lambda.›

lemma Lambda_syq: "Λ R = R ÷ epsilon"
  unfolding Lambda_def syq_set epsilon_def by blast

lemma epsiloff_epsilon: "epsiloff = epsilon"
  unfolding epsiloff_def epsilon_def converse_unfold by simp

lemma alpha_set: "α R = {(a,b) |a b. b  {B. (a,B)  R}}"
  unfolding alpha_def epsiloff_def by force

lemma alpha_relcomp [simp]: "α (R ; S) = R ; α S"
  by (simp add: O_assoc alpha_def)

lemma Lambda_epsiloff_up1: "f = Λ R  R = α f"
  unfolding Lambda_def alpha_set by simp

lemma Lambda_epsiloff_up2: "deterministic f  R = α f  f = Λ R"
  unfolding Lambda_def alpha_set deterministic_set
  apply safe
  apply force
  by (clarsimp, smt (verit, best) mem_Collect_eq set_eq_iff)

lemma Lambda_epsiloff_up:
  assumes "deterministic f"
  shows "(R = α f) = (f = Λ R)"
  by (meson Lambda_epsiloff_up1 Lambda_epsiloff_up2 assms)

lemma det_lambda: "deterministic (Λ R)"
  unfolding Lambda_def deterministic_set by simp

lemma Lambda_alpha_canc: "deterministic f  Λ (α f) = f"
  using Lambda_epsiloff_up2 by blast

lemma alpha_Lambda_canc [simp]: "α (Λ R) = R"
  using Lambda_epsiloff_up1 by blast

lemma alpha_cancel:
  assumes "deterministic f"
  and "deterministic g"
  shows "α f = α g  f = g"
  by (metis Lambda_epsiloff_up2 assms)

lemma Lambda_fusion:
  assumes "deterministic f"
  shows "Λ (f ; R) = f ; Λ R"
proof -
  have h: "deterministic (f ; Λ R)"
    by (simp add: assms det_lambda det_relcomp)
  have "f ; R = α (f ; Λ R)"
    by simp
  also have " = f ; α (Λ R)"
    by simp
  thus ?thesis
    by (simp add: alpha_cancel det_lambda h)
qed

lemma Lambda_fusion_var: "Λ (Λ R ; S) = Λ R ; Λ S"
  by (simp add: Lambda_fusion det_lambda)

lemma Lambda_epsiloff [simp]: "Λ epsiloff = Id"
proof -
  have "Λ epsiloff = Λ (Id ; epsiloff)"
    by simp
  also have " = Id"
    by (metis Lambda_epsiloff_up alpha_def det_Id)
  finally show ?thesis.
qed

lemma alpha_epsiloff [simp]: "α Id = epsiloff"
  by (simp add: alpha_def)

lemma alpha_Sup_pres: "α () = (R  . α R)"
  unfolding alpha_def by force

lemma alpha_ord_pres: "R  S  alpha R  alpha S"
  unfolding alpha_def by force

lemma alpha_inf_pres: "α {(a,A). B C. A = B  C  (a,B)  R  (a,C)  S} = α R  α S"
  unfolding alpha_set by blast


subsection ‹Relational image functor›

definition pow :: "('a, 'b) rel  ('a set, 'b set) rel" ("𝒫") where
  "𝒫 R = Λ (epsiloff ; R)"

lemma pow_set: "𝒫 R = {(A,B). B = Image R A}"
  unfolding pow_def epsiloff_def Lambda_def relcomp_def Image_def by force

lemma pow_set_var: "𝒫 R = {(A,B). B = {b. a  A. (a,b)  R}}"
  unfolding pow_set Image_def by simp

lemma pow_converse_set: "𝒫 (R) = {(Q,P). P = {a. b. (a,b)  R  b  Q}}"
  unfolding pow_set Image_def by force

lemma det_pow: "deterministic (𝒫 R)"
  unfolding pow_set deterministic_set Image_def by simp

lemma Lambda_pow: "Λ (R ; S) = Λ R ; 𝒫 S"
proof -
  have "Λ R ; 𝒫 S = Λ R ; Λ (epsiloff ; S)"
    by (simp add: pow_def)
  also have " = Λ (Λ R ; epsiloff ; S)"
    by (simp add: Lambda_fusion_var O_assoc)
  also have " = Λ (R ; S)"
    by (metis alpha_Lambda_canc alpha_def)
  finally show ?thesis..
qed

lemma pow_func1 [simp]: "𝒫 Id = Id"
  by (simp add: pow_def)

lemma pow_func2: "𝒫 (R ; S) = 𝒫 R ; 𝒫 S"
  by (metis Lambda_pow pow_def O_assoc)

lemma Grph_Image [simp]: "Grph  Image = 𝒫"
  apply (simp add: fun_eq_iff)
  unfolding pow_def Grph_def Image_def Lambda_def epsiloff_def by blast

lemma lambda_alpha_idem [simp]: "Λ (α (Λ (α R))) = Λ (α R)"
  by simp


subsection ‹Unit and multiplication of powerset monad›

definition eta :: "('a,'a set) rel" ("η") where
  "η = Λ Id"

definition mu :: "('a set set, 'a set) rel" ("μ") where
  "μ = pow epsiloff"

lemma eta_set: "η = {(a,{a}) |a. True}"
  unfolding eta_def Lambda_def Id_def by simp

lemma alpha_eta [simp]: "α η = Id"
  by (simp add: eta_def)

lemma det_eta: "deterministic η"
  unfolding deterministic_set eta_set by simp

lemma mu_set: "μ = {(A,B). B = {b. C. C  A  b  C}}"
  unfolding mu_def pow_def Lambda_def epsiloff_def by force

lemma det_mu: "deterministic μ"
  unfolding deterministic_set mu_set by simp

lemma Lambda_eta:
  assumes "deterministic R"
  shows "Λ R = R ; η"
proof -
  have "Λ R = Λ (R ; Id)"
    by simp
  also have " = R ; Λ Id"
    using Lambda_fusion assms by blast
  also have " = R ; η"
    by (simp add: eta_def)
  finally show ?thesis.
qed

lemma eta_nat_trans:
  assumes "deterministic R"
  shows "η ; 𝒫 R = R ; η"
proof -
  have "η ; 𝒫 R = Λ Id ; 𝒫 R"
    by (simp add: eta_def)
  also have " = Λ (Id ; R)"
    using Lambda_pow by blast
  also have " = Λ R"
    by simp
  also have " = R ; η"
    by (simp add: Lambda_eta assms)
  finally show ?thesis.
qed

lemma mu_nat_trans:
  assumes "deterministic R"
  shows "𝒫 (𝒫 R) ; μ = μ ; 𝒫 R"
  by (metis pow_def alpha_Lambda_canc alpha_def mu_def pow_func2)

text ‹The standard axioms for the powerset monad are derivable.›

lemma pow_monad1 [simp]: "𝒫 μ ; μ = μ ; μ"
  by (metis pow_def alpha_Lambda_canc alpha_def mu_def pow_func2)

lemma pow_monad2 [simp]: "𝒫 η ; μ = Id"
  by (metis alpha_Lambda_canc alpha_def eta_def mu_def pow_func1 pow_func2)

lemma pow_monad3 [simp]: "η ; μ = Id"
  by (metis Lambda_epsiloff Lambda_pow alpha_def alpha_epsiloff eta_def mu_def)

lemma Lambda_mu:
  assumes "deterministic R"
  shows "Λ(R) ; μ = R"
proof -
  have "Λ R ; μ = R ; η ; μ"
    by (simp add: Lambda_eta assms)
  also have " = R"
    by (simp add: O_assoc)
  finally show ?thesis.
qed

lemma pow_Lambda_mu [simp]: "𝒫 (Λ R) ; μ = 𝒫 R"
  by (metis alpha_Lambda_canc alpha_def mu_def pow_func2)

lemma lambda_alpha_mu: "Λ (α R) = Λ R ; μ"
  by (simp add: Lambda_pow alpha_def mu_def)

lemma alpha_eta_pow [simp]: "α (η ; 𝒫 R) = R"
proof -
  have "α (η ; 𝒫 R) = α (Λ Id ; 𝒫 R)"
    by (simp add: eta_def)
  also have " = α (Λ (Id ; R))"
    by (metis Lambda_pow)
  also have " = R"
    by simp
  finally show ?thesis.
qed

lemma eta_pow_Lambda [simp]: "η ; 𝒫 R = Λ R"
  by (metis Id_O_R Lambda_pow eta_def)

lemma pow_prop1: "𝒫 R  S  R  α (η ; S)"
  by (metis alpha_eta_pow alpha_ord_pres relcomp_distrib subset_Un_eq)

lemma pow_prop_2: "R  𝒫 S  α (η ; R)  S"
  by (metis alpha_eta_pow alpha_ord_pres relcomp_distrib subset_Un_eq)

lemma pow_prop: "R = 𝒫 S  α (η ; R) = S"
  using alpha_eta_pow by blast

lemma alpha_eta_id [simp]: "α (R ; η) = R"
  by simp

lemma eta_alpha_idem [simp]: "α (α R; η) ; η = α R ; η"
  by simp

lemma lambda_eta_alpha [simp]: "Λ (α (α R ; η)) = Λ (α R)"
  by simp

lemma eta_lambda_idem [simp]: "α (Λ (α R)) ; η = α R ; η"
  by simp

lemma Grph_eta [simp]: "Grph (λx. {x}) = η"
  unfolding Grph_def eta_def Lambda_def Id_def by force

lemma Grph_epsiloff [simp]: "Grph (λx. {x}) ; epsiloff = Id"
  by (metis Grph_eta alpha_def alpha_eta)

lemma Image_epsiloff [simp]: "Image epsiloff  (λx. {x}) = id"
  unfolding Image_def epsiloff_def id_def by force


subsection ‹Subset relation›

definition Omega :: "('a set, 'a set) rel" ("Ω") where
  "Ω = epsilon  epsilon"

lemma Omega_set: "Ω = {(A,B). A  B}"
  unfolding Omega_def rres_def epsilon_def by force

lemma conv_Omega: "Omega = epsiloff  epsiloff"
  by (simp add: Omega_def epsiloff_epsilon rres_lres_conv)

lemma epsilon_eta_Omega [simp]: "η ; Ω = epsilon"
  unfolding eta_set Omega_set epsilon_def by force

lemma epsiloff_eta_Omega [simp]: "Ω ; η = epsiloff"
  by (metis converse_relcomp epsiloff_epsilon epsilon_eta_Omega)

lemma epsilon_Omega [simp]: "epsilon ; Ω = epsilon"
  by (simp add: Omega_def)

lemma conv_Omega_epsiloff [simp]: "Ω ; epsiloff = epsiloff"
  by (simp add: conv_Omega)

lemma Lambda_conv [simp]: "(Λ R) = epsilon ÷ R"
  by (simp add: Lambda_syq)

lemma Lambda_Omega: "Λ R ; Ω = R  epsilon"
proof -
  have "Λ R ; Ω = Λ R ; (epsilon  epsilon)"
    by (simp add: Omega_def)
  also have " = Λ R ; -(epsiloff ; -epsilon)"
    by (simp add: epsiloff_epsilon rres_compl)
  also have " = -(Λ R ; epsiloff ; -epsilon)"
    by (metis O_assoc det_lambda deterministic_var2)
  also have " = - (R ; -epsilon)"
    by (metis alpha_Lambda_canc alpha_def)
  also have " = R  epsilon"
    by (simp add: rres_compl)
  finally show ?thesis.
qed

lemma syq_epsiloff_prop [simp]: "Ω ; (epsilon ÷ R) = epsiloff  R"
  by (metis Lambda_Omega Lambda_syq converse_converse converse_relcomp converse_syq epsiloff_epsilon rres_lres_conv)

lemma pow_semicomm: "((P,Q)  𝒫 R ; Ω) = (Δ P ; R  R ; Δ Q)"
  unfolding pow_set Image_def Omega_def rres_def epsilon_def Delta_def by blast


subsection ‹Complementation relation›

definition Compl :: "('a set,'a set) rel" ("𝒞") where
  "𝒞 = epsilon ÷ -epsilon"

lemma Compl_set: "𝒞 = {(A,-A) |A. True}"
  unfolding Compl_def syq_set epsilon_def by force

lemma Compl_Compl [simp]: "𝒞 ; 𝒞 = Id"
  by (metis Compl_def Lambda_syq boolean_algebra_class.boolean_algebra.double_compl converse_converse converse_syq det_lambda deterministic_def set_eq_subset syq_compl2 total_def univalent_def)

lemma Compl_def_var: "𝒞 = Λ (-epsiloff)"
  by (metis Compl_def Lambda_syq boolean_algebra_class.boolean_algebra.double_compl compl_conv converse_converse epsiloff_epsilon syq_compl2)

lemma converse_Compl [simp]: "𝒞 = 𝒞"
  by (metis Compl_def converse_syq double_complement syq_compl2)

lemma det_Compl: "deterministic 𝒞"
  by (simp add: Compl_def_var det_lambda)

lemma bij_Compl: "bijective 𝒞"
  by (simp add: bij_det det_Compl)

lemma Compl_compl_epsiloff [simp]: "𝒞 ; -epsiloff = epsiloff"
  by (metis Compl_Compl Compl_def_var alpha_Lambda_canc alpha_epsiloff alpha_relcomp)

lemma Compl_epsiloff [simp]: "𝒞 ; epsiloff = -epsiloff"
  by (smt (z3) Compl_def_var alpha_Lambda_canc alpha_def)

lemma compl_epsilon_Compl [simp]: "-epsilon ; 𝒞 = epsilon"
  by (metis Compl_compl_epsiloff compl_conv converse_Compl converse_converse converse_relcomp epsiloff_epsilon)

lemma epsilon_Compl [simp]: "epsilon ; 𝒞 = -epsilon"
  by (metis Compl_epsiloff compl_conv converse_Compl converse_converse converse_relcomp epsiloff_epsilon)

lemma Lambda_Compl_var: "Λ R ; 𝒞 = R ÷ -epsilon"
  by (simp add: Lambda_syq bij_det det_Compl syq_bij)

lemma Lambda_Compl: "Λ R ; 𝒞 = Λ (-R)"
proof -
  have "Λ R ; 𝒞 = Λ R ; Λ (-epsiloff)"
    by (simp add: Compl_def_var)
  also have " = Λ (Λ R ; -epsiloff)"
    by (simp add: Lambda_fusion_var)
  also have " = Λ (-(Λ R ; epsiloff))"
    by (metis det_lambda deterministic_var2)
  also have " = Λ (-R)"
    by (metis alpha_Lambda_canc alpha_def)
  finally show ?thesis.
qed


subsection ‹Kleisli lifting and Kleisli composition›

definition klift :: "('a,'b set) rel  ('a set,'b set) rel" ("_𝒫" [1000] 999) where
  "(R)𝒫 = 𝒫 (α R)"

definition kcomp :: "('a,'b set) rel  ('b,'c set) rel  ('a,'c set) rel" (infixl "𝒫" 70) where
  "R 𝒫 S = R ; (S)𝒫"

lemma klift_var: "(R)𝒫 = Λ (epsiloff ; R ; epsiloff)"
  by (simp add: pow_def O_assoc alpha_def klift_def)

lemma klift_set: "(R)𝒫 = {(A,B). B = (Image R A)}"
  unfolding klift_def Image_def pow_set alpha_set by force

lemma klift_set_var: "(R)𝒫 = {(A,B). B = {C. a  A.(a,C)  R}}"
  unfolding klift_set Image_def by auto

lemma klift_mu: "(R)𝒫 = 𝒫 R ; μ"
proof -
  have "(R)𝒫 = 𝒫 (R ; epsiloff)"
    by (simp add: alpha_def klift_def)
  also have " = 𝒫 R ; 𝒫 epsiloff"
    by (simp add: pow_func2)
  also have " = 𝒫 R ; μ"
    by (simp add: mu_def)
  finally show ?thesis.
qed

lemma klift_empty: "({},A)  (R)𝒫  A = {}"
  using klift_set by auto

lemma klift_ext1: "(R ; (S)𝒫)𝒫 = (R)𝒫 ; (S)𝒫"
  by (metis (no_types, opaque_lifting) Lambda_epsiloff_up1 Lambda_fusion_var O_assoc alpha_def klift_var)

lemma klift_ext2: "deterministic R  η ; (R)𝒫 = R"
  by (metis Id_O_R Lambda_alpha_canc Lambda_pow eta_def klift_def)

lemma klift_ext3 [simp]: "(η)𝒫 = Id"
  by (simp add: klift_def)

lemma pow_klift [simp]: "(R ; η)𝒫 = 𝒫 R"
  by (simp add: klift_def)

lemma mu_klift [simp]: "(Id)𝒫 = μ"
  by (simp add: klift_def mu_def)

lemma kcomp_var: "R 𝒫 S = R ; 𝒫 S ; μ"
  by (simp add: O_assoc kcomp_def klift_mu)

lemma kcomp_assoc: "R 𝒫 (S 𝒫 T) = (R 𝒫 S) 𝒫T"
proof -
  have "R 𝒫 (S 𝒫 T) = R ; (S ; (T)𝒫)𝒫"
    by (simp add: kcomp_def)
  also have " = R ; ((S)𝒫 ; (T)𝒫)"
    by (simp add: klift_ext1)
  also have " = (R 𝒫 S) 𝒫 T"
    by (simp add: O_assoc kcomp_def)
  finally show ?thesis.
qed

lemma kcomp_oner: "R 𝒫 η = R"
  by (simp add: kcomp_def)

lemma kcomp_onel: "deterministic R  η 𝒫 R = R"
  by (simp add: kcomp_def klift_ext2)


subsection ‹Relational box›

definition rbox :: "('a,'b) rel  ('b set, 'a set) rel" where
  "rbox R = Λ (epsiloff  R)"

lemma rbox_set: "rbox R = {(Q,P). P = {a. b. (a,b)  R  b  Q}}"
  unfolding rbox_def Lambda_def lres_def epsiloff_def
  by force

lemma rbox_exp: "((Q,P)  (rbox (R::('a,'b) rel))) = (P = -{a. b. (a,b)  R  b  -Q})"
  by (smt (z3) Collect_cong Collect_neg_eq ComplD ComplI case_prodD case_prodI mem_Collect_eq rbox_set)

lemma rbox_subset: "rbox R ; Ω = {(Q,P). P  {a. b. (a,b)  R  b  Q}}"
  unfolding rbox_set Omega_set by blast

lemma rbox_semicomm: "(Q,P)  rbox R ; Ω = (Δ P ; R  R ; Δ Q)"
  unfolding rbox_subset Delta_def by blast

lemma rbox_semicomm_var: "(Q,P)  rbox R ; Ω = (Δ P  (R ; Δ Q)  R)"
  by (simp add: lres_galois rbox_semicomm)

lemma rbox_omega: "rbox epsiloff = Λ (Ω)"
  by (simp add: conv_Omega rbox_def)

lemma Omega_rbox: "Ω = (α (rbox epsiloff))"
  by (simp add: rbox_omega)

lemma pow_rbox: "((Q,P)  rbox R ; Ω) = ((P,Q)  𝒫 R ; Ω)"
proof -
  have "(Q,P)  rbox R ; Ω = (Δ P ; R  R ; Δ Q)"
    by (simp add: rbox_semicomm)
  also have " = ((P,Q)  𝒫 R ; Ω)"
    by (simp add: pow_semicomm)
  finally show ?thesis.
qed

lemma rbox_pow_Compl: "rbox R = 𝒞 ; 𝒫 (R) ; 𝒞"
proof -
  have "𝒞 ; 𝒫 (R) ; 𝒞 = Λ (-epsiloff) ; 𝒫 (R) ; 𝒞"
    by (simp add: Compl_def_var)
  also have " = Λ (-epsiloff ; R) ; 𝒞"
    by (simp add: Lambda_pow)
  also have " = Λ (-(-epsiloff ; R))"
    by (simp add: Lambda_Compl)
  also have " = Λ (epsiloff  R)"
    by (simp add: lres_compl)
  also have " = rbox R"
    by (simp add: rbox_def)
  finally show ?thesis..
qed

lemma pow_rbox_Compl: "𝒫 R = 𝒞 ; rbox (R) ; 𝒞"
  by (metis Compl_Compl Id_O_R O_assoc R_O_Id converse_converse rbox_pow_Compl)

lemma pow_conjugation: "𝒞 ; (𝒫 (R) ; Ω) = 𝒫 R ; 𝒞 ; Ω"
proof -
  have "𝒫 R ; 𝒞 ; Ω = Λ (-(epsiloff ; R)) ; -(- epsiloff ; epsilon)"
    by (simp add: Lambda_Compl pow_def conv_Omega epsiloff_epsilon lres_compl)
  also have " = -(Λ (-(epsiloff ; R)) ; - epsiloff ; epsilon)"
    by (metis (no_types, opaque_lifting) alpha_Lambda_canc alpha_def converse_converse det_lambda det_lres deterministic_var2 epsiloff_epsilon lres_compl)
  also have " = -(Λ (-(epsiloff ; R)) ; 𝒞 ; epsiloff ; epsilon)"
    by (metis Compl_epsiloff alpha_def alpha_relcomp)
  also have " = -(Λ (epsiloff ; R) ; epsiloff ; epsilon)"
    by (simp add: Lambda_Compl)
  also have " = -(epsiloff ; R ; epsilon)"
    by (metis Lambda_epsiloff_up1 alpha_def)
  also have " = -(𝒞 ; -epsiloff ; (epsiloff ; R))"
    by (metis Compl_compl_epsiloff O_assoc converse_converse converse_relcomp epsiloff_epsilon)
  also have " = 𝒞 ; (epsiloff  (epsiloff ; R))"
    by (metis (no_types, opaque_lifting) Compl_def_var Lambda_Compl Lambda_fusion_var pow_def alpha_Lambda_canc boolean_algebra_class.boolean_algebra.double_compl converse_converse pow_rbox_Compl rbox_def)
  also have " = 𝒞; (𝒫 (R) ; Ω)"
    by (simp add: Lambda_Omega pow_def epsiloff_epsilon rres_lres_conv)
  finally show ?thesis..
qed

lemma pow_rbox_eq: "rbox R ; Ω = (𝒫 R ; Ω)"
  by (metis (no_types, lifting) Compl_Compl O_assoc R_O_Id converse_converse converse_relcomp pow_conjugation rbox_pow_Compl)

end