Quelle  Quantales.thy

(* Title: Quantales
   Author: Georg Struth 
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk> 
   Contributions by Brijesh Dongol, Victor Gomes, Ian Hayes
*)

section ‹Quantales›

theory Quantales
  imports
    "Order_Lattice_Props.Closure_Operators"
   Kleene_Algebra.Dioid
begin

subsection ‹Families of Proto-Quantales›
  
text ‹Proto-Quanales are complete lattices equipped with an operation of composition or multiplication
  need not be associative. The notation in this component differs from Rosenthal's cite‹"Rosenthal90"›, but is consistent with the one we use
  semirings and Kleene algebras.›
  
class proto_near_quantale = complete_lattice + times + 
  assumes Sup_distr: "⊔X ⋅ y = (⊔x ∈ X. x ⋅ y)"

lemma Sup_pres_multr: "Sup_pres (λ(z::'a::proto_near_quantale). z ⋅ y)"
  unfolding fun_eq_iff comp_def Sup_distr by simp 

lemma sup_pres_multr: "sup_pres (λ(z::'a::proto_near_quantale). z ⋅ y)"
  using Sup_pres_multr Sup_sup_pres by fastforce

lemma bot_pres_multr: "bot_pres (λ(z::'a::proto_near_quantale). z ⋅ y)"
  by (metis SUP_empty Sup_distr Sup_empty)

context proto_near_quantale
begin

lemma mult_botl [simp]: "⊥ ⋅ x = ⊥"
proof -
  have "⊥ ⋅ x = (⊔a∈{}. a ⋅ x)"
    using Sup_distr Sup_empty by blast
  thus ?thesis
    by simp
qed
  
lemma sup_distr: "(x ⊔ y) ⋅ z = (x ⋅ z) ⊔ (y ⋅ z)"
  by (smt SUP_empty SUP_insert Sup_distr sup_Sup sup_bot.right_neutral)
   
lemma mult_isor: "x ≤ y ==> x ⋅ z ≤ y ⋅ z"
  by (metis sup.absorb_iff1 sup_distr)

text ‹Left and right residuals can be defined in every proto-nearquantale.›
    
definition bres :: "'a ==> 'a ==> 'a" (infixr ‹→› 60) where 
  "x → z = ⊔{y. x ⋅ y ≤ z}"

definition fres :: "'a ==> 'a ==> 'a" (infixl ‹←› 60) where 
  "z ← y = ⊔{x. x ⋅ y ≤ z}"

text ‹The left one is a right adjoint to composition. For the right one, additional assumptions are needed›

lemma bres_galois_imp: "x ⋅ y ≤ z ==> y ≤ x → z"
  by (simp add: Sup_upper bres_def)
    
lemma fres_galois: "(x ⋅ y ≤ z) = (x ≤ z ← y)"
proof 
  show "x ⋅ y ≤ z ==> x ≤ z ← y"
    by (simp add: Sup_upper fres_def)
next
  assume "x ≤ z ← y"
  hence "x ⋅ y ≤ ⊔{x. x ⋅ y ≤ z} ⋅ y"
    by (simp add: fres_def mult_isor)
  also have "... = ⊔{x ⋅ y |x. x ⋅ y ≤ z}"
    by (simp add: Sup_distr setcompr_eq_image)
  also have "... ≤ z"
    by (rule Sup_least, auto)
  finally show "x ⋅ y ≤ z" .
qed

end

lemma fres_adj: "(λ(x::'a::proto_near_quantale). x ⋅ y) ⊣ (λx. x ← y)"
  by (simp add: adj_def fres_galois)

context proto_near_quantale
begin

lemma fres_canc1: "(y ← x) ⋅ x ≤ y"
  by (simp add: fres_galois)

lemma fres_canc2: "y ≤ (y ⋅ x) ← x"
  using fres_galois by force

lemma inf_fres: "y ⋅ x = ⊓{z. y ≤ z ← x}"
  by (metis (mono_tags, lifting) fres_canc2 Inf_eqI fres_galois mem_Collect_eq)

lemma bres_iso: "x ≤ y ==> z → x ≤ z → y"
  using Sup_le_iff bres_def bres_galois_imp by force

lemma bres_anti: "x ≤ y ==> y → z ≤ x → z"
  by (smt Sup_le_iff bres_def bres_galois_imp fres_galois order_trans mem_Collect_eq)

lemma fres_iso: "x ≤ y ==> x ← z ≤ y ← z"
  using fres_galois dual_order.trans by blast

lemma bres_top_top [simp]: "⊤ → ⊤ = ⊤"
  by (simp add: bres_galois_imp dual_order.antisym)

lemma fres_top_top [simp]: "⊤ ← ⊤ = ⊤"
  using fres_galois top_greatest top_le by blast

lemma bres_bot_bot [simp]: "⊥ → ⊥ = ⊤"
  by (simp add: bres_galois_imp top_le)

lemma left_sided_localp: "⊤ ⋅ y = y ==> x ⋅ y ≤ y"
  by (metis mult_isor top_greatest)

lemma fres_sol: "((y ← x) ⋅ x = y) = (∃z. z ⋅ x = y)"
  using dual_order.antisym fres_canc1 fres_canc2 mult_isor by fastforce

lemma sol_fres: "((y ⋅ x) ← x = y) = (∃z. y = z ← x)"
  by (metis fres_canc1 fres_canc2 fres_sol order.eq_iff fres_galois)

end

class proto_pre_quantale = proto_near_quantale + 
  assumes Sup_subdistl: "(⊔y ∈ Y. x ⋅ y) ≤ x ⋅ ⊔Y"
    
begin

lemma sup_subdistl: "(x ⋅ y) ⊔ (x ⋅ z) ≤ x ⋅ (y ⊔ z)"
  by (smt SUP_empty SUP_insert Sup_subdistl sup_Sup sup_bot_right)

lemma mult_isol: "x ≤ y ==> z ⋅ x ≤ z ⋅ y"
  by (metis le_iff_sup le_sup_iff sup_subdistl)

lemma fres_anti: "x ≤ y ==> z ← y ≤ z ← x"
  using dual_order.trans fres_galois mult_isol by blast

end
    
class weak_proto_quantale = proto_near_quantale +
  assumes weak_Sup_distl: "Y ≠ {} ==> x ⋅ ⊔Y = (⊔y ∈ Y. x ⋅ y)" 

begin

subclass proto_pre_quantale
proof unfold_locales
  have a: "∧x Y. Y = {} ==> (⊔y ∈ Y. x ⋅ y) ≤ x ⋅ ⊔Y"
    by simp
  have b: "∧x Y. Y ≠ {} ==> (⊔y ∈ Y. x ⋅ y) ≤ x ⋅ ⊔Y"
    by (simp add: weak_Sup_distl)
  show  "∧x Y. (⊔y ∈ Y. x ⋅ y) ≤ x ⋅ ⊔Y"
    using a b by blast
qed
  
lemma  sup_distl: "x ⋅ (y ⊔ z) = (x ⋅ y) ⊔ (x ⋅ z)"  
  using weak_Sup_distl[where Y="{y, z}"] by (fastforce intro!: Sup_eqI)

lemma "y ≤ x → z ⟶ x ⋅ y ≤ z" (* nitpick [expect = genuine] *)
oops

end
  
class proto_quantale = proto_near_quantale +
  assumes Sup_distl: "x ⋅ ⊔Y = (⊔y ∈ Y. x ⋅ y)"  

lemma Sup_pres_multl: "Sup_pres (λ(z::'a::proto_quantale). x ⋅ z)"
  unfolding fun_eq_iff comp_def Sup_distl by simp 

lemma sup_pres_multl: "sup_pres (λ(z::'a::proto_quantale). x ⋅ z)"
  by (metis (no_types, lifting) SUP_insert Sup_distl Sup_empty Sup_insert sup_bot_right)

lemma bot_pres_multl: "bot_pres (λ(z::'a::proto_quantale). x ⋅ z)"
  by (metis SUP_empty Sup_distl Sup_empty)

context proto_quantale
begin
 
subclass weak_proto_quantale
  by standard (simp add: Sup_distl)

lemma mult_botr [simp]: "x ⋅ ⊥ = ⊥"
  by (smt image_empty Sup_distl Sup_empty)

text ‹Now there is also an adjunction for the other residual.›
    
lemma bres_galois: "x ⋅ y ≤ z ⟷ y ≤ x → z"
proof 
  show "x ⋅ y ≤ z ==> y ≤ x → z"
    by (simp add: Sup_upper bres_def)
next
  assume "y ≤ x → z"
  hence "x ⋅ y ≤ x ⋅ ⊔{y. x ⋅ y ≤ z}"
    by (simp add: bres_def mult_isol)
  also have "... = ⊔{x ⋅ y |y. x ⋅ y ≤ z}"
    by (simp add: Sup_distl setcompr_eq_image)
  also have "... ≤ z"
    by (rule Sup_least, safe)
  finally show "x ⋅ y ≤ z" .
qed 

end

lemma bres_adj: "(λ(y::'a::proto_quantale). x ⋅ y) ⊣ (λy. x → y)"
  by (simp add: adj_def bres_galois)

context proto_quantale
begin

lemma bres_canc1: "x ⋅ (x → y) ≤ y"
  by (simp add: bres_galois)

lemma bres_canc2: "y ≤ x → (x ⋅ y)"
  by (simp add: bres_galois_imp)

lemma  inf_bres: "x ⋅ y = ⊓{z. y ≤ x → z}"
  using bres_galois fres_galois inf_fres by force

lemma bres_sol: "(x ⋅ (x → y) = y) = (∃z. x ⋅ z = y)"
  using bres_galois order.antisym mult_isol by force

lemma sol_bres: "(x → (x ⋅ y) = y) = (∃z. y = x → z)"
  by (metis bres_canc1 bres_canc2 bres_iso order.eq_iff)

end 

lemma bres_fres_clop: "clop (λx::'a::proto_quantale. y ← (x → y))"
  unfolding clop_def comp_def mono_def le_fun_def
  by (metis bres_anti bres_canc1 bres_galois_imp fres_anti fres_galois id_apply)

lemma fres_bres_clop: "clop (λx::'a::proto_quantale. (y ← x) → y)"
  unfolding clop_def comp_def mono_def le_fun_def
  by (metis bres_anti bres_canc1 bres_galois_imp fres_anti fres_canc1 fres_galois id_apply)


subsection ‹Families of Quantales›
  
class near_quantale = proto_near_quantale + semigroup_mult 

sublocale near_quantale ⊆ nsrnq: near_dioid "(⊔)" "(⋅)" "(≤)" "(<)"
  apply unfold_locales
       apply (simp add: sup_assoc)
      apply (simp add: sup_commute)
     apply (simp_all add: sup_distr)
   apply (simp add: le_iff_sup)
  by auto

context near_quantale
begin

lemma fres_curry: "(z ← y) ← x = z ← (x ⋅ y)"
  by (metis order.eq_iff fres_canc1 fres_galois mult_assoc)

end
  
class unital_near_quantale = near_quantale + monoid_mult

sublocale unital_near_quantale ⊆ nsrnqo: near_dioid_one "(⊔)" "(⋅)" "1""(≤)" "(<)"
  by (unfold_locales, simp_all)

context unital_near_quantale
begin

definition iter :: "'a ==> 'a" where
  "iter x ≡ ⊓i. x ^ i"

lemma iter_ref [simp]: "iter x ≤ 1"
  by (metis iter_def Inf_lower power.power_0 rangeI)
   
lemma le_top: "x ≤ ⊤ ⋅ x"
  by (metis mult.left_neutral mult_isor top_greatest)

lemma top_times_top [simp]: "⊤ ⋅ ⊤ = ⊤"
  by (simp add: le_top top_le)

lemma bres_one: "1 ≤ x → x"
  by (simp add: bres_galois_imp)

lemma fres_one: "1 ≤ x ← x"
  using fres_galois by fastforce

end
  
class pre_quantale = proto_pre_quantale + semigroup_mult 

begin

subclass near_quantale ..

lemma fres_interchange: "z ⋅ (x ← y) ≤ (z ⋅ x) ← y"
  using Sup_upper fres_canc1 fres_def mult_isol mult_assoc by fastforce

end

sublocale pre_quantale ⊆  psrpq: pre_dioid "(⊔)" "(⋅)" "(≤)" "(<)"
  by (unfold_locales, simp add: mult_isol)

class unital_pre_quantale = pre_quantale + monoid_mult

begin
  
subclass unital_near_quantale ..

text ‹Abstract rules of Hoare logic without the star can be derived.›

lemma h_w1: "x ≤ x' ==> x' ⋅ y ≤ z ==> x ⋅ y ≤ z"  
  by (simp add: fres_galois)

lemma h_w2: "x ⋅ y ≤ z' ==> z' ≤ z ==> x ⋅ y ≤ z"
  using order_trans by blast

lemma h_seq: "x ⋅ v ≤ z ==> y ⋅ w ≤ v ==> x ⋅ y ⋅ w ≤ z"
  using dual_order.trans mult_isol mult_assoc by presburger

lemma h_sup: "x ⋅ w ≤ z ==> y ⋅ w ≤ z ==> (x ⊔ y) ⋅ w ≤ z"
  by (simp add: fres_galois)

lemma h_Sup: "∀x ∈ X. x ⋅ w ≤ z ==> ⊔X ⋅ w ≤ z"
  by (simp add: Sup_least fres_galois)

end

sublocale unital_pre_quantale ⊆  psrpqo: pre_dioid_one "(⊔)" "(⋅)" "1" "(≤)" "(<)"..
    
class weak_quantale = weak_proto_quantale + semigroup_mult

begin
  
subclass pre_quantale ..
    
text ‹The following counterexample shows an important consequence of weakness:
  absence of right annihilation.›
    
lemma "x ⋅ ⊥ = ⊥" (*nitpick[expect=genuine]*)
  oops

end

class unital_weak_quantale = weak_quantale + monoid_mult
    
lemma (in unital_weak_quantale) "x ⋅ ⊥ = ⊥" (*nitpick[expect=genuine]*)
  oops
  
subclass (in unital_weak_quantale) unital_pre_quantale ..

sublocale unital_weak_quantale ⊆  wswq: dioid_one_zerol "(⊔)" "(⋅)" "1" "⊥" "(≤)" "(<)"
  by (unfold_locales, simp_all add: sup_distl)

    
class quantale = proto_quantale + semigroup_mult 
  
begin
  
subclass weak_quantale ..   

lemma Inf_subdistl: "x ⋅ ⊓Y ≤ (⊓y ∈ Y. x ⋅ y)"
  by (auto intro!: Inf_greatest Inf_lower mult_isol)

lemma Inf_subdistr: "⊓ X ⋅ y ≤ (⊓x ∈ X. x ⋅ y)"
  by (auto intro!: Inf_greatest Inf_lower mult_isor)
    
lemma fres_bot_bot [simp]: "⊥ ← ⊥ = ⊤"
  by (simp add: fres_def)

lemma bres_interchange: "(x → y) ⋅ z ≤ x → (y ⋅ z)"
  by (metis bres_canc1 bres_galois mult_isor mult_assoc)

lemma bres_curry: "x → (y → z) = (y ⋅ x) → z"
  by (metis bres_canc1 bres_galois dual_order.antisym mult_assoc)

lemma fres_bres: "x → (y ← z) = (x → y) ← z"
proof-
  {fix w
  have "(w ≤ x → (y ← z)) = (x ⋅ w ≤ y ← z)"
    by (simp add: bres_galois)
  also have "... = (x ⋅ w ⋅ z ≤ y)"
    by (simp add: fres_galois)
  also have "... = (w ⋅ z ≤ x → y)"
    by (simp add: bres_galois mult_assoc)
  also have "... = (w ≤ (x → y) ← z)"
    by (simp add: fres_galois)
  finally have "(w ≤ x → (y ← z)) = (w ≤ (x → y) ← z)".}
  thus ?thesis
    using order.eq_iff by blast
qed

end

class quantale_with_dual = quantale + complete_lattice_with_dual

class unital_quantale = quantale + monoid_mult

class unital_quantale_with_dual = unital_quantale + quantale_with_dual
  
subclass (in unital_quantale) unital_weak_quantale ..

sublocale unital_quantale ⊆ wswq: dioid_one_zero "(⊔)" "(⋅)" "1" "⊥" "(≤)" "(<)"
  by (unfold_locales, simp)

class ab_quantale = quantale + ab_semigroup_mult

begin

lemma bres_fres_eq: "x → y = y ← x" 
  by (simp add: fres_def bres_def mult_commute)

end

class ab_unital_quantale = ab_quantale + unital_quantale

sublocale complete_heyting_algebra ⊆ chaq: ab_unital_quantale "(⊓)" _ _ _ _ _ _ _ _ ⊤
  by (unfold_locales, simp add: inf.assoc, simp_all add: inf.assoc ch_dist inf.commute)

class distrib_quantale = quantale + distrib_lattice
  
class bool_quantale = quantale + complete_boolean_algebra_alt 
  
class distrib_unital_quantale = unital_quantale + distrib_lattice
  
class bool_unital_quantale = unital_quantale + complete_boolean_algebra_alt
  
class distrib_ab_quantale = distrib_quantale + ab_quantale
  
class bool_ab_quantale = bool_quantale + ab_quantale
  
class distrib_ab_unital_quantale = distrib_quantale + unital_quantale
  
class bool_ab_unital_quantale = bool_ab_quantale + unital_quantale

sublocale complete_boolean_algebra ⊆ cba_quantale: bool_ab_unital_quantale inf _ _ _ _ _ _ _ _ _ _ ⊤
  by (unfold_locales, simp add: inf.assoc, simp_all add: inf.commute Setcompr_eq_image inf_Sup Sup_inf)

context complete_boolean_algebra
begin

text ‹In this setting, residuation is classical implication.›
  
lemma cba_bres1: "x ⊓ y ≤ z ⟷ x ≤ cba_quantale.bres y z"
  using cba_quantale.bres_galois inf.commute by fastforce
    
lemma cba_bres2: "x ≤ -y ⊔ z ⟷ x ≤ cba_quantale.bres y z"
  using cba_bres1 shunt1 by auto
    
lemma cba_bres_prop: "cba_quantale.bres x y = -x ⊔ y"
  using cba_bres2 order.eq_iff by blast
  
end

subsection ‹Quantales Based on Sup-Lattices and Inf-Lattices›

text ‹These classes are defined for convenience in instantiation and interpretation proofs, or likewise.
  are useful, e.g., in the context of predicate transformers, where only one of Sup or Inf may be well behaved.›

class Sup_quantale = Sup_lattice + semigroup_mult + 
  assumes Supq_distr: "⊔X ⋅ y = (⊔x ∈ X. x ⋅ y)"
  and Supq_distl: "x ⋅ ⊔Y = (⊔y ∈ Y. x ⋅ y)"

class unital_Sup_quantale = Sup_quantale + monoid_mult

class Inf_quantale = Inf_lattice + monoid_mult + 
  assumes Supq_distr: "⊓X ⋅ y = (⊓x ∈ X. x ⋅ y)"
  and Supq_distl: "x ⋅ ⊓Y = (⊓y ∈ Y. x ⋅ y)"

class unital_Inf_quantale = Inf_quantale + monoid_mult

sublocale Inf_quantale ⊆ qdual: Sup_quantale _ Inf "(≥)"
  by (unfold_locales, simp_all add: Supq_distr Supq_distl)

sublocale unital_Inf_quantale ⊆ uqdual: unital_Sup_quantale _ _ Inf  "(≥)"..

sublocale Sup_quantale ⊆ supq: quantale _ Infs Sup_class.Sup infs "(≤)" le sups bots tops
  by (unfold_locales, simp_all add: Supq_distr Supq_distl)

sublocale unital_Sup_quantale ⊆ usupq: unital_quantale _ _ Infs Sup_class.Sup infs "(≤)" le sups bots tops..


subsection ‹Products of Quantales›
  
definition "Inf_prod X = ((⊓x ∈ X. fst x), (⊓x ∈ X. snd x))"
  
definition "inf_prod x y = (fst x ⊓ fst y, snd x ⊓ snd y)"

definition "bot_prod = (bot,bot)"
  
definition "Sup_prod X = ((⊔x ∈ X. fst x), (⊔x ∈ X. snd x))"
    
definition "sup_prod x y = (fst x ⊔ fst y, snd x ⊔ snd y)"
    
definition "top_prod = (top,top)"
    
definition "less_eq_prod x y ≡ less_eq (fst x) (fst y) ∧ less_eq (snd x) (snd y)"

definition "less_prod x y ≡ less_eq (fst x) (fst y) ∧ less_eq (snd x) (snd y) ∧ x ≠ y"
  
definition "times_prod' x y = (fst x ⋅ fst y, snd x ⋅ snd y)"

definition "one_prod = (1,1)"

definition "dual_prod x = (∂ (fst x),∂ (snd x))"
  
interpretation prod: complete_lattice Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::complete_lattice × 'b::complete_lattice)"
  by standard (auto simp add: Inf_prod_def Sup_prod_def inf_prod_def sup_prod_def bot_prod_def top_prod_def less_eq_prod_def less_prod_def Sup_distl Sup_distr intro: Inf_lower Inf_greatest Sup_upper Sup_least)

interpretation prod: complete_lattice_with_dual Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::complete_lattice_with_dual × 'b::complete_lattice_with_dual)" dual_prod
  by standard (simp_all add: dual_prod_def fun_eq_iff inj_def Sup_prod_def Inf_prod_def inj_dual_iff Sup_dual_def_var image_comp)

interpretation prod: proto_near_quantale Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::proto_near_quantale × 'b::proto_near_quantale)" times_prod'
  by standard (simp add: times_prod'_def Sup_prod_def Sup_distr image_comp)

interpretation prod: proto_quantale Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::proto_quantale × 'b::proto_quantale)" times_prod'
  by standard (simp add: times_prod'_def Sup_prod_def less_eq_prod_def Sup_distl image_comp)

interpretation prod: unital_quantale one_prod times_prod' Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::unital_quantale × 'b::unital_quantale)" 
  by standard (simp_all add: one_prod_def times_prod'_def ac_simps image_comp)


subsection ‹Quantale Morphisms›

text ‹There are various ways of defining quantale morphisms, depending on the application. Following Rosenthal,
  present the most important one.›

abbreviation comp_pres :: "('a::times ==> 'b::times) ==> bool" where
  "comp_pres f ≡ (∀x y. f (x ⋅ y) = f x ⋅ f y)"

abbreviation un_pres :: "('a::one ==> 'b::one) ==> bool" where
  "un_pres f ≡ (f 1 = 1)"

definition "comp_closed_set X = (∀x ∈ X. ∀y ∈ X. x ⋅ y ∈ X)" 

definition "un_closed_set X = (1 ∈ X)" 

definition quantale_homset :: "('a::quantale ==> 'b::quantale) set" where
  "quantale_homset = {f. comp_pres f ∧ Sup_pres f}"

lemma quantale_homset_iff: "f ∈ quantale_homset = (comp_pres f ∧ Sup_pres f)"
  unfolding quantale_homset_def by clarsimp

definition unital_quantale_homset :: "('a::unital_quantale ==> 'b::unital_quantale) set" where
  "unital_quantale_homset = {f. comp_pres f ∧ Sup_pres f ∧ un_pres f}"

lemma unital_quantale_homset_iff: "f ∈ unital_quantale_homset = (comp_pres f ∧ Sup_pres f ∧ un_pres f)"
  unfolding unital_quantale_homset_def by clarsimp

text ‹Though Infs can be defined from Sups in any quantale, quantale morphisms do not generally preserve Infs.
  different kind of morphism is needed if this is to be guaranteed.›

lemma "f ∈ quantale_homset ==> Inf_pres f" (*nitpick*)
  oops

text ‹The images of quantale morphisms are closed under compositions and Sups, hence they form quantales.›

lemma quantale_hom_q_pres: "f ∈ quantale_homset ==> Sup_closed_set (range f) ∧ comp_closed_set (range f)"
  apply safe
   apply (simp add: Sup_pres_Sup_closed quantale_homset_iff)
  unfolding quantale_homset_iff comp_closed_set_def by (metis (no_types, lifting) imageE range_eqI) 

text ‹Yet the image need not be Inf-closed.›

lemma "f ∈ quantale_homset ==> Inf_closed_set (range f)" (*nitpick*)
  oops

text ‹Of course Sups are preserved by quantale-morphisms, hence they are the same in subsets as in the original set.
  in the subset, however, exist, since they subset forms a quantale in which Infs can be defined, but these are generally
  from the Infs in the superstructure.

  fact is hidden in Isabelle's definition of complete lattices, where Infs are axiomatised. There is no easy way in general to
  that images of quantale morphisms form quantales, though the statement for Sup-quantales is straightforward. I show this for quantic nuclei
  left-sided elements.›

typedef (overloaded) ('a,'b) quantale_homset = "quantale_homset::('a::quantale ==> 'b::quantale) set"
proof-
  have a: "comp_pres (λx::'a::quantale. bot::'b)"
    by simp
  have b: "Sup_pres (λx::'a::quantale. bot::'b)"
    unfolding fun_eq_iff comp_def by simp
  hence "(λx::'a::quantale. bot::'b) ∈ quantale_homset"
    by (simp add: quantale_homset_iff)
  thus ?thesis
    by auto
qed

setup_lifting type_definition_quantale_homset

text ‹Interestingly, the following type is not (gobally) inhabited.›

typedef (overloaded) ('a,'b) unital_quantale_homset = "unital_quantale_homset::('a::unital_quantale ==> 'b::unital_quantale) set" (*nitpick*)
  oops

lemma quantale_hom_radj: 
  fixes f :: "'a::quantale_with_dual ==> 'b::quantale_with_dual"
  shows "f ∈ quantale_homset ==> f ⊣ radj f"
  unfolding quantale_homset_iff by (simp add: Sup_pres_ladj_aux)

lemma quantale_hom_prop1: 
  fixes f :: "'a::quantale_with_dual ==> 'b::quantale_with_dual"
  shows "f ∈ quantale_homset ==> radj f (f x → y) = x → radj f y"
proof-
  assume h: "f ∈ quantale_homset"
  have "f x ⋅ f (radj f (f x → y)) ≤ y"
    by (meson h adj_def bres_galois order_refl quantale_hom_radj)
  hence "f (x ⋅ radj f (f x → y)) ≤ y"
    by (metis h quantale_homset_iff)
  hence "x ⋅ radj f (f x → y) ≤ radj f y"
    using adj_def h quantale_hom_radj by blast
  hence le: "radj f (f x → y) ≤ x → radj f y"
    by (simp add: bres_galois)
  have "x ⋅ (x → radj f y) ≤ radj f y"
    by (simp add: bres_canc1)
  hence  "f (x ⋅ (x → radj f y)) ≤ y"
    using adj_def h quantale_hom_radj by blast
  hence "f x ⋅ f (x → radj f y) ≤ y"
    by (metis h quantale_homset_iff)
  hence "f (x → radj f y) ≤ f x → y"
    by (simp add: bres_galois)
  hence "x → radj f y ≤ radj f (f x → y)"
    using adj_def h quantale_hom_radj by blast
  thus ?thesis
    by (simp add: dual_order.antisym le)
qed

lemma quantale_hom_prop2: 
  fixes f :: "'a::quantale_with_dual ==> 'b::quantale_with_dual"
  shows "f ∈ quantale_homset ==> radj f (y ← f x) = radj f y ← x"
proof-
  assume h: "f ∈ quantale_homset"
  have "f (radj f (y ← f x)) ⋅ f x ≤ y"
    by (meson adj_def fres_galois h order_refl quantale_hom_radj)
  hence "f (radj f (y ← f x) ⋅ x) ≤ y"
    by (metis h quantale_homset_iff)
  hence "radj f (y ← f x) ⋅ x≤ radj f y"
    using adj_def h quantale_hom_radj by blast
  hence le: "radj f (y ← f x) ≤ radj f y ← x"
    by (simp add: fres_galois)
  have "(radj f y ← x) ⋅ x ≤ radj f y"
    by (simp add: fres_canc1)
  hence  "f ((radj f y ← x) ⋅ x) ≤ y"
    using adj_def h quantale_hom_radj by blast
  hence "f (radj f y ← x) ⋅ f x≤ y"
    by (metis h quantale_homset_iff)
  hence "f (radj f y ← x) ≤ y ← f x"
    by (simp add: fres_galois)
  hence "radj f y ← x≤ radj f (y ← f x)"
    using adj_def h quantale_hom_radj by blast
  thus ?thesis
    by (simp add: dual_order.antisym le)
qed

definition quantale_closed_maps :: "('a::quantale ==> 'b::quantale) set" where
  "quantale_closed_maps = {f. (∀x y. f x ⋅ f y ≤ f (x ⋅ y))}"

lemma quantale_closed_maps_iff: "f ∈ quantale_closed_maps = (∀ x y. f x ⋅ f y ≤ f (x ⋅ y))"
  unfolding quantale_closed_maps_def by clarsimp

definition quantale_closed_Sup_maps :: "('a::quantale ==> 'b::quantale) set" where
  "quantale_closed_Sup_maps = {f. (∀ x y. f x ⋅ f y ≤ f (x ⋅ y)) ∧ Sup_pres f}"

lemma quantale_closed_Sup_maps_iff: "f ∈ quantale_closed_Sup_maps = (∀ x y. f x ⋅ f y ≤ f (x ⋅ y) ∧ Sup_pres f)"
  unfolding quantale_closed_Sup_maps_def by clarsimp

definition quantale_closed_unital_maps :: "('a::unital_quantale ==> 'b::unital_quantale) set" where
  "quantale_closed_unital_maps = {f. (∀ x y. f x ⋅ f y ≤ f (x ⋅ y)) ∧ 1 ≤ f 1}"

lemma quantale_closed_unital_maps_iff: "f ∈ quantale_closed_unital_maps = (∀ x y. f x ⋅ f y ≤ f (x ⋅ y) ∧ 1 ≤ f 1)"
  unfolding quantale_closed_unital_maps_def by clarsimp

definition quantale_closed_unital_Sup_maps :: "('a::unital_quantale ==> 'b::unital_quantale) set" where
  "quantale_closed_unital_Sup_maps = {f. (∀ x y. f x ⋅ f y ≤ f (x ⋅ y)) ∧ Sup_pres f ∧ 1 ≤ f 1}"

lemma quantale_closed_unital_Sup_maps_iff: "f ∈ quantale_closed_unital_Sup_maps = (∀ x y. f x ⋅ f y ≤ f (x ⋅ y) ∧ Sup_pres f ∧ 1 ≤ f 1)"
  unfolding quantale_closed_unital_Sup_maps_def by clarsimp

text ‹Closed maps are the right adjoints of quantale morphisms.›

lemma quantale_hom_closed_map:
  fixes f :: "'a::quantale_with_dual ==> 'b::quantale_with_dual"
  shows "(f ∈ quantale_homset) ==> (radj f ∈ quantale_closed_maps)"
proof-
  assume h: "f ∈ quantale_homset"
  have "∀x y. f (radj f x) ⋅ f (radj f y) ≤ x ⋅ y"
    by (metis adj_def h order_refl psrpq.mult_isol_var quantale_hom_radj) 
  hence "∀x y. f (radj f x ⋅ radj f y) ≤ x ⋅ y"
    by (metis h quantale_homset_iff)
  hence "∀x y. radj f x ⋅ radj f y ≤ radj f (x ⋅ y)"
    using adj_def h quantale_hom_radj by blast
  thus ?thesis
    by (simp add: quantale_closed_maps_iff)
qed

lemma unital_quantale_hom_closed_unital_map:
  fixes f :: "'a::unital_quantale_with_dual ==> 'b::unital_quantale_with_dual"
  shows "(f ∈ unital_quantale_homset) ==> (radj f ∈ quantale_closed_unital_maps)"
  by (metis (no_types, opaque_lifting) adj_def order_refl quantale_closed_maps_iff quantale_closed_unital_maps_iff quantale_hom_closed_map quantale_hom_radj quantale_homset_iff unital_quantale_homset_iff)

 end