header{* Free algebras for an BNF *}
theory Stream_FreeAlg5
imports Stream_Input5
begin
declare K5.map_transfer[transfer_rule]
composition_bnf (open) raw_Σ5: "'a Σ4 + 'a K5"
typedef 'a Σ5 = "UNIV :: ('a Σ4 + 'a K5) set" by (rule UNIV_witness)
setup_lifting type_definition_Σ5
lift_definition Σ5_map :: "('a => 'b) => 'a Σ5 => 'b Σ5" is "λf. map_sum (Σ4_map f) (K5_map f)" .
lift_definition Σ5_set :: "'a Σ5 => 'a set"
is "λx. UNION (Basic_BNFs.setl x) Σ4_set ∪ UNION (Basic_BNFs.setr x) K5_set" .
lift_definition Σ5_rel :: "('a => 'b => bool) => 'a Σ5 => 'b Σ5 => bool"
is "λR. rel_sum (Σ4_rel R) (K5_rel R)" .
typedef Σ5_bd_type = "UNIV :: ((Σ4_bd_type + bd_type_K5) × nat) set" by (rule UNIV_witness)
definition "Σ5_bd = dir_image ((Σ4_bd +c bd_K5) *c natLeq) Abs_Σ5_bd_type"
bnf "'a Σ5"
map: Σ5_map
sets: Σ5_set
bd: Σ5_bd
rel: Σ5_rel
unfolding Σ5_bd_def
apply -
apply transfer apply (rule raw_Σ5.map_id0)
apply transfer apply (rule raw_Σ5.map_comp0)
apply transfer apply (erule raw_Σ5.map_cong0)
apply transfer apply (rule raw_Σ5.set_map0)
apply (rule card_order_dir_image[OF bijI raw_Σ5.bd_card_order])
apply (metis inj_on_def Abs_Σ5_bd_type_inverse[OF UNIV_I])
apply (metis surj_def Abs_Σ5_bd_type_cases)
apply (rule conjunct1[OF Cinfinite_cong[OF dir_image[OF _ raw_Σ5.bd_Card_order] raw_Σ5.bd_Cinfinite]])
apply (metis Abs_Σ5_bd_type_inverse[OF UNIV_I])
apply (unfold Σ5_set_def map_fun_def id_o) [1] apply (subst o_apply)
apply (rule ordLeq_ordIso_trans[OF raw_Σ5.set_bd dir_image[OF _ raw_Σ5.bd_Card_order]])
apply (metis Abs_Σ5_bd_type_inverse[OF UNIV_I])
apply (rule predicate2I) apply transfer apply (subst raw_Σ5.rel_compp) apply assumption
apply transfer' apply (rule raw_Σ5.rel_compp_Grp)
done
declare Σ5.map_transfer[transfer_rule]
lemma Rep_Σ5_transfer[transfer_rule]: "(Σ5_rel R ===> rel_sum (Σ4_rel R) (K5_rel R)) Rep_Σ5 Rep_Σ5"
unfolding rel_fun_def by transfer blast
lemma Abs_Σ5_transfer[transfer_rule]: "(rel_sum (Σ4_rel R) (K5_rel R) ===> Σ5_rel R) Abs_Σ5 Abs_Σ5"
unfolding rel_fun_def by transfer blast
theorem Rep_Σ5_natural: "map_sum (Σ4_map f) (K5_map f) o Rep_Σ5 = Rep_Σ5 o Σ5_map f"
using Rep_Σ5_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ5.rel_Grp raw_Σ5.rel_Grp
unfolding Grp_def rel_fun_def by auto
theorem Abs_Σ5_natural: "Σ5_map f o Abs_Σ5 = Abs_Σ5 o map_sum (Σ4_map f) (K5_map f)"
using Abs_Σ5_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ5.rel_Grp raw_Σ5.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma Rep_Σ5_o_Abs_Σ5: "Rep_Σ5 o Abs_Σ5 = id"
apply (rule ext)
apply (rule box_equals[OF _ o_apply[symmetric] id_apply[symmetric]])
apply (rule Abs_Σ5_inverse[OF UNIV_I])
done
lemma Σ5_rel_Σ5_map_Σ5_map:
"Σ5_rel R (Σ5_map f x) (Σ5_map g y) = Σ5_rel (BNF_Def.vimage2p f g R) x y"
unfolding Σ5.rel_Grp vimage2p_Grp Σ5.rel_compp Σ5.rel_conversep
unfolding relcompp.simps Grp_def by simp
subsection{* Definitions and basic setup *}
datatype_new (ΣΣ5_set: 'x) ΣΣ5 =
\<oo>\<pp>5 "'x ΣΣ5 Σ5" | leaf5 "'x"
for map: ΣΣ5_map rel: ΣΣ5_rel
declare ΣΣ5.ctor_fold_transfer
[unfolded rel_pre_ΣΣ5_def id_apply BNF_Comp.id_bnf_comp_def vimage2p_def, transfer_rule]
lemma \<oo>\<pp>5_transfer[transfer_rule]:
"(Σ5_rel (ΣΣ5_rel R) ===> ΣΣ5_rel R) \<oo>\<pp>5 \<oo>\<pp>5"
by (rule rel_funI) (erule iffD2[OF ΣΣ5.rel_inject(1)])
lemma leaf5_transfer[transfer_rule]: "(R ===> ΣΣ5_rel R) leaf5 leaf5"
by (rule rel_funI) (erule iffD2[OF ΣΣ5.rel_inject(2)])
abbreviation "ext5 s ≡ rec_ΣΣ5 (s o Σ5_map snd)"
lemmas ext5_\<oo>\<pp>5 = ΣΣ5.rec(1)[of "s o Σ5_map snd" for s,
unfolded o_apply Σ5.map_comp snd_convol[unfolded convol_def]]
lemmas ext5_leaf5 = ΣΣ5.rec(2)[of "s o Σ5_map snd" for s,
unfolded o_apply Σ5.map_comp snd_convol[unfolded convol_def]]
lemmas leaf5_inj = ΣΣ5.inject(2)
lemmas \<oo>\<pp>5_inj = ΣΣ5.inject(1)
lemma ext5_alt: "ext5 s f = ctor_fold_ΣΣ5 (case_sum s f)"
apply (rule ΣΣ5.ctor_fold_unique)
apply (rule ext)
apply (rename_tac x)
apply (case_tac x)
apply (auto simp only: rec_ΣΣ5_def ΣΣ5.ctor_rec fun_eq_iff o_apply BNF_Comp.id_bnf_comp_def
id_def[symmetric] o_id map_pre_ΣΣ5_def id_apply map_sum.simps sum.inject sum.distinct
Σ5.map_comp snd_convol split: sum.splits)
done
lemma \<oo>\<pp>5_def_pointfree: "\<oo>\<pp>5 ≡ ctor_ΣΣ5 o Inl"
unfolding \<oo>\<pp>5_def comp_def BNF_Comp.id_bnf_comp_def .
lemma leaf5_def_pointfree: "leaf5 ≡ ctor_ΣΣ5 o Inr"
unfolding leaf5_def comp_def BNF_Comp.id_bnf_comp_def .
definition flat5 :: "('x ΣΣ5) ΣΣ5 => 'x ΣΣ5" where
flat5_def: "flat5 ≡ ext5 \<oo>\<pp>5 id"
lemma flat5_transfer[transfer_rule]: "(ΣΣ5_rel (ΣΣ5_rel R) ===> ΣΣ5_rel R) flat5 flat5"
unfolding flat5_def ext5_alt by transfer_prover
lemma ctor_fold_ΣΣ5_pointfree:
"ctor_fold_ΣΣ5 s o ctor_ΣΣ5 = s o (map_pre_ΣΣ5 id (ctor_fold_ΣΣ5 s))"
unfolding comp_def ΣΣ5.ctor_fold ..
lemma ΣΣ5_map_ctor_ΣΣ5:
"ΣΣ5_map f o ctor_ΣΣ5 = ctor_ΣΣ5 o map_sum (Σ5_map (ΣΣ5_map f)) f"
unfolding comp_def
unfolding fun_eq_iff
unfolding ΣΣ5.ctor_map
unfolding map_pre_ΣΣ5_def
unfolding id_apply BNF_Comp.id_bnf_comp_def id_def[symmetric] o_id id_o by simp
lemma dtor_ΣΣ5_ΣΣ5_map:
"dtor_ΣΣ5 o ΣΣ5_map f = map_sum (Σ5_map (ΣΣ5_map f)) f o dtor_ΣΣ5"
using ΣΣ5_map_ctor_ΣΣ5[of f] ΣΣ5.dtor_ctor ΣΣ5.ctor_dtor unfolding comp_def fun_eq_iff by metis
lemma dtor_ΣΣ5_ctor_ΣΣ5: "dtor_ΣΣ5 o ctor_ΣΣ5 = id"
unfolding comp_def ΣΣ5.dtor_ctor id_def ..
lemma ctor_ΣΣ5_dtor_ΣΣ5: "ctor_ΣΣ5 o dtor_ΣΣ5 = id"
unfolding comp_def ΣΣ5.ctor_dtor id_def ..
lemma ΣΣ5_rel_inf: "ΣΣ5_rel (R \<sqinter> Σ4) ≤ ΣΣ5_rel R \<sqinter> ΣΣ5_rel Σ4"
apply (rule inf_greatest)
apply (rule ΣΣ5.rel_mono[OF inf_sup_ord(1)])
apply (rule ΣΣ5.rel_mono[OF inf_sup_ord(2)])
done
lemma ΣΣ5_rel_Grp_ΣΣ5_map: "ΣΣ5_rel (BNF_Def.Grp UNIV f) x y <-> ΣΣ5_map f x = y"
unfolding ΣΣ5.rel_Grp by (auto simp: Grp_def)
lemma ΣΣ5_rel_ΣΣ5_map_ΣΣ5_map: "ΣΣ5_rel R (ΣΣ5_map f x) (ΣΣ5_map g y) =
ΣΣ5_rel (BNF_Def.vimage2p f g R) x y"
unfolding ΣΣ5.rel_Grp vimage2p_Grp apply (auto simp: ΣΣ5.rel_compp ΣΣ5.rel_conversep relcompp.simps)
apply (intro exI conjI)
apply (rule iffD2[OF ΣΣ5_rel_Grp_ΣΣ5_map refl])
apply assumption
apply (rule iffD2[OF ΣΣ5_rel_Grp_ΣΣ5_map refl])
unfolding ΣΣ5_rel_Grp_ΣΣ5_map
apply simp
done
subsection{* @{term Σ5} extension theorems *}
theorem ext5_commute:
"ext5 s i o \<oo>\<pp>5 = s o Σ5_map (ext5 s i)"
unfolding ext5_alt \<oo>\<pp>5_def_pointfree o_assoc ctor_fold_ΣΣ5_pointfree map_pre_ΣΣ5_def
case_sum_o_map_sum case_sum_o_inj(1) BNF_Comp.id_bnf_comp_def id_def[symmetric] o_id ..
theorem ext5_comp_leaf5:
"ext5 s i o leaf5 = i"
unfolding ext5_alt leaf5_def_pointfree o_assoc ctor_fold_ΣΣ5_pointfree map_pre_ΣΣ5_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 ext5_unique:
assumes leaf5: "f o leaf5 = i" and com: "f o \<oo>\<pp>5 = s o Σ5_map f"
shows "f = ext5 s i"
unfolding ext5_alt
apply (rule ΣΣ5.ctor_fold_unique)
apply (rule sum_comp_cases)
unfolding map_pre_ΣΣ5_def case_sum_o_map_sum id_apply o_id case_sum_o_inj
leaf5[unfolded leaf5_def_pointfree o_assoc] com[unfolded \<oo>\<pp>5_def_pointfree o_assoc]
BNF_Comp.id_bnf_comp_def id_def[symmetric] id_o
by (rule refl)+
subsection{* Customizing @{term ΣΣ5} *}
subsection{* Injectiveness, naturality, adjunction *}
theorem leaf5_natural: "ΣΣ5_map f o leaf5 = leaf5 o f"
using leaf5_transfer[of "BNF_Def.Grp UNIV f"]
unfolding ΣΣ5.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma \<oo>\<pp>5_natural: "\<oo>\<pp>5 o Σ5_map (ΣΣ5_map f) = ΣΣ5_map f o \<oo>\<pp>5"
using \<oo>\<pp>5_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ5.rel_Grp ΣΣ5.rel_Grp Σ5_map_def
unfolding Grp_def rel_fun_def by auto
lemma ΣΣ5_map_def2: "ΣΣ5_map i = ext5 \<oo>\<pp>5 (leaf5 o i)"
by (rule ext5_unique[OF leaf5_natural \<oo>\<pp>5_natural[symmetric]])
lemma ext5_\<oo>\<pp>5_leaf5: "ext5 \<oo>\<pp>5 leaf5 = id"
apply (rule ext5_unique[symmetric]) unfolding Σ5.map_id0 o_id id_o by (rule refl)+
lemma ext5_ΣΣ5_map:
"ext5 s (j o f) = ext5 s j o ΣΣ5_map f"
proof (rule ext5_unique[symmetric])
show "ext5 s j o ΣΣ5_map f o leaf5 = j o f"
unfolding o_assoc[symmetric] leaf5_natural
unfolding o_assoc ext5_comp_leaf5 ..
next
show "ext5 s j o ΣΣ5_map f o \<oo>\<pp>5 = s o Σ5_map (ext5 s j o ΣΣ5_map f)"
unfolding o_assoc[symmetric] \<oo>\<pp>5_natural[symmetric]
unfolding o_assoc ext5_commute
unfolding o_assoc[symmetric] Σ5.map_comp0 ..
qed
lemma ext5_Σ5_map:
assumes "t o Σ5_map f = f o s"
shows "ext5 t (f o i) = f o ext5 s i"
proof (rule ext5_unique[symmetric])
show "f o ext5 s i o leaf5 = f o i"
unfolding o_assoc[symmetric] ext5_comp_leaf5 ..
next
show "f o ext5 s i o \<oo>\<pp>5 = t o Σ5_map (f o ext5 s i)"
unfolding Σ5.map_comp0 o_assoc assms
unfolding o_assoc[symmetric] ext5_commute[symmetric] ..
qed
subsection{* Monadic laws *}
lemma flat5_commute: "\<oo>\<pp>5 o Σ5_map flat5 = flat5 o \<oo>\<pp>5"
unfolding flat5_def ext5_commute ..
theorem flat5_leaf5: "flat5 o leaf5 = id"
unfolding flat5_def ext5_comp_leaf5 ..
theorem leaf5_flat5: "flat5 o ΣΣ5_map leaf5 = id"
unfolding flat5_def ext5_ΣΣ5_map[symmetric] id_o ext5_\<oo>\<pp>5_leaf5 ..
theorem flat5_natural: "flat5 o ΣΣ5_map (ΣΣ5_map i) = ΣΣ5_map i o flat5"
using flat5_transfer[of "BNF_Def.Grp UNIV i"]
unfolding prod.rel_Grp ΣΣ5.rel_Grp
unfolding Grp_def rel_fun_def by auto
theorem flat5_assoc: "flat5 o ΣΣ5_map flat5 = flat5 o flat5"
unfolding flat5_def unfolding ext5_ΣΣ5_map[symmetric] id_o
proof(rule ext5_unique[symmetric], unfold flat5_def[symmetric])
show "flat5 o flat5 o leaf5 = flat5"
unfolding o_assoc[symmetric] flat5_leaf5 o_id ..
next
show "flat5 o flat5 o \<oo>\<pp>5 = \<oo>\<pp>5 o Σ5_map (flat5 o flat5)"
unfolding flat5_def unfolding o_assoc[symmetric] ext5_commute
unfolding flat5_def[symmetric]
unfolding Σ5.map_comp0 o_assoc unfolding flat5_commute ..
qed
definition K5_as_ΣΣ5 :: "'a K5 => 'a ΣΣ5" where
"K5_as_ΣΣ5 ≡ \<oo>\<pp>5 o Σ5_map leaf5 o Abs_Σ5 o Inr"
lemma K5_as_ΣΣ5_transfer[transfer_rule]:
"(K5_rel R ===> ΣΣ5_rel R) K5_as_ΣΣ5 K5_as_ΣΣ5"
unfolding K5_as_ΣΣ5_def by transfer_prover
lemma K5_as_ΣΣ5_natural:
"K5_as_ΣΣ5 o K5_map f = ΣΣ5_map f o K5_as_ΣΣ5"
using K5_as_ΣΣ5_transfer[of "BNF_Def.Grp UNIV f"]
unfolding K5.rel_Grp ΣΣ5.rel_Grp
unfolding Grp_def rel_fun_def by auto
end