header{* Free algebras for an BNF *}
theory Stream_FreeAlg4
imports Stream_Input4
begin
declare K4.map_transfer[transfer_rule]
composition_bnf (open) raw_Σ4: "'a Σ3 + 'a K4"
typedef 'a Σ4 = "UNIV :: ('a Σ3 + 'a K4) set" by (rule UNIV_witness)
setup_lifting type_definition_Σ4
lift_definition Σ4_map :: "('a => 'b) => 'a Σ4 => 'b Σ4" is "λf. map_sum (Σ3_map f) (K4_map f)" .
lift_definition Σ4_set :: "'a Σ4 => 'a set"
is "λx. UNION (Basic_BNFs.setl x) Σ3_set ∪ UNION (Basic_BNFs.setr x) K4_set" .
lift_definition Σ4_rel :: "('a => 'b => bool) => 'a Σ4 => 'b Σ4 => bool"
is "λR. rel_sum (Σ3_rel R) (K4_rel R)" .
typedef Σ4_bd_type = "UNIV :: ((Σ3_bd_type + bd_type_K4) × nat) set" by (rule UNIV_witness)
definition "Σ4_bd = dir_image ((Σ3_bd +c bd_K4) *c natLeq) Abs_Σ4_bd_type"
bnf "'a Σ4"
map: Σ4_map
sets: Σ4_set
bd: Σ4_bd
rel: Σ4_rel
unfolding Σ4_bd_def
apply -
apply transfer apply (rule raw_Σ4.map_id0)
apply transfer apply (rule raw_Σ4.map_comp0)
apply transfer apply (erule raw_Σ4.map_cong0)
apply transfer apply (rule raw_Σ4.set_map0)
apply (rule card_order_dir_image[OF bijI raw_Σ4.bd_card_order])
apply (metis inj_on_def Abs_Σ4_bd_type_inverse[OF UNIV_I])
apply (metis surj_def Abs_Σ4_bd_type_cases)
apply (rule conjunct1[OF Cinfinite_cong[OF dir_image[OF _ raw_Σ4.bd_Card_order] raw_Σ4.bd_Cinfinite]])
apply (metis Abs_Σ4_bd_type_inverse[OF UNIV_I])
apply (unfold Σ4_set_def map_fun_def id_o) [1] apply (subst o_apply)
apply (rule ordLeq_ordIso_trans[OF raw_Σ4.set_bd dir_image[OF _ raw_Σ4.bd_Card_order]])
apply (metis Abs_Σ4_bd_type_inverse[OF UNIV_I])
apply (rule predicate2I) apply transfer apply (subst raw_Σ4.rel_compp) apply assumption
apply transfer' apply (rule raw_Σ4.rel_compp_Grp)
done
declare Σ4.map_transfer[transfer_rule]
lemma Rep_Σ4_transfer[transfer_rule]: "(Σ4_rel R ===> rel_sum (Σ3_rel R) (K4_rel R)) Rep_Σ4 Rep_Σ4"
unfolding rel_fun_def by transfer blast
lemma Abs_Σ4_transfer[transfer_rule]: "(rel_sum (Σ3_rel R) (K4_rel R) ===> Σ4_rel R) Abs_Σ4 Abs_Σ4"
unfolding rel_fun_def by transfer blast
theorem Rep_Σ4_natural: "map_sum (Σ3_map f) (K4_map f) o Rep_Σ4 = Rep_Σ4 o Σ4_map f"
using Rep_Σ4_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ4.rel_Grp raw_Σ4.rel_Grp
unfolding Grp_def rel_fun_def by auto
theorem Abs_Σ4_natural: "Σ4_map f o Abs_Σ4 = Abs_Σ4 o map_sum (Σ3_map f) (K4_map f)"
using Abs_Σ4_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ4.rel_Grp raw_Σ4.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma Rep_Σ4_o_Abs_Σ4: "Rep_Σ4 o Abs_Σ4 = id"
apply (rule ext)
apply (rule box_equals[OF _ o_apply[symmetric] id_apply[symmetric]])
apply (rule Abs_Σ4_inverse[OF UNIV_I])
done
lemma Σ4_rel_Σ4_map_Σ4_map:
"Σ4_rel R (Σ4_map f x) (Σ4_map g y) = Σ4_rel (BNF_Def.vimage2p f g R) x y"
unfolding Σ4.rel_Grp vimage2p_Grp Σ4.rel_compp Σ4.rel_conversep
unfolding relcompp.simps Grp_def by simp
subsection{* Definitions and basic setup *}
datatype_new (ΣΣ4_set: 'x) ΣΣ4 =
\<oo>\<pp>4 "'x ΣΣ4 Σ4" | leaf4 "'x"
for map: ΣΣ4_map rel: ΣΣ4_rel
declare ΣΣ4.ctor_fold_transfer
[unfolded rel_pre_ΣΣ4_def id_apply BNF_Comp.id_bnf_comp_def vimage2p_def, transfer_rule]
lemma \<oo>\<pp>4_transfer[transfer_rule]:
"(Σ4_rel (ΣΣ4_rel R) ===> ΣΣ4_rel R) \<oo>\<pp>4 \<oo>\<pp>4"
by (rule rel_funI) (erule iffD2[OF ΣΣ4.rel_inject(1)])
lemma leaf4_transfer[transfer_rule]: "(R ===> ΣΣ4_rel R) leaf4 leaf4"
by (rule rel_funI) (erule iffD2[OF ΣΣ4.rel_inject(2)])
abbreviation "ext4 s ≡ rec_ΣΣ4 (s o Σ4_map snd)"
lemmas ext4_\<oo>\<pp>4 = ΣΣ4.rec(1)[of "s o Σ4_map snd" for s,
unfolded o_apply Σ4.map_comp snd_convol[unfolded convol_def]]
lemmas ext4_leaf4 = ΣΣ4.rec(2)[of "s o Σ4_map snd" for s,
unfolded o_apply Σ4.map_comp snd_convol[unfolded convol_def]]
lemmas leaf4_inj = ΣΣ4.inject(2)
lemmas \<oo>\<pp>4_inj = ΣΣ4.inject(1)
lemma ext4_alt: "ext4 s f = ctor_fold_ΣΣ4 (case_sum s f)"
apply (rule ΣΣ4.ctor_fold_unique)
apply (rule ext)
apply (rename_tac x)
apply (case_tac x)
apply (auto simp only: rec_ΣΣ4_def ΣΣ4.ctor_rec fun_eq_iff o_apply BNF_Comp.id_bnf_comp_def
id_def[symmetric] o_id map_pre_ΣΣ4_def id_apply map_sum.simps sum.inject sum.distinct
Σ4.map_comp snd_convol split: sum.splits)
done
lemma \<oo>\<pp>4_def_pointfree: "\<oo>\<pp>4 ≡ ctor_ΣΣ4 o Inl"
unfolding \<oo>\<pp>4_def comp_def BNF_Comp.id_bnf_comp_def .
lemma leaf4_def_pointfree: "leaf4 ≡ ctor_ΣΣ4 o Inr"
unfolding leaf4_def comp_def BNF_Comp.id_bnf_comp_def .
definition flat4 :: "('x ΣΣ4) ΣΣ4 => 'x ΣΣ4" where
flat4_def: "flat4 ≡ ext4 \<oo>\<pp>4 id"
lemma flat4_transfer[transfer_rule]: "(ΣΣ4_rel (ΣΣ4_rel R) ===> ΣΣ4_rel R) flat4 flat4"
unfolding flat4_def ext4_alt by transfer_prover
lemma ctor_fold_ΣΣ4_pointfree:
"ctor_fold_ΣΣ4 s o ctor_ΣΣ4 = s o (map_pre_ΣΣ4 id (ctor_fold_ΣΣ4 s))"
unfolding comp_def ΣΣ4.ctor_fold ..
lemma ΣΣ4_map_ctor_ΣΣ4:
"ΣΣ4_map f o ctor_ΣΣ4 = ctor_ΣΣ4 o map_sum (Σ4_map (ΣΣ4_map f)) f"
unfolding comp_def
unfolding fun_eq_iff
unfolding ΣΣ4.ctor_map
unfolding map_pre_ΣΣ4_def
unfolding id_apply BNF_Comp.id_bnf_comp_def id_def[symmetric] o_id id_o by simp
lemma dtor_ΣΣ4_ΣΣ4_map:
"dtor_ΣΣ4 o ΣΣ4_map f = map_sum (Σ4_map (ΣΣ4_map f)) f o dtor_ΣΣ4"
using ΣΣ4_map_ctor_ΣΣ4[of f] ΣΣ4.dtor_ctor ΣΣ4.ctor_dtor unfolding comp_def fun_eq_iff by metis
lemma dtor_ΣΣ4_ctor_ΣΣ4: "dtor_ΣΣ4 o ctor_ΣΣ4 = id"
unfolding comp_def ΣΣ4.dtor_ctor id_def ..
lemma ctor_ΣΣ4_dtor_ΣΣ4: "ctor_ΣΣ4 o dtor_ΣΣ4 = id"
unfolding comp_def ΣΣ4.ctor_dtor id_def ..
lemma ΣΣ4_rel_inf: "ΣΣ4_rel (R \<sqinter> Σ3) ≤ ΣΣ4_rel R \<sqinter> ΣΣ4_rel Σ3"
apply (rule inf_greatest)
apply (rule ΣΣ4.rel_mono[OF inf_sup_ord(1)])
apply (rule ΣΣ4.rel_mono[OF inf_sup_ord(2)])
done
lemma ΣΣ4_rel_Grp_ΣΣ4_map: "ΣΣ4_rel (BNF_Def.Grp UNIV f) x y <-> ΣΣ4_map f x = y"
unfolding ΣΣ4.rel_Grp by (auto simp: Grp_def)
lemma ΣΣ4_rel_ΣΣ4_map_ΣΣ4_map: "ΣΣ4_rel R (ΣΣ4_map f x) (ΣΣ4_map g y) =
ΣΣ4_rel (BNF_Def.vimage2p f g R) x y"
unfolding ΣΣ4.rel_Grp vimage2p_Grp apply (auto simp: ΣΣ4.rel_compp ΣΣ4.rel_conversep relcompp.simps)
apply (intro exI conjI)
apply (rule iffD2[OF ΣΣ4_rel_Grp_ΣΣ4_map refl])
apply assumption
apply (rule iffD2[OF ΣΣ4_rel_Grp_ΣΣ4_map refl])
unfolding ΣΣ4_rel_Grp_ΣΣ4_map
apply simp
done
subsection{* @{term Σ4} extension theorems *}
theorem ext4_commute:
"ext4 s i o \<oo>\<pp>4 = s o Σ4_map (ext4 s i)"
unfolding ext4_alt \<oo>\<pp>4_def_pointfree o_assoc ctor_fold_ΣΣ4_pointfree map_pre_ΣΣ4_def
case_sum_o_map_sum case_sum_o_inj(1) BNF_Comp.id_bnf_comp_def id_def[symmetric] o_id ..
theorem ext4_comp_leaf4:
"ext4 s i o leaf4 = i"
unfolding ext4_alt leaf4_def_pointfree o_assoc ctor_fold_ΣΣ4_pointfree map_pre_ΣΣ4_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 ext4_unique:
assumes leaf4: "f o leaf4 = i" and com: "f o \<oo>\<pp>4 = s o Σ4_map f"
shows "f = ext4 s i"
unfolding ext4_alt
apply (rule ΣΣ4.ctor_fold_unique)
apply (rule sum_comp_cases)
unfolding map_pre_ΣΣ4_def case_sum_o_map_sum id_apply o_id case_sum_o_inj
leaf4[unfolded leaf4_def_pointfree o_assoc] com[unfolded \<oo>\<pp>4_def_pointfree o_assoc]
BNF_Comp.id_bnf_comp_def id_def[symmetric] id_o
by (rule refl)+
subsection{* Customizing @{term ΣΣ4} *}
subsection{* Injectiveness, naturality, adjunction *}
theorem leaf4_natural: "ΣΣ4_map f o leaf4 = leaf4 o f"
using leaf4_transfer[of "BNF_Def.Grp UNIV f"]
unfolding ΣΣ4.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma \<oo>\<pp>4_natural: "\<oo>\<pp>4 o Σ4_map (ΣΣ4_map f) = ΣΣ4_map f o \<oo>\<pp>4"
using \<oo>\<pp>4_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ4.rel_Grp ΣΣ4.rel_Grp Σ4_map_def
unfolding Grp_def rel_fun_def by auto
lemma ΣΣ4_map_def2: "ΣΣ4_map i = ext4 \<oo>\<pp>4 (leaf4 o i)"
by (rule ext4_unique[OF leaf4_natural \<oo>\<pp>4_natural[symmetric]])
lemma ext4_\<oo>\<pp>4_leaf4: "ext4 \<oo>\<pp>4 leaf4 = id"
apply (rule ext4_unique[symmetric]) unfolding Σ4.map_id0 o_id id_o by (rule refl)+
lemma ext4_ΣΣ4_map:
"ext4 s (j o f) = ext4 s j o ΣΣ4_map f"
proof (rule ext4_unique[symmetric])
show "ext4 s j o ΣΣ4_map f o leaf4 = j o f"
unfolding o_assoc[symmetric] leaf4_natural
unfolding o_assoc ext4_comp_leaf4 ..
next
show "ext4 s j o ΣΣ4_map f o \<oo>\<pp>4 = s o Σ4_map (ext4 s j o ΣΣ4_map f)"
unfolding o_assoc[symmetric] \<oo>\<pp>4_natural[symmetric]
unfolding o_assoc ext4_commute
unfolding o_assoc[symmetric] Σ4.map_comp0 ..
qed
lemma ext4_Σ4_map:
assumes "t o Σ4_map f = f o s"
shows "ext4 t (f o i) = f o ext4 s i"
proof (rule ext4_unique[symmetric])
show "f o ext4 s i o leaf4 = f o i"
unfolding o_assoc[symmetric] ext4_comp_leaf4 ..
next
show "f o ext4 s i o \<oo>\<pp>4 = t o Σ4_map (f o ext4 s i)"
unfolding Σ4.map_comp0 o_assoc assms
unfolding o_assoc[symmetric] ext4_commute[symmetric] ..
qed
subsection{* Monadic laws *}
lemma flat4_commute: "\<oo>\<pp>4 o Σ4_map flat4 = flat4 o \<oo>\<pp>4"
unfolding flat4_def ext4_commute ..
theorem flat4_leaf4: "flat4 o leaf4 = id"
unfolding flat4_def ext4_comp_leaf4 ..
theorem leaf4_flat4: "flat4 o ΣΣ4_map leaf4 = id"
unfolding flat4_def ext4_ΣΣ4_map[symmetric] id_o ext4_\<oo>\<pp>4_leaf4 ..
theorem flat4_natural: "flat4 o ΣΣ4_map (ΣΣ4_map i) = ΣΣ4_map i o flat4"
using flat4_transfer[of "BNF_Def.Grp UNIV i"]
unfolding prod.rel_Grp ΣΣ4.rel_Grp
unfolding Grp_def rel_fun_def by auto
theorem flat4_assoc: "flat4 o ΣΣ4_map flat4 = flat4 o flat4"
unfolding flat4_def unfolding ext4_ΣΣ4_map[symmetric] id_o
proof(rule ext4_unique[symmetric], unfold flat4_def[symmetric])
show "flat4 o flat4 o leaf4 = flat4"
unfolding o_assoc[symmetric] flat4_leaf4 o_id ..
next
show "flat4 o flat4 o \<oo>\<pp>4 = \<oo>\<pp>4 o Σ4_map (flat4 o flat4)"
unfolding flat4_def unfolding o_assoc[symmetric] ext4_commute
unfolding flat4_def[symmetric]
unfolding Σ4.map_comp0 o_assoc unfolding flat4_commute ..
qed
definition K4_as_ΣΣ4 :: "'a K4 => 'a ΣΣ4" where
"K4_as_ΣΣ4 ≡ \<oo>\<pp>4 o Σ4_map leaf4 o Abs_Σ4 o Inr"
lemma K4_as_ΣΣ4_transfer[transfer_rule]:
"(K4_rel R ===> ΣΣ4_rel R) K4_as_ΣΣ4 K4_as_ΣΣ4"
unfolding K4_as_ΣΣ4_def by transfer_prover
lemma K4_as_ΣΣ4_natural:
"K4_as_ΣΣ4 o K4_map f = ΣΣ4_map f o K4_as_ΣΣ4"
using K4_as_ΣΣ4_transfer[of "BNF_Def.Grp UNIV f"]
unfolding K4.rel_Grp ΣΣ4.rel_Grp
unfolding Grp_def rel_fun_def by auto
end