header{* Free algebras for an BNF *}
theory Tree_FreeAlg1
imports Tree_Input1
begin
declare K1.map_transfer[transfer_rule]
composition_bnf (open) raw_Σ1: "'a Σ0 + 'a K1"
typedef 'a Σ1 = "UNIV :: ('a Σ0 + 'a K1) set" by (rule UNIV_witness)
setup_lifting type_definition_Σ1
lift_definition Σ1_map :: "('a => 'b) => 'a Σ1 => 'b Σ1" is "λf. map_sum (Σ0_map f) (K1_map f)" .
lift_definition Σ1_set :: "'a Σ1 => 'a set"
is "λx. UNION (Basic_BNFs.setl x) Σ0_set ∪ UNION (Basic_BNFs.setr x) K1_set" .
lift_definition Σ1_rel :: "('a => 'b => bool) => 'a Σ1 => 'b Σ1 => bool"
is "λR. rel_sum (Σ0_rel R) (K1_rel R)" .
typedef Σ1_bd_type = "UNIV :: ((Σ0_bd_type + bd_type_K1) × nat) set" by (rule UNIV_witness)
definition "Σ1_bd = dir_image ((Σ0_bd +c bd_K1) *c natLeq) Abs_Σ1_bd_type"
bnf "'a Σ1"
map: Σ1_map
sets: Σ1_set
bd: Σ1_bd
rel: Σ1_rel
unfolding Σ1_bd_def
apply -
apply transfer apply (rule raw_Σ1.map_id0)
apply transfer apply (rule raw_Σ1.map_comp0)
apply transfer apply (erule raw_Σ1.map_cong0)
apply transfer apply (rule raw_Σ1.set_map0)
apply (rule card_order_dir_image[OF bijI raw_Σ1.bd_card_order])
apply (metis inj_on_def Abs_Σ1_bd_type_inverse[OF UNIV_I])
apply (metis surj_def Abs_Σ1_bd_type_cases)
apply (rule conjunct1[OF Cinfinite_cong[OF dir_image[OF _ raw_Σ1.bd_Card_order] raw_Σ1.bd_Cinfinite]])
apply (metis Abs_Σ1_bd_type_inverse[OF UNIV_I])
apply (unfold Σ1_set_def map_fun_def id_o) [1] apply (subst o_apply)
apply (rule ordLeq_ordIso_trans[OF raw_Σ1.set_bd dir_image[OF _ raw_Σ1.bd_Card_order]])
apply (metis Abs_Σ1_bd_type_inverse[OF UNIV_I])
apply (rule predicate2I) apply transfer apply (subst raw_Σ1.rel_compp) apply assumption
apply transfer' apply (rule raw_Σ1.rel_compp_Grp)
done
declare Σ1.map_transfer[transfer_rule]
lemma Rep_Σ1_transfer[transfer_rule]: "(Σ1_rel R ===> rel_sum (Σ0_rel R) (K1_rel R)) Rep_Σ1 Rep_Σ1"
unfolding rel_fun_def by transfer blast
lemma Abs_Σ1_transfer[transfer_rule]: "(rel_sum (Σ0_rel R) (K1_rel R) ===> Σ1_rel R) Abs_Σ1 Abs_Σ1"
unfolding rel_fun_def by transfer blast
theorem Rep_Σ1_natural: "map_sum (Σ0_map f) (K1_map f) o Rep_Σ1 = Rep_Σ1 o Σ1_map f"
using Rep_Σ1_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ1.rel_Grp raw_Σ1.rel_Grp
unfolding Grp_def rel_fun_def by auto
theorem Abs_Σ1_natural: "Σ1_map f o Abs_Σ1 = Abs_Σ1 o map_sum (Σ0_map f) (K1_map f)"
using Abs_Σ1_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ1.rel_Grp raw_Σ1.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma Rep_Σ1_o_Abs_Σ1: "Rep_Σ1 o Abs_Σ1 = id"
apply (rule ext)
apply (rule box_equals[OF _ o_apply[symmetric] id_apply[symmetric]])
apply (rule Abs_Σ1_inverse[OF UNIV_I])
done
lemma Σ1_rel_Σ1_map_Σ1_map:
"Σ1_rel R (Σ1_map f x) (Σ1_map g y) = Σ1_rel (BNF_Def.vimage2p f g R) x y"
unfolding Σ1.rel_Grp vimage2p_Grp Σ1.rel_compp Σ1.rel_conversep
unfolding relcompp.simps Grp_def by simp
subsection{* Definitions and basic setup *}
datatype_new (ΣΣ1_set: 'x) ΣΣ1 =
\<oo>\<pp>1 "'x ΣΣ1 Σ1" | leaf1 "'x"
for map: ΣΣ1_map rel: ΣΣ1_rel
declare ΣΣ1.ctor_fold_transfer
[unfolded rel_pre_ΣΣ1_def id_apply BNF_Comp.id_bnf_comp_def vimage2p_def, transfer_rule]
lemma \<oo>\<pp>1_transfer[transfer_rule]:
"(Σ1_rel (ΣΣ1_rel R) ===> ΣΣ1_rel R) \<oo>\<pp>1 \<oo>\<pp>1"
by (rule rel_funI) (erule iffD2[OF ΣΣ1.rel_inject(1)])
lemma leaf1_transfer[transfer_rule]: "(R ===> ΣΣ1_rel R) leaf1 leaf1"
by (rule rel_funI) (erule iffD2[OF ΣΣ1.rel_inject(2)])
abbreviation "ext1 s ≡ rec_ΣΣ1 (s o Σ1_map snd)"
lemmas ext1_\<oo>\<pp>1 = ΣΣ1.rec(1)[of "s o Σ1_map snd" for s,
unfolded o_apply Σ1.map_comp snd_convol[unfolded convol_def]]
lemmas ext1_leaf1 = ΣΣ1.rec(2)[of "s o Σ1_map snd" for s,
unfolded o_apply Σ1.map_comp snd_convol[unfolded convol_def]]
lemmas leaf1_inj = ΣΣ1.inject(2)
lemmas \<oo>\<pp>1_inj = ΣΣ1.inject(1)
lemma ext1_alt: "ext1 s f = ctor_fold_ΣΣ1 (case_sum s f)"
apply (rule ΣΣ1.ctor_fold_unique)
apply (rule ext)
apply (rename_tac x)
apply (case_tac x)
apply (auto simp only: rec_ΣΣ1_def ΣΣ1.ctor_rec fun_eq_iff o_apply BNF_Comp.id_bnf_comp_def
id_def[symmetric] o_id map_pre_ΣΣ1_def id_apply map_sum.simps sum.inject sum.distinct
Σ1.map_comp snd_convol split: sum.splits)
done
lemma \<oo>\<pp>1_def_pointfree: "\<oo>\<pp>1 ≡ ctor_ΣΣ1 o Inl"
unfolding \<oo>\<pp>1_def comp_def BNF_Comp.id_bnf_comp_def .
lemma leaf1_def_pointfree: "leaf1 ≡ ctor_ΣΣ1 o Inr"
unfolding leaf1_def comp_def BNF_Comp.id_bnf_comp_def .
definition flat1 :: "('x ΣΣ1) ΣΣ1 => 'x ΣΣ1" where
flat1_def: "flat1 ≡ ext1 \<oo>\<pp>1 id"
lemma flat1_transfer[transfer_rule]: "(ΣΣ1_rel (ΣΣ1_rel R) ===> ΣΣ1_rel R) flat1 flat1"
unfolding flat1_def ext1_alt by transfer_prover
lemma ctor_fold_ΣΣ1_pointfree:
"ctor_fold_ΣΣ1 s o ctor_ΣΣ1 = s o (map_pre_ΣΣ1 id (ctor_fold_ΣΣ1 s))"
unfolding comp_def ΣΣ1.ctor_fold ..
lemma ΣΣ1_map_ctor_ΣΣ1:
"ΣΣ1_map f o ctor_ΣΣ1 = ctor_ΣΣ1 o map_sum (Σ1_map (ΣΣ1_map f)) f"
unfolding comp_def
unfolding fun_eq_iff
unfolding ΣΣ1.ctor_map
unfolding map_pre_ΣΣ1_def
unfolding id_apply BNF_Comp.id_bnf_comp_def id_def[symmetric] o_id id_o by simp
lemma dtor_ΣΣ1_ΣΣ1_map:
"dtor_ΣΣ1 o ΣΣ1_map f = map_sum (Σ1_map (ΣΣ1_map f)) f o dtor_ΣΣ1"
using ΣΣ1_map_ctor_ΣΣ1[of f] ΣΣ1.dtor_ctor ΣΣ1.ctor_dtor unfolding comp_def fun_eq_iff by metis
lemma dtor_ΣΣ1_ctor_ΣΣ1: "dtor_ΣΣ1 o ctor_ΣΣ1 = id"
unfolding comp_def ΣΣ1.dtor_ctor id_def ..
lemma ctor_ΣΣ1_dtor_ΣΣ1: "ctor_ΣΣ1 o dtor_ΣΣ1 = id"
unfolding comp_def ΣΣ1.ctor_dtor id_def ..
lemma ΣΣ1_rel_inf: "ΣΣ1_rel (R \<sqinter> Σ0) ≤ ΣΣ1_rel R \<sqinter> ΣΣ1_rel Σ0"
apply (rule inf_greatest)
apply (rule ΣΣ1.rel_mono[OF inf_sup_ord(1)])
apply (rule ΣΣ1.rel_mono[OF inf_sup_ord(2)])
done
lemma ΣΣ1_rel_Grp_ΣΣ1_map: "ΣΣ1_rel (BNF_Def.Grp UNIV f) x y <-> ΣΣ1_map f x = y"
unfolding ΣΣ1.rel_Grp by (auto simp: Grp_def)
lemma ΣΣ1_rel_ΣΣ1_map_ΣΣ1_map: "ΣΣ1_rel R (ΣΣ1_map f x) (ΣΣ1_map g y) =
ΣΣ1_rel (BNF_Def.vimage2p f g R) x y"
unfolding ΣΣ1.rel_Grp vimage2p_Grp apply (auto simp: ΣΣ1.rel_compp ΣΣ1.rel_conversep relcompp.simps)
apply (intro exI conjI)
apply (rule iffD2[OF ΣΣ1_rel_Grp_ΣΣ1_map refl])
apply assumption
apply (rule iffD2[OF ΣΣ1_rel_Grp_ΣΣ1_map refl])
unfolding ΣΣ1_rel_Grp_ΣΣ1_map
apply simp
done
subsection{* @{term Σ1} extension theorems *}
theorem ext1_commute:
"ext1 s i o \<oo>\<pp>1 = s o Σ1_map (ext1 s i)"
unfolding ext1_alt \<oo>\<pp>1_def_pointfree o_assoc ctor_fold_ΣΣ1_pointfree map_pre_ΣΣ1_def
case_sum_o_map_sum case_sum_o_inj(1) BNF_Comp.id_bnf_comp_def id_def[symmetric] o_id ..
theorem ext1_comp_leaf1:
"ext1 s i o leaf1 = i"
unfolding ext1_alt leaf1_def_pointfree o_assoc ctor_fold_ΣΣ1_pointfree map_pre_ΣΣ1_def
case_sum_o_map_sum case_sum_o_inj(2) id_apply BNF_Comp.id_bnf_comp_def id_def[symmetric] o_id ..
theorem ext1_unique:
assumes leaf1: "f o leaf1 = i" and com: "f o \<oo>\<pp>1 = s o Σ1_map f"
shows "f = ext1 s i"
unfolding ext1_alt
apply (rule ΣΣ1.ctor_fold_unique)
apply (rule sum_comp_cases)
unfolding map_pre_ΣΣ1_def case_sum_o_map_sum id_apply o_id case_sum_o_inj
leaf1[unfolded leaf1_def_pointfree o_assoc] com[unfolded \<oo>\<pp>1_def_pointfree o_assoc]
BNF_Comp.id_bnf_comp_def id_def[symmetric] id_o
by (rule refl)+
subsection{* Customizing @{term ΣΣ1} *}
subsection{* Injectiveness, naturality, adjunction *}
theorem leaf1_natural: "ΣΣ1_map f o leaf1 = leaf1 o f"
using leaf1_transfer[of "BNF_Def.Grp UNIV f"]
unfolding ΣΣ1.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma \<oo>\<pp>1_natural: "\<oo>\<pp>1 o Σ1_map (ΣΣ1_map f) = ΣΣ1_map f o \<oo>\<pp>1"
using \<oo>\<pp>1_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ1.rel_Grp ΣΣ1.rel_Grp Σ1_map_def
unfolding Grp_def rel_fun_def by auto
lemma ΣΣ1_map_def2: "ΣΣ1_map i = ext1 \<oo>\<pp>1 (leaf1 o i)"
by (rule ext1_unique[OF leaf1_natural \<oo>\<pp>1_natural[symmetric]])
lemma ext1_\<oo>\<pp>1_leaf1: "ext1 \<oo>\<pp>1 leaf1 = id"
apply (rule ext1_unique[symmetric]) unfolding Σ1.map_id0 o_id id_o by (rule refl)+
lemma ext1_ΣΣ1_map:
"ext1 s (j o f) = ext1 s j o ΣΣ1_map f"
proof (rule ext1_unique[symmetric])
show "ext1 s j o ΣΣ1_map f o leaf1 = j o f"
unfolding o_assoc[symmetric] leaf1_natural
unfolding o_assoc ext1_comp_leaf1 ..
next
show "ext1 s j o ΣΣ1_map f o \<oo>\<pp>1 = s o Σ1_map (ext1 s j o ΣΣ1_map f)"
unfolding o_assoc[symmetric] \<oo>\<pp>1_natural[symmetric]
unfolding o_assoc ext1_commute
unfolding o_assoc[symmetric] Σ1.map_comp0 ..
qed
lemma ext1_Σ1_map:
assumes "t o Σ1_map f = f o s"
shows "ext1 t (f o i) = f o ext1 s i"
proof (rule ext1_unique[symmetric])
show "f o ext1 s i o leaf1 = f o i"
unfolding o_assoc[symmetric] ext1_comp_leaf1 ..
next
show "f o ext1 s i o \<oo>\<pp>1 = t o Σ1_map (f o ext1 s i)"
unfolding Σ1.map_comp0 o_assoc assms
unfolding o_assoc[symmetric] ext1_commute[symmetric] ..
qed
subsection{* Monadic laws *}
lemma flat1_commute: "\<oo>\<pp>1 o Σ1_map flat1 = flat1 o \<oo>\<pp>1"
unfolding flat1_def ext1_commute ..
theorem flat1_leaf1: "flat1 o leaf1 = id"
unfolding flat1_def ext1_comp_leaf1 ..
theorem leaf1_flat1: "flat1 o ΣΣ1_map leaf1 = id"
unfolding flat1_def ext1_ΣΣ1_map[symmetric] id_o ext1_\<oo>\<pp>1_leaf1 ..
theorem flat1_natural: "flat1 o ΣΣ1_map (ΣΣ1_map i) = ΣΣ1_map i o flat1"
using flat1_transfer[of "BNF_Def.Grp UNIV i"]
unfolding prod.rel_Grp ΣΣ1.rel_Grp
unfolding Grp_def rel_fun_def by auto
theorem flat1_assoc: "flat1 o ΣΣ1_map flat1 = flat1 o flat1"
unfolding flat1_def unfolding ext1_ΣΣ1_map[symmetric] id_o
proof(rule ext1_unique[symmetric], unfold flat1_def[symmetric])
show "flat1 o flat1 o leaf1 = flat1"
unfolding o_assoc[symmetric] flat1_leaf1 o_id ..
next
show "flat1 o flat1 o \<oo>\<pp>1 = \<oo>\<pp>1 o Σ1_map (flat1 o flat1)"
unfolding flat1_def unfolding o_assoc[symmetric] ext1_commute
unfolding flat1_def[symmetric]
unfolding Σ1.map_comp0 o_assoc unfolding flat1_commute ..
qed
definition K1_as_ΣΣ1 :: "'a K1 => 'a ΣΣ1" where
"K1_as_ΣΣ1 ≡ \<oo>\<pp>1 o Σ1_map leaf1 o Abs_Σ1 o Inr"
lemma K1_as_ΣΣ1_transfer[transfer_rule]:
"(K1_rel R ===> ΣΣ1_rel R) K1_as_ΣΣ1 K1_as_ΣΣ1"
unfolding K1_as_ΣΣ1_def by transfer_prover
lemma K1_as_ΣΣ1_natural:
"K1_as_ΣΣ1 o K1_map f = ΣΣ1_map f o K1_as_ΣΣ1"
using K1_as_ΣΣ1_transfer[of "BNF_Def.Grp UNIV f"]
unfolding K1.rel_Grp ΣΣ1.rel_Grp
unfolding Grp_def rel_fun_def by auto
end