header{* The integration of a new operation in the up-to setting *}
theory Tree_Integrate_New_Op1
imports Tree_Op_Input1
begin
subsection{* The assumptions *}
lemma ρ1_natural: "ρ1 o K1_map (f ** F_map f) = F_map (ΣΣ1_map f) o ρ1"
using ρ1_transfer[of "BNF_Def.Grp UNIV f"]
unfolding F_rel_Grp ΣΣ1.rel_Grp K1.rel_Grp prod.rel_Grp
unfolding Grp_def rel_fun_def by auto
subsection{* The integration *}
definition embL1 :: "'a ΣΣ0 => 'a ΣΣ1" where
"embL1 ≡ ext0 (\<oo>\<pp>1 o Abs_Σ1 o Inl) leaf1"
definition embR1 :: "('a K1) ΣΣ0 => 'a ΣΣ1" where
"embR1 ≡ ext0 (\<oo>\<pp>1 o Abs_Σ1 o Inl) (\<oo>\<pp>1 o Σ1_map leaf1 o Abs_Σ1 o Inr)"
definition Λ1 :: "('a × 'a F) Σ1 => 'a ΣΣ1 F" where
"Λ1 = case_sum (F_map embL1 o Λ0) ρ1 o Rep_Σ1"
lemma embL1_transfer[transfer_rule]:
"(ΣΣ0_rel R ===> ΣΣ1_rel R) embL1 embL1"
unfolding embL1_def ext0_alt by transfer_prover
lemma embR1_transfer[transfer_rule]:
"(ΣΣ0_rel (K1_rel R) ===> ΣΣ1_rel R) embR1 embR1"
unfolding embR1_def ext0_alt by transfer_prover
lemma Λ1_transfer[transfer_rule]:
"(Σ1_rel (rel_prod R (F_rel R)) ===> F_rel (ΣΣ1_rel R)) Λ1 Λ1"
unfolding Λ1_def by transfer_prover
lemma Λ1_natural: "Λ1 o Σ1_map (f ** F_map f) = F_map (ΣΣ1_map f) o Λ1"
using Λ1_transfer[of "BNF_Def.Grp UNIV f"]
unfolding F_rel_Grp ΣΣ1.rel_Grp Σ1.rel_Grp prod.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma embL1_natural: "embL1 o ΣΣ0_map f = ΣΣ1_map f o embL1"
using embL1_transfer[of "BNF_Def.Grp UNIV f"]
unfolding ΣΣ0.rel_Grp ΣΣ1.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma embR1_natural: "embR1 o ΣΣ0_map (K1_map f) = ΣΣ1_map f o embR1"
using embR1_transfer[of "BNF_Def.Grp UNIV f"]
unfolding ΣΣ0.rel_Grp K1.rel_Grp ΣΣ1.rel_Grp
unfolding Grp_def rel_fun_def by auto
lemma Λ1_Inl: "Λ1 o Abs_Σ1 o Inl = F_map embL1 o Λ0"
and Λ1_Inr: "Λ1 o Abs_Σ1 o Inr = ρ1"
unfolding Λ1_def o_assoc[symmetric] Rep_Σ1_o_Abs_Σ1 o_id by auto
lemma embL1_leaf0: "embL1 o leaf0 = leaf1"
unfolding embL1_def ext0_comp_leaf0 ..
lemma embL1_\<oo>\<pp>0: "embL1 o \<oo>\<pp>0 = \<oo>\<pp>1 o Abs_Σ1 o Inl o Σ0_map embL1"
unfolding embL1_def ext0_commute ..
lemma embR1_leaf0: "embR1 o leaf0 = \<oo>\<pp>1 o Abs_Σ1 o Inr o K1_map leaf1"
unfolding embR1_def ext0_comp_leaf0
unfolding o_assoc[symmetric] Abs_Σ1_natural map_sum_Inr ..
lemma embR1_\<oo>\<pp>0: "embR1 o \<oo>\<pp>0 = \<oo>\<pp>1 o Abs_Σ1 o Inl o Σ0_map embR1"
unfolding embR1_def ext0_commute ..
end