Theory Integrate_New_Op_step

theory Integrate_New_Op_step
imports Op_Input_step
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 *}

(*
(* The operation that creates the new distributive law, since its definition splits
trough a natural transformation ll, which will be defined in More_Corec_Upto_step as follows: *)
definition algρ_step :: "J K_step => J" where
"algρ_step = unfoldU_base (ρ_step o K_step_map <id, dtor_J>)"
*)

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