header {* Corecursion and coinduction up to for the initial law *}
theory Corec_Upto_base
imports Lift_to_Free_base
begin
subsection{* The algebra associated to dd_base *}
definition "eval_base ≡ dtor_unfold_J (dd_base o ΣΣ_base_map <id, dtor_J>)"
lemma eval_base: "F_map eval_base o dd_base o ΣΣ_base_map <id, dtor_J> = dtor_J o eval_base"
unfolding eval_base_def dtor_unfold_J_pointfree unfolding o_assoc ..
lemma eval_base_ctor_J: "ctor_J o F_map eval_base o dd_base o ΣΣ_base_map <id, dtor_J> = eval_base"
unfolding o_def spec[OF eval_base[unfolded o_def fun_eq_iff]] J.ctor_dtor ..
lemma eval_base_leaf_base: "eval_base o leaf_base = id"
proof (rule trans)
show "eval_base o leaf_base = dtor_unfold_J dtor_J"
apply(rule J.dtor_unfold_unique)
unfolding o_assoc eval_base[symmetric] unfolding o_assoc[symmetric] leaf_base_natural
apply(rule sym)
unfolding F_map_comp o_assoc apply (subst o_assoc[symmetric])
unfolding dd_base_leaf_base unfolding o_assoc[symmetric] by simp
qed(metis F_map_id J.dtor_unfold_unique fun.map_id o_id)
lemma eval_base_flat_base: "eval_base o flat_base = eval_base o ΣΣ_base_map eval_base" term "eval_base o flat_base"
proof (rule trans)
let ?K = "dtor_unfold_J (dd_base o ΣΣ_base_map <ΣΣ_base_map fst, dd_base> o ΣΣ_base_map (ΣΣ_base_map <id, dtor_J>))"
show "eval_base o flat_base = ?K"
apply(rule J.dtor_unfold_unique)
unfolding F_map_comp o_assoc
apply(subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding dd_base_flat_base
unfolding o_assoc[symmetric] ΣΣ_base.map_comp[symmetric] snd_convol
unfolding flat_base_natural
unfolding o_assoc eval_base ..
have A: "<eval_base, dtor_J o eval_base> = <id,dtor_J> o eval_base" by simp
show "?K = eval_base o ΣΣ_base_map eval_base"
apply(rule J.dtor_unfold_unique[symmetric])
unfolding o_assoc[symmetric] map_prod_o_convol id_o
unfolding F_map_comp o_assoc
apply(subst o_assoc[symmetric]) unfolding dd_base_natural[symmetric]
unfolding o_assoc[symmetric] ΣΣ_base.map_comp0[symmetric]
unfolding o_assoc unfolding map_prod_o_convol unfolding convol_o
unfolding o_assoc[symmetric] ΣΣ_base.map_comp0[symmetric] fst_convol ΣΣ_base.map_id0 o_id
unfolding o_assoc eval_base unfolding A unfolding convol_o id_o
apply(rule sym) apply(subst eval_base[symmetric])
unfolding o_assoc[symmetric] ΣΣ_base.map_comp0[symmetric] convol_o id_o ..
qed
subsection{* The correspondence between coalgebras up to and coalgebras *}
definition cutΣΣ_baseOc :: "('a => 'a ΣΣ_base F) => ('a ΣΣ_base => 'a ΣΣ_base F)"
where "cutΣΣ_baseOc s ≡ F_map flat_base o dd_base o ΣΣ_base_map <leaf_base, s>"
definition cΣΣ_baseOcut :: "('a ΣΣ_base => 'a ΣΣ_base F) => ('a => 'a ΣΣ_base F)"
where "cΣΣ_baseOcut s' ≡ s' o leaf_base"
lemma cΣΣ_baseOcut_cutΣΣ_baseOc: "cΣΣ_baseOcut (cutΣΣ_baseOc s) = s"
unfolding cΣΣ_baseOcut_def cutΣΣ_baseOc_def
unfolding o_assoc[symmetric] unfolding leaf_base_natural
unfolding o_assoc apply(subst o_assoc[symmetric])
unfolding dd_base_leaf_base unfolding o_assoc F_map_comp[symmetric] flat_base_leaf_base
unfolding F_map_id id_o by simp
lemma cutΣΣ_baseOc_inj: "cutΣΣ_baseOc s1 = cutΣΣ_baseOc s2 <-> s1 = s2"
by (metis cΣΣ_baseOcut_cutΣΣ_baseOc)
lemma cΣΣ_baseOcut_surj: "∃ s'. cΣΣ_baseOcut s' = s"
using cΣΣ_baseOcut_cutΣΣ_baseOc by(rule exI[of _ "cutΣΣ_baseOc s"])
definition extdd_base :: "('a => J) => ('a ΣΣ_base => J)"
where "extdd_base f ≡ eval_base o ΣΣ_base_map f"
term eval_base
definition restr :: "('a ΣΣ_base => J) => ('a => J)"
where "restr f' ≡ f' o leaf_base"
lemma extdd_base_mor:
assumes f: "F_map (extdd_base f) o s = dtor_J o f"
shows "F_map (extdd_base f) o cutΣΣ_baseOc s = dtor_J o (extdd_base f)"
proof-
have AA: "eval_base ** F_map eval_base o (ΣΣ_base_map f ** F_map (ΣΣ_base_map f) o <leaf_base , s>) =
<f , F_map eval_base o (F_map (ΣΣ_base_map f) o s)>"
unfolding map_prod_o_convol unfolding leaf_base_natural o_assoc eval_base_leaf_base id_o ..
show ?thesis
unfolding extdd_base_def
unfolding o_assoc eval_base[symmetric]
unfolding o_assoc[symmetric] ΣΣ_base.map_comp0[symmetric]
unfolding convol_comp[symmetric] id_o
unfolding f[symmetric, unfolded extdd_base_def]
unfolding o_assoc
apply(subst o_assoc[symmetric])
unfolding F_map_comp o_assoc
unfolding cutΣΣ_baseOc_def
unfolding o_assoc
unfolding F_map_comp[symmetric] unfolding o_assoc[symmetric]
unfolding flat_base_natural[symmetric]
unfolding o_assoc F_map_comp
apply(subst o_assoc[symmetric], subst o_assoc[symmetric], subst o_assoc[symmetric])
unfolding dd_base_natural[symmetric]
unfolding o_assoc unfolding F_map_comp[symmetric] eval_base_flat_base
unfolding F_map_comp apply(subst o_assoc[symmetric])
unfolding dd_base_natural[symmetric] unfolding o_assoc[symmetric] ΣΣ_base.map_comp0[symmetric]
unfolding o_assoc[symmetric] AA[unfolded o_assoc[symmetric]] ..
qed
lemma mor_cutΣΣ_baseOc_flat_base:
assumes f': "F_map f' o cutΣΣ_baseOc s = dtor_J o f'"
shows "eval_base o ΣΣ_base_map f' = f' o flat_base"
proof(rule trans)
def h ≡ "dd_base o ΣΣ_base_map <id,cutΣΣ_baseOc s>"
have f'_id: "f' = f' o id" by simp
show "eval_base o ΣΣ_base_map f' = dtor_unfold_J h"
apply(rule J.dtor_unfold_unique, rule sym)
unfolding o_assoc eval_base[symmetric]
unfolding o_assoc[symmetric] ΣΣ_base.map_comp0[symmetric]
unfolding convol_comp_id1[symmetric] unfolding f'[symmetric]
apply(subst f'_id)
unfolding o_assoc ΣΣ_base.map_comp
apply(subst o_assoc[symmetric])
unfolding o_assoc[symmetric] F_map_comp
unfolding h_def apply(rule sym)
unfolding o_assoc apply(subst o_assoc[symmetric])
unfolding dd_base_natural[symmetric] unfolding o_assoc[symmetric]
unfolding ΣΣ_base.map_comp0[symmetric] map_prod_o_convol ..
have AA: "<id , cutΣΣ_baseOc s> = (flat_base ** F_map flat_base) o (id ** dd_base) o <leaf_base, ΣΣ_base_map <leaf_base , s>>"
unfolding map_prod_o_convol o_assoc map_prod.comp cutΣΣ_baseOc_def o_id flat_base_leaf_base ..
have BB: "flat_base ** F_map flat_base o id ** dd_base o <leaf_base , ΣΣ_base_map <leaf_base , s>> = flat_base ** F_map flat_base o id ** dd_base o <ΣΣ_base_map leaf_base , ΣΣ_base_map <leaf_base , s>>"
unfolding map_prod.comp unfolding map_prod_o_convol unfolding o_id unfolding flat_base_leaf_base leaf_base_flat_base ..
show "dtor_unfold_J h = f' o flat_base"
apply(rule J.dtor_unfold_unique[symmetric], rule sym)
unfolding o_assoc f'[symmetric]
unfolding F_map_comp o_assoc[symmetric]
apply(rule arg_cong[of _ _ "op o (F_map f')"])
unfolding h_def
unfolding AA BB
unfolding ΣΣ_base.map_comp0 apply(rule sym)
unfolding o_assoc apply(subst o_assoc[symmetric])
unfolding dd_base_natural
unfolding o_assoc F_map_comp[symmetric]
unfolding flat_base_assoc unfolding F_map_comp
unfolding cutΣΣ_baseOc_def o_assoc[symmetric] apply(rule arg_cong[of _ _ "op o (F_map flat_base)"])
unfolding o_assoc
unfolding o_assoc[symmetric] unfolding ΣΣ_base.map_comp0[symmetric] unfolding map_prod_o_convol id_o
unfolding flat_base_natural[symmetric] unfolding o_assoc
unfolding dd_base_flat_base[symmetric] unfolding o_assoc[symmetric] unfolding ΣΣ_base.map_comp0[symmetric]
unfolding convol_o unfolding ΣΣ_base.map_comp0[symmetric] unfolding fst_convol ..
qed
lemma restr_mor:
assumes f': "F_map f' o cutΣΣ_baseOc s = dtor_J o f'"
shows "F_map (extdd_base (restr f')) o s = dtor_J o restr f'"
unfolding extdd_base_def restr_def ΣΣ_base.map_comp0
unfolding o_assoc mor_cutΣΣ_baseOc_flat_base[OF f']
unfolding o_assoc[symmetric] leaf_base_flat_base o_id
unfolding o_assoc f'[symmetric]
unfolding o_assoc[symmetric] cΣΣ_baseOcut_cutΣΣ_baseOc[unfolded cΣΣ_baseOcut_def] ..
lemma extdd_base_restr:
assumes f': "F_map f' o cutΣΣ_baseOc s = dtor_J o f'"
shows "extdd_base (restr f') = f'"
proof-
have "f' = eval_base o ΣΣ_base_map f' o leaf_base"
unfolding o_assoc[symmetric] leaf_base_natural
unfolding o_assoc eval_base_leaf_base by simp
also have "... = eval_base o ΣΣ_base_map (f' o leaf_base)"
unfolding ΣΣ_base.map_comp0 o_assoc
unfolding mor_cutΣΣ_baseOc_flat_base[OF f'] unfolding o_assoc[symmetric] flat_base_leaf_base leaf_base_flat_base ..
finally have A: "f' = eval_base o ΣΣ_base_map (f' o leaf_base)" .
show ?thesis unfolding extdd_base_def restr_def A[symmetric] ..
qed
lemma restr_inj:
assumes f1': "F_map f1' o cutΣΣ_baseOc s = dtor_J o f1'"
and f2': "F_map f2' o cutΣΣ_baseOc s = dtor_J o f2'"
shows "restr f1' = restr f2' <-> f1' = f2'"
using extdd_base_restr[OF f1'] extdd_base_restr[OF f2'] by metis
lemma extdd_base_surj:
assumes f': "F_map f' o cutΣΣ_baseOc s = dtor_J o f'"
shows "∃ f. extdd_base f = f'"
using extdd_base_restr[OF f'] by(rule exI[of _ "restr f'"])
lemma restr_extdd_base:
assumes f: "F_map (extdd_base f) o s = dtor_J o f"
shows "restr (extdd_base f) = f"
proof-
have "dtor_J o f = F_map (extdd_base f) o s" using assms unfolding extdd_base_def by (rule sym)
also have "... = dtor_J o restr (extdd_base f)"
unfolding restr_def unfolding o_assoc extdd_base_mor[OF f, symmetric]
unfolding o_assoc[symmetric] cΣΣ_baseOcut_cutΣΣ_baseOc[unfolded cΣΣ_baseOcut_def] ..
finally have "dtor_J o f = dtor_J o restr (extdd_base f)" .
thus ?thesis unfolding dtor_J_o_inj by (rule sym)
qed
lemma extdd_base_inj:
assumes f1: "F_map (extdd_base f1) o s = dtor_J o f1"
and f2: "F_map (extdd_base f2) o s = dtor_J o f2"
shows "extdd_base f1 = extdd_base f2 <-> f1 = f2"
using restr_extdd_base[OF f1] restr_extdd_base[OF f2] by metis
lemma restr_surj:
assumes f: "F_map (extdd_base f) o s = dtor_J o f"
shows "∃ f'. restr f' = f"
using restr_extdd_base[OF f] by(rule exI[of _ "extdd_base f"])
subsection{* Coiteration up-to *}
definition "unfoldU_base s ≡ restr (dtor_unfold_J (cutΣΣ_baseOc s))"
theorem unfoldU_base_pointfree:
"F_map (extdd_base (unfoldU_base s)) o s = dtor_J o unfoldU_base s"
unfolding unfoldU_base_def apply(rule restr_mor)
unfolding dtor_unfold_J_pointfree ..
theorem unfoldU_base: "F_map (extdd_base (unfoldU_base s)) (s a) = dtor_J (unfoldU_base s a)"
using unfoldU_base_pointfree unfolding o_def fun_eq_iff by(rule allE)
theorem unfoldU_base_ctor_J:
"ctor_J (F_map (extdd_base (unfoldU_base s)) (s a)) = unfoldU_base s a"
using unfoldU_base by (metis J.ctor_dtor)
theorem unfoldU_base_unique:
assumes "F_map (extdd_base f) o s = dtor_J o f"
shows "f = unfoldU_base s"
proof-
note f = extdd_base_mor[OF assms] note co = extdd_base_mor[OF unfoldU_base_pointfree]
have A: "extdd_base f = extdd_base (unfoldU_base s)"
proof(rule trans)
show "extdd_base f = dtor_unfold_J (cutΣΣ_baseOc s)" apply(rule J.dtor_unfold_unique) using f .
show "dtor_unfold_J (cutΣΣ_baseOc s) = extdd_base (unfoldU_base s)"
apply(rule J.dtor_unfold_unique[symmetric]) using co .
qed
show ?thesis using A unfolding extdd_base_inj[OF assms unfoldU_base_pointfree] .
qed
lemma unfoldU_base_ctor_J_pointfree:
"ctor_J o F_map (extdd_base (unfoldU_base s)) o s = unfoldU_base s"
unfolding o_def fun_eq_iff by (subst unfoldU_base_ctor_J[symmetric]) (rule allI, rule refl)
definition corecU_base :: "('a => (J + 'a) ΣΣ_base F) => 'a => J" where
"corecU_base s = unfoldU_base (case_sum (dd_base o leaf_base o <Inl, F_map Inl o dtor_J>) s) o Inr"
definition extddRec_base where
"extddRec_base f ≡ eval_base o ΣΣ_base_map (case_sum id f)"
lemma unfoldU_base_Inl:
"unfoldU_base (case_sum (dd_base o leaf_base o <Inl , F_map Inl o dtor_J>) s) o Inl = id"
(is "?L = ?R")
proof-
have "?L = unfoldU_base (dd_base o leaf_base o <id, dtor_J>)"
apply(rule unfoldU_base_unique)
unfolding o_assoc unfoldU_base_pointfree[symmetric]
unfolding o_assoc[symmetric] case_sum_o_inj extdd_base_def F_map_comp ΣΣ_base.map_comp0
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_base_natural[symmetric]
apply(subst o_assoc[symmetric]) unfolding leaf_base_natural
unfolding o_assoc[symmetric] map_prod_o_convol o_id ..
also have "... = ?R"
apply(rule sym, rule unfoldU_base_unique)
unfolding extdd_base_def ΣΣ_base.map_id0 o_id dd_base_leaf_base
unfolding o_assoc[symmetric] snd_convol
unfolding o_assoc F_map_comp[symmetric] eval_base_leaf_base F_map_id id_o ..
finally show ?thesis .
qed
theorem corecU_base_pointfree:
"F_map (extddRec_base (corecU_base s)) o s = dtor_J o corecU_base s" (is "?L = ?R")
unfolding corecU_base_def
unfolding o_assoc unfoldU_base_pointfree[symmetric] extddRec_base_def
unfolding o_assoc[symmetric] case_sum_o_inj
apply(subst unfoldU_base_Inl[symmetric, of s])
unfolding o_assoc case_sum_Inl_Inr_L extdd_base_def ..
theorem corecU_base:
"F_map (extddRec_base (corecU_base s)) (s a) = dtor_J (corecU_base s a)"
using corecU_base_pointfree unfolding o_def fun_eq_iff by(rule allE)
subsection{* Coinduction up-to *}
definition "cptdd_base R ≡ (ΣΣ_base_rel R ===> R) eval_base eval_base"
definition "cngdd_base R ≡ equivp R ∧ cptdd_base R"
lemma cngdd_base_Retr: "cngdd_base R ==> cngdd_base (R \<sqinter> Retr R)"
unfolding cngdd_base_def cptdd_base_def
apply (erule conjE)
apply (rule conjI[OF equivp_inf[OF _ equivp_retr]])
apply assumption
apply assumption
apply (rule rel_funI)
apply (frule predicate2D[OF ΣΣ_base_rel_inf])
apply (erule inf2E)
apply (rule inf2I)
apply (erule rel_funE)
apply assumption
apply assumption
apply (subst Retr_def)
apply (subst eval_base_def)+
apply (subst J.dtor_unfold)+
unfolding F_rel_F_map_F_map Grp_def relcompp.simps[abs_def] conversep.simps[abs_def]
apply auto
unfolding eval_base_def[symmetric]
apply (rule predicate2D[OF F_rel_mono])
apply (rule predicate2I)
apply (erule rel_funD)
apply assumption
apply (rule F_rel_ΣΣ_base_rel)
unfolding ΣΣ_base_rel_ΣΣ_base_map_ΣΣ_base_map vimage2p_rel_prod vimage2p_id
unfolding vimage2p_def Retr_def[symmetric]
apply assumption
done
definition "genCngdd_base R j1 j2 ≡ ∀ R'. R ≤ R' ∧ cngdd_base R' --> R' j1 j2"
lemma cngdd_base_genCngdd_base: "cngdd_base (genCngdd_base R)"
unfolding cngdd_base_def proof safe
show "cptdd_base (genCngdd_base R)"
unfolding cptdd_base_def rel_fun_def proof safe
fix x y assume 1: "ΣΣ_base_rel (genCngdd_base R) x y"
show "genCngdd_base R (eval_base x) (eval_base y)"
unfolding genCngdd_base_def[abs_def] proof safe
fix R' assume "R ≤ R'" and 2: "cngdd_base R'"
hence "ΣΣ_base_rel R' x y" by (metis 1 ΣΣ_base.rel_mono_strong genCngdd_base_def)
thus "R' (eval_base x) (eval_base y)" using 2 unfolding cngdd_base_def cptdd_base_def rel_fun_def by auto
qed
qed
qed(rule equivpI, unfold reflp_def symp_def transp_def genCngdd_base_def cngdd_base_def equivp_def, auto)
lemma
genCngdd_base_refl[intro,simp]: "genCngdd_base R j j"
and genCngdd_base_sym[intro]: "genCngdd_base R j1 j2 ==> genCngdd_base R j2 j1"
and genCngdd_base_trans[intro]: "[|genCngdd_base R j1 j2; genCngdd_base R j2 j3|] ==> genCngdd_base R j1 j3"
using cngdd_base_genCngdd_base unfolding cngdd_base_def equivp_def by auto
lemma genCngdd_base_eval_base_rel_fun: "(ΣΣ_base_rel (genCngdd_base R) ===> genCngdd_base R) eval_base eval_base"
using cngdd_base_genCngdd_base unfolding cngdd_base_def cptdd_base_def by auto
lemma genCngdd_base_eval_base: "ΣΣ_base_rel (genCngdd_base R) x y ==> genCngdd_base R (eval_base x) (eval_base y)"
using genCngdd_base_eval_base_rel_fun unfolding rel_fun_def by auto
lemma leq_genCngdd_base: "R ≤ genCngdd_base R"
and imp_genCngdd_base[intro]: "R j1 j2 ==> genCngdd_base R j1 j2"
unfolding genCngdd_base_def[abs_def] by auto
lemma genCngdd_base_minimal: "[|R ≤ R'; cngdd_base R'|] ==> genCngdd_base R ≤ R'"
unfolding genCngdd_base_def[abs_def] by (metis (lifting, no_types) predicate2I)
theorem coinductionU_genCngdd_base:
assumes "∀ a b. R a b --> F_rel (genCngdd_base R) (dtor_J a) (dtor_J b)"
shows "R a b --> a = b"
proof-
let ?R' = "genCngdd_base R"
have "R ≤ Retr ?R'" using assms unfolding Retr_def[abs_def] by auto
hence "R ≤ ?R' \<sqinter> Retr ?R'" using leq_genCngdd_base by auto
moreover have "cngdd_base (?R' \<sqinter> Retr ?R')" using cngdd_base_Retr[OF cngdd_base_genCngdd_base[of R]] .
ultimately have "?R' ≤ ?R' \<sqinter> Retr ?R'" using genCngdd_base_minimal by metis
hence "?R' ≤ Retr ?R'" by auto
hence "?R' a b --> a = b" unfolding Retr_def[abs_def] by (intro J.dtor_coinduct) auto
thus ?thesis using leq_genCngdd_base by auto
qed
definition algΛ_base :: "J Σ_base => J" where
"algΛ_base = eval_base o \<oo>\<pp>_base o Σ_base_map leaf_base"
theorem eval_base_comp_\<oo>\<pp>_base: "eval_base o \<oo>\<pp>_base = algΛ_base o Σ_base_map eval_base"
unfolding algΛ_base_def
unfolding o_assoc[symmetric] Σ_base.map_comp0[symmetric]
unfolding leaf_base_natural[symmetric] unfolding Σ_base.map_comp0
apply(rule sym) unfolding o_assoc apply(subst o_assoc[symmetric])
unfolding \<oo>\<pp>_base_natural
unfolding o_assoc eval_base_flat_base[symmetric]
apply(subst o_assoc[symmetric]) unfolding flat_base_commute[symmetric]
unfolding o_assoc[symmetric] Σ_base.map_comp0[symmetric] flat_base_leaf_base Σ_base.map_id0 o_id ..
theorem eval_base_\<oo>\<pp>_base: "eval_base (\<oo>\<pp>_base t) = algΛ_base (Σ_base_map eval_base t)"
using eval_base_comp_\<oo>\<pp>_base unfolding o_def fun_eq_iff by (rule allE)
theorem eval_base_leaf_base': "eval_base (leaf_base j) = j"
using eval_base_leaf_base unfolding o_def fun_eq_iff id_def by (rule allE)
theorem dtor_J_algΛ_base: "dtor_J o algΛ_base = F_map eval_base o Λ_base o Σ_base_map <id, dtor_J>"
unfolding algΛ_base_def eval_base_def o_assoc dtor_unfold_J_pointfree Λ_base_dd_base
unfolding o_assoc[symmetric] \<oo>\<pp>_base_natural[symmetric] Σ_base.map_comp0[symmetric] leaf_base_natural
..
theorem dtor_J_algΛ_base': "dtor_J (algΛ_base t) = F_map eval_base (Λ_base (Σ_base_map (<id, dtor_J>) t))"
by (rule trans[OF o_eq_dest[OF dtor_J_algΛ_base] o_apply])
theorem ctor_J_algΛ_base: "algΛ_base t = ctor_J (F_map eval_base (Λ_base (Σ_base_map (<id, dtor_J>) t)))"
by (rule iffD1[OF J.dtor_inject trans[OF dtor_J_algΛ_base' J.dtor_ctor[symmetric]]])
definition "cptΛ_base R ≡ (Σ_base_rel R ===> R) algΛ_base algΛ_base"
definition "cngΛ_base R ≡ equivp R ∧ cptΛ_base R"
lemma cptdd_base_iff_cptΛ_base: "cptdd_base R <-> cptΛ_base R"
apply (rule iffI)
apply (unfold cptΛ_base_def cptdd_base_def algΛ_base_def o_assoc[symmetric]) [1]
apply (erule rel_funD[OF rel_funD[OF comp_transfer]])
apply transfer_prover
apply (unfold cptΛ_base_def cptdd_base_def) [1]
unfolding rel_fun_def
apply (rule allI)+
apply (rule ΣΣ_base_rel_induct)
apply (simp only: eval_base_leaf_base')
unfolding eval_base_\<oo>\<pp>_base
apply (drule spec2)
apply (erule mp)
apply (rule iffD2[OF Σ_base_rel_Σ_base_map_Σ_base_map])
apply (subst vimage2p_def)
apply assumption
done
theorem genCngdd_base_def2: "genCngdd_base R j1 j2 <-> (∀ R'. R ≤ R' ∧ cngΛ_base R' --> R' j1 j2)"
unfolding genCngdd_base_def cngdd_base_def cngΛ_base_def cptdd_base_iff_cptΛ_base ..
subsection {* Incremental coinduction *}
interpretation I_base: Incremental where Retr = Retr and Cl = genCngdd_base
proof
show "mono Retr" by (rule mono_retr)
next
show "mono genCngdd_base" unfolding mono_def
unfolding genCngdd_base_def[abs_def] by (smt order.trans predicate2I)
next
fix r show "genCngdd_base (genCngdd_base r) = genCngdd_base r"
by (metis cngdd_base_genCngdd_base genCngdd_base_minimal leq_genCngdd_base order_class.order.antisym)
next
fix r show "r ≤ genCngdd_base r" by (metis leq_genCngdd_base)
next
fix r assume "genCngdd_base r = r" thus "genCngdd_base (r \<sqinter> Retr r) = r \<sqinter> Retr r"
by (metis antisym cngdd_base_Retr cngdd_base_genCngdd_base genCngdd_base_minimal
inf.orderI inf_idem leq_genCngdd_base)
qed
definition ded_base where "ded_base r s ≡ I_base.ded r s"
theorems Ax = I_base.Ax'[unfolded ded_base_def[symmetric]]
theorems Split = I_base.Split[unfolded ded_base_def[symmetric]]
theorems Coind = I_base.Coind[unfolded ded_base_def[symmetric]]
theorem soundness_ded:
assumes "ded_base (op =) s" shows "s ≤ (op =)"
unfolding gfp_Retr_eq[symmetric] apply(rule I_base.soundness_ded[unfolded ded_base_def[symmetric]] )
using assms unfolding gfp_Retr_eq[symmetric] ded_base_def .
unused_thms
end