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