Theory Tree_Integrate_New_Op1

theory Tree_Integrate_New_Op1
imports Tree_Op_Input1
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 *}

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

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