header{* Free algebras for an BNF *}
theory Tree_FreeAlg2
imports Tree_Input2
begin
declare K2.map_transfer[transfer_rule]
composition_bnf (open) raw_Σ2: "'a Σ1 + 'a K2"
typedef 'a Σ2 = "UNIV :: ('a Σ1 + 'a K2) set" by (rule UNIV_witness)
setup_lifting type_definition_Σ2
lift_definition Σ2_map :: "('a => 'b) => 'a Σ2 => 'b Σ2" is "λf. map_sum (Σ1_map f) (K2_map f)" .
lift_definition Σ2_set :: "'a Σ2 => 'a set"
is "λx. UNION (Basic_BNFs.setl x) Σ1_set ∪ UNION (Basic_BNFs.setr x) K2_set" .
lift_definition Σ2_rel :: "('a => 'b => bool) => 'a Σ2 => 'b Σ2 => bool"
is "λR. rel_sum (Σ1_rel R) (K2_rel R)" .
typedef Σ2_bd_type = "UNIV :: ((Σ1_bd_type + bd_type_K2) × nat) set" by (rule UNIV_witness)
definition "Σ2_bd = dir_image ((Σ1_bd +c bd_K2) *c natLeq) Abs_Σ2_bd_type"
bnf "'a Σ2"
map: Σ2_map
sets: Σ2_set
bd: Σ2_bd
rel: Σ2_rel
unfolding Σ2_bd_def
apply -
apply transfer apply (rule raw_Σ2.map_id0)
apply transfer apply (rule raw_Σ2.map_comp0)
apply transfer apply (erule raw_Σ2.map_cong0)
apply transfer apply (rule raw_Σ2.set_map0)
apply (rule card_order_dir_image[OF bijI raw_Σ2.bd_card_order])
apply (metis inj_on_def Abs_Σ2_bd_type_inverse[OF UNIV_I])
apply (metis surj_def Abs_Σ2_bd_type_cases)
apply (rule conjunct1[OF Cinfinite_cong[OF dir_image[OF _ raw_Σ2.bd_Card_order] raw_Σ2.bd_Cinfinite]])
apply (metis Abs_Σ2_bd_type_inverse[OF UNIV_I])
apply (unfold Σ2_set_def map_fun_def id_o) [1] apply (subst o_apply)
apply (rule ordLeq_ordIso_trans[OF raw_Σ2.set_bd dir_image[OF _ raw_Σ2.bd_Card_order]])
apply (metis Abs_Σ2_bd_type_inverse[OF UNIV_I])
apply (rule predicate2I) apply transfer apply (subst raw_Σ2.rel_compp) apply assumption
apply transfer' apply (rule raw_Σ2.rel_compp_Grp)
done
declare Σ2.map_transfer[transfer_rule]
lemma Rep_Σ2_transfer[transfer_rule]: "(Σ2_rel R ===> rel_sum (Σ1_rel R) (K2_rel R)) Rep_Σ2 Rep_Σ2"
unfolding rel_fun_def by transfer blast
lemma Abs_Σ2_transfer[transfer_rule]: "(rel_sum (Σ1_rel R) (K2_rel R) ===> Σ2_rel R) Abs_Σ2 Abs_Σ2"
unfolding rel_fun_def by transfer blast
theorem Rep_Σ2_natural: "map_sum (Σ1_map f) (K2_map f) o Rep_Σ2 = Rep_Σ2 o Σ2_map f"
using Rep_Σ2_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ2.rel_Grp raw_Σ2.rel_Grp
unfolding Grp_def rel_fun_def by auto
theorem Abs_Σ2_natural: "Σ2_map f o Abs_Σ2 = Abs_Σ2 o map_sum (Σ1_map f) (K2_map f)"
using Abs_Σ2_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ2.rel_Grp raw_Σ2.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma Rep_Σ2_o_Abs_Σ2: "Rep_Σ2 o Abs_Σ2 = id"
apply (rule ext)
apply (rule box_equals[OF _ o_apply[symmetric] id_apply[symmetric]])
apply (rule Abs_Σ2_inverse[OF UNIV_I])
done
lemma Σ2_rel_Σ2_map_Σ2_map:
"Σ2_rel R (Σ2_map f x) (Σ2_map g y) = Σ2_rel (BNF_Def.vimage2p f g R) x y"
unfolding Σ2.rel_Grp vimage2p_Grp Σ2.rel_compp Σ2.rel_conversep
unfolding relcompp.simps Grp_def by simp
subsection{* Definitions and basic setup *}
datatype_new (ΣΣ2_set: 'x) ΣΣ2 =
\<oo>\<pp>2 "'x ΣΣ2 Σ2" | leaf2 "'x"
for map: ΣΣ2_map rel: ΣΣ2_rel
declare ΣΣ2.ctor_fold_transfer
[unfolded rel_pre_ΣΣ2_def id_apply BNF_Comp.id_bnf_comp_def vimage2p_def, transfer_rule]
lemma \<oo>\<pp>2_transfer[transfer_rule]:
"(Σ2_rel (ΣΣ2_rel R) ===> ΣΣ2_rel R) \<oo>\<pp>2 \<oo>\<pp>2"
by (rule rel_funI) (erule iffD2[OF ΣΣ2.rel_inject(1)])
lemma leaf2_transfer[transfer_rule]: "(R ===> ΣΣ2_rel R) leaf2 leaf2"
by (rule rel_funI) (erule iffD2[OF ΣΣ2.rel_inject(2)])
abbreviation "ext2 s ≡ rec_ΣΣ2 (s o Σ2_map snd)"
lemmas ext2_\<oo>\<pp>2 = ΣΣ2.rec(1)[of "s o Σ2_map snd" for s,
unfolded o_apply Σ2.map_comp snd_convol[unfolded convol_def]]
lemmas ext2_leaf2 = ΣΣ2.rec(2)[of "s o Σ2_map snd" for s,
unfolded o_apply Σ2.map_comp snd_convol[unfolded convol_def]]
lemmas leaf2_inj = ΣΣ2.inject(2)
lemmas \<oo>\<pp>2_inj = ΣΣ2.inject(1)
lemma ext2_alt: "ext2 s f = ctor_fold_ΣΣ2 (case_sum s f)"
apply (rule ΣΣ2.ctor_fold_unique)
apply (rule ext)
apply (rename_tac x)
apply (case_tac x)
apply (auto simp only: rec_ΣΣ2_def ΣΣ2.ctor_rec fun_eq_iff o_apply BNF_Comp.id_bnf_comp_def
id_def[symmetric] o_id map_pre_ΣΣ2_def id_apply map_sum.simps sum.inject sum.distinct
Σ2.map_comp snd_convol split: sum.splits)
done
lemma \<oo>\<pp>2_def_pointfree: "\<oo>\<pp>2 ≡ ctor_ΣΣ2 o Inl"
unfolding \<oo>\<pp>2_def comp_def BNF_Comp.id_bnf_comp_def .
lemma leaf2_def_pointfree: "leaf2 ≡ ctor_ΣΣ2 o Inr"
unfolding leaf2_def comp_def BNF_Comp.id_bnf_comp_def .
definition flat2 :: "('x ΣΣ2) ΣΣ2 => 'x ΣΣ2" where
flat2_def: "flat2 ≡ ext2 \<oo>\<pp>2 id"
lemma flat2_transfer[transfer_rule]: "(ΣΣ2_rel (ΣΣ2_rel R) ===> ΣΣ2_rel R) flat2 flat2"
unfolding flat2_def ext2_alt by transfer_prover
lemma ctor_fold_ΣΣ2_pointfree:
"ctor_fold_ΣΣ2 s o ctor_ΣΣ2 = s o (map_pre_ΣΣ2 id (ctor_fold_ΣΣ2 s))"
unfolding comp_def ΣΣ2.ctor_fold ..
lemma ΣΣ2_map_ctor_ΣΣ2:
"ΣΣ2_map f o ctor_ΣΣ2 = ctor_ΣΣ2 o map_sum (Σ2_map (ΣΣ2_map f)) f"
unfolding comp_def
unfolding fun_eq_iff
unfolding ΣΣ2.ctor_map
unfolding map_pre_ΣΣ2_def
unfolding id_apply BNF_Comp.id_bnf_comp_def id_def[symmetric] o_id id_o by simp
lemma dtor_ΣΣ2_ΣΣ2_map:
"dtor_ΣΣ2 o ΣΣ2_map f = map_sum (Σ2_map (ΣΣ2_map f)) f o dtor_ΣΣ2"
using ΣΣ2_map_ctor_ΣΣ2[of f] ΣΣ2.dtor_ctor ΣΣ2.ctor_dtor unfolding comp_def fun_eq_iff by metis
lemma dtor_ΣΣ2_ctor_ΣΣ2: "dtor_ΣΣ2 o ctor_ΣΣ2 = id"
unfolding comp_def ΣΣ2.dtor_ctor id_def ..
lemma ctor_ΣΣ2_dtor_ΣΣ2: "ctor_ΣΣ2 o dtor_ΣΣ2 = id"
unfolding comp_def ΣΣ2.ctor_dtor id_def ..
lemma ΣΣ2_rel_inf: "ΣΣ2_rel (R \<sqinter> Σ1) ≤ ΣΣ2_rel R \<sqinter> ΣΣ2_rel Σ1"
apply (rule inf_greatest)
apply (rule ΣΣ2.rel_mono[OF inf_sup_ord(1)])
apply (rule ΣΣ2.rel_mono[OF inf_sup_ord(2)])
done
lemma ΣΣ2_rel_Grp_ΣΣ2_map: "ΣΣ2_rel (BNF_Def.Grp UNIV f) x y <-> ΣΣ2_map f x = y"
unfolding ΣΣ2.rel_Grp by (auto simp: Grp_def)
lemma ΣΣ2_rel_ΣΣ2_map_ΣΣ2_map: "ΣΣ2_rel R (ΣΣ2_map f x) (ΣΣ2_map g y) =
ΣΣ2_rel (BNF_Def.vimage2p f g R) x y"
unfolding ΣΣ2.rel_Grp vimage2p_Grp apply (auto simp: ΣΣ2.rel_compp ΣΣ2.rel_conversep relcompp.simps)
apply (intro exI conjI)
apply (rule iffD2[OF ΣΣ2_rel_Grp_ΣΣ2_map refl])
apply assumption
apply (rule iffD2[OF ΣΣ2_rel_Grp_ΣΣ2_map refl])
unfolding ΣΣ2_rel_Grp_ΣΣ2_map
apply simp
done
subsection{* @{term Σ2} extension theorems *}
theorem ext2_commute:
"ext2 s i o \<oo>\<pp>2 = s o Σ2_map (ext2 s i)"
unfolding ext2_alt \<oo>\<pp>2_def_pointfree o_assoc ctor_fold_ΣΣ2_pointfree map_pre_ΣΣ2_def
case_sum_o_map_sum case_sum_o_inj(1) BNF_Comp.id_bnf_comp_def id_def[symmetric] o_id ..
theorem ext2_comp_leaf2:
"ext2 s i o leaf2 = i"
unfolding ext2_alt leaf2_def_pointfree o_assoc ctor_fold_ΣΣ2_pointfree map_pre_ΣΣ2_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 ext2_unique:
assumes leaf2: "f o leaf2 = i" and com: "f o \<oo>\<pp>2 = s o Σ2_map f"
shows "f = ext2 s i"
unfolding ext2_alt
apply (rule ΣΣ2.ctor_fold_unique)
apply (rule sum_comp_cases)
unfolding map_pre_ΣΣ2_def case_sum_o_map_sum id_apply o_id case_sum_o_inj
leaf2[unfolded leaf2_def_pointfree o_assoc] com[unfolded \<oo>\<pp>2_def_pointfree o_assoc]
BNF_Comp.id_bnf_comp_def id_def[symmetric] id_o
by (rule refl)+
subsection{* Customizing @{term ΣΣ2} *}
subsection{* Injectiveness, naturality, adjunction *}
theorem leaf2_natural: "ΣΣ2_map f o leaf2 = leaf2 o f"
using leaf2_transfer[of "BNF_Def.Grp UNIV f"]
unfolding ΣΣ2.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma \<oo>\<pp>2_natural: "\<oo>\<pp>2 o Σ2_map (ΣΣ2_map f) = ΣΣ2_map f o \<oo>\<pp>2"
using \<oo>\<pp>2_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ2.rel_Grp ΣΣ2.rel_Grp Σ2_map_def
unfolding Grp_def rel_fun_def by auto
lemma ΣΣ2_map_def2: "ΣΣ2_map i = ext2 \<oo>\<pp>2 (leaf2 o i)"
by (rule ext2_unique[OF leaf2_natural \<oo>\<pp>2_natural[symmetric]])
lemma ext2_\<oo>\<pp>2_leaf2: "ext2 \<oo>\<pp>2 leaf2 = id"
apply (rule ext2_unique[symmetric]) unfolding Σ2.map_id0 o_id id_o by (rule refl)+
lemma ext2_ΣΣ2_map:
"ext2 s (j o f) = ext2 s j o ΣΣ2_map f"
proof (rule ext2_unique[symmetric])
show "ext2 s j o ΣΣ2_map f o leaf2 = j o f"
unfolding o_assoc[symmetric] leaf2_natural
unfolding o_assoc ext2_comp_leaf2 ..
next
show "ext2 s j o ΣΣ2_map f o \<oo>\<pp>2 = s o Σ2_map (ext2 s j o ΣΣ2_map f)"
unfolding o_assoc[symmetric] \<oo>\<pp>2_natural[symmetric]
unfolding o_assoc ext2_commute
unfolding o_assoc[symmetric] Σ2.map_comp0 ..
qed
lemma ext2_Σ2_map:
assumes "t o Σ2_map f = f o s"
shows "ext2 t (f o i) = f o ext2 s i"
proof (rule ext2_unique[symmetric])
show "f o ext2 s i o leaf2 = f o i"
unfolding o_assoc[symmetric] ext2_comp_leaf2 ..
next
show "f o ext2 s i o \<oo>\<pp>2 = t o Σ2_map (f o ext2 s i)"
unfolding Σ2.map_comp0 o_assoc assms
unfolding o_assoc[symmetric] ext2_commute[symmetric] ..
qed
subsection{* Monadic laws *}
lemma flat2_commute: "\<oo>\<pp>2 o Σ2_map flat2 = flat2 o \<oo>\<pp>2"
unfolding flat2_def ext2_commute ..
theorem flat2_leaf2: "flat2 o leaf2 = id"
unfolding flat2_def ext2_comp_leaf2 ..
theorem leaf2_flat2: "flat2 o ΣΣ2_map leaf2 = id"
unfolding flat2_def ext2_ΣΣ2_map[symmetric] id_o ext2_\<oo>\<pp>2_leaf2 ..
theorem flat2_natural: "flat2 o ΣΣ2_map (ΣΣ2_map i) = ΣΣ2_map i o flat2"
using flat2_transfer[of "BNF_Def.Grp UNIV i"]
unfolding prod.rel_Grp ΣΣ2.rel_Grp
unfolding Grp_def rel_fun_def by auto
theorem flat2_assoc: "flat2 o ΣΣ2_map flat2 = flat2 o flat2"
unfolding flat2_def unfolding ext2_ΣΣ2_map[symmetric] id_o
proof(rule ext2_unique[symmetric], unfold flat2_def[symmetric])
show "flat2 o flat2 o leaf2 = flat2"
unfolding o_assoc[symmetric] flat2_leaf2 o_id ..
next
show "flat2 o flat2 o \<oo>\<pp>2 = \<oo>\<pp>2 o Σ2_map (flat2 o flat2)"
unfolding flat2_def unfolding o_assoc[symmetric] ext2_commute
unfolding flat2_def[symmetric]
unfolding Σ2.map_comp0 o_assoc unfolding flat2_commute ..
qed
definition K2_as_ΣΣ2 :: "'a K2 => 'a ΣΣ2" where
"K2_as_ΣΣ2 ≡ \<oo>\<pp>2 o Σ2_map leaf2 o Abs_Σ2 o Inr"
lemma K2_as_ΣΣ2_transfer[transfer_rule]:
"(K2_rel R ===> ΣΣ2_rel R) K2_as_ΣΣ2 K2_as_ΣΣ2"
unfolding K2_as_ΣΣ2_def by transfer_prover
lemma K2_as_ΣΣ2_natural:
"K2_as_ΣΣ2 o K2_map f = ΣΣ2_map f o K2_as_ΣΣ2"
using K2_as_ΣΣ2_transfer[of "BNF_Def.Grp UNIV f"]
unfolding K2.rel_Grp ΣΣ2.rel_Grp
unfolding Grp_def rel_fun_def by auto
end