Theory Lift_to_Free_base

theory Lift_to_Free_base
imports Distributive_Law_base
header {* Copy of lift_to_free, but for the initial distributive law  *}

theory Lift_to_Free_base
imports Distributive_Law_base
begin


subsection{* The lifting *}

(* Our aim is lift ll to an (S,S,T)-distributive law dd_base compatible with the monadic structure. *)

(* In order to be able to define dd_base, we need a larger codomain type: *)
definition ddd_base :: "('a × 'a F) ΣΣ_base => 'a ΣΣ_base × 'a ΣΣ_base F" where
"ddd_base = ext_base <\<oo>\<pp>_base o Σ_base_map fst, F_map flat_base o Λ_base> (leaf_base ** F_map leaf_base)"

definition dd_base :: "('a × 'a F) ΣΣ_base => 'a ΣΣ_base F" where
"dd_base = snd o ddd_base"

lemma ddd_base_transfer[transfer_rule]:
  "(ΣΣ_base_rel (rel_prod R (F_rel R)) ===> rel_prod (ΣΣ_base_rel R) (F_rel (ΣΣ_base_rel R))) ddd_base ddd_base"
  unfolding ddd_base_def ext_base_alt by transfer_prover

lemma dd_base_transfer[transfer_rule]:
  "(ΣΣ_base_rel (rel_prod R (F_rel R)) ===> F_rel (ΣΣ_base_rel R)) dd_base dd_base"
  unfolding dd_base_def by transfer_prover

lemma F_rel_ΣΣ_base_rel: "ΣΣ_base_rel (rel_prod R (F_rel R)) x y ==> F_rel (ΣΣ_base_rel R) (dd_base x) (dd_base y)"
  by (erule rel_funD[OF dd_base_transfer])

(* We verify the facts for dd_base: *)
theorem dd_base_leaf_base: "dd_base o leaf_base = F_map leaf_base o snd"
unfolding dd_base_def ddd_base_def by auto

lemma ddd_base_natural: "ddd_base o ΣΣ_base_map (f ** F_map f) = (ΣΣ_base_map f ** F_map (ΣΣ_base_map f)) o ddd_base"
  using ddd_base_transfer[of "BNF_Def.Grp UNIV f"]
  unfolding F_rel_Grp prod.rel_Grp ΣΣ_base.rel_Grp
  unfolding Grp_def rel_fun_def by auto

theorem dd_base_natural: "dd_base o ΣΣ_base_map (f ** F_map f) = F_map (ΣΣ_base_map f) o dd_base"
  using dd_base_transfer[of "BNF_Def.Grp UNIV f"]
  unfolding F_rel_Grp prod.rel_Grp ΣΣ_base.rel_Grp
  unfolding Grp_def rel_fun_def by auto

lemma Λ_base_dd_base: "Λ_base = dd_base o \<oo>\<pp>_base o Σ_base_map leaf_base"
  unfolding dd_base_def ddd_base_def o_assoc[symmetric] Σ_base.map_comp0[symmetric] ext_base_commute
  unfolding o_assoc snd_convol ext_base_comp_leaf_base
  unfolding o_assoc[symmetric] Λ_base_natural
  unfolding o_assoc F_map_comp[symmetric] leaf_base_flat_base F_map_id id_o
  ..

lemma fst_ddd_base: "fst o ddd_base = ΣΣ_base_map fst"
proof-
  have "fst o ddd_base = ext_base \<oo>\<pp>_base (leaf_base o fst)"
  apply(rule ext_base_unique) unfolding ddd_base_def o_assoc[symmetric] ext_base_comp_leaf_base ext_base_commute
  unfolding o_assoc fst_comp_map_prod fst_convol
  unfolding o_assoc[symmetric] Σ_base.map_comp0 by(rule refl, rule refl)
  also have "... = ΣΣ_base_map fst"
  apply(rule sym, rule ext_base_unique)
  unfolding leaf_base_natural \<oo>\<pp>_base_natural by(rule refl, rule refl)
  finally show ?thesis .
qed

lemma ddd_base_flat_base: "(flat_base ** F_map flat_base) o ddd_base o ΣΣ_base_map ddd_base = ddd_base o flat_base" (is "?L = ?R")
proof-
  have "?L = ext_base <\<oo>\<pp>_base o Σ_base_map fst, F_map flat_base o Λ_base> ddd_base"
  proof(rule ext_base_unique)
    show "(flat_base ** F_map flat_base) o ddd_base o ΣΣ_base_map ddd_base o leaf_base = ddd_base"
    unfolding ddd_base_def unfolding o_assoc[symmetric] leaf_base_natural
    unfolding o_assoc
    apply(subst o_assoc[symmetric]) unfolding ext_base_comp_leaf_base
    unfolding map_prod.comp F_map_comp[symmetric] flat_base_leaf_base F_map_id map_prod.id id_o ..
  next
    have 1: "<flat_base o (\<oo>\<pp>_base o Σ_base_map fst) , F_map flat_base o (F_map flat_base o Λ_base)>  =
             <\<oo>\<pp>_base o Σ_base_map fst , F_map flat_base o Λ_base> o Σ_base_map (flat_base ** F_map flat_base)"
    unfolding o_assoc unfolding flat_base_commute[symmetric]
    apply(rule fst_snd_cong) unfolding o_assoc fst_convol snd_convol
    unfolding o_assoc[symmetric] Σ_base.map_comp0[symmetric] fst_comp_map_prod snd_comp_map_prod
    unfolding Λ_base_natural unfolding o_assoc F_map_comp[symmetric] flat_base_assoc
    by(rule refl, rule refl)
    show "(flat_base ** F_map flat_base) o ddd_base o ΣΣ_base_map ddd_base o \<oo>\<pp>_base =
          <\<oo>\<pp>_base o Σ_base_map fst , F_map flat_base o Λ_base> o Σ_base_map (flat_base ** F_map flat_base o ddd_base o ΣΣ_base_map ddd_base)"
    unfolding ddd_base_def unfolding o_assoc[symmetric] unfolding \<oo>\<pp>_base_natural[symmetric]
    unfolding o_assoc
    apply(subst o_assoc[symmetric]) unfolding ext_base_commute
    unfolding o_assoc[symmetric] Σ_base.map_comp0[symmetric]
    unfolding Σ_base.map_comp0
    unfolding o_assoc unfolding map_prod_o_convol
    unfolding ext_base_ΣΣ_base_map[symmetric] 1 ..
  qed
  also have "... = ?R"
  proof(rule sym, rule ext_base_unique)
    show "ddd_base o flat_base o leaf_base = ddd_base" unfolding o_assoc[symmetric] flat_base_leaf_base o_id ..
  next
    show "ddd_base o flat_base o \<oo>\<pp>_base = <\<oo>\<pp>_base o Σ_base_map fst , F_map flat_base o Λ_base> o Σ_base_map (ddd_base o flat_base)"
    unfolding ddd_base_def unfolding o_assoc[symmetric] unfolding flat_base_commute[symmetric]
    unfolding o_assoc unfolding ext_base_commute Σ_base.map_comp0 unfolding o_assoc ..
  qed
  finally show ?thesis .
qed

theorem dd_base_flat_base: "F_map flat_base o dd_base o ΣΣ_base_map <ΣΣ_base_map fst, dd_base> = dd_base o flat_base"
proof-
  have 1: "snd o ((flat_base ** F_map flat_base) o ddd_base o ΣΣ_base_map ddd_base) = snd o (ddd_base o flat_base)"
  unfolding ddd_base_flat_base ..
  have 2: "ddd_base = <ΣΣ_base_map fst , snd o ddd_base>" apply(rule fst_snd_cong)
  unfolding fst_ddd_base by auto
  show ?thesis unfolding dd_base_def
  unfolding 1[symmetric, unfolded o_assoc snd_comp_map_prod] o_assoc 2[symmetric] ..
qed


(* The next two theorems are not necessary for the development.
They show that the conditions dd_base_leaf_base and dd_base_flat_base imply the
more standard conditions for the distributive law dd_base' = <ΣΣ_base_map fst, dd_base>
for the functors ΣΣ_base and 'a F' = 'a × 'a F_ In fact, they can be shown
equivalent to these. *)

lemma dd_base_leaf_base2: "<ΣΣ_base_map fst, dd_base> o leaf_base = leaf_base ** F_map leaf_base"
apply (rule fst_snd_cong) unfolding o_assoc by (simp_all add: leaf_base_natural dd_base_leaf_base)

lemma ddd_base_leaf_base: "ddd_base o leaf_base = leaf_base ** F_map leaf_base"
unfolding ddd_base_def ext_base_comp_leaf_base ..

lemma ddd_base_\<oo>\<pp>_base:
"ddd_base o \<oo>\<pp>_base = <\<oo>\<pp>_base o Σ_base_map fst , F_map flat_base o Λ_base> o Σ_base_map ddd_base"
unfolding ddd_base_def ext_base_commute ..


(* More customization *)

lemma ΣΣ_base_rel_induct_pointfree:
assumes leaf: "!! x1 x2. R x1 x2 ==> phi (leaf_base x1) (leaf_base x2)"
and \<oo>\<pp>: "!! y1 y2. [|Σ_base_rel (ΣΣ_base_rel R) y1 y2; Σ_base_rel phi y1 y2|] ==> phi (\<oo>\<pp>_base y1) (\<oo>\<pp>_base y2)"
shows "ΣΣ_base_rel R ≤ phi"
proof-
  have "ΣΣ_base_rel R ≤ phi \<sqinter> ΣΣ_base_rel R"
  apply(induct rule: ΣΣ_base.ctor_rel_induct)
  using assms ΣΣ_base.rel_inject[of R] unfolding rel_pre_ΣΣ_base_def ΣΣ_base.leaf_base_def ΣΣ_base.\<oo>\<pp>_base_def
  using inf_greatest[OF Σ_base.rel_mono[OF inf_le1] Σ_base.rel_mono[OF inf_le2]]
  unfolding rel_sum_def BNF_Comp.id_bnf_comp_def vimage2p_def by (auto split: sum.splits) blast+
  thus ?thesis by simp
qed

lemma ΣΣ_base_rel_induct[case_names leaf \<oo>\<pp>]:
assumes leaf: "!! x1 x2. R x1 x2 ==> phi (leaf_base x1) (leaf_base x2)"
and \<oo>\<pp>: "!! y1 y2. [|Σ_base_rel (ΣΣ_base_rel R) y1 y2; Σ_base_rel phi y1 y2|] ==> phi (\<oo>\<pp>_base y1) (\<oo>\<pp>_base y2)"
shows "ΣΣ_base_rel R t1 t2 --> phi t1 t2"
using ΣΣ_base_rel_induct_pointfree[of R, OF assms] by auto

end