header {* More on corecursion and coinduction up to *}
theory More_Corec_Upto_step
imports Corec_Upto_step
begin
subsection{* A natural-transformation-based version of the up-to corecursion principle *}
definition algρ_step :: "J K_step => J" where "algρ_step ≡ eval_step o K_step_as_ΣΣ_step"
lemma dd_step_K_step_as_ΣΣ_step:
"dd_step o K_step_as_ΣΣ_step = ρ_step"
unfolding K_step_as_ΣΣ_step_def dd_step_def
unfolding o_assoc apply(subst o_assoc[symmetric])
unfolding ddd_step_\<oo>\<pp>_step unfolding o_assoc snd_convol
unfolding o_assoc apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding Σ_step.map_comp0[symmetric] ddd_step_leaf_step Λ_step_natural
unfolding o_assoc F_map_comp[symmetric] leaf_step_flat_step F_map_id id_o Λ_step_Inr ..
lemma algρ_step: "dtor_J o algρ_step = F_map eval_step o ρ_step o K_step_map <id, dtor_J>"
unfolding dd_step_K_step_as_ΣΣ_step[symmetric] o_assoc
unfolding o_assoc[symmetric] K_step_as_ΣΣ_step_natural
unfolding o_assoc eval_step algρ_step_def ..
lemma flat_step_embL_step: "flat_step o embL_step o ΣΣ_base_map embL_step = embL_step o flat_base" (is "?L = ?R")
proof-
have "?L = ext_base (\<oo>\<pp>_step o Abs_Σ_step o Inl) embL_step"
proof(rule ext_base_unique)
show "flat_step o embL_step o ΣΣ_base_map embL_step o leaf_base = embL_step"
unfolding o_assoc[symmetric] unfolding leaf_base_natural
unfolding o_assoc apply(subst o_assoc[symmetric])
apply(subst embL_step_def) unfolding ext_base_comp_leaf_base flat_step_leaf_step id_o ..
next
show "flat_step o embL_step o ΣΣ_base_map embL_step o \<oo>\<pp>_base = \<oo>\<pp>_step o Abs_Σ_step o Inl o Σ_base_map (flat_step o embL_step o ΣΣ_base_map embL_step)"
apply(subst o_assoc[symmetric]) unfolding embL_step_natural
unfolding o_assoc apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric],
subst o_assoc[symmetric])
unfolding embL_step_def unfolding ext_base_commute unfolding embL_step_def[symmetric]
unfolding o_assoc apply(subst o_assoc[symmetric])
unfolding \<oo>\<pp>_step_natural[symmetric]
unfolding o_assoc apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding map_sum_Inl Abs_Σ_step_natural
unfolding o_assoc[symmetric] map_sum_Inl Σ_base.map_comp0[symmetric] embL_step_natural[symmetric]
apply(rule sym) apply(subst Σ_base.map_comp0) unfolding o_assoc
unfolding flat_step_def unfolding ext_step_commute
apply(rule sym) apply(subst o_assoc[symmetric])
unfolding Abs_Σ_step_natural unfolding o_assoc[symmetric] map_sum_Inl \<oo>\<pp>_step_natural[symmetric] ..
qed
also have "... = ?R"
proof(rule sym, rule ext_base_unique)
show "embL_step o flat_base o leaf_base = embL_step"
unfolding o_assoc[symmetric] flat_base_leaf_base o_id ..
next
show "embL_step o flat_base o \<oo>\<pp>_base = \<oo>\<pp>_step o Abs_Σ_step o Inl o Σ_base_map (embL_step o flat_base)"
unfolding flat_base_def o_assoc[symmetric] ext_base_commute
unfolding o_assoc
apply(subst embL_step_def) unfolding ext_base_commute apply(subst embL_step_def[symmetric])
unfolding Σ_base.map_comp0 o_assoc ..
qed
finally show ?thesis .
qed
lemma ddd_step_embL_step: "ddd_step o embL_step = (embL_step ** F_map embL_step) o ddd_base" (is "?L = ?R")
proof-
have "?L = ext_base <\<oo>\<pp>_step o Abs_Σ_step o Inl o Σ_base_map fst, F_map (flat_step o embL_step) o Λ_base> (leaf_step ** F_map leaf_step)"
proof(rule ext_base_unique)
show "ddd_step o embL_step o leaf_base = leaf_step ** F_map leaf_step"
apply(rule fst_snd_cong)
unfolding fst_comp_map_prod snd_comp_map_prod
unfolding embL_step_def
apply (subst (3) o_assoc[symmetric]) defer apply (subst (3) o_assoc[symmetric])
unfolding ext_base_comp_leaf_base
unfolding ddd_step_def ext_step_comp_leaf_step fst_comp_map_prod snd_comp_map_prod by(rule refl, rule refl)
next
show "ddd_step o embL_step o \<oo>\<pp>_base =
<\<oo>\<pp>_step o Abs_Σ_step o Inl o Σ_base_map fst , F_map (flat_step o embL_step) o Λ_base> o Σ_base_map (ddd_step o embL_step)" (is "?A = ?B")
proof(rule fst_snd_cong)
show "fst o ?A = fst o ?B"
unfolding o_assoc fst_convol unfolding o_assoc[symmetric] Σ_base.map_comp0[symmetric]
unfolding o_assoc
apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
apply(subst embL_step_def) unfolding ext_base_commute apply(subst embL_step_def[symmetric])
unfolding o_assoc apply(subst o_assoc[symmetric])
apply(subst ddd_step_def) unfolding ext_step_commute apply(subst ddd_step_def[symmetric])
unfolding o_assoc fst_convol
apply(subst o_assoc[symmetric]) unfolding Σ_step.map_comp0[symmetric]
apply(subst o_assoc[symmetric]) unfolding Abs_Σ_step_natural map_sum_Inl o_assoc[symmetric]
unfolding Σ_base.map_comp0[symmetric] o_assoc ..
next
show "snd o ?A = snd o ?B"
unfolding o_assoc snd_convol unfolding o_assoc[symmetric]
apply(subst embL_step_def) unfolding ext_base_commute apply(subst embL_step_def[symmetric])
unfolding o_assoc apply(subst o_assoc[symmetric], subst o_assoc[symmetric])
apply(subst ddd_step_def) unfolding ext_step_commute apply(subst ddd_step_def[symmetric])
unfolding o_assoc snd_convol
unfolding o_assoc apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding Abs_Σ_step_natural map_sum_Inl o_assoc[symmetric]
unfolding o_assoc apply(subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding Λ_step_Inl unfolding Σ_base.map_comp0 F_map_comp o_assoc ..
qed
qed
also have "... = ?R"
proof(rule sym, rule ext_base_unique)
show "(embL_step ** F_map embL_step) o ddd_base o leaf_base = leaf_step ** F_map leaf_step"
unfolding o_assoc apply(subst o_assoc[symmetric])
apply(subst ddd_base_def) unfolding ext_base_comp_leaf_base
unfolding map_prod.comp unfolding F_map_comp[symmetric]
apply(subst embL_step_def, subst embL_step_def) unfolding ext_base_comp_leaf_base ..
next
show "embL_step ** F_map embL_step o ddd_base o \<oo>\<pp>_base =
<\<oo>\<pp>_step o Abs_Σ_step o Inl o Σ_base_map fst , F_map (flat_step o embL_step) o Λ_base> o Σ_base_map (embL_step ** F_map embL_step o ddd_base)"
(is "?A = ?B") proof(rule fst_snd_cong)
show "fst o ?A = fst o ?B"
unfolding o_assoc fst_convol fst_comp_map_prod
unfolding o_assoc[symmetric] Σ_base.map_comp0[symmetric] unfolding o_assoc unfolding fst_comp_map_prod
unfolding o_assoc apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
apply(subst ddd_base_def) unfolding ext_base_commute apply(subst ddd_base_def[symmetric])
unfolding o_assoc fst_convol
apply(subst embL_step_def) unfolding ext_base_commute apply(subst embL_step_def[symmetric])
unfolding Σ_base.map_comp0 o_assoc ..
next
show "snd o ?A = snd o ?B"
unfolding o_assoc snd_convol snd_comp_map_prod
unfolding o_assoc apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
apply(subst ddd_base_def) unfolding ext_base_commute apply(subst ddd_base_def[symmetric])
unfolding o_assoc apply(subst o_assoc[symmetric]) unfolding snd_convol
unfolding o_assoc F_map_comp[symmetric]
unfolding flat_step_embL_step[symmetric]
unfolding F_map_comp
unfolding o_assoc apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding Λ_base_natural[symmetric]
unfolding o_assoc Σ_base.map_comp0 ..
qed
qed
finally show ?thesis .
qed
lemma dd_step_embL_step: "dd_step o embL_step = F_map embL_step o dd_base"
unfolding dd_step_def dd_base_def o_assoc[symmetric] ddd_step_embL_step by auto
lemma F_map_embL_step_ΣΣ_base_map:
"F_map embL_step o dd_base o ΣΣ_base_map <id , dtor_J> =
dd_step o ΣΣ_step_map <id , dtor_J> o embL_step"
unfolding o_assoc[symmetric] unfolding embL_step_natural[symmetric]
unfolding o_assoc dd_step_embL_step ..
lemma eval_step_embL_step: "eval_step o embL_step = eval_base"
unfolding eval_base_def apply(rule J.dtor_unfold_unique)
unfolding eval_step_def unfolding o_assoc
unfolding dtor_unfold_J_pointfree
unfolding F_map_comp
apply(subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding F_map_embL_step_ΣΣ_base_map o_assoc ..
theorem algΛ_step_algΛ_base_algρ_step:
"algΛ_step o Abs_Σ_step = case_sum algΛ_base algρ_step" (is "?L = ?R")
proof(rule sum_comp_cases)
show "?L o Inl = ?R o Inl"
unfolding case_sum_o_inj apply(subst dtor_J_o_inj[symmetric])
unfolding o_assoc dtor_J_algΛ_step unfolding Abs_Σ_step_natural o_assoc[symmetric] map_sum_Inl
unfolding o_assoc apply(subst o_assoc[symmetric], subst o_assoc[symmetric]) unfolding Λ_step_Inl
unfolding o_assoc F_map_comp[symmetric] eval_step_embL_step dtor_J_algΛ_base ..
next
show "?L o Inr = ?R o Inr"
unfolding algρ_step_def case_sum_o_inj algΛ_step_def K_step_as_ΣΣ_step_def o_assoc ..
qed
theorem algΛ_step_Inl: "algΛ_step (Abs_Σ_step (Inl x)) = algΛ_base x" (is "?L = ?R")
unfolding o_eq_dest_lhs[OF algΛ_step_algΛ_base_algρ_step] by simp
lemma algΛ_step_Inl_pointfree: "algΛ_step o Abs_Σ_step o Inl = algΛ_base"
unfolding o_def fun_eq_iff algΛ_step_Inl by simp
theorem algΛ_step_Inr: "algΛ_step (Abs_Σ_step (Inr x)) = algρ_step x" (is "?L = ?R")
unfolding o_eq_dest_lhs[OF algΛ_step_algΛ_base_algρ_step] by simp
subsection{* Up-to corecursor with guard not necessarily at the top *}
definition ff_step :: "'a F => 'a Σ_step" where "ff_step ≡ Abs_Σ_step o Inl o ff_base"
lemma algΛ_step_ff_step: "algΛ_step o ff_step = ctor_J"
unfolding ff_step_def o_assoc algΛ_step_Inl_pointfree algΛ_base_ff_base ..
lemma ff_step_transfer[transfer_rule]: "(F_rel R ===> Σ_step_rel R) ff_step ff_step"
unfolding ff_step_def by transfer_prover
lemma ff_step_natural: "Σ_step_map f o ff_step = ff_step o F_map f"
using ff_step_transfer[of "BNF_Def.Grp UNIV f"]
unfolding Σ_step.rel_Grp F_rel_Grp
unfolding Grp_def rel_fun_def by auto
definition gg_step :: "'a ΣΣ_step F => 'a ΣΣ_step" where
"gg_step ≡ \<oo>\<pp>_step o ff_step"
lemma eval_step_gg_step: "eval_step o gg_step = ctor_J o F_map eval_step"
unfolding gg_step_def
unfolding o_assoc unfolding eval_step_comp_\<oo>\<pp>_step
unfolding o_assoc[symmetric] ff_step_natural
unfolding o_assoc algΛ_step_ff_step ..
lemma gg_step_transfer[transfer_rule]: "(F_rel (ΣΣ_step_rel R) ===> ΣΣ_step_rel R) gg_step gg_step"
unfolding gg_step_def by transfer_prover
lemma gg_step_natural: "ΣΣ_step_map f o gg_step = gg_step o F_map (ΣΣ_step_map f)"
using gg_step_transfer[of "BNF_Def.Grp UNIV f"]
unfolding ΣΣ_step.rel_Grp F_rel_Grp
unfolding Grp_def rel_fun_def by auto
definition unfoldUU_step :: "('a => 'a ΣΣ_step F ΣΣ_step) => 'a => J" where
"unfoldUU_step s ≡ unfoldU_step (F_map flat_step o dd_step o ΣΣ_step_map <gg_step, id> o s)"
theorem unfoldUU_step:
"unfoldUU_step s =
eval_step o ΣΣ_step_map (ctor_J o F_map eval_step o F_map (ΣΣ_step_map (unfoldUU_step s))) o s"
unfolding unfoldUU_step_def apply(subst unfoldU_step_ctor_J_pointfree[symmetric]) unfolding unfoldUU_step_def[symmetric]
unfolding extdd_step_def F_map_comp[symmetric] o_assoc
apply(subst o_assoc[symmetric]) unfolding F_map_comp[symmetric]
apply(subst o_assoc[symmetric]) unfolding flat_step_natural[symmetric]
apply(subst o_assoc) unfolding eval_step_flat_step
unfolding F_map_comp
apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding dd_step_natural[symmetric]
unfolding o_assoc apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding dd_step_natural[symmetric]
unfolding o_assoc[symmetric] ΣΣ_step.map_comp0[symmetric]
unfolding o_assoc eval_step_gg_step unfolding ΣΣ_step.map_comp0 o_assoc
apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric],
subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding ΣΣ_step.map_comp0[symmetric]
apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding ΣΣ_step.map_comp0[symmetric] map_prod.comp map_prod_o_convol o_id F_map_comp[symmetric]
apply(rule sym) unfolding o_assoc
apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding ΣΣ_step.map_comp0[symmetric] F_map_comp[symmetric] o_assoc[symmetric] gg_step_natural
unfolding o_assoc eval_step_gg_step
apply(rule sym)
apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding F_map_comp[symmetric] convol_comp_id2 convol_ctor_J_dtor_J
ΣΣ_step.map_comp0 o_assoc eval_step ctor_dtor_J_pointfree id_o ..
theorem unfoldUU_step_unique:
assumes f: "f = eval_step o ΣΣ_step_map (ctor_J o F_map eval_step o F_map (ΣΣ_step_map f)) o s"
shows "f = unfoldUU_step s"
unfolding unfoldUU_step_def apply(rule unfoldU_step_unique)
apply(rule sym) apply(subst f) unfolding extdd_step_def
unfolding o_assoc
apply(subst eval_step_def) unfolding dtor_unfold_J_pointfree apply(subst eval_step_def[symmetric])
unfolding o_assoc
apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding o_assoc ΣΣ_step.map_comp0[symmetric] convol_o id_o dtor_J_ctor_pointfree F_map_comp[symmetric]
unfolding o_assoc[symmetric] flat_step_natural[symmetric]
unfolding o_assoc eval_step_flat_step unfolding o_assoc[symmetric] unfolding F_map_comp
apply(rule sym) apply(subst F_map_comp[symmetric], subst ΣΣ_step.map_comp0[symmetric])
unfolding o_assoc apply(subst o_assoc[symmetric])
unfolding dd_step_natural[symmetric]
unfolding o_assoc[symmetric] ΣΣ_step.map_comp0[symmetric] map_prod_o_convol o_id
unfolding o_assoc[symmetric] gg_step_natural
unfolding o_assoc eval_step_gg_step F_map_comp ..
definition corecUU_step :: "('a => (J + 'a) ΣΣ_step F ΣΣ_step) => 'a => J" where
"corecUU_step s ≡
unfoldUU_step (case_sum (leaf_step o dd_step o leaf_step o <Inl , F_map Inl o dtor_J>) s) o Inr"
lemma unfoldUU_step_Inl:
"unfoldUU_step (case_sum (leaf_step o dd_step o leaf_step o <Inl , F_map Inl o dtor_J>) s) o Inl = id"
(is "?L = ?R")
proof-
have "?L = unfoldUU_step (leaf_step o dd_step o leaf_step o <id, dtor_J>)"
apply(rule unfoldUU_step_unique)
apply(subst unfoldUU_step)
unfolding o_assoc[symmetric] case_sum_o_inj snd_convol
unfolding F_map_comp ΣΣ_step.map_comp0
unfolding o_assoc
apply(rule sym)
unfolding o_assoc
apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric],
subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric],
subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric],
subst o_assoc[symmetric])
unfolding leaf_step_natural apply(subst o_assoc[symmetric])
apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric],
subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding dd_step_natural[symmetric]
apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric],
subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
apply(subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding leaf_step_natural
unfolding o_assoc[symmetric] map_prod_o_convol o_id ..
also have "... = ?R"
apply(rule sym, rule unfoldUU_step_unique)
unfolding ΣΣ_step.map_id0 F_map_id o_id
unfolding o_assoc
apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric],
subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding dd_step_leaf_step
unfolding o_assoc[symmetric] snd_convol
unfolding o_assoc
apply(subst o_assoc[symmetric])
unfolding leaf_step_natural unfolding o_assoc eval_step_leaf_step id_o
apply(subst o_assoc[symmetric])
unfolding F_map_comp[symmetric] eval_step_leaf_step F_map_id o_id ctor_dtor_J_pointfree ..
finally show ?thesis .
qed
theorem corecUU_step_pointfree:
"corecUU_step s =
eval_step o ΣΣ_step_map (ctor_J o F_map eval_step o F_map (ΣΣ_step_map (case_sum id (corecUU_step s)))) o s"
unfolding corecUU_step_def
apply(subst unfoldUU_step)
unfolding o_assoc[symmetric] unfolding case_sum_o_inj
apply(subst unfoldUU_step_Inl[symmetric, of s])
unfolding o_assoc case_sum_Inl_Inr_L extdd_step_def ..
theorem corecUU_step_unique:
assumes f: "f = eval_step o ΣΣ_step_map (ctor_J o F_map eval_step o F_map (ΣΣ_step_map (case_sum id f))) o s"
shows "f = corecUU_step s"
unfolding corecUU_step_def
apply(rule eq_o_InrI[OF unfoldUU_step_Inl unfoldUU_step_unique])
apply (subst f)
apply (auto simp: fun_eq_iff eval_step_leaf_step' pre_J.map_comp o_eq_dest[OF dd_step_leaf_step] convol_def
leaf_step_natural o_assoc case_sum_o_inj(1) eval_step_leaf_step pre_J.map_id J.ctor_dtor split: sum.splits)
done
theorem corecUU_step:
"corecUU_step s a =
eval_step (ΣΣ_step_map (ctor_J o F_map eval_step o F_map (ΣΣ_step_map (case_sum id (corecUU_step s)))) (s a))"
using corecUU_step_pointfree unfolding o_def fun_eq_iff by(rule allE)
end