header {* Motivating Examples *}
theory Tree_Examples
imports Tree_Lib
begin
section {* Sum *}
definition pls :: "tree => tree => tree" where
"pls xs ys = dtor_corec_J (λ(xs, ys). (val xs + val ys, map Inr (zip (sub xs) (sub ys)))) (xs, ys)"
lemma val_pls[simp]: "val (pls t u) = val t + val u"
unfolding pls_def J.dtor_corec map_pre_J_def BNF_Comp.id_bnf_comp_def by simp
lemma sub_pls[simp]: "sub (pls t u) = map (split pls) (zip (sub t) (sub u))"
unfolding pls_def[abs_def] J.dtor_corec map_pre_J_def BNF_Comp.id_bnf_comp_def by simp
lemma pls_code[code]: "pls t u = Node (val t + val u) (map (split pls) (zip (sub t) (sub u)))"
by (metis J.ctor_dtor prod.collapse val_pls sub_pls)
lemma pls_uniform: "pls t u = algρ1 (t, u)"
unfolding pls_def
apply (rule fun_cong[OF sym[OF J.dtor_corec_unique]])
unfolding algρ1
by (simp add: map_pre_J_def BNF_Comp.id_bnf_comp_def fun_eq_iff convol_def ρ1_def algρ1_def)
section {* Shuffle product *}
definition prd :: "tree => tree => tree" where
"prd t u = corecUU1 (λ(t, u). GUARD1 (val t * val u,
map (λ(t', u'). PLS1 (CONT1 (t, u'), CONT1 (t', u))) (zip (sub t) (sub u)))) (t, u)"
lemma val_prd[simp]: "val (prd t u) = val t * val u"
unfolding prd_def corecUU1
by (simp add: map_pre_J_def BNF_Comp.id_bnf_comp_def J.dtor_ctor eval1_leaf1')
lemma sub_prd[simp]:
"sub (prd t u) = map (λ(t', u'). pls (prd t u') (prd t' u)) (zip (sub t) (sub u))"
apply (subst prd_def)
unfolding corecUU1 prod.case
by (simp add: map_pre_J_def BNF_Comp.id_bnf_comp_def J.dtor_ctor eval1_leaf1'
eval1_\<oo>\<pp>1 algΛ1_Inr o_eq_dest[OF Abs_Σ1_natural] pls_uniform prd_def split_beta)
lemma prd_code[code]: "prd t u =
Node (val t * val u) (map (λ(t', u'). pls (prd t u') (prd t' u)) (zip (sub t) (sub u)))"
by (metis J.ctor_dtor prod.collapse val_prd sub_prd)
lemma prd_uniform: "prd t u = algρ2 (t, u)"
unfolding prd_def
apply (rule fun_cong[OF sym[OF corecUU1_unique]])
apply (rule iffD1[OF dtor_J_o_inj])
unfolding algρ2
apply (simp add: map_pre_J_def BNF_Comp.id_bnf_comp_def fun_eq_iff J.dtor_ctor
ρ2_def Let_def convol_def eval2_\<oo>\<pp>2 eval1_\<oo>\<pp>1 eval1_leaf1'
o_eq_dest[OF Abs_Σ1_natural] o_eq_dest[OF Abs_Σ2_natural] algΛ2_Inl algρ2_def split_beta)
done
section {* Coinduction Up-To Congruence *}
lemma Node_uniform: "Node x ts = eval0 (gg0 (x, map leaf0 ts))"
by (rule iffD1[OF J.dtor_inject])
(simp add: map_pre_J_def BNF_Comp.id_bnf_comp_def J.dtor_ctor o_eq_dest[OF eval0_gg0] eval0_leaf0)
lemma genCngdd0_Node: "[|x1 = x2; list_all2 (genCngdd0 R) ts1 ts2|] ==>
genCngdd0 R (Node x1 ts1) (Node x2 ts2)"
unfolding Node_uniform
apply (rule genCngdd0_eval0)
apply (rule rel_funD[OF gg0_transfer])
unfolding rel_pre_J_def BNF_Comp.id_bnf_comp_def vimage2p_def
apply (rule rel_funD[OF rel_funD[OF Pair_transfer], rotated])
apply (erule rel_funD[OF rel_funD[OF map_transfer], rotated])
apply (rule leaf0_transfer)
apply assumption
done
lemma genCngdd0_genCngdd1: "genCngdd0 R xs ys ==> genCngdd1 R xs ys"
unfolding genCngdd0_def cngdd0_def cptdd0_def genCngdd1_def cngdd1_def cptdd1_def eval1_embL1[symmetric]
apply (intro allI impI)
apply (erule conjE)+
apply (drule spec)
apply (erule mp conjI)+
apply (erule rel_funD[OF rel_funD[OF comp_transfer]])
apply (rule embL1_transfer)
done
lemma genCngdd1_Node: "[|x1 = x2; list_all2 (genCngdd1 R) ts1 ts2|] ==>
genCngdd1 R (Node x1 ts1) (Node x2 ts2)"
apply (subst I1.idem_Cl[symmetric])
apply (rule genCngdd0_genCngdd1)
apply (rule genCngdd0_Node)
apply (auto intro: predicate2D[OF list.rel_mono])
done
lemma genCngdd1_pls: "[|genCngdd1 R xs1 xs2; genCngdd1 R ys1 ys2|] ==>
genCngdd1 R (pls xs1 ys1) (pls xs2 ys2)"
unfolding pls_uniform algρ1_def o_apply
apply (rule genCngdd1_eval1)
apply (rule rel_funD[OF K1_as_ΣΣ1_transfer])
apply simp
done
lemma genCngdd1_genCngdd2: "genCngdd1 R xs ys ==> genCngdd2 R xs ys"
unfolding genCngdd1_def cngdd1_def cptdd1_def genCngdd2_def cngdd2_def cptdd2_def eval2_embL2[symmetric]
apply (intro allI impI)
apply (erule conjE)+
apply (drule spec)
apply (erule mp conjI)+
apply (erule rel_funD[OF rel_funD[OF comp_transfer]])
apply (rule embL2_transfer)
done
lemma genCngdd2_Node: "[|x1 = x2; list_all2 (genCngdd2 R) ts1 ts2|] ==>
genCngdd2 R (Node x1 ts1) (Node x2 ts2)"
apply (subst I2.idem_Cl[symmetric])
apply (rule genCngdd1_genCngdd2)
apply (rule genCngdd1_Node)
apply (auto intro: predicate2D[OF list.rel_mono])
done
lemma genCngdd2_pls: "[|genCngdd2 R xs1 xs2; genCngdd2 R ys1 ys2|] ==>
genCngdd2 R (pls xs1 ys1) (pls xs2 ys2)"
apply (subst I2.idem_Cl[symmetric])
apply (rule genCngdd1_genCngdd2)
apply (rule genCngdd1_pls)
apply auto
done
lemma genCngdd2_prd: "[|genCngdd2 R xs1 xs2; genCngdd2 R ys1 ys2|] ==>
genCngdd2 R (prd xs1 ys1) (prd xs2 ys2)"
unfolding prd_uniform algρ2_def o_apply
apply (rule genCngdd2_eval2)
apply (rule rel_funD[OF K2_as_ΣΣ2_transfer])
apply simp
done
lemma tree_coinduct[case_names Eq_tree, case_conclusion Eq_tree val sub]:
assumes "R s s'" "!!s s'. R s s' ==> val s = val s' ∧ list_all2 R (sub s) (sub s')"
shows "s = s'"
using assms(1) proof (rule mp[OF J.dtor_coinduct, rotated], safe)
fix a b
assume "R a b"
from assms(2)[OF this] show "F_rel R (dtor_J a) (dtor_J b)"
by (cases "dtor_J a" "dtor_J b" rule: prod.exhaust[case_product prod.exhaust])
(auto simp: rel_pre_J_def vimage2p_def BNF_Comp.id_bnf_comp_def)
qed
lemma tree_coinduct0[case_names Eq_tree, case_conclusion Eq_tree val sub]:
assumes "R s s'" "!!s s'. R s s' ==> val s = val s' ∧ list_all2 (genCngdd0 R) (sub s) (sub s')"
shows "s = s'"
using assms(1) proof (rule mp[OF coinductionU_genCngdd0, rotated], safe)
fix a b
assume "R a b"
from assms(2)[OF this] show "F_rel (genCngdd0 R) (dtor_J a) (dtor_J b)"
by (cases "dtor_J a" "dtor_J b" rule: prod.exhaust[case_product prod.exhaust])
(auto simp: rel_pre_J_def vimage2p_def BNF_Comp.id_bnf_comp_def)
qed
lemma tree_coinduct1[case_names Eq_tree, case_conclusion Eq_tree val sub]:
assumes "R s s'" "!!s s'. R s s' ==> val s = val s' ∧ list_all2 (genCngdd1 R) (sub s) (sub s')"
shows "s = s'"
using assms(1) proof (rule mp[OF coinductionU_genCngdd1, rotated], safe)
fix a b
assume "R a b"
from assms(2)[OF this] show "F_rel (genCngdd1 R) (dtor_J a) (dtor_J b)"
by (cases "dtor_J a" "dtor_J b" rule: prod.exhaust[case_product prod.exhaust])
(auto simp: rel_pre_J_def vimage2p_def BNF_Comp.id_bnf_comp_def)
qed
lemma tree_coinduct2[case_names Eq_tree, case_conclusion Eq_tree val sub]:
assumes "R s s'" "!!s s'. R s s' ==> val s = val s' ∧ list_all2 (genCngdd2 R) (sub s) (sub s')"
shows "s = s'"
using assms(1) proof (rule mp[OF coinductionU_genCngdd2, rotated], safe)
fix a b
assume "R a b"
from assms(2)[OF this] show "F_rel (genCngdd2 R) (dtor_J a) (dtor_J b)"
by (cases "dtor_J a" "dtor_J b" rule: prod.exhaust[case_product prod.exhaust])
(auto simp: rel_pre_J_def vimage2p_def BNF_Comp.id_bnf_comp_def)
qed
section {* Proofs by Coinduction Up-To Congruence *}
lemma pls_assoc: "pls (pls t u) zs = pls t (pls u zs)"
by (coinduction arbitrary: t u zs rule: tree_coinduct) (force simp: list_all2_iff in_set_zip)
lemma pls_commute: "pls t u = pls u t"
by (coinduction arbitrary: t u rule: tree_coinduct) (force simp: list_all2_iff in_set_zip)
lemma pls_commute_assoc: "pls t (pls u zs) = pls u (pls t zs)"
by (metis pls_assoc pls_commute)
lemmas pls_ac_simps = pls_assoc pls_commute pls_commute_assoc
lemma prd_commute: "prd t u = prd u t"
proof (coinduction arbitrary: t u rule: tree_coinduct1)
case Eq_tree
have ?sub unfolding sub_prd
by (subst pls_commute) (fastforce simp: list_all2_iff in_set_zip intro!: genCngdd1_pls)
then show ?case by simp
qed
lemma prd_distribL: "prd xs (pls ys zs) = pls (prd xs ys) (prd xs zs)"
proof (coinduction arbitrary: xs ys zs rule: tree_coinduct1)
case Eq_tree
have "!!a b c d. pls (pls a b) (pls c d) = pls (pls a c) (pls b d)" by (metis pls_assoc pls_commute)
then have ?sub by (fastforce simp: list_all2_iff in_set_zip intro!: genCngdd1_pls)
then show ?case by (simp add: algebra_simps)
qed
lemma prd_distribR: "prd (pls xs ys) zs = pls (prd xs zs) (prd ys zs)"
proof (coinduction arbitrary: xs ys zs rule: tree_coinduct1)
case Eq_tree
have "!!a b c d. pls (pls a b) (pls c d) = pls (pls a c) (pls b d)" by (metis pls_assoc pls_commute)
then have ?sub by (fastforce simp: list_all2_iff in_set_zip intro!: genCngdd1_pls)
then show ?case by (simp add: algebra_simps)
qed
lemma prd_assoc: "prd (prd xs ys) zs = prd xs (prd ys zs)"
proof (coinduction arbitrary: xs ys zs rule: tree_coinduct1)
case Eq_tree
have ?sub unfolding sub_prd zip_map1 zip_map2 list.map_comp
by (fastforce simp: list_all2_iff in_set_zip pls_ac_simps prd_distribL prd_distribR
intro!: genCngdd1_pls)
then show ?case by simp
qed
lemma prd_commute_assoc: "prd xs (prd ys zs) = prd ys (prd xs zs)"
by (metis prd_assoc prd_commute)
lemmas prd_ac_simps = prd_assoc prd_commute prd_commute_assoc
end