--- a/src/HOL/BNF/Examples/Derivation_Trees/DTree.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,92 +0,0 @@
-(* Title: HOL/BNF/Examples/Derivation_Trees/DTree.thy
- Author: Andrei Popescu, TU Muenchen
- Copyright 2012
-
-Derivation trees with nonterminal internal nodes and terminal leaves.
-*)
-
-header {* Trees with Nonterminal Internal Nodes and Terminal Leaves *}
-
-theory DTree
-imports Prelim
-begin
-
-typedecl N
-typedecl T
-
-codatatype dtree = NNode (root: N) (ccont: "(T + dtree) fset")
-
-subsection{* Transporting the Characteristic Lemmas from @{text "fset"} to @{text "set"} *}
-
-definition "Node n as \<equiv> NNode n (the_inv fset as)"
-definition "cont \<equiv> fset o ccont"
-definition "unfold rt ct \<equiv> unfold_dtree rt (the_inv fset o ct)"
-definition "corec rt ct \<equiv> corec_dtree rt (the_inv fset o ct)"
-
-lemma finite_cont[simp]: "finite (cont tr)"
- unfolding cont_def comp_apply by (cases tr, clarsimp)
-
-lemma Node_root_cont[simp]:
- "Node (root tr) (cont tr) = tr"
- unfolding Node_def cont_def comp_apply
- apply (rule trans[OF _ dtree.collapse])
- apply (rule arg_cong2[OF refl the_inv_into_f_f[unfolded inj_on_def]])
- apply (simp_all add: fset_inject)
- done
-
-lemma dtree_simps[simp]:
-assumes "finite as" and "finite as'"
-shows "Node n as = Node n' as' \<longleftrightarrow> n = n' \<and> as = as'"
-using assms dtree.inject unfolding Node_def
-by (metis fset_to_fset)
-
-lemma dtree_cases[elim, case_names Node Choice]:
-assumes Node: "\<And> n as. \<lbrakk>finite as; tr = Node n as\<rbrakk> \<Longrightarrow> phi"
-shows phi
-apply(cases rule: dtree.exhaust[of tr])
-using Node unfolding Node_def
-by (metis Node Node_root_cont finite_cont)
-
-lemma dtree_sel_ctor[simp]:
-"root (Node n as) = n"
-"finite as \<Longrightarrow> cont (Node n as) = as"
-unfolding Node_def cont_def by auto
-
-lemmas root_Node = dtree_sel_ctor(1)
-lemmas cont_Node = dtree_sel_ctor(2)
-
-lemma dtree_cong:
-assumes "root tr = root tr'" and "cont tr = cont tr'"
-shows "tr = tr'"
-by (metis Node_root_cont assms)
-
-lemma set_rel_cont:
-"set_rel \<chi> (cont tr1) (cont tr2) = fset_rel \<chi> (ccont tr1) (ccont tr2)"
-unfolding cont_def comp_def fset_rel_fset ..
-
-lemma dtree_coinduct[elim, consumes 1, case_names Lift, induct pred: "HOL.eq"]:
-assumes phi: "\<phi> tr1 tr2" and
-Lift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow>
- root tr1 = root tr2 \<and> set_rel (sum_rel op = \<phi>) (cont tr1) (cont tr2)"
-shows "tr1 = tr2"
-using phi apply(elim dtree.coinduct)
-apply(rule Lift[unfolded set_rel_cont]) .
-
-lemma unfold:
-"root (unfold rt ct b) = rt b"
-"finite (ct b) \<Longrightarrow> cont (unfold rt ct b) = image (id \<oplus> unfold rt ct) (ct b)"
-using dtree.sel_unfold[of rt "the_inv fset \<circ> ct" b] unfolding unfold_def
-apply - apply metis
-unfolding cont_def comp_def
-by simp
-
-lemma corec:
-"root (corec rt ct b) = rt b"
-"finite (ct b) \<Longrightarrow> cont (corec rt ct b) = image (id \<oplus> ([[id, corec rt ct]])) (ct b)"
-using dtree.sel_corec[of rt "the_inv fset \<circ> ct" b] unfolding corec_def
-apply -
-apply simp
-unfolding cont_def comp_def id_def
-by simp
-
-end
--- a/src/HOL/BNF/Examples/Derivation_Trees/Gram_Lang.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,1359 +0,0 @@
-(* Title: HOL/BNF/Examples/Derivation_Trees/Gram_Lang.thy
- Author: Andrei Popescu, TU Muenchen
- Copyright 2012
-
-Language of a grammar.
-*)
-
-header {* Language of a Grammar *}
-
-theory Gram_Lang
-imports DTree
-begin
-
-
-(* We assume that the sets of terminals, and the left-hand sides of
-productions are finite and that the grammar has no unused nonterminals. *)
-consts P :: "(N \<times> (T + N) set) set"
-axiomatization where
- finite_N: "finite (UNIV::N set)"
-and finite_in_P: "\<And> n tns. (n,tns) \<in> P \<longrightarrow> finite tns"
-and used: "\<And> n. \<exists> tns. (n,tns) \<in> P"
-
-
-subsection{* Tree Basics: frontier, interior, etc. *}
-
-
-(* Frontier *)
-
-inductive inFr :: "N set \<Rightarrow> dtree \<Rightarrow> T \<Rightarrow> bool" where
-Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr ns tr t"
-|
-Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inFr ns tr1 t\<rbrakk> \<Longrightarrow> inFr ns tr t"
-
-definition "Fr ns tr \<equiv> {t. inFr ns tr t}"
-
-lemma inFr_root_in: "inFr ns tr t \<Longrightarrow> root tr \<in> ns"
-by (metis inFr.simps)
-
-lemma inFr_mono:
-assumes "inFr ns tr t" and "ns \<subseteq> ns'"
-shows "inFr ns' tr t"
-using assms apply(induct arbitrary: ns' rule: inFr.induct)
-using Base Ind by (metis inFr.simps set_mp)+
-
-lemma inFr_Ind_minus:
-assumes "inFr ns1 tr1 t" and "Inr tr1 \<in> cont tr"
-shows "inFr (insert (root tr) ns1) tr t"
-using assms apply(induct rule: inFr.induct)
- apply (metis inFr.simps insert_iff)
- by (metis inFr.simps inFr_mono insertI1 subset_insertI)
-
-(* alternative definition *)
-inductive inFr2 :: "N set \<Rightarrow> dtree \<Rightarrow> T \<Rightarrow> bool" where
-Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr2 ns tr t"
-|
-Ind: "\<lbrakk>Inr tr1 \<in> cont tr; inFr2 ns1 tr1 t\<rbrakk>
- \<Longrightarrow> inFr2 (insert (root tr) ns1) tr t"
-
-lemma inFr2_root_in: "inFr2 ns tr t \<Longrightarrow> root tr \<in> ns"
-apply(induct rule: inFr2.induct) by auto
-
-lemma inFr2_mono:
-assumes "inFr2 ns tr t" and "ns \<subseteq> ns'"
-shows "inFr2 ns' tr t"
-using assms apply(induct arbitrary: ns' rule: inFr2.induct)
-using Base Ind
-apply (metis subsetD) by (metis inFr2.simps insert_absorb insert_subset)
-
-lemma inFr2_Ind:
-assumes "inFr2 ns tr1 t" and "root tr \<in> ns" and "Inr tr1 \<in> cont tr"
-shows "inFr2 ns tr t"
-using assms apply(induct rule: inFr2.induct)
- apply (metis inFr2.simps insert_absorb)
- by (metis inFr2.simps insert_absorb)
-
-lemma inFr_inFr2:
-"inFr = inFr2"
-apply (rule ext)+ apply(safe)
- apply(erule inFr.induct)
- apply (metis (lifting) inFr2.Base)
- apply (metis (lifting) inFr2_Ind)
- apply(erule inFr2.induct)
- apply (metis (lifting) inFr.Base)
- apply (metis (lifting) inFr_Ind_minus)
-done
-
-lemma not_root_inFr:
-assumes "root tr \<notin> ns"
-shows "\<not> inFr ns tr t"
-by (metis assms inFr_root_in)
-
-lemma not_root_Fr:
-assumes "root tr \<notin> ns"
-shows "Fr ns tr = {}"
-using not_root_inFr[OF assms] unfolding Fr_def by auto
-
-
-(* Interior *)
-
-inductive inItr :: "N set \<Rightarrow> dtree \<Rightarrow> N \<Rightarrow> bool" where
-Base: "root tr \<in> ns \<Longrightarrow> inItr ns tr (root tr)"
-|
-Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inItr ns tr1 n\<rbrakk> \<Longrightarrow> inItr ns tr n"
-
-definition "Itr ns tr \<equiv> {n. inItr ns tr n}"
-
-lemma inItr_root_in: "inItr ns tr n \<Longrightarrow> root tr \<in> ns"
-by (metis inItr.simps)
-
-lemma inItr_mono:
-assumes "inItr ns tr n" and "ns \<subseteq> ns'"
-shows "inItr ns' tr n"
-using assms apply(induct arbitrary: ns' rule: inItr.induct)
-using Base Ind by (metis inItr.simps set_mp)+
-
-
-(* The subtree relation *)
-
-inductive subtr where
-Refl: "root tr \<in> ns \<Longrightarrow> subtr ns tr tr"
-|
-Step: "\<lbrakk>root tr3 \<in> ns; subtr ns tr1 tr2; Inr tr2 \<in> cont tr3\<rbrakk> \<Longrightarrow> subtr ns tr1 tr3"
-
-lemma subtr_rootL_in:
-assumes "subtr ns tr1 tr2"
-shows "root tr1 \<in> ns"
-using assms apply(induct rule: subtr.induct) by auto
-
-lemma subtr_rootR_in:
-assumes "subtr ns tr1 tr2"
-shows "root tr2 \<in> ns"
-using assms apply(induct rule: subtr.induct) by auto
-
-lemmas subtr_roots_in = subtr_rootL_in subtr_rootR_in
-
-lemma subtr_mono:
-assumes "subtr ns tr1 tr2" and "ns \<subseteq> ns'"
-shows "subtr ns' tr1 tr2"
-using assms apply(induct arbitrary: ns' rule: subtr.induct)
-using Refl Step by (metis subtr.simps set_mp)+
-
-lemma subtr_trans_Un:
-assumes "subtr ns12 tr1 tr2" and "subtr ns23 tr2 tr3"
-shows "subtr (ns12 \<union> ns23) tr1 tr3"
-proof-
- have "subtr ns23 tr2 tr3 \<Longrightarrow>
- (\<forall> ns12 tr1. subtr ns12 tr1 tr2 \<longrightarrow> subtr (ns12 \<union> ns23) tr1 tr3)"
- apply(induct rule: subtr.induct, safe)
- apply (metis subtr_mono sup_commute sup_ge2)
- by (metis (lifting) Step UnI2)
- thus ?thesis using assms by auto
-qed
-
-lemma subtr_trans:
-assumes "subtr ns tr1 tr2" and "subtr ns tr2 tr3"
-shows "subtr ns tr1 tr3"
-using subtr_trans_Un[OF assms] by simp
-
-lemma subtr_StepL:
-assumes r: "root tr1 \<in> ns" and tr12: "Inr tr1 \<in> cont tr2" and s: "subtr ns tr2 tr3"
-shows "subtr ns tr1 tr3"
-apply(rule subtr_trans[OF _ s])
-apply(rule Step[of tr2 ns tr1 tr1])
-apply(rule subtr_rootL_in[OF s])
-apply(rule Refl[OF r])
-apply(rule tr12)
-done
-
-(* alternative definition: *)
-inductive subtr2 where
-Refl: "root tr \<in> ns \<Longrightarrow> subtr2 ns tr tr"
-|
-Step: "\<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr2 ns tr2 tr3\<rbrakk> \<Longrightarrow> subtr2 ns tr1 tr3"
-
-lemma subtr2_rootL_in:
-assumes "subtr2 ns tr1 tr2"
-shows "root tr1 \<in> ns"
-using assms apply(induct rule: subtr2.induct) by auto
-
-lemma subtr2_rootR_in:
-assumes "subtr2 ns tr1 tr2"
-shows "root tr2 \<in> ns"
-using assms apply(induct rule: subtr2.induct) by auto
-
-lemmas subtr2_roots_in = subtr2_rootL_in subtr2_rootR_in
-
-lemma subtr2_mono:
-assumes "subtr2 ns tr1 tr2" and "ns \<subseteq> ns'"
-shows "subtr2 ns' tr1 tr2"
-using assms apply(induct arbitrary: ns' rule: subtr2.induct)
-using Refl Step by (metis subtr2.simps set_mp)+
-
-lemma subtr2_trans_Un:
-assumes "subtr2 ns12 tr1 tr2" and "subtr2 ns23 tr2 tr3"
-shows "subtr2 (ns12 \<union> ns23) tr1 tr3"
-proof-
- have "subtr2 ns12 tr1 tr2 \<Longrightarrow>
- (\<forall> ns23 tr3. subtr2 ns23 tr2 tr3 \<longrightarrow> subtr2 (ns12 \<union> ns23) tr1 tr3)"
- apply(induct rule: subtr2.induct, safe)
- apply (metis subtr2_mono sup_commute sup_ge2)
- by (metis Un_iff subtr2.simps)
- thus ?thesis using assms by auto
-qed
-
-lemma subtr2_trans:
-assumes "subtr2 ns tr1 tr2" and "subtr2 ns tr2 tr3"
-shows "subtr2 ns tr1 tr3"
-using subtr2_trans_Un[OF assms] by simp
-
-lemma subtr2_StepR:
-assumes r: "root tr3 \<in> ns" and tr23: "Inr tr2 \<in> cont tr3" and s: "subtr2 ns tr1 tr2"
-shows "subtr2 ns tr1 tr3"
-apply(rule subtr2_trans[OF s])
-apply(rule Step[of _ _ tr3])
-apply(rule subtr2_rootR_in[OF s])
-apply(rule tr23)
-apply(rule Refl[OF r])
-done
-
-lemma subtr_subtr2:
-"subtr = subtr2"
-apply (rule ext)+ apply(safe)
- apply(erule subtr.induct)
- apply (metis (lifting) subtr2.Refl)
- apply (metis (lifting) subtr2_StepR)
- apply(erule subtr2.induct)
- apply (metis (lifting) subtr.Refl)
- apply (metis (lifting) subtr_StepL)
-done
-
-lemma subtr_inductL[consumes 1, case_names Refl Step]:
-assumes s: "subtr ns tr1 tr2" and Refl: "\<And>ns tr. \<phi> ns tr tr"
-and Step:
-"\<And>ns tr1 tr2 tr3.
- \<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr ns tr2 tr3; \<phi> ns tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> ns tr1 tr3"
-shows "\<phi> ns tr1 tr2"
-using s unfolding subtr_subtr2 apply(rule subtr2.induct)
-using Refl Step unfolding subtr_subtr2 by auto
-
-lemma subtr_UNIV_inductL[consumes 1, case_names Refl Step]:
-assumes s: "subtr UNIV tr1 tr2" and Refl: "\<And>tr. \<phi> tr tr"
-and Step:
-"\<And>tr1 tr2 tr3.
- \<lbrakk>Inr tr1 \<in> cont tr2; subtr UNIV tr2 tr3; \<phi> tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> tr1 tr3"
-shows "\<phi> tr1 tr2"
-using s apply(induct rule: subtr_inductL)
-apply(rule Refl) using Step subtr_mono by (metis subset_UNIV)
-
-(* Subtree versus frontier: *)
-lemma subtr_inFr:
-assumes "inFr ns tr t" and "subtr ns tr tr1"
-shows "inFr ns tr1 t"
-proof-
- have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inFr ns tr t \<longrightarrow> inFr ns tr1 t)"
- apply(induct rule: subtr.induct, safe) by (metis inFr.Ind)
- thus ?thesis using assms by auto
-qed
-
-corollary Fr_subtr:
-"Fr ns tr = \<Union> {Fr ns tr' | tr'. subtr ns tr' tr}"
-unfolding Fr_def proof safe
- fix t assume t: "inFr ns tr t" hence "root tr \<in> ns" by (rule inFr_root_in)
- thus "t \<in> \<Union>{{t. inFr ns tr' t} |tr'. subtr ns tr' tr}"
- apply(intro UnionI[of "{t. inFr ns tr t}" _ t]) using t subtr.Refl by auto
-qed(metis subtr_inFr)
-
-lemma inFr_subtr:
-assumes "inFr ns tr t"
-shows "\<exists> tr'. subtr ns tr' tr \<and> Inl t \<in> cont tr'"
-using assms apply(induct rule: inFr.induct) apply safe
- apply (metis subtr.Refl)
- by (metis (lifting) subtr.Step)
-
-corollary Fr_subtr_cont:
-"Fr ns tr = \<Union> {Inl -` cont tr' | tr'. subtr ns tr' tr}"
-unfolding Fr_def
-apply safe
-apply (frule inFr_subtr)
-apply auto
-by (metis inFr.Base subtr_inFr subtr_rootL_in)
-
-(* Subtree versus interior: *)
-lemma subtr_inItr:
-assumes "inItr ns tr n" and "subtr ns tr tr1"
-shows "inItr ns tr1 n"
-proof-
- have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inItr ns tr n \<longrightarrow> inItr ns tr1 n)"
- apply(induct rule: subtr.induct, safe) by (metis inItr.Ind)
- thus ?thesis using assms by auto
-qed
-
-corollary Itr_subtr:
-"Itr ns tr = \<Union> {Itr ns tr' | tr'. subtr ns tr' tr}"
-unfolding Itr_def apply safe
-apply (metis (lifting, mono_tags) UnionI inItr_root_in mem_Collect_eq subtr.Refl)
-by (metis subtr_inItr)
-
-lemma inItr_subtr:
-assumes "inItr ns tr n"
-shows "\<exists> tr'. subtr ns tr' tr \<and> root tr' = n"
-using assms apply(induct rule: inItr.induct) apply safe
- apply (metis subtr.Refl)
- by (metis (lifting) subtr.Step)
-
-corollary Itr_subtr_cont:
-"Itr ns tr = {root tr' | tr'. subtr ns tr' tr}"
-unfolding Itr_def apply safe
- apply (metis (lifting, mono_tags) inItr_subtr)
- by (metis inItr.Base subtr_inItr subtr_rootL_in)
-
-
-subsection{* The Immediate Subtree Function *}
-
-(* production of: *)
-abbreviation "prodOf tr \<equiv> (id \<oplus> root) ` (cont tr)"
-(* subtree of: *)
-definition "subtrOf tr n \<equiv> SOME tr'. Inr tr' \<in> cont tr \<and> root tr' = n"
-
-lemma subtrOf:
-assumes n: "Inr n \<in> prodOf tr"
-shows "Inr (subtrOf tr n) \<in> cont tr \<and> root (subtrOf tr n) = n"
-proof-
- obtain tr' where "Inr tr' \<in> cont tr \<and> root tr' = n"
- using n unfolding image_def by (metis (lifting) Inr_oplus_elim assms)
- thus ?thesis unfolding subtrOf_def by(rule someI)
-qed
-
-lemmas Inr_subtrOf = subtrOf[THEN conjunct1]
-lemmas root_subtrOf[simp] = subtrOf[THEN conjunct2]
-
-lemma Inl_prodOf: "Inl -` (prodOf tr) = Inl -` (cont tr)"
-proof safe
- fix t ttr assume "Inl t = (id \<oplus> root) ttr" and "ttr \<in> cont tr"
- thus "t \<in> Inl -` cont tr" by(cases ttr, auto)
-next
- fix t assume "Inl t \<in> cont tr" thus "t \<in> Inl -` prodOf tr"
- by (metis (lifting) id_def image_iff sum_map.simps(1) vimageI2)
-qed
-
-lemma root_prodOf:
-assumes "Inr tr' \<in> cont tr"
-shows "Inr (root tr') \<in> prodOf tr"
-by (metis (lifting) assms image_iff sum_map.simps(2))
-
-
-subsection{* Well-Formed Derivation Trees *}
-
-hide_const wf
-
-coinductive wf where
-dtree: "\<lbrakk>(root tr, (id \<oplus> root) ` (cont tr)) \<in> P; inj_on root (Inr -` cont tr);
- \<And> tr'. tr' \<in> Inr -` (cont tr) \<Longrightarrow> wf tr'\<rbrakk> \<Longrightarrow> wf tr"
-
-(* destruction rules: *)
-lemma wf_P:
-assumes "wf tr"
-shows "(root tr, (id \<oplus> root) ` (cont tr)) \<in> P"
-using assms wf.simps[of tr] by auto
-
-lemma wf_inj_on:
-assumes "wf tr"
-shows "inj_on root (Inr -` cont tr)"
-using assms wf.simps[of tr] by auto
-
-lemma wf_inj[simp]:
-assumes "wf tr" and "Inr tr1 \<in> cont tr" and "Inr tr2 \<in> cont tr"
-shows "root tr1 = root tr2 \<longleftrightarrow> tr1 = tr2"
-using assms wf_inj_on unfolding inj_on_def by auto
-
-lemma wf_cont:
-assumes "wf tr" and "Inr tr' \<in> cont tr"
-shows "wf tr'"
-using assms wf.simps[of tr] by auto
-
-
-(* coinduction:*)
-lemma wf_coind[elim, consumes 1, case_names Hyp]:
-assumes phi: "\<phi> tr"
-and Hyp:
-"\<And> tr. \<phi> tr \<Longrightarrow>
- (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
- inj_on root (Inr -` cont tr) \<and>
- (\<forall> tr' \<in> Inr -` (cont tr). \<phi> tr' \<or> wf tr')"
-shows "wf tr"
-apply(rule wf.coinduct[of \<phi> tr, OF phi])
-using Hyp by blast
-
-lemma wf_raw_coind[elim, consumes 1, case_names Hyp]:
-assumes phi: "\<phi> tr"
-and Hyp:
-"\<And> tr. \<phi> tr \<Longrightarrow>
- (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
- inj_on root (Inr -` cont tr) \<and>
- (\<forall> tr' \<in> Inr -` (cont tr). \<phi> tr')"
-shows "wf tr"
-using phi apply(induct rule: wf_coind)
-using Hyp by (metis (mono_tags))
-
-lemma wf_subtr_inj_on:
-assumes d: "wf tr1" and s: "subtr ns tr tr1"
-shows "inj_on root (Inr -` cont tr)"
-using s d apply(induct rule: subtr.induct)
-apply (metis (lifting) wf_inj_on) by (metis wf_cont)
-
-lemma wf_subtr_P:
-assumes d: "wf tr1" and s: "subtr ns tr tr1"
-shows "(root tr, (id \<oplus> root) ` cont tr) \<in> P"
-using s d apply(induct rule: subtr.induct)
-apply (metis (lifting) wf_P) by (metis wf_cont)
-
-lemma subtrOf_root[simp]:
-assumes tr: "wf tr" and cont: "Inr tr' \<in> cont tr"
-shows "subtrOf tr (root tr') = tr'"
-proof-
- have 0: "Inr (subtrOf tr (root tr')) \<in> cont tr" using Inr_subtrOf
- by (metis (lifting) cont root_prodOf)
- have "root (subtrOf tr (root tr')) = root tr'"
- using root_subtrOf by (metis (lifting) cont root_prodOf)
- thus ?thesis unfolding wf_inj[OF tr 0 cont] .
-qed
-
-lemma surj_subtrOf:
-assumes "wf tr" and 0: "Inr tr' \<in> cont tr"
-shows "\<exists> n. Inr n \<in> prodOf tr \<and> subtrOf tr n = tr'"
-apply(rule exI[of _ "root tr'"])
-using root_prodOf[OF 0] subtrOf_root[OF assms] by simp
-
-lemma wf_subtr:
-assumes "wf tr1" and "subtr ns tr tr1"
-shows "wf tr"
-proof-
- have "(\<exists> ns tr1. wf tr1 \<and> subtr ns tr tr1) \<Longrightarrow> wf tr"
- proof (induct rule: wf_raw_coind)
- case (Hyp tr)
- then obtain ns tr1 where tr1: "wf tr1" and tr_tr1: "subtr ns tr tr1" by auto
- show ?case proof safe
- show "(root tr, (id \<oplus> root) ` cont tr) \<in> P" using wf_subtr_P[OF tr1 tr_tr1] .
- next
- show "inj_on root (Inr -` cont tr)" using wf_subtr_inj_on[OF tr1 tr_tr1] .
- next
- fix tr' assume tr': "Inr tr' \<in> cont tr"
- have tr_tr1: "subtr (ns \<union> {root tr'}) tr tr1" using subtr_mono[OF tr_tr1] by auto
- have "subtr (ns \<union> {root tr'}) tr' tr1" using subtr_StepL[OF _ tr' tr_tr1] by auto
- thus "\<exists>ns' tr1. wf tr1 \<and> subtr ns' tr' tr1" using tr1 by blast
- qed
- qed
- thus ?thesis using assms by auto
-qed
-
-
-subsection{* Default Trees *}
-
-(* Pick a left-hand side of a production for each nonterminal *)
-definition S where "S n \<equiv> SOME tns. (n,tns) \<in> P"
-
-lemma S_P: "(n, S n) \<in> P"
-using used unfolding S_def by(rule someI_ex)
-
-lemma finite_S: "finite (S n)"
-using S_P finite_in_P by auto
-
-
-(* The default tree of a nonterminal *)
-definition deftr :: "N \<Rightarrow> dtree" where
-"deftr \<equiv> unfold id S"
-
-lemma deftr_simps[simp]:
-"root (deftr n) = n"
-"cont (deftr n) = image (id \<oplus> deftr) (S n)"
-using unfold(1)[of id S n] unfold(2)[of S n id, OF finite_S]
-unfolding deftr_def by simp_all
-
-lemmas root_deftr = deftr_simps(1)
-lemmas cont_deftr = deftr_simps(2)
-
-lemma root_o_deftr[simp]: "root o deftr = id"
-by (rule ext, auto)
-
-lemma wf_deftr: "wf (deftr n)"
-proof-
- {fix tr assume "\<exists> n. tr = deftr n" hence "wf tr"
- apply(induct rule: wf_raw_coind) apply safe
- unfolding deftr_simps image_compose[symmetric] sum_map.comp id_comp
- root_o_deftr sum_map.id image_id id_apply apply(rule S_P)
- unfolding inj_on_def by auto
- }
- thus ?thesis by auto
-qed
-
-
-subsection{* Hereditary Substitution *}
-
-(* Auxiliary concept: The root-ommiting frontier: *)
-definition "inFrr ns tr t \<equiv> \<exists> tr'. Inr tr' \<in> cont tr \<and> inFr ns tr' t"
-definition "Frr ns tr \<equiv> {t. \<exists> tr'. Inr tr' \<in> cont tr \<and> t \<in> Fr ns tr'}"
-
-context
-fixes tr0 :: dtree
-begin
-
-definition "hsubst_r tr \<equiv> root tr"
-definition "hsubst_c tr \<equiv> if root tr = root tr0 then cont tr0 else cont tr"
-
-(* Hereditary substitution: *)
-definition hsubst :: "dtree \<Rightarrow> dtree" where
-"hsubst \<equiv> unfold hsubst_r hsubst_c"
-
-lemma finite_hsubst_c: "finite (hsubst_c n)"
-unfolding hsubst_c_def by (metis (full_types) finite_cont)
-
-lemma root_hsubst[simp]: "root (hsubst tr) = root tr"
-using unfold(1)[of hsubst_r hsubst_c tr] unfolding hsubst_def hsubst_r_def by simp
-
-lemma root_o_subst[simp]: "root o hsubst = root"
-unfolding comp_def root_hsubst ..
-
-lemma cont_hsubst_eq[simp]:
-assumes "root tr = root tr0"
-shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr0)"
-apply(subst id_comp[symmetric, of id]) unfolding id_comp
-using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
-unfolding hsubst_def hsubst_c_def using assms by simp
-
-lemma hsubst_eq:
-assumes "root tr = root tr0"
-shows "hsubst tr = hsubst tr0"
-apply(rule dtree_cong) using assms cont_hsubst_eq by auto
-
-lemma cont_hsubst_neq[simp]:
-assumes "root tr \<noteq> root tr0"
-shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr)"
-apply(subst id_comp[symmetric, of id]) unfolding id_comp
-using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
-unfolding hsubst_def hsubst_c_def using assms by simp
-
-lemma Inl_cont_hsubst_eq[simp]:
-assumes "root tr = root tr0"
-shows "Inl -` cont (hsubst tr) = Inl -` (cont tr0)"
-unfolding cont_hsubst_eq[OF assms] by simp
-
-lemma Inr_cont_hsubst_eq[simp]:
-assumes "root tr = root tr0"
-shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr0"
-unfolding cont_hsubst_eq[OF assms] by simp
-
-lemma Inl_cont_hsubst_neq[simp]:
-assumes "root tr \<noteq> root tr0"
-shows "Inl -` cont (hsubst tr) = Inl -` (cont tr)"
-unfolding cont_hsubst_neq[OF assms] by simp
-
-lemma Inr_cont_hsubst_neq[simp]:
-assumes "root tr \<noteq> root tr0"
-shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr"
-unfolding cont_hsubst_neq[OF assms] by simp
-
-lemma wf_hsubst:
-assumes tr0: "wf tr0" and tr: "wf tr"
-shows "wf (hsubst tr)"
-proof-
- {fix tr1 have "(\<exists> tr. wf tr \<and> tr1 = hsubst tr) \<Longrightarrow> wf tr1"
- proof (induct rule: wf_raw_coind)
- case (Hyp tr1) then obtain tr
- where dtr: "wf tr" and tr1: "tr1 = hsubst tr" by auto
- show ?case unfolding tr1 proof safe
- show "(root (hsubst tr), prodOf (hsubst tr)) \<in> P"
- unfolding tr1 apply(cases "root tr = root tr0")
- using wf_P[OF dtr] wf_P[OF tr0]
- by (auto simp add: image_compose[symmetric] sum_map.comp)
- show "inj_on root (Inr -` cont (hsubst tr))"
- apply(cases "root tr = root tr0") using wf_inj_on[OF dtr] wf_inj_on[OF tr0]
- unfolding inj_on_def by (auto, blast)
- fix tr' assume "Inr tr' \<in> cont (hsubst tr)"
- thus "\<exists>tra. wf tra \<and> tr' = hsubst tra"
- apply(cases "root tr = root tr0", simp_all)
- apply (metis wf_cont tr0)
- by (metis dtr wf_cont)
- qed
- qed
- }
- thus ?thesis using assms by blast
-qed
-
-lemma Frr: "Frr ns tr = {t. inFrr ns tr t}"
-unfolding inFrr_def Frr_def Fr_def by auto
-
-lemma inFr_hsubst_imp:
-assumes "inFr ns (hsubst tr) t"
-shows "t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
- inFr (ns - {root tr0}) tr t"
-proof-
- {fix tr1
- have "inFr ns tr1 t \<Longrightarrow>
- (\<And> tr. tr1 = hsubst tr \<Longrightarrow> (t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
- inFr (ns - {root tr0}) tr t))"
- proof(induct rule: inFr.induct)
- case (Base tr1 ns t tr)
- hence rtr: "root tr1 \<in> ns" and t_tr1: "Inl t \<in> cont tr1" and tr1: "tr1 = hsubst tr"
- by auto
- show ?case
- proof(cases "root tr1 = root tr0")
- case True
- hence "t \<in> Inl -` (cont tr0)" using t_tr1 unfolding tr1 by auto
- thus ?thesis by simp
- next
- case False
- hence "inFr (ns - {root tr0}) tr t" using t_tr1 unfolding tr1 apply simp
- by (metis Base.prems Diff_iff root_hsubst inFr.Base rtr singletonE)
- thus ?thesis by simp
- qed
- next
- case (Ind tr1 ns tr1' t) note IH = Ind(4)
- have rtr1: "root tr1 \<in> ns" and tr1'_tr1: "Inr tr1' \<in> cont tr1"
- and t_tr1': "inFr ns tr1' t" and tr1: "tr1 = hsubst tr" using Ind by auto
- have rtr1: "root tr1 = root tr" unfolding tr1 by simp
- show ?case
- proof(cases "root tr1 = root tr0")
- case True
- then obtain tr' where tr'_tr0: "Inr tr' \<in> cont tr0" and tr1': "tr1' = hsubst tr'"
- using tr1'_tr1 unfolding tr1 by auto
- show ?thesis using IH[OF tr1'] proof (elim disjE)
- assume "inFr (ns - {root tr0}) tr' t"
- thus ?thesis using tr'_tr0 unfolding inFrr_def by auto
- qed auto
- next
- case False
- then obtain tr' where tr'_tr: "Inr tr' \<in> cont tr" and tr1': "tr1' = hsubst tr'"
- using tr1'_tr1 unfolding tr1 by auto
- show ?thesis using IH[OF tr1'] proof (elim disjE)
- assume "inFr (ns - {root tr0}) tr' t"
- thus ?thesis using tr'_tr unfolding inFrr_def
- by (metis Diff_iff False Ind(1) empty_iff inFr2_Ind inFr_inFr2 insert_iff rtr1)
- qed auto
- qed
- qed
- }
- thus ?thesis using assms by auto
-qed
-
-lemma inFr_hsubst_notin:
-assumes "inFr ns tr t" and "root tr0 \<notin> ns"
-shows "inFr ns (hsubst tr) t"
-using assms apply(induct rule: inFr.induct)
-apply (metis Inl_cont_hsubst_neq inFr2.Base inFr_inFr2 root_hsubst vimageD vimageI2)
-by (metis (lifting) Inr_cont_hsubst_neq inFr.Ind rev_image_eqI root_hsubst vimageD vimageI2)
-
-lemma inFr_hsubst_minus:
-assumes "inFr (ns - {root tr0}) tr t"
-shows "inFr ns (hsubst tr) t"
-proof-
- have 1: "inFr (ns - {root tr0}) (hsubst tr) t"
- using inFr_hsubst_notin[OF assms] by simp
- show ?thesis using inFr_mono[OF 1] by auto
-qed
-
-lemma inFr_self_hsubst:
-assumes "root tr0 \<in> ns"
-shows
-"inFr ns (hsubst tr0) t \<longleftrightarrow>
- t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t"
-(is "?A \<longleftrightarrow> ?B \<or> ?C")
-apply(intro iffI)
-apply (metis inFr_hsubst_imp Diff_iff inFr_root_in insertI1) proof(elim disjE)
- assume ?B thus ?A apply(intro inFr.Base) using assms by auto
-next
- assume ?C then obtain tr where
- tr_tr0: "Inr tr \<in> cont tr0" and t_tr: "inFr (ns - {root tr0}) tr t"
- unfolding inFrr_def by auto
- def tr1 \<equiv> "hsubst tr"
- have 1: "inFr ns tr1 t" using t_tr unfolding tr1_def using inFr_hsubst_minus by auto
- have "Inr tr1 \<in> cont (hsubst tr0)" unfolding tr1_def using tr_tr0 by auto
- thus ?A using 1 inFr.Ind assms by (metis root_hsubst)
-qed
-
-lemma Fr_self_hsubst:
-assumes "root tr0 \<in> ns"
-shows "Fr ns (hsubst tr0) = Inl -` (cont tr0) \<union> Frr (ns - {root tr0}) tr0"
-using inFr_self_hsubst[OF assms] unfolding Frr Fr_def by auto
-
-end (* context *)
-
-
-subsection{* Regular Trees *}
-
-hide_const regular
-
-definition "reg f tr \<equiv> \<forall> tr'. subtr UNIV tr' tr \<longrightarrow> tr' = f (root tr')"
-definition "regular tr \<equiv> \<exists> f. reg f tr"
-
-lemma reg_def2: "reg f tr \<longleftrightarrow> (\<forall> ns tr'. subtr ns tr' tr \<longrightarrow> tr' = f (root tr'))"
-unfolding reg_def using subtr_mono by (metis subset_UNIV)
-
-lemma regular_def2: "regular tr \<longleftrightarrow> (\<exists> f. reg f tr \<and> (\<forall> n. root (f n) = n))"
-unfolding regular_def proof safe
- fix f assume f: "reg f tr"
- def g \<equiv> "\<lambda> n. if inItr UNIV tr n then f n else deftr n"
- show "\<exists>g. reg g tr \<and> (\<forall>n. root (g n) = n)"
- apply(rule exI[of _ g])
- using f deftr_simps(1) unfolding g_def reg_def apply safe
- apply (metis (lifting) inItr.Base subtr_inItr subtr_rootL_in)
- by (metis (full_types) inItr_subtr)
-qed auto
-
-lemma reg_root:
-assumes "reg f tr"
-shows "f (root tr) = tr"
-using assms unfolding reg_def
-by (metis (lifting) iso_tuple_UNIV_I subtr.Refl)
-
-
-lemma reg_Inr_cont:
-assumes "reg f tr" and "Inr tr' \<in> cont tr"
-shows "reg f tr'"
-by (metis (lifting) assms iso_tuple_UNIV_I reg_def subtr.Step)
-
-lemma reg_subtr:
-assumes "reg f tr" and "subtr ns tr' tr"
-shows "reg f tr'"
-using assms unfolding reg_def using subtr_trans[of UNIV tr] UNIV_I
-by (metis UNIV_eq_I UnCI Un_upper1 iso_tuple_UNIV_I subtr_mono subtr_trans)
-
-lemma regular_subtr:
-assumes r: "regular tr" and s: "subtr ns tr' tr"
-shows "regular tr'"
-using r reg_subtr[OF _ s] unfolding regular_def by auto
-
-lemma subtr_deftr:
-assumes "subtr ns tr' (deftr n)"
-shows "tr' = deftr (root tr')"
-proof-
- {fix tr have "subtr ns tr' tr \<Longrightarrow> (\<forall> n. tr = deftr n \<longrightarrow> tr' = deftr (root tr'))"
- apply (induct rule: subtr.induct)
- proof(metis (lifting) deftr_simps(1), safe)
- fix tr3 ns tr1 tr2 n
- assume 1: "root (deftr n) \<in> ns" and 2: "subtr ns tr1 tr2"
- and IH: "\<forall>n. tr2 = deftr n \<longrightarrow> tr1 = deftr (root tr1)"
- and 3: "Inr tr2 \<in> cont (deftr n)"
- have "tr2 \<in> deftr ` UNIV"
- using 3 unfolding deftr_simps image_def
- by (metis (lifting, full_types) 3 CollectI Inr_oplus_iff cont_deftr
- iso_tuple_UNIV_I)
- then obtain n where "tr2 = deftr n" by auto
- thus "tr1 = deftr (root tr1)" using IH by auto
- qed
- }
- thus ?thesis using assms by auto
-qed
-
-lemma reg_deftr: "reg deftr (deftr n)"
-unfolding reg_def using subtr_deftr by auto
-
-lemma wf_subtrOf_Union:
-assumes "wf tr"
-shows "\<Union>{K tr' |tr'. Inr tr' \<in> cont tr} =
- \<Union>{K (subtrOf tr n) |n. Inr n \<in> prodOf tr}"
-unfolding Union_eq Bex_def mem_Collect_eq proof safe
- fix x xa tr'
- assume x: "x \<in> K tr'" and tr'_tr: "Inr tr' \<in> cont tr"
- show "\<exists>X. (\<exists>n. X = K (subtrOf tr n) \<and> Inr n \<in> prodOf tr) \<and> x \<in> X"
- apply(rule exI[of _ "K (subtrOf tr (root tr'))"]) apply(intro conjI)
- apply(rule exI[of _ "root tr'"]) apply (metis (lifting) root_prodOf tr'_tr)
- by (metis (lifting) assms subtrOf_root tr'_tr x)
-next
- fix x X n ttr
- assume x: "x \<in> K (subtrOf tr n)" and n: "Inr n = (id \<oplus> root) ttr" and ttr: "ttr \<in> cont tr"
- show "\<exists>X. (\<exists>tr'. X = K tr' \<and> Inr tr' \<in> cont tr) \<and> x \<in> X"
- apply(rule exI[of _ "K (subtrOf tr n)"]) apply(intro conjI)
- apply(rule exI[of _ "subtrOf tr n"]) apply (metis imageI n subtrOf ttr)
- using x .
-qed
-
-
-
-
-subsection {* Paths in a Regular Tree *}
-
-inductive path :: "(N \<Rightarrow> dtree) \<Rightarrow> N list \<Rightarrow> bool" for f where
-Base: "path f [n]"
-|
-Ind: "\<lbrakk>path f (n1 # nl); Inr (f n1) \<in> cont (f n)\<rbrakk>
- \<Longrightarrow> path f (n # n1 # nl)"
-
-lemma path_NE:
-assumes "path f nl"
-shows "nl \<noteq> Nil"
-using assms apply(induct rule: path.induct) by auto
-
-lemma path_post:
-assumes f: "path f (n # nl)" and nl: "nl \<noteq> []"
-shows "path f nl"
-proof-
- obtain n1 nl1 where nl: "nl = n1 # nl1" using nl by (cases nl, auto)
- show ?thesis using assms unfolding nl using path.simps by (metis (lifting) list.inject)
-qed
-
-lemma path_post_concat:
-assumes "path f (nl1 @ nl2)" and "nl2 \<noteq> Nil"
-shows "path f nl2"
-using assms apply (induct nl1)
-apply (metis append_Nil) by (metis Nil_is_append_conv append_Cons path_post)
-
-lemma path_concat:
-assumes "path f nl1" and "path f ((last nl1) # nl2)"
-shows "path f (nl1 @ nl2)"
-using assms apply(induct rule: path.induct) apply simp
-by (metis append_Cons last.simps list.simps(3) path.Ind)
-
-lemma path_distinct:
-assumes "path f nl"
-shows "\<exists> nl'. path f nl' \<and> hd nl' = hd nl \<and> last nl' = last nl \<and>
- set nl' \<subseteq> set nl \<and> distinct nl'"
-using assms proof(induct rule: length_induct)
- case (1 nl) hence p_nl: "path f nl" by simp
- then obtain n nl1 where nl: "nl = n # nl1" by (metis list.exhaust path_NE)
- show ?case
- proof(cases nl1)
- case Nil
- show ?thesis apply(rule exI[of _ nl]) using path.Base unfolding nl Nil by simp
- next
- case (Cons n1 nl2)
- hence p1: "path f nl1" by (metis list.simps(3) nl p_nl path_post)
- show ?thesis
- proof(cases "n \<in> set nl1")
- case False
- obtain nl1' where p1': "path f nl1'" and hd_nl1': "hd nl1' = hd nl1" and
- l_nl1': "last nl1' = last nl1" and d_nl1': "distinct nl1'"
- and s_nl1': "set nl1' \<subseteq> set nl1"
- using 1(1)[THEN allE[of _ nl1]] p1 unfolding nl by auto
- obtain nl2' where nl1': "nl1' = n1 # nl2'" using path_NE[OF p1'] hd_nl1'
- unfolding Cons by(cases nl1', auto)
- show ?thesis apply(intro exI[of _ "n # nl1'"]) unfolding nl proof safe
- show "path f (n # nl1')" unfolding nl1'
- apply(rule path.Ind, metis nl1' p1')
- by (metis (lifting) Cons list.inject nl p1 p_nl path.simps path_NE)
- qed(insert l_nl1' Cons nl1' s_nl1' d_nl1' False, auto)
- next
- case True
- then obtain nl11 nl12 where nl1: "nl1 = nl11 @ n # nl12"
- by (metis split_list)
- have p12: "path f (n # nl12)"
- apply(rule path_post_concat[of _ "n # nl11"]) using p_nl[unfolded nl nl1] by auto
- obtain nl12' where p1': "path f nl12'" and hd_nl12': "hd nl12' = n" and
- l_nl12': "last nl12' = last (n # nl12)" and d_nl12': "distinct nl12'"
- and s_nl12': "set nl12' \<subseteq> {n} \<union> set nl12"
- using 1(1)[THEN allE[of _ "n # nl12"]] p12 unfolding nl nl1 by auto
- thus ?thesis apply(intro exI[of _ nl12']) unfolding nl nl1 by auto
- qed
- qed
-qed
-
-lemma path_subtr:
-assumes f: "\<And> n. root (f n) = n"
-and p: "path f nl"
-shows "subtr (set nl) (f (last nl)) (f (hd nl))"
-using p proof (induct rule: path.induct)
- case (Ind n1 nl n) let ?ns1 = "insert n1 (set nl)"
- have "path f (n1 # nl)"
- and "subtr ?ns1 (f (last (n1 # nl))) (f n1)"
- and fn1: "Inr (f n1) \<in> cont (f n)" using Ind by simp_all
- hence fn1_flast: "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n1)"
- by (metis subset_insertI subtr_mono)
- have 1: "last (n # n1 # nl) = last (n1 # nl)" by auto
- have "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n)"
- using f subtr.Step[OF _ fn1_flast fn1] by auto
- thus ?case unfolding 1 by simp
-qed (metis f hd.simps last_ConsL last_in_set not_Cons_self2 subtr.Refl)
-
-lemma reg_subtr_path_aux:
-assumes f: "reg f tr" and n: "subtr ns tr1 tr"
-shows "\<exists> nl. path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
-using n f proof(induct rule: subtr.induct)
- case (Refl tr ns)
- thus ?case
- apply(intro exI[of _ "[root tr]"]) apply simp by (metis (lifting) path.Base reg_root)
-next
- case (Step tr ns tr2 tr1)
- hence rtr: "root tr \<in> ns" and tr1_tr: "Inr tr1 \<in> cont tr"
- and tr2_tr1: "subtr ns tr2 tr1" and tr: "reg f tr" by auto
- have tr1: "reg f tr1" using reg_subtr[OF tr] rtr tr1_tr
- by (metis (lifting) Step.prems iso_tuple_UNIV_I reg_def subtr.Step)
- obtain nl where nl: "path f nl" and f_nl: "f (hd nl) = tr1"
- and last_nl: "f (last nl) = tr2" and set: "set nl \<subseteq> ns" using Step(3)[OF tr1] by auto
- have 0: "path f (root tr # nl)" apply (subst path.simps)
- using f_nl nl reg_root tr tr1_tr by (metis hd.simps neq_Nil_conv)
- show ?case apply(rule exI[of _ "(root tr) # nl"])
- using 0 reg_root tr last_nl nl path_NE rtr set by auto
-qed
-
-lemma reg_subtr_path:
-assumes f: "reg f tr" and n: "subtr ns tr1 tr"
-shows "\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
-using reg_subtr_path_aux[OF assms] path_distinct[of f]
-by (metis (lifting) order_trans)
-
-lemma subtr_iff_path:
-assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
-shows "subtr ns tr1 tr \<longleftrightarrow>
- (\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns)"
-proof safe
- fix nl assume p: "path f nl" and nl: "set nl \<subseteq> ns"
- have "subtr (set nl) (f (last nl)) (f (hd nl))"
- apply(rule path_subtr) using p f by simp_all
- thus "subtr ns (f (last nl)) (f (hd nl))"
- using subtr_mono nl by auto
-qed(insert reg_subtr_path[OF r], auto)
-
-lemma inFr_iff_path:
-assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
-shows
-"inFr ns tr t \<longleftrightarrow>
- (\<exists> nl tr1. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and>
- set nl \<subseteq> ns \<and> Inl t \<in> cont tr1)"
-apply safe
-apply (metis (no_types) inFr_subtr r reg_subtr_path)
-by (metis f inFr.Base path_subtr subtr_inFr subtr_mono subtr_rootL_in)
-
-
-
-subsection{* The Regular Cut of a Tree *}
-
-context fixes tr0 :: dtree
-begin
-
-(* Picking a subtree of a certain root: *)
-definition "pick n \<equiv> SOME tr. subtr UNIV tr tr0 \<and> root tr = n"
-
-lemma pick:
-assumes "inItr UNIV tr0 n"
-shows "subtr UNIV (pick n) tr0 \<and> root (pick n) = n"
-proof-
- have "\<exists> tr. subtr UNIV tr tr0 \<and> root tr = n"
- using assms by (metis (lifting) inItr_subtr)
- thus ?thesis unfolding pick_def by(rule someI_ex)
-qed
-
-lemmas subtr_pick = pick[THEN conjunct1]
-lemmas root_pick = pick[THEN conjunct2]
-
-lemma wf_pick:
-assumes tr0: "wf tr0" and n: "inItr UNIV tr0 n"
-shows "wf (pick n)"
-using wf_subtr[OF tr0 subtr_pick[OF n]] .
-
-definition "H_r n \<equiv> root (pick n)"
-definition "H_c n \<equiv> (id \<oplus> root) ` cont (pick n)"
-
-(* The regular tree of a function: *)
-definition H :: "N \<Rightarrow> dtree" where
-"H \<equiv> unfold H_r H_c"
-
-lemma finite_H_c: "finite (H_c n)"
-unfolding H_c_def by (metis finite_cont finite_imageI)
-
-lemma root_H_pick: "root (H n) = root (pick n)"
-using unfold(1)[of H_r H_c n] unfolding H_def H_r_def by simp
-
-lemma root_H[simp]:
-assumes "inItr UNIV tr0 n"
-shows "root (H n) = n"
-unfolding root_H_pick root_pick[OF assms] ..
-
-lemma cont_H[simp]:
-"cont (H n) = (id \<oplus> (H o root)) ` cont (pick n)"
-apply(subst id_comp[symmetric, of id]) unfolding sum_map.comp[symmetric]
-unfolding image_compose unfolding H_c_def[symmetric]
-using unfold(2)[of H_c n H_r, OF finite_H_c]
-unfolding H_def ..
-
-lemma Inl_cont_H[simp]:
-"Inl -` (cont (H n)) = Inl -` (cont (pick n))"
-unfolding cont_H by simp
-
-lemma Inr_cont_H:
-"Inr -` (cont (H n)) = (H \<circ> root) ` (Inr -` cont (pick n))"
-unfolding cont_H by simp
-
-lemma subtr_H:
-assumes n: "inItr UNIV tr0 n" and "subtr UNIV tr1 (H n)"
-shows "\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = H n1"
-proof-
- {fix tr ns assume "subtr UNIV tr1 tr"
- hence "tr = H n \<longrightarrow> (\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = H n1)"
- proof (induct rule: subtr_UNIV_inductL)
- case (Step tr2 tr1 tr)
- show ?case proof
- assume "tr = H n"
- then obtain n1 where tr2: "Inr tr2 \<in> cont tr1"
- and tr1_tr: "subtr UNIV tr1 tr" and n1: "inItr UNIV tr0 n1" and tr1: "tr1 = H n1"
- using Step by auto
- obtain tr2' where tr2: "tr2 = H (root tr2')"
- and tr2': "Inr tr2' \<in> cont (pick n1)"
- using tr2 Inr_cont_H[of n1]
- unfolding tr1 image_def comp_def using vimage_eq by auto
- have "inItr UNIV tr0 (root tr2')"
- using inItr.Base inItr.Ind n1 pick subtr_inItr tr2' by (metis iso_tuple_UNIV_I)
- thus "\<exists>n2. inItr UNIV tr0 n2 \<and> tr2 = H n2" using tr2 by blast
- qed
- qed(insert n, auto)
- }
- thus ?thesis using assms by auto
-qed
-
-lemma root_H_root:
-assumes n: "inItr UNIV tr0 n" and t_tr: "t_tr \<in> cont (pick n)"
-shows "(id \<oplus> (root \<circ> H \<circ> root)) t_tr = (id \<oplus> root) t_tr"
-using assms apply(cases t_tr)
- apply (metis (lifting) sum_map.simps(1))
- using pick H_def H_r_def unfold(1)
- inItr.Base comp_apply subtr_StepL subtr_inItr sum_map.simps(2)
- by (metis UNIV_I)
-
-lemma H_P:
-assumes tr0: "wf tr0" and n: "inItr UNIV tr0 n"
-shows "(n, (id \<oplus> root) ` cont (H n)) \<in> P" (is "?L \<in> P")
-proof-
- have "?L = (n, (id \<oplus> root) ` cont (pick n))"
- unfolding cont_H image_compose[symmetric] sum_map.comp id_comp comp_assoc[symmetric]
- unfolding Pair_eq apply(rule conjI[OF refl]) apply(rule image_cong[OF refl])
- by (rule root_H_root[OF n])
- moreover have "... \<in> P" by (metis (lifting) wf_pick root_pick wf_P n tr0)
- ultimately show ?thesis by simp
-qed
-
-lemma wf_H:
-assumes tr0: "wf tr0" and "inItr UNIV tr0 n"
-shows "wf (H n)"
-proof-
- {fix tr have "\<exists> n. inItr UNIV tr0 n \<and> tr = H n \<Longrightarrow> wf tr"
- proof (induct rule: wf_raw_coind)
- case (Hyp tr)
- then obtain n where n: "inItr UNIV tr0 n" and tr: "tr = H n" by auto
- show ?case apply safe
- apply (metis (lifting) H_P root_H n tr tr0)
- unfolding tr Inr_cont_H unfolding inj_on_def apply clarsimp using root_H
- apply (metis UNIV_I inItr.Base n pick subtr2.simps subtr_inItr subtr_subtr2)
- by (metis n subtr.Refl subtr_StepL subtr_H tr UNIV_I)
- qed
- }
- thus ?thesis using assms by blast
-qed
-
-(* The regular cut of a tree: *)
-definition "rcut \<equiv> H (root tr0)"
-
-lemma reg_rcut: "reg H rcut"
-unfolding reg_def rcut_def
-by (metis inItr.Base root_H subtr_H UNIV_I)
-
-lemma rcut_reg:
-assumes "reg H tr0"
-shows "rcut = tr0"
-using assms unfolding rcut_def reg_def by (metis subtr.Refl UNIV_I)
-
-lemma rcut_eq: "rcut = tr0 \<longleftrightarrow> reg H tr0"
-using reg_rcut rcut_reg by metis
-
-lemma regular_rcut: "regular rcut"
-using reg_rcut unfolding regular_def by blast
-
-lemma Fr_rcut: "Fr UNIV rcut \<subseteq> Fr UNIV tr0"
-proof safe
- fix t assume "t \<in> Fr UNIV rcut"
- then obtain tr where t: "Inl t \<in> cont tr" and tr: "subtr UNIV tr (H (root tr0))"
- using Fr_subtr[of UNIV "H (root tr0)"] unfolding rcut_def
- by (metis (full_types) Fr_def inFr_subtr mem_Collect_eq)
- obtain n where n: "inItr UNIV tr0 n" and tr: "tr = H n" using tr
- by (metis (lifting) inItr.Base subtr_H UNIV_I)
- have "Inl t \<in> cont (pick n)" using t using Inl_cont_H[of n] unfolding tr
- by (metis (lifting) vimageD vimageI2)
- moreover have "subtr UNIV (pick n) tr0" using subtr_pick[OF n] ..
- ultimately show "t \<in> Fr UNIV tr0" unfolding Fr_subtr_cont by auto
-qed
-
-lemma wf_rcut:
-assumes "wf tr0"
-shows "wf rcut"
-unfolding rcut_def using wf_H[OF assms inItr.Base] by simp
-
-lemma root_rcut[simp]: "root rcut = root tr0"
-unfolding rcut_def
-by (metis (lifting) root_H inItr.Base reg_def reg_root subtr_rootR_in)
-
-end (* context *)
-
-
-subsection{* Recursive Description of the Regular Tree Frontiers *}
-
-lemma regular_inFr:
-assumes r: "regular tr" and In: "root tr \<in> ns"
-and t: "inFr ns tr t"
-shows "t \<in> Inl -` (cont tr) \<or>
- (\<exists> tr'. Inr tr' \<in> cont tr \<and> inFr (ns - {root tr}) tr' t)"
-(is "?L \<or> ?R")
-proof-
- obtain f where r: "reg f tr" and f: "\<And>n. root (f n) = n"
- using r unfolding regular_def2 by auto
- obtain nl tr1 where d_nl: "distinct nl" and p: "path f nl" and hd_nl: "f (hd nl) = tr"
- and l_nl: "f (last nl) = tr1" and s_nl: "set nl \<subseteq> ns" and t_tr1: "Inl t \<in> cont tr1"
- using t unfolding inFr_iff_path[OF r f] by auto
- obtain n nl1 where nl: "nl = n # nl1" by (metis (lifting) p path.simps)
- hence f_n: "f n = tr" using hd_nl by simp
- have n_nl1: "n \<notin> set nl1" using d_nl unfolding nl by auto
- show ?thesis
- proof(cases nl1)
- case Nil hence "tr = tr1" using f_n l_nl unfolding nl by simp
- hence ?L using t_tr1 by simp thus ?thesis by simp
- next
- case (Cons n1 nl2) note nl1 = Cons
- have 1: "last nl1 = last nl" "hd nl1 = n1" unfolding nl nl1 by simp_all
- have p1: "path f nl1" and n1_tr: "Inr (f n1) \<in> cont tr"
- using path.simps[of f nl] p f_n unfolding nl nl1 by auto
- have r1: "reg f (f n1)" using reg_Inr_cont[OF r n1_tr] .
- have 0: "inFr (set nl1) (f n1) t" unfolding inFr_iff_path[OF r1 f]
- apply(intro exI[of _ nl1], intro exI[of _ tr1])
- using d_nl unfolding 1 l_nl unfolding nl using p1 t_tr1 by auto
- have root_tr: "root tr = n" by (metis f f_n)
- have "inFr (ns - {root tr}) (f n1) t" apply(rule inFr_mono[OF 0])
- using s_nl unfolding root_tr unfolding nl using n_nl1 by auto
- thus ?thesis using n1_tr by auto
- qed
-qed
-
-lemma regular_Fr:
-assumes r: "regular tr" and In: "root tr \<in> ns"
-shows "Fr ns tr =
- Inl -` (cont tr) \<union>
- \<Union> {Fr (ns - {root tr}) tr' | tr'. Inr tr' \<in> cont tr}"
-unfolding Fr_def
-using In inFr.Base regular_inFr[OF assms] apply safe
-apply (simp, metis (full_types) mem_Collect_eq)
-apply simp
-by (simp, metis (lifting) inFr_Ind_minus insert_Diff)
-
-
-subsection{* The Generated Languages *}
-
-(* The (possibly inifinite tree) generated language *)
-definition "L ns n \<equiv> {Fr ns tr | tr. wf tr \<and> root tr = n}"
-
-(* The regular-tree generated language *)
-definition "Lr ns n \<equiv> {Fr ns tr | tr. wf tr \<and> root tr = n \<and> regular tr}"
-
-lemma L_rec_notin:
-assumes "n \<notin> ns"
-shows "L ns n = {{}}"
-using assms unfolding L_def apply safe
- using not_root_Fr apply force
- apply(rule exI[of _ "deftr n"])
- by (metis (no_types) wf_deftr not_root_Fr root_deftr)
-
-lemma Lr_rec_notin:
-assumes "n \<notin> ns"
-shows "Lr ns n = {{}}"
-using assms unfolding Lr_def apply safe
- using not_root_Fr apply force
- apply(rule exI[of _ "deftr n"])
- by (metis (no_types) regular_def wf_deftr not_root_Fr reg_deftr root_deftr)
-
-lemma wf_subtrOf:
-assumes "wf tr" and "Inr n \<in> prodOf tr"
-shows "wf (subtrOf tr n)"
-by (metis assms wf_cont subtrOf)
-
-lemma Lr_rec_in:
-assumes n: "n \<in> ns"
-shows "Lr ns n \<subseteq>
-{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
- (n,tns) \<in> P \<and>
- (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n')}"
-(is "Lr ns n \<subseteq> {?F tns K | tns K. (n,tns) \<in> P \<and> ?\<phi> tns K}")
-proof safe
- fix ts assume "ts \<in> Lr ns n"
- then obtain tr where dtr: "wf tr" and r: "root tr = n" and tr: "regular tr"
- and ts: "ts = Fr ns tr" unfolding Lr_def by auto
- def tns \<equiv> "(id \<oplus> root) ` (cont tr)"
- def K \<equiv> "\<lambda> n'. Fr (ns - {n}) (subtrOf tr n')"
- show "\<exists>tns K. ts = ?F tns K \<and> (n, tns) \<in> P \<and> ?\<phi> tns K"
- apply(rule exI[of _ tns], rule exI[of _ K]) proof(intro conjI allI impI)
- show "ts = Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns}"
- unfolding ts regular_Fr[OF tr n[unfolded r[symmetric]]]
- unfolding tns_def K_def r[symmetric]
- unfolding Inl_prodOf wf_subtrOf_Union[OF dtr] ..
- show "(n, tns) \<in> P" unfolding tns_def r[symmetric] using wf_P[OF dtr] .
- fix n' assume "Inr n' \<in> tns" thus "K n' \<in> Lr (ns - {n}) n'"
- unfolding K_def Lr_def mem_Collect_eq apply(intro exI[of _ "subtrOf tr n'"])
- using dtr tr apply(intro conjI refl) unfolding tns_def
- apply(erule wf_subtrOf[OF dtr])
- apply (metis subtrOf)
- by (metis Inr_subtrOf UNIV_I regular_subtr subtr.simps)
- qed
-qed
-
-lemma hsubst_aux:
-fixes n ftr tns
-assumes n: "n \<in> ns" and tns: "finite tns" and
-1: "\<And> n'. Inr n' \<in> tns \<Longrightarrow> wf (ftr n')"
-defines "tr \<equiv> Node n ((id \<oplus> ftr) ` tns)" defines "tr' \<equiv> hsubst tr tr"
-shows "Fr ns tr' = Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
-(is "_ = ?B") proof-
- have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
- unfolding tr_def using tns by auto
- have Frr: "Frr (ns - {n}) tr = \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
- unfolding Frr_def ctr by auto
- have "Fr ns tr' = Inl -` (cont tr) \<union> Frr (ns - {n}) tr"
- using Fr_self_hsubst[OF n[unfolded rtr[symmetric]]] unfolding tr'_def rtr ..
- also have "... = ?B" unfolding ctr Frr by simp
- finally show ?thesis .
-qed
-
-lemma L_rec_in:
-assumes n: "n \<in> ns"
-shows "
-{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
- (n,tns) \<in> P \<and>
- (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n')}
- \<subseteq> L ns n"
-proof safe
- fix tns K
- assume P: "(n, tns) \<in> P" and 0: "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n'"
- {fix n' assume "Inr n' \<in> tns"
- hence "K n' \<in> L (ns - {n}) n'" using 0 by auto
- hence "\<exists> tr'. K n' = Fr (ns - {n}) tr' \<and> wf tr' \<and> root tr' = n'"
- unfolding L_def mem_Collect_eq by auto
- }
- then obtain ftr where 0: "\<And> n'. Inr n' \<in> tns \<Longrightarrow>
- K n' = Fr (ns - {n}) (ftr n') \<and> wf (ftr n') \<and> root (ftr n') = n'"
- by metis
- def tr \<equiv> "Node n ((id \<oplus> ftr) ` tns)" def tr' \<equiv> "hsubst tr tr"
- have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
- unfolding tr_def by (simp, metis P cont_Node finite_imageI finite_in_P)
- have prtr: "prodOf tr = tns" apply(rule Inl_Inr_image_cong)
- unfolding ctr apply simp apply simp apply safe
- using 0 unfolding image_def apply force apply simp by (metis 0 vimageI2)
- have 1: "{K n' |n'. Inr n' \<in> tns} = {Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
- using 0 by auto
- have dtr: "wf tr" apply(rule wf.dtree)
- apply (metis (lifting) P prtr rtr)
- unfolding inj_on_def ctr using 0 by auto
- hence dtr': "wf tr'" unfolding tr'_def by (metis wf_hsubst)
- have tns: "finite tns" using finite_in_P P by simp
- have "Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns} \<in> L ns n"
- unfolding L_def mem_Collect_eq apply(intro exI[of _ tr'] conjI)
- using dtr' 0 hsubst_aux[OF assms tns, of ftr] unfolding tr_def tr'_def by auto
- thus "Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} \<in> L ns n" unfolding 1 .
-qed
-
-lemma card_N: "(n::N) \<in> ns \<Longrightarrow> card (ns - {n}) < card ns"
-by (metis finite_N Diff_UNIV Diff_infinite_finite card_Diff1_less finite.emptyI)
-
-function LL where
-"LL ns n =
- (if n \<notin> ns then {{}} else
- {Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
- (n,tns) \<in> P \<and>
- (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n')})"
-by(pat_completeness, auto)
-termination apply(relation "inv_image (measure card) fst")
-using card_N by auto
-
-declare LL.simps[code]
-declare LL.simps[simp del]
-
-lemma Lr_LL: "Lr ns n \<subseteq> LL ns n"
-proof (induct ns arbitrary: n rule: measure_induct[of card])
- case (1 ns n) show ?case proof(cases "n \<in> ns")
- case False thus ?thesis unfolding Lr_rec_notin[OF False] by (simp add: LL.simps)
- next
- case True show ?thesis apply(rule subset_trans)
- using Lr_rec_in[OF True] apply assumption
- unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
- fix tns K
- assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
- assume "(n, tns) \<in> P"
- and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n'"
- thus "\<exists>tnsa Ka.
- Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
- Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
- (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> LL (ns - {n}) n')"
- apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
- qed
- qed
-qed
-
-lemma LL_L: "LL ns n \<subseteq> L ns n"
-proof (induct ns arbitrary: n rule: measure_induct[of card])
- case (1 ns n) show ?case proof(cases "n \<in> ns")
- case False thus ?thesis unfolding L_rec_notin[OF False] by (simp add: LL.simps)
- next
- case True show ?thesis apply(rule subset_trans)
- prefer 2 using L_rec_in[OF True] apply assumption
- unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
- fix tns K
- assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
- assume "(n, tns) \<in> P"
- and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n'"
- thus "\<exists>tnsa Ka.
- Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
- Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
- (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> L (ns - {n}) n')"
- apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
- qed
- qed
-qed
-
-(* The subsumpsion relation between languages *)
-definition "subs L1 L2 \<equiv> \<forall> ts2 \<in> L2. \<exists> ts1 \<in> L1. ts1 \<subseteq> ts2"
-
-lemma incl_subs[simp]: "L2 \<subseteq> L1 \<Longrightarrow> subs L1 L2"
-unfolding subs_def by auto
-
-lemma subs_refl[simp]: "subs L1 L1" unfolding subs_def by auto
-
-lemma subs_trans: "\<lbrakk>subs L1 L2; subs L2 L3\<rbrakk> \<Longrightarrow> subs L1 L3"
-unfolding subs_def by (metis subset_trans)
-
-(* Language equivalence *)
-definition "leqv L1 L2 \<equiv> subs L1 L2 \<and> subs L2 L1"
-
-lemma subs_leqv[simp]: "leqv L1 L2 \<Longrightarrow> subs L1 L2"
-unfolding leqv_def by auto
-
-lemma subs_leqv_sym[simp]: "leqv L1 L2 \<Longrightarrow> subs L2 L1"
-unfolding leqv_def by auto
-
-lemma leqv_refl[simp]: "leqv L1 L1" unfolding leqv_def by auto
-
-lemma leqv_trans:
-assumes 12: "leqv L1 L2" and 23: "leqv L2 L3"
-shows "leqv L1 L3"
-using assms unfolding leqv_def by (metis (lifting) subs_trans)
-
-lemma leqv_sym: "leqv L1 L2 \<Longrightarrow> leqv L2 L1"
-unfolding leqv_def by auto
-
-lemma leqv_Sym: "leqv L1 L2 \<longleftrightarrow> leqv L2 L1"
-unfolding leqv_def by auto
-
-lemma Lr_incl_L: "Lr ns ts \<subseteq> L ns ts"
-unfolding Lr_def L_def by auto
-
-lemma Lr_subs_L: "subs (Lr UNIV ts) (L UNIV ts)"
-unfolding subs_def proof safe
- fix ts2 assume "ts2 \<in> L UNIV ts"
- then obtain tr where ts2: "ts2 = Fr UNIV tr" and dtr: "wf tr" and rtr: "root tr = ts"
- unfolding L_def by auto
- thus "\<exists>ts1\<in>Lr UNIV ts. ts1 \<subseteq> ts2"
- apply(intro bexI[of _ "Fr UNIV (rcut tr)"])
- unfolding Lr_def L_def using Fr_rcut wf_rcut root_rcut regular_rcut by auto
-qed
-
-lemma Lr_leqv_L: "leqv (Lr UNIV ts) (L UNIV ts)"
-using Lr_subs_L unfolding leqv_def by (metis (lifting) Lr_incl_L incl_subs)
-
-lemma LL_leqv_L: "leqv (LL UNIV ts) (L UNIV ts)"
-by (metis (lifting) LL_L Lr_LL Lr_subs_L incl_subs leqv_def subs_trans)
-
-lemma LL_leqv_Lr: "leqv (LL UNIV ts) (Lr UNIV ts)"
-using Lr_leqv_L LL_leqv_L by (metis leqv_Sym leqv_trans)
-
-end
--- a/src/HOL/BNF/Examples/Derivation_Trees/Parallel.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,147 +0,0 @@
-(* Title: HOL/BNF/Examples/Derivation_Trees/Parallel.thy
- Author: Andrei Popescu, TU Muenchen
- Copyright 2012
-
-Parallel composition.
-*)
-
-header {* Parallel Composition *}
-
-theory Parallel
-imports DTree
-begin
-
-no_notation plus_class.plus (infixl "+" 65)
-
-consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)
-
-axiomatization where
- Nplus_comm: "(a::N) + b = b + (a::N)"
-and Nplus_assoc: "((a::N) + b) + c = a + (b + c)"
-
-subsection{* Corecursive Definition of Parallel Composition *}
-
-fun par_r where "par_r (tr1,tr2) = root tr1 + root tr2"
-fun par_c where
-"par_c (tr1,tr2) =
- Inl ` (Inl -` (cont tr1 \<union> cont tr2)) \<union>
- Inr ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
-
-declare par_r.simps[simp del] declare par_c.simps[simp del]
-
-definition par :: "dtree \<times> dtree \<Rightarrow> dtree" where
-"par \<equiv> unfold par_r par_c"
-
-abbreviation par_abbr (infixr "\<parallel>" 80) where "tr1 \<parallel> tr2 \<equiv> par (tr1, tr2)"
-
-lemma finite_par_c: "finite (par_c (tr1, tr2))"
-unfolding par_c.simps apply(rule finite_UnI)
- apply (metis finite_Un finite_cont finite_imageI finite_vimageI inj_Inl)
- apply(intro finite_imageI finite_cartesian_product finite_vimageI)
- using finite_cont by auto
-
-lemma root_par: "root (tr1 \<parallel> tr2) = root tr1 + root tr2"
-using unfold(1)[of par_r par_c "(tr1,tr2)"] unfolding par_def par_r.simps by simp
-
-lemma cont_par:
-"cont (tr1 \<parallel> tr2) = (id \<oplus> par) ` par_c (tr1,tr2)"
-using unfold(2)[of par_c "(tr1,tr2)" par_r, OF finite_par_c]
-unfolding par_def ..
-
-lemma Inl_cont_par[simp]:
-"Inl -` (cont (tr1 \<parallel> tr2)) = Inl -` (cont tr1 \<union> cont tr2)"
-unfolding cont_par par_c.simps by auto
-
-lemma Inr_cont_par[simp]:
-"Inr -` (cont (tr1 \<parallel> tr2)) = par ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
-unfolding cont_par par_c.simps by auto
-
-lemma Inl_in_cont_par:
-"Inl t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (Inl t \<in> cont tr1 \<or> Inl t \<in> cont tr2)"
-using Inl_cont_par[of tr1 tr2] unfolding vimage_def by auto
-
-lemma Inr_in_cont_par:
-"Inr t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (t \<in> par ` (Inr -` cont tr1 \<times> Inr -` cont tr2))"
-using Inr_cont_par[of tr1 tr2] unfolding vimage_def by auto
-
-
-subsection{* Structural Coinduction Proofs *}
-
-lemma set_rel_sum_rel_eq[simp]:
-"set_rel (sum_rel (op =) \<phi>) A1 A2 \<longleftrightarrow>
- Inl -` A1 = Inl -` A2 \<and> set_rel \<phi> (Inr -` A1) (Inr -` A2)"
-unfolding set_rel_sum_rel set_rel_eq ..
-
-(* Detailed proofs of commutativity and associativity: *)
-theorem par_com: "tr1 \<parallel> tr2 = tr2 \<parallel> tr1"
-proof-
- let ?\<theta> = "\<lambda> trA trB. \<exists> tr1 tr2. trA = tr1 \<parallel> tr2 \<and> trB = tr2 \<parallel> tr1"
- {fix trA trB
- assume "?\<theta> trA trB" hence "trA = trB"
- apply (induct rule: dtree_coinduct)
- unfolding set_rel_sum_rel set_rel_eq unfolding set_rel_def proof safe
- fix tr1 tr2 show "root (tr1 \<parallel> tr2) = root (tr2 \<parallel> tr1)"
- unfolding root_par by (rule Nplus_comm)
- next
- fix n tr1 tr2 assume "Inl n \<in> cont (tr1 \<parallel> tr2)" thus "n \<in> Inl -` (cont (tr2 \<parallel> tr1))"
- unfolding Inl_in_cont_par by auto
- next
- fix n tr1 tr2 assume "Inl n \<in> cont (tr2 \<parallel> tr1)" thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2))"
- unfolding Inl_in_cont_par by auto
- next
- fix tr1 tr2 trA' assume "Inr trA' \<in> cont (tr1 \<parallel> tr2)"
- then obtain tr1' tr2' where "trA' = tr1' \<parallel> tr2'"
- and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
- unfolding Inr_in_cont_par by auto
- thus "\<exists> trB' \<in> Inr -` (cont (tr2 \<parallel> tr1)). ?\<theta> trA' trB'"
- apply(intro bexI[of _ "tr2' \<parallel> tr1'"]) unfolding Inr_in_cont_par by auto
- next
- fix tr1 tr2 trB' assume "Inr trB' \<in> cont (tr2 \<parallel> tr1)"
- then obtain tr1' tr2' where "trB' = tr2' \<parallel> tr1'"
- and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
- unfolding Inr_in_cont_par by auto
- thus "\<exists> trA' \<in> Inr -` (cont (tr1 \<parallel> tr2)). ?\<theta> trA' trB'"
- apply(intro bexI[of _ "tr1' \<parallel> tr2'"]) unfolding Inr_in_cont_par by auto
- qed
- }
- thus ?thesis by blast
-qed
-
-lemma par_assoc: "(tr1 \<parallel> tr2) \<parallel> tr3 = tr1 \<parallel> (tr2 \<parallel> tr3)"
-proof-
- let ?\<theta> =
- "\<lambda> trA trB. \<exists> tr1 tr2 tr3. trA = (tr1 \<parallel> tr2) \<parallel> tr3 \<and> trB = tr1 \<parallel> (tr2 \<parallel> tr3)"
- {fix trA trB
- assume "?\<theta> trA trB" hence "trA = trB"
- apply (induct rule: dtree_coinduct)
- unfolding set_rel_sum_rel set_rel_eq unfolding set_rel_def proof safe
- fix tr1 tr2 tr3 show "root ((tr1 \<parallel> tr2) \<parallel> tr3) = root (tr1 \<parallel> (tr2 \<parallel> tr3))"
- unfolding root_par by (rule Nplus_assoc)
- next
- fix n tr1 tr2 tr3 assume "Inl n \<in> (cont ((tr1 \<parallel> tr2) \<parallel> tr3))"
- thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2 \<parallel> tr3))" unfolding Inl_in_cont_par by simp
- next
- fix n tr1 tr2 tr3 assume "Inl n \<in> (cont (tr1 \<parallel> tr2 \<parallel> tr3))"
- thus "n \<in> Inl -` (cont ((tr1 \<parallel> tr2) \<parallel> tr3))" unfolding Inl_in_cont_par by simp
- next
- fix trA' tr1 tr2 tr3 assume "Inr trA' \<in> cont ((tr1 \<parallel> tr2) \<parallel> tr3)"
- then obtain tr1' tr2' tr3' where "trA' = (tr1' \<parallel> tr2') \<parallel> tr3'"
- and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
- and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
- thus "\<exists> trB' \<in> Inr -` (cont (tr1 \<parallel> tr2 \<parallel> tr3)). ?\<theta> trA' trB'"
- apply(intro bexI[of _ "tr1' \<parallel> tr2' \<parallel> tr3'"])
- unfolding Inr_in_cont_par by auto
- next
- fix trB' tr1 tr2 tr3 assume "Inr trB' \<in> cont (tr1 \<parallel> tr2 \<parallel> tr3)"
- then obtain tr1' tr2' tr3' where "trB' = tr1' \<parallel> (tr2' \<parallel> tr3')"
- and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
- and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
- thus "\<exists> trA' \<in> Inr -` cont ((tr1 \<parallel> tr2) \<parallel> tr3). ?\<theta> trA' trB'"
- apply(intro bexI[of _ "(tr1' \<parallel> tr2') \<parallel> tr3'"])
- unfolding Inr_in_cont_par by auto
- qed
- }
- thus ?thesis by blast
-qed
-
-end
--- a/src/HOL/BNF/Examples/Derivation_Trees/Prelim.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,62 +0,0 @@
-(* Title: HOL/BNF/Examples/Derivation_Trees/Prelim.thy
- Author: Andrei Popescu, TU Muenchen
- Copyright 2012
-
-Preliminaries.
-*)
-
-header {* Preliminaries *}
-
-theory Prelim
-imports "../../BNF" "../../More_BNFs"
-begin
-
-declare fset_to_fset[simp]
-
-lemma fst_snd_convol_o[simp]: "<fst o s, snd o s> = s"
-apply(rule ext) by (simp add: convol_def)
-
-abbreviation sm_abbrev (infix "\<oplus>" 60)
-where "f \<oplus> g \<equiv> Sum_Type.sum_map f g"
-
-lemma sum_map_InlD: "(f \<oplus> g) z = Inl x \<Longrightarrow> \<exists>y. z = Inl y \<and> f y = x"
-by (cases z) auto
-
-lemma sum_map_InrD: "(f \<oplus> g) z = Inr x \<Longrightarrow> \<exists>y. z = Inr y \<and> g y = x"
-by (cases z) auto
-
-abbreviation sum_case_abbrev ("[[_,_]]" 800)
-where "[[f,g]] \<equiv> Sum_Type.sum_case f g"
-
-lemma Inl_oplus_elim:
-assumes "Inl tr \<in> (id \<oplus> f) ` tns"
-shows "Inl tr \<in> tns"
-using assms apply clarify by (case_tac x, auto)
-
-lemma Inl_oplus_iff[simp]: "Inl tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> Inl tr \<in> tns"
-using Inl_oplus_elim
-by (metis id_def image_iff sum_map.simps(1))
-
-lemma Inl_m_oplus[simp]: "Inl -` (id \<oplus> f) ` tns = Inl -` tns"
-using Inl_oplus_iff unfolding vimage_def by auto
-
-lemma Inr_oplus_elim:
-assumes "Inr tr \<in> (id \<oplus> f) ` tns"
-shows "\<exists> n. Inr n \<in> tns \<and> f n = tr"
-using assms apply clarify by (case_tac x, auto)
-
-lemma Inr_oplus_iff[simp]:
-"Inr tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> (\<exists> n. Inr n \<in> tns \<and> f n = tr)"
-apply (rule iffI)
- apply (metis Inr_oplus_elim)
-by (metis image_iff sum_map.simps(2))
-
-lemma Inr_m_oplus[simp]: "Inr -` (id \<oplus> f) ` tns = f ` (Inr -` tns)"
-using Inr_oplus_iff unfolding vimage_def by auto
-
-lemma Inl_Inr_image_cong:
-assumes "Inl -` A = Inl -` B" and "Inr -` A = Inr -` B"
-shows "A = B"
-apply safe using assms apply(case_tac x, auto) by(case_tac x, auto)
-
-end
\ No newline at end of file
--- a/src/HOL/BNF/Examples/Koenig.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,122 +0,0 @@
-(* Title: HOL/BNF/Examples/Koenig.thy
- Author: Dmitriy Traytel, TU Muenchen
- Author: Andrei Popescu, TU Muenchen
- Copyright 2012
-
-Koenig's lemma.
-*)
-
-header {* Koenig's lemma *}
-
-theory Koenig
-imports TreeFI Stream
-begin
-
-(* infinite trees: *)
-coinductive infiniteTr where
-"\<lbrakk>tr' \<in> set_listF (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"
-
-lemma infiniteTr_strong_coind[consumes 1, case_names sub]:
-assumes *: "phi tr" and
-**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set_listF (sub tr). phi tr' \<or> infiniteTr tr'"
-shows "infiniteTr tr"
-using assms by (elim infiniteTr.coinduct) blast
-
-lemma infiniteTr_coind[consumes 1, case_names sub, induct pred: infiniteTr]:
-assumes *: "phi tr" and
-**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set_listF (sub tr). phi tr'"
-shows "infiniteTr tr"
-using assms by (elim infiniteTr.coinduct) blast
-
-lemma infiniteTr_sub[simp]:
-"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> set_listF (sub tr). infiniteTr tr')"
-by (erule infiniteTr.cases) blast
-
-primcorec konigPath where
- "shd (konigPath t) = lab t"
-| "stl (konigPath t) = konigPath (SOME tr. tr \<in> set_listF (sub t) \<and> infiniteTr tr)"
-
-(* proper paths in trees: *)
-coinductive properPath where
-"\<lbrakk>shd as = lab tr; tr' \<in> set_listF (sub tr); properPath (stl as) tr'\<rbrakk> \<Longrightarrow>
- properPath as tr"
-
-lemma properPath_strong_coind[consumes 1, case_names shd_lab sub]:
-assumes *: "phi as tr" and
-**: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
-***: "\<And> as tr.
- phi as tr \<Longrightarrow>
- \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
-shows "properPath as tr"
-using assms by (elim properPath.coinduct) blast
-
-lemma properPath_coind[consumes 1, case_names shd_lab sub, induct pred: properPath]:
-assumes *: "phi as tr" and
-**: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
-***: "\<And> as tr.
- phi as tr \<Longrightarrow>
- \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr'"
-shows "properPath as tr"
-using properPath_strong_coind[of phi, OF * **] *** by blast
-
-lemma properPath_shd_lab:
-"properPath as tr \<Longrightarrow> shd as = lab tr"
-by (erule properPath.cases) blast
-
-lemma properPath_sub:
-"properPath as tr \<Longrightarrow>
- \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
-by (erule properPath.cases) blast
-
-(* prove the following by coinduction *)
-theorem Konig:
- assumes "infiniteTr tr"
- shows "properPath (konigPath tr) tr"
-proof-
- {fix as
- assume "infiniteTr tr \<and> as = konigPath tr" hence "properPath as tr"
- proof (coinduction arbitrary: tr as rule: properPath_coind)
- case (sub tr as)
- let ?t = "SOME t'. t' \<in> set_listF (sub tr) \<and> infiniteTr t'"
- from sub have "\<exists>t' \<in> set_listF (sub tr). infiniteTr t'" by simp
- then have "\<exists>t'. t' \<in> set_listF (sub tr) \<and> infiniteTr t'" by blast
- then have "?t \<in> set_listF (sub tr) \<and> infiniteTr ?t" by (rule someI_ex)
- moreover have "stl (konigPath tr) = konigPath ?t" by simp
- ultimately show ?case using sub by blast
- qed simp
- }
- thus ?thesis using assms by blast
-qed
-
-(* some more stream theorems *)
-
-primcorec plus :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<oplus>" 66) where
- "shd (plus xs ys) = shd xs + shd ys"
-| "stl (plus xs ys) = plus (stl xs) (stl ys)"
-
-definition scalar :: "nat \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<cdot>" 68) where
- [simp]: "scalar n = smap (\<lambda>x. n * x)"
-
-primcorec ones :: "nat stream" where "ones = 1 ## ones"
-primcorec twos :: "nat stream" where "twos = 2 ## twos"
-definition ns :: "nat \<Rightarrow> nat stream" where [simp]: "ns n = scalar n ones"
-
-lemma "ones \<oplus> ones = twos"
- by coinduction simp
-
-lemma "n \<cdot> twos = ns (2 * n)"
- by coinduction simp
-
-lemma prod_scalar: "(n * m) \<cdot> xs = n \<cdot> m \<cdot> xs"
- by (coinduction arbitrary: xs) auto
-
-lemma scalar_plus: "n \<cdot> (xs \<oplus> ys) = n \<cdot> xs \<oplus> n \<cdot> ys"
- by (coinduction arbitrary: xs ys) (auto simp: add_mult_distrib2)
-
-lemma plus_comm: "xs \<oplus> ys = ys \<oplus> xs"
- by (coinduction arbitrary: xs ys) auto
-
-lemma plus_assoc: "(xs \<oplus> ys) \<oplus> zs = xs \<oplus> ys \<oplus> zs"
- by (coinduction arbitrary: xs ys zs) auto
-
-end
--- a/src/HOL/BNF/Examples/Lambda_Term.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,52 +0,0 @@
-(* Title: HOL/BNF/Examples/Lambda_Term.thy
- Author: Dmitriy Traytel, TU Muenchen
- Author: Andrei Popescu, TU Muenchen
- Copyright 2012
-
-Lambda-terms.
-*)
-
-header {* Lambda-Terms *}
-
-theory Lambda_Term
-imports "../More_BNFs"
-begin
-
-thy_deps
-
-section {* Datatype definition *}
-
-datatype_new 'a trm =
- Var 'a |
- App "'a trm" "'a trm" |
- Lam 'a "'a trm" |
- Lt "('a \<times> 'a trm) fset" "'a trm"
-
-
-subsection{* Example: The set of all variables varsOf and free variables fvarsOf of a term: *}
-
-primrec_new varsOf :: "'a trm \<Rightarrow> 'a set" where
- "varsOf (Var a) = {a}"
-| "varsOf (App f x) = varsOf f \<union> varsOf x"
-| "varsOf (Lam x b) = {x} \<union> varsOf b"
-| "varsOf (Lt F t) = varsOf t \<union> (\<Union> { {x} \<union> X | x X. (x,X) |\<in>| fimage (map_pair id varsOf) F})"
-
-primrec_new fvarsOf :: "'a trm \<Rightarrow> 'a set" where
- "fvarsOf (Var x) = {x}"
-| "fvarsOf (App t1 t2) = fvarsOf t1 \<union> fvarsOf t2"
-| "fvarsOf (Lam x t) = fvarsOf t - {x}"
-| "fvarsOf (Lt xts t) = fvarsOf t - {x | x X. (x,X) |\<in>| fimage (map_pair id varsOf) xts} \<union>
- (\<Union> {X | x X. (x,X) |\<in>| fimage (map_pair id varsOf) xts})"
-
-lemma diff_Un_incl_triv: "\<lbrakk>A \<subseteq> D; C \<subseteq> E\<rbrakk> \<Longrightarrow> A - B \<union> C \<subseteq> D \<union> E" by blast
-
-lemma in_fmap_map_pair_fset_iff[simp]:
- "(x, y) |\<in>| fimage (map_pair f g) xts \<longleftrightarrow> (\<exists> t1 t2. (t1, t2) |\<in>| xts \<and> x = f t1 \<and> y = g t2)"
- by force
-
-lemma fvarsOf_varsOf: "fvarsOf t \<subseteq> varsOf t"
-proof induct
- case (Lt xts t) thus ?case unfolding fvarsOf.simps varsOf.simps by (elim diff_Un_incl_triv) auto
-qed auto
-
-end
--- a/src/HOL/BNF/Examples/ListF.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,111 +0,0 @@
-(* Title: HOL/BNF/Examples/ListF.thy
- Author: Dmitriy Traytel, TU Muenchen
- Author: Andrei Popescu, TU Muenchen
- Copyright 2012
-
-Finite lists.
-*)
-
-header {* Finite Lists *}
-
-theory ListF
-imports "../BNF"
-begin
-
-datatype_new 'a listF (map: mapF rel: relF) =
- NilF (defaults tlF: NilF) | Conss (hdF: 'a) (tlF: "'a listF")
-datatype_new_compat listF
-
-definition Singll ("[[_]]") where
- [simp]: "Singll a \<equiv> Conss a NilF"
-
-primrec_new appendd (infixr "@@" 65) where
- "NilF @@ ys = ys"
-| "Conss x xs @@ ys = Conss x (xs @@ ys)"
-
-primrec_new lrev where
- "lrev NilF = NilF"
-| "lrev (Conss y ys) = lrev ys @@ [[y]]"
-
-lemma appendd_NilF[simp]: "xs @@ NilF = xs"
- by (induct xs) auto
-
-lemma appendd_assoc[simp]: "(xs @@ ys) @@ zs = xs @@ ys @@ zs"
- by (induct xs) auto
-
-lemma lrev_appendd[simp]: "lrev (xs @@ ys) = lrev ys @@ lrev xs"
- by (induct xs) auto
-
-lemma listF_map_appendd[simp]:
- "mapF f (xs @@ ys) = mapF f xs @@ mapF f ys"
- by (induct xs) auto
-
-lemma lrev_listF_map[simp]: "lrev (mapF f xs) = mapF f (lrev xs)"
- by (induct xs) auto
-
-lemma lrev_lrev[simp]: "lrev (lrev xs) = xs"
- by (induct xs) auto
-
-primrec_new lengthh where
- "lengthh NilF = 0"
-| "lengthh (Conss x xs) = Suc (lengthh xs)"
-
-fun nthh where
- "nthh (Conss x xs) 0 = x"
-| "nthh (Conss x xs) (Suc n) = nthh xs n"
-| "nthh xs i = undefined"
-
-lemma lengthh_listF_map[simp]: "lengthh (mapF f xs) = lengthh xs"
- by (induct xs) auto
-
-lemma nthh_listF_map[simp]:
- "i < lengthh xs \<Longrightarrow> nthh (mapF f xs) i = f (nthh xs i)"
- by (induct rule: nthh.induct) auto
-
-lemma nthh_listF_set[simp]: "i < lengthh xs \<Longrightarrow> nthh xs i \<in> set_listF xs"
- by (induct rule: nthh.induct) auto
-
-lemma NilF_iff[iff]: "(lengthh xs = 0) = (xs = NilF)"
- by (induct xs) auto
-
-lemma Conss_iff[iff]:
- "(lengthh xs = Suc n) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
- by (induct xs) auto
-
-lemma Conss_iff'[iff]:
- "(Suc n = lengthh xs) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
- by (induct xs) (simp, simp, blast)
-
-lemma listF_induct2[consumes 1, case_names NilF Conss]: "\<lbrakk>lengthh xs = lengthh ys; P NilF NilF;
- \<And>x xs y ys. P xs ys \<Longrightarrow> P (Conss x xs) (Conss y ys)\<rbrakk> \<Longrightarrow> P xs ys"
- by (induct xs arbitrary: ys) auto
-
-fun zipp where
- "zipp NilF NilF = NilF"
-| "zipp (Conss x xs) (Conss y ys) = Conss (x, y) (zipp xs ys)"
-| "zipp xs ys = undefined"
-
-lemma listF_map_fst_zip[simp]:
- "lengthh xs = lengthh ys \<Longrightarrow> mapF fst (zipp xs ys) = xs"
- by (induct rule: listF_induct2) auto
-
-lemma listF_map_snd_zip[simp]:
- "lengthh xs = lengthh ys \<Longrightarrow> mapF snd (zipp xs ys) = ys"
- by (induct rule: listF_induct2) auto
-
-lemma lengthh_zip[simp]:
- "lengthh xs = lengthh ys \<Longrightarrow> lengthh (zipp xs ys) = lengthh xs"
- by (induct rule: listF_induct2) auto
-
-lemma nthh_zip[simp]:
- assumes "lengthh xs = lengthh ys"
- shows "i < lengthh xs \<Longrightarrow> nthh (zipp xs ys) i = (nthh xs i, nthh ys i)"
-using assms proof (induct arbitrary: i rule: listF_induct2)
- case (Conss x xs y ys) thus ?case by (induct i) auto
-qed simp
-
-lemma list_set_nthh[simp]:
- "(x \<in> set_listF xs) \<Longrightarrow> (\<exists>i < lengthh xs. nthh xs i = x)"
- by (induct xs) (auto, induct rule: nthh.induct, auto)
-
-end
--- a/src/HOL/BNF/Examples/Misc_Codatatype.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,120 +0,0 @@
-(* Title: HOL/BNF/Examples/Misc_Codatatype.thy
- Author: Dmitriy Traytel, TU Muenchen
- Author: Andrei Popescu, TU Muenchen
- Author: Jasmin Blanchette, TU Muenchen
- Copyright 2012, 2013
-
-Miscellaneous codatatype definitions.
-*)
-
-header {* Miscellaneous Codatatype Definitions *}
-
-theory Misc_Codatatype
-imports More_BNFs
-begin
-
-codatatype simple = X1 | X2 | X3 | X4
-
-codatatype simple' = X1' unit | X2' unit | X3' unit | X4' unit
-
-codatatype simple'' = X1'' nat int | X2''
-
-codatatype 'a stream = Stream (shd: 'a) (stl: "'a stream")
-
-codatatype 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
-
-codatatype ('b, 'c, 'd, 'e) some_passive =
- SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
-
-codatatype lambda =
- Var string |
- App lambda lambda |
- Abs string lambda |
- Let "(string \<times> lambda) fset" lambda
-
-codatatype 'a par_lambda =
- PVar 'a |
- PApp "'a par_lambda" "'a par_lambda" |
- PAbs 'a "'a par_lambda" |
- PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
-
-(*
- ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
- ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
-*)
-
-codatatype 'a p = P "'a + 'a p"
-
-codatatype 'a J1 = J11 'a "'a J1" | J12 'a "'a J2"
-and 'a J2 = J21 | J22 "'a J1" "'a J2"
-
-codatatype 'a tree = TEmpty | TNode 'a "'a forest"
-and 'a forest = FNil | FCons "'a tree" "'a forest"
-
-codatatype 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
-and 'a branch = Branch 'a "'a tree'"
-
-codatatype ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
-and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
-and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
-
-codatatype ('a, 'b, 'c) some_killing =
- SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
-and ('a, 'b, 'c) in_here =
- IH1 'b 'a | IH2 'c
-
-codatatype ('a, 'b, 'c) some_killing' =
- SK' "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing' + ('a, 'b, 'c) in_here'"
-and ('a, 'b, 'c) in_here' =
- IH1' 'b | IH2' 'c
-
-codatatype ('a, 'b, 'c) some_killing'' =
- SK'' "'a \<Rightarrow> ('a, 'b, 'c) in_here''"
-and ('a, 'b, 'c) in_here'' =
- IH1'' 'b 'a | IH2'' 'c
-
-codatatype ('b, 'c) less_killing = LK "'b \<Rightarrow> 'c"
-
-codatatype 'b poly_unit = U "'b \<Rightarrow> 'b poly_unit"
-codatatype 'b cps = CPS1 'b | CPS2 "'b \<Rightarrow> 'b cps"
-
-codatatype ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs =
- FR "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow>
- ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs"
-
-codatatype ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
- 'b18, 'b19, 'b20) fun_rhs' =
- FR' "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow> 'b10 \<Rightarrow> 'b11 \<Rightarrow> 'b12 \<Rightarrow> 'b13 \<Rightarrow> 'b14 \<Rightarrow>
- 'b15 \<Rightarrow> 'b16 \<Rightarrow> 'b17 \<Rightarrow> 'b18 \<Rightarrow> 'b19 \<Rightarrow> 'b20 \<Rightarrow>
- ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
- 'b18, 'b19, 'b20) fun_rhs'"
-
-codatatype ('a, 'b, 'c) wit3_F1 = W1 'a "('a, 'b, 'c) wit3_F1" "('a, 'b, 'c) wit3_F2"
-and ('a, 'b, 'c) wit3_F2 = W2 'b "('a, 'b, 'c) wit3_F2"
-and ('a, 'b, 'c) wit3_F3 = W31 'a 'b "('a, 'b, 'c) wit3_F1" | W32 'c 'a 'b "('a, 'b, 'c) wit3_F1"
-
-codatatype ('c, 'e, 'g) coind_wit1 =
- CW1 'c "('c, 'e, 'g) coind_wit1" "('c, 'e, 'g) ind_wit" "('c, 'e, 'g) coind_wit2"
-and ('c, 'e, 'g) coind_wit2 =
- CW21 "('c, 'e, 'g) coind_wit2" 'e | CW22 'c 'g
-and ('c, 'e, 'g) ind_wit =
- IW1 | IW2 'c
-
-codatatype ('b, 'a) bar = BAR "'a \<Rightarrow> 'b"
-codatatype ('a, 'b, 'c, 'd) foo = FOO "'d + 'b \<Rightarrow> 'c + 'a"
-
-codatatype 'a dead_foo = A
-codatatype ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
-
-(* SLOW, MEMORY-HUNGRY
-codatatype ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
-and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
-and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
-and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
-and ('a, 'c) D5 = A5 "('a, 'c) D6"
-and ('a, 'c) D6 = A6 "('a, 'c) D7"
-and ('a, 'c) D7 = A7 "('a, 'c) D8"
-and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
-*)
-
-end
--- a/src/HOL/BNF/Examples/Misc_Datatype.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,185 +0,0 @@
-(* Title: HOL/BNF/Examples/Misc_Datatype.thy
- Author: Dmitriy Traytel, TU Muenchen
- Author: Andrei Popescu, TU Muenchen
- Author: Jasmin Blanchette, TU Muenchen
- Copyright 2012, 2013
-
-Miscellaneous datatype definitions.
-*)
-
-header {* Miscellaneous Datatype Definitions *}
-
-theory Misc_Datatype
-imports "../BNF"
-begin
-
-datatype_new simple = X1 | X2 | X3 | X4
-
-datatype_new simple' = X1' unit | X2' unit | X3' unit | X4' unit
-
-datatype_new simple'' = X1'' nat int | X2''
-
-datatype_new 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
-
-datatype_new ('b, 'c, 'd, 'e) some_passive =
- SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
-
-datatype_new hfset = HFset "hfset fset"
-
-datatype_new lambda =
- Var string |
- App lambda lambda |
- Abs string lambda |
- Let "(string \<times> lambda) fset" lambda
-
-datatype_new 'a par_lambda =
- PVar 'a |
- PApp "'a par_lambda" "'a par_lambda" |
- PAbs 'a "'a par_lambda" |
- PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
-
-(*
- ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
- ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
-*)
-
-datatype_new 'a I1 = I11 'a "'a I1" | I12 'a "'a I2"
-and 'a I2 = I21 | I22 "'a I1" "'a I2"
-
-datatype_new 'a tree = TEmpty | TNode 'a "'a forest"
-and 'a forest = FNil | FCons "'a tree" "'a forest"
-
-datatype_new 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
-and 'a branch = Branch 'a "'a tree'"
-
-datatype_new ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
-and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
-and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
-
-datatype_new 'a ftree = FTLeaf 'a | FTNode "'a \<Rightarrow> 'a ftree"
-
-datatype_new ('a, 'b, 'c) some_killing =
- SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
-and ('a, 'b, 'c) in_here =
- IH1 'b 'a | IH2 'c
-
-datatype_new 'b nofail1 = NF11 "'b nofail1" 'b | NF12 'b
-datatype_new 'b nofail2 = NF2 "('b nofail2 \<times> 'b \<times> 'b nofail2 \<times> 'b) list"
-datatype_new 'b nofail3 = NF3 'b "('b nofail3 \<times> 'b \<times> 'b nofail3 \<times> 'b) fset"
-datatype_new 'b nofail4 = NF4 "('b nofail4 \<times> ('b nofail4 \<times> 'b \<times> 'b nofail4 \<times> 'b) fset) list"
-
-(*
-datatype_new 'b fail = F "'b fail" 'b "'b fail" "'b list"
-datatype_new 'b fail = F "'b fail" 'b "'b fail" 'b
-datatype_new 'b fail = F1 "'b fail" 'b | F2 "'b fail"
-datatype_new 'b fail = F "'b fail" 'b
-*)
-
-datatype_new l1 = L1 "l2 list"
-and l2 = L21 "l1 fset" | L22 l2
-
-datatype_new kk1 = KK1 kk2
-and kk2 = KK2 kk3
-and kk3 = KK3 "kk1 list"
-
-datatype_new t1 = T11 t3 | T12 t2
-and t2 = T2 t1
-and t3 = T3
-
-datatype_new t1' = T11' t2' | T12' t3'
-and t2' = T2' t1'
-and t3' = T3'
-
-(*
-datatype_new fail1 = F1 fail2
-and fail2 = F2 fail3
-and fail3 = F3 fail1
-
-datatype_new fail1 = F1 "fail2 list" fail2
-and fail2 = F2 "fail2 fset" fail3
-and fail3 = F3 fail1
-
-datatype_new fail1 = F1 "fail2 list" fail2
-and fail2 = F2 "fail1 fset" fail1
-*)
-
-(* SLOW
-datatype_new ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
-and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
-and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
-and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
-and ('a, 'c) D5 = A5 "('a, 'c) D6"
-and ('a, 'c) D6 = A6 "('a, 'c) D7"
-and ('a, 'c) D7 = A7 "('a, 'c) D8"
-and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
-
-(*time comparison*)
-datatype ('a, 'c) D1' = A1' "('a, 'c) D2'" | B1' "'a list"
- and ('a, 'c) D2' = A2' "('a, 'c) D3'" | B2' "'c list"
- and ('a, 'c) D3' = A3' "('a, 'c) D3'" | B3' "('a, 'c) D4'" | C3' "('a, 'c) D4'" "('a, 'c) D5'"
- and ('a, 'c) D4' = A4' "('a, 'c) D5'" | B4' "'a list list list"
- and ('a, 'c) D5' = A5' "('a, 'c) D6'"
- and ('a, 'c) D6' = A6' "('a, 'c) D7'"
- and ('a, 'c) D7' = A7' "('a, 'c) D8'"
- and ('a, 'c) D8' = A8' "('a, 'c) D1' list"
-*)
-
-(* fail:
-datatype_new tt1 = TT11 tt2 tt3 | TT12 tt2 tt4
-and tt2 = TT2
-and tt3 = TT3 tt4
-and tt4 = TT4 tt1
-*)
-
-datatype_new k1 = K11 k2 k3 | K12 k2 k4
-and k2 = K2
-and k3 = K3 k4
-and k4 = K4
-
-datatype_new tt1 = TT11 tt3 tt2 | TT12 tt2 tt4
-and tt2 = TT2
-and tt3 = TT3 tt1
-and tt4 = TT4
-
-(* SLOW
-datatype_new s1 = S11 s2 s3 s4 | S12 s3 | S13 s2 s6 | S14 s4 s2 | S15 s2 s2
-and s2 = S21 s7 s5 | S22 s5 s4 s6
-and s3 = S31 s1 s7 s2 | S32 s3 s3 | S33 s4 s5
-and s4 = S4 s5
-and s5 = S5
-and s6 = S61 s6 | S62 s1 s2 | S63 s6
-and s7 = S71 s8 | S72 s5
-and s8 = S8 nat
-*)
-
-datatype_new 'a deadbar = DeadBar "'a \<Rightarrow> 'a"
-datatype_new 'a deadbar_option = DeadBarOption "'a option \<Rightarrow> 'a option"
-datatype_new ('a, 'b) bar = Bar "'b \<Rightarrow> 'a"
-datatype_new ('a, 'b, 'c, 'd) foo = Foo "'d + 'b \<Rightarrow> 'c + 'a"
-datatype_new 'a deadfoo = DeadFoo "'a \<Rightarrow> 'a + 'a"
-
-datatype_new 'a dead_foo = A
-datatype_new ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
-
-datatype_new d1 = D
-datatype_new d1' = is_D: D
-
-datatype_new d2 = D nat
-datatype_new d2' = is_D: D nat
-
-datatype_new d3 = D | E
-datatype_new d3' = D | is_E: E
-datatype_new d3'' = is_D: D | E
-datatype_new d3''' = is_D: D | is_E: E
-
-datatype_new d4 = D nat | E
-datatype_new d4' = D nat | is_E: E
-datatype_new d4'' = is_D: D nat | E
-datatype_new d4''' = is_D: D nat | is_E: E
-
-datatype_new d5 = D nat | E int
-datatype_new d5' = D nat | is_E: E int
-datatype_new d5'' = is_D: D nat | E int
-datatype_new d5''' = is_D: D nat | is_E: E int
-
-end
--- a/src/HOL/BNF/Examples/Misc_Primcorec.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,112 +0,0 @@
-(* Title: HOL/BNF/Examples/Misc_Primcorec.thy
- Author: Jasmin Blanchette, TU Muenchen
- Copyright 2013
-
-Miscellaneous primitive corecursive function definitions.
-*)
-
-header {* Miscellaneous Primitive Corecursive Function Definitions *}
-
-theory Misc_Primcorec
-imports Misc_Codatatype
-begin
-
-primcorec simple_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple" where
- "simple_of_bools b b' = (if b then if b' then X1 else X2 else if b' then X3 else X4)"
-
-primcorec simple'_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple'" where
- "simple'_of_bools b b' =
- (if b then if b' then X1' () else X2' () else if b' then X3' () else X4' ())"
-
-primcorec inc_simple'' :: "nat \<Rightarrow> simple'' \<Rightarrow> simple''" where
- "inc_simple'' k s = (case s of X1'' n i \<Rightarrow> X1'' (n + k) (i + int k) | X2'' \<Rightarrow> X2'')"
-
-primcorec sinterleave :: "'a stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
- "sinterleave s s' = Stream (shd s) (sinterleave s' (stl s))"
-
-primcorec myapp :: "'a mylist \<Rightarrow> 'a mylist \<Rightarrow> 'a mylist" where
- "myapp xs ys =
- (if xs = MyNil then ys
- else if ys = MyNil then xs
- else MyCons (myhd xs) (myapp (mytl xs) ys))"
-
-primcorec shuffle_sp :: "('a, 'b, 'c, 'd) some_passive \<Rightarrow> ('d, 'a, 'b, 'c) some_passive" where
- "shuffle_sp sp =
- (case sp of
- SP1 sp' \<Rightarrow> SP1 (shuffle_sp sp')
- | SP2 a \<Rightarrow> SP3 a
- | SP3 b \<Rightarrow> SP4 b
- | SP4 c \<Rightarrow> SP5 c
- | SP5 d \<Rightarrow> SP2 d)"
-
-primcorec rename_lam :: "(string \<Rightarrow> string) \<Rightarrow> lambda \<Rightarrow> lambda" where
- "rename_lam f l =
- (case l of
- Var s \<Rightarrow> Var (f s)
- | App l l' \<Rightarrow> App (rename_lam f l) (rename_lam f l')
- | Abs s l \<Rightarrow> Abs (f s) (rename_lam f l)
- | Let SL l \<Rightarrow> Let (fimage (map_pair f (rename_lam f)) SL) (rename_lam f l))"
-
-primcorec
- j1_sum :: "('a\<Colon>{zero,one,plus}) \<Rightarrow> 'a J1" and
- j2_sum :: "'a \<Rightarrow> 'a J2"
-where
- "n = 0 \<Longrightarrow> is_J11 (j1_sum n)" |
- "un_J111 (j1_sum _) = 0" |
- "un_J112 (j1_sum _) = j1_sum 0" |
- "un_J121 (j1_sum n) = n + 1" |
- "un_J122 (j1_sum n) = j2_sum (n + 1)" |
- "n = 0 \<Longrightarrow> is_J21 (j2_sum n)" |
- "un_J221 (j2_sum n) = j1_sum (n + 1)" |
- "un_J222 (j2_sum n) = j2_sum (n + 1)"
-
-primcorec forest_of_mylist :: "'a tree mylist \<Rightarrow> 'a forest" where
- "forest_of_mylist ts =
- (case ts of
- MyNil \<Rightarrow> FNil
- | MyCons t ts \<Rightarrow> FCons t (forest_of_mylist ts))"
-
-primcorec mylist_of_forest :: "'a forest \<Rightarrow> 'a tree mylist" where
- "mylist_of_forest f =
- (case f of
- FNil \<Rightarrow> MyNil
- | FCons t ts \<Rightarrow> MyCons t (mylist_of_forest ts))"
-
-primcorec semi_stream :: "'a stream \<Rightarrow> 'a stream" where
- "semi_stream s = Stream (shd s) (semi_stream (stl (stl s)))"
-
-primcorec
- tree'_of_stream :: "'a stream \<Rightarrow> 'a tree'" and
- branch_of_stream :: "'a stream \<Rightarrow> 'a branch"
-where
- "tree'_of_stream s =
- TNode' (branch_of_stream (semi_stream s)) (branch_of_stream (semi_stream (stl s)))" |
- "branch_of_stream s = (case s of Stream h t \<Rightarrow> Branch h (tree'_of_stream t))"
-
-primcorec
- freeze_exp :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) exp \<Rightarrow> ('a, 'b) exp" and
- freeze_trm :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) trm \<Rightarrow> ('a, 'b) trm" and
- freeze_factor :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) factor \<Rightarrow> ('a, 'b) factor"
-where
- "freeze_exp g e =
- (case e of
- Term t \<Rightarrow> Term (freeze_trm g t)
- | Sum t e \<Rightarrow> Sum (freeze_trm g t) (freeze_exp g e))" |
- "freeze_trm g t =
- (case t of
- Factor f \<Rightarrow> Factor (freeze_factor g f)
- | Prod f t \<Rightarrow> Prod (freeze_factor g f) (freeze_trm g t))" |
- "freeze_factor g f =
- (case f of
- C a \<Rightarrow> C a
- | V b \<Rightarrow> C (g b)
- | Paren e \<Rightarrow> Paren (freeze_exp g e))"
-
-primcorec poly_unity :: "'a poly_unit" where
- "poly_unity = U (\<lambda>_. poly_unity)"
-
-primcorec build_cps :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool stream) \<Rightarrow> 'a \<Rightarrow> bool stream \<Rightarrow> 'a cps" where
- "shd b \<Longrightarrow> build_cps f g a b = CPS1 a" |
- "_ \<Longrightarrow> build_cps f g a b = CPS2 (\<lambda>a. build_cps f g (f a) (g a))"
-
-end
--- a/src/HOL/BNF/Examples/Misc_Primrec.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,114 +0,0 @@
-(* Title: HOL/BNF/Examples/Misc_Primrec.thy
- Author: Jasmin Blanchette, TU Muenchen
- Copyright 2013
-
-Miscellaneous primitive recursive function definitions.
-*)
-
-header {* Miscellaneous Primitive Recursive Function Definitions *}
-
-theory Misc_Primrec
-imports Misc_Datatype
-begin
-
-primrec_new nat_of_simple :: "simple \<Rightarrow> nat" where
- "nat_of_simple X1 = 1" |
- "nat_of_simple X2 = 2" |
- "nat_of_simple X3 = 3" |
- "nat_of_simple X4 = 4"
-
-primrec_new simple_of_simple' :: "simple' \<Rightarrow> simple" where
- "simple_of_simple' (X1' _) = X1" |
- "simple_of_simple' (X2' _) = X2" |
- "simple_of_simple' (X3' _) = X3" |
- "simple_of_simple' (X4' _) = X4"
-
-primrec_new inc_simple'' :: "nat \<Rightarrow> simple'' \<Rightarrow> simple''" where
- "inc_simple'' k (X1'' n i) = X1'' (n + k) (i + int k)" |
- "inc_simple'' _ X2'' = X2''"
-
-primrec_new myapp :: "'a mylist \<Rightarrow> 'a mylist \<Rightarrow> 'a mylist" where
- "myapp MyNil ys = ys" |
- "myapp (MyCons x xs) ys = MyCons x (myapp xs ys)"
-
-primrec_new myrev :: "'a mylist \<Rightarrow> 'a mylist" where
- "myrev MyNil = MyNil" |
- "myrev (MyCons x xs) = myapp (myrev xs) (MyCons x MyNil)"
-
-primrec_new shuffle_sp :: "('a, 'b, 'c, 'd) some_passive \<Rightarrow> ('d, 'a, 'b, 'c) some_passive" where
- "shuffle_sp (SP1 sp) = SP1 (shuffle_sp sp)" |
- "shuffle_sp (SP2 a) = SP3 a" |
- "shuffle_sp (SP3 b) = SP4 b" |
- "shuffle_sp (SP4 c) = SP5 c" |
- "shuffle_sp (SP5 d) = SP2 d"
-
-primrec_new
- hf_size :: "hfset \<Rightarrow> nat"
-where
- "hf_size (HFset X) = 1 + setsum id (fset (fimage hf_size X))"
-
-primrec_new rename_lam :: "(string \<Rightarrow> string) \<Rightarrow> lambda \<Rightarrow> lambda" where
- "rename_lam f (Var s) = Var (f s)" |
- "rename_lam f (App l l') = App (rename_lam f l) (rename_lam f l')" |
- "rename_lam f (Abs s l) = Abs (f s) (rename_lam f l)" |
- "rename_lam f (Let SL l) = Let (fimage (map_pair f (rename_lam f)) SL) (rename_lam f l)"
-
-primrec_new
- sum_i1 :: "('a\<Colon>{zero,plus}) I1 \<Rightarrow> 'a" and
- sum_i2 :: "'a I2 \<Rightarrow> 'a"
-where
- "sum_i1 (I11 n i) = n + sum_i1 i" |
- "sum_i1 (I12 n i) = n + sum_i2 i" |
- "sum_i2 I21 = 0" |
- "sum_i2 (I22 i j) = sum_i1 i + sum_i2 j"
-
-primrec_new forest_of_mylist :: "'a tree mylist \<Rightarrow> 'a forest" where
- "forest_of_mylist MyNil = FNil" |
- "forest_of_mylist (MyCons t ts) = FCons t (forest_of_mylist ts)"
-
-primrec_new mylist_of_forest :: "'a forest \<Rightarrow> 'a tree mylist" where
- "mylist_of_forest FNil = MyNil" |
- "mylist_of_forest (FCons t ts) = MyCons t (mylist_of_forest ts)"
-
-definition frev :: "'a forest \<Rightarrow> 'a forest" where
- "frev = forest_of_mylist \<circ> myrev \<circ> mylist_of_forest"
-
-primrec_new
- mirror_tree :: "'a tree \<Rightarrow> 'a tree" and
- mirror_forest :: "'a forest \<Rightarrow> 'a forest"
-where
- "mirror_tree TEmpty = TEmpty" |
- "mirror_tree (TNode x ts) = TNode x (mirror_forest ts)" |
- "mirror_forest FNil = FNil" |
- "mirror_forest (FCons t ts) = frev (FCons (mirror_tree t) (mirror_forest ts))"
-
-primrec_new
- mylist_of_tree' :: "'a tree' \<Rightarrow> 'a mylist" and
- mylist_of_branch :: "'a branch \<Rightarrow> 'a mylist"
-where
- "mylist_of_tree' TEmpty' = MyNil" |
- "mylist_of_tree' (TNode' b b') = myapp (mylist_of_branch b) (mylist_of_branch b')" |
- "mylist_of_branch (Branch x t) = MyCons x (mylist_of_tree' t)"
-
-primrec_new
- is_ground_exp :: "('a, 'b) exp \<Rightarrow> bool" and
- is_ground_trm :: "('a, 'b) trm \<Rightarrow> bool" and
- is_ground_factor :: "('a, 'b) factor \<Rightarrow> bool"
-where
- "is_ground_exp (Term t) \<longleftrightarrow> is_ground_trm t" |
- "is_ground_exp (Sum t e) \<longleftrightarrow> is_ground_trm t \<and> is_ground_exp e" |
- "is_ground_trm (Factor f) \<longleftrightarrow> is_ground_factor f" |
- "is_ground_trm (Prod f t) \<longleftrightarrow> is_ground_factor f \<and> is_ground_trm t" |
- "is_ground_factor (C _) \<longleftrightarrow> True" |
- "is_ground_factor (V _) \<longleftrightarrow> False" |
- "is_ground_factor (Paren e) \<longleftrightarrow> is_ground_exp e"
-
-primrec_new map_ftreeA :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
- "map_ftreeA f (FTLeaf x) = FTLeaf (f x)" |
- "map_ftreeA f (FTNode g) = FTNode (map_ftreeA f \<circ> g)"
-
-primrec_new map_ftreeB :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ftree \<Rightarrow> 'b ftree" where
- "map_ftreeB f (FTLeaf x) = FTLeaf (f x)" |
- "map_ftreeB f (FTNode g) = FTNode (map_ftreeB f \<circ> g \<circ> the_inv f)"
-
-end
--- a/src/HOL/BNF/Examples/Process.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,278 +0,0 @@
-(* Title: HOL/BNF/Examples/Process.thy
- Author: Andrei Popescu, TU Muenchen
- Copyright 2012
-
-Processes.
-*)
-
-header {* Processes *}
-
-theory Process
-imports Stream
-begin
-
-codatatype 'a process =
- isAction: Action (prefOf: 'a) (contOf: "'a process") |
- isChoice: Choice (ch1Of: "'a process") (ch2Of: "'a process")
-
-(* Read: prefix of, continuation of, choice 1 of, choice 2 of *)
-
-section {* Customization *}
-
-subsection {* Basic properties *}
-
-declare
- rel_pre_process_def[simp]
- sum_rel_def[simp]
- prod_rel_def[simp]
-
-(* Constructors versus discriminators *)
-theorem isAction_isChoice:
-"isAction p \<or> isChoice p"
-by (rule process.disc_exhaust) auto
-
-theorem not_isAction_isChoice: "\<not> (isAction p \<and> isChoice p)"
-by (cases rule: process.exhaust[of p]) auto
-
-
-subsection{* Coinduction *}
-
-theorem process_coind[elim, consumes 1, case_names iss Action Choice, induct pred: "HOL.eq"]:
- assumes phi: "\<phi> p p'" and
- iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
- Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> \<phi> p p'" and
- Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> \<phi> p p' \<and> \<phi> q q'"
- shows "p = p'"
- using assms
- by (coinduct rule: process.coinduct) (metis process.collapse(1,2) process.disc(3))
-
-(* Stronger coinduction, up to equality: *)
-theorem process_strong_coind[elim, consumes 1, case_names iss Action Choice]:
- assumes phi: "\<phi> p p'" and
- iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
- Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> (\<phi> p p' \<or> p = p')" and
- Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> (\<phi> p p' \<or> p = p') \<and> (\<phi> q q' \<or> q = q')"
- shows "p = p'"
- using assms
- by (coinduct rule: process.strong_coinduct) (metis process.collapse(1,2) process.disc(3))
-
-
-subsection {* Coiteration (unfold) *}
-
-
-section{* Coinductive definition of the notion of trace *}
-coinductive trace where
-"trace p as \<Longrightarrow> trace (Action a p) (a ## as)"
-|
-"trace p as \<or> trace q as \<Longrightarrow> trace (Choice p q) as"
-
-
-section{* Examples of corecursive definitions: *}
-
-subsection{* Single-guard fixpoint definition *}
-
-primcorec BX where
- "isAction BX"
-| "prefOf BX = ''a''"
-| "contOf BX = BX"
-
-
-subsection{* Multi-guard fixpoint definitions, simulated with auxiliary arguments *}
-
-datatype x_y_ax = x | y | ax
-
-primcorec F :: "x_y_ax \<Rightarrow> char list process" where
- "xyax = x \<Longrightarrow> isChoice (F xyax)"
-| "ch1Of (F xyax) = F ax"
-| "ch2Of (F xyax) = F y"
-| "prefOf (F xyax) = (if xyax = y then ''b'' else ''a'')"
-| "contOf (F xyax) = F x"
-
-definition "X = F x" definition "Y = F y" definition "AX = F ax"
-
-lemma X_Y_AX: "X = Choice AX Y" "Y = Action ''b'' X" "AX = Action ''a'' X"
-unfolding X_def Y_def AX_def by (subst F.code, simp)+
-
-(* end product: *)
-lemma X_AX:
-"X = Choice AX (Action ''b'' X)"
-"AX = Action ''a'' X"
-using X_Y_AX by simp_all
-
-
-
-section{* Case study: Multi-guard fixpoint definitions, without auxiliary arguments *}
-
-hide_const x y ax X Y AX
-
-(* Process terms *)
-datatype ('a,'pvar) process_term =
- VAR 'pvar |
- PROC "'a process" |
- ACT 'a "('a,'pvar) process_term" | CH "('a,'pvar) process_term" "('a,'pvar) process_term"
-
-(* below, sys represents a system of equations *)
-fun isACT where
-"isACT sys (VAR X) =
- (case sys X of ACT a T \<Rightarrow> True |PROC p \<Rightarrow> isAction p |_ \<Rightarrow> False)"
-|
-"isACT sys (PROC p) = isAction p"
-|
-"isACT sys (ACT a T) = True"
-|
-"isACT sys (CH T1 T2) = False"
-
-fun PREF where
-"PREF sys (VAR X) =
- (case sys X of ACT a T \<Rightarrow> a | PROC p \<Rightarrow> prefOf p)"
-|
-"PREF sys (PROC p) = prefOf p"
-|
-"PREF sys (ACT a T) = a"
-
-fun CONT where
-"CONT sys (VAR X) =
- (case sys X of ACT a T \<Rightarrow> T | PROC p \<Rightarrow> PROC (contOf p))"
-|
-"CONT sys (PROC p) = PROC (contOf p)"
-|
-"CONT sys (ACT a T) = T"
-
-fun CH1 where
-"CH1 sys (VAR X) =
- (case sys X of CH T1 T2 \<Rightarrow> T1 |PROC p \<Rightarrow> PROC (ch1Of p))"
-|
-"CH1 sys (PROC p) = PROC (ch1Of p)"
-|
-"CH1 sys (CH T1 T2) = T1"
-
-fun CH2 where
-"CH2 sys (VAR X) =
- (case sys X of CH T1 T2 \<Rightarrow> T2 |PROC p \<Rightarrow> PROC (ch2Of p))"
-|
-"CH2 sys (PROC p) = PROC (ch2Of p)"
-|
-"CH2 sys (CH T1 T2) = T2"
-
-definition "guarded sys \<equiv> \<forall> X Y. sys X \<noteq> VAR Y"
-
-primcorec solution where
- "isACT sys T \<Longrightarrow> solution sys T = Action (PREF sys T) (solution sys (CONT sys T))"
-| "_ \<Longrightarrow> solution sys T = Choice (solution sys (CH1 sys T)) (solution sys (CH2 sys T))"
-
-lemma isACT_VAR:
-assumes g: "guarded sys"
-shows "isACT sys (VAR X) \<longleftrightarrow> isACT sys (sys X)"
-using g unfolding guarded_def by (cases "sys X") auto
-
-lemma solution_VAR:
-assumes g: "guarded sys"
-shows "solution sys (VAR X) = solution sys (sys X)"
-proof(cases "isACT sys (VAR X)")
- case True
- hence T: "isACT sys (sys X)" unfolding isACT_VAR[OF g] .
- show ?thesis
- unfolding solution.ctr(1)[OF T] using solution.ctr(1)[of sys "VAR X"] True g
- unfolding guarded_def by (cases "sys X", auto)
-next
- case False note FFalse = False
- hence TT: "\<not> isACT sys (sys X)" unfolding isACT_VAR[OF g] .
- show ?thesis
- unfolding solution.ctr(2)[OF TT] using solution.ctr(2)[of sys "VAR X"] FFalse g
- unfolding guarded_def by (cases "sys X", auto)
-qed
-
-lemma solution_PROC[simp]:
-"solution sys (PROC p) = p"
-proof-
- {fix q assume "q = solution sys (PROC p)"
- hence "p = q"
- proof (coinduct rule: process_coind)
- case (iss p p')
- from isAction_isChoice[of p] show ?case
- proof
- assume p: "isAction p"
- hence 0: "isACT sys (PROC p)" by simp
- thus ?thesis using iss not_isAction_isChoice by auto
- next
- assume "isChoice p"
- hence 0: "\<not> isACT sys (PROC p)"
- using not_isAction_isChoice by auto
- thus ?thesis using iss isAction_isChoice by auto
- qed
- next
- case (Action a a' p p')
- hence 0: "isACT sys (PROC (Action a p))" by simp
- show ?case using Action unfolding solution.ctr(1)[OF 0] by simp
- next
- case (Choice p q p' q')
- hence 0: "\<not> isACT sys (PROC (Choice p q))" using not_isAction_isChoice by auto
- show ?case using Choice unfolding solution.ctr(2)[OF 0] by simp
- qed
- }
- thus ?thesis by metis
-qed
-
-lemma solution_ACT[simp]:
-"solution sys (ACT a T) = Action a (solution sys T)"
-by (metis CONT.simps(3) PREF.simps(3) isACT.simps(3) solution.ctr(1))
-
-lemma solution_CH[simp]:
-"solution sys (CH T1 T2) = Choice (solution sys T1) (solution sys T2)"
-by (metis CH1.simps(3) CH2.simps(3) isACT.simps(4) solution.ctr(2))
-
-
-(* Example: *)
-
-fun sys where
-"sys 0 = CH (VAR (Suc 0)) (ACT ''b'' (VAR 0))"
-|
-"sys (Suc 0) = ACT ''a'' (VAR 0)"
-| (* dummy guarded term for variables outside the system: *)
-"sys X = ACT ''a'' (VAR 0)"
-
-lemma guarded_sys:
-"guarded sys"
-unfolding guarded_def proof (intro allI)
- fix X Y show "sys X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
-qed
-
-(* the actual processes: *)
-definition "x \<equiv> solution sys (VAR 0)"
-definition "ax \<equiv> solution sys (VAR (Suc 0))"
-
-(* end product: *)
-lemma x_ax:
-"x = Choice ax (Action ''b'' x)"
-"ax = Action ''a'' x"
-unfolding x_def ax_def by (subst solution_VAR[OF guarded_sys], simp)+
-
-
-(* Thanks to the inclusion of processes as process terms, one can
-also consider parametrized systems of equations---here, x is a (semantic)
-process parameter: *)
-
-fun sys' where
-"sys' 0 = CH (PROC x) (ACT ''b'' (VAR 0))"
-|
-"sys' (Suc 0) = CH (ACT ''a'' (VAR 0)) (PROC x)"
-| (* dummy guarded term : *)
-"sys' X = ACT ''a'' (VAR 0)"
-
-lemma guarded_sys':
-"guarded sys'"
-unfolding guarded_def proof (intro allI)
- fix X Y show "sys' X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
-qed
-
-(* the actual processes: *)
-definition "y \<equiv> solution sys' (VAR 0)"
-definition "ay \<equiv> solution sys' (VAR (Suc 0))"
-
-(* end product: *)
-lemma y_ay:
-"y = Choice x (Action ''b'' y)"
-"ay = Choice (Action ''a'' y) x"
-unfolding y_def ay_def by (subst solution_VAR[OF guarded_sys'], simp)+
-
-end
--- a/src/HOL/BNF/Examples/Stream.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,526 +0,0 @@
-(* Title: HOL/BNF/Examples/Stream.thy
- Author: Dmitriy Traytel, TU Muenchen
- Author: Andrei Popescu, TU Muenchen
- Copyright 2012, 2013
-
-Infinite streams.
-*)
-
-header {* Infinite Streams *}
-
-theory Stream
-imports "~~/Library/Nat_Bijection"
-begin
-
-codatatype (sset: 'a) stream (map: smap rel: stream_all2) =
- SCons (shd: 'a) (stl: "'a stream") (infixr "##" 65)
-
-(*for code generation only*)
-definition smember :: "'a \<Rightarrow> 'a stream \<Rightarrow> bool" where
- [code_abbrev]: "smember x s \<longleftrightarrow> x \<in> sset s"
-
-lemma smember_code[code, simp]: "smember x (y ## s) = (if x = y then True else smember x s)"
- unfolding smember_def by auto
-
-hide_const (open) smember
-
-(* TODO: Provide by the package*)
-theorem sset_induct:
- "\<lbrakk>\<And>s. P (shd s) s; \<And>s y. \<lbrakk>y \<in> sset (stl s); P y (stl s)\<rbrakk> \<Longrightarrow> P y s\<rbrakk> \<Longrightarrow>
- \<forall>y \<in> sset s. P y s"
- apply (rule stream.dtor_set_induct)
- apply (auto simp add: shd_def stl_def fsts_def snds_def split_beta)
- apply (metis SCons_def fst_conv stream.case stream.dtor_ctor stream.exhaust)
- by (metis SCons_def sndI stl_def stream.collapse stream.dtor_ctor)
-
-lemma smap_simps[simp]:
- "shd (smap f s) = f (shd s)" "stl (smap f s) = smap f (stl s)"
- by (case_tac [!] s) auto
-
-theorem shd_sset: "shd s \<in> sset s"
- by (case_tac s) auto
-
-theorem stl_sset: "y \<in> sset (stl s) \<Longrightarrow> y \<in> sset s"
- by (case_tac s) auto
-
-(* only for the non-mutual case: *)
-theorem sset_induct1[consumes 1, case_names shd stl, induct set: "sset"]:
- assumes "y \<in> sset s" and "\<And>s. P (shd s) s"
- and "\<And>s y. \<lbrakk>y \<in> sset (stl s); P y (stl s)\<rbrakk> \<Longrightarrow> P y s"
- shows "P y s"
- using assms sset_induct by blast
-(* end TODO *)
-
-
-subsection {* prepend list to stream *}
-
-primrec shift :: "'a list \<Rightarrow> 'a stream \<Rightarrow> 'a stream" (infixr "@-" 65) where
- "shift [] s = s"
-| "shift (x # xs) s = x ## shift xs s"
-
-lemma smap_shift[simp]: "smap f (xs @- s) = map f xs @- smap f s"
- by (induct xs) auto
-
-lemma shift_append[simp]: "(xs @ ys) @- s = xs @- ys @- s"
- by (induct xs) auto
-
-lemma shift_simps[simp]:
- "shd (xs @- s) = (if xs = [] then shd s else hd xs)"
- "stl (xs @- s) = (if xs = [] then stl s else tl xs @- s)"
- by (induct xs) auto
-
-lemma sset_shift[simp]: "sset (xs @- s) = set xs \<union> sset s"
- by (induct xs) auto
-
-lemma shift_left_inj[simp]: "xs @- s1 = xs @- s2 \<longleftrightarrow> s1 = s2"
- by (induct xs) auto
-
-
-subsection {* set of streams with elements in some fixed set *}
-
-coinductive_set
- streams :: "'a set \<Rightarrow> 'a stream set"
- for A :: "'a set"
-where
- Stream[intro!, simp, no_atp]: "\<lbrakk>a \<in> A; s \<in> streams A\<rbrakk> \<Longrightarrow> a ## s \<in> streams A"
-
-lemma shift_streams: "\<lbrakk>w \<in> lists A; s \<in> streams A\<rbrakk> \<Longrightarrow> w @- s \<in> streams A"
- by (induct w) auto
-
-lemma streams_Stream: "x ## s \<in> streams A \<longleftrightarrow> x \<in> A \<and> s \<in> streams A"
- by (auto elim: streams.cases)
-
-lemma streams_stl: "s \<in> streams A \<Longrightarrow> stl s \<in> streams A"
- by (cases s) (auto simp: streams_Stream)
-
-lemma streams_shd: "s \<in> streams A \<Longrightarrow> shd s \<in> A"
- by (cases s) (auto simp: streams_Stream)
-
-lemma sset_streams:
- assumes "sset s \<subseteq> A"
- shows "s \<in> streams A"
-using assms proof (coinduction arbitrary: s)
- case streams then show ?case by (cases s) simp
-qed
-
-lemma streams_sset:
- assumes "s \<in> streams A"
- shows "sset s \<subseteq> A"
-proof
- fix x assume "x \<in> sset s" from this `s \<in> streams A` show "x \<in> A"
- by (induct s) (auto intro: streams_shd streams_stl)
-qed
-
-lemma streams_iff_sset: "s \<in> streams A \<longleftrightarrow> sset s \<subseteq> A"
- by (metis sset_streams streams_sset)
-
-lemma streams_mono: "s \<in> streams A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> s \<in> streams B"
- unfolding streams_iff_sset by auto
-
-lemma smap_streams: "s \<in> streams A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<in> B) \<Longrightarrow> smap f s \<in> streams B"
- unfolding streams_iff_sset stream.set_map by auto
-
-lemma streams_empty: "streams {} = {}"
- by (auto elim: streams.cases)
-
-lemma streams_UNIV[simp]: "streams UNIV = UNIV"
- by (auto simp: streams_iff_sset)
-
-subsection {* nth, take, drop for streams *}
-
-primrec snth :: "'a stream \<Rightarrow> nat \<Rightarrow> 'a" (infixl "!!" 100) where
- "s !! 0 = shd s"
-| "s !! Suc n = stl s !! n"
-
-lemma snth_smap[simp]: "smap f s !! n = f (s !! n)"
- by (induct n arbitrary: s) auto
-
-lemma shift_snth_less[simp]: "p < length xs \<Longrightarrow> (xs @- s) !! p = xs ! p"
- by (induct p arbitrary: xs) (auto simp: hd_conv_nth nth_tl)
-
-lemma shift_snth_ge[simp]: "p \<ge> length xs \<Longrightarrow> (xs @- s) !! p = s !! (p - length xs)"
- by (induct p arbitrary: xs) (auto simp: Suc_diff_eq_diff_pred)
-
-lemma snth_sset[simp]: "s !! n \<in> sset s"
- by (induct n arbitrary: s) (auto intro: shd_sset stl_sset)
-
-lemma sset_range: "sset s = range (snth s)"
-proof (intro equalityI subsetI)
- fix x assume "x \<in> sset s"
- thus "x \<in> range (snth s)"
- proof (induct s)
- case (stl s x)
- then obtain n where "x = stl s !! n" by auto
- thus ?case by (auto intro: range_eqI[of _ _ "Suc n"])
- qed (auto intro: range_eqI[of _ _ 0])
-qed auto
-
-primrec stake :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a list" where
- "stake 0 s = []"
-| "stake (Suc n) s = shd s # stake n (stl s)"
-
-lemma length_stake[simp]: "length (stake n s) = n"
- by (induct n arbitrary: s) auto
-
-lemma stake_smap[simp]: "stake n (smap f s) = map f (stake n s)"
- by (induct n arbitrary: s) auto
-
-primrec sdrop :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
- "sdrop 0 s = s"
-| "sdrop (Suc n) s = sdrop n (stl s)"
-
-lemma sdrop_simps[simp]:
- "shd (sdrop n s) = s !! n" "stl (sdrop n s) = sdrop (Suc n) s"
- by (induct n arbitrary: s) auto
-
-lemma sdrop_smap[simp]: "sdrop n (smap f s) = smap f (sdrop n s)"
- by (induct n arbitrary: s) auto
-
-lemma sdrop_stl: "sdrop n (stl s) = stl (sdrop n s)"
- by (induct n) auto
-
-lemma stake_sdrop: "stake n s @- sdrop n s = s"
- by (induct n arbitrary: s) auto
-
-lemma id_stake_snth_sdrop:
- "s = stake i s @- s !! i ## sdrop (Suc i) s"
- by (subst stake_sdrop[symmetric, of _ i]) (metis sdrop_simps stream.collapse)
-
-lemma smap_alt: "smap f s = s' \<longleftrightarrow> (\<forall>n. f (s !! n) = s' !! n)" (is "?L = ?R")
-proof
- assume ?R
- then have "\<And>n. smap f (sdrop n s) = sdrop n s'"
- by coinduction (auto intro: exI[of _ 0] simp del: sdrop.simps(2))
- then show ?L using sdrop.simps(1) by metis
-qed auto
-
-lemma stake_invert_Nil[iff]: "stake n s = [] \<longleftrightarrow> n = 0"
- by (induct n) auto
-
-lemma sdrop_shift: "\<lbrakk>s = w @- s'; length w = n\<rbrakk> \<Longrightarrow> sdrop n s = s'"
- by (induct n arbitrary: w s) auto
-
-lemma stake_shift: "\<lbrakk>s = w @- s'; length w = n\<rbrakk> \<Longrightarrow> stake n s = w"
- by (induct n arbitrary: w s) auto
-
-lemma stake_add[simp]: "stake m s @ stake n (sdrop m s) = stake (m + n) s"
- by (induct m arbitrary: s) auto
-
-lemma sdrop_add[simp]: "sdrop n (sdrop m s) = sdrop (m + n) s"
- by (induct m arbitrary: s) auto
-
-partial_function (tailrec) sdrop_while :: "('a \<Rightarrow> bool) \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
- "sdrop_while P s = (if P (shd s) then sdrop_while P (stl s) else s)"
-
-lemma sdrop_while_SCons[code]:
- "sdrop_while P (a ## s) = (if P a then sdrop_while P s else a ## s)"
- by (subst sdrop_while.simps) simp
-
-lemma sdrop_while_sdrop_LEAST:
- assumes "\<exists>n. P (s !! n)"
- shows "sdrop_while (Not o P) s = sdrop (LEAST n. P (s !! n)) s"
-proof -
- from assms obtain m where "P (s !! m)" "\<And>n. P (s !! n) \<Longrightarrow> m \<le> n"
- and *: "(LEAST n. P (s !! n)) = m" by atomize_elim (auto intro: LeastI Least_le)
- thus ?thesis unfolding *
- proof (induct m arbitrary: s)
- case (Suc m)
- hence "sdrop_while (Not \<circ> P) (stl s) = sdrop m (stl s)"
- by (metis (full_types) not_less_eq_eq snth.simps(2))
- moreover from Suc(3) have "\<not> (P (s !! 0))" by blast
- ultimately show ?case by (subst sdrop_while.simps) simp
- qed (metis comp_apply sdrop.simps(1) sdrop_while.simps snth.simps(1))
-qed
-
-primcorec sfilter where
- "shd (sfilter P s) = shd (sdrop_while (Not o P) s)"
-| "stl (sfilter P s) = sfilter P (stl (sdrop_while (Not o P) s))"
-
-lemma sfilter_Stream: "sfilter P (x ## s) = (if P x then x ## sfilter P s else sfilter P s)"
-proof (cases "P x")
- case True thus ?thesis by (subst sfilter.ctr) (simp add: sdrop_while_SCons)
-next
- case False thus ?thesis by (subst (1 2) sfilter.ctr) (simp add: sdrop_while_SCons)
-qed
-
-
-subsection {* unary predicates lifted to streams *}
-
-definition "stream_all P s = (\<forall>p. P (s !! p))"
-
-lemma stream_all_iff[iff]: "stream_all P s \<longleftrightarrow> Ball (sset s) P"
- unfolding stream_all_def sset_range by auto
-
-lemma stream_all_shift[simp]: "stream_all P (xs @- s) = (list_all P xs \<and> stream_all P s)"
- unfolding stream_all_iff list_all_iff by auto
-
-lemma stream_all_Stream: "stream_all P (x ## X) \<longleftrightarrow> P x \<and> stream_all P X"
- by simp
-
-
-subsection {* recurring stream out of a list *}
-
-primcorec cycle :: "'a list \<Rightarrow> 'a stream" where
- "shd (cycle xs) = hd xs"
-| "stl (cycle xs) = cycle (tl xs @ [hd xs])"
-
-lemma cycle_decomp: "u \<noteq> [] \<Longrightarrow> cycle u = u @- cycle u"
-proof (coinduction arbitrary: u)
- case Eq_stream then show ?case using stream.collapse[of "cycle u"]
- by (auto intro!: exI[of _ "tl u @ [hd u]"])
-qed
-
-lemma cycle_Cons[code]: "cycle (x # xs) = x ## cycle (xs @ [x])"
- by (subst cycle.ctr) simp
-
-lemma cycle_rotated: "\<lbrakk>v \<noteq> []; cycle u = v @- s\<rbrakk> \<Longrightarrow> cycle (tl u @ [hd u]) = tl v @- s"
- by (auto dest: arg_cong[of _ _ stl])
-
-lemma stake_append: "stake n (u @- s) = take (min (length u) n) u @ stake (n - length u) s"
-proof (induct n arbitrary: u)
- case (Suc n) thus ?case by (cases u) auto
-qed auto
-
-lemma stake_cycle_le[simp]:
- assumes "u \<noteq> []" "n < length u"
- shows "stake n (cycle u) = take n u"
-using min_absorb2[OF less_imp_le_nat[OF assms(2)]]
- by (subst cycle_decomp[OF assms(1)], subst stake_append) auto
-
-lemma stake_cycle_eq[simp]: "u \<noteq> [] \<Longrightarrow> stake (length u) (cycle u) = u"
- by (metis cycle_decomp stake_shift)
-
-lemma sdrop_cycle_eq[simp]: "u \<noteq> [] \<Longrightarrow> sdrop (length u) (cycle u) = cycle u"
- by (metis cycle_decomp sdrop_shift)
-
-lemma stake_cycle_eq_mod_0[simp]: "\<lbrakk>u \<noteq> []; n mod length u = 0\<rbrakk> \<Longrightarrow>
- stake n (cycle u) = concat (replicate (n div length u) u)"
- by (induct "n div length u" arbitrary: n u) (auto simp: stake_add[symmetric])
-
-lemma sdrop_cycle_eq_mod_0[simp]: "\<lbrakk>u \<noteq> []; n mod length u = 0\<rbrakk> \<Longrightarrow>
- sdrop n (cycle u) = cycle u"
- by (induct "n div length u" arbitrary: n u) (auto simp: sdrop_add[symmetric])
-
-lemma stake_cycle: "u \<noteq> [] \<Longrightarrow>
- stake n (cycle u) = concat (replicate (n div length u) u) @ take (n mod length u) u"
- by (subst mod_div_equality[of n "length u", symmetric], unfold stake_add[symmetric]) auto
-
-lemma sdrop_cycle: "u \<noteq> [] \<Longrightarrow> sdrop n (cycle u) = cycle (rotate (n mod length u) u)"
- by (induct n arbitrary: u) (auto simp: rotate1_rotate_swap rotate1_hd_tl rotate_conv_mod[symmetric])
-
-
-subsection {* iterated application of a function *}
-
-primcorec siterate where
- "shd (siterate f x) = x"
-| "stl (siterate f x) = siterate f (f x)"
-
-lemma stake_Suc: "stake (Suc n) s = stake n s @ [s !! n]"
- by (induct n arbitrary: s) auto
-
-lemma snth_siterate[simp]: "siterate f x !! n = (f^^n) x"
- by (induct n arbitrary: x) (auto simp: funpow_swap1)
-
-lemma sdrop_siterate[simp]: "sdrop n (siterate f x) = siterate f ((f^^n) x)"
- by (induct n arbitrary: x) (auto simp: funpow_swap1)
-
-lemma stake_siterate[simp]: "stake n (siterate f x) = map (\<lambda>n. (f^^n) x) [0 ..< n]"
- by (induct n arbitrary: x) (auto simp del: stake.simps(2) simp: stake_Suc)
-
-lemma sset_siterate: "sset (siterate f x) = {(f^^n) x | n. True}"
- by (auto simp: sset_range)
-
-lemma smap_siterate: "smap f (siterate f x) = siterate f (f x)"
- by (coinduction arbitrary: x) auto
-
-
-subsection {* stream repeating a single element *}
-
-abbreviation "sconst \<equiv> siterate id"
-
-lemma shift_replicate_sconst[simp]: "replicate n x @- sconst x = sconst x"
- by (subst (3) stake_sdrop[symmetric]) (simp add: map_replicate_trivial)
-
-lemma stream_all_same[simp]: "sset (sconst x) = {x}"
- by (simp add: sset_siterate)
-
-lemma same_cycle: "sconst x = cycle [x]"
- by coinduction auto
-
-lemma smap_sconst: "smap f (sconst x) = sconst (f x)"
- by coinduction auto
-
-lemma sconst_streams: "x \<in> A \<Longrightarrow> sconst x \<in> streams A"
- by (simp add: streams_iff_sset)
-
-
-subsection {* stream of natural numbers *}
-
-abbreviation "fromN \<equiv> siterate Suc"
-
-abbreviation "nats \<equiv> fromN 0"
-
-lemma sset_fromN[simp]: "sset (fromN n) = {n ..}"
- by (auto simp add: sset_siterate le_iff_add)
-
-
-subsection {* flatten a stream of lists *}
-
-primcorec flat where
- "shd (flat ws) = hd (shd ws)"
-| "stl (flat ws) = flat (if tl (shd ws) = [] then stl ws else tl (shd ws) ## stl ws)"
-
-lemma flat_Cons[simp, code]: "flat ((x # xs) ## ws) = x ## flat (if xs = [] then ws else xs ## ws)"
- by (subst flat.ctr) simp
-
-lemma flat_Stream[simp]: "xs \<noteq> [] \<Longrightarrow> flat (xs ## ws) = xs @- flat ws"
- by (induct xs) auto
-
-lemma flat_unfold: "shd ws \<noteq> [] \<Longrightarrow> flat ws = shd ws @- flat (stl ws)"
- by (cases ws) auto
-
-lemma flat_snth: "\<forall>xs \<in> sset s. xs \<noteq> [] \<Longrightarrow> flat s !! n = (if n < length (shd s) then
- shd s ! n else flat (stl s) !! (n - length (shd s)))"
- by (metis flat_unfold not_less shd_sset shift_snth_ge shift_snth_less)
-
-lemma sset_flat[simp]: "\<forall>xs \<in> sset s. xs \<noteq> [] \<Longrightarrow>
- sset (flat s) = (\<Union>xs \<in> sset s. set xs)" (is "?P \<Longrightarrow> ?L = ?R")
-proof safe
- fix x assume ?P "x : ?L"
- then obtain m where "x = flat s !! m" by (metis image_iff sset_range)
- with `?P` obtain n m' where "x = s !! n ! m'" "m' < length (s !! n)"
- proof (atomize_elim, induct m arbitrary: s rule: less_induct)
- case (less y)
- thus ?case
- proof (cases "y < length (shd s)")
- case True thus ?thesis by (metis flat_snth less(2,3) snth.simps(1))
- next
- case False
- hence "x = flat (stl s) !! (y - length (shd s))" by (metis less(2,3) flat_snth)
- moreover
- { from less(2) have *: "length (shd s) > 0" by (cases s) simp_all
- with False have "y > 0" by (cases y) simp_all
- with * have "y - length (shd s) < y" by simp
- }
- moreover have "\<forall>xs \<in> sset (stl s). xs \<noteq> []" using less(2) by (cases s) auto
- ultimately have "\<exists>n m'. x = stl s !! n ! m' \<and> m' < length (stl s !! n)" by (intro less(1)) auto
- thus ?thesis by (metis snth.simps(2))
- qed
- qed
- thus "x \<in> ?R" by (auto simp: sset_range dest!: nth_mem)
-next
- fix x xs assume "xs \<in> sset s" ?P "x \<in> set xs" thus "x \<in> ?L"
- by (induct rule: sset_induct1)
- (metis UnI1 flat_unfold shift.simps(1) sset_shift,
- metis UnI2 flat_unfold shd_sset stl_sset sset_shift)
-qed
-
-
-subsection {* merge a stream of streams *}
-
-definition smerge :: "'a stream stream \<Rightarrow> 'a stream" where
- "smerge ss = flat (smap (\<lambda>n. map (\<lambda>s. s !! n) (stake (Suc n) ss) @ stake n (ss !! n)) nats)"
-
-lemma stake_nth[simp]: "m < n \<Longrightarrow> stake n s ! m = s !! m"
- by (induct n arbitrary: s m) (auto simp: nth_Cons', metis Suc_pred snth.simps(2))
-
-lemma snth_sset_smerge: "ss !! n !! m \<in> sset (smerge ss)"
-proof (cases "n \<le> m")
- case False thus ?thesis unfolding smerge_def
- by (subst sset_flat)
- (auto simp: stream.set_map in_set_conv_nth simp del: stake.simps
- intro!: exI[of _ n, OF disjI2] exI[of _ m, OF mp])
-next
- case True thus ?thesis unfolding smerge_def
- by (subst sset_flat)
- (auto simp: stream.set_map in_set_conv_nth image_iff simp del: stake.simps snth.simps
- intro!: exI[of _ m, OF disjI1] bexI[of _ "ss !! n"] exI[of _ n, OF mp])
-qed
-
-lemma sset_smerge: "sset (smerge ss) = UNION (sset ss) sset"
-proof safe
- fix x assume "x \<in> sset (smerge ss)"
- thus "x \<in> UNION (sset ss) sset"
- unfolding smerge_def by (subst (asm) sset_flat)
- (auto simp: stream.set_map in_set_conv_nth sset_range simp del: stake.simps, fast+)
-next
- fix s x assume "s \<in> sset ss" "x \<in> sset s"
- thus "x \<in> sset (smerge ss)" using snth_sset_smerge by (auto simp: sset_range)
-qed
-
-
-subsection {* product of two streams *}
-
-definition sproduct :: "'a stream \<Rightarrow> 'b stream \<Rightarrow> ('a \<times> 'b) stream" where
- "sproduct s1 s2 = smerge (smap (\<lambda>x. smap (Pair x) s2) s1)"
-
-lemma sset_sproduct: "sset (sproduct s1 s2) = sset s1 \<times> sset s2"
- unfolding sproduct_def sset_smerge by (auto simp: stream.set_map)
-
-
-subsection {* interleave two streams *}
-
-primcorec sinterleave where
- "shd (sinterleave s1 s2) = shd s1"
-| "stl (sinterleave s1 s2) = sinterleave s2 (stl s1)"
-
-lemma sinterleave_code[code]:
- "sinterleave (x ## s1) s2 = x ## sinterleave s2 s1"
- by (subst sinterleave.ctr) simp
-
-lemma sinterleave_snth[simp]:
- "even n \<Longrightarrow> sinterleave s1 s2 !! n = s1 !! (n div 2)"
- "odd n \<Longrightarrow> sinterleave s1 s2 !! n = s2 !! (n div 2)"
- by (induct n arbitrary: s1 s2)
- (auto dest: even_nat_Suc_div_2 odd_nat_plus_one_div_two[folded nat_2])
-
-lemma sset_sinterleave: "sset (sinterleave s1 s2) = sset s1 \<union> sset s2"
-proof (intro equalityI subsetI)
- fix x assume "x \<in> sset (sinterleave s1 s2)"
- then obtain n where "x = sinterleave s1 s2 !! n" unfolding sset_range by blast
- thus "x \<in> sset s1 \<union> sset s2" by (cases "even n") auto
-next
- fix x assume "x \<in> sset s1 \<union> sset s2"
- thus "x \<in> sset (sinterleave s1 s2)"
- proof
- assume "x \<in> sset s1"
- then obtain n where "x = s1 !! n" unfolding sset_range by blast
- hence "sinterleave s1 s2 !! (2 * n) = x" by simp
- thus ?thesis unfolding sset_range by blast
- next
- assume "x \<in> sset s2"
- then obtain n where "x = s2 !! n" unfolding sset_range by blast
- hence "sinterleave s1 s2 !! (2 * n + 1) = x" by simp
- thus ?thesis unfolding sset_range by blast
- qed
-qed
-
-
-subsection {* zip *}
-
-primcorec szip where
- "shd (szip s1 s2) = (shd s1, shd s2)"
-| "stl (szip s1 s2) = szip (stl s1) (stl s2)"
-
-lemma szip_unfold[code]: "szip (a ## s1) (b ## s2) = (a, b) ## (szip s1 s2)"
- by (subst szip.ctr) simp
-
-lemma snth_szip[simp]: "szip s1 s2 !! n = (s1 !! n, s2 !! n)"
- by (induct n arbitrary: s1 s2) auto
-
-
-subsection {* zip via function *}
-
-primcorec smap2 where
- "shd (smap2 f s1 s2) = f (shd s1) (shd s2)"
-| "stl (smap2 f s1 s2) = smap2 f (stl s1) (stl s2)"
-
-lemma smap2_unfold[code]:
- "smap2 f (a ## s1) (b ## s2) = f a b ## (smap2 f s1 s2)"
- by (subst smap2.ctr) simp
-
-lemma smap2_szip:
- "smap2 f s1 s2 = smap (split f) (szip s1 s2)"
- by (coinduction arbitrary: s1 s2) auto
-
-end
--- a/src/HOL/BNF/Examples/Stream_Processor.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,187 +0,0 @@
-(* Title: HOL/BNF/Examples/Stream_Processor.thy
- Author: Dmitriy Traytel, TU Muenchen
- Author: Andrei Popescu, TU Muenchen
- Copyright 2014
-
-Stream processors---a syntactic representation of continuous functions on streams
-*)
-
-header {* Stream Processors *}
-
-theory Stream_Processor
-imports Stream "../BNF_Decl"
-begin
-
-section {* Continuous Functions on Streams *}
-
-datatype_new ('a, 'b, 'c) sp\<^sub>\<mu> = Get "'a \<Rightarrow> ('a, 'b, 'c) sp\<^sub>\<mu>" | Put "'b" "'c"
-codatatype ('a, 'b) sp\<^sub>\<nu> = In (out: "('a, 'b, ('a, 'b) sp\<^sub>\<nu>) sp\<^sub>\<mu>")
-
-primrec_new run\<^sub>\<mu> :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> 'a stream \<Rightarrow> ('b \<times> 'c) \<times> 'a stream" where
- "run\<^sub>\<mu> (Get f) s = run\<^sub>\<mu> (f (shd s)) (stl s)"
-| "run\<^sub>\<mu> (Put b sp) s = ((b, sp), s)"
-
-primcorec run\<^sub>\<nu> :: "('a, 'b) sp\<^sub>\<nu> \<Rightarrow> 'a stream \<Rightarrow> 'b stream" where
- "run\<^sub>\<nu> sp s = (let ((h, sp), s) = run\<^sub>\<mu> (out sp) s in h ## run\<^sub>\<nu> sp s)"
-
-primcorec copy :: "('a, 'a) sp\<^sub>\<nu>" where
- "copy = In (Get (\<lambda>a. Put a copy))"
-
-lemma run\<^sub>\<nu>_copy: "run\<^sub>\<nu> copy s = s"
- by (coinduction arbitrary: s) simp
-
-text {*
-To use the function package for the definition of composition the
-wellfoundedness of the subtree relation needs to be proved first.
-*}
-
-definition "sub \<equiv> {(f a, Get f) | a f. True}"
-
-lemma subI[intro]: "(f a, Get f) \<in> sub"
- unfolding sub_def by blast
-
-lemma wf_sub[simp, intro]: "wf sub"
-proof (rule wfUNIVI)
- fix P :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> bool" and x
- assume "\<forall>x. (\<forall>y. (y, x) \<in> sub \<longrightarrow> P y) \<longrightarrow> P x"
- hence I: "\<And>x. (\<forall>y. (\<exists>a f. y = f a \<and> x = Get f) \<longrightarrow> P y) \<Longrightarrow> P x" unfolding sub_def by blast
- show "P x" by (induct x) (auto intro: I)
-qed
-
-function
- sp\<^sub>\<mu>_comp :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> ('d, 'a, ('d, 'a) sp\<^sub>\<nu>) sp\<^sub>\<mu> \<Rightarrow> ('d, 'b, 'c \<times> ('d, 'a) sp\<^sub>\<nu>) sp\<^sub>\<mu>"
- (infixl "o\<^sub>\<mu>" 65)
-where
- "Put b sp o\<^sub>\<mu> fsp = Put b (sp, In fsp)"
-| "Get f o\<^sub>\<mu> Put b sp = f b o\<^sub>\<mu> out sp"
-| "Get f o\<^sub>\<mu> Get g = Get (\<lambda>a. Get f o\<^sub>\<mu> g a)"
-by pat_completeness auto
-termination by (relation "lex_prod sub sub") auto
-
-primcorec sp\<^sub>\<nu>_comp (infixl "o\<^sub>\<nu>" 65) where
- "out (sp o\<^sub>\<nu> sp') = map_sp\<^sub>\<mu> id (\<lambda>(sp, sp'). sp o\<^sub>\<nu> sp') (out sp o\<^sub>\<mu> out sp')"
-
-lemma run\<^sub>\<nu>_sp\<^sub>\<nu>_comp: "run\<^sub>\<nu> (sp o\<^sub>\<nu> sp') = run\<^sub>\<nu> sp o run\<^sub>\<nu> sp'"
-proof (rule ext, unfold comp_apply)
- fix s
- show "run\<^sub>\<nu> (sp o\<^sub>\<nu> sp') s = run\<^sub>\<nu> sp (run\<^sub>\<nu> sp' s)"
- proof (coinduction arbitrary: sp sp' s)
- case Eq_stream
- show ?case
- proof (induct "out sp" "out sp'" arbitrary: sp sp' s rule: sp\<^sub>\<mu>_comp.induct)
- case (1 b sp'')
- show ?case by (auto simp add: 1[symmetric])
- next
- case (2 f b sp'')
- from 2(1)[of "In (f b)" sp''] show ?case by (simp add: 2(2,3)[symmetric])
- next
- case (3 f h)
- from 3(1)[of _ "shd s" "In (h (shd s))", OF 3(2)] show ?case by (simp add: 3(2,3)[symmetric])
- qed
- qed
-qed
-
-text {* Alternative definition of composition using primrec_new instead of function *}
-
-primrec_new sp\<^sub>\<mu>_comp2R where
- "sp\<^sub>\<mu>_comp2R f (Put b sp) = f b (out sp)"
-| "sp\<^sub>\<mu>_comp2R f (Get h) = Get (sp\<^sub>\<mu>_comp2R f o h)"
-
-primrec_new sp\<^sub>\<mu>_comp2 (infixl "o\<^sup>*\<^sub>\<mu>" 65) where
- "Put b sp o\<^sup>*\<^sub>\<mu> fsp = Put b (sp, In fsp)"
-| "Get f o\<^sup>*\<^sub>\<mu> fsp = sp\<^sub>\<mu>_comp2R (op o\<^sup>*\<^sub>\<mu> o f) fsp"
-
-primcorec sp\<^sub>\<nu>_comp2 (infixl "o\<^sup>*\<^sub>\<nu>" 65) where
- "out (sp o\<^sup>*\<^sub>\<nu> sp') = map_sp\<^sub>\<mu> id (\<lambda>(sp, sp'). sp o\<^sup>*\<^sub>\<nu> sp') (out sp o\<^sup>*\<^sub>\<mu> out sp')"
-
-lemma run\<^sub>\<nu>_sp\<^sub>\<nu>_comp2: "run\<^sub>\<nu> (sp o\<^sup>*\<^sub>\<nu> sp') = run\<^sub>\<nu> sp o run\<^sub>\<nu> sp'"
-proof (rule ext, unfold comp_apply)
- fix s
- show "run\<^sub>\<nu> (sp o\<^sup>*\<^sub>\<nu> sp') s = run\<^sub>\<nu> sp (run\<^sub>\<nu> sp' s)"
- proof (coinduction arbitrary: sp sp' s)
- case Eq_stream
- show ?case
- proof (induct "out sp" arbitrary: sp sp' s)
- case (Put b sp'')
- show ?case by (auto simp add: Put[symmetric])
- next
- case (Get f)
- then show ?case
- proof (induct "out sp'" arbitrary: sp sp' s)
- case (Put b sp'')
- from Put(2)[of "In (f b)" sp''] show ?case by (simp add: Put(1,3)[symmetric])
- next
- case (Get h)
- from Get(1)[OF _ Get(3,4), of "In (h (shd s))"] show ?case by (simp add: Get(2,4)[symmetric])
- qed
- qed
- qed
-qed
-
-text {* The two definitions are equivalent *}
-
-lemma sp\<^sub>\<mu>_comp_sp\<^sub>\<mu>_comp2[simp]: "sp o\<^sub>\<mu> sp' = sp o\<^sup>*\<^sub>\<mu> sp'"
- by (induct sp sp' rule: sp\<^sub>\<mu>_comp.induct) auto
-
-(*will be provided by the package*)
-lemma sp\<^sub>\<mu>_rel_map_map[unfolded vimage2p_def, simp]:
- "rel_sp\<^sub>\<mu> R1 R2 (map_sp\<^sub>\<mu> f1 f2 sp) (map_sp\<^sub>\<mu> g1 g2 sp') =
- rel_sp\<^sub>\<mu> (BNF_Def.vimage2p f1 g1 R1) (BNF_Def.vimage2p f2 g2 R2) sp sp'"
-by (tactic {*
- let val ks = 1 upto 2;
- in
- BNF_Tactics.unfold_thms_tac @{context}
- @{thms sp\<^sub>\<mu>.rel_compp sp\<^sub>\<mu>.rel_conversep sp\<^sub>\<mu>.rel_Grp vimage2p_Grp} THEN
- HEADGOAL (EVERY' [rtac iffI, rtac @{thm relcomppI}, rtac @{thm GrpI}, rtac refl, rtac CollectI,
- BNF_Util.CONJ_WRAP' (K (rtac @{thm subset_UNIV})) ks, rtac @{thm relcomppI}, atac,
- rtac @{thm conversepI}, rtac @{thm GrpI}, rtac refl, rtac CollectI,
- BNF_Util.CONJ_WRAP' (K (rtac @{thm subset_UNIV})) ks,
- REPEAT_DETERM o eresolve_tac @{thms relcomppE conversepE GrpE},
- hyp_subst_tac @{context}, atac])
- end
-*})
-
-lemma sp\<^sub>\<mu>_rel_self: "\<lbrakk>op = \<le> R1; op = \<le> R2\<rbrakk> \<Longrightarrow> rel_sp\<^sub>\<mu> R1 R2 x x"
- by (erule (1) predicate2D[OF sp\<^sub>\<mu>.rel_mono]) (simp only: sp\<^sub>\<mu>.rel_eq)
-
-lemma sp\<^sub>\<nu>_comp_sp\<^sub>\<nu>_comp2: "sp o\<^sub>\<nu> sp' = sp o\<^sup>*\<^sub>\<nu> sp'"
- by (coinduction arbitrary: sp sp') (auto intro!: sp\<^sub>\<mu>_rel_self)
-
-
-section {* Generalization to an Arbitrary BNF as Codomain *}
-
-bnf_decl ('a, 'b) F (map: F)
-
-definition \<theta> :: "('p,'a) F * 'b \<Rightarrow> ('p,'a * 'b) F" where
- "\<theta> xb = F id <id, \<lambda> a. (snd xb)> (fst xb)"
-
-(* The strength laws for \<theta>: *)
-lemma \<theta>_natural: "F id (map_pair f g) o \<theta> = \<theta> o map_pair (F id f) g"
- unfolding \<theta>_def F.map_comp comp_def id_apply convol_def map_pair_def split_beta fst_conv snd_conv ..
-
-definition assl :: "'a * ('b * 'c) \<Rightarrow> ('a * 'b) * 'c" where
- "assl abc = ((fst abc, fst (snd abc)), snd (snd abc))"
-
-lemma \<theta>_rid: "F id fst o \<theta> = fst"
- unfolding \<theta>_def F.map_comp F.map_id comp_def id_apply convol_def fst_conv sym[OF id_def] ..
-
-lemma \<theta>_assl: "F id assl o \<theta> = \<theta> o map_pair \<theta> id o assl"
- unfolding assl_def \<theta>_def F.map_comp comp_def id_apply convol_def map_pair_def split fst_conv snd_conv ..
-
-datatype_new ('a, 'b, 'c) spF\<^sub>\<mu> = GetF "'a \<Rightarrow> ('a, 'b, 'c) spF\<^sub>\<mu>" | PutF "('b,'c) F"
-codatatype ('a, 'b) spF\<^sub>\<nu> = InF (outF: "('a, 'b, ('a, 'b) spF\<^sub>\<nu>) spF\<^sub>\<mu>")
-
-codatatype 'b JF = Ctor (dtor: "('b, 'b JF) F")
-
-(* Definition of run for an arbitrary final coalgebra as codomain: *)
-
-primrec_new
- runF\<^sub>\<mu> :: "('a, 'b, ('a, 'b) spF\<^sub>\<nu>) spF\<^sub>\<mu> \<Rightarrow> 'a stream \<Rightarrow> (('b, ('a, 'b) spF\<^sub>\<nu>) F) \<times> 'a stream"
-where
- "runF\<^sub>\<mu> (GetF f) s = (runF\<^sub>\<mu> o f) (shd s) (stl s)"
-| "runF\<^sub>\<mu> (PutF x) s = (x, s)"
-
-primcorec runF\<^sub>\<nu> :: "('a, 'b) spF\<^sub>\<nu> \<Rightarrow> 'a stream \<Rightarrow> 'b JF" where
- "runF\<^sub>\<nu> sp s = (let (x, s) = runF\<^sub>\<mu> (outF sp) s in Ctor (F id (\<lambda> sp. runF\<^sub>\<nu> sp s) x))"
-
-end
--- a/src/HOL/BNF/Examples/TreeFI.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,46 +0,0 @@
-(* Title: HOL/BNF/Examples/TreeFI.thy
- Author: Dmitriy Traytel, TU Muenchen
- Author: Andrei Popescu, TU Muenchen
- Copyright 2012
-
-Finitely branching possibly infinite trees.
-*)
-
-header {* Finitely Branching Possibly Infinite Trees *}
-
-theory TreeFI
-imports ListF
-begin
-
-codatatype 'a treeFI = Tree (lab: 'a) (sub: "'a treeFI listF")
-
-(* Tree reverse:*)
-primcorec trev where
- "lab (trev t) = lab t"
-| "sub (trev t) = mapF trev (lrev (sub t))"
-
-lemma treeFI_coinduct:
- assumes *: "phi x y"
- and step: "\<And>a b. phi a b \<Longrightarrow>
- lab a = lab b \<and>
- lengthh (sub a) = lengthh (sub b) \<and>
- (\<forall>i < lengthh (sub a). phi (nthh (sub a) i) (nthh (sub b) i))"
- shows "x = y"
-using * proof (coinduction arbitrary: x y)
- case (Eq_treeFI t1 t2)
- from conjunct1[OF conjunct2[OF step[OF Eq_treeFI]]] conjunct2[OF conjunct2[OF step[OF Eq_treeFI]]]
- have "relF phi (sub t1) (sub t2)"
- proof (induction "sub t1" "sub t2" arbitrary: t1 t2 rule: listF_induct2)
- case (Conss x xs y ys)
- note sub = Conss(2,3)[symmetric] and phi = mp[OF spec[OF Conss(4)], unfolded sub]
- and IH = Conss(1)[of "Tree (lab t1) (tlF (sub t1))" "Tree (lab t2) (tlF (sub t2))",
- unfolded sub, simplified]
- from phi[of 0] show ?case unfolding sub by (auto intro!: IH dest: phi[simplified, OF Suc_mono])
- qed simp
- with conjunct1[OF step[OF Eq_treeFI]] show ?case by simp
-qed
-
-lemma trev_trev: "trev (trev tr) = tr"
- by (coinduction arbitrary: tr rule: treeFI_coinduct) auto
-
-end
--- a/src/HOL/BNF/Examples/TreeFsetI.thy Mon Jan 20 18:24:56 2014 +0100
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,27 +0,0 @@
-(* Title: HOL/BNF/Examples/TreeFsetI.thy
- Author: Dmitriy Traytel, TU Muenchen
- Author: Andrei Popescu, TU Muenchen
- Copyright 2012
-
-Finitely branching possibly infinite trees, with sets of children.
-*)
-
-header {* Finitely Branching Possibly Infinite Trees, with Sets of Children *}
-
-theory TreeFsetI
-imports "../BNF"
-begin
-
-hide_fact (open) Lifting_Product.prod_rel_def
-
-codatatype 'a treeFsetI = Tree (lab: 'a) (sub: "'a treeFsetI fset")
-
-(* tree map (contrived example): *)
-primcorec tmap where
-"lab (tmap f t) = f (lab t)" |
-"sub (tmap f t) = fimage (tmap f) (sub t)"
-
-lemma "tmap (f o g) x = tmap f (tmap g x)"
- by (coinduction arbitrary: x) (auto simp: fset_rel_alt)
-
-end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/Derivation_Trees/DTree.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,92 @@
+(* Title: HOL/BNF/Examples/Derivation_Trees/DTree.thy
+ Author: Andrei Popescu, TU Muenchen
+ Copyright 2012
+
+Derivation trees with nonterminal internal nodes and terminal leaves.
+*)
+
+header {* Trees with Nonterminal Internal Nodes and Terminal Leaves *}
+
+theory DTree
+imports Prelim
+begin
+
+typedecl N
+typedecl T
+
+codatatype dtree = NNode (root: N) (ccont: "(T + dtree) fset")
+
+subsection{* Transporting the Characteristic Lemmas from @{text "fset"} to @{text "set"} *}
+
+definition "Node n as \<equiv> NNode n (the_inv fset as)"
+definition "cont \<equiv> fset o ccont"
+definition "unfold rt ct \<equiv> unfold_dtree rt (the_inv fset o ct)"
+definition "corec rt ct \<equiv> corec_dtree rt (the_inv fset o ct)"
+
+lemma finite_cont[simp]: "finite (cont tr)"
+ unfolding cont_def comp_apply by (cases tr, clarsimp)
+
+lemma Node_root_cont[simp]:
+ "Node (root tr) (cont tr) = tr"
+ unfolding Node_def cont_def comp_apply
+ apply (rule trans[OF _ dtree.collapse])
+ apply (rule arg_cong2[OF refl the_inv_into_f_f[unfolded inj_on_def]])
+ apply (simp_all add: fset_inject)
+ done
+
+lemma dtree_simps[simp]:
+assumes "finite as" and "finite as'"
+shows "Node n as = Node n' as' \<longleftrightarrow> n = n' \<and> as = as'"
+using assms dtree.inject unfolding Node_def
+by (metis fset_to_fset)
+
+lemma dtree_cases[elim, case_names Node Choice]:
+assumes Node: "\<And> n as. \<lbrakk>finite as; tr = Node n as\<rbrakk> \<Longrightarrow> phi"
+shows phi
+apply(cases rule: dtree.exhaust[of tr])
+using Node unfolding Node_def
+by (metis Node Node_root_cont finite_cont)
+
+lemma dtree_sel_ctor[simp]:
+"root (Node n as) = n"
+"finite as \<Longrightarrow> cont (Node n as) = as"
+unfolding Node_def cont_def by auto
+
+lemmas root_Node = dtree_sel_ctor(1)
+lemmas cont_Node = dtree_sel_ctor(2)
+
+lemma dtree_cong:
+assumes "root tr = root tr'" and "cont tr = cont tr'"
+shows "tr = tr'"
+by (metis Node_root_cont assms)
+
+lemma set_rel_cont:
+"set_rel \<chi> (cont tr1) (cont tr2) = fset_rel \<chi> (ccont tr1) (ccont tr2)"
+unfolding cont_def comp_def fset_rel_fset ..
+
+lemma dtree_coinduct[elim, consumes 1, case_names Lift, induct pred: "HOL.eq"]:
+assumes phi: "\<phi> tr1 tr2" and
+Lift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow>
+ root tr1 = root tr2 \<and> set_rel (sum_rel op = \<phi>) (cont tr1) (cont tr2)"
+shows "tr1 = tr2"
+using phi apply(elim dtree.coinduct)
+apply(rule Lift[unfolded set_rel_cont]) .
+
+lemma unfold:
+"root (unfold rt ct b) = rt b"
+"finite (ct b) \<Longrightarrow> cont (unfold rt ct b) = image (id \<oplus> unfold rt ct) (ct b)"
+using dtree.sel_unfold[of rt "the_inv fset \<circ> ct" b] unfolding unfold_def
+apply - apply metis
+unfolding cont_def comp_def
+by simp
+
+lemma corec:
+"root (corec rt ct b) = rt b"
+"finite (ct b) \<Longrightarrow> cont (corec rt ct b) = image (id \<oplus> ([[id, corec rt ct]])) (ct b)"
+using dtree.sel_corec[of rt "the_inv fset \<circ> ct" b] unfolding corec_def
+apply -
+apply simp
+unfolding cont_def comp_def id_def
+by simp
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/Derivation_Trees/Gram_Lang.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,1359 @@
+(* Title: HOL/BNF/Examples/Derivation_Trees/Gram_Lang.thy
+ Author: Andrei Popescu, TU Muenchen
+ Copyright 2012
+
+Language of a grammar.
+*)
+
+header {* Language of a Grammar *}
+
+theory Gram_Lang
+imports DTree
+begin
+
+
+(* We assume that the sets of terminals, and the left-hand sides of
+productions are finite and that the grammar has no unused nonterminals. *)
+consts P :: "(N \<times> (T + N) set) set"
+axiomatization where
+ finite_N: "finite (UNIV::N set)"
+and finite_in_P: "\<And> n tns. (n,tns) \<in> P \<longrightarrow> finite tns"
+and used: "\<And> n. \<exists> tns. (n,tns) \<in> P"
+
+
+subsection{* Tree Basics: frontier, interior, etc. *}
+
+
+(* Frontier *)
+
+inductive inFr :: "N set \<Rightarrow> dtree \<Rightarrow> T \<Rightarrow> bool" where
+Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr ns tr t"
+|
+Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inFr ns tr1 t\<rbrakk> \<Longrightarrow> inFr ns tr t"
+
+definition "Fr ns tr \<equiv> {t. inFr ns tr t}"
+
+lemma inFr_root_in: "inFr ns tr t \<Longrightarrow> root tr \<in> ns"
+by (metis inFr.simps)
+
+lemma inFr_mono:
+assumes "inFr ns tr t" and "ns \<subseteq> ns'"
+shows "inFr ns' tr t"
+using assms apply(induct arbitrary: ns' rule: inFr.induct)
+using Base Ind by (metis inFr.simps set_mp)+
+
+lemma inFr_Ind_minus:
+assumes "inFr ns1 tr1 t" and "Inr tr1 \<in> cont tr"
+shows "inFr (insert (root tr) ns1) tr t"
+using assms apply(induct rule: inFr.induct)
+ apply (metis inFr.simps insert_iff)
+ by (metis inFr.simps inFr_mono insertI1 subset_insertI)
+
+(* alternative definition *)
+inductive inFr2 :: "N set \<Rightarrow> dtree \<Rightarrow> T \<Rightarrow> bool" where
+Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr2 ns tr t"
+|
+Ind: "\<lbrakk>Inr tr1 \<in> cont tr; inFr2 ns1 tr1 t\<rbrakk>
+ \<Longrightarrow> inFr2 (insert (root tr) ns1) tr t"
+
+lemma inFr2_root_in: "inFr2 ns tr t \<Longrightarrow> root tr \<in> ns"
+apply(induct rule: inFr2.induct) by auto
+
+lemma inFr2_mono:
+assumes "inFr2 ns tr t" and "ns \<subseteq> ns'"
+shows "inFr2 ns' tr t"
+using assms apply(induct arbitrary: ns' rule: inFr2.induct)
+using Base Ind
+apply (metis subsetD) by (metis inFr2.simps insert_absorb insert_subset)
+
+lemma inFr2_Ind:
+assumes "inFr2 ns tr1 t" and "root tr \<in> ns" and "Inr tr1 \<in> cont tr"
+shows "inFr2 ns tr t"
+using assms apply(induct rule: inFr2.induct)
+ apply (metis inFr2.simps insert_absorb)
+ by (metis inFr2.simps insert_absorb)
+
+lemma inFr_inFr2:
+"inFr = inFr2"
+apply (rule ext)+ apply(safe)
+ apply(erule inFr.induct)
+ apply (metis (lifting) inFr2.Base)
+ apply (metis (lifting) inFr2_Ind)
+ apply(erule inFr2.induct)
+ apply (metis (lifting) inFr.Base)
+ apply (metis (lifting) inFr_Ind_minus)
+done
+
+lemma not_root_inFr:
+assumes "root tr \<notin> ns"
+shows "\<not> inFr ns tr t"
+by (metis assms inFr_root_in)
+
+lemma not_root_Fr:
+assumes "root tr \<notin> ns"
+shows "Fr ns tr = {}"
+using not_root_inFr[OF assms] unfolding Fr_def by auto
+
+
+(* Interior *)
+
+inductive inItr :: "N set \<Rightarrow> dtree \<Rightarrow> N \<Rightarrow> bool" where
+Base: "root tr \<in> ns \<Longrightarrow> inItr ns tr (root tr)"
+|
+Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inItr ns tr1 n\<rbrakk> \<Longrightarrow> inItr ns tr n"
+
+definition "Itr ns tr \<equiv> {n. inItr ns tr n}"
+
+lemma inItr_root_in: "inItr ns tr n \<Longrightarrow> root tr \<in> ns"
+by (metis inItr.simps)
+
+lemma inItr_mono:
+assumes "inItr ns tr n" and "ns \<subseteq> ns'"
+shows "inItr ns' tr n"
+using assms apply(induct arbitrary: ns' rule: inItr.induct)
+using Base Ind by (metis inItr.simps set_mp)+
+
+
+(* The subtree relation *)
+
+inductive subtr where
+Refl: "root tr \<in> ns \<Longrightarrow> subtr ns tr tr"
+|
+Step: "\<lbrakk>root tr3 \<in> ns; subtr ns tr1 tr2; Inr tr2 \<in> cont tr3\<rbrakk> \<Longrightarrow> subtr ns tr1 tr3"
+
+lemma subtr_rootL_in:
+assumes "subtr ns tr1 tr2"
+shows "root tr1 \<in> ns"
+using assms apply(induct rule: subtr.induct) by auto
+
+lemma subtr_rootR_in:
+assumes "subtr ns tr1 tr2"
+shows "root tr2 \<in> ns"
+using assms apply(induct rule: subtr.induct) by auto
+
+lemmas subtr_roots_in = subtr_rootL_in subtr_rootR_in
+
+lemma subtr_mono:
+assumes "subtr ns tr1 tr2" and "ns \<subseteq> ns'"
+shows "subtr ns' tr1 tr2"
+using assms apply(induct arbitrary: ns' rule: subtr.induct)
+using Refl Step by (metis subtr.simps set_mp)+
+
+lemma subtr_trans_Un:
+assumes "subtr ns12 tr1 tr2" and "subtr ns23 tr2 tr3"
+shows "subtr (ns12 \<union> ns23) tr1 tr3"
+proof-
+ have "subtr ns23 tr2 tr3 \<Longrightarrow>
+ (\<forall> ns12 tr1. subtr ns12 tr1 tr2 \<longrightarrow> subtr (ns12 \<union> ns23) tr1 tr3)"
+ apply(induct rule: subtr.induct, safe)
+ apply (metis subtr_mono sup_commute sup_ge2)
+ by (metis (lifting) Step UnI2)
+ thus ?thesis using assms by auto
+qed
+
+lemma subtr_trans:
+assumes "subtr ns tr1 tr2" and "subtr ns tr2 tr3"
+shows "subtr ns tr1 tr3"
+using subtr_trans_Un[OF assms] by simp
+
+lemma subtr_StepL:
+assumes r: "root tr1 \<in> ns" and tr12: "Inr tr1 \<in> cont tr2" and s: "subtr ns tr2 tr3"
+shows "subtr ns tr1 tr3"
+apply(rule subtr_trans[OF _ s])
+apply(rule Step[of tr2 ns tr1 tr1])
+apply(rule subtr_rootL_in[OF s])
+apply(rule Refl[OF r])
+apply(rule tr12)
+done
+
+(* alternative definition: *)
+inductive subtr2 where
+Refl: "root tr \<in> ns \<Longrightarrow> subtr2 ns tr tr"
+|
+Step: "\<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr2 ns tr2 tr3\<rbrakk> \<Longrightarrow> subtr2 ns tr1 tr3"
+
+lemma subtr2_rootL_in:
+assumes "subtr2 ns tr1 tr2"
+shows "root tr1 \<in> ns"
+using assms apply(induct rule: subtr2.induct) by auto
+
+lemma subtr2_rootR_in:
+assumes "subtr2 ns tr1 tr2"
+shows "root tr2 \<in> ns"
+using assms apply(induct rule: subtr2.induct) by auto
+
+lemmas subtr2_roots_in = subtr2_rootL_in subtr2_rootR_in
+
+lemma subtr2_mono:
+assumes "subtr2 ns tr1 tr2" and "ns \<subseteq> ns'"
+shows "subtr2 ns' tr1 tr2"
+using assms apply(induct arbitrary: ns' rule: subtr2.induct)
+using Refl Step by (metis subtr2.simps set_mp)+
+
+lemma subtr2_trans_Un:
+assumes "subtr2 ns12 tr1 tr2" and "subtr2 ns23 tr2 tr3"
+shows "subtr2 (ns12 \<union> ns23) tr1 tr3"
+proof-
+ have "subtr2 ns12 tr1 tr2 \<Longrightarrow>
+ (\<forall> ns23 tr3. subtr2 ns23 tr2 tr3 \<longrightarrow> subtr2 (ns12 \<union> ns23) tr1 tr3)"
+ apply(induct rule: subtr2.induct, safe)
+ apply (metis subtr2_mono sup_commute sup_ge2)
+ by (metis Un_iff subtr2.simps)
+ thus ?thesis using assms by auto
+qed
+
+lemma subtr2_trans:
+assumes "subtr2 ns tr1 tr2" and "subtr2 ns tr2 tr3"
+shows "subtr2 ns tr1 tr3"
+using subtr2_trans_Un[OF assms] by simp
+
+lemma subtr2_StepR:
+assumes r: "root tr3 \<in> ns" and tr23: "Inr tr2 \<in> cont tr3" and s: "subtr2 ns tr1 tr2"
+shows "subtr2 ns tr1 tr3"
+apply(rule subtr2_trans[OF s])
+apply(rule Step[of _ _ tr3])
+apply(rule subtr2_rootR_in[OF s])
+apply(rule tr23)
+apply(rule Refl[OF r])
+done
+
+lemma subtr_subtr2:
+"subtr = subtr2"
+apply (rule ext)+ apply(safe)
+ apply(erule subtr.induct)
+ apply (metis (lifting) subtr2.Refl)
+ apply (metis (lifting) subtr2_StepR)
+ apply(erule subtr2.induct)
+ apply (metis (lifting) subtr.Refl)
+ apply (metis (lifting) subtr_StepL)
+done
+
+lemma subtr_inductL[consumes 1, case_names Refl Step]:
+assumes s: "subtr ns tr1 tr2" and Refl: "\<And>ns tr. \<phi> ns tr tr"
+and Step:
+"\<And>ns tr1 tr2 tr3.
+ \<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr ns tr2 tr3; \<phi> ns tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> ns tr1 tr3"
+shows "\<phi> ns tr1 tr2"
+using s unfolding subtr_subtr2 apply(rule subtr2.induct)
+using Refl Step unfolding subtr_subtr2 by auto
+
+lemma subtr_UNIV_inductL[consumes 1, case_names Refl Step]:
+assumes s: "subtr UNIV tr1 tr2" and Refl: "\<And>tr. \<phi> tr tr"
+and Step:
+"\<And>tr1 tr2 tr3.
+ \<lbrakk>Inr tr1 \<in> cont tr2; subtr UNIV tr2 tr3; \<phi> tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> tr1 tr3"
+shows "\<phi> tr1 tr2"
+using s apply(induct rule: subtr_inductL)
+apply(rule Refl) using Step subtr_mono by (metis subset_UNIV)
+
+(* Subtree versus frontier: *)
+lemma subtr_inFr:
+assumes "inFr ns tr t" and "subtr ns tr tr1"
+shows "inFr ns tr1 t"
+proof-
+ have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inFr ns tr t \<longrightarrow> inFr ns tr1 t)"
+ apply(induct rule: subtr.induct, safe) by (metis inFr.Ind)
+ thus ?thesis using assms by auto
+qed
+
+corollary Fr_subtr:
+"Fr ns tr = \<Union> {Fr ns tr' | tr'. subtr ns tr' tr}"
+unfolding Fr_def proof safe
+ fix t assume t: "inFr ns tr t" hence "root tr \<in> ns" by (rule inFr_root_in)
+ thus "t \<in> \<Union>{{t. inFr ns tr' t} |tr'. subtr ns tr' tr}"
+ apply(intro UnionI[of "{t. inFr ns tr t}" _ t]) using t subtr.Refl by auto
+qed(metis subtr_inFr)
+
+lemma inFr_subtr:
+assumes "inFr ns tr t"
+shows "\<exists> tr'. subtr ns tr' tr \<and> Inl t \<in> cont tr'"
+using assms apply(induct rule: inFr.induct) apply safe
+ apply (metis subtr.Refl)
+ by (metis (lifting) subtr.Step)
+
+corollary Fr_subtr_cont:
+"Fr ns tr = \<Union> {Inl -` cont tr' | tr'. subtr ns tr' tr}"
+unfolding Fr_def
+apply safe
+apply (frule inFr_subtr)
+apply auto
+by (metis inFr.Base subtr_inFr subtr_rootL_in)
+
+(* Subtree versus interior: *)
+lemma subtr_inItr:
+assumes "inItr ns tr n" and "subtr ns tr tr1"
+shows "inItr ns tr1 n"
+proof-
+ have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inItr ns tr n \<longrightarrow> inItr ns tr1 n)"
+ apply(induct rule: subtr.induct, safe) by (metis inItr.Ind)
+ thus ?thesis using assms by auto
+qed
+
+corollary Itr_subtr:
+"Itr ns tr = \<Union> {Itr ns tr' | tr'. subtr ns tr' tr}"
+unfolding Itr_def apply safe
+apply (metis (lifting, mono_tags) UnionI inItr_root_in mem_Collect_eq subtr.Refl)
+by (metis subtr_inItr)
+
+lemma inItr_subtr:
+assumes "inItr ns tr n"
+shows "\<exists> tr'. subtr ns tr' tr \<and> root tr' = n"
+using assms apply(induct rule: inItr.induct) apply safe
+ apply (metis subtr.Refl)
+ by (metis (lifting) subtr.Step)
+
+corollary Itr_subtr_cont:
+"Itr ns tr = {root tr' | tr'. subtr ns tr' tr}"
+unfolding Itr_def apply safe
+ apply (metis (lifting, mono_tags) inItr_subtr)
+ by (metis inItr.Base subtr_inItr subtr_rootL_in)
+
+
+subsection{* The Immediate Subtree Function *}
+
+(* production of: *)
+abbreviation "prodOf tr \<equiv> (id \<oplus> root) ` (cont tr)"
+(* subtree of: *)
+definition "subtrOf tr n \<equiv> SOME tr'. Inr tr' \<in> cont tr \<and> root tr' = n"
+
+lemma subtrOf:
+assumes n: "Inr n \<in> prodOf tr"
+shows "Inr (subtrOf tr n) \<in> cont tr \<and> root (subtrOf tr n) = n"
+proof-
+ obtain tr' where "Inr tr' \<in> cont tr \<and> root tr' = n"
+ using n unfolding image_def by (metis (lifting) Inr_oplus_elim assms)
+ thus ?thesis unfolding subtrOf_def by(rule someI)
+qed
+
+lemmas Inr_subtrOf = subtrOf[THEN conjunct1]
+lemmas root_subtrOf[simp] = subtrOf[THEN conjunct2]
+
+lemma Inl_prodOf: "Inl -` (prodOf tr) = Inl -` (cont tr)"
+proof safe
+ fix t ttr assume "Inl t = (id \<oplus> root) ttr" and "ttr \<in> cont tr"
+ thus "t \<in> Inl -` cont tr" by(cases ttr, auto)
+next
+ fix t assume "Inl t \<in> cont tr" thus "t \<in> Inl -` prodOf tr"
+ by (metis (lifting) id_def image_iff sum_map.simps(1) vimageI2)
+qed
+
+lemma root_prodOf:
+assumes "Inr tr' \<in> cont tr"
+shows "Inr (root tr') \<in> prodOf tr"
+by (metis (lifting) assms image_iff sum_map.simps(2))
+
+
+subsection{* Well-Formed Derivation Trees *}
+
+hide_const wf
+
+coinductive wf where
+dtree: "\<lbrakk>(root tr, (id \<oplus> root) ` (cont tr)) \<in> P; inj_on root (Inr -` cont tr);
+ \<And> tr'. tr' \<in> Inr -` (cont tr) \<Longrightarrow> wf tr'\<rbrakk> \<Longrightarrow> wf tr"
+
+(* destruction rules: *)
+lemma wf_P:
+assumes "wf tr"
+shows "(root tr, (id \<oplus> root) ` (cont tr)) \<in> P"
+using assms wf.simps[of tr] by auto
+
+lemma wf_inj_on:
+assumes "wf tr"
+shows "inj_on root (Inr -` cont tr)"
+using assms wf.simps[of tr] by auto
+
+lemma wf_inj[simp]:
+assumes "wf tr" and "Inr tr1 \<in> cont tr" and "Inr tr2 \<in> cont tr"
+shows "root tr1 = root tr2 \<longleftrightarrow> tr1 = tr2"
+using assms wf_inj_on unfolding inj_on_def by auto
+
+lemma wf_cont:
+assumes "wf tr" and "Inr tr' \<in> cont tr"
+shows "wf tr'"
+using assms wf.simps[of tr] by auto
+
+
+(* coinduction:*)
+lemma wf_coind[elim, consumes 1, case_names Hyp]:
+assumes phi: "\<phi> tr"
+and Hyp:
+"\<And> tr. \<phi> tr \<Longrightarrow>
+ (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
+ inj_on root (Inr -` cont tr) \<and>
+ (\<forall> tr' \<in> Inr -` (cont tr). \<phi> tr' \<or> wf tr')"
+shows "wf tr"
+apply(rule wf.coinduct[of \<phi> tr, OF phi])
+using Hyp by blast
+
+lemma wf_raw_coind[elim, consumes 1, case_names Hyp]:
+assumes phi: "\<phi> tr"
+and Hyp:
+"\<And> tr. \<phi> tr \<Longrightarrow>
+ (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
+ inj_on root (Inr -` cont tr) \<and>
+ (\<forall> tr' \<in> Inr -` (cont tr). \<phi> tr')"
+shows "wf tr"
+using phi apply(induct rule: wf_coind)
+using Hyp by (metis (mono_tags))
+
+lemma wf_subtr_inj_on:
+assumes d: "wf tr1" and s: "subtr ns tr tr1"
+shows "inj_on root (Inr -` cont tr)"
+using s d apply(induct rule: subtr.induct)
+apply (metis (lifting) wf_inj_on) by (metis wf_cont)
+
+lemma wf_subtr_P:
+assumes d: "wf tr1" and s: "subtr ns tr tr1"
+shows "(root tr, (id \<oplus> root) ` cont tr) \<in> P"
+using s d apply(induct rule: subtr.induct)
+apply (metis (lifting) wf_P) by (metis wf_cont)
+
+lemma subtrOf_root[simp]:
+assumes tr: "wf tr" and cont: "Inr tr' \<in> cont tr"
+shows "subtrOf tr (root tr') = tr'"
+proof-
+ have 0: "Inr (subtrOf tr (root tr')) \<in> cont tr" using Inr_subtrOf
+ by (metis (lifting) cont root_prodOf)
+ have "root (subtrOf tr (root tr')) = root tr'"
+ using root_subtrOf by (metis (lifting) cont root_prodOf)
+ thus ?thesis unfolding wf_inj[OF tr 0 cont] .
+qed
+
+lemma surj_subtrOf:
+assumes "wf tr" and 0: "Inr tr' \<in> cont tr"
+shows "\<exists> n. Inr n \<in> prodOf tr \<and> subtrOf tr n = tr'"
+apply(rule exI[of _ "root tr'"])
+using root_prodOf[OF 0] subtrOf_root[OF assms] by simp
+
+lemma wf_subtr:
+assumes "wf tr1" and "subtr ns tr tr1"
+shows "wf tr"
+proof-
+ have "(\<exists> ns tr1. wf tr1 \<and> subtr ns tr tr1) \<Longrightarrow> wf tr"
+ proof (induct rule: wf_raw_coind)
+ case (Hyp tr)
+ then obtain ns tr1 where tr1: "wf tr1" and tr_tr1: "subtr ns tr tr1" by auto
+ show ?case proof safe
+ show "(root tr, (id \<oplus> root) ` cont tr) \<in> P" using wf_subtr_P[OF tr1 tr_tr1] .
+ next
+ show "inj_on root (Inr -` cont tr)" using wf_subtr_inj_on[OF tr1 tr_tr1] .
+ next
+ fix tr' assume tr': "Inr tr' \<in> cont tr"
+ have tr_tr1: "subtr (ns \<union> {root tr'}) tr tr1" using subtr_mono[OF tr_tr1] by auto
+ have "subtr (ns \<union> {root tr'}) tr' tr1" using subtr_StepL[OF _ tr' tr_tr1] by auto
+ thus "\<exists>ns' tr1. wf tr1 \<and> subtr ns' tr' tr1" using tr1 by blast
+ qed
+ qed
+ thus ?thesis using assms by auto
+qed
+
+
+subsection{* Default Trees *}
+
+(* Pick a left-hand side of a production for each nonterminal *)
+definition S where "S n \<equiv> SOME tns. (n,tns) \<in> P"
+
+lemma S_P: "(n, S n) \<in> P"
+using used unfolding S_def by(rule someI_ex)
+
+lemma finite_S: "finite (S n)"
+using S_P finite_in_P by auto
+
+
+(* The default tree of a nonterminal *)
+definition deftr :: "N \<Rightarrow> dtree" where
+"deftr \<equiv> unfold id S"
+
+lemma deftr_simps[simp]:
+"root (deftr n) = n"
+"cont (deftr n) = image (id \<oplus> deftr) (S n)"
+using unfold(1)[of id S n] unfold(2)[of S n id, OF finite_S]
+unfolding deftr_def by simp_all
+
+lemmas root_deftr = deftr_simps(1)
+lemmas cont_deftr = deftr_simps(2)
+
+lemma root_o_deftr[simp]: "root o deftr = id"
+by (rule ext, auto)
+
+lemma wf_deftr: "wf (deftr n)"
+proof-
+ {fix tr assume "\<exists> n. tr = deftr n" hence "wf tr"
+ apply(induct rule: wf_raw_coind) apply safe
+ unfolding deftr_simps image_compose[symmetric] sum_map.comp id_comp
+ root_o_deftr sum_map.id image_id id_apply apply(rule S_P)
+ unfolding inj_on_def by auto
+ }
+ thus ?thesis by auto
+qed
+
+
+subsection{* Hereditary Substitution *}
+
+(* Auxiliary concept: The root-ommiting frontier: *)
+definition "inFrr ns tr t \<equiv> \<exists> tr'. Inr tr' \<in> cont tr \<and> inFr ns tr' t"
+definition "Frr ns tr \<equiv> {t. \<exists> tr'. Inr tr' \<in> cont tr \<and> t \<in> Fr ns tr'}"
+
+context
+fixes tr0 :: dtree
+begin
+
+definition "hsubst_r tr \<equiv> root tr"
+definition "hsubst_c tr \<equiv> if root tr = root tr0 then cont tr0 else cont tr"
+
+(* Hereditary substitution: *)
+definition hsubst :: "dtree \<Rightarrow> dtree" where
+"hsubst \<equiv> unfold hsubst_r hsubst_c"
+
+lemma finite_hsubst_c: "finite (hsubst_c n)"
+unfolding hsubst_c_def by (metis (full_types) finite_cont)
+
+lemma root_hsubst[simp]: "root (hsubst tr) = root tr"
+using unfold(1)[of hsubst_r hsubst_c tr] unfolding hsubst_def hsubst_r_def by simp
+
+lemma root_o_subst[simp]: "root o hsubst = root"
+unfolding comp_def root_hsubst ..
+
+lemma cont_hsubst_eq[simp]:
+assumes "root tr = root tr0"
+shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr0)"
+apply(subst id_comp[symmetric, of id]) unfolding id_comp
+using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
+unfolding hsubst_def hsubst_c_def using assms by simp
+
+lemma hsubst_eq:
+assumes "root tr = root tr0"
+shows "hsubst tr = hsubst tr0"
+apply(rule dtree_cong) using assms cont_hsubst_eq by auto
+
+lemma cont_hsubst_neq[simp]:
+assumes "root tr \<noteq> root tr0"
+shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr)"
+apply(subst id_comp[symmetric, of id]) unfolding id_comp
+using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
+unfolding hsubst_def hsubst_c_def using assms by simp
+
+lemma Inl_cont_hsubst_eq[simp]:
+assumes "root tr = root tr0"
+shows "Inl -` cont (hsubst tr) = Inl -` (cont tr0)"
+unfolding cont_hsubst_eq[OF assms] by simp
+
+lemma Inr_cont_hsubst_eq[simp]:
+assumes "root tr = root tr0"
+shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr0"
+unfolding cont_hsubst_eq[OF assms] by simp
+
+lemma Inl_cont_hsubst_neq[simp]:
+assumes "root tr \<noteq> root tr0"
+shows "Inl -` cont (hsubst tr) = Inl -` (cont tr)"
+unfolding cont_hsubst_neq[OF assms] by simp
+
+lemma Inr_cont_hsubst_neq[simp]:
+assumes "root tr \<noteq> root tr0"
+shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr"
+unfolding cont_hsubst_neq[OF assms] by simp
+
+lemma wf_hsubst:
+assumes tr0: "wf tr0" and tr: "wf tr"
+shows "wf (hsubst tr)"
+proof-
+ {fix tr1 have "(\<exists> tr. wf tr \<and> tr1 = hsubst tr) \<Longrightarrow> wf tr1"
+ proof (induct rule: wf_raw_coind)
+ case (Hyp tr1) then obtain tr
+ where dtr: "wf tr" and tr1: "tr1 = hsubst tr" by auto
+ show ?case unfolding tr1 proof safe
+ show "(root (hsubst tr), prodOf (hsubst tr)) \<in> P"
+ unfolding tr1 apply(cases "root tr = root tr0")
+ using wf_P[OF dtr] wf_P[OF tr0]
+ by (auto simp add: image_compose[symmetric] sum_map.comp)
+ show "inj_on root (Inr -` cont (hsubst tr))"
+ apply(cases "root tr = root tr0") using wf_inj_on[OF dtr] wf_inj_on[OF tr0]
+ unfolding inj_on_def by (auto, blast)
+ fix tr' assume "Inr tr' \<in> cont (hsubst tr)"
+ thus "\<exists>tra. wf tra \<and> tr' = hsubst tra"
+ apply(cases "root tr = root tr0", simp_all)
+ apply (metis wf_cont tr0)
+ by (metis dtr wf_cont)
+ qed
+ qed
+ }
+ thus ?thesis using assms by blast
+qed
+
+lemma Frr: "Frr ns tr = {t. inFrr ns tr t}"
+unfolding inFrr_def Frr_def Fr_def by auto
+
+lemma inFr_hsubst_imp:
+assumes "inFr ns (hsubst tr) t"
+shows "t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
+ inFr (ns - {root tr0}) tr t"
+proof-
+ {fix tr1
+ have "inFr ns tr1 t \<Longrightarrow>
+ (\<And> tr. tr1 = hsubst tr \<Longrightarrow> (t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
+ inFr (ns - {root tr0}) tr t))"
+ proof(induct rule: inFr.induct)
+ case (Base tr1 ns t tr)
+ hence rtr: "root tr1 \<in> ns" and t_tr1: "Inl t \<in> cont tr1" and tr1: "tr1 = hsubst tr"
+ by auto
+ show ?case
+ proof(cases "root tr1 = root tr0")
+ case True
+ hence "t \<in> Inl -` (cont tr0)" using t_tr1 unfolding tr1 by auto
+ thus ?thesis by simp
+ next
+ case False
+ hence "inFr (ns - {root tr0}) tr t" using t_tr1 unfolding tr1 apply simp
+ by (metis Base.prems Diff_iff root_hsubst inFr.Base rtr singletonE)
+ thus ?thesis by simp
+ qed
+ next
+ case (Ind tr1 ns tr1' t) note IH = Ind(4)
+ have rtr1: "root tr1 \<in> ns" and tr1'_tr1: "Inr tr1' \<in> cont tr1"
+ and t_tr1': "inFr ns tr1' t" and tr1: "tr1 = hsubst tr" using Ind by auto
+ have rtr1: "root tr1 = root tr" unfolding tr1 by simp
+ show ?case
+ proof(cases "root tr1 = root tr0")
+ case True
+ then obtain tr' where tr'_tr0: "Inr tr' \<in> cont tr0" and tr1': "tr1' = hsubst tr'"
+ using tr1'_tr1 unfolding tr1 by auto
+ show ?thesis using IH[OF tr1'] proof (elim disjE)
+ assume "inFr (ns - {root tr0}) tr' t"
+ thus ?thesis using tr'_tr0 unfolding inFrr_def by auto
+ qed auto
+ next
+ case False
+ then obtain tr' where tr'_tr: "Inr tr' \<in> cont tr" and tr1': "tr1' = hsubst tr'"
+ using tr1'_tr1 unfolding tr1 by auto
+ show ?thesis using IH[OF tr1'] proof (elim disjE)
+ assume "inFr (ns - {root tr0}) tr' t"
+ thus ?thesis using tr'_tr unfolding inFrr_def
+ by (metis Diff_iff False Ind(1) empty_iff inFr2_Ind inFr_inFr2 insert_iff rtr1)
+ qed auto
+ qed
+ qed
+ }
+ thus ?thesis using assms by auto
+qed
+
+lemma inFr_hsubst_notin:
+assumes "inFr ns tr t" and "root tr0 \<notin> ns"
+shows "inFr ns (hsubst tr) t"
+using assms apply(induct rule: inFr.induct)
+apply (metis Inl_cont_hsubst_neq inFr2.Base inFr_inFr2 root_hsubst vimageD vimageI2)
+by (metis (lifting) Inr_cont_hsubst_neq inFr.Ind rev_image_eqI root_hsubst vimageD vimageI2)
+
+lemma inFr_hsubst_minus:
+assumes "inFr (ns - {root tr0}) tr t"
+shows "inFr ns (hsubst tr) t"
+proof-
+ have 1: "inFr (ns - {root tr0}) (hsubst tr) t"
+ using inFr_hsubst_notin[OF assms] by simp
+ show ?thesis using inFr_mono[OF 1] by auto
+qed
+
+lemma inFr_self_hsubst:
+assumes "root tr0 \<in> ns"
+shows
+"inFr ns (hsubst tr0) t \<longleftrightarrow>
+ t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t"
+(is "?A \<longleftrightarrow> ?B \<or> ?C")
+apply(intro iffI)
+apply (metis inFr_hsubst_imp Diff_iff inFr_root_in insertI1) proof(elim disjE)
+ assume ?B thus ?A apply(intro inFr.Base) using assms by auto
+next
+ assume ?C then obtain tr where
+ tr_tr0: "Inr tr \<in> cont tr0" and t_tr: "inFr (ns - {root tr0}) tr t"
+ unfolding inFrr_def by auto
+ def tr1 \<equiv> "hsubst tr"
+ have 1: "inFr ns tr1 t" using t_tr unfolding tr1_def using inFr_hsubst_minus by auto
+ have "Inr tr1 \<in> cont (hsubst tr0)" unfolding tr1_def using tr_tr0 by auto
+ thus ?A using 1 inFr.Ind assms by (metis root_hsubst)
+qed
+
+lemma Fr_self_hsubst:
+assumes "root tr0 \<in> ns"
+shows "Fr ns (hsubst tr0) = Inl -` (cont tr0) \<union> Frr (ns - {root tr0}) tr0"
+using inFr_self_hsubst[OF assms] unfolding Frr Fr_def by auto
+
+end (* context *)
+
+
+subsection{* Regular Trees *}
+
+hide_const regular
+
+definition "reg f tr \<equiv> \<forall> tr'. subtr UNIV tr' tr \<longrightarrow> tr' = f (root tr')"
+definition "regular tr \<equiv> \<exists> f. reg f tr"
+
+lemma reg_def2: "reg f tr \<longleftrightarrow> (\<forall> ns tr'. subtr ns tr' tr \<longrightarrow> tr' = f (root tr'))"
+unfolding reg_def using subtr_mono by (metis subset_UNIV)
+
+lemma regular_def2: "regular tr \<longleftrightarrow> (\<exists> f. reg f tr \<and> (\<forall> n. root (f n) = n))"
+unfolding regular_def proof safe
+ fix f assume f: "reg f tr"
+ def g \<equiv> "\<lambda> n. if inItr UNIV tr n then f n else deftr n"
+ show "\<exists>g. reg g tr \<and> (\<forall>n. root (g n) = n)"
+ apply(rule exI[of _ g])
+ using f deftr_simps(1) unfolding g_def reg_def apply safe
+ apply (metis (lifting) inItr.Base subtr_inItr subtr_rootL_in)
+ by (metis (full_types) inItr_subtr)
+qed auto
+
+lemma reg_root:
+assumes "reg f tr"
+shows "f (root tr) = tr"
+using assms unfolding reg_def
+by (metis (lifting) iso_tuple_UNIV_I subtr.Refl)
+
+
+lemma reg_Inr_cont:
+assumes "reg f tr" and "Inr tr' \<in> cont tr"
+shows "reg f tr'"
+by (metis (lifting) assms iso_tuple_UNIV_I reg_def subtr.Step)
+
+lemma reg_subtr:
+assumes "reg f tr" and "subtr ns tr' tr"
+shows "reg f tr'"
+using assms unfolding reg_def using subtr_trans[of UNIV tr] UNIV_I
+by (metis UNIV_eq_I UnCI Un_upper1 iso_tuple_UNIV_I subtr_mono subtr_trans)
+
+lemma regular_subtr:
+assumes r: "regular tr" and s: "subtr ns tr' tr"
+shows "regular tr'"
+using r reg_subtr[OF _ s] unfolding regular_def by auto
+
+lemma subtr_deftr:
+assumes "subtr ns tr' (deftr n)"
+shows "tr' = deftr (root tr')"
+proof-
+ {fix tr have "subtr ns tr' tr \<Longrightarrow> (\<forall> n. tr = deftr n \<longrightarrow> tr' = deftr (root tr'))"
+ apply (induct rule: subtr.induct)
+ proof(metis (lifting) deftr_simps(1), safe)
+ fix tr3 ns tr1 tr2 n
+ assume 1: "root (deftr n) \<in> ns" and 2: "subtr ns tr1 tr2"
+ and IH: "\<forall>n. tr2 = deftr n \<longrightarrow> tr1 = deftr (root tr1)"
+ and 3: "Inr tr2 \<in> cont (deftr n)"
+ have "tr2 \<in> deftr ` UNIV"
+ using 3 unfolding deftr_simps image_def
+ by (metis (lifting, full_types) 3 CollectI Inr_oplus_iff cont_deftr
+ iso_tuple_UNIV_I)
+ then obtain n where "tr2 = deftr n" by auto
+ thus "tr1 = deftr (root tr1)" using IH by auto
+ qed
+ }
+ thus ?thesis using assms by auto
+qed
+
+lemma reg_deftr: "reg deftr (deftr n)"
+unfolding reg_def using subtr_deftr by auto
+
+lemma wf_subtrOf_Union:
+assumes "wf tr"
+shows "\<Union>{K tr' |tr'. Inr tr' \<in> cont tr} =
+ \<Union>{K (subtrOf tr n) |n. Inr n \<in> prodOf tr}"
+unfolding Union_eq Bex_def mem_Collect_eq proof safe
+ fix x xa tr'
+ assume x: "x \<in> K tr'" and tr'_tr: "Inr tr' \<in> cont tr"
+ show "\<exists>X. (\<exists>n. X = K (subtrOf tr n) \<and> Inr n \<in> prodOf tr) \<and> x \<in> X"
+ apply(rule exI[of _ "K (subtrOf tr (root tr'))"]) apply(intro conjI)
+ apply(rule exI[of _ "root tr'"]) apply (metis (lifting) root_prodOf tr'_tr)
+ by (metis (lifting) assms subtrOf_root tr'_tr x)
+next
+ fix x X n ttr
+ assume x: "x \<in> K (subtrOf tr n)" and n: "Inr n = (id \<oplus> root) ttr" and ttr: "ttr \<in> cont tr"
+ show "\<exists>X. (\<exists>tr'. X = K tr' \<and> Inr tr' \<in> cont tr) \<and> x \<in> X"
+ apply(rule exI[of _ "K (subtrOf tr n)"]) apply(intro conjI)
+ apply(rule exI[of _ "subtrOf tr n"]) apply (metis imageI n subtrOf ttr)
+ using x .
+qed
+
+
+
+
+subsection {* Paths in a Regular Tree *}
+
+inductive path :: "(N \<Rightarrow> dtree) \<Rightarrow> N list \<Rightarrow> bool" for f where
+Base: "path f [n]"
+|
+Ind: "\<lbrakk>path f (n1 # nl); Inr (f n1) \<in> cont (f n)\<rbrakk>
+ \<Longrightarrow> path f (n # n1 # nl)"
+
+lemma path_NE:
+assumes "path f nl"
+shows "nl \<noteq> Nil"
+using assms apply(induct rule: path.induct) by auto
+
+lemma path_post:
+assumes f: "path f (n # nl)" and nl: "nl \<noteq> []"
+shows "path f nl"
+proof-
+ obtain n1 nl1 where nl: "nl = n1 # nl1" using nl by (cases nl, auto)
+ show ?thesis using assms unfolding nl using path.simps by (metis (lifting) list.inject)
+qed
+
+lemma path_post_concat:
+assumes "path f (nl1 @ nl2)" and "nl2 \<noteq> Nil"
+shows "path f nl2"
+using assms apply (induct nl1)
+apply (metis append_Nil) by (metis Nil_is_append_conv append_Cons path_post)
+
+lemma path_concat:
+assumes "path f nl1" and "path f ((last nl1) # nl2)"
+shows "path f (nl1 @ nl2)"
+using assms apply(induct rule: path.induct) apply simp
+by (metis append_Cons last.simps list.simps(3) path.Ind)
+
+lemma path_distinct:
+assumes "path f nl"
+shows "\<exists> nl'. path f nl' \<and> hd nl' = hd nl \<and> last nl' = last nl \<and>
+ set nl' \<subseteq> set nl \<and> distinct nl'"
+using assms proof(induct rule: length_induct)
+ case (1 nl) hence p_nl: "path f nl" by simp
+ then obtain n nl1 where nl: "nl = n # nl1" by (metis list.exhaust path_NE)
+ show ?case
+ proof(cases nl1)
+ case Nil
+ show ?thesis apply(rule exI[of _ nl]) using path.Base unfolding nl Nil by simp
+ next
+ case (Cons n1 nl2)
+ hence p1: "path f nl1" by (metis list.simps(3) nl p_nl path_post)
+ show ?thesis
+ proof(cases "n \<in> set nl1")
+ case False
+ obtain nl1' where p1': "path f nl1'" and hd_nl1': "hd nl1' = hd nl1" and
+ l_nl1': "last nl1' = last nl1" and d_nl1': "distinct nl1'"
+ and s_nl1': "set nl1' \<subseteq> set nl1"
+ using 1(1)[THEN allE[of _ nl1]] p1 unfolding nl by auto
+ obtain nl2' where nl1': "nl1' = n1 # nl2'" using path_NE[OF p1'] hd_nl1'
+ unfolding Cons by(cases nl1', auto)
+ show ?thesis apply(intro exI[of _ "n # nl1'"]) unfolding nl proof safe
+ show "path f (n # nl1')" unfolding nl1'
+ apply(rule path.Ind, metis nl1' p1')
+ by (metis (lifting) Cons list.inject nl p1 p_nl path.simps path_NE)
+ qed(insert l_nl1' Cons nl1' s_nl1' d_nl1' False, auto)
+ next
+ case True
+ then obtain nl11 nl12 where nl1: "nl1 = nl11 @ n # nl12"
+ by (metis split_list)
+ have p12: "path f (n # nl12)"
+ apply(rule path_post_concat[of _ "n # nl11"]) using p_nl[unfolded nl nl1] by auto
+ obtain nl12' where p1': "path f nl12'" and hd_nl12': "hd nl12' = n" and
+ l_nl12': "last nl12' = last (n # nl12)" and d_nl12': "distinct nl12'"
+ and s_nl12': "set nl12' \<subseteq> {n} \<union> set nl12"
+ using 1(1)[THEN allE[of _ "n # nl12"]] p12 unfolding nl nl1 by auto
+ thus ?thesis apply(intro exI[of _ nl12']) unfolding nl nl1 by auto
+ qed
+ qed
+qed
+
+lemma path_subtr:
+assumes f: "\<And> n. root (f n) = n"
+and p: "path f nl"
+shows "subtr (set nl) (f (last nl)) (f (hd nl))"
+using p proof (induct rule: path.induct)
+ case (Ind n1 nl n) let ?ns1 = "insert n1 (set nl)"
+ have "path f (n1 # nl)"
+ and "subtr ?ns1 (f (last (n1 # nl))) (f n1)"
+ and fn1: "Inr (f n1) \<in> cont (f n)" using Ind by simp_all
+ hence fn1_flast: "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n1)"
+ by (metis subset_insertI subtr_mono)
+ have 1: "last (n # n1 # nl) = last (n1 # nl)" by auto
+ have "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n)"
+ using f subtr.Step[OF _ fn1_flast fn1] by auto
+ thus ?case unfolding 1 by simp
+qed (metis f hd.simps last_ConsL last_in_set not_Cons_self2 subtr.Refl)
+
+lemma reg_subtr_path_aux:
+assumes f: "reg f tr" and n: "subtr ns tr1 tr"
+shows "\<exists> nl. path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
+using n f proof(induct rule: subtr.induct)
+ case (Refl tr ns)
+ thus ?case
+ apply(intro exI[of _ "[root tr]"]) apply simp by (metis (lifting) path.Base reg_root)
+next
+ case (Step tr ns tr2 tr1)
+ hence rtr: "root tr \<in> ns" and tr1_tr: "Inr tr1 \<in> cont tr"
+ and tr2_tr1: "subtr ns tr2 tr1" and tr: "reg f tr" by auto
+ have tr1: "reg f tr1" using reg_subtr[OF tr] rtr tr1_tr
+ by (metis (lifting) Step.prems iso_tuple_UNIV_I reg_def subtr.Step)
+ obtain nl where nl: "path f nl" and f_nl: "f (hd nl) = tr1"
+ and last_nl: "f (last nl) = tr2" and set: "set nl \<subseteq> ns" using Step(3)[OF tr1] by auto
+ have 0: "path f (root tr # nl)" apply (subst path.simps)
+ using f_nl nl reg_root tr tr1_tr by (metis hd.simps neq_Nil_conv)
+ show ?case apply(rule exI[of _ "(root tr) # nl"])
+ using 0 reg_root tr last_nl nl path_NE rtr set by auto
+qed
+
+lemma reg_subtr_path:
+assumes f: "reg f tr" and n: "subtr ns tr1 tr"
+shows "\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
+using reg_subtr_path_aux[OF assms] path_distinct[of f]
+by (metis (lifting) order_trans)
+
+lemma subtr_iff_path:
+assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
+shows "subtr ns tr1 tr \<longleftrightarrow>
+ (\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns)"
+proof safe
+ fix nl assume p: "path f nl" and nl: "set nl \<subseteq> ns"
+ have "subtr (set nl) (f (last nl)) (f (hd nl))"
+ apply(rule path_subtr) using p f by simp_all
+ thus "subtr ns (f (last nl)) (f (hd nl))"
+ using subtr_mono nl by auto
+qed(insert reg_subtr_path[OF r], auto)
+
+lemma inFr_iff_path:
+assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
+shows
+"inFr ns tr t \<longleftrightarrow>
+ (\<exists> nl tr1. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and>
+ set nl \<subseteq> ns \<and> Inl t \<in> cont tr1)"
+apply safe
+apply (metis (no_types) inFr_subtr r reg_subtr_path)
+by (metis f inFr.Base path_subtr subtr_inFr subtr_mono subtr_rootL_in)
+
+
+
+subsection{* The Regular Cut of a Tree *}
+
+context fixes tr0 :: dtree
+begin
+
+(* Picking a subtree of a certain root: *)
+definition "pick n \<equiv> SOME tr. subtr UNIV tr tr0 \<and> root tr = n"
+
+lemma pick:
+assumes "inItr UNIV tr0 n"
+shows "subtr UNIV (pick n) tr0 \<and> root (pick n) = n"
+proof-
+ have "\<exists> tr. subtr UNIV tr tr0 \<and> root tr = n"
+ using assms by (metis (lifting) inItr_subtr)
+ thus ?thesis unfolding pick_def by(rule someI_ex)
+qed
+
+lemmas subtr_pick = pick[THEN conjunct1]
+lemmas root_pick = pick[THEN conjunct2]
+
+lemma wf_pick:
+assumes tr0: "wf tr0" and n: "inItr UNIV tr0 n"
+shows "wf (pick n)"
+using wf_subtr[OF tr0 subtr_pick[OF n]] .
+
+definition "H_r n \<equiv> root (pick n)"
+definition "H_c n \<equiv> (id \<oplus> root) ` cont (pick n)"
+
+(* The regular tree of a function: *)
+definition H :: "N \<Rightarrow> dtree" where
+"H \<equiv> unfold H_r H_c"
+
+lemma finite_H_c: "finite (H_c n)"
+unfolding H_c_def by (metis finite_cont finite_imageI)
+
+lemma root_H_pick: "root (H n) = root (pick n)"
+using unfold(1)[of H_r H_c n] unfolding H_def H_r_def by simp
+
+lemma root_H[simp]:
+assumes "inItr UNIV tr0 n"
+shows "root (H n) = n"
+unfolding root_H_pick root_pick[OF assms] ..
+
+lemma cont_H[simp]:
+"cont (H n) = (id \<oplus> (H o root)) ` cont (pick n)"
+apply(subst id_comp[symmetric, of id]) unfolding sum_map.comp[symmetric]
+unfolding image_compose unfolding H_c_def[symmetric]
+using unfold(2)[of H_c n H_r, OF finite_H_c]
+unfolding H_def ..
+
+lemma Inl_cont_H[simp]:
+"Inl -` (cont (H n)) = Inl -` (cont (pick n))"
+unfolding cont_H by simp
+
+lemma Inr_cont_H:
+"Inr -` (cont (H n)) = (H \<circ> root) ` (Inr -` cont (pick n))"
+unfolding cont_H by simp
+
+lemma subtr_H:
+assumes n: "inItr UNIV tr0 n" and "subtr UNIV tr1 (H n)"
+shows "\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = H n1"
+proof-
+ {fix tr ns assume "subtr UNIV tr1 tr"
+ hence "tr = H n \<longrightarrow> (\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = H n1)"
+ proof (induct rule: subtr_UNIV_inductL)
+ case (Step tr2 tr1 tr)
+ show ?case proof
+ assume "tr = H n"
+ then obtain n1 where tr2: "Inr tr2 \<in> cont tr1"
+ and tr1_tr: "subtr UNIV tr1 tr" and n1: "inItr UNIV tr0 n1" and tr1: "tr1 = H n1"
+ using Step by auto
+ obtain tr2' where tr2: "tr2 = H (root tr2')"
+ and tr2': "Inr tr2' \<in> cont (pick n1)"
+ using tr2 Inr_cont_H[of n1]
+ unfolding tr1 image_def comp_def using vimage_eq by auto
+ have "inItr UNIV tr0 (root tr2')"
+ using inItr.Base inItr.Ind n1 pick subtr_inItr tr2' by (metis iso_tuple_UNIV_I)
+ thus "\<exists>n2. inItr UNIV tr0 n2 \<and> tr2 = H n2" using tr2 by blast
+ qed
+ qed(insert n, auto)
+ }
+ thus ?thesis using assms by auto
+qed
+
+lemma root_H_root:
+assumes n: "inItr UNIV tr0 n" and t_tr: "t_tr \<in> cont (pick n)"
+shows "(id \<oplus> (root \<circ> H \<circ> root)) t_tr = (id \<oplus> root) t_tr"
+using assms apply(cases t_tr)
+ apply (metis (lifting) sum_map.simps(1))
+ using pick H_def H_r_def unfold(1)
+ inItr.Base comp_apply subtr_StepL subtr_inItr sum_map.simps(2)
+ by (metis UNIV_I)
+
+lemma H_P:
+assumes tr0: "wf tr0" and n: "inItr UNIV tr0 n"
+shows "(n, (id \<oplus> root) ` cont (H n)) \<in> P" (is "?L \<in> P")
+proof-
+ have "?L = (n, (id \<oplus> root) ` cont (pick n))"
+ unfolding cont_H image_compose[symmetric] sum_map.comp id_comp comp_assoc[symmetric]
+ unfolding Pair_eq apply(rule conjI[OF refl]) apply(rule image_cong[OF refl])
+ by (rule root_H_root[OF n])
+ moreover have "... \<in> P" by (metis (lifting) wf_pick root_pick wf_P n tr0)
+ ultimately show ?thesis by simp
+qed
+
+lemma wf_H:
+assumes tr0: "wf tr0" and "inItr UNIV tr0 n"
+shows "wf (H n)"
+proof-
+ {fix tr have "\<exists> n. inItr UNIV tr0 n \<and> tr = H n \<Longrightarrow> wf tr"
+ proof (induct rule: wf_raw_coind)
+ case (Hyp tr)
+ then obtain n where n: "inItr UNIV tr0 n" and tr: "tr = H n" by auto
+ show ?case apply safe
+ apply (metis (lifting) H_P root_H n tr tr0)
+ unfolding tr Inr_cont_H unfolding inj_on_def apply clarsimp using root_H
+ apply (metis UNIV_I inItr.Base n pick subtr2.simps subtr_inItr subtr_subtr2)
+ by (metis n subtr.Refl subtr_StepL subtr_H tr UNIV_I)
+ qed
+ }
+ thus ?thesis using assms by blast
+qed
+
+(* The regular cut of a tree: *)
+definition "rcut \<equiv> H (root tr0)"
+
+lemma reg_rcut: "reg H rcut"
+unfolding reg_def rcut_def
+by (metis inItr.Base root_H subtr_H UNIV_I)
+
+lemma rcut_reg:
+assumes "reg H tr0"
+shows "rcut = tr0"
+using assms unfolding rcut_def reg_def by (metis subtr.Refl UNIV_I)
+
+lemma rcut_eq: "rcut = tr0 \<longleftrightarrow> reg H tr0"
+using reg_rcut rcut_reg by metis
+
+lemma regular_rcut: "regular rcut"
+using reg_rcut unfolding regular_def by blast
+
+lemma Fr_rcut: "Fr UNIV rcut \<subseteq> Fr UNIV tr0"
+proof safe
+ fix t assume "t \<in> Fr UNIV rcut"
+ then obtain tr where t: "Inl t \<in> cont tr" and tr: "subtr UNIV tr (H (root tr0))"
+ using Fr_subtr[of UNIV "H (root tr0)"] unfolding rcut_def
+ by (metis (full_types) Fr_def inFr_subtr mem_Collect_eq)
+ obtain n where n: "inItr UNIV tr0 n" and tr: "tr = H n" using tr
+ by (metis (lifting) inItr.Base subtr_H UNIV_I)
+ have "Inl t \<in> cont (pick n)" using t using Inl_cont_H[of n] unfolding tr
+ by (metis (lifting) vimageD vimageI2)
+ moreover have "subtr UNIV (pick n) tr0" using subtr_pick[OF n] ..
+ ultimately show "t \<in> Fr UNIV tr0" unfolding Fr_subtr_cont by auto
+qed
+
+lemma wf_rcut:
+assumes "wf tr0"
+shows "wf rcut"
+unfolding rcut_def using wf_H[OF assms inItr.Base] by simp
+
+lemma root_rcut[simp]: "root rcut = root tr0"
+unfolding rcut_def
+by (metis (lifting) root_H inItr.Base reg_def reg_root subtr_rootR_in)
+
+end (* context *)
+
+
+subsection{* Recursive Description of the Regular Tree Frontiers *}
+
+lemma regular_inFr:
+assumes r: "regular tr" and In: "root tr \<in> ns"
+and t: "inFr ns tr t"
+shows "t \<in> Inl -` (cont tr) \<or>
+ (\<exists> tr'. Inr tr' \<in> cont tr \<and> inFr (ns - {root tr}) tr' t)"
+(is "?L \<or> ?R")
+proof-
+ obtain f where r: "reg f tr" and f: "\<And>n. root (f n) = n"
+ using r unfolding regular_def2 by auto
+ obtain nl tr1 where d_nl: "distinct nl" and p: "path f nl" and hd_nl: "f (hd nl) = tr"
+ and l_nl: "f (last nl) = tr1" and s_nl: "set nl \<subseteq> ns" and t_tr1: "Inl t \<in> cont tr1"
+ using t unfolding inFr_iff_path[OF r f] by auto
+ obtain n nl1 where nl: "nl = n # nl1" by (metis (lifting) p path.simps)
+ hence f_n: "f n = tr" using hd_nl by simp
+ have n_nl1: "n \<notin> set nl1" using d_nl unfolding nl by auto
+ show ?thesis
+ proof(cases nl1)
+ case Nil hence "tr = tr1" using f_n l_nl unfolding nl by simp
+ hence ?L using t_tr1 by simp thus ?thesis by simp
+ next
+ case (Cons n1 nl2) note nl1 = Cons
+ have 1: "last nl1 = last nl" "hd nl1 = n1" unfolding nl nl1 by simp_all
+ have p1: "path f nl1" and n1_tr: "Inr (f n1) \<in> cont tr"
+ using path.simps[of f nl] p f_n unfolding nl nl1 by auto
+ have r1: "reg f (f n1)" using reg_Inr_cont[OF r n1_tr] .
+ have 0: "inFr (set nl1) (f n1) t" unfolding inFr_iff_path[OF r1 f]
+ apply(intro exI[of _ nl1], intro exI[of _ tr1])
+ using d_nl unfolding 1 l_nl unfolding nl using p1 t_tr1 by auto
+ have root_tr: "root tr = n" by (metis f f_n)
+ have "inFr (ns - {root tr}) (f n1) t" apply(rule inFr_mono[OF 0])
+ using s_nl unfolding root_tr unfolding nl using n_nl1 by auto
+ thus ?thesis using n1_tr by auto
+ qed
+qed
+
+lemma regular_Fr:
+assumes r: "regular tr" and In: "root tr \<in> ns"
+shows "Fr ns tr =
+ Inl -` (cont tr) \<union>
+ \<Union> {Fr (ns - {root tr}) tr' | tr'. Inr tr' \<in> cont tr}"
+unfolding Fr_def
+using In inFr.Base regular_inFr[OF assms] apply safe
+apply (simp, metis (full_types) mem_Collect_eq)
+apply simp
+by (simp, metis (lifting) inFr_Ind_minus insert_Diff)
+
+
+subsection{* The Generated Languages *}
+
+(* The (possibly inifinite tree) generated language *)
+definition "L ns n \<equiv> {Fr ns tr | tr. wf tr \<and> root tr = n}"
+
+(* The regular-tree generated language *)
+definition "Lr ns n \<equiv> {Fr ns tr | tr. wf tr \<and> root tr = n \<and> regular tr}"
+
+lemma L_rec_notin:
+assumes "n \<notin> ns"
+shows "L ns n = {{}}"
+using assms unfolding L_def apply safe
+ using not_root_Fr apply force
+ apply(rule exI[of _ "deftr n"])
+ by (metis (no_types) wf_deftr not_root_Fr root_deftr)
+
+lemma Lr_rec_notin:
+assumes "n \<notin> ns"
+shows "Lr ns n = {{}}"
+using assms unfolding Lr_def apply safe
+ using not_root_Fr apply force
+ apply(rule exI[of _ "deftr n"])
+ by (metis (no_types) regular_def wf_deftr not_root_Fr reg_deftr root_deftr)
+
+lemma wf_subtrOf:
+assumes "wf tr" and "Inr n \<in> prodOf tr"
+shows "wf (subtrOf tr n)"
+by (metis assms wf_cont subtrOf)
+
+lemma Lr_rec_in:
+assumes n: "n \<in> ns"
+shows "Lr ns n \<subseteq>
+{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
+ (n,tns) \<in> P \<and>
+ (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n')}"
+(is "Lr ns n \<subseteq> {?F tns K | tns K. (n,tns) \<in> P \<and> ?\<phi> tns K}")
+proof safe
+ fix ts assume "ts \<in> Lr ns n"
+ then obtain tr where dtr: "wf tr" and r: "root tr = n" and tr: "regular tr"
+ and ts: "ts = Fr ns tr" unfolding Lr_def by auto
+ def tns \<equiv> "(id \<oplus> root) ` (cont tr)"
+ def K \<equiv> "\<lambda> n'. Fr (ns - {n}) (subtrOf tr n')"
+ show "\<exists>tns K. ts = ?F tns K \<and> (n, tns) \<in> P \<and> ?\<phi> tns K"
+ apply(rule exI[of _ tns], rule exI[of _ K]) proof(intro conjI allI impI)
+ show "ts = Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns}"
+ unfolding ts regular_Fr[OF tr n[unfolded r[symmetric]]]
+ unfolding tns_def K_def r[symmetric]
+ unfolding Inl_prodOf wf_subtrOf_Union[OF dtr] ..
+ show "(n, tns) \<in> P" unfolding tns_def r[symmetric] using wf_P[OF dtr] .
+ fix n' assume "Inr n' \<in> tns" thus "K n' \<in> Lr (ns - {n}) n'"
+ unfolding K_def Lr_def mem_Collect_eq apply(intro exI[of _ "subtrOf tr n'"])
+ using dtr tr apply(intro conjI refl) unfolding tns_def
+ apply(erule wf_subtrOf[OF dtr])
+ apply (metis subtrOf)
+ by (metis Inr_subtrOf UNIV_I regular_subtr subtr.simps)
+ qed
+qed
+
+lemma hsubst_aux:
+fixes n ftr tns
+assumes n: "n \<in> ns" and tns: "finite tns" and
+1: "\<And> n'. Inr n' \<in> tns \<Longrightarrow> wf (ftr n')"
+defines "tr \<equiv> Node n ((id \<oplus> ftr) ` tns)" defines "tr' \<equiv> hsubst tr tr"
+shows "Fr ns tr' = Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
+(is "_ = ?B") proof-
+ have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
+ unfolding tr_def using tns by auto
+ have Frr: "Frr (ns - {n}) tr = \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
+ unfolding Frr_def ctr by auto
+ have "Fr ns tr' = Inl -` (cont tr) \<union> Frr (ns - {n}) tr"
+ using Fr_self_hsubst[OF n[unfolded rtr[symmetric]]] unfolding tr'_def rtr ..
+ also have "... = ?B" unfolding ctr Frr by simp
+ finally show ?thesis .
+qed
+
+lemma L_rec_in:
+assumes n: "n \<in> ns"
+shows "
+{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
+ (n,tns) \<in> P \<and>
+ (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n')}
+ \<subseteq> L ns n"
+proof safe
+ fix tns K
+ assume P: "(n, tns) \<in> P" and 0: "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n'"
+ {fix n' assume "Inr n' \<in> tns"
+ hence "K n' \<in> L (ns - {n}) n'" using 0 by auto
+ hence "\<exists> tr'. K n' = Fr (ns - {n}) tr' \<and> wf tr' \<and> root tr' = n'"
+ unfolding L_def mem_Collect_eq by auto
+ }
+ then obtain ftr where 0: "\<And> n'. Inr n' \<in> tns \<Longrightarrow>
+ K n' = Fr (ns - {n}) (ftr n') \<and> wf (ftr n') \<and> root (ftr n') = n'"
+ by metis
+ def tr \<equiv> "Node n ((id \<oplus> ftr) ` tns)" def tr' \<equiv> "hsubst tr tr"
+ have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
+ unfolding tr_def by (simp, metis P cont_Node finite_imageI finite_in_P)
+ have prtr: "prodOf tr = tns" apply(rule Inl_Inr_image_cong)
+ unfolding ctr apply simp apply simp apply safe
+ using 0 unfolding image_def apply force apply simp by (metis 0 vimageI2)
+ have 1: "{K n' |n'. Inr n' \<in> tns} = {Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
+ using 0 by auto
+ have dtr: "wf tr" apply(rule wf.dtree)
+ apply (metis (lifting) P prtr rtr)
+ unfolding inj_on_def ctr using 0 by auto
+ hence dtr': "wf tr'" unfolding tr'_def by (metis wf_hsubst)
+ have tns: "finite tns" using finite_in_P P by simp
+ have "Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns} \<in> L ns n"
+ unfolding L_def mem_Collect_eq apply(intro exI[of _ tr'] conjI)
+ using dtr' 0 hsubst_aux[OF assms tns, of ftr] unfolding tr_def tr'_def by auto
+ thus "Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} \<in> L ns n" unfolding 1 .
+qed
+
+lemma card_N: "(n::N) \<in> ns \<Longrightarrow> card (ns - {n}) < card ns"
+by (metis finite_N Diff_UNIV Diff_infinite_finite card_Diff1_less finite.emptyI)
+
+function LL where
+"LL ns n =
+ (if n \<notin> ns then {{}} else
+ {Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
+ (n,tns) \<in> P \<and>
+ (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n')})"
+by(pat_completeness, auto)
+termination apply(relation "inv_image (measure card) fst")
+using card_N by auto
+
+declare LL.simps[code]
+declare LL.simps[simp del]
+
+lemma Lr_LL: "Lr ns n \<subseteq> LL ns n"
+proof (induct ns arbitrary: n rule: measure_induct[of card])
+ case (1 ns n) show ?case proof(cases "n \<in> ns")
+ case False thus ?thesis unfolding Lr_rec_notin[OF False] by (simp add: LL.simps)
+ next
+ case True show ?thesis apply(rule subset_trans)
+ using Lr_rec_in[OF True] apply assumption
+ unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
+ fix tns K
+ assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
+ assume "(n, tns) \<in> P"
+ and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n'"
+ thus "\<exists>tnsa Ka.
+ Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
+ Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
+ (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> LL (ns - {n}) n')"
+ apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
+ qed
+ qed
+qed
+
+lemma LL_L: "LL ns n \<subseteq> L ns n"
+proof (induct ns arbitrary: n rule: measure_induct[of card])
+ case (1 ns n) show ?case proof(cases "n \<in> ns")
+ case False thus ?thesis unfolding L_rec_notin[OF False] by (simp add: LL.simps)
+ next
+ case True show ?thesis apply(rule subset_trans)
+ prefer 2 using L_rec_in[OF True] apply assumption
+ unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
+ fix tns K
+ assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
+ assume "(n, tns) \<in> P"
+ and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n'"
+ thus "\<exists>tnsa Ka.
+ Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
+ Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
+ (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> L (ns - {n}) n')"
+ apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
+ qed
+ qed
+qed
+
+(* The subsumpsion relation between languages *)
+definition "subs L1 L2 \<equiv> \<forall> ts2 \<in> L2. \<exists> ts1 \<in> L1. ts1 \<subseteq> ts2"
+
+lemma incl_subs[simp]: "L2 \<subseteq> L1 \<Longrightarrow> subs L1 L2"
+unfolding subs_def by auto
+
+lemma subs_refl[simp]: "subs L1 L1" unfolding subs_def by auto
+
+lemma subs_trans: "\<lbrakk>subs L1 L2; subs L2 L3\<rbrakk> \<Longrightarrow> subs L1 L3"
+unfolding subs_def by (metis subset_trans)
+
+(* Language equivalence *)
+definition "leqv L1 L2 \<equiv> subs L1 L2 \<and> subs L2 L1"
+
+lemma subs_leqv[simp]: "leqv L1 L2 \<Longrightarrow> subs L1 L2"
+unfolding leqv_def by auto
+
+lemma subs_leqv_sym[simp]: "leqv L1 L2 \<Longrightarrow> subs L2 L1"
+unfolding leqv_def by auto
+
+lemma leqv_refl[simp]: "leqv L1 L1" unfolding leqv_def by auto
+
+lemma leqv_trans:
+assumes 12: "leqv L1 L2" and 23: "leqv L2 L3"
+shows "leqv L1 L3"
+using assms unfolding leqv_def by (metis (lifting) subs_trans)
+
+lemma leqv_sym: "leqv L1 L2 \<Longrightarrow> leqv L2 L1"
+unfolding leqv_def by auto
+
+lemma leqv_Sym: "leqv L1 L2 \<longleftrightarrow> leqv L2 L1"
+unfolding leqv_def by auto
+
+lemma Lr_incl_L: "Lr ns ts \<subseteq> L ns ts"
+unfolding Lr_def L_def by auto
+
+lemma Lr_subs_L: "subs (Lr UNIV ts) (L UNIV ts)"
+unfolding subs_def proof safe
+ fix ts2 assume "ts2 \<in> L UNIV ts"
+ then obtain tr where ts2: "ts2 = Fr UNIV tr" and dtr: "wf tr" and rtr: "root tr = ts"
+ unfolding L_def by auto
+ thus "\<exists>ts1\<in>Lr UNIV ts. ts1 \<subseteq> ts2"
+ apply(intro bexI[of _ "Fr UNIV (rcut tr)"])
+ unfolding Lr_def L_def using Fr_rcut wf_rcut root_rcut regular_rcut by auto
+qed
+
+lemma Lr_leqv_L: "leqv (Lr UNIV ts) (L UNIV ts)"
+using Lr_subs_L unfolding leqv_def by (metis (lifting) Lr_incl_L incl_subs)
+
+lemma LL_leqv_L: "leqv (LL UNIV ts) (L UNIV ts)"
+by (metis (lifting) LL_L Lr_LL Lr_subs_L incl_subs leqv_def subs_trans)
+
+lemma LL_leqv_Lr: "leqv (LL UNIV ts) (Lr UNIV ts)"
+using Lr_leqv_L LL_leqv_L by (metis leqv_Sym leqv_trans)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/Derivation_Trees/Parallel.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,147 @@
+(* Title: HOL/BNF/Examples/Derivation_Trees/Parallel.thy
+ Author: Andrei Popescu, TU Muenchen
+ Copyright 2012
+
+Parallel composition.
+*)
+
+header {* Parallel Composition *}
+
+theory Parallel
+imports DTree
+begin
+
+no_notation plus_class.plus (infixl "+" 65)
+
+consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)
+
+axiomatization where
+ Nplus_comm: "(a::N) + b = b + (a::N)"
+and Nplus_assoc: "((a::N) + b) + c = a + (b + c)"
+
+subsection{* Corecursive Definition of Parallel Composition *}
+
+fun par_r where "par_r (tr1,tr2) = root tr1 + root tr2"
+fun par_c where
+"par_c (tr1,tr2) =
+ Inl ` (Inl -` (cont tr1 \<union> cont tr2)) \<union>
+ Inr ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
+
+declare par_r.simps[simp del] declare par_c.simps[simp del]
+
+definition par :: "dtree \<times> dtree \<Rightarrow> dtree" where
+"par \<equiv> unfold par_r par_c"
+
+abbreviation par_abbr (infixr "\<parallel>" 80) where "tr1 \<parallel> tr2 \<equiv> par (tr1, tr2)"
+
+lemma finite_par_c: "finite (par_c (tr1, tr2))"
+unfolding par_c.simps apply(rule finite_UnI)
+ apply (metis finite_Un finite_cont finite_imageI finite_vimageI inj_Inl)
+ apply(intro finite_imageI finite_cartesian_product finite_vimageI)
+ using finite_cont by auto
+
+lemma root_par: "root (tr1 \<parallel> tr2) = root tr1 + root tr2"
+using unfold(1)[of par_r par_c "(tr1,tr2)"] unfolding par_def par_r.simps by simp
+
+lemma cont_par:
+"cont (tr1 \<parallel> tr2) = (id \<oplus> par) ` par_c (tr1,tr2)"
+using unfold(2)[of par_c "(tr1,tr2)" par_r, OF finite_par_c]
+unfolding par_def ..
+
+lemma Inl_cont_par[simp]:
+"Inl -` (cont (tr1 \<parallel> tr2)) = Inl -` (cont tr1 \<union> cont tr2)"
+unfolding cont_par par_c.simps by auto
+
+lemma Inr_cont_par[simp]:
+"Inr -` (cont (tr1 \<parallel> tr2)) = par ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
+unfolding cont_par par_c.simps by auto
+
+lemma Inl_in_cont_par:
+"Inl t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (Inl t \<in> cont tr1 \<or> Inl t \<in> cont tr2)"
+using Inl_cont_par[of tr1 tr2] unfolding vimage_def by auto
+
+lemma Inr_in_cont_par:
+"Inr t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (t \<in> par ` (Inr -` cont tr1 \<times> Inr -` cont tr2))"
+using Inr_cont_par[of tr1 tr2] unfolding vimage_def by auto
+
+
+subsection{* Structural Coinduction Proofs *}
+
+lemma set_rel_sum_rel_eq[simp]:
+"set_rel (sum_rel (op =) \<phi>) A1 A2 \<longleftrightarrow>
+ Inl -` A1 = Inl -` A2 \<and> set_rel \<phi> (Inr -` A1) (Inr -` A2)"
+unfolding set_rel_sum_rel set_rel_eq ..
+
+(* Detailed proofs of commutativity and associativity: *)
+theorem par_com: "tr1 \<parallel> tr2 = tr2 \<parallel> tr1"
+proof-
+ let ?\<theta> = "\<lambda> trA trB. \<exists> tr1 tr2. trA = tr1 \<parallel> tr2 \<and> trB = tr2 \<parallel> tr1"
+ {fix trA trB
+ assume "?\<theta> trA trB" hence "trA = trB"
+ apply (induct rule: dtree_coinduct)
+ unfolding set_rel_sum_rel set_rel_eq unfolding set_rel_def proof safe
+ fix tr1 tr2 show "root (tr1 \<parallel> tr2) = root (tr2 \<parallel> tr1)"
+ unfolding root_par by (rule Nplus_comm)
+ next
+ fix n tr1 tr2 assume "Inl n \<in> cont (tr1 \<parallel> tr2)" thus "n \<in> Inl -` (cont (tr2 \<parallel> tr1))"
+ unfolding Inl_in_cont_par by auto
+ next
+ fix n tr1 tr2 assume "Inl n \<in> cont (tr2 \<parallel> tr1)" thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2))"
+ unfolding Inl_in_cont_par by auto
+ next
+ fix tr1 tr2 trA' assume "Inr trA' \<in> cont (tr1 \<parallel> tr2)"
+ then obtain tr1' tr2' where "trA' = tr1' \<parallel> tr2'"
+ and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
+ unfolding Inr_in_cont_par by auto
+ thus "\<exists> trB' \<in> Inr -` (cont (tr2 \<parallel> tr1)). ?\<theta> trA' trB'"
+ apply(intro bexI[of _ "tr2' \<parallel> tr1'"]) unfolding Inr_in_cont_par by auto
+ next
+ fix tr1 tr2 trB' assume "Inr trB' \<in> cont (tr2 \<parallel> tr1)"
+ then obtain tr1' tr2' where "trB' = tr2' \<parallel> tr1'"
+ and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
+ unfolding Inr_in_cont_par by auto
+ thus "\<exists> trA' \<in> Inr -` (cont (tr1 \<parallel> tr2)). ?\<theta> trA' trB'"
+ apply(intro bexI[of _ "tr1' \<parallel> tr2'"]) unfolding Inr_in_cont_par by auto
+ qed
+ }
+ thus ?thesis by blast
+qed
+
+lemma par_assoc: "(tr1 \<parallel> tr2) \<parallel> tr3 = tr1 \<parallel> (tr2 \<parallel> tr3)"
+proof-
+ let ?\<theta> =
+ "\<lambda> trA trB. \<exists> tr1 tr2 tr3. trA = (tr1 \<parallel> tr2) \<parallel> tr3 \<and> trB = tr1 \<parallel> (tr2 \<parallel> tr3)"
+ {fix trA trB
+ assume "?\<theta> trA trB" hence "trA = trB"
+ apply (induct rule: dtree_coinduct)
+ unfolding set_rel_sum_rel set_rel_eq unfolding set_rel_def proof safe
+ fix tr1 tr2 tr3 show "root ((tr1 \<parallel> tr2) \<parallel> tr3) = root (tr1 \<parallel> (tr2 \<parallel> tr3))"
+ unfolding root_par by (rule Nplus_assoc)
+ next
+ fix n tr1 tr2 tr3 assume "Inl n \<in> (cont ((tr1 \<parallel> tr2) \<parallel> tr3))"
+ thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2 \<parallel> tr3))" unfolding Inl_in_cont_par by simp
+ next
+ fix n tr1 tr2 tr3 assume "Inl n \<in> (cont (tr1 \<parallel> tr2 \<parallel> tr3))"
+ thus "n \<in> Inl -` (cont ((tr1 \<parallel> tr2) \<parallel> tr3))" unfolding Inl_in_cont_par by simp
+ next
+ fix trA' tr1 tr2 tr3 assume "Inr trA' \<in> cont ((tr1 \<parallel> tr2) \<parallel> tr3)"
+ then obtain tr1' tr2' tr3' where "trA' = (tr1' \<parallel> tr2') \<parallel> tr3'"
+ and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
+ and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
+ thus "\<exists> trB' \<in> Inr -` (cont (tr1 \<parallel> tr2 \<parallel> tr3)). ?\<theta> trA' trB'"
+ apply(intro bexI[of _ "tr1' \<parallel> tr2' \<parallel> tr3'"])
+ unfolding Inr_in_cont_par by auto
+ next
+ fix trB' tr1 tr2 tr3 assume "Inr trB' \<in> cont (tr1 \<parallel> tr2 \<parallel> tr3)"
+ then obtain tr1' tr2' tr3' where "trB' = tr1' \<parallel> (tr2' \<parallel> tr3')"
+ and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
+ and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
+ thus "\<exists> trA' \<in> Inr -` cont ((tr1 \<parallel> tr2) \<parallel> tr3). ?\<theta> trA' trB'"
+ apply(intro bexI[of _ "(tr1' \<parallel> tr2') \<parallel> tr3'"])
+ unfolding Inr_in_cont_par by auto
+ qed
+ }
+ thus ?thesis by blast
+qed
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/Derivation_Trees/Prelim.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,62 @@
+(* Title: HOL/BNF/Examples/Derivation_Trees/Prelim.thy
+ Author: Andrei Popescu, TU Muenchen
+ Copyright 2012
+
+Preliminaries.
+*)
+
+header {* Preliminaries *}
+
+theory Prelim
+imports "../../BNF" "../../More_BNFs"
+begin
+
+declare fset_to_fset[simp]
+
+lemma fst_snd_convol_o[simp]: "<fst o s, snd o s> = s"
+apply(rule ext) by (simp add: convol_def)
+
+abbreviation sm_abbrev (infix "\<oplus>" 60)
+where "f \<oplus> g \<equiv> Sum_Type.sum_map f g"
+
+lemma sum_map_InlD: "(f \<oplus> g) z = Inl x \<Longrightarrow> \<exists>y. z = Inl y \<and> f y = x"
+by (cases z) auto
+
+lemma sum_map_InrD: "(f \<oplus> g) z = Inr x \<Longrightarrow> \<exists>y. z = Inr y \<and> g y = x"
+by (cases z) auto
+
+abbreviation sum_case_abbrev ("[[_,_]]" 800)
+where "[[f,g]] \<equiv> Sum_Type.sum_case f g"
+
+lemma Inl_oplus_elim:
+assumes "Inl tr \<in> (id \<oplus> f) ` tns"
+shows "Inl tr \<in> tns"
+using assms apply clarify by (case_tac x, auto)
+
+lemma Inl_oplus_iff[simp]: "Inl tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> Inl tr \<in> tns"
+using Inl_oplus_elim
+by (metis id_def image_iff sum_map.simps(1))
+
+lemma Inl_m_oplus[simp]: "Inl -` (id \<oplus> f) ` tns = Inl -` tns"
+using Inl_oplus_iff unfolding vimage_def by auto
+
+lemma Inr_oplus_elim:
+assumes "Inr tr \<in> (id \<oplus> f) ` tns"
+shows "\<exists> n. Inr n \<in> tns \<and> f n = tr"
+using assms apply clarify by (case_tac x, auto)
+
+lemma Inr_oplus_iff[simp]:
+"Inr tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> (\<exists> n. Inr n \<in> tns \<and> f n = tr)"
+apply (rule iffI)
+ apply (metis Inr_oplus_elim)
+by (metis image_iff sum_map.simps(2))
+
+lemma Inr_m_oplus[simp]: "Inr -` (id \<oplus> f) ` tns = f ` (Inr -` tns)"
+using Inr_oplus_iff unfolding vimage_def by auto
+
+lemma Inl_Inr_image_cong:
+assumes "Inl -` A = Inl -` B" and "Inr -` A = Inr -` B"
+shows "A = B"
+apply safe using assms apply(case_tac x, auto) by(case_tac x, auto)
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/Koenig.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,122 @@
+(* Title: HOL/BNF/Examples/Koenig.thy
+ Author: Dmitriy Traytel, TU Muenchen
+ Author: Andrei Popescu, TU Muenchen
+ Copyright 2012
+
+Koenig's lemma.
+*)
+
+header {* Koenig's lemma *}
+
+theory Koenig
+imports TreeFI Stream
+begin
+
+(* infinite trees: *)
+coinductive infiniteTr where
+"\<lbrakk>tr' \<in> set_listF (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"
+
+lemma infiniteTr_strong_coind[consumes 1, case_names sub]:
+assumes *: "phi tr" and
+**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set_listF (sub tr). phi tr' \<or> infiniteTr tr'"
+shows "infiniteTr tr"
+using assms by (elim infiniteTr.coinduct) blast
+
+lemma infiniteTr_coind[consumes 1, case_names sub, induct pred: infiniteTr]:
+assumes *: "phi tr" and
+**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set_listF (sub tr). phi tr'"
+shows "infiniteTr tr"
+using assms by (elim infiniteTr.coinduct) blast
+
+lemma infiniteTr_sub[simp]:
+"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> set_listF (sub tr). infiniteTr tr')"
+by (erule infiniteTr.cases) blast
+
+primcorec konigPath where
+ "shd (konigPath t) = lab t"
+| "stl (konigPath t) = konigPath (SOME tr. tr \<in> set_listF (sub t) \<and> infiniteTr tr)"
+
+(* proper paths in trees: *)
+coinductive properPath where
+"\<lbrakk>shd as = lab tr; tr' \<in> set_listF (sub tr); properPath (stl as) tr'\<rbrakk> \<Longrightarrow>
+ properPath as tr"
+
+lemma properPath_strong_coind[consumes 1, case_names shd_lab sub]:
+assumes *: "phi as tr" and
+**: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
+***: "\<And> as tr.
+ phi as tr \<Longrightarrow>
+ \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
+shows "properPath as tr"
+using assms by (elim properPath.coinduct) blast
+
+lemma properPath_coind[consumes 1, case_names shd_lab sub, induct pred: properPath]:
+assumes *: "phi as tr" and
+**: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
+***: "\<And> as tr.
+ phi as tr \<Longrightarrow>
+ \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr'"
+shows "properPath as tr"
+using properPath_strong_coind[of phi, OF * **] *** by blast
+
+lemma properPath_shd_lab:
+"properPath as tr \<Longrightarrow> shd as = lab tr"
+by (erule properPath.cases) blast
+
+lemma properPath_sub:
+"properPath as tr \<Longrightarrow>
+ \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
+by (erule properPath.cases) blast
+
+(* prove the following by coinduction *)
+theorem Konig:
+ assumes "infiniteTr tr"
+ shows "properPath (konigPath tr) tr"
+proof-
+ {fix as
+ assume "infiniteTr tr \<and> as = konigPath tr" hence "properPath as tr"
+ proof (coinduction arbitrary: tr as rule: properPath_coind)
+ case (sub tr as)
+ let ?t = "SOME t'. t' \<in> set_listF (sub tr) \<and> infiniteTr t'"
+ from sub have "\<exists>t' \<in> set_listF (sub tr). infiniteTr t'" by simp
+ then have "\<exists>t'. t' \<in> set_listF (sub tr) \<and> infiniteTr t'" by blast
+ then have "?t \<in> set_listF (sub tr) \<and> infiniteTr ?t" by (rule someI_ex)
+ moreover have "stl (konigPath tr) = konigPath ?t" by simp
+ ultimately show ?case using sub by blast
+ qed simp
+ }
+ thus ?thesis using assms by blast
+qed
+
+(* some more stream theorems *)
+
+primcorec plus :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<oplus>" 66) where
+ "shd (plus xs ys) = shd xs + shd ys"
+| "stl (plus xs ys) = plus (stl xs) (stl ys)"
+
+definition scalar :: "nat \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<cdot>" 68) where
+ [simp]: "scalar n = smap (\<lambda>x. n * x)"
+
+primcorec ones :: "nat stream" where "ones = 1 ## ones"
+primcorec twos :: "nat stream" where "twos = 2 ## twos"
+definition ns :: "nat \<Rightarrow> nat stream" where [simp]: "ns n = scalar n ones"
+
+lemma "ones \<oplus> ones = twos"
+ by coinduction simp
+
+lemma "n \<cdot> twos = ns (2 * n)"
+ by coinduction simp
+
+lemma prod_scalar: "(n * m) \<cdot> xs = n \<cdot> m \<cdot> xs"
+ by (coinduction arbitrary: xs) auto
+
+lemma scalar_plus: "n \<cdot> (xs \<oplus> ys) = n \<cdot> xs \<oplus> n \<cdot> ys"
+ by (coinduction arbitrary: xs ys) (auto simp: add_mult_distrib2)
+
+lemma plus_comm: "xs \<oplus> ys = ys \<oplus> xs"
+ by (coinduction arbitrary: xs ys) auto
+
+lemma plus_assoc: "(xs \<oplus> ys) \<oplus> zs = xs \<oplus> ys \<oplus> zs"
+ by (coinduction arbitrary: xs ys zs) auto
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/Lambda_Term.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,52 @@
+(* Title: HOL/BNF/Examples/Lambda_Term.thy
+ Author: Dmitriy Traytel, TU Muenchen
+ Author: Andrei Popescu, TU Muenchen
+ Copyright 2012
+
+Lambda-terms.
+*)
+
+header {* Lambda-Terms *}
+
+theory Lambda_Term
+imports "../More_BNFs"
+begin
+
+thy_deps
+
+section {* Datatype definition *}
+
+datatype_new 'a trm =
+ Var 'a |
+ App "'a trm" "'a trm" |
+ Lam 'a "'a trm" |
+ Lt "('a \<times> 'a trm) fset" "'a trm"
+
+
+subsection{* Example: The set of all variables varsOf and free variables fvarsOf of a term: *}
+
+primrec_new varsOf :: "'a trm \<Rightarrow> 'a set" where
+ "varsOf (Var a) = {a}"
+| "varsOf (App f x) = varsOf f \<union> varsOf x"
+| "varsOf (Lam x b) = {x} \<union> varsOf b"
+| "varsOf (Lt F t) = varsOf t \<union> (\<Union> { {x} \<union> X | x X. (x,X) |\<in>| fimage (map_pair id varsOf) F})"
+
+primrec_new fvarsOf :: "'a trm \<Rightarrow> 'a set" where
+ "fvarsOf (Var x) = {x}"
+| "fvarsOf (App t1 t2) = fvarsOf t1 \<union> fvarsOf t2"
+| "fvarsOf (Lam x t) = fvarsOf t - {x}"
+| "fvarsOf (Lt xts t) = fvarsOf t - {x | x X. (x,X) |\<in>| fimage (map_pair id varsOf) xts} \<union>
+ (\<Union> {X | x X. (x,X) |\<in>| fimage (map_pair id varsOf) xts})"
+
+lemma diff_Un_incl_triv: "\<lbrakk>A \<subseteq> D; C \<subseteq> E\<rbrakk> \<Longrightarrow> A - B \<union> C \<subseteq> D \<union> E" by blast
+
+lemma in_fmap_map_pair_fset_iff[simp]:
+ "(x, y) |\<in>| fimage (map_pair f g) xts \<longleftrightarrow> (\<exists> t1 t2. (t1, t2) |\<in>| xts \<and> x = f t1 \<and> y = g t2)"
+ by force
+
+lemma fvarsOf_varsOf: "fvarsOf t \<subseteq> varsOf t"
+proof induct
+ case (Lt xts t) thus ?case unfolding fvarsOf.simps varsOf.simps by (elim diff_Un_incl_triv) auto
+qed auto
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/ListF.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,111 @@
+(* Title: HOL/BNF/Examples/ListF.thy
+ Author: Dmitriy Traytel, TU Muenchen
+ Author: Andrei Popescu, TU Muenchen
+ Copyright 2012
+
+Finite lists.
+*)
+
+header {* Finite Lists *}
+
+theory ListF
+imports "../BNF"
+begin
+
+datatype_new 'a listF (map: mapF rel: relF) =
+ NilF (defaults tlF: NilF) | Conss (hdF: 'a) (tlF: "'a listF")
+datatype_new_compat listF
+
+definition Singll ("[[_]]") where
+ [simp]: "Singll a \<equiv> Conss a NilF"
+
+primrec_new appendd (infixr "@@" 65) where
+ "NilF @@ ys = ys"
+| "Conss x xs @@ ys = Conss x (xs @@ ys)"
+
+primrec_new lrev where
+ "lrev NilF = NilF"
+| "lrev (Conss y ys) = lrev ys @@ [[y]]"
+
+lemma appendd_NilF[simp]: "xs @@ NilF = xs"
+ by (induct xs) auto
+
+lemma appendd_assoc[simp]: "(xs @@ ys) @@ zs = xs @@ ys @@ zs"
+ by (induct xs) auto
+
+lemma lrev_appendd[simp]: "lrev (xs @@ ys) = lrev ys @@ lrev xs"
+ by (induct xs) auto
+
+lemma listF_map_appendd[simp]:
+ "mapF f (xs @@ ys) = mapF f xs @@ mapF f ys"
+ by (induct xs) auto
+
+lemma lrev_listF_map[simp]: "lrev (mapF f xs) = mapF f (lrev xs)"
+ by (induct xs) auto
+
+lemma lrev_lrev[simp]: "lrev (lrev xs) = xs"
+ by (induct xs) auto
+
+primrec_new lengthh where
+ "lengthh NilF = 0"
+| "lengthh (Conss x xs) = Suc (lengthh xs)"
+
+fun nthh where
+ "nthh (Conss x xs) 0 = x"
+| "nthh (Conss x xs) (Suc n) = nthh xs n"
+| "nthh xs i = undefined"
+
+lemma lengthh_listF_map[simp]: "lengthh (mapF f xs) = lengthh xs"
+ by (induct xs) auto
+
+lemma nthh_listF_map[simp]:
+ "i < lengthh xs \<Longrightarrow> nthh (mapF f xs) i = f (nthh xs i)"
+ by (induct rule: nthh.induct) auto
+
+lemma nthh_listF_set[simp]: "i < lengthh xs \<Longrightarrow> nthh xs i \<in> set_listF xs"
+ by (induct rule: nthh.induct) auto
+
+lemma NilF_iff[iff]: "(lengthh xs = 0) = (xs = NilF)"
+ by (induct xs) auto
+
+lemma Conss_iff[iff]:
+ "(lengthh xs = Suc n) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
+ by (induct xs) auto
+
+lemma Conss_iff'[iff]:
+ "(Suc n = lengthh xs) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
+ by (induct xs) (simp, simp, blast)
+
+lemma listF_induct2[consumes 1, case_names NilF Conss]: "\<lbrakk>lengthh xs = lengthh ys; P NilF NilF;
+ \<And>x xs y ys. P xs ys \<Longrightarrow> P (Conss x xs) (Conss y ys)\<rbrakk> \<Longrightarrow> P xs ys"
+ by (induct xs arbitrary: ys) auto
+
+fun zipp where
+ "zipp NilF NilF = NilF"
+| "zipp (Conss x xs) (Conss y ys) = Conss (x, y) (zipp xs ys)"
+| "zipp xs ys = undefined"
+
+lemma listF_map_fst_zip[simp]:
+ "lengthh xs = lengthh ys \<Longrightarrow> mapF fst (zipp xs ys) = xs"
+ by (induct rule: listF_induct2) auto
+
+lemma listF_map_snd_zip[simp]:
+ "lengthh xs = lengthh ys \<Longrightarrow> mapF snd (zipp xs ys) = ys"
+ by (induct rule: listF_induct2) auto
+
+lemma lengthh_zip[simp]:
+ "lengthh xs = lengthh ys \<Longrightarrow> lengthh (zipp xs ys) = lengthh xs"
+ by (induct rule: listF_induct2) auto
+
+lemma nthh_zip[simp]:
+ assumes "lengthh xs = lengthh ys"
+ shows "i < lengthh xs \<Longrightarrow> nthh (zipp xs ys) i = (nthh xs i, nthh ys i)"
+using assms proof (induct arbitrary: i rule: listF_induct2)
+ case (Conss x xs y ys) thus ?case by (induct i) auto
+qed simp
+
+lemma list_set_nthh[simp]:
+ "(x \<in> set_listF xs) \<Longrightarrow> (\<exists>i < lengthh xs. nthh xs i = x)"
+ by (induct xs) (auto, induct rule: nthh.induct, auto)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/Misc_Codatatype.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,120 @@
+(* Title: HOL/BNF/Examples/Misc_Codatatype.thy
+ Author: Dmitriy Traytel, TU Muenchen
+ Author: Andrei Popescu, TU Muenchen
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2012, 2013
+
+Miscellaneous codatatype definitions.
+*)
+
+header {* Miscellaneous Codatatype Definitions *}
+
+theory Misc_Codatatype
+imports More_BNFs
+begin
+
+codatatype simple = X1 | X2 | X3 | X4
+
+codatatype simple' = X1' unit | X2' unit | X3' unit | X4' unit
+
+codatatype simple'' = X1'' nat int | X2''
+
+codatatype 'a stream = Stream (shd: 'a) (stl: "'a stream")
+
+codatatype 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
+
+codatatype ('b, 'c, 'd, 'e) some_passive =
+ SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
+
+codatatype lambda =
+ Var string |
+ App lambda lambda |
+ Abs string lambda |
+ Let "(string \<times> lambda) fset" lambda
+
+codatatype 'a par_lambda =
+ PVar 'a |
+ PApp "'a par_lambda" "'a par_lambda" |
+ PAbs 'a "'a par_lambda" |
+ PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
+
+(*
+ ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
+ ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
+*)
+
+codatatype 'a p = P "'a + 'a p"
+
+codatatype 'a J1 = J11 'a "'a J1" | J12 'a "'a J2"
+and 'a J2 = J21 | J22 "'a J1" "'a J2"
+
+codatatype 'a tree = TEmpty | TNode 'a "'a forest"
+and 'a forest = FNil | FCons "'a tree" "'a forest"
+
+codatatype 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
+and 'a branch = Branch 'a "'a tree'"
+
+codatatype ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
+and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
+and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
+
+codatatype ('a, 'b, 'c) some_killing =
+ SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
+and ('a, 'b, 'c) in_here =
+ IH1 'b 'a | IH2 'c
+
+codatatype ('a, 'b, 'c) some_killing' =
+ SK' "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing' + ('a, 'b, 'c) in_here'"
+and ('a, 'b, 'c) in_here' =
+ IH1' 'b | IH2' 'c
+
+codatatype ('a, 'b, 'c) some_killing'' =
+ SK'' "'a \<Rightarrow> ('a, 'b, 'c) in_here''"
+and ('a, 'b, 'c) in_here'' =
+ IH1'' 'b 'a | IH2'' 'c
+
+codatatype ('b, 'c) less_killing = LK "'b \<Rightarrow> 'c"
+
+codatatype 'b poly_unit = U "'b \<Rightarrow> 'b poly_unit"
+codatatype 'b cps = CPS1 'b | CPS2 "'b \<Rightarrow> 'b cps"
+
+codatatype ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs =
+ FR "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow>
+ ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs"
+
+codatatype ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
+ 'b18, 'b19, 'b20) fun_rhs' =
+ FR' "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow> 'b10 \<Rightarrow> 'b11 \<Rightarrow> 'b12 \<Rightarrow> 'b13 \<Rightarrow> 'b14 \<Rightarrow>
+ 'b15 \<Rightarrow> 'b16 \<Rightarrow> 'b17 \<Rightarrow> 'b18 \<Rightarrow> 'b19 \<Rightarrow> 'b20 \<Rightarrow>
+ ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
+ 'b18, 'b19, 'b20) fun_rhs'"
+
+codatatype ('a, 'b, 'c) wit3_F1 = W1 'a "('a, 'b, 'c) wit3_F1" "('a, 'b, 'c) wit3_F2"
+and ('a, 'b, 'c) wit3_F2 = W2 'b "('a, 'b, 'c) wit3_F2"
+and ('a, 'b, 'c) wit3_F3 = W31 'a 'b "('a, 'b, 'c) wit3_F1" | W32 'c 'a 'b "('a, 'b, 'c) wit3_F1"
+
+codatatype ('c, 'e, 'g) coind_wit1 =
+ CW1 'c "('c, 'e, 'g) coind_wit1" "('c, 'e, 'g) ind_wit" "('c, 'e, 'g) coind_wit2"
+and ('c, 'e, 'g) coind_wit2 =
+ CW21 "('c, 'e, 'g) coind_wit2" 'e | CW22 'c 'g
+and ('c, 'e, 'g) ind_wit =
+ IW1 | IW2 'c
+
+codatatype ('b, 'a) bar = BAR "'a \<Rightarrow> 'b"
+codatatype ('a, 'b, 'c, 'd) foo = FOO "'d + 'b \<Rightarrow> 'c + 'a"
+
+codatatype 'a dead_foo = A
+codatatype ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
+
+(* SLOW, MEMORY-HUNGRY
+codatatype ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
+and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
+and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
+and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
+and ('a, 'c) D5 = A5 "('a, 'c) D6"
+and ('a, 'c) D6 = A6 "('a, 'c) D7"
+and ('a, 'c) D7 = A7 "('a, 'c) D8"
+and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
+*)
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/Misc_Datatype.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,185 @@
+(* Title: HOL/BNF/Examples/Misc_Datatype.thy
+ Author: Dmitriy Traytel, TU Muenchen
+ Author: Andrei Popescu, TU Muenchen
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2012, 2013
+
+Miscellaneous datatype definitions.
+*)
+
+header {* Miscellaneous Datatype Definitions *}
+
+theory Misc_Datatype
+imports "../BNF"
+begin
+
+datatype_new simple = X1 | X2 | X3 | X4
+
+datatype_new simple' = X1' unit | X2' unit | X3' unit | X4' unit
+
+datatype_new simple'' = X1'' nat int | X2''
+
+datatype_new 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
+
+datatype_new ('b, 'c, 'd, 'e) some_passive =
+ SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
+
+datatype_new hfset = HFset "hfset fset"
+
+datatype_new lambda =
+ Var string |
+ App lambda lambda |
+ Abs string lambda |
+ Let "(string \<times> lambda) fset" lambda
+
+datatype_new 'a par_lambda =
+ PVar 'a |
+ PApp "'a par_lambda" "'a par_lambda" |
+ PAbs 'a "'a par_lambda" |
+ PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
+
+(*
+ ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
+ ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
+*)
+
+datatype_new 'a I1 = I11 'a "'a I1" | I12 'a "'a I2"
+and 'a I2 = I21 | I22 "'a I1" "'a I2"
+
+datatype_new 'a tree = TEmpty | TNode 'a "'a forest"
+and 'a forest = FNil | FCons "'a tree" "'a forest"
+
+datatype_new 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
+and 'a branch = Branch 'a "'a tree'"
+
+datatype_new ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
+and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
+and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
+
+datatype_new 'a ftree = FTLeaf 'a | FTNode "'a \<Rightarrow> 'a ftree"
+
+datatype_new ('a, 'b, 'c) some_killing =
+ SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
+and ('a, 'b, 'c) in_here =
+ IH1 'b 'a | IH2 'c
+
+datatype_new 'b nofail1 = NF11 "'b nofail1" 'b | NF12 'b
+datatype_new 'b nofail2 = NF2 "('b nofail2 \<times> 'b \<times> 'b nofail2 \<times> 'b) list"
+datatype_new 'b nofail3 = NF3 'b "('b nofail3 \<times> 'b \<times> 'b nofail3 \<times> 'b) fset"
+datatype_new 'b nofail4 = NF4 "('b nofail4 \<times> ('b nofail4 \<times> 'b \<times> 'b nofail4 \<times> 'b) fset) list"
+
+(*
+datatype_new 'b fail = F "'b fail" 'b "'b fail" "'b list"
+datatype_new 'b fail = F "'b fail" 'b "'b fail" 'b
+datatype_new 'b fail = F1 "'b fail" 'b | F2 "'b fail"
+datatype_new 'b fail = F "'b fail" 'b
+*)
+
+datatype_new l1 = L1 "l2 list"
+and l2 = L21 "l1 fset" | L22 l2
+
+datatype_new kk1 = KK1 kk2
+and kk2 = KK2 kk3
+and kk3 = KK3 "kk1 list"
+
+datatype_new t1 = T11 t3 | T12 t2
+and t2 = T2 t1
+and t3 = T3
+
+datatype_new t1' = T11' t2' | T12' t3'
+and t2' = T2' t1'
+and t3' = T3'
+
+(*
+datatype_new fail1 = F1 fail2
+and fail2 = F2 fail3
+and fail3 = F3 fail1
+
+datatype_new fail1 = F1 "fail2 list" fail2
+and fail2 = F2 "fail2 fset" fail3
+and fail3 = F3 fail1
+
+datatype_new fail1 = F1 "fail2 list" fail2
+and fail2 = F2 "fail1 fset" fail1
+*)
+
+(* SLOW
+datatype_new ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
+and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
+and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
+and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
+and ('a, 'c) D5 = A5 "('a, 'c) D6"
+and ('a, 'c) D6 = A6 "('a, 'c) D7"
+and ('a, 'c) D7 = A7 "('a, 'c) D8"
+and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
+
+(*time comparison*)
+datatype ('a, 'c) D1' = A1' "('a, 'c) D2'" | B1' "'a list"
+ and ('a, 'c) D2' = A2' "('a, 'c) D3'" | B2' "'c list"
+ and ('a, 'c) D3' = A3' "('a, 'c) D3'" | B3' "('a, 'c) D4'" | C3' "('a, 'c) D4'" "('a, 'c) D5'"
+ and ('a, 'c) D4' = A4' "('a, 'c) D5'" | B4' "'a list list list"
+ and ('a, 'c) D5' = A5' "('a, 'c) D6'"
+ and ('a, 'c) D6' = A6' "('a, 'c) D7'"
+ and ('a, 'c) D7' = A7' "('a, 'c) D8'"
+ and ('a, 'c) D8' = A8' "('a, 'c) D1' list"
+*)
+
+(* fail:
+datatype_new tt1 = TT11 tt2 tt3 | TT12 tt2 tt4
+and tt2 = TT2
+and tt3 = TT3 tt4
+and tt4 = TT4 tt1
+*)
+
+datatype_new k1 = K11 k2 k3 | K12 k2 k4
+and k2 = K2
+and k3 = K3 k4
+and k4 = K4
+
+datatype_new tt1 = TT11 tt3 tt2 | TT12 tt2 tt4
+and tt2 = TT2
+and tt3 = TT3 tt1
+and tt4 = TT4
+
+(* SLOW
+datatype_new s1 = S11 s2 s3 s4 | S12 s3 | S13 s2 s6 | S14 s4 s2 | S15 s2 s2
+and s2 = S21 s7 s5 | S22 s5 s4 s6
+and s3 = S31 s1 s7 s2 | S32 s3 s3 | S33 s4 s5
+and s4 = S4 s5
+and s5 = S5
+and s6 = S61 s6 | S62 s1 s2 | S63 s6
+and s7 = S71 s8 | S72 s5
+and s8 = S8 nat
+*)
+
+datatype_new 'a deadbar = DeadBar "'a \<Rightarrow> 'a"
+datatype_new 'a deadbar_option = DeadBarOption "'a option \<Rightarrow> 'a option"
+datatype_new ('a, 'b) bar = Bar "'b \<Rightarrow> 'a"
+datatype_new ('a, 'b, 'c, 'd) foo = Foo "'d + 'b \<Rightarrow> 'c + 'a"
+datatype_new 'a deadfoo = DeadFoo "'a \<Rightarrow> 'a + 'a"
+
+datatype_new 'a dead_foo = A
+datatype_new ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
+
+datatype_new d1 = D
+datatype_new d1' = is_D: D
+
+datatype_new d2 = D nat
+datatype_new d2' = is_D: D nat
+
+datatype_new d3 = D | E
+datatype_new d3' = D | is_E: E
+datatype_new d3'' = is_D: D | E
+datatype_new d3''' = is_D: D | is_E: E
+
+datatype_new d4 = D nat | E
+datatype_new d4' = D nat | is_E: E
+datatype_new d4'' = is_D: D nat | E
+datatype_new d4''' = is_D: D nat | is_E: E
+
+datatype_new d5 = D nat | E int
+datatype_new d5' = D nat | is_E: E int
+datatype_new d5'' = is_D: D nat | E int
+datatype_new d5''' = is_D: D nat | is_E: E int
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/Misc_Primcorec.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,112 @@
+(* Title: HOL/BNF/Examples/Misc_Primcorec.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2013
+
+Miscellaneous primitive corecursive function definitions.
+*)
+
+header {* Miscellaneous Primitive Corecursive Function Definitions *}
+
+theory Misc_Primcorec
+imports Misc_Codatatype
+begin
+
+primcorec simple_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple" where
+ "simple_of_bools b b' = (if b then if b' then X1 else X2 else if b' then X3 else X4)"
+
+primcorec simple'_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple'" where
+ "simple'_of_bools b b' =
+ (if b then if b' then X1' () else X2' () else if b' then X3' () else X4' ())"
+
+primcorec inc_simple'' :: "nat \<Rightarrow> simple'' \<Rightarrow> simple''" where
+ "inc_simple'' k s = (case s of X1'' n i \<Rightarrow> X1'' (n + k) (i + int k) | X2'' \<Rightarrow> X2'')"
+
+primcorec sinterleave :: "'a stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
+ "sinterleave s s' = Stream (shd s) (sinterleave s' (stl s))"
+
+primcorec myapp :: "'a mylist \<Rightarrow> 'a mylist \<Rightarrow> 'a mylist" where
+ "myapp xs ys =
+ (if xs = MyNil then ys
+ else if ys = MyNil then xs
+ else MyCons (myhd xs) (myapp (mytl xs) ys))"
+
+primcorec shuffle_sp :: "('a, 'b, 'c, 'd) some_passive \<Rightarrow> ('d, 'a, 'b, 'c) some_passive" where
+ "shuffle_sp sp =
+ (case sp of
+ SP1 sp' \<Rightarrow> SP1 (shuffle_sp sp')
+ | SP2 a \<Rightarrow> SP3 a
+ | SP3 b \<Rightarrow> SP4 b
+ | SP4 c \<Rightarrow> SP5 c
+ | SP5 d \<Rightarrow> SP2 d)"
+
+primcorec rename_lam :: "(string \<Rightarrow> string) \<Rightarrow> lambda \<Rightarrow> lambda" where
+ "rename_lam f l =
+ (case l of
+ Var s \<Rightarrow> Var (f s)
+ | App l l' \<Rightarrow> App (rename_lam f l) (rename_lam f l')
+ | Abs s l \<Rightarrow> Abs (f s) (rename_lam f l)
+ | Let SL l \<Rightarrow> Let (fimage (map_pair f (rename_lam f)) SL) (rename_lam f l))"
+
+primcorec
+ j1_sum :: "('a\<Colon>{zero,one,plus}) \<Rightarrow> 'a J1" and
+ j2_sum :: "'a \<Rightarrow> 'a J2"
+where
+ "n = 0 \<Longrightarrow> is_J11 (j1_sum n)" |
+ "un_J111 (j1_sum _) = 0" |
+ "un_J112 (j1_sum _) = j1_sum 0" |
+ "un_J121 (j1_sum n) = n + 1" |
+ "un_J122 (j1_sum n) = j2_sum (n + 1)" |
+ "n = 0 \<Longrightarrow> is_J21 (j2_sum n)" |
+ "un_J221 (j2_sum n) = j1_sum (n + 1)" |
+ "un_J222 (j2_sum n) = j2_sum (n + 1)"
+
+primcorec forest_of_mylist :: "'a tree mylist \<Rightarrow> 'a forest" where
+ "forest_of_mylist ts =
+ (case ts of
+ MyNil \<Rightarrow> FNil
+ | MyCons t ts \<Rightarrow> FCons t (forest_of_mylist ts))"
+
+primcorec mylist_of_forest :: "'a forest \<Rightarrow> 'a tree mylist" where
+ "mylist_of_forest f =
+ (case f of
+ FNil \<Rightarrow> MyNil
+ | FCons t ts \<Rightarrow> MyCons t (mylist_of_forest ts))"
+
+primcorec semi_stream :: "'a stream \<Rightarrow> 'a stream" where
+ "semi_stream s = Stream (shd s) (semi_stream (stl (stl s)))"
+
+primcorec
+ tree'_of_stream :: "'a stream \<Rightarrow> 'a tree'" and
+ branch_of_stream :: "'a stream \<Rightarrow> 'a branch"
+where
+ "tree'_of_stream s =
+ TNode' (branch_of_stream (semi_stream s)) (branch_of_stream (semi_stream (stl s)))" |
+ "branch_of_stream s = (case s of Stream h t \<Rightarrow> Branch h (tree'_of_stream t))"
+
+primcorec
+ freeze_exp :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) exp \<Rightarrow> ('a, 'b) exp" and
+ freeze_trm :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) trm \<Rightarrow> ('a, 'b) trm" and
+ freeze_factor :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) factor \<Rightarrow> ('a, 'b) factor"
+where
+ "freeze_exp g e =
+ (case e of
+ Term t \<Rightarrow> Term (freeze_trm g t)
+ | Sum t e \<Rightarrow> Sum (freeze_trm g t) (freeze_exp g e))" |
+ "freeze_trm g t =
+ (case t of
+ Factor f \<Rightarrow> Factor (freeze_factor g f)
+ | Prod f t \<Rightarrow> Prod (freeze_factor g f) (freeze_trm g t))" |
+ "freeze_factor g f =
+ (case f of
+ C a \<Rightarrow> C a
+ | V b \<Rightarrow> C (g b)
+ | Paren e \<Rightarrow> Paren (freeze_exp g e))"
+
+primcorec poly_unity :: "'a poly_unit" where
+ "poly_unity = U (\<lambda>_. poly_unity)"
+
+primcorec build_cps :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool stream) \<Rightarrow> 'a \<Rightarrow> bool stream \<Rightarrow> 'a cps" where
+ "shd b \<Longrightarrow> build_cps f g a b = CPS1 a" |
+ "_ \<Longrightarrow> build_cps f g a b = CPS2 (\<lambda>a. build_cps f g (f a) (g a))"
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/Misc_Primrec.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,114 @@
+(* Title: HOL/BNF/Examples/Misc_Primrec.thy
+ Author: Jasmin Blanchette, TU Muenchen
+ Copyright 2013
+
+Miscellaneous primitive recursive function definitions.
+*)
+
+header {* Miscellaneous Primitive Recursive Function Definitions *}
+
+theory Misc_Primrec
+imports Misc_Datatype
+begin
+
+primrec_new nat_of_simple :: "simple \<Rightarrow> nat" where
+ "nat_of_simple X1 = 1" |
+ "nat_of_simple X2 = 2" |
+ "nat_of_simple X3 = 3" |
+ "nat_of_simple X4 = 4"
+
+primrec_new simple_of_simple' :: "simple' \<Rightarrow> simple" where
+ "simple_of_simple' (X1' _) = X1" |
+ "simple_of_simple' (X2' _) = X2" |
+ "simple_of_simple' (X3' _) = X3" |
+ "simple_of_simple' (X4' _) = X4"
+
+primrec_new inc_simple'' :: "nat \<Rightarrow> simple'' \<Rightarrow> simple''" where
+ "inc_simple'' k (X1'' n i) = X1'' (n + k) (i + int k)" |
+ "inc_simple'' _ X2'' = X2''"
+
+primrec_new myapp :: "'a mylist \<Rightarrow> 'a mylist \<Rightarrow> 'a mylist" where
+ "myapp MyNil ys = ys" |
+ "myapp (MyCons x xs) ys = MyCons x (myapp xs ys)"
+
+primrec_new myrev :: "'a mylist \<Rightarrow> 'a mylist" where
+ "myrev MyNil = MyNil" |
+ "myrev (MyCons x xs) = myapp (myrev xs) (MyCons x MyNil)"
+
+primrec_new shuffle_sp :: "('a, 'b, 'c, 'd) some_passive \<Rightarrow> ('d, 'a, 'b, 'c) some_passive" where
+ "shuffle_sp (SP1 sp) = SP1 (shuffle_sp sp)" |
+ "shuffle_sp (SP2 a) = SP3 a" |
+ "shuffle_sp (SP3 b) = SP4 b" |
+ "shuffle_sp (SP4 c) = SP5 c" |
+ "shuffle_sp (SP5 d) = SP2 d"
+
+primrec_new
+ hf_size :: "hfset \<Rightarrow> nat"
+where
+ "hf_size (HFset X) = 1 + setsum id (fset (fimage hf_size X))"
+
+primrec_new rename_lam :: "(string \<Rightarrow> string) \<Rightarrow> lambda \<Rightarrow> lambda" where
+ "rename_lam f (Var s) = Var (f s)" |
+ "rename_lam f (App l l') = App (rename_lam f l) (rename_lam f l')" |
+ "rename_lam f (Abs s l) = Abs (f s) (rename_lam f l)" |
+ "rename_lam f (Let SL l) = Let (fimage (map_pair f (rename_lam f)) SL) (rename_lam f l)"
+
+primrec_new
+ sum_i1 :: "('a\<Colon>{zero,plus}) I1 \<Rightarrow> 'a" and
+ sum_i2 :: "'a I2 \<Rightarrow> 'a"
+where
+ "sum_i1 (I11 n i) = n + sum_i1 i" |
+ "sum_i1 (I12 n i) = n + sum_i2 i" |
+ "sum_i2 I21 = 0" |
+ "sum_i2 (I22 i j) = sum_i1 i + sum_i2 j"
+
+primrec_new forest_of_mylist :: "'a tree mylist \<Rightarrow> 'a forest" where
+ "forest_of_mylist MyNil = FNil" |
+ "forest_of_mylist (MyCons t ts) = FCons t (forest_of_mylist ts)"
+
+primrec_new mylist_of_forest :: "'a forest \<Rightarrow> 'a tree mylist" where
+ "mylist_of_forest FNil = MyNil" |
+ "mylist_of_forest (FCons t ts) = MyCons t (mylist_of_forest ts)"
+
+definition frev :: "'a forest \<Rightarrow> 'a forest" where
+ "frev = forest_of_mylist \<circ> myrev \<circ> mylist_of_forest"
+
+primrec_new
+ mirror_tree :: "'a tree \<Rightarrow> 'a tree" and
+ mirror_forest :: "'a forest \<Rightarrow> 'a forest"
+where
+ "mirror_tree TEmpty = TEmpty" |
+ "mirror_tree (TNode x ts) = TNode x (mirror_forest ts)" |
+ "mirror_forest FNil = FNil" |
+ "mirror_forest (FCons t ts) = frev (FCons (mirror_tree t) (mirror_forest ts))"
+
+primrec_new
+ mylist_of_tree' :: "'a tree' \<Rightarrow> 'a mylist" and
+ mylist_of_branch :: "'a branch \<Rightarrow> 'a mylist"
+where
+ "mylist_of_tree' TEmpty' = MyNil" |
+ "mylist_of_tree' (TNode' b b') = myapp (mylist_of_branch b) (mylist_of_branch b')" |
+ "mylist_of_branch (Branch x t) = MyCons x (mylist_of_tree' t)"
+
+primrec_new
+ is_ground_exp :: "('a, 'b) exp \<Rightarrow> bool" and
+ is_ground_trm :: "('a, 'b) trm \<Rightarrow> bool" and
+ is_ground_factor :: "('a, 'b) factor \<Rightarrow> bool"
+where
+ "is_ground_exp (Term t) \<longleftrightarrow> is_ground_trm t" |
+ "is_ground_exp (Sum t e) \<longleftrightarrow> is_ground_trm t \<and> is_ground_exp e" |
+ "is_ground_trm (Factor f) \<longleftrightarrow> is_ground_factor f" |
+ "is_ground_trm (Prod f t) \<longleftrightarrow> is_ground_factor f \<and> is_ground_trm t" |
+ "is_ground_factor (C _) \<longleftrightarrow> True" |
+ "is_ground_factor (V _) \<longleftrightarrow> False" |
+ "is_ground_factor (Paren e) \<longleftrightarrow> is_ground_exp e"
+
+primrec_new map_ftreeA :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
+ "map_ftreeA f (FTLeaf x) = FTLeaf (f x)" |
+ "map_ftreeA f (FTNode g) = FTNode (map_ftreeA f \<circ> g)"
+
+primrec_new map_ftreeB :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ftree \<Rightarrow> 'b ftree" where
+ "map_ftreeB f (FTLeaf x) = FTLeaf (f x)" |
+ "map_ftreeB f (FTNode g) = FTNode (map_ftreeB f \<circ> g \<circ> the_inv f)"
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/Process.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,278 @@
+(* Title: HOL/BNF/Examples/Process.thy
+ Author: Andrei Popescu, TU Muenchen
+ Copyright 2012
+
+Processes.
+*)
+
+header {* Processes *}
+
+theory Process
+imports Stream
+begin
+
+codatatype 'a process =
+ isAction: Action (prefOf: 'a) (contOf: "'a process") |
+ isChoice: Choice (ch1Of: "'a process") (ch2Of: "'a process")
+
+(* Read: prefix of, continuation of, choice 1 of, choice 2 of *)
+
+section {* Customization *}
+
+subsection {* Basic properties *}
+
+declare
+ rel_pre_process_def[simp]
+ sum_rel_def[simp]
+ prod_rel_def[simp]
+
+(* Constructors versus discriminators *)
+theorem isAction_isChoice:
+"isAction p \<or> isChoice p"
+by (rule process.disc_exhaust) auto
+
+theorem not_isAction_isChoice: "\<not> (isAction p \<and> isChoice p)"
+by (cases rule: process.exhaust[of p]) auto
+
+
+subsection{* Coinduction *}
+
+theorem process_coind[elim, consumes 1, case_names iss Action Choice, induct pred: "HOL.eq"]:
+ assumes phi: "\<phi> p p'" and
+ iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
+ Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> \<phi> p p'" and
+ Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> \<phi> p p' \<and> \<phi> q q'"
+ shows "p = p'"
+ using assms
+ by (coinduct rule: process.coinduct) (metis process.collapse(1,2) process.disc(3))
+
+(* Stronger coinduction, up to equality: *)
+theorem process_strong_coind[elim, consumes 1, case_names iss Action Choice]:
+ assumes phi: "\<phi> p p'" and
+ iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
+ Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> (\<phi> p p' \<or> p = p')" and
+ Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> (\<phi> p p' \<or> p = p') \<and> (\<phi> q q' \<or> q = q')"
+ shows "p = p'"
+ using assms
+ by (coinduct rule: process.strong_coinduct) (metis process.collapse(1,2) process.disc(3))
+
+
+subsection {* Coiteration (unfold) *}
+
+
+section{* Coinductive definition of the notion of trace *}
+coinductive trace where
+"trace p as \<Longrightarrow> trace (Action a p) (a ## as)"
+|
+"trace p as \<or> trace q as \<Longrightarrow> trace (Choice p q) as"
+
+
+section{* Examples of corecursive definitions: *}
+
+subsection{* Single-guard fixpoint definition *}
+
+primcorec BX where
+ "isAction BX"
+| "prefOf BX = ''a''"
+| "contOf BX = BX"
+
+
+subsection{* Multi-guard fixpoint definitions, simulated with auxiliary arguments *}
+
+datatype x_y_ax = x | y | ax
+
+primcorec F :: "x_y_ax \<Rightarrow> char list process" where
+ "xyax = x \<Longrightarrow> isChoice (F xyax)"
+| "ch1Of (F xyax) = F ax"
+| "ch2Of (F xyax) = F y"
+| "prefOf (F xyax) = (if xyax = y then ''b'' else ''a'')"
+| "contOf (F xyax) = F x"
+
+definition "X = F x" definition "Y = F y" definition "AX = F ax"
+
+lemma X_Y_AX: "X = Choice AX Y" "Y = Action ''b'' X" "AX = Action ''a'' X"
+unfolding X_def Y_def AX_def by (subst F.code, simp)+
+
+(* end product: *)
+lemma X_AX:
+"X = Choice AX (Action ''b'' X)"
+"AX = Action ''a'' X"
+using X_Y_AX by simp_all
+
+
+
+section{* Case study: Multi-guard fixpoint definitions, without auxiliary arguments *}
+
+hide_const x y ax X Y AX
+
+(* Process terms *)
+datatype ('a,'pvar) process_term =
+ VAR 'pvar |
+ PROC "'a process" |
+ ACT 'a "('a,'pvar) process_term" | CH "('a,'pvar) process_term" "('a,'pvar) process_term"
+
+(* below, sys represents a system of equations *)
+fun isACT where
+"isACT sys (VAR X) =
+ (case sys X of ACT a T \<Rightarrow> True |PROC p \<Rightarrow> isAction p |_ \<Rightarrow> False)"
+|
+"isACT sys (PROC p) = isAction p"
+|
+"isACT sys (ACT a T) = True"
+|
+"isACT sys (CH T1 T2) = False"
+
+fun PREF where
+"PREF sys (VAR X) =
+ (case sys X of ACT a T \<Rightarrow> a | PROC p \<Rightarrow> prefOf p)"
+|
+"PREF sys (PROC p) = prefOf p"
+|
+"PREF sys (ACT a T) = a"
+
+fun CONT where
+"CONT sys (VAR X) =
+ (case sys X of ACT a T \<Rightarrow> T | PROC p \<Rightarrow> PROC (contOf p))"
+|
+"CONT sys (PROC p) = PROC (contOf p)"
+|
+"CONT sys (ACT a T) = T"
+
+fun CH1 where
+"CH1 sys (VAR X) =
+ (case sys X of CH T1 T2 \<Rightarrow> T1 |PROC p \<Rightarrow> PROC (ch1Of p))"
+|
+"CH1 sys (PROC p) = PROC (ch1Of p)"
+|
+"CH1 sys (CH T1 T2) = T1"
+
+fun CH2 where
+"CH2 sys (VAR X) =
+ (case sys X of CH T1 T2 \<Rightarrow> T2 |PROC p \<Rightarrow> PROC (ch2Of p))"
+|
+"CH2 sys (PROC p) = PROC (ch2Of p)"
+|
+"CH2 sys (CH T1 T2) = T2"
+
+definition "guarded sys \<equiv> \<forall> X Y. sys X \<noteq> VAR Y"
+
+primcorec solution where
+ "isACT sys T \<Longrightarrow> solution sys T = Action (PREF sys T) (solution sys (CONT sys T))"
+| "_ \<Longrightarrow> solution sys T = Choice (solution sys (CH1 sys T)) (solution sys (CH2 sys T))"
+
+lemma isACT_VAR:
+assumes g: "guarded sys"
+shows "isACT sys (VAR X) \<longleftrightarrow> isACT sys (sys X)"
+using g unfolding guarded_def by (cases "sys X") auto
+
+lemma solution_VAR:
+assumes g: "guarded sys"
+shows "solution sys (VAR X) = solution sys (sys X)"
+proof(cases "isACT sys (VAR X)")
+ case True
+ hence T: "isACT sys (sys X)" unfolding isACT_VAR[OF g] .
+ show ?thesis
+ unfolding solution.ctr(1)[OF T] using solution.ctr(1)[of sys "VAR X"] True g
+ unfolding guarded_def by (cases "sys X", auto)
+next
+ case False note FFalse = False
+ hence TT: "\<not> isACT sys (sys X)" unfolding isACT_VAR[OF g] .
+ show ?thesis
+ unfolding solution.ctr(2)[OF TT] using solution.ctr(2)[of sys "VAR X"] FFalse g
+ unfolding guarded_def by (cases "sys X", auto)
+qed
+
+lemma solution_PROC[simp]:
+"solution sys (PROC p) = p"
+proof-
+ {fix q assume "q = solution sys (PROC p)"
+ hence "p = q"
+ proof (coinduct rule: process_coind)
+ case (iss p p')
+ from isAction_isChoice[of p] show ?case
+ proof
+ assume p: "isAction p"
+ hence 0: "isACT sys (PROC p)" by simp
+ thus ?thesis using iss not_isAction_isChoice by auto
+ next
+ assume "isChoice p"
+ hence 0: "\<not> isACT sys (PROC p)"
+ using not_isAction_isChoice by auto
+ thus ?thesis using iss isAction_isChoice by auto
+ qed
+ next
+ case (Action a a' p p')
+ hence 0: "isACT sys (PROC (Action a p))" by simp
+ show ?case using Action unfolding solution.ctr(1)[OF 0] by simp
+ next
+ case (Choice p q p' q')
+ hence 0: "\<not> isACT sys (PROC (Choice p q))" using not_isAction_isChoice by auto
+ show ?case using Choice unfolding solution.ctr(2)[OF 0] by simp
+ qed
+ }
+ thus ?thesis by metis
+qed
+
+lemma solution_ACT[simp]:
+"solution sys (ACT a T) = Action a (solution sys T)"
+by (metis CONT.simps(3) PREF.simps(3) isACT.simps(3) solution.ctr(1))
+
+lemma solution_CH[simp]:
+"solution sys (CH T1 T2) = Choice (solution sys T1) (solution sys T2)"
+by (metis CH1.simps(3) CH2.simps(3) isACT.simps(4) solution.ctr(2))
+
+
+(* Example: *)
+
+fun sys where
+"sys 0 = CH (VAR (Suc 0)) (ACT ''b'' (VAR 0))"
+|
+"sys (Suc 0) = ACT ''a'' (VAR 0)"
+| (* dummy guarded term for variables outside the system: *)
+"sys X = ACT ''a'' (VAR 0)"
+
+lemma guarded_sys:
+"guarded sys"
+unfolding guarded_def proof (intro allI)
+ fix X Y show "sys X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
+qed
+
+(* the actual processes: *)
+definition "x \<equiv> solution sys (VAR 0)"
+definition "ax \<equiv> solution sys (VAR (Suc 0))"
+
+(* end product: *)
+lemma x_ax:
+"x = Choice ax (Action ''b'' x)"
+"ax = Action ''a'' x"
+unfolding x_def ax_def by (subst solution_VAR[OF guarded_sys], simp)+
+
+
+(* Thanks to the inclusion of processes as process terms, one can
+also consider parametrized systems of equations---here, x is a (semantic)
+process parameter: *)
+
+fun sys' where
+"sys' 0 = CH (PROC x) (ACT ''b'' (VAR 0))"
+|
+"sys' (Suc 0) = CH (ACT ''a'' (VAR 0)) (PROC x)"
+| (* dummy guarded term : *)
+"sys' X = ACT ''a'' (VAR 0)"
+
+lemma guarded_sys':
+"guarded sys'"
+unfolding guarded_def proof (intro allI)
+ fix X Y show "sys' X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
+qed
+
+(* the actual processes: *)
+definition "y \<equiv> solution sys' (VAR 0)"
+definition "ay \<equiv> solution sys' (VAR (Suc 0))"
+
+(* end product: *)
+lemma y_ay:
+"y = Choice x (Action ''b'' y)"
+"ay = Choice (Action ''a'' y) x"
+unfolding y_def ay_def by (subst solution_VAR[OF guarded_sys'], simp)+
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/Stream.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,526 @@
+(* Title: HOL/BNF/Examples/Stream.thy
+ Author: Dmitriy Traytel, TU Muenchen
+ Author: Andrei Popescu, TU Muenchen
+ Copyright 2012, 2013
+
+Infinite streams.
+*)
+
+header {* Infinite Streams *}
+
+theory Stream
+imports "~~/Library/Nat_Bijection"
+begin
+
+codatatype (sset: 'a) stream (map: smap rel: stream_all2) =
+ SCons (shd: 'a) (stl: "'a stream") (infixr "##" 65)
+
+(*for code generation only*)
+definition smember :: "'a \<Rightarrow> 'a stream \<Rightarrow> bool" where
+ [code_abbrev]: "smember x s \<longleftrightarrow> x \<in> sset s"
+
+lemma smember_code[code, simp]: "smember x (y ## s) = (if x = y then True else smember x s)"
+ unfolding smember_def by auto
+
+hide_const (open) smember
+
+(* TODO: Provide by the package*)
+theorem sset_induct:
+ "\<lbrakk>\<And>s. P (shd s) s; \<And>s y. \<lbrakk>y \<in> sset (stl s); P y (stl s)\<rbrakk> \<Longrightarrow> P y s\<rbrakk> \<Longrightarrow>
+ \<forall>y \<in> sset s. P y s"
+ apply (rule stream.dtor_set_induct)
+ apply (auto simp add: shd_def stl_def fsts_def snds_def split_beta)
+ apply (metis SCons_def fst_conv stream.case stream.dtor_ctor stream.exhaust)
+ by (metis SCons_def sndI stl_def stream.collapse stream.dtor_ctor)
+
+lemma smap_simps[simp]:
+ "shd (smap f s) = f (shd s)" "stl (smap f s) = smap f (stl s)"
+ by (case_tac [!] s) auto
+
+theorem shd_sset: "shd s \<in> sset s"
+ by (case_tac s) auto
+
+theorem stl_sset: "y \<in> sset (stl s) \<Longrightarrow> y \<in> sset s"
+ by (case_tac s) auto
+
+(* only for the non-mutual case: *)
+theorem sset_induct1[consumes 1, case_names shd stl, induct set: "sset"]:
+ assumes "y \<in> sset s" and "\<And>s. P (shd s) s"
+ and "\<And>s y. \<lbrakk>y \<in> sset (stl s); P y (stl s)\<rbrakk> \<Longrightarrow> P y s"
+ shows "P y s"
+ using assms sset_induct by blast
+(* end TODO *)
+
+
+subsection {* prepend list to stream *}
+
+primrec shift :: "'a list \<Rightarrow> 'a stream \<Rightarrow> 'a stream" (infixr "@-" 65) where
+ "shift [] s = s"
+| "shift (x # xs) s = x ## shift xs s"
+
+lemma smap_shift[simp]: "smap f (xs @- s) = map f xs @- smap f s"
+ by (induct xs) auto
+
+lemma shift_append[simp]: "(xs @ ys) @- s = xs @- ys @- s"
+ by (induct xs) auto
+
+lemma shift_simps[simp]:
+ "shd (xs @- s) = (if xs = [] then shd s else hd xs)"
+ "stl (xs @- s) = (if xs = [] then stl s else tl xs @- s)"
+ by (induct xs) auto
+
+lemma sset_shift[simp]: "sset (xs @- s) = set xs \<union> sset s"
+ by (induct xs) auto
+
+lemma shift_left_inj[simp]: "xs @- s1 = xs @- s2 \<longleftrightarrow> s1 = s2"
+ by (induct xs) auto
+
+
+subsection {* set of streams with elements in some fixed set *}
+
+coinductive_set
+ streams :: "'a set \<Rightarrow> 'a stream set"
+ for A :: "'a set"
+where
+ Stream[intro!, simp, no_atp]: "\<lbrakk>a \<in> A; s \<in> streams A\<rbrakk> \<Longrightarrow> a ## s \<in> streams A"
+
+lemma shift_streams: "\<lbrakk>w \<in> lists A; s \<in> streams A\<rbrakk> \<Longrightarrow> w @- s \<in> streams A"
+ by (induct w) auto
+
+lemma streams_Stream: "x ## s \<in> streams A \<longleftrightarrow> x \<in> A \<and> s \<in> streams A"
+ by (auto elim: streams.cases)
+
+lemma streams_stl: "s \<in> streams A \<Longrightarrow> stl s \<in> streams A"
+ by (cases s) (auto simp: streams_Stream)
+
+lemma streams_shd: "s \<in> streams A \<Longrightarrow> shd s \<in> A"
+ by (cases s) (auto simp: streams_Stream)
+
+lemma sset_streams:
+ assumes "sset s \<subseteq> A"
+ shows "s \<in> streams A"
+using assms proof (coinduction arbitrary: s)
+ case streams then show ?case by (cases s) simp
+qed
+
+lemma streams_sset:
+ assumes "s \<in> streams A"
+ shows "sset s \<subseteq> A"
+proof
+ fix x assume "x \<in> sset s" from this `s \<in> streams A` show "x \<in> A"
+ by (induct s) (auto intro: streams_shd streams_stl)
+qed
+
+lemma streams_iff_sset: "s \<in> streams A \<longleftrightarrow> sset s \<subseteq> A"
+ by (metis sset_streams streams_sset)
+
+lemma streams_mono: "s \<in> streams A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> s \<in> streams B"
+ unfolding streams_iff_sset by auto
+
+lemma smap_streams: "s \<in> streams A \<Longrightarrow> (\<And>x. x \<in> A \<Longrightarrow> f x \<in> B) \<Longrightarrow> smap f s \<in> streams B"
+ unfolding streams_iff_sset stream.set_map by auto
+
+lemma streams_empty: "streams {} = {}"
+ by (auto elim: streams.cases)
+
+lemma streams_UNIV[simp]: "streams UNIV = UNIV"
+ by (auto simp: streams_iff_sset)
+
+subsection {* nth, take, drop for streams *}
+
+primrec snth :: "'a stream \<Rightarrow> nat \<Rightarrow> 'a" (infixl "!!" 100) where
+ "s !! 0 = shd s"
+| "s !! Suc n = stl s !! n"
+
+lemma snth_smap[simp]: "smap f s !! n = f (s !! n)"
+ by (induct n arbitrary: s) auto
+
+lemma shift_snth_less[simp]: "p < length xs \<Longrightarrow> (xs @- s) !! p = xs ! p"
+ by (induct p arbitrary: xs) (auto simp: hd_conv_nth nth_tl)
+
+lemma shift_snth_ge[simp]: "p \<ge> length xs \<Longrightarrow> (xs @- s) !! p = s !! (p - length xs)"
+ by (induct p arbitrary: xs) (auto simp: Suc_diff_eq_diff_pred)
+
+lemma snth_sset[simp]: "s !! n \<in> sset s"
+ by (induct n arbitrary: s) (auto intro: shd_sset stl_sset)
+
+lemma sset_range: "sset s = range (snth s)"
+proof (intro equalityI subsetI)
+ fix x assume "x \<in> sset s"
+ thus "x \<in> range (snth s)"
+ proof (induct s)
+ case (stl s x)
+ then obtain n where "x = stl s !! n" by auto
+ thus ?case by (auto intro: range_eqI[of _ _ "Suc n"])
+ qed (auto intro: range_eqI[of _ _ 0])
+qed auto
+
+primrec stake :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a list" where
+ "stake 0 s = []"
+| "stake (Suc n) s = shd s # stake n (stl s)"
+
+lemma length_stake[simp]: "length (stake n s) = n"
+ by (induct n arbitrary: s) auto
+
+lemma stake_smap[simp]: "stake n (smap f s) = map f (stake n s)"
+ by (induct n arbitrary: s) auto
+
+primrec sdrop :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
+ "sdrop 0 s = s"
+| "sdrop (Suc n) s = sdrop n (stl s)"
+
+lemma sdrop_simps[simp]:
+ "shd (sdrop n s) = s !! n" "stl (sdrop n s) = sdrop (Suc n) s"
+ by (induct n arbitrary: s) auto
+
+lemma sdrop_smap[simp]: "sdrop n (smap f s) = smap f (sdrop n s)"
+ by (induct n arbitrary: s) auto
+
+lemma sdrop_stl: "sdrop n (stl s) = stl (sdrop n s)"
+ by (induct n) auto
+
+lemma stake_sdrop: "stake n s @- sdrop n s = s"
+ by (induct n arbitrary: s) auto
+
+lemma id_stake_snth_sdrop:
+ "s = stake i s @- s !! i ## sdrop (Suc i) s"
+ by (subst stake_sdrop[symmetric, of _ i]) (metis sdrop_simps stream.collapse)
+
+lemma smap_alt: "smap f s = s' \<longleftrightarrow> (\<forall>n. f (s !! n) = s' !! n)" (is "?L = ?R")
+proof
+ assume ?R
+ then have "\<And>n. smap f (sdrop n s) = sdrop n s'"
+ by coinduction (auto intro: exI[of _ 0] simp del: sdrop.simps(2))
+ then show ?L using sdrop.simps(1) by metis
+qed auto
+
+lemma stake_invert_Nil[iff]: "stake n s = [] \<longleftrightarrow> n = 0"
+ by (induct n) auto
+
+lemma sdrop_shift: "\<lbrakk>s = w @- s'; length w = n\<rbrakk> \<Longrightarrow> sdrop n s = s'"
+ by (induct n arbitrary: w s) auto
+
+lemma stake_shift: "\<lbrakk>s = w @- s'; length w = n\<rbrakk> \<Longrightarrow> stake n s = w"
+ by (induct n arbitrary: w s) auto
+
+lemma stake_add[simp]: "stake m s @ stake n (sdrop m s) = stake (m + n) s"
+ by (induct m arbitrary: s) auto
+
+lemma sdrop_add[simp]: "sdrop n (sdrop m s) = sdrop (m + n) s"
+ by (induct m arbitrary: s) auto
+
+partial_function (tailrec) sdrop_while :: "('a \<Rightarrow> bool) \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
+ "sdrop_while P s = (if P (shd s) then sdrop_while P (stl s) else s)"
+
+lemma sdrop_while_SCons[code]:
+ "sdrop_while P (a ## s) = (if P a then sdrop_while P s else a ## s)"
+ by (subst sdrop_while.simps) simp
+
+lemma sdrop_while_sdrop_LEAST:
+ assumes "\<exists>n. P (s !! n)"
+ shows "sdrop_while (Not o P) s = sdrop (LEAST n. P (s !! n)) s"
+proof -
+ from assms obtain m where "P (s !! m)" "\<And>n. P (s !! n) \<Longrightarrow> m \<le> n"
+ and *: "(LEAST n. P (s !! n)) = m" by atomize_elim (auto intro: LeastI Least_le)
+ thus ?thesis unfolding *
+ proof (induct m arbitrary: s)
+ case (Suc m)
+ hence "sdrop_while (Not \<circ> P) (stl s) = sdrop m (stl s)"
+ by (metis (full_types) not_less_eq_eq snth.simps(2))
+ moreover from Suc(3) have "\<not> (P (s !! 0))" by blast
+ ultimately show ?case by (subst sdrop_while.simps) simp
+ qed (metis comp_apply sdrop.simps(1) sdrop_while.simps snth.simps(1))
+qed
+
+primcorec sfilter where
+ "shd (sfilter P s) = shd (sdrop_while (Not o P) s)"
+| "stl (sfilter P s) = sfilter P (stl (sdrop_while (Not o P) s))"
+
+lemma sfilter_Stream: "sfilter P (x ## s) = (if P x then x ## sfilter P s else sfilter P s)"
+proof (cases "P x")
+ case True thus ?thesis by (subst sfilter.ctr) (simp add: sdrop_while_SCons)
+next
+ case False thus ?thesis by (subst (1 2) sfilter.ctr) (simp add: sdrop_while_SCons)
+qed
+
+
+subsection {* unary predicates lifted to streams *}
+
+definition "stream_all P s = (\<forall>p. P (s !! p))"
+
+lemma stream_all_iff[iff]: "stream_all P s \<longleftrightarrow> Ball (sset s) P"
+ unfolding stream_all_def sset_range by auto
+
+lemma stream_all_shift[simp]: "stream_all P (xs @- s) = (list_all P xs \<and> stream_all P s)"
+ unfolding stream_all_iff list_all_iff by auto
+
+lemma stream_all_Stream: "stream_all P (x ## X) \<longleftrightarrow> P x \<and> stream_all P X"
+ by simp
+
+
+subsection {* recurring stream out of a list *}
+
+primcorec cycle :: "'a list \<Rightarrow> 'a stream" where
+ "shd (cycle xs) = hd xs"
+| "stl (cycle xs) = cycle (tl xs @ [hd xs])"
+
+lemma cycle_decomp: "u \<noteq> [] \<Longrightarrow> cycle u = u @- cycle u"
+proof (coinduction arbitrary: u)
+ case Eq_stream then show ?case using stream.collapse[of "cycle u"]
+ by (auto intro!: exI[of _ "tl u @ [hd u]"])
+qed
+
+lemma cycle_Cons[code]: "cycle (x # xs) = x ## cycle (xs @ [x])"
+ by (subst cycle.ctr) simp
+
+lemma cycle_rotated: "\<lbrakk>v \<noteq> []; cycle u = v @- s\<rbrakk> \<Longrightarrow> cycle (tl u @ [hd u]) = tl v @- s"
+ by (auto dest: arg_cong[of _ _ stl])
+
+lemma stake_append: "stake n (u @- s) = take (min (length u) n) u @ stake (n - length u) s"
+proof (induct n arbitrary: u)
+ case (Suc n) thus ?case by (cases u) auto
+qed auto
+
+lemma stake_cycle_le[simp]:
+ assumes "u \<noteq> []" "n < length u"
+ shows "stake n (cycle u) = take n u"
+using min_absorb2[OF less_imp_le_nat[OF assms(2)]]
+ by (subst cycle_decomp[OF assms(1)], subst stake_append) auto
+
+lemma stake_cycle_eq[simp]: "u \<noteq> [] \<Longrightarrow> stake (length u) (cycle u) = u"
+ by (metis cycle_decomp stake_shift)
+
+lemma sdrop_cycle_eq[simp]: "u \<noteq> [] \<Longrightarrow> sdrop (length u) (cycle u) = cycle u"
+ by (metis cycle_decomp sdrop_shift)
+
+lemma stake_cycle_eq_mod_0[simp]: "\<lbrakk>u \<noteq> []; n mod length u = 0\<rbrakk> \<Longrightarrow>
+ stake n (cycle u) = concat (replicate (n div length u) u)"
+ by (induct "n div length u" arbitrary: n u) (auto simp: stake_add[symmetric])
+
+lemma sdrop_cycle_eq_mod_0[simp]: "\<lbrakk>u \<noteq> []; n mod length u = 0\<rbrakk> \<Longrightarrow>
+ sdrop n (cycle u) = cycle u"
+ by (induct "n div length u" arbitrary: n u) (auto simp: sdrop_add[symmetric])
+
+lemma stake_cycle: "u \<noteq> [] \<Longrightarrow>
+ stake n (cycle u) = concat (replicate (n div length u) u) @ take (n mod length u) u"
+ by (subst mod_div_equality[of n "length u", symmetric], unfold stake_add[symmetric]) auto
+
+lemma sdrop_cycle: "u \<noteq> [] \<Longrightarrow> sdrop n (cycle u) = cycle (rotate (n mod length u) u)"
+ by (induct n arbitrary: u) (auto simp: rotate1_rotate_swap rotate1_hd_tl rotate_conv_mod[symmetric])
+
+
+subsection {* iterated application of a function *}
+
+primcorec siterate where
+ "shd (siterate f x) = x"
+| "stl (siterate f x) = siterate f (f x)"
+
+lemma stake_Suc: "stake (Suc n) s = stake n s @ [s !! n]"
+ by (induct n arbitrary: s) auto
+
+lemma snth_siterate[simp]: "siterate f x !! n = (f^^n) x"
+ by (induct n arbitrary: x) (auto simp: funpow_swap1)
+
+lemma sdrop_siterate[simp]: "sdrop n (siterate f x) = siterate f ((f^^n) x)"
+ by (induct n arbitrary: x) (auto simp: funpow_swap1)
+
+lemma stake_siterate[simp]: "stake n (siterate f x) = map (\<lambda>n. (f^^n) x) [0 ..< n]"
+ by (induct n arbitrary: x) (auto simp del: stake.simps(2) simp: stake_Suc)
+
+lemma sset_siterate: "sset (siterate f x) = {(f^^n) x | n. True}"
+ by (auto simp: sset_range)
+
+lemma smap_siterate: "smap f (siterate f x) = siterate f (f x)"
+ by (coinduction arbitrary: x) auto
+
+
+subsection {* stream repeating a single element *}
+
+abbreviation "sconst \<equiv> siterate id"
+
+lemma shift_replicate_sconst[simp]: "replicate n x @- sconst x = sconst x"
+ by (subst (3) stake_sdrop[symmetric]) (simp add: map_replicate_trivial)
+
+lemma stream_all_same[simp]: "sset (sconst x) = {x}"
+ by (simp add: sset_siterate)
+
+lemma same_cycle: "sconst x = cycle [x]"
+ by coinduction auto
+
+lemma smap_sconst: "smap f (sconst x) = sconst (f x)"
+ by coinduction auto
+
+lemma sconst_streams: "x \<in> A \<Longrightarrow> sconst x \<in> streams A"
+ by (simp add: streams_iff_sset)
+
+
+subsection {* stream of natural numbers *}
+
+abbreviation "fromN \<equiv> siterate Suc"
+
+abbreviation "nats \<equiv> fromN 0"
+
+lemma sset_fromN[simp]: "sset (fromN n) = {n ..}"
+ by (auto simp add: sset_siterate le_iff_add)
+
+
+subsection {* flatten a stream of lists *}
+
+primcorec flat where
+ "shd (flat ws) = hd (shd ws)"
+| "stl (flat ws) = flat (if tl (shd ws) = [] then stl ws else tl (shd ws) ## stl ws)"
+
+lemma flat_Cons[simp, code]: "flat ((x # xs) ## ws) = x ## flat (if xs = [] then ws else xs ## ws)"
+ by (subst flat.ctr) simp
+
+lemma flat_Stream[simp]: "xs \<noteq> [] \<Longrightarrow> flat (xs ## ws) = xs @- flat ws"
+ by (induct xs) auto
+
+lemma flat_unfold: "shd ws \<noteq> [] \<Longrightarrow> flat ws = shd ws @- flat (stl ws)"
+ by (cases ws) auto
+
+lemma flat_snth: "\<forall>xs \<in> sset s. xs \<noteq> [] \<Longrightarrow> flat s !! n = (if n < length (shd s) then
+ shd s ! n else flat (stl s) !! (n - length (shd s)))"
+ by (metis flat_unfold not_less shd_sset shift_snth_ge shift_snth_less)
+
+lemma sset_flat[simp]: "\<forall>xs \<in> sset s. xs \<noteq> [] \<Longrightarrow>
+ sset (flat s) = (\<Union>xs \<in> sset s. set xs)" (is "?P \<Longrightarrow> ?L = ?R")
+proof safe
+ fix x assume ?P "x : ?L"
+ then obtain m where "x = flat s !! m" by (metis image_iff sset_range)
+ with `?P` obtain n m' where "x = s !! n ! m'" "m' < length (s !! n)"
+ proof (atomize_elim, induct m arbitrary: s rule: less_induct)
+ case (less y)
+ thus ?case
+ proof (cases "y < length (shd s)")
+ case True thus ?thesis by (metis flat_snth less(2,3) snth.simps(1))
+ next
+ case False
+ hence "x = flat (stl s) !! (y - length (shd s))" by (metis less(2,3) flat_snth)
+ moreover
+ { from less(2) have *: "length (shd s) > 0" by (cases s) simp_all
+ with False have "y > 0" by (cases y) simp_all
+ with * have "y - length (shd s) < y" by simp
+ }
+ moreover have "\<forall>xs \<in> sset (stl s). xs \<noteq> []" using less(2) by (cases s) auto
+ ultimately have "\<exists>n m'. x = stl s !! n ! m' \<and> m' < length (stl s !! n)" by (intro less(1)) auto
+ thus ?thesis by (metis snth.simps(2))
+ qed
+ qed
+ thus "x \<in> ?R" by (auto simp: sset_range dest!: nth_mem)
+next
+ fix x xs assume "xs \<in> sset s" ?P "x \<in> set xs" thus "x \<in> ?L"
+ by (induct rule: sset_induct1)
+ (metis UnI1 flat_unfold shift.simps(1) sset_shift,
+ metis UnI2 flat_unfold shd_sset stl_sset sset_shift)
+qed
+
+
+subsection {* merge a stream of streams *}
+
+definition smerge :: "'a stream stream \<Rightarrow> 'a stream" where
+ "smerge ss = flat (smap (\<lambda>n. map (\<lambda>s. s !! n) (stake (Suc n) ss) @ stake n (ss !! n)) nats)"
+
+lemma stake_nth[simp]: "m < n \<Longrightarrow> stake n s ! m = s !! m"
+ by (induct n arbitrary: s m) (auto simp: nth_Cons', metis Suc_pred snth.simps(2))
+
+lemma snth_sset_smerge: "ss !! n !! m \<in> sset (smerge ss)"
+proof (cases "n \<le> m")
+ case False thus ?thesis unfolding smerge_def
+ by (subst sset_flat)
+ (auto simp: stream.set_map in_set_conv_nth simp del: stake.simps
+ intro!: exI[of _ n, OF disjI2] exI[of _ m, OF mp])
+next
+ case True thus ?thesis unfolding smerge_def
+ by (subst sset_flat)
+ (auto simp: stream.set_map in_set_conv_nth image_iff simp del: stake.simps snth.simps
+ intro!: exI[of _ m, OF disjI1] bexI[of _ "ss !! n"] exI[of _ n, OF mp])
+qed
+
+lemma sset_smerge: "sset (smerge ss) = UNION (sset ss) sset"
+proof safe
+ fix x assume "x \<in> sset (smerge ss)"
+ thus "x \<in> UNION (sset ss) sset"
+ unfolding smerge_def by (subst (asm) sset_flat)
+ (auto simp: stream.set_map in_set_conv_nth sset_range simp del: stake.simps, fast+)
+next
+ fix s x assume "s \<in> sset ss" "x \<in> sset s"
+ thus "x \<in> sset (smerge ss)" using snth_sset_smerge by (auto simp: sset_range)
+qed
+
+
+subsection {* product of two streams *}
+
+definition sproduct :: "'a stream \<Rightarrow> 'b stream \<Rightarrow> ('a \<times> 'b) stream" where
+ "sproduct s1 s2 = smerge (smap (\<lambda>x. smap (Pair x) s2) s1)"
+
+lemma sset_sproduct: "sset (sproduct s1 s2) = sset s1 \<times> sset s2"
+ unfolding sproduct_def sset_smerge by (auto simp: stream.set_map)
+
+
+subsection {* interleave two streams *}
+
+primcorec sinterleave where
+ "shd (sinterleave s1 s2) = shd s1"
+| "stl (sinterleave s1 s2) = sinterleave s2 (stl s1)"
+
+lemma sinterleave_code[code]:
+ "sinterleave (x ## s1) s2 = x ## sinterleave s2 s1"
+ by (subst sinterleave.ctr) simp
+
+lemma sinterleave_snth[simp]:
+ "even n \<Longrightarrow> sinterleave s1 s2 !! n = s1 !! (n div 2)"
+ "odd n \<Longrightarrow> sinterleave s1 s2 !! n = s2 !! (n div 2)"
+ by (induct n arbitrary: s1 s2)
+ (auto dest: even_nat_Suc_div_2 odd_nat_plus_one_div_two[folded nat_2])
+
+lemma sset_sinterleave: "sset (sinterleave s1 s2) = sset s1 \<union> sset s2"
+proof (intro equalityI subsetI)
+ fix x assume "x \<in> sset (sinterleave s1 s2)"
+ then obtain n where "x = sinterleave s1 s2 !! n" unfolding sset_range by blast
+ thus "x \<in> sset s1 \<union> sset s2" by (cases "even n") auto
+next
+ fix x assume "x \<in> sset s1 \<union> sset s2"
+ thus "x \<in> sset (sinterleave s1 s2)"
+ proof
+ assume "x \<in> sset s1"
+ then obtain n where "x = s1 !! n" unfolding sset_range by blast
+ hence "sinterleave s1 s2 !! (2 * n) = x" by simp
+ thus ?thesis unfolding sset_range by blast
+ next
+ assume "x \<in> sset s2"
+ then obtain n where "x = s2 !! n" unfolding sset_range by blast
+ hence "sinterleave s1 s2 !! (2 * n + 1) = x" by simp
+ thus ?thesis unfolding sset_range by blast
+ qed
+qed
+
+
+subsection {* zip *}
+
+primcorec szip where
+ "shd (szip s1 s2) = (shd s1, shd s2)"
+| "stl (szip s1 s2) = szip (stl s1) (stl s2)"
+
+lemma szip_unfold[code]: "szip (a ## s1) (b ## s2) = (a, b) ## (szip s1 s2)"
+ by (subst szip.ctr) simp
+
+lemma snth_szip[simp]: "szip s1 s2 !! n = (s1 !! n, s2 !! n)"
+ by (induct n arbitrary: s1 s2) auto
+
+
+subsection {* zip via function *}
+
+primcorec smap2 where
+ "shd (smap2 f s1 s2) = f (shd s1) (shd s2)"
+| "stl (smap2 f s1 s2) = smap2 f (stl s1) (stl s2)"
+
+lemma smap2_unfold[code]:
+ "smap2 f (a ## s1) (b ## s2) = f a b ## (smap2 f s1 s2)"
+ by (subst smap2.ctr) simp
+
+lemma smap2_szip:
+ "smap2 f s1 s2 = smap (split f) (szip s1 s2)"
+ by (coinduction arbitrary: s1 s2) auto
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/Stream_Processor.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,187 @@
+(* Title: HOL/BNF/Examples/Stream_Processor.thy
+ Author: Dmitriy Traytel, TU Muenchen
+ Author: Andrei Popescu, TU Muenchen
+ Copyright 2014
+
+Stream processors---a syntactic representation of continuous functions on streams
+*)
+
+header {* Stream Processors *}
+
+theory Stream_Processor
+imports Stream "../BNF_Decl"
+begin
+
+section {* Continuous Functions on Streams *}
+
+datatype_new ('a, 'b, 'c) sp\<^sub>\<mu> = Get "'a \<Rightarrow> ('a, 'b, 'c) sp\<^sub>\<mu>" | Put "'b" "'c"
+codatatype ('a, 'b) sp\<^sub>\<nu> = In (out: "('a, 'b, ('a, 'b) sp\<^sub>\<nu>) sp\<^sub>\<mu>")
+
+primrec_new run\<^sub>\<mu> :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> 'a stream \<Rightarrow> ('b \<times> 'c) \<times> 'a stream" where
+ "run\<^sub>\<mu> (Get f) s = run\<^sub>\<mu> (f (shd s)) (stl s)"
+| "run\<^sub>\<mu> (Put b sp) s = ((b, sp), s)"
+
+primcorec run\<^sub>\<nu> :: "('a, 'b) sp\<^sub>\<nu> \<Rightarrow> 'a stream \<Rightarrow> 'b stream" where
+ "run\<^sub>\<nu> sp s = (let ((h, sp), s) = run\<^sub>\<mu> (out sp) s in h ## run\<^sub>\<nu> sp s)"
+
+primcorec copy :: "('a, 'a) sp\<^sub>\<nu>" where
+ "copy = In (Get (\<lambda>a. Put a copy))"
+
+lemma run\<^sub>\<nu>_copy: "run\<^sub>\<nu> copy s = s"
+ by (coinduction arbitrary: s) simp
+
+text {*
+To use the function package for the definition of composition the
+wellfoundedness of the subtree relation needs to be proved first.
+*}
+
+definition "sub \<equiv> {(f a, Get f) | a f. True}"
+
+lemma subI[intro]: "(f a, Get f) \<in> sub"
+ unfolding sub_def by blast
+
+lemma wf_sub[simp, intro]: "wf sub"
+proof (rule wfUNIVI)
+ fix P :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> bool" and x
+ assume "\<forall>x. (\<forall>y. (y, x) \<in> sub \<longrightarrow> P y) \<longrightarrow> P x"
+ hence I: "\<And>x. (\<forall>y. (\<exists>a f. y = f a \<and> x = Get f) \<longrightarrow> P y) \<Longrightarrow> P x" unfolding sub_def by blast
+ show "P x" by (induct x) (auto intro: I)
+qed
+
+function
+ sp\<^sub>\<mu>_comp :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> ('d, 'a, ('d, 'a) sp\<^sub>\<nu>) sp\<^sub>\<mu> \<Rightarrow> ('d, 'b, 'c \<times> ('d, 'a) sp\<^sub>\<nu>) sp\<^sub>\<mu>"
+ (infixl "o\<^sub>\<mu>" 65)
+where
+ "Put b sp o\<^sub>\<mu> fsp = Put b (sp, In fsp)"
+| "Get f o\<^sub>\<mu> Put b sp = f b o\<^sub>\<mu> out sp"
+| "Get f o\<^sub>\<mu> Get g = Get (\<lambda>a. Get f o\<^sub>\<mu> g a)"
+by pat_completeness auto
+termination by (relation "lex_prod sub sub") auto
+
+primcorec sp\<^sub>\<nu>_comp (infixl "o\<^sub>\<nu>" 65) where
+ "out (sp o\<^sub>\<nu> sp') = map_sp\<^sub>\<mu> id (\<lambda>(sp, sp'). sp o\<^sub>\<nu> sp') (out sp o\<^sub>\<mu> out sp')"
+
+lemma run\<^sub>\<nu>_sp\<^sub>\<nu>_comp: "run\<^sub>\<nu> (sp o\<^sub>\<nu> sp') = run\<^sub>\<nu> sp o run\<^sub>\<nu> sp'"
+proof (rule ext, unfold comp_apply)
+ fix s
+ show "run\<^sub>\<nu> (sp o\<^sub>\<nu> sp') s = run\<^sub>\<nu> sp (run\<^sub>\<nu> sp' s)"
+ proof (coinduction arbitrary: sp sp' s)
+ case Eq_stream
+ show ?case
+ proof (induct "out sp" "out sp'" arbitrary: sp sp' s rule: sp\<^sub>\<mu>_comp.induct)
+ case (1 b sp'')
+ show ?case by (auto simp add: 1[symmetric])
+ next
+ case (2 f b sp'')
+ from 2(1)[of "In (f b)" sp''] show ?case by (simp add: 2(2,3)[symmetric])
+ next
+ case (3 f h)
+ from 3(1)[of _ "shd s" "In (h (shd s))", OF 3(2)] show ?case by (simp add: 3(2,3)[symmetric])
+ qed
+ qed
+qed
+
+text {* Alternative definition of composition using primrec_new instead of function *}
+
+primrec_new sp\<^sub>\<mu>_comp2R where
+ "sp\<^sub>\<mu>_comp2R f (Put b sp) = f b (out sp)"
+| "sp\<^sub>\<mu>_comp2R f (Get h) = Get (sp\<^sub>\<mu>_comp2R f o h)"
+
+primrec_new sp\<^sub>\<mu>_comp2 (infixl "o\<^sup>*\<^sub>\<mu>" 65) where
+ "Put b sp o\<^sup>*\<^sub>\<mu> fsp = Put b (sp, In fsp)"
+| "Get f o\<^sup>*\<^sub>\<mu> fsp = sp\<^sub>\<mu>_comp2R (op o\<^sup>*\<^sub>\<mu> o f) fsp"
+
+primcorec sp\<^sub>\<nu>_comp2 (infixl "o\<^sup>*\<^sub>\<nu>" 65) where
+ "out (sp o\<^sup>*\<^sub>\<nu> sp') = map_sp\<^sub>\<mu> id (\<lambda>(sp, sp'). sp o\<^sup>*\<^sub>\<nu> sp') (out sp o\<^sup>*\<^sub>\<mu> out sp')"
+
+lemma run\<^sub>\<nu>_sp\<^sub>\<nu>_comp2: "run\<^sub>\<nu> (sp o\<^sup>*\<^sub>\<nu> sp') = run\<^sub>\<nu> sp o run\<^sub>\<nu> sp'"
+proof (rule ext, unfold comp_apply)
+ fix s
+ show "run\<^sub>\<nu> (sp o\<^sup>*\<^sub>\<nu> sp') s = run\<^sub>\<nu> sp (run\<^sub>\<nu> sp' s)"
+ proof (coinduction arbitrary: sp sp' s)
+ case Eq_stream
+ show ?case
+ proof (induct "out sp" arbitrary: sp sp' s)
+ case (Put b sp'')
+ show ?case by (auto simp add: Put[symmetric])
+ next
+ case (Get f)
+ then show ?case
+ proof (induct "out sp'" arbitrary: sp sp' s)
+ case (Put b sp'')
+ from Put(2)[of "In (f b)" sp''] show ?case by (simp add: Put(1,3)[symmetric])
+ next
+ case (Get h)
+ from Get(1)[OF _ Get(3,4), of "In (h (shd s))"] show ?case by (simp add: Get(2,4)[symmetric])
+ qed
+ qed
+ qed
+qed
+
+text {* The two definitions are equivalent *}
+
+lemma sp\<^sub>\<mu>_comp_sp\<^sub>\<mu>_comp2[simp]: "sp o\<^sub>\<mu> sp' = sp o\<^sup>*\<^sub>\<mu> sp'"
+ by (induct sp sp' rule: sp\<^sub>\<mu>_comp.induct) auto
+
+(*will be provided by the package*)
+lemma sp\<^sub>\<mu>_rel_map_map[unfolded vimage2p_def, simp]:
+ "rel_sp\<^sub>\<mu> R1 R2 (map_sp\<^sub>\<mu> f1 f2 sp) (map_sp\<^sub>\<mu> g1 g2 sp') =
+ rel_sp\<^sub>\<mu> (BNF_Def.vimage2p f1 g1 R1) (BNF_Def.vimage2p f2 g2 R2) sp sp'"
+by (tactic {*
+ let val ks = 1 upto 2;
+ in
+ BNF_Tactics.unfold_thms_tac @{context}
+ @{thms sp\<^sub>\<mu>.rel_compp sp\<^sub>\<mu>.rel_conversep sp\<^sub>\<mu>.rel_Grp vimage2p_Grp} THEN
+ HEADGOAL (EVERY' [rtac iffI, rtac @{thm relcomppI}, rtac @{thm GrpI}, rtac refl, rtac CollectI,
+ BNF_Util.CONJ_WRAP' (K (rtac @{thm subset_UNIV})) ks, rtac @{thm relcomppI}, atac,
+ rtac @{thm conversepI}, rtac @{thm GrpI}, rtac refl, rtac CollectI,
+ BNF_Util.CONJ_WRAP' (K (rtac @{thm subset_UNIV})) ks,
+ REPEAT_DETERM o eresolve_tac @{thms relcomppE conversepE GrpE},
+ hyp_subst_tac @{context}, atac])
+ end
+*})
+
+lemma sp\<^sub>\<mu>_rel_self: "\<lbrakk>op = \<le> R1; op = \<le> R2\<rbrakk> \<Longrightarrow> rel_sp\<^sub>\<mu> R1 R2 x x"
+ by (erule (1) predicate2D[OF sp\<^sub>\<mu>.rel_mono]) (simp only: sp\<^sub>\<mu>.rel_eq)
+
+lemma sp\<^sub>\<nu>_comp_sp\<^sub>\<nu>_comp2: "sp o\<^sub>\<nu> sp' = sp o\<^sup>*\<^sub>\<nu> sp'"
+ by (coinduction arbitrary: sp sp') (auto intro!: sp\<^sub>\<mu>_rel_self)
+
+
+section {* Generalization to an Arbitrary BNF as Codomain *}
+
+bnf_decl ('a, 'b) F (map: F)
+
+definition \<theta> :: "('p,'a) F * 'b \<Rightarrow> ('p,'a * 'b) F" where
+ "\<theta> xb = F id <id, \<lambda> a. (snd xb)> (fst xb)"
+
+(* The strength laws for \<theta>: *)
+lemma \<theta>_natural: "F id (map_pair f g) o \<theta> = \<theta> o map_pair (F id f) g"
+ unfolding \<theta>_def F.map_comp comp_def id_apply convol_def map_pair_def split_beta fst_conv snd_conv ..
+
+definition assl :: "'a * ('b * 'c) \<Rightarrow> ('a * 'b) * 'c" where
+ "assl abc = ((fst abc, fst (snd abc)), snd (snd abc))"
+
+lemma \<theta>_rid: "F id fst o \<theta> = fst"
+ unfolding \<theta>_def F.map_comp F.map_id comp_def id_apply convol_def fst_conv sym[OF id_def] ..
+
+lemma \<theta>_assl: "F id assl o \<theta> = \<theta> o map_pair \<theta> id o assl"
+ unfolding assl_def \<theta>_def F.map_comp comp_def id_apply convol_def map_pair_def split fst_conv snd_conv ..
+
+datatype_new ('a, 'b, 'c) spF\<^sub>\<mu> = GetF "'a \<Rightarrow> ('a, 'b, 'c) spF\<^sub>\<mu>" | PutF "('b,'c) F"
+codatatype ('a, 'b) spF\<^sub>\<nu> = InF (outF: "('a, 'b, ('a, 'b) spF\<^sub>\<nu>) spF\<^sub>\<mu>")
+
+codatatype 'b JF = Ctor (dtor: "('b, 'b JF) F")
+
+(* Definition of run for an arbitrary final coalgebra as codomain: *)
+
+primrec_new
+ runF\<^sub>\<mu> :: "('a, 'b, ('a, 'b) spF\<^sub>\<nu>) spF\<^sub>\<mu> \<Rightarrow> 'a stream \<Rightarrow> (('b, ('a, 'b) spF\<^sub>\<nu>) F) \<times> 'a stream"
+where
+ "runF\<^sub>\<mu> (GetF f) s = (runF\<^sub>\<mu> o f) (shd s) (stl s)"
+| "runF\<^sub>\<mu> (PutF x) s = (x, s)"
+
+primcorec runF\<^sub>\<nu> :: "('a, 'b) spF\<^sub>\<nu> \<Rightarrow> 'a stream \<Rightarrow> 'b JF" where
+ "runF\<^sub>\<nu> sp s = (let (x, s) = runF\<^sub>\<mu> (outF sp) s in Ctor (F id (\<lambda> sp. runF\<^sub>\<nu> sp s) x))"
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/TreeFI.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,46 @@
+(* Title: HOL/BNF/Examples/TreeFI.thy
+ Author: Dmitriy Traytel, TU Muenchen
+ Author: Andrei Popescu, TU Muenchen
+ Copyright 2012
+
+Finitely branching possibly infinite trees.
+*)
+
+header {* Finitely Branching Possibly Infinite Trees *}
+
+theory TreeFI
+imports ListF
+begin
+
+codatatype 'a treeFI = Tree (lab: 'a) (sub: "'a treeFI listF")
+
+(* Tree reverse:*)
+primcorec trev where
+ "lab (trev t) = lab t"
+| "sub (trev t) = mapF trev (lrev (sub t))"
+
+lemma treeFI_coinduct:
+ assumes *: "phi x y"
+ and step: "\<And>a b. phi a b \<Longrightarrow>
+ lab a = lab b \<and>
+ lengthh (sub a) = lengthh (sub b) \<and>
+ (\<forall>i < lengthh (sub a). phi (nthh (sub a) i) (nthh (sub b) i))"
+ shows "x = y"
+using * proof (coinduction arbitrary: x y)
+ case (Eq_treeFI t1 t2)
+ from conjunct1[OF conjunct2[OF step[OF Eq_treeFI]]] conjunct2[OF conjunct2[OF step[OF Eq_treeFI]]]
+ have "relF phi (sub t1) (sub t2)"
+ proof (induction "sub t1" "sub t2" arbitrary: t1 t2 rule: listF_induct2)
+ case (Conss x xs y ys)
+ note sub = Conss(2,3)[symmetric] and phi = mp[OF spec[OF Conss(4)], unfolded sub]
+ and IH = Conss(1)[of "Tree (lab t1) (tlF (sub t1))" "Tree (lab t2) (tlF (sub t2))",
+ unfolded sub, simplified]
+ from phi[of 0] show ?case unfolding sub by (auto intro!: IH dest: phi[simplified, OF Suc_mono])
+ qed simp
+ with conjunct1[OF step[OF Eq_treeFI]] show ?case by simp
+qed
+
+lemma trev_trev: "trev (trev tr) = tr"
+ by (coinduction arbitrary: tr rule: treeFI_coinduct) auto
+
+end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/HOL/BNF_Examples/TreeFsetI.thy Mon Jan 20 18:24:56 2014 +0100
@@ -0,0 +1,27 @@
+(* Title: HOL/BNF/Examples/TreeFsetI.thy
+ Author: Dmitriy Traytel, TU Muenchen
+ Author: Andrei Popescu, TU Muenchen
+ Copyright 2012
+
+Finitely branching possibly infinite trees, with sets of children.
+*)
+
+header {* Finitely Branching Possibly Infinite Trees, with Sets of Children *}
+
+theory TreeFsetI
+imports "../BNF"
+begin
+
+hide_fact (open) Lifting_Product.prod_rel_def
+
+codatatype 'a treeFsetI = Tree (lab: 'a) (sub: "'a treeFsetI fset")
+
+(* tree map (contrived example): *)
+primcorec tmap where
+"lab (tmap f t) = f (lab t)" |
+"sub (tmap f t) = fimage (tmap f) (sub t)"
+
+lemma "tmap (f o g) x = tmap f (tmap g x)"
+ by (coinduction arbitrary: x) (auto simp: fset_rel_alt)
+
+end
--- a/src/HOL/ROOT Mon Jan 20 18:24:56 2014 +0100
+++ b/src/HOL/ROOT Mon Jan 20 18:24:56 2014 +0100
@@ -706,7 +706,7 @@
options [document = false]
theories BNF
-session "HOL-BNF-Examples" in "BNF/Examples" = "HOL-BNF" +
+session "HOL-BNF_Examples" in BNF_Examples = HOL +
description {*
Examples for Bounded Natural Functors.
*}