header{* The integration of a new operation in the up-to setting *}
theory Integrate_New_Op_step
imports Op_Input_step
begin
subsection{* The assumptions *}
lemma ρ_step_natural: "ρ_step o K_step_map (f ** F_map f) = F_map (ΣΣ_step_map f) o ρ_step"
using ρ_step_transfer[of "BNF_Def.Grp UNIV f"]
unfolding F_rel_Grp ΣΣ_step.rel_Grp K_step.rel_Grp prod.rel_Grp
unfolding Grp_def rel_fun_def by auto
subsection{* The integration *}
definition embL_step :: "'a ΣΣ_base => 'a ΣΣ_step" where
"embL_step ≡ ext_base (\<oo>\<pp>_step o Abs_Σ_step o Inl) leaf_step"
definition embR_step :: "('a K_step) ΣΣ_base => 'a ΣΣ_step" where
"embR_step ≡ ext_base (\<oo>\<pp>_step o Abs_Σ_step o Inl) (\<oo>\<pp>_step o Σ_step_map leaf_step o Abs_Σ_step o Inr)"
definition Λ_step :: "('a × 'a F) Σ_step => 'a ΣΣ_step F" where
"Λ_step = case_sum (F_map embL_step o Λ_base) ρ_step o Rep_Σ_step"
lemma embL_step_transfer[transfer_rule]:
"(ΣΣ_base_rel R ===> ΣΣ_step_rel R) embL_step embL_step"
unfolding embL_step_def ext_base_alt by transfer_prover
lemma embR_step_transfer[transfer_rule]:
"(ΣΣ_base_rel (K_step_rel R) ===> ΣΣ_step_rel R) embR_step embR_step"
unfolding embR_step_def ext_base_alt by transfer_prover
lemma Λ_step_transfer[transfer_rule]:
"(Σ_step_rel (rel_prod R (F_rel R)) ===> F_rel (ΣΣ_step_rel R)) Λ_step Λ_step"
unfolding Λ_step_def by transfer_prover
lemma Λ_step_natural: "Λ_step o Σ_step_map (f ** F_map f) = F_map (ΣΣ_step_map f) o Λ_step"
using Λ_step_transfer[of "BNF_Def.Grp UNIV f"]
unfolding F_rel_Grp ΣΣ_step.rel_Grp Σ_step.rel_Grp prod.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma embL_step_natural: "embL_step o ΣΣ_base_map f = ΣΣ_step_map f o embL_step"
using embL_step_transfer[of "BNF_Def.Grp UNIV f"]
unfolding ΣΣ_base.rel_Grp ΣΣ_step.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma embR_step_natural: "embR_step o ΣΣ_base_map (K_step_map f) = ΣΣ_step_map f o embR_step"
using embR_step_transfer[of "BNF_Def.Grp UNIV f"]
unfolding ΣΣ_base.rel_Grp K_step.rel_Grp ΣΣ_step.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma Λ_step_Inl: "Λ_step o Abs_Σ_step o Inl = F_map embL_step o Λ_base"
and Λ_step_Inr: "Λ_step o Abs_Σ_step o Inr = ρ_step"
unfolding Λ_step_def o_assoc[symmetric] Rep_Σ_step_o_Abs_Σ_step o_id by auto
lemma embL_step_leaf_base: "embL_step o leaf_base = leaf_step"
unfolding embL_step_def ext_base_comp_leaf_base ..
lemma embL_step_\<oo>\<pp>_base: "embL_step o \<oo>\<pp>_base = \<oo>\<pp>_step o Abs_Σ_step o Inl o Σ_base_map embL_step"
unfolding embL_step_def ext_base_commute ..
lemma embR_step_leaf_base: "embR_step o leaf_base = \<oo>\<pp>_step o Abs_Σ_step o Inr o K_step_map leaf_step"
unfolding embR_step_def ext_base_comp_leaf_base
unfolding o_assoc[symmetric] Abs_Σ_step_natural map_sum_Inr ..
lemma embR_step_\<oo>\<pp>_base: "embR_step o \<oo>\<pp>_base = \<oo>\<pp>_step o Abs_Σ_step o Inl o Σ_base_map embR_step"
unfolding embR_step_def ext_base_commute ..
end