header{* The initial free algebra for bootstrapping, for a copy of the behavior BNF *}
theory FreeAlg_base
imports Behavior_BNF
begin
typedef 'a Σ_base = "UNIV :: 'a F set" by (rule UNIV_witness)
setup_lifting type_definition_Σ_base
lift_definition Σ_base_map :: "('a => 'b) => 'a Σ_base => 'b Σ_base" is F_map .
lift_definition Σ_base_set :: "'a Σ_base => 'a set" is F_set .
lift_definition Σ_base_rel :: "('a => 'b => bool) => 'a Σ_base => 'b Σ_base => bool" is F_rel .
typedef Σ_base_bd_type = "UNIV :: bd_type_F set" by (rule UNIV_witness)
definition "Σ_base_bd = dir_image F_bd Abs_Σ_base_bd_type"
bnf "'a Σ_base"
map: Σ_base_map
sets: Σ_base_set
bd: Σ_base_bd
rel: Σ_base_rel
unfolding Σ_base_bd_def
apply -
apply transfer apply (rule pre_J.map_id0)
apply transfer apply (rule pre_J.map_comp0)
apply transfer apply (erule pre_J.map_cong0)
apply transfer apply (rule pre_J.set_map0)
apply (rule card_order_dir_image[OF bijI pre_J.bd_card_order])
apply (metis inj_on_def Abs_Σ_base_bd_type_inverse[OF UNIV_I])
apply (metis surj_def Abs_Σ_base_bd_type_cases)
apply (rule conjunct1[OF Cinfinite_cong[OF dir_image[OF _ pre_J.bd_Card_order] pre_J.bd_Cinfinite]])
apply (metis Abs_Σ_base_bd_type_inverse[OF UNIV_I])
apply (unfold Σ_base_set_def map_fun_def id_o) [1] apply (subst o_apply)
apply (rule ordLeq_ordIso_trans[OF pre_J.set_bd dir_image[OF _ pre_J.bd_Card_order]])
apply (metis Abs_Σ_base_bd_type_inverse[OF UNIV_I])
apply (rule predicate2I) apply transfer apply (subst pre_J.rel_compp) apply assumption
apply transfer' apply (rule pre_J.rel_compp_Grp)
done
declare Σ_base.map_transfer[transfer_rule]
lemma Rep_Σ_base_transfer[transfer_rule]: "(Σ_base_rel R ===> F_rel R) Rep_Σ_base Rep_Σ_base"
unfolding rel_fun_def by transfer blast
lemma Abs_Σ_base_transfer[transfer_rule]: "(F_rel R ===> Σ_base_rel R) Abs_Σ_base Abs_Σ_base"
unfolding rel_fun_def by transfer blast
theorem Rep_Σ_base_natural: "F_map f o Rep_Σ_base = Rep_Σ_base o Σ_base_map f"
using Rep_Σ_base_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ_base.rel_Grp F_rel_Grp
unfolding Grp_def rel_fun_def by auto
theorem Abs_Σ_base_natural: "Σ_base_map f o Abs_Σ_base = Abs_Σ_base o F_map f"
using Abs_Σ_base_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ_base.rel_Grp F_rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma Rep_Σ_base_o_Abs_Σ_base: "Rep_Σ_base o Abs_Σ_base = id"
apply (rule ext)
apply (rule box_equals[OF _ o_apply[symmetric] id_apply[symmetric]])
apply (rule Abs_Σ_base_inverse[OF UNIV_I])
done
lemma Σ_base_rel_Σ_base_map_Σ_base_map:
"Σ_base_rel R (Σ_base_map f x) (Σ_base_map g y) = Σ_base_rel (BNF_Def.vimage2p f g R) x y"
unfolding Σ_base.rel_Grp vimage2p_Grp Σ_base.rel_compp Σ_base.rel_conversep
unfolding relcompp.simps Grp_def by blast
subsection{* Definitions and basic setup *}
datatype_new (ΣΣ_base_set: 'x) ΣΣ_base =
\<oo>\<pp>_base "'x ΣΣ_base Σ_base" | leaf_base "'x"
for map: ΣΣ_base_map rel: ΣΣ_base_rel
declare ΣΣ_base.ctor_fold_transfer
[unfolded rel_pre_ΣΣ_base_def id_apply BNF_Comp.id_bnf_comp_def vimage2p_def, transfer_rule]
lemma \<oo>\<pp>_base_transfer[transfer_rule]: "(Σ_base_rel (ΣΣ_base_rel R) ===> ΣΣ_base_rel R) \<oo>\<pp>_base \<oo>\<pp>_base"
by (rule rel_funI) (erule iffD2[OF ΣΣ_base.rel_inject(1)])
lemma leaf_base_transfer[transfer_rule]: "(R ===> ΣΣ_base_rel R) leaf_base leaf_base"
by (rule rel_funI) (erule iffD2[OF ΣΣ_base.rel_inject(2)])
abbreviation "ext_base s ≡ rec_ΣΣ_base (s o Σ_base_map snd)"
lemmas ext_base_\<oo>\<pp>_base = ΣΣ_base.rec(1)[of "s o Σ_base_map snd" for s,
unfolded o_apply Σ_base.map_comp snd_convol[unfolded convol_def]]
lemmas ext_base_leaf_base = ΣΣ_base.rec(2)[of "s o Σ_base_map snd" for s,
unfolded o_apply Σ_base.map_comp snd_convol[unfolded convol_def]]
lemmas leaf_base_inj = ΣΣ_base.inject(2)
lemmas \<oo>\<pp>_base_inj = ΣΣ_base.inject(1)
lemma ext_base_alt: "ext_base s f = ctor_fold_ΣΣ_base (case_sum s f)"
apply (rule ΣΣ_base.ctor_fold_unique)
apply (rule ext)
apply (rename_tac x)
apply (case_tac x)
apply (auto simp only: rec_ΣΣ_base_def ΣΣ_base.ctor_rec fun_eq_iff o_apply BNF_Comp.id_bnf_comp_def
id_def[symmetric] o_id map_pre_ΣΣ_base_def id_apply map_sum.simps sum.inject sum.distinct
Σ_base.map_comp snd_convol split: sum.splits)
done
lemma \<oo>\<pp>_base_def_pointfree: "\<oo>\<pp>_base = ctor_ΣΣ_base o Inl"
unfolding \<oo>\<pp>_base_def BNF_Comp.id_bnf_comp_def comp_def ..
lemma leaf_base_def_pointfree: "leaf_base = ctor_ΣΣ_base o Inr"
unfolding leaf_base_def BNF_Comp.id_bnf_comp_def comp_def ..
definition flat_base :: "('x ΣΣ_base) ΣΣ_base => 'x ΣΣ_base" where
flat_base_def: "flat_base ≡ ext_base \<oo>\<pp>_base id"
lemma flat_base_transfer[transfer_rule]: "(ΣΣ_base_rel (ΣΣ_base_rel R) ===> ΣΣ_base_rel R) flat_base flat_base"
unfolding flat_base_def ext_base_alt by transfer_prover
lemma ctor_fold_ΣΣ_base_pointfree:
"ctor_fold_ΣΣ_base s o ctor_ΣΣ_base = s o (map_pre_ΣΣ_base id (ctor_fold_ΣΣ_base s))"
unfolding comp_def ΣΣ_base.ctor_fold ..
lemma ΣΣ_base_map_ctor_ΣΣ_base:
"ΣΣ_base_map f o ctor_ΣΣ_base = ctor_ΣΣ_base o map_sum (Σ_base_map (ΣΣ_base_map f)) f"
unfolding comp_def fun_eq_iff ΣΣ_base.ctor_map map_pre_ΣΣ_base_def BNF_Comp.id_bnf_comp_def id_apply by simp
lemma dtor_ΣΣ_base_ΣΣ_base_map:
"dtor_ΣΣ_base o ΣΣ_base_map f = map_sum (Σ_base_map (ΣΣ_base_map f)) f o dtor_ΣΣ_base"
using ΣΣ_base_map_ctor_ΣΣ_base[of f] ΣΣ_base.dtor_ctor ΣΣ_base.ctor_dtor unfolding comp_def fun_eq_iff by metis
lemma dtor_ΣΣ_base_ctor_ΣΣ_base: "dtor_ΣΣ_base o ctor_ΣΣ_base = id"
unfolding comp_def ΣΣ_base.dtor_ctor id_def ..
lemma ctor_ΣΣ_base_dtor_ΣΣ_base: "ctor_ΣΣ_base o dtor_ΣΣ_base = id"
unfolding comp_def ΣΣ_base.ctor_dtor id_def ..
lemma ΣΣ_base_rel_inf: "ΣΣ_base_rel (R \<sqinter> S) ≤ ΣΣ_base_rel R \<sqinter> ΣΣ_base_rel S"
apply (rule inf_greatest)
apply (rule ΣΣ_base.rel_mono[OF inf_sup_ord(1)])
apply (rule ΣΣ_base.rel_mono[OF inf_sup_ord(2)])
done
lemma ΣΣ_base_rel_Grp_ΣΣ_base_map: "ΣΣ_base_rel (BNF_Def.Grp UNIV f) x y <-> ΣΣ_base_map f x = y"
unfolding ΣΣ_base.rel_Grp by (auto simp: Grp_def)
lemma ΣΣ_base_rel_ΣΣ_base_map_ΣΣ_base_map: "ΣΣ_base_rel R (ΣΣ_base_map f x) (ΣΣ_base_map g y) =
ΣΣ_base_rel (BNF_Def.vimage2p f g R) x y"
unfolding ΣΣ_base.rel_Grp vimage2p_Grp apply (auto simp: ΣΣ_base.rel_compp ΣΣ_base.rel_conversep relcompp.simps)
apply (intro exI conjI)
apply (rule iffD2[OF ΣΣ_base_rel_Grp_ΣΣ_base_map refl])
apply assumption
apply (rule iffD2[OF ΣΣ_base_rel_Grp_ΣΣ_base_map refl])
unfolding ΣΣ_base_rel_Grp_ΣΣ_base_map
apply simp
done
subsection{* @{term Σ_base} extension theorems *}
theorem ext_base_commute:
"ext_base s i o \<oo>\<pp>_base = s o Σ_base_map (ext_base s i)"
unfolding ext_base_alt \<oo>\<pp>_base_def_pointfree o_assoc ctor_fold_ΣΣ_base_pointfree map_pre_ΣΣ_base_def
case_sum_o_map_sum case_sum_o_inj(1) BNF_Comp.id_bnf_comp_def id_def[symmetric] o_id ..
theorem ext_base_comp_leaf_base:
"ext_base s i o leaf_base = i"
unfolding ext_base_alt leaf_base_def_pointfree o_assoc ctor_fold_ΣΣ_base_pointfree map_pre_ΣΣ_base_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 ext_base_unique:
assumes leaf_base: "f o leaf_base = i" and com: "f o \<oo>\<pp>_base = s o Σ_base_map f"
shows "f = ext_base s i"
unfolding ext_base_alt
apply (rule ΣΣ_base.ctor_fold_unique)
apply (rule sum_comp_cases)
unfolding map_pre_ΣΣ_base_def case_sum_o_map_sum id_apply o_id case_sum_o_inj
leaf_base[unfolded leaf_base_def_pointfree o_assoc] com[unfolded \<oo>\<pp>_base_def_pointfree o_assoc]
BNF_Comp.id_bnf_comp_def id_def[symmetric] id_o
by (rule refl)+
subsection{* Customizing @{term ΣΣ_base} *}
subsection{* Injectiveness, naturality, adjunction *}
theorem leaf_base_natural: "ΣΣ_base_map f o leaf_base = leaf_base o f"
using leaf_base_transfer[of "BNF_Def.Grp UNIV f"]
unfolding ΣΣ_base.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma \<oo>\<pp>_base_natural: "\<oo>\<pp>_base o Σ_base_map (ΣΣ_base_map f) = ΣΣ_base_map f o \<oo>\<pp>_base"
using \<oo>\<pp>_base_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ_base.rel_Grp ΣΣ_base.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma ΣΣ_base_map_def2: "ΣΣ_base_map i = ext_base \<oo>\<pp>_base (leaf_base o i)"
by (rule ext_base_unique[OF leaf_base_natural \<oo>\<pp>_base_natural[symmetric]])
lemma ext_base_\<oo>\<pp>_base_leaf_base: "ext_base \<oo>\<pp>_base leaf_base = id"
apply (rule ext_base_unique[symmetric]) unfolding Σ_base.map_id0 o_id id_o by (rule refl)+
lemma ext_base_ΣΣ_base_map:
"ext_base s (j o f) = ext_base s j o ΣΣ_base_map f"
proof (rule ext_base_unique[symmetric])
show "ext_base s j o ΣΣ_base_map f o leaf_base = j o f"
unfolding o_assoc[symmetric] leaf_base_natural
unfolding o_assoc ext_base_comp_leaf_base ..
next
show "ext_base s j o ΣΣ_base_map f o \<oo>\<pp>_base = s o Σ_base_map (ext_base s j o ΣΣ_base_map f)"
unfolding o_assoc[symmetric] \<oo>\<pp>_base_natural[symmetric]
unfolding o_assoc ext_base_commute
unfolding o_assoc[symmetric] Σ_base.map_comp0 ..
qed
lemma ext_base_Σ_base_map:
assumes "t o Σ_base_map f = f o s"
shows "ext_base t (f o i) = f o ext_base s i"
proof (rule ext_base_unique[symmetric])
show "f o ext_base s i o leaf_base = f o i"
unfolding o_assoc[symmetric] ext_base_comp_leaf_base ..
next
show "f o ext_base s i o \<oo>\<pp>_base = t o Σ_base_map (f o ext_base s i)"
unfolding Σ_base.map_comp0 o_assoc assms
unfolding o_assoc[symmetric] ext_base_commute[symmetric] ..
qed
subsection{* Monadic laws *}
lemma flat_base_commute: "\<oo>\<pp>_base o Σ_base_map flat_base = flat_base o \<oo>\<pp>_base"
unfolding flat_base_def ext_base_commute ..
theorem flat_base_leaf_base: "flat_base o leaf_base = id"
unfolding flat_base_def ext_base_comp_leaf_base ..
theorem leaf_base_flat_base: "flat_base o ΣΣ_base_map leaf_base = id"
unfolding flat_base_def ext_base_ΣΣ_base_map[symmetric] id_o ext_base_\<oo>\<pp>_base_leaf_base ..
theorem flat_base_natural: "flat_base o ΣΣ_base_map (ΣΣ_base_map i) = ΣΣ_base_map i o flat_base"
using flat_base_transfer[of "BNF_Def.Grp UNIV i"]
unfolding ΣΣ_base.rel_Grp
unfolding Grp_def rel_fun_def by auto
theorem flat_base_assoc: "flat_base o ΣΣ_base_map flat_base = flat_base o flat_base"
unfolding flat_base_def unfolding ext_base_ΣΣ_base_map[symmetric] id_o
proof(rule ext_base_unique[symmetric], unfold flat_base_def[symmetric])
show "flat_base o flat_base o leaf_base = flat_base"
unfolding o_assoc[symmetric] flat_base_leaf_base by simp
next
show "flat_base o flat_base o \<oo>\<pp>_base = \<oo>\<pp>_base o Σ_base_map (flat_base o flat_base)"
unfolding flat_base_def unfolding o_assoc[symmetric] ext_base_commute
unfolding flat_base_def[symmetric]
unfolding Σ_base.map_comp0 o_assoc unfolding flat_base_commute ..
qed
end