moved BNF examples
authorblanchet
Mon Jan 20 18:24:56 2014 +0100 (2014-01-20)
changeset 550718ae6f86a3477
parent 55070 235c7661a96b
child 55072 8488fdc4ddc0
moved BNF examples
src/HOL/BNF/Examples/Derivation_Trees/DTree.thy
src/HOL/BNF/Examples/Derivation_Trees/Gram_Lang.thy
src/HOL/BNF/Examples/Derivation_Trees/Parallel.thy
src/HOL/BNF/Examples/Derivation_Trees/Prelim.thy
src/HOL/BNF/Examples/Koenig.thy
src/HOL/BNF/Examples/Lambda_Term.thy
src/HOL/BNF/Examples/ListF.thy
src/HOL/BNF/Examples/Misc_Codatatype.thy
src/HOL/BNF/Examples/Misc_Datatype.thy
src/HOL/BNF/Examples/Misc_Primcorec.thy
src/HOL/BNF/Examples/Misc_Primrec.thy
src/HOL/BNF/Examples/Process.thy
src/HOL/BNF/Examples/Stream.thy
src/HOL/BNF/Examples/Stream_Processor.thy
src/HOL/BNF/Examples/TreeFI.thy
src/HOL/BNF/Examples/TreeFsetI.thy
src/HOL/BNF_Examples/Derivation_Trees/DTree.thy
src/HOL/BNF_Examples/Derivation_Trees/Gram_Lang.thy
src/HOL/BNF_Examples/Derivation_Trees/Parallel.thy
src/HOL/BNF_Examples/Derivation_Trees/Prelim.thy
src/HOL/BNF_Examples/Koenig.thy
src/HOL/BNF_Examples/Lambda_Term.thy
src/HOL/BNF_Examples/ListF.thy
src/HOL/BNF_Examples/Misc_Codatatype.thy
src/HOL/BNF_Examples/Misc_Datatype.thy
src/HOL/BNF_Examples/Misc_Primcorec.thy
src/HOL/BNF_Examples/Misc_Primrec.thy
src/HOL/BNF_Examples/Process.thy
src/HOL/BNF_Examples/Stream.thy
src/HOL/BNF_Examples/Stream_Processor.thy
src/HOL/BNF_Examples/TreeFI.thy
src/HOL/BNF_Examples/TreeFsetI.thy
src/HOL/ROOT
     1.1 --- a/src/HOL/BNF/Examples/Derivation_Trees/DTree.thy	Mon Jan 20 18:24:56 2014 +0100
     1.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.3 @@ -1,92 +0,0 @@
     1.4 -(*  Title:      HOL/BNF/Examples/Derivation_Trees/DTree.thy
     1.5 -    Author:     Andrei Popescu, TU Muenchen
     1.6 -    Copyright   2012
     1.7 -
     1.8 -Derivation trees with nonterminal internal nodes and terminal leaves.
     1.9 -*)
    1.10 -
    1.11 -header {* Trees with Nonterminal Internal Nodes and Terminal Leaves *}
    1.12 -
    1.13 -theory DTree
    1.14 -imports Prelim
    1.15 -begin
    1.16 -
    1.17 -typedecl N
    1.18 -typedecl T
    1.19 -
    1.20 -codatatype dtree = NNode (root: N) (ccont: "(T + dtree) fset")
    1.21 -
    1.22 -subsection{* Transporting the Characteristic Lemmas from @{text "fset"} to @{text "set"} *}
    1.23 -
    1.24 -definition "Node n as \<equiv> NNode n (the_inv fset as)"
    1.25 -definition "cont \<equiv> fset o ccont"
    1.26 -definition "unfold rt ct \<equiv> unfold_dtree rt (the_inv fset o ct)"
    1.27 -definition "corec rt ct \<equiv> corec_dtree rt (the_inv fset o ct)"
    1.28 -
    1.29 -lemma finite_cont[simp]: "finite (cont tr)"
    1.30 -  unfolding cont_def comp_apply by (cases tr, clarsimp)
    1.31 -
    1.32 -lemma Node_root_cont[simp]:
    1.33 -  "Node (root tr) (cont tr) = tr"
    1.34 -  unfolding Node_def cont_def comp_apply
    1.35 -  apply (rule trans[OF _ dtree.collapse])
    1.36 -  apply (rule arg_cong2[OF refl the_inv_into_f_f[unfolded inj_on_def]])
    1.37 -  apply (simp_all add: fset_inject)
    1.38 -  done
    1.39 -
    1.40 -lemma dtree_simps[simp]:
    1.41 -assumes "finite as" and "finite as'"
    1.42 -shows "Node n as = Node n' as' \<longleftrightarrow> n = n' \<and> as = as'"
    1.43 -using assms dtree.inject unfolding Node_def
    1.44 -by (metis fset_to_fset)
    1.45 -
    1.46 -lemma dtree_cases[elim, case_names Node Choice]:
    1.47 -assumes Node: "\<And> n as. \<lbrakk>finite as; tr = Node n as\<rbrakk> \<Longrightarrow> phi"
    1.48 -shows phi
    1.49 -apply(cases rule: dtree.exhaust[of tr])
    1.50 -using Node unfolding Node_def
    1.51 -by (metis Node Node_root_cont finite_cont)
    1.52 -
    1.53 -lemma dtree_sel_ctor[simp]:
    1.54 -"root (Node n as) = n"
    1.55 -"finite as \<Longrightarrow> cont (Node n as) = as"
    1.56 -unfolding Node_def cont_def by auto
    1.57 -
    1.58 -lemmas root_Node = dtree_sel_ctor(1)
    1.59 -lemmas cont_Node = dtree_sel_ctor(2)
    1.60 -
    1.61 -lemma dtree_cong:
    1.62 -assumes "root tr = root tr'" and "cont tr = cont tr'"
    1.63 -shows "tr = tr'"
    1.64 -by (metis Node_root_cont assms)
    1.65 -
    1.66 -lemma set_rel_cont:
    1.67 -"set_rel \<chi> (cont tr1) (cont tr2) = fset_rel \<chi> (ccont tr1) (ccont tr2)"
    1.68 -unfolding cont_def comp_def fset_rel_fset ..
    1.69 -
    1.70 -lemma dtree_coinduct[elim, consumes 1, case_names Lift, induct pred: "HOL.eq"]:
    1.71 -assumes phi: "\<phi> tr1 tr2" and
    1.72 -Lift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow>
    1.73 -                  root tr1 = root tr2 \<and> set_rel (sum_rel op = \<phi>) (cont tr1) (cont tr2)"
    1.74 -shows "tr1 = tr2"
    1.75 -using phi apply(elim dtree.coinduct)
    1.76 -apply(rule Lift[unfolded set_rel_cont]) .
    1.77 -
    1.78 -lemma unfold:
    1.79 -"root (unfold rt ct b) = rt b"
    1.80 -"finite (ct b) \<Longrightarrow> cont (unfold rt ct b) = image (id \<oplus> unfold rt ct) (ct b)"
    1.81 -using dtree.sel_unfold[of rt "the_inv fset \<circ> ct" b] unfolding unfold_def
    1.82 -apply - apply metis
    1.83 -unfolding cont_def comp_def
    1.84 -by simp
    1.85 -
    1.86 -lemma corec:
    1.87 -"root (corec rt ct b) = rt b"
    1.88 -"finite (ct b) \<Longrightarrow> cont (corec rt ct b) = image (id \<oplus> ([[id, corec rt ct]])) (ct b)"
    1.89 -using dtree.sel_corec[of rt "the_inv fset \<circ> ct" b] unfolding corec_def
    1.90 -apply -
    1.91 -apply simp
    1.92 -unfolding cont_def comp_def id_def
    1.93 -by simp
    1.94 -
    1.95 -end
     2.1 --- a/src/HOL/BNF/Examples/Derivation_Trees/Gram_Lang.thy	Mon Jan 20 18:24:56 2014 +0100
     2.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.3 @@ -1,1359 +0,0 @@
     2.4 -(*  Title:      HOL/BNF/Examples/Derivation_Trees/Gram_Lang.thy
     2.5 -    Author:     Andrei Popescu, TU Muenchen
     2.6 -    Copyright   2012
     2.7 -
     2.8 -Language of a grammar.
     2.9 -*)
    2.10 -
    2.11 -header {* Language of a Grammar *}
    2.12 -
    2.13 -theory Gram_Lang
    2.14 -imports DTree
    2.15 -begin
    2.16 -
    2.17 -
    2.18 -(* We assume that the sets of terminals, and the left-hand sides of
    2.19 -productions are finite and that the grammar has no unused nonterminals. *)
    2.20 -consts P :: "(N \<times> (T + N) set) set"
    2.21 -axiomatization where
    2.22 -    finite_N: "finite (UNIV::N set)"
    2.23 -and finite_in_P: "\<And> n tns. (n,tns) \<in> P \<longrightarrow> finite tns"
    2.24 -and used: "\<And> n. \<exists> tns. (n,tns) \<in> P"
    2.25 -
    2.26 -
    2.27 -subsection{* Tree Basics: frontier, interior, etc. *}
    2.28 -
    2.29 -
    2.30 -(* Frontier *)
    2.31 -
    2.32 -inductive inFr :: "N set \<Rightarrow> dtree \<Rightarrow> T \<Rightarrow> bool" where
    2.33 -Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr ns tr t"
    2.34 -|
    2.35 -Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inFr ns tr1 t\<rbrakk> \<Longrightarrow> inFr ns tr t"
    2.36 -
    2.37 -definition "Fr ns tr \<equiv> {t. inFr ns tr t}"
    2.38 -
    2.39 -lemma inFr_root_in: "inFr ns tr t \<Longrightarrow> root tr \<in> ns"
    2.40 -by (metis inFr.simps)
    2.41 -
    2.42 -lemma inFr_mono:
    2.43 -assumes "inFr ns tr t" and "ns \<subseteq> ns'"
    2.44 -shows "inFr ns' tr t"
    2.45 -using assms apply(induct arbitrary: ns' rule: inFr.induct)
    2.46 -using Base Ind by (metis inFr.simps set_mp)+
    2.47 -
    2.48 -lemma inFr_Ind_minus:
    2.49 -assumes "inFr ns1 tr1 t" and "Inr tr1 \<in> cont tr"
    2.50 -shows "inFr (insert (root tr) ns1) tr t"
    2.51 -using assms apply(induct rule: inFr.induct)
    2.52 -  apply (metis inFr.simps insert_iff)
    2.53 -  by (metis inFr.simps inFr_mono insertI1 subset_insertI)
    2.54 -
    2.55 -(* alternative definition *)
    2.56 -inductive inFr2 :: "N set \<Rightarrow> dtree \<Rightarrow> T \<Rightarrow> bool" where
    2.57 -Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr2 ns tr t"
    2.58 -|
    2.59 -Ind: "\<lbrakk>Inr tr1 \<in> cont tr; inFr2 ns1 tr1 t\<rbrakk>
    2.60 -      \<Longrightarrow> inFr2 (insert (root tr) ns1) tr t"
    2.61 -
    2.62 -lemma inFr2_root_in: "inFr2 ns tr t \<Longrightarrow> root tr \<in> ns"
    2.63 -apply(induct rule: inFr2.induct) by auto
    2.64 -
    2.65 -lemma inFr2_mono:
    2.66 -assumes "inFr2 ns tr t" and "ns \<subseteq> ns'"
    2.67 -shows "inFr2 ns' tr t"
    2.68 -using assms apply(induct arbitrary: ns' rule: inFr2.induct)
    2.69 -using Base Ind
    2.70 -apply (metis subsetD) by (metis inFr2.simps insert_absorb insert_subset)
    2.71 -
    2.72 -lemma inFr2_Ind:
    2.73 -assumes "inFr2 ns tr1 t" and "root tr \<in> ns" and "Inr tr1 \<in> cont tr"
    2.74 -shows "inFr2 ns tr t"
    2.75 -using assms apply(induct rule: inFr2.induct)
    2.76 -  apply (metis inFr2.simps insert_absorb)
    2.77 -  by (metis inFr2.simps insert_absorb)
    2.78 -
    2.79 -lemma inFr_inFr2:
    2.80 -"inFr = inFr2"
    2.81 -apply (rule ext)+  apply(safe)
    2.82 -  apply(erule inFr.induct)
    2.83 -    apply (metis (lifting) inFr2.Base)
    2.84 -    apply (metis (lifting) inFr2_Ind)
    2.85 -  apply(erule inFr2.induct)
    2.86 -    apply (metis (lifting) inFr.Base)
    2.87 -    apply (metis (lifting) inFr_Ind_minus)
    2.88 -done
    2.89 -
    2.90 -lemma not_root_inFr:
    2.91 -assumes "root tr \<notin> ns"
    2.92 -shows "\<not> inFr ns tr t"
    2.93 -by (metis assms inFr_root_in)
    2.94 -
    2.95 -lemma not_root_Fr:
    2.96 -assumes "root tr \<notin> ns"
    2.97 -shows "Fr ns tr = {}"
    2.98 -using not_root_inFr[OF assms] unfolding Fr_def by auto
    2.99 -
   2.100 -
   2.101 -(* Interior *)
   2.102 -
   2.103 -inductive inItr :: "N set \<Rightarrow> dtree \<Rightarrow> N \<Rightarrow> bool" where
   2.104 -Base: "root tr \<in> ns \<Longrightarrow> inItr ns tr (root tr)"
   2.105 -|
   2.106 -Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inItr ns tr1 n\<rbrakk> \<Longrightarrow> inItr ns tr n"
   2.107 -
   2.108 -definition "Itr ns tr \<equiv> {n. inItr ns tr n}"
   2.109 -
   2.110 -lemma inItr_root_in: "inItr ns tr n \<Longrightarrow> root tr \<in> ns"
   2.111 -by (metis inItr.simps)
   2.112 -
   2.113 -lemma inItr_mono:
   2.114 -assumes "inItr ns tr n" and "ns \<subseteq> ns'"
   2.115 -shows "inItr ns' tr n"
   2.116 -using assms apply(induct arbitrary: ns' rule: inItr.induct)
   2.117 -using Base Ind by (metis inItr.simps set_mp)+
   2.118 -
   2.119 -
   2.120 -(* The subtree relation *)
   2.121 -
   2.122 -inductive subtr where
   2.123 -Refl: "root tr \<in> ns \<Longrightarrow> subtr ns tr tr"
   2.124 -|
   2.125 -Step: "\<lbrakk>root tr3 \<in> ns; subtr ns tr1 tr2; Inr tr2 \<in> cont tr3\<rbrakk> \<Longrightarrow> subtr ns tr1 tr3"
   2.126 -
   2.127 -lemma subtr_rootL_in:
   2.128 -assumes "subtr ns tr1 tr2"
   2.129 -shows "root tr1 \<in> ns"
   2.130 -using assms apply(induct rule: subtr.induct) by auto
   2.131 -
   2.132 -lemma subtr_rootR_in:
   2.133 -assumes "subtr ns tr1 tr2"
   2.134 -shows "root tr2 \<in> ns"
   2.135 -using assms apply(induct rule: subtr.induct) by auto
   2.136 -
   2.137 -lemmas subtr_roots_in = subtr_rootL_in subtr_rootR_in
   2.138 -
   2.139 -lemma subtr_mono:
   2.140 -assumes "subtr ns tr1 tr2" and "ns \<subseteq> ns'"
   2.141 -shows "subtr ns' tr1 tr2"
   2.142 -using assms apply(induct arbitrary: ns' rule: subtr.induct)
   2.143 -using Refl Step by (metis subtr.simps set_mp)+
   2.144 -
   2.145 -lemma subtr_trans_Un:
   2.146 -assumes "subtr ns12 tr1 tr2" and "subtr ns23 tr2 tr3"
   2.147 -shows "subtr (ns12 \<union> ns23) tr1 tr3"
   2.148 -proof-
   2.149 -  have "subtr ns23 tr2 tr3  \<Longrightarrow>
   2.150 -        (\<forall> ns12 tr1. subtr ns12 tr1 tr2 \<longrightarrow> subtr (ns12 \<union> ns23) tr1 tr3)"
   2.151 -  apply(induct  rule: subtr.induct, safe)
   2.152 -    apply (metis subtr_mono sup_commute sup_ge2)
   2.153 -    by (metis (lifting) Step UnI2)
   2.154 -  thus ?thesis using assms by auto
   2.155 -qed
   2.156 -
   2.157 -lemma subtr_trans:
   2.158 -assumes "subtr ns tr1 tr2" and "subtr ns tr2 tr3"
   2.159 -shows "subtr ns tr1 tr3"
   2.160 -using subtr_trans_Un[OF assms] by simp
   2.161 -
   2.162 -lemma subtr_StepL:
   2.163 -assumes r: "root tr1 \<in> ns" and tr12: "Inr tr1 \<in> cont tr2" and s: "subtr ns tr2 tr3"
   2.164 -shows "subtr ns tr1 tr3"
   2.165 -apply(rule subtr_trans[OF _ s])
   2.166 -apply(rule Step[of tr2 ns tr1 tr1])
   2.167 -apply(rule subtr_rootL_in[OF s])
   2.168 -apply(rule Refl[OF r])
   2.169 -apply(rule tr12)
   2.170 -done
   2.171 -
   2.172 -(* alternative definition: *)
   2.173 -inductive subtr2 where
   2.174 -Refl: "root tr \<in> ns \<Longrightarrow> subtr2 ns tr tr"
   2.175 -|
   2.176 -Step: "\<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr2 ns tr2 tr3\<rbrakk> \<Longrightarrow> subtr2 ns tr1 tr3"
   2.177 -
   2.178 -lemma subtr2_rootL_in:
   2.179 -assumes "subtr2 ns tr1 tr2"
   2.180 -shows "root tr1 \<in> ns"
   2.181 -using assms apply(induct rule: subtr2.induct) by auto
   2.182 -
   2.183 -lemma subtr2_rootR_in:
   2.184 -assumes "subtr2 ns tr1 tr2"
   2.185 -shows "root tr2 \<in> ns"
   2.186 -using assms apply(induct rule: subtr2.induct) by auto
   2.187 -
   2.188 -lemmas subtr2_roots_in = subtr2_rootL_in subtr2_rootR_in
   2.189 -
   2.190 -lemma subtr2_mono:
   2.191 -assumes "subtr2 ns tr1 tr2" and "ns \<subseteq> ns'"
   2.192 -shows "subtr2 ns' tr1 tr2"
   2.193 -using assms apply(induct arbitrary: ns' rule: subtr2.induct)
   2.194 -using Refl Step by (metis subtr2.simps set_mp)+
   2.195 -
   2.196 -lemma subtr2_trans_Un:
   2.197 -assumes "subtr2 ns12 tr1 tr2" and "subtr2 ns23 tr2 tr3"
   2.198 -shows "subtr2 (ns12 \<union> ns23) tr1 tr3"
   2.199 -proof-
   2.200 -  have "subtr2 ns12 tr1 tr2  \<Longrightarrow>
   2.201 -        (\<forall> ns23 tr3. subtr2 ns23 tr2 tr3 \<longrightarrow> subtr2 (ns12 \<union> ns23) tr1 tr3)"
   2.202 -  apply(induct  rule: subtr2.induct, safe)
   2.203 -    apply (metis subtr2_mono sup_commute sup_ge2)
   2.204 -    by (metis Un_iff subtr2.simps)
   2.205 -  thus ?thesis using assms by auto
   2.206 -qed
   2.207 -
   2.208 -lemma subtr2_trans:
   2.209 -assumes "subtr2 ns tr1 tr2" and "subtr2 ns tr2 tr3"
   2.210 -shows "subtr2 ns tr1 tr3"
   2.211 -using subtr2_trans_Un[OF assms] by simp
   2.212 -
   2.213 -lemma subtr2_StepR:
   2.214 -assumes r: "root tr3 \<in> ns" and tr23: "Inr tr2 \<in> cont tr3" and s: "subtr2 ns tr1 tr2"
   2.215 -shows "subtr2 ns tr1 tr3"
   2.216 -apply(rule subtr2_trans[OF s])
   2.217 -apply(rule Step[of _ _ tr3])
   2.218 -apply(rule subtr2_rootR_in[OF s])
   2.219 -apply(rule tr23)
   2.220 -apply(rule Refl[OF r])
   2.221 -done
   2.222 -
   2.223 -lemma subtr_subtr2:
   2.224 -"subtr = subtr2"
   2.225 -apply (rule ext)+  apply(safe)
   2.226 -  apply(erule subtr.induct)
   2.227 -    apply (metis (lifting) subtr2.Refl)
   2.228 -    apply (metis (lifting) subtr2_StepR)
   2.229 -  apply(erule subtr2.induct)
   2.230 -    apply (metis (lifting) subtr.Refl)
   2.231 -    apply (metis (lifting) subtr_StepL)
   2.232 -done
   2.233 -
   2.234 -lemma subtr_inductL[consumes 1, case_names Refl Step]:
   2.235 -assumes s: "subtr ns tr1 tr2" and Refl: "\<And>ns tr. \<phi> ns tr tr"
   2.236 -and Step:
   2.237 -"\<And>ns tr1 tr2 tr3.
   2.238 -   \<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr ns tr2 tr3; \<phi> ns tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> ns tr1 tr3"
   2.239 -shows "\<phi> ns tr1 tr2"
   2.240 -using s unfolding subtr_subtr2 apply(rule subtr2.induct)
   2.241 -using Refl Step unfolding subtr_subtr2 by auto
   2.242 -
   2.243 -lemma subtr_UNIV_inductL[consumes 1, case_names Refl Step]:
   2.244 -assumes s: "subtr UNIV tr1 tr2" and Refl: "\<And>tr. \<phi> tr tr"
   2.245 -and Step:
   2.246 -"\<And>tr1 tr2 tr3.
   2.247 -   \<lbrakk>Inr tr1 \<in> cont tr2; subtr UNIV tr2 tr3; \<phi> tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> tr1 tr3"
   2.248 -shows "\<phi> tr1 tr2"
   2.249 -using s apply(induct rule: subtr_inductL)
   2.250 -apply(rule Refl) using Step subtr_mono by (metis subset_UNIV)
   2.251 -
   2.252 -(* Subtree versus frontier: *)
   2.253 -lemma subtr_inFr:
   2.254 -assumes "inFr ns tr t" and "subtr ns tr tr1"
   2.255 -shows "inFr ns tr1 t"
   2.256 -proof-
   2.257 -  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inFr ns tr t \<longrightarrow> inFr ns tr1 t)"
   2.258 -  apply(induct rule: subtr.induct, safe) by (metis inFr.Ind)
   2.259 -  thus ?thesis using assms by auto
   2.260 -qed
   2.261 -
   2.262 -corollary Fr_subtr:
   2.263 -"Fr ns tr = \<Union> {Fr ns tr' | tr'. subtr ns tr' tr}"
   2.264 -unfolding Fr_def proof safe
   2.265 -  fix t assume t: "inFr ns tr t"  hence "root tr \<in> ns" by (rule inFr_root_in)
   2.266 -  thus "t \<in> \<Union>{{t. inFr ns tr' t} |tr'. subtr ns tr' tr}"
   2.267 -  apply(intro UnionI[of "{t. inFr ns tr t}" _ t]) using t subtr.Refl by auto
   2.268 -qed(metis subtr_inFr)
   2.269 -
   2.270 -lemma inFr_subtr:
   2.271 -assumes "inFr ns tr t"
   2.272 -shows "\<exists> tr'. subtr ns tr' tr \<and> Inl t \<in> cont tr'"
   2.273 -using assms apply(induct rule: inFr.induct) apply safe
   2.274 -  apply (metis subtr.Refl)
   2.275 -  by (metis (lifting) subtr.Step)
   2.276 -
   2.277 -corollary Fr_subtr_cont:
   2.278 -"Fr ns tr = \<Union> {Inl -` cont tr' | tr'. subtr ns tr' tr}"
   2.279 -unfolding Fr_def
   2.280 -apply safe
   2.281 -apply (frule inFr_subtr)
   2.282 -apply auto
   2.283 -by (metis inFr.Base subtr_inFr subtr_rootL_in)
   2.284 -
   2.285 -(* Subtree versus interior: *)
   2.286 -lemma subtr_inItr:
   2.287 -assumes "inItr ns tr n" and "subtr ns tr tr1"
   2.288 -shows "inItr ns tr1 n"
   2.289 -proof-
   2.290 -  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inItr ns tr n \<longrightarrow> inItr ns tr1 n)"
   2.291 -  apply(induct rule: subtr.induct, safe) by (metis inItr.Ind)
   2.292 -  thus ?thesis using assms by auto
   2.293 -qed
   2.294 -
   2.295 -corollary Itr_subtr:
   2.296 -"Itr ns tr = \<Union> {Itr ns tr' | tr'. subtr ns tr' tr}"
   2.297 -unfolding Itr_def apply safe
   2.298 -apply (metis (lifting, mono_tags) UnionI inItr_root_in mem_Collect_eq subtr.Refl)
   2.299 -by (metis subtr_inItr)
   2.300 -
   2.301 -lemma inItr_subtr:
   2.302 -assumes "inItr ns tr n"
   2.303 -shows "\<exists> tr'. subtr ns tr' tr \<and> root tr' = n"
   2.304 -using assms apply(induct rule: inItr.induct) apply safe
   2.305 -  apply (metis subtr.Refl)
   2.306 -  by (metis (lifting) subtr.Step)
   2.307 -
   2.308 -corollary Itr_subtr_cont:
   2.309 -"Itr ns tr = {root tr' | tr'. subtr ns tr' tr}"
   2.310 -unfolding Itr_def apply safe
   2.311 -  apply (metis (lifting, mono_tags) inItr_subtr)
   2.312 -  by (metis inItr.Base subtr_inItr subtr_rootL_in)
   2.313 -
   2.314 -
   2.315 -subsection{* The Immediate Subtree Function *}
   2.316 -
   2.317 -(* production of: *)
   2.318 -abbreviation "prodOf tr \<equiv> (id \<oplus> root) ` (cont tr)"
   2.319 -(* subtree of: *)
   2.320 -definition "subtrOf tr n \<equiv> SOME tr'. Inr tr' \<in> cont tr \<and> root tr' = n"
   2.321 -
   2.322 -lemma subtrOf:
   2.323 -assumes n: "Inr n \<in> prodOf tr"
   2.324 -shows "Inr (subtrOf tr n) \<in> cont tr \<and> root (subtrOf tr n) = n"
   2.325 -proof-
   2.326 -  obtain tr' where "Inr tr' \<in> cont tr \<and> root tr' = n"
   2.327 -  using n unfolding image_def by (metis (lifting) Inr_oplus_elim assms)
   2.328 -  thus ?thesis unfolding subtrOf_def by(rule someI)
   2.329 -qed
   2.330 -
   2.331 -lemmas Inr_subtrOf = subtrOf[THEN conjunct1]
   2.332 -lemmas root_subtrOf[simp] = subtrOf[THEN conjunct2]
   2.333 -
   2.334 -lemma Inl_prodOf: "Inl -` (prodOf tr) = Inl -` (cont tr)"
   2.335 -proof safe
   2.336 -  fix t ttr assume "Inl t = (id \<oplus> root) ttr" and "ttr \<in> cont tr"
   2.337 -  thus "t \<in> Inl -` cont tr" by(cases ttr, auto)
   2.338 -next
   2.339 -  fix t assume "Inl t \<in> cont tr" thus "t \<in> Inl -` prodOf tr"
   2.340 -  by (metis (lifting) id_def image_iff sum_map.simps(1) vimageI2)
   2.341 -qed
   2.342 -
   2.343 -lemma root_prodOf:
   2.344 -assumes "Inr tr' \<in> cont tr"
   2.345 -shows "Inr (root tr') \<in> prodOf tr"
   2.346 -by (metis (lifting) assms image_iff sum_map.simps(2))
   2.347 -
   2.348 -
   2.349 -subsection{* Well-Formed Derivation Trees *}
   2.350 -
   2.351 -hide_const wf
   2.352 -
   2.353 -coinductive wf where
   2.354 -dtree: "\<lbrakk>(root tr, (id \<oplus> root) ` (cont tr)) \<in> P; inj_on root (Inr -` cont tr);
   2.355 -        \<And> tr'. tr' \<in> Inr -` (cont tr) \<Longrightarrow> wf tr'\<rbrakk> \<Longrightarrow> wf tr"
   2.356 -
   2.357 -(* destruction rules: *)
   2.358 -lemma wf_P:
   2.359 -assumes "wf tr"
   2.360 -shows "(root tr, (id \<oplus> root) ` (cont tr)) \<in> P"
   2.361 -using assms wf.simps[of tr] by auto
   2.362 -
   2.363 -lemma wf_inj_on:
   2.364 -assumes "wf tr"
   2.365 -shows "inj_on root (Inr -` cont tr)"
   2.366 -using assms wf.simps[of tr] by auto
   2.367 -
   2.368 -lemma wf_inj[simp]:
   2.369 -assumes "wf tr" and "Inr tr1 \<in> cont tr" and "Inr tr2 \<in> cont tr"
   2.370 -shows "root tr1 = root tr2 \<longleftrightarrow> tr1 = tr2"
   2.371 -using assms wf_inj_on unfolding inj_on_def by auto
   2.372 -
   2.373 -lemma wf_cont:
   2.374 -assumes "wf tr" and "Inr tr' \<in> cont tr"
   2.375 -shows "wf tr'"
   2.376 -using assms wf.simps[of tr] by auto
   2.377 -
   2.378 -
   2.379 -(* coinduction:*)
   2.380 -lemma wf_coind[elim, consumes 1, case_names Hyp]:
   2.381 -assumes phi: "\<phi> tr"
   2.382 -and Hyp:
   2.383 -"\<And> tr. \<phi> tr \<Longrightarrow>
   2.384 -       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
   2.385 -       inj_on root (Inr -` cont tr) \<and>
   2.386 -       (\<forall> tr' \<in> Inr -` (cont tr). \<phi> tr' \<or> wf tr')"
   2.387 -shows "wf tr"
   2.388 -apply(rule wf.coinduct[of \<phi> tr, OF phi])
   2.389 -using Hyp by blast
   2.390 -
   2.391 -lemma wf_raw_coind[elim, consumes 1, case_names Hyp]:
   2.392 -assumes phi: "\<phi> tr"
   2.393 -and Hyp:
   2.394 -"\<And> tr. \<phi> tr \<Longrightarrow>
   2.395 -       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
   2.396 -       inj_on root (Inr -` cont tr) \<and>
   2.397 -       (\<forall> tr' \<in> Inr -` (cont tr). \<phi> tr')"
   2.398 -shows "wf tr"
   2.399 -using phi apply(induct rule: wf_coind)
   2.400 -using Hyp by (metis (mono_tags))
   2.401 -
   2.402 -lemma wf_subtr_inj_on:
   2.403 -assumes d: "wf tr1" and s: "subtr ns tr tr1"
   2.404 -shows "inj_on root (Inr -` cont tr)"
   2.405 -using s d apply(induct rule: subtr.induct)
   2.406 -apply (metis (lifting) wf_inj_on) by (metis wf_cont)
   2.407 -
   2.408 -lemma wf_subtr_P:
   2.409 -assumes d: "wf tr1" and s: "subtr ns tr tr1"
   2.410 -shows "(root tr, (id \<oplus> root) ` cont tr) \<in> P"
   2.411 -using s d apply(induct rule: subtr.induct)
   2.412 -apply (metis (lifting) wf_P) by (metis wf_cont)
   2.413 -
   2.414 -lemma subtrOf_root[simp]:
   2.415 -assumes tr: "wf tr" and cont: "Inr tr' \<in> cont tr"
   2.416 -shows "subtrOf tr (root tr') = tr'"
   2.417 -proof-
   2.418 -  have 0: "Inr (subtrOf tr (root tr')) \<in> cont tr" using Inr_subtrOf
   2.419 -  by (metis (lifting) cont root_prodOf)
   2.420 -  have "root (subtrOf tr (root tr')) = root tr'"
   2.421 -  using root_subtrOf by (metis (lifting) cont root_prodOf)
   2.422 -  thus ?thesis unfolding wf_inj[OF tr 0 cont] .
   2.423 -qed
   2.424 -
   2.425 -lemma surj_subtrOf:
   2.426 -assumes "wf tr" and 0: "Inr tr' \<in> cont tr"
   2.427 -shows "\<exists> n. Inr n \<in> prodOf tr \<and> subtrOf tr n = tr'"
   2.428 -apply(rule exI[of _ "root tr'"])
   2.429 -using root_prodOf[OF 0] subtrOf_root[OF assms] by simp
   2.430 -
   2.431 -lemma wf_subtr:
   2.432 -assumes "wf tr1" and "subtr ns tr tr1"
   2.433 -shows "wf tr"
   2.434 -proof-
   2.435 -  have "(\<exists> ns tr1. wf tr1 \<and> subtr ns tr tr1) \<Longrightarrow> wf tr"
   2.436 -  proof (induct rule: wf_raw_coind)
   2.437 -    case (Hyp tr)
   2.438 -    then obtain ns tr1 where tr1: "wf tr1" and tr_tr1: "subtr ns tr tr1" by auto
   2.439 -    show ?case proof safe
   2.440 -      show "(root tr, (id \<oplus> root) ` cont tr) \<in> P" using wf_subtr_P[OF tr1 tr_tr1] .
   2.441 -    next
   2.442 -      show "inj_on root (Inr -` cont tr)" using wf_subtr_inj_on[OF tr1 tr_tr1] .
   2.443 -    next
   2.444 -      fix tr' assume tr': "Inr tr' \<in> cont tr"
   2.445 -      have tr_tr1: "subtr (ns \<union> {root tr'}) tr tr1" using subtr_mono[OF tr_tr1] by auto
   2.446 -      have "subtr (ns \<union> {root tr'}) tr' tr1" using subtr_StepL[OF _ tr' tr_tr1] by auto
   2.447 -      thus "\<exists>ns' tr1. wf tr1 \<and> subtr ns' tr' tr1" using tr1 by blast
   2.448 -    qed
   2.449 -  qed
   2.450 -  thus ?thesis using assms by auto
   2.451 -qed
   2.452 -
   2.453 -
   2.454 -subsection{* Default Trees *}
   2.455 -
   2.456 -(* Pick a left-hand side of a production for each nonterminal *)
   2.457 -definition S where "S n \<equiv> SOME tns. (n,tns) \<in> P"
   2.458 -
   2.459 -lemma S_P: "(n, S n) \<in> P"
   2.460 -using used unfolding S_def by(rule someI_ex)
   2.461 -
   2.462 -lemma finite_S: "finite (S n)"
   2.463 -using S_P finite_in_P by auto
   2.464 -
   2.465 -
   2.466 -(* The default tree of a nonterminal *)
   2.467 -definition deftr :: "N \<Rightarrow> dtree" where
   2.468 -"deftr \<equiv> unfold id S"
   2.469 -
   2.470 -lemma deftr_simps[simp]:
   2.471 -"root (deftr n) = n"
   2.472 -"cont (deftr n) = image (id \<oplus> deftr) (S n)"
   2.473 -using unfold(1)[of id S n] unfold(2)[of S n id, OF finite_S]
   2.474 -unfolding deftr_def by simp_all
   2.475 -
   2.476 -lemmas root_deftr = deftr_simps(1)
   2.477 -lemmas cont_deftr = deftr_simps(2)
   2.478 -
   2.479 -lemma root_o_deftr[simp]: "root o deftr = id"
   2.480 -by (rule ext, auto)
   2.481 -
   2.482 -lemma wf_deftr: "wf (deftr n)"
   2.483 -proof-
   2.484 -  {fix tr assume "\<exists> n. tr = deftr n" hence "wf tr"
   2.485 -   apply(induct rule: wf_raw_coind) apply safe
   2.486 -   unfolding deftr_simps image_compose[symmetric] sum_map.comp id_comp
   2.487 -   root_o_deftr sum_map.id image_id id_apply apply(rule S_P)
   2.488 -   unfolding inj_on_def by auto
   2.489 -  }
   2.490 -  thus ?thesis by auto
   2.491 -qed
   2.492 -
   2.493 -
   2.494 -subsection{* Hereditary Substitution *}
   2.495 -
   2.496 -(* Auxiliary concept: The root-ommiting frontier: *)
   2.497 -definition "inFrr ns tr t \<equiv> \<exists> tr'. Inr tr' \<in> cont tr \<and> inFr ns tr' t"
   2.498 -definition "Frr ns tr \<equiv> {t. \<exists> tr'. Inr tr' \<in> cont tr \<and> t \<in> Fr ns tr'}"
   2.499 -
   2.500 -context
   2.501 -fixes tr0 :: dtree
   2.502 -begin
   2.503 -
   2.504 -definition "hsubst_r tr \<equiv> root tr"
   2.505 -definition "hsubst_c tr \<equiv> if root tr = root tr0 then cont tr0 else cont tr"
   2.506 -
   2.507 -(* Hereditary substitution: *)
   2.508 -definition hsubst :: "dtree \<Rightarrow> dtree" where
   2.509 -"hsubst \<equiv> unfold hsubst_r hsubst_c"
   2.510 -
   2.511 -lemma finite_hsubst_c: "finite (hsubst_c n)"
   2.512 -unfolding hsubst_c_def by (metis (full_types) finite_cont)
   2.513 -
   2.514 -lemma root_hsubst[simp]: "root (hsubst tr) = root tr"
   2.515 -using unfold(1)[of hsubst_r hsubst_c tr] unfolding hsubst_def hsubst_r_def by simp
   2.516 -
   2.517 -lemma root_o_subst[simp]: "root o hsubst = root"
   2.518 -unfolding comp_def root_hsubst ..
   2.519 -
   2.520 -lemma cont_hsubst_eq[simp]:
   2.521 -assumes "root tr = root tr0"
   2.522 -shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr0)"
   2.523 -apply(subst id_comp[symmetric, of id]) unfolding id_comp
   2.524 -using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
   2.525 -unfolding hsubst_def hsubst_c_def using assms by simp
   2.526 -
   2.527 -lemma hsubst_eq:
   2.528 -assumes "root tr = root tr0"
   2.529 -shows "hsubst tr = hsubst tr0"
   2.530 -apply(rule dtree_cong) using assms cont_hsubst_eq by auto
   2.531 -
   2.532 -lemma cont_hsubst_neq[simp]:
   2.533 -assumes "root tr \<noteq> root tr0"
   2.534 -shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr)"
   2.535 -apply(subst id_comp[symmetric, of id]) unfolding id_comp
   2.536 -using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
   2.537 -unfolding hsubst_def hsubst_c_def using assms by simp
   2.538 -
   2.539 -lemma Inl_cont_hsubst_eq[simp]:
   2.540 -assumes "root tr = root tr0"
   2.541 -shows "Inl -` cont (hsubst tr) = Inl -` (cont tr0)"
   2.542 -unfolding cont_hsubst_eq[OF assms] by simp
   2.543 -
   2.544 -lemma Inr_cont_hsubst_eq[simp]:
   2.545 -assumes "root tr = root tr0"
   2.546 -shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr0"
   2.547 -unfolding cont_hsubst_eq[OF assms] by simp
   2.548 -
   2.549 -lemma Inl_cont_hsubst_neq[simp]:
   2.550 -assumes "root tr \<noteq> root tr0"
   2.551 -shows "Inl -` cont (hsubst tr) = Inl -` (cont tr)"
   2.552 -unfolding cont_hsubst_neq[OF assms] by simp
   2.553 -
   2.554 -lemma Inr_cont_hsubst_neq[simp]:
   2.555 -assumes "root tr \<noteq> root tr0"
   2.556 -shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr"
   2.557 -unfolding cont_hsubst_neq[OF assms] by simp
   2.558 -
   2.559 -lemma wf_hsubst:
   2.560 -assumes tr0: "wf tr0" and tr: "wf tr"
   2.561 -shows "wf (hsubst tr)"
   2.562 -proof-
   2.563 -  {fix tr1 have "(\<exists> tr. wf tr \<and> tr1 = hsubst tr) \<Longrightarrow> wf tr1"
   2.564 -   proof (induct rule: wf_raw_coind)
   2.565 -     case (Hyp tr1) then obtain tr
   2.566 -     where dtr: "wf tr" and tr1: "tr1 = hsubst tr" by auto
   2.567 -     show ?case unfolding tr1 proof safe
   2.568 -       show "(root (hsubst tr), prodOf (hsubst tr)) \<in> P"
   2.569 -       unfolding tr1 apply(cases "root tr = root tr0")
   2.570 -       using  wf_P[OF dtr] wf_P[OF tr0]
   2.571 -       by (auto simp add: image_compose[symmetric] sum_map.comp)
   2.572 -       show "inj_on root (Inr -` cont (hsubst tr))"
   2.573 -       apply(cases "root tr = root tr0") using wf_inj_on[OF dtr] wf_inj_on[OF tr0]
   2.574 -       unfolding inj_on_def by (auto, blast)
   2.575 -       fix tr' assume "Inr tr' \<in> cont (hsubst tr)"
   2.576 -       thus "\<exists>tra. wf tra \<and> tr' = hsubst tra"
   2.577 -       apply(cases "root tr = root tr0", simp_all)
   2.578 -         apply (metis wf_cont tr0)
   2.579 -         by (metis dtr wf_cont)
   2.580 -     qed
   2.581 -   qed
   2.582 -  }
   2.583 -  thus ?thesis using assms by blast
   2.584 -qed
   2.585 -
   2.586 -lemma Frr: "Frr ns tr = {t. inFrr ns tr t}"
   2.587 -unfolding inFrr_def Frr_def Fr_def by auto
   2.588 -
   2.589 -lemma inFr_hsubst_imp:
   2.590 -assumes "inFr ns (hsubst tr) t"
   2.591 -shows "t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
   2.592 -       inFr (ns - {root tr0}) tr t"
   2.593 -proof-
   2.594 -  {fix tr1
   2.595 -   have "inFr ns tr1 t \<Longrightarrow>
   2.596 -   (\<And> tr. tr1 = hsubst tr \<Longrightarrow> (t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
   2.597 -                              inFr (ns - {root tr0}) tr t))"
   2.598 -   proof(induct rule: inFr.induct)
   2.599 -     case (Base tr1 ns t tr)
   2.600 -     hence rtr: "root tr1 \<in> ns" and t_tr1: "Inl t \<in> cont tr1" and tr1: "tr1 = hsubst tr"
   2.601 -     by auto
   2.602 -     show ?case
   2.603 -     proof(cases "root tr1 = root tr0")
   2.604 -       case True
   2.605 -       hence "t \<in> Inl -` (cont tr0)" using t_tr1 unfolding tr1 by auto
   2.606 -       thus ?thesis by simp
   2.607 -     next
   2.608 -       case False
   2.609 -       hence "inFr (ns - {root tr0}) tr t" using t_tr1 unfolding tr1 apply simp
   2.610 -       by (metis Base.prems Diff_iff root_hsubst inFr.Base rtr singletonE)
   2.611 -       thus ?thesis by simp
   2.612 -     qed
   2.613 -   next
   2.614 -     case (Ind tr1 ns tr1' t) note IH = Ind(4)
   2.615 -     have rtr1: "root tr1 \<in> ns" and tr1'_tr1: "Inr tr1' \<in> cont tr1"
   2.616 -     and t_tr1': "inFr ns tr1' t" and tr1: "tr1 = hsubst tr" using Ind by auto
   2.617 -     have rtr1: "root tr1 = root tr" unfolding tr1 by simp
   2.618 -     show ?case
   2.619 -     proof(cases "root tr1 = root tr0")
   2.620 -       case True
   2.621 -       then obtain tr' where tr'_tr0: "Inr tr' \<in> cont tr0" and tr1': "tr1' = hsubst tr'"
   2.622 -       using tr1'_tr1 unfolding tr1 by auto
   2.623 -       show ?thesis using IH[OF tr1'] proof (elim disjE)
   2.624 -         assume "inFr (ns - {root tr0}) tr' t"
   2.625 -         thus ?thesis using tr'_tr0 unfolding inFrr_def by auto
   2.626 -       qed auto
   2.627 -     next
   2.628 -       case False
   2.629 -       then obtain tr' where tr'_tr: "Inr tr' \<in> cont tr" and tr1': "tr1' = hsubst tr'"
   2.630 -       using tr1'_tr1 unfolding tr1 by auto
   2.631 -       show ?thesis using IH[OF tr1'] proof (elim disjE)
   2.632 -         assume "inFr (ns - {root tr0}) tr' t"
   2.633 -         thus ?thesis using tr'_tr unfolding inFrr_def
   2.634 -         by (metis Diff_iff False Ind(1) empty_iff inFr2_Ind inFr_inFr2 insert_iff rtr1)
   2.635 -       qed auto
   2.636 -     qed
   2.637 -   qed
   2.638 -  }
   2.639 -  thus ?thesis using assms by auto
   2.640 -qed
   2.641 -
   2.642 -lemma inFr_hsubst_notin:
   2.643 -assumes "inFr ns tr t" and "root tr0 \<notin> ns"
   2.644 -shows "inFr ns (hsubst tr) t"
   2.645 -using assms apply(induct rule: inFr.induct)
   2.646 -apply (metis Inl_cont_hsubst_neq inFr2.Base inFr_inFr2 root_hsubst vimageD vimageI2)
   2.647 -by (metis (lifting) Inr_cont_hsubst_neq inFr.Ind rev_image_eqI root_hsubst vimageD vimageI2)
   2.648 -
   2.649 -lemma inFr_hsubst_minus:
   2.650 -assumes "inFr (ns - {root tr0}) tr t"
   2.651 -shows "inFr ns (hsubst tr) t"
   2.652 -proof-
   2.653 -  have 1: "inFr (ns - {root tr0}) (hsubst tr) t"
   2.654 -  using inFr_hsubst_notin[OF assms] by simp
   2.655 -  show ?thesis using inFr_mono[OF 1] by auto
   2.656 -qed
   2.657 -
   2.658 -lemma inFr_self_hsubst:
   2.659 -assumes "root tr0 \<in> ns"
   2.660 -shows
   2.661 -"inFr ns (hsubst tr0) t \<longleftrightarrow>
   2.662 - t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t"
   2.663 -(is "?A \<longleftrightarrow> ?B \<or> ?C")
   2.664 -apply(intro iffI)
   2.665 -apply (metis inFr_hsubst_imp Diff_iff inFr_root_in insertI1) proof(elim disjE)
   2.666 -  assume ?B thus ?A apply(intro inFr.Base) using assms by auto
   2.667 -next
   2.668 -  assume ?C then obtain tr where
   2.669 -  tr_tr0: "Inr tr \<in> cont tr0" and t_tr: "inFr (ns - {root tr0}) tr t"
   2.670 -  unfolding inFrr_def by auto
   2.671 -  def tr1 \<equiv> "hsubst tr"
   2.672 -  have 1: "inFr ns tr1 t" using t_tr unfolding tr1_def using inFr_hsubst_minus by auto
   2.673 -  have "Inr tr1 \<in> cont (hsubst tr0)" unfolding tr1_def using tr_tr0 by auto
   2.674 -  thus ?A using 1 inFr.Ind assms by (metis root_hsubst)
   2.675 -qed
   2.676 -
   2.677 -lemma Fr_self_hsubst:
   2.678 -assumes "root tr0 \<in> ns"
   2.679 -shows "Fr ns (hsubst tr0) = Inl -` (cont tr0) \<union> Frr (ns - {root tr0}) tr0"
   2.680 -using inFr_self_hsubst[OF assms] unfolding Frr Fr_def by auto
   2.681 -
   2.682 -end (* context *)
   2.683 -
   2.684 -
   2.685 -subsection{* Regular Trees *}
   2.686 -
   2.687 -hide_const regular
   2.688 -
   2.689 -definition "reg f tr \<equiv> \<forall> tr'. subtr UNIV tr' tr \<longrightarrow> tr' = f (root tr')"
   2.690 -definition "regular tr \<equiv> \<exists> f. reg f tr"
   2.691 -
   2.692 -lemma reg_def2: "reg f tr \<longleftrightarrow> (\<forall> ns tr'. subtr ns tr' tr \<longrightarrow> tr' = f (root tr'))"
   2.693 -unfolding reg_def using subtr_mono by (metis subset_UNIV)
   2.694 -
   2.695 -lemma regular_def2: "regular tr \<longleftrightarrow> (\<exists> f. reg f tr \<and> (\<forall> n. root (f n) = n))"
   2.696 -unfolding regular_def proof safe
   2.697 -  fix f assume f: "reg f tr"
   2.698 -  def g \<equiv> "\<lambda> n. if inItr UNIV tr n then f n else deftr n"
   2.699 -  show "\<exists>g. reg g tr \<and> (\<forall>n. root (g n) = n)"
   2.700 -  apply(rule exI[of _ g])
   2.701 -  using f deftr_simps(1) unfolding g_def reg_def apply safe
   2.702 -    apply (metis (lifting) inItr.Base subtr_inItr subtr_rootL_in)
   2.703 -    by (metis (full_types) inItr_subtr)
   2.704 -qed auto
   2.705 -
   2.706 -lemma reg_root:
   2.707 -assumes "reg f tr"
   2.708 -shows "f (root tr) = tr"
   2.709 -using assms unfolding reg_def
   2.710 -by (metis (lifting) iso_tuple_UNIV_I subtr.Refl)
   2.711 -
   2.712 -
   2.713 -lemma reg_Inr_cont:
   2.714 -assumes "reg f tr" and "Inr tr' \<in> cont tr"
   2.715 -shows "reg f tr'"
   2.716 -by (metis (lifting) assms iso_tuple_UNIV_I reg_def subtr.Step)
   2.717 -
   2.718 -lemma reg_subtr:
   2.719 -assumes "reg f tr" and "subtr ns tr' tr"
   2.720 -shows "reg f tr'"
   2.721 -using assms unfolding reg_def using subtr_trans[of UNIV tr] UNIV_I
   2.722 -by (metis UNIV_eq_I UnCI Un_upper1 iso_tuple_UNIV_I subtr_mono subtr_trans)
   2.723 -
   2.724 -lemma regular_subtr:
   2.725 -assumes r: "regular tr" and s: "subtr ns tr' tr"
   2.726 -shows "regular tr'"
   2.727 -using r reg_subtr[OF _ s] unfolding regular_def by auto
   2.728 -
   2.729 -lemma subtr_deftr:
   2.730 -assumes "subtr ns tr' (deftr n)"
   2.731 -shows "tr' = deftr (root tr')"
   2.732 -proof-
   2.733 -  {fix tr have "subtr ns tr' tr \<Longrightarrow> (\<forall> n. tr = deftr n \<longrightarrow> tr' = deftr (root tr'))"
   2.734 -   apply (induct rule: subtr.induct)
   2.735 -   proof(metis (lifting) deftr_simps(1), safe)
   2.736 -     fix tr3 ns tr1 tr2 n
   2.737 -     assume 1: "root (deftr n) \<in> ns" and 2: "subtr ns tr1 tr2"
   2.738 -     and IH: "\<forall>n. tr2 = deftr n \<longrightarrow> tr1 = deftr (root tr1)"
   2.739 -     and 3: "Inr tr2 \<in> cont (deftr n)"
   2.740 -     have "tr2 \<in> deftr ` UNIV"
   2.741 -     using 3 unfolding deftr_simps image_def
   2.742 -     by (metis (lifting, full_types) 3 CollectI Inr_oplus_iff cont_deftr
   2.743 -         iso_tuple_UNIV_I)
   2.744 -     then obtain n where "tr2 = deftr n" by auto
   2.745 -     thus "tr1 = deftr (root tr1)" using IH by auto
   2.746 -   qed
   2.747 -  }
   2.748 -  thus ?thesis using assms by auto
   2.749 -qed
   2.750 -
   2.751 -lemma reg_deftr: "reg deftr (deftr n)"
   2.752 -unfolding reg_def using subtr_deftr by auto
   2.753 -
   2.754 -lemma wf_subtrOf_Union:
   2.755 -assumes "wf tr"
   2.756 -shows "\<Union>{K tr' |tr'. Inr tr' \<in> cont tr} =
   2.757 -       \<Union>{K (subtrOf tr n) |n. Inr n \<in> prodOf tr}"
   2.758 -unfolding Union_eq Bex_def mem_Collect_eq proof safe
   2.759 -  fix x xa tr'
   2.760 -  assume x: "x \<in> K tr'" and tr'_tr: "Inr tr' \<in> cont tr"
   2.761 -  show "\<exists>X. (\<exists>n. X = K (subtrOf tr n) \<and> Inr n \<in> prodOf tr) \<and> x \<in> X"
   2.762 -  apply(rule exI[of _ "K (subtrOf tr (root tr'))"]) apply(intro conjI)
   2.763 -    apply(rule exI[of _ "root tr'"]) apply (metis (lifting) root_prodOf tr'_tr)
   2.764 -    by (metis (lifting) assms subtrOf_root tr'_tr x)
   2.765 -next
   2.766 -  fix x X n ttr
   2.767 -  assume x: "x \<in> K (subtrOf tr n)" and n: "Inr n = (id \<oplus> root) ttr" and ttr: "ttr \<in> cont tr"
   2.768 -  show "\<exists>X. (\<exists>tr'. X = K tr' \<and> Inr tr' \<in> cont tr) \<and> x \<in> X"
   2.769 -  apply(rule exI[of _ "K (subtrOf tr n)"]) apply(intro conjI)
   2.770 -    apply(rule exI[of _ "subtrOf tr n"]) apply (metis imageI n subtrOf ttr)
   2.771 -    using x .
   2.772 -qed
   2.773 -
   2.774 -
   2.775 -
   2.776 -
   2.777 -subsection {* Paths in a Regular Tree *}
   2.778 -
   2.779 -inductive path :: "(N \<Rightarrow> dtree) \<Rightarrow> N list \<Rightarrow> bool" for f where
   2.780 -Base: "path f [n]"
   2.781 -|
   2.782 -Ind: "\<lbrakk>path f (n1 # nl); Inr (f n1) \<in> cont (f n)\<rbrakk>
   2.783 -      \<Longrightarrow> path f (n # n1 # nl)"
   2.784 -
   2.785 -lemma path_NE:
   2.786 -assumes "path f nl"
   2.787 -shows "nl \<noteq> Nil"
   2.788 -using assms apply(induct rule: path.induct) by auto
   2.789 -
   2.790 -lemma path_post:
   2.791 -assumes f: "path f (n # nl)" and nl: "nl \<noteq> []"
   2.792 -shows "path f nl"
   2.793 -proof-
   2.794 -  obtain n1 nl1 where nl: "nl = n1 # nl1" using nl by (cases nl, auto)
   2.795 -  show ?thesis using assms unfolding nl using path.simps by (metis (lifting) list.inject)
   2.796 -qed
   2.797 -
   2.798 -lemma path_post_concat:
   2.799 -assumes "path f (nl1 @ nl2)" and "nl2 \<noteq> Nil"
   2.800 -shows "path f nl2"
   2.801 -using assms apply (induct nl1)
   2.802 -apply (metis append_Nil) by (metis Nil_is_append_conv append_Cons path_post)
   2.803 -
   2.804 -lemma path_concat:
   2.805 -assumes "path f nl1" and "path f ((last nl1) # nl2)"
   2.806 -shows "path f (nl1 @ nl2)"
   2.807 -using assms apply(induct rule: path.induct) apply simp
   2.808 -by (metis append_Cons last.simps list.simps(3) path.Ind)
   2.809 -
   2.810 -lemma path_distinct:
   2.811 -assumes "path f nl"
   2.812 -shows "\<exists> nl'. path f nl' \<and> hd nl' = hd nl \<and> last nl' = last nl \<and>
   2.813 -              set nl' \<subseteq> set nl \<and> distinct nl'"
   2.814 -using assms proof(induct rule: length_induct)
   2.815 -  case (1 nl)  hence p_nl: "path f nl" by simp
   2.816 -  then obtain n nl1 where nl: "nl = n # nl1" by (metis list.exhaust path_NE)
   2.817 -  show ?case
   2.818 -  proof(cases nl1)
   2.819 -    case Nil
   2.820 -    show ?thesis apply(rule exI[of _ nl]) using path.Base unfolding nl Nil by simp
   2.821 -  next
   2.822 -    case (Cons n1 nl2)
   2.823 -    hence p1: "path f nl1" by (metis list.simps(3) nl p_nl path_post)
   2.824 -    show ?thesis
   2.825 -    proof(cases "n \<in> set nl1")
   2.826 -      case False
   2.827 -      obtain nl1' where p1': "path f nl1'" and hd_nl1': "hd nl1' = hd nl1" and
   2.828 -      l_nl1': "last nl1' = last nl1" and d_nl1': "distinct nl1'"
   2.829 -      and s_nl1': "set nl1' \<subseteq> set nl1"
   2.830 -      using 1(1)[THEN allE[of _ nl1]] p1 unfolding nl by auto
   2.831 -      obtain nl2' where nl1': "nl1' = n1 # nl2'" using path_NE[OF p1'] hd_nl1'
   2.832 -      unfolding Cons by(cases nl1', auto)
   2.833 -      show ?thesis apply(intro exI[of _ "n # nl1'"]) unfolding nl proof safe
   2.834 -        show "path f (n # nl1')" unfolding nl1'
   2.835 -        apply(rule path.Ind, metis nl1' p1')
   2.836 -        by (metis (lifting) Cons list.inject nl p1 p_nl path.simps path_NE)
   2.837 -      qed(insert l_nl1' Cons nl1' s_nl1' d_nl1' False, auto)
   2.838 -    next
   2.839 -      case True
   2.840 -      then obtain nl11 nl12 where nl1: "nl1 = nl11 @ n # nl12"
   2.841 -      by (metis split_list)
   2.842 -      have p12: "path f (n # nl12)"
   2.843 -      apply(rule path_post_concat[of _ "n # nl11"]) using p_nl[unfolded nl nl1] by auto
   2.844 -      obtain nl12' where p1': "path f nl12'" and hd_nl12': "hd nl12' = n" and
   2.845 -      l_nl12': "last nl12' = last (n # nl12)" and d_nl12': "distinct nl12'"
   2.846 -      and s_nl12': "set nl12' \<subseteq> {n} \<union> set nl12"
   2.847 -      using 1(1)[THEN allE[of _ "n # nl12"]] p12 unfolding nl nl1 by auto
   2.848 -      thus ?thesis apply(intro exI[of _ nl12']) unfolding nl nl1 by auto
   2.849 -    qed
   2.850 -  qed
   2.851 -qed
   2.852 -
   2.853 -lemma path_subtr:
   2.854 -assumes f: "\<And> n. root (f n) = n"
   2.855 -and p: "path f nl"
   2.856 -shows "subtr (set nl) (f (last nl)) (f (hd nl))"
   2.857 -using p proof (induct rule: path.induct)
   2.858 -  case (Ind n1 nl n)  let ?ns1 = "insert n1 (set nl)"
   2.859 -  have "path f (n1 # nl)"
   2.860 -  and "subtr ?ns1 (f (last (n1 # nl))) (f n1)"
   2.861 -  and fn1: "Inr (f n1) \<in> cont (f n)" using Ind by simp_all
   2.862 -  hence fn1_flast:  "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n1)"
   2.863 -  by (metis subset_insertI subtr_mono)
   2.864 -  have 1: "last (n # n1 # nl) = last (n1 # nl)" by auto
   2.865 -  have "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n)"
   2.866 -  using f subtr.Step[OF _ fn1_flast fn1] by auto
   2.867 -  thus ?case unfolding 1 by simp
   2.868 -qed (metis f hd.simps last_ConsL last_in_set not_Cons_self2 subtr.Refl)
   2.869 -
   2.870 -lemma reg_subtr_path_aux:
   2.871 -assumes f: "reg f tr" and n: "subtr ns tr1 tr"
   2.872 -shows "\<exists> nl. path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
   2.873 -using n f proof(induct rule: subtr.induct)
   2.874 -  case (Refl tr ns)
   2.875 -  thus ?case
   2.876 -  apply(intro exI[of _ "[root tr]"]) apply simp by (metis (lifting) path.Base reg_root)
   2.877 -next
   2.878 -  case (Step tr ns tr2 tr1)
   2.879 -  hence rtr: "root tr \<in> ns" and tr1_tr: "Inr tr1 \<in> cont tr"
   2.880 -  and tr2_tr1: "subtr ns tr2 tr1" and tr: "reg f tr" by auto
   2.881 -  have tr1: "reg f tr1" using reg_subtr[OF tr] rtr tr1_tr
   2.882 -  by (metis (lifting) Step.prems iso_tuple_UNIV_I reg_def subtr.Step)
   2.883 -  obtain nl where nl: "path f nl" and f_nl: "f (hd nl) = tr1"
   2.884 -  and last_nl: "f (last nl) = tr2" and set: "set nl \<subseteq> ns" using Step(3)[OF tr1] by auto
   2.885 -  have 0: "path f (root tr # nl)" apply (subst path.simps)
   2.886 -  using f_nl nl reg_root tr tr1_tr by (metis hd.simps neq_Nil_conv)
   2.887 -  show ?case apply(rule exI[of _ "(root tr) # nl"])
   2.888 -  using 0 reg_root tr last_nl nl path_NE rtr set by auto
   2.889 -qed
   2.890 -
   2.891 -lemma reg_subtr_path:
   2.892 -assumes f: "reg f tr" and n: "subtr ns tr1 tr"
   2.893 -shows "\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
   2.894 -using reg_subtr_path_aux[OF assms] path_distinct[of f]
   2.895 -by (metis (lifting) order_trans)
   2.896 -
   2.897 -lemma subtr_iff_path:
   2.898 -assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
   2.899 -shows "subtr ns tr1 tr \<longleftrightarrow>
   2.900 -       (\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns)"
   2.901 -proof safe
   2.902 -  fix nl assume p: "path f nl" and nl: "set nl \<subseteq> ns"
   2.903 -  have "subtr (set nl) (f (last nl)) (f (hd nl))"
   2.904 -  apply(rule path_subtr) using p f by simp_all
   2.905 -  thus "subtr ns (f (last nl)) (f (hd nl))"
   2.906 -  using subtr_mono nl by auto
   2.907 -qed(insert reg_subtr_path[OF r], auto)
   2.908 -
   2.909 -lemma inFr_iff_path:
   2.910 -assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
   2.911 -shows
   2.912 -"inFr ns tr t \<longleftrightarrow>
   2.913 - (\<exists> nl tr1. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and>
   2.914 -            set nl \<subseteq> ns \<and> Inl t \<in> cont tr1)"
   2.915 -apply safe
   2.916 -apply (metis (no_types) inFr_subtr r reg_subtr_path)
   2.917 -by (metis f inFr.Base path_subtr subtr_inFr subtr_mono subtr_rootL_in)
   2.918 -
   2.919 -
   2.920 -
   2.921 -subsection{* The Regular Cut of a Tree *}
   2.922 -
   2.923 -context fixes tr0 :: dtree
   2.924 -begin
   2.925 -
   2.926 -(* Picking a subtree of a certain root: *)
   2.927 -definition "pick n \<equiv> SOME tr. subtr UNIV tr tr0 \<and> root tr = n"
   2.928 -
   2.929 -lemma pick:
   2.930 -assumes "inItr UNIV tr0 n"
   2.931 -shows "subtr UNIV (pick n) tr0 \<and> root (pick n) = n"
   2.932 -proof-
   2.933 -  have "\<exists> tr. subtr UNIV tr tr0 \<and> root tr = n"
   2.934 -  using assms by (metis (lifting) inItr_subtr)
   2.935 -  thus ?thesis unfolding pick_def by(rule someI_ex)
   2.936 -qed
   2.937 -
   2.938 -lemmas subtr_pick = pick[THEN conjunct1]
   2.939 -lemmas root_pick = pick[THEN conjunct2]
   2.940 -
   2.941 -lemma wf_pick:
   2.942 -assumes tr0: "wf tr0" and n: "inItr UNIV tr0 n"
   2.943 -shows "wf (pick n)"
   2.944 -using wf_subtr[OF tr0 subtr_pick[OF n]] .
   2.945 -
   2.946 -definition "H_r n \<equiv> root (pick n)"
   2.947 -definition "H_c n \<equiv> (id \<oplus> root) ` cont (pick n)"
   2.948 -
   2.949 -(* The regular tree of a function: *)
   2.950 -definition H :: "N \<Rightarrow> dtree" where
   2.951 -"H \<equiv> unfold H_r H_c"
   2.952 -
   2.953 -lemma finite_H_c: "finite (H_c n)"
   2.954 -unfolding H_c_def by (metis finite_cont finite_imageI)
   2.955 -
   2.956 -lemma root_H_pick: "root (H n) = root (pick n)"
   2.957 -using unfold(1)[of H_r H_c n] unfolding H_def H_r_def by simp
   2.958 -
   2.959 -lemma root_H[simp]:
   2.960 -assumes "inItr UNIV tr0 n"
   2.961 -shows "root (H n) = n"
   2.962 -unfolding root_H_pick root_pick[OF assms] ..
   2.963 -
   2.964 -lemma cont_H[simp]:
   2.965 -"cont (H n) = (id \<oplus> (H o root)) ` cont (pick n)"
   2.966 -apply(subst id_comp[symmetric, of id]) unfolding sum_map.comp[symmetric]
   2.967 -unfolding image_compose unfolding H_c_def[symmetric]
   2.968 -using unfold(2)[of H_c n H_r, OF finite_H_c]
   2.969 -unfolding H_def ..
   2.970 -
   2.971 -lemma Inl_cont_H[simp]:
   2.972 -"Inl -` (cont (H n)) = Inl -` (cont (pick n))"
   2.973 -unfolding cont_H by simp
   2.974 -
   2.975 -lemma Inr_cont_H:
   2.976 -"Inr -` (cont (H n)) = (H \<circ> root) ` (Inr -` cont (pick n))"
   2.977 -unfolding cont_H by simp
   2.978 -
   2.979 -lemma subtr_H:
   2.980 -assumes n: "inItr UNIV tr0 n" and "subtr UNIV tr1 (H n)"
   2.981 -shows "\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = H n1"
   2.982 -proof-
   2.983 -  {fix tr ns assume "subtr UNIV tr1 tr"
   2.984 -   hence "tr = H n \<longrightarrow> (\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = H n1)"
   2.985 -   proof (induct rule: subtr_UNIV_inductL)
   2.986 -     case (Step tr2 tr1 tr)
   2.987 -     show ?case proof
   2.988 -       assume "tr = H n"
   2.989 -       then obtain n1 where tr2: "Inr tr2 \<in> cont tr1"
   2.990 -       and tr1_tr: "subtr UNIV tr1 tr" and n1: "inItr UNIV tr0 n1" and tr1: "tr1 = H n1"
   2.991 -       using Step by auto
   2.992 -       obtain tr2' where tr2: "tr2 = H (root tr2')"
   2.993 -       and tr2': "Inr tr2' \<in> cont (pick n1)"
   2.994 -       using tr2 Inr_cont_H[of n1]
   2.995 -       unfolding tr1 image_def comp_def using vimage_eq by auto
   2.996 -       have "inItr UNIV tr0 (root tr2')"
   2.997 -       using inItr.Base inItr.Ind n1 pick subtr_inItr tr2' by (metis iso_tuple_UNIV_I)
   2.998 -       thus "\<exists>n2. inItr UNIV tr0 n2 \<and> tr2 = H n2" using tr2 by blast
   2.999 -     qed
  2.1000 -   qed(insert n, auto)
  2.1001 -  }
  2.1002 -  thus ?thesis using assms by auto
  2.1003 -qed
  2.1004 -
  2.1005 -lemma root_H_root:
  2.1006 -assumes n: "inItr UNIV tr0 n" and t_tr: "t_tr \<in> cont (pick n)"
  2.1007 -shows "(id \<oplus> (root \<circ> H \<circ> root)) t_tr = (id \<oplus> root) t_tr"
  2.1008 -using assms apply(cases t_tr)
  2.1009 -  apply (metis (lifting) sum_map.simps(1))
  2.1010 -  using pick H_def H_r_def unfold(1)
  2.1011 -      inItr.Base comp_apply subtr_StepL subtr_inItr sum_map.simps(2)
  2.1012 -  by (metis UNIV_I)
  2.1013 -
  2.1014 -lemma H_P:
  2.1015 -assumes tr0: "wf tr0" and n: "inItr UNIV tr0 n"
  2.1016 -shows "(n, (id \<oplus> root) ` cont (H n)) \<in> P" (is "?L \<in> P")
  2.1017 -proof-
  2.1018 -  have "?L = (n, (id \<oplus> root) ` cont (pick n))"
  2.1019 -  unfolding cont_H image_compose[symmetric] sum_map.comp id_comp comp_assoc[symmetric]
  2.1020 -  unfolding Pair_eq apply(rule conjI[OF refl]) apply(rule image_cong[OF refl])
  2.1021 -  by (rule root_H_root[OF n])
  2.1022 -  moreover have "... \<in> P" by (metis (lifting) wf_pick root_pick wf_P n tr0)
  2.1023 -  ultimately show ?thesis by simp
  2.1024 -qed
  2.1025 -
  2.1026 -lemma wf_H:
  2.1027 -assumes tr0: "wf tr0" and "inItr UNIV tr0 n"
  2.1028 -shows "wf (H n)"
  2.1029 -proof-
  2.1030 -  {fix tr have "\<exists> n. inItr UNIV tr0 n \<and> tr = H n \<Longrightarrow> wf tr"
  2.1031 -   proof (induct rule: wf_raw_coind)
  2.1032 -     case (Hyp tr)
  2.1033 -     then obtain n where n: "inItr UNIV tr0 n" and tr: "tr = H n" by auto
  2.1034 -     show ?case apply safe
  2.1035 -     apply (metis (lifting) H_P root_H n tr tr0)
  2.1036 -     unfolding tr Inr_cont_H unfolding inj_on_def apply clarsimp using root_H
  2.1037 -     apply (metis UNIV_I inItr.Base n pick subtr2.simps subtr_inItr subtr_subtr2)
  2.1038 -     by (metis n subtr.Refl subtr_StepL subtr_H tr UNIV_I)
  2.1039 -   qed
  2.1040 -  }
  2.1041 -  thus ?thesis using assms by blast
  2.1042 -qed
  2.1043 -
  2.1044 -(* The regular cut of a tree: *)
  2.1045 -definition "rcut \<equiv> H (root tr0)"
  2.1046 -
  2.1047 -lemma reg_rcut: "reg H rcut"
  2.1048 -unfolding reg_def rcut_def
  2.1049 -by (metis inItr.Base root_H subtr_H UNIV_I)
  2.1050 -
  2.1051 -lemma rcut_reg:
  2.1052 -assumes "reg H tr0"
  2.1053 -shows "rcut = tr0"
  2.1054 -using assms unfolding rcut_def reg_def by (metis subtr.Refl UNIV_I)
  2.1055 -
  2.1056 -lemma rcut_eq: "rcut = tr0 \<longleftrightarrow> reg H tr0"
  2.1057 -using reg_rcut rcut_reg by metis
  2.1058 -
  2.1059 -lemma regular_rcut: "regular rcut"
  2.1060 -using reg_rcut unfolding regular_def by blast
  2.1061 -
  2.1062 -lemma Fr_rcut: "Fr UNIV rcut \<subseteq> Fr UNIV tr0"
  2.1063 -proof safe
  2.1064 -  fix t assume "t \<in> Fr UNIV rcut"
  2.1065 -  then obtain tr where t: "Inl t \<in> cont tr" and tr: "subtr UNIV tr (H (root tr0))"
  2.1066 -  using Fr_subtr[of UNIV "H (root tr0)"] unfolding rcut_def
  2.1067 -  by (metis (full_types) Fr_def inFr_subtr mem_Collect_eq)
  2.1068 -  obtain n where n: "inItr UNIV tr0 n" and tr: "tr = H n" using tr
  2.1069 -  by (metis (lifting) inItr.Base subtr_H UNIV_I)
  2.1070 -  have "Inl t \<in> cont (pick n)" using t using Inl_cont_H[of n] unfolding tr
  2.1071 -  by (metis (lifting) vimageD vimageI2)
  2.1072 -  moreover have "subtr UNIV (pick n) tr0" using subtr_pick[OF n] ..
  2.1073 -  ultimately show "t \<in> Fr UNIV tr0" unfolding Fr_subtr_cont by auto
  2.1074 -qed
  2.1075 -
  2.1076 -lemma wf_rcut:
  2.1077 -assumes "wf tr0"
  2.1078 -shows "wf rcut"
  2.1079 -unfolding rcut_def using wf_H[OF assms inItr.Base] by simp
  2.1080 -
  2.1081 -lemma root_rcut[simp]: "root rcut = root tr0"
  2.1082 -unfolding rcut_def
  2.1083 -by (metis (lifting) root_H inItr.Base reg_def reg_root subtr_rootR_in)
  2.1084 -
  2.1085 -end (* context *)
  2.1086 -
  2.1087 -
  2.1088 -subsection{* Recursive Description of the Regular Tree Frontiers *}
  2.1089 -
  2.1090 -lemma regular_inFr:
  2.1091 -assumes r: "regular tr" and In: "root tr \<in> ns"
  2.1092 -and t: "inFr ns tr t"
  2.1093 -shows "t \<in> Inl -` (cont tr) \<or>
  2.1094 -       (\<exists> tr'. Inr tr' \<in> cont tr \<and> inFr (ns - {root tr}) tr' t)"
  2.1095 -(is "?L \<or> ?R")
  2.1096 -proof-
  2.1097 -  obtain f where r: "reg f tr" and f: "\<And>n. root (f n) = n"
  2.1098 -  using r unfolding regular_def2 by auto
  2.1099 -  obtain nl tr1 where d_nl: "distinct nl" and p: "path f nl" and hd_nl: "f (hd nl) = tr"
  2.1100 -  and l_nl: "f (last nl) = tr1" and s_nl: "set nl \<subseteq> ns" and t_tr1: "Inl t \<in> cont tr1"
  2.1101 -  using t unfolding inFr_iff_path[OF r f] by auto
  2.1102 -  obtain n nl1 where nl: "nl = n # nl1" by (metis (lifting) p path.simps)
  2.1103 -  hence f_n: "f n = tr" using hd_nl by simp
  2.1104 -  have n_nl1: "n \<notin> set nl1" using d_nl unfolding nl by auto
  2.1105 -  show ?thesis
  2.1106 -  proof(cases nl1)
  2.1107 -    case Nil hence "tr = tr1" using f_n l_nl unfolding nl by simp
  2.1108 -    hence ?L using t_tr1 by simp thus ?thesis by simp
  2.1109 -  next
  2.1110 -    case (Cons n1 nl2) note nl1 = Cons
  2.1111 -    have 1: "last nl1 = last nl" "hd nl1 = n1" unfolding nl nl1 by simp_all
  2.1112 -    have p1: "path f nl1" and n1_tr: "Inr (f n1) \<in> cont tr"
  2.1113 -    using path.simps[of f nl] p f_n unfolding nl nl1 by auto
  2.1114 -    have r1: "reg f (f n1)" using reg_Inr_cont[OF r n1_tr] .
  2.1115 -    have 0: "inFr (set nl1) (f n1) t" unfolding inFr_iff_path[OF r1 f]
  2.1116 -    apply(intro exI[of _ nl1], intro exI[of _ tr1])
  2.1117 -    using d_nl unfolding 1 l_nl unfolding nl using p1 t_tr1 by auto
  2.1118 -    have root_tr: "root tr = n" by (metis f f_n)
  2.1119 -    have "inFr (ns - {root tr}) (f n1) t" apply(rule inFr_mono[OF 0])
  2.1120 -    using s_nl unfolding root_tr unfolding nl using n_nl1 by auto
  2.1121 -    thus ?thesis using n1_tr by auto
  2.1122 -  qed
  2.1123 -qed
  2.1124 -
  2.1125 -lemma regular_Fr:
  2.1126 -assumes r: "regular tr" and In: "root tr \<in> ns"
  2.1127 -shows "Fr ns tr =
  2.1128 -       Inl -` (cont tr) \<union>
  2.1129 -       \<Union> {Fr (ns - {root tr}) tr' | tr'. Inr tr' \<in> cont tr}"
  2.1130 -unfolding Fr_def
  2.1131 -using In inFr.Base regular_inFr[OF assms] apply safe
  2.1132 -apply (simp, metis (full_types) mem_Collect_eq)
  2.1133 -apply simp
  2.1134 -by (simp, metis (lifting) inFr_Ind_minus insert_Diff)
  2.1135 -
  2.1136 -
  2.1137 -subsection{* The Generated Languages *}
  2.1138 -
  2.1139 -(* The (possibly inifinite tree) generated language *)
  2.1140 -definition "L ns n \<equiv> {Fr ns tr | tr. wf tr \<and> root tr = n}"
  2.1141 -
  2.1142 -(* The regular-tree generated language *)
  2.1143 -definition "Lr ns n \<equiv> {Fr ns tr | tr. wf tr \<and> root tr = n \<and> regular tr}"
  2.1144 -
  2.1145 -lemma L_rec_notin:
  2.1146 -assumes "n \<notin> ns"
  2.1147 -shows "L ns n = {{}}"
  2.1148 -using assms unfolding L_def apply safe
  2.1149 -  using not_root_Fr apply force
  2.1150 -  apply(rule exI[of _ "deftr n"])
  2.1151 -  by (metis (no_types) wf_deftr not_root_Fr root_deftr)
  2.1152 -
  2.1153 -lemma Lr_rec_notin:
  2.1154 -assumes "n \<notin> ns"
  2.1155 -shows "Lr ns n = {{}}"
  2.1156 -using assms unfolding Lr_def apply safe
  2.1157 -  using not_root_Fr apply force
  2.1158 -  apply(rule exI[of _ "deftr n"])
  2.1159 -  by (metis (no_types) regular_def wf_deftr not_root_Fr reg_deftr root_deftr)
  2.1160 -
  2.1161 -lemma wf_subtrOf:
  2.1162 -assumes "wf tr" and "Inr n \<in> prodOf tr"
  2.1163 -shows "wf (subtrOf tr n)"
  2.1164 -by (metis assms wf_cont subtrOf)
  2.1165 -
  2.1166 -lemma Lr_rec_in:
  2.1167 -assumes n: "n \<in> ns"
  2.1168 -shows "Lr ns n \<subseteq>
  2.1169 -{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
  2.1170 -    (n,tns) \<in> P \<and>
  2.1171 -    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n')}"
  2.1172 -(is "Lr ns n \<subseteq> {?F tns K | tns K. (n,tns) \<in> P \<and> ?\<phi> tns K}")
  2.1173 -proof safe
  2.1174 -  fix ts assume "ts \<in> Lr ns n"
  2.1175 -  then obtain tr where dtr: "wf tr" and r: "root tr = n" and tr: "regular tr"
  2.1176 -  and ts: "ts = Fr ns tr" unfolding Lr_def by auto
  2.1177 -  def tns \<equiv> "(id \<oplus> root) ` (cont tr)"
  2.1178 -  def K \<equiv> "\<lambda> n'. Fr (ns - {n}) (subtrOf tr n')"
  2.1179 -  show "\<exists>tns K. ts = ?F tns K \<and> (n, tns) \<in> P \<and> ?\<phi> tns K"
  2.1180 -  apply(rule exI[of _ tns], rule exI[of _ K]) proof(intro conjI allI impI)
  2.1181 -    show "ts = Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns}"
  2.1182 -    unfolding ts regular_Fr[OF tr n[unfolded r[symmetric]]]
  2.1183 -    unfolding tns_def K_def r[symmetric]
  2.1184 -    unfolding Inl_prodOf wf_subtrOf_Union[OF dtr] ..
  2.1185 -    show "(n, tns) \<in> P" unfolding tns_def r[symmetric] using wf_P[OF dtr] .
  2.1186 -    fix n' assume "Inr n' \<in> tns" thus "K n' \<in> Lr (ns - {n}) n'"
  2.1187 -    unfolding K_def Lr_def mem_Collect_eq apply(intro exI[of _ "subtrOf tr n'"])
  2.1188 -    using dtr tr apply(intro conjI refl)  unfolding tns_def
  2.1189 -      apply(erule wf_subtrOf[OF dtr])
  2.1190 -      apply (metis subtrOf)
  2.1191 -      by (metis Inr_subtrOf UNIV_I regular_subtr subtr.simps)
  2.1192 -  qed
  2.1193 -qed
  2.1194 -
  2.1195 -lemma hsubst_aux:
  2.1196 -fixes n ftr tns
  2.1197 -assumes n: "n \<in> ns" and tns: "finite tns" and
  2.1198 -1: "\<And> n'. Inr n' \<in> tns \<Longrightarrow> wf (ftr n')"
  2.1199 -defines "tr \<equiv> Node n ((id \<oplus> ftr) ` tns)"  defines "tr' \<equiv> hsubst tr tr"
  2.1200 -shows "Fr ns tr' = Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
  2.1201 -(is "_ = ?B") proof-
  2.1202 -  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
  2.1203 -  unfolding tr_def using tns by auto
  2.1204 -  have Frr: "Frr (ns - {n}) tr = \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
  2.1205 -  unfolding Frr_def ctr by auto
  2.1206 -  have "Fr ns tr' = Inl -` (cont tr) \<union> Frr (ns - {n}) tr"
  2.1207 -  using Fr_self_hsubst[OF n[unfolded rtr[symmetric]]] unfolding tr'_def rtr ..
  2.1208 -  also have "... = ?B" unfolding ctr Frr by simp
  2.1209 -  finally show ?thesis .
  2.1210 -qed
  2.1211 -
  2.1212 -lemma L_rec_in:
  2.1213 -assumes n: "n \<in> ns"
  2.1214 -shows "
  2.1215 -{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
  2.1216 -    (n,tns) \<in> P \<and>
  2.1217 -    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n')}
  2.1218 - \<subseteq> L ns n"
  2.1219 -proof safe
  2.1220 -  fix tns K
  2.1221 -  assume P: "(n, tns) \<in> P" and 0: "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n'"
  2.1222 -  {fix n' assume "Inr n' \<in> tns"
  2.1223 -   hence "K n' \<in> L (ns - {n}) n'" using 0 by auto
  2.1224 -   hence "\<exists> tr'. K n' = Fr (ns - {n}) tr' \<and> wf tr' \<and> root tr' = n'"
  2.1225 -   unfolding L_def mem_Collect_eq by auto
  2.1226 -  }
  2.1227 -  then obtain ftr where 0: "\<And> n'. Inr n' \<in> tns \<Longrightarrow>
  2.1228 -  K n' = Fr (ns - {n}) (ftr n') \<and> wf (ftr n') \<and> root (ftr n') = n'"
  2.1229 -  by metis
  2.1230 -  def tr \<equiv> "Node n ((id \<oplus> ftr) ` tns)"  def tr' \<equiv> "hsubst tr tr"
  2.1231 -  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
  2.1232 -  unfolding tr_def by (simp, metis P cont_Node finite_imageI finite_in_P)
  2.1233 -  have prtr: "prodOf tr = tns" apply(rule Inl_Inr_image_cong)
  2.1234 -  unfolding ctr apply simp apply simp apply safe
  2.1235 -  using 0 unfolding image_def apply force apply simp by (metis 0 vimageI2)
  2.1236 -  have 1: "{K n' |n'. Inr n' \<in> tns} = {Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
  2.1237 -  using 0 by auto
  2.1238 -  have dtr: "wf tr" apply(rule wf.dtree)
  2.1239 -    apply (metis (lifting) P prtr rtr)
  2.1240 -    unfolding inj_on_def ctr using 0 by auto
  2.1241 -  hence dtr': "wf tr'" unfolding tr'_def by (metis wf_hsubst)
  2.1242 -  have tns: "finite tns" using finite_in_P P by simp
  2.1243 -  have "Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns} \<in> L ns n"
  2.1244 -  unfolding L_def mem_Collect_eq apply(intro exI[of _ tr'] conjI)
  2.1245 -  using dtr' 0 hsubst_aux[OF assms tns, of ftr] unfolding tr_def tr'_def by auto
  2.1246 -  thus "Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} \<in> L ns n" unfolding 1 .
  2.1247 -qed
  2.1248 -
  2.1249 -lemma card_N: "(n::N) \<in> ns \<Longrightarrow> card (ns - {n}) < card ns"
  2.1250 -by (metis finite_N Diff_UNIV Diff_infinite_finite card_Diff1_less finite.emptyI)
  2.1251 -
  2.1252 -function LL where
  2.1253 -"LL ns n =
  2.1254 - (if n \<notin> ns then {{}} else
  2.1255 - {Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
  2.1256 -    (n,tns) \<in> P \<and>
  2.1257 -    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n')})"
  2.1258 -by(pat_completeness, auto)
  2.1259 -termination apply(relation "inv_image (measure card) fst")
  2.1260 -using card_N by auto
  2.1261 -
  2.1262 -declare LL.simps[code]
  2.1263 -declare LL.simps[simp del]
  2.1264 -
  2.1265 -lemma Lr_LL: "Lr ns n \<subseteq> LL ns n"
  2.1266 -proof (induct ns arbitrary: n rule: measure_induct[of card])
  2.1267 -  case (1 ns n) show ?case proof(cases "n \<in> ns")
  2.1268 -    case False thus ?thesis unfolding Lr_rec_notin[OF False] by (simp add: LL.simps)
  2.1269 -  next
  2.1270 -    case True show ?thesis apply(rule subset_trans)
  2.1271 -    using Lr_rec_in[OF True] apply assumption
  2.1272 -    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
  2.1273 -      fix tns K
  2.1274 -      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
  2.1275 -      assume "(n, tns) \<in> P"
  2.1276 -      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n'"
  2.1277 -      thus "\<exists>tnsa Ka.
  2.1278 -             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
  2.1279 -             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
  2.1280 -             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> LL (ns - {n}) n')"
  2.1281 -      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
  2.1282 -    qed
  2.1283 -  qed
  2.1284 -qed
  2.1285 -
  2.1286 -lemma LL_L: "LL ns n \<subseteq> L ns n"
  2.1287 -proof (induct ns arbitrary: n rule: measure_induct[of card])
  2.1288 -  case (1 ns n) show ?case proof(cases "n \<in> ns")
  2.1289 -    case False thus ?thesis unfolding L_rec_notin[OF False] by (simp add: LL.simps)
  2.1290 -  next
  2.1291 -    case True show ?thesis apply(rule subset_trans)
  2.1292 -    prefer 2 using L_rec_in[OF True] apply assumption
  2.1293 -    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
  2.1294 -      fix tns K
  2.1295 -      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
  2.1296 -      assume "(n, tns) \<in> P"
  2.1297 -      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n'"
  2.1298 -      thus "\<exists>tnsa Ka.
  2.1299 -             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
  2.1300 -             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
  2.1301 -             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> L (ns - {n}) n')"
  2.1302 -      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
  2.1303 -    qed
  2.1304 -  qed
  2.1305 -qed
  2.1306 -
  2.1307 -(* The subsumpsion relation between languages *)
  2.1308 -definition "subs L1 L2 \<equiv> \<forall> ts2 \<in> L2. \<exists> ts1 \<in> L1. ts1 \<subseteq> ts2"
  2.1309 -
  2.1310 -lemma incl_subs[simp]: "L2 \<subseteq> L1 \<Longrightarrow> subs L1 L2"
  2.1311 -unfolding subs_def by auto
  2.1312 -
  2.1313 -lemma subs_refl[simp]: "subs L1 L1" unfolding subs_def by auto
  2.1314 -
  2.1315 -lemma subs_trans: "\<lbrakk>subs L1 L2; subs L2 L3\<rbrakk> \<Longrightarrow> subs L1 L3"
  2.1316 -unfolding subs_def by (metis subset_trans)
  2.1317 -
  2.1318 -(* Language equivalence *)
  2.1319 -definition "leqv L1 L2 \<equiv> subs L1 L2 \<and> subs L2 L1"
  2.1320 -
  2.1321 -lemma subs_leqv[simp]: "leqv L1 L2 \<Longrightarrow> subs L1 L2"
  2.1322 -unfolding leqv_def by auto
  2.1323 -
  2.1324 -lemma subs_leqv_sym[simp]: "leqv L1 L2 \<Longrightarrow> subs L2 L1"
  2.1325 -unfolding leqv_def by auto
  2.1326 -
  2.1327 -lemma leqv_refl[simp]: "leqv L1 L1" unfolding leqv_def by auto
  2.1328 -
  2.1329 -lemma leqv_trans:
  2.1330 -assumes 12: "leqv L1 L2" and 23: "leqv L2 L3"
  2.1331 -shows "leqv L1 L3"
  2.1332 -using assms unfolding leqv_def by (metis (lifting) subs_trans)
  2.1333 -
  2.1334 -lemma leqv_sym: "leqv L1 L2 \<Longrightarrow> leqv L2 L1"
  2.1335 -unfolding leqv_def by auto
  2.1336 -
  2.1337 -lemma leqv_Sym: "leqv L1 L2 \<longleftrightarrow> leqv L2 L1"
  2.1338 -unfolding leqv_def by auto
  2.1339 -
  2.1340 -lemma Lr_incl_L: "Lr ns ts \<subseteq> L ns ts"
  2.1341 -unfolding Lr_def L_def by auto
  2.1342 -
  2.1343 -lemma Lr_subs_L: "subs (Lr UNIV ts) (L UNIV ts)"
  2.1344 -unfolding subs_def proof safe
  2.1345 -  fix ts2 assume "ts2 \<in> L UNIV ts"
  2.1346 -  then obtain tr where ts2: "ts2 = Fr UNIV tr" and dtr: "wf tr" and rtr: "root tr = ts"
  2.1347 -  unfolding L_def by auto
  2.1348 -  thus "\<exists>ts1\<in>Lr UNIV ts. ts1 \<subseteq> ts2"
  2.1349 -  apply(intro bexI[of _ "Fr UNIV (rcut tr)"])
  2.1350 -  unfolding Lr_def L_def using Fr_rcut wf_rcut root_rcut regular_rcut by auto
  2.1351 -qed
  2.1352 -
  2.1353 -lemma Lr_leqv_L: "leqv (Lr UNIV ts) (L UNIV ts)"
  2.1354 -using Lr_subs_L unfolding leqv_def by (metis (lifting) Lr_incl_L incl_subs)
  2.1355 -
  2.1356 -lemma LL_leqv_L: "leqv (LL UNIV ts) (L UNIV ts)"
  2.1357 -by (metis (lifting) LL_L Lr_LL Lr_subs_L incl_subs leqv_def subs_trans)
  2.1358 -
  2.1359 -lemma LL_leqv_Lr: "leqv (LL UNIV ts) (Lr UNIV ts)"
  2.1360 -using Lr_leqv_L LL_leqv_L by (metis leqv_Sym leqv_trans)
  2.1361 -
  2.1362 -end
     3.1 --- a/src/HOL/BNF/Examples/Derivation_Trees/Parallel.thy	Mon Jan 20 18:24:56 2014 +0100
     3.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.3 @@ -1,147 +0,0 @@
     3.4 -(*  Title:      HOL/BNF/Examples/Derivation_Trees/Parallel.thy
     3.5 -    Author:     Andrei Popescu, TU Muenchen
     3.6 -    Copyright   2012
     3.7 -
     3.8 -Parallel composition.
     3.9 -*)
    3.10 -
    3.11 -header {* Parallel Composition *}
    3.12 -
    3.13 -theory Parallel
    3.14 -imports DTree
    3.15 -begin
    3.16 -
    3.17 -no_notation plus_class.plus (infixl "+" 65)
    3.18 -
    3.19 -consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)
    3.20 -
    3.21 -axiomatization where
    3.22 -    Nplus_comm: "(a::N) + b = b + (a::N)"
    3.23 -and Nplus_assoc: "((a::N) + b) + c = a + (b + c)"
    3.24 -
    3.25 -subsection{* Corecursive Definition of Parallel Composition *}
    3.26 -
    3.27 -fun par_r where "par_r (tr1,tr2) = root tr1 + root tr2"
    3.28 -fun par_c where
    3.29 -"par_c (tr1,tr2) =
    3.30 - Inl ` (Inl -` (cont tr1 \<union> cont tr2)) \<union>
    3.31 - Inr ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
    3.32 -
    3.33 -declare par_r.simps[simp del]  declare par_c.simps[simp del]
    3.34 -
    3.35 -definition par :: "dtree \<times> dtree \<Rightarrow> dtree" where
    3.36 -"par \<equiv> unfold par_r par_c"
    3.37 -
    3.38 -abbreviation par_abbr (infixr "\<parallel>" 80) where "tr1 \<parallel> tr2 \<equiv> par (tr1, tr2)"
    3.39 -
    3.40 -lemma finite_par_c: "finite (par_c (tr1, tr2))"
    3.41 -unfolding par_c.simps apply(rule finite_UnI)
    3.42 -  apply (metis finite_Un finite_cont finite_imageI finite_vimageI inj_Inl)
    3.43 -  apply(intro finite_imageI finite_cartesian_product finite_vimageI)
    3.44 -  using finite_cont by auto
    3.45 -
    3.46 -lemma root_par: "root (tr1 \<parallel> tr2) = root tr1 + root tr2"
    3.47 -using unfold(1)[of par_r par_c "(tr1,tr2)"] unfolding par_def par_r.simps by simp
    3.48 -
    3.49 -lemma cont_par:
    3.50 -"cont (tr1 \<parallel> tr2) = (id \<oplus> par) ` par_c (tr1,tr2)"
    3.51 -using unfold(2)[of par_c "(tr1,tr2)" par_r, OF finite_par_c]
    3.52 -unfolding par_def ..
    3.53 -
    3.54 -lemma Inl_cont_par[simp]:
    3.55 -"Inl -` (cont (tr1 \<parallel> tr2)) = Inl -` (cont tr1 \<union> cont tr2)"
    3.56 -unfolding cont_par par_c.simps by auto
    3.57 -
    3.58 -lemma Inr_cont_par[simp]:
    3.59 -"Inr -` (cont (tr1 \<parallel> tr2)) = par ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
    3.60 -unfolding cont_par par_c.simps by auto
    3.61 -
    3.62 -lemma Inl_in_cont_par:
    3.63 -"Inl t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (Inl t \<in> cont tr1 \<or> Inl t \<in> cont tr2)"
    3.64 -using Inl_cont_par[of tr1 tr2] unfolding vimage_def by auto
    3.65 -
    3.66 -lemma Inr_in_cont_par:
    3.67 -"Inr t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (t \<in> par ` (Inr -` cont tr1 \<times> Inr -` cont tr2))"
    3.68 -using Inr_cont_par[of tr1 tr2] unfolding vimage_def by auto
    3.69 -
    3.70 -
    3.71 -subsection{* Structural Coinduction Proofs *}
    3.72 -
    3.73 -lemma set_rel_sum_rel_eq[simp]:
    3.74 -"set_rel (sum_rel (op =) \<phi>) A1 A2 \<longleftrightarrow>
    3.75 - Inl -` A1 = Inl -` A2 \<and> set_rel \<phi> (Inr -` A1) (Inr -` A2)"
    3.76 -unfolding set_rel_sum_rel set_rel_eq ..
    3.77 -
    3.78 -(* Detailed proofs of commutativity and associativity: *)
    3.79 -theorem par_com: "tr1 \<parallel> tr2 = tr2 \<parallel> tr1"
    3.80 -proof-
    3.81 -  let ?\<theta> = "\<lambda> trA trB. \<exists> tr1 tr2. trA = tr1 \<parallel> tr2 \<and> trB = tr2 \<parallel> tr1"
    3.82 -  {fix trA trB
    3.83 -   assume "?\<theta> trA trB" hence "trA = trB"
    3.84 -   apply (induct rule: dtree_coinduct)
    3.85 -   unfolding set_rel_sum_rel set_rel_eq unfolding set_rel_def proof safe
    3.86 -     fix tr1 tr2  show "root (tr1 \<parallel> tr2) = root (tr2 \<parallel> tr1)"
    3.87 -     unfolding root_par by (rule Nplus_comm)
    3.88 -   next
    3.89 -     fix n tr1 tr2 assume "Inl n \<in> cont (tr1 \<parallel> tr2)" thus "n \<in> Inl -` (cont (tr2 \<parallel> tr1))"
    3.90 -     unfolding Inl_in_cont_par by auto
    3.91 -   next
    3.92 -     fix n tr1 tr2 assume "Inl n \<in> cont (tr2 \<parallel> tr1)" thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2))"
    3.93 -     unfolding Inl_in_cont_par by auto
    3.94 -   next
    3.95 -     fix tr1 tr2 trA' assume "Inr trA' \<in> cont (tr1 \<parallel> tr2)"
    3.96 -     then obtain tr1' tr2' where "trA' = tr1' \<parallel> tr2'"
    3.97 -     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
    3.98 -     unfolding Inr_in_cont_par by auto
    3.99 -     thus "\<exists> trB' \<in> Inr -` (cont (tr2 \<parallel> tr1)). ?\<theta> trA' trB'"
   3.100 -     apply(intro bexI[of _ "tr2' \<parallel> tr1'"]) unfolding Inr_in_cont_par by auto
   3.101 -   next
   3.102 -     fix tr1 tr2 trB' assume "Inr trB' \<in> cont (tr2 \<parallel> tr1)"
   3.103 -     then obtain tr1' tr2' where "trB' = tr2' \<parallel> tr1'"
   3.104 -     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
   3.105 -     unfolding Inr_in_cont_par by auto
   3.106 -     thus "\<exists> trA' \<in> Inr -` (cont (tr1 \<parallel> tr2)). ?\<theta> trA' trB'"
   3.107 -     apply(intro bexI[of _ "tr1' \<parallel> tr2'"]) unfolding Inr_in_cont_par by auto
   3.108 -   qed
   3.109 -  }
   3.110 -  thus ?thesis by blast
   3.111 -qed
   3.112 -
   3.113 -lemma par_assoc: "(tr1 \<parallel> tr2) \<parallel> tr3 = tr1 \<parallel> (tr2 \<parallel> tr3)"
   3.114 -proof-
   3.115 -  let ?\<theta> =
   3.116 -  "\<lambda> trA trB. \<exists> tr1 tr2 tr3. trA = (tr1 \<parallel> tr2) \<parallel> tr3 \<and> trB = tr1 \<parallel> (tr2 \<parallel> tr3)"
   3.117 -  {fix trA trB
   3.118 -   assume "?\<theta> trA trB" hence "trA = trB"
   3.119 -   apply (induct rule: dtree_coinduct)
   3.120 -   unfolding set_rel_sum_rel set_rel_eq unfolding set_rel_def proof safe
   3.121 -     fix tr1 tr2 tr3  show "root ((tr1 \<parallel> tr2) \<parallel> tr3) = root (tr1 \<parallel> (tr2 \<parallel> tr3))"
   3.122 -     unfolding root_par by (rule Nplus_assoc)
   3.123 -   next
   3.124 -     fix n tr1 tr2 tr3 assume "Inl n \<in> (cont ((tr1 \<parallel> tr2) \<parallel> tr3))"
   3.125 -     thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2 \<parallel> tr3))" unfolding Inl_in_cont_par by simp
   3.126 -   next
   3.127 -     fix n tr1 tr2 tr3 assume "Inl n \<in> (cont (tr1 \<parallel> tr2 \<parallel> tr3))"
   3.128 -     thus "n \<in> Inl -` (cont ((tr1 \<parallel> tr2) \<parallel> tr3))" unfolding Inl_in_cont_par by simp
   3.129 -   next
   3.130 -     fix trA' tr1 tr2 tr3 assume "Inr trA' \<in> cont ((tr1 \<parallel> tr2) \<parallel> tr3)"
   3.131 -     then obtain tr1' tr2' tr3' where "trA' = (tr1' \<parallel> tr2') \<parallel> tr3'"
   3.132 -     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
   3.133 -     and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
   3.134 -     thus "\<exists> trB' \<in> Inr -` (cont (tr1 \<parallel> tr2 \<parallel> tr3)). ?\<theta> trA' trB'"
   3.135 -     apply(intro bexI[of _ "tr1' \<parallel> tr2' \<parallel> tr3'"])
   3.136 -     unfolding Inr_in_cont_par by auto
   3.137 -   next
   3.138 -     fix trB' tr1 tr2 tr3 assume "Inr trB' \<in> cont (tr1 \<parallel> tr2 \<parallel> tr3)"
   3.139 -     then obtain tr1' tr2' tr3' where "trB' = tr1' \<parallel> (tr2' \<parallel> tr3')"
   3.140 -     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
   3.141 -     and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
   3.142 -     thus "\<exists> trA' \<in> Inr -` cont ((tr1 \<parallel> tr2) \<parallel> tr3). ?\<theta> trA' trB'"
   3.143 -     apply(intro bexI[of _ "(tr1' \<parallel> tr2') \<parallel> tr3'"])
   3.144 -     unfolding Inr_in_cont_par by auto
   3.145 -   qed
   3.146 -  }
   3.147 -  thus ?thesis by blast
   3.148 -qed
   3.149 -
   3.150 -end
     4.1 --- a/src/HOL/BNF/Examples/Derivation_Trees/Prelim.thy	Mon Jan 20 18:24:56 2014 +0100
     4.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.3 @@ -1,62 +0,0 @@
     4.4 -(*  Title:      HOL/BNF/Examples/Derivation_Trees/Prelim.thy
     4.5 -    Author:     Andrei Popescu, TU Muenchen
     4.6 -    Copyright   2012
     4.7 -
     4.8 -Preliminaries.
     4.9 -*)
    4.10 -
    4.11 -header {* Preliminaries *}
    4.12 -
    4.13 -theory Prelim
    4.14 -imports "../../BNF" "../../More_BNFs"
    4.15 -begin
    4.16 -
    4.17 -declare fset_to_fset[simp]
    4.18 -
    4.19 -lemma fst_snd_convol_o[simp]: "<fst o s, snd o s> = s"
    4.20 -apply(rule ext) by (simp add: convol_def)
    4.21 -
    4.22 -abbreviation sm_abbrev (infix "\<oplus>" 60)
    4.23 -where "f \<oplus> g \<equiv> Sum_Type.sum_map f g"
    4.24 -
    4.25 -lemma sum_map_InlD: "(f \<oplus> g) z = Inl x \<Longrightarrow> \<exists>y. z = Inl y \<and> f y = x"
    4.26 -by (cases z) auto
    4.27 -
    4.28 -lemma sum_map_InrD: "(f \<oplus> g) z = Inr x \<Longrightarrow> \<exists>y. z = Inr y \<and> g y = x"
    4.29 -by (cases z) auto
    4.30 -
    4.31 -abbreviation sum_case_abbrev ("[[_,_]]" 800)
    4.32 -where "[[f,g]] \<equiv> Sum_Type.sum_case f g"
    4.33 -
    4.34 -lemma Inl_oplus_elim:
    4.35 -assumes "Inl tr \<in> (id \<oplus> f) ` tns"
    4.36 -shows "Inl tr \<in> tns"
    4.37 -using assms apply clarify by (case_tac x, auto)
    4.38 -
    4.39 -lemma Inl_oplus_iff[simp]: "Inl tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> Inl tr \<in> tns"
    4.40 -using Inl_oplus_elim
    4.41 -by (metis id_def image_iff sum_map.simps(1))
    4.42 -
    4.43 -lemma Inl_m_oplus[simp]: "Inl -` (id \<oplus> f) ` tns = Inl -` tns"
    4.44 -using Inl_oplus_iff unfolding vimage_def by auto
    4.45 -
    4.46 -lemma Inr_oplus_elim:
    4.47 -assumes "Inr tr \<in> (id \<oplus> f) ` tns"
    4.48 -shows "\<exists> n. Inr n \<in> tns \<and> f n = tr"
    4.49 -using assms apply clarify by (case_tac x, auto)
    4.50 -
    4.51 -lemma Inr_oplus_iff[simp]:
    4.52 -"Inr tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> (\<exists> n. Inr n \<in> tns \<and> f n = tr)"
    4.53 -apply (rule iffI)
    4.54 - apply (metis Inr_oplus_elim)
    4.55 -by (metis image_iff sum_map.simps(2))
    4.56 -
    4.57 -lemma Inr_m_oplus[simp]: "Inr -` (id \<oplus> f) ` tns = f ` (Inr -` tns)"
    4.58 -using Inr_oplus_iff unfolding vimage_def by auto
    4.59 -
    4.60 -lemma Inl_Inr_image_cong:
    4.61 -assumes "Inl -` A = Inl -` B" and "Inr -` A = Inr -` B"
    4.62 -shows "A = B"
    4.63 -apply safe using assms apply(case_tac x, auto) by(case_tac x, auto)
    4.64 -
    4.65 -end
    4.66 \ No newline at end of file
     5.1 --- a/src/HOL/BNF/Examples/Koenig.thy	Mon Jan 20 18:24:56 2014 +0100
     5.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.3 @@ -1,122 +0,0 @@
     5.4 -(*  Title:      HOL/BNF/Examples/Koenig.thy
     5.5 -    Author:     Dmitriy Traytel, TU Muenchen
     5.6 -    Author:     Andrei Popescu, TU Muenchen
     5.7 -    Copyright   2012
     5.8 -
     5.9 -Koenig's lemma.
    5.10 -*)
    5.11 -
    5.12 -header {* Koenig's lemma *}
    5.13 -
    5.14 -theory Koenig
    5.15 -imports TreeFI Stream
    5.16 -begin
    5.17 -
    5.18 -(* infinite trees: *)
    5.19 -coinductive infiniteTr where
    5.20 -"\<lbrakk>tr' \<in> set_listF (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"
    5.21 -
    5.22 -lemma infiniteTr_strong_coind[consumes 1, case_names sub]:
    5.23 -assumes *: "phi tr" and
    5.24 -**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set_listF (sub tr). phi tr' \<or> infiniteTr tr'"
    5.25 -shows "infiniteTr tr"
    5.26 -using assms by (elim infiniteTr.coinduct) blast
    5.27 -
    5.28 -lemma infiniteTr_coind[consumes 1, case_names sub, induct pred: infiniteTr]:
    5.29 -assumes *: "phi tr" and
    5.30 -**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set_listF (sub tr). phi tr'"
    5.31 -shows "infiniteTr tr"
    5.32 -using assms by (elim infiniteTr.coinduct) blast
    5.33 -
    5.34 -lemma infiniteTr_sub[simp]:
    5.35 -"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> set_listF (sub tr). infiniteTr tr')"
    5.36 -by (erule infiniteTr.cases) blast
    5.37 -
    5.38 -primcorec konigPath where
    5.39 -  "shd (konigPath t) = lab t"
    5.40 -| "stl (konigPath t) = konigPath (SOME tr. tr \<in> set_listF (sub t) \<and> infiniteTr tr)"
    5.41 -
    5.42 -(* proper paths in trees: *)
    5.43 -coinductive properPath where
    5.44 -"\<lbrakk>shd as = lab tr; tr' \<in> set_listF (sub tr); properPath (stl as) tr'\<rbrakk> \<Longrightarrow>
    5.45 - properPath as tr"
    5.46 -
    5.47 -lemma properPath_strong_coind[consumes 1, case_names shd_lab sub]:
    5.48 -assumes *: "phi as tr" and
    5.49 -**: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
    5.50 -***: "\<And> as tr.
    5.51 -         phi as tr \<Longrightarrow>
    5.52 -         \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
    5.53 -shows "properPath as tr"
    5.54 -using assms by (elim properPath.coinduct) blast
    5.55 -
    5.56 -lemma properPath_coind[consumes 1, case_names shd_lab sub, induct pred: properPath]:
    5.57 -assumes *: "phi as tr" and
    5.58 -**: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
    5.59 -***: "\<And> as tr.
    5.60 -         phi as tr \<Longrightarrow>
    5.61 -         \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr'"
    5.62 -shows "properPath as tr"
    5.63 -using properPath_strong_coind[of phi, OF * **] *** by blast
    5.64 -
    5.65 -lemma properPath_shd_lab:
    5.66 -"properPath as tr \<Longrightarrow> shd as = lab tr"
    5.67 -by (erule properPath.cases) blast
    5.68 -
    5.69 -lemma properPath_sub:
    5.70 -"properPath as tr \<Longrightarrow>
    5.71 - \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
    5.72 -by (erule properPath.cases) blast
    5.73 -
    5.74 -(* prove the following by coinduction *)
    5.75 -theorem Konig:
    5.76 -  assumes "infiniteTr tr"
    5.77 -  shows "properPath (konigPath tr) tr"
    5.78 -proof-
    5.79 -  {fix as
    5.80 -   assume "infiniteTr tr \<and> as = konigPath tr" hence "properPath as tr"
    5.81 -   proof (coinduction arbitrary: tr as rule: properPath_coind)
    5.82 -     case (sub tr as)
    5.83 -     let ?t = "SOME t'. t' \<in> set_listF (sub tr) \<and> infiniteTr t'"
    5.84 -     from sub have "\<exists>t' \<in> set_listF (sub tr). infiniteTr t'" by simp
    5.85 -     then have "\<exists>t'. t' \<in> set_listF (sub tr) \<and> infiniteTr t'" by blast
    5.86 -     then have "?t \<in> set_listF (sub tr) \<and> infiniteTr ?t" by (rule someI_ex)
    5.87 -     moreover have "stl (konigPath tr) = konigPath ?t" by simp
    5.88 -     ultimately show ?case using sub by blast
    5.89 -   qed simp
    5.90 -  }
    5.91 -  thus ?thesis using assms by blast
    5.92 -qed
    5.93 -
    5.94 -(* some more stream theorems *)
    5.95 -
    5.96 -primcorec plus :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<oplus>" 66) where
    5.97 -  "shd (plus xs ys) = shd xs + shd ys"
    5.98 -| "stl (plus xs ys) = plus (stl xs) (stl ys)"
    5.99 -
   5.100 -definition scalar :: "nat \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<cdot>" 68) where
   5.101 -  [simp]: "scalar n = smap (\<lambda>x. n * x)"
   5.102 -
   5.103 -primcorec ones :: "nat stream" where "ones = 1 ## ones"
   5.104 -primcorec twos :: "nat stream" where "twos = 2 ## twos"
   5.105 -definition ns :: "nat \<Rightarrow> nat stream" where [simp]: "ns n = scalar n ones"
   5.106 -
   5.107 -lemma "ones \<oplus> ones = twos"
   5.108 -  by coinduction simp
   5.109 -
   5.110 -lemma "n \<cdot> twos = ns (2 * n)"
   5.111 -  by coinduction simp
   5.112 -
   5.113 -lemma prod_scalar: "(n * m) \<cdot> xs = n \<cdot> m \<cdot> xs"
   5.114 -  by (coinduction arbitrary: xs) auto
   5.115 -
   5.116 -lemma scalar_plus: "n \<cdot> (xs \<oplus> ys) = n \<cdot> xs \<oplus> n \<cdot> ys"
   5.117 -  by (coinduction arbitrary: xs ys) (auto simp: add_mult_distrib2)
   5.118 -
   5.119 -lemma plus_comm: "xs \<oplus> ys = ys \<oplus> xs"
   5.120 -  by (coinduction arbitrary: xs ys) auto
   5.121 -
   5.122 -lemma plus_assoc: "(xs \<oplus> ys) \<oplus> zs = xs \<oplus> ys \<oplus> zs"
   5.123 -  by (coinduction arbitrary: xs ys zs) auto
   5.124 -
   5.125 -end
     6.1 --- a/src/HOL/BNF/Examples/Lambda_Term.thy	Mon Jan 20 18:24:56 2014 +0100
     6.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.3 @@ -1,52 +0,0 @@
     6.4 -(*  Title:      HOL/BNF/Examples/Lambda_Term.thy
     6.5 -    Author:     Dmitriy Traytel, TU Muenchen
     6.6 -    Author:     Andrei Popescu, TU Muenchen
     6.7 -    Copyright   2012
     6.8 -
     6.9 -Lambda-terms.
    6.10 -*)
    6.11 -
    6.12 -header {* Lambda-Terms *}
    6.13 -
    6.14 -theory Lambda_Term
    6.15 -imports "../More_BNFs"
    6.16 -begin
    6.17 -
    6.18 -thy_deps
    6.19 -
    6.20 -section {* Datatype definition *}
    6.21 -
    6.22 -datatype_new 'a trm =
    6.23 -  Var 'a |
    6.24 -  App "'a trm" "'a trm" |
    6.25 -  Lam 'a "'a trm" |
    6.26 -  Lt "('a \<times> 'a trm) fset" "'a trm"
    6.27 -
    6.28 -
    6.29 -subsection{* Example: The set of all variables varsOf and free variables fvarsOf of a term: *}
    6.30 -
    6.31 -primrec_new varsOf :: "'a trm \<Rightarrow> 'a set" where
    6.32 -  "varsOf (Var a) = {a}"
    6.33 -| "varsOf (App f x) = varsOf f \<union> varsOf x"
    6.34 -| "varsOf (Lam x b) = {x} \<union> varsOf b"
    6.35 -| "varsOf (Lt F t) = varsOf t \<union> (\<Union> { {x} \<union> X | x X. (x,X) |\<in>| fimage (map_pair id varsOf) F})"
    6.36 -
    6.37 -primrec_new fvarsOf :: "'a trm \<Rightarrow> 'a set" where
    6.38 -  "fvarsOf (Var x) = {x}"
    6.39 -| "fvarsOf (App t1 t2) = fvarsOf t1 \<union> fvarsOf t2"
    6.40 -| "fvarsOf (Lam x t) = fvarsOf t - {x}"
    6.41 -| "fvarsOf (Lt xts t) = fvarsOf t - {x | x X. (x,X) |\<in>| fimage (map_pair id varsOf) xts} \<union>
    6.42 -    (\<Union> {X | x X. (x,X) |\<in>| fimage (map_pair id varsOf) xts})"
    6.43 -
    6.44 -lemma diff_Un_incl_triv: "\<lbrakk>A \<subseteq> D; C \<subseteq> E\<rbrakk> \<Longrightarrow> A - B \<union> C \<subseteq> D \<union> E" by blast
    6.45 -
    6.46 -lemma in_fmap_map_pair_fset_iff[simp]:
    6.47 -  "(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)"
    6.48 -  by force
    6.49 -
    6.50 -lemma fvarsOf_varsOf: "fvarsOf t \<subseteq> varsOf t"
    6.51 -proof induct
    6.52 -  case (Lt xts t) thus ?case unfolding fvarsOf.simps varsOf.simps by (elim diff_Un_incl_triv) auto
    6.53 -qed auto
    6.54 -
    6.55 -end
     7.1 --- a/src/HOL/BNF/Examples/ListF.thy	Mon Jan 20 18:24:56 2014 +0100
     7.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.3 @@ -1,111 +0,0 @@
     7.4 -(*  Title:      HOL/BNF/Examples/ListF.thy
     7.5 -    Author:     Dmitriy Traytel, TU Muenchen
     7.6 -    Author:     Andrei Popescu, TU Muenchen
     7.7 -    Copyright   2012
     7.8 -
     7.9 -Finite lists.
    7.10 -*)
    7.11 -
    7.12 -header {* Finite Lists *}
    7.13 -
    7.14 -theory ListF
    7.15 -imports "../BNF"
    7.16 -begin
    7.17 -
    7.18 -datatype_new 'a listF (map: mapF rel: relF) =
    7.19 -  NilF (defaults tlF: NilF) | Conss (hdF: 'a) (tlF: "'a listF")
    7.20 -datatype_new_compat listF
    7.21 -
    7.22 -definition Singll ("[[_]]") where
    7.23 -  [simp]: "Singll a \<equiv> Conss a NilF"
    7.24 -
    7.25 -primrec_new appendd (infixr "@@" 65) where
    7.26 -  "NilF @@ ys = ys"
    7.27 -| "Conss x xs @@ ys = Conss x (xs @@ ys)"
    7.28 -
    7.29 -primrec_new lrev where
    7.30 -  "lrev NilF = NilF"
    7.31 -| "lrev (Conss y ys) = lrev ys @@ [[y]]"
    7.32 -
    7.33 -lemma appendd_NilF[simp]: "xs @@ NilF = xs"
    7.34 -  by (induct xs) auto
    7.35 -
    7.36 -lemma appendd_assoc[simp]: "(xs @@ ys) @@ zs = xs @@ ys @@ zs"
    7.37 -  by (induct xs) auto
    7.38 -
    7.39 -lemma lrev_appendd[simp]: "lrev (xs @@ ys) = lrev ys @@ lrev xs"
    7.40 -  by (induct xs) auto
    7.41 -
    7.42 -lemma listF_map_appendd[simp]:
    7.43 -  "mapF f (xs @@ ys) = mapF f xs @@ mapF f ys"
    7.44 -  by (induct xs) auto
    7.45 -
    7.46 -lemma lrev_listF_map[simp]: "lrev (mapF f xs) = mapF f (lrev xs)"
    7.47 -  by (induct xs) auto
    7.48 -
    7.49 -lemma lrev_lrev[simp]: "lrev (lrev xs) = xs"
    7.50 -  by (induct xs) auto
    7.51 -
    7.52 -primrec_new lengthh where
    7.53 -  "lengthh NilF = 0"
    7.54 -| "lengthh (Conss x xs) = Suc (lengthh xs)"
    7.55 -
    7.56 -fun nthh where
    7.57 -  "nthh (Conss x xs) 0 = x"
    7.58 -| "nthh (Conss x xs) (Suc n) = nthh xs n"
    7.59 -| "nthh xs i = undefined"
    7.60 -
    7.61 -lemma lengthh_listF_map[simp]: "lengthh (mapF f xs) = lengthh xs"
    7.62 -  by (induct xs) auto
    7.63 -
    7.64 -lemma nthh_listF_map[simp]:
    7.65 -  "i < lengthh xs \<Longrightarrow> nthh (mapF f xs) i = f (nthh xs i)"
    7.66 -  by (induct rule: nthh.induct) auto
    7.67 -
    7.68 -lemma nthh_listF_set[simp]: "i < lengthh xs \<Longrightarrow> nthh xs i \<in> set_listF xs"
    7.69 -  by (induct rule: nthh.induct) auto
    7.70 -
    7.71 -lemma NilF_iff[iff]: "(lengthh xs = 0) = (xs = NilF)"
    7.72 -  by (induct xs) auto
    7.73 -
    7.74 -lemma Conss_iff[iff]:
    7.75 -  "(lengthh xs = Suc n) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
    7.76 -  by (induct xs) auto
    7.77 -
    7.78 -lemma Conss_iff'[iff]:
    7.79 -  "(Suc n = lengthh xs) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
    7.80 -  by (induct xs) (simp, simp, blast)
    7.81 -
    7.82 -lemma listF_induct2[consumes 1, case_names NilF Conss]: "\<lbrakk>lengthh xs = lengthh ys; P NilF NilF;
    7.83 -    \<And>x xs y ys. P xs ys \<Longrightarrow> P (Conss x xs) (Conss y ys)\<rbrakk> \<Longrightarrow> P xs ys"
    7.84 -    by (induct xs arbitrary: ys) auto
    7.85 -
    7.86 -fun zipp where
    7.87 -  "zipp NilF NilF = NilF"
    7.88 -| "zipp (Conss x xs) (Conss y ys) = Conss (x, y) (zipp xs ys)"
    7.89 -| "zipp xs ys = undefined"
    7.90 -
    7.91 -lemma listF_map_fst_zip[simp]:
    7.92 -  "lengthh xs = lengthh ys \<Longrightarrow> mapF fst (zipp xs ys) = xs"
    7.93 -  by (induct rule: listF_induct2) auto
    7.94 -
    7.95 -lemma listF_map_snd_zip[simp]:
    7.96 -  "lengthh xs = lengthh ys \<Longrightarrow> mapF snd (zipp xs ys) = ys"
    7.97 -  by (induct rule: listF_induct2) auto
    7.98 -
    7.99 -lemma lengthh_zip[simp]:
   7.100 -  "lengthh xs = lengthh ys \<Longrightarrow> lengthh (zipp xs ys) = lengthh xs"
   7.101 -  by (induct rule: listF_induct2) auto
   7.102 -
   7.103 -lemma nthh_zip[simp]:
   7.104 -  assumes "lengthh xs = lengthh ys"
   7.105 -  shows "i < lengthh xs \<Longrightarrow> nthh (zipp xs ys) i = (nthh xs i, nthh ys i)"
   7.106 -using assms proof (induct arbitrary: i rule: listF_induct2)
   7.107 -  case (Conss x xs y ys) thus ?case by (induct i) auto
   7.108 -qed simp
   7.109 -
   7.110 -lemma list_set_nthh[simp]:
   7.111 -  "(x \<in> set_listF xs) \<Longrightarrow> (\<exists>i < lengthh xs. nthh xs i = x)"
   7.112 -  by (induct xs) (auto, induct rule: nthh.induct, auto)
   7.113 -
   7.114 -end
     8.1 --- a/src/HOL/BNF/Examples/Misc_Codatatype.thy	Mon Jan 20 18:24:56 2014 +0100
     8.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.3 @@ -1,120 +0,0 @@
     8.4 -(*  Title:      HOL/BNF/Examples/Misc_Codatatype.thy
     8.5 -    Author:     Dmitriy Traytel, TU Muenchen
     8.6 -    Author:     Andrei Popescu, TU Muenchen
     8.7 -    Author:     Jasmin Blanchette, TU Muenchen
     8.8 -    Copyright   2012, 2013
     8.9 -
    8.10 -Miscellaneous codatatype definitions.
    8.11 -*)
    8.12 -
    8.13 -header {* Miscellaneous Codatatype Definitions *}
    8.14 -
    8.15 -theory Misc_Codatatype
    8.16 -imports More_BNFs
    8.17 -begin
    8.18 -
    8.19 -codatatype simple = X1 | X2 | X3 | X4
    8.20 -
    8.21 -codatatype simple' = X1' unit | X2' unit | X3' unit | X4' unit
    8.22 -
    8.23 -codatatype simple'' = X1'' nat int | X2''
    8.24 -
    8.25 -codatatype 'a stream = Stream (shd: 'a) (stl: "'a stream")
    8.26 -
    8.27 -codatatype 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
    8.28 -
    8.29 -codatatype ('b, 'c, 'd, 'e) some_passive =
    8.30 -  SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
    8.31 -
    8.32 -codatatype lambda =
    8.33 -  Var string |
    8.34 -  App lambda lambda |
    8.35 -  Abs string lambda |
    8.36 -  Let "(string \<times> lambda) fset" lambda
    8.37 -
    8.38 -codatatype 'a par_lambda =
    8.39 -  PVar 'a |
    8.40 -  PApp "'a par_lambda" "'a par_lambda" |
    8.41 -  PAbs 'a "'a par_lambda" |
    8.42 -  PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
    8.43 -
    8.44 -(*
    8.45 -  ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
    8.46 -  ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
    8.47 -*)
    8.48 -
    8.49 -codatatype 'a p = P "'a + 'a p"
    8.50 -
    8.51 -codatatype 'a J1 = J11 'a "'a J1" | J12 'a "'a J2"
    8.52 -and 'a J2 = J21 | J22 "'a J1" "'a J2"
    8.53 -
    8.54 -codatatype 'a tree = TEmpty | TNode 'a "'a forest"
    8.55 -and 'a forest = FNil | FCons "'a tree" "'a forest"
    8.56 -
    8.57 -codatatype 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
    8.58 -and 'a branch = Branch 'a "'a tree'"
    8.59 -
    8.60 -codatatype ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
    8.61 -and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
    8.62 -and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
    8.63 -
    8.64 -codatatype ('a, 'b, 'c) some_killing =
    8.65 -  SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
    8.66 -and ('a, 'b, 'c) in_here =
    8.67 -  IH1 'b 'a | IH2 'c
    8.68 -
    8.69 -codatatype ('a, 'b, 'c) some_killing' =
    8.70 -  SK' "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing' + ('a, 'b, 'c) in_here'"
    8.71 -and ('a, 'b, 'c) in_here' =
    8.72 -  IH1' 'b | IH2' 'c
    8.73 -
    8.74 -codatatype ('a, 'b, 'c) some_killing'' =
    8.75 -  SK'' "'a \<Rightarrow> ('a, 'b, 'c) in_here''"
    8.76 -and ('a, 'b, 'c) in_here'' =
    8.77 -  IH1'' 'b 'a | IH2'' 'c
    8.78 -
    8.79 -codatatype ('b, 'c) less_killing = LK "'b \<Rightarrow> 'c"
    8.80 -
    8.81 -codatatype 'b poly_unit = U "'b \<Rightarrow> 'b poly_unit"
    8.82 -codatatype 'b cps = CPS1 'b | CPS2 "'b \<Rightarrow> 'b cps"
    8.83 -
    8.84 -codatatype ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs =
    8.85 -  FR "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow>
    8.86 -      ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs"
    8.87 -
    8.88 -codatatype ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
    8.89 -        'b18, 'b19, 'b20) fun_rhs' =
    8.90 -  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>
    8.91 -       'b15 \<Rightarrow> 'b16 \<Rightarrow> 'b17 \<Rightarrow> 'b18 \<Rightarrow> 'b19 \<Rightarrow> 'b20 \<Rightarrow>
    8.92 -       ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
    8.93 -        'b18, 'b19, 'b20) fun_rhs'"
    8.94 -
    8.95 -codatatype ('a, 'b, 'c) wit3_F1 = W1 'a "('a, 'b, 'c) wit3_F1" "('a, 'b, 'c) wit3_F2"
    8.96 -and ('a, 'b, 'c) wit3_F2 = W2 'b "('a, 'b, 'c) wit3_F2"
    8.97 -and ('a, 'b, 'c) wit3_F3 = W31 'a 'b "('a, 'b, 'c) wit3_F1" | W32 'c 'a 'b "('a, 'b, 'c) wit3_F1"
    8.98 -
    8.99 -codatatype ('c, 'e, 'g) coind_wit1 =
   8.100 -       CW1 'c "('c, 'e, 'g) coind_wit1" "('c, 'e, 'g) ind_wit" "('c, 'e, 'g) coind_wit2"
   8.101 -and ('c, 'e, 'g) coind_wit2 =
   8.102 -       CW21 "('c, 'e, 'g) coind_wit2" 'e | CW22 'c 'g
   8.103 -and ('c, 'e, 'g) ind_wit =
   8.104 -       IW1 | IW2 'c
   8.105 -
   8.106 -codatatype ('b, 'a) bar = BAR "'a \<Rightarrow> 'b"
   8.107 -codatatype ('a, 'b, 'c, 'd) foo = FOO "'d + 'b \<Rightarrow> 'c + 'a"
   8.108 -
   8.109 -codatatype 'a dead_foo = A
   8.110 -codatatype ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
   8.111 -
   8.112 -(* SLOW, MEMORY-HUNGRY
   8.113 -codatatype ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
   8.114 -and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
   8.115 -and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
   8.116 -and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
   8.117 -and ('a, 'c) D5 = A5 "('a, 'c) D6"
   8.118 -and ('a, 'c) D6 = A6 "('a, 'c) D7"
   8.119 -and ('a, 'c) D7 = A7 "('a, 'c) D8"
   8.120 -and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
   8.121 -*)
   8.122 -
   8.123 -end
     9.1 --- a/src/HOL/BNF/Examples/Misc_Datatype.thy	Mon Jan 20 18:24:56 2014 +0100
     9.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.3 @@ -1,185 +0,0 @@
     9.4 -(*  Title:      HOL/BNF/Examples/Misc_Datatype.thy
     9.5 -    Author:     Dmitriy Traytel, TU Muenchen
     9.6 -    Author:     Andrei Popescu, TU Muenchen
     9.7 -    Author:     Jasmin Blanchette, TU Muenchen
     9.8 -    Copyright   2012, 2013
     9.9 -
    9.10 -Miscellaneous datatype definitions.
    9.11 -*)
    9.12 -
    9.13 -header {* Miscellaneous Datatype Definitions *}
    9.14 -
    9.15 -theory Misc_Datatype
    9.16 -imports "../BNF"
    9.17 -begin
    9.18 -
    9.19 -datatype_new simple = X1 | X2 | X3 | X4
    9.20 -
    9.21 -datatype_new simple' = X1' unit | X2' unit | X3' unit | X4' unit
    9.22 -
    9.23 -datatype_new simple'' = X1'' nat int | X2''
    9.24 -
    9.25 -datatype_new 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
    9.26 -
    9.27 -datatype_new ('b, 'c, 'd, 'e) some_passive =
    9.28 -  SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
    9.29 -
    9.30 -datatype_new hfset = HFset "hfset fset"
    9.31 -
    9.32 -datatype_new lambda =
    9.33 -  Var string |
    9.34 -  App lambda lambda |
    9.35 -  Abs string lambda |
    9.36 -  Let "(string \<times> lambda) fset" lambda
    9.37 -
    9.38 -datatype_new 'a par_lambda =
    9.39 -  PVar 'a |
    9.40 -  PApp "'a par_lambda" "'a par_lambda" |
    9.41 -  PAbs 'a "'a par_lambda" |
    9.42 -  PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
    9.43 -
    9.44 -(*
    9.45 -  ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
    9.46 -  ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
    9.47 -*)
    9.48 -
    9.49 -datatype_new 'a I1 = I11 'a "'a I1" | I12 'a "'a I2"
    9.50 -and 'a I2 = I21 | I22 "'a I1" "'a I2"
    9.51 -
    9.52 -datatype_new 'a tree = TEmpty | TNode 'a "'a forest"
    9.53 -and 'a forest = FNil | FCons "'a tree" "'a forest"
    9.54 -
    9.55 -datatype_new 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
    9.56 -and 'a branch = Branch 'a "'a tree'"
    9.57 -
    9.58 -datatype_new ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
    9.59 -and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
    9.60 -and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
    9.61 -
    9.62 -datatype_new 'a ftree = FTLeaf 'a | FTNode "'a \<Rightarrow> 'a ftree"
    9.63 -
    9.64 -datatype_new ('a, 'b, 'c) some_killing =
    9.65 -  SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
    9.66 -and ('a, 'b, 'c) in_here =
    9.67 -  IH1 'b 'a | IH2 'c
    9.68 -
    9.69 -datatype_new 'b nofail1 = NF11 "'b nofail1" 'b | NF12 'b
    9.70 -datatype_new 'b nofail2 = NF2 "('b nofail2 \<times> 'b \<times> 'b nofail2 \<times> 'b) list"
    9.71 -datatype_new 'b nofail3 = NF3 'b "('b nofail3 \<times> 'b \<times> 'b nofail3 \<times> 'b) fset"
    9.72 -datatype_new 'b nofail4 = NF4 "('b nofail4 \<times> ('b nofail4 \<times> 'b \<times> 'b nofail4 \<times> 'b) fset) list"
    9.73 -
    9.74 -(*
    9.75 -datatype_new 'b fail = F "'b fail" 'b "'b fail" "'b list"
    9.76 -datatype_new 'b fail = F "'b fail" 'b "'b fail" 'b
    9.77 -datatype_new 'b fail = F1 "'b fail" 'b | F2 "'b fail"
    9.78 -datatype_new 'b fail = F "'b fail" 'b
    9.79 -*)
    9.80 -
    9.81 -datatype_new l1 = L1 "l2 list"
    9.82 -and l2 = L21 "l1 fset" | L22 l2
    9.83 -
    9.84 -datatype_new kk1 = KK1 kk2
    9.85 -and kk2 = KK2 kk3
    9.86 -and kk3 = KK3 "kk1 list"
    9.87 -
    9.88 -datatype_new t1 = T11 t3 | T12 t2
    9.89 -and t2 = T2 t1
    9.90 -and t3 = T3
    9.91 -
    9.92 -datatype_new t1' = T11' t2' | T12' t3'
    9.93 -and t2' = T2' t1'
    9.94 -and t3' = T3'
    9.95 -
    9.96 -(*
    9.97 -datatype_new fail1 = F1 fail2
    9.98 -and fail2 = F2 fail3
    9.99 -and fail3 = F3 fail1
   9.100 -
   9.101 -datatype_new fail1 = F1 "fail2 list" fail2
   9.102 -and fail2 = F2 "fail2 fset" fail3
   9.103 -and fail3 = F3 fail1
   9.104 -
   9.105 -datatype_new fail1 = F1 "fail2 list" fail2
   9.106 -and fail2 = F2 "fail1 fset" fail1
   9.107 -*)
   9.108 -
   9.109 -(* SLOW
   9.110 -datatype_new ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
   9.111 -and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
   9.112 -and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
   9.113 -and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
   9.114 -and ('a, 'c) D5 = A5 "('a, 'c) D6"
   9.115 -and ('a, 'c) D6 = A6 "('a, 'c) D7"
   9.116 -and ('a, 'c) D7 = A7 "('a, 'c) D8"
   9.117 -and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
   9.118 -
   9.119 -(*time comparison*)
   9.120 -datatype ('a, 'c) D1' = A1' "('a, 'c) D2'" | B1' "'a list"
   9.121 -     and ('a, 'c) D2' = A2' "('a, 'c) D3'" | B2' "'c list"
   9.122 -     and ('a, 'c) D3' = A3' "('a, 'c) D3'" | B3' "('a, 'c) D4'" | C3' "('a, 'c) D4'" "('a, 'c) D5'"
   9.123 -     and ('a, 'c) D4' = A4' "('a, 'c) D5'" | B4' "'a list list list"
   9.124 -     and ('a, 'c) D5' = A5' "('a, 'c) D6'"
   9.125 -     and ('a, 'c) D6' = A6' "('a, 'c) D7'"
   9.126 -     and ('a, 'c) D7' = A7' "('a, 'c) D8'"
   9.127 -     and ('a, 'c) D8' = A8' "('a, 'c) D1' list"
   9.128 -*)
   9.129 -
   9.130 -(* fail:
   9.131 -datatype_new tt1 = TT11 tt2 tt3 | TT12 tt2 tt4
   9.132 -and tt2 = TT2
   9.133 -and tt3 = TT3 tt4
   9.134 -and tt4 = TT4 tt1
   9.135 -*)
   9.136 -
   9.137 -datatype_new k1 = K11 k2 k3 | K12 k2 k4
   9.138 -and k2 = K2
   9.139 -and k3 = K3 k4
   9.140 -and k4 = K4
   9.141 -
   9.142 -datatype_new tt1 = TT11 tt3 tt2 | TT12 tt2 tt4
   9.143 -and tt2 = TT2
   9.144 -and tt3 = TT3 tt1
   9.145 -and tt4 = TT4
   9.146 -
   9.147 -(* SLOW
   9.148 -datatype_new s1 = S11 s2 s3 s4 | S12 s3 | S13 s2 s6 | S14 s4 s2 | S15 s2 s2
   9.149 -and s2 = S21 s7 s5 | S22 s5 s4 s6
   9.150 -and s3 = S31 s1 s7 s2 | S32 s3 s3 | S33 s4 s5
   9.151 -and s4 = S4 s5
   9.152 -and s5 = S5
   9.153 -and s6 = S61 s6 | S62 s1 s2 | S63 s6
   9.154 -and s7 = S71 s8 | S72 s5
   9.155 -and s8 = S8 nat
   9.156 -*)
   9.157 -
   9.158 -datatype_new 'a deadbar = DeadBar "'a \<Rightarrow> 'a"
   9.159 -datatype_new 'a deadbar_option = DeadBarOption "'a option \<Rightarrow> 'a option"
   9.160 -datatype_new ('a, 'b) bar = Bar "'b \<Rightarrow> 'a"
   9.161 -datatype_new ('a, 'b, 'c, 'd) foo = Foo "'d + 'b \<Rightarrow> 'c + 'a"
   9.162 -datatype_new 'a deadfoo = DeadFoo "'a \<Rightarrow> 'a + 'a"
   9.163 -
   9.164 -datatype_new 'a dead_foo = A
   9.165 -datatype_new ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
   9.166 -
   9.167 -datatype_new d1 = D
   9.168 -datatype_new d1' = is_D: D
   9.169 -
   9.170 -datatype_new d2 = D nat
   9.171 -datatype_new d2' = is_D: D nat
   9.172 -
   9.173 -datatype_new d3 = D | E
   9.174 -datatype_new d3' = D | is_E: E
   9.175 -datatype_new d3'' = is_D: D | E
   9.176 -datatype_new d3''' = is_D: D | is_E: E
   9.177 -
   9.178 -datatype_new d4 = D nat | E
   9.179 -datatype_new d4' = D nat | is_E: E
   9.180 -datatype_new d4'' = is_D: D nat | E
   9.181 -datatype_new d4''' = is_D: D nat | is_E: E
   9.182 -
   9.183 -datatype_new d5 = D nat | E int
   9.184 -datatype_new d5' = D nat | is_E: E int
   9.185 -datatype_new d5'' = is_D: D nat | E int
   9.186 -datatype_new d5''' = is_D: D nat | is_E: E int
   9.187 -
   9.188 -end
    10.1 --- a/src/HOL/BNF/Examples/Misc_Primcorec.thy	Mon Jan 20 18:24:56 2014 +0100
    10.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.3 @@ -1,112 +0,0 @@
    10.4 -(*  Title:      HOL/BNF/Examples/Misc_Primcorec.thy
    10.5 -    Author:     Jasmin Blanchette, TU Muenchen
    10.6 -    Copyright   2013
    10.7 -
    10.8 -Miscellaneous primitive corecursive function definitions.
    10.9 -*)
   10.10 -
   10.11 -header {* Miscellaneous Primitive Corecursive Function Definitions *}
   10.12 -
   10.13 -theory Misc_Primcorec
   10.14 -imports Misc_Codatatype
   10.15 -begin
   10.16 -
   10.17 -primcorec simple_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple" where
   10.18 -  "simple_of_bools b b' = (if b then if b' then X1 else X2 else if b' then X3 else X4)"
   10.19 -
   10.20 -primcorec simple'_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple'" where
   10.21 -  "simple'_of_bools b b' =
   10.22 -     (if b then if b' then X1' () else X2' () else if b' then X3' () else X4' ())"
   10.23 -
   10.24 -primcorec inc_simple'' :: "nat \<Rightarrow> simple'' \<Rightarrow> simple''" where
   10.25 -  "inc_simple'' k s = (case s of X1'' n i \<Rightarrow> X1'' (n + k) (i + int k) | X2'' \<Rightarrow> X2'')"
   10.26 -
   10.27 -primcorec sinterleave :: "'a stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
   10.28 -  "sinterleave s s' = Stream (shd s) (sinterleave s' (stl s))"
   10.29 -
   10.30 -primcorec myapp :: "'a mylist \<Rightarrow> 'a mylist \<Rightarrow> 'a mylist" where
   10.31 -  "myapp xs ys =
   10.32 -     (if xs = MyNil then ys
   10.33 -      else if ys = MyNil then xs
   10.34 -      else MyCons (myhd xs) (myapp (mytl xs) ys))"
   10.35 -
   10.36 -primcorec shuffle_sp :: "('a, 'b, 'c, 'd) some_passive \<Rightarrow> ('d, 'a, 'b, 'c) some_passive" where
   10.37 -  "shuffle_sp sp =
   10.38 -     (case sp of
   10.39 -       SP1 sp' \<Rightarrow> SP1 (shuffle_sp sp')
   10.40 -     | SP2 a \<Rightarrow> SP3 a
   10.41 -     | SP3 b \<Rightarrow> SP4 b
   10.42 -     | SP4 c \<Rightarrow> SP5 c
   10.43 -     | SP5 d \<Rightarrow> SP2 d)"
   10.44 -
   10.45 -primcorec rename_lam :: "(string \<Rightarrow> string) \<Rightarrow> lambda \<Rightarrow> lambda" where
   10.46 -  "rename_lam f l =
   10.47 -     (case l of
   10.48 -       Var s \<Rightarrow> Var (f s)
   10.49 -     | App l l' \<Rightarrow> App (rename_lam f l) (rename_lam f l')
   10.50 -     | Abs s l \<Rightarrow> Abs (f s) (rename_lam f l)
   10.51 -     | Let SL l \<Rightarrow> Let (fimage (map_pair f (rename_lam f)) SL) (rename_lam f l))"
   10.52 -
   10.53 -primcorec
   10.54 -  j1_sum :: "('a\<Colon>{zero,one,plus}) \<Rightarrow> 'a J1" and
   10.55 -  j2_sum :: "'a \<Rightarrow> 'a J2"
   10.56 -where
   10.57 -  "n = 0 \<Longrightarrow> is_J11 (j1_sum n)" |
   10.58 -  "un_J111 (j1_sum _) = 0" |
   10.59 -  "un_J112 (j1_sum _) = j1_sum 0" |
   10.60 -  "un_J121 (j1_sum n) = n + 1" |
   10.61 -  "un_J122 (j1_sum n) = j2_sum (n + 1)" |
   10.62 -  "n = 0 \<Longrightarrow> is_J21 (j2_sum n)" |
   10.63 -  "un_J221 (j2_sum n) = j1_sum (n + 1)" |
   10.64 -  "un_J222 (j2_sum n) = j2_sum (n + 1)"
   10.65 -
   10.66 -primcorec forest_of_mylist :: "'a tree mylist \<Rightarrow> 'a forest" where
   10.67 -  "forest_of_mylist ts =
   10.68 -     (case ts of
   10.69 -       MyNil \<Rightarrow> FNil
   10.70 -     | MyCons t ts \<Rightarrow> FCons t (forest_of_mylist ts))"
   10.71 -
   10.72 -primcorec mylist_of_forest :: "'a forest \<Rightarrow> 'a tree mylist" where
   10.73 -  "mylist_of_forest f =
   10.74 -     (case f of
   10.75 -       FNil \<Rightarrow> MyNil
   10.76 -     | FCons t ts \<Rightarrow> MyCons t (mylist_of_forest ts))"
   10.77 -
   10.78 -primcorec semi_stream :: "'a stream \<Rightarrow> 'a stream" where
   10.79 -  "semi_stream s = Stream (shd s) (semi_stream (stl (stl s)))"
   10.80 -
   10.81 -primcorec
   10.82 -  tree'_of_stream :: "'a stream \<Rightarrow> 'a tree'" and
   10.83 -  branch_of_stream :: "'a stream \<Rightarrow> 'a branch"
   10.84 -where
   10.85 -  "tree'_of_stream s =
   10.86 -     TNode' (branch_of_stream (semi_stream s)) (branch_of_stream (semi_stream (stl s)))" |
   10.87 -  "branch_of_stream s = (case s of Stream h t \<Rightarrow> Branch h (tree'_of_stream t))"
   10.88 -
   10.89 -primcorec
   10.90 -  freeze_exp :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) exp \<Rightarrow> ('a, 'b) exp" and
   10.91 -  freeze_trm :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) trm \<Rightarrow> ('a, 'b) trm" and
   10.92 -  freeze_factor :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) factor \<Rightarrow> ('a, 'b) factor"
   10.93 -where
   10.94 -  "freeze_exp g e =
   10.95 -     (case e of
   10.96 -       Term t \<Rightarrow> Term (freeze_trm g t)
   10.97 -     | Sum t e \<Rightarrow> Sum (freeze_trm g t) (freeze_exp g e))" |
   10.98 -  "freeze_trm g t =
   10.99 -     (case t of
  10.100 -       Factor f \<Rightarrow> Factor (freeze_factor g f)
  10.101 -     | Prod f t \<Rightarrow> Prod (freeze_factor g f) (freeze_trm g t))" |
  10.102 -  "freeze_factor g f =
  10.103 -     (case f of
  10.104 -       C a \<Rightarrow> C a
  10.105 -     | V b \<Rightarrow> C (g b)
  10.106 -     | Paren e \<Rightarrow> Paren (freeze_exp g e))"
  10.107 -
  10.108 -primcorec poly_unity :: "'a poly_unit" where
  10.109 -  "poly_unity = U (\<lambda>_. poly_unity)"
  10.110 -
  10.111 -primcorec build_cps :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool stream) \<Rightarrow> 'a \<Rightarrow> bool stream \<Rightarrow> 'a cps" where
  10.112 -  "shd b \<Longrightarrow> build_cps f g a b = CPS1 a" |
  10.113 -  "_ \<Longrightarrow> build_cps f g a b = CPS2 (\<lambda>a. build_cps f g (f a) (g a))"
  10.114 -
  10.115 -end
    11.1 --- a/src/HOL/BNF/Examples/Misc_Primrec.thy	Mon Jan 20 18:24:56 2014 +0100
    11.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.3 @@ -1,114 +0,0 @@
    11.4 -(*  Title:      HOL/BNF/Examples/Misc_Primrec.thy
    11.5 -    Author:     Jasmin Blanchette, TU Muenchen
    11.6 -    Copyright   2013
    11.7 -
    11.8 -Miscellaneous primitive recursive function definitions.
    11.9 -*)
   11.10 -
   11.11 -header {* Miscellaneous Primitive Recursive Function Definitions *}
   11.12 -
   11.13 -theory Misc_Primrec
   11.14 -imports Misc_Datatype
   11.15 -begin
   11.16 -
   11.17 -primrec_new nat_of_simple :: "simple \<Rightarrow> nat" where
   11.18 -  "nat_of_simple X1 = 1" |
   11.19 -  "nat_of_simple X2 = 2" |
   11.20 -  "nat_of_simple X3 = 3" |
   11.21 -  "nat_of_simple X4 = 4"
   11.22 -
   11.23 -primrec_new simple_of_simple' :: "simple' \<Rightarrow> simple" where
   11.24 -  "simple_of_simple' (X1' _) = X1" |
   11.25 -  "simple_of_simple' (X2' _) = X2" |
   11.26 -  "simple_of_simple' (X3' _) = X3" |
   11.27 -  "simple_of_simple' (X4' _) = X4"
   11.28 -
   11.29 -primrec_new inc_simple'' :: "nat \<Rightarrow> simple'' \<Rightarrow> simple''" where
   11.30 -  "inc_simple'' k (X1'' n i) = X1'' (n + k) (i + int k)" |
   11.31 -  "inc_simple'' _ X2'' = X2''"
   11.32 -
   11.33 -primrec_new myapp :: "'a mylist \<Rightarrow> 'a mylist \<Rightarrow> 'a mylist" where
   11.34 -  "myapp MyNil ys = ys" |
   11.35 -  "myapp (MyCons x xs) ys = MyCons x (myapp xs ys)"
   11.36 -
   11.37 -primrec_new myrev :: "'a mylist \<Rightarrow> 'a mylist" where
   11.38 -  "myrev MyNil = MyNil" |
   11.39 -  "myrev (MyCons x xs) = myapp (myrev xs) (MyCons x MyNil)"
   11.40 -
   11.41 -primrec_new shuffle_sp :: "('a, 'b, 'c, 'd) some_passive \<Rightarrow> ('d, 'a, 'b, 'c) some_passive" where
   11.42 -  "shuffle_sp (SP1 sp) = SP1 (shuffle_sp sp)" |
   11.43 -  "shuffle_sp (SP2 a) = SP3 a" |
   11.44 -  "shuffle_sp (SP3 b) = SP4 b" |
   11.45 -  "shuffle_sp (SP4 c) = SP5 c" |
   11.46 -  "shuffle_sp (SP5 d) = SP2 d"
   11.47 -
   11.48 -primrec_new
   11.49 -  hf_size :: "hfset \<Rightarrow> nat"
   11.50 -where
   11.51 -  "hf_size (HFset X) = 1 + setsum id (fset (fimage hf_size X))"
   11.52 -
   11.53 -primrec_new rename_lam :: "(string \<Rightarrow> string) \<Rightarrow> lambda \<Rightarrow> lambda" where
   11.54 -  "rename_lam f (Var s) = Var (f s)" |
   11.55 -  "rename_lam f (App l l') = App (rename_lam f l) (rename_lam f l')" |
   11.56 -  "rename_lam f (Abs s l) = Abs (f s) (rename_lam f l)" |
   11.57 -  "rename_lam f (Let SL l) = Let (fimage (map_pair f (rename_lam f)) SL) (rename_lam f l)"
   11.58 -
   11.59 -primrec_new
   11.60 -  sum_i1 :: "('a\<Colon>{zero,plus}) I1 \<Rightarrow> 'a" and
   11.61 -  sum_i2 :: "'a I2 \<Rightarrow> 'a"
   11.62 -where
   11.63 -  "sum_i1 (I11 n i) = n + sum_i1 i" |
   11.64 -  "sum_i1 (I12 n i) = n + sum_i2 i" |
   11.65 -  "sum_i2 I21 = 0" |
   11.66 -  "sum_i2 (I22 i j) = sum_i1 i + sum_i2 j"
   11.67 -
   11.68 -primrec_new forest_of_mylist :: "'a tree mylist \<Rightarrow> 'a forest" where
   11.69 -  "forest_of_mylist MyNil = FNil" |
   11.70 -  "forest_of_mylist (MyCons t ts) = FCons t (forest_of_mylist ts)"
   11.71 -
   11.72 -primrec_new mylist_of_forest :: "'a forest \<Rightarrow> 'a tree mylist" where
   11.73 -  "mylist_of_forest FNil = MyNil" |
   11.74 -  "mylist_of_forest (FCons t ts) = MyCons t (mylist_of_forest ts)"
   11.75 -
   11.76 -definition frev :: "'a forest \<Rightarrow> 'a forest" where
   11.77 -  "frev = forest_of_mylist \<circ> myrev \<circ> mylist_of_forest"
   11.78 -
   11.79 -primrec_new
   11.80 -  mirror_tree :: "'a tree \<Rightarrow> 'a tree" and
   11.81 -  mirror_forest :: "'a forest \<Rightarrow> 'a forest"
   11.82 -where
   11.83 -  "mirror_tree TEmpty = TEmpty" |
   11.84 -  "mirror_tree (TNode x ts) = TNode x (mirror_forest ts)" |
   11.85 -  "mirror_forest FNil = FNil" |
   11.86 -  "mirror_forest (FCons t ts) = frev (FCons (mirror_tree t) (mirror_forest ts))"
   11.87 -
   11.88 -primrec_new
   11.89 -  mylist_of_tree' :: "'a tree' \<Rightarrow> 'a mylist" and
   11.90 -  mylist_of_branch :: "'a branch \<Rightarrow> 'a mylist"
   11.91 -where
   11.92 -  "mylist_of_tree' TEmpty' = MyNil" |
   11.93 -  "mylist_of_tree' (TNode' b b') = myapp (mylist_of_branch b) (mylist_of_branch b')" |
   11.94 -  "mylist_of_branch (Branch x t) = MyCons x (mylist_of_tree' t)"
   11.95 -
   11.96 -primrec_new
   11.97 -  is_ground_exp :: "('a, 'b) exp \<Rightarrow> bool" and
   11.98 -  is_ground_trm :: "('a, 'b) trm \<Rightarrow> bool" and
   11.99 -  is_ground_factor :: "('a, 'b) factor \<Rightarrow> bool"
  11.100 -where
  11.101 -  "is_ground_exp (Term t) \<longleftrightarrow> is_ground_trm t" |
  11.102 -  "is_ground_exp (Sum t e) \<longleftrightarrow> is_ground_trm t \<and> is_ground_exp e" |
  11.103 -  "is_ground_trm (Factor f) \<longleftrightarrow> is_ground_factor f" |
  11.104 -  "is_ground_trm (Prod f t) \<longleftrightarrow> is_ground_factor f \<and> is_ground_trm t" |
  11.105 -  "is_ground_factor (C _) \<longleftrightarrow> True" |
  11.106 -  "is_ground_factor (V _) \<longleftrightarrow> False" |
  11.107 -  "is_ground_factor (Paren e) \<longleftrightarrow> is_ground_exp e"
  11.108 -
  11.109 -primrec_new map_ftreeA :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
  11.110 -  "map_ftreeA f (FTLeaf x) = FTLeaf (f x)" |
  11.111 -  "map_ftreeA f (FTNode g) = FTNode (map_ftreeA f \<circ> g)"
  11.112 -
  11.113 -primrec_new map_ftreeB :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ftree \<Rightarrow> 'b ftree" where
  11.114 -  "map_ftreeB f (FTLeaf x) = FTLeaf (f x)" |
  11.115 -  "map_ftreeB f (FTNode g) = FTNode (map_ftreeB f \<circ> g \<circ> the_inv f)"
  11.116 -
  11.117 -end
    12.1 --- a/src/HOL/BNF/Examples/Process.thy	Mon Jan 20 18:24:56 2014 +0100
    12.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.3 @@ -1,278 +0,0 @@
    12.4 -(*  Title:      HOL/BNF/Examples/Process.thy
    12.5 -    Author:     Andrei Popescu, TU Muenchen
    12.6 -    Copyright   2012
    12.7 -
    12.8 -Processes.
    12.9 -*)
   12.10 -
   12.11 -header {* Processes *}
   12.12 -
   12.13 -theory Process
   12.14 -imports Stream 
   12.15 -begin
   12.16 -
   12.17 -codatatype 'a process =
   12.18 -  isAction: Action (prefOf: 'a) (contOf: "'a process") |
   12.19 -  isChoice: Choice (ch1Of: "'a process") (ch2Of: "'a process")
   12.20 -
   12.21 -(* Read: prefix of, continuation of, choice 1 of, choice 2 of *)
   12.22 -
   12.23 -section {* Customization *}
   12.24 -
   12.25 -subsection {* Basic properties *}
   12.26 -
   12.27 -declare
   12.28 -  rel_pre_process_def[simp]
   12.29 -  sum_rel_def[simp]
   12.30 -  prod_rel_def[simp]
   12.31 -
   12.32 -(* Constructors versus discriminators *)
   12.33 -theorem isAction_isChoice:
   12.34 -"isAction p \<or> isChoice p"
   12.35 -by (rule process.disc_exhaust) auto
   12.36 -
   12.37 -theorem not_isAction_isChoice: "\<not> (isAction p \<and> isChoice p)"
   12.38 -by (cases rule: process.exhaust[of p]) auto
   12.39 -
   12.40 -
   12.41 -subsection{* Coinduction *}
   12.42 -
   12.43 -theorem process_coind[elim, consumes 1, case_names iss Action Choice, induct pred: "HOL.eq"]:
   12.44 -  assumes phi: "\<phi> p p'" and
   12.45 -  iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
   12.46 -  Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> \<phi> p p'" and
   12.47 -  Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> \<phi> p p' \<and> \<phi> q q'"
   12.48 -  shows "p = p'"
   12.49 -  using assms
   12.50 -  by (coinduct rule: process.coinduct) (metis process.collapse(1,2) process.disc(3))
   12.51 -
   12.52 -(* Stronger coinduction, up to equality: *)
   12.53 -theorem process_strong_coind[elim, consumes 1, case_names iss Action Choice]:
   12.54 -  assumes phi: "\<phi> p p'" and
   12.55 -  iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
   12.56 -  Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> (\<phi> p p' \<or> p = p')" and
   12.57 -  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')"
   12.58 -  shows "p = p'"
   12.59 -  using assms
   12.60 -  by (coinduct rule: process.strong_coinduct) (metis process.collapse(1,2) process.disc(3))
   12.61 -
   12.62 -
   12.63 -subsection {* Coiteration (unfold) *}
   12.64 -
   12.65 -
   12.66 -section{* Coinductive definition of the notion of trace *}
   12.67 -coinductive trace where
   12.68 -"trace p as \<Longrightarrow> trace (Action a p) (a ## as)"
   12.69 -|
   12.70 -"trace p as \<or> trace q as \<Longrightarrow> trace (Choice p q) as"
   12.71 -
   12.72 -
   12.73 -section{* Examples of corecursive definitions: *}
   12.74 -
   12.75 -subsection{* Single-guard fixpoint definition *}
   12.76 -
   12.77 -primcorec BX where
   12.78 -  "isAction BX"
   12.79 -| "prefOf BX = ''a''"
   12.80 -| "contOf BX = BX"
   12.81 -
   12.82 -
   12.83 -subsection{* Multi-guard fixpoint definitions, simulated with auxiliary arguments *}
   12.84 -
   12.85 -datatype x_y_ax = x | y | ax
   12.86 -
   12.87 -primcorec F :: "x_y_ax \<Rightarrow> char list process" where
   12.88 -  "xyax = x \<Longrightarrow> isChoice (F xyax)"
   12.89 -| "ch1Of (F xyax) = F ax"
   12.90 -| "ch2Of (F xyax) = F y"
   12.91 -| "prefOf (F xyax) = (if xyax = y then ''b'' else ''a'')"
   12.92 -| "contOf (F xyax) = F x"
   12.93 -
   12.94 -definition "X = F x"  definition "Y = F y"  definition "AX = F ax"
   12.95 -
   12.96 -lemma X_Y_AX: "X = Choice AX Y"  "Y = Action ''b'' X"  "AX = Action ''a'' X"
   12.97 -unfolding X_def Y_def AX_def by (subst F.code, simp)+
   12.98 -
   12.99 -(* end product: *)
  12.100 -lemma X_AX:
  12.101 -"X = Choice AX (Action ''b'' X)"
  12.102 -"AX = Action ''a'' X"
  12.103 -using X_Y_AX by simp_all
  12.104 -
  12.105 -
  12.106 -
  12.107 -section{* Case study: Multi-guard fixpoint definitions, without auxiliary arguments *}
  12.108 -
  12.109 -hide_const x y ax X Y AX
  12.110 -
  12.111 -(* Process terms *)
  12.112 -datatype ('a,'pvar) process_term =
  12.113 - VAR 'pvar |
  12.114 - PROC "'a process" |
  12.115 - ACT 'a "('a,'pvar) process_term" | CH "('a,'pvar) process_term" "('a,'pvar) process_term"
  12.116 -
  12.117 -(* below, sys represents a system of equations *)
  12.118 -fun isACT where
  12.119 -"isACT sys (VAR X) =
  12.120 - (case sys X of ACT a T \<Rightarrow> True |PROC p \<Rightarrow> isAction p |_ \<Rightarrow> False)"
  12.121 -|
  12.122 -"isACT sys (PROC p) = isAction p"
  12.123 -|
  12.124 -"isACT sys (ACT a T) = True"
  12.125 -|
  12.126 -"isACT sys (CH T1 T2) = False"
  12.127 -
  12.128 -fun PREF where
  12.129 -"PREF sys (VAR X) =
  12.130 - (case sys X of ACT a T \<Rightarrow> a | PROC p \<Rightarrow> prefOf p)"
  12.131 -|
  12.132 -"PREF sys (PROC p) = prefOf p"
  12.133 -|
  12.134 -"PREF sys (ACT a T) = a"
  12.135 -
  12.136 -fun CONT where
  12.137 -"CONT sys (VAR X) =
  12.138 - (case sys X of ACT a T \<Rightarrow> T | PROC p \<Rightarrow> PROC (contOf p))"
  12.139 -|
  12.140 -"CONT sys (PROC p) = PROC (contOf p)"
  12.141 -|
  12.142 -"CONT sys (ACT a T) = T"
  12.143 -
  12.144 -fun CH1 where
  12.145 -"CH1 sys (VAR X) =
  12.146 - (case sys X of CH T1 T2 \<Rightarrow> T1 |PROC p \<Rightarrow> PROC (ch1Of p))"
  12.147 -|
  12.148 -"CH1 sys (PROC p) = PROC (ch1Of p)"
  12.149 -|
  12.150 -"CH1 sys (CH T1 T2) = T1"
  12.151 -
  12.152 -fun CH2 where
  12.153 -"CH2 sys (VAR X) =
  12.154 - (case sys X of CH T1 T2 \<Rightarrow> T2 |PROC p \<Rightarrow> PROC (ch2Of p))"
  12.155 -|
  12.156 -"CH2 sys (PROC p) = PROC (ch2Of p)"
  12.157 -|
  12.158 -"CH2 sys (CH T1 T2) = T2"
  12.159 -
  12.160 -definition "guarded sys \<equiv> \<forall> X Y. sys X \<noteq> VAR Y"
  12.161 -
  12.162 -primcorec solution where
  12.163 -  "isACT sys T \<Longrightarrow> solution sys T = Action (PREF sys T) (solution sys (CONT sys T))"
  12.164 -| "_ \<Longrightarrow> solution sys T = Choice (solution sys (CH1 sys T)) (solution sys (CH2 sys T))"
  12.165 -
  12.166 -lemma isACT_VAR:
  12.167 -assumes g: "guarded sys"
  12.168 -shows "isACT sys (VAR X) \<longleftrightarrow> isACT sys (sys X)"
  12.169 -using g unfolding guarded_def by (cases "sys X") auto
  12.170 -
  12.171 -lemma solution_VAR:
  12.172 -assumes g: "guarded sys"
  12.173 -shows "solution sys (VAR X) = solution sys (sys X)"
  12.174 -proof(cases "isACT sys (VAR X)")
  12.175 -  case True
  12.176 -  hence T: "isACT sys (sys X)" unfolding isACT_VAR[OF g] .
  12.177 -  show ?thesis
  12.178 -  unfolding solution.ctr(1)[OF T] using solution.ctr(1)[of sys "VAR X"] True g
  12.179 -  unfolding guarded_def by (cases "sys X", auto)
  12.180 -next
  12.181 -  case False note FFalse = False
  12.182 -  hence TT: "\<not> isACT sys (sys X)" unfolding isACT_VAR[OF g] .
  12.183 -  show ?thesis
  12.184 -  unfolding solution.ctr(2)[OF TT] using solution.ctr(2)[of sys "VAR X"] FFalse g
  12.185 -  unfolding guarded_def by (cases "sys X", auto)
  12.186 -qed
  12.187 -
  12.188 -lemma solution_PROC[simp]:
  12.189 -"solution sys (PROC p) = p"
  12.190 -proof-
  12.191 -  {fix q assume "q = solution sys (PROC p)"
  12.192 -   hence "p = q"
  12.193 -   proof (coinduct rule: process_coind)
  12.194 -     case (iss p p')
  12.195 -     from isAction_isChoice[of p] show ?case
  12.196 -     proof
  12.197 -       assume p: "isAction p"
  12.198 -       hence 0: "isACT sys (PROC p)" by simp
  12.199 -       thus ?thesis using iss not_isAction_isChoice by auto
  12.200 -     next
  12.201 -       assume "isChoice p"
  12.202 -       hence 0: "\<not> isACT sys (PROC p)"
  12.203 -       using not_isAction_isChoice by auto
  12.204 -       thus ?thesis using iss isAction_isChoice by auto
  12.205 -     qed
  12.206 -   next
  12.207 -     case (Action a a' p p')
  12.208 -     hence 0: "isACT sys (PROC (Action a p))" by simp
  12.209 -     show ?case using Action unfolding solution.ctr(1)[OF 0] by simp
  12.210 -   next
  12.211 -     case (Choice p q p' q')
  12.212 -     hence 0: "\<not> isACT sys (PROC (Choice p q))" using not_isAction_isChoice by auto
  12.213 -     show ?case using Choice unfolding solution.ctr(2)[OF 0] by simp
  12.214 -   qed
  12.215 -  }
  12.216 -  thus ?thesis by metis
  12.217 -qed
  12.218 -
  12.219 -lemma solution_ACT[simp]:
  12.220 -"solution sys (ACT a T) = Action a (solution sys T)"
  12.221 -by (metis CONT.simps(3) PREF.simps(3) isACT.simps(3) solution.ctr(1))
  12.222 -
  12.223 -lemma solution_CH[simp]:
  12.224 -"solution sys (CH T1 T2) = Choice (solution sys T1) (solution sys T2)"
  12.225 -by (metis CH1.simps(3) CH2.simps(3) isACT.simps(4) solution.ctr(2))
  12.226 -
  12.227 -
  12.228 -(* Example: *)
  12.229 -
  12.230 -fun sys where
  12.231 -"sys 0 = CH (VAR (Suc 0)) (ACT ''b'' (VAR 0))"
  12.232 -|
  12.233 -"sys (Suc 0) = ACT ''a'' (VAR 0)"
  12.234 -| (* dummy guarded term for variables outside the system: *)
  12.235 -"sys X = ACT ''a'' (VAR 0)"
  12.236 -
  12.237 -lemma guarded_sys:
  12.238 -"guarded sys"
  12.239 -unfolding guarded_def proof (intro allI)
  12.240 -  fix X Y show "sys X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
  12.241 -qed
  12.242 -
  12.243 -(* the actual processes: *)
  12.244 -definition "x \<equiv> solution sys (VAR 0)"
  12.245 -definition "ax \<equiv> solution sys (VAR (Suc 0))"
  12.246 -
  12.247 -(* end product: *)
  12.248 -lemma x_ax:
  12.249 -"x = Choice ax (Action ''b'' x)"
  12.250 -"ax = Action ''a'' x"
  12.251 -unfolding x_def ax_def by (subst solution_VAR[OF guarded_sys], simp)+
  12.252 -
  12.253 -
  12.254 -(* Thanks to the inclusion of processes as process terms, one can
  12.255 -also consider parametrized systems of equations---here, x is a (semantic)
  12.256 -process parameter: *)
  12.257 -
  12.258 -fun sys' where
  12.259 -"sys' 0 = CH (PROC x) (ACT ''b'' (VAR 0))"
  12.260 -|
  12.261 -"sys' (Suc 0) = CH (ACT ''a'' (VAR 0)) (PROC x)"
  12.262 -| (* dummy guarded term : *)
  12.263 -"sys' X = ACT ''a'' (VAR 0)"
  12.264 -
  12.265 -lemma guarded_sys':
  12.266 -"guarded sys'"
  12.267 -unfolding guarded_def proof (intro allI)
  12.268 -  fix X Y show "sys' X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
  12.269 -qed
  12.270 -
  12.271 -(* the actual processes: *)
  12.272 -definition "y \<equiv> solution sys' (VAR 0)"
  12.273 -definition "ay \<equiv> solution sys' (VAR (Suc 0))"
  12.274 -
  12.275 -(* end product: *)
  12.276 -lemma y_ay:
  12.277 -"y = Choice x (Action ''b'' y)"
  12.278 -"ay = Choice (Action ''a'' y) x"
  12.279 -unfolding y_def ay_def by (subst solution_VAR[OF guarded_sys'], simp)+
  12.280 -
  12.281 -end
    13.1 --- a/src/HOL/BNF/Examples/Stream.thy	Mon Jan 20 18:24:56 2014 +0100
    13.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.3 @@ -1,526 +0,0 @@
    13.4 -(*  Title:      HOL/BNF/Examples/Stream.thy
    13.5 -    Author:     Dmitriy Traytel, TU Muenchen
    13.6 -    Author:     Andrei Popescu, TU Muenchen
    13.7 -    Copyright   2012, 2013
    13.8 -
    13.9 -Infinite streams.
   13.10 -*)
   13.11 -
   13.12 -header {* Infinite Streams *}
   13.13 -
   13.14 -theory Stream
   13.15 -imports "~~/Library/Nat_Bijection"
   13.16 -begin
   13.17 -
   13.18 -codatatype (sset: 'a) stream (map: smap rel: stream_all2) =
   13.19 -  SCons (shd: 'a) (stl: "'a stream") (infixr "##" 65)
   13.20 -
   13.21 -(*for code generation only*)
   13.22 -definition smember :: "'a \<Rightarrow> 'a stream \<Rightarrow> bool" where
   13.23 -  [code_abbrev]: "smember x s \<longleftrightarrow> x \<in> sset s"
   13.24 -
   13.25 -lemma smember_code[code, simp]: "smember x (y ## s) = (if x = y then True else smember x s)"
   13.26 -  unfolding smember_def by auto
   13.27 -
   13.28 -hide_const (open) smember
   13.29 -
   13.30 -(* TODO: Provide by the package*)
   13.31 -theorem sset_induct:
   13.32 -  "\<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>
   13.33 -    \<forall>y \<in> sset s. P y s"
   13.34 -  apply (rule stream.dtor_set_induct)
   13.35 -  apply (auto simp add: shd_def stl_def fsts_def snds_def split_beta)
   13.36 -  apply (metis SCons_def fst_conv stream.case stream.dtor_ctor stream.exhaust)
   13.37 -  by (metis SCons_def sndI stl_def stream.collapse stream.dtor_ctor)
   13.38 -
   13.39 -lemma smap_simps[simp]:
   13.40 -  "shd (smap f s) = f (shd s)" "stl (smap f s) = smap f (stl s)"
   13.41 -  by (case_tac [!] s) auto
   13.42 -
   13.43 -theorem shd_sset: "shd s \<in> sset s"
   13.44 -  by (case_tac s) auto
   13.45 -
   13.46 -theorem stl_sset: "y \<in> sset (stl s) \<Longrightarrow> y \<in> sset s"
   13.47 -  by (case_tac s) auto
   13.48 -
   13.49 -(* only for the non-mutual case: *)
   13.50 -theorem sset_induct1[consumes 1, case_names shd stl, induct set: "sset"]:
   13.51 -  assumes "y \<in> sset s" and "\<And>s. P (shd s) s"
   13.52 -  and "\<And>s y. \<lbrakk>y \<in> sset (stl s); P y (stl s)\<rbrakk> \<Longrightarrow> P y s"
   13.53 -  shows "P y s"
   13.54 -  using assms sset_induct by blast
   13.55 -(* end TODO *)
   13.56 -
   13.57 -
   13.58 -subsection {* prepend list to stream *}
   13.59 -
   13.60 -primrec shift :: "'a list \<Rightarrow> 'a stream \<Rightarrow> 'a stream" (infixr "@-" 65) where
   13.61 -  "shift [] s = s"
   13.62 -| "shift (x # xs) s = x ## shift xs s"
   13.63 -
   13.64 -lemma smap_shift[simp]: "smap f (xs @- s) = map f xs @- smap f s"
   13.65 -  by (induct xs) auto
   13.66 -
   13.67 -lemma shift_append[simp]: "(xs @ ys) @- s = xs @- ys @- s"
   13.68 -  by (induct xs) auto
   13.69 -
   13.70 -lemma shift_simps[simp]:
   13.71 -   "shd (xs @- s) = (if xs = [] then shd s else hd xs)"
   13.72 -   "stl (xs @- s) = (if xs = [] then stl s else tl xs @- s)"
   13.73 -  by (induct xs) auto
   13.74 -
   13.75 -lemma sset_shift[simp]: "sset (xs @- s) = set xs \<union> sset s"
   13.76 -  by (induct xs) auto
   13.77 -
   13.78 -lemma shift_left_inj[simp]: "xs @- s1 = xs @- s2 \<longleftrightarrow> s1 = s2"
   13.79 -  by (induct xs) auto
   13.80 -
   13.81 -
   13.82 -subsection {* set of streams with elements in some fixed set *}
   13.83 -
   13.84 -coinductive_set
   13.85 -  streams :: "'a set \<Rightarrow> 'a stream set"
   13.86 -  for A :: "'a set"
   13.87 -where
   13.88 -  Stream[intro!, simp, no_atp]: "\<lbrakk>a \<in> A; s \<in> streams A\<rbrakk> \<Longrightarrow> a ## s \<in> streams A"
   13.89 -
   13.90 -lemma shift_streams: "\<lbrakk>w \<in> lists A; s \<in> streams A\<rbrakk> \<Longrightarrow> w @- s \<in> streams A"
   13.91 -  by (induct w) auto
   13.92 -
   13.93 -lemma streams_Stream: "x ## s \<in> streams A \<longleftrightarrow> x \<in> A \<and> s \<in> streams A"
   13.94 -  by (auto elim: streams.cases)
   13.95 -
   13.96 -lemma streams_stl: "s \<in> streams A \<Longrightarrow> stl s \<in> streams A"
   13.97 -  by (cases s) (auto simp: streams_Stream)
   13.98 -
   13.99 -lemma streams_shd: "s \<in> streams A \<Longrightarrow> shd s \<in> A"
  13.100 -  by (cases s) (auto simp: streams_Stream)
  13.101 -
  13.102 -lemma sset_streams:
  13.103 -  assumes "sset s \<subseteq> A"
  13.104 -  shows "s \<in> streams A"
  13.105 -using assms proof (coinduction arbitrary: s)
  13.106 -  case streams then show ?case by (cases s) simp
  13.107 -qed
  13.108 -
  13.109 -lemma streams_sset:
  13.110 -  assumes "s \<in> streams A"
  13.111 -  shows "sset s \<subseteq> A"
  13.112 -proof
  13.113 -  fix x assume "x \<in> sset s" from this `s \<in> streams A` show "x \<in> A"
  13.114 -    by (induct s) (auto intro: streams_shd streams_stl)
  13.115 -qed
  13.116 -
  13.117 -lemma streams_iff_sset: "s \<in> streams A \<longleftrightarrow> sset s \<subseteq> A"
  13.118 -  by (metis sset_streams streams_sset)
  13.119 -
  13.120 -lemma streams_mono:  "s \<in> streams A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> s \<in> streams B"
  13.121 -  unfolding streams_iff_sset by auto
  13.122 -
  13.123 -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"
  13.124 -  unfolding streams_iff_sset stream.set_map by auto
  13.125 -
  13.126 -lemma streams_empty: "streams {} = {}"
  13.127 -  by (auto elim: streams.cases)
  13.128 -
  13.129 -lemma streams_UNIV[simp]: "streams UNIV = UNIV"
  13.130 -  by (auto simp: streams_iff_sset)
  13.131 -
  13.132 -subsection {* nth, take, drop for streams *}
  13.133 -
  13.134 -primrec snth :: "'a stream \<Rightarrow> nat \<Rightarrow> 'a" (infixl "!!" 100) where
  13.135 -  "s !! 0 = shd s"
  13.136 -| "s !! Suc n = stl s !! n"
  13.137 -
  13.138 -lemma snth_smap[simp]: "smap f s !! n = f (s !! n)"
  13.139 -  by (induct n arbitrary: s) auto
  13.140 -
  13.141 -lemma shift_snth_less[simp]: "p < length xs \<Longrightarrow> (xs @- s) !! p = xs ! p"
  13.142 -  by (induct p arbitrary: xs) (auto simp: hd_conv_nth nth_tl)
  13.143 -
  13.144 -lemma shift_snth_ge[simp]: "p \<ge> length xs \<Longrightarrow> (xs @- s) !! p = s !! (p - length xs)"
  13.145 -  by (induct p arbitrary: xs) (auto simp: Suc_diff_eq_diff_pred)
  13.146 -
  13.147 -lemma snth_sset[simp]: "s !! n \<in> sset s"
  13.148 -  by (induct n arbitrary: s) (auto intro: shd_sset stl_sset)
  13.149 -
  13.150 -lemma sset_range: "sset s = range (snth s)"
  13.151 -proof (intro equalityI subsetI)
  13.152 -  fix x assume "x \<in> sset s"
  13.153 -  thus "x \<in> range (snth s)"
  13.154 -  proof (induct s)
  13.155 -    case (stl s x)
  13.156 -    then obtain n where "x = stl s !! n" by auto
  13.157 -    thus ?case by (auto intro: range_eqI[of _ _ "Suc n"])
  13.158 -  qed (auto intro: range_eqI[of _ _ 0])
  13.159 -qed auto
  13.160 -
  13.161 -primrec stake :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a list" where
  13.162 -  "stake 0 s = []"
  13.163 -| "stake (Suc n) s = shd s # stake n (stl s)"
  13.164 -
  13.165 -lemma length_stake[simp]: "length (stake n s) = n"
  13.166 -  by (induct n arbitrary: s) auto
  13.167 -
  13.168 -lemma stake_smap[simp]: "stake n (smap f s) = map f (stake n s)"
  13.169 -  by (induct n arbitrary: s) auto
  13.170 -
  13.171 -primrec sdrop :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
  13.172 -  "sdrop 0 s = s"
  13.173 -| "sdrop (Suc n) s = sdrop n (stl s)"
  13.174 -
  13.175 -lemma sdrop_simps[simp]:
  13.176 -  "shd (sdrop n s) = s !! n" "stl (sdrop n s) = sdrop (Suc n) s"
  13.177 -  by (induct n arbitrary: s)  auto
  13.178 -
  13.179 -lemma sdrop_smap[simp]: "sdrop n (smap f s) = smap f (sdrop n s)"
  13.180 -  by (induct n arbitrary: s) auto
  13.181 -
  13.182 -lemma sdrop_stl: "sdrop n (stl s) = stl (sdrop n s)"
  13.183 -  by (induct n) auto
  13.184 -
  13.185 -lemma stake_sdrop: "stake n s @- sdrop n s = s"
  13.186 -  by (induct n arbitrary: s) auto
  13.187 -
  13.188 -lemma id_stake_snth_sdrop:
  13.189 -  "s = stake i s @- s !! i ## sdrop (Suc i) s"
  13.190 -  by (subst stake_sdrop[symmetric, of _ i]) (metis sdrop_simps stream.collapse)
  13.191 -
  13.192 -lemma smap_alt: "smap f s = s' \<longleftrightarrow> (\<forall>n. f (s !! n) = s' !! n)" (is "?L = ?R")
  13.193 -proof
  13.194 -  assume ?R
  13.195 -  then have "\<And>n. smap f (sdrop n s) = sdrop n s'"
  13.196 -    by coinduction (auto intro: exI[of _ 0] simp del: sdrop.simps(2))
  13.197 -  then show ?L using sdrop.simps(1) by metis
  13.198 -qed auto
  13.199 -
  13.200 -lemma stake_invert_Nil[iff]: "stake n s = [] \<longleftrightarrow> n = 0"
  13.201 -  by (induct n) auto
  13.202 -
  13.203 -lemma sdrop_shift: "\<lbrakk>s = w @- s'; length w = n\<rbrakk> \<Longrightarrow> sdrop n s = s'"
  13.204 -  by (induct n arbitrary: w s) auto
  13.205 -
  13.206 -lemma stake_shift: "\<lbrakk>s = w @- s'; length w = n\<rbrakk> \<Longrightarrow> stake n s = w"
  13.207 -  by (induct n arbitrary: w s) auto
  13.208 -
  13.209 -lemma stake_add[simp]: "stake m s @ stake n (sdrop m s) = stake (m + n) s"
  13.210 -  by (induct m arbitrary: s) auto
  13.211 -
  13.212 -lemma sdrop_add[simp]: "sdrop n (sdrop m s) = sdrop (m + n) s"
  13.213 -  by (induct m arbitrary: s) auto
  13.214 -
  13.215 -partial_function (tailrec) sdrop_while :: "('a \<Rightarrow> bool) \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where 
  13.216 -  "sdrop_while P s = (if P (shd s) then sdrop_while P (stl s) else s)"
  13.217 -
  13.218 -lemma sdrop_while_SCons[code]:
  13.219 -  "sdrop_while P (a ## s) = (if P a then sdrop_while P s else a ## s)"
  13.220 -  by (subst sdrop_while.simps) simp
  13.221 -
  13.222 -lemma sdrop_while_sdrop_LEAST:
  13.223 -  assumes "\<exists>n. P (s !! n)"
  13.224 -  shows "sdrop_while (Not o P) s = sdrop (LEAST n. P (s !! n)) s"
  13.225 -proof -
  13.226 -  from assms obtain m where "P (s !! m)" "\<And>n. P (s !! n) \<Longrightarrow> m \<le> n"
  13.227 -    and *: "(LEAST n. P (s !! n)) = m" by atomize_elim (auto intro: LeastI Least_le)
  13.228 -  thus ?thesis unfolding *
  13.229 -  proof (induct m arbitrary: s)
  13.230 -    case (Suc m)
  13.231 -    hence "sdrop_while (Not \<circ> P) (stl s) = sdrop m (stl s)"
  13.232 -      by (metis (full_types) not_less_eq_eq snth.simps(2))
  13.233 -    moreover from Suc(3) have "\<not> (P (s !! 0))" by blast
  13.234 -    ultimately show ?case by (subst sdrop_while.simps) simp
  13.235 -  qed (metis comp_apply sdrop.simps(1) sdrop_while.simps snth.simps(1))
  13.236 -qed
  13.237 -
  13.238 -primcorec sfilter where
  13.239 -  "shd (sfilter P s) = shd (sdrop_while (Not o P) s)"
  13.240 -| "stl (sfilter P s) = sfilter P (stl (sdrop_while (Not o P) s))"
  13.241 -
  13.242 -lemma sfilter_Stream: "sfilter P (x ## s) = (if P x then x ## sfilter P s else sfilter P s)"
  13.243 -proof (cases "P x")
  13.244 -  case True thus ?thesis by (subst sfilter.ctr) (simp add: sdrop_while_SCons)
  13.245 -next
  13.246 -  case False thus ?thesis by (subst (1 2) sfilter.ctr) (simp add: sdrop_while_SCons)
  13.247 -qed
  13.248 -
  13.249 -
  13.250 -subsection {* unary predicates lifted to streams *}
  13.251 -
  13.252 -definition "stream_all P s = (\<forall>p. P (s !! p))"
  13.253 -
  13.254 -lemma stream_all_iff[iff]: "stream_all P s \<longleftrightarrow> Ball (sset s) P"
  13.255 -  unfolding stream_all_def sset_range by auto
  13.256 -
  13.257 -lemma stream_all_shift[simp]: "stream_all P (xs @- s) = (list_all P xs \<and> stream_all P s)"
  13.258 -  unfolding stream_all_iff list_all_iff by auto
  13.259 -
  13.260 -lemma stream_all_Stream: "stream_all P (x ## X) \<longleftrightarrow> P x \<and> stream_all P X"
  13.261 -  by simp
  13.262 -
  13.263 -
  13.264 -subsection {* recurring stream out of a list *}
  13.265 -
  13.266 -primcorec cycle :: "'a list \<Rightarrow> 'a stream" where
  13.267 -  "shd (cycle xs) = hd xs"
  13.268 -| "stl (cycle xs) = cycle (tl xs @ [hd xs])"
  13.269 -
  13.270 -lemma cycle_decomp: "u \<noteq> [] \<Longrightarrow> cycle u = u @- cycle u"
  13.271 -proof (coinduction arbitrary: u)
  13.272 -  case Eq_stream then show ?case using stream.collapse[of "cycle u"]
  13.273 -    by (auto intro!: exI[of _ "tl u @ [hd u]"])
  13.274 -qed
  13.275 -
  13.276 -lemma cycle_Cons[code]: "cycle (x # xs) = x ## cycle (xs @ [x])"
  13.277 -  by (subst cycle.ctr) simp
  13.278 -
  13.279 -lemma cycle_rotated: "\<lbrakk>v \<noteq> []; cycle u = v @- s\<rbrakk> \<Longrightarrow> cycle (tl u @ [hd u]) = tl v @- s"
  13.280 -  by (auto dest: arg_cong[of _ _ stl])
  13.281 -
  13.282 -lemma stake_append: "stake n (u @- s) = take (min (length u) n) u @ stake (n - length u) s"
  13.283 -proof (induct n arbitrary: u)
  13.284 -  case (Suc n) thus ?case by (cases u) auto
  13.285 -qed auto
  13.286 -
  13.287 -lemma stake_cycle_le[simp]:
  13.288 -  assumes "u \<noteq> []" "n < length u"
  13.289 -  shows "stake n (cycle u) = take n u"
  13.290 -using min_absorb2[OF less_imp_le_nat[OF assms(2)]]
  13.291 -  by (subst cycle_decomp[OF assms(1)], subst stake_append) auto
  13.292 -
  13.293 -lemma stake_cycle_eq[simp]: "u \<noteq> [] \<Longrightarrow> stake (length u) (cycle u) = u"
  13.294 -  by (metis cycle_decomp stake_shift)
  13.295 -
  13.296 -lemma sdrop_cycle_eq[simp]: "u \<noteq> [] \<Longrightarrow> sdrop (length u) (cycle u) = cycle u"
  13.297 -  by (metis cycle_decomp sdrop_shift)
  13.298 -
  13.299 -lemma stake_cycle_eq_mod_0[simp]: "\<lbrakk>u \<noteq> []; n mod length u = 0\<rbrakk> \<Longrightarrow>
  13.300 -   stake n (cycle u) = concat (replicate (n div length u) u)"
  13.301 -  by (induct "n div length u" arbitrary: n u) (auto simp: stake_add[symmetric])
  13.302 -
  13.303 -lemma sdrop_cycle_eq_mod_0[simp]: "\<lbrakk>u \<noteq> []; n mod length u = 0\<rbrakk> \<Longrightarrow>
  13.304 -   sdrop n (cycle u) = cycle u"
  13.305 -  by (induct "n div length u" arbitrary: n u) (auto simp: sdrop_add[symmetric])
  13.306 -
  13.307 -lemma stake_cycle: "u \<noteq> [] \<Longrightarrow>
  13.308 -   stake n (cycle u) = concat (replicate (n div length u) u) @ take (n mod length u) u"
  13.309 -  by (subst mod_div_equality[of n "length u", symmetric], unfold stake_add[symmetric]) auto
  13.310 -
  13.311 -lemma sdrop_cycle: "u \<noteq> [] \<Longrightarrow> sdrop n (cycle u) = cycle (rotate (n mod length u) u)"
  13.312 -  by (induct n arbitrary: u) (auto simp: rotate1_rotate_swap rotate1_hd_tl rotate_conv_mod[symmetric])
  13.313 -
  13.314 -
  13.315 -subsection {* iterated application of a function *}
  13.316 -
  13.317 -primcorec siterate where
  13.318 -  "shd (siterate f x) = x"
  13.319 -| "stl (siterate f x) = siterate f (f x)"
  13.320 -
  13.321 -lemma stake_Suc: "stake (Suc n) s = stake n s @ [s !! n]"
  13.322 -  by (induct n arbitrary: s) auto
  13.323 -
  13.324 -lemma snth_siterate[simp]: "siterate f x !! n = (f^^n) x"
  13.325 -  by (induct n arbitrary: x) (auto simp: funpow_swap1)
  13.326 -
  13.327 -lemma sdrop_siterate[simp]: "sdrop n (siterate f x) = siterate f ((f^^n) x)"
  13.328 -  by (induct n arbitrary: x) (auto simp: funpow_swap1)
  13.329 -
  13.330 -lemma stake_siterate[simp]: "stake n (siterate f x) = map (\<lambda>n. (f^^n) x) [0 ..< n]"
  13.331 -  by (induct n arbitrary: x) (auto simp del: stake.simps(2) simp: stake_Suc)
  13.332 -
  13.333 -lemma sset_siterate: "sset (siterate f x) = {(f^^n) x | n. True}"
  13.334 -  by (auto simp: sset_range)
  13.335 -
  13.336 -lemma smap_siterate: "smap f (siterate f x) = siterate f (f x)"
  13.337 -  by (coinduction arbitrary: x) auto
  13.338 -
  13.339 -
  13.340 -subsection {* stream repeating a single element *}
  13.341 -
  13.342 -abbreviation "sconst \<equiv> siterate id"
  13.343 -
  13.344 -lemma shift_replicate_sconst[simp]: "replicate n x @- sconst x = sconst x"
  13.345 -  by (subst (3) stake_sdrop[symmetric]) (simp add: map_replicate_trivial)
  13.346 -
  13.347 -lemma stream_all_same[simp]: "sset (sconst x) = {x}"
  13.348 -  by (simp add: sset_siterate)
  13.349 -
  13.350 -lemma same_cycle: "sconst x = cycle [x]"
  13.351 -  by coinduction auto
  13.352 -
  13.353 -lemma smap_sconst: "smap f (sconst x) = sconst (f x)"
  13.354 -  by coinduction auto
  13.355 -
  13.356 -lemma sconst_streams: "x \<in> A \<Longrightarrow> sconst x \<in> streams A"
  13.357 -  by (simp add: streams_iff_sset)
  13.358 -
  13.359 -
  13.360 -subsection {* stream of natural numbers *}
  13.361 -
  13.362 -abbreviation "fromN \<equiv> siterate Suc"
  13.363 -
  13.364 -abbreviation "nats \<equiv> fromN 0"
  13.365 -
  13.366 -lemma sset_fromN[simp]: "sset (fromN n) = {n ..}"
  13.367 -  by (auto simp add: sset_siterate le_iff_add)
  13.368 -
  13.369 -
  13.370 -subsection {* flatten a stream of lists *}
  13.371 -
  13.372 -primcorec flat where
  13.373 -  "shd (flat ws) = hd (shd ws)"
  13.374 -| "stl (flat ws) = flat (if tl (shd ws) = [] then stl ws else tl (shd ws) ## stl ws)"
  13.375 -
  13.376 -lemma flat_Cons[simp, code]: "flat ((x # xs) ## ws) = x ## flat (if xs = [] then ws else xs ## ws)"
  13.377 -  by (subst flat.ctr) simp
  13.378 -
  13.379 -lemma flat_Stream[simp]: "xs \<noteq> [] \<Longrightarrow> flat (xs ## ws) = xs @- flat ws"
  13.380 -  by (induct xs) auto
  13.381 -
  13.382 -lemma flat_unfold: "shd ws \<noteq> [] \<Longrightarrow> flat ws = shd ws @- flat (stl ws)"
  13.383 -  by (cases ws) auto
  13.384 -
  13.385 -lemma flat_snth: "\<forall>xs \<in> sset s. xs \<noteq> [] \<Longrightarrow> flat s !! n = (if n < length (shd s) then 
  13.386 -  shd s ! n else flat (stl s) !! (n - length (shd s)))"
  13.387 -  by (metis flat_unfold not_less shd_sset shift_snth_ge shift_snth_less)
  13.388 -
  13.389 -lemma sset_flat[simp]: "\<forall>xs \<in> sset s. xs \<noteq> [] \<Longrightarrow> 
  13.390 -  sset (flat s) = (\<Union>xs \<in> sset s. set xs)" (is "?P \<Longrightarrow> ?L = ?R")
  13.391 -proof safe
  13.392 -  fix x assume ?P "x : ?L"
  13.393 -  then obtain m where "x = flat s !! m" by (metis image_iff sset_range)
  13.394 -  with `?P` obtain n m' where "x = s !! n ! m'" "m' < length (s !! n)"
  13.395 -  proof (atomize_elim, induct m arbitrary: s rule: less_induct)
  13.396 -    case (less y)
  13.397 -    thus ?case
  13.398 -    proof (cases "y < length (shd s)")
  13.399 -      case True thus ?thesis by (metis flat_snth less(2,3) snth.simps(1))
  13.400 -    next
  13.401 -      case False
  13.402 -      hence "x = flat (stl s) !! (y - length (shd s))" by (metis less(2,3) flat_snth)
  13.403 -      moreover
  13.404 -      { from less(2) have *: "length (shd s) > 0" by (cases s) simp_all
  13.405 -        with False have "y > 0" by (cases y) simp_all
  13.406 -        with * have "y - length (shd s) < y" by simp
  13.407 -      }
  13.408 -      moreover have "\<forall>xs \<in> sset (stl s). xs \<noteq> []" using less(2) by (cases s) auto
  13.409 -      ultimately have "\<exists>n m'. x = stl s !! n ! m' \<and> m' < length (stl s !! n)" by (intro less(1)) auto
  13.410 -      thus ?thesis by (metis snth.simps(2))
  13.411 -    qed
  13.412 -  qed
  13.413 -  thus "x \<in> ?R" by (auto simp: sset_range dest!: nth_mem)
  13.414 -next
  13.415 -  fix x xs assume "xs \<in> sset s" ?P "x \<in> set xs" thus "x \<in> ?L"
  13.416 -    by (induct rule: sset_induct1)
  13.417 -      (metis UnI1 flat_unfold shift.simps(1) sset_shift,
  13.418 -       metis UnI2 flat_unfold shd_sset stl_sset sset_shift)
  13.419 -qed
  13.420 -
  13.421 -
  13.422 -subsection {* merge a stream of streams *}
  13.423 -
  13.424 -definition smerge :: "'a stream stream \<Rightarrow> 'a stream" where
  13.425 -  "smerge ss = flat (smap (\<lambda>n. map (\<lambda>s. s !! n) (stake (Suc n) ss) @ stake n (ss !! n)) nats)"
  13.426 -
  13.427 -lemma stake_nth[simp]: "m < n \<Longrightarrow> stake n s ! m = s !! m"
  13.428 -  by (induct n arbitrary: s m) (auto simp: nth_Cons', metis Suc_pred snth.simps(2))
  13.429 -
  13.430 -lemma snth_sset_smerge: "ss !! n !! m \<in> sset (smerge ss)"
  13.431 -proof (cases "n \<le> m")
  13.432 -  case False thus ?thesis unfolding smerge_def
  13.433 -    by (subst sset_flat)
  13.434 -      (auto simp: stream.set_map in_set_conv_nth simp del: stake.simps
  13.435 -        intro!: exI[of _ n, OF disjI2] exI[of _ m, OF mp])
  13.436 -next
  13.437 -  case True thus ?thesis unfolding smerge_def
  13.438 -    by (subst sset_flat)
  13.439 -      (auto simp: stream.set_map in_set_conv_nth image_iff simp del: stake.simps snth.simps
  13.440 -        intro!: exI[of _ m, OF disjI1] bexI[of _ "ss !! n"] exI[of _ n, OF mp])
  13.441 -qed
  13.442 -
  13.443 -lemma sset_smerge: "sset (smerge ss) = UNION (sset ss) sset"
  13.444 -proof safe
  13.445 -  fix x assume "x \<in> sset (smerge ss)"
  13.446 -  thus "x \<in> UNION (sset ss) sset"
  13.447 -    unfolding smerge_def by (subst (asm) sset_flat)
  13.448 -      (auto simp: stream.set_map in_set_conv_nth sset_range simp del: stake.simps, fast+)
  13.449 -next
  13.450 -  fix s x assume "s \<in> sset ss" "x \<in> sset s"
  13.451 -  thus "x \<in> sset (smerge ss)" using snth_sset_smerge by (auto simp: sset_range)
  13.452 -qed
  13.453 -
  13.454 -
  13.455 -subsection {* product of two streams *}
  13.456 -
  13.457 -definition sproduct :: "'a stream \<Rightarrow> 'b stream \<Rightarrow> ('a \<times> 'b) stream" where
  13.458 -  "sproduct s1 s2 = smerge (smap (\<lambda>x. smap (Pair x) s2) s1)"
  13.459 -
  13.460 -lemma sset_sproduct: "sset (sproduct s1 s2) = sset s1 \<times> sset s2"
  13.461 -  unfolding sproduct_def sset_smerge by (auto simp: stream.set_map)
  13.462 -
  13.463 -
  13.464 -subsection {* interleave two streams *}
  13.465 -
  13.466 -primcorec sinterleave where
  13.467 -  "shd (sinterleave s1 s2) = shd s1"
  13.468 -| "stl (sinterleave s1 s2) = sinterleave s2 (stl s1)"
  13.469 -
  13.470 -lemma sinterleave_code[code]:
  13.471 -  "sinterleave (x ## s1) s2 = x ## sinterleave s2 s1"
  13.472 -  by (subst sinterleave.ctr) simp
  13.473 -
  13.474 -lemma sinterleave_snth[simp]:
  13.475 -  "even n \<Longrightarrow> sinterleave s1 s2 !! n = s1 !! (n div 2)"
  13.476 -   "odd n \<Longrightarrow> sinterleave s1 s2 !! n = s2 !! (n div 2)"
  13.477 -  by (induct n arbitrary: s1 s2)
  13.478 -    (auto dest: even_nat_Suc_div_2 odd_nat_plus_one_div_two[folded nat_2])
  13.479 -
  13.480 -lemma sset_sinterleave: "sset (sinterleave s1 s2) = sset s1 \<union> sset s2"
  13.481 -proof (intro equalityI subsetI)
  13.482 -  fix x assume "x \<in> sset (sinterleave s1 s2)"
  13.483 -  then obtain n where "x = sinterleave s1 s2 !! n" unfolding sset_range by blast
  13.484 -  thus "x \<in> sset s1 \<union> sset s2" by (cases "even n") auto
  13.485 -next
  13.486 -  fix x assume "x \<in> sset s1 \<union> sset s2"
  13.487 -  thus "x \<in> sset (sinterleave s1 s2)"
  13.488 -  proof
  13.489 -    assume "x \<in> sset s1"
  13.490 -    then obtain n where "x = s1 !! n" unfolding sset_range by blast
  13.491 -    hence "sinterleave s1 s2 !! (2 * n) = x" by simp
  13.492 -    thus ?thesis unfolding sset_range by blast
  13.493 -  next
  13.494 -    assume "x \<in> sset s2"
  13.495 -    then obtain n where "x = s2 !! n" unfolding sset_range by blast
  13.496 -    hence "sinterleave s1 s2 !! (2 * n + 1) = x" by simp
  13.497 -    thus ?thesis unfolding sset_range by blast
  13.498 -  qed
  13.499 -qed
  13.500 -
  13.501 -
  13.502 -subsection {* zip *}
  13.503 -
  13.504 -primcorec szip where
  13.505 -  "shd (szip s1 s2) = (shd s1, shd s2)"
  13.506 -| "stl (szip s1 s2) = szip (stl s1) (stl s2)"
  13.507 -
  13.508 -lemma szip_unfold[code]: "szip (a ## s1) (b ## s2) = (a, b) ## (szip s1 s2)"
  13.509 -  by (subst szip.ctr) simp
  13.510 -
  13.511 -lemma snth_szip[simp]: "szip s1 s2 !! n = (s1 !! n, s2 !! n)"
  13.512 -  by (induct n arbitrary: s1 s2) auto
  13.513 -
  13.514 -
  13.515 -subsection {* zip via function *}
  13.516 -
  13.517 -primcorec smap2 where
  13.518 -  "shd (smap2 f s1 s2) = f (shd s1) (shd s2)"
  13.519 -| "stl (smap2 f s1 s2) = smap2 f (stl s1) (stl s2)"
  13.520 -
  13.521 -lemma smap2_unfold[code]:
  13.522 -  "smap2 f (a ## s1) (b ## s2) = f a b ## (smap2 f s1 s2)"
  13.523 -  by (subst smap2.ctr) simp
  13.524 -
  13.525 -lemma smap2_szip:
  13.526 -  "smap2 f s1 s2 = smap (split f) (szip s1 s2)"
  13.527 -  by (coinduction arbitrary: s1 s2) auto
  13.528 -
  13.529 -end
    14.1 --- a/src/HOL/BNF/Examples/Stream_Processor.thy	Mon Jan 20 18:24:56 2014 +0100
    14.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.3 @@ -1,187 +0,0 @@
    14.4 -(*  Title:      HOL/BNF/Examples/Stream_Processor.thy
    14.5 -    Author:     Dmitriy Traytel, TU Muenchen
    14.6 -    Author:     Andrei Popescu, TU Muenchen
    14.7 -    Copyright   2014
    14.8 -
    14.9 -Stream processors---a syntactic representation of continuous functions on streams
   14.10 -*)
   14.11 -
   14.12 -header {* Stream Processors *}
   14.13 -
   14.14 -theory Stream_Processor
   14.15 -imports Stream "../BNF_Decl"
   14.16 -begin
   14.17 -
   14.18 -section {* Continuous Functions on Streams *}
   14.19 -
   14.20 -datatype_new ('a, 'b, 'c) sp\<^sub>\<mu> = Get "'a \<Rightarrow> ('a, 'b, 'c) sp\<^sub>\<mu>" | Put "'b" "'c"
   14.21 -codatatype ('a, 'b) sp\<^sub>\<nu> = In (out: "('a, 'b, ('a, 'b) sp\<^sub>\<nu>) sp\<^sub>\<mu>")
   14.22 -
   14.23 -primrec_new run\<^sub>\<mu> :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> 'a stream \<Rightarrow> ('b \<times> 'c) \<times> 'a stream" where
   14.24 -  "run\<^sub>\<mu> (Get f) s = run\<^sub>\<mu> (f (shd s)) (stl s)"
   14.25 -| "run\<^sub>\<mu> (Put b sp) s = ((b, sp), s)"
   14.26 -
   14.27 -primcorec run\<^sub>\<nu> :: "('a, 'b) sp\<^sub>\<nu> \<Rightarrow> 'a stream \<Rightarrow> 'b stream" where
   14.28 -  "run\<^sub>\<nu> sp s = (let ((h, sp), s) = run\<^sub>\<mu> (out sp) s in h ## run\<^sub>\<nu> sp s)"
   14.29 -
   14.30 -primcorec copy :: "('a, 'a) sp\<^sub>\<nu>" where
   14.31 -  "copy = In (Get (\<lambda>a. Put a copy))"
   14.32 -
   14.33 -lemma run\<^sub>\<nu>_copy: "run\<^sub>\<nu> copy s = s"
   14.34 -  by (coinduction arbitrary: s) simp
   14.35 -
   14.36 -text {*
   14.37 -To use the function package for the definition of composition the
   14.38 -wellfoundedness of the subtree relation needs to be proved first.
   14.39 -*}
   14.40 -
   14.41 -definition "sub \<equiv> {(f a, Get f) | a f. True}"
   14.42 -
   14.43 -lemma subI[intro]: "(f a, Get f) \<in> sub"
   14.44 -  unfolding sub_def by blast
   14.45 -
   14.46 -lemma wf_sub[simp, intro]: "wf sub"
   14.47 -proof (rule wfUNIVI)
   14.48 -  fix P  :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> bool" and x
   14.49 -  assume "\<forall>x. (\<forall>y. (y, x) \<in> sub \<longrightarrow> P y) \<longrightarrow> P x"
   14.50 -  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
   14.51 -  show "P x" by (induct x) (auto intro: I)
   14.52 -qed
   14.53 -
   14.54 -function
   14.55 -  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>"
   14.56 -  (infixl "o\<^sub>\<mu>" 65)
   14.57 -where
   14.58 -  "Put b sp o\<^sub>\<mu> fsp = Put b (sp, In fsp)"
   14.59 -| "Get f o\<^sub>\<mu> Put b sp = f b o\<^sub>\<mu> out sp"
   14.60 -| "Get f o\<^sub>\<mu> Get g = Get (\<lambda>a. Get f o\<^sub>\<mu> g a)"
   14.61 -by pat_completeness auto
   14.62 -termination by (relation "lex_prod sub sub") auto
   14.63 -
   14.64 -primcorec sp\<^sub>\<nu>_comp (infixl "o\<^sub>\<nu>" 65) where
   14.65 -  "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')"
   14.66 -
   14.67 -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'"
   14.68 -proof (rule ext, unfold comp_apply)
   14.69 -  fix s
   14.70 -  show "run\<^sub>\<nu> (sp o\<^sub>\<nu> sp') s = run\<^sub>\<nu> sp (run\<^sub>\<nu> sp' s)"
   14.71 -  proof (coinduction arbitrary: sp sp' s)
   14.72 -    case Eq_stream
   14.73 -    show ?case
   14.74 -    proof (induct "out sp" "out sp'" arbitrary: sp sp' s rule: sp\<^sub>\<mu>_comp.induct)
   14.75 -      case (1 b sp'')
   14.76 -      show ?case by (auto simp add: 1[symmetric])
   14.77 -    next
   14.78 -      case (2 f b sp'')
   14.79 -      from 2(1)[of "In (f b)" sp''] show ?case by (simp add: 2(2,3)[symmetric])
   14.80 -    next
   14.81 -      case (3 f h)
   14.82 -      from 3(1)[of _ "shd s" "In (h (shd s))", OF 3(2)] show ?case by (simp add: 3(2,3)[symmetric])
   14.83 -    qed
   14.84 -  qed
   14.85 -qed
   14.86 -
   14.87 -text {* Alternative definition of composition using primrec_new instead of function *}
   14.88 -
   14.89 -primrec_new sp\<^sub>\<mu>_comp2R  where
   14.90 -  "sp\<^sub>\<mu>_comp2R f (Put b sp) = f b (out sp)"
   14.91 -| "sp\<^sub>\<mu>_comp2R f (Get h) = Get (sp\<^sub>\<mu>_comp2R f o h)"
   14.92 -
   14.93 -primrec_new sp\<^sub>\<mu>_comp2 (infixl "o\<^sup>*\<^sub>\<mu>" 65) where
   14.94 -  "Put b sp o\<^sup>*\<^sub>\<mu> fsp = Put b (sp, In fsp)"
   14.95 -| "Get f o\<^sup>*\<^sub>\<mu> fsp = sp\<^sub>\<mu>_comp2R (op o\<^sup>*\<^sub>\<mu> o f) fsp"
   14.96 -
   14.97 -primcorec sp\<^sub>\<nu>_comp2 (infixl "o\<^sup>*\<^sub>\<nu>" 65) where
   14.98 -  "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')"
   14.99 -
  14.100 -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'"
  14.101 -proof (rule ext, unfold comp_apply)
  14.102 -  fix s
  14.103 -  show "run\<^sub>\<nu> (sp o\<^sup>*\<^sub>\<nu> sp') s = run\<^sub>\<nu> sp (run\<^sub>\<nu> sp' s)"
  14.104 -  proof (coinduction arbitrary: sp sp' s)
  14.105 -    case Eq_stream
  14.106 -    show ?case
  14.107 -    proof (induct "out sp" arbitrary: sp sp' s)
  14.108 -      case (Put b sp'')
  14.109 -      show ?case by (auto simp add: Put[symmetric])
  14.110 -    next
  14.111 -      case (Get f)
  14.112 -      then show ?case
  14.113 -      proof (induct "out sp'" arbitrary: sp sp' s)
  14.114 -        case (Put b sp'')
  14.115 -        from Put(2)[of "In (f b)" sp''] show ?case by (simp add: Put(1,3)[symmetric])
  14.116 -      next
  14.117 -        case (Get h)
  14.118 -        from Get(1)[OF _ Get(3,4), of "In (h (shd s))"] show ?case by (simp add: Get(2,4)[symmetric])
  14.119 -      qed
  14.120 -    qed
  14.121 -  qed
  14.122 -qed
  14.123 -
  14.124 -text {* The two definitions are equivalent *}
  14.125 -
  14.126 -lemma sp\<^sub>\<mu>_comp_sp\<^sub>\<mu>_comp2[simp]: "sp o\<^sub>\<mu> sp' = sp o\<^sup>*\<^sub>\<mu> sp'"
  14.127 -  by (induct sp sp' rule: sp\<^sub>\<mu>_comp.induct) auto
  14.128 -
  14.129 -(*will be provided by the package*)
  14.130 -lemma sp\<^sub>\<mu>_rel_map_map[unfolded vimage2p_def, simp]:
  14.131 -  "rel_sp\<^sub>\<mu> R1 R2 (map_sp\<^sub>\<mu> f1 f2 sp) (map_sp\<^sub>\<mu> g1 g2 sp') =
  14.132 -  rel_sp\<^sub>\<mu> (BNF_Def.vimage2p f1 g1 R1) (BNF_Def.vimage2p f2 g2 R2) sp sp'"
  14.133 -by (tactic {*
  14.134 -  let val ks = 1 upto 2;
  14.135 -  in
  14.136 -    BNF_Tactics.unfold_thms_tac @{context}
  14.137 -      @{thms sp\<^sub>\<mu>.rel_compp sp\<^sub>\<mu>.rel_conversep sp\<^sub>\<mu>.rel_Grp vimage2p_Grp} THEN
  14.138 -    HEADGOAL (EVERY' [rtac iffI, rtac @{thm relcomppI}, rtac @{thm GrpI}, rtac refl, rtac CollectI,
  14.139 -      BNF_Util.CONJ_WRAP' (K (rtac @{thm subset_UNIV})) ks, rtac @{thm relcomppI}, atac,
  14.140 -      rtac @{thm conversepI}, rtac @{thm GrpI}, rtac refl, rtac CollectI,
  14.141 -      BNF_Util.CONJ_WRAP' (K (rtac @{thm subset_UNIV})) ks,
  14.142 -      REPEAT_DETERM o eresolve_tac @{thms relcomppE conversepE GrpE},
  14.143 -      hyp_subst_tac @{context}, atac])
  14.144 -  end
  14.145 -*})
  14.146 -
  14.147 -lemma sp\<^sub>\<mu>_rel_self: "\<lbrakk>op = \<le> R1; op = \<le> R2\<rbrakk> \<Longrightarrow> rel_sp\<^sub>\<mu> R1 R2 x x"
  14.148 -  by (erule (1) predicate2D[OF sp\<^sub>\<mu>.rel_mono]) (simp only: sp\<^sub>\<mu>.rel_eq)
  14.149 -
  14.150 -lemma sp\<^sub>\<nu>_comp_sp\<^sub>\<nu>_comp2: "sp o\<^sub>\<nu> sp' = sp o\<^sup>*\<^sub>\<nu> sp'"
  14.151 -  by (coinduction arbitrary: sp sp') (auto intro!: sp\<^sub>\<mu>_rel_self)
  14.152 -
  14.153 -
  14.154 -section {* Generalization to an Arbitrary BNF as Codomain *}
  14.155 -
  14.156 -bnf_decl ('a, 'b) F (map: F)
  14.157 -
  14.158 -definition \<theta> :: "('p,'a) F * 'b \<Rightarrow> ('p,'a * 'b) F" where
  14.159 -   "\<theta> xb = F id <id, \<lambda> a. (snd xb)> (fst xb)"
  14.160 -
  14.161 -(* The strength laws for \<theta>: *)
  14.162 -lemma \<theta>_natural: "F id (map_pair f g) o \<theta> = \<theta> o map_pair (F id f) g"
  14.163 -  unfolding \<theta>_def F.map_comp comp_def id_apply convol_def map_pair_def split_beta fst_conv snd_conv ..
  14.164 -
  14.165 -definition assl :: "'a * ('b * 'c) \<Rightarrow> ('a * 'b) * 'c" where
  14.166 -  "assl abc = ((fst abc, fst (snd abc)), snd (snd abc))"
  14.167 -
  14.168 -lemma \<theta>_rid: "F id fst o \<theta> = fst"
  14.169 -  unfolding \<theta>_def F.map_comp F.map_id comp_def id_apply convol_def fst_conv sym[OF id_def] ..
  14.170 -
  14.171 -lemma \<theta>_assl: "F id assl o \<theta> = \<theta> o map_pair \<theta> id o assl"
  14.172 -  unfolding assl_def \<theta>_def F.map_comp comp_def id_apply convol_def map_pair_def split fst_conv snd_conv ..
  14.173 -
  14.174 -datatype_new ('a, 'b, 'c) spF\<^sub>\<mu> = GetF "'a \<Rightarrow> ('a, 'b, 'c) spF\<^sub>\<mu>" | PutF "('b,'c) F"
  14.175 -codatatype ('a, 'b) spF\<^sub>\<nu> = InF (outF: "('a, 'b, ('a, 'b) spF\<^sub>\<nu>) spF\<^sub>\<mu>")
  14.176 -
  14.177 -codatatype 'b JF = Ctor (dtor: "('b, 'b JF) F")
  14.178 -
  14.179 -(* Definition of run for an arbitrary final coalgebra as codomain: *)
  14.180 -
  14.181 -primrec_new
  14.182 -  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" 
  14.183 -where
  14.184 -  "runF\<^sub>\<mu> (GetF f) s = (runF\<^sub>\<mu> o f) (shd s) (stl s)"
  14.185 -| "runF\<^sub>\<mu> (PutF x) s = (x, s)"
  14.186 -
  14.187 -primcorec runF\<^sub>\<nu> :: "('a, 'b) spF\<^sub>\<nu> \<Rightarrow> 'a stream \<Rightarrow> 'b JF" where
  14.188 -  "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))"
  14.189 -
  14.190 -end
    15.1 --- a/src/HOL/BNF/Examples/TreeFI.thy	Mon Jan 20 18:24:56 2014 +0100
    15.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.3 @@ -1,46 +0,0 @@
    15.4 -(*  Title:      HOL/BNF/Examples/TreeFI.thy
    15.5 -    Author:     Dmitriy Traytel, TU Muenchen
    15.6 -    Author:     Andrei Popescu, TU Muenchen
    15.7 -    Copyright   2012
    15.8 -
    15.9 -Finitely branching possibly infinite trees.
   15.10 -*)
   15.11 -
   15.12 -header {* Finitely Branching Possibly Infinite Trees *}
   15.13 -
   15.14 -theory TreeFI
   15.15 -imports ListF
   15.16 -begin
   15.17 -
   15.18 -codatatype 'a treeFI = Tree (lab: 'a) (sub: "'a treeFI listF")
   15.19 -
   15.20 -(* Tree reverse:*)
   15.21 -primcorec trev where
   15.22 -  "lab (trev t) = lab t"
   15.23 -| "sub (trev t) = mapF trev (lrev (sub t))"
   15.24 -
   15.25 -lemma treeFI_coinduct:
   15.26 -  assumes *: "phi x y"
   15.27 -  and step: "\<And>a b. phi a b \<Longrightarrow>
   15.28 -     lab a = lab b \<and>
   15.29 -     lengthh (sub a) = lengthh (sub b) \<and>
   15.30 -     (\<forall>i < lengthh (sub a). phi (nthh (sub a) i) (nthh (sub b) i))"
   15.31 -  shows "x = y"
   15.32 -using * proof (coinduction arbitrary: x y)
   15.33 -  case (Eq_treeFI t1 t2)
   15.34 -  from conjunct1[OF conjunct2[OF step[OF Eq_treeFI]]] conjunct2[OF conjunct2[OF step[OF Eq_treeFI]]]
   15.35 -  have "relF phi (sub t1) (sub t2)"
   15.36 -  proof (induction "sub t1" "sub t2" arbitrary: t1 t2 rule: listF_induct2)
   15.37 -    case (Conss x xs y ys)
   15.38 -    note sub = Conss(2,3)[symmetric] and phi = mp[OF spec[OF Conss(4)], unfolded sub]
   15.39 -      and IH = Conss(1)[of "Tree (lab t1) (tlF (sub t1))" "Tree (lab t2) (tlF (sub t2))",
   15.40 -        unfolded sub, simplified]
   15.41 -    from phi[of 0] show ?case unfolding sub by (auto intro!: IH dest: phi[simplified, OF Suc_mono])
   15.42 -  qed simp
   15.43 -  with conjunct1[OF step[OF Eq_treeFI]] show ?case by simp
   15.44 -qed
   15.45 -
   15.46 -lemma trev_trev: "trev (trev tr) = tr"
   15.47 -  by (coinduction arbitrary: tr rule: treeFI_coinduct) auto
   15.48 -
   15.49 -end
    16.1 --- a/src/HOL/BNF/Examples/TreeFsetI.thy	Mon Jan 20 18:24:56 2014 +0100
    16.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.3 @@ -1,27 +0,0 @@
    16.4 -(*  Title:      HOL/BNF/Examples/TreeFsetI.thy
    16.5 -    Author:     Dmitriy Traytel, TU Muenchen
    16.6 -    Author:     Andrei Popescu, TU Muenchen
    16.7 -    Copyright   2012
    16.8 -
    16.9 -Finitely branching possibly infinite trees, with sets of children.
   16.10 -*)
   16.11 -
   16.12 -header {* Finitely Branching Possibly Infinite Trees, with Sets of Children *}
   16.13 -
   16.14 -theory TreeFsetI
   16.15 -imports "../BNF"
   16.16 -begin
   16.17 -
   16.18 -hide_fact (open) Lifting_Product.prod_rel_def
   16.19 -
   16.20 -codatatype 'a treeFsetI = Tree (lab: 'a) (sub: "'a treeFsetI fset")
   16.21 -
   16.22 -(* tree map (contrived example): *)
   16.23 -primcorec tmap where
   16.24 -"lab (tmap f t) = f (lab t)" |
   16.25 -"sub (tmap f t) = fimage (tmap f) (sub t)"
   16.26 -
   16.27 -lemma "tmap (f o g) x = tmap f (tmap g x)"
   16.28 -  by (coinduction arbitrary: x) (auto simp: fset_rel_alt)
   16.29 -
   16.30 -end
    17.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.2 +++ b/src/HOL/BNF_Examples/Derivation_Trees/DTree.thy	Mon Jan 20 18:24:56 2014 +0100
    17.3 @@ -0,0 +1,92 @@
    17.4 +(*  Title:      HOL/BNF/Examples/Derivation_Trees/DTree.thy
    17.5 +    Author:     Andrei Popescu, TU Muenchen
    17.6 +    Copyright   2012
    17.7 +
    17.8 +Derivation trees with nonterminal internal nodes and terminal leaves.
    17.9 +*)
   17.10 +
   17.11 +header {* Trees with Nonterminal Internal Nodes and Terminal Leaves *}
   17.12 +
   17.13 +theory DTree
   17.14 +imports Prelim
   17.15 +begin
   17.16 +
   17.17 +typedecl N
   17.18 +typedecl T
   17.19 +
   17.20 +codatatype dtree = NNode (root: N) (ccont: "(T + dtree) fset")
   17.21 +
   17.22 +subsection{* Transporting the Characteristic Lemmas from @{text "fset"} to @{text "set"} *}
   17.23 +
   17.24 +definition "Node n as \<equiv> NNode n (the_inv fset as)"
   17.25 +definition "cont \<equiv> fset o ccont"
   17.26 +definition "unfold rt ct \<equiv> unfold_dtree rt (the_inv fset o ct)"
   17.27 +definition "corec rt ct \<equiv> corec_dtree rt (the_inv fset o ct)"
   17.28 +
   17.29 +lemma finite_cont[simp]: "finite (cont tr)"
   17.30 +  unfolding cont_def comp_apply by (cases tr, clarsimp)
   17.31 +
   17.32 +lemma Node_root_cont[simp]:
   17.33 +  "Node (root tr) (cont tr) = tr"
   17.34 +  unfolding Node_def cont_def comp_apply
   17.35 +  apply (rule trans[OF _ dtree.collapse])
   17.36 +  apply (rule arg_cong2[OF refl the_inv_into_f_f[unfolded inj_on_def]])
   17.37 +  apply (simp_all add: fset_inject)
   17.38 +  done
   17.39 +
   17.40 +lemma dtree_simps[simp]:
   17.41 +assumes "finite as" and "finite as'"
   17.42 +shows "Node n as = Node n' as' \<longleftrightarrow> n = n' \<and> as = as'"
   17.43 +using assms dtree.inject unfolding Node_def
   17.44 +by (metis fset_to_fset)
   17.45 +
   17.46 +lemma dtree_cases[elim, case_names Node Choice]:
   17.47 +assumes Node: "\<And> n as. \<lbrakk>finite as; tr = Node n as\<rbrakk> \<Longrightarrow> phi"
   17.48 +shows phi
   17.49 +apply(cases rule: dtree.exhaust[of tr])
   17.50 +using Node unfolding Node_def
   17.51 +by (metis Node Node_root_cont finite_cont)
   17.52 +
   17.53 +lemma dtree_sel_ctor[simp]:
   17.54 +"root (Node n as) = n"
   17.55 +"finite as \<Longrightarrow> cont (Node n as) = as"
   17.56 +unfolding Node_def cont_def by auto
   17.57 +
   17.58 +lemmas root_Node = dtree_sel_ctor(1)
   17.59 +lemmas cont_Node = dtree_sel_ctor(2)
   17.60 +
   17.61 +lemma dtree_cong:
   17.62 +assumes "root tr = root tr'" and "cont tr = cont tr'"
   17.63 +shows "tr = tr'"
   17.64 +by (metis Node_root_cont assms)
   17.65 +
   17.66 +lemma set_rel_cont:
   17.67 +"set_rel \<chi> (cont tr1) (cont tr2) = fset_rel \<chi> (ccont tr1) (ccont tr2)"
   17.68 +unfolding cont_def comp_def fset_rel_fset ..
   17.69 +
   17.70 +lemma dtree_coinduct[elim, consumes 1, case_names Lift, induct pred: "HOL.eq"]:
   17.71 +assumes phi: "\<phi> tr1 tr2" and
   17.72 +Lift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow>
   17.73 +                  root tr1 = root tr2 \<and> set_rel (sum_rel op = \<phi>) (cont tr1) (cont tr2)"
   17.74 +shows "tr1 = tr2"
   17.75 +using phi apply(elim dtree.coinduct)
   17.76 +apply(rule Lift[unfolded set_rel_cont]) .
   17.77 +
   17.78 +lemma unfold:
   17.79 +"root (unfold rt ct b) = rt b"
   17.80 +"finite (ct b) \<Longrightarrow> cont (unfold rt ct b) = image (id \<oplus> unfold rt ct) (ct b)"
   17.81 +using dtree.sel_unfold[of rt "the_inv fset \<circ> ct" b] unfolding unfold_def
   17.82 +apply - apply metis
   17.83 +unfolding cont_def comp_def
   17.84 +by simp
   17.85 +
   17.86 +lemma corec:
   17.87 +"root (corec rt ct b) = rt b"
   17.88 +"finite (ct b) \<Longrightarrow> cont (corec rt ct b) = image (id \<oplus> ([[id, corec rt ct]])) (ct b)"
   17.89 +using dtree.sel_corec[of rt "the_inv fset \<circ> ct" b] unfolding corec_def
   17.90 +apply -
   17.91 +apply simp
   17.92 +unfolding cont_def comp_def id_def
   17.93 +by simp
   17.94 +
   17.95 +end
    18.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.2 +++ b/src/HOL/BNF_Examples/Derivation_Trees/Gram_Lang.thy	Mon Jan 20 18:24:56 2014 +0100
    18.3 @@ -0,0 +1,1359 @@
    18.4 +(*  Title:      HOL/BNF/Examples/Derivation_Trees/Gram_Lang.thy
    18.5 +    Author:     Andrei Popescu, TU Muenchen
    18.6 +    Copyright   2012
    18.7 +
    18.8 +Language of a grammar.
    18.9 +*)
   18.10 +
   18.11 +header {* Language of a Grammar *}
   18.12 +
   18.13 +theory Gram_Lang
   18.14 +imports DTree
   18.15 +begin
   18.16 +
   18.17 +
   18.18 +(* We assume that the sets of terminals, and the left-hand sides of
   18.19 +productions are finite and that the grammar has no unused nonterminals. *)
   18.20 +consts P :: "(N \<times> (T + N) set) set"
   18.21 +axiomatization where
   18.22 +    finite_N: "finite (UNIV::N set)"
   18.23 +and finite_in_P: "\<And> n tns. (n,tns) \<in> P \<longrightarrow> finite tns"
   18.24 +and used: "\<And> n. \<exists> tns. (n,tns) \<in> P"
   18.25 +
   18.26 +
   18.27 +subsection{* Tree Basics: frontier, interior, etc. *}
   18.28 +
   18.29 +
   18.30 +(* Frontier *)
   18.31 +
   18.32 +inductive inFr :: "N set \<Rightarrow> dtree \<Rightarrow> T \<Rightarrow> bool" where
   18.33 +Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr ns tr t"
   18.34 +|
   18.35 +Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inFr ns tr1 t\<rbrakk> \<Longrightarrow> inFr ns tr t"
   18.36 +
   18.37 +definition "Fr ns tr \<equiv> {t. inFr ns tr t}"
   18.38 +
   18.39 +lemma inFr_root_in: "inFr ns tr t \<Longrightarrow> root tr \<in> ns"
   18.40 +by (metis inFr.simps)
   18.41 +
   18.42 +lemma inFr_mono:
   18.43 +assumes "inFr ns tr t" and "ns \<subseteq> ns'"
   18.44 +shows "inFr ns' tr t"
   18.45 +using assms apply(induct arbitrary: ns' rule: inFr.induct)
   18.46 +using Base Ind by (metis inFr.simps set_mp)+
   18.47 +
   18.48 +lemma inFr_Ind_minus:
   18.49 +assumes "inFr ns1 tr1 t" and "Inr tr1 \<in> cont tr"
   18.50 +shows "inFr (insert (root tr) ns1) tr t"
   18.51 +using assms apply(induct rule: inFr.induct)
   18.52 +  apply (metis inFr.simps insert_iff)
   18.53 +  by (metis inFr.simps inFr_mono insertI1 subset_insertI)
   18.54 +
   18.55 +(* alternative definition *)
   18.56 +inductive inFr2 :: "N set \<Rightarrow> dtree \<Rightarrow> T \<Rightarrow> bool" where
   18.57 +Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr2 ns tr t"
   18.58 +|
   18.59 +Ind: "\<lbrakk>Inr tr1 \<in> cont tr; inFr2 ns1 tr1 t\<rbrakk>
   18.60 +      \<Longrightarrow> inFr2 (insert (root tr) ns1) tr t"
   18.61 +
   18.62 +lemma inFr2_root_in: "inFr2 ns tr t \<Longrightarrow> root tr \<in> ns"
   18.63 +apply(induct rule: inFr2.induct) by auto
   18.64 +
   18.65 +lemma inFr2_mono:
   18.66 +assumes "inFr2 ns tr t" and "ns \<subseteq> ns'"
   18.67 +shows "inFr2 ns' tr t"
   18.68 +using assms apply(induct arbitrary: ns' rule: inFr2.induct)
   18.69 +using Base Ind
   18.70 +apply (metis subsetD) by (metis inFr2.simps insert_absorb insert_subset)
   18.71 +
   18.72 +lemma inFr2_Ind:
   18.73 +assumes "inFr2 ns tr1 t" and "root tr \<in> ns" and "Inr tr1 \<in> cont tr"
   18.74 +shows "inFr2 ns tr t"
   18.75 +using assms apply(induct rule: inFr2.induct)
   18.76 +  apply (metis inFr2.simps insert_absorb)
   18.77 +  by (metis inFr2.simps insert_absorb)
   18.78 +
   18.79 +lemma inFr_inFr2:
   18.80 +"inFr = inFr2"
   18.81 +apply (rule ext)+  apply(safe)
   18.82 +  apply(erule inFr.induct)
   18.83 +    apply (metis (lifting) inFr2.Base)
   18.84 +    apply (metis (lifting) inFr2_Ind)
   18.85 +  apply(erule inFr2.induct)
   18.86 +    apply (metis (lifting) inFr.Base)
   18.87 +    apply (metis (lifting) inFr_Ind_minus)
   18.88 +done
   18.89 +
   18.90 +lemma not_root_inFr:
   18.91 +assumes "root tr \<notin> ns"
   18.92 +shows "\<not> inFr ns tr t"
   18.93 +by (metis assms inFr_root_in)
   18.94 +
   18.95 +lemma not_root_Fr:
   18.96 +assumes "root tr \<notin> ns"
   18.97 +shows "Fr ns tr = {}"
   18.98 +using not_root_inFr[OF assms] unfolding Fr_def by auto
   18.99 +
  18.100 +
  18.101 +(* Interior *)
  18.102 +
  18.103 +inductive inItr :: "N set \<Rightarrow> dtree \<Rightarrow> N \<Rightarrow> bool" where
  18.104 +Base: "root tr \<in> ns \<Longrightarrow> inItr ns tr (root tr)"
  18.105 +|
  18.106 +Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inItr ns tr1 n\<rbrakk> \<Longrightarrow> inItr ns tr n"
  18.107 +
  18.108 +definition "Itr ns tr \<equiv> {n. inItr ns tr n}"
  18.109 +
  18.110 +lemma inItr_root_in: "inItr ns tr n \<Longrightarrow> root tr \<in> ns"
  18.111 +by (metis inItr.simps)
  18.112 +
  18.113 +lemma inItr_mono:
  18.114 +assumes "inItr ns tr n" and "ns \<subseteq> ns'"
  18.115 +shows "inItr ns' tr n"
  18.116 +using assms apply(induct arbitrary: ns' rule: inItr.induct)
  18.117 +using Base Ind by (metis inItr.simps set_mp)+
  18.118 +
  18.119 +
  18.120 +(* The subtree relation *)
  18.121 +
  18.122 +inductive subtr where
  18.123 +Refl: "root tr \<in> ns \<Longrightarrow> subtr ns tr tr"
  18.124 +|
  18.125 +Step: "\<lbrakk>root tr3 \<in> ns; subtr ns tr1 tr2; Inr tr2 \<in> cont tr3\<rbrakk> \<Longrightarrow> subtr ns tr1 tr3"
  18.126 +
  18.127 +lemma subtr_rootL_in:
  18.128 +assumes "subtr ns tr1 tr2"
  18.129 +shows "root tr1 \<in> ns"
  18.130 +using assms apply(induct rule: subtr.induct) by auto
  18.131 +
  18.132 +lemma subtr_rootR_in:
  18.133 +assumes "subtr ns tr1 tr2"
  18.134 +shows "root tr2 \<in> ns"
  18.135 +using assms apply(induct rule: subtr.induct) by auto
  18.136 +
  18.137 +lemmas subtr_roots_in = subtr_rootL_in subtr_rootR_in
  18.138 +
  18.139 +lemma subtr_mono:
  18.140 +assumes "subtr ns tr1 tr2" and "ns \<subseteq> ns'"
  18.141 +shows "subtr ns' tr1 tr2"
  18.142 +using assms apply(induct arbitrary: ns' rule: subtr.induct)
  18.143 +using Refl Step by (metis subtr.simps set_mp)+
  18.144 +
  18.145 +lemma subtr_trans_Un:
  18.146 +assumes "subtr ns12 tr1 tr2" and "subtr ns23 tr2 tr3"
  18.147 +shows "subtr (ns12 \<union> ns23) tr1 tr3"
  18.148 +proof-
  18.149 +  have "subtr ns23 tr2 tr3  \<Longrightarrow>
  18.150 +        (\<forall> ns12 tr1. subtr ns12 tr1 tr2 \<longrightarrow> subtr (ns12 \<union> ns23) tr1 tr3)"
  18.151 +  apply(induct  rule: subtr.induct, safe)
  18.152 +    apply (metis subtr_mono sup_commute sup_ge2)
  18.153 +    by (metis (lifting) Step UnI2)
  18.154 +  thus ?thesis using assms by auto
  18.155 +qed
  18.156 +
  18.157 +lemma subtr_trans:
  18.158 +assumes "subtr ns tr1 tr2" and "subtr ns tr2 tr3"
  18.159 +shows "subtr ns tr1 tr3"
  18.160 +using subtr_trans_Un[OF assms] by simp
  18.161 +
  18.162 +lemma subtr_StepL:
  18.163 +assumes r: "root tr1 \<in> ns" and tr12: "Inr tr1 \<in> cont tr2" and s: "subtr ns tr2 tr3"
  18.164 +shows "subtr ns tr1 tr3"
  18.165 +apply(rule subtr_trans[OF _ s])
  18.166 +apply(rule Step[of tr2 ns tr1 tr1])
  18.167 +apply(rule subtr_rootL_in[OF s])
  18.168 +apply(rule Refl[OF r])
  18.169 +apply(rule tr12)
  18.170 +done
  18.171 +
  18.172 +(* alternative definition: *)
  18.173 +inductive subtr2 where
  18.174 +Refl: "root tr \<in> ns \<Longrightarrow> subtr2 ns tr tr"
  18.175 +|
  18.176 +Step: "\<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr2 ns tr2 tr3\<rbrakk> \<Longrightarrow> subtr2 ns tr1 tr3"
  18.177 +
  18.178 +lemma subtr2_rootL_in:
  18.179 +assumes "subtr2 ns tr1 tr2"
  18.180 +shows "root tr1 \<in> ns"
  18.181 +using assms apply(induct rule: subtr2.induct) by auto
  18.182 +
  18.183 +lemma subtr2_rootR_in:
  18.184 +assumes "subtr2 ns tr1 tr2"
  18.185 +shows "root tr2 \<in> ns"
  18.186 +using assms apply(induct rule: subtr2.induct) by auto
  18.187 +
  18.188 +lemmas subtr2_roots_in = subtr2_rootL_in subtr2_rootR_in
  18.189 +
  18.190 +lemma subtr2_mono:
  18.191 +assumes "subtr2 ns tr1 tr2" and "ns \<subseteq> ns'"
  18.192 +shows "subtr2 ns' tr1 tr2"
  18.193 +using assms apply(induct arbitrary: ns' rule: subtr2.induct)
  18.194 +using Refl Step by (metis subtr2.simps set_mp)+
  18.195 +
  18.196 +lemma subtr2_trans_Un:
  18.197 +assumes "subtr2 ns12 tr1 tr2" and "subtr2 ns23 tr2 tr3"
  18.198 +shows "subtr2 (ns12 \<union> ns23) tr1 tr3"
  18.199 +proof-
  18.200 +  have "subtr2 ns12 tr1 tr2  \<Longrightarrow>
  18.201 +        (\<forall> ns23 tr3. subtr2 ns23 tr2 tr3 \<longrightarrow> subtr2 (ns12 \<union> ns23) tr1 tr3)"
  18.202 +  apply(induct  rule: subtr2.induct, safe)
  18.203 +    apply (metis subtr2_mono sup_commute sup_ge2)
  18.204 +    by (metis Un_iff subtr2.simps)
  18.205 +  thus ?thesis using assms by auto
  18.206 +qed
  18.207 +
  18.208 +lemma subtr2_trans:
  18.209 +assumes "subtr2 ns tr1 tr2" and "subtr2 ns tr2 tr3"
  18.210 +shows "subtr2 ns tr1 tr3"
  18.211 +using subtr2_trans_Un[OF assms] by simp
  18.212 +
  18.213 +lemma subtr2_StepR:
  18.214 +assumes r: "root tr3 \<in> ns" and tr23: "Inr tr2 \<in> cont tr3" and s: "subtr2 ns tr1 tr2"
  18.215 +shows "subtr2 ns tr1 tr3"
  18.216 +apply(rule subtr2_trans[OF s])
  18.217 +apply(rule Step[of _ _ tr3])
  18.218 +apply(rule subtr2_rootR_in[OF s])
  18.219 +apply(rule tr23)
  18.220 +apply(rule Refl[OF r])
  18.221 +done
  18.222 +
  18.223 +lemma subtr_subtr2:
  18.224 +"subtr = subtr2"
  18.225 +apply (rule ext)+  apply(safe)
  18.226 +  apply(erule subtr.induct)
  18.227 +    apply (metis (lifting) subtr2.Refl)
  18.228 +    apply (metis (lifting) subtr2_StepR)
  18.229 +  apply(erule subtr2.induct)
  18.230 +    apply (metis (lifting) subtr.Refl)
  18.231 +    apply (metis (lifting) subtr_StepL)
  18.232 +done
  18.233 +
  18.234 +lemma subtr_inductL[consumes 1, case_names Refl Step]:
  18.235 +assumes s: "subtr ns tr1 tr2" and Refl: "\<And>ns tr. \<phi> ns tr tr"
  18.236 +and Step:
  18.237 +"\<And>ns tr1 tr2 tr3.
  18.238 +   \<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr ns tr2 tr3; \<phi> ns tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> ns tr1 tr3"
  18.239 +shows "\<phi> ns tr1 tr2"
  18.240 +using s unfolding subtr_subtr2 apply(rule subtr2.induct)
  18.241 +using Refl Step unfolding subtr_subtr2 by auto
  18.242 +
  18.243 +lemma subtr_UNIV_inductL[consumes 1, case_names Refl Step]:
  18.244 +assumes s: "subtr UNIV tr1 tr2" and Refl: "\<And>tr. \<phi> tr tr"
  18.245 +and Step:
  18.246 +"\<And>tr1 tr2 tr3.
  18.247 +   \<lbrakk>Inr tr1 \<in> cont tr2; subtr UNIV tr2 tr3; \<phi> tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> tr1 tr3"
  18.248 +shows "\<phi> tr1 tr2"
  18.249 +using s apply(induct rule: subtr_inductL)
  18.250 +apply(rule Refl) using Step subtr_mono by (metis subset_UNIV)
  18.251 +
  18.252 +(* Subtree versus frontier: *)
  18.253 +lemma subtr_inFr:
  18.254 +assumes "inFr ns tr t" and "subtr ns tr tr1"
  18.255 +shows "inFr ns tr1 t"
  18.256 +proof-
  18.257 +  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inFr ns tr t \<longrightarrow> inFr ns tr1 t)"
  18.258 +  apply(induct rule: subtr.induct, safe) by (metis inFr.Ind)
  18.259 +  thus ?thesis using assms by auto
  18.260 +qed
  18.261 +
  18.262 +corollary Fr_subtr:
  18.263 +"Fr ns tr = \<Union> {Fr ns tr' | tr'. subtr ns tr' tr}"
  18.264 +unfolding Fr_def proof safe
  18.265 +  fix t assume t: "inFr ns tr t"  hence "root tr \<in> ns" by (rule inFr_root_in)
  18.266 +  thus "t \<in> \<Union>{{t. inFr ns tr' t} |tr'. subtr ns tr' tr}"
  18.267 +  apply(intro UnionI[of "{t. inFr ns tr t}" _ t]) using t subtr.Refl by auto
  18.268 +qed(metis subtr_inFr)
  18.269 +
  18.270 +lemma inFr_subtr:
  18.271 +assumes "inFr ns tr t"
  18.272 +shows "\<exists> tr'. subtr ns tr' tr \<and> Inl t \<in> cont tr'"
  18.273 +using assms apply(induct rule: inFr.induct) apply safe
  18.274 +  apply (metis subtr.Refl)
  18.275 +  by (metis (lifting) subtr.Step)
  18.276 +
  18.277 +corollary Fr_subtr_cont:
  18.278 +"Fr ns tr = \<Union> {Inl -` cont tr' | tr'. subtr ns tr' tr}"
  18.279 +unfolding Fr_def
  18.280 +apply safe
  18.281 +apply (frule inFr_subtr)
  18.282 +apply auto
  18.283 +by (metis inFr.Base subtr_inFr subtr_rootL_in)
  18.284 +
  18.285 +(* Subtree versus interior: *)
  18.286 +lemma subtr_inItr:
  18.287 +assumes "inItr ns tr n" and "subtr ns tr tr1"
  18.288 +shows "inItr ns tr1 n"
  18.289 +proof-
  18.290 +  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inItr ns tr n \<longrightarrow> inItr ns tr1 n)"
  18.291 +  apply(induct rule: subtr.induct, safe) by (metis inItr.Ind)
  18.292 +  thus ?thesis using assms by auto
  18.293 +qed
  18.294 +
  18.295 +corollary Itr_subtr:
  18.296 +"Itr ns tr = \<Union> {Itr ns tr' | tr'. subtr ns tr' tr}"
  18.297 +unfolding Itr_def apply safe
  18.298 +apply (metis (lifting, mono_tags) UnionI inItr_root_in mem_Collect_eq subtr.Refl)
  18.299 +by (metis subtr_inItr)
  18.300 +
  18.301 +lemma inItr_subtr:
  18.302 +assumes "inItr ns tr n"
  18.303 +shows "\<exists> tr'. subtr ns tr' tr \<and> root tr' = n"
  18.304 +using assms apply(induct rule: inItr.induct) apply safe
  18.305 +  apply (metis subtr.Refl)
  18.306 +  by (metis (lifting) subtr.Step)
  18.307 +
  18.308 +corollary Itr_subtr_cont:
  18.309 +"Itr ns tr = {root tr' | tr'. subtr ns tr' tr}"
  18.310 +unfolding Itr_def apply safe
  18.311 +  apply (metis (lifting, mono_tags) inItr_subtr)
  18.312 +  by (metis inItr.Base subtr_inItr subtr_rootL_in)
  18.313 +
  18.314 +
  18.315 +subsection{* The Immediate Subtree Function *}
  18.316 +
  18.317 +(* production of: *)
  18.318 +abbreviation "prodOf tr \<equiv> (id \<oplus> root) ` (cont tr)"
  18.319 +(* subtree of: *)
  18.320 +definition "subtrOf tr n \<equiv> SOME tr'. Inr tr' \<in> cont tr \<and> root tr' = n"
  18.321 +
  18.322 +lemma subtrOf:
  18.323 +assumes n: "Inr n \<in> prodOf tr"
  18.324 +shows "Inr (subtrOf tr n) \<in> cont tr \<and> root (subtrOf tr n) = n"
  18.325 +proof-
  18.326 +  obtain tr' where "Inr tr' \<in> cont tr \<and> root tr' = n"
  18.327 +  using n unfolding image_def by (metis (lifting) Inr_oplus_elim assms)
  18.328 +  thus ?thesis unfolding subtrOf_def by(rule someI)
  18.329 +qed
  18.330 +
  18.331 +lemmas Inr_subtrOf = subtrOf[THEN conjunct1]
  18.332 +lemmas root_subtrOf[simp] = subtrOf[THEN conjunct2]
  18.333 +
  18.334 +lemma Inl_prodOf: "Inl -` (prodOf tr) = Inl -` (cont tr)"
  18.335 +proof safe
  18.336 +  fix t ttr assume "Inl t = (id \<oplus> root) ttr" and "ttr \<in> cont tr"
  18.337 +  thus "t \<in> Inl -` cont tr" by(cases ttr, auto)
  18.338 +next
  18.339 +  fix t assume "Inl t \<in> cont tr" thus "t \<in> Inl -` prodOf tr"
  18.340 +  by (metis (lifting) id_def image_iff sum_map.simps(1) vimageI2)
  18.341 +qed
  18.342 +
  18.343 +lemma root_prodOf:
  18.344 +assumes "Inr tr' \<in> cont tr"
  18.345 +shows "Inr (root tr') \<in> prodOf tr"
  18.346 +by (metis (lifting) assms image_iff sum_map.simps(2))
  18.347 +
  18.348 +
  18.349 +subsection{* Well-Formed Derivation Trees *}
  18.350 +
  18.351 +hide_const wf
  18.352 +
  18.353 +coinductive wf where
  18.354 +dtree: "\<lbrakk>(root tr, (id \<oplus> root) ` (cont tr)) \<in> P; inj_on root (Inr -` cont tr);
  18.355 +        \<And> tr'. tr' \<in> Inr -` (cont tr) \<Longrightarrow> wf tr'\<rbrakk> \<Longrightarrow> wf tr"
  18.356 +
  18.357 +(* destruction rules: *)
  18.358 +lemma wf_P:
  18.359 +assumes "wf tr"
  18.360 +shows "(root tr, (id \<oplus> root) ` (cont tr)) \<in> P"
  18.361 +using assms wf.simps[of tr] by auto
  18.362 +
  18.363 +lemma wf_inj_on:
  18.364 +assumes "wf tr"
  18.365 +shows "inj_on root (Inr -` cont tr)"
  18.366 +using assms wf.simps[of tr] by auto
  18.367 +
  18.368 +lemma wf_inj[simp]:
  18.369 +assumes "wf tr" and "Inr tr1 \<in> cont tr" and "Inr tr2 \<in> cont tr"
  18.370 +shows "root tr1 = root tr2 \<longleftrightarrow> tr1 = tr2"
  18.371 +using assms wf_inj_on unfolding inj_on_def by auto
  18.372 +
  18.373 +lemma wf_cont:
  18.374 +assumes "wf tr" and "Inr tr' \<in> cont tr"
  18.375 +shows "wf tr'"
  18.376 +using assms wf.simps[of tr] by auto
  18.377 +
  18.378 +
  18.379 +(* coinduction:*)
  18.380 +lemma wf_coind[elim, consumes 1, case_names Hyp]:
  18.381 +assumes phi: "\<phi> tr"
  18.382 +and Hyp:
  18.383 +"\<And> tr. \<phi> tr \<Longrightarrow>
  18.384 +       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
  18.385 +       inj_on root (Inr -` cont tr) \<and>
  18.386 +       (\<forall> tr' \<in> Inr -` (cont tr). \<phi> tr' \<or> wf tr')"
  18.387 +shows "wf tr"
  18.388 +apply(rule wf.coinduct[of \<phi> tr, OF phi])
  18.389 +using Hyp by blast
  18.390 +
  18.391 +lemma wf_raw_coind[elim, consumes 1, case_names Hyp]:
  18.392 +assumes phi: "\<phi> tr"
  18.393 +and Hyp:
  18.394 +"\<And> tr. \<phi> tr \<Longrightarrow>
  18.395 +       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
  18.396 +       inj_on root (Inr -` cont tr) \<and>
  18.397 +       (\<forall> tr' \<in> Inr -` (cont tr). \<phi> tr')"
  18.398 +shows "wf tr"
  18.399 +using phi apply(induct rule: wf_coind)
  18.400 +using Hyp by (metis (mono_tags))
  18.401 +
  18.402 +lemma wf_subtr_inj_on:
  18.403 +assumes d: "wf tr1" and s: "subtr ns tr tr1"
  18.404 +shows "inj_on root (Inr -` cont tr)"
  18.405 +using s d apply(induct rule: subtr.induct)
  18.406 +apply (metis (lifting) wf_inj_on) by (metis wf_cont)
  18.407 +
  18.408 +lemma wf_subtr_P:
  18.409 +assumes d: "wf tr1" and s: "subtr ns tr tr1"
  18.410 +shows "(root tr, (id \<oplus> root) ` cont tr) \<in> P"
  18.411 +using s d apply(induct rule: subtr.induct)
  18.412 +apply (metis (lifting) wf_P) by (metis wf_cont)
  18.413 +
  18.414 +lemma subtrOf_root[simp]:
  18.415 +assumes tr: "wf tr" and cont: "Inr tr' \<in> cont tr"
  18.416 +shows "subtrOf tr (root tr') = tr'"
  18.417 +proof-
  18.418 +  have 0: "Inr (subtrOf tr (root tr')) \<in> cont tr" using Inr_subtrOf
  18.419 +  by (metis (lifting) cont root_prodOf)
  18.420 +  have "root (subtrOf tr (root tr')) = root tr'"
  18.421 +  using root_subtrOf by (metis (lifting) cont root_prodOf)
  18.422 +  thus ?thesis unfolding wf_inj[OF tr 0 cont] .
  18.423 +qed
  18.424 +
  18.425 +lemma surj_subtrOf:
  18.426 +assumes "wf tr" and 0: "Inr tr' \<in> cont tr"
  18.427 +shows "\<exists> n. Inr n \<in> prodOf tr \<and> subtrOf tr n = tr'"
  18.428 +apply(rule exI[of _ "root tr'"])
  18.429 +using root_prodOf[OF 0] subtrOf_root[OF assms] by simp
  18.430 +
  18.431 +lemma wf_subtr:
  18.432 +assumes "wf tr1" and "subtr ns tr tr1"
  18.433 +shows "wf tr"
  18.434 +proof-
  18.435 +  have "(\<exists> ns tr1. wf tr1 \<and> subtr ns tr tr1) \<Longrightarrow> wf tr"
  18.436 +  proof (induct rule: wf_raw_coind)
  18.437 +    case (Hyp tr)
  18.438 +    then obtain ns tr1 where tr1: "wf tr1" and tr_tr1: "subtr ns tr tr1" by auto
  18.439 +    show ?case proof safe
  18.440 +      show "(root tr, (id \<oplus> root) ` cont tr) \<in> P" using wf_subtr_P[OF tr1 tr_tr1] .
  18.441 +    next
  18.442 +      show "inj_on root (Inr -` cont tr)" using wf_subtr_inj_on[OF tr1 tr_tr1] .
  18.443 +    next
  18.444 +      fix tr' assume tr': "Inr tr' \<in> cont tr"
  18.445 +      have tr_tr1: "subtr (ns \<union> {root tr'}) tr tr1" using subtr_mono[OF tr_tr1] by auto
  18.446 +      have "subtr (ns \<union> {root tr'}) tr' tr1" using subtr_StepL[OF _ tr' tr_tr1] by auto
  18.447 +      thus "\<exists>ns' tr1. wf tr1 \<and> subtr ns' tr' tr1" using tr1 by blast
  18.448 +    qed
  18.449 +  qed
  18.450 +  thus ?thesis using assms by auto
  18.451 +qed
  18.452 +
  18.453 +
  18.454 +subsection{* Default Trees *}
  18.455 +
  18.456 +(* Pick a left-hand side of a production for each nonterminal *)
  18.457 +definition S where "S n \<equiv> SOME tns. (n,tns) \<in> P"
  18.458 +
  18.459 +lemma S_P: "(n, S n) \<in> P"
  18.460 +using used unfolding S_def by(rule someI_ex)
  18.461 +
  18.462 +lemma finite_S: "finite (S n)"
  18.463 +using S_P finite_in_P by auto
  18.464 +
  18.465 +
  18.466 +(* The default tree of a nonterminal *)
  18.467 +definition deftr :: "N \<Rightarrow> dtree" where
  18.468 +"deftr \<equiv> unfold id S"
  18.469 +
  18.470 +lemma deftr_simps[simp]:
  18.471 +"root (deftr n) = n"
  18.472 +"cont (deftr n) = image (id \<oplus> deftr) (S n)"
  18.473 +using unfold(1)[of id S n] unfold(2)[of S n id, OF finite_S]
  18.474 +unfolding deftr_def by simp_all
  18.475 +
  18.476 +lemmas root_deftr = deftr_simps(1)
  18.477 +lemmas cont_deftr = deftr_simps(2)
  18.478 +
  18.479 +lemma root_o_deftr[simp]: "root o deftr = id"
  18.480 +by (rule ext, auto)
  18.481 +
  18.482 +lemma wf_deftr: "wf (deftr n)"
  18.483 +proof-
  18.484 +  {fix tr assume "\<exists> n. tr = deftr n" hence "wf tr"
  18.485 +   apply(induct rule: wf_raw_coind) apply safe
  18.486 +   unfolding deftr_simps image_compose[symmetric] sum_map.comp id_comp
  18.487 +   root_o_deftr sum_map.id image_id id_apply apply(rule S_P)
  18.488 +   unfolding inj_on_def by auto
  18.489 +  }
  18.490 +  thus ?thesis by auto
  18.491 +qed
  18.492 +
  18.493 +
  18.494 +subsection{* Hereditary Substitution *}
  18.495 +
  18.496 +(* Auxiliary concept: The root-ommiting frontier: *)
  18.497 +definition "inFrr ns tr t \<equiv> \<exists> tr'. Inr tr' \<in> cont tr \<and> inFr ns tr' t"
  18.498 +definition "Frr ns tr \<equiv> {t. \<exists> tr'. Inr tr' \<in> cont tr \<and> t \<in> Fr ns tr'}"
  18.499 +
  18.500 +context
  18.501 +fixes tr0 :: dtree
  18.502 +begin
  18.503 +
  18.504 +definition "hsubst_r tr \<equiv> root tr"
  18.505 +definition "hsubst_c tr \<equiv> if root tr = root tr0 then cont tr0 else cont tr"
  18.506 +
  18.507 +(* Hereditary substitution: *)
  18.508 +definition hsubst :: "dtree \<Rightarrow> dtree" where
  18.509 +"hsubst \<equiv> unfold hsubst_r hsubst_c"
  18.510 +
  18.511 +lemma finite_hsubst_c: "finite (hsubst_c n)"
  18.512 +unfolding hsubst_c_def by (metis (full_types) finite_cont)
  18.513 +
  18.514 +lemma root_hsubst[simp]: "root (hsubst tr) = root tr"
  18.515 +using unfold(1)[of hsubst_r hsubst_c tr] unfolding hsubst_def hsubst_r_def by simp
  18.516 +
  18.517 +lemma root_o_subst[simp]: "root o hsubst = root"
  18.518 +unfolding comp_def root_hsubst ..
  18.519 +
  18.520 +lemma cont_hsubst_eq[simp]:
  18.521 +assumes "root tr = root tr0"
  18.522 +shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr0)"
  18.523 +apply(subst id_comp[symmetric, of id]) unfolding id_comp
  18.524 +using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
  18.525 +unfolding hsubst_def hsubst_c_def using assms by simp
  18.526 +
  18.527 +lemma hsubst_eq:
  18.528 +assumes "root tr = root tr0"
  18.529 +shows "hsubst tr = hsubst tr0"
  18.530 +apply(rule dtree_cong) using assms cont_hsubst_eq by auto
  18.531 +
  18.532 +lemma cont_hsubst_neq[simp]:
  18.533 +assumes "root tr \<noteq> root tr0"
  18.534 +shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr)"
  18.535 +apply(subst id_comp[symmetric, of id]) unfolding id_comp
  18.536 +using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
  18.537 +unfolding hsubst_def hsubst_c_def using assms by simp
  18.538 +
  18.539 +lemma Inl_cont_hsubst_eq[simp]:
  18.540 +assumes "root tr = root tr0"
  18.541 +shows "Inl -` cont (hsubst tr) = Inl -` (cont tr0)"
  18.542 +unfolding cont_hsubst_eq[OF assms] by simp
  18.543 +
  18.544 +lemma Inr_cont_hsubst_eq[simp]:
  18.545 +assumes "root tr = root tr0"
  18.546 +shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr0"
  18.547 +unfolding cont_hsubst_eq[OF assms] by simp
  18.548 +
  18.549 +lemma Inl_cont_hsubst_neq[simp]:
  18.550 +assumes "root tr \<noteq> root tr0"
  18.551 +shows "Inl -` cont (hsubst tr) = Inl -` (cont tr)"
  18.552 +unfolding cont_hsubst_neq[OF assms] by simp
  18.553 +
  18.554 +lemma Inr_cont_hsubst_neq[simp]:
  18.555 +assumes "root tr \<noteq> root tr0"
  18.556 +shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr"
  18.557 +unfolding cont_hsubst_neq[OF assms] by simp
  18.558 +
  18.559 +lemma wf_hsubst:
  18.560 +assumes tr0: "wf tr0" and tr: "wf tr"
  18.561 +shows "wf (hsubst tr)"
  18.562 +proof-
  18.563 +  {fix tr1 have "(\<exists> tr. wf tr \<and> tr1 = hsubst tr) \<Longrightarrow> wf tr1"
  18.564 +   proof (induct rule: wf_raw_coind)
  18.565 +     case (Hyp tr1) then obtain tr
  18.566 +     where dtr: "wf tr" and tr1: "tr1 = hsubst tr" by auto
  18.567 +     show ?case unfolding tr1 proof safe
  18.568 +       show "(root (hsubst tr), prodOf (hsubst tr)) \<in> P"
  18.569 +       unfolding tr1 apply(cases "root tr = root tr0")
  18.570 +       using  wf_P[OF dtr] wf_P[OF tr0]
  18.571 +       by (auto simp add: image_compose[symmetric] sum_map.comp)
  18.572 +       show "inj_on root (Inr -` cont (hsubst tr))"
  18.573 +       apply(cases "root tr = root tr0") using wf_inj_on[OF dtr] wf_inj_on[OF tr0]
  18.574 +       unfolding inj_on_def by (auto, blast)
  18.575 +       fix tr' assume "Inr tr' \<in> cont (hsubst tr)"
  18.576 +       thus "\<exists>tra. wf tra \<and> tr' = hsubst tra"
  18.577 +       apply(cases "root tr = root tr0", simp_all)
  18.578 +         apply (metis wf_cont tr0)
  18.579 +         by (metis dtr wf_cont)
  18.580 +     qed
  18.581 +   qed
  18.582 +  }
  18.583 +  thus ?thesis using assms by blast
  18.584 +qed
  18.585 +
  18.586 +lemma Frr: "Frr ns tr = {t. inFrr ns tr t}"
  18.587 +unfolding inFrr_def Frr_def Fr_def by auto
  18.588 +
  18.589 +lemma inFr_hsubst_imp:
  18.590 +assumes "inFr ns (hsubst tr) t"
  18.591 +shows "t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
  18.592 +       inFr (ns - {root tr0}) tr t"
  18.593 +proof-
  18.594 +  {fix tr1
  18.595 +   have "inFr ns tr1 t \<Longrightarrow>
  18.596 +   (\<And> tr. tr1 = hsubst tr \<Longrightarrow> (t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
  18.597 +                              inFr (ns - {root tr0}) tr t))"
  18.598 +   proof(induct rule: inFr.induct)
  18.599 +     case (Base tr1 ns t tr)
  18.600 +     hence rtr: "root tr1 \<in> ns" and t_tr1: "Inl t \<in> cont tr1" and tr1: "tr1 = hsubst tr"
  18.601 +     by auto
  18.602 +     show ?case
  18.603 +     proof(cases "root tr1 = root tr0")
  18.604 +       case True
  18.605 +       hence "t \<in> Inl -` (cont tr0)" using t_tr1 unfolding tr1 by auto
  18.606 +       thus ?thesis by simp
  18.607 +     next
  18.608 +       case False
  18.609 +       hence "inFr (ns - {root tr0}) tr t" using t_tr1 unfolding tr1 apply simp
  18.610 +       by (metis Base.prems Diff_iff root_hsubst inFr.Base rtr singletonE)
  18.611 +       thus ?thesis by simp
  18.612 +     qed
  18.613 +   next
  18.614 +     case (Ind tr1 ns tr1' t) note IH = Ind(4)
  18.615 +     have rtr1: "root tr1 \<in> ns" and tr1'_tr1: "Inr tr1' \<in> cont tr1"
  18.616 +     and t_tr1': "inFr ns tr1' t" and tr1: "tr1 = hsubst tr" using Ind by auto
  18.617 +     have rtr1: "root tr1 = root tr" unfolding tr1 by simp
  18.618 +     show ?case
  18.619 +     proof(cases "root tr1 = root tr0")
  18.620 +       case True
  18.621 +       then obtain tr' where tr'_tr0: "Inr tr' \<in> cont tr0" and tr1': "tr1' = hsubst tr'"
  18.622 +       using tr1'_tr1 unfolding tr1 by auto
  18.623 +       show ?thesis using IH[OF tr1'] proof (elim disjE)
  18.624 +         assume "inFr (ns - {root tr0}) tr' t"
  18.625 +         thus ?thesis using tr'_tr0 unfolding inFrr_def by auto
  18.626 +       qed auto
  18.627 +     next
  18.628 +       case False
  18.629 +       then obtain tr' where tr'_tr: "Inr tr' \<in> cont tr" and tr1': "tr1' = hsubst tr'"
  18.630 +       using tr1'_tr1 unfolding tr1 by auto
  18.631 +       show ?thesis using IH[OF tr1'] proof (elim disjE)
  18.632 +         assume "inFr (ns - {root tr0}) tr' t"
  18.633 +         thus ?thesis using tr'_tr unfolding inFrr_def
  18.634 +         by (metis Diff_iff False Ind(1) empty_iff inFr2_Ind inFr_inFr2 insert_iff rtr1)
  18.635 +       qed auto
  18.636 +     qed
  18.637 +   qed
  18.638 +  }
  18.639 +  thus ?thesis using assms by auto
  18.640 +qed
  18.641 +
  18.642 +lemma inFr_hsubst_notin:
  18.643 +assumes "inFr ns tr t" and "root tr0 \<notin> ns"
  18.644 +shows "inFr ns (hsubst tr) t"
  18.645 +using assms apply(induct rule: inFr.induct)
  18.646 +apply (metis Inl_cont_hsubst_neq inFr2.Base inFr_inFr2 root_hsubst vimageD vimageI2)
  18.647 +by (metis (lifting) Inr_cont_hsubst_neq inFr.Ind rev_image_eqI root_hsubst vimageD vimageI2)
  18.648 +
  18.649 +lemma inFr_hsubst_minus:
  18.650 +assumes "inFr (ns - {root tr0}) tr t"
  18.651 +shows "inFr ns (hsubst tr) t"
  18.652 +proof-
  18.653 +  have 1: "inFr (ns - {root tr0}) (hsubst tr) t"
  18.654 +  using inFr_hsubst_notin[OF assms] by simp
  18.655 +  show ?thesis using inFr_mono[OF 1] by auto
  18.656 +qed
  18.657 +
  18.658 +lemma inFr_self_hsubst:
  18.659 +assumes "root tr0 \<in> ns"
  18.660 +shows
  18.661 +"inFr ns (hsubst tr0) t \<longleftrightarrow>
  18.662 + t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t"
  18.663 +(is "?A \<longleftrightarrow> ?B \<or> ?C")
  18.664 +apply(intro iffI)
  18.665 +apply (metis inFr_hsubst_imp Diff_iff inFr_root_in insertI1) proof(elim disjE)
  18.666 +  assume ?B thus ?A apply(intro inFr.Base) using assms by auto
  18.667 +next
  18.668 +  assume ?C then obtain tr where
  18.669 +  tr_tr0: "Inr tr \<in> cont tr0" and t_tr: "inFr (ns - {root tr0}) tr t"
  18.670 +  unfolding inFrr_def by auto
  18.671 +  def tr1 \<equiv> "hsubst tr"
  18.672 +  have 1: "inFr ns tr1 t" using t_tr unfolding tr1_def using inFr_hsubst_minus by auto
  18.673 +  have "Inr tr1 \<in> cont (hsubst tr0)" unfolding tr1_def using tr_tr0 by auto
  18.674 +  thus ?A using 1 inFr.Ind assms by (metis root_hsubst)
  18.675 +qed
  18.676 +
  18.677 +lemma Fr_self_hsubst:
  18.678 +assumes "root tr0 \<in> ns"
  18.679 +shows "Fr ns (hsubst tr0) = Inl -` (cont tr0) \<union> Frr (ns - {root tr0}) tr0"
  18.680 +using inFr_self_hsubst[OF assms] unfolding Frr Fr_def by auto
  18.681 +
  18.682 +end (* context *)
  18.683 +
  18.684 +
  18.685 +subsection{* Regular Trees *}
  18.686 +
  18.687 +hide_const regular
  18.688 +
  18.689 +definition "reg f tr \<equiv> \<forall> tr'. subtr UNIV tr' tr \<longrightarrow> tr' = f (root tr')"
  18.690 +definition "regular tr \<equiv> \<exists> f. reg f tr"
  18.691 +
  18.692 +lemma reg_def2: "reg f tr \<longleftrightarrow> (\<forall> ns tr'. subtr ns tr' tr \<longrightarrow> tr' = f (root tr'))"
  18.693 +unfolding reg_def using subtr_mono by (metis subset_UNIV)
  18.694 +
  18.695 +lemma regular_def2: "regular tr \<longleftrightarrow> (\<exists> f. reg f tr \<and> (\<forall> n. root (f n) = n))"
  18.696 +unfolding regular_def proof safe
  18.697 +  fix f assume f: "reg f tr"
  18.698 +  def g \<equiv> "\<lambda> n. if inItr UNIV tr n then f n else deftr n"
  18.699 +  show "\<exists>g. reg g tr \<and> (\<forall>n. root (g n) = n)"
  18.700 +  apply(rule exI[of _ g])
  18.701 +  using f deftr_simps(1) unfolding g_def reg_def apply safe
  18.702 +    apply (metis (lifting) inItr.Base subtr_inItr subtr_rootL_in)
  18.703 +    by (metis (full_types) inItr_subtr)
  18.704 +qed auto
  18.705 +
  18.706 +lemma reg_root:
  18.707 +assumes "reg f tr"
  18.708 +shows "f (root tr) = tr"
  18.709 +using assms unfolding reg_def
  18.710 +by (metis (lifting) iso_tuple_UNIV_I subtr.Refl)
  18.711 +
  18.712 +
  18.713 +lemma reg_Inr_cont:
  18.714 +assumes "reg f tr" and "Inr tr' \<in> cont tr"
  18.715 +shows "reg f tr'"
  18.716 +by (metis (lifting) assms iso_tuple_UNIV_I reg_def subtr.Step)
  18.717 +
  18.718 +lemma reg_subtr:
  18.719 +assumes "reg f tr" and "subtr ns tr' tr"
  18.720 +shows "reg f tr'"
  18.721 +using assms unfolding reg_def using subtr_trans[of UNIV tr] UNIV_I
  18.722 +by (metis UNIV_eq_I UnCI Un_upper1 iso_tuple_UNIV_I subtr_mono subtr_trans)
  18.723 +
  18.724 +lemma regular_subtr:
  18.725 +assumes r: "regular tr" and s: "subtr ns tr' tr"
  18.726 +shows "regular tr'"
  18.727 +using r reg_subtr[OF _ s] unfolding regular_def by auto
  18.728 +
  18.729 +lemma subtr_deftr:
  18.730 +assumes "subtr ns tr' (deftr n)"
  18.731 +shows "tr' = deftr (root tr')"
  18.732 +proof-
  18.733 +  {fix tr have "subtr ns tr' tr \<Longrightarrow> (\<forall> n. tr = deftr n \<longrightarrow> tr' = deftr (root tr'))"
  18.734 +   apply (induct rule: subtr.induct)
  18.735 +   proof(metis (lifting) deftr_simps(1), safe)
  18.736 +     fix tr3 ns tr1 tr2 n
  18.737 +     assume 1: "root (deftr n) \<in> ns" and 2: "subtr ns tr1 tr2"
  18.738 +     and IH: "\<forall>n. tr2 = deftr n \<longrightarrow> tr1 = deftr (root tr1)"
  18.739 +     and 3: "Inr tr2 \<in> cont (deftr n)"
  18.740 +     have "tr2 \<in> deftr ` UNIV"
  18.741 +     using 3 unfolding deftr_simps image_def
  18.742 +     by (metis (lifting, full_types) 3 CollectI Inr_oplus_iff cont_deftr
  18.743 +         iso_tuple_UNIV_I)
  18.744 +     then obtain n where "tr2 = deftr n" by auto
  18.745 +     thus "tr1 = deftr (root tr1)" using IH by auto
  18.746 +   qed
  18.747 +  }
  18.748 +  thus ?thesis using assms by auto
  18.749 +qed
  18.750 +
  18.751 +lemma reg_deftr: "reg deftr (deftr n)"
  18.752 +unfolding reg_def using subtr_deftr by auto
  18.753 +
  18.754 +lemma wf_subtrOf_Union:
  18.755 +assumes "wf tr"
  18.756 +shows "\<Union>{K tr' |tr'. Inr tr' \<in> cont tr} =
  18.757 +       \<Union>{K (subtrOf tr n) |n. Inr n \<in> prodOf tr}"
  18.758 +unfolding Union_eq Bex_def mem_Collect_eq proof safe
  18.759 +  fix x xa tr'
  18.760 +  assume x: "x \<in> K tr'" and tr'_tr: "Inr tr' \<in> cont tr"
  18.761 +  show "\<exists>X. (\<exists>n. X = K (subtrOf tr n) \<and> Inr n \<in> prodOf tr) \<and> x \<in> X"
  18.762 +  apply(rule exI[of _ "K (subtrOf tr (root tr'))"]) apply(intro conjI)
  18.763 +    apply(rule exI[of _ "root tr'"]) apply (metis (lifting) root_prodOf tr'_tr)
  18.764 +    by (metis (lifting) assms subtrOf_root tr'_tr x)
  18.765 +next
  18.766 +  fix x X n ttr
  18.767 +  assume x: "x \<in> K (subtrOf tr n)" and n: "Inr n = (id \<oplus> root) ttr" and ttr: "ttr \<in> cont tr"
  18.768 +  show "\<exists>X. (\<exists>tr'. X = K tr' \<and> Inr tr' \<in> cont tr) \<and> x \<in> X"
  18.769 +  apply(rule exI[of _ "K (subtrOf tr n)"]) apply(intro conjI)
  18.770 +    apply(rule exI[of _ "subtrOf tr n"]) apply (metis imageI n subtrOf ttr)
  18.771 +    using x .
  18.772 +qed
  18.773 +
  18.774 +
  18.775 +
  18.776 +
  18.777 +subsection {* Paths in a Regular Tree *}
  18.778 +
  18.779 +inductive path :: "(N \<Rightarrow> dtree) \<Rightarrow> N list \<Rightarrow> bool" for f where
  18.780 +Base: "path f [n]"
  18.781 +|
  18.782 +Ind: "\<lbrakk>path f (n1 # nl); Inr (f n1) \<in> cont (f n)\<rbrakk>
  18.783 +      \<Longrightarrow> path f (n # n1 # nl)"
  18.784 +
  18.785 +lemma path_NE:
  18.786 +assumes "path f nl"
  18.787 +shows "nl \<noteq> Nil"
  18.788 +using assms apply(induct rule: path.induct) by auto
  18.789 +
  18.790 +lemma path_post:
  18.791 +assumes f: "path f (n # nl)" and nl: "nl \<noteq> []"
  18.792 +shows "path f nl"
  18.793 +proof-
  18.794 +  obtain n1 nl1 where nl: "nl = n1 # nl1" using nl by (cases nl, auto)
  18.795 +  show ?thesis using assms unfolding nl using path.simps by (metis (lifting) list.inject)
  18.796 +qed
  18.797 +
  18.798 +lemma path_post_concat:
  18.799 +assumes "path f (nl1 @ nl2)" and "nl2 \<noteq> Nil"
  18.800 +shows "path f nl2"
  18.801 +using assms apply (induct nl1)
  18.802 +apply (metis append_Nil) by (metis Nil_is_append_conv append_Cons path_post)
  18.803 +
  18.804 +lemma path_concat:
  18.805 +assumes "path f nl1" and "path f ((last nl1) # nl2)"
  18.806 +shows "path f (nl1 @ nl2)"
  18.807 +using assms apply(induct rule: path.induct) apply simp
  18.808 +by (metis append_Cons last.simps list.simps(3) path.Ind)
  18.809 +
  18.810 +lemma path_distinct:
  18.811 +assumes "path f nl"
  18.812 +shows "\<exists> nl'. path f nl' \<and> hd nl' = hd nl \<and> last nl' = last nl \<and>
  18.813 +              set nl' \<subseteq> set nl \<and> distinct nl'"
  18.814 +using assms proof(induct rule: length_induct)
  18.815 +  case (1 nl)  hence p_nl: "path f nl" by simp
  18.816 +  then obtain n nl1 where nl: "nl = n # nl1" by (metis list.exhaust path_NE)
  18.817 +  show ?case
  18.818 +  proof(cases nl1)
  18.819 +    case Nil
  18.820 +    show ?thesis apply(rule exI[of _ nl]) using path.Base unfolding nl Nil by simp
  18.821 +  next
  18.822 +    case (Cons n1 nl2)
  18.823 +    hence p1: "path f nl1" by (metis list.simps(3) nl p_nl path_post)
  18.824 +    show ?thesis
  18.825 +    proof(cases "n \<in> set nl1")
  18.826 +      case False
  18.827 +      obtain nl1' where p1': "path f nl1'" and hd_nl1': "hd nl1' = hd nl1" and
  18.828 +      l_nl1': "last nl1' = last nl1" and d_nl1': "distinct nl1'"
  18.829 +      and s_nl1': "set nl1' \<subseteq> set nl1"
  18.830 +      using 1(1)[THEN allE[of _ nl1]] p1 unfolding nl by auto
  18.831 +      obtain nl2' where nl1': "nl1' = n1 # nl2'" using path_NE[OF p1'] hd_nl1'
  18.832 +      unfolding Cons by(cases nl1', auto)
  18.833 +      show ?thesis apply(intro exI[of _ "n # nl1'"]) unfolding nl proof safe
  18.834 +        show "path f (n # nl1')" unfolding nl1'
  18.835 +        apply(rule path.Ind, metis nl1' p1')
  18.836 +        by (metis (lifting) Cons list.inject nl p1 p_nl path.simps path_NE)
  18.837 +      qed(insert l_nl1' Cons nl1' s_nl1' d_nl1' False, auto)
  18.838 +    next
  18.839 +      case True
  18.840 +      then obtain nl11 nl12 where nl1: "nl1 = nl11 @ n # nl12"
  18.841 +      by (metis split_list)
  18.842 +      have p12: "path f (n # nl12)"
  18.843 +      apply(rule path_post_concat[of _ "n # nl11"]) using p_nl[unfolded nl nl1] by auto
  18.844 +      obtain nl12' where p1': "path f nl12'" and hd_nl12': "hd nl12' = n" and
  18.845 +      l_nl12': "last nl12' = last (n # nl12)" and d_nl12': "distinct nl12'"
  18.846 +      and s_nl12': "set nl12' \<subseteq> {n} \<union> set nl12"
  18.847 +      using 1(1)[THEN allE[of _ "n # nl12"]] p12 unfolding nl nl1 by auto
  18.848 +      thus ?thesis apply(intro exI[of _ nl12']) unfolding nl nl1 by auto
  18.849 +    qed
  18.850 +  qed
  18.851 +qed
  18.852 +
  18.853 +lemma path_subtr:
  18.854 +assumes f: "\<And> n. root (f n) = n"
  18.855 +and p: "path f nl"
  18.856 +shows "subtr (set nl) (f (last nl)) (f (hd nl))"
  18.857 +using p proof (induct rule: path.induct)
  18.858 +  case (Ind n1 nl n)  let ?ns1 = "insert n1 (set nl)"
  18.859 +  have "path f (n1 # nl)"
  18.860 +  and "subtr ?ns1 (f (last (n1 # nl))) (f n1)"
  18.861 +  and fn1: "Inr (f n1) \<in> cont (f n)" using Ind by simp_all
  18.862 +  hence fn1_flast:  "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n1)"
  18.863 +  by (metis subset_insertI subtr_mono)
  18.864 +  have 1: "last (n # n1 # nl) = last (n1 # nl)" by auto
  18.865 +  have "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n)"
  18.866 +  using f subtr.Step[OF _ fn1_flast fn1] by auto
  18.867 +  thus ?case unfolding 1 by simp
  18.868 +qed (metis f hd.simps last_ConsL last_in_set not_Cons_self2 subtr.Refl)
  18.869 +
  18.870 +lemma reg_subtr_path_aux:
  18.871 +assumes f: "reg f tr" and n: "subtr ns tr1 tr"
  18.872 +shows "\<exists> nl. path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
  18.873 +using n f proof(induct rule: subtr.induct)
  18.874 +  case (Refl tr ns)
  18.875 +  thus ?case
  18.876 +  apply(intro exI[of _ "[root tr]"]) apply simp by (metis (lifting) path.Base reg_root)
  18.877 +next
  18.878 +  case (Step tr ns tr2 tr1)
  18.879 +  hence rtr: "root tr \<in> ns" and tr1_tr: "Inr tr1 \<in> cont tr"
  18.880 +  and tr2_tr1: "subtr ns tr2 tr1" and tr: "reg f tr" by auto
  18.881 +  have tr1: "reg f tr1" using reg_subtr[OF tr] rtr tr1_tr
  18.882 +  by (metis (lifting) Step.prems iso_tuple_UNIV_I reg_def subtr.Step)
  18.883 +  obtain nl where nl: "path f nl" and f_nl: "f (hd nl) = tr1"
  18.884 +  and last_nl: "f (last nl) = tr2" and set: "set nl \<subseteq> ns" using Step(3)[OF tr1] by auto
  18.885 +  have 0: "path f (root tr # nl)" apply (subst path.simps)
  18.886 +  using f_nl nl reg_root tr tr1_tr by (metis hd.simps neq_Nil_conv)
  18.887 +  show ?case apply(rule exI[of _ "(root tr) # nl"])
  18.888 +  using 0 reg_root tr last_nl nl path_NE rtr set by auto
  18.889 +qed
  18.890 +
  18.891 +lemma reg_subtr_path:
  18.892 +assumes f: "reg f tr" and n: "subtr ns tr1 tr"
  18.893 +shows "\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
  18.894 +using reg_subtr_path_aux[OF assms] path_distinct[of f]
  18.895 +by (metis (lifting) order_trans)
  18.896 +
  18.897 +lemma subtr_iff_path:
  18.898 +assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
  18.899 +shows "subtr ns tr1 tr \<longleftrightarrow>
  18.900 +       (\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns)"
  18.901 +proof safe
  18.902 +  fix nl assume p: "path f nl" and nl: "set nl \<subseteq> ns"
  18.903 +  have "subtr (set nl) (f (last nl)) (f (hd nl))"
  18.904 +  apply(rule path_subtr) using p f by simp_all
  18.905 +  thus "subtr ns (f (last nl)) (f (hd nl))"
  18.906 +  using subtr_mono nl by auto
  18.907 +qed(insert reg_subtr_path[OF r], auto)
  18.908 +
  18.909 +lemma inFr_iff_path:
  18.910 +assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
  18.911 +shows
  18.912 +"inFr ns tr t \<longleftrightarrow>
  18.913 + (\<exists> nl tr1. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and>
  18.914 +            set nl \<subseteq> ns \<and> Inl t \<in> cont tr1)"
  18.915 +apply safe
  18.916 +apply (metis (no_types) inFr_subtr r reg_subtr_path)
  18.917 +by (metis f inFr.Base path_subtr subtr_inFr subtr_mono subtr_rootL_in)
  18.918 +
  18.919 +
  18.920 +
  18.921 +subsection{* The Regular Cut of a Tree *}
  18.922 +
  18.923 +context fixes tr0 :: dtree
  18.924 +begin
  18.925 +
  18.926 +(* Picking a subtree of a certain root: *)
  18.927 +definition "pick n \<equiv> SOME tr. subtr UNIV tr tr0 \<and> root tr = n"
  18.928 +
  18.929 +lemma pick:
  18.930 +assumes "inItr UNIV tr0 n"
  18.931 +shows "subtr UNIV (pick n) tr0 \<and> root (pick n) = n"
  18.932 +proof-
  18.933 +  have "\<exists> tr. subtr UNIV tr tr0 \<and> root tr = n"
  18.934 +  using assms by (metis (lifting) inItr_subtr)
  18.935 +  thus ?thesis unfolding pick_def by(rule someI_ex)
  18.936 +qed
  18.937 +
  18.938 +lemmas subtr_pick = pick[THEN conjunct1]
  18.939 +lemmas root_pick = pick[THEN conjunct2]
  18.940 +
  18.941 +lemma wf_pick:
  18.942 +assumes tr0: "wf tr0" and n: "inItr UNIV tr0 n"
  18.943 +shows "wf (pick n)"
  18.944 +using wf_subtr[OF tr0 subtr_pick[OF n]] .
  18.945 +
  18.946 +definition "H_r n \<equiv> root (pick n)"
  18.947 +definition "H_c n \<equiv> (id \<oplus> root) ` cont (pick n)"
  18.948 +
  18.949 +(* The regular tree of a function: *)
  18.950 +definition H :: "N \<Rightarrow> dtree" where
  18.951 +"H \<equiv> unfold H_r H_c"
  18.952 +
  18.953 +lemma finite_H_c: "finite (H_c n)"
  18.954 +unfolding H_c_def by (metis finite_cont finite_imageI)
  18.955 +
  18.956 +lemma root_H_pick: "root (H n) = root (pick n)"
  18.957 +using unfold(1)[of H_r H_c n] unfolding H_def H_r_def by simp
  18.958 +
  18.959 +lemma root_H[simp]:
  18.960 +assumes "inItr UNIV tr0 n"
  18.961 +shows "root (H n) = n"
  18.962 +unfolding root_H_pick root_pick[OF assms] ..
  18.963 +
  18.964 +lemma cont_H[simp]:
  18.965 +"cont (H n) = (id \<oplus> (H o root)) ` cont (pick n)"
  18.966 +apply(subst id_comp[symmetric, of id]) unfolding sum_map.comp[symmetric]
  18.967 +unfolding image_compose unfolding H_c_def[symmetric]
  18.968 +using unfold(2)[of H_c n H_r, OF finite_H_c]
  18.969 +unfolding H_def ..
  18.970 +
  18.971 +lemma Inl_cont_H[simp]:
  18.972 +"Inl -` (cont (H n)) = Inl -` (cont (pick n))"
  18.973 +unfolding cont_H by simp
  18.974 +
  18.975 +lemma Inr_cont_H:
  18.976 +"Inr -` (cont (H n)) = (H \<circ> root) ` (Inr -` cont (pick n))"
  18.977 +unfolding cont_H by simp
  18.978 +
  18.979 +lemma subtr_H:
  18.980 +assumes n: "inItr UNIV tr0 n" and "subtr UNIV tr1 (H n)"
  18.981 +shows "\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = H n1"
  18.982 +proof-
  18.983 +  {fix tr ns assume "subtr UNIV tr1 tr"
  18.984 +   hence "tr = H n \<longrightarrow> (\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = H n1)"
  18.985 +   proof (induct rule: subtr_UNIV_inductL)
  18.986 +     case (Step tr2 tr1 tr)
  18.987 +     show ?case proof
  18.988 +       assume "tr = H n"
  18.989 +       then obtain n1 where tr2: "Inr tr2 \<in> cont tr1"
  18.990 +       and tr1_tr: "subtr UNIV tr1 tr" and n1: "inItr UNIV tr0 n1" and tr1: "tr1 = H n1"
  18.991 +       using Step by auto
  18.992 +       obtain tr2' where tr2: "tr2 = H (root tr2')"
  18.993 +       and tr2': "Inr tr2' \<in> cont (pick n1)"
  18.994 +       using tr2 Inr_cont_H[of n1]
  18.995 +       unfolding tr1 image_def comp_def using vimage_eq by auto
  18.996 +       have "inItr UNIV tr0 (root tr2')"
  18.997 +       using inItr.Base inItr.Ind n1 pick subtr_inItr tr2' by (metis iso_tuple_UNIV_I)
  18.998 +       thus "\<exists>n2. inItr UNIV tr0 n2 \<and> tr2 = H n2" using tr2 by blast
  18.999 +     qed
 18.1000 +   qed(insert n, auto)
 18.1001 +  }
 18.1002 +  thus ?thesis using assms by auto
 18.1003 +qed
 18.1004 +
 18.1005 +lemma root_H_root:
 18.1006 +assumes n: "inItr UNIV tr0 n" and t_tr: "t_tr \<in> cont (pick n)"
 18.1007 +shows "(id \<oplus> (root \<circ> H \<circ> root)) t_tr = (id \<oplus> root) t_tr"
 18.1008 +using assms apply(cases t_tr)
 18.1009 +  apply (metis (lifting) sum_map.simps(1))
 18.1010 +  using pick H_def H_r_def unfold(1)
 18.1011 +      inItr.Base comp_apply subtr_StepL subtr_inItr sum_map.simps(2)
 18.1012 +  by (metis UNIV_I)
 18.1013 +
 18.1014 +lemma H_P:
 18.1015 +assumes tr0: "wf tr0" and n: "inItr UNIV tr0 n"
 18.1016 +shows "(n, (id \<oplus> root) ` cont (H n)) \<in> P" (is "?L \<in> P")
 18.1017 +proof-
 18.1018 +  have "?L = (n, (id \<oplus> root) ` cont (pick n))"
 18.1019 +  unfolding cont_H image_compose[symmetric] sum_map.comp id_comp comp_assoc[symmetric]
 18.1020 +  unfolding Pair_eq apply(rule conjI[OF refl]) apply(rule image_cong[OF refl])
 18.1021 +  by (rule root_H_root[OF n])
 18.1022 +  moreover have "... \<in> P" by (metis (lifting) wf_pick root_pick wf_P n tr0)
 18.1023 +  ultimately show ?thesis by simp
 18.1024 +qed
 18.1025 +
 18.1026 +lemma wf_H:
 18.1027 +assumes tr0: "wf tr0" and "inItr UNIV tr0 n"
 18.1028 +shows "wf (H n)"
 18.1029 +proof-
 18.1030 +  {fix tr have "\<exists> n. inItr UNIV tr0 n \<and> tr = H n \<Longrightarrow> wf tr"
 18.1031 +   proof (induct rule: wf_raw_coind)
 18.1032 +     case (Hyp tr)
 18.1033 +     then obtain n where n: "inItr UNIV tr0 n" and tr: "tr = H n" by auto
 18.1034 +     show ?case apply safe
 18.1035 +     apply (metis (lifting) H_P root_H n tr tr0)
 18.1036 +     unfolding tr Inr_cont_H unfolding inj_on_def apply clarsimp using root_H
 18.1037 +     apply (metis UNIV_I inItr.Base n pick subtr2.simps subtr_inItr subtr_subtr2)
 18.1038 +     by (metis n subtr.Refl subtr_StepL subtr_H tr UNIV_I)
 18.1039 +   qed
 18.1040 +  }
 18.1041 +  thus ?thesis using assms by blast
 18.1042 +qed
 18.1043 +
 18.1044 +(* The regular cut of a tree: *)
 18.1045 +definition "rcut \<equiv> H (root tr0)"
 18.1046 +
 18.1047 +lemma reg_rcut: "reg H rcut"
 18.1048 +unfolding reg_def rcut_def
 18.1049 +by (metis inItr.Base root_H subtr_H UNIV_I)
 18.1050 +
 18.1051 +lemma rcut_reg:
 18.1052 +assumes "reg H tr0"
 18.1053 +shows "rcut = tr0"
 18.1054 +using assms unfolding rcut_def reg_def by (metis subtr.Refl UNIV_I)
 18.1055 +
 18.1056 +lemma rcut_eq: "rcut = tr0 \<longleftrightarrow> reg H tr0"
 18.1057 +using reg_rcut rcut_reg by metis
 18.1058 +
 18.1059 +lemma regular_rcut: "regular rcut"
 18.1060 +using reg_rcut unfolding regular_def by blast
 18.1061 +
 18.1062 +lemma Fr_rcut: "Fr UNIV rcut \<subseteq> Fr UNIV tr0"
 18.1063 +proof safe
 18.1064 +  fix t assume "t \<in> Fr UNIV rcut"
 18.1065 +  then obtain tr where t: "Inl t \<in> cont tr" and tr: "subtr UNIV tr (H (root tr0))"
 18.1066 +  using Fr_subtr[of UNIV "H (root tr0)"] unfolding rcut_def
 18.1067 +  by (metis (full_types) Fr_def inFr_subtr mem_Collect_eq)
 18.1068 +  obtain n where n: "inItr UNIV tr0 n" and tr: "tr = H n" using tr
 18.1069 +  by (metis (lifting) inItr.Base subtr_H UNIV_I)
 18.1070 +  have "Inl t \<in> cont (pick n)" using t using Inl_cont_H[of n] unfolding tr
 18.1071 +  by (metis (lifting) vimageD vimageI2)
 18.1072 +  moreover have "subtr UNIV (pick n) tr0" using subtr_pick[OF n] ..
 18.1073 +  ultimately show "t \<in> Fr UNIV tr0" unfolding Fr_subtr_cont by auto
 18.1074 +qed
 18.1075 +
 18.1076 +lemma wf_rcut:
 18.1077 +assumes "wf tr0"
 18.1078 +shows "wf rcut"
 18.1079 +unfolding rcut_def using wf_H[OF assms inItr.Base] by simp
 18.1080 +
 18.1081 +lemma root_rcut[simp]: "root rcut = root tr0"
 18.1082 +unfolding rcut_def
 18.1083 +by (metis (lifting) root_H inItr.Base reg_def reg_root subtr_rootR_in)
 18.1084 +
 18.1085 +end (* context *)
 18.1086 +
 18.1087 +
 18.1088 +subsection{* Recursive Description of the Regular Tree Frontiers *}
 18.1089 +
 18.1090 +lemma regular_inFr:
 18.1091 +assumes r: "regular tr" and In: "root tr \<in> ns"
 18.1092 +and t: "inFr ns tr t"
 18.1093 +shows "t \<in> Inl -` (cont tr) \<or>
 18.1094 +       (\<exists> tr'. Inr tr' \<in> cont tr \<and> inFr (ns - {root tr}) tr' t)"
 18.1095 +(is "?L \<or> ?R")
 18.1096 +proof-
 18.1097 +  obtain f where r: "reg f tr" and f: "\<And>n. root (f n) = n"
 18.1098 +  using r unfolding regular_def2 by auto
 18.1099 +  obtain nl tr1 where d_nl: "distinct nl" and p: "path f nl" and hd_nl: "f (hd nl) = tr"
 18.1100 +  and l_nl: "f (last nl) = tr1" and s_nl: "set nl \<subseteq> ns" and t_tr1: "Inl t \<in> cont tr1"
 18.1101 +  using t unfolding inFr_iff_path[OF r f] by auto
 18.1102 +  obtain n nl1 where nl: "nl = n # nl1" by (metis (lifting) p path.simps)
 18.1103 +  hence f_n: "f n = tr" using hd_nl by simp
 18.1104 +  have n_nl1: "n \<notin> set nl1" using d_nl unfolding nl by auto
 18.1105 +  show ?thesis
 18.1106 +  proof(cases nl1)
 18.1107 +    case Nil hence "tr = tr1" using f_n l_nl unfolding nl by simp
 18.1108 +    hence ?L using t_tr1 by simp thus ?thesis by simp
 18.1109 +  next
 18.1110 +    case (Cons n1 nl2) note nl1 = Cons
 18.1111 +    have 1: "last nl1 = last nl" "hd nl1 = n1" unfolding nl nl1 by simp_all
 18.1112 +    have p1: "path f nl1" and n1_tr: "Inr (f n1) \<in> cont tr"
 18.1113 +    using path.simps[of f nl] p f_n unfolding nl nl1 by auto
 18.1114 +    have r1: "reg f (f n1)" using reg_Inr_cont[OF r n1_tr] .
 18.1115 +    have 0: "inFr (set nl1) (f n1) t" unfolding inFr_iff_path[OF r1 f]
 18.1116 +    apply(intro exI[of _ nl1], intro exI[of _ tr1])
 18.1117 +    using d_nl unfolding 1 l_nl unfolding nl using p1 t_tr1 by auto
 18.1118 +    have root_tr: "root tr = n" by (metis f f_n)
 18.1119 +    have "inFr (ns - {root tr}) (f n1) t" apply(rule inFr_mono[OF 0])
 18.1120 +    using s_nl unfolding root_tr unfolding nl using n_nl1 by auto
 18.1121 +    thus ?thesis using n1_tr by auto
 18.1122 +  qed
 18.1123 +qed
 18.1124 +
 18.1125 +lemma regular_Fr:
 18.1126 +assumes r: "regular tr" and In: "root tr \<in> ns"
 18.1127 +shows "Fr ns tr =
 18.1128 +       Inl -` (cont tr) \<union>
 18.1129 +       \<Union> {Fr (ns - {root tr}) tr' | tr'. Inr tr' \<in> cont tr}"
 18.1130 +unfolding Fr_def
 18.1131 +using In inFr.Base regular_inFr[OF assms] apply safe
 18.1132 +apply (simp, metis (full_types) mem_Collect_eq)
 18.1133 +apply simp
 18.1134 +by (simp, metis (lifting) inFr_Ind_minus insert_Diff)
 18.1135 +
 18.1136 +
 18.1137 +subsection{* The Generated Languages *}
 18.1138 +
 18.1139 +(* The (possibly inifinite tree) generated language *)
 18.1140 +definition "L ns n \<equiv> {Fr ns tr | tr. wf tr \<and> root tr = n}"
 18.1141 +
 18.1142 +(* The regular-tree generated language *)
 18.1143 +definition "Lr ns n \<equiv> {Fr ns tr | tr. wf tr \<and> root tr = n \<and> regular tr}"
 18.1144 +
 18.1145 +lemma L_rec_notin:
 18.1146 +assumes "n \<notin> ns"
 18.1147 +shows "L ns n = {{}}"
 18.1148 +using assms unfolding L_def apply safe
 18.1149 +  using not_root_Fr apply force
 18.1150 +  apply(rule exI[of _ "deftr n"])
 18.1151 +  by (metis (no_types) wf_deftr not_root_Fr root_deftr)
 18.1152 +
 18.1153 +lemma Lr_rec_notin:
 18.1154 +assumes "n \<notin> ns"
 18.1155 +shows "Lr ns n = {{}}"
 18.1156 +using assms unfolding Lr_def apply safe
 18.1157 +  using not_root_Fr apply force
 18.1158 +  apply(rule exI[of _ "deftr n"])
 18.1159 +  by (metis (no_types) regular_def wf_deftr not_root_Fr reg_deftr root_deftr)
 18.1160 +
 18.1161 +lemma wf_subtrOf:
 18.1162 +assumes "wf tr" and "Inr n \<in> prodOf tr"
 18.1163 +shows "wf (subtrOf tr n)"
 18.1164 +by (metis assms wf_cont subtrOf)
 18.1165 +
 18.1166 +lemma Lr_rec_in:
 18.1167 +assumes n: "n \<in> ns"
 18.1168 +shows "Lr ns n \<subseteq>
 18.1169 +{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
 18.1170 +    (n,tns) \<in> P \<and>
 18.1171 +    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n')}"
 18.1172 +(is "Lr ns n \<subseteq> {?F tns K | tns K. (n,tns) \<in> P \<and> ?\<phi> tns K}")
 18.1173 +proof safe
 18.1174 +  fix ts assume "ts \<in> Lr ns n"
 18.1175 +  then obtain tr where dtr: "wf tr" and r: "root tr = n" and tr: "regular tr"
 18.1176 +  and ts: "ts = Fr ns tr" unfolding Lr_def by auto
 18.1177 +  def tns \<equiv> "(id \<oplus> root) ` (cont tr)"
 18.1178 +  def K \<equiv> "\<lambda> n'. Fr (ns - {n}) (subtrOf tr n')"
 18.1179 +  show "\<exists>tns K. ts = ?F tns K \<and> (n, tns) \<in> P \<and> ?\<phi> tns K"
 18.1180 +  apply(rule exI[of _ tns], rule exI[of _ K]) proof(intro conjI allI impI)
 18.1181 +    show "ts = Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns}"
 18.1182 +    unfolding ts regular_Fr[OF tr n[unfolded r[symmetric]]]
 18.1183 +    unfolding tns_def K_def r[symmetric]
 18.1184 +    unfolding Inl_prodOf wf_subtrOf_Union[OF dtr] ..
 18.1185 +    show "(n, tns) \<in> P" unfolding tns_def r[symmetric] using wf_P[OF dtr] .
 18.1186 +    fix n' assume "Inr n' \<in> tns" thus "K n' \<in> Lr (ns - {n}) n'"
 18.1187 +    unfolding K_def Lr_def mem_Collect_eq apply(intro exI[of _ "subtrOf tr n'"])
 18.1188 +    using dtr tr apply(intro conjI refl)  unfolding tns_def
 18.1189 +      apply(erule wf_subtrOf[OF dtr])
 18.1190 +      apply (metis subtrOf)
 18.1191 +      by (metis Inr_subtrOf UNIV_I regular_subtr subtr.simps)
 18.1192 +  qed
 18.1193 +qed
 18.1194 +
 18.1195 +lemma hsubst_aux:
 18.1196 +fixes n ftr tns
 18.1197 +assumes n: "n \<in> ns" and tns: "finite tns" and
 18.1198 +1: "\<And> n'. Inr n' \<in> tns \<Longrightarrow> wf (ftr n')"
 18.1199 +defines "tr \<equiv> Node n ((id \<oplus> ftr) ` tns)"  defines "tr' \<equiv> hsubst tr tr"
 18.1200 +shows "Fr ns tr' = Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
 18.1201 +(is "_ = ?B") proof-
 18.1202 +  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
 18.1203 +  unfolding tr_def using tns by auto
 18.1204 +  have Frr: "Frr (ns - {n}) tr = \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
 18.1205 +  unfolding Frr_def ctr by auto
 18.1206 +  have "Fr ns tr' = Inl -` (cont tr) \<union> Frr (ns - {n}) tr"
 18.1207 +  using Fr_self_hsubst[OF n[unfolded rtr[symmetric]]] unfolding tr'_def rtr ..
 18.1208 +  also have "... = ?B" unfolding ctr Frr by simp
 18.1209 +  finally show ?thesis .
 18.1210 +qed
 18.1211 +
 18.1212 +lemma L_rec_in:
 18.1213 +assumes n: "n \<in> ns"
 18.1214 +shows "
 18.1215 +{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
 18.1216 +    (n,tns) \<in> P \<and>
 18.1217 +    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n')}
 18.1218 + \<subseteq> L ns n"
 18.1219 +proof safe
 18.1220 +  fix tns K
 18.1221 +  assume P: "(n, tns) \<in> P" and 0: "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n'"
 18.1222 +  {fix n' assume "Inr n' \<in> tns"
 18.1223 +   hence "K n' \<in> L (ns - {n}) n'" using 0 by auto
 18.1224 +   hence "\<exists> tr'. K n' = Fr (ns - {n}) tr' \<and> wf tr' \<and> root tr' = n'"
 18.1225 +   unfolding L_def mem_Collect_eq by auto
 18.1226 +  }
 18.1227 +  then obtain ftr where 0: "\<And> n'. Inr n' \<in> tns \<Longrightarrow>
 18.1228 +  K n' = Fr (ns - {n}) (ftr n') \<and> wf (ftr n') \<and> root (ftr n') = n'"
 18.1229 +  by metis
 18.1230 +  def tr \<equiv> "Node n ((id \<oplus> ftr) ` tns)"  def tr' \<equiv> "hsubst tr tr"
 18.1231 +  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
 18.1232 +  unfolding tr_def by (simp, metis P cont_Node finite_imageI finite_in_P)
 18.1233 +  have prtr: "prodOf tr = tns" apply(rule Inl_Inr_image_cong)
 18.1234 +  unfolding ctr apply simp apply simp apply safe
 18.1235 +  using 0 unfolding image_def apply force apply simp by (metis 0 vimageI2)
 18.1236 +  have 1: "{K n' |n'. Inr n' \<in> tns} = {Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
 18.1237 +  using 0 by auto
 18.1238 +  have dtr: "wf tr" apply(rule wf.dtree)
 18.1239 +    apply (metis (lifting) P prtr rtr)
 18.1240 +    unfolding inj_on_def ctr using 0 by auto
 18.1241 +  hence dtr': "wf tr'" unfolding tr'_def by (metis wf_hsubst)
 18.1242 +  have tns: "finite tns" using finite_in_P P by simp
 18.1243 +  have "Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns} \<in> L ns n"
 18.1244 +  unfolding L_def mem_Collect_eq apply(intro exI[of _ tr'] conjI)
 18.1245 +  using dtr' 0 hsubst_aux[OF assms tns, of ftr] unfolding tr_def tr'_def by auto
 18.1246 +  thus "Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} \<in> L ns n" unfolding 1 .
 18.1247 +qed
 18.1248 +
 18.1249 +lemma card_N: "(n::N) \<in> ns \<Longrightarrow> card (ns - {n}) < card ns"
 18.1250 +by (metis finite_N Diff_UNIV Diff_infinite_finite card_Diff1_less finite.emptyI)
 18.1251 +
 18.1252 +function LL where
 18.1253 +"LL ns n =
 18.1254 + (if n \<notin> ns then {{}} else
 18.1255 + {Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
 18.1256 +    (n,tns) \<in> P \<and>
 18.1257 +    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n')})"
 18.1258 +by(pat_completeness, auto)
 18.1259 +termination apply(relation "inv_image (measure card) fst")
 18.1260 +using card_N by auto
 18.1261 +
 18.1262 +declare LL.simps[code]
 18.1263 +declare LL.simps[simp del]
 18.1264 +
 18.1265 +lemma Lr_LL: "Lr ns n \<subseteq> LL ns n"
 18.1266 +proof (induct ns arbitrary: n rule: measure_induct[of card])
 18.1267 +  case (1 ns n) show ?case proof(cases "n \<in> ns")
 18.1268 +    case False thus ?thesis unfolding Lr_rec_notin[OF False] by (simp add: LL.simps)
 18.1269 +  next
 18.1270 +    case True show ?thesis apply(rule subset_trans)
 18.1271 +    using Lr_rec_in[OF True] apply assumption
 18.1272 +    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
 18.1273 +      fix tns K
 18.1274 +      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
 18.1275 +      assume "(n, tns) \<in> P"
 18.1276 +      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n'"
 18.1277 +      thus "\<exists>tnsa Ka.
 18.1278 +             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
 18.1279 +             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
 18.1280 +             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> LL (ns - {n}) n')"
 18.1281 +      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
 18.1282 +    qed
 18.1283 +  qed
 18.1284 +qed
 18.1285 +
 18.1286 +lemma LL_L: "LL ns n \<subseteq> L ns n"
 18.1287 +proof (induct ns arbitrary: n rule: measure_induct[of card])
 18.1288 +  case (1 ns n) show ?case proof(cases "n \<in> ns")
 18.1289 +    case False thus ?thesis unfolding L_rec_notin[OF False] by (simp add: LL.simps)
 18.1290 +  next
 18.1291 +    case True show ?thesis apply(rule subset_trans)
 18.1292 +    prefer 2 using L_rec_in[OF True] apply assumption
 18.1293 +    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
 18.1294 +      fix tns K
 18.1295 +      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
 18.1296 +      assume "(n, tns) \<in> P"
 18.1297 +      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n'"
 18.1298 +      thus "\<exists>tnsa Ka.
 18.1299 +             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
 18.1300 +             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
 18.1301 +             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> L (ns - {n}) n')"
 18.1302 +      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
 18.1303 +    qed
 18.1304 +  qed
 18.1305 +qed
 18.1306 +
 18.1307 +(* The subsumpsion relation between languages *)
 18.1308 +definition "subs L1 L2 \<equiv> \<forall> ts2 \<in> L2. \<exists> ts1 \<in> L1. ts1 \<subseteq> ts2"
 18.1309 +
 18.1310 +lemma incl_subs[simp]: "L2 \<subseteq> L1 \<Longrightarrow> subs L1 L2"
 18.1311 +unfolding subs_def by auto
 18.1312 +
 18.1313 +lemma subs_refl[simp]: "subs L1 L1" unfolding subs_def by auto
 18.1314 +
 18.1315 +lemma subs_trans: "\<lbrakk>subs L1 L2; subs L2 L3\<rbrakk> \<Longrightarrow> subs L1 L3"
 18.1316 +unfolding subs_def by (metis subset_trans)
 18.1317 +
 18.1318 +(* Language equivalence *)
 18.1319 +definition "leqv L1 L2 \<equiv> subs L1 L2 \<and> subs L2 L1"
 18.1320 +
 18.1321 +lemma subs_leqv[simp]: "leqv L1 L2 \<Longrightarrow> subs L1 L2"
 18.1322 +unfolding leqv_def by auto
 18.1323 +
 18.1324 +lemma subs_leqv_sym[simp]: "leqv L1 L2 \<Longrightarrow> subs L2 L1"
 18.1325 +unfolding leqv_def by auto
 18.1326 +
 18.1327 +lemma leqv_refl[simp]: "leqv L1 L1" unfolding leqv_def by auto
 18.1328 +
 18.1329 +lemma leqv_trans:
 18.1330 +assumes 12: "leqv L1 L2" and 23: "leqv L2 L3"
 18.1331 +shows "leqv L1 L3"
 18.1332 +using assms unfolding leqv_def by (metis (lifting) subs_trans)
 18.1333 +
 18.1334 +lemma leqv_sym: "leqv L1 L2 \<Longrightarrow> leqv L2 L1"
 18.1335 +unfolding leqv_def by auto
 18.1336 +
 18.1337 +lemma leqv_Sym: "leqv L1 L2 \<longleftrightarrow> leqv L2 L1"
 18.1338 +unfolding leqv_def by auto
 18.1339 +
 18.1340 +lemma Lr_incl_L: "Lr ns ts \<subseteq> L ns ts"
 18.1341 +unfolding Lr_def L_def by auto
 18.1342 +
 18.1343 +lemma Lr_subs_L: "subs (Lr UNIV ts) (L UNIV ts)"
 18.1344 +unfolding subs_def proof safe
 18.1345 +  fix ts2 assume "ts2 \<in> L UNIV ts"
 18.1346 +  then obtain tr where ts2: "ts2 = Fr UNIV tr" and dtr: "wf tr" and rtr: "root tr = ts"
 18.1347 +  unfolding L_def by auto
 18.1348 +  thus "\<exists>ts1\<in>Lr UNIV ts. ts1 \<subseteq> ts2"
 18.1349 +  apply(intro bexI[of _ "Fr UNIV (rcut tr)"])
 18.1350 +  unfolding Lr_def L_def using Fr_rcut wf_rcut root_rcut regular_rcut by auto
 18.1351 +qed
 18.1352 +
 18.1353 +lemma Lr_leqv_L: "leqv (Lr UNIV ts) (L UNIV ts)"
 18.1354 +using Lr_subs_L unfolding leqv_def by (metis (lifting) Lr_incl_L incl_subs)
 18.1355 +
 18.1356 +lemma LL_leqv_L: "leqv (LL UNIV ts) (L UNIV ts)"
 18.1357 +by (metis (lifting) LL_L Lr_LL Lr_subs_L incl_subs leqv_def subs_trans)
 18.1358 +
 18.1359 +lemma LL_leqv_Lr: "leqv (LL UNIV ts) (Lr UNIV ts)"
 18.1360 +using Lr_leqv_L LL_leqv_L by (metis leqv_Sym leqv_trans)
 18.1361 +
 18.1362 +end
    19.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.2 +++ b/src/HOL/BNF_Examples/Derivation_Trees/Parallel.thy	Mon Jan 20 18:24:56 2014 +0100
    19.3 @@ -0,0 +1,147 @@
    19.4 +(*  Title:      HOL/BNF/Examples/Derivation_Trees/Parallel.thy
    19.5 +    Author:     Andrei Popescu, TU Muenchen
    19.6 +    Copyright   2012
    19.7 +
    19.8 +Parallel composition.
    19.9 +*)
   19.10 +
   19.11 +header {* Parallel Composition *}
   19.12 +
   19.13 +theory Parallel
   19.14 +imports DTree
   19.15 +begin
   19.16 +
   19.17 +no_notation plus_class.plus (infixl "+" 65)
   19.18 +
   19.19 +consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)
   19.20 +
   19.21 +axiomatization where
   19.22 +    Nplus_comm: "(a::N) + b = b + (a::N)"
   19.23 +and Nplus_assoc: "((a::N) + b) + c = a + (b + c)"
   19.24 +
   19.25 +subsection{* Corecursive Definition of Parallel Composition *}
   19.26 +
   19.27 +fun par_r where "par_r (tr1,tr2) = root tr1 + root tr2"
   19.28 +fun par_c where
   19.29 +"par_c (tr1,tr2) =
   19.30 + Inl ` (Inl -` (cont tr1 \<union> cont tr2)) \<union>
   19.31 + Inr ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
   19.32 +
   19.33 +declare par_r.simps[simp del]  declare par_c.simps[simp del]
   19.34 +
   19.35 +definition par :: "dtree \<times> dtree \<Rightarrow> dtree" where
   19.36 +"par \<equiv> unfold par_r par_c"
   19.37 +
   19.38 +abbreviation par_abbr (infixr "\<parallel>" 80) where "tr1 \<parallel> tr2 \<equiv> par (tr1, tr2)"
   19.39 +
   19.40 +lemma finite_par_c: "finite (par_c (tr1, tr2))"
   19.41 +unfolding par_c.simps apply(rule finite_UnI)
   19.42 +  apply (metis finite_Un finite_cont finite_imageI finite_vimageI inj_Inl)
   19.43 +  apply(intro finite_imageI finite_cartesian_product finite_vimageI)
   19.44 +  using finite_cont by auto
   19.45 +
   19.46 +lemma root_par: "root (tr1 \<parallel> tr2) = root tr1 + root tr2"
   19.47 +using unfold(1)[of par_r par_c "(tr1,tr2)"] unfolding par_def par_r.simps by simp
   19.48 +
   19.49 +lemma cont_par:
   19.50 +"cont (tr1 \<parallel> tr2) = (id \<oplus> par) ` par_c (tr1,tr2)"
   19.51 +using unfold(2)[of par_c "(tr1,tr2)" par_r, OF finite_par_c]
   19.52 +unfolding par_def ..
   19.53 +
   19.54 +lemma Inl_cont_par[simp]:
   19.55 +"Inl -` (cont (tr1 \<parallel> tr2)) = Inl -` (cont tr1 \<union> cont tr2)"
   19.56 +unfolding cont_par par_c.simps by auto
   19.57 +
   19.58 +lemma Inr_cont_par[simp]:
   19.59 +"Inr -` (cont (tr1 \<parallel> tr2)) = par ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
   19.60 +unfolding cont_par par_c.simps by auto
   19.61 +
   19.62 +lemma Inl_in_cont_par:
   19.63 +"Inl t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (Inl t \<in> cont tr1 \<or> Inl t \<in> cont tr2)"
   19.64 +using Inl_cont_par[of tr1 tr2] unfolding vimage_def by auto
   19.65 +
   19.66 +lemma Inr_in_cont_par:
   19.67 +"Inr t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (t \<in> par ` (Inr -` cont tr1 \<times> Inr -` cont tr2))"
   19.68 +using Inr_cont_par[of tr1 tr2] unfolding vimage_def by auto
   19.69 +
   19.70 +
   19.71 +subsection{* Structural Coinduction Proofs *}
   19.72 +
   19.73 +lemma set_rel_sum_rel_eq[simp]:
   19.74 +"set_rel (sum_rel (op =) \<phi>) A1 A2 \<longleftrightarrow>
   19.75 + Inl -` A1 = Inl -` A2 \<and> set_rel \<phi> (Inr -` A1) (Inr -` A2)"
   19.76 +unfolding set_rel_sum_rel set_rel_eq ..
   19.77 +
   19.78 +(* Detailed proofs of commutativity and associativity: *)
   19.79 +theorem par_com: "tr1 \<parallel> tr2 = tr2 \<parallel> tr1"
   19.80 +proof-
   19.81 +  let ?\<theta> = "\<lambda> trA trB. \<exists> tr1 tr2. trA = tr1 \<parallel> tr2 \<and> trB = tr2 \<parallel> tr1"
   19.82 +  {fix trA trB
   19.83 +   assume "?\<theta> trA trB" hence "trA = trB"
   19.84 +   apply (induct rule: dtree_coinduct)
   19.85 +   unfolding set_rel_sum_rel set_rel_eq unfolding set_rel_def proof safe
   19.86 +     fix tr1 tr2  show "root (tr1 \<parallel> tr2) = root (tr2 \<parallel> tr1)"
   19.87 +     unfolding root_par by (rule Nplus_comm)
   19.88 +   next
   19.89 +     fix n tr1 tr2 assume "Inl n \<in> cont (tr1 \<parallel> tr2)" thus "n \<in> Inl -` (cont (tr2 \<parallel> tr1))"
   19.90 +     unfolding Inl_in_cont_par by auto
   19.91 +   next
   19.92 +     fix n tr1 tr2 assume "Inl n \<in> cont (tr2 \<parallel> tr1)" thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2))"
   19.93 +     unfolding Inl_in_cont_par by auto
   19.94 +   next
   19.95 +     fix tr1 tr2 trA' assume "Inr trA' \<in> cont (tr1 \<parallel> tr2)"
   19.96 +     then obtain tr1' tr2' where "trA' = tr1' \<parallel> tr2'"
   19.97 +     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
   19.98 +     unfolding Inr_in_cont_par by auto
   19.99 +     thus "\<exists> trB' \<in> Inr -` (cont (tr2 \<parallel> tr1)). ?\<theta> trA' trB'"
  19.100 +     apply(intro bexI[of _ "tr2' \<parallel> tr1'"]) unfolding Inr_in_cont_par by auto
  19.101 +   next
  19.102 +     fix tr1 tr2 trB' assume "Inr trB' \<in> cont (tr2 \<parallel> tr1)"
  19.103 +     then obtain tr1' tr2' where "trB' = tr2' \<parallel> tr1'"
  19.104 +     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
  19.105 +     unfolding Inr_in_cont_par by auto
  19.106 +     thus "\<exists> trA' \<in> Inr -` (cont (tr1 \<parallel> tr2)). ?\<theta> trA' trB'"
  19.107 +     apply(intro bexI[of _ "tr1' \<parallel> tr2'"]) unfolding Inr_in_cont_par by auto
  19.108 +   qed
  19.109 +  }
  19.110 +  thus ?thesis by blast
  19.111 +qed
  19.112 +
  19.113 +lemma par_assoc: "(tr1 \<parallel> tr2) \<parallel> tr3 = tr1 \<parallel> (tr2 \<parallel> tr3)"
  19.114 +proof-
  19.115 +  let ?\<theta> =
  19.116 +  "\<lambda> trA trB. \<exists> tr1 tr2 tr3. trA = (tr1 \<parallel> tr2) \<parallel> tr3 \<and> trB = tr1 \<parallel> (tr2 \<parallel> tr3)"
  19.117 +  {fix trA trB
  19.118 +   assume "?\<theta> trA trB" hence "trA = trB"
  19.119 +   apply (induct rule: dtree_coinduct)
  19.120 +   unfolding set_rel_sum_rel set_rel_eq unfolding set_rel_def proof safe
  19.121 +     fix tr1 tr2 tr3  show "root ((tr1 \<parallel> tr2) \<parallel> tr3) = root (tr1 \<parallel> (tr2 \<parallel> tr3))"
  19.122 +     unfolding root_par by (rule Nplus_assoc)
  19.123 +   next
  19.124 +     fix n tr1 tr2 tr3 assume "Inl n \<in> (cont ((tr1 \<parallel> tr2) \<parallel> tr3))"
  19.125 +     thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2 \<parallel> tr3))" unfolding Inl_in_cont_par by simp
  19.126 +   next
  19.127 +     fix n tr1 tr2 tr3 assume "Inl n \<in> (cont (tr1 \<parallel> tr2 \<parallel> tr3))"
  19.128 +     thus "n \<in> Inl -` (cont ((tr1 \<parallel> tr2) \<parallel> tr3))" unfolding Inl_in_cont_par by simp
  19.129 +   next
  19.130 +     fix trA' tr1 tr2 tr3 assume "Inr trA' \<in> cont ((tr1 \<parallel> tr2) \<parallel> tr3)"
  19.131 +     then obtain tr1' tr2' tr3' where "trA' = (tr1' \<parallel> tr2') \<parallel> tr3'"
  19.132 +     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
  19.133 +     and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
  19.134 +     thus "\<exists> trB' \<in> Inr -` (cont (tr1 \<parallel> tr2 \<parallel> tr3)). ?\<theta> trA' trB'"
  19.135 +     apply(intro bexI[of _ "tr1' \<parallel> tr2' \<parallel> tr3'"])
  19.136 +     unfolding Inr_in_cont_par by auto
  19.137 +   next
  19.138 +     fix trB' tr1 tr2 tr3 assume "Inr trB' \<in> cont (tr1 \<parallel> tr2 \<parallel> tr3)"
  19.139 +     then obtain tr1' tr2' tr3' where "trB' = tr1' \<parallel> (tr2' \<parallel> tr3')"
  19.140 +     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
  19.141 +     and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
  19.142 +     thus "\<exists> trA' \<in> Inr -` cont ((tr1 \<parallel> tr2) \<parallel> tr3). ?\<theta> trA' trB'"
  19.143 +     apply(intro bexI[of _ "(tr1' \<parallel> tr2') \<parallel> tr3'"])
  19.144 +     unfolding Inr_in_cont_par by auto
  19.145 +   qed
  19.146 +  }
  19.147 +  thus ?thesis by blast
  19.148 +qed
  19.149 +
  19.150 +end
    20.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.2 +++ b/src/HOL/BNF_Examples/Derivation_Trees/Prelim.thy	Mon Jan 20 18:24:56 2014 +0100
    20.3 @@ -0,0 +1,62 @@
    20.4 +(*  Title:      HOL/BNF/Examples/Derivation_Trees/Prelim.thy
    20.5 +    Author:     Andrei Popescu, TU Muenchen
    20.6 +    Copyright   2012
    20.7 +
    20.8 +Preliminaries.
    20.9 +*)
   20.10 +
   20.11 +header {* Preliminaries *}
   20.12 +
   20.13 +theory Prelim
   20.14 +imports "../../BNF" "../../More_BNFs"
   20.15 +begin
   20.16 +
   20.17 +declare fset_to_fset[simp]
   20.18 +
   20.19 +lemma fst_snd_convol_o[simp]: "<fst o s, snd o s> = s"
   20.20 +apply(rule ext) by (simp add: convol_def)
   20.21 +
   20.22 +abbreviation sm_abbrev (infix "\<oplus>" 60)
   20.23 +where "f \<oplus> g \<equiv> Sum_Type.sum_map f g"
   20.24 +
   20.25 +lemma sum_map_InlD: "(f \<oplus> g) z = Inl x \<Longrightarrow> \<exists>y. z = Inl y \<and> f y = x"
   20.26 +by (cases z) auto
   20.27 +
   20.28 +lemma sum_map_InrD: "(f \<oplus> g) z = Inr x \<Longrightarrow> \<exists>y. z = Inr y \<and> g y = x"
   20.29 +by (cases z) auto
   20.30 +
   20.31 +abbreviation sum_case_abbrev ("[[_,_]]" 800)
   20.32 +where "[[f,g]] \<equiv> Sum_Type.sum_case f g"
   20.33 +
   20.34 +lemma Inl_oplus_elim:
   20.35 +assumes "Inl tr \<in> (id \<oplus> f) ` tns"
   20.36 +shows "Inl tr \<in> tns"
   20.37 +using assms apply clarify by (case_tac x, auto)
   20.38 +
   20.39 +lemma Inl_oplus_iff[simp]: "Inl tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> Inl tr \<in> tns"
   20.40 +using Inl_oplus_elim
   20.41 +by (metis id_def image_iff sum_map.simps(1))
   20.42 +
   20.43 +lemma Inl_m_oplus[simp]: "Inl -` (id \<oplus> f) ` tns = Inl -` tns"
   20.44 +using Inl_oplus_iff unfolding vimage_def by auto
   20.45 +
   20.46 +lemma Inr_oplus_elim:
   20.47 +assumes "Inr tr \<in> (id \<oplus> f) ` tns"
   20.48 +shows "\<exists> n. Inr n \<in> tns \<and> f n = tr"
   20.49 +using assms apply clarify by (case_tac x, auto)
   20.50 +
   20.51 +lemma Inr_oplus_iff[simp]:
   20.52 +"Inr tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> (\<exists> n. Inr n \<in> tns \<and> f n = tr)"
   20.53 +apply (rule iffI)
   20.54 + apply (metis Inr_oplus_elim)
   20.55 +by (metis image_iff sum_map.simps(2))
   20.56 +
   20.57 +lemma Inr_m_oplus[simp]: "Inr -` (id \<oplus> f) ` tns = f ` (Inr -` tns)"
   20.58 +using Inr_oplus_iff unfolding vimage_def by auto
   20.59 +
   20.60 +lemma Inl_Inr_image_cong:
   20.61 +assumes "Inl -` A = Inl -` B" and "Inr -` A = Inr -` B"
   20.62 +shows "A = B"
   20.63 +apply safe using assms apply(case_tac x, auto) by(case_tac x, auto)
   20.64 +
   20.65 +end
   20.66 \ No newline at end of file
    21.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.2 +++ b/src/HOL/BNF_Examples/Koenig.thy	Mon Jan 20 18:24:56 2014 +0100
    21.3 @@ -0,0 +1,122 @@
    21.4 +(*  Title:      HOL/BNF/Examples/Koenig.thy
    21.5 +    Author:     Dmitriy Traytel, TU Muenchen
    21.6 +    Author:     Andrei Popescu, TU Muenchen
    21.7 +    Copyright   2012
    21.8 +
    21.9 +Koenig's lemma.
   21.10 +*)
   21.11 +
   21.12 +header {* Koenig's lemma *}
   21.13 +
   21.14 +theory Koenig
   21.15 +imports TreeFI Stream
   21.16 +begin
   21.17 +
   21.18 +(* infinite trees: *)
   21.19 +coinductive infiniteTr where
   21.20 +"\<lbrakk>tr' \<in> set_listF (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"
   21.21 +
   21.22 +lemma infiniteTr_strong_coind[consumes 1, case_names sub]:
   21.23 +assumes *: "phi tr" and
   21.24 +**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set_listF (sub tr). phi tr' \<or> infiniteTr tr'"
   21.25 +shows "infiniteTr tr"
   21.26 +using assms by (elim infiniteTr.coinduct) blast
   21.27 +
   21.28 +lemma infiniteTr_coind[consumes 1, case_names sub, induct pred: infiniteTr]:
   21.29 +assumes *: "phi tr" and
   21.30 +**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set_listF (sub tr). phi tr'"
   21.31 +shows "infiniteTr tr"
   21.32 +using assms by (elim infiniteTr.coinduct) blast
   21.33 +
   21.34 +lemma infiniteTr_sub[simp]:
   21.35 +"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> set_listF (sub tr). infiniteTr tr')"
   21.36 +by (erule infiniteTr.cases) blast
   21.37 +
   21.38 +primcorec konigPath where
   21.39 +  "shd (konigPath t) = lab t"
   21.40 +| "stl (konigPath t) = konigPath (SOME tr. tr \<in> set_listF (sub t) \<and> infiniteTr tr)"
   21.41 +
   21.42 +(* proper paths in trees: *)
   21.43 +coinductive properPath where
   21.44 +"\<lbrakk>shd as = lab tr; tr' \<in> set_listF (sub tr); properPath (stl as) tr'\<rbrakk> \<Longrightarrow>
   21.45 + properPath as tr"
   21.46 +
   21.47 +lemma properPath_strong_coind[consumes 1, case_names shd_lab sub]:
   21.48 +assumes *: "phi as tr" and
   21.49 +**: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
   21.50 +***: "\<And> as tr.
   21.51 +         phi as tr \<Longrightarrow>
   21.52 +         \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
   21.53 +shows "properPath as tr"
   21.54 +using assms by (elim properPath.coinduct) blast
   21.55 +
   21.56 +lemma properPath_coind[consumes 1, case_names shd_lab sub, induct pred: properPath]:
   21.57 +assumes *: "phi as tr" and
   21.58 +**: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
   21.59 +***: "\<And> as tr.
   21.60 +         phi as tr \<Longrightarrow>
   21.61 +         \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr'"
   21.62 +shows "properPath as tr"
   21.63 +using properPath_strong_coind[of phi, OF * **] *** by blast
   21.64 +
   21.65 +lemma properPath_shd_lab:
   21.66 +"properPath as tr \<Longrightarrow> shd as = lab tr"
   21.67 +by (erule properPath.cases) blast
   21.68 +
   21.69 +lemma properPath_sub:
   21.70 +"properPath as tr \<Longrightarrow>
   21.71 + \<exists> tr' \<in> set_listF (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
   21.72 +by (erule properPath.cases) blast
   21.73 +
   21.74 +(* prove the following by coinduction *)
   21.75 +theorem Konig:
   21.76 +  assumes "infiniteTr tr"
   21.77 +  shows "properPath (konigPath tr) tr"
   21.78 +proof-
   21.79 +  {fix as
   21.80 +   assume "infiniteTr tr \<and> as = konigPath tr" hence "properPath as tr"
   21.81 +   proof (coinduction arbitrary: tr as rule: properPath_coind)
   21.82 +     case (sub tr as)
   21.83 +     let ?t = "SOME t'. t' \<in> set_listF (sub tr) \<and> infiniteTr t'"
   21.84 +     from sub have "\<exists>t' \<in> set_listF (sub tr). infiniteTr t'" by simp
   21.85 +     then have "\<exists>t'. t' \<in> set_listF (sub tr) \<and> infiniteTr t'" by blast
   21.86 +     then have "?t \<in> set_listF (sub tr) \<and> infiniteTr ?t" by (rule someI_ex)
   21.87 +     moreover have "stl (konigPath tr) = konigPath ?t" by simp
   21.88 +     ultimately show ?case using sub by blast
   21.89 +   qed simp
   21.90 +  }
   21.91 +  thus ?thesis using assms by blast
   21.92 +qed
   21.93 +
   21.94 +(* some more stream theorems *)
   21.95 +
   21.96 +primcorec plus :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<oplus>" 66) where
   21.97 +  "shd (plus xs ys) = shd xs + shd ys"
   21.98 +| "stl (plus xs ys) = plus (stl xs) (stl ys)"
   21.99 +
  21.100 +definition scalar :: "nat \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<cdot>" 68) where
  21.101 +  [simp]: "scalar n = smap (\<lambda>x. n * x)"
  21.102 +
  21.103 +primcorec ones :: "nat stream" where "ones = 1 ## ones"
  21.104 +primcorec twos :: "nat stream" where "twos = 2 ## twos"
  21.105 +definition ns :: "nat \<Rightarrow> nat stream" where [simp]: "ns n = scalar n ones"
  21.106 +
  21.107 +lemma "ones \<oplus> ones = twos"
  21.108 +  by coinduction simp
  21.109 +
  21.110 +lemma "n \<cdot> twos = ns (2 * n)"
  21.111 +  by coinduction simp
  21.112 +
  21.113 +lemma prod_scalar: "(n * m) \<cdot> xs = n \<cdot> m \<cdot> xs"
  21.114 +  by (coinduction arbitrary: xs) auto
  21.115 +
  21.116 +lemma scalar_plus: "n \<cdot> (xs \<oplus> ys) = n \<cdot> xs \<oplus> n \<cdot> ys"
  21.117 +  by (coinduction arbitrary: xs ys) (auto simp: add_mult_distrib2)
  21.118 +
  21.119 +lemma plus_comm: "xs \<oplus> ys = ys \<oplus> xs"
  21.120 +  by (coinduction arbitrary: xs ys) auto
  21.121 +
  21.122 +lemma plus_assoc: "(xs \<oplus> ys) \<oplus> zs = xs \<oplus> ys \<oplus> zs"
  21.123 +  by (coinduction arbitrary: xs ys zs) auto
  21.124 +
  21.125 +end
    22.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.2 +++ b/src/HOL/BNF_Examples/Lambda_Term.thy	Mon Jan 20 18:24:56 2014 +0100
    22.3 @@ -0,0 +1,52 @@
    22.4 +(*  Title:      HOL/BNF/Examples/Lambda_Term.thy
    22.5 +    Author:     Dmitriy Traytel, TU Muenchen
    22.6 +    Author:     Andrei Popescu, TU Muenchen
    22.7 +    Copyright   2012
    22.8 +
    22.9 +Lambda-terms.
   22.10 +*)
   22.11 +
   22.12 +header {* Lambda-Terms *}
   22.13 +
   22.14 +theory Lambda_Term
   22.15 +imports "../More_BNFs"
   22.16 +begin
   22.17 +
   22.18 +thy_deps
   22.19 +
   22.20 +section {* Datatype definition *}
   22.21 +
   22.22 +datatype_new 'a trm =
   22.23 +  Var 'a |
   22.24 +  App "'a trm" "'a trm" |
   22.25 +  Lam 'a "'a trm" |
   22.26 +  Lt "('a \<times> 'a trm) fset" "'a trm"
   22.27 +
   22.28 +
   22.29 +subsection{* Example: The set of all variables varsOf and free variables fvarsOf of a term: *}
   22.30 +
   22.31 +primrec_new varsOf :: "'a trm \<Rightarrow> 'a set" where
   22.32 +  "varsOf (Var a) = {a}"
   22.33 +| "varsOf (App f x) = varsOf f \<union> varsOf x"
   22.34 +| "varsOf (Lam x b) = {x} \<union> varsOf b"
   22.35 +| "varsOf (Lt F t) = varsOf t \<union> (\<Union> { {x} \<union> X | x X. (x,X) |\<in>| fimage (map_pair id varsOf) F})"
   22.36 +
   22.37 +primrec_new fvarsOf :: "'a trm \<Rightarrow> 'a set" where
   22.38 +  "fvarsOf (Var x) = {x}"
   22.39 +| "fvarsOf (App t1 t2) = fvarsOf t1 \<union> fvarsOf t2"
   22.40 +| "fvarsOf (Lam x t) = fvarsOf t - {x}"
   22.41 +| "fvarsOf (Lt xts t) = fvarsOf t - {x | x X. (x,X) |\<in>| fimage (map_pair id varsOf) xts} \<union>
   22.42 +    (\<Union> {X | x X. (x,X) |\<in>| fimage (map_pair id varsOf) xts})"
   22.43 +
   22.44 +lemma diff_Un_incl_triv: "\<lbrakk>A \<subseteq> D; C \<subseteq> E\<rbrakk> \<Longrightarrow> A - B \<union> C \<subseteq> D \<union> E" by blast
   22.45 +
   22.46 +lemma in_fmap_map_pair_fset_iff[simp]:
   22.47 +  "(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)"
   22.48 +  by force
   22.49 +
   22.50 +lemma fvarsOf_varsOf: "fvarsOf t \<subseteq> varsOf t"
   22.51 +proof induct
   22.52 +  case (Lt xts t) thus ?case unfolding fvarsOf.simps varsOf.simps by (elim diff_Un_incl_triv) auto
   22.53 +qed auto
   22.54 +
   22.55 +end
    23.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.2 +++ b/src/HOL/BNF_Examples/ListF.thy	Mon Jan 20 18:24:56 2014 +0100
    23.3 @@ -0,0 +1,111 @@
    23.4 +(*  Title:      HOL/BNF/Examples/ListF.thy
    23.5 +    Author:     Dmitriy Traytel, TU Muenchen
    23.6 +    Author:     Andrei Popescu, TU Muenchen
    23.7 +    Copyright   2012
    23.8 +
    23.9 +Finite lists.
   23.10 +*)
   23.11 +
   23.12 +header {* Finite Lists *}
   23.13 +
   23.14 +theory ListF
   23.15 +imports "../BNF"
   23.16 +begin
   23.17 +
   23.18 +datatype_new 'a listF (map: mapF rel: relF) =
   23.19 +  NilF (defaults tlF: NilF) | Conss (hdF: 'a) (tlF: "'a listF")
   23.20 +datatype_new_compat listF
   23.21 +
   23.22 +definition Singll ("[[_]]") where
   23.23 +  [simp]: "Singll a \<equiv> Conss a NilF"
   23.24 +
   23.25 +primrec_new appendd (infixr "@@" 65) where
   23.26 +  "NilF @@ ys = ys"
   23.27 +| "Conss x xs @@ ys = Conss x (xs @@ ys)"
   23.28 +
   23.29 +primrec_new lrev where
   23.30 +  "lrev NilF = NilF"
   23.31 +| "lrev (Conss y ys) = lrev ys @@ [[y]]"
   23.32 +
   23.33 +lemma appendd_NilF[simp]: "xs @@ NilF = xs"
   23.34 +  by (induct xs) auto
   23.35 +
   23.36 +lemma appendd_assoc[simp]: "(xs @@ ys) @@ zs = xs @@ ys @@ zs"
   23.37 +  by (induct xs) auto
   23.38 +
   23.39 +lemma lrev_appendd[simp]: "lrev (xs @@ ys) = lrev ys @@ lrev xs"
   23.40 +  by (induct xs) auto
   23.41 +
   23.42 +lemma listF_map_appendd[simp]:
   23.43 +  "mapF f (xs @@ ys) = mapF f xs @@ mapF f ys"
   23.44 +  by (induct xs) auto
   23.45 +
   23.46 +lemma lrev_listF_map[simp]: "lrev (mapF f xs) = mapF f (lrev xs)"
   23.47 +  by (induct xs) auto
   23.48 +
   23.49 +lemma lrev_lrev[simp]: "lrev (lrev xs) = xs"
   23.50 +  by (induct xs) auto
   23.51 +
   23.52 +primrec_new lengthh where
   23.53 +  "lengthh NilF = 0"
   23.54 +| "lengthh (Conss x xs) = Suc (lengthh xs)"
   23.55 +
   23.56 +fun nthh where
   23.57 +  "nthh (Conss x xs) 0 = x"
   23.58 +| "nthh (Conss x xs) (Suc n) = nthh xs n"
   23.59 +| "nthh xs i = undefined"
   23.60 +
   23.61 +lemma lengthh_listF_map[simp]: "lengthh (mapF f xs) = lengthh xs"
   23.62 +  by (induct xs) auto
   23.63 +
   23.64 +lemma nthh_listF_map[simp]:
   23.65 +  "i < lengthh xs \<Longrightarrow> nthh (mapF f xs) i = f (nthh xs i)"
   23.66 +  by (induct rule: nthh.induct) auto
   23.67 +
   23.68 +lemma nthh_listF_set[simp]: "i < lengthh xs \<Longrightarrow> nthh xs i \<in> set_listF xs"
   23.69 +  by (induct rule: nthh.induct) auto
   23.70 +
   23.71 +lemma NilF_iff[iff]: "(lengthh xs = 0) = (xs = NilF)"
   23.72 +  by (induct xs) auto
   23.73 +
   23.74 +lemma Conss_iff[iff]:
   23.75 +  "(lengthh xs = Suc n) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
   23.76 +  by (induct xs) auto
   23.77 +
   23.78 +lemma Conss_iff'[iff]:
   23.79 +  "(Suc n = lengthh xs) = (\<exists>y ys. xs = Conss y ys \<and> lengthh ys = n)"
   23.80 +  by (induct xs) (simp, simp, blast)
   23.81 +
   23.82 +lemma listF_induct2[consumes 1, case_names NilF Conss]: "\<lbrakk>lengthh xs = lengthh ys; P NilF NilF;
   23.83 +    \<And>x xs y ys. P xs ys \<Longrightarrow> P (Conss x xs) (Conss y ys)\<rbrakk> \<Longrightarrow> P xs ys"
   23.84 +    by (induct xs arbitrary: ys) auto
   23.85 +
   23.86 +fun zipp where
   23.87 +  "zipp NilF NilF = NilF"
   23.88 +| "zipp (Conss x xs) (Conss y ys) = Conss (x, y) (zipp xs ys)"
   23.89 +| "zipp xs ys = undefined"
   23.90 +
   23.91 +lemma listF_map_fst_zip[simp]:
   23.92 +  "lengthh xs = lengthh ys \<Longrightarrow> mapF fst (zipp xs ys) = xs"
   23.93 +  by (induct rule: listF_induct2) auto
   23.94 +
   23.95 +lemma listF_map_snd_zip[simp]:
   23.96 +  "lengthh xs = lengthh ys \<Longrightarrow> mapF snd (zipp xs ys) = ys"
   23.97 +  by (induct rule: listF_induct2) auto
   23.98 +
   23.99 +lemma lengthh_zip[simp]:
  23.100 +  "lengthh xs = lengthh ys \<Longrightarrow> lengthh (zipp xs ys) = lengthh xs"
  23.101 +  by (induct rule: listF_induct2) auto
  23.102 +
  23.103 +lemma nthh_zip[simp]:
  23.104 +  assumes "lengthh xs = lengthh ys"
  23.105 +  shows "i < lengthh xs \<Longrightarrow> nthh (zipp xs ys) i = (nthh xs i, nthh ys i)"
  23.106 +using assms proof (induct arbitrary: i rule: listF_induct2)
  23.107 +  case (Conss x xs y ys) thus ?case by (induct i) auto
  23.108 +qed simp
  23.109 +
  23.110 +lemma list_set_nthh[simp]:
  23.111 +  "(x \<in> set_listF xs) \<Longrightarrow> (\<exists>i < lengthh xs. nthh xs i = x)"
  23.112 +  by (induct xs) (auto, induct rule: nthh.induct, auto)
  23.113 +
  23.114 +end
    24.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.2 +++ b/src/HOL/BNF_Examples/Misc_Codatatype.thy	Mon Jan 20 18:24:56 2014 +0100
    24.3 @@ -0,0 +1,120 @@
    24.4 +(*  Title:      HOL/BNF/Examples/Misc_Codatatype.thy
    24.5 +    Author:     Dmitriy Traytel, TU Muenchen
    24.6 +    Author:     Andrei Popescu, TU Muenchen
    24.7 +    Author:     Jasmin Blanchette, TU Muenchen
    24.8 +    Copyright   2012, 2013
    24.9 +
   24.10 +Miscellaneous codatatype definitions.
   24.11 +*)
   24.12 +
   24.13 +header {* Miscellaneous Codatatype Definitions *}
   24.14 +
   24.15 +theory Misc_Codatatype
   24.16 +imports More_BNFs
   24.17 +begin
   24.18 +
   24.19 +codatatype simple = X1 | X2 | X3 | X4
   24.20 +
   24.21 +codatatype simple' = X1' unit | X2' unit | X3' unit | X4' unit
   24.22 +
   24.23 +codatatype simple'' = X1'' nat int | X2''
   24.24 +
   24.25 +codatatype 'a stream = Stream (shd: 'a) (stl: "'a stream")
   24.26 +
   24.27 +codatatype 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
   24.28 +
   24.29 +codatatype ('b, 'c, 'd, 'e) some_passive =
   24.30 +  SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
   24.31 +
   24.32 +codatatype lambda =
   24.33 +  Var string |
   24.34 +  App lambda lambda |
   24.35 +  Abs string lambda |
   24.36 +  Let "(string \<times> lambda) fset" lambda
   24.37 +
   24.38 +codatatype 'a par_lambda =
   24.39 +  PVar 'a |
   24.40 +  PApp "'a par_lambda" "'a par_lambda" |
   24.41 +  PAbs 'a "'a par_lambda" |
   24.42 +  PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
   24.43 +
   24.44 +(*
   24.45 +  ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
   24.46 +  ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
   24.47 +*)
   24.48 +
   24.49 +codatatype 'a p = P "'a + 'a p"
   24.50 +
   24.51 +codatatype 'a J1 = J11 'a "'a J1" | J12 'a "'a J2"
   24.52 +and 'a J2 = J21 | J22 "'a J1" "'a J2"
   24.53 +
   24.54 +codatatype 'a tree = TEmpty | TNode 'a "'a forest"
   24.55 +and 'a forest = FNil | FCons "'a tree" "'a forest"
   24.56 +
   24.57 +codatatype 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
   24.58 +and 'a branch = Branch 'a "'a tree'"
   24.59 +
   24.60 +codatatype ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
   24.61 +and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
   24.62 +and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
   24.63 +
   24.64 +codatatype ('a, 'b, 'c) some_killing =
   24.65 +  SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
   24.66 +and ('a, 'b, 'c) in_here =
   24.67 +  IH1 'b 'a | IH2 'c
   24.68 +
   24.69 +codatatype ('a, 'b, 'c) some_killing' =
   24.70 +  SK' "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing' + ('a, 'b, 'c) in_here'"
   24.71 +and ('a, 'b, 'c) in_here' =
   24.72 +  IH1' 'b | IH2' 'c
   24.73 +
   24.74 +codatatype ('a, 'b, 'c) some_killing'' =
   24.75 +  SK'' "'a \<Rightarrow> ('a, 'b, 'c) in_here''"
   24.76 +and ('a, 'b, 'c) in_here'' =
   24.77 +  IH1'' 'b 'a | IH2'' 'c
   24.78 +
   24.79 +codatatype ('b, 'c) less_killing = LK "'b \<Rightarrow> 'c"
   24.80 +
   24.81 +codatatype 'b poly_unit = U "'b \<Rightarrow> 'b poly_unit"
   24.82 +codatatype 'b cps = CPS1 'b | CPS2 "'b \<Rightarrow> 'b cps"
   24.83 +
   24.84 +codatatype ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs =
   24.85 +  FR "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow>
   24.86 +      ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs"
   24.87 +
   24.88 +codatatype ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
   24.89 +        'b18, 'b19, 'b20) fun_rhs' =
   24.90 +  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>
   24.91 +       'b15 \<Rightarrow> 'b16 \<Rightarrow> 'b17 \<Rightarrow> 'b18 \<Rightarrow> 'b19 \<Rightarrow> 'b20 \<Rightarrow>
   24.92 +       ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
   24.93 +        'b18, 'b19, 'b20) fun_rhs'"
   24.94 +
   24.95 +codatatype ('a, 'b, 'c) wit3_F1 = W1 'a "('a, 'b, 'c) wit3_F1" "('a, 'b, 'c) wit3_F2"
   24.96 +and ('a, 'b, 'c) wit3_F2 = W2 'b "('a, 'b, 'c) wit3_F2"
   24.97 +and ('a, 'b, 'c) wit3_F3 = W31 'a 'b "('a, 'b, 'c) wit3_F1" | W32 'c 'a 'b "('a, 'b, 'c) wit3_F1"
   24.98 +
   24.99 +codatatype ('c, 'e, 'g) coind_wit1 =
  24.100 +       CW1 'c "('c, 'e, 'g) coind_wit1" "('c, 'e, 'g) ind_wit" "('c, 'e, 'g) coind_wit2"
  24.101 +and ('c, 'e, 'g) coind_wit2 =
  24.102 +       CW21 "('c, 'e, 'g) coind_wit2" 'e | CW22 'c 'g
  24.103 +and ('c, 'e, 'g) ind_wit =
  24.104 +       IW1 | IW2 'c
  24.105 +
  24.106 +codatatype ('b, 'a) bar = BAR "'a \<Rightarrow> 'b"
  24.107 +codatatype ('a, 'b, 'c, 'd) foo = FOO "'d + 'b \<Rightarrow> 'c + 'a"
  24.108 +
  24.109 +codatatype 'a dead_foo = A
  24.110 +codatatype ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
  24.111 +
  24.112 +(* SLOW, MEMORY-HUNGRY
  24.113 +codatatype ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
  24.114 +and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
  24.115 +and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
  24.116 +and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
  24.117 +and ('a, 'c) D5 = A5 "('a, 'c) D6"
  24.118 +and ('a, 'c) D6 = A6 "('a, 'c) D7"
  24.119 +and ('a, 'c) D7 = A7 "('a, 'c) D8"
  24.120 +and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
  24.121 +*)
  24.122 +
  24.123 +end
    25.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    25.2 +++ b/src/HOL/BNF_Examples/Misc_Datatype.thy	Mon Jan 20 18:24:56 2014 +0100
    25.3 @@ -0,0 +1,185 @@
    25.4 +(*  Title:      HOL/BNF/Examples/Misc_Datatype.thy
    25.5 +    Author:     Dmitriy Traytel, TU Muenchen
    25.6 +    Author:     Andrei Popescu, TU Muenchen
    25.7 +    Author:     Jasmin Blanchette, TU Muenchen
    25.8 +    Copyright   2012, 2013
    25.9 +
   25.10 +Miscellaneous datatype definitions.
   25.11 +*)
   25.12 +
   25.13 +header {* Miscellaneous Datatype Definitions *}
   25.14 +
   25.15 +theory Misc_Datatype
   25.16 +imports "../BNF"
   25.17 +begin
   25.18 +
   25.19 +datatype_new simple = X1 | X2 | X3 | X4
   25.20 +
   25.21 +datatype_new simple' = X1' unit | X2' unit | X3' unit | X4' unit
   25.22 +
   25.23 +datatype_new simple'' = X1'' nat int | X2''
   25.24 +
   25.25 +datatype_new 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
   25.26 +
   25.27 +datatype_new ('b, 'c, 'd, 'e) some_passive =
   25.28 +  SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
   25.29 +
   25.30 +datatype_new hfset = HFset "hfset fset"
   25.31 +
   25.32 +datatype_new lambda =
   25.33 +  Var string |
   25.34 +  App lambda lambda |
   25.35 +  Abs string lambda |
   25.36 +  Let "(string \<times> lambda) fset" lambda
   25.37 +
   25.38 +datatype_new 'a par_lambda =
   25.39 +  PVar 'a |
   25.40 +  PApp "'a par_lambda" "'a par_lambda" |
   25.41 +  PAbs 'a "'a par_lambda" |
   25.42 +  PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
   25.43 +
   25.44 +(*
   25.45 +  ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
   25.46 +  ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
   25.47 +*)
   25.48 +
   25.49 +datatype_new 'a I1 = I11 'a "'a I1" | I12 'a "'a I2"
   25.50 +and 'a I2 = I21 | I22 "'a I1" "'a I2"
   25.51 +
   25.52 +datatype_new 'a tree = TEmpty | TNode 'a "'a forest"
   25.53 +and 'a forest = FNil | FCons "'a tree" "'a forest"
   25.54 +
   25.55 +datatype_new 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
   25.56 +and 'a branch = Branch 'a "'a tree'"
   25.57 +
   25.58 +datatype_new ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
   25.59 +and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
   25.60 +and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
   25.61 +
   25.62 +datatype_new 'a ftree = FTLeaf 'a | FTNode "'a \<Rightarrow> 'a ftree"
   25.63 +
   25.64 +datatype_new ('a, 'b, 'c) some_killing =
   25.65 +  SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
   25.66 +and ('a, 'b, 'c) in_here =
   25.67 +  IH1 'b 'a | IH2 'c
   25.68 +
   25.69 +datatype_new 'b nofail1 = NF11 "'b nofail1" 'b | NF12 'b
   25.70 +datatype_new 'b nofail2 = NF2 "('b nofail2 \<times> 'b \<times> 'b nofail2 \<times> 'b) list"
   25.71 +datatype_new 'b nofail3 = NF3 'b "('b nofail3 \<times> 'b \<times> 'b nofail3 \<times> 'b) fset"
   25.72 +datatype_new 'b nofail4 = NF4 "('b nofail4 \<times> ('b nofail4 \<times> 'b \<times> 'b nofail4 \<times> 'b) fset) list"
   25.73 +
   25.74 +(*
   25.75 +datatype_new 'b fail = F "'b fail" 'b "'b fail" "'b list"
   25.76 +datatype_new 'b fail = F "'b fail" 'b "'b fail" 'b
   25.77 +datatype_new 'b fail = F1 "'b fail" 'b | F2 "'b fail"
   25.78 +datatype_new 'b fail = F "'b fail" 'b
   25.79 +*)
   25.80 +
   25.81 +datatype_new l1 = L1 "l2 list"
   25.82 +and l2 = L21 "l1 fset" | L22 l2
   25.83 +
   25.84 +datatype_new kk1 = KK1 kk2
   25.85 +and kk2 = KK2 kk3
   25.86 +and kk3 = KK3 "kk1 list"
   25.87 +
   25.88 +datatype_new t1 = T11 t3 | T12 t2
   25.89 +and t2 = T2 t1
   25.90 +and t3 = T3
   25.91 +
   25.92 +datatype_new t1' = T11' t2' | T12' t3'
   25.93 +and t2' = T2' t1'
   25.94 +and t3' = T3'
   25.95 +
   25.96 +(*
   25.97 +datatype_new fail1 = F1 fail2
   25.98 +and fail2 = F2 fail3
   25.99 +and fail3 = F3 fail1
  25.100 +
  25.101 +datatype_new fail1 = F1 "fail2 list" fail2
  25.102 +and fail2 = F2 "fail2 fset" fail3
  25.103 +and fail3 = F3 fail1
  25.104 +
  25.105 +datatype_new fail1 = F1 "fail2 list" fail2
  25.106 +and fail2 = F2 "fail1 fset" fail1
  25.107 +*)
  25.108 +
  25.109 +(* SLOW
  25.110 +datatype_new ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
  25.111 +and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
  25.112 +and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
  25.113 +and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
  25.114 +and ('a, 'c) D5 = A5 "('a, 'c) D6"
  25.115 +and ('a, 'c) D6 = A6 "('a, 'c) D7"
  25.116 +and ('a, 'c) D7 = A7 "('a, 'c) D8"
  25.117 +and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
  25.118 +
  25.119 +(*time comparison*)
  25.120 +datatype ('a, 'c) D1' = A1' "('a, 'c) D2'" | B1' "'a list"
  25.121 +     and ('a, 'c) D2' = A2' "('a, 'c) D3'" | B2' "'c list"
  25.122 +     and ('a, 'c) D3' = A3' "('a, 'c) D3'" | B3' "('a, 'c) D4'" | C3' "('a, 'c) D4'" "('a, 'c) D5'"
  25.123 +     and ('a, 'c) D4' = A4' "('a, 'c) D5'" | B4' "'a list list list"
  25.124 +     and ('a, 'c) D5' = A5' "('a, 'c) D6'"
  25.125 +     and ('a, 'c) D6' = A6' "('a, 'c) D7'"
  25.126 +     and ('a, 'c) D7' = A7' "('a, 'c) D8'"
  25.127 +     and ('a, 'c) D8' = A8' "('a, 'c) D1' list"
  25.128 +*)
  25.129 +
  25.130 +(* fail:
  25.131 +datatype_new tt1 = TT11 tt2 tt3 | TT12 tt2 tt4
  25.132 +and tt2 = TT2
  25.133 +and tt3 = TT3 tt4
  25.134 +and tt4 = TT4 tt1
  25.135 +*)
  25.136 +
  25.137 +datatype_new k1 = K11 k2 k3 | K12 k2 k4
  25.138 +and k2 = K2
  25.139 +and k3 = K3 k4
  25.140 +and k4 = K4
  25.141 +
  25.142 +datatype_new tt1 = TT11 tt3 tt2 | TT12 tt2 tt4
  25.143 +and tt2 = TT2
  25.144 +and tt3 = TT3 tt1
  25.145 +and tt4 = TT4
  25.146 +
  25.147 +(* SLOW
  25.148 +datatype_new s1 = S11 s2 s3 s4 | S12 s3 | S13 s2 s6 | S14 s4 s2 | S15 s2 s2
  25.149 +and s2 = S21 s7 s5 | S22 s5 s4 s6
  25.150 +and s3 = S31 s1 s7 s2 | S32 s3 s3 | S33 s4 s5
  25.151 +and s4 = S4 s5
  25.152 +and s5 = S5
  25.153 +and s6 = S61 s6 | S62 s1 s2 | S63 s6
  25.154 +and s7 = S71 s8 | S72 s5
  25.155 +and s8 = S8 nat
  25.156 +*)
  25.157 +
  25.158 +datatype_new 'a deadbar = DeadBar "'a \<Rightarrow> 'a"
  25.159 +datatype_new 'a deadbar_option = DeadBarOption "'a option \<Rightarrow> 'a option"
  25.160 +datatype_new ('a, 'b) bar = Bar "'b \<Rightarrow> 'a"
  25.161 +datatype_new ('a, 'b, 'c, 'd) foo = Foo "'d + 'b \<Rightarrow> 'c + 'a"
  25.162 +datatype_new 'a deadfoo = DeadFoo "'a \<Rightarrow> 'a + 'a"
  25.163 +
  25.164 +datatype_new 'a dead_foo = A
  25.165 +datatype_new ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
  25.166 +
  25.167 +datatype_new d1 = D
  25.168 +datatype_new d1' = is_D: D
  25.169 +
  25.170 +datatype_new d2 = D nat
  25.171 +datatype_new d2' = is_D: D nat
  25.172 +
  25.173 +datatype_new d3 = D | E
  25.174 +datatype_new d3' = D | is_E: E
  25.175 +datatype_new d3'' = is_D: D | E
  25.176 +datatype_new d3''' = is_D: D | is_E: E
  25.177 +
  25.178 +datatype_new d4 = D nat | E
  25.179 +datatype_new d4' = D nat | is_E: E
  25.180 +datatype_new d4'' = is_D: D nat | E
  25.181 +datatype_new d4''' = is_D: D nat | is_E: E
  25.182 +
  25.183 +datatype_new d5 = D nat | E int
  25.184 +datatype_new d5' = D nat | is_E: E int
  25.185 +datatype_new d5'' = is_D: D nat | E int
  25.186 +datatype_new d5''' = is_D: D nat | is_E: E int
  25.187 +
  25.188 +end
    26.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    26.2 +++ b/src/HOL/BNF_Examples/Misc_Primcorec.thy	Mon Jan 20 18:24:56 2014 +0100
    26.3 @@ -0,0 +1,112 @@
    26.4 +(*  Title:      HOL/BNF/Examples/Misc_Primcorec.thy
    26.5 +    Author:     Jasmin Blanchette, TU Muenchen
    26.6 +    Copyright   2013
    26.7 +
    26.8 +Miscellaneous primitive corecursive function definitions.
    26.9 +*)
   26.10 +
   26.11 +header {* Miscellaneous Primitive Corecursive Function Definitions *}
   26.12 +
   26.13 +theory Misc_Primcorec
   26.14 +imports Misc_Codatatype
   26.15 +begin
   26.16 +
   26.17 +primcorec simple_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple" where
   26.18 +  "simple_of_bools b b' = (if b then if b' then X1 else X2 else if b' then X3 else X4)"
   26.19 +
   26.20 +primcorec simple'_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple'" where
   26.21 +  "simple'_of_bools b b' =
   26.22 +     (if b then if b' then X1' () else X2' () else if b' then X3' () else X4' ())"
   26.23 +
   26.24 +primcorec inc_simple'' :: "nat \<Rightarrow> simple'' \<Rightarrow> simple''" where
   26.25 +  "inc_simple'' k s = (case s of X1'' n i \<Rightarrow> X1'' (n + k) (i + int k) | X2'' \<Rightarrow> X2'')"
   26.26 +
   26.27 +primcorec sinterleave :: "'a stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
   26.28 +  "sinterleave s s' = Stream (shd s) (sinterleave s' (stl s))"
   26.29 +
   26.30 +primcorec myapp :: "'a mylist \<Rightarrow> 'a mylist \<Rightarrow> 'a mylist" where
   26.31 +  "myapp xs ys =
   26.32 +     (if xs = MyNil then ys
   26.33 +      else if ys = MyNil then xs
   26.34 +      else MyCons (myhd xs) (myapp (mytl xs) ys))"
   26.35 +
   26.36 +primcorec shuffle_sp :: "('a, 'b, 'c, 'd) some_passive \<Rightarrow> ('d, 'a, 'b, 'c) some_passive" where
   26.37 +  "shuffle_sp sp =
   26.38 +     (case sp of
   26.39 +       SP1 sp' \<Rightarrow> SP1 (shuffle_sp sp')
   26.40 +     | SP2 a \<Rightarrow> SP3 a
   26.41 +     | SP3 b \<Rightarrow> SP4 b
   26.42 +     | SP4 c \<Rightarrow> SP5 c
   26.43 +     | SP5 d \<Rightarrow> SP2 d)"
   26.44 +
   26.45 +primcorec rename_lam :: "(string \<Rightarrow> string) \<Rightarrow> lambda \<Rightarrow> lambda" where
   26.46 +  "rename_lam f l =
   26.47 +     (case l of
   26.48 +       Var s \<Rightarrow> Var (f s)
   26.49 +     | App l l' \<Rightarrow> App (rename_lam f l) (rename_lam f l')
   26.50 +     | Abs s l \<Rightarrow> Abs (f s) (rename_lam f l)
   26.51 +     | Let SL l \<Rightarrow> Let (fimage (map_pair f (rename_lam f)) SL) (rename_lam f l))"
   26.52 +
   26.53 +primcorec
   26.54 +  j1_sum :: "('a\<Colon>{zero,one,plus}) \<Rightarrow> 'a J1" and
   26.55 +  j2_sum :: "'a \<Rightarrow> 'a J2"
   26.56 +where
   26.57 +  "n = 0 \<Longrightarrow> is_J11 (j1_sum n)" |
   26.58 +  "un_J111 (j1_sum _) = 0" |
   26.59 +  "un_J112 (j1_sum _) = j1_sum 0" |
   26.60 +  "un_J121 (j1_sum n) = n + 1" |
   26.61 +  "un_J122 (j1_sum n) = j2_sum (n + 1)" |
   26.62 +  "n = 0 \<Longrightarrow> is_J21 (j2_sum n)" |
   26.63 +  "un_J221 (j2_sum n) = j1_sum (n + 1)" |
   26.64 +  "un_J222 (j2_sum n) = j2_sum (n + 1)"
   26.65 +
   26.66 +primcorec forest_of_mylist :: "'a tree mylist \<Rightarrow> 'a forest" where
   26.67 +  "forest_of_mylist ts =
   26.68 +     (case ts of
   26.69 +       MyNil \<Rightarrow> FNil
   26.70 +     | MyCons t ts \<Rightarrow> FCons t (forest_of_mylist ts))"
   26.71 +
   26.72 +primcorec mylist_of_forest :: "'a forest \<Rightarrow> 'a tree mylist" where
   26.73 +  "mylist_of_forest f =
   26.74 +     (case f of
   26.75 +       FNil \<Rightarrow> MyNil
   26.76 +     | FCons t ts \<Rightarrow> MyCons t (mylist_of_forest ts))"
   26.77 +
   26.78 +primcorec semi_stream :: "'a stream \<Rightarrow> 'a stream" where
   26.79 +  "semi_stream s = Stream (shd s) (semi_stream (stl (stl s)))"
   26.80 +
   26.81 +primcorec
   26.82 +  tree'_of_stream :: "'a stream \<Rightarrow> 'a tree'" and
   26.83 +  branch_of_stream :: "'a stream \<Rightarrow> 'a branch"
   26.84 +where
   26.85 +  "tree'_of_stream s =
   26.86 +     TNode' (branch_of_stream (semi_stream s)) (branch_of_stream (semi_stream (stl s)))" |
   26.87 +  "branch_of_stream s = (case s of Stream h t \<Rightarrow> Branch h (tree'_of_stream t))"
   26.88 +
   26.89 +primcorec
   26.90 +  freeze_exp :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) exp \<Rightarrow> ('a, 'b) exp" and
   26.91 +  freeze_trm :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) trm \<Rightarrow> ('a, 'b) trm" and
   26.92 +  freeze_factor :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) factor \<Rightarrow> ('a, 'b) factor"
   26.93 +where
   26.94 +  "freeze_exp g e =
   26.95 +     (case e of
   26.96 +       Term t \<Rightarrow> Term (freeze_trm g t)
   26.97 +     | Sum t e \<Rightarrow> Sum (freeze_trm g t) (freeze_exp g e))" |
   26.98 +  "freeze_trm g t =
   26.99 +     (case t of
  26.100 +       Factor f \<Rightarrow> Factor (freeze_factor g f)
  26.101 +     | Prod f t \<Rightarrow> Prod (freeze_factor g f) (freeze_trm g t))" |
  26.102 +  "freeze_factor g f =
  26.103 +     (case f of
  26.104 +       C a \<Rightarrow> C a
  26.105 +     | V b \<Rightarrow> C (g b)
  26.106 +     | Paren e \<Rightarrow> Paren (freeze_exp g e))"
  26.107 +
  26.108 +primcorec poly_unity :: "'a poly_unit" where
  26.109 +  "poly_unity = U (\<lambda>_. poly_unity)"
  26.110 +
  26.111 +primcorec build_cps :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool stream) \<Rightarrow> 'a \<Rightarrow> bool stream \<Rightarrow> 'a cps" where
  26.112 +  "shd b \<Longrightarrow> build_cps f g a b = CPS1 a" |
  26.113 +  "_ \<Longrightarrow> build_cps f g a b = CPS2 (\<lambda>a. build_cps f g (f a) (g a))"
  26.114 +
  26.115 +end
    27.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    27.2 +++ b/src/HOL/BNF_Examples/Misc_Primrec.thy	Mon Jan 20 18:24:56 2014 +0100
    27.3 @@ -0,0 +1,114 @@
    27.4 +(*  Title:      HOL/BNF/Examples/Misc_Primrec.thy
    27.5 +    Author:     Jasmin Blanchette, TU Muenchen
    27.6 +    Copyright   2013
    27.7 +
    27.8 +Miscellaneous primitive recursive function definitions.
    27.9 +*)
   27.10 +
   27.11 +header {* Miscellaneous Primitive Recursive Function Definitions *}
   27.12 +
   27.13 +theory Misc_Primrec
   27.14 +imports Misc_Datatype
   27.15 +begin
   27.16 +
   27.17 +primrec_new nat_of_simple :: "simple \<Rightarrow> nat" where
   27.18 +  "nat_of_simple X1 = 1" |
   27.19 +  "nat_of_simple X2 = 2" |
   27.20 +  "nat_of_simple X3 = 3" |
   27.21 +  "nat_of_simple X4 = 4"
   27.22 +
   27.23 +primrec_new simple_of_simple' :: "simple' \<Rightarrow> simple" where
   27.24 +  "simple_of_simple' (X1' _) = X1" |
   27.25 +  "simple_of_simple' (X2' _) = X2" |
   27.26 +  "simple_of_simple' (X3' _) = X3" |
   27.27 +  "simple_of_simple' (X4' _) = X4"
   27.28 +
   27.29 +primrec_new inc_simple'' :: "nat \<Rightarrow> simple'' \<Rightarrow> simple''" where
   27.30 +  "inc_simple'' k (X1'' n i) = X1'' (n + k) (i + int k)" |
   27.31 +  "inc_simple'' _ X2'' = X2''"
   27.32 +
   27.33 +primrec_new myapp :: "'a mylist \<Rightarrow> 'a mylist \<Rightarrow> 'a mylist" where
   27.34 +  "myapp MyNil ys = ys" |
   27.35 +  "myapp (MyCons x xs) ys = MyCons x (myapp xs ys)"
   27.36 +
   27.37 +primrec_new myrev :: "'a mylist \<Rightarrow> 'a mylist" where
   27.38 +  "myrev MyNil = MyNil" |
   27.39 +  "myrev (MyCons x xs) = myapp (myrev xs) (MyCons x MyNil)"
   27.40 +
   27.41 +primrec_new shuffle_sp :: "('a, 'b, 'c, 'd) some_passive \<Rightarrow> ('d, 'a, 'b, 'c) some_passive" where
   27.42 +  "shuffle_sp (SP1 sp) = SP1 (shuffle_sp sp)" |
   27.43 +  "shuffle_sp (SP2 a) = SP3 a" |
   27.44 +  "shuffle_sp (SP3 b) = SP4 b" |
   27.45 +  "shuffle_sp (SP4 c) = SP5 c" |
   27.46 +  "shuffle_sp (SP5 d) = SP2 d"
   27.47 +
   27.48 +primrec_new
   27.49 +  hf_size :: "hfset \<Rightarrow> nat"
   27.50 +where
   27.51 +  "hf_size (HFset X) = 1 + setsum id (fset (fimage hf_size X))"
   27.52 +
   27.53 +primrec_new rename_lam :: "(string \<Rightarrow> string) \<Rightarrow> lambda \<Rightarrow> lambda" where
   27.54 +  "rename_lam f (Var s) = Var (f s)" |
   27.55 +  "rename_lam f (App l l') = App (rename_lam f l) (rename_lam f l')" |
   27.56 +  "rename_lam f (Abs s l) = Abs (f s) (rename_lam f l)" |
   27.57 +  "rename_lam f (Let SL l) = Let (fimage (map_pair f (rename_lam f)) SL) (rename_lam f l)"
   27.58 +
   27.59 +primrec_new
   27.60 +  sum_i1 :: "('a\<Colon>{zero,plus}) I1 \<Rightarrow> 'a" and
   27.61 +  sum_i2 :: "'a I2 \<Rightarrow> 'a"
   27.62 +where
   27.63 +  "sum_i1 (I11 n i) = n + sum_i1 i" |
   27.64 +  "sum_i1 (I12 n i) = n + sum_i2 i" |
   27.65 +  "sum_i2 I21 = 0" |
   27.66 +  "sum_i2 (I22 i j) = sum_i1 i + sum_i2 j"
   27.67 +
   27.68 +primrec_new forest_of_mylist :: "'a tree mylist \<Rightarrow> 'a forest" where
   27.69 +  "forest_of_mylist MyNil = FNil" |
   27.70 +  "forest_of_mylist (MyCons t ts) = FCons t (forest_of_mylist ts)"
   27.71 +
   27.72 +primrec_new mylist_of_forest :: "'a forest \<Rightarrow> 'a tree mylist" where
   27.73 +  "mylist_of_forest FNil = MyNil" |
   27.74 +  "mylist_of_forest (FCons t ts) = MyCons t (mylist_of_forest ts)"
   27.75 +
   27.76 +definition frev :: "'a forest \<Rightarrow> 'a forest" where
   27.77 +  "frev = forest_of_mylist \<circ> myrev \<circ> mylist_of_forest"
   27.78 +
   27.79 +primrec_new
   27.80 +  mirror_tree :: "'a tree \<Rightarrow> 'a tree" and
   27.81 +  mirror_forest :: "'a forest \<Rightarrow> 'a forest"
   27.82 +where
   27.83 +  "mirror_tree TEmpty = TEmpty" |
   27.84 +  "mirror_tree (TNode x ts) = TNode x (mirror_forest ts)" |
   27.85 +  "mirror_forest FNil = FNil" |
   27.86 +  "mirror_forest (FCons t ts) = frev (FCons (mirror_tree t) (mirror_forest ts))"
   27.87 +
   27.88 +primrec_new
   27.89 +  mylist_of_tree' :: "'a tree' \<Rightarrow> 'a mylist" and
   27.90 +  mylist_of_branch :: "'a branch \<Rightarrow> 'a mylist"
   27.91 +where
   27.92 +  "mylist_of_tree' TEmpty' = MyNil" |
   27.93 +  "mylist_of_tree' (TNode' b b') = myapp (mylist_of_branch b) (mylist_of_branch b')" |
   27.94 +  "mylist_of_branch (Branch x t) = MyCons x (mylist_of_tree' t)"
   27.95 +
   27.96 +primrec_new
   27.97 +  is_ground_exp :: "('a, 'b) exp \<Rightarrow> bool" and
   27.98 +  is_ground_trm :: "('a, 'b) trm \<Rightarrow> bool" and
   27.99 +  is_ground_factor :: "('a, 'b) factor \<Rightarrow> bool"
  27.100 +where
  27.101 +  "is_ground_exp (Term t) \<longleftrightarrow> is_ground_trm t" |
  27.102 +  "is_ground_exp (Sum t e) \<longleftrightarrow> is_ground_trm t \<and> is_ground_exp e" |
  27.103 +  "is_ground_trm (Factor f) \<longleftrightarrow> is_ground_factor f" |
  27.104 +  "is_ground_trm (Prod f t) \<longleftrightarrow> is_ground_factor f \<and> is_ground_trm t" |
  27.105 +  "is_ground_factor (C _) \<longleftrightarrow> True" |
  27.106 +  "is_ground_factor (V _) \<longleftrightarrow> False" |
  27.107 +  "is_ground_factor (Paren e) \<longleftrightarrow> is_ground_exp e"
  27.108 +
  27.109 +primrec_new map_ftreeA :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
  27.110 +  "map_ftreeA f (FTLeaf x) = FTLeaf (f x)" |
  27.111 +  "map_ftreeA f (FTNode g) = FTNode (map_ftreeA f \<circ> g)"
  27.112 +
  27.113 +primrec_new map_ftreeB :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ftree \<Rightarrow> 'b ftree" where
  27.114 +  "map_ftreeB f (FTLeaf x) = FTLeaf (f x)" |
  27.115 +  "map_ftreeB f (FTNode g) = FTNode (map_ftreeB f \<circ> g \<circ> the_inv f)"
  27.116 +
  27.117 +end
    28.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    28.2 +++ b/src/HOL/BNF_Examples/Process.thy	Mon Jan 20 18:24:56 2014 +0100
    28.3 @@ -0,0 +1,278 @@
    28.4 +(*  Title:      HOL/BNF/Examples/Process.thy
    28.5 +    Author:     Andrei Popescu, TU Muenchen
    28.6 +    Copyright   2012
    28.7 +
    28.8 +Processes.
    28.9 +*)
   28.10 +
   28.11 +header {* Processes *}
   28.12 +
   28.13 +theory Process
   28.14 +imports Stream 
   28.15 +begin
   28.16 +
   28.17 +codatatype 'a process =
   28.18 +  isAction: Action (prefOf: 'a) (contOf: "'a process") |
   28.19 +  isChoice: Choice (ch1Of: "'a process") (ch2Of: "'a process")
   28.20 +
   28.21 +(* Read: prefix of, continuation of, choice 1 of, choice 2 of *)
   28.22 +
   28.23 +section {* Customization *}
   28.24 +
   28.25 +subsection {* Basic properties *}
   28.26 +
   28.27 +declare
   28.28 +  rel_pre_process_def[simp]
   28.29 +  sum_rel_def[simp]
   28.30 +  prod_rel_def[simp]
   28.31 +
   28.32 +(* Constructors versus discriminators *)
   28.33 +theorem isAction_isChoice:
   28.34 +"isAction p \<or> isChoice p"
   28.35 +by (rule process.disc_exhaust) auto
   28.36 +
   28.37 +theorem not_isAction_isChoice: "\<not> (isAction p \<and> isChoice p)"
   28.38 +by (cases rule: process.exhaust[of p]) auto
   28.39 +
   28.40 +
   28.41 +subsection{* Coinduction *}
   28.42 +
   28.43 +theorem process_coind[elim, consumes 1, case_names iss Action Choice, induct pred: "HOL.eq"]:
   28.44 +  assumes phi: "\<phi> p p'" and
   28.45 +  iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
   28.46 +  Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> \<phi> p p'" and
   28.47 +  Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> \<phi> p p' \<and> \<phi> q q'"
   28.48 +  shows "p = p'"
   28.49 +  using assms
   28.50 +  by (coinduct rule: process.coinduct) (metis process.collapse(1,2) process.disc(3))
   28.51 +
   28.52 +(* Stronger coinduction, up to equality: *)
   28.53 +theorem process_strong_coind[elim, consumes 1, case_names iss Action Choice]:
   28.54 +  assumes phi: "\<phi> p p'" and
   28.55 +  iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
   28.56 +  Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> (\<phi> p p' \<or> p = p')" and
   28.57 +  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')"
   28.58 +  shows "p = p'"
   28.59 +  using assms
   28.60 +  by (coinduct rule: process.strong_coinduct) (metis process.collapse(1,2) process.disc(3))
   28.61 +
   28.62 +
   28.63 +subsection {* Coiteration (unfold) *}
   28.64 +
   28.65 +
   28.66 +section{* Coinductive definition of the notion of trace *}
   28.67 +coinductive trace where
   28.68 +"trace p as \<Longrightarrow> trace (Action a p) (a ## as)"
   28.69 +|
   28.70 +"trace p as \<or> trace q as \<Longrightarrow> trace (Choice p q) as"
   28.71 +
   28.72 +
   28.73 +section{* Examples of corecursive definitions: *}
   28.74 +
   28.75 +subsection{* Single-guard fixpoint definition *}
   28.76 +
   28.77 +primcorec BX where
   28.78 +  "isAction BX"
   28.79 +| "prefOf BX = ''a''"
   28.80 +| "contOf BX = BX"
   28.81 +
   28.82 +
   28.83 +subsection{* Multi-guard fixpoint definitions, simulated with auxiliary arguments *}
   28.84 +
   28.85 +datatype x_y_ax = x | y | ax
   28.86 +
   28.87 +primcorec F :: "x_y_ax \<Rightarrow> char list process" where
   28.88 +  "xyax = x \<Longrightarrow> isChoice (F xyax)"
   28.89 +| "ch1Of (F xyax) = F ax"
   28.90 +| "ch2Of (F xyax) = F y"
   28.91 +| "prefOf (F xyax) = (if xyax = y then ''b'' else ''a'')"
   28.92 +| "contOf (F xyax) = F x"
   28.93 +
   28.94 +definition "X = F x"  definition "Y = F y"  definition "AX = F ax"
   28.95 +
   28.96 +lemma X_Y_AX: "X = Choice AX Y"  "Y = Action ''b'' X"  "AX = Action ''a'' X"
   28.97 +unfolding X_def Y_def AX_def by (subst F.code, simp)+
   28.98 +
   28.99 +(* end product: *)
  28.100 +lemma X_AX:
  28.101 +"X = Choice AX (Action ''b'' X)"
  28.102 +"AX = Action ''a'' X"
  28.103 +using X_Y_AX by simp_all
  28.104 +
  28.105 +
  28.106 +
  28.107 +section{* Case study: Multi-guard fixpoint definitions, without auxiliary arguments *}
  28.108 +
  28.109 +hide_const x y ax X Y AX
  28.110 +
  28.111 +(* Process terms *)
  28.112 +datatype ('a,'pvar) process_term =
  28.113 + VAR 'pvar |
  28.114 + PROC "'a process" |
  28.115 + ACT 'a "('a,'pvar) process_term" | CH "('a,'pvar) process_term" "('a,'pvar) process_term"
  28.116 +
  28.117 +(* below, sys represents a system of equations *)
  28.118 +fun isACT where
  28.119 +"isACT sys (VAR X) =
  28.120 + (case sys X of ACT a T \<Rightarrow> True |PROC p \<Rightarrow> isAction p |_ \<Rightarrow> False)"
  28.121 +|
  28.122 +"isACT sys (PROC p) = isAction p"
  28.123 +|
  28.124 +"isACT sys (ACT a T) = True"
  28.125 +|
  28.126 +"isACT sys (CH T1 T2) = False"
  28.127 +
  28.128 +fun PREF where
  28.129 +"PREF sys (VAR X) =
  28.130 + (case sys X of ACT a T \<Rightarrow> a | PROC p \<Rightarrow> prefOf p)"
  28.131 +|
  28.132 +"PREF sys (PROC p) = prefOf p"
  28.133 +|
  28.134 +"PREF sys (ACT a T) = a"
  28.135 +
  28.136 +fun CONT where
  28.137 +"CONT sys (VAR X) =
  28.138 + (case sys X of ACT a T \<Rightarrow> T | PROC p \<Rightarrow> PROC (contOf p))"
  28.139 +|
  28.140 +"CONT sys (PROC p) = PROC (contOf p)"
  28.141 +|
  28.142 +"CONT sys (ACT a T) = T"
  28.143 +
  28.144 +fun CH1 where
  28.145 +"CH1 sys (VAR X) =
  28.146 + (case sys X of CH T1 T2 \<Rightarrow> T1 |PROC p \<Rightarrow> PROC (ch1Of p))"
  28.147 +|
  28.148 +"CH1 sys (PROC p) = PROC (ch1Of p)"
  28.149 +|
  28.150 +"CH1 sys (CH T1 T2) = T1"
  28.151 +
  28.152 +fun CH2 where
  28.153 +"CH2 sys (VAR X) =
  28.154 + (case sys X of CH T1 T2 \<Rightarrow> T2 |PROC p \<Rightarrow> PROC (ch2Of p))"
  28.155 +|
  28.156 +"CH2 sys (PROC p) = PROC (ch2Of p)"
  28.157 +|
  28.158 +"CH2 sys (CH T1 T2) = T2"
  28.159 +
  28.160 +definition "guarded sys \<equiv> \<forall> X Y. sys X \<noteq> VAR Y"
  28.161 +
  28.162 +primcorec solution where
  28.163 +  "isACT sys T \<Longrightarrow> solution sys T = Action (PREF sys T) (solution sys (CONT sys T))"
  28.164 +| "_ \<Longrightarrow> solution sys T = Choice (solution sys (CH1 sys T)) (solution sys (CH2 sys T))"
  28.165 +
  28.166 +lemma isACT_VAR:
  28.167 +assumes g: "guarded sys"
  28.168 +shows "isACT sys (VAR X) \<longleftrightarrow> isACT sys (sys X)"
  28.169 +using g unfolding guarded_def by (cases "sys X") auto
  28.170 +
  28.171 +lemma solution_VAR:
  28.172 +assumes g: "guarded sys"
  28.173 +shows "solution sys (VAR X) = solution sys (sys X)"
  28.174 +proof(cases "isACT sys (VAR X)")
  28.175 +  case True
  28.176 +  hence T: "isACT sys (sys X)" unfolding isACT_VAR[OF g] .
  28.177 +  show ?thesis
  28.178 +  unfolding solution.ctr(1)[OF T] using solution.ctr(1)[of sys "VAR X"] True g
  28.179 +  unfolding guarded_def by (cases "sys X", auto)
  28.180 +next
  28.181 +  case False note FFalse = False
  28.182 +  hence TT: "\<not> isACT sys (sys X)" unfolding isACT_VAR[OF g] .
  28.183 +  show ?thesis
  28.184 +  unfolding solution.ctr(2)[OF TT] using solution.ctr(2)[of sys "VAR X"] FFalse g
  28.185 +  unfolding guarded_def by (cases "sys X", auto)
  28.186 +qed
  28.187 +
  28.188 +lemma solution_PROC[simp]:
  28.189 +"solution sys (PROC p) = p"
  28.190 +proof-
  28.191 +  {fix q assume "q = solution sys (PROC p)"
  28.192 +   hence "p = q"
  28.193 +   proof (coinduct rule: process_coind)
  28.194 +     case (iss p p')
  28.195 +     from isAction_isChoice[of p] show ?case
  28.196 +     proof
  28.197 +       assume p: "isAction p"
  28.198 +       hence 0: "isACT sys (PROC p)" by simp
  28.199 +       thus ?thesis using iss not_isAction_isChoice by auto
  28.200 +     next
  28.201 +       assume "isChoice p"
  28.202 +       hence 0: "\<not> isACT sys (PROC p)"
  28.203 +       using not_isAction_isChoice by auto
  28.204 +       thus ?thesis using iss isAction_isChoice by auto
  28.205 +     qed
  28.206 +   next
  28.207 +     case (Action a a' p p')
  28.208 +     hence 0: "isACT sys (PROC (Action a p))" by simp
  28.209 +     show ?case using Action unfolding solution.ctr(1)[OF 0] by simp
  28.210 +   next
  28.211 +     case (Choice p q p' q')
  28.212 +     hence 0: "\<not> isACT sys (PROC (Choice p q))" using not_isAction_isChoice by auto
  28.213 +     show ?case using Choice unfolding solution.ctr(2)[OF 0] by simp
  28.214 +   qed
  28.215 +  }
  28.216 +  thus ?thesis by metis
  28.217 +qed
  28.218 +
  28.219 +lemma solution_ACT[simp]:
  28.220 +"solution sys (ACT a T) = Action a (solution sys T)"
  28.221 +by (metis CONT.simps(3) PREF.simps(3) isACT.simps(3) solution.ctr(1))
  28.222 +
  28.223 +lemma solution_CH[simp]:
  28.224 +"solution sys (CH T1 T2) = Choice (solution sys T1) (solution sys T2)"
  28.225 +by (metis CH1.simps(3) CH2.simps(3) isACT.simps(4) solution.ctr(2))
  28.226 +
  28.227 +
  28.228 +(* Example: *)
  28.229 +
  28.230 +fun sys where
  28.231 +"sys 0 = CH (VAR (Suc 0)) (ACT ''b'' (VAR 0))"
  28.232 +|
  28.233 +"sys (Suc 0) = ACT ''a'' (VAR 0)"
  28.234 +| (* dummy guarded term for variables outside the system: *)
  28.235 +"sys X = ACT ''a'' (VAR 0)"
  28.236 +
  28.237 +lemma guarded_sys:
  28.238 +"guarded sys"
  28.239 +unfolding guarded_def proof (intro allI)
  28.240 +  fix X Y show "sys X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
  28.241 +qed
  28.242 +
  28.243 +(* the actual processes: *)
  28.244 +definition "x \<equiv> solution sys (VAR 0)"
  28.245 +definition "ax \<equiv> solution sys (VAR (Suc 0))"
  28.246 +
  28.247 +(* end product: *)
  28.248 +lemma x_ax:
  28.249 +"x = Choice ax (Action ''b'' x)"
  28.250 +"ax = Action ''a'' x"
  28.251 +unfolding x_def ax_def by (subst solution_VAR[OF guarded_sys], simp)+
  28.252 +
  28.253 +
  28.254 +(* Thanks to the inclusion of processes as process terms, one can
  28.255 +also consider parametrized systems of equations---here, x is a (semantic)
  28.256 +process parameter: *)
  28.257 +
  28.258 +fun sys' where
  28.259 +"sys' 0 = CH (PROC x) (ACT ''b'' (VAR 0))"
  28.260 +|
  28.261 +"sys' (Suc 0) = CH (ACT ''a'' (VAR 0)) (PROC x)"
  28.262 +| (* dummy guarded term : *)
  28.263 +"sys' X = ACT ''a'' (VAR 0)"
  28.264 +
  28.265 +lemma guarded_sys':
  28.266 +"guarded sys'"
  28.267 +unfolding guarded_def proof (intro allI)
  28.268 +  fix X Y show "sys' X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
  28.269 +qed
  28.270 +
  28.271 +(* the actual processes: *)
  28.272 +definition "y \<equiv> solution sys' (VAR 0)"
  28.273 +definition "ay \<equiv> solution sys' (VAR (Suc 0))"
  28.274 +
  28.275 +(* end product: *)
  28.276 +lemma y_ay:
  28.277 +"y = Choice x (Action ''b'' y)"
  28.278 +"ay = Choice (Action ''a'' y) x"
  28.279 +unfolding y_def ay_def by (subst solution_VAR[OF guarded_sys'], simp)+
  28.280 +
  28.281 +end
    29.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    29.2 +++ b/src/HOL/BNF_Examples/Stream.thy	Mon Jan 20 18:24:56 2014 +0100
    29.3 @@ -0,0 +1,526 @@
    29.4 +(*  Title:      HOL/BNF/Examples/Stream.thy
    29.5 +    Author:     Dmitriy Traytel, TU Muenchen
    29.6 +    Author:     Andrei Popescu, TU Muenchen
    29.7 +    Copyright   2012, 2013
    29.8 +
    29.9 +Infinite streams.
   29.10 +*)
   29.11 +
   29.12 +header {* Infinite Streams *}
   29.13 +
   29.14 +theory Stream
   29.15 +imports "~~/Library/Nat_Bijection"
   29.16 +begin
   29.17 +
   29.18 +codatatype (sset: 'a) stream (map: smap rel: stream_all2) =
   29.19 +  SCons (shd: 'a) (stl: "'a stream") (infixr "##" 65)
   29.20 +
   29.21 +(*for code generation only*)
   29.22 +definition smember :: "'a \<Rightarrow> 'a stream \<Rightarrow> bool" where
   29.23 +  [code_abbrev]: "smember x s \<longleftrightarrow> x \<in> sset s"
   29.24 +
   29.25 +lemma smember_code[code, simp]: "smember x (y ## s) = (if x = y then True else smember x s)"
   29.26 +  unfolding smember_def by auto
   29.27 +
   29.28 +hide_const (open) smember
   29.29 +
   29.30 +(* TODO: Provide by the package*)
   29.31 +theorem sset_induct:
   29.32 +  "\<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>
   29.33 +    \<forall>y \<in> sset s. P y s"
   29.34 +  apply (rule stream.dtor_set_induct)
   29.35 +  apply (auto simp add: shd_def stl_def fsts_def snds_def split_beta)
   29.36 +  apply (metis SCons_def fst_conv stream.case stream.dtor_ctor stream.exhaust)
   29.37 +  by (metis SCons_def sndI stl_def stream.collapse stream.dtor_ctor)
   29.38 +
   29.39 +lemma smap_simps[simp]:
   29.40 +  "shd (smap f s) = f (shd s)" "stl (smap f s) = smap f (stl s)"
   29.41 +  by (case_tac [!] s) auto
   29.42 +
   29.43 +theorem shd_sset: "shd s \<in> sset s"
   29.44 +  by (case_tac s) auto
   29.45 +
   29.46 +theorem stl_sset: "y \<in> sset (stl s) \<Longrightarrow> y \<in> sset s"
   29.47 +  by (case_tac s) auto
   29.48 +
   29.49 +(* only for the non-mutual case: *)
   29.50 +theorem sset_induct1[consumes 1, case_names shd stl, induct set: "sset"]:
   29.51 +  assumes "y \<in> sset s" and "\<And>s. P (shd s) s"
   29.52 +  and "\<And>s y. \<lbrakk>y \<in> sset (stl s); P y (stl s)\<rbrakk> \<Longrightarrow> P y s"
   29.53 +  shows "P y s"
   29.54 +  using assms sset_induct by blast
   29.55 +(* end TODO *)
   29.56 +
   29.57 +
   29.58 +subsection {* prepend list to stream *}
   29.59 +
   29.60 +primrec shift :: "'a list \<Rightarrow> 'a stream \<Rightarrow> 'a stream" (infixr "@-" 65) where
   29.61 +  "shift [] s = s"
   29.62 +| "shift (x # xs) s = x ## shift xs s"
   29.63 +
   29.64 +lemma smap_shift[simp]: "smap f (xs @- s) = map f xs @- smap f s"
   29.65 +  by (induct xs) auto
   29.66 +
   29.67 +lemma shift_append[simp]: "(xs @ ys) @- s = xs @- ys @- s"
   29.68 +  by (induct xs) auto
   29.69 +
   29.70 +lemma shift_simps[simp]:
   29.71 +   "shd (xs @- s) = (if xs = [] then shd s else hd xs)"
   29.72 +   "stl (xs @- s) = (if xs = [] then stl s else tl xs @- s)"
   29.73 +  by (induct xs) auto
   29.74 +
   29.75 +lemma sset_shift[simp]: "sset (xs @- s) = set xs \<union> sset s"
   29.76 +  by (induct xs) auto
   29.77 +
   29.78 +lemma shift_left_inj[simp]: "xs @- s1 = xs @- s2 \<longleftrightarrow> s1 = s2"
   29.79 +  by (induct xs) auto
   29.80 +
   29.81 +
   29.82 +subsection {* set of streams with elements in some fixed set *}
   29.83 +
   29.84 +coinductive_set
   29.85 +  streams :: "'a set \<Rightarrow> 'a stream set"
   29.86 +  for A :: "'a set"
   29.87 +where
   29.88 +  Stream[intro!, simp, no_atp]: "\<lbrakk>a \<in> A; s \<in> streams A\<rbrakk> \<Longrightarrow> a ## s \<in> streams A"
   29.89 +
   29.90 +lemma shift_streams: "\<lbrakk>w \<in> lists A; s \<in> streams A\<rbrakk> \<Longrightarrow> w @- s \<in> streams A"
   29.91 +  by (induct w) auto
   29.92 +
   29.93 +lemma streams_Stream: "x ## s \<in> streams A \<longleftrightarrow> x \<in> A \<and> s \<in> streams A"
   29.94 +  by (auto elim: streams.cases)
   29.95 +
   29.96 +lemma streams_stl: "s \<in> streams A \<Longrightarrow> stl s \<in> streams A"
   29.97 +  by (cases s) (auto simp: streams_Stream)
   29.98 +
   29.99 +lemma streams_shd: "s \<in> streams A \<Longrightarrow> shd s \<in> A"
  29.100 +  by (cases s) (auto simp: streams_Stream)
  29.101 +
  29.102 +lemma sset_streams:
  29.103 +  assumes "sset s \<subseteq> A"
  29.104 +  shows "s \<in> streams A"
  29.105 +using assms proof (coinduction arbitrary: s)
  29.106 +  case streams then show ?case by (cases s) simp
  29.107 +qed
  29.108 +
  29.109 +lemma streams_sset:
  29.110 +  assumes "s \<in> streams A"
  29.111 +  shows "sset s \<subseteq> A"
  29.112 +proof
  29.113 +  fix x assume "x \<in> sset s" from this `s \<in> streams A` show "x \<in> A"
  29.114 +    by (induct s) (auto intro: streams_shd streams_stl)
  29.115 +qed
  29.116 +
  29.117 +lemma streams_iff_sset: "s \<in> streams A \<longleftrightarrow> sset s \<subseteq> A"
  29.118 +  by (metis sset_streams streams_sset)
  29.119 +
  29.120 +lemma streams_mono:  "s \<in> streams A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> s \<in> streams B"
  29.121 +  unfolding streams_iff_sset by auto
  29.122 +
  29.123 +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"
  29.124 +  unfolding streams_iff_sset stream.set_map by auto
  29.125 +
  29.126 +lemma streams_empty: "streams {} = {}"
  29.127 +  by (auto elim: streams.cases)
  29.128 +
  29.129 +lemma streams_UNIV[simp]: "streams UNIV = UNIV"
  29.130 +  by (auto simp: streams_iff_sset)
  29.131 +
  29.132 +subsection {* nth, take, drop for streams *}
  29.133 +
  29.134 +primrec snth :: "'a stream \<Rightarrow> nat \<Rightarrow> 'a" (infixl "!!" 100) where
  29.135 +  "s !! 0 = shd s"
  29.136 +| "s !! Suc n = stl s !! n"
  29.137 +
  29.138 +lemma snth_smap[simp]: "smap f s !! n = f (s !! n)"
  29.139 +  by (induct n arbitrary: s) auto
  29.140 +
  29.141 +lemma shift_snth_less[simp]: "p < length xs \<Longrightarrow> (xs @- s) !! p = xs ! p"
  29.142 +  by (induct p arbitrary: xs) (auto simp: hd_conv_nth nth_tl)
  29.143 +
  29.144 +lemma shift_snth_ge[simp]: "p \<ge> length xs \<Longrightarrow> (xs @- s) !! p = s !! (p - length xs)"
  29.145 +  by (induct p arbitrary: xs) (auto simp: Suc_diff_eq_diff_pred)
  29.146 +
  29.147 +lemma snth_sset[simp]: "s !! n \<in> sset s"
  29.148 +  by (induct n arbitrary: s) (auto intro: shd_sset stl_sset)
  29.149 +
  29.150 +lemma sset_range: "sset s = range (snth s)"
  29.151 +proof (intro equalityI subsetI)
  29.152 +  fix x assume "x \<in> sset s"
  29.153 +  thus "x \<in> range (snth s)"
  29.154 +  proof (induct s)
  29.155 +    case (stl s x)
  29.156 +    then obtain n where "x = stl s !! n" by auto
  29.157 +    thus ?case by (auto intro: range_eqI[of _ _ "Suc n"])
  29.158 +  qed (auto intro: range_eqI[of _ _ 0])
  29.159 +qed auto
  29.160 +
  29.161 +primrec stake :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a list" where
  29.162 +  "stake 0 s = []"
  29.163 +| "stake (Suc n) s = shd s # stake n (stl s)"
  29.164 +
  29.165 +lemma length_stake[simp]: "length (stake n s) = n"
  29.166 +  by (induct n arbitrary: s) auto
  29.167 +
  29.168 +lemma stake_smap[simp]: "stake n (smap f s) = map f (stake n s)"
  29.169 +  by (induct n arbitrary: s) auto
  29.170 +
  29.171 +primrec sdrop :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
  29.172 +  "sdrop 0 s = s"
  29.173 +| "sdrop (Suc n) s = sdrop n (stl s)"
  29.174 +
  29.175 +lemma sdrop_simps[simp]:
  29.176 +  "shd (sdrop n s) = s !! n" "stl (sdrop n s) = sdrop (Suc n) s"
  29.177 +  by (induct n arbitrary: s)  auto
  29.178 +
  29.179 +lemma sdrop_smap[simp]: "sdrop n (smap f s) = smap f (sdrop n s)"
  29.180 +  by (induct n arbitrary: s) auto
  29.181 +
  29.182 +lemma sdrop_stl: "sdrop n (stl s) = stl (sdrop n s)"
  29.183 +  by (induct n) auto
  29.184 +
  29.185 +lemma stake_sdrop: "stake n s @- sdrop n s = s"
  29.186 +  by (induct n arbitrary: s) auto
  29.187 +
  29.188 +lemma id_stake_snth_sdrop:
  29.189 +  "s = stake i s @- s !! i ## sdrop (Suc i) s"
  29.190 +  by (subst stake_sdrop[symmetric, of _ i]) (metis sdrop_simps stream.collapse)
  29.191 +
  29.192 +lemma smap_alt: "smap f s = s' \<longleftrightarrow> (\<forall>n. f (s !! n) = s' !! n)" (is "?L = ?R")
  29.193 +proof
  29.194 +  assume ?R
  29.195 +  then have "\<And>n. smap f (sdrop n s) = sdrop n s'"
  29.196 +    by coinduction (auto intro: exI[of _ 0] simp del: sdrop.simps(2))
  29.197 +  then show ?L using sdrop.simps(1) by metis
  29.198 +qed auto
  29.199 +
  29.200 +lemma stake_invert_Nil[iff]: "stake n s = [] \<longleftrightarrow> n = 0"
  29.201 +  by (induct n) auto
  29.202 +
  29.203 +lemma sdrop_shift: "\<lbrakk>s = w @- s'; length w = n\<rbrakk> \<Longrightarrow> sdrop n s = s'"
  29.204 +  by (induct n arbitrary: w s) auto
  29.205 +
  29.206 +lemma stake_shift: "\<lbrakk>s = w @- s'; length w = n\<rbrakk> \<Longrightarrow> stake n s = w"
  29.207 +  by (induct n arbitrary: w s) auto
  29.208 +
  29.209 +lemma stake_add[simp]: "stake m s @ stake n (sdrop m s) = stake (m + n) s"
  29.210 +  by (induct m arbitrary: s) auto
  29.211 +
  29.212 +lemma sdrop_add[simp]: "sdrop n (sdrop m s) = sdrop (m + n) s"
  29.213 +  by (induct m arbitrary: s) auto
  29.214 +
  29.215 +partial_function (tailrec) sdrop_while :: "('a \<Rightarrow> bool) \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where 
  29.216 +  "sdrop_while P s = (if P (shd s) then sdrop_while P (stl s) else s)"
  29.217 +
  29.218 +lemma sdrop_while_SCons[code]:
  29.219 +  "sdrop_while P (a ## s) = (if P a then sdrop_while P s else a ## s)"
  29.220 +  by (subst sdrop_while.simps) simp
  29.221 +
  29.222 +lemma sdrop_while_sdrop_LEAST:
  29.223 +  assumes "\<exists>n. P (s !! n)"
  29.224 +  shows "sdrop_while (Not o P) s = sdrop (LEAST n. P (s !! n)) s"
  29.225 +proof -
  29.226 +  from assms obtain m where "P (s !! m)" "\<And>n. P (s !! n) \<Longrightarrow> m \<le> n"
  29.227 +    and *: "(LEAST n. P (s !! n)) = m" by atomize_elim (auto intro: LeastI Least_le)
  29.228 +  thus ?thesis unfolding *
  29.229 +  proof (induct m arbitrary: s)
  29.230 +    case (Suc m)
  29.231 +    hence "sdrop_while (Not \<circ> P) (stl s) = sdrop m (stl s)"
  29.232 +      by (metis (full_types) not_less_eq_eq snth.simps(2))
  29.233 +    moreover from Suc(3) have "\<not> (P (s !! 0))" by blast
  29.234 +    ultimately show ?case by (subst sdrop_while.simps) simp
  29.235 +  qed (metis comp_apply sdrop.simps(1) sdrop_while.simps snth.simps(1))
  29.236 +qed
  29.237 +
  29.238 +primcorec sfilter where
  29.239 +  "shd (sfilter P s) = shd (sdrop_while (Not o P) s)"
  29.240 +| "stl (sfilter P s) = sfilter P (stl (sdrop_while (Not o P) s))"
  29.241 +
  29.242 +lemma sfilter_Stream: "sfilter P (x ## s) = (if P x then x ## sfilter P s else sfilter P s)"
  29.243 +proof (cases "P x")
  29.244 +  case True thus ?thesis by (subst sfilter.ctr) (simp add: sdrop_while_SCons)
  29.245 +next
  29.246 +  case False thus ?thesis by (subst (1 2) sfilter.ctr) (simp add: sdrop_while_SCons)
  29.247 +qed
  29.248 +
  29.249 +
  29.250 +subsection {* unary predicates lifted to streams *}
  29.251 +
  29.252 +definition "stream_all P s = (\<forall>p. P (s !! p))"
  29.253 +
  29.254 +lemma stream_all_iff[iff]: "stream_all P s \<longleftrightarrow> Ball (sset s) P"
  29.255 +  unfolding stream_all_def sset_range by auto
  29.256 +
  29.257 +lemma stream_all_shift[simp]: "stream_all P (xs @- s) = (list_all P xs \<and> stream_all P s)"
  29.258 +  unfolding stream_all_iff list_all_iff by auto
  29.259 +
  29.260 +lemma stream_all_Stream: "stream_all P (x ## X) \<longleftrightarrow> P x \<and> stream_all P X"
  29.261 +  by simp
  29.262 +
  29.263 +
  29.264 +subsection {* recurring stream out of a list *}
  29.265 +
  29.266 +primcorec cycle :: "'a list \<Rightarrow> 'a stream" where
  29.267 +  "shd (cycle xs) = hd xs"
  29.268 +| "stl (cycle xs) = cycle (tl xs @ [hd xs])"
  29.269 +
  29.270 +lemma cycle_decomp: "u \<noteq> [] \<Longrightarrow> cycle u = u @- cycle u"
  29.271 +proof (coinduction arbitrary: u)
  29.272 +  case Eq_stream then show ?case using stream.collapse[of "cycle u"]
  29.273 +    by (auto intro!: exI[of _ "tl u @ [hd u]"])
  29.274 +qed
  29.275 +
  29.276 +lemma cycle_Cons[code]: "cycle (x # xs) = x ## cycle (xs @ [x])"
  29.277 +  by (subst cycle.ctr) simp
  29.278 +
  29.279 +lemma cycle_rotated: "\<lbrakk>v \<noteq> []; cycle u = v @- s\<rbrakk> \<Longrightarrow> cycle (tl u @ [hd u]) = tl v @- s"
  29.280 +  by (auto dest: arg_cong[of _ _ stl])
  29.281 +
  29.282 +lemma stake_append: "stake n (u @- s) = take (min (length u) n) u @ stake (n - length u) s"
  29.283 +proof (induct n arbitrary: u)
  29.284 +  case (Suc n) thus ?case by (cases u) auto
  29.285 +qed auto
  29.286 +
  29.287 +lemma stake_cycle_le[simp]:
  29.288 +  assumes "u \<noteq> []" "n < length u"
  29.289 +  shows "stake n (cycle u) = take n u"
  29.290 +using min_absorb2[OF less_imp_le_nat[OF assms(2)]]
  29.291 +  by (subst cycle_decomp[OF assms(1)], subst stake_append) auto
  29.292 +
  29.293 +lemma stake_cycle_eq[simp]: "u \<noteq> [] \<Longrightarrow> stake (length u) (cycle u) = u"
  29.294 +  by (metis cycle_decomp stake_shift)
  29.295 +
  29.296 +lemma sdrop_cycle_eq[simp]: "u \<noteq> [] \<Longrightarrow> sdrop (length u) (cycle u) = cycle u"
  29.297 +  by (metis cycle_decomp sdrop_shift)
  29.298 +
  29.299 +lemma stake_cycle_eq_mod_0[simp]: "\<lbrakk>u \<noteq> []; n mod length u = 0\<rbrakk> \<Longrightarrow>
  29.300 +   stake n (cycle u) = concat (replicate (n div length u) u)"
  29.301 +  by (induct "n div length u" arbitrary: n u) (auto simp: stake_add[symmetric])
  29.302 +
  29.303 +lemma sdrop_cycle_eq_mod_0[simp]: "\<lbrakk>u \<noteq> []; n mod length u = 0\<rbrakk> \<Longrightarrow>
  29.304 +   sdrop n (cycle u) = cycle u"
  29.305 +  by (induct "n div length u" arbitrary: n u) (auto simp: sdrop_add[symmetric])
  29.306 +
  29.307 +lemma stake_cycle: "u \<noteq> [] \<Longrightarrow>
  29.308 +   stake n (cycle u) = concat (replicate (n div length u) u) @ take (n mod length u) u"
  29.309 +  by (subst mod_div_equality[of n "length u", symmetric], unfold stake_add[symmetric]) auto
  29.310 +
  29.311 +lemma sdrop_cycle: "u \<noteq> [] \<Longrightarrow> sdrop n (cycle u) = cycle (rotate (n mod length u) u)"
  29.312 +  by (induct n arbitrary: u) (auto simp: rotate1_rotate_swap rotate1_hd_tl rotate_conv_mod[symmetric])
  29.313 +
  29.314 +
  29.315 +subsection {* iterated application of a function *}
  29.316 +
  29.317 +primcorec siterate where
  29.318 +  "shd (siterate f x) = x"
  29.319 +| "stl (siterate f x) = siterate f (f x)"
  29.320 +
  29.321 +lemma stake_Suc: "stake (Suc n) s = stake n s @ [s !! n]"
  29.322 +  by (induct n arbitrary: s) auto
  29.323 +
  29.324 +lemma snth_siterate[simp]: "siterate f x !! n = (f^^n) x"
  29.325 +  by (induct n arbitrary: x) (auto simp: funpow_swap1)
  29.326 +
  29.327 +lemma sdrop_siterate[simp]: "sdrop n (siterate f x) = siterate f ((f^^n) x)"
  29.328 +  by (induct n arbitrary: x) (auto simp: funpow_swap1)
  29.329 +
  29.330 +lemma stake_siterate[simp]: "stake n (siterate f x) = map (\<lambda>n. (f^^n) x) [0 ..< n]"
  29.331 +  by (induct n arbitrary: x) (auto simp del: stake.simps(2) simp: stake_Suc)
  29.332 +
  29.333 +lemma sset_siterate: "sset (siterate f x) = {(f^^n) x | n. True}"
  29.334 +  by (auto simp: sset_range)
  29.335 +
  29.336 +lemma smap_siterate: "smap f (siterate f x) = siterate f (f x)"
  29.337 +  by (coinduction arbitrary: x) auto
  29.338 +
  29.339 +
  29.340 +subsection {* stream repeating a single element *}
  29.341 +
  29.342 +abbreviation "sconst \<equiv> siterate id"
  29.343 +
  29.344 +lemma shift_replicate_sconst[simp]: "replicate n x @- sconst x = sconst x"
  29.345 +  by (subst (3) stake_sdrop[symmetric]) (simp add: map_replicate_trivial)
  29.346 +
  29.347 +lemma stream_all_same[simp]: "sset (sconst x) = {x}"
  29.348 +  by (simp add: sset_siterate)
  29.349 +
  29.350 +lemma same_cycle: "sconst x = cycle [x]"
  29.351 +  by coinduction auto
  29.352 +
  29.353 +lemma smap_sconst: "smap f (sconst x) = sconst (f x)"
  29.354 +  by coinduction auto
  29.355 +
  29.356 +lemma sconst_streams: "x \<in> A \<Longrightarrow> sconst x \<in> streams A"
  29.357 +  by (simp add: streams_iff_sset)
  29.358 +
  29.359 +
  29.360 +subsection {* stream of natural numbers *}
  29.361 +
  29.362 +abbreviation "fromN \<equiv> siterate Suc"
  29.363 +
  29.364 +abbreviation "nats \<equiv> fromN 0"
  29.365 +
  29.366 +lemma sset_fromN[simp]: "sset (fromN n) = {n ..}"
  29.367 +  by (auto simp add: sset_siterate le_iff_add)
  29.368 +
  29.369 +
  29.370 +subsection {* flatten a stream of lists *}
  29.371 +
  29.372 +primcorec flat where
  29.373 +  "shd (flat ws) = hd (shd ws)"
  29.374 +| "stl (flat ws) = flat (if tl (shd ws) = [] then stl ws else tl (shd ws) ## stl ws)"
  29.375 +
  29.376 +lemma flat_Cons[simp, code]: "flat ((x # xs) ## ws) = x ## flat (if xs = [] then ws else xs ## ws)"
  29.377 +  by (subst flat.ctr) simp
  29.378 +
  29.379 +lemma flat_Stream[simp]: "xs \<noteq> [] \<Longrightarrow> flat (xs ## ws) = xs @- flat ws"
  29.380 +  by (induct xs) auto
  29.381 +
  29.382 +lemma flat_unfold: "shd ws \<noteq> [] \<Longrightarrow> flat ws = shd ws @- flat (stl ws)"
  29.383 +  by (cases ws) auto
  29.384 +
  29.385 +lemma flat_snth: "\<forall>xs \<in> sset s. xs \<noteq> [] \<Longrightarrow> flat s !! n = (if n < length (shd s) then 
  29.386 +  shd s ! n else flat (stl s) !! (n - length (shd s)))"
  29.387 +  by (metis flat_unfold not_less shd_sset shift_snth_ge shift_snth_less)
  29.388 +
  29.389 +lemma sset_flat[simp]: "\<forall>xs \<in> sset s. xs \<noteq> [] \<Longrightarrow> 
  29.390 +  sset (flat s) = (\<Union>xs \<in> sset s. set xs)" (is "?P \<Longrightarrow> ?L = ?R")
  29.391 +proof safe
  29.392 +  fix x assume ?P "x : ?L"
  29.393 +  then obtain m where "x = flat s !! m" by (metis image_iff sset_range)
  29.394 +  with `?P` obtain n m' where "x = s !! n ! m'" "m' < length (s !! n)"
  29.395 +  proof (atomize_elim, induct m arbitrary: s rule: less_induct)
  29.396 +    case (less y)
  29.397 +    thus ?case
  29.398 +    proof (cases "y < length (shd s)")
  29.399 +      case True thus ?thesis by (metis flat_snth less(2,3) snth.simps(1))
  29.400 +    next
  29.401 +      case False
  29.402 +      hence "x = flat (stl s) !! (y - length (shd s))" by (metis less(2,3) flat_snth)
  29.403 +      moreover
  29.404 +      { from less(2) have *: "length (shd s) > 0" by (cases s) simp_all
  29.405 +        with False have "y > 0" by (cases y) simp_all
  29.406 +        with * have "y - length (shd s) < y" by simp
  29.407 +      }
  29.408 +      moreover have "\<forall>xs \<in> sset (stl s). xs \<noteq> []" using less(2) by (cases s) auto
  29.409 +      ultimately have "\<exists>n m'. x = stl s !! n ! m' \<and> m' < length (stl s !! n)" by (intro less(1)) auto
  29.410 +      thus ?thesis by (metis snth.simps(2))
  29.411 +    qed
  29.412 +  qed
  29.413 +  thus "x \<in> ?R" by (auto simp: sset_range dest!: nth_mem)
  29.414 +next
  29.415 +  fix x xs assume "xs \<in> sset s" ?P "x \<in> set xs" thus "x \<in> ?L"
  29.416 +    by (induct rule: sset_induct1)
  29.417 +      (metis UnI1 flat_unfold shift.simps(1) sset_shift,
  29.418 +       metis UnI2 flat_unfold shd_sset stl_sset sset_shift)
  29.419 +qed
  29.420 +
  29.421 +
  29.422 +subsection {* merge a stream of streams *}
  29.423 +
  29.424 +definition smerge :: "'a stream stream \<Rightarrow> 'a stream" where
  29.425 +  "smerge ss = flat (smap (\<lambda>n. map (\<lambda>s. s !! n) (stake (Suc n) ss) @ stake n (ss !! n)) nats)"
  29.426 +
  29.427 +lemma stake_nth[simp]: "m < n \<Longrightarrow> stake n s ! m = s !! m"
  29.428 +  by (induct n arbitrary: s m) (auto simp: nth_Cons', metis Suc_pred snth.simps(2))
  29.429 +
  29.430 +lemma snth_sset_smerge: "ss !! n !! m \<in> sset (smerge ss)"
  29.431 +proof (cases "n \<le> m")
  29.432 +  case False thus ?thesis unfolding smerge_def
  29.433 +    by (subst sset_flat)
  29.434 +      (auto simp: stream.set_map in_set_conv_nth simp del: stake.simps
  29.435 +        intro!: exI[of _ n, OF disjI2] exI[of _ m, OF mp])
  29.436 +next
  29.437 +  case True thus ?thesis unfolding smerge_def
  29.438 +    by (subst sset_flat)
  29.439 +      (auto simp: stream.set_map in_set_conv_nth image_iff simp del: stake.simps snth.simps
  29.440 +        intro!: exI[of _ m, OF disjI1] bexI[of _ "ss !! n"] exI[of _ n, OF mp])
  29.441 +qed
  29.442 +
  29.443 +lemma sset_smerge: "sset (smerge ss) = UNION (sset ss) sset"
  29.444 +proof safe
  29.445 +  fix x assume "x \<in> sset (smerge ss)"
  29.446 +  thus "x \<in> UNION (sset ss) sset"
  29.447 +    unfolding smerge_def by (subst (asm) sset_flat)
  29.448 +      (auto simp: stream.set_map in_set_conv_nth sset_range simp del: stake.simps, fast+)
  29.449 +next
  29.450 +  fix s x assume "s \<in> sset ss" "x \<in> sset s"
  29.451 +  thus "x \<in> sset (smerge ss)" using snth_sset_smerge by (auto simp: sset_range)
  29.452 +qed
  29.453 +
  29.454 +
  29.455 +subsection {* product of two streams *}
  29.456 +
  29.457 +definition sproduct :: "'a stream \<Rightarrow> 'b stream \<Rightarrow> ('a \<times> 'b) stream" where
  29.458 +  "sproduct s1 s2 = smerge (smap (\<lambda>x. smap (Pair x) s2) s1)"
  29.459 +
  29.460 +lemma sset_sproduct: "sset (sproduct s1 s2) = sset s1 \<times> sset s2"
  29.461 +  unfolding sproduct_def sset_smerge by (auto simp: stream.set_map)
  29.462 +
  29.463 +
  29.464 +subsection {* interleave two streams *}
  29.465 +
  29.466 +primcorec sinterleave where
  29.467 +  "shd (sinterleave s1 s2) = shd s1"
  29.468 +| "stl (sinterleave s1 s2) = sinterleave s2 (stl s1)"
  29.469 +
  29.470 +lemma sinterleave_code[code]:
  29.471 +  "sinterleave (x ## s1) s2 = x ## sinterleave s2 s1"
  29.472 +  by (subst sinterleave.ctr) simp
  29.473 +
  29.474 +lemma sinterleave_snth[simp]:
  29.475 +  "even n \<Longrightarrow> sinterleave s1 s2 !! n = s1 !! (n div 2)"
  29.476 +   "odd n \<Longrightarrow> sinterleave s1 s2 !! n = s2 !! (n div 2)"
  29.477 +  by (induct n arbitrary: s1 s2)
  29.478 +    (auto dest: even_nat_Suc_div_2 odd_nat_plus_one_div_two[folded nat_2])
  29.479 +
  29.480 +lemma sset_sinterleave: "sset (sinterleave s1 s2) = sset s1 \<union> sset s2"
  29.481 +proof (intro equalityI subsetI)
  29.482 +  fix x assume "x \<in> sset (sinterleave s1 s2)"
  29.483 +  then obtain n where "x = sinterleave s1 s2 !! n" unfolding sset_range by blast
  29.484 +  thus "x \<in> sset s1 \<union> sset s2" by (cases "even n") auto
  29.485 +next
  29.486 +  fix x assume "x \<in> sset s1 \<union> sset s2"
  29.487 +  thus "x \<in> sset (sinterleave s1 s2)"
  29.488 +  proof
  29.489 +    assume "x \<in> sset s1"
  29.490 +    then obtain n where "x = s1 !! n" unfolding sset_range by blast
  29.491 +    hence "sinterleave s1 s2 !! (2 * n) = x" by simp
  29.492 +    thus ?thesis unfolding sset_range by blast
  29.493 +  next
  29.494 +    assume "x \<in> sset s2"
  29.495 +    then obtain n where "x = s2 !! n" unfolding sset_range by blast
  29.496 +    hence "sinterleave s1 s2 !! (2 * n + 1) = x" by simp
  29.497 +    thus ?thesis unfolding sset_range by blast
  29.498 +  qed
  29.499 +qed
  29.500 +
  29.501 +
  29.502 +subsection {* zip *}
  29.503 +
  29.504 +primcorec szip where
  29.505 +  "shd (szip s1 s2) = (shd s1, shd s2)"
  29.506 +| "stl (szip s1 s2) = szip (stl s1) (stl s2)"
  29.507 +
  29.508 +lemma szip_unfold[code]: "szip (a ## s1) (b ## s2) = (a, b) ## (szip s1 s2)"
  29.509 +  by (subst szip.ctr) simp
  29.510 +
  29.511 +lemma snth_szip[simp]: "szip s1 s2 !! n = (s1 !! n, s2 !! n)"
  29.512 +  by (induct n arbitrary: s1 s2) auto
  29.513 +
  29.514 +
  29.515 +subsection {* zip via function *}
  29.516 +
  29.517 +primcorec smap2 where
  29.518 +  "shd (smap2 f s1 s2) = f (shd s1) (shd s2)"
  29.519 +| "stl (smap2 f s1 s2) = smap2 f (stl s1) (stl s2)"
  29.520 +
  29.521 +lemma smap2_unfold[code]:
  29.522 +  "smap2 f (a ## s1) (b ## s2) = f a b ## (smap2 f s1 s2)"
  29.523 +  by (subst smap2.ctr) simp
  29.524 +
  29.525 +lemma smap2_szip:
  29.526 +  "smap2 f s1 s2 = smap (split f) (szip s1 s2)"
  29.527 +  by (coinduction arbitrary: s1 s2) auto
  29.528 +
  29.529 +end
    30.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    30.2 +++ b/src/HOL/BNF_Examples/Stream_Processor.thy	Mon Jan 20 18:24:56 2014 +0100
    30.3 @@ -0,0 +1,187 @@
    30.4 +(*  Title:      HOL/BNF/Examples/Stream_Processor.thy
    30.5 +    Author:     Dmitriy Traytel, TU Muenchen
    30.6 +    Author:     Andrei Popescu, TU Muenchen
    30.7 +    Copyright   2014
    30.8 +
    30.9 +Stream processors---a syntactic representation of continuous functions on streams
   30.10 +*)
   30.11 +
   30.12 +header {* Stream Processors *}
   30.13 +
   30.14 +theory Stream_Processor
   30.15 +imports Stream "../BNF_Decl"
   30.16 +begin
   30.17 +
   30.18 +section {* Continuous Functions on Streams *}
   30.19 +
   30.20 +datatype_new ('a, 'b, 'c) sp\<^sub>\<mu> = Get "'a \<Rightarrow> ('a, 'b, 'c) sp\<^sub>\<mu>" | Put "'b" "'c"
   30.21 +codatatype ('a, 'b) sp\<^sub>\<nu> = In (out: "('a, 'b, ('a, 'b) sp\<^sub>\<nu>) sp\<^sub>\<mu>")
   30.22 +
   30.23 +primrec_new run\<^sub>\<mu> :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> 'a stream \<Rightarrow> ('b \<times> 'c) \<times> 'a stream" where
   30.24 +  "run\<^sub>\<mu> (Get f) s = run\<^sub>\<mu> (f (shd s)) (stl s)"
   30.25 +| "run\<^sub>\<mu> (Put b sp) s = ((b, sp), s)"
   30.26 +
   30.27 +primcorec run\<^sub>\<nu> :: "('a, 'b) sp\<^sub>\<nu> \<Rightarrow> 'a stream \<Rightarrow> 'b stream" where
   30.28 +  "run\<^sub>\<nu> sp s = (let ((h, sp), s) = run\<^sub>\<mu> (out sp) s in h ## run\<^sub>\<nu> sp s)"
   30.29 +
   30.30 +primcorec copy :: "('a, 'a) sp\<^sub>\<nu>" where
   30.31 +  "copy = In (Get (\<lambda>a. Put a copy))"
   30.32 +
   30.33 +lemma run\<^sub>\<nu>_copy: "run\<^sub>\<nu> copy s = s"
   30.34 +  by (coinduction arbitrary: s) simp
   30.35 +
   30.36 +text {*
   30.37 +To use the function package for the definition of composition the
   30.38 +wellfoundedness of the subtree relation needs to be proved first.
   30.39 +*}
   30.40 +
   30.41 +definition "sub \<equiv> {(f a, Get f) | a f. True}"
   30.42 +
   30.43 +lemma subI[intro]: "(f a, Get f) \<in> sub"
   30.44 +  unfolding sub_def by blast
   30.45 +
   30.46 +lemma wf_sub[simp, intro]: "wf sub"
   30.47 +proof (rule wfUNIVI)
   30.48 +  fix P  :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> bool" and x
   30.49 +  assume "\<forall>x. (\<forall>y. (y, x) \<in> sub \<longrightarrow> P y) \<longrightarrow> P x"
   30.50 +  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
   30.51 +  show "P x" by (induct x) (auto intro: I)
   30.52 +qed
   30.53 +
   30.54 +function
   30.55 +  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>"
   30.56 +  (infixl "o\<^sub>\<mu>" 65)
   30.57 +where
   30.58 +  "Put b sp o\<^sub>\<mu> fsp = Put b (sp, In fsp)"
   30.59 +| "Get f o\<^sub>\<mu> Put b sp = f b o\<^sub>\<mu> out sp"
   30.60 +| "Get f o\<^sub>\<mu> Get g = Get (\<lambda>a. Get f o\<^sub>\<mu> g a)"
   30.61 +by pat_completeness auto
   30.62 +termination by (relation "lex_prod sub sub") auto
   30.63 +
   30.64 +primcorec sp\<^sub>\<nu>_comp (infixl "o\<^sub>\<nu>" 65) where
   30.65 +  "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')"
   30.66 +
   30.67 +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'"
   30.68 +proof (rule ext, unfold comp_apply)
   30.69 +  fix s
   30.70 +  show "run\<^sub>\<nu> (sp o\<^sub>\<nu> sp') s = run\<^sub>\<nu> sp (run\<^sub>\<nu> sp' s)"
   30.71 +  proof (coinduction arbitrary: sp sp' s)
   30.72 +    case Eq_stream
   30.73 +    show ?case
   30.74 +    proof (induct "out sp" "out sp'" arbitrary: sp sp' s rule: sp\<^sub>\<mu>_comp.induct)
   30.75 +      case (1 b sp'')
   30.76 +      show ?case by (auto simp add: 1[symmetric])
   30.77 +    next
   30.78 +      case (2 f b sp'')
   30.79 +      from 2(1)[of "In (f b)" sp''] show ?case by (simp add: 2(2,3)[symmetric])
   30.80 +    next
   30.81 +      case (3 f h)
   30.82 +      from 3(1)[of _ "shd s" "In (h (shd s))", OF 3(2)] show ?case by (simp add: 3(2,3)[symmetric])
   30.83 +    qed
   30.84 +  qed
   30.85 +qed
   30.86 +
   30.87 +text {* Alternative definition of composition using primrec_new instead of function *}
   30.88 +
   30.89 +primrec_new sp\<^sub>\<mu>_comp2R  where
   30.90 +  "sp\<^sub>\<mu>_comp2R f (Put b sp) = f b (out sp)"
   30.91 +| "sp\<^sub>\<mu>_comp2R f (Get h) = Get (sp\<^sub>\<mu>_comp2R f o h)"
   30.92 +
   30.93 +primrec_new sp\<^sub>\<mu>_comp2 (infixl "o\<^sup>*\<^sub>\<mu>" 65) where
   30.94 +  "Put b sp o\<^sup>*\<^sub>\<mu> fsp = Put b (sp, In fsp)"
   30.95 +| "Get f o\<^sup>*\<^sub>\<mu> fsp = sp\<^sub>\<mu>_comp2R (op o\<^sup>*\<^sub>\<mu> o f) fsp"
   30.96 +
   30.97 +primcorec sp\<^sub>\<nu>_comp2 (infixl "o\<^sup>*\<^sub>\<nu>" 65) where
   30.98 +  "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')"
   30.99 +
  30.100 +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'"
  30.101 +proof (rule ext, unfold comp_apply)
  30.102 +  fix s
  30.103 +  show "run\<^sub>\<nu> (sp o\<^sup>*\<^sub>\<nu> sp') s = run\<^sub>\<nu> sp (run\<^sub>\<nu> sp' s)"
  30.104 +  proof (coinduction arbitrary: sp sp' s)
  30.105 +    case Eq_stream
  30.106 +    show ?case
  30.107 +    proof (induct "out sp" arbitrary: sp sp' s)
  30.108 +      case (Put b sp'')
  30.109 +      show ?case by (auto simp add: Put[symmetric])
  30.110 +    next
  30.111 +      case (Get f)
  30.112 +      then show ?case
  30.113 +      proof (induct "out sp'" arbitrary: sp sp' s)
  30.114 +        case (Put b sp'')
  30.115 +        from Put(2)[of "In (f b)" sp''] show ?case by (simp add: Put(1,3)[symmetric])
  30.116 +      next
  30.117 +        case (Get h)
  30.118 +        from Get(1)[OF _ Get(3,4), of "In (h (shd s))"] show ?case by (simp add: Get(2,4)[symmetric])
  30.119 +      qed
  30.120 +    qed
  30.121 +  qed
  30.122 +qed
  30.123 +
  30.124 +text {* The two definitions are equivalent *}
  30.125 +
  30.126 +lemma sp\<^sub>\<mu>_comp_sp\<^sub>\<mu>_comp2[simp]: "sp o\<^sub>\<mu> sp' = sp o\<^sup>*\<^sub>\<mu> sp'"
  30.127 +  by (induct sp sp' rule: sp\<^sub>\<mu>_comp.induct) auto
  30.128 +
  30.129 +(*will be provided by the package*)
  30.130 +lemma sp\<^sub>\<mu>_rel_map_map[unfolded vimage2p_def, simp]:
  30.131 +  "rel_sp\<^sub>\<mu> R1 R2 (map_sp\<^sub>\<mu> f1 f2 sp) (map_sp\<^sub>\<mu> g1 g2 sp') =
  30.132 +  rel_sp\<^sub>\<mu> (BNF_Def.vimage2p f1 g1 R1) (BNF_Def.vimage2p f2 g2 R2) sp sp'"
  30.133 +by (tactic {*
  30.134 +  let val ks = 1 upto 2;
  30.135 +  in
  30.136 +    BNF_Tactics.unfold_thms_tac @{context}
  30.137 +      @{thms sp\<^sub>\<mu>.rel_compp sp\<^sub>\<mu>.rel_conversep sp\<^sub>\<mu>.rel_Grp vimage2p_Grp} THEN
  30.138 +    HEADGOAL (EVERY' [rtac iffI, rtac @{thm relcomppI}, rtac @{thm GrpI}, rtac refl, rtac CollectI,
  30.139 +      BNF_Util.CONJ_WRAP' (K (rtac @{thm subset_UNIV})) ks, rtac @{thm relcomppI}, atac,
  30.140 +      rtac @{thm conversepI}, rtac @{thm GrpI}, rtac refl, rtac CollectI,
  30.141 +      BNF_Util.CONJ_WRAP' (K (rtac @{thm subset_UNIV})) ks,
  30.142 +      REPEAT_DETERM o eresolve_tac @{thms relcomppE conversepE GrpE},
  30.143 +      hyp_subst_tac @{context}, atac])
  30.144 +  end
  30.145 +*})
  30.146 +
  30.147 +lemma sp\<^sub>\<mu>_rel_self: "\<lbrakk>op = \<le> R1; op = \<le> R2\<rbrakk> \<Longrightarrow> rel_sp\<^sub>\<mu> R1 R2 x x"
  30.148 +  by (erule (1) predicate2D[OF sp\<^sub>\<mu>.rel_mono]) (simp only: sp\<^sub>\<mu>.rel_eq)
  30.149 +
  30.150 +lemma sp\<^sub>\<nu>_comp_sp\<^sub>\<nu>_comp2: "sp o\<^sub>\<nu> sp' = sp o\<^sup>*\<^sub>\<nu> sp'"
  30.151 +  by (coinduction arbitrary: sp sp') (auto intro!: sp\<^sub>\<mu>_rel_self)
  30.152 +
  30.153 +
  30.154 +section {* Generalization to an Arbitrary BNF as Codomain *}
  30.155 +
  30.156 +bnf_decl ('a, 'b) F (map: F)
  30.157 +
  30.158 +definition \<theta> :: "('p,'a) F * 'b \<Rightarrow> ('p,'a * 'b) F" where
  30.159 +   "\<theta> xb = F id <id, \<lambda> a. (snd xb)> (fst xb)"
  30.160 +
  30.161 +(* The strength laws for \<theta>: *)
  30.162 +lemma \<theta>_natural: "F id (map_pair f g) o \<theta> = \<theta> o map_pair (F id f) g"
  30.163 +  unfolding \<theta>_def F.map_comp comp_def id_apply convol_def map_pair_def split_beta fst_conv snd_conv ..
  30.164 +
  30.165 +definition assl :: "'a * ('b * 'c) \<Rightarrow> ('a * 'b) * 'c" where
  30.166 +  "assl abc = ((fst abc, fst (snd abc)), snd (snd abc))"
  30.167 +
  30.168 +lemma \<theta>_rid: "F id fst o \<theta> = fst"
  30.169 +  unfolding \<theta>_def F.map_comp F.map_id comp_def id_apply convol_def fst_conv sym[OF id_def] ..
  30.170 +
  30.171 +lemma \<theta>_assl: "F id assl o \<theta> = \<theta> o map_pair \<theta> id o assl"
  30.172 +  unfolding assl_def \<theta>_def F.map_comp comp_def id_apply convol_def map_pair_def split fst_conv snd_conv ..
  30.173 +
  30.174 +datatype_new ('a, 'b, 'c) spF\<^sub>\<mu> = GetF "'a \<Rightarrow> ('a, 'b, 'c) spF\<^sub>\<mu>" | PutF "('b,'c) F"
  30.175 +codatatype ('a, 'b) spF\<^sub>\<nu> = InF (outF: "('a, 'b, ('a, 'b) spF\<^sub>\<nu>) spF\<^sub>\<mu>")
  30.176 +
  30.177 +codatatype 'b JF = Ctor (dtor: "('b, 'b JF) F")
  30.178 +
  30.179 +(* Definition of run for an arbitrary final coalgebra as codomain: *)
  30.180 +
  30.181 +primrec_new
  30.182 +  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" 
  30.183 +where
  30.184 +  "runF\<^sub>\<mu> (GetF f) s = (runF\<^sub>\<mu> o f) (shd s) (stl s)"
  30.185 +| "runF\<^sub>\<mu> (PutF x) s = (x, s)"
  30.186 +
  30.187 +primcorec runF\<^sub>\<nu> :: "('a, 'b) spF\<^sub>\<nu> \<Rightarrow> 'a stream \<Rightarrow> 'b JF" where
  30.188 +  "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))"
  30.189 +
  30.190 +end
    31.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    31.2 +++ b/src/HOL/BNF_Examples/TreeFI.thy	Mon Jan 20 18:24:56 2014 +0100
    31.3 @@ -0,0 +1,46 @@
    31.4 +(*  Title:      HOL/BNF/Examples/TreeFI.thy
    31.5 +    Author:     Dmitriy Traytel, TU Muenchen
    31.6 +    Author:     Andrei Popescu, TU Muenchen
    31.7 +    Copyright   2012
    31.8 +
    31.9 +Finitely branching possibly infinite trees.
   31.10 +*)
   31.11 +
   31.12 +header {* Finitely Branching Possibly Infinite Trees *}
   31.13 +
   31.14 +theory TreeFI
   31.15 +imports ListF
   31.16 +begin
   31.17 +
   31.18 +codatatype 'a treeFI = Tree (lab: 'a) (sub: "'a treeFI listF")
   31.19 +
   31.20 +(* Tree reverse:*)
   31.21 +primcorec trev where
   31.22 +  "lab (trev t) = lab t"
   31.23 +| "sub (trev t) = mapF trev (lrev (sub t))"
   31.24 +
   31.25 +lemma treeFI_coinduct:
   31.26 +  assumes *: "phi x y"
   31.27 +  and step: "\<And>a b. phi a b \<Longrightarrow>
   31.28 +     lab a = lab b \<and>
   31.29 +     lengthh (sub a) = lengthh (sub b) \<and>
   31.30 +     (\<forall>i < lengthh (sub a). phi (nthh (sub a) i) (nthh (sub b) i))"
   31.31 +  shows "x = y"
   31.32 +using * proof (coinduction arbitrary: x y)
   31.33 +  case (Eq_treeFI t1 t2)
   31.34 +  from conjunct1[OF conjunct2[OF step[OF Eq_treeFI]]] conjunct2[OF conjunct2[OF step[OF Eq_treeFI]]]
   31.35 +  have "relF phi (sub t1) (sub t2)"
   31.36 +  proof (induction "sub t1" "sub t2" arbitrary: t1 t2 rule: listF_induct2)
   31.37 +    case (Conss x xs y ys)
   31.38 +    note sub = Conss(2,3)[symmetric] and phi = mp[OF spec[OF Conss(4)], unfolded sub]
   31.39 +      and IH = Conss(1)[of "Tree (lab t1) (tlF (sub t1))" "Tree (lab t2) (tlF (sub t2))",
   31.40 +        unfolded sub, simplified]
   31.41 +    from phi[of 0] show ?case unfolding sub by (auto intro!: IH dest: phi[simplified, OF Suc_mono])
   31.42 +  qed simp
   31.43 +  with conjunct1[OF step[OF Eq_treeFI]] show ?case by simp
   31.44 +qed
   31.45 +
   31.46 +lemma trev_trev: "trev (trev tr) = tr"
   31.47 +  by (coinduction arbitrary: tr rule: treeFI_coinduct) auto
   31.48 +
   31.49 +end
    32.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    32.2 +++ b/src/HOL/BNF_Examples/TreeFsetI.thy	Mon Jan 20 18:24:56 2014 +0100
    32.3 @@ -0,0 +1,27 @@
    32.4 +(*  Title:      HOL/BNF/Examples/TreeFsetI.thy
    32.5 +    Author:     Dmitriy Traytel, TU Muenchen
    32.6 +    Author:     Andrei Popescu, TU Muenchen
    32.7 +    Copyright   2012
    32.8 +
    32.9 +Finitely branching possibly infinite trees, with sets of children.
   32.10 +*)
   32.11 +
   32.12 +header {* Finitely Branching Possibly Infinite Trees, with Sets of Children *}
   32.13 +
   32.14 +theory TreeFsetI
   32.15 +imports "../BNF"
   32.16 +begin
   32.17 +
   32.18 +hide_fact (open) Lifting_Product.prod_rel_def
   32.19 +
   32.20 +codatatype 'a treeFsetI = Tree (lab: 'a) (sub: "'a treeFsetI fset")
   32.21 +
   32.22 +(* tree map (contrived example): *)
   32.23 +primcorec tmap where
   32.24 +"lab (tmap f t) = f (lab t)" |
   32.25 +"sub (tmap f t) = fimage (tmap f) (sub t)"
   32.26 +
   32.27 +lemma "tmap (f o g) x = tmap f (tmap g x)"
   32.28 +  by (coinduction arbitrary: x) (auto simp: fset_rel_alt)
   32.29 +
   32.30 +end
    33.1 --- a/src/HOL/ROOT	Mon Jan 20 18:24:56 2014 +0100
    33.2 +++ b/src/HOL/ROOT	Mon Jan 20 18:24:56 2014 +0100
    33.3 @@ -706,7 +706,7 @@
    33.4    options [document = false]
    33.5    theories BNF
    33.6  
    33.7 -session "HOL-BNF-Examples" in "BNF/Examples" = "HOL-BNF" +
    33.8 +session "HOL-BNF_Examples" in BNF_Examples = HOL +
    33.9    description {*
   33.10      Examples for Bounded Natural Functors.
   33.11    *}