Theory Tree_Integrate_New_Op2

theory Tree_Integrate_New_Op2
imports Tree_Op_Input2
header{* The integration of a new operation in the up-to setting *}

theory Tree_Integrate_New_Op2
imports Tree_Op_Input2
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_Upto2 as follows: *)
definition algρ2 :: "J K2 => J" where
"algρ2 = unfoldU1 (ρ2 o K2_map <id, dtor_J>)"
*)

lemma ρ2_natural: "ρ2 o K2_map (f ** F_map f) = F_map (ΣΣ2_map f) o ρ2"
  using ρ2_transfer[of "BNF_Def.Grp UNIV f"]
  unfolding F_rel_Grp ΣΣ2.rel_Grp K2.rel_Grp prod.rel_Grp
  unfolding Grp_def rel_fun_def by auto

subsection{* The integration *}

definition embL2 :: "'a ΣΣ1 => 'a ΣΣ2" where
"embL2 ≡ ext1 (\<oo>\<pp>2 o Abs_Σ2 o Inl) leaf2"

definition embR2 :: "('a K2) ΣΣ1 => 'a ΣΣ2" where
"embR2 ≡ ext1 (\<oo>\<pp>2 o Abs_Σ2 o Inl) (\<oo>\<pp>2 o Σ2_map leaf2 o Abs_Σ2 o Inr)"

definition Λ2 :: "('a × 'a F) Σ2 => 'a ΣΣ2 F" where
"Λ2 = case_sum (F_map embL2 o Λ1) ρ2 o Rep_Σ2"

lemma embL2_transfer[transfer_rule]:
  "(ΣΣ1_rel R ===> ΣΣ2_rel R) embL2 embL2"
  unfolding embL2_def ext1_alt by transfer_prover

lemma embR2_transfer[transfer_rule]:
  "(ΣΣ1_rel (K2_rel R) ===> ΣΣ2_rel R) embR2 embR2"
  unfolding embR2_def ext1_alt by transfer_prover

lemma Λ2_transfer[transfer_rule]:
  "(Σ2_rel (rel_prod R (F_rel R)) ===> F_rel (ΣΣ2_rel R)) Λ2 Λ2"
  unfolding Λ2_def by transfer_prover

lemma Λ2_natural: "Λ2 o Σ2_map (f ** F_map f) = F_map (ΣΣ2_map f) o Λ2"
  using Λ2_transfer[of "BNF_Def.Grp UNIV f"]
  unfolding F_rel_Grp ΣΣ2.rel_Grp Σ2.rel_Grp prod.rel_Grp
  unfolding Grp_def rel_fun_def by auto

lemma embL2_natural: "embL2 o ΣΣ1_map f = ΣΣ2_map f o embL2"
  using embL2_transfer[of "BNF_Def.Grp UNIV f"]
  unfolding ΣΣ1.rel_Grp ΣΣ2.rel_Grp
  unfolding Grp_def rel_fun_def by auto

lemma embR2_natural: "embR2 o ΣΣ1_map (K2_map f) = ΣΣ2_map f o embR2"
  using embR2_transfer[of "BNF_Def.Grp UNIV f"]
  unfolding ΣΣ1.rel_Grp K2.rel_Grp ΣΣ2.rel_Grp
  unfolding Grp_def rel_fun_def by auto

lemma Λ2_Inl: "Λ2 o Abs_Σ2 o Inl = F_map embL2 o Λ1"
  and Λ2_Inr: "Λ2 o Abs_Σ2 o Inr = ρ2"
unfolding Λ2_def o_assoc[symmetric] Rep_Σ2_o_Abs_Σ2 o_id by auto

lemma embL2_leaf1: "embL2 o leaf1 = leaf2"
unfolding embL2_def ext1_comp_leaf1 ..

lemma embL2_\<oo>\<pp>1: "embL2 o \<oo>\<pp>1 = \<oo>\<pp>2 o Abs_Σ2 o Inl o Σ1_map embL2"
unfolding embL2_def ext1_commute ..

lemma embR2_leaf1: "embR2 o leaf1 = \<oo>\<pp>2 o Abs_Σ2 o Inr o K2_map leaf2"
unfolding embR2_def ext1_comp_leaf1
unfolding o_assoc[symmetric] Abs_Σ2_natural map_sum_Inr ..

lemma embR2_\<oo>\<pp>1: "embR2 o \<oo>\<pp>1 = \<oo>\<pp>2 o Abs_Σ2 o  Inl o Σ1_map embR2"
unfolding embR2_def ext1_commute ..

end