renamed 'BNF_Examples' to 'Datatype_Examples' (cf. 'datatypes.pdf')
authorblanchet
Thu Sep 11 19:26:59 2014 +0200 (2014-09-11)
changeset 58309a09ec6daaa19
parent 58308 0ccba1b6d00b
child 58310 91ea607a34d8
renamed 'BNF_Examples' to 'Datatype_Examples' (cf. 'datatypes.pdf')
src/Doc/Datatypes/Datatypes.thy
src/HOL/BNF_Examples/Brackin.thy
src/HOL/BNF_Examples/Compat.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/Instructions.thy
src/HOL/BNF_Examples/IsaFoR_Datatypes.thy
src/HOL/BNF_Examples/Koenig.thy
src/HOL/BNF_Examples/Lambda_Term.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/SML.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/Verilog.thy
src/HOL/Datatype_Examples/Brackin.thy
src/HOL/Datatype_Examples/Compat.thy
src/HOL/Datatype_Examples/Derivation_Trees/DTree.thy
src/HOL/Datatype_Examples/Derivation_Trees/Gram_Lang.thy
src/HOL/Datatype_Examples/Derivation_Trees/Parallel.thy
src/HOL/Datatype_Examples/Derivation_Trees/Prelim.thy
src/HOL/Datatype_Examples/Instructions.thy
src/HOL/Datatype_Examples/IsaFoR_Datatypes.thy
src/HOL/Datatype_Examples/Koenig.thy
src/HOL/Datatype_Examples/Lambda_Term.thy
src/HOL/Datatype_Examples/Misc_Codatatype.thy
src/HOL/Datatype_Examples/Misc_Datatype.thy
src/HOL/Datatype_Examples/Misc_Primcorec.thy
src/HOL/Datatype_Examples/Misc_Primrec.thy
src/HOL/Datatype_Examples/Process.thy
src/HOL/Datatype_Examples/SML.thy
src/HOL/Datatype_Examples/Stream.thy
src/HOL/Datatype_Examples/Stream_Processor.thy
src/HOL/Datatype_Examples/TreeFI.thy
src/HOL/Datatype_Examples/TreeFsetI.thy
src/HOL/Datatype_Examples/Verilog.thy
src/HOL/ROOT
     1.1 --- a/src/Doc/Datatypes/Datatypes.thy	Thu Sep 11 19:20:23 2014 +0200
     1.2 +++ b/src/Doc/Datatypes/Datatypes.thy	Thu Sep 11 19:26:59 2014 +0200
     1.3 @@ -1112,7 +1112,7 @@
     1.4  text {*
     1.5  Primitive recursion is illustrated through concrete examples based on the
     1.6  datatypes defined in Section~\ref{ssec:datatype-introductory-examples}. More
     1.7 -examples can be found in the directory \verb|~~/src/HOL/BNF_Examples|.
     1.8 +examples can be found in the directory \verb|~~/src/HOL/Datatype_Examples|.
     1.9  *}
    1.10  
    1.11  
    1.12 @@ -1847,7 +1847,7 @@
    1.13  \keyw{prim\-corec\-ursive} commands, which support primitive corecursion, or
    1.14  using the more general \keyw{partial_function} command. Here, the focus is on
    1.15  the first two. More examples can be found in the directory
    1.16 -\verb|~~/src/HOL/BNF_Examples|.
    1.17 +\verb|~~/src/HOL/Datatype_Examples|.
    1.18  
    1.19  Whereas recursive functions consume datatypes one constructor at a time,
    1.20  corecursive functions construct codatatypes one constructor at a time.
    1.21 @@ -1891,8 +1891,8 @@
    1.22  text {*
    1.23  Primitive corecursion is illustrated through concrete examples based on the
    1.24  codatatypes defined in Section~\ref{ssec:codatatype-introductory-examples}. More
    1.25 -examples can be found in the directory \verb|~~/src/HOL/BNF_Examples|. The code
    1.26 -view is favored in the examples below. Sections
    1.27 +examples can be found in the directory \verb|~~/src/HOL/Datatype_Examples|. The
    1.28 +code view is favored in the examples below. Sections
    1.29  \ref{ssec:primrec-constructor-view} and \ref{ssec:primrec-destructor-view}
    1.30  present the same examples expressed using the constructor and destructor views.
    1.31  *}
     2.1 --- a/src/HOL/BNF_Examples/Brackin.thy	Thu Sep 11 19:20:23 2014 +0200
     2.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.3 @@ -1,41 +0,0 @@
     2.4 -(*  Title:      HOL/Datatype_Benchmark/Brackin.thy
     2.5 -
     2.6 -A couple of datatypes from Steve Brackin's work.
     2.7 -*)
     2.8 -
     2.9 -theory Brackin imports Main begin
    2.10 -
    2.11 -datatype T =
    2.12 -    X1 | X2 | X3 | X4 | X5 | X6 | X7 | X8 | X9 | X10 | X11 |
    2.13 -    X12 | X13 | X14 | X15 | X16 | X17 | X18 | X19 | X20 | X21 |
    2.14 -    X22 | X23 | X24 | X25 | X26 | X27 | X28 | X29 | X30 | X31 |
    2.15 -    X32 | X33 | X34
    2.16 -
    2.17 -datatype ('a, 'b, 'c) TY1 =
    2.18 -      NoF
    2.19 -    | Fk 'a "('a, 'b, 'c) TY2"
    2.20 -and ('a, 'b, 'c) TY2 =
    2.21 -      Ta bool
    2.22 -    | Td bool
    2.23 -    | Tf "('a, 'b, 'c) TY1"
    2.24 -    | Tk bool
    2.25 -    | Tp bool
    2.26 -    | App 'a "('a, 'b, 'c) TY1" "('a, 'b, 'c) TY2" "('a, 'b, 'c) TY3"
    2.27 -    | Pair "('a, 'b, 'c) TY2" "('a, 'b, 'c) TY2"
    2.28 -and ('a, 'b, 'c) TY3 =
    2.29 -      NoS
    2.30 -    | Fresh "('a, 'b, 'c) TY2"
    2.31 -    | Trustworthy 'a
    2.32 -    | PrivateKey 'a 'b 'c
    2.33 -    | PublicKey 'a 'b 'c
    2.34 -    | Conveyed 'a "('a, 'b, 'c) TY2"
    2.35 -    | Possesses 'a "('a, 'b, 'c) TY2"
    2.36 -    | Received 'a "('a, 'b, 'c) TY2"
    2.37 -    | Recognizes 'a "('a, 'b, 'c) TY2"
    2.38 -    | NeverMalFromSelf 'a 'b "('a, 'b, 'c) TY2"
    2.39 -    | Sends 'a "('a, 'b, 'c) TY2" 'b
    2.40 -    | SharedSecret 'a "('a, 'b, 'c) TY2" 'b
    2.41 -    | Believes 'a "('a, 'b, 'c) TY3"
    2.42 -    | And "('a, 'b, 'c) TY3" "('a, 'b, 'c) TY3"
    2.43 -
    2.44 -end
     3.1 --- a/src/HOL/BNF_Examples/Compat.thy	Thu Sep 11 19:20:23 2014 +0200
     3.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.3 @@ -1,236 +0,0 @@
     3.4 -(*  Title:      HOL/BNF_Examples/Compat.thy
     3.5 -    Author:     Jasmin Blanchette, TU Muenchen
     3.6 -    Copyright   2014
     3.7 -
     3.8 -Tests for compatibility with the old datatype package.
     3.9 -*)
    3.10 -
    3.11 -header \<open> Tests for Compatibility with the Old Datatype Package \<close>
    3.12 -
    3.13 -theory Compat
    3.14 -imports Main
    3.15 -begin
    3.16 -
    3.17 -subsection \<open> Viewing and Registering New-Style Datatypes as Old-Style Ones \<close>
    3.18 -
    3.19 -ML \<open>
    3.20 -fun check_len n xs label =
    3.21 -  length xs = n orelse error ("Expected length " ^ string_of_int (length xs) ^ " for " ^ label);
    3.22 -
    3.23 -fun check_lens (n1, n2, n3) (xs1, xs2, xs3) =
    3.24 -  check_len n1 xs1 "old" andalso check_len n2 xs2 "unfold" andalso check_len n3 xs3 "keep";
    3.25 -
    3.26 -fun get_descrs thy lens T_name =
    3.27 -  (these (Option.map #descr (Old_Datatype_Data.get_info thy T_name)),
    3.28 -   these (Option.map #descr (BNF_LFP_Compat.get_info thy BNF_LFP_Compat.Unfold_Nesting T_name)),
    3.29 -   these (Option.map #descr (BNF_LFP_Compat.get_info thy BNF_LFP_Compat.Keep_Nesting T_name)))
    3.30 -  |> tap (check_lens lens);
    3.31 -\<close>
    3.32 -
    3.33 -old_datatype 'a old_lst = Old_Nl | Old_Cns 'a "'a old_lst"
    3.34 -
    3.35 -ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name old_lst}; \<close>
    3.36 -
    3.37 -datatype_new 'a lst = Nl | Cns 'a "'a lst"
    3.38 -
    3.39 -ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name lst}; \<close>
    3.40 -
    3.41 -datatype_compat lst
    3.42 -
    3.43 -ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name lst}; \<close>
    3.44 -
    3.45 -datatype_new 'b w = W | W' "'b w \<times> 'b list"
    3.46 -
    3.47 -(* no support for sums of products:
    3.48 -datatype_compat w
    3.49 -*)
    3.50 -
    3.51 -ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name w}; \<close>
    3.52 -
    3.53 -datatype_new ('c, 'b) s = L 'c | R 'b
    3.54 -
    3.55 -ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name s}; \<close>
    3.56 -
    3.57 -datatype_new 'd x = X | X' "('d x lst, 'd list) s"
    3.58 -
    3.59 -ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name x}; \<close>
    3.60 -
    3.61 -datatype_compat s
    3.62 -
    3.63 -ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name s}; \<close>
    3.64 -ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name x}; \<close>
    3.65 -
    3.66 -datatype_compat x
    3.67 -
    3.68 -ML \<open> get_descrs @{theory} (3, 3, 1) @{type_name x}; \<close>
    3.69 -
    3.70 -thm x.induct x.rec
    3.71 -thm compat_x.induct compat_x.rec
    3.72 -
    3.73 -datatype_new 'a tttre = TTTre 'a "'a tttre lst lst lst"
    3.74 -
    3.75 -ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name tttre}; \<close>
    3.76 -
    3.77 -datatype_compat tttre
    3.78 -
    3.79 -ML \<open> get_descrs @{theory} (4, 4, 1) @{type_name tttre}; \<close>
    3.80 -
    3.81 -thm tttre.induct tttre.rec
    3.82 -thm compat_tttre.induct compat_tttre.rec
    3.83 -
    3.84 -datatype_new 'a ftre = FEmp | FTre "'a \<Rightarrow> 'a ftre lst"
    3.85 -
    3.86 -ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name ftre}; \<close>
    3.87 -
    3.88 -datatype_compat ftre
    3.89 -
    3.90 -ML \<open> get_descrs @{theory} (2, 2, 1) @{type_name ftre}; \<close>
    3.91 -
    3.92 -thm ftre.induct ftre.rec
    3.93 -thm compat_ftre.induct compat_ftre.rec
    3.94 -
    3.95 -datatype_new 'a btre = BTre 'a "'a btre lst" "'a btre lst"
    3.96 -
    3.97 -ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name btre}; \<close>
    3.98 -
    3.99 -datatype_compat btre
   3.100 -
   3.101 -ML \<open> get_descrs @{theory} (3, 3, 1) @{type_name btre}; \<close>
   3.102 -
   3.103 -thm btre.induct btre.rec
   3.104 -thm compat_btre.induct compat_btre.rec
   3.105 -
   3.106 -datatype_new 'a foo = Foo | Foo' 'a "'a bar" and 'a bar = Bar | Bar' 'a "'a foo"
   3.107 -
   3.108 -ML \<open> get_descrs @{theory} (0, 2, 2) @{type_name foo}; \<close>
   3.109 -ML \<open> get_descrs @{theory} (0, 2, 2) @{type_name bar}; \<close>
   3.110 -
   3.111 -datatype_compat foo bar
   3.112 -
   3.113 -ML \<open> get_descrs @{theory} (2, 2, 2) @{type_name foo}; \<close>
   3.114 -ML \<open> get_descrs @{theory} (2, 2, 2) @{type_name bar}; \<close>
   3.115 -
   3.116 -datatype_new 'a tre = Tre 'a "'a tre lst"
   3.117 -
   3.118 -ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name tre}; \<close>
   3.119 -
   3.120 -datatype_compat tre
   3.121 -
   3.122 -ML \<open> get_descrs @{theory} (2, 2, 1) @{type_name tre}; \<close>
   3.123 -
   3.124 -thm tre.induct tre.rec
   3.125 -thm compat_tre.induct compat_tre.rec
   3.126 -
   3.127 -datatype_new 'a f = F 'a and 'a g = G 'a
   3.128 -
   3.129 -ML \<open> get_descrs @{theory} (0, 2, 2) @{type_name f}; \<close>
   3.130 -ML \<open> get_descrs @{theory} (0, 2, 2) @{type_name g}; \<close>
   3.131 -
   3.132 -datatype_new h = H "h f" | H'
   3.133 -
   3.134 -ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name h}; \<close>
   3.135 -
   3.136 -datatype_compat f g
   3.137 -
   3.138 -ML \<open> get_descrs @{theory} (2, 2, 2) @{type_name f}; \<close>
   3.139 -ML \<open> get_descrs @{theory} (2, 2, 2) @{type_name g}; \<close>
   3.140 -ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name h}; \<close>
   3.141 -
   3.142 -datatype_compat h
   3.143 -
   3.144 -ML \<open> get_descrs @{theory} (3, 3, 1) @{type_name h}; \<close>
   3.145 -
   3.146 -thm h.induct h.rec
   3.147 -thm compat_h.induct compat_h.rec
   3.148 -
   3.149 -datatype_new myunit = MyUnity
   3.150 -
   3.151 -ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name myunit}; \<close>
   3.152 -
   3.153 -datatype_compat myunit
   3.154 -
   3.155 -ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name myunit}; \<close>
   3.156 -
   3.157 -datatype_new mylist = MyNil | MyCons nat mylist
   3.158 -
   3.159 -ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name mylist}; \<close>
   3.160 -
   3.161 -datatype_compat mylist
   3.162 -
   3.163 -ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name mylist}; \<close>
   3.164 -
   3.165 -datatype_new foo' = FooNil | FooCons bar' foo' and bar' = Bar
   3.166 -
   3.167 -ML \<open> get_descrs @{theory} (0, 2, 2) @{type_name foo'}; \<close>
   3.168 -ML \<open> get_descrs @{theory} (0, 2, 2) @{type_name bar'}; \<close>
   3.169 -
   3.170 -datatype_compat bar' foo'
   3.171 -
   3.172 -ML \<open> get_descrs @{theory} (2, 2, 2) @{type_name foo'}; \<close>
   3.173 -ML \<open> get_descrs @{theory} (2, 2, 2) @{type_name bar'}; \<close>
   3.174 -
   3.175 -old_datatype funky = Funky "funky tre" | Funky'
   3.176 -
   3.177 -ML \<open> get_descrs @{theory} (3, 3, 3) @{type_name funky}; \<close>
   3.178 -
   3.179 -old_datatype fnky = Fnky "nat tre"
   3.180 -
   3.181 -ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name fnky}; \<close>
   3.182 -
   3.183 -datatype_new tree = Tree "tree foo"
   3.184 -
   3.185 -ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name tree}; \<close>
   3.186 -
   3.187 -datatype_compat tree
   3.188 -
   3.189 -ML \<open> get_descrs @{theory} (3, 3, 1) @{type_name tree}; \<close>
   3.190 -
   3.191 -thm tree.induct tree.rec
   3.192 -thm compat_tree.induct compat_tree.rec
   3.193 -
   3.194 -
   3.195 -subsection \<open> Creating New-Style Datatypes Using Old-Style Interfaces \<close>
   3.196 -
   3.197 -ML \<open>
   3.198 -val l_specs =
   3.199 -  [((@{binding l}, [("'a", @{sort type})], NoSyn),
   3.200 -   [(@{binding N}, [], NoSyn),
   3.201 -    (@{binding C}, [@{typ 'a}, Type (Sign.full_name @{theory} @{binding l}, [@{typ 'a}])], NoSyn)])];
   3.202 -\<close>
   3.203 -
   3.204 -setup \<open> snd o BNF_LFP_Compat.add_datatype BNF_LFP_Compat.Unfold_Nesting l_specs; \<close>
   3.205 -
   3.206 -ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name l}; \<close>
   3.207 -
   3.208 -thm l.exhaust l.map l.induct l.rec l.size
   3.209 -
   3.210 -ML \<open>
   3.211 -val t_specs =
   3.212 -  [((@{binding t}, [("'b", @{sort type})], NoSyn),
   3.213 -   [(@{binding T}, [@{typ 'b}, Type (@{type_name l},
   3.214 -       [Type (Sign.full_name @{theory} @{binding t}, [@{typ 'b}])])], NoSyn)])];
   3.215 -\<close>
   3.216 -
   3.217 -setup \<open> snd o BNF_LFP_Compat.add_datatype BNF_LFP_Compat.Unfold_Nesting t_specs; \<close>
   3.218 -
   3.219 -ML \<open> get_descrs @{theory} (2, 2, 1) @{type_name t}; \<close>
   3.220 -
   3.221 -thm t.exhaust t.map t.induct t.rec t.size
   3.222 -thm compat_t.induct compat_t.rec
   3.223 -
   3.224 -ML \<open>
   3.225 -val ft_specs =
   3.226 -  [((@{binding ft}, [("'a", @{sort type})], NoSyn),
   3.227 -   [(@{binding FT0}, [], NoSyn),
   3.228 -    (@{binding FT}, [@{typ 'a} --> Type (Sign.full_name @{theory} @{binding ft}, [@{typ 'a}])],
   3.229 -     NoSyn)])];
   3.230 -\<close>
   3.231 -
   3.232 -setup \<open> snd o BNF_LFP_Compat.add_datatype BNF_LFP_Compat.Unfold_Nesting ft_specs; \<close>
   3.233 -
   3.234 -ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name ft}; \<close>
   3.235 -
   3.236 -thm ft.exhaust ft.induct ft.rec ft.size
   3.237 -thm compat_ft.induct compat_ft.rec
   3.238 -
   3.239 -end
     4.1 --- a/src/HOL/BNF_Examples/Derivation_Trees/DTree.thy	Thu Sep 11 19:20:23 2014 +0200
     4.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.3 @@ -1,90 +0,0 @@
     4.4 -(*  Title:      HOL/BNF_Examples/Derivation_Trees/DTree.thy
     4.5 -    Author:     Andrei Popescu, TU Muenchen
     4.6 -    Copyright   2012
     4.7 -
     4.8 -Derivation trees with nonterminal internal nodes and terminal leaves.
     4.9 -*)
    4.10 -
    4.11 -header {* Trees with Nonterminal Internal Nodes and Terminal Leaves *}
    4.12 -
    4.13 -theory DTree
    4.14 -imports Prelim
    4.15 -begin
    4.16 -
    4.17 -typedecl N
    4.18 -typedecl T
    4.19 -
    4.20 -codatatype dtree = NNode (root: N) (ccont: "(T + dtree) fset")
    4.21 -
    4.22 -subsection{* Transporting the Characteristic Lemmas from @{text "fset"} to @{text "set"} *}
    4.23 -
    4.24 -definition "Node n as \<equiv> NNode n (the_inv fset as)"
    4.25 -definition "cont \<equiv> fset o ccont"
    4.26 -definition "unfold rt ct \<equiv> corec_dtree rt (the_inv fset o image (map_sum id Inr) o ct)"
    4.27 -definition "corec rt ct \<equiv> corec_dtree rt (the_inv fset o ct)"
    4.28 -
    4.29 -lemma finite_cont[simp]: "finite (cont tr)"
    4.30 -  unfolding cont_def comp_apply by (cases tr, clarsimp)
    4.31 -
    4.32 -lemma Node_root_cont[simp]:
    4.33 -  "Node (root tr) (cont tr) = tr"
    4.34 -  unfolding Node_def cont_def comp_apply
    4.35 -  apply (rule trans[OF _ dtree.collapse])
    4.36 -  apply (rule arg_cong2[OF refl the_inv_into_f_f[unfolded inj_on_def]])
    4.37 -  apply (simp_all add: fset_inject)
    4.38 -  done
    4.39 -
    4.40 -lemma dtree_simps[simp]:
    4.41 -assumes "finite as" and "finite as'"
    4.42 -shows "Node n as = Node n' as' \<longleftrightarrow> n = n' \<and> as = as'"
    4.43 -using assms dtree.inject unfolding Node_def
    4.44 -by (metis fset_to_fset)
    4.45 -
    4.46 -lemma dtree_cases[elim, case_names Node Choice]:
    4.47 -assumes Node: "\<And> n as. \<lbrakk>finite as; tr = Node n as\<rbrakk> \<Longrightarrow> phi"
    4.48 -shows phi
    4.49 -apply(cases rule: dtree.exhaust[of tr])
    4.50 -using Node unfolding Node_def
    4.51 -by (metis Node Node_root_cont finite_cont)
    4.52 -
    4.53 -lemma dtree_sel_ctr[simp]:
    4.54 -"root (Node n as) = n"
    4.55 -"finite as \<Longrightarrow> cont (Node n as) = as"
    4.56 -unfolding Node_def cont_def by auto
    4.57 -
    4.58 -lemmas root_Node = dtree_sel_ctr(1)
    4.59 -lemmas cont_Node = dtree_sel_ctr(2)
    4.60 -
    4.61 -lemma dtree_cong:
    4.62 -assumes "root tr = root tr'" and "cont tr = cont tr'"
    4.63 -shows "tr = tr'"
    4.64 -by (metis Node_root_cont assms)
    4.65 -
    4.66 -lemma rel_set_cont:
    4.67 -"rel_set \<chi> (cont tr1) (cont tr2) = rel_fset \<chi> (ccont tr1) (ccont tr2)"
    4.68 -unfolding cont_def comp_def rel_fset_fset ..
    4.69 -
    4.70 -lemma dtree_coinduct[elim, consumes 1, case_names Lift, induct pred: "HOL.eq"]:
    4.71 -assumes phi: "\<phi> tr1 tr2" and
    4.72 -Lift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow>
    4.73 -                  root tr1 = root tr2 \<and> rel_set (rel_sum op = \<phi>) (cont tr1) (cont tr2)"
    4.74 -shows "tr1 = tr2"
    4.75 -using phi apply(elim dtree.coinduct)
    4.76 -apply(rule Lift[unfolded rel_set_cont]) .
    4.77 -
    4.78 -lemma unfold:
    4.79 -"root (unfold rt ct b) = rt b"
    4.80 -"finite (ct b) \<Longrightarrow> cont (unfold rt ct b) = image (id \<oplus> unfold rt ct) (ct b)"
    4.81 -using dtree.corec_sel[of rt "the_inv fset o image (map_sum id Inr) o ct" b] unfolding unfold_def
    4.82 -apply blast
    4.83 -unfolding cont_def comp_def
    4.84 -by (simp add: case_sum_o_inj map_sum.compositionality image_image)
    4.85 -
    4.86 -lemma corec:
    4.87 -"root (corec rt ct b) = rt b"
    4.88 -"finite (ct b) \<Longrightarrow> cont (corec rt ct b) = image (id \<oplus> ([[id, corec rt ct]])) (ct b)"
    4.89 -using dtree.corec_sel[of rt "the_inv fset \<circ> ct" b] unfolding corec_def
    4.90 -unfolding cont_def comp_def id_def
    4.91 -by simp_all
    4.92 -
    4.93 -end
     5.1 --- a/src/HOL/BNF_Examples/Derivation_Trees/Gram_Lang.thy	Thu Sep 11 19:20:23 2014 +0200
     5.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.3 @@ -1,1357 +0,0 @@
     5.4 -(*  Title:      HOL/BNF_Examples/Derivation_Trees/Gram_Lang.thy
     5.5 -    Author:     Andrei Popescu, TU Muenchen
     5.6 -    Copyright   2012
     5.7 -
     5.8 -Language of a grammar.
     5.9 -*)
    5.10 -
    5.11 -header {* Language of a Grammar *}
    5.12 -
    5.13 -theory Gram_Lang
    5.14 -imports DTree "~~/src/HOL/Library/Infinite_Set"
    5.15 -begin
    5.16 -
    5.17 -
    5.18 -(* We assume that the sets of terminals, and the left-hand sides of
    5.19 -productions are finite and that the grammar has no unused nonterminals. *)
    5.20 -consts P :: "(N \<times> (T + N) set) set"
    5.21 -axiomatization where
    5.22 -    finite_N: "finite (UNIV::N set)"
    5.23 -and finite_in_P: "\<And> n tns. (n,tns) \<in> P \<longrightarrow> finite tns"
    5.24 -and used: "\<And> n. \<exists> tns. (n,tns) \<in> P"
    5.25 -
    5.26 -
    5.27 -subsection{* Tree Basics: frontier, interior, etc. *}
    5.28 -
    5.29 -
    5.30 -(* Frontier *)
    5.31 -
    5.32 -inductive inFr :: "N set \<Rightarrow> dtree \<Rightarrow> T \<Rightarrow> bool" where
    5.33 -Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr ns tr t"
    5.34 -|
    5.35 -Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inFr ns tr1 t\<rbrakk> \<Longrightarrow> inFr ns tr t"
    5.36 -
    5.37 -definition "Fr ns tr \<equiv> {t. inFr ns tr t}"
    5.38 -
    5.39 -lemma inFr_root_in: "inFr ns tr t \<Longrightarrow> root tr \<in> ns"
    5.40 -by (metis inFr.simps)
    5.41 -
    5.42 -lemma inFr_mono:
    5.43 -assumes "inFr ns tr t" and "ns \<subseteq> ns'"
    5.44 -shows "inFr ns' tr t"
    5.45 -using assms apply(induct arbitrary: ns' rule: inFr.induct)
    5.46 -using Base Ind by (metis inFr.simps set_mp)+
    5.47 -
    5.48 -lemma inFr_Ind_minus:
    5.49 -assumes "inFr ns1 tr1 t" and "Inr tr1 \<in> cont tr"
    5.50 -shows "inFr (insert (root tr) ns1) tr t"
    5.51 -using assms apply(induct rule: inFr.induct)
    5.52 -  apply (metis inFr.simps insert_iff)
    5.53 -  by (metis inFr.simps inFr_mono insertI1 subset_insertI)
    5.54 -
    5.55 -(* alternative definition *)
    5.56 -inductive inFr2 :: "N set \<Rightarrow> dtree \<Rightarrow> T \<Rightarrow> bool" where
    5.57 -Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr2 ns tr t"
    5.58 -|
    5.59 -Ind: "\<lbrakk>Inr tr1 \<in> cont tr; inFr2 ns1 tr1 t\<rbrakk>
    5.60 -      \<Longrightarrow> inFr2 (insert (root tr) ns1) tr t"
    5.61 -
    5.62 -lemma inFr2_root_in: "inFr2 ns tr t \<Longrightarrow> root tr \<in> ns"
    5.63 -apply(induct rule: inFr2.induct) by auto
    5.64 -
    5.65 -lemma inFr2_mono:
    5.66 -assumes "inFr2 ns tr t" and "ns \<subseteq> ns'"
    5.67 -shows "inFr2 ns' tr t"
    5.68 -using assms apply(induct arbitrary: ns' rule: inFr2.induct)
    5.69 -using Base Ind
    5.70 -apply (metis subsetD) by (metis inFr2.simps insert_absorb insert_subset)
    5.71 -
    5.72 -lemma inFr2_Ind:
    5.73 -assumes "inFr2 ns tr1 t" and "root tr \<in> ns" and "Inr tr1 \<in> cont tr"
    5.74 -shows "inFr2 ns tr t"
    5.75 -using assms apply(induct rule: inFr2.induct)
    5.76 -  apply (metis inFr2.simps insert_absorb)
    5.77 -  by (metis inFr2.simps insert_absorb)
    5.78 -
    5.79 -lemma inFr_inFr2:
    5.80 -"inFr = inFr2"
    5.81 -apply (rule ext)+  apply(safe)
    5.82 -  apply(erule inFr.induct)
    5.83 -    apply (metis (lifting) inFr2.Base)
    5.84 -    apply (metis (lifting) inFr2_Ind)
    5.85 -  apply(erule inFr2.induct)
    5.86 -    apply (metis (lifting) inFr.Base)
    5.87 -    apply (metis (lifting) inFr_Ind_minus)
    5.88 -done
    5.89 -
    5.90 -lemma not_root_inFr:
    5.91 -assumes "root tr \<notin> ns"
    5.92 -shows "\<not> inFr ns tr t"
    5.93 -by (metis assms inFr_root_in)
    5.94 -
    5.95 -lemma not_root_Fr:
    5.96 -assumes "root tr \<notin> ns"
    5.97 -shows "Fr ns tr = {}"
    5.98 -using not_root_inFr[OF assms] unfolding Fr_def by auto
    5.99 -
   5.100 -
   5.101 -(* Interior *)
   5.102 -
   5.103 -inductive inItr :: "N set \<Rightarrow> dtree \<Rightarrow> N \<Rightarrow> bool" where
   5.104 -Base: "root tr \<in> ns \<Longrightarrow> inItr ns tr (root tr)"
   5.105 -|
   5.106 -Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inItr ns tr1 n\<rbrakk> \<Longrightarrow> inItr ns tr n"
   5.107 -
   5.108 -definition "Itr ns tr \<equiv> {n. inItr ns tr n}"
   5.109 -
   5.110 -lemma inItr_root_in: "inItr ns tr n \<Longrightarrow> root tr \<in> ns"
   5.111 -by (metis inItr.simps)
   5.112 -
   5.113 -lemma inItr_mono:
   5.114 -assumes "inItr ns tr n" and "ns \<subseteq> ns'"
   5.115 -shows "inItr ns' tr n"
   5.116 -using assms apply(induct arbitrary: ns' rule: inItr.induct)
   5.117 -using Base Ind by (metis inItr.simps set_mp)+
   5.118 -
   5.119 -
   5.120 -(* The subtree relation *)
   5.121 -
   5.122 -inductive subtr where
   5.123 -Refl: "root tr \<in> ns \<Longrightarrow> subtr ns tr tr"
   5.124 -|
   5.125 -Step: "\<lbrakk>root tr3 \<in> ns; subtr ns tr1 tr2; Inr tr2 \<in> cont tr3\<rbrakk> \<Longrightarrow> subtr ns tr1 tr3"
   5.126 -
   5.127 -lemma subtr_rootL_in:
   5.128 -assumes "subtr ns tr1 tr2"
   5.129 -shows "root tr1 \<in> ns"
   5.130 -using assms apply(induct rule: subtr.induct) by auto
   5.131 -
   5.132 -lemma subtr_rootR_in:
   5.133 -assumes "subtr ns tr1 tr2"
   5.134 -shows "root tr2 \<in> ns"
   5.135 -using assms apply(induct rule: subtr.induct) by auto
   5.136 -
   5.137 -lemmas subtr_roots_in = subtr_rootL_in subtr_rootR_in
   5.138 -
   5.139 -lemma subtr_mono:
   5.140 -assumes "subtr ns tr1 tr2" and "ns \<subseteq> ns'"
   5.141 -shows "subtr ns' tr1 tr2"
   5.142 -using assms apply(induct arbitrary: ns' rule: subtr.induct)
   5.143 -using Refl Step by (metis subtr.simps set_mp)+
   5.144 -
   5.145 -lemma subtr_trans_Un:
   5.146 -assumes "subtr ns12 tr1 tr2" and "subtr ns23 tr2 tr3"
   5.147 -shows "subtr (ns12 \<union> ns23) tr1 tr3"
   5.148 -proof-
   5.149 -  have "subtr ns23 tr2 tr3  \<Longrightarrow>
   5.150 -        (\<forall> ns12 tr1. subtr ns12 tr1 tr2 \<longrightarrow> subtr (ns12 \<union> ns23) tr1 tr3)"
   5.151 -  apply(induct  rule: subtr.induct, safe)
   5.152 -    apply (metis subtr_mono sup_commute sup_ge2)
   5.153 -    by (metis (lifting) Step UnI2)
   5.154 -  thus ?thesis using assms by auto
   5.155 -qed
   5.156 -
   5.157 -lemma subtr_trans:
   5.158 -assumes "subtr ns tr1 tr2" and "subtr ns tr2 tr3"
   5.159 -shows "subtr ns tr1 tr3"
   5.160 -using subtr_trans_Un[OF assms] by simp
   5.161 -
   5.162 -lemma subtr_StepL:
   5.163 -assumes r: "root tr1 \<in> ns" and tr12: "Inr tr1 \<in> cont tr2" and s: "subtr ns tr2 tr3"
   5.164 -shows "subtr ns tr1 tr3"
   5.165 -apply(rule subtr_trans[OF _ s])
   5.166 -apply(rule Step[of tr2 ns tr1 tr1])
   5.167 -apply(rule subtr_rootL_in[OF s])
   5.168 -apply(rule Refl[OF r])
   5.169 -apply(rule tr12)
   5.170 -done
   5.171 -
   5.172 -(* alternative definition: *)
   5.173 -inductive subtr2 where
   5.174 -Refl: "root tr \<in> ns \<Longrightarrow> subtr2 ns tr tr"
   5.175 -|
   5.176 -Step: "\<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr2 ns tr2 tr3\<rbrakk> \<Longrightarrow> subtr2 ns tr1 tr3"
   5.177 -
   5.178 -lemma subtr2_rootL_in:
   5.179 -assumes "subtr2 ns tr1 tr2"
   5.180 -shows "root tr1 \<in> ns"
   5.181 -using assms apply(induct rule: subtr2.induct) by auto
   5.182 -
   5.183 -lemma subtr2_rootR_in:
   5.184 -assumes "subtr2 ns tr1 tr2"
   5.185 -shows "root tr2 \<in> ns"
   5.186 -using assms apply(induct rule: subtr2.induct) by auto
   5.187 -
   5.188 -lemmas subtr2_roots_in = subtr2_rootL_in subtr2_rootR_in
   5.189 -
   5.190 -lemma subtr2_mono:
   5.191 -assumes "subtr2 ns tr1 tr2" and "ns \<subseteq> ns'"
   5.192 -shows "subtr2 ns' tr1 tr2"
   5.193 -using assms apply(induct arbitrary: ns' rule: subtr2.induct)
   5.194 -using Refl Step by (metis subtr2.simps set_mp)+
   5.195 -
   5.196 -lemma subtr2_trans_Un:
   5.197 -assumes "subtr2 ns12 tr1 tr2" and "subtr2 ns23 tr2 tr3"
   5.198 -shows "subtr2 (ns12 \<union> ns23) tr1 tr3"
   5.199 -proof-
   5.200 -  have "subtr2 ns12 tr1 tr2  \<Longrightarrow>
   5.201 -        (\<forall> ns23 tr3. subtr2 ns23 tr2 tr3 \<longrightarrow> subtr2 (ns12 \<union> ns23) tr1 tr3)"
   5.202 -  apply(induct  rule: subtr2.induct, safe)
   5.203 -    apply (metis subtr2_mono sup_commute sup_ge2)
   5.204 -    by (metis Un_iff subtr2.simps)
   5.205 -  thus ?thesis using assms by auto
   5.206 -qed
   5.207 -
   5.208 -lemma subtr2_trans:
   5.209 -assumes "subtr2 ns tr1 tr2" and "subtr2 ns tr2 tr3"
   5.210 -shows "subtr2 ns tr1 tr3"
   5.211 -using subtr2_trans_Un[OF assms] by simp
   5.212 -
   5.213 -lemma subtr2_StepR:
   5.214 -assumes r: "root tr3 \<in> ns" and tr23: "Inr tr2 \<in> cont tr3" and s: "subtr2 ns tr1 tr2"
   5.215 -shows "subtr2 ns tr1 tr3"
   5.216 -apply(rule subtr2_trans[OF s])
   5.217 -apply(rule Step[of _ _ tr3])
   5.218 -apply(rule subtr2_rootR_in[OF s])
   5.219 -apply(rule tr23)
   5.220 -apply(rule Refl[OF r])
   5.221 -done
   5.222 -
   5.223 -lemma subtr_subtr2:
   5.224 -"subtr = subtr2"
   5.225 -apply (rule ext)+  apply(safe)
   5.226 -  apply(erule subtr.induct)
   5.227 -    apply (metis (lifting) subtr2.Refl)
   5.228 -    apply (metis (lifting) subtr2_StepR)
   5.229 -  apply(erule subtr2.induct)
   5.230 -    apply (metis (lifting) subtr.Refl)
   5.231 -    apply (metis (lifting) subtr_StepL)
   5.232 -done
   5.233 -
   5.234 -lemma subtr_inductL[consumes 1, case_names Refl Step]:
   5.235 -assumes s: "subtr ns tr1 tr2" and Refl: "\<And>ns tr. \<phi> ns tr tr"
   5.236 -and Step:
   5.237 -"\<And>ns tr1 tr2 tr3.
   5.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"
   5.239 -shows "\<phi> ns tr1 tr2"
   5.240 -using s unfolding subtr_subtr2 apply(rule subtr2.induct)
   5.241 -using Refl Step unfolding subtr_subtr2 by auto
   5.242 -
   5.243 -lemma subtr_UNIV_inductL[consumes 1, case_names Refl Step]:
   5.244 -assumes s: "subtr UNIV tr1 tr2" and Refl: "\<And>tr. \<phi> tr tr"
   5.245 -and Step:
   5.246 -"\<And>tr1 tr2 tr3.
   5.247 -   \<lbrakk>Inr tr1 \<in> cont tr2; subtr UNIV tr2 tr3; \<phi> tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> tr1 tr3"
   5.248 -shows "\<phi> tr1 tr2"
   5.249 -using s apply(induct rule: subtr_inductL)
   5.250 -apply(rule Refl) using Step subtr_mono by (metis subset_UNIV)
   5.251 -
   5.252 -(* Subtree versus frontier: *)
   5.253 -lemma subtr_inFr:
   5.254 -assumes "inFr ns tr t" and "subtr ns tr tr1"
   5.255 -shows "inFr ns tr1 t"
   5.256 -proof-
   5.257 -  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inFr ns tr t \<longrightarrow> inFr ns tr1 t)"
   5.258 -  apply(induct rule: subtr.induct, safe) by (metis inFr.Ind)
   5.259 -  thus ?thesis using assms by auto
   5.260 -qed
   5.261 -
   5.262 -corollary Fr_subtr:
   5.263 -"Fr ns tr = \<Union> {Fr ns tr' | tr'. subtr ns tr' tr}"
   5.264 -unfolding Fr_def proof safe
   5.265 -  fix t assume t: "inFr ns tr t"  hence "root tr \<in> ns" by (rule inFr_root_in)
   5.266 -  thus "t \<in> \<Union>{{t. inFr ns tr' t} |tr'. subtr ns tr' tr}"
   5.267 -  apply(intro UnionI[of "{t. inFr ns tr t}" _ t]) using t subtr.Refl by auto
   5.268 -qed(metis subtr_inFr)
   5.269 -
   5.270 -lemma inFr_subtr:
   5.271 -assumes "inFr ns tr t"
   5.272 -shows "\<exists> tr'. subtr ns tr' tr \<and> Inl t \<in> cont tr'"
   5.273 -using assms apply(induct rule: inFr.induct) apply safe
   5.274 -  apply (metis subtr.Refl)
   5.275 -  by (metis (lifting) subtr.Step)
   5.276 -
   5.277 -corollary Fr_subtr_cont:
   5.278 -"Fr ns tr = \<Union> {Inl -` cont tr' | tr'. subtr ns tr' tr}"
   5.279 -unfolding Fr_def
   5.280 -apply safe
   5.281 -apply (frule inFr_subtr)
   5.282 -apply auto
   5.283 -by (metis inFr.Base subtr_inFr subtr_rootL_in)
   5.284 -
   5.285 -(* Subtree versus interior: *)
   5.286 -lemma subtr_inItr:
   5.287 -assumes "inItr ns tr n" and "subtr ns tr tr1"
   5.288 -shows "inItr ns tr1 n"
   5.289 -proof-
   5.290 -  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inItr ns tr n \<longrightarrow> inItr ns tr1 n)"
   5.291 -  apply(induct rule: subtr.induct, safe) by (metis inItr.Ind)
   5.292 -  thus ?thesis using assms by auto
   5.293 -qed
   5.294 -
   5.295 -corollary Itr_subtr:
   5.296 -"Itr ns tr = \<Union> {Itr ns tr' | tr'. subtr ns tr' tr}"
   5.297 -unfolding Itr_def apply safe
   5.298 -apply (metis (lifting, mono_tags) UnionI inItr_root_in mem_Collect_eq subtr.Refl)
   5.299 -by (metis subtr_inItr)
   5.300 -
   5.301 -lemma inItr_subtr:
   5.302 -assumes "inItr ns tr n"
   5.303 -shows "\<exists> tr'. subtr ns tr' tr \<and> root tr' = n"
   5.304 -using assms apply(induct rule: inItr.induct) apply safe
   5.305 -  apply (metis subtr.Refl)
   5.306 -  by (metis (lifting) subtr.Step)
   5.307 -
   5.308 -corollary Itr_subtr_cont:
   5.309 -"Itr ns tr = {root tr' | tr'. subtr ns tr' tr}"
   5.310 -unfolding Itr_def apply safe
   5.311 -  apply (metis (lifting, mono_tags) inItr_subtr)
   5.312 -  by (metis inItr.Base subtr_inItr subtr_rootL_in)
   5.313 -
   5.314 -
   5.315 -subsection{* The Immediate Subtree Function *}
   5.316 -
   5.317 -(* production of: *)
   5.318 -abbreviation "prodOf tr \<equiv> (id \<oplus> root) ` (cont tr)"
   5.319 -(* subtree of: *)
   5.320 -definition "subtrOf tr n \<equiv> SOME tr'. Inr tr' \<in> cont tr \<and> root tr' = n"
   5.321 -
   5.322 -lemma subtrOf:
   5.323 -assumes n: "Inr n \<in> prodOf tr"
   5.324 -shows "Inr (subtrOf tr n) \<in> cont tr \<and> root (subtrOf tr n) = n"
   5.325 -proof-
   5.326 -  obtain tr' where "Inr tr' \<in> cont tr \<and> root tr' = n"
   5.327 -  using n unfolding image_def by (metis (lifting) Inr_oplus_elim assms)
   5.328 -  thus ?thesis unfolding subtrOf_def by(rule someI)
   5.329 -qed
   5.330 -
   5.331 -lemmas Inr_subtrOf = subtrOf[THEN conjunct1]
   5.332 -lemmas root_subtrOf[simp] = subtrOf[THEN conjunct2]
   5.333 -
   5.334 -lemma Inl_prodOf: "Inl -` (prodOf tr) = Inl -` (cont tr)"
   5.335 -proof safe
   5.336 -  fix t ttr assume "Inl t = (id \<oplus> root) ttr" and "ttr \<in> cont tr"
   5.337 -  thus "t \<in> Inl -` cont tr" by(cases ttr, auto)
   5.338 -next
   5.339 -  fix t assume "Inl t \<in> cont tr" thus "t \<in> Inl -` prodOf tr"
   5.340 -  by (metis (lifting) id_def image_iff map_sum.simps(1) vimageI2)
   5.341 -qed
   5.342 -
   5.343 -lemma root_prodOf:
   5.344 -assumes "Inr tr' \<in> cont tr"
   5.345 -shows "Inr (root tr') \<in> prodOf tr"
   5.346 -by (metis (lifting) assms image_iff map_sum.simps(2))
   5.347 -
   5.348 -
   5.349 -subsection{* Well-Formed Derivation Trees *}
   5.350 -
   5.351 -hide_const wf
   5.352 -
   5.353 -coinductive wf where
   5.354 -dtree: "\<lbrakk>(root tr, (id \<oplus> root) ` (cont tr)) \<in> P; inj_on root (Inr -` cont tr);
   5.355 -        \<And> tr'. tr' \<in> Inr -` (cont tr) \<Longrightarrow> wf tr'\<rbrakk> \<Longrightarrow> wf tr"
   5.356 -
   5.357 -(* destruction rules: *)
   5.358 -lemma wf_P:
   5.359 -assumes "wf tr"
   5.360 -shows "(root tr, (id \<oplus> root) ` (cont tr)) \<in> P"
   5.361 -using assms wf.simps[of tr] by auto
   5.362 -
   5.363 -lemma wf_inj_on:
   5.364 -assumes "wf tr"
   5.365 -shows "inj_on root (Inr -` cont tr)"
   5.366 -using assms wf.simps[of tr] by auto
   5.367 -
   5.368 -lemma wf_inj[simp]:
   5.369 -assumes "wf tr" and "Inr tr1 \<in> cont tr" and "Inr tr2 \<in> cont tr"
   5.370 -shows "root tr1 = root tr2 \<longleftrightarrow> tr1 = tr2"
   5.371 -using assms wf_inj_on unfolding inj_on_def by auto
   5.372 -
   5.373 -lemma wf_cont:
   5.374 -assumes "wf tr" and "Inr tr' \<in> cont tr"
   5.375 -shows "wf tr'"
   5.376 -using assms wf.simps[of tr] by auto
   5.377 -
   5.378 -
   5.379 -(* coinduction:*)
   5.380 -lemma wf_coind[elim, consumes 1, case_names Hyp]:
   5.381 -assumes phi: "\<phi> tr"
   5.382 -and Hyp:
   5.383 -"\<And> tr. \<phi> tr \<Longrightarrow>
   5.384 -       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
   5.385 -       inj_on root (Inr -` cont tr) \<and>
   5.386 -       (\<forall> tr' \<in> Inr -` (cont tr). \<phi> tr' \<or> wf tr')"
   5.387 -shows "wf tr"
   5.388 -apply(rule wf.coinduct[of \<phi> tr, OF phi])
   5.389 -using Hyp by blast
   5.390 -
   5.391 -lemma wf_raw_coind[elim, consumes 1, case_names Hyp]:
   5.392 -assumes phi: "\<phi> tr"
   5.393 -and Hyp:
   5.394 -"\<And> tr. \<phi> tr \<Longrightarrow>
   5.395 -       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
   5.396 -       inj_on root (Inr -` cont tr) \<and>
   5.397 -       (\<forall> tr' \<in> Inr -` (cont tr). \<phi> tr')"
   5.398 -shows "wf tr"
   5.399 -using phi apply(induct rule: wf_coind)
   5.400 -using Hyp by (metis (mono_tags))
   5.401 -
   5.402 -lemma wf_subtr_inj_on:
   5.403 -assumes d: "wf tr1" and s: "subtr ns tr tr1"
   5.404 -shows "inj_on root (Inr -` cont tr)"
   5.405 -using s d apply(induct rule: subtr.induct)
   5.406 -apply (metis (lifting) wf_inj_on) by (metis wf_cont)
   5.407 -
   5.408 -lemma wf_subtr_P:
   5.409 -assumes d: "wf tr1" and s: "subtr ns tr tr1"
   5.410 -shows "(root tr, (id \<oplus> root) ` cont tr) \<in> P"
   5.411 -using s d apply(induct rule: subtr.induct)
   5.412 -apply (metis (lifting) wf_P) by (metis wf_cont)
   5.413 -
   5.414 -lemma subtrOf_root[simp]:
   5.415 -assumes tr: "wf tr" and cont: "Inr tr' \<in> cont tr"
   5.416 -shows "subtrOf tr (root tr') = tr'"
   5.417 -proof-
   5.418 -  have 0: "Inr (subtrOf tr (root tr')) \<in> cont tr" using Inr_subtrOf
   5.419 -  by (metis (lifting) cont root_prodOf)
   5.420 -  have "root (subtrOf tr (root tr')) = root tr'"
   5.421 -  using root_subtrOf by (metis (lifting) cont root_prodOf)
   5.422 -  thus ?thesis unfolding wf_inj[OF tr 0 cont] .
   5.423 -qed
   5.424 -
   5.425 -lemma surj_subtrOf:
   5.426 -assumes "wf tr" and 0: "Inr tr' \<in> cont tr"
   5.427 -shows "\<exists> n. Inr n \<in> prodOf tr \<and> subtrOf tr n = tr'"
   5.428 -apply(rule exI[of _ "root tr'"])
   5.429 -using root_prodOf[OF 0] subtrOf_root[OF assms] by simp
   5.430 -
   5.431 -lemma wf_subtr:
   5.432 -assumes "wf tr1" and "subtr ns tr tr1"
   5.433 -shows "wf tr"
   5.434 -proof-
   5.435 -  have "(\<exists> ns tr1. wf tr1 \<and> subtr ns tr tr1) \<Longrightarrow> wf tr"
   5.436 -  proof (induct rule: wf_raw_coind)
   5.437 -    case (Hyp tr)
   5.438 -    then obtain ns tr1 where tr1: "wf tr1" and tr_tr1: "subtr ns tr tr1" by auto
   5.439 -    show ?case proof safe
   5.440 -      show "(root tr, (id \<oplus> root) ` cont tr) \<in> P" using wf_subtr_P[OF tr1 tr_tr1] .
   5.441 -    next
   5.442 -      show "inj_on root (Inr -` cont tr)" using wf_subtr_inj_on[OF tr1 tr_tr1] .
   5.443 -    next
   5.444 -      fix tr' assume tr': "Inr tr' \<in> cont tr"
   5.445 -      have tr_tr1: "subtr (ns \<union> {root tr'}) tr tr1" using subtr_mono[OF tr_tr1] by auto
   5.446 -      have "subtr (ns \<union> {root tr'}) tr' tr1" using subtr_StepL[OF _ tr' tr_tr1] by auto
   5.447 -      thus "\<exists>ns' tr1. wf tr1 \<and> subtr ns' tr' tr1" using tr1 by blast
   5.448 -    qed
   5.449 -  qed
   5.450 -  thus ?thesis using assms by auto
   5.451 -qed
   5.452 -
   5.453 -
   5.454 -subsection{* Default Trees *}
   5.455 -
   5.456 -(* Pick a left-hand side of a production for each nonterminal *)
   5.457 -definition S where "S n \<equiv> SOME tns. (n,tns) \<in> P"
   5.458 -
   5.459 -lemma S_P: "(n, S n) \<in> P"
   5.460 -using used unfolding S_def by(rule someI_ex)
   5.461 -
   5.462 -lemma finite_S: "finite (S n)"
   5.463 -using S_P finite_in_P by auto
   5.464 -
   5.465 -
   5.466 -(* The default tree of a nonterminal *)
   5.467 -definition deftr :: "N \<Rightarrow> dtree" where
   5.468 -"deftr \<equiv> unfold id S"
   5.469 -
   5.470 -lemma deftr_simps[simp]:
   5.471 -"root (deftr n) = n"
   5.472 -"cont (deftr n) = image (id \<oplus> deftr) (S n)"
   5.473 -using unfold(1)[of id S n] unfold(2)[of S n id, OF finite_S]
   5.474 -unfolding deftr_def by simp_all
   5.475 -
   5.476 -lemmas root_deftr = deftr_simps(1)
   5.477 -lemmas cont_deftr = deftr_simps(2)
   5.478 -
   5.479 -lemma root_o_deftr[simp]: "root o deftr = id"
   5.480 -by (rule ext, auto)
   5.481 -
   5.482 -lemma wf_deftr: "wf (deftr n)"
   5.483 -proof-
   5.484 -  {fix tr assume "\<exists> n. tr = deftr n" hence "wf tr"
   5.485 -   apply(induct rule: wf_raw_coind) apply safe
   5.486 -   unfolding deftr_simps image_comp map_sum.comp id_comp
   5.487 -   root_o_deftr map_sum.id image_id id_apply apply(rule S_P)
   5.488 -   unfolding inj_on_def by auto
   5.489 -  }
   5.490 -  thus ?thesis by auto
   5.491 -qed
   5.492 -
   5.493 -
   5.494 -subsection{* Hereditary Substitution *}
   5.495 -
   5.496 -(* Auxiliary concept: The root-ommiting frontier: *)
   5.497 -definition "inFrr ns tr t \<equiv> \<exists> tr'. Inr tr' \<in> cont tr \<and> inFr ns tr' t"
   5.498 -definition "Frr ns tr \<equiv> {t. \<exists> tr'. Inr tr' \<in> cont tr \<and> t \<in> Fr ns tr'}"
   5.499 -
   5.500 -context
   5.501 -fixes tr0 :: dtree
   5.502 -begin
   5.503 -
   5.504 -definition "hsubst_r tr \<equiv> root tr"
   5.505 -definition "hsubst_c tr \<equiv> if root tr = root tr0 then cont tr0 else cont tr"
   5.506 -
   5.507 -(* Hereditary substitution: *)
   5.508 -definition hsubst :: "dtree \<Rightarrow> dtree" where
   5.509 -"hsubst \<equiv> unfold hsubst_r hsubst_c"
   5.510 -
   5.511 -lemma finite_hsubst_c: "finite (hsubst_c n)"
   5.512 -unfolding hsubst_c_def by (metis (full_types) finite_cont)
   5.513 -
   5.514 -lemma root_hsubst[simp]: "root (hsubst tr) = root tr"
   5.515 -using unfold(1)[of hsubst_r hsubst_c tr] unfolding hsubst_def hsubst_r_def by simp
   5.516 -
   5.517 -lemma root_o_subst[simp]: "root o hsubst = root"
   5.518 -unfolding comp_def root_hsubst ..
   5.519 -
   5.520 -lemma cont_hsubst_eq[simp]:
   5.521 -assumes "root tr = root tr0"
   5.522 -shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr0)"
   5.523 -apply(subst id_comp[symmetric, of id]) unfolding id_comp
   5.524 -using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
   5.525 -unfolding hsubst_def hsubst_c_def using assms by simp
   5.526 -
   5.527 -lemma hsubst_eq:
   5.528 -assumes "root tr = root tr0"
   5.529 -shows "hsubst tr = hsubst tr0"
   5.530 -apply(rule dtree_cong) using assms cont_hsubst_eq by auto
   5.531 -
   5.532 -lemma cont_hsubst_neq[simp]:
   5.533 -assumes "root tr \<noteq> root tr0"
   5.534 -shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr)"
   5.535 -apply(subst id_comp[symmetric, of id]) unfolding id_comp
   5.536 -using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
   5.537 -unfolding hsubst_def hsubst_c_def using assms by simp
   5.538 -
   5.539 -lemma Inl_cont_hsubst_eq[simp]:
   5.540 -assumes "root tr = root tr0"
   5.541 -shows "Inl -` cont (hsubst tr) = Inl -` (cont tr0)"
   5.542 -unfolding cont_hsubst_eq[OF assms] by simp
   5.543 -
   5.544 -lemma Inr_cont_hsubst_eq[simp]:
   5.545 -assumes "root tr = root tr0"
   5.546 -shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr0"
   5.547 -unfolding cont_hsubst_eq[OF assms] by simp
   5.548 -
   5.549 -lemma Inl_cont_hsubst_neq[simp]:
   5.550 -assumes "root tr \<noteq> root tr0"
   5.551 -shows "Inl -` cont (hsubst tr) = Inl -` (cont tr)"
   5.552 -unfolding cont_hsubst_neq[OF assms] by simp
   5.553 -
   5.554 -lemma Inr_cont_hsubst_neq[simp]:
   5.555 -assumes "root tr \<noteq> root tr0"
   5.556 -shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr"
   5.557 -unfolding cont_hsubst_neq[OF assms] by simp
   5.558 -
   5.559 -lemma wf_hsubst:
   5.560 -assumes tr0: "wf tr0" and tr: "wf tr"
   5.561 -shows "wf (hsubst tr)"
   5.562 -proof-
   5.563 -  {fix tr1 have "(\<exists> tr. wf tr \<and> tr1 = hsubst tr) \<Longrightarrow> wf tr1"
   5.564 -   proof (induct rule: wf_raw_coind)
   5.565 -     case (Hyp tr1) then obtain tr
   5.566 -     where dtr: "wf tr" and tr1: "tr1 = hsubst tr" by auto
   5.567 -     show ?case unfolding tr1 proof safe
   5.568 -       show "(root (hsubst tr), prodOf (hsubst tr)) \<in> P"
   5.569 -       unfolding tr1 apply(cases "root tr = root tr0")
   5.570 -       using  wf_P[OF dtr] wf_P[OF tr0]
   5.571 -       by (auto simp add: image_comp map_sum.comp)
   5.572 -       show "inj_on root (Inr -` cont (hsubst tr))"
   5.573 -       apply(cases "root tr = root tr0") using wf_inj_on[OF dtr] wf_inj_on[OF tr0]
   5.574 -       unfolding inj_on_def by (auto, blast)
   5.575 -       fix tr' assume "Inr tr' \<in> cont (hsubst tr)"
   5.576 -       thus "\<exists>tra. wf tra \<and> tr' = hsubst tra"
   5.577 -       apply(cases "root tr = root tr0", simp_all)
   5.578 -         apply (metis wf_cont tr0)
   5.579 -         by (metis dtr wf_cont)
   5.580 -     qed
   5.581 -   qed
   5.582 -  }
   5.583 -  thus ?thesis using assms by blast
   5.584 -qed
   5.585 -
   5.586 -lemma Frr: "Frr ns tr = {t. inFrr ns tr t}"
   5.587 -unfolding inFrr_def Frr_def Fr_def by auto
   5.588 -
   5.589 -lemma inFr_hsubst_imp:
   5.590 -assumes "inFr ns (hsubst tr) t"
   5.591 -shows "t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
   5.592 -       inFr (ns - {root tr0}) tr t"
   5.593 -proof-
   5.594 -  {fix tr1
   5.595 -   have "inFr ns tr1 t \<Longrightarrow>
   5.596 -   (\<And> tr. tr1 = hsubst tr \<Longrightarrow> (t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
   5.597 -                              inFr (ns - {root tr0}) tr t))"
   5.598 -   proof(induct rule: inFr.induct)
   5.599 -     case (Base tr1 ns t tr)
   5.600 -     hence rtr: "root tr1 \<in> ns" and t_tr1: "Inl t \<in> cont tr1" and tr1: "tr1 = hsubst tr"
   5.601 -     by auto
   5.602 -     show ?case
   5.603 -     proof(cases "root tr1 = root tr0")
   5.604 -       case True
   5.605 -       hence "t \<in> Inl -` (cont tr0)" using t_tr1 unfolding tr1 by auto
   5.606 -       thus ?thesis by simp
   5.607 -     next
   5.608 -       case False
   5.609 -       hence "inFr (ns - {root tr0}) tr t" using t_tr1 unfolding tr1 apply simp
   5.610 -       by (metis Base.prems Diff_iff root_hsubst inFr.Base rtr singletonE)
   5.611 -       thus ?thesis by simp
   5.612 -     qed
   5.613 -   next
   5.614 -     case (Ind tr1 ns tr1' t) note IH = Ind(4)
   5.615 -     have rtr1: "root tr1 \<in> ns" and tr1'_tr1: "Inr tr1' \<in> cont tr1"
   5.616 -     and t_tr1': "inFr ns tr1' t" and tr1: "tr1 = hsubst tr" using Ind by auto
   5.617 -     have rtr1: "root tr1 = root tr" unfolding tr1 by simp
   5.618 -     show ?case
   5.619 -     proof(cases "root tr1 = root tr0")
   5.620 -       case True
   5.621 -       then obtain tr' where tr'_tr0: "Inr tr' \<in> cont tr0" and tr1': "tr1' = hsubst tr'"
   5.622 -       using tr1'_tr1 unfolding tr1 by auto
   5.623 -       show ?thesis using IH[OF tr1'] proof (elim disjE)
   5.624 -         assume "inFr (ns - {root tr0}) tr' t"
   5.625 -         thus ?thesis using tr'_tr0 unfolding inFrr_def by auto
   5.626 -       qed auto
   5.627 -     next
   5.628 -       case False
   5.629 -       then obtain tr' where tr'_tr: "Inr tr' \<in> cont tr" and tr1': "tr1' = hsubst tr'"
   5.630 -       using tr1'_tr1 unfolding tr1 by auto
   5.631 -       show ?thesis using IH[OF tr1'] proof (elim disjE)
   5.632 -         assume "inFr (ns - {root tr0}) tr' t"
   5.633 -         thus ?thesis using tr'_tr unfolding inFrr_def
   5.634 -         by (metis Diff_iff False Ind(1) empty_iff inFr2_Ind inFr_inFr2 insert_iff rtr1)
   5.635 -       qed auto
   5.636 -     qed
   5.637 -   qed
   5.638 -  }
   5.639 -  thus ?thesis using assms by auto
   5.640 -qed
   5.641 -
   5.642 -lemma inFr_hsubst_notin:
   5.643 -assumes "inFr ns tr t" and "root tr0 \<notin> ns"
   5.644 -shows "inFr ns (hsubst tr) t"
   5.645 -using assms apply(induct rule: inFr.induct)
   5.646 -apply (metis Inl_cont_hsubst_neq inFr2.Base inFr_inFr2 root_hsubst vimageD vimageI2)
   5.647 -by (metis (lifting) Inr_cont_hsubst_neq inFr.Ind rev_image_eqI root_hsubst vimageD vimageI2)
   5.648 -
   5.649 -lemma inFr_hsubst_minus:
   5.650 -assumes "inFr (ns - {root tr0}) tr t"
   5.651 -shows "inFr ns (hsubst tr) t"
   5.652 -proof-
   5.653 -  have 1: "inFr (ns - {root tr0}) (hsubst tr) t"
   5.654 -  using inFr_hsubst_notin[OF assms] by simp
   5.655 -  show ?thesis using inFr_mono[OF 1] by auto
   5.656 -qed
   5.657 -
   5.658 -lemma inFr_self_hsubst:
   5.659 -assumes "root tr0 \<in> ns"
   5.660 -shows
   5.661 -"inFr ns (hsubst tr0) t \<longleftrightarrow>
   5.662 - t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t"
   5.663 -(is "?A \<longleftrightarrow> ?B \<or> ?C")
   5.664 -apply(intro iffI)
   5.665 -apply (metis inFr_hsubst_imp Diff_iff inFr_root_in insertI1) proof(elim disjE)
   5.666 -  assume ?B thus ?A apply(intro inFr.Base) using assms by auto
   5.667 -next
   5.668 -  assume ?C then obtain tr where
   5.669 -  tr_tr0: "Inr tr \<in> cont tr0" and t_tr: "inFr (ns - {root tr0}) tr t"
   5.670 -  unfolding inFrr_def by auto
   5.671 -  def tr1 \<equiv> "hsubst tr"
   5.672 -  have 1: "inFr ns tr1 t" using t_tr unfolding tr1_def using inFr_hsubst_minus by auto
   5.673 -  have "Inr tr1 \<in> cont (hsubst tr0)" unfolding tr1_def using tr_tr0 by auto
   5.674 -  thus ?A using 1 inFr.Ind assms by (metis root_hsubst)
   5.675 -qed
   5.676 -
   5.677 -lemma Fr_self_hsubst:
   5.678 -assumes "root tr0 \<in> ns"
   5.679 -shows "Fr ns (hsubst tr0) = Inl -` (cont tr0) \<union> Frr (ns - {root tr0}) tr0"
   5.680 -using inFr_self_hsubst[OF assms] unfolding Frr Fr_def by auto
   5.681 -
   5.682 -end (* context *)
   5.683 -
   5.684 -
   5.685 -subsection{* Regular Trees *}
   5.686 -
   5.687 -definition "reg f tr \<equiv> \<forall> tr'. subtr UNIV tr' tr \<longrightarrow> tr' = f (root tr')"
   5.688 -definition "regular tr \<equiv> \<exists> f. reg f tr"
   5.689 -
   5.690 -lemma reg_def2: "reg f tr \<longleftrightarrow> (\<forall> ns tr'. subtr ns tr' tr \<longrightarrow> tr' = f (root tr'))"
   5.691 -unfolding reg_def using subtr_mono by (metis subset_UNIV)
   5.692 -
   5.693 -lemma regular_def2: "regular tr \<longleftrightarrow> (\<exists> f. reg f tr \<and> (\<forall> n. root (f n) = n))"
   5.694 -unfolding regular_def proof safe
   5.695 -  fix f assume f: "reg f tr"
   5.696 -  def g \<equiv> "\<lambda> n. if inItr UNIV tr n then f n else deftr n"
   5.697 -  show "\<exists>g. reg g tr \<and> (\<forall>n. root (g n) = n)"
   5.698 -  apply(rule exI[of _ g])
   5.699 -  using f deftr_simps(1) unfolding g_def reg_def apply safe
   5.700 -    apply (metis (lifting) inItr.Base subtr_inItr subtr_rootL_in)
   5.701 -    by (metis (full_types) inItr_subtr)
   5.702 -qed auto
   5.703 -
   5.704 -lemma reg_root:
   5.705 -assumes "reg f tr"
   5.706 -shows "f (root tr) = tr"
   5.707 -using assms unfolding reg_def
   5.708 -by (metis (lifting) iso_tuple_UNIV_I subtr.Refl)
   5.709 -
   5.710 -
   5.711 -lemma reg_Inr_cont:
   5.712 -assumes "reg f tr" and "Inr tr' \<in> cont tr"
   5.713 -shows "reg f tr'"
   5.714 -by (metis (lifting) assms iso_tuple_UNIV_I reg_def subtr.Step)
   5.715 -
   5.716 -lemma reg_subtr:
   5.717 -assumes "reg f tr" and "subtr ns tr' tr"
   5.718 -shows "reg f tr'"
   5.719 -using assms unfolding reg_def using subtr_trans[of UNIV tr] UNIV_I
   5.720 -by (metis UNIV_eq_I UnCI Un_upper1 iso_tuple_UNIV_I subtr_mono subtr_trans)
   5.721 -
   5.722 -lemma regular_subtr:
   5.723 -assumes r: "regular tr" and s: "subtr ns tr' tr"
   5.724 -shows "regular tr'"
   5.725 -using r reg_subtr[OF _ s] unfolding regular_def by auto
   5.726 -
   5.727 -lemma subtr_deftr:
   5.728 -assumes "subtr ns tr' (deftr n)"
   5.729 -shows "tr' = deftr (root tr')"
   5.730 -proof-
   5.731 -  {fix tr have "subtr ns tr' tr \<Longrightarrow> (\<forall> n. tr = deftr n \<longrightarrow> tr' = deftr (root tr'))"
   5.732 -   apply (induct rule: subtr.induct)
   5.733 -   proof(metis (lifting) deftr_simps(1), safe)
   5.734 -     fix tr3 ns tr1 tr2 n
   5.735 -     assume 1: "root (deftr n) \<in> ns" and 2: "subtr ns tr1 tr2"
   5.736 -     and IH: "\<forall>n. tr2 = deftr n \<longrightarrow> tr1 = deftr (root tr1)"
   5.737 -     and 3: "Inr tr2 \<in> cont (deftr n)"
   5.738 -     have "tr2 \<in> deftr ` UNIV"
   5.739 -     using 3 unfolding deftr_simps image_def
   5.740 -     by (metis (lifting, full_types) 3 CollectI Inr_oplus_iff cont_deftr
   5.741 -         iso_tuple_UNIV_I)
   5.742 -     then obtain n where "tr2 = deftr n" by auto
   5.743 -     thus "tr1 = deftr (root tr1)" using IH by auto
   5.744 -   qed
   5.745 -  }
   5.746 -  thus ?thesis using assms by auto
   5.747 -qed
   5.748 -
   5.749 -lemma reg_deftr: "reg deftr (deftr n)"
   5.750 -unfolding reg_def using subtr_deftr by auto
   5.751 -
   5.752 -lemma wf_subtrOf_Union:
   5.753 -assumes "wf tr"
   5.754 -shows "\<Union>{K tr' |tr'. Inr tr' \<in> cont tr} =
   5.755 -       \<Union>{K (subtrOf tr n) |n. Inr n \<in> prodOf tr}"
   5.756 -unfolding Union_eq Bex_def mem_Collect_eq proof safe
   5.757 -  fix x xa tr'
   5.758 -  assume x: "x \<in> K tr'" and tr'_tr: "Inr tr' \<in> cont tr"
   5.759 -  show "\<exists>X. (\<exists>n. X = K (subtrOf tr n) \<and> Inr n \<in> prodOf tr) \<and> x \<in> X"
   5.760 -  apply(rule exI[of _ "K (subtrOf tr (root tr'))"]) apply(intro conjI)
   5.761 -    apply(rule exI[of _ "root tr'"]) apply (metis (lifting) root_prodOf tr'_tr)
   5.762 -    by (metis (lifting) assms subtrOf_root tr'_tr x)
   5.763 -next
   5.764 -  fix x X n ttr
   5.765 -  assume x: "x \<in> K (subtrOf tr n)" and n: "Inr n = (id \<oplus> root) ttr" and ttr: "ttr \<in> cont tr"
   5.766 -  show "\<exists>X. (\<exists>tr'. X = K tr' \<and> Inr tr' \<in> cont tr) \<and> x \<in> X"
   5.767 -  apply(rule exI[of _ "K (subtrOf tr n)"]) apply(intro conjI)
   5.768 -    apply(rule exI[of _ "subtrOf tr n"]) apply (metis imageI n subtrOf ttr)
   5.769 -    using x .
   5.770 -qed
   5.771 -
   5.772 -
   5.773 -
   5.774 -
   5.775 -subsection {* Paths in a Regular Tree *}
   5.776 -
   5.777 -inductive path :: "(N \<Rightarrow> dtree) \<Rightarrow> N list \<Rightarrow> bool" for f where
   5.778 -Base: "path f [n]"
   5.779 -|
   5.780 -Ind: "\<lbrakk>path f (n1 # nl); Inr (f n1) \<in> cont (f n)\<rbrakk>
   5.781 -      \<Longrightarrow> path f (n # n1 # nl)"
   5.782 -
   5.783 -lemma path_NE:
   5.784 -assumes "path f nl"
   5.785 -shows "nl \<noteq> Nil"
   5.786 -using assms apply(induct rule: path.induct) by auto
   5.787 -
   5.788 -lemma path_post:
   5.789 -assumes f: "path f (n # nl)" and nl: "nl \<noteq> []"
   5.790 -shows "path f nl"
   5.791 -proof-
   5.792 -  obtain n1 nl1 where nl: "nl = n1 # nl1" using nl by (cases nl, auto)
   5.793 -  show ?thesis using assms unfolding nl using path.simps by (metis (lifting) list.inject)
   5.794 -qed
   5.795 -
   5.796 -lemma path_post_concat:
   5.797 -assumes "path f (nl1 @ nl2)" and "nl2 \<noteq> Nil"
   5.798 -shows "path f nl2"
   5.799 -using assms apply (induct nl1)
   5.800 -apply (metis append_Nil) by (metis Nil_is_append_conv append_Cons path_post)
   5.801 -
   5.802 -lemma path_concat:
   5.803 -assumes "path f nl1" and "path f ((last nl1) # nl2)"
   5.804 -shows "path f (nl1 @ nl2)"
   5.805 -using assms apply(induct rule: path.induct) apply simp
   5.806 -by (metis append_Cons last.simps list.simps(3) path.Ind)
   5.807 -
   5.808 -lemma path_distinct:
   5.809 -assumes "path f nl"
   5.810 -shows "\<exists> nl'. path f nl' \<and> hd nl' = hd nl \<and> last nl' = last nl \<and>
   5.811 -              set nl' \<subseteq> set nl \<and> distinct nl'"
   5.812 -using assms proof(induct rule: length_induct)
   5.813 -  case (1 nl)  hence p_nl: "path f nl" by simp
   5.814 -  then obtain n nl1 where nl: "nl = n # nl1" by (metis list.exhaust path_NE)
   5.815 -  show ?case
   5.816 -  proof(cases nl1)
   5.817 -    case Nil
   5.818 -    show ?thesis apply(rule exI[of _ nl]) using path.Base unfolding nl Nil by simp
   5.819 -  next
   5.820 -    case (Cons n1 nl2)
   5.821 -    hence p1: "path f nl1" by (metis list.simps(3) nl p_nl path_post)
   5.822 -    show ?thesis
   5.823 -    proof(cases "n \<in> set nl1")
   5.824 -      case False
   5.825 -      obtain nl1' where p1': "path f nl1'" and hd_nl1': "hd nl1' = hd nl1" and
   5.826 -      l_nl1': "last nl1' = last nl1" and d_nl1': "distinct nl1'"
   5.827 -      and s_nl1': "set nl1' \<subseteq> set nl1"
   5.828 -      using 1(1)[THEN allE[of _ nl1]] p1 unfolding nl by auto
   5.829 -      obtain nl2' where nl1': "nl1' = n1 # nl2'" using path_NE[OF p1'] hd_nl1'
   5.830 -      unfolding Cons by(cases nl1', auto)
   5.831 -      show ?thesis apply(intro exI[of _ "n # nl1'"]) unfolding nl proof safe
   5.832 -        show "path f (n # nl1')" unfolding nl1'
   5.833 -        apply(rule path.Ind, metis nl1' p1')
   5.834 -        by (metis (lifting) Cons list.inject nl p1 p_nl path.simps path_NE)
   5.835 -      qed(insert l_nl1' Cons nl1' s_nl1' d_nl1' False, auto)
   5.836 -    next
   5.837 -      case True
   5.838 -      then obtain nl11 nl12 where nl1: "nl1 = nl11 @ n # nl12"
   5.839 -      by (metis split_list)
   5.840 -      have p12: "path f (n # nl12)"
   5.841 -      apply(rule path_post_concat[of _ "n # nl11"]) using p_nl[unfolded nl nl1] by auto
   5.842 -      obtain nl12' where p1': "path f nl12'" and hd_nl12': "hd nl12' = n" and
   5.843 -      l_nl12': "last nl12' = last (n # nl12)" and d_nl12': "distinct nl12'"
   5.844 -      and s_nl12': "set nl12' \<subseteq> {n} \<union> set nl12"
   5.845 -      using 1(1)[THEN allE[of _ "n # nl12"]] p12 unfolding nl nl1 by auto
   5.846 -      thus ?thesis apply(intro exI[of _ nl12']) unfolding nl nl1 by auto
   5.847 -    qed
   5.848 -  qed
   5.849 -qed
   5.850 -
   5.851 -lemma path_subtr:
   5.852 -assumes f: "\<And> n. root (f n) = n"
   5.853 -and p: "path f nl"
   5.854 -shows "subtr (set nl) (f (last nl)) (f (hd nl))"
   5.855 -using p proof (induct rule: path.induct)
   5.856 -  case (Ind n1 nl n)  let ?ns1 = "insert n1 (set nl)"
   5.857 -  have "path f (n1 # nl)"
   5.858 -  and "subtr ?ns1 (f (last (n1 # nl))) (f n1)"
   5.859 -  and fn1: "Inr (f n1) \<in> cont (f n)" using Ind by simp_all
   5.860 -  hence fn1_flast:  "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n1)"
   5.861 -  by (metis subset_insertI subtr_mono)
   5.862 -  have 1: "last (n # n1 # nl) = last (n1 # nl)" by auto
   5.863 -  have "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n)"
   5.864 -  using f subtr.Step[OF _ fn1_flast fn1] by auto
   5.865 -  thus ?case unfolding 1 by simp
   5.866 -qed (metis f list.sel(1) last_ConsL last_in_set not_Cons_self2 subtr.Refl)
   5.867 -
   5.868 -lemma reg_subtr_path_aux:
   5.869 -assumes f: "reg f tr" and n: "subtr ns tr1 tr"
   5.870 -shows "\<exists> nl. path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
   5.871 -using n f proof(induct rule: subtr.induct)
   5.872 -  case (Refl tr ns)
   5.873 -  thus ?case
   5.874 -  apply(intro exI[of _ "[root tr]"]) apply simp by (metis (lifting) path.Base reg_root)
   5.875 -next
   5.876 -  case (Step tr ns tr2 tr1)
   5.877 -  hence rtr: "root tr \<in> ns" and tr1_tr: "Inr tr1 \<in> cont tr"
   5.878 -  and tr2_tr1: "subtr ns tr2 tr1" and tr: "reg f tr" by auto
   5.879 -  have tr1: "reg f tr1" using reg_subtr[OF tr] rtr tr1_tr
   5.880 -  by (metis (lifting) Step.prems iso_tuple_UNIV_I reg_def subtr.Step)
   5.881 -  obtain nl where nl: "path f nl" and f_nl: "f (hd nl) = tr1"
   5.882 -  and last_nl: "f (last nl) = tr2" and set: "set nl \<subseteq> ns" using Step(3)[OF tr1] by auto
   5.883 -  have 0: "path f (root tr # nl)" apply (subst path.simps)
   5.884 -  using f_nl nl reg_root tr tr1_tr by (metis list.sel(1) neq_Nil_conv)
   5.885 -  show ?case apply(rule exI[of _ "(root tr) # nl"])
   5.886 -  using 0 reg_root tr last_nl nl path_NE rtr set by auto
   5.887 -qed
   5.888 -
   5.889 -lemma reg_subtr_path:
   5.890 -assumes f: "reg f tr" and n: "subtr ns tr1 tr"
   5.891 -shows "\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
   5.892 -using reg_subtr_path_aux[OF assms] path_distinct[of f]
   5.893 -by (metis (lifting) order_trans)
   5.894 -
   5.895 -lemma subtr_iff_path:
   5.896 -assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
   5.897 -shows "subtr ns tr1 tr \<longleftrightarrow>
   5.898 -       (\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns)"
   5.899 -proof safe
   5.900 -  fix nl assume p: "path f nl" and nl: "set nl \<subseteq> ns"
   5.901 -  have "subtr (set nl) (f (last nl)) (f (hd nl))"
   5.902 -  apply(rule path_subtr) using p f by simp_all
   5.903 -  thus "subtr ns (f (last nl)) (f (hd nl))"
   5.904 -  using subtr_mono nl by auto
   5.905 -qed(insert reg_subtr_path[OF r], auto)
   5.906 -
   5.907 -lemma inFr_iff_path:
   5.908 -assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
   5.909 -shows
   5.910 -"inFr ns tr t \<longleftrightarrow>
   5.911 - (\<exists> nl tr1. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and>
   5.912 -            set nl \<subseteq> ns \<and> Inl t \<in> cont tr1)"
   5.913 -apply safe
   5.914 -apply (metis (no_types) inFr_subtr r reg_subtr_path)
   5.915 -by (metis f inFr.Base path_subtr subtr_inFr subtr_mono subtr_rootL_in)
   5.916 -
   5.917 -
   5.918 -
   5.919 -subsection{* The Regular Cut of a Tree *}
   5.920 -
   5.921 -context fixes tr0 :: dtree
   5.922 -begin
   5.923 -
   5.924 -(* Picking a subtree of a certain root: *)
   5.925 -definition "pick n \<equiv> SOME tr. subtr UNIV tr tr0 \<and> root tr = n"
   5.926 -
   5.927 -lemma pick:
   5.928 -assumes "inItr UNIV tr0 n"
   5.929 -shows "subtr UNIV (pick n) tr0 \<and> root (pick n) = n"
   5.930 -proof-
   5.931 -  have "\<exists> tr. subtr UNIV tr tr0 \<and> root tr = n"
   5.932 -  using assms by (metis (lifting) inItr_subtr)
   5.933 -  thus ?thesis unfolding pick_def by(rule someI_ex)
   5.934 -qed
   5.935 -
   5.936 -lemmas subtr_pick = pick[THEN conjunct1]
   5.937 -lemmas root_pick = pick[THEN conjunct2]
   5.938 -
   5.939 -lemma wf_pick:
   5.940 -assumes tr0: "wf tr0" and n: "inItr UNIV tr0 n"
   5.941 -shows "wf (pick n)"
   5.942 -using wf_subtr[OF tr0 subtr_pick[OF n]] .
   5.943 -
   5.944 -definition "H_r n \<equiv> root (pick n)"
   5.945 -definition "H_c n \<equiv> (id \<oplus> root) ` cont (pick n)"
   5.946 -
   5.947 -(* The regular tree of a function: *)
   5.948 -definition H :: "N \<Rightarrow> dtree" where
   5.949 -"H \<equiv> unfold H_r H_c"
   5.950 -
   5.951 -lemma finite_H_c: "finite (H_c n)"
   5.952 -unfolding H_c_def by (metis finite_cont finite_imageI)
   5.953 -
   5.954 -lemma root_H_pick: "root (H n) = root (pick n)"
   5.955 -using unfold(1)[of H_r H_c n] unfolding H_def H_r_def by simp
   5.956 -
   5.957 -lemma root_H[simp]:
   5.958 -assumes "inItr UNIV tr0 n"
   5.959 -shows "root (H n) = n"
   5.960 -unfolding root_H_pick root_pick[OF assms] ..
   5.961 -
   5.962 -lemma cont_H[simp]:
   5.963 -"cont (H n) = (id \<oplus> (H o root)) ` cont (pick n)"
   5.964 -apply(subst id_comp[symmetric, of id]) unfolding map_sum.comp[symmetric]
   5.965 -unfolding image_comp [symmetric] H_c_def [symmetric]
   5.966 -using unfold(2) [of H_c n H_r, OF finite_H_c]
   5.967 -unfolding H_def ..
   5.968 -
   5.969 -lemma Inl_cont_H[simp]:
   5.970 -"Inl -` (cont (H n)) = Inl -` (cont (pick n))"
   5.971 -unfolding cont_H by simp
   5.972 -
   5.973 -lemma Inr_cont_H:
   5.974 -"Inr -` (cont (H n)) = (H \<circ> root) ` (Inr -` cont (pick n))"
   5.975 -unfolding cont_H by simp
   5.976 -
   5.977 -lemma subtr_H:
   5.978 -assumes n: "inItr UNIV tr0 n" and "subtr UNIV tr1 (H n)"
   5.979 -shows "\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = H n1"
   5.980 -proof-
   5.981 -  {fix tr ns assume "subtr UNIV tr1 tr"
   5.982 -   hence "tr = H n \<longrightarrow> (\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = H n1)"
   5.983 -   proof (induct rule: subtr_UNIV_inductL)
   5.984 -     case (Step tr2 tr1 tr)
   5.985 -     show ?case proof
   5.986 -       assume "tr = H n"
   5.987 -       then obtain n1 where tr2: "Inr tr2 \<in> cont tr1"
   5.988 -       and tr1_tr: "subtr UNIV tr1 tr" and n1: "inItr UNIV tr0 n1" and tr1: "tr1 = H n1"
   5.989 -       using Step by auto
   5.990 -       obtain tr2' where tr2: "tr2 = H (root tr2')"
   5.991 -       and tr2': "Inr tr2' \<in> cont (pick n1)"
   5.992 -       using tr2 Inr_cont_H[of n1]
   5.993 -       unfolding tr1 image_def comp_def using vimage_eq by auto
   5.994 -       have "inItr UNIV tr0 (root tr2')"
   5.995 -       using inItr.Base inItr.Ind n1 pick subtr_inItr tr2' by (metis iso_tuple_UNIV_I)
   5.996 -       thus "\<exists>n2. inItr UNIV tr0 n2 \<and> tr2 = H n2" using tr2 by blast
   5.997 -     qed
   5.998 -   qed(insert n, auto)
   5.999 -  }
  5.1000 -  thus ?thesis using assms by auto
  5.1001 -qed
  5.1002 -
  5.1003 -lemma root_H_root:
  5.1004 -assumes n: "inItr UNIV tr0 n" and t_tr: "t_tr \<in> cont (pick n)"
  5.1005 -shows "(id \<oplus> (root \<circ> H \<circ> root)) t_tr = (id \<oplus> root) t_tr"
  5.1006 -using assms apply(cases t_tr)
  5.1007 -  apply (metis (lifting) map_sum.simps(1))
  5.1008 -  using pick H_def H_r_def unfold(1)
  5.1009 -      inItr.Base comp_apply subtr_StepL subtr_inItr map_sum.simps(2)
  5.1010 -  by (metis UNIV_I)
  5.1011 -
  5.1012 -lemma H_P:
  5.1013 -assumes tr0: "wf tr0" and n: "inItr UNIV tr0 n"
  5.1014 -shows "(n, (id \<oplus> root) ` cont (H n)) \<in> P" (is "?L \<in> P")
  5.1015 -proof-
  5.1016 -  have "?L = (n, (id \<oplus> root) ` cont (pick n))"
  5.1017 -  unfolding cont_H image_comp map_sum.comp id_comp comp_assoc[symmetric]
  5.1018 -  unfolding Pair_eq apply(rule conjI[OF refl]) apply(rule image_cong[OF refl])
  5.1019 -  by (rule root_H_root[OF n])
  5.1020 -  moreover have "... \<in> P" by (metis (lifting) wf_pick root_pick wf_P n tr0)
  5.1021 -  ultimately show ?thesis by simp
  5.1022 -qed
  5.1023 -
  5.1024 -lemma wf_H:
  5.1025 -assumes tr0: "wf tr0" and "inItr UNIV tr0 n"
  5.1026 -shows "wf (H n)"
  5.1027 -proof-
  5.1028 -  {fix tr have "\<exists> n. inItr UNIV tr0 n \<and> tr = H n \<Longrightarrow> wf tr"
  5.1029 -   proof (induct rule: wf_raw_coind)
  5.1030 -     case (Hyp tr)
  5.1031 -     then obtain n where n: "inItr UNIV tr0 n" and tr: "tr = H n" by auto
  5.1032 -     show ?case apply safe
  5.1033 -     apply (metis (lifting) H_P root_H n tr tr0)
  5.1034 -     unfolding tr Inr_cont_H unfolding inj_on_def apply clarsimp using root_H
  5.1035 -     apply (metis UNIV_I inItr.Base n pick subtr2.simps subtr_inItr subtr_subtr2)
  5.1036 -     by (metis n subtr.Refl subtr_StepL subtr_H tr UNIV_I)
  5.1037 -   qed
  5.1038 -  }
  5.1039 -  thus ?thesis using assms by blast
  5.1040 -qed
  5.1041 -
  5.1042 -(* The regular cut of a tree: *)
  5.1043 -definition "rcut \<equiv> H (root tr0)"
  5.1044 -
  5.1045 -lemma reg_rcut: "reg H rcut"
  5.1046 -unfolding reg_def rcut_def
  5.1047 -by (metis inItr.Base root_H subtr_H UNIV_I)
  5.1048 -
  5.1049 -lemma rcut_reg:
  5.1050 -assumes "reg H tr0"
  5.1051 -shows "rcut = tr0"
  5.1052 -using assms unfolding rcut_def reg_def by (metis subtr.Refl UNIV_I)
  5.1053 -
  5.1054 -lemma rcut_eq: "rcut = tr0 \<longleftrightarrow> reg H tr0"
  5.1055 -using reg_rcut rcut_reg by metis
  5.1056 -
  5.1057 -lemma regular_rcut: "regular rcut"
  5.1058 -using reg_rcut unfolding regular_def by blast
  5.1059 -
  5.1060 -lemma Fr_rcut: "Fr UNIV rcut \<subseteq> Fr UNIV tr0"
  5.1061 -proof safe
  5.1062 -  fix t assume "t \<in> Fr UNIV rcut"
  5.1063 -  then obtain tr where t: "Inl t \<in> cont tr" and tr: "subtr UNIV tr (H (root tr0))"
  5.1064 -  using Fr_subtr[of UNIV "H (root tr0)"] unfolding rcut_def
  5.1065 -  by (metis (full_types) Fr_def inFr_subtr mem_Collect_eq)
  5.1066 -  obtain n where n: "inItr UNIV tr0 n" and tr: "tr = H n" using tr
  5.1067 -  by (metis (lifting) inItr.Base subtr_H UNIV_I)
  5.1068 -  have "Inl t \<in> cont (pick n)" using t using Inl_cont_H[of n] unfolding tr
  5.1069 -  by (metis (lifting) vimageD vimageI2)
  5.1070 -  moreover have "subtr UNIV (pick n) tr0" using subtr_pick[OF n] ..
  5.1071 -  ultimately show "t \<in> Fr UNIV tr0" unfolding Fr_subtr_cont by auto
  5.1072 -qed
  5.1073 -
  5.1074 -lemma wf_rcut:
  5.1075 -assumes "wf tr0"
  5.1076 -shows "wf rcut"
  5.1077 -unfolding rcut_def using wf_H[OF assms inItr.Base] by simp
  5.1078 -
  5.1079 -lemma root_rcut[simp]: "root rcut = root tr0"
  5.1080 -unfolding rcut_def
  5.1081 -by (metis (lifting) root_H inItr.Base reg_def reg_root subtr_rootR_in)
  5.1082 -
  5.1083 -end (* context *)
  5.1084 -
  5.1085 -
  5.1086 -subsection{* Recursive Description of the Regular Tree Frontiers *}
  5.1087 -
  5.1088 -lemma regular_inFr:
  5.1089 -assumes r: "regular tr" and In: "root tr \<in> ns"
  5.1090 -and t: "inFr ns tr t"
  5.1091 -shows "t \<in> Inl -` (cont tr) \<or>
  5.1092 -       (\<exists> tr'. Inr tr' \<in> cont tr \<and> inFr (ns - {root tr}) tr' t)"
  5.1093 -(is "?L \<or> ?R")
  5.1094 -proof-
  5.1095 -  obtain f where r: "reg f tr" and f: "\<And>n. root (f n) = n"
  5.1096 -  using r unfolding regular_def2 by auto
  5.1097 -  obtain nl tr1 where d_nl: "distinct nl" and p: "path f nl" and hd_nl: "f (hd nl) = tr"
  5.1098 -  and l_nl: "f (last nl) = tr1" and s_nl: "set nl \<subseteq> ns" and t_tr1: "Inl t \<in> cont tr1"
  5.1099 -  using t unfolding inFr_iff_path[OF r f] by auto
  5.1100 -  obtain n nl1 where nl: "nl = n # nl1" by (metis (lifting) p path.simps)
  5.1101 -  hence f_n: "f n = tr" using hd_nl by simp
  5.1102 -  have n_nl1: "n \<notin> set nl1" using d_nl unfolding nl by auto
  5.1103 -  show ?thesis
  5.1104 -  proof(cases nl1)
  5.1105 -    case Nil hence "tr = tr1" using f_n l_nl unfolding nl by simp
  5.1106 -    hence ?L using t_tr1 by simp thus ?thesis by simp
  5.1107 -  next
  5.1108 -    case (Cons n1 nl2) note nl1 = Cons
  5.1109 -    have 1: "last nl1 = last nl" "hd nl1 = n1" unfolding nl nl1 by simp_all
  5.1110 -    have p1: "path f nl1" and n1_tr: "Inr (f n1) \<in> cont tr"
  5.1111 -    using path.simps[of f nl] p f_n unfolding nl nl1 by auto
  5.1112 -    have r1: "reg f (f n1)" using reg_Inr_cont[OF r n1_tr] .
  5.1113 -    have 0: "inFr (set nl1) (f n1) t" unfolding inFr_iff_path[OF r1 f]
  5.1114 -    apply(intro exI[of _ nl1], intro exI[of _ tr1])
  5.1115 -    using d_nl unfolding 1 l_nl unfolding nl using p1 t_tr1 by auto
  5.1116 -    have root_tr: "root tr = n" by (metis f f_n)
  5.1117 -    have "inFr (ns - {root tr}) (f n1) t" apply(rule inFr_mono[OF 0])
  5.1118 -    using s_nl unfolding root_tr unfolding nl using n_nl1 by auto
  5.1119 -    thus ?thesis using n1_tr by auto
  5.1120 -  qed
  5.1121 -qed
  5.1122 -
  5.1123 -lemma regular_Fr:
  5.1124 -assumes r: "regular tr" and In: "root tr \<in> ns"
  5.1125 -shows "Fr ns tr =
  5.1126 -       Inl -` (cont tr) \<union>
  5.1127 -       \<Union> {Fr (ns - {root tr}) tr' | tr'. Inr tr' \<in> cont tr}"
  5.1128 -unfolding Fr_def
  5.1129 -using In inFr.Base regular_inFr[OF assms] apply safe
  5.1130 -apply (simp, metis (full_types) mem_Collect_eq)
  5.1131 -apply simp
  5.1132 -by (simp, metis (lifting) inFr_Ind_minus insert_Diff)
  5.1133 -
  5.1134 -
  5.1135 -subsection{* The Generated Languages *}
  5.1136 -
  5.1137 -(* The (possibly inifinite tree) generated language *)
  5.1138 -definition "L ns n \<equiv> {Fr ns tr | tr. wf tr \<and> root tr = n}"
  5.1139 -
  5.1140 -(* The regular-tree generated language *)
  5.1141 -definition "Lr ns n \<equiv> {Fr ns tr | tr. wf tr \<and> root tr = n \<and> regular tr}"
  5.1142 -
  5.1143 -lemma L_rec_notin:
  5.1144 -assumes "n \<notin> ns"
  5.1145 -shows "L ns n = {{}}"
  5.1146 -using assms unfolding L_def apply safe
  5.1147 -  using not_root_Fr apply force
  5.1148 -  apply(rule exI[of _ "deftr n"])
  5.1149 -  by (metis (no_types) wf_deftr not_root_Fr root_deftr)
  5.1150 -
  5.1151 -lemma Lr_rec_notin:
  5.1152 -assumes "n \<notin> ns"
  5.1153 -shows "Lr ns n = {{}}"
  5.1154 -using assms unfolding Lr_def apply safe
  5.1155 -  using not_root_Fr apply force
  5.1156 -  apply(rule exI[of _ "deftr n"])
  5.1157 -  by (metis (no_types) regular_def wf_deftr not_root_Fr reg_deftr root_deftr)
  5.1158 -
  5.1159 -lemma wf_subtrOf:
  5.1160 -assumes "wf tr" and "Inr n \<in> prodOf tr"
  5.1161 -shows "wf (subtrOf tr n)"
  5.1162 -by (metis assms wf_cont subtrOf)
  5.1163 -
  5.1164 -lemma Lr_rec_in:
  5.1165 -assumes n: "n \<in> ns"
  5.1166 -shows "Lr ns n \<subseteq>
  5.1167 -{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
  5.1168 -    (n,tns) \<in> P \<and>
  5.1169 -    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n')}"
  5.1170 -(is "Lr ns n \<subseteq> {?F tns K | tns K. (n,tns) \<in> P \<and> ?\<phi> tns K}")
  5.1171 -proof safe
  5.1172 -  fix ts assume "ts \<in> Lr ns n"
  5.1173 -  then obtain tr where dtr: "wf tr" and r: "root tr = n" and tr: "regular tr"
  5.1174 -  and ts: "ts = Fr ns tr" unfolding Lr_def by auto
  5.1175 -  def tns \<equiv> "(id \<oplus> root) ` (cont tr)"
  5.1176 -  def K \<equiv> "\<lambda> n'. Fr (ns - {n}) (subtrOf tr n')"
  5.1177 -  show "\<exists>tns K. ts = ?F tns K \<and> (n, tns) \<in> P \<and> ?\<phi> tns K"
  5.1178 -  apply(rule exI[of _ tns], rule exI[of _ K]) proof(intro conjI allI impI)
  5.1179 -    show "ts = Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns}"
  5.1180 -    unfolding ts regular_Fr[OF tr n[unfolded r[symmetric]]]
  5.1181 -    unfolding tns_def K_def r[symmetric]
  5.1182 -    unfolding Inl_prodOf wf_subtrOf_Union[OF dtr] ..
  5.1183 -    show "(n, tns) \<in> P" unfolding tns_def r[symmetric] using wf_P[OF dtr] .
  5.1184 -    fix n' assume "Inr n' \<in> tns" thus "K n' \<in> Lr (ns - {n}) n'"
  5.1185 -    unfolding K_def Lr_def mem_Collect_eq apply(intro exI[of _ "subtrOf tr n'"])
  5.1186 -    using dtr tr apply(intro conjI refl)  unfolding tns_def
  5.1187 -      apply(erule wf_subtrOf[OF dtr])
  5.1188 -      apply (metis subtrOf)
  5.1189 -      by (metis Inr_subtrOf UNIV_I regular_subtr subtr.simps)
  5.1190 -  qed
  5.1191 -qed
  5.1192 -
  5.1193 -lemma hsubst_aux:
  5.1194 -fixes n ftr tns
  5.1195 -assumes n: "n \<in> ns" and tns: "finite tns" and
  5.1196 -1: "\<And> n'. Inr n' \<in> tns \<Longrightarrow> wf (ftr n')"
  5.1197 -defines "tr \<equiv> Node n ((id \<oplus> ftr) ` tns)"  defines "tr' \<equiv> hsubst tr tr"
  5.1198 -shows "Fr ns tr' = Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
  5.1199 -(is "_ = ?B") proof-
  5.1200 -  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
  5.1201 -  unfolding tr_def using tns by auto
  5.1202 -  have Frr: "Frr (ns - {n}) tr = \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
  5.1203 -  unfolding Frr_def ctr by auto
  5.1204 -  have "Fr ns tr' = Inl -` (cont tr) \<union> Frr (ns - {n}) tr"
  5.1205 -  using Fr_self_hsubst[OF n[unfolded rtr[symmetric]]] unfolding tr'_def rtr ..
  5.1206 -  also have "... = ?B" unfolding ctr Frr by simp
  5.1207 -  finally show ?thesis .
  5.1208 -qed
  5.1209 -
  5.1210 -lemma L_rec_in:
  5.1211 -assumes n: "n \<in> ns"
  5.1212 -shows "
  5.1213 -{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
  5.1214 -    (n,tns) \<in> P \<and>
  5.1215 -    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n')}
  5.1216 - \<subseteq> L ns n"
  5.1217 -proof safe
  5.1218 -  fix tns K
  5.1219 -  assume P: "(n, tns) \<in> P" and 0: "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n'"
  5.1220 -  {fix n' assume "Inr n' \<in> tns"
  5.1221 -   hence "K n' \<in> L (ns - {n}) n'" using 0 by auto
  5.1222 -   hence "\<exists> tr'. K n' = Fr (ns - {n}) tr' \<and> wf tr' \<and> root tr' = n'"
  5.1223 -   unfolding L_def mem_Collect_eq by auto
  5.1224 -  }
  5.1225 -  then obtain ftr where 0: "\<And> n'. Inr n' \<in> tns \<Longrightarrow>
  5.1226 -  K n' = Fr (ns - {n}) (ftr n') \<and> wf (ftr n') \<and> root (ftr n') = n'"
  5.1227 -  by metis
  5.1228 -  def tr \<equiv> "Node n ((id \<oplus> ftr) ` tns)"  def tr' \<equiv> "hsubst tr tr"
  5.1229 -  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
  5.1230 -  unfolding tr_def by (simp, metis P cont_Node finite_imageI finite_in_P)
  5.1231 -  have prtr: "prodOf tr = tns" apply(rule Inl_Inr_image_cong)
  5.1232 -  unfolding ctr apply simp apply simp apply safe
  5.1233 -  using 0 unfolding image_def apply force apply simp by (metis 0 vimageI2)
  5.1234 -  have 1: "{K n' |n'. Inr n' \<in> tns} = {Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
  5.1235 -  using 0 by auto
  5.1236 -  have dtr: "wf tr" apply(rule wf.dtree)
  5.1237 -    apply (metis (lifting) P prtr rtr)
  5.1238 -    unfolding inj_on_def ctr using 0 by auto
  5.1239 -  hence dtr': "wf tr'" unfolding tr'_def by (metis wf_hsubst)
  5.1240 -  have tns: "finite tns" using finite_in_P P by simp
  5.1241 -  have "Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns} \<in> L ns n"
  5.1242 -  unfolding L_def mem_Collect_eq apply(intro exI[of _ tr'] conjI)
  5.1243 -  using dtr' 0 hsubst_aux[OF assms tns, of ftr] unfolding tr_def tr'_def by auto
  5.1244 -  thus "Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} \<in> L ns n" unfolding 1 .
  5.1245 -qed
  5.1246 -
  5.1247 -lemma card_N: "(n::N) \<in> ns \<Longrightarrow> card (ns - {n}) < card ns"
  5.1248 -by (metis finite_N Diff_UNIV Diff_infinite_finite card_Diff1_less finite.emptyI)
  5.1249 -
  5.1250 -function LL where
  5.1251 -"LL ns n =
  5.1252 - (if n \<notin> ns then {{}} else
  5.1253 - {Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
  5.1254 -    (n,tns) \<in> P \<and>
  5.1255 -    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n')})"
  5.1256 -by(pat_completeness, auto)
  5.1257 -termination apply(relation "inv_image (measure card) fst")
  5.1258 -using card_N by auto
  5.1259 -
  5.1260 -declare LL.simps[code]
  5.1261 -declare LL.simps[simp del]
  5.1262 -
  5.1263 -lemma Lr_LL: "Lr ns n \<subseteq> LL ns n"
  5.1264 -proof (induct ns arbitrary: n rule: measure_induct[of card])
  5.1265 -  case (1 ns n) show ?case proof(cases "n \<in> ns")
  5.1266 -    case False thus ?thesis unfolding Lr_rec_notin[OF False] by (simp add: LL.simps)
  5.1267 -  next
  5.1268 -    case True show ?thesis apply(rule subset_trans)
  5.1269 -    using Lr_rec_in[OF True] apply assumption
  5.1270 -    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
  5.1271 -      fix tns K
  5.1272 -      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
  5.1273 -      assume "(n, tns) \<in> P"
  5.1274 -      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n'"
  5.1275 -      thus "\<exists>tnsa Ka.
  5.1276 -             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
  5.1277 -             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
  5.1278 -             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> LL (ns - {n}) n')"
  5.1279 -      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
  5.1280 -    qed
  5.1281 -  qed
  5.1282 -qed
  5.1283 -
  5.1284 -lemma LL_L: "LL ns n \<subseteq> L ns n"
  5.1285 -proof (induct ns arbitrary: n rule: measure_induct[of card])
  5.1286 -  case (1 ns n) show ?case proof(cases "n \<in> ns")
  5.1287 -    case False thus ?thesis unfolding L_rec_notin[OF False] by (simp add: LL.simps)
  5.1288 -  next
  5.1289 -    case True show ?thesis apply(rule subset_trans)
  5.1290 -    prefer 2 using L_rec_in[OF True] apply assumption
  5.1291 -    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
  5.1292 -      fix tns K
  5.1293 -      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
  5.1294 -      assume "(n, tns) \<in> P"
  5.1295 -      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n'"
  5.1296 -      thus "\<exists>tnsa Ka.
  5.1297 -             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
  5.1298 -             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
  5.1299 -             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> L (ns - {n}) n')"
  5.1300 -      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
  5.1301 -    qed
  5.1302 -  qed
  5.1303 -qed
  5.1304 -
  5.1305 -(* The subsumpsion relation between languages *)
  5.1306 -definition "subs L1 L2 \<equiv> \<forall> ts2 \<in> L2. \<exists> ts1 \<in> L1. ts1 \<subseteq> ts2"
  5.1307 -
  5.1308 -lemma incl_subs[simp]: "L2 \<subseteq> L1 \<Longrightarrow> subs L1 L2"
  5.1309 -unfolding subs_def by auto
  5.1310 -
  5.1311 -lemma subs_refl[simp]: "subs L1 L1" unfolding subs_def by auto
  5.1312 -
  5.1313 -lemma subs_trans: "\<lbrakk>subs L1 L2; subs L2 L3\<rbrakk> \<Longrightarrow> subs L1 L3"
  5.1314 -unfolding subs_def by (metis subset_trans)
  5.1315 -
  5.1316 -(* Language equivalence *)
  5.1317 -definition "leqv L1 L2 \<equiv> subs L1 L2 \<and> subs L2 L1"
  5.1318 -
  5.1319 -lemma subs_leqv[simp]: "leqv L1 L2 \<Longrightarrow> subs L1 L2"
  5.1320 -unfolding leqv_def by auto
  5.1321 -
  5.1322 -lemma subs_leqv_sym[simp]: "leqv L1 L2 \<Longrightarrow> subs L2 L1"
  5.1323 -unfolding leqv_def by auto
  5.1324 -
  5.1325 -lemma leqv_refl[simp]: "leqv L1 L1" unfolding leqv_def by auto
  5.1326 -
  5.1327 -lemma leqv_trans:
  5.1328 -assumes 12: "leqv L1 L2" and 23: "leqv L2 L3"
  5.1329 -shows "leqv L1 L3"
  5.1330 -using assms unfolding leqv_def by (metis (lifting) subs_trans)
  5.1331 -
  5.1332 -lemma leqv_sym: "leqv L1 L2 \<Longrightarrow> leqv L2 L1"
  5.1333 -unfolding leqv_def by auto
  5.1334 -
  5.1335 -lemma leqv_Sym: "leqv L1 L2 \<longleftrightarrow> leqv L2 L1"
  5.1336 -unfolding leqv_def by auto
  5.1337 -
  5.1338 -lemma Lr_incl_L: "Lr ns ts \<subseteq> L ns ts"
  5.1339 -unfolding Lr_def L_def by auto
  5.1340 -
  5.1341 -lemma Lr_subs_L: "subs (Lr UNIV ts) (L UNIV ts)"
  5.1342 -unfolding subs_def proof safe
  5.1343 -  fix ts2 assume "ts2 \<in> L UNIV ts"
  5.1344 -  then obtain tr where ts2: "ts2 = Fr UNIV tr" and dtr: "wf tr" and rtr: "root tr = ts"
  5.1345 -  unfolding L_def by auto
  5.1346 -  thus "\<exists>ts1\<in>Lr UNIV ts. ts1 \<subseteq> ts2"
  5.1347 -  apply(intro bexI[of _ "Fr UNIV (rcut tr)"])
  5.1348 -  unfolding Lr_def L_def using Fr_rcut wf_rcut root_rcut regular_rcut by auto
  5.1349 -qed
  5.1350 -
  5.1351 -lemma Lr_leqv_L: "leqv (Lr UNIV ts) (L UNIV ts)"
  5.1352 -using Lr_subs_L unfolding leqv_def by (metis (lifting) Lr_incl_L incl_subs)
  5.1353 -
  5.1354 -lemma LL_leqv_L: "leqv (LL UNIV ts) (L UNIV ts)"
  5.1355 -by (metis (lifting) LL_L Lr_LL Lr_subs_L incl_subs leqv_def subs_trans)
  5.1356 -
  5.1357 -lemma LL_leqv_Lr: "leqv (LL UNIV ts) (Lr UNIV ts)"
  5.1358 -using Lr_leqv_L LL_leqv_L by (metis leqv_Sym leqv_trans)
  5.1359 -
  5.1360 -end
     6.1 --- a/src/HOL/BNF_Examples/Derivation_Trees/Parallel.thy	Thu Sep 11 19:20:23 2014 +0200
     6.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.3 @@ -1,147 +0,0 @@
     6.4 -(*  Title:      HOL/BNF_Examples/Derivation_Trees/Parallel.thy
     6.5 -    Author:     Andrei Popescu, TU Muenchen
     6.6 -    Copyright   2012
     6.7 -
     6.8 -Parallel composition.
     6.9 -*)
    6.10 -
    6.11 -header {* Parallel Composition *}
    6.12 -
    6.13 -theory Parallel
    6.14 -imports DTree
    6.15 -begin
    6.16 -
    6.17 -no_notation plus_class.plus (infixl "+" 65)
    6.18 -
    6.19 -consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)
    6.20 -
    6.21 -axiomatization where
    6.22 -    Nplus_comm: "(a::N) + b = b + (a::N)"
    6.23 -and Nplus_assoc: "((a::N) + b) + c = a + (b + c)"
    6.24 -
    6.25 -subsection{* Corecursive Definition of Parallel Composition *}
    6.26 -
    6.27 -fun par_r where "par_r (tr1,tr2) = root tr1 + root tr2"
    6.28 -fun par_c where
    6.29 -"par_c (tr1,tr2) =
    6.30 - Inl ` (Inl -` (cont tr1 \<union> cont tr2)) \<union>
    6.31 - Inr ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
    6.32 -
    6.33 -declare par_r.simps[simp del]  declare par_c.simps[simp del]
    6.34 -
    6.35 -definition par :: "dtree \<times> dtree \<Rightarrow> dtree" where
    6.36 -"par \<equiv> unfold par_r par_c"
    6.37 -
    6.38 -abbreviation par_abbr (infixr "\<parallel>" 80) where "tr1 \<parallel> tr2 \<equiv> par (tr1, tr2)"
    6.39 -
    6.40 -lemma finite_par_c: "finite (par_c (tr1, tr2))"
    6.41 -unfolding par_c.simps apply(rule finite_UnI)
    6.42 -  apply (metis finite_Un finite_cont finite_imageI finite_vimageI inj_Inl)
    6.43 -  apply(intro finite_imageI finite_cartesian_product finite_vimageI)
    6.44 -  using finite_cont by auto
    6.45 -
    6.46 -lemma root_par: "root (tr1 \<parallel> tr2) = root tr1 + root tr2"
    6.47 -using unfold(1)[of par_r par_c "(tr1,tr2)"] unfolding par_def par_r.simps by simp
    6.48 -
    6.49 -lemma cont_par:
    6.50 -"cont (tr1 \<parallel> tr2) = (id \<oplus> par) ` par_c (tr1,tr2)"
    6.51 -using unfold(2)[of par_c "(tr1,tr2)" par_r, OF finite_par_c]
    6.52 -unfolding par_def ..
    6.53 -
    6.54 -lemma Inl_cont_par[simp]:
    6.55 -"Inl -` (cont (tr1 \<parallel> tr2)) = Inl -` (cont tr1 \<union> cont tr2)"
    6.56 -unfolding cont_par par_c.simps by auto
    6.57 -
    6.58 -lemma Inr_cont_par[simp]:
    6.59 -"Inr -` (cont (tr1 \<parallel> tr2)) = par ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
    6.60 -unfolding cont_par par_c.simps by auto
    6.61 -
    6.62 -lemma Inl_in_cont_par:
    6.63 -"Inl t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (Inl t \<in> cont tr1 \<or> Inl t \<in> cont tr2)"
    6.64 -using Inl_cont_par[of tr1 tr2] unfolding vimage_def by auto
    6.65 -
    6.66 -lemma Inr_in_cont_par:
    6.67 -"Inr t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (t \<in> par ` (Inr -` cont tr1 \<times> Inr -` cont tr2))"
    6.68 -using Inr_cont_par[of tr1 tr2] unfolding vimage_def by auto
    6.69 -
    6.70 -
    6.71 -subsection{* Structural Coinduction Proofs *}
    6.72 -
    6.73 -lemma rel_set_rel_sum_eq[simp]:
    6.74 -"rel_set (rel_sum (op =) \<phi>) A1 A2 \<longleftrightarrow>
    6.75 - Inl -` A1 = Inl -` A2 \<and> rel_set \<phi> (Inr -` A1) (Inr -` A2)"
    6.76 -unfolding rel_set_rel_sum rel_set_eq ..
    6.77 -
    6.78 -(* Detailed proofs of commutativity and associativity: *)
    6.79 -theorem par_com: "tr1 \<parallel> tr2 = tr2 \<parallel> tr1"
    6.80 -proof-
    6.81 -  let ?\<theta> = "\<lambda> trA trB. \<exists> tr1 tr2. trA = tr1 \<parallel> tr2 \<and> trB = tr2 \<parallel> tr1"
    6.82 -  {fix trA trB
    6.83 -   assume "?\<theta> trA trB" hence "trA = trB"
    6.84 -   apply (induct rule: dtree_coinduct)
    6.85 -   unfolding rel_set_rel_sum rel_set_eq unfolding rel_set_def proof safe
    6.86 -     fix tr1 tr2  show "root (tr1 \<parallel> tr2) = root (tr2 \<parallel> tr1)"
    6.87 -     unfolding root_par by (rule Nplus_comm)
    6.88 -   next
    6.89 -     fix n tr1 tr2 assume "Inl n \<in> cont (tr1 \<parallel> tr2)" thus "n \<in> Inl -` (cont (tr2 \<parallel> tr1))"
    6.90 -     unfolding Inl_in_cont_par by auto
    6.91 -   next
    6.92 -     fix n tr1 tr2 assume "Inl n \<in> cont (tr2 \<parallel> tr1)" thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2))"
    6.93 -     unfolding Inl_in_cont_par by auto
    6.94 -   next
    6.95 -     fix tr1 tr2 trA' assume "Inr trA' \<in> cont (tr1 \<parallel> tr2)"
    6.96 -     then obtain tr1' tr2' where "trA' = tr1' \<parallel> tr2'"
    6.97 -     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
    6.98 -     unfolding Inr_in_cont_par by auto
    6.99 -     thus "\<exists> trB' \<in> Inr -` (cont (tr2 \<parallel> tr1)). ?\<theta> trA' trB'"
   6.100 -     apply(intro bexI[of _ "tr2' \<parallel> tr1'"]) unfolding Inr_in_cont_par by auto
   6.101 -   next
   6.102 -     fix tr1 tr2 trB' assume "Inr trB' \<in> cont (tr2 \<parallel> tr1)"
   6.103 -     then obtain tr1' tr2' where "trB' = tr2' \<parallel> tr1'"
   6.104 -     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
   6.105 -     unfolding Inr_in_cont_par by auto
   6.106 -     thus "\<exists> trA' \<in> Inr -` (cont (tr1 \<parallel> tr2)). ?\<theta> trA' trB'"
   6.107 -     apply(intro bexI[of _ "tr1' \<parallel> tr2'"]) unfolding Inr_in_cont_par by auto
   6.108 -   qed
   6.109 -  }
   6.110 -  thus ?thesis by blast
   6.111 -qed
   6.112 -
   6.113 -lemma par_assoc: "(tr1 \<parallel> tr2) \<parallel> tr3 = tr1 \<parallel> (tr2 \<parallel> tr3)"
   6.114 -proof-
   6.115 -  let ?\<theta> =
   6.116 -  "\<lambda> trA trB. \<exists> tr1 tr2 tr3. trA = (tr1 \<parallel> tr2) \<parallel> tr3 \<and> trB = tr1 \<parallel> (tr2 \<parallel> tr3)"
   6.117 -  {fix trA trB
   6.118 -   assume "?\<theta> trA trB" hence "trA = trB"
   6.119 -   apply (induct rule: dtree_coinduct)
   6.120 -   unfolding rel_set_rel_sum rel_set_eq unfolding rel_set_def proof safe
   6.121 -     fix tr1 tr2 tr3  show "root ((tr1 \<parallel> tr2) \<parallel> tr3) = root (tr1 \<parallel> (tr2 \<parallel> tr3))"
   6.122 -     unfolding root_par by (rule Nplus_assoc)
   6.123 -   next
   6.124 -     fix n tr1 tr2 tr3 assume "Inl n \<in> (cont ((tr1 \<parallel> tr2) \<parallel> tr3))"
   6.125 -     thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2 \<parallel> tr3))" unfolding Inl_in_cont_par by simp
   6.126 -   next
   6.127 -     fix n tr1 tr2 tr3 assume "Inl n \<in> (cont (tr1 \<parallel> tr2 \<parallel> tr3))"
   6.128 -     thus "n \<in> Inl -` (cont ((tr1 \<parallel> tr2) \<parallel> tr3))" unfolding Inl_in_cont_par by simp
   6.129 -   next
   6.130 -     fix trA' tr1 tr2 tr3 assume "Inr trA' \<in> cont ((tr1 \<parallel> tr2) \<parallel> tr3)"
   6.131 -     then obtain tr1' tr2' tr3' where "trA' = (tr1' \<parallel> tr2') \<parallel> tr3'"
   6.132 -     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
   6.133 -     and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
   6.134 -     thus "\<exists> trB' \<in> Inr -` (cont (tr1 \<parallel> tr2 \<parallel> tr3)). ?\<theta> trA' trB'"
   6.135 -     apply(intro bexI[of _ "tr1' \<parallel> tr2' \<parallel> tr3'"])
   6.136 -     unfolding Inr_in_cont_par by auto
   6.137 -   next
   6.138 -     fix trB' tr1 tr2 tr3 assume "Inr trB' \<in> cont (tr1 \<parallel> tr2 \<parallel> tr3)"
   6.139 -     then obtain tr1' tr2' tr3' where "trB' = tr1' \<parallel> (tr2' \<parallel> tr3')"
   6.140 -     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
   6.141 -     and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
   6.142 -     thus "\<exists> trA' \<in> Inr -` cont ((tr1 \<parallel> tr2) \<parallel> tr3). ?\<theta> trA' trB'"
   6.143 -     apply(intro bexI[of _ "(tr1' \<parallel> tr2') \<parallel> tr3'"])
   6.144 -     unfolding Inr_in_cont_par by auto
   6.145 -   qed
   6.146 -  }
   6.147 -  thus ?thesis by blast
   6.148 -qed
   6.149 -
   6.150 -end
     7.1 --- a/src/HOL/BNF_Examples/Derivation_Trees/Prelim.thy	Thu Sep 11 19:20:23 2014 +0200
     7.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.3 @@ -1,64 +0,0 @@
     7.4 -(*  Title:      HOL/BNF_Examples/Derivation_Trees/Prelim.thy
     7.5 -    Author:     Andrei Popescu, TU Muenchen
     7.6 -    Copyright   2012
     7.7 -
     7.8 -Preliminaries.
     7.9 -*)
    7.10 -
    7.11 -header {* Preliminaries *}
    7.12 -
    7.13 -theory Prelim
    7.14 -imports "~~/src/HOL/Library/FSet"
    7.15 -begin
    7.16 -
    7.17 -notation BNF_Def.convol ("\<langle>(_,/ _)\<rangle>")
    7.18 -
    7.19 -declare fset_to_fset[simp]
    7.20 -
    7.21 -lemma fst_snd_convol_o[simp]: "\<langle>fst o s, snd o s\<rangle> = s"
    7.22 -apply(rule ext) by (simp add: convol_def)
    7.23 -
    7.24 -abbreviation sm_abbrev (infix "\<oplus>" 60)
    7.25 -where "f \<oplus> g \<equiv> Sum_Type.map_sum f g"
    7.26 -
    7.27 -lemma map_sum_InlD: "(f \<oplus> g) z = Inl x \<Longrightarrow> \<exists>y. z = Inl y \<and> f y = x"
    7.28 -by (cases z) auto
    7.29 -
    7.30 -lemma map_sum_InrD: "(f \<oplus> g) z = Inr x \<Longrightarrow> \<exists>y. z = Inr y \<and> g y = x"
    7.31 -by (cases z) auto
    7.32 -
    7.33 -abbreviation case_sum_abbrev ("[[_,_]]" 800)
    7.34 -where "[[f,g]] \<equiv> Sum_Type.case_sum f g"
    7.35 -
    7.36 -lemma Inl_oplus_elim:
    7.37 -assumes "Inl tr \<in> (id \<oplus> f) ` tns"
    7.38 -shows "Inl tr \<in> tns"
    7.39 -using assms apply clarify by (case_tac x, auto)
    7.40 -
    7.41 -lemma Inl_oplus_iff[simp]: "Inl tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> Inl tr \<in> tns"
    7.42 -using Inl_oplus_elim
    7.43 -by (metis id_def image_iff map_sum.simps(1))
    7.44 -
    7.45 -lemma Inl_m_oplus[simp]: "Inl -` (id \<oplus> f) ` tns = Inl -` tns"
    7.46 -using Inl_oplus_iff unfolding vimage_def by auto
    7.47 -
    7.48 -lemma Inr_oplus_elim:
    7.49 -assumes "Inr tr \<in> (id \<oplus> f) ` tns"
    7.50 -shows "\<exists> n. Inr n \<in> tns \<and> f n = tr"
    7.51 -using assms apply clarify by (case_tac x, auto)
    7.52 -
    7.53 -lemma Inr_oplus_iff[simp]:
    7.54 -"Inr tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> (\<exists> n. Inr n \<in> tns \<and> f n = tr)"
    7.55 -apply (rule iffI)
    7.56 - apply (metis Inr_oplus_elim)
    7.57 -by (metis image_iff map_sum.simps(2))
    7.58 -
    7.59 -lemma Inr_m_oplus[simp]: "Inr -` (id \<oplus> f) ` tns = f ` (Inr -` tns)"
    7.60 -using Inr_oplus_iff unfolding vimage_def by auto
    7.61 -
    7.62 -lemma Inl_Inr_image_cong:
    7.63 -assumes "Inl -` A = Inl -` B" and "Inr -` A = Inr -` B"
    7.64 -shows "A = B"
    7.65 -apply safe using assms apply(case_tac x, auto) by(case_tac x, auto)
    7.66 -
    7.67 -end
    7.68 \ No newline at end of file
     8.1 --- a/src/HOL/BNF_Examples/Instructions.thy	Thu Sep 11 19:20:23 2014 +0200
     8.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.3 @@ -1,162 +0,0 @@
     8.4 -(*  Title:      HOL/Datatype_Benchmark/Instructions.thy
     8.5 -
     8.6 -Example from Konrad: 68000 instruction set.
     8.7 -*)
     8.8 -
     8.9 -theory Instructions imports Main begin
    8.10 -
    8.11 -datatype Size = Byte | Word | Long
    8.12 -
    8.13 -datatype DataRegister =
    8.14 -  RegD0
    8.15 -| RegD1
    8.16 -| RegD2
    8.17 -| RegD3
    8.18 -| RegD4
    8.19 -| RegD5
    8.20 -| RegD6
    8.21 -| RegD7
    8.22 -
    8.23 -datatype AddressRegister =
    8.24 -  RegA0
    8.25 -| RegA1
    8.26 -| RegA2
    8.27 -| RegA3
    8.28 -| RegA4
    8.29 -| RegA5
    8.30 -| RegA6
    8.31 -| RegA7
    8.32 -
    8.33 -datatype DataOrAddressRegister =
    8.34 -  data DataRegister
    8.35 -| address AddressRegister
    8.36 -
    8.37 -datatype Condition =
    8.38 -  Hi
    8.39 -| Ls
    8.40 -| Cc
    8.41 -| Cs
    8.42 -| Ne
    8.43 -| Eq
    8.44 -| Vc
    8.45 -| Vs
    8.46 -| Pl
    8.47 -| Mi
    8.48 -| Ge
    8.49 -| Lt
    8.50 -| Gt
    8.51 -| Le
    8.52 -
    8.53 -datatype AddressingMode =
    8.54 -  immediate nat
    8.55 -| direct DataOrAddressRegister
    8.56 -| indirect AddressRegister
    8.57 -| postinc AddressRegister
    8.58 -| predec AddressRegister
    8.59 -| indirectdisp nat AddressRegister
    8.60 -| indirectindex nat AddressRegister DataOrAddressRegister Size
    8.61 -| absolute nat
    8.62 -| pcdisp nat
    8.63 -| pcindex nat DataOrAddressRegister Size
    8.64 -
    8.65 -datatype M68kInstruction =
    8.66 -  ABCD AddressingMode AddressingMode
    8.67 -| ADD Size AddressingMode AddressingMode
    8.68 -| ADDA Size AddressingMode AddressRegister
    8.69 -| ADDI Size nat AddressingMode
    8.70 -| ADDQ Size nat AddressingMode
    8.71 -| ADDX Size AddressingMode AddressingMode
    8.72 -| AND Size AddressingMode AddressingMode
    8.73 -| ANDI Size nat AddressingMode
    8.74 -| ANDItoCCR nat
    8.75 -| ANDItoSR nat
    8.76 -| ASL Size AddressingMode DataRegister
    8.77 -| ASLW AddressingMode
    8.78 -| ASR Size AddressingMode DataRegister
    8.79 -| ASRW AddressingMode
    8.80 -| Bcc Condition Size nat
    8.81 -| BTST Size AddressingMode AddressingMode
    8.82 -| BCHG Size AddressingMode AddressingMode
    8.83 -| BCLR Size AddressingMode AddressingMode
    8.84 -| BSET Size AddressingMode AddressingMode
    8.85 -| BRA Size nat
    8.86 -| BSR Size nat
    8.87 -| CHK AddressingMode DataRegister
    8.88 -| CLR Size AddressingMode
    8.89 -| CMP Size AddressingMode DataRegister
    8.90 -| CMPA Size AddressingMode AddressRegister
    8.91 -| CMPI Size nat AddressingMode
    8.92 -| CMPM Size AddressRegister AddressRegister
    8.93 -| DBT DataRegister nat
    8.94 -| DBF DataRegister nat
    8.95 -| DBcc Condition DataRegister nat
    8.96 -| DIVS AddressingMode DataRegister
    8.97 -| DIVU AddressingMode DataRegister
    8.98 -| EOR Size DataRegister AddressingMode
    8.99 -| EORI Size nat AddressingMode
   8.100 -| EORItoCCR nat
   8.101 -| EORItoSR nat
   8.102 -| EXG DataOrAddressRegister DataOrAddressRegister
   8.103 -| EXT Size DataRegister
   8.104 -| ILLEGAL
   8.105 -| JMP AddressingMode
   8.106 -| JSR AddressingMode
   8.107 -| LEA AddressingMode AddressRegister
   8.108 -| LINK AddressRegister nat
   8.109 -| LSL Size AddressingMode DataRegister
   8.110 -| LSLW AddressingMode
   8.111 -| LSR Size AddressingMode DataRegister
   8.112 -| LSRW AddressingMode
   8.113 -| MOVE Size AddressingMode AddressingMode
   8.114 -| MOVEtoCCR AddressingMode
   8.115 -| MOVEtoSR AddressingMode
   8.116 -| MOVEfromSR AddressingMode
   8.117 -| MOVEtoUSP AddressingMode
   8.118 -| MOVEfromUSP AddressingMode
   8.119 -| MOVEA Size AddressingMode AddressRegister
   8.120 -| MOVEMto Size AddressingMode "DataOrAddressRegister list"
   8.121 -| MOVEMfrom Size "DataOrAddressRegister list" AddressingMode
   8.122 -| MOVEP Size AddressingMode AddressingMode
   8.123 -| MOVEQ nat DataRegister
   8.124 -| MULS AddressingMode DataRegister
   8.125 -| MULU AddressingMode DataRegister
   8.126 -| NBCD AddressingMode
   8.127 -| NEG Size AddressingMode
   8.128 -| NEGX Size AddressingMode
   8.129 -| NOP
   8.130 -| NOT Size AddressingMode
   8.131 -| OR Size AddressingMode AddressingMode
   8.132 -| ORI Size nat AddressingMode
   8.133 -| ORItoCCR nat
   8.134 -| ORItoSR nat
   8.135 -| PEA AddressingMode
   8.136 -| RESET
   8.137 -| ROL Size AddressingMode DataRegister
   8.138 -| ROLW AddressingMode
   8.139 -| ROR Size AddressingMode DataRegister
   8.140 -| RORW AddressingMode
   8.141 -| ROXL Size AddressingMode DataRegister
   8.142 -| ROXLW AddressingMode
   8.143 -| ROXR Size AddressingMode DataRegister
   8.144 -| ROXRW AddressingMode
   8.145 -| RTE
   8.146 -| RTR
   8.147 -| RTS
   8.148 -| SBCD AddressingMode AddressingMode
   8.149 -| ST AddressingMode
   8.150 -| SF AddressingMode
   8.151 -| Scc Condition AddressingMode
   8.152 -| STOP nat
   8.153 -| SUB Size AddressingMode AddressingMode
   8.154 -| SUBA Size AddressingMode AddressingMode
   8.155 -| SUBI Size nat AddressingMode
   8.156 -| SUBQ Size nat AddressingMode
   8.157 -| SUBX Size AddressingMode AddressingMode
   8.158 -| SWAP DataRegister
   8.159 -| TAS AddressingMode
   8.160 -| TRAP nat
   8.161 -| TRAPV
   8.162 -| TST Size AddressingMode
   8.163 -| UNLK AddressRegister
   8.164 -
   8.165 -end
     9.1 --- a/src/HOL/BNF_Examples/IsaFoR_Datatypes.thy	Thu Sep 11 19:20:23 2014 +0200
     9.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.3 @@ -1,380 +0,0 @@
     9.4 -(*  Title:      HOL/BNF_Examples/IsaFoR_Datatypes.thy
     9.5 -    Author:     Rene Thiemann, UIBK
     9.6 -    Copyright   2014
     9.7 -
     9.8 -Benchmark consisting of datatypes defined in IsaFoR.
     9.9 -*)
    9.10 -
    9.11 -header {* Benchmark Consisting of Datatypes Defined in IsaFoR *}
    9.12 -
    9.13 -theory IsaFoR_Datatypes
    9.14 -imports Real
    9.15 -begin
    9.16 -
    9.17 -datatype_new (discs_sels) ('f, 'l) lab =
    9.18 -    Lab "('f, 'l) lab" 'l
    9.19 -  | FunLab "('f, 'l) lab" "('f, 'l) lab list"
    9.20 -  | UnLab 'f
    9.21 -  | Sharp "('f, 'l) lab"
    9.22 -
    9.23 -datatype_new (discs_sels) 'f projL = Projection "(('f \<times> nat) \<times> nat) list"
    9.24 -
    9.25 -datatype_new (discs_sels) ('f, 'v) "term" = Var 'v | Fun 'f "('f, 'v) term list"
    9.26 -datatype_new (discs_sels) ('f, 'v) ctxt =
    9.27 -    Hole ("\<box>")
    9.28 -  | More 'f "('f, 'v) term list" "('f, 'v) ctxt" "('f, 'v) term list"
    9.29 -
    9.30 -type_synonym ('f, 'v) rule = "('f, 'v) term \<times> ('f, 'v) term"
    9.31 -type_synonym ('f, 'v) trs  = "('f, 'v) rule set"
    9.32 -
    9.33 -type_synonym ('f, 'v) rules = "('f, 'v) rule list"
    9.34 -type_synonym ('f, 'l, 'v) ruleLL  = "(('f, 'l) lab, 'v) rule"
    9.35 -type_synonym ('f, 'l, 'v) trsLL   = "(('f, 'l) lab, 'v) rules"
    9.36 -type_synonym ('f, 'l, 'v) termsLL = "(('f, 'l) lab, 'v) term list"
    9.37 -
    9.38 -datatype_new (discs_sels) pos = Empty ("\<epsilon>") | PCons "nat" "pos" (infixr "<#" 70)
    9.39 -
    9.40 -type_synonym  ('f, 'v) prseq = "(pos \<times> ('f, 'v) rule \<times> bool \<times> ('f, 'v) term) list"
    9.41 -type_synonym  ('f, 'v) rseq = "(pos \<times> ('f, 'v) rule \<times> ('f, 'v) term) list"
    9.42 -
    9.43 -type_synonym ('f, 'l, 'v) rseqL   = "((('f, 'l) lab, 'v) rule \<times> (('f, 'l) lab, 'v) rseq) list"
    9.44 -type_synonym ('f, 'l, 'v) dppLL   =
    9.45 -  "bool \<times> bool \<times> ('f, 'l, 'v) trsLL \<times> ('f, 'l, 'v) trsLL \<times>
    9.46 -  ('f, 'l, 'v) termsLL \<times>
    9.47 -  ('f, 'l, 'v) trsLL \<times> ('f, 'l, 'v) trsLL"
    9.48 -
    9.49 -type_synonym ('f, 'l, 'v) qreltrsLL =
    9.50 -  "bool \<times> ('f, 'l, 'v) termsLL \<times> ('f, 'l, 'v) trsLL \<times> ('f, 'l, 'v) trsLL"
    9.51 -
    9.52 -type_synonym ('f, 'l, 'v) qtrsLL =
    9.53 -  "bool \<times> ('f, 'l, 'v) termsLL \<times> ('f, 'l, 'v) trsLL"
    9.54 -
    9.55 -datatype_new (discs_sels) location = H | A | B | R
    9.56 -
    9.57 -type_synonym ('f, 'v) forb_pattern = "('f, 'v) ctxt \<times> ('f, 'v) term \<times> location"
    9.58 -type_synonym ('f, 'v) forb_patterns = "('f, 'v) forb_pattern set"
    9.59 -
    9.60 -type_synonym ('f, 'l, 'v) fptrsLL =
    9.61 -  "(('f, 'l) lab, 'v) forb_pattern list \<times> ('f, 'l, 'v) trsLL"
    9.62 -
    9.63 -type_synonym ('f, 'l, 'v) prob = "('f, 'l, 'v) qreltrsLL + ('f, 'l, 'v) dppLL"
    9.64 -
    9.65 -type_synonym ('f, 'a) lpoly_inter = "'f \<times> nat \<Rightarrow> ('a \<times> 'a list)"
    9.66 -type_synonym ('f, 'a) lpoly_interL = "(('f \<times> nat) \<times> ('a \<times> 'a list)) list"
    9.67 -
    9.68 -type_synonym 'v monom = "('v \<times> nat) list"
    9.69 -type_synonym ('v, 'a) poly = "('v monom \<times> 'a) list"
    9.70 -type_synonym ('f, 'a) poly_inter_list = "(('f \<times> nat) \<times> (nat, 'a) poly) list"
    9.71 -type_synonym 'a vec = "'a list"
    9.72 -type_synonym 'a mat = "'a vec list"
    9.73 -
    9.74 -datatype_new (discs_sels) arctic = MinInfty | Num_arc int
    9.75 -datatype_new (discs_sels) 'a arctic_delta = MinInfty_delta | Num_arc_delta 'a
    9.76 -datatype_new (discs_sels) order_tag = Lex | Mul
    9.77 -
    9.78 -type_synonym 'f status_prec_repr = "(('f \<times> nat) \<times> (nat \<times> order_tag)) list"
    9.79 -
    9.80 -datatype_new (discs_sels) af_entry =
    9.81 -    Collapse nat
    9.82 -  | AFList "nat list"
    9.83 -
    9.84 -type_synonym 'f afs_list = "(('f \<times> nat) \<times> af_entry) list"
    9.85 -type_synonym 'f prec_weight_repr = "(('f \<times> nat) \<times> (nat \<times> nat \<times> (nat list option))) list \<times> nat"
    9.86 -
    9.87 -datatype_new (discs_sels) 'f redtriple_impl =
    9.88 -    Int_carrier "('f, int) lpoly_interL"
    9.89 -  | Int_nl_carrier "('f, int) poly_inter_list"
    9.90 -  | Rat_carrier "('f, rat) lpoly_interL"
    9.91 -  | Rat_nl_carrier rat "('f, rat) poly_inter_list"
    9.92 -  | Real_carrier "('f, real) lpoly_interL"
    9.93 -  | Real_nl_carrier real "('f, real) poly_inter_list"
    9.94 -  | Arctic_carrier "('f, arctic) lpoly_interL"
    9.95 -  | Arctic_rat_carrier "('f, rat arctic_delta) lpoly_interL"
    9.96 -  | Int_mat_carrier nat nat "('f, int mat) lpoly_interL"
    9.97 -  | Rat_mat_carrier nat nat "('f, rat mat) lpoly_interL"
    9.98 -  | Real_mat_carrier nat nat "('f, real mat) lpoly_interL"
    9.99 -  | Arctic_mat_carrier nat "('f, arctic mat) lpoly_interL"
   9.100 -  | Arctic_rat_mat_carrier nat "('f, rat arctic_delta mat) lpoly_interL"
   9.101 -  | RPO "'f status_prec_repr" "'f afs_list"
   9.102 -  | KBO "'f prec_weight_repr" "'f afs_list"
   9.103 -
   9.104 -datatype_new (discs_sels) list_order_type = MS_Ext | Max_Ext | Min_Ext  | Dms_Ext
   9.105 -type_synonym 'f scnp_af = "(('f \<times> nat) \<times> (nat \<times> nat) list) list"
   9.106 -
   9.107 -datatype_new (discs_sels) 'f root_redtriple_impl = SCNP list_order_type "'f scnp_af" "'f redtriple_impl"
   9.108 -
   9.109 -type_synonym 'f sig_map_list = "(('f \<times> nat) \<times> 'f list) list"
   9.110 -type_synonym ('f, 'v) uncurry_info = "'f \<times> 'f sig_map_list \<times> ('f, 'v) rules \<times> ('f, 'v) rules"
   9.111 -
   9.112 -datatype_new (discs_sels) arithFun =
   9.113 -    Arg nat
   9.114 -  | Const nat
   9.115 -  | Sum "arithFun list"
   9.116 -  | Max "arithFun list"
   9.117 -  | Min "arithFun list"
   9.118 -  | Prod "arithFun list"
   9.119 -  | IfEqual arithFun arithFun arithFun arithFun
   9.120 -
   9.121 -datatype_new (discs_sels) 'f sl_inter = SL_Inter nat "(('f \<times> nat) \<times> arithFun) list"
   9.122 -datatype_new (discs_sels) ('f, 'v) sl_variant =
   9.123 -    Rootlab "('f \<times> nat) option"
   9.124 -  | Finitelab "'f sl_inter"
   9.125 -  | QuasiFinitelab "'f sl_inter" 'v
   9.126 -
   9.127 -type_synonym ('f, 'v) crit_pair_joins = "(('f, 'v) term \<times> ('f, 'v) rseq \<times> ('f, 'v) term \<times> ('f, 'v) rseq) list"
   9.128 -
   9.129 -datatype_new (discs_sels) 'f join_info = Guided "('f, string) crit_pair_joins" | Join_NF | Join_BFS nat
   9.130 -
   9.131 -type_synonym unknown_info = string
   9.132 -
   9.133 -type_synonym dummy_prf = unit
   9.134 -
   9.135 -datatype_new (discs_sels) ('f, 'v) complex_constant_removal_prf = Complex_Constant_Removal_Proof
   9.136 -  "('f, 'v) term"
   9.137 -  "(('f, 'v) rule \<times> ('f, 'v) rule) list"
   9.138 -
   9.139 -datatype_new (discs_sels) ('f, 'v) cond_constraint =
   9.140 -    CC_cond bool "('f, 'v) rule"
   9.141 -  | CC_rewr "('f, 'v) term" "('f, 'v) term"
   9.142 -  | CC_impl "('f, 'v) cond_constraint list" "('f, 'v) cond_constraint"
   9.143 -  | CC_all 'v "('f, 'v) cond_constraint"
   9.144 -
   9.145 -type_synonym ('f, 'v, 'w) gsubstL = "('v \<times> ('f, 'w) term) list"
   9.146 -type_synonym ('f, 'v) substL = "('f, 'v, 'v) gsubstL"
   9.147 -
   9.148 -datatype_new (discs_sels) ('f, 'v) cond_constraint_prf =
   9.149 -    Final
   9.150 -  | Delete_Condition "('f, 'v) cond_constraint" "('f, 'v) cond_constraint_prf"
   9.151 -  | Different_Constructor "('f, 'v) cond_constraint"
   9.152 -  | Same_Constructor "('f, 'v) cond_constraint" "('f, 'v) cond_constraint" "('f, 'v) cond_constraint_prf"
   9.153 -  | Variable_Equation 'v "('f, 'v) term" "('f, 'v) cond_constraint" "('f, 'v) cond_constraint_prf"
   9.154 -  | Funarg_Into_Var "('f, 'v) cond_constraint" nat 'v "('f, 'v) cond_constraint" "('f, 'v) cond_constraint_prf"
   9.155 -  | Simplify_Condition "('f, 'v) cond_constraint" "('f, 'v) substL" "('f, 'v) cond_constraint" "('f, 'v) cond_constraint_prf"
   9.156 -  | Induction "('f, 'v) cond_constraint" "('f, 'v) cond_constraint list" "(('f, 'v) rule \<times> (('f, 'v) term \<times> 'v list) list \<times> ('f, 'v) cond_constraint \<times> ('f, 'v) cond_constraint_prf) list"
   9.157 -
   9.158 -datatype_new (discs_sels) ('f, 'v) cond_red_pair_prf =
   9.159 -  Cond_Red_Pair_Prf
   9.160 -    'f "(('f, 'v) cond_constraint \<times> ('f, 'v) rules \<times> ('f, 'v) cond_constraint_prf) list" nat nat
   9.161 -
   9.162 -datatype_new (discs_sels) ('q, 'f) ta_rule = TA_rule 'f "'q list" 'q ("_ _ \<rightarrow> _")
   9.163 -datatype_new (discs_sels) ('q, 'f) tree_automaton = Tree_Automaton "'q list" "('q, 'f) ta_rule list" "('q \<times> 'q) list"
   9.164 -datatype_new (discs_sels) 'q ta_relation =
   9.165 -    Decision_Proc
   9.166 -  | Id_Relation
   9.167 -  | Some_Relation "('q \<times> 'q) list"
   9.168 -
   9.169 -datatype_new (discs_sels) boundstype = Roof | Match
   9.170 -datatype_new (discs_sels) ('f, 'q) bounds_info = Bounds_Info boundstype nat "'q list" "('q, 'f \<times> nat) tree_automaton" "'q ta_relation"
   9.171 -
   9.172 -datatype_new (discs_sels) ('f, 'v) pat_eqv_prf =
   9.173 -    Pat_Dom_Renaming "('f, 'v) substL"
   9.174 -  | Pat_Irrelevant "('f, 'v) substL" "('f, 'v) substL"
   9.175 -  | Pat_Simplify "('f, 'v) substL" "('f, 'v) substL"
   9.176 -
   9.177 -datatype_new (discs_sels) pat_rule_pos = Pat_Base | Pat_Pump | Pat_Close
   9.178 -
   9.179 -datatype_new (discs_sels) ('f, 'v) pat_rule_prf =
   9.180 -    Pat_OrigRule "('f, 'v) rule" bool
   9.181 -  | Pat_InitPump "('f, 'v) pat_rule_prf" "('f, 'v) substL" "('f, 'v) substL"
   9.182 -  | Pat_InitPumpCtxt "('f, 'v) pat_rule_prf" "('f, 'v) substL" pos 'v
   9.183 -  | Pat_Equiv "('f, 'v) pat_rule_prf" bool "('f, 'v) pat_eqv_prf"
   9.184 -  | Pat_Narrow "('f, 'v) pat_rule_prf" "('f, 'v) pat_rule_prf" pos
   9.185 -  | Pat_Inst "('f, 'v) pat_rule_prf" "('f, 'v) substL" pat_rule_pos
   9.186 -  | Pat_Rewr "('f, 'v) pat_rule_prf" "('f, 'v) term \<times> ('f, 'v) rseq" pat_rule_pos 'v
   9.187 -  | Pat_Exp_Sigma "('f, 'v) pat_rule_prf" nat
   9.188 -
   9.189 -datatype_new (discs_sels) ('f, 'v) non_loop_prf =
   9.190 -    Non_Loop_Prf "('f, 'v) pat_rule_prf" "('f, 'v) substL" "('f, 'v) substL" nat nat pos
   9.191 -
   9.192 -datatype_new (discs_sels) ('f, 'l, 'v) problem =
   9.193 -    SN_TRS "('f, 'l, 'v) qreltrsLL"
   9.194 -  | SN_FP_TRS "('f, 'l, 'v) fptrsLL"
   9.195 -  | Finite_DPP "('f, 'l, 'v) dppLL"
   9.196 -  | Unknown_Problem unknown_info
   9.197 -  | Not_SN_TRS "('f, 'l, 'v) qtrsLL"
   9.198 -  | Not_RelSN_TRS "('f, 'l, 'v) qreltrsLL"
   9.199 -  | Infinite_DPP "('f, 'l, 'v) dppLL"
   9.200 -  | Not_SN_FP_TRS "('f, 'l, 'v) fptrsLL"
   9.201 -
   9.202 -declare [[bnf_timing]]
   9.203 -
   9.204 -datatype_new (discs_sels) ('f, 'l, 'v, 'a, 'b, 'c, 'd, 'e) generic_assm_proof =
   9.205 -    SN_assm_proof "('f, 'l, 'v) qreltrsLL" 'a
   9.206 -  | Finite_assm_proof "('f, 'l, 'v) dppLL" 'b
   9.207 -  | SN_FP_assm_proof "('f, 'l, 'v) fptrsLL" 'c
   9.208 -  | Not_SN_assm_proof "('f, 'l, 'v) qtrsLL" 'a
   9.209 -  | Infinite_assm_proof "('f, 'l, 'v) dppLL" 'b
   9.210 -  | Not_RelSN_assm_proof "('f, 'l, 'v) qreltrsLL" 'c
   9.211 -  | Not_SN_FP_assm_proof "('f, 'l, 'v) fptrsLL" 'd
   9.212 -  | Unknown_assm_proof unknown_info 'e
   9.213 -
   9.214 -type_synonym ('f, 'l, 'v, 'a, 'b, 'c, 'd) assm_proof = "('f, 'l, 'v, 'a, 'b, 'c, dummy_prf, 'd) generic_assm_proof"
   9.215 -
   9.216 -datatype_new (discs_sels) ('f, 'l, 'v) assm =
   9.217 -    SN_assm "('f, 'l, 'v) problem list" "('f, 'l, 'v) qreltrsLL"
   9.218 -  | SN_FP_assm "('f, 'l, 'v) problem list" "('f, 'l, 'v) fptrsLL"
   9.219 -  | Finite_assm "('f, 'l, 'v) problem list" "('f, 'l, 'v) dppLL"
   9.220 -  | Unknown_assm "('f, 'l, 'v) problem list" unknown_info
   9.221 -  | Not_SN_assm "('f, 'l, 'v) problem list" "('f, 'l, 'v) qtrsLL"
   9.222 -  | Not_RelSN_assm "('f, 'l, 'v) problem list" "('f, 'l, 'v) qreltrsLL"
   9.223 -  | Not_SN_FP_assm "('f, 'l, 'v) problem list" "('f, 'l, 'v) fptrsLL"
   9.224 -  | Infinite_assm "('f, 'l, 'v) problem list" "('f, 'l, 'v) dppLL"
   9.225 -
   9.226 -fun satisfied :: "('f, 'l, 'v) problem \<Rightarrow> bool" where
   9.227 -  "satisfied (SN_TRS t) = (t = t)"
   9.228 -| "satisfied (SN_FP_TRS t) = (t \<noteq> t)"
   9.229 -| "satisfied (Finite_DPP d) = (d \<noteq> d)"
   9.230 -| "satisfied (Unknown_Problem s) = (s = ''foo'')"
   9.231 -| "satisfied (Not_SN_TRS (nfs, q, r)) = (length q = length r)"
   9.232 -| "satisfied (Not_RelSN_TRS (nfs, q, r, rw)) = (r = rw)"
   9.233 -| "satisfied (Infinite_DPP d) = (d = d)"
   9.234 -| "satisfied (Not_SN_FP_TRS t) = (t = t)"
   9.235 -
   9.236 -fun collect_assms :: "('tp \<Rightarrow> ('f, 'l, 'v) assm list)
   9.237 -  \<Rightarrow> ('dpp \<Rightarrow> ('f, 'l, 'v) assm list)
   9.238 -  \<Rightarrow> ('fptp \<Rightarrow> ('f, 'l, 'v) assm list)
   9.239 -  \<Rightarrow> ('unk \<Rightarrow> ('f, 'l, 'v) assm list)
   9.240 -  \<Rightarrow> ('f, 'l, 'v, 'tp, 'dpp, 'fptp, 'unk) assm_proof \<Rightarrow> ('f, 'l, 'v) assm list" where
   9.241 -  "collect_assms tp dpp fptp unk (SN_assm_proof t prf) = tp prf"
   9.242 -| "collect_assms tp dpp fptp unk (SN_FP_assm_proof t prf) = fptp prf"
   9.243 -| "collect_assms tp dpp fptp unk (Finite_assm_proof d prf) = dpp prf"
   9.244 -| "collect_assms tp dpp fptp unk (Unknown_assm_proof p prf) = unk prf"
   9.245 -| "collect_assms _ _ _ _ _ = []"
   9.246 -
   9.247 -fun collect_neg_assms :: "('tp \<Rightarrow> ('f, 'l, 'v) assm list)
   9.248 -  \<Rightarrow> ('dpp \<Rightarrow> ('f, 'l, 'v) assm list)
   9.249 -  \<Rightarrow> ('rtp \<Rightarrow> ('f, 'l, 'v) assm list)
   9.250 -  \<Rightarrow> ('fptp \<Rightarrow> ('f, 'l, 'v) assm list)
   9.251 -  \<Rightarrow> ('unk \<Rightarrow> ('f, 'l, 'v) assm list)
   9.252 -  \<Rightarrow> ('f, 'l, 'v, 'tp, 'dpp, 'rtp, 'fptp, 'unk) generic_assm_proof \<Rightarrow> ('f, 'l, 'v) assm list" where
   9.253 -  "collect_neg_assms tp dpp rtp fptp unk (Not_SN_assm_proof t prf) = tp prf"
   9.254 -| "collect_neg_assms tp dpp rtp fptp unk (Infinite_assm_proof d prf) = dpp prf"
   9.255 -| "collect_neg_assms tp dpp rtp fptp unk (Not_RelSN_assm_proof t prf) = rtp prf"
   9.256 -| "collect_neg_assms tp dpp rtp fptp unk (Not_SN_FP_assm_proof t prf) = fptp prf"
   9.257 -| "collect_neg_assms tp dpp rtp fptp unk (Unknown_assm_proof p prf) = unk prf"
   9.258 -| "collect_neg_assms tp dpp rtp fptp unk _ = []"
   9.259 -
   9.260 -datatype_new (discs_sels) ('f, 'l, 'v) dp_nontermination_proof =
   9.261 -    DP_Loop "(('f, 'l) lab, 'v) term" "(('f, 'l) lab, 'v) prseq" "(('f, 'l) lab, 'v) substL" "(('f, 'l) lab, 'v) ctxt"
   9.262 -  | DP_Nonloop "(('f, 'l) lab, 'v) non_loop_prf"
   9.263 -  | DP_Rule_Removal "('f, 'l, 'v) trsLL option" "('f, 'l, 'v) trsLL option" "('f, 'l, 'v) dp_nontermination_proof"
   9.264 -  | DP_Q_Increase "('f, 'l, 'v) termsLL" "('f, 'l, 'v) dp_nontermination_proof"
   9.265 -  | DP_Q_Reduction "('f, 'l, 'v) termsLL" "('f, 'l, 'v) dp_nontermination_proof"
   9.266 -  | DP_Termination_Switch "('f, 'l) lab join_info" "('f, 'l, 'v) dp_nontermination_proof"
   9.267 -  | DP_Instantiation "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_nontermination_proof"
   9.268 -  | DP_Rewriting "('f, 'l, 'v) trsLL option" "('f, 'l, 'v) ruleLL" "('f, 'l, 'v) ruleLL" "('f, 'l, 'v) ruleLL" "(('f, 'l) lab, 'v) rule" pos "('f, 'l, 'v) dp_nontermination_proof"
   9.269 -  | DP_Narrowing "('f, 'l, 'v) ruleLL" pos "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_nontermination_proof"
   9.270 -  | DP_Assume_Infinite  "('f, 'l, 'v) dppLL"
   9.271 -      "('f, 'l, 'v, ('f, 'l, 'v) trs_nontermination_proof,
   9.272 -       ('f, 'l, 'v) dp_nontermination_proof,
   9.273 -       ('f, 'l, 'v) reltrs_nontermination_proof,
   9.274 -       ('f, 'l, 'v) fp_nontermination_proof,
   9.275 -       ('f, 'l, 'v) neg_unknown_proof) generic_assm_proof list"
   9.276 -and ('f, 'l, 'v) "trs_nontermination_proof" =
   9.277 -    TRS_Loop "(('f, 'l) lab, 'v) term" "(('f, 'l) lab, 'v) rseq" "(('f, 'l) lab, 'v) substL" "(('f, 'l) lab, 'v) ctxt"
   9.278 -  | TRS_Not_Well_Formed
   9.279 -  | TRS_Rule_Removal "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trs_nontermination_proof"
   9.280 -  | TRS_String_Reversal "('f, 'l, 'v) trs_nontermination_proof"
   9.281 -  | TRS_DP_Trans "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_nontermination_proof"
   9.282 -  | TRS_Nonloop "(('f, 'l) lab, 'v) non_loop_prf"
   9.283 -  | TRS_Q_Increase "('f, 'l, 'v) termsLL" "('f, 'l, 'v) trs_nontermination_proof"
   9.284 -  | TRS_Assume_Not_SN  "('f, 'l, 'v) qtrsLL"
   9.285 -      "('f, 'l, 'v, ('f, 'l, 'v) trs_nontermination_proof,
   9.286 -       ('f, 'l, 'v) dp_nontermination_proof,
   9.287 -       ('f, 'l, 'v) reltrs_nontermination_proof,
   9.288 -       ('f, 'l, 'v) fp_nontermination_proof,
   9.289 -       ('f, 'l, 'v) neg_unknown_proof) generic_assm_proof list"
   9.290 -and ('f, 'l, 'v)"reltrs_nontermination_proof" =
   9.291 -    Rel_Loop "(('f, 'l) lab, 'v) term" "(('f, 'l) lab, 'v) prseq" "(('f, 'l) lab, 'v) substL" "(('f, 'l) lab, 'v) ctxt"
   9.292 -  | Rel_Not_Well_Formed
   9.293 -  | Rel_Rule_Removal "('f, 'l, 'v) trsLL option" "('f, 'l, 'v) trsLL option" "('f, 'l, 'v) reltrs_nontermination_proof"
   9.294 -  | Rel_R_Not_SN "('f, 'l, 'v) trs_nontermination_proof"
   9.295 -  | Rel_TRS_Assume_Not_SN  "('f, 'l, 'v) qreltrsLL"
   9.296 -      "('f, 'l, 'v, ('f, 'l, 'v) trs_nontermination_proof,
   9.297 -       ('f, 'l, 'v) dp_nontermination_proof,
   9.298 -       ('f, 'l, 'v) reltrs_nontermination_proof,
   9.299 -       ('f, 'l, 'v) fp_nontermination_proof,
   9.300 -       ('f, 'l, 'v) neg_unknown_proof) generic_assm_proof list"
   9.301 -and ('f, 'l, 'v) "fp_nontermination_proof" =
   9.302 -    FPTRS_Loop "(('f, 'l) lab, 'v) term" "(('f, 'l) lab, 'v) rseq" "(('f, 'l) lab, 'v) substL" "(('f, 'l) lab, 'v) ctxt"
   9.303 -  | FPTRS_Rule_Removal "('f, 'l, 'v) trsLL" "('f, 'l, 'v) fp_nontermination_proof"
   9.304 -  | FPTRS_Assume_Not_SN  "('f, 'l, 'v) fptrsLL"
   9.305 -      "('f, 'l, 'v, ('f, 'l, 'v) trs_nontermination_proof,
   9.306 -       ('f, 'l, 'v) dp_nontermination_proof,
   9.307 -       ('f, 'l, 'v) reltrs_nontermination_proof,
   9.308 -       ('f, 'l, 'v) fp_nontermination_proof,
   9.309 -       ('f, 'l, 'v) neg_unknown_proof) generic_assm_proof list"
   9.310 -and ('f, 'l, 'v) neg_unknown_proof =
   9.311 -    Assume_NT_Unknown unknown_info
   9.312 -      "('f, 'l, 'v, ('f, 'l, 'v) trs_nontermination_proof,
   9.313 -       ('f, 'l, 'v) dp_nontermination_proof,
   9.314 -       ('f, 'l, 'v) reltrs_nontermination_proof,
   9.315 -       ('f, 'l, 'v) fp_nontermination_proof,
   9.316 -       ('f, 'l, 'v) neg_unknown_proof) generic_assm_proof list"
   9.317 -
   9.318 -datatype_new (discs_sels) ('f, 'l, 'v) dp_termination_proof =
   9.319 -    P_is_Empty
   9.320 -  | Subterm_Criterion_Proc "('f, 'l) lab projL" "('f, 'l, 'v) rseqL"
   9.321 -      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
   9.322 -  | Redpair_Proc "('f, 'l) lab root_redtriple_impl + ('f, 'l) lab redtriple_impl" "('f, 'l, 'v) trsLL"  "('f, 'l, 'v) dp_termination_proof"
   9.323 -  | Redpair_UR_Proc "('f, 'l) lab root_redtriple_impl + ('f, 'l) lab redtriple_impl"
   9.324 -      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
   9.325 -  | Usable_Rules_Proc "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
   9.326 -  | Dep_Graph_Proc "(('f, 'l, 'v) dp_termination_proof option \<times> ('f, 'l, 'v) trsLL) list"
   9.327 -  | Mono_Redpair_Proc "('f, 'l) lab redtriple_impl"
   9.328 -      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
   9.329 -  | Mono_Redpair_UR_Proc "('f, 'l) lab redtriple_impl"
   9.330 -      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
   9.331 -  | Size_Change_Subterm_Proc "((('f, 'l) lab, 'v) rule \<times> ((nat \<times> nat) list \<times> (nat \<times> nat) list)) list"
   9.332 -  | Size_Change_Redpair_Proc "('f, 'l) lab redtriple_impl" "('f, 'l, 'v) trsLL option"
   9.333 -      "((('f, 'l) lab, 'v) rule \<times> ((nat \<times> nat) list \<times> (nat \<times> nat) list)) list"
   9.334 -  | Uncurry_Proc "nat option" "(('f, 'l) lab, 'v) uncurry_info"
   9.335 -      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
   9.336 -  | Fcc_Proc "('f, 'l) lab" "(('f, 'l) lab, 'v) ctxt list"
   9.337 -      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
   9.338 -  | Split_Proc
   9.339 -      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL"
   9.340 -      "('f, 'l, 'v) dp_termination_proof" "('f, 'l, 'v) dp_termination_proof"
   9.341 -  | Semlab_Proc
   9.342 -      "(('f, 'l) lab, 'v) sl_variant" "('f, 'l, 'v) trsLL"
   9.343 -      "(('f, 'l) lab, 'v) term list" "('f, 'l, 'v) trsLL"
   9.344 -      "('f, 'l, 'v) dp_termination_proof"
   9.345 -  | Switch_Innermost_Proc "('f, 'l) lab join_info" "('f, 'l, 'v) dp_termination_proof"
   9.346 -  | Rewriting_Proc
   9.347 -      "('f, 'l, 'v) trsLL option" "('f, 'l, 'v) ruleLL" "('f, 'l, 'v) ruleLL"
   9.348 -      "('f, 'l, 'v) ruleLL" "('f, 'l, 'v) ruleLL" pos "('f, 'l, 'v) dp_termination_proof"
   9.349 -  | Instantiation_Proc "('f, 'l, 'v) ruleLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
   9.350 -  | Forward_Instantiation_Proc
   9.351 -      "('f, 'l, 'v) ruleLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL option" "('f, 'l, 'v) dp_termination_proof"
   9.352 -  | Narrowing_Proc "('f, 'l, 'v) ruleLL" pos "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
   9.353 -  | Assume_Finite
   9.354 -      "('f, 'l, 'v) dppLL" "('f, 'l, 'v, ('f, 'l, 'v) trs_termination_proof, ('f, 'l, 'v) dp_termination_proof, ('f, 'l, 'v) fptrs_termination_proof, ('f, 'l, 'v) unknown_proof) assm_proof list"
   9.355 -  | Unlab_Proc "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
   9.356 -  | Q_Reduction_Proc "('f, 'l, 'v) termsLL" "('f, 'l, 'v) dp_termination_proof"
   9.357 -  | Complex_Constant_Removal_Proc "(('f, 'l) lab, 'v) complex_constant_removal_prf" "('f, 'l, 'v) dp_termination_proof"
   9.358 -  | General_Redpair_Proc
   9.359 -      "('f, 'l) lab redtriple_impl" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL"
   9.360 -      "(('f, 'l) lab, 'v) cond_red_pair_prf" "('f, 'l, 'v) dp_termination_proof list"
   9.361 -  | To_Trs_Proc "('f, 'l, 'v) trs_termination_proof"
   9.362 -and ('f, 'l, 'v) trs_termination_proof =
   9.363 -    DP_Trans bool bool "(('f, 'l) lab, 'v) rules" "('f, 'l, 'v) dp_termination_proof"
   9.364 -  | Rule_Removal "('f, 'l) lab redtriple_impl" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trs_termination_proof"
   9.365 -  | String_Reversal "('f, 'l, 'v) trs_termination_proof"
   9.366 -  | Bounds "(('f, 'l) lab, 'v) bounds_info"
   9.367 -  | Uncurry "(('f, 'l) lab, 'v) uncurry_info" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trs_termination_proof"
   9.368 -  | Semlab
   9.369 -      "(('f, 'l) lab, 'v) sl_variant" "(('f, 'l) lab, 'v) term list"
   9.370 -      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trs_termination_proof"
   9.371 -  | R_is_Empty
   9.372 -  | Fcc "(('f, 'l) lab, 'v) ctxt list" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trs_termination_proof"
   9.373 -  | Split "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trs_termination_proof" "('f, 'l, 'v) trs_termination_proof"
   9.374 -  | Switch_Innermost "('f, 'l) lab join_info" "('f, 'l, 'v) trs_termination_proof"
   9.375 -  | Drop_Equality "('f, 'l, 'v) trs_termination_proof"
   9.376 -  | Remove_Nonapplicable_Rules "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trs_termination_proof"
   9.377 -  | Assume_SN "('f, 'l, 'v) qreltrsLL" "('f, 'l, 'v, ('f, 'l, 'v) trs_termination_proof, ('f, 'l, 'v) dp_termination_proof, ('f, 'l, 'v) fptrs_termination_proof, ('f, 'l, 'v) unknown_proof) assm_proof list"
   9.378 -and ('f, 'l, 'v) unknown_proof =
   9.379 -    Assume_Unknown unknown_info "('f, 'l, 'v, ('f, 'l, 'v) trs_termination_proof, ('f, 'l, 'v) dp_termination_proof, ('f, 'l, 'v) fptrs_termination_proof, ('f, 'l, 'v) unknown_proof) assm_proof list"
   9.380 -and ('f, 'l, 'v) fptrs_termination_proof =
   9.381 -    Assume_FP_SN "('f, 'l, 'v) fptrsLL" "('f, 'l, 'v, ('f, 'l, 'v) trs_termination_proof, ('f, 'l, 'v) dp_termination_proof, ('f, 'l, 'v) fptrs_termination_proof, ('f, 'l, 'v) unknown_proof) assm_proof list"
   9.382 -
   9.383 -end
    10.1 --- a/src/HOL/BNF_Examples/Koenig.thy	Thu Sep 11 19:20:23 2014 +0200
    10.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    10.3 @@ -1,122 +0,0 @@
    10.4 -(*  Title:      HOL/BNF_Examples/Koenig.thy
    10.5 -    Author:     Dmitriy Traytel, TU Muenchen
    10.6 -    Author:     Andrei Popescu, TU Muenchen
    10.7 -    Copyright   2012
    10.8 -
    10.9 -Koenig's lemma.
   10.10 -*)
   10.11 -
   10.12 -header {* Koenig's Lemma *}
   10.13 -
   10.14 -theory Koenig
   10.15 -imports TreeFI Stream
   10.16 -begin
   10.17 -
   10.18 -(* infinite trees: *)
   10.19 -coinductive infiniteTr where
   10.20 -"\<lbrakk>tr' \<in> set (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"
   10.21 -
   10.22 -lemma infiniteTr_strong_coind[consumes 1, case_names sub]:
   10.23 -assumes *: "phi tr" and
   10.24 -**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set (sub tr). phi tr' \<or> infiniteTr tr'"
   10.25 -shows "infiniteTr tr"
   10.26 -using assms by (elim infiniteTr.coinduct) blast
   10.27 -
   10.28 -lemma infiniteTr_coind[consumes 1, case_names sub, induct pred: infiniteTr]:
   10.29 -assumes *: "phi tr" and
   10.30 -**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set (sub tr). phi tr'"
   10.31 -shows "infiniteTr tr"
   10.32 -using assms by (elim infiniteTr.coinduct) blast
   10.33 -
   10.34 -lemma infiniteTr_sub[simp]:
   10.35 -"infiniteTr tr \<Longrightarrow> (\<exists> tr' \<in> set (sub tr). infiniteTr tr')"
   10.36 -by (erule infiniteTr.cases) blast
   10.37 -
   10.38 -primcorec konigPath where
   10.39 -  "shd (konigPath t) = lab t"
   10.40 -| "stl (konigPath t) = konigPath (SOME tr. tr \<in> set (sub t) \<and> infiniteTr tr)"
   10.41 -
   10.42 -(* proper paths in trees: *)
   10.43 -coinductive properPath where
   10.44 -"\<lbrakk>shd as = lab tr; tr' \<in> set (sub tr); properPath (stl as) tr'\<rbrakk> \<Longrightarrow>
   10.45 - properPath as tr"
   10.46 -
   10.47 -lemma properPath_strong_coind[consumes 1, case_names shd_lab sub]:
   10.48 -assumes *: "phi as tr" and
   10.49 -**: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
   10.50 -***: "\<And> as tr.
   10.51 -         phi as tr \<Longrightarrow>
   10.52 -         \<exists> tr' \<in> set (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
   10.53 -shows "properPath as tr"
   10.54 -using assms by (elim properPath.coinduct) blast
   10.55 -
   10.56 -lemma properPath_coind[consumes 1, case_names shd_lab sub, induct pred: properPath]:
   10.57 -assumes *: "phi as tr" and
   10.58 -**: "\<And> as tr. phi as tr \<Longrightarrow> shd as = lab tr" and
   10.59 -***: "\<And> as tr.
   10.60 -         phi as tr \<Longrightarrow>
   10.61 -         \<exists> tr' \<in> set (sub tr). phi (stl as) tr'"
   10.62 -shows "properPath as tr"
   10.63 -using properPath_strong_coind[of phi, OF * **] *** by blast
   10.64 -
   10.65 -lemma properPath_shd_lab:
   10.66 -"properPath as tr \<Longrightarrow> shd as = lab tr"
   10.67 -by (erule properPath.cases) blast
   10.68 -
   10.69 -lemma properPath_sub:
   10.70 -"properPath as tr \<Longrightarrow>
   10.71 - \<exists> tr' \<in> set (sub tr). phi (stl as) tr' \<or> properPath (stl as) tr'"
   10.72 -by (erule properPath.cases) blast
   10.73 -
   10.74 -(* prove the following by coinduction *)
   10.75 -theorem Konig:
   10.76 -  assumes "infiniteTr tr"
   10.77 -  shows "properPath (konigPath tr) tr"
   10.78 -proof-
   10.79 -  {fix as
   10.80 -   assume "infiniteTr tr \<and> as = konigPath tr" hence "properPath as tr"
   10.81 -   proof (coinduction arbitrary: tr as rule: properPath_coind)
   10.82 -     case (sub tr as)
   10.83 -     let ?t = "SOME t'. t' \<in> set (sub tr) \<and> infiniteTr t'"
   10.84 -     from sub have "\<exists>t' \<in> set (sub tr). infiniteTr t'" by simp
   10.85 -     then have "\<exists>t'. t' \<in> set (sub tr) \<and> infiniteTr t'" by blast
   10.86 -     then have "?t \<in> set (sub tr) \<and> infiniteTr ?t" by (rule someI_ex)
   10.87 -     moreover have "stl (konigPath tr) = konigPath ?t" by simp
   10.88 -     ultimately show ?case using sub by blast
   10.89 -   qed simp
   10.90 -  }
   10.91 -  thus ?thesis using assms by blast
   10.92 -qed
   10.93 -
   10.94 -(* some more stream theorems *)
   10.95 -
   10.96 -primcorec plus :: "nat stream \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<oplus>" 66) where
   10.97 -  "shd (plus xs ys) = shd xs + shd ys"
   10.98 -| "stl (plus xs ys) = plus (stl xs) (stl ys)"
   10.99 -
  10.100 -definition scalar :: "nat \<Rightarrow> nat stream \<Rightarrow> nat stream" (infixr "\<cdot>" 68) where
  10.101 -  [simp]: "scalar n = smap (\<lambda>x. n * x)"
  10.102 -
  10.103 -primcorec ones :: "nat stream" where "ones = 1 ## ones"
  10.104 -primcorec twos :: "nat stream" where "twos = 2 ## twos"
  10.105 -definition ns :: "nat \<Rightarrow> nat stream" where [simp]: "ns n = scalar n ones"
  10.106 -
  10.107 -lemma "ones \<oplus> ones = twos"
  10.108 -  by coinduction simp
  10.109 -
  10.110 -lemma "n \<cdot> twos = ns (2 * n)"
  10.111 -  by coinduction simp
  10.112 -
  10.113 -lemma prod_scalar: "(n * m) \<cdot> xs = n \<cdot> m \<cdot> xs"
  10.114 -  by (coinduction arbitrary: xs) auto
  10.115 -
  10.116 -lemma scalar_plus: "n \<cdot> (xs \<oplus> ys) = n \<cdot> xs \<oplus> n \<cdot> ys"
  10.117 -  by (coinduction arbitrary: xs ys) (auto simp: add_mult_distrib2)
  10.118 -
  10.119 -lemma plus_comm: "xs \<oplus> ys = ys \<oplus> xs"
  10.120 -  by (coinduction arbitrary: xs ys) auto
  10.121 -
  10.122 -lemma plus_assoc: "(xs \<oplus> ys) \<oplus> zs = xs \<oplus> ys \<oplus> zs"
  10.123 -  by (coinduction arbitrary: xs ys zs) auto
  10.124 -
  10.125 -end
    11.1 --- a/src/HOL/BNF_Examples/Lambda_Term.thy	Thu Sep 11 19:20:23 2014 +0200
    11.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    11.3 @@ -1,50 +0,0 @@
    11.4 -(*  Title:      HOL/BNF_Examples/Lambda_Term.thy
    11.5 -    Author:     Dmitriy Traytel, TU Muenchen
    11.6 -    Author:     Andrei Popescu, TU Muenchen
    11.7 -    Copyright   2012
    11.8 -
    11.9 -Lambda-terms.
   11.10 -*)
   11.11 -
   11.12 -header {* Lambda-Terms *}
   11.13 -
   11.14 -theory Lambda_Term
   11.15 -imports "~~/src/HOL/Library/FSet"
   11.16 -begin
   11.17 -
   11.18 -section {* Datatype definition *}
   11.19 -
   11.20 -datatype_new 'a trm =
   11.21 -  Var 'a |
   11.22 -  App "'a trm" "'a trm" |
   11.23 -  Lam 'a "'a trm" |
   11.24 -  Lt "('a \<times> 'a trm) fset" "'a trm"
   11.25 -
   11.26 -
   11.27 -subsection {* Example: The set of all variables varsOf and free variables fvarsOf of a term *}
   11.28 -
   11.29 -primrec varsOf :: "'a trm \<Rightarrow> 'a set" where
   11.30 -  "varsOf (Var a) = {a}"
   11.31 -| "varsOf (App f x) = varsOf f \<union> varsOf x"
   11.32 -| "varsOf (Lam x b) = {x} \<union> varsOf b"
   11.33 -| "varsOf (Lt F t) = varsOf t \<union> (\<Union> { {x} \<union> X | x X. (x,X) |\<in>| fimage (map_prod id varsOf) F})"
   11.34 -
   11.35 -primrec fvarsOf :: "'a trm \<Rightarrow> 'a set" where
   11.36 -  "fvarsOf (Var x) = {x}"
   11.37 -| "fvarsOf (App t1 t2) = fvarsOf t1 \<union> fvarsOf t2"
   11.38 -| "fvarsOf (Lam x t) = fvarsOf t - {x}"
   11.39 -| "fvarsOf (Lt xts t) = fvarsOf t - {x | x X. (x,X) |\<in>| fimage (map_prod id varsOf) xts} \<union>
   11.40 -    (\<Union> {X | x X. (x,X) |\<in>| fimage (map_prod id varsOf) xts})"
   11.41 -
   11.42 -lemma diff_Un_incl_triv: "\<lbrakk>A \<subseteq> D; C \<subseteq> E\<rbrakk> \<Longrightarrow> A - B \<union> C \<subseteq> D \<union> E" by blast
   11.43 -
   11.44 -lemma in_fimage_map_prod_fset_iff[simp]:
   11.45 -  "(x, y) |\<in>| fimage (map_prod f g) xts \<longleftrightarrow> (\<exists> t1 t2. (t1, t2) |\<in>| xts \<and> x = f t1 \<and> y = g t2)"
   11.46 -  by force
   11.47 -
   11.48 -lemma fvarsOf_varsOf: "fvarsOf t \<subseteq> varsOf t"
   11.49 -proof induct
   11.50 -  case (Lt xts t) thus ?case unfolding fvarsOf.simps varsOf.simps by (elim diff_Un_incl_triv) auto
   11.51 -qed auto
   11.52 -
   11.53 -end
    12.1 --- a/src/HOL/BNF_Examples/Misc_Codatatype.thy	Thu Sep 11 19:20:23 2014 +0200
    12.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    12.3 @@ -1,122 +0,0 @@
    12.4 -(*  Title:      HOL/BNF_Examples/Misc_Codatatype.thy
    12.5 -    Author:     Dmitriy Traytel, TU Muenchen
    12.6 -    Author:     Andrei Popescu, TU Muenchen
    12.7 -    Author:     Jasmin Blanchette, TU Muenchen
    12.8 -    Copyright   2012, 2013
    12.9 -
   12.10 -Miscellaneous codatatype definitions.
   12.11 -*)
   12.12 -
   12.13 -header {* Miscellaneous Codatatype Definitions *}
   12.14 -
   12.15 -theory Misc_Codatatype
   12.16 -imports "~~/src/HOL/Library/FSet"
   12.17 -begin
   12.18 -
   12.19 -codatatype simple = X1 | X2 | X3 | X4
   12.20 -
   12.21 -codatatype simple' = X1' unit | X2' unit | X3' unit | X4' unit
   12.22 -
   12.23 -codatatype simple'' = X1'' nat int | X2''
   12.24 -
   12.25 -codatatype 'a stream = Stream (shd: 'a) (stl: "'a stream")
   12.26 -
   12.27 -codatatype 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
   12.28 -
   12.29 -codatatype ('b, 'c :: ord, 'd, 'e) some_passive =
   12.30 -  SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
   12.31 -
   12.32 -codatatype lambda =
   12.33 -  Var string |
   12.34 -  App lambda lambda |
   12.35 -  Abs string lambda |
   12.36 -  Let "(string \<times> lambda) fset" lambda
   12.37 -
   12.38 -codatatype 'a par_lambda =
   12.39 -  PVar 'a |
   12.40 -  PApp "'a par_lambda" "'a par_lambda" |
   12.41 -  PAbs 'a "'a par_lambda" |
   12.42 -  PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
   12.43 -
   12.44 -(*
   12.45 -  ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
   12.46 -  ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
   12.47 -*)
   12.48 -
   12.49 -codatatype 'a p = P "'a + 'a p"
   12.50 -
   12.51 -codatatype 'a J1 = J11 'a "'a J1" | J12 'a "'a J2"
   12.52 -and 'a J2 = J21 | J22 "'a J1" "'a J2"
   12.53 -
   12.54 -codatatype 'a tree = TEmpty | TNode 'a "'a forest"
   12.55 -and 'a forest = FNil | FCons "'a tree" "'a forest"
   12.56 -
   12.57 -codatatype 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
   12.58 -and 'a branch = Branch 'a "'a tree'"
   12.59 -
   12.60 -codatatype 'a bin_rose_tree = BRTree 'a "'a bin_rose_tree mylist" "'a bin_rose_tree mylist"
   12.61 -
   12.62 -codatatype ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
   12.63 -and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
   12.64 -and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
   12.65 -
   12.66 -codatatype ('a, 'b, 'c) some_killing =
   12.67 -  SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
   12.68 -and ('a, 'b, 'c) in_here =
   12.69 -  IH1 'b 'a | IH2 'c
   12.70 -
   12.71 -codatatype ('a, 'b, 'c) some_killing' =
   12.72 -  SK' "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing' + ('a, 'b, 'c) in_here'"
   12.73 -and ('a, 'b, 'c) in_here' =
   12.74 -  IH1' 'b | IH2' 'c
   12.75 -
   12.76 -codatatype ('a, 'b, 'c) some_killing'' =
   12.77 -  SK'' "'a \<Rightarrow> ('a, 'b, 'c) in_here''"
   12.78 -and ('a, 'b, 'c) in_here'' =
   12.79 -  IH1'' 'b 'a | IH2'' 'c
   12.80 -
   12.81 -codatatype ('b, 'c) less_killing = LK "'b \<Rightarrow> 'c"
   12.82 -
   12.83 -codatatype 'b poly_unit = U "'b \<Rightarrow> 'b poly_unit"
   12.84 -codatatype 'b cps = CPS1 'b | CPS2 "'b \<Rightarrow> 'b cps"
   12.85 -
   12.86 -codatatype ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs =
   12.87 -  FR "'b1 \<Rightarrow> 'b2 \<Rightarrow> 'b3 \<Rightarrow> 'b4 \<Rightarrow> 'b5 \<Rightarrow> 'b6 \<Rightarrow> 'b7 \<Rightarrow> 'b8 \<Rightarrow> 'b9 \<Rightarrow>
   12.88 -      ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9) fun_rhs"
   12.89 -
   12.90 -codatatype ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
   12.91 -        'b18, 'b19, 'b20) fun_rhs' =
   12.92 -  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>
   12.93 -       'b15 \<Rightarrow> 'b16 \<Rightarrow> 'b17 \<Rightarrow> 'b18 \<Rightarrow> 'b19 \<Rightarrow> 'b20 \<Rightarrow>
   12.94 -       ('b1, 'b2, 'b3, 'b4, 'b5, 'b6, 'b7, 'b8, 'b9, 'b10, 'b11, 'b12, 'b13, 'b14, 'b15, 'b16, 'b17,
   12.95 -        'b18, 'b19, 'b20) fun_rhs'"
   12.96 -
   12.97 -codatatype ('a, 'b, 'c) wit3_F1 = W1 'a "('a, 'b, 'c) wit3_F1" "('a, 'b, 'c) wit3_F2"
   12.98 -and ('a, 'b, 'c) wit3_F2 = W2 'b "('a, 'b, 'c) wit3_F2"
   12.99 -and ('a, 'b, 'c) wit3_F3 = W31 'a 'b "('a, 'b, 'c) wit3_F1" | W32 'c 'a 'b "('a, 'b, 'c) wit3_F1"
  12.100 -
  12.101 -codatatype ('c, 'e, 'g) coind_wit1 =
  12.102 -       CW1 'c "('c, 'e, 'g) coind_wit1" "('c, 'e, 'g) ind_wit" "('c, 'e, 'g) coind_wit2"
  12.103 -and ('c, 'e, 'g) coind_wit2 =
  12.104 -       CW21 "('c, 'e, 'g) coind_wit2" 'e | CW22 'c 'g
  12.105 -and ('c, 'e, 'g) ind_wit =
  12.106 -       IW1 | IW2 'c
  12.107 -
  12.108 -codatatype ('b, 'a) bar = BAR "'a \<Rightarrow> 'b"
  12.109 -codatatype ('a, 'b, 'c, 'd) foo = FOO "'d + 'b \<Rightarrow> 'c + 'a"
  12.110 -
  12.111 -codatatype 'a dead_foo = A
  12.112 -codatatype ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
  12.113 -
  12.114 -(* SLOW, MEMORY-HUNGRY
  12.115 -codatatype ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
  12.116 -and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
  12.117 -and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
  12.118 -and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
  12.119 -and ('a, 'c) D5 = A5 "('a, 'c) D6"
  12.120 -and ('a, 'c) D6 = A6 "('a, 'c) D7"
  12.121 -and ('a, 'c) D7 = A7 "('a, 'c) D8"
  12.122 -and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
  12.123 -*)
  12.124 -
  12.125 -end
    13.1 --- a/src/HOL/BNF_Examples/Misc_Datatype.thy	Thu Sep 11 19:20:23 2014 +0200
    13.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    13.3 @@ -1,338 +0,0 @@
    13.4 -(*  Title:      HOL/BNF_Examples/Misc_Datatype.thy
    13.5 -    Author:     Dmitriy Traytel, TU Muenchen
    13.6 -    Author:     Andrei Popescu, TU Muenchen
    13.7 -    Author:     Jasmin Blanchette, TU Muenchen
    13.8 -    Copyright   2012, 2013
    13.9 -
   13.10 -Miscellaneous datatype definitions.
   13.11 -*)
   13.12 -
   13.13 -header {* Miscellaneous Datatype Definitions *}
   13.14 -
   13.15 -theory Misc_Datatype
   13.16 -imports "~~/src/HOL/Library/Countable" "~~/src/HOL/Library/FSet"
   13.17 -begin
   13.18 -
   13.19 -datatype_new (discs_sels) simple = X1 | X2 | X3 | X4
   13.20 -
   13.21 -datatype_new (discs_sels) simple' = X1' unit | X2' unit | X3' unit | X4' unit
   13.22 -
   13.23 -datatype_new (discs_sels) simple'' = X1'' nat int | X2''
   13.24 -
   13.25 -datatype_new (discs_sels) 'a mylist = MyNil | MyCons (myhd: 'a) (mytl: "'a mylist")
   13.26 -
   13.27 -datatype_new (discs_sels) ('b, 'c :: ord, 'd, 'e) some_passive =
   13.28 -  SP1 "('b, 'c, 'd, 'e) some_passive" | SP2 'b | SP3 'c | SP4 'd | SP5 'e
   13.29 -
   13.30 -datatype_new (discs_sels) hfset = HFset "hfset fset"
   13.31 -
   13.32 -datatype_new (discs_sels) lambda =
   13.33 -  Var string |
   13.34 -  App lambda lambda |
   13.35 -  Abs string lambda |
   13.36 -  Let "(string \<times> lambda) fset" lambda
   13.37 -
   13.38 -datatype_new (discs_sels) 'a par_lambda =
   13.39 -  PVar 'a |
   13.40 -  PApp "'a par_lambda" "'a par_lambda" |
   13.41 -  PAbs 'a "'a par_lambda" |
   13.42 -  PLet "('a \<times> 'a par_lambda) fset" "'a par_lambda"
   13.43 -
   13.44 -(*
   13.45 -  ('a, 'b1, 'b2) F1 = 'a * 'b1 + 'a * 'b2
   13.46 -  ('a, 'b1, 'b2) F2 = unit + 'b1 * 'b2
   13.47 -*)
   13.48 -
   13.49 -datatype_new (discs_sels) 'a I1 = I11 'a "'a I1" | I12 'a "'a I2"
   13.50 -and 'a I2 = I21 | I22 "'a I1" "'a I2"
   13.51 -
   13.52 -datatype_new (discs_sels) 'a tree = TEmpty | TNode 'a "'a forest"
   13.53 -and 'a forest = FNil | FCons "'a tree" "'a forest"
   13.54 -
   13.55 -datatype_new (discs_sels) 'a tree' = TEmpty' | TNode' "'a branch" "'a branch"
   13.56 -and 'a branch = Branch 'a "'a tree'"
   13.57 -
   13.58 -datatype_new (discs_sels) 'a bin_rose_tree = BRTree 'a "'a bin_rose_tree mylist" "'a bin_rose_tree mylist"
   13.59 -
   13.60 -datatype_new (discs_sels) ('a, 'b) exp = Term "('a, 'b) trm" | Sum "('a, 'b) trm" "('a, 'b) exp"
   13.61 -and ('a, 'b) trm = Factor "('a, 'b) factor" | Prod "('a, 'b) factor" "('a, 'b) trm"
   13.62 -and ('a, 'b) factor = C 'a | V 'b | Paren "('a, 'b) exp"
   13.63 -
   13.64 -datatype_new (discs_sels) 'a ftree = FTLeaf 'a | FTNode "'a \<Rightarrow> 'a ftree"
   13.65 -
   13.66 -datatype_new (discs_sels) ('a, 'b, 'c) some_killing =
   13.67 -  SK "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b, 'c) some_killing + ('a, 'b, 'c) in_here"
   13.68 -and ('a, 'b, 'c) in_here =
   13.69 -  IH1 'b 'a | IH2 'c
   13.70 -
   13.71 -datatype_new (discs_sels) 'b nofail1 = NF11 "'b nofail1" 'b | NF12 'b
   13.72 -datatype_new (discs_sels) 'b nofail2 = NF2 "('b nofail2 \<times> 'b \<times> 'b nofail2 \<times> 'b) list"
   13.73 -datatype_new (discs_sels) 'b nofail3 = NF3 'b "('b nofail3 \<times> 'b \<times> 'b nofail3 \<times> 'b) fset"
   13.74 -datatype_new (discs_sels) 'b nofail4 = NF4 "('b nofail4 \<times> ('b nofail4 \<times> 'b \<times> 'b nofail4 \<times> 'b) fset) list"
   13.75 -
   13.76 -(*
   13.77 -datatype_new (discs_sels) 'b fail = F "'b fail" 'b "'b fail" "'b list"
   13.78 -datatype_new (discs_sels) 'b fail = F "'b fail" 'b "'b fail" 'b
   13.79 -datatype_new (discs_sels) 'b fail = F1 "'b fail" 'b | F2 "'b fail"
   13.80 -datatype_new (discs_sels) 'b fail = F "'b fail" 'b
   13.81 -*)
   13.82 -
   13.83 -datatype_new (discs_sels) l1 = L1 "l2 list"
   13.84 -and l2 = L21 "l1 fset" | L22 l2
   13.85 -
   13.86 -datatype_new (discs_sels) kk1 = KK1 kk2
   13.87 -and kk2 = KK2 kk3
   13.88 -and kk3 = KK3 "kk1 list"
   13.89 -
   13.90 -datatype_new (discs_sels) t1 = T11 t3 | T12 t2
   13.91 -and t2 = T2 t1
   13.92 -and t3 = T3
   13.93 -
   13.94 -datatype_new (discs_sels) t1' = T11' t2' | T12' t3'
   13.95 -and t2' = T2' t1'
   13.96 -and t3' = T3'
   13.97 -
   13.98 -(*
   13.99 -datatype_new (discs_sels) fail1 = F1 fail2
  13.100 -and fail2 = F2 fail3
  13.101 -and fail3 = F3 fail1
  13.102 -
  13.103 -datatype_new (discs_sels) fail1 = F1 "fail2 list" fail2
  13.104 -and fail2 = F2 "fail2 fset" fail3
  13.105 -and fail3 = F3 fail1
  13.106 -
  13.107 -datatype_new (discs_sels) fail1 = F1 "fail2 list" fail2
  13.108 -and fail2 = F2 "fail1 fset" fail1
  13.109 -*)
  13.110 -
  13.111 -(* SLOW
  13.112 -datatype_new (discs_sels) ('a, 'c) D1 = A1 "('a, 'c) D2" | B1 "'a list"
  13.113 -and ('a, 'c) D2 = A2 "('a, 'c) D3" | B2 "'c list"
  13.114 -and ('a, 'c) D3 = A3 "('a, 'c) D3" | B3 "('a, 'c) D4" | C3 "('a, 'c) D4" "('a, 'c) D5"
  13.115 -and ('a, 'c) D4 = A4 "('a, 'c) D5" | B4 "'a list list list"
  13.116 -and ('a, 'c) D5 = A5 "('a, 'c) D6"
  13.117 -and ('a, 'c) D6 = A6 "('a, 'c) D7"
  13.118 -and ('a, 'c) D7 = A7 "('a, 'c) D8"
  13.119 -and ('a, 'c) D8 = A8 "('a, 'c) D1 list"
  13.120 -*)
  13.121 -
  13.122 -(* fail:
  13.123 -datatype_new (discs_sels) tt1 = TT11 tt2 tt3 | TT12 tt2 tt4
  13.124 -and tt2 = TT2
  13.125 -and tt3 = TT3 tt4
  13.126 -and tt4 = TT4 tt1
  13.127 -*)
  13.128 -
  13.129 -datatype_new (discs_sels) k1 = K11 k2 k3 | K12 k2 k4
  13.130 -and k2 = K2
  13.131 -and k3 = K3 k4
  13.132 -and k4 = K4
  13.133 -
  13.134 -datatype_new (discs_sels) tt1 = TT11 tt3 tt2 | TT12 tt2 tt4
  13.135 -and tt2 = TT2
  13.136 -and tt3 = TT3 tt1
  13.137 -and tt4 = TT4
  13.138 -
  13.139 -(* SLOW
  13.140 -datatype_new (discs_sels) s1 = S11 s2 s3 s4 | S12 s3 | S13 s2 s6 | S14 s4 s2 | S15 s2 s2
  13.141 -and s2 = S21 s7 s5 | S22 s5 s4 s6
  13.142 -and s3 = S31 s1 s7 s2 | S32 s3 s3 | S33 s4 s5
  13.143 -and s4 = S4 s5
  13.144 -and s5 = S5
  13.145 -and s6 = S61 s6 | S62 s1 s2 | S63 s6
  13.146 -and s7 = S71 s8 | S72 s5
  13.147 -and s8 = S8 nat
  13.148 -*)
  13.149 -
  13.150 -datatype_new (discs_sels) 'a deadbar = DeadBar "'a \<Rightarrow> 'a"
  13.151 -datatype_new (discs_sels) 'a deadbar_option = DeadBarOption "'a option \<Rightarrow> 'a option"
  13.152 -datatype_new (discs_sels) ('a, 'b) bar = Bar "'b \<Rightarrow> 'a"
  13.153 -datatype_new (discs_sels) ('a, 'b, 'c, 'd) foo = Foo "'d + 'b \<Rightarrow> 'c + 'a"
  13.154 -datatype_new (discs_sels) 'a deadfoo = DeadFoo "'a \<Rightarrow> 'a + 'a"
  13.155 -
  13.156 -datatype_new (discs_sels) 'a dead_foo = A
  13.157 -datatype_new (discs_sels) ('a, 'b) use_dead_foo = Y "'a" "'b dead_foo"
  13.158 -
  13.159 -datatype_new (discs_sels) d1 = D
  13.160 -datatype_new (discs_sels) d1' = is_D: D
  13.161 -
  13.162 -datatype_new (discs_sels) d2 = D nat
  13.163 -datatype_new (discs_sels) d2' = is_D: D nat
  13.164 -
  13.165 -datatype_new (discs_sels) d3 = D | E
  13.166 -datatype_new (discs_sels) d3' = D | is_E: E
  13.167 -datatype_new (discs_sels) d3'' = is_D: D | E
  13.168 -datatype_new (discs_sels) d3''' = is_D: D | is_E: E
  13.169 -
  13.170 -datatype_new (discs_sels) d4 = D nat | E
  13.171 -datatype_new (discs_sels) d4' = D nat | is_E: E
  13.172 -datatype_new (discs_sels) d4'' = is_D: D nat | E
  13.173 -datatype_new (discs_sels) d4''' = is_D: D nat | is_E: E
  13.174 -
  13.175 -datatype_new (discs_sels) d5 = D nat | E int
  13.176 -datatype_new (discs_sels) d5' = D nat | is_E: E int
  13.177 -datatype_new (discs_sels) d5'' = is_D: D nat | E int
  13.178 -datatype_new (discs_sels) d5''' = is_D: D nat | is_E: E int
  13.179 -
  13.180 -instance simple :: countable
  13.181 -  by countable_datatype
  13.182 -
  13.183 -instance simple'' :: countable
  13.184 -  by countable_datatype
  13.185 -
  13.186 -instance mylist :: (countable) countable
  13.187 -  by countable_datatype
  13.188 -
  13.189 -instance some_passive :: (countable, "{countable,ord}", countable, countable) countable
  13.190 -  by countable_datatype
  13.191 -
  13.192 -(* TODO: Enable once "fset" is registered as countable:
  13.193 -
  13.194 -instance hfset :: countable
  13.195 -  by countable_datatype
  13.196 -
  13.197 -instance lambda :: countable
  13.198 -  by countable_datatype
  13.199 -
  13.200 -instance par_lambda :: (countable) countable
  13.201 -  by countable_datatype
  13.202 -*)
  13.203 -
  13.204 -instance I1 and I2 :: (countable) countable
  13.205 -  by countable_datatype
  13.206 -
  13.207 -instance tree and forest :: (countable) countable
  13.208 -  by countable_datatype
  13.209 -
  13.210 -instance tree' and branch :: (countable) countable
  13.211 -  by countable_datatype
  13.212 -
  13.213 -instance bin_rose_tree :: (countable) countable
  13.214 -  by countable_datatype
  13.215 -
  13.216 -instance exp and trm and factor :: (countable, countable) countable
  13.217 -  by countable_datatype
  13.218 -
  13.219 -instance nofail1 :: (countable) countable
  13.220 -  by countable_datatype
  13.221 -
  13.222 -instance nofail2 :: (countable) countable
  13.223 -  by countable_datatype
  13.224 -
  13.225 -(* TODO: Enable once "fset" is registered as countable:
  13.226 -
  13.227 -instance nofail3 :: (countable) countable
  13.228 -  by countable_datatype
  13.229 -
  13.230 -instance nofail4 :: (countable) countable
  13.231 -  by countable_datatype
  13.232 -
  13.233 -instance l1 and l2 :: countable
  13.234 -  by countable_datatype
  13.235 -*)
  13.236 -
  13.237 -instance kk1 and kk2 :: countable
  13.238 -  by countable_datatype
  13.239 -
  13.240 -instance t1 and t2 and t3 :: countable
  13.241 -  by countable_datatype
  13.242 -
  13.243 -instance t1' and t2' and t3' :: countable
  13.244 -  by countable_datatype
  13.245 -
  13.246 -instance k1 and k2 and k3 and k4 :: countable
  13.247 -  by countable_datatype
  13.248 -
  13.249 -instance tt1 and tt2 and tt3 and tt4 :: countable
  13.250 -  by countable_datatype
  13.251 -
  13.252 -instance d1 :: countable
  13.253 -  by countable_datatype
  13.254 -
  13.255 -instance d1' :: countable
  13.256 -  by countable_datatype
  13.257 -
  13.258 -instance d2 :: countable
  13.259 -  by countable_datatype
  13.260 -
  13.261 -instance d2' :: countable
  13.262 -  by countable_datatype
  13.263 -
  13.264 -instance d3 :: countable
  13.265 -  by countable_datatype
  13.266 -
  13.267 -instance d3' :: countable
  13.268 -  by countable_datatype
  13.269 -
  13.270 -instance d3'' :: countable
  13.271 -  by countable_datatype
  13.272 -
  13.273 -instance d3''' :: countable
  13.274 -  by countable_datatype
  13.275 -
  13.276 -instance d4 :: countable
  13.277 -  by countable_datatype
  13.278 -
  13.279 -instance d4' :: countable
  13.280 -  by countable_datatype
  13.281 -
  13.282 -instance d4'' :: countable
  13.283 -  by countable_datatype
  13.284 -
  13.285 -instance d4''' :: countable
  13.286 -  by countable_datatype
  13.287 -
  13.288 -instance d5 :: countable
  13.289 -  by countable_datatype
  13.290 -
  13.291 -instance d5' :: countable
  13.292 -  by countable_datatype
  13.293 -
  13.294 -instance d5'' :: countable
  13.295 -  by countable_datatype
  13.296 -
  13.297 -instance d5''' :: countable
  13.298 -  by countable_datatype
  13.299 -
  13.300 -datatype_compat simple
  13.301 -datatype_compat simple'
  13.302 -datatype_compat simple''
  13.303 -datatype_compat mylist
  13.304 -datatype_compat some_passive
  13.305 -datatype_compat I1 I2
  13.306 -datatype_compat tree forest
  13.307 -datatype_compat tree' branch
  13.308 -datatype_compat bin_rose_tree
  13.309 -datatype_compat exp trm factor
  13.310 -datatype_compat ftree
  13.311 -datatype_compat nofail1
  13.312 -datatype_compat kk1 kk2 kk3
  13.313 -datatype_compat t1 t2 t3
  13.314 -datatype_compat t1' t2' t3'
  13.315 -datatype_compat k1 k2 k3 k4
  13.316 -datatype_compat tt1 tt2 tt3 tt4
  13.317 -datatype_compat deadbar
  13.318 -datatype_compat deadbar_option
  13.319 -datatype_compat bar
  13.320 -datatype_compat foo
  13.321 -datatype_compat deadfoo
  13.322 -datatype_compat dead_foo
  13.323 -datatype_compat use_dead_foo
  13.324 -datatype_compat d1
  13.325 -datatype_compat d1'
  13.326 -datatype_compat d2
  13.327 -datatype_compat d2'
  13.328 -datatype_compat d3
  13.329 -datatype_compat d3'
  13.330 -datatype_compat d3''
  13.331 -datatype_compat d3'''
  13.332 -datatype_compat d4
  13.333 -datatype_compat d4'
  13.334 -datatype_compat d4''
  13.335 -datatype_compat d4'''
  13.336 -datatype_compat d5
  13.337 -datatype_compat d5'
  13.338 -datatype_compat d5''
  13.339 -datatype_compat d5'''
  13.340 -
  13.341 -end
    14.1 --- a/src/HOL/BNF_Examples/Misc_Primcorec.thy	Thu Sep 11 19:20:23 2014 +0200
    14.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    14.3 @@ -1,138 +0,0 @@
    14.4 -(*  Title:      HOL/BNF_Examples/Misc_Primcorec.thy
    14.5 -    Author:     Jasmin Blanchette, TU Muenchen
    14.6 -    Copyright   2013
    14.7 -
    14.8 -Miscellaneous primitive corecursive function definitions.
    14.9 -*)
   14.10 -
   14.11 -header {* Miscellaneous Primitive Corecursive Function Definitions *}
   14.12 -
   14.13 -theory Misc_Primcorec
   14.14 -imports Misc_Codatatype
   14.15 -begin
   14.16 -
   14.17 -primcorec simple_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple" where
   14.18 -  "simple_of_bools b b' = (if b then if b' then X1 else X2 else if b' then X3 else X4)"
   14.19 -
   14.20 -primcorec simple'_of_bools :: "bool \<Rightarrow> bool \<Rightarrow> simple'" where
   14.21 -  "simple'_of_bools b b' =
   14.22 -     (if b then if b' then X1' () else X2' () else if b' then X3' () else X4' ())"
   14.23 -
   14.24 -primcorec inc_simple'' :: "nat \<Rightarrow> simple'' \<Rightarrow> simple''" where
   14.25 -  "inc_simple'' k s = (case s of X1'' n i \<Rightarrow> X1'' (n + k) (i + int k) | X2'' \<Rightarrow> X2'')"
   14.26 -
   14.27 -primcorec sinterleave :: "'a stream \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
   14.28 -  "sinterleave s s' = Stream (shd s) (sinterleave s' (stl s))"
   14.29 -
   14.30 -primcorec myapp :: "'a mylist \<Rightarrow> 'a mylist \<Rightarrow> 'a mylist" where
   14.31 -  "myapp xs ys =
   14.32 -     (if xs = MyNil then ys
   14.33 -      else if ys = MyNil then xs
   14.34 -      else MyCons (myhd xs) (myapp (mytl xs) ys))"
   14.35 -
   14.36 -primcorec shuffle_sp :: "('a \<Colon> ord, 'b \<Colon> ord, 'c, 'd) some_passive \<Rightarrow> ('d, 'a, 'b, 'c) some_passive" where
   14.37 -  "shuffle_sp sp =
   14.38 -     (case sp of
   14.39 -       SP1 sp' \<Rightarrow> SP1 (shuffle_sp sp')
   14.40 -     | SP2 a \<Rightarrow> SP3 a
   14.41 -     | SP3 b \<Rightarrow> SP4 b
   14.42 -     | SP4 c \<Rightarrow> SP5 c
   14.43 -     | SP5 d \<Rightarrow> SP2 d)"
   14.44 -
   14.45 -primcorec rename_lam :: "(string \<Rightarrow> string) \<Rightarrow> lambda \<Rightarrow> lambda" where
   14.46 -  "rename_lam f l =
   14.47 -     (case l of
   14.48 -       Var s \<Rightarrow> Var (f s)
   14.49 -     | App l l' \<Rightarrow> App (rename_lam f l) (rename_lam f l')
   14.50 -     | Abs s l \<Rightarrow> Abs (f s) (rename_lam f l)
   14.51 -     | Let SL l \<Rightarrow> Let (fimage (map_prod f (rename_lam f)) SL) (rename_lam f l))"
   14.52 -
   14.53 -primcorec
   14.54 -  j1_sum :: "('a\<Colon>{zero,one,plus}) \<Rightarrow> 'a J1" and
   14.55 -  j2_sum :: "'a \<Rightarrow> 'a J2"
   14.56 -where
   14.57 -  "n = 0 \<Longrightarrow> is_J11 (j1_sum n)" |
   14.58 -  "un_J111 (j1_sum _) = 0" |
   14.59 -  "un_J112 (j1_sum _) = j1_sum 0" |
   14.60 -  "un_J121 (j1_sum n) = n + 1" |
   14.61 -  "un_J122 (j1_sum n) = j2_sum (n + 1)" |
   14.62 -  "n = 0 \<Longrightarrow> j2_sum n = J21" |
   14.63 -  "un_J221 (j2_sum n) = j1_sum (n + 1)" |
   14.64 -  "un_J222 (j2_sum n) = j2_sum (n + 1)"
   14.65 -
   14.66 -primcorec forest_of_mylist :: "'a tree mylist \<Rightarrow> 'a forest" where
   14.67 -  "forest_of_mylist ts =
   14.68 -     (case ts of
   14.69 -       MyNil \<Rightarrow> FNil
   14.70 -     | MyCons t ts \<Rightarrow> FCons t (forest_of_mylist ts))"
   14.71 -
   14.72 -primcorec mylist_of_forest :: "'a forest \<Rightarrow> 'a tree mylist" where
   14.73 -  "mylist_of_forest f =
   14.74 -     (case f of
   14.75 -       FNil \<Rightarrow> MyNil
   14.76 -     | FCons t ts \<Rightarrow> MyCons t (mylist_of_forest ts))"
   14.77 -
   14.78 -primcorec semi_stream :: "'a stream \<Rightarrow> 'a stream" where
   14.79 -  "semi_stream s = Stream (shd s) (semi_stream (stl (stl s)))"
   14.80 -
   14.81 -primcorec
   14.82 -  tree'_of_stream :: "'a stream \<Rightarrow> 'a tree'" and
   14.83 -  branch_of_stream :: "'a stream \<Rightarrow> 'a branch"
   14.84 -where
   14.85 -  "tree'_of_stream s =
   14.86 -     TNode' (branch_of_stream (semi_stream s)) (branch_of_stream (semi_stream (stl s)))" |
   14.87 -  "branch_of_stream s = (case s of Stream h t \<Rightarrow> Branch h (tree'_of_stream t))"
   14.88 -
   14.89 -primcorec
   14.90 -  id_tree :: "'a bin_rose_tree \<Rightarrow> 'a bin_rose_tree" and
   14.91 -  id_trees1 :: "'a bin_rose_tree mylist \<Rightarrow> 'a bin_rose_tree mylist" and
   14.92 -  id_trees2 :: "'a bin_rose_tree mylist \<Rightarrow> 'a bin_rose_tree mylist"
   14.93 -where
   14.94 -  "id_tree t = (case t of BRTree a ts ts' \<Rightarrow> BRTree a (id_trees1 ts) (id_trees2 ts'))" |
   14.95 -  "id_trees1 ts = (case ts of
   14.96 -       MyNil \<Rightarrow> MyNil
   14.97 -     | MyCons t ts \<Rightarrow> MyCons (id_tree t) (id_trees1 ts))" |
   14.98 -  "id_trees2 ts = (case ts of
   14.99 -       MyNil \<Rightarrow> MyNil
  14.100 -     | MyCons t ts \<Rightarrow> MyCons (id_tree t) (id_trees2 ts))"
  14.101 -
  14.102 -primcorec
  14.103 -  trunc_tree :: "'a bin_rose_tree \<Rightarrow> 'a bin_rose_tree" and
  14.104 -  trunc_trees1 :: "'a bin_rose_tree mylist \<Rightarrow> 'a bin_rose_tree mylist" and
  14.105 -  trunc_trees2 :: "'a bin_rose_tree mylist \<Rightarrow> 'a bin_rose_tree mylist"
  14.106 -where
  14.107 -  "trunc_tree t = (case t of BRTree a ts ts' \<Rightarrow> BRTree a (trunc_trees1 ts) (trunc_trees2 ts'))" |
  14.108 -  "trunc_trees1 ts = (case ts of
  14.109 -       MyNil \<Rightarrow> MyNil
  14.110 -     | MyCons t _ \<Rightarrow> MyCons (trunc_tree t) MyNil)" |
  14.111 -  "trunc_trees2 ts = (case ts of
  14.112 -       MyNil \<Rightarrow> MyNil
  14.113 -     | MyCons t ts \<Rightarrow> MyCons (trunc_tree t) MyNil)"
  14.114 -
  14.115 -primcorec
  14.116 -  freeze_exp :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) exp \<Rightarrow> ('a, 'b) exp" and
  14.117 -  freeze_trm :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) trm \<Rightarrow> ('a, 'b) trm" and
  14.118 -  freeze_factor :: "('b \<Rightarrow> 'a) \<Rightarrow> ('a, 'b) factor \<Rightarrow> ('a, 'b) factor"
  14.119 -where
  14.120 -  "freeze_exp g e =
  14.121 -     (case e of
  14.122 -       Term t \<Rightarrow> Term (freeze_trm g t)
  14.123 -     | Sum t e \<Rightarrow> Sum (freeze_trm g t) (freeze_exp g e))" |
  14.124 -  "freeze_trm g t =
  14.125 -     (case t of
  14.126 -       Factor f \<Rightarrow> Factor (freeze_factor g f)
  14.127 -     | Prod f t \<Rightarrow> Prod (freeze_factor g f) (freeze_trm g t))" |
  14.128 -  "freeze_factor g f =
  14.129 -     (case f of
  14.130 -       C a \<Rightarrow> C a
  14.131 -     | V b \<Rightarrow> C (g b)
  14.132 -     | Paren e \<Rightarrow> Paren (freeze_exp g e))"
  14.133 -
  14.134 -primcorec poly_unity :: "'a poly_unit" where
  14.135 -  "poly_unity = U (\<lambda>_. poly_unity)"
  14.136 -
  14.137 -primcorec build_cps :: "('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> bool stream) \<Rightarrow> 'a \<Rightarrow> bool stream \<Rightarrow> 'a cps" where
  14.138 -  "shd b \<Longrightarrow> build_cps f g a b = CPS1 a" |
  14.139 -  "_ \<Longrightarrow> build_cps f g a b = CPS2 (\<lambda>a. build_cps f g (f a) (g a))"
  14.140 -
  14.141 -end
    15.1 --- a/src/HOL/BNF_Examples/Misc_Primrec.thy	Thu Sep 11 19:20:23 2014 +0200
    15.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    15.3 @@ -1,136 +0,0 @@
    15.4 -(*  Title:      HOL/BNF_Examples/Misc_Primrec.thy
    15.5 -    Author:     Jasmin Blanchette, TU Muenchen
    15.6 -    Copyright   2013
    15.7 -
    15.8 -Miscellaneous primitive recursive function definitions.
    15.9 -*)
   15.10 -
   15.11 -header {* Miscellaneous Primitive Recursive Function Definitions *}
   15.12 -
   15.13 -theory Misc_Primrec
   15.14 -imports Misc_Datatype
   15.15 -begin
   15.16 -
   15.17 -primrec nat_of_simple :: "simple \<Rightarrow> nat" where
   15.18 -  "nat_of_simple X1 = 1" |
   15.19 -  "nat_of_simple X2 = 2" |
   15.20 -  "nat_of_simple X3 = 3" |
   15.21 -  "nat_of_simple X4 = 4"
   15.22 -
   15.23 -primrec simple_of_simple' :: "simple' \<Rightarrow> simple" where
   15.24 -  "simple_of_simple' (X1' _) = X1" |
   15.25 -  "simple_of_simple' (X2' _) = X2" |
   15.26 -  "simple_of_simple' (X3' _) = X3" |
   15.27 -  "simple_of_simple' (X4' _) = X4"
   15.28 -
   15.29 -primrec inc_simple'' :: "nat \<Rightarrow> simple'' \<Rightarrow> simple''" where
   15.30 -  "inc_simple'' k (X1'' n i) = X1'' (n + k) (i + int k)" |
   15.31 -  "inc_simple'' _ X2'' = X2''"
   15.32 -
   15.33 -primrec myapp :: "'a mylist \<Rightarrow> 'a mylist \<Rightarrow> 'a mylist" where
   15.34 -  "myapp MyNil ys = ys" |
   15.35 -  "myapp (MyCons x xs) ys = MyCons x (myapp xs ys)"
   15.36 -
   15.37 -primrec myrev :: "'a mylist \<Rightarrow> 'a mylist" where
   15.38 -  "myrev MyNil = MyNil" |
   15.39 -  "myrev (MyCons x xs) = myapp (myrev xs) (MyCons x MyNil)"
   15.40 -
   15.41 -primrec shuffle_sp :: "('a \<Colon> ord, 'b \<Colon> ord, 'c, 'd) some_passive \<Rightarrow> ('d, 'a, 'b, 'c) some_passive" where
   15.42 -  "shuffle_sp (SP1 sp) = SP1 (shuffle_sp sp)" |
   15.43 -  "shuffle_sp (SP2 a) = SP3 a" |
   15.44 -  "shuffle_sp (SP3 b) = SP4 b" |
   15.45 -  "shuffle_sp (SP4 c) = SP5 c" |
   15.46 -  "shuffle_sp (SP5 d) = SP2 d"
   15.47 -
   15.48 -primrec
   15.49 -  hf_size :: "hfset \<Rightarrow> nat"
   15.50 -where
   15.51 -  "hf_size (HFset X) = 1 + setsum id (fset (fimage hf_size X))"
   15.52 -
   15.53 -primrec rename_lam :: "(string \<Rightarrow> string) \<Rightarrow> lambda \<Rightarrow> lambda" where
   15.54 -  "rename_lam f (Var s) = Var (f s)" |
   15.55 -  "rename_lam f (App l l') = App (rename_lam f l) (rename_lam f l')" |
   15.56 -  "rename_lam f (Abs s l) = Abs (f s) (rename_lam f l)" |
   15.57 -  "rename_lam f (Let SL l) = Let (fimage (map_prod f (rename_lam f)) SL) (rename_lam f l)"
   15.58 -
   15.59 -primrec
   15.60 -  sum_i1 :: "('a\<Colon>{zero,plus}) I1 \<Rightarrow> 'a" and
   15.61 -  sum_i2 :: "'a I2 \<Rightarrow> 'a"
   15.62 -where
   15.63 -  "sum_i1 (I11 n i) = n + sum_i1 i" |
   15.64 -  "sum_i1 (I12 n i) = n + sum_i2 i" |
   15.65 -  "sum_i2 I21 = 0" |
   15.66 -  "sum_i2 (I22 i j) = sum_i1 i + sum_i2 j"
   15.67 -
   15.68 -primrec forest_of_mylist :: "'a tree mylist \<Rightarrow> 'a forest" where
   15.69 -  "forest_of_mylist MyNil = FNil" |
   15.70 -  "forest_of_mylist (MyCons t ts) = FCons t (forest_of_mylist ts)"
   15.71 -
   15.72 -primrec mylist_of_forest :: "'a forest \<Rightarrow> 'a tree mylist" where
   15.73 -  "mylist_of_forest FNil = MyNil" |
   15.74 -  "mylist_of_forest (FCons t ts) = MyCons t (mylist_of_forest ts)"
   15.75 -
   15.76 -definition frev :: "'a forest \<Rightarrow> 'a forest" where
   15.77 -  "frev = forest_of_mylist \<circ> myrev \<circ> mylist_of_forest"
   15.78 -
   15.79 -primrec
   15.80 -  mirror_tree :: "'a tree \<Rightarrow> 'a tree" and
   15.81 -  mirror_forest :: "'a forest \<Rightarrow> 'a forest"
   15.82 -where
   15.83 -  "mirror_tree TEmpty = TEmpty" |
   15.84 -  "mirror_tree (TNode x ts) = TNode x (mirror_forest ts)" |
   15.85 -  "mirror_forest FNil = FNil" |
   15.86 -  "mirror_forest (FCons t ts) = frev (FCons (mirror_tree t) (mirror_forest ts))"
   15.87 -
   15.88 -primrec
   15.89 -  mylist_of_tree' :: "'a tree' \<Rightarrow> 'a mylist" and
   15.90 -  mylist_of_branch :: "'a branch \<Rightarrow> 'a mylist"
   15.91 -where
   15.92 -  "mylist_of_tree' TEmpty' = MyNil" |
   15.93 -  "mylist_of_tree' (TNode' b b') = myapp (mylist_of_branch b) (mylist_of_branch b')" |
   15.94 -  "mylist_of_branch (Branch x t) = MyCons x (mylist_of_tree' t)"
   15.95 -
   15.96 -primrec
   15.97 -  id_tree :: "'a bin_rose_tree \<Rightarrow> 'a bin_rose_tree" and
   15.98 -  id_trees1 :: "'a bin_rose_tree mylist \<Rightarrow> 'a bin_rose_tree mylist" and
   15.99 -  id_trees2 :: "'a bin_rose_tree mylist \<Rightarrow> 'a bin_rose_tree mylist"
  15.100 -where
  15.101 -  "id_tree (BRTree a ts ts') = BRTree a (id_trees1 ts) (id_trees2 ts')" |
  15.102 -  "id_trees1 MyNil = MyNil" |
  15.103 -  "id_trees1 (MyCons t ts) = MyCons (id_tree t) (id_trees1 ts)" |
  15.104 -  "id_trees2 MyNil = MyNil" |
  15.105 -  "id_trees2 (MyCons t ts) = MyCons (id_tree t) (id_trees2 ts)"
  15.106 -
  15.107 -primrec
  15.108 -  trunc_tree :: "'a bin_rose_tree \<Rightarrow> 'a bin_rose_tree" and
  15.109 -  trunc_trees1 :: "'a bin_rose_tree mylist \<Rightarrow> 'a bin_rose_tree mylist" and
  15.110 -  trunc_trees2 :: "'a bin_rose_tree mylist \<Rightarrow> 'a bin_rose_tree mylist"
  15.111 -where
  15.112 -  "trunc_tree (BRTree a ts ts') = BRTree a (trunc_trees1 ts) (trunc_trees2 ts')" |
  15.113 -  "trunc_trees1 MyNil = MyNil" |
  15.114 -  "trunc_trees1 (MyCons t ts) = MyCons (id_tree t) MyNil" |
  15.115 -  "trunc_trees2 MyNil = MyNil" |
  15.116 -  "trunc_trees2 (MyCons t ts) = MyCons (id_tree t) MyNil"
  15.117 -
  15.118 -primrec
  15.119 -  is_ground_exp :: "('a, 'b) exp \<Rightarrow> bool" and
  15.120 -  is_ground_trm :: "('a, 'b) trm \<Rightarrow> bool" and
  15.121 -  is_ground_factor :: "('a, 'b) factor \<Rightarrow> bool"
  15.122 -where
  15.123 -  "is_ground_exp (Term t) \<longleftrightarrow> is_ground_trm t" |
  15.124 -  "is_ground_exp (Sum t e) \<longleftrightarrow> is_ground_trm t \<and> is_ground_exp e" |
  15.125 -  "is_ground_trm (Factor f) \<longleftrightarrow> is_ground_factor f" |
  15.126 -  "is_ground_trm (Prod f t) \<longleftrightarrow> is_ground_factor f \<and> is_ground_trm t" |
  15.127 -  "is_ground_factor (C _) \<longleftrightarrow> True" |
  15.128 -  "is_ground_factor (V _) \<longleftrightarrow> False" |
  15.129 -  "is_ground_factor (Paren e) \<longleftrightarrow> is_ground_exp e"
  15.130 -
  15.131 -primrec map_ftreeA :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a ftree \<Rightarrow> 'a ftree" where
  15.132 -  "map_ftreeA f (FTLeaf x) = FTLeaf (f x)" |
  15.133 -  "map_ftreeA f (FTNode g) = FTNode (map_ftreeA f \<circ> g)"
  15.134 -
  15.135 -primrec map_ftreeB :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a ftree \<Rightarrow> 'b ftree" where
  15.136 -  "map_ftreeB f (FTLeaf x) = FTLeaf (f x)" |
  15.137 -  "map_ftreeB f (FTNode g) = FTNode (map_ftreeB f \<circ> g \<circ> the_inv f)"
  15.138 -
  15.139 -end
    16.1 --- a/src/HOL/BNF_Examples/Process.thy	Thu Sep 11 19:20:23 2014 +0200
    16.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.3 @@ -1,278 +0,0 @@
    16.4 -(*  Title:      HOL/BNF_Examples/Process.thy
    16.5 -    Author:     Andrei Popescu, TU Muenchen
    16.6 -    Copyright   2012
    16.7 -
    16.8 -Processes.
    16.9 -*)
   16.10 -
   16.11 -header {* Processes *}
   16.12 -
   16.13 -theory Process
   16.14 -imports Stream 
   16.15 -begin
   16.16 -
   16.17 -codatatype 'a process =
   16.18 -  isAction: Action (prefOf: 'a) (contOf: "'a process") |
   16.19 -  isChoice: Choice (ch1Of: "'a process") (ch2Of: "'a process")
   16.20 -
   16.21 -(* Read: prefix of, continuation of, choice 1 of, choice 2 of *)
   16.22 -
   16.23 -section {* Customization *}
   16.24 -
   16.25 -subsection {* Basic properties *}
   16.26 -
   16.27 -declare
   16.28 -  rel_pre_process_def[simp]
   16.29 -  rel_sum_def[simp]
   16.30 -  rel_prod_def[simp]
   16.31 -
   16.32 -(* Constructors versus discriminators *)
   16.33 -theorem isAction_isChoice:
   16.34 -"isAction p \<or> isChoice p"
   16.35 -by (rule process.exhaust_disc) auto
   16.36 -
   16.37 -theorem not_isAction_isChoice: "\<not> (isAction p \<and> isChoice p)"
   16.38 -by (cases rule: process.exhaust[of p]) auto
   16.39 -
   16.40 -
   16.41 -subsection{* Coinduction *}
   16.42 -
   16.43 -theorem process_coind[elim, consumes 1, case_names iss Action Choice, induct pred: "HOL.eq"]:
   16.44 -  assumes phi: "\<phi> p p'" and
   16.45 -  iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
   16.46 -  Act: "\<And> a a' p p'. \<phi> (Action a p) (Action a' p') \<Longrightarrow> a = a' \<and> \<phi> p p'" and
   16.47 -  Ch: "\<And> p q p' q'. \<phi> (Choice p q) (Choice p' q') \<Longrightarrow> \<phi> p p' \<and> \<phi> q q'"
   16.48 -  shows "p = p'"
   16.49 -  using assms
   16.50 -  by (coinduct rule: process.coinduct) (metis process.collapse(1,2) process.disc(3))
   16.51 -
   16.52 -(* Stronger coinduction, up to equality: *)
   16.53 -theorem process_strong_coind[elim, consumes 1, case_names iss Action Choice]:
   16.54 -  assumes phi: "\<phi> p p'" and
   16.55 -  iss: "\<And>p p'. \<phi> p p' \<Longrightarrow> (isAction p \<longleftrightarrow> isAction p') \<and> (isChoice p \<longleftrightarrow> isChoice p')" and
   16.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
   16.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')"
   16.58 -  shows "p = p'"
   16.59 -  using assms
   16.60 -  by (coinduct rule: process.coinduct_strong) (metis process.collapse(1,2) process.disc(3))
   16.61 -
   16.62 -
   16.63 -subsection {* Coiteration (unfold) *}
   16.64 -
   16.65 -
   16.66 -section{* Coinductive definition of the notion of trace *}
   16.67 -coinductive trace where
   16.68 -"trace p as \<Longrightarrow> trace (Action a p) (a ## as)"
   16.69 -|
   16.70 -"trace p as \<or> trace q as \<Longrightarrow> trace (Choice p q) as"
   16.71 -
   16.72 -
   16.73 -section{* Examples of corecursive definitions: *}
   16.74 -
   16.75 -subsection{* Single-guard fixpoint definition *}
   16.76 -
   16.77 -primcorec BX where
   16.78 -  "isAction BX"
   16.79 -| "prefOf BX = ''a''"
   16.80 -| "contOf BX = BX"
   16.81 -
   16.82 -
   16.83 -subsection{* Multi-guard fixpoint definitions, simulated with auxiliary arguments *}
   16.84 -
   16.85 -datatype_new x_y_ax = x | y | ax
   16.86 -
   16.87 -primcorec F :: "x_y_ax \<Rightarrow> char list process" where
   16.88 -  "xyax = x \<Longrightarrow> isChoice (F xyax)"
   16.89 -| "ch1Of (F xyax) = F ax"
   16.90 -| "ch2Of (F xyax) = F y"
   16.91 -| "prefOf (F xyax) = (if xyax = y then ''b'' else ''a'')"
   16.92 -| "contOf (F xyax) = F x"
   16.93 -
   16.94 -definition "X = F x"  definition "Y = F y"  definition "AX = F ax"
   16.95 -
   16.96 -lemma X_Y_AX: "X = Choice AX Y"  "Y = Action ''b'' X"  "AX = Action ''a'' X"
   16.97 -unfolding X_def Y_def AX_def by (subst F.code, simp)+
   16.98 -
   16.99 -(* end product: *)
  16.100 -lemma X_AX:
  16.101 -"X = Choice AX (Action ''b'' X)"
  16.102 -"AX = Action ''a'' X"
  16.103 -using X_Y_AX by simp_all
  16.104 -
  16.105 -
  16.106 -
  16.107 -section{* Case study: Multi-guard fixpoint definitions, without auxiliary arguments *}
  16.108 -
  16.109 -hide_const x y ax X Y AX
  16.110 -
  16.111 -(* Process terms *)
  16.112 -datatype_new ('a,'pvar) process_term =
  16.113 - VAR 'pvar |
  16.114 - PROC "'a process" |
  16.115 - ACT 'a "('a,'pvar) process_term" | CH "('a,'pvar) process_term" "('a,'pvar) process_term"
  16.116 -
  16.117 -(* below, sys represents a system of equations *)
  16.118 -fun isACT where
  16.119 -"isACT sys (VAR X) =
  16.120 - (case sys X of ACT a T \<Rightarrow> True |PROC p \<Rightarrow> isAction p |_ \<Rightarrow> False)"
  16.121 -|
  16.122 -"isACT sys (PROC p) = isAction p"
  16.123 -|
  16.124 -"isACT sys (ACT a T) = True"
  16.125 -|
  16.126 -"isACT sys (CH T1 T2) = False"
  16.127 -
  16.128 -fun PREF where
  16.129 -"PREF sys (VAR X) =
  16.130 - (case sys X of ACT a T \<Rightarrow> a | PROC p \<Rightarrow> prefOf p)"
  16.131 -|
  16.132 -"PREF sys (PROC p) = prefOf p"
  16.133 -|
  16.134 -"PREF sys (ACT a T) = a"
  16.135 -
  16.136 -fun CONT where
  16.137 -"CONT sys (VAR X) =
  16.138 - (case sys X of ACT a T \<Rightarrow> T | PROC p \<Rightarrow> PROC (contOf p))"
  16.139 -|
  16.140 -"CONT sys (PROC p) = PROC (contOf p)"
  16.141 -|
  16.142 -"CONT sys (ACT a T) = T"
  16.143 -
  16.144 -fun CH1 where
  16.145 -"CH1 sys (VAR X) =
  16.146 - (case sys X of CH T1 T2 \<Rightarrow> T1 |PROC p \<Rightarrow> PROC (ch1Of p))"
  16.147 -|
  16.148 -"CH1 sys (PROC p) = PROC (ch1Of p)"
  16.149 -|
  16.150 -"CH1 sys (CH T1 T2) = T1"
  16.151 -
  16.152 -fun CH2 where
  16.153 -"CH2 sys (VAR X) =
  16.154 - (case sys X of CH T1 T2 \<Rightarrow> T2 |PROC p \<Rightarrow> PROC (ch2Of p))"
  16.155 -|
  16.156 -"CH2 sys (PROC p) = PROC (ch2Of p)"
  16.157 -|
  16.158 -"CH2 sys (CH T1 T2) = T2"
  16.159 -
  16.160 -definition "guarded sys \<equiv> \<forall> X Y. sys X \<noteq> VAR Y"
  16.161 -
  16.162 -primcorec solution where
  16.163 -  "isACT sys T \<Longrightarrow> solution sys T = Action (PREF sys T) (solution sys (CONT sys T))"
  16.164 -| "_ \<Longrightarrow> solution sys T = Choice (solution sys (CH1 sys T)) (solution sys (CH2 sys T))"
  16.165 -
  16.166 -lemma isACT_VAR:
  16.167 -assumes g: "guarded sys"
  16.168 -shows "isACT sys (VAR X) \<longleftrightarrow> isACT sys (sys X)"
  16.169 -using g unfolding guarded_def by (cases "sys X") auto
  16.170 -
  16.171 -lemma solution_VAR:
  16.172 -assumes g: "guarded sys"
  16.173 -shows "solution sys (VAR X) = solution sys (sys X)"
  16.174 -proof(cases "isACT sys (VAR X)")
  16.175 -  case True
  16.176 -  hence T: "isACT sys (sys X)" unfolding isACT_VAR[OF g] .
  16.177 -  show ?thesis
  16.178 -  unfolding solution.ctr(1)[OF T] using solution.ctr(1)[of sys "VAR X"] True g
  16.179 -  unfolding guarded_def by (cases "sys X", auto)
  16.180 -next
  16.181 -  case False note FFalse = False
  16.182 -  hence TT: "\<not> isACT sys (sys X)" unfolding isACT_VAR[OF g] .
  16.183 -  show ?thesis
  16.184 -  unfolding solution.ctr(2)[OF TT] using solution.ctr(2)[of sys "VAR X"] FFalse g
  16.185 -  unfolding guarded_def by (cases "sys X", auto)
  16.186 -qed
  16.187 -
  16.188 -lemma solution_PROC[simp]:
  16.189 -"solution sys (PROC p) = p"
  16.190 -proof-
  16.191 -  {fix q assume "q = solution sys (PROC p)"
  16.192 -   hence "p = q"
  16.193 -   proof (coinduct rule: process_coind)
  16.194 -     case (iss p p')
  16.195 -     from isAction_isChoice[of p] show ?case
  16.196 -     proof
  16.197 -       assume p: "isAction p"
  16.198 -       hence 0: "isACT sys (PROC p)" by simp
  16.199 -       thus ?thesis using iss not_isAction_isChoice by auto
  16.200 -     next
  16.201 -       assume "isChoice p"
  16.202 -       hence 0: "\<not> isACT sys (PROC p)"
  16.203 -       using not_isAction_isChoice by auto
  16.204 -       thus ?thesis using iss isAction_isChoice by auto
  16.205 -     qed
  16.206 -   next
  16.207 -     case (Action a a' p p')
  16.208 -     hence 0: "isACT sys (PROC (Action a p))" by simp
  16.209 -     show ?case using Action unfolding solution.ctr(1)[OF 0] by simp
  16.210 -   next
  16.211 -     case (Choice p q p' q')
  16.212 -     hence 0: "\<not> isACT sys (PROC (Choice p q))" using not_isAction_isChoice by auto
  16.213 -     show ?case using Choice unfolding solution.ctr(2)[OF 0] by simp
  16.214 -   qed
  16.215 -  }
  16.216 -  thus ?thesis by metis
  16.217 -qed
  16.218 -
  16.219 -lemma solution_ACT[simp]:
  16.220 -"solution sys (ACT a T) = Action a (solution sys T)"
  16.221 -by (metis CONT.simps(3) PREF.simps(3) isACT.simps(3) solution.ctr(1))
  16.222 -
  16.223 -lemma solution_CH[simp]:
  16.224 -"solution sys (CH T1 T2) = Choice (solution sys T1) (solution sys T2)"
  16.225 -by (metis CH1.simps(3) CH2.simps(3) isACT.simps(4) solution.ctr(2))
  16.226 -
  16.227 -
  16.228 -(* Example: *)
  16.229 -
  16.230 -fun sys where
  16.231 -"sys 0 = CH (VAR (Suc 0)) (ACT ''b'' (VAR 0))"
  16.232 -|
  16.233 -"sys (Suc 0) = ACT ''a'' (VAR 0)"
  16.234 -| (* dummy guarded term for variables outside the system: *)
  16.235 -"sys X = ACT ''a'' (VAR 0)"
  16.236 -
  16.237 -lemma guarded_sys:
  16.238 -"guarded sys"
  16.239 -unfolding guarded_def proof (intro allI)
  16.240 -  fix X Y show "sys X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
  16.241 -qed
  16.242 -
  16.243 -(* the actual processes: *)
  16.244 -definition "x \<equiv> solution sys (VAR 0)"
  16.245 -definition "ax \<equiv> solution sys (VAR (Suc 0))"
  16.246 -
  16.247 -(* end product: *)
  16.248 -lemma x_ax:
  16.249 -"x = Choice ax (Action ''b'' x)"
  16.250 -"ax = Action ''a'' x"
  16.251 -unfolding x_def ax_def by (subst solution_VAR[OF guarded_sys], simp)+
  16.252 -
  16.253 -
  16.254 -(* Thanks to the inclusion of processes as process terms, one can
  16.255 -also consider parametrized systems of equations---here, x is a (semantic)
  16.256 -process parameter: *)
  16.257 -
  16.258 -fun sys' where
  16.259 -"sys' 0 = CH (PROC x) (ACT ''b'' (VAR 0))"
  16.260 -|
  16.261 -"sys' (Suc 0) = CH (ACT ''a'' (VAR 0)) (PROC x)"
  16.262 -| (* dummy guarded term : *)
  16.263 -"sys' X = ACT ''a'' (VAR 0)"
  16.264 -
  16.265 -lemma guarded_sys':
  16.266 -"guarded sys'"
  16.267 -unfolding guarded_def proof (intro allI)
  16.268 -  fix X Y show "sys' X \<noteq> VAR Y" by (cases X, simp, case_tac nat, auto)
  16.269 -qed
  16.270 -
  16.271 -(* the actual processes: *)
  16.272 -definition "y \<equiv> solution sys' (VAR 0)"
  16.273 -definition "ay \<equiv> solution sys' (VAR (Suc 0))"
  16.274 -
  16.275 -(* end product: *)
  16.276 -lemma y_ay:
  16.277 -"y = Choice x (Action ''b'' y)"
  16.278 -"ay = Choice (Action ''a'' y) x"
  16.279 -unfolding y_def ay_def by (subst solution_VAR[OF guarded_sys'], simp)+
  16.280 -
  16.281 -end
    17.1 --- a/src/HOL/BNF_Examples/SML.thy	Thu Sep 11 19:20:23 2014 +0200
    17.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.3 @@ -1,91 +0,0 @@
    17.4 -(*  Title:      HOL/Datatype_Benchmark/SML.thy
    17.5 -
    17.6 -Example from Myra: part of the syntax of SML.
    17.7 -*)
    17.8 -
    17.9 -theory SML imports Main begin
   17.10 -
   17.11 -datatype
   17.12 -  string = EMPTY_STRING | CONS_STRING nat string
   17.13 -
   17.14 -datatype
   17.15 -   strid = STRID string
   17.16 -
   17.17 -datatype
   17.18 -   var = VAR string
   17.19 -
   17.20 -datatype
   17.21 -   con = CON string
   17.22 -
   17.23 -datatype
   17.24 -   scon = SCINT nat | SCSTR string
   17.25 -
   17.26 -datatype
   17.27 -   excon = EXCON string
   17.28 -
   17.29 -datatype
   17.30 -   label = LABEL string
   17.31 -
   17.32 -datatype
   17.33 -  'a nonemptylist = Head_and_tail 'a "'a list"
   17.34 -
   17.35 -datatype
   17.36 -  'a long = BASE 'a | QUALIFIED strid "'a long"
   17.37 -
   17.38 -datatype
   17.39 -   atpat_e = WILDCARDatpat_e
   17.40 -           | SCONatpat_e scon
   17.41 -           | VARatpat_e var
   17.42 -           | CONatpat_e "con long"
   17.43 -           | EXCONatpat_e "excon long"
   17.44 -           | RECORDatpat_e "patrow_e option"
   17.45 -           | PARatpat_e pat_e
   17.46 -and
   17.47 -   patrow_e = DOTDOTDOT_e
   17.48 -            | PATROW_e label pat_e "patrow_e option"
   17.49 -and
   17.50 -   pat_e = ATPATpat_e atpat_e
   17.51 -         | CONpat_e "con long" atpat_e
   17.52 -         | EXCONpat_e "excon long" atpat_e
   17.53 -         | LAYEREDpat_e var pat_e
   17.54 -and
   17.55 -   conbind_e = CONBIND_e con "conbind_e option"
   17.56 -and
   17.57 -   datbind_e = DATBIND_e conbind_e "datbind_e option"
   17.58 -and
   17.59 -   exbind_e = EXBIND1_e excon "exbind_e option"
   17.60 -            | EXBIND2_e excon "excon long" "exbind_e option"
   17.61 -and
   17.62 -   atexp_e = SCONatexp_e scon
   17.63 -           | VARatexp_e "var long"
   17.64 -           | CONatexp_e "con long"
   17.65 -           | EXCONatexp_e "excon long"
   17.66 -           | RECORDatexp_e "exprow_e option"
   17.67 -           | LETatexp_e dec_e exp_e
   17.68 -           | PARatexp_e exp_e
   17.69 -and
   17.70 -   exprow_e = EXPROW_e label exp_e "exprow_e option"
   17.71 -and
   17.72 -   exp_e = ATEXPexp_e atexp_e
   17.73 -         | APPexp_e exp_e atexp_e
   17.74 -         | HANDLEexp_e exp_e match_e
   17.75 -         | RAISEexp_e exp_e
   17.76 -         | FNexp_e match_e
   17.77 -and
   17.78 -   match_e = MATCH_e mrule_e "match_e option"
   17.79 -and
   17.80 -   mrule_e = MRULE_e pat_e exp_e
   17.81 -and
   17.82 -   dec_e = VALdec_e valbind_e
   17.83 -         | DATATYPEdec_e datbind_e
   17.84 -         | ABSTYPEdec_e datbind_e dec_e
   17.85 -         | EXCEPTdec_e exbind_e
   17.86 -         | LOCALdec_e dec_e dec_e
   17.87 -         | OPENdec_e "strid long nonemptylist"
   17.88 -         | EMPTYdec_e
   17.89 -         | SEQdec_e dec_e dec_e
   17.90 -and
   17.91 -   valbind_e = PLAINvalbind_e pat_e exp_e "valbind_e option"
   17.92 -             | RECvalbind_e valbind_e
   17.93 -
   17.94 -end
    18.1 --- a/src/HOL/BNF_Examples/Stream.thy	Thu Sep 11 19:20:23 2014 +0200
    18.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.3 @@ -1,582 +0,0 @@
    18.4 -(*  Title:      HOL/BNF_Examples/Stream.thy
    18.5 -    Author:     Dmitriy Traytel, TU Muenchen
    18.6 -    Author:     Andrei Popescu, TU Muenchen
    18.7 -    Copyright   2012, 2013
    18.8 -
    18.9 -Infinite streams.
   18.10 -*)
   18.11 -
   18.12 -header {* Infinite Streams *}
   18.13 -
   18.14 -theory Stream
   18.15 -imports "~~/src/HOL/Library/Nat_Bijection"
   18.16 -begin
   18.17 -
   18.18 -codatatype (sset: 'a) stream =
   18.19 -  SCons (shd: 'a) (stl: "'a stream") (infixr "##" 65)
   18.20 -for
   18.21 -  map: smap
   18.22 -  rel: stream_all2
   18.23 -
   18.24 -(*for code generation only*)
   18.25 -definition smember :: "'a \<Rightarrow> 'a stream \<Rightarrow> bool" where
   18.26 -  [code_abbrev]: "smember x s \<longleftrightarrow> x \<in> sset s"
   18.27 -
   18.28 -lemma smember_code[code, simp]: "smember x (y ## s) = (if x = y then True else smember x s)"
   18.29 -  unfolding smember_def by auto
   18.30 -
   18.31 -hide_const (open) smember
   18.32 -
   18.33 -lemmas smap_simps[simp] = stream.map_sel
   18.34 -lemmas shd_sset = stream.set_sel(1)
   18.35 -lemmas stl_sset = stream.set_sel(2)
   18.36 -
   18.37 -theorem sset_induct[consumes 1, case_names shd stl, induct set: sset]:
   18.38 -  assumes "y \<in> sset s" and "\<And>s. P (shd s) s" and "\<And>s y. \<lbrakk>y \<in> sset (stl s); P y (stl s)\<rbrakk> \<Longrightarrow> P y s"
   18.39 -  shows "P y s"
   18.40 -using assms by induct (metis stream.sel(1), auto)
   18.41 -
   18.42 -
   18.43 -subsection {* prepend list to stream *}
   18.44 -
   18.45 -primrec shift :: "'a list \<Rightarrow> 'a stream \<Rightarrow> 'a stream" (infixr "@-" 65) where
   18.46 -  "shift [] s = s"
   18.47 -| "shift (x # xs) s = x ## shift xs s"
   18.48 -
   18.49 -lemma smap_shift[simp]: "smap f (xs @- s) = map f xs @- smap f s"
   18.50 -  by (induct xs) auto
   18.51 -
   18.52 -lemma shift_append[simp]: "(xs @ ys) @- s = xs @- ys @- s"
   18.53 -  by (induct xs) auto
   18.54 -
   18.55 -lemma shift_simps[simp]:
   18.56 -   "shd (xs @- s) = (if xs = [] then shd s else hd xs)"
   18.57 -   "stl (xs @- s) = (if xs = [] then stl s else tl xs @- s)"
   18.58 -  by (induct xs) auto
   18.59 -
   18.60 -lemma sset_shift[simp]: "sset (xs @- s) = set xs \<union> sset s"
   18.61 -  by (induct xs) auto
   18.62 -
   18.63 -lemma shift_left_inj[simp]: "xs @- s1 = xs @- s2 \<longleftrightarrow> s1 = s2"
   18.64 -  by (induct xs) auto
   18.65 -
   18.66 -
   18.67 -subsection {* set of streams with elements in some fixed set *}
   18.68 -
   18.69 -coinductive_set
   18.70 -  streams :: "'a set \<Rightarrow> 'a stream set"
   18.71 -  for A :: "'a set"
   18.72 -where
   18.73 -  Stream[intro!, simp, no_atp]: "\<lbrakk>a \<in> A; s \<in> streams A\<rbrakk> \<Longrightarrow> a ## s \<in> streams A"
   18.74 -
   18.75 -lemma shift_streams: "\<lbrakk>w \<in> lists A; s \<in> streams A\<rbrakk> \<Longrightarrow> w @- s \<in> streams A"
   18.76 -  by (induct w) auto
   18.77 -
   18.78 -lemma streams_Stream: "x ## s \<in> streams A \<longleftrightarrow> x \<in> A \<and> s \<in> streams A"
   18.79 -  by (auto elim: streams.cases)
   18.80 -
   18.81 -lemma streams_stl: "s \<in> streams A \<Longrightarrow> stl s \<in> streams A"
   18.82 -  by (cases s) (auto simp: streams_Stream)
   18.83 -
   18.84 -lemma streams_shd: "s \<in> streams A \<Longrightarrow> shd s \<in> A"
   18.85 -  by (cases s) (auto simp: streams_Stream)
   18.86 -
   18.87 -lemma sset_streams:
   18.88 -  assumes "sset s \<subseteq> A"
   18.89 -  shows "s \<in> streams A"
   18.90 -using assms proof (coinduction arbitrary: s)
   18.91 -  case streams then show ?case by (cases s) simp
   18.92 -qed
   18.93 -
   18.94 -lemma streams_sset:
   18.95 -  assumes "s \<in> streams A"
   18.96 -  shows "sset s \<subseteq> A"
   18.97 -proof
   18.98 -  fix x assume "x \<in> sset s" from this `s \<in> streams A` show "x \<in> A"
   18.99 -    by (induct s) (auto intro: streams_shd streams_stl)
  18.100 -qed
  18.101 -
  18.102 -lemma streams_iff_sset: "s \<in> streams A \<longleftrightarrow> sset s \<subseteq> A"
  18.103 -  by (metis sset_streams streams_sset)
  18.104 -
  18.105 -lemma streams_mono:  "s \<in> streams A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> s \<in> streams B"
  18.106 -  unfolding streams_iff_sset by auto
  18.107 -
  18.108 -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"
  18.109 -  unfolding streams_iff_sset stream.set_map by auto
  18.110 -
  18.111 -lemma streams_empty: "streams {} = {}"
  18.112 -  by (auto elim: streams.cases)
  18.113 -
  18.114 -lemma streams_UNIV[simp]: "streams UNIV = UNIV"
  18.115 -  by (auto simp: streams_iff_sset)
  18.116 -
  18.117 -subsection {* nth, take, drop for streams *}
  18.118 -
  18.119 -primrec snth :: "'a stream \<Rightarrow> nat \<Rightarrow> 'a" (infixl "!!" 100) where
  18.120 -  "s !! 0 = shd s"
  18.121 -| "s !! Suc n = stl s !! n"
  18.122 -
  18.123 -lemma snth_smap[simp]: "smap f s !! n = f (s !! n)"
  18.124 -  by (induct n arbitrary: s) auto
  18.125 -
  18.126 -lemma shift_snth_less[simp]: "p < length xs \<Longrightarrow> (xs @- s) !! p = xs ! p"
  18.127 -  by (induct p arbitrary: xs) (auto simp: hd_conv_nth nth_tl)
  18.128 -
  18.129 -lemma shift_snth_ge[simp]: "p \<ge> length xs \<Longrightarrow> (xs @- s) !! p = s !! (p - length xs)"
  18.130 -  by (induct p arbitrary: xs) (auto simp: Suc_diff_eq_diff_pred)
  18.131 -
  18.132 -lemma shift_snth: "(xs @- s) !! n = (if n < length xs then xs ! n else s !! (n - length xs))"
  18.133 -  by auto
  18.134 -
  18.135 -lemma snth_sset[simp]: "s !! n \<in> sset s"
  18.136 -  by (induct n arbitrary: s) (auto intro: shd_sset stl_sset)
  18.137 -
  18.138 -lemma sset_range: "sset s = range (snth s)"
  18.139 -proof (intro equalityI subsetI)
  18.140 -  fix x assume "x \<in> sset s"
  18.141 -  thus "x \<in> range (snth s)"
  18.142 -  proof (induct s)
  18.143 -    case (stl s x)
  18.144 -    then obtain n where "x = stl s !! n" by auto
  18.145 -    thus ?case by (auto intro: range_eqI[of _ _ "Suc n"])
  18.146 -  qed (auto intro: range_eqI[of _ _ 0])
  18.147 -qed auto
  18.148 -
  18.149 -primrec stake :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a list" where
  18.150 -  "stake 0 s = []"
  18.151 -| "stake (Suc n) s = shd s # stake n (stl s)"
  18.152 -
  18.153 -lemma length_stake[simp]: "length (stake n s) = n"
  18.154 -  by (induct n arbitrary: s) auto
  18.155 -
  18.156 -lemma stake_smap[simp]: "stake n (smap f s) = map f (stake n s)"
  18.157 -  by (induct n arbitrary: s) auto
  18.158 -
  18.159 -lemma take_stake: "take n (stake m s) = stake (min n m) s"
  18.160 -proof (induct m arbitrary: s n)
  18.161 -  case (Suc m) thus ?case by (cases n) auto
  18.162 -qed simp
  18.163 -
  18.164 -primrec sdrop :: "nat \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where
  18.165 -  "sdrop 0 s = s"
  18.166 -| "sdrop (Suc n) s = sdrop n (stl s)"
  18.167 -
  18.168 -lemma sdrop_simps[simp]:
  18.169 -  "shd (sdrop n s) = s !! n" "stl (sdrop n s) = sdrop (Suc n) s"
  18.170 -  by (induct n arbitrary: s)  auto
  18.171 -
  18.172 -lemma sdrop_smap[simp]: "sdrop n (smap f s) = smap f (sdrop n s)"
  18.173 -  by (induct n arbitrary: s) auto
  18.174 -
  18.175 -lemma sdrop_stl: "sdrop n (stl s) = stl (sdrop n s)"
  18.176 -  by (induct n) auto
  18.177 -
  18.178 -lemma drop_stake: "drop n (stake m s) = stake (m - n) (sdrop n s)"
  18.179 -proof (induct m arbitrary: s n)
  18.180 -  case (Suc m) thus ?case by (cases n) auto
  18.181 -qed simp
  18.182 -
  18.183 -lemma stake_sdrop: "stake n s @- sdrop n s = s"
  18.184 -  by (induct n arbitrary: s) auto
  18.185 -
  18.186 -lemma id_stake_snth_sdrop:
  18.187 -  "s = stake i s @- s !! i ## sdrop (Suc i) s"
  18.188 -  by (subst stake_sdrop[symmetric, of _ i]) (metis sdrop_simps stream.collapse)
  18.189 -
  18.190 -lemma smap_alt: "smap f s = s' \<longleftrightarrow> (\<forall>n. f (s !! n) = s' !! n)" (is "?L = ?R")
  18.191 -proof
  18.192 -  assume ?R
  18.193 -  then have "\<And>n. smap f (sdrop n s) = sdrop n s'"
  18.194 -    by coinduction (auto intro: exI[of _ 0] simp del: sdrop.simps(2))
  18.195 -  then show ?L using sdrop.simps(1) by metis
  18.196 -qed auto
  18.197 -
  18.198 -lemma stake_invert_Nil[iff]: "stake n s = [] \<longleftrightarrow> n = 0"
  18.199 -  by (induct n) auto
  18.200 -
  18.201 -lemma sdrop_shift: "sdrop i (w @- s) = drop i w @- sdrop (i - length w) s"
  18.202 -  by (induct i arbitrary: w s) (auto simp: drop_tl drop_Suc neq_Nil_conv)
  18.203 -
  18.204 -lemma stake_shift: "stake i (w @- s) = take i w @ stake (i - length w) s"
  18.205 -  by (induct i arbitrary: w s) (auto simp: neq_Nil_conv)
  18.206 -
  18.207 -lemma stake_add[simp]: "stake m s @ stake n (sdrop m s) = stake (m + n) s"
  18.208 -  by (induct m arbitrary: s) auto
  18.209 -
  18.210 -lemma sdrop_add[simp]: "sdrop n (sdrop m s) = sdrop (m + n) s"
  18.211 -  by (induct m arbitrary: s) auto
  18.212 -
  18.213 -lemma sdrop_snth: "sdrop n s !! m = s !! (n + m)"
  18.214 -  by (induct n arbitrary: m s) auto
  18.215 -
  18.216 -partial_function (tailrec) sdrop_while :: "('a \<Rightarrow> bool) \<Rightarrow> 'a stream \<Rightarrow> 'a stream" where 
  18.217 -  "sdrop_while P s = (if P (shd s) then sdrop_while P (stl s) else s)"
  18.218 -
  18.219 -lemma sdrop_while_SCons[code]:
  18.220 -  "sdrop_while P (a ## s) = (if P a then sdrop_while P s else a ## s)"
  18.221 -  by (subst sdrop_while.simps) simp
  18.222 -
  18.223 -lemma sdrop_while_sdrop_LEAST:
  18.224 -  assumes "\<exists>n. P (s !! n)"
  18.225 -  shows "sdrop_while (Not o P) s = sdrop (LEAST n. P (s !! n)) s"
  18.226 -proof -
  18.227 -  from assms obtain m where "P (s !! m)" "\<And>n. P (s !! n) \<Longrightarrow> m \<le> n"
  18.228 -    and *: "(LEAST n. P (s !! n)) = m" by atomize_elim (auto intro: LeastI Least_le)
  18.229 -  thus ?thesis unfolding *
  18.230 -  proof (induct m arbitrary: s)
  18.231 -    case (Suc m)
  18.232 -    hence "sdrop_while (Not \<circ> P) (stl s) = sdrop m (stl s)"
  18.233 -      by (metis (full_types) not_less_eq_eq snth.simps(2))
  18.234 -    moreover from Suc(3) have "\<not> (P (s !! 0))" by blast
  18.235 -    ultimately show ?case by (subst sdrop_while.simps) simp
  18.236 -  qed (metis comp_apply sdrop.simps(1) sdrop_while.simps snth.simps(1))
  18.237 -qed
  18.238 -
  18.239 -primcorec sfilter where
  18.240 -  "shd (sfilter P s) = shd (sdrop_while (Not o P) s)"
  18.241 -| "stl (sfilter P s) = sfilter P (stl (sdrop_while (Not o P) s))"
  18.242 -
  18.243 -lemma sfilter_Stream: "sfilter P (x ## s) = (if P x then x ## sfilter P s else sfilter P s)"
  18.244 -proof (cases "P x")
  18.245 -  case True thus ?thesis by (subst sfilter.ctr) (simp add: sdrop_while_SCons)
  18.246 -next
  18.247 -  case False thus ?thesis by (subst (1 2) sfilter.ctr) (simp add: sdrop_while_SCons)
  18.248 -qed
  18.249 -
  18.250 -
  18.251 -subsection {* unary predicates lifted to streams *}
  18.252 -
  18.253 -definition "stream_all P s = (\<forall>p. P (s !! p))"
  18.254 -
  18.255 -lemma stream_all_iff[iff]: "stream_all P s \<longleftrightarrow> Ball (sset s) P"
  18.256 -  unfolding stream_all_def sset_range by auto
  18.257 -
  18.258 -lemma stream_all_shift[simp]: "stream_all P (xs @- s) = (list_all P xs \<and> stream_all P s)"
  18.259 -  unfolding stream_all_iff list_all_iff by auto
  18.260 -
  18.261 -lemma stream_all_Stream: "stream_all P (x ## X) \<longleftrightarrow> P x \<and> stream_all P X"
  18.262 -  by simp
  18.263 -
  18.264 -
  18.265 -subsection {* recurring stream out of a list *}
  18.266 -
  18.267 -primcorec cycle :: "'a list \<Rightarrow> 'a stream" where
  18.268 -  "shd (cycle xs) = hd xs"
  18.269 -| "stl (cycle xs) = cycle (tl xs @ [hd xs])"
  18.270 -
  18.271 -lemma cycle_decomp: "u \<noteq> [] \<Longrightarrow> cycle u = u @- cycle u"
  18.272 -proof (coinduction arbitrary: u)
  18.273 -  case Eq_stream then show ?case using stream.collapse[of "cycle u"]
  18.274 -    by (auto intro!: exI[of _ "tl u @ [hd u]"])
  18.275 -qed
  18.276 -
  18.277 -lemma cycle_Cons[code]: "cycle (x # xs) = x ## cycle (xs @ [x])"
  18.278 -  by (subst cycle.ctr) simp
  18.279 -
  18.280 -lemma cycle_rotated: "\<lbrakk>v \<noteq> []; cycle u = v @- s\<rbrakk> \<Longrightarrow> cycle (tl u @ [hd u]) = tl v @- s"
  18.281 -  by (auto dest: arg_cong[of _ _ stl])
  18.282 -
  18.283 -lemma stake_append: "stake n (u @- s) = take (min (length u) n) u @ stake (n - length u) s"
  18.284 -proof (induct n arbitrary: u)
  18.285 -  case (Suc n) thus ?case by (cases u) auto
  18.286 -qed auto
  18.287 -
  18.288 -lemma stake_cycle_le[simp]:
  18.289 -  assumes "u \<noteq> []" "n < length u"
  18.290 -  shows "stake n (cycle u) = take n u"
  18.291 -using min_absorb2[OF less_imp_le_nat[OF assms(2)]]
  18.292 -  by (subst cycle_decomp[OF assms(1)], subst stake_append) auto
  18.293 -
  18.294 -lemma stake_cycle_eq[simp]: "u \<noteq> [] \<Longrightarrow> stake (length u) (cycle u) = u"
  18.295 -  by (subst cycle_decomp) (auto simp: stake_shift)
  18.296 -
  18.297 -lemma sdrop_cycle_eq[simp]: "u \<noteq> [] \<Longrightarrow> sdrop (length u) (cycle u) = cycle u"
  18.298 -  by (subst cycle_decomp) (auto simp: sdrop_shift)
  18.299 -
  18.300 -lemma stake_cycle_eq_mod_0[simp]: "\<lbrakk>u \<noteq> []; n mod length u = 0\<rbrakk> \<Longrightarrow>
  18.301 -   stake n (cycle u) = concat (replicate (n div length u) u)"
  18.302 -  by (induct "n div length u" arbitrary: n u) (auto simp: stake_add[symmetric])
  18.303 -
  18.304 -lemma sdrop_cycle_eq_mod_0[simp]: "\<lbrakk>u \<noteq> []; n mod length u = 0\<rbrakk> \<Longrightarrow>
  18.305 -   sdrop n (cycle u) = cycle u"
  18.306 -  by (induct "n div length u" arbitrary: n u) (auto simp: sdrop_add[symmetric])
  18.307 -
  18.308 -lemma stake_cycle: "u \<noteq> [] \<Longrightarrow>
  18.309 -   stake n (cycle u) = concat (replicate (n div length u) u) @ take (n mod length u) u"
  18.310 -  by (subst mod_div_equality[of n "length u", symmetric], unfold stake_add[symmetric]) auto
  18.311 -
  18.312 -lemma sdrop_cycle: "u \<noteq> [] \<Longrightarrow> sdrop n (cycle u) = cycle (rotate (n mod length u) u)"
  18.313 -  by (induct n arbitrary: u) (auto simp: rotate1_rotate_swap rotate1_hd_tl rotate_conv_mod[symmetric])
  18.314 -
  18.315 -
  18.316 -subsection {* iterated application of a function *}
  18.317 -
  18.318 -primcorec siterate where
  18.319 -  "shd (siterate f x) = x"
  18.320 -| "stl (siterate f x) = siterate f (f x)"
  18.321 -
  18.322 -lemma stake_Suc: "stake (Suc n) s = stake n s @ [s !! n]"
  18.323 -  by (induct n arbitrary: s) auto
  18.324 -
  18.325 -lemma snth_siterate[simp]: "siterate f x !! n = (f^^n) x"
  18.326 -  by (induct n arbitrary: x) (auto simp: funpow_swap1)
  18.327 -
  18.328 -lemma sdrop_siterate[simp]: "sdrop n (siterate f x) = siterate f ((f^^n) x)"
  18.329 -  by (induct n arbitrary: x) (auto simp: funpow_swap1)
  18.330 -
  18.331 -lemma stake_siterate[simp]: "stake n (siterate f x) = map (\<lambda>n. (f^^n) x) [0 ..< n]"
  18.332 -  by (induct n arbitrary: x) (auto simp del: stake.simps(2) simp: stake_Suc)
  18.333 -
  18.334 -lemma sset_siterate: "sset (siterate f x) = {(f^^n) x | n. True}"
  18.335 -  by (auto simp: sset_range)
  18.336 -
  18.337 -lemma smap_siterate: "smap f (siterate f x) = siterate f (f x)"
  18.338 -  by (coinduction arbitrary: x) auto
  18.339 -
  18.340 -
  18.341 -subsection {* stream repeating a single element *}
  18.342 -
  18.343 -abbreviation "sconst \<equiv> siterate id"
  18.344 -
  18.345 -lemma shift_replicate_sconst[simp]: "replicate n x @- sconst x = sconst x"
  18.346 -  by (subst (3) stake_sdrop[symmetric]) (simp add: map_replicate_trivial)
  18.347 -
  18.348 -lemma sset_sconst[simp]: "sset (sconst x) = {x}"
  18.349 -  by (simp add: sset_siterate)
  18.350 -
  18.351 -lemma sconst_alt: "s = sconst x \<longleftrightarrow> sset s = {x}"
  18.352 -proof
  18.353 -  assume "sset s = {x}"
  18.354 -  then show "s = sconst x"
  18.355 -  proof (coinduction arbitrary: s)
  18.356 -    case Eq_stream
  18.357 -    then have "shd s = x" "sset (stl s) \<subseteq> {x}" by (case_tac [!] s) auto
  18.358 -    then have "sset (stl s) = {x}" by (cases "stl s") auto
  18.359 -    with `shd s = x` show ?case by auto
  18.360 -  qed
  18.361 -qed simp
  18.362 -
  18.363 -lemma same_cycle: "sconst x = cycle [x]"
  18.364 -  by coinduction auto
  18.365 -
  18.366 -lemma smap_sconst: "smap f (sconst x) = sconst (f x)"
  18.367 -  by coinduction auto
  18.368 -
  18.369 -lemma sconst_streams: "x \<in> A \<Longrightarrow> sconst x \<in> streams A"
  18.370 -  by (simp add: streams_iff_sset)
  18.371 -
  18.372 -
  18.373 -subsection {* stream of natural numbers *}
  18.374 -
  18.375 -abbreviation "fromN \<equiv> siterate Suc"
  18.376 -
  18.377 -abbreviation "nats \<equiv> fromN 0"
  18.378 -
  18.379 -lemma sset_fromN[simp]: "sset (fromN n) = {n ..}"
  18.380 -  by (auto simp add: sset_siterate le_iff_add)
  18.381 -
  18.382 -lemma stream_smap_fromN: "s = smap (\<lambda>j. let i = j - n in s !! i) (fromN n)"
  18.383 -  by (coinduction arbitrary: s n)
  18.384 -    (force simp: neq_Nil_conv Let_def snth.simps(2)[symmetric] Suc_diff_Suc
  18.385 -      intro: stream.map_cong split: if_splits simp del: snth.simps(2))
  18.386 -
  18.387 -lemma stream_smap_nats: "s = smap (snth s) nats"
  18.388 -  using stream_smap_fromN[where n = 0] by simp
  18.389 -
  18.390 -
  18.391 -subsection {* flatten a stream of lists *}
  18.392 -
  18.393 -primcorec flat where
  18.394 -  "shd (flat ws) = hd (shd ws)"
  18.395 -| "stl (flat ws) = flat (if tl (shd ws) = [] then stl ws else tl (shd ws) ## stl ws)"
  18.396 -
  18.397 -lemma flat_Cons[simp, code]: "flat ((x # xs) ## ws) = x ## flat (if xs = [] then ws else xs ## ws)"
  18.398 -  by (subst flat.ctr) simp
  18.399 -
  18.400 -lemma flat_Stream[simp]: "xs \<noteq> [] \<Longrightarrow> flat (xs ## ws) = xs @- flat ws"
  18.401 -  by (induct xs) auto
  18.402 -
  18.403 -lemma flat_unfold: "shd ws \<noteq> [] \<Longrightarrow> flat ws = shd ws @- flat (stl ws)"
  18.404 -  by (cases ws) auto
  18.405 -
  18.406 -lemma flat_snth: "\<forall>xs \<in> sset s. xs \<noteq> [] \<Longrightarrow> flat s !! n = (if n < length (shd s) then 
  18.407 -  shd s ! n else flat (stl s) !! (n - length (shd s)))"
  18.408 -  by (metis flat_unfold not_less shd_sset shift_snth_ge shift_snth_less)
  18.409 -
  18.410 -lemma sset_flat[simp]: "\<forall>xs \<in> sset s. xs \<noteq> [] \<Longrightarrow> 
  18.411 -  sset (flat s) = (\<Union>xs \<in> sset s. set xs)" (is "?P \<Longrightarrow> ?L = ?R")
  18.412 -proof safe
  18.413 -  fix x assume ?P "x : ?L"
  18.414 -  then obtain m where "x = flat s !! m" by (metis image_iff sset_range)
  18.415 -  with `?P` obtain n m' where "x = s !! n ! m'" "m' < length (s !! n)"
  18.416 -  proof (atomize_elim, induct m arbitrary: s rule: less_induct)
  18.417 -    case (less y)
  18.418 -    thus ?case
  18.419 -    proof (cases "y < length (shd s)")
  18.420 -      case True thus ?thesis by (metis flat_snth less(2,3) snth.simps(1))
  18.421 -    next
  18.422 -      case False
  18.423 -      hence "x = flat (stl s) !! (y - length (shd s))" by (metis less(2,3) flat_snth)
  18.424 -      moreover
  18.425 -      { from less(2) have *: "length (shd s) > 0" by (cases s) simp_all
  18.426 -        with False have "y > 0" by (cases y) simp_all
  18.427 -        with * have "y - length (shd s) < y" by simp
  18.428 -      }
  18.429 -      moreover have "\<forall>xs \<in> sset (stl s). xs \<noteq> []" using less(2) by (cases s) auto
  18.430 -      ultimately have "\<exists>n m'. x = stl s !! n ! m' \<and> m' < length (stl s !! n)" by (intro less(1)) auto
  18.431 -      thus ?thesis by (metis snth.simps(2))
  18.432 -    qed
  18.433 -  qed
  18.434 -  thus "x \<in> ?R" by (auto simp: sset_range dest!: nth_mem)
  18.435 -next
  18.436 -  fix x xs assume "xs \<in> sset s" ?P "x \<in> set xs" thus "x \<in> ?L"
  18.437 -    by (induct rule: sset_induct)
  18.438 -      (metis UnI1 flat_unfold shift.simps(1) sset_shift,
  18.439 -       metis UnI2 flat_unfold shd_sset stl_sset sset_shift)
  18.440 -qed
  18.441 -
  18.442 -
  18.443 -subsection {* merge a stream of streams *}
  18.444 -
  18.445 -definition smerge :: "'a stream stream \<Rightarrow> 'a stream" where
  18.446 -  "smerge ss = flat (smap (\<lambda>n. map (\<lambda>s. s !! n) (stake (Suc n) ss) @ stake n (ss !! n)) nats)"
  18.447 -
  18.448 -lemma stake_nth[simp]: "m < n \<Longrightarrow> stake n s ! m = s !! m"
  18.449 -  by (induct n arbitrary: s m) (auto simp: nth_Cons', metis Suc_pred snth.simps(2))
  18.450 -
  18.451 -lemma snth_sset_smerge: "ss !! n !! m \<in> sset (smerge ss)"
  18.452 -proof (cases "n \<le> m")
  18.453 -  case False thus ?thesis unfolding smerge_def
  18.454 -    by (subst sset_flat)
  18.455 -      (auto simp: stream.set_map in_set_conv_nth simp del: stake.simps
  18.456 -        intro!: exI[of _ n, OF disjI2] exI[of _ m, OF mp])
  18.457 -next
  18.458 -  case True thus ?thesis unfolding smerge_def
  18.459 -    by (subst sset_flat)
  18.460 -      (auto simp: stream.set_map in_set_conv_nth image_iff simp del: stake.simps snth.simps
  18.461 -        intro!: exI[of _ m, OF disjI1] bexI[of _ "ss !! n"] exI[of _ n, OF mp])
  18.462 -qed
  18.463 -
  18.464 -lemma sset_smerge: "sset (smerge ss) = UNION (sset ss) sset"
  18.465 -proof safe
  18.466 -  fix x assume "x \<in> sset (smerge ss)"
  18.467 -  thus "x \<in> UNION (sset ss) sset"
  18.468 -    unfolding smerge_def by (subst (asm) sset_flat)
  18.469 -      (auto simp: stream.set_map in_set_conv_nth sset_range simp del: stake.simps, fast+)
  18.470 -next
  18.471 -  fix s x assume "s \<in> sset ss" "x \<in> sset s"
  18.472 -  thus "x \<in> sset (smerge ss)" using snth_sset_smerge by (auto simp: sset_range)
  18.473 -qed
  18.474 -
  18.475 -
  18.476 -subsection {* product of two streams *}
  18.477 -
  18.478 -definition sproduct :: "'a stream \<Rightarrow> 'b stream \<Rightarrow> ('a \<times> 'b) stream" where
  18.479 -  "sproduct s1 s2 = smerge (smap (\<lambda>x. smap (Pair x) s2) s1)"
  18.480 -
  18.481 -lemma sset_sproduct: "sset (sproduct s1 s2) = sset s1 \<times> sset s2"
  18.482 -  unfolding sproduct_def sset_smerge by (auto simp: stream.set_map)
  18.483 -
  18.484 -
  18.485 -subsection {* interleave two streams *}
  18.486 -
  18.487 -primcorec sinterleave where
  18.488 -  "shd (sinterleave s1 s2) = shd s1"
  18.489 -| "stl (sinterleave s1 s2) = sinterleave s2 (stl s1)"
  18.490 -
  18.491 -lemma sinterleave_code[code]:
  18.492 -  "sinterleave (x ## s1) s2 = x ## sinterleave s2 s1"
  18.493 -  by (subst sinterleave.ctr) simp
  18.494 -
  18.495 -lemma sinterleave_snth[simp]:
  18.496 -  "even n \<Longrightarrow> sinterleave s1 s2 !! n = s1 !! (n div 2)"
  18.497 -   "odd n \<Longrightarrow> sinterleave s1 s2 !! n = s2 !! (n div 2)"
  18.498 -  by (induct n arbitrary: s1 s2)
  18.499 -    (auto dest: even_nat_Suc_div_2 odd_nat_plus_one_div_two[folded nat_2])
  18.500 -
  18.501 -lemma sset_sinterleave: "sset (sinterleave s1 s2) = sset s1 \<union> sset s2"
  18.502 -proof (intro equalityI subsetI)
  18.503 -  fix x assume "x \<in> sset (sinterleave s1 s2)"
  18.504 -  then obtain n where "x = sinterleave s1 s2 !! n" unfolding sset_range by blast
  18.505 -  thus "x \<in> sset s1 \<union> sset s2" by (cases "even n") auto
  18.506 -next
  18.507 -  fix x assume "x \<in> sset s1 \<union> sset s2"
  18.508 -  thus "x \<in> sset (sinterleave s1 s2)"
  18.509 -  proof
  18.510 -    assume "x \<in> sset s1"
  18.511 -    then obtain n where "x = s1 !! n" unfolding sset_range by blast
  18.512 -    hence "sinterleave s1 s2 !! (2 * n) = x" by simp
  18.513 -    thus ?thesis unfolding sset_range by blast
  18.514 -  next
  18.515 -    assume "x \<in> sset s2"
  18.516 -    then obtain n where "x = s2 !! n" unfolding sset_range by blast
  18.517 -    hence "sinterleave s1 s2 !! (2 * n + 1) = x" by simp
  18.518 -    thus ?thesis unfolding sset_range by blast
  18.519 -  qed
  18.520 -qed
  18.521 -
  18.522 -
  18.523 -subsection {* zip *}
  18.524 -
  18.525 -primcorec szip where
  18.526 -  "shd (szip s1 s2) = (shd s1, shd s2)"
  18.527 -| "stl (szip s1 s2) = szip (stl s1) (stl s2)"
  18.528 -
  18.529 -lemma szip_unfold[code]: "szip (a ## s1) (b ## s2) = (a, b) ## (szip s1 s2)"
  18.530 -  by (subst szip.ctr) simp
  18.531 -
  18.532 -lemma snth_szip[simp]: "szip s1 s2 !! n = (s1 !! n, s2 !! n)"
  18.533 -  by (induct n arbitrary: s1 s2) auto
  18.534 -
  18.535 -lemma stake_szip[simp]:
  18.536 -  "stake n (szip s1 s2) = zip (stake n s1) (stake n s2)"
  18.537 -  by (induct n arbitrary: s1 s2) auto
  18.538 -
  18.539 -lemma sdrop_szip[simp]: "sdrop n (szip s1 s2) = szip (sdrop n s1) (sdrop n s2)"
  18.540 -  by (induct n arbitrary: s1 s2) auto
  18.541 -
  18.542 -lemma smap_szip_fst:
  18.543 -  "smap (\<lambda>x. f (fst x)) (szip s1 s2) = smap f s1"
  18.544 -  by (coinduction arbitrary: s1 s2) auto
  18.545 -
  18.546 -lemma smap_szip_snd:
  18.547 -  "smap (\<lambda>x. g (snd x)) (szip s1 s2) = smap g s2"
  18.548 -  by (coinduction arbitrary: s1 s2) auto
  18.549 -
  18.550 -
  18.551 -subsection {* zip via function *}
  18.552 -
  18.553 -primcorec smap2 where
  18.554 -  "shd (smap2 f s1 s2) = f (shd s1) (shd s2)"
  18.555 -| "stl (smap2 f s1 s2) = smap2 f (stl s1) (stl s2)"
  18.556 -
  18.557 -lemma smap2_unfold[code]:
  18.558 -  "smap2 f (a ## s1) (b ## s2) = f a b ## (smap2 f s1 s2)"
  18.559 -  by (subst smap2.ctr) simp
  18.560 -
  18.561 -lemma smap2_szip:
  18.562 -  "smap2 f s1 s2 = smap (split f) (szip s1 s2)"
  18.563 -  by (coinduction arbitrary: s1 s2) auto
  18.564 -
  18.565 -lemma smap_smap2[simp]:
  18.566 -  "smap f (smap2 g s1 s2) = smap2 (\<lambda>x y. f (g x y)) s1 s2"
  18.567 -  unfolding smap2_szip stream.map_comp o_def split_def ..
  18.568 -
  18.569 -lemma smap2_alt:
  18.570 -  "(smap2 f s1 s2 = s) = (\<forall>n. f (s1 !! n) (s2 !! n) = s !! n)"
  18.571 -  unfolding smap2_szip smap_alt by auto
  18.572 -
  18.573 -lemma snth_smap2[simp]:
  18.574 -  "smap2 f s1 s2 !! n = f (s1 !! n) (s2 !! n)"
  18.575 -  by (induct n arbitrary: s1 s2) auto
  18.576 -
  18.577 -lemma stake_smap2[simp]:
  18.578 -  "stake n (smap2 f s1 s2) = map (split f) (zip (stake n s1) (stake n s2))"
  18.579 -  by (induct n arbitrary: s1 s2) auto
  18.580 -
  18.581 -lemma sdrop_smap2[simp]:
  18.582 -  "sdrop n (smap2 f s1 s2) = smap2 f (sdrop n s1) (sdrop n s2)"
  18.583 -  by (induct n arbitrary: s1 s2) auto
  18.584 -
  18.585 -end
    19.1 --- a/src/HOL/BNF_Examples/Stream_Processor.thy	Thu Sep 11 19:20:23 2014 +0200
    19.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    19.3 @@ -1,189 +0,0 @@
    19.4 -(*  Title:      HOL/BNF_Examples/Stream_Processor.thy
    19.5 -    Author:     Dmitriy Traytel, TU Muenchen
    19.6 -    Author:     Andrei Popescu, TU Muenchen
    19.7 -    Copyright   2014
    19.8 -
    19.9 -Stream processors---a syntactic representation of continuous functions on streams.
   19.10 -*)
   19.11 -
   19.12 -header {* Stream Processors---A Syntactic Representation of Continuous Functions on Streams *}
   19.13 -
   19.14 -theory Stream_Processor
   19.15 -imports Stream "~~/src/HOL/Library/BNF_Axiomatization"
   19.16 -begin
   19.17 -
   19.18 -section {* Continuous Functions on Streams *}
   19.19 -
   19.20 -datatype_new ('a, 'b, 'c) sp\<^sub>\<mu> = Get "'a \<Rightarrow> ('a, 'b, 'c) sp\<^sub>\<mu>" | Put "'b" "'c"
   19.21 -codatatype ('a, 'b) sp\<^sub>\<nu> = In (out: "('a, 'b, ('a, 'b) sp\<^sub>\<nu>) sp\<^sub>\<mu>")
   19.22 -
   19.23 -primrec run\<^sub>\<mu> :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> 'a stream \<Rightarrow> ('b \<times> 'c) \<times> 'a stream" where
   19.24 -  "run\<^sub>\<mu> (Get f) s = run\<^sub>\<mu> (f (shd s)) (stl s)"
   19.25 -| "run\<^sub>\<mu> (Put b sp) s = ((b, sp), s)"
   19.26 -
   19.27 -primcorec run\<^sub>\<nu> :: "('a, 'b) sp\<^sub>\<nu> \<Rightarrow> 'a stream \<Rightarrow> 'b stream" where
   19.28 -  "run\<^sub>\<nu> sp s = (let ((h, sp), s) = run\<^sub>\<mu> (out sp) s in h ## run\<^sub>\<nu> sp s)"
   19.29 -
   19.30 -primcorec copy :: "('a, 'a) sp\<^sub>\<nu>" where
   19.31 -  "copy = In (Get (\<lambda>a. Put a copy))"
   19.32 -
   19.33 -lemma run\<^sub>\<nu>_copy: "run\<^sub>\<nu> copy s = s"
   19.34 -  by (coinduction arbitrary: s) simp
   19.35 -
   19.36 -text {*
   19.37 -To use the function package for the definition of composition the
   19.38 -wellfoundedness of the subtree relation needs to be proved first.
   19.39 -*}
   19.40 -
   19.41 -definition "sub \<equiv> {(f a, Get f) | a f. True}"
   19.42 -
   19.43 -lemma subI[intro]: "(f a, Get f) \<in> sub"
   19.44 -  unfolding sub_def by blast
   19.45 -
   19.46 -lemma wf_sub[simp, intro]: "wf sub"
   19.47 -proof (rule wfUNIVI)
   19.48 -  fix P  :: "('a, 'b, 'c) sp\<^sub>\<mu> \<Rightarrow> bool" and x
   19.49 -  assume "\<forall>x. (\<forall>y. (y, x) \<in> sub \<longrightarrow> P y) \<longrightarrow> P x"
   19.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
   19.51 -  show "P x" by (induct x) (auto intro: I)
   19.52 -qed
   19.53 -
   19.54 -function
   19.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>"
   19.56 -  (infixl "o\<^sub>\<mu>" 65)
   19.57 -where
   19.58 -  "Put b sp o\<^sub>\<mu> fsp = Put b (sp, In fsp)"
   19.59 -| "Get f o\<^sub>\<mu> Put b sp = f b o\<^sub>\<mu> out sp"
   19.60 -| "Get f o\<^sub>\<mu> Get g = Get (\<lambda>a. Get f o\<^sub>\<mu> g a)"
   19.61 -by pat_completeness auto
   19.62 -termination by (relation "lex_prod sub sub") auto
   19.63 -
   19.64 -primcorec sp\<^sub>\<nu>_comp (infixl "o\<^sub>\<nu>" 65) where
   19.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')"
   19.66 -
   19.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'"
   19.68 -proof (rule ext, unfold comp_apply)
   19.69 -  fix s
   19.70 -  show "run\<^sub>\<nu> (sp o\<^sub>\<nu> sp') s = run\<^sub>\<nu> sp (run\<^sub>\<nu> sp' s)"
   19.71 -  proof (coinduction arbitrary: sp sp' s)
   19.72 -    case Eq_stream
   19.73 -    show ?case
   19.74 -    proof (induct "out sp" "out sp'" arbitrary: sp sp' s rule: sp\<^sub>\<mu>_comp.induct)
   19.75 -      case (1 b sp'')
   19.76 -      show ?case by (auto simp add: 1[symmetric])
   19.77 -    next
   19.78 -      case (2 f b sp'')
   19.79 -      from 2(1)[of "In (f b)" sp''] show ?case by (simp add: 2(2,3)[symmetric])
   19.80 -    next
   19.81 -      case (3 f h)
   19.82 -      from 3(1)[of _ "shd s" "In (h (shd s))", OF 3(2)] show ?case by (simp add: 3(2,3)[symmetric])
   19.83 -    qed
   19.84 -  qed
   19.85 -qed
   19.86 -
   19.87 -text {* Alternative definition of composition using primrec instead of function *}
   19.88 -
   19.89 -primrec sp\<^sub>\<mu>_comp2R  where
   19.90 -  "sp\<^sub>\<mu>_comp2R f (Put b sp) = f b (out sp)"
   19.91 -| "sp\<^sub>\<mu>_comp2R f (Get h) = Get (sp\<^sub>\<mu>_comp2R f o h)"
   19.92 -
   19.93 -primrec sp\<^sub>\<mu>_comp2 (infixl "o\<^sup>*\<^sub>\<mu>" 65) where
   19.94 -  "Put b sp o\<^sup>*\<^sub>\<mu> fsp = Put b (sp, In fsp)"
   19.95 -| "Get f o\<^sup>*\<^sub>\<mu> fsp = sp\<^sub>\<mu>_comp2R (op o\<^sup>*\<^sub>\<mu> o f) fsp"
   19.96 -
   19.97 -primcorec sp\<^sub>\<nu>_comp2 (infixl "o\<^sup>*\<^sub>\<nu>" 65) where
   19.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')"
   19.99 -
  19.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'"
  19.101 -proof (rule ext, unfold comp_apply)
  19.102 -  fix s
  19.103 -  show "run\<^sub>\<nu> (sp o\<^sup>*\<^sub>\<nu> sp') s = run\<^sub>\<nu> sp (run\<^sub>\<nu> sp' s)"
  19.104 -  proof (coinduction arbitrary: sp sp' s)
  19.105 -    case Eq_stream
  19.106 -    show ?case
  19.107 -    proof (induct "out sp" arbitrary: sp sp' s)
  19.108 -      case (Put b sp'')
  19.109 -      show ?case by (auto simp add: Put[symmetric])
  19.110 -    next
  19.111 -      case (Get f)
  19.112 -      then show ?case
  19.113 -      proof (induct "out sp'" arbitrary: sp sp' s)
  19.114 -        case (Put b sp'')
  19.115 -        from Put(2)[of "In (f b)" sp''] show ?case by (simp add: Put(1,3)[symmetric])
  19.116 -      next
  19.117 -        case (Get h)
  19.118 -        from Get(1)[OF _ Get(3,4), of "In (h (shd s))"] show ?case by (simp add: Get(2,4)[symmetric])
  19.119 -      qed
  19.120 -    qed
  19.121 -  qed
  19.122 -qed
  19.123 -
  19.124 -text {* The two definitions are equivalent *}
  19.125 -
  19.126 -lemma sp\<^sub>\<mu>_comp_sp\<^sub>\<mu>_comp2[simp]: "sp o\<^sub>\<mu> sp' = sp o\<^sup>*\<^sub>\<mu> sp'"
  19.127 -  by (induct sp sp' rule: sp\<^sub>\<mu>_comp.induct) auto
  19.128 -
  19.129 -(*will be provided by the package*)
  19.130 -lemma sp\<^sub>\<mu>_rel_map_map[unfolded vimage2p_def, simp]:
  19.131 -  "rel_sp\<^sub>\<mu> R1 R2 (map_sp\<^sub>\<mu> f1 f2 sp) (map_sp\<^sub>\<mu> g1 g2 sp') =
  19.132 -  rel_sp\<^sub>\<mu> (BNF_Def.vimage2p f1 g1 R1) (BNF_Def.vimage2p f2 g2 R2) sp sp'"
  19.133 -by (tactic {*
  19.134 -  let val ks = 1 upto 2;
  19.135 -  in
  19.136 -    BNF_Tactics.unfold_thms_tac @{context}
  19.137 -      @{thms sp\<^sub>\<mu>.rel_compp sp\<^sub>\<mu>.rel_conversep sp\<^sub>\<mu>.rel_Grp vimage2p_Grp} THEN
  19.138 -    HEADGOAL (EVERY' [rtac iffI, rtac @{thm relcomppI}, rtac @{thm GrpI}, rtac refl, rtac CollectI,
  19.139 -      BNF_Util.CONJ_WRAP' (K (rtac @{thm subset_UNIV})) ks, rtac @{thm relcomppI}, atac,
  19.140 -      rtac @{thm conversepI}, rtac @{thm GrpI}, rtac refl, rtac CollectI,
  19.141 -      BNF_Util.CONJ_WRAP' (K (rtac @{thm subset_UNIV})) ks,
  19.142 -      REPEAT_DETERM o eresolve_tac @{thms relcomppE conversepE GrpE},
  19.143 -      hyp_subst_tac @{context}, atac])
  19.144 -  end
  19.145 -*})
  19.146 -
  19.147 -lemma sp\<^sub>\<mu>_rel_self: "\<lbrakk>op = \<le> R1; op = \<le> R2\<rbrakk> \<Longrightarrow> rel_sp\<^sub>\<mu> R1 R2 x x"
  19.148 -  by (erule (1) predicate2D[OF sp\<^sub>\<mu>.rel_mono]) (simp only: sp\<^sub>\<mu>.rel_eq)
  19.149 -
  19.150 -lemma sp\<^sub>\<nu>_comp_sp\<^sub>\<nu>_comp2: "sp o\<^sub>\<nu> sp' = sp o\<^sup>*\<^sub>\<nu> sp'"
  19.151 -  by (coinduction arbitrary: sp sp') (auto intro!: sp\<^sub>\<mu>_rel_self)
  19.152 -
  19.153 -
  19.154 -section {* Generalization to an Arbitrary BNF as Codomain *}
  19.155 -
  19.156 -bnf_axiomatization ('a, 'b) F for map: F
  19.157 -
  19.158 -notation BNF_Def.convol ("\<langle>(_,/ _)\<rangle>")
  19.159 -
  19.160 -definition \<theta> :: "('p,'a) F * 'b \<Rightarrow> ('p,'a * 'b) F" where
  19.161 -  "\<theta> xb = F id \<langle>id, \<lambda> a. (snd xb)\<rangle> (fst xb)"
  19.162 -
  19.163 -(* The strength laws for \<theta>: *)
  19.164 -lemma \<theta>_natural: "F id (map_prod f g) o \<theta> = \<theta> o map_prod (F id f) g"
  19.165 -  unfolding \<theta>_def F.map_comp comp_def id_apply convol_def map_prod_def split_beta fst_conv snd_conv ..
  19.166 -
  19.167 -definition assl :: "'a * ('b * 'c) \<Rightarrow> ('a * 'b) * 'c" where
  19.168 -  "assl abc = ((fst abc, fst (snd abc)), snd (snd abc))"
  19.169 -
  19.170 -lemma \<theta>_rid: "F id fst o \<theta> = fst"
  19.171 -  unfolding \<theta>_def F.map_comp F.map_id comp_def id_apply convol_def fst_conv sym[OF id_def] ..
  19.172 -
  19.173 -lemma \<theta>_assl: "F id assl o \<theta> = \<theta> o map_prod \<theta> id o assl"
  19.174 -  unfolding assl_def \<theta>_def F.map_comp comp_def id_apply convol_def map_prod_def split fst_conv snd_conv ..
  19.175 -
  19.176 -datatype_new ('a, 'b, 'c) spF\<^sub>\<mu> = GetF "'a \<Rightarrow> ('a, 'b, 'c) spF\<^sub>\<mu>" | PutF "('b,'c) F"
  19.177 -codatatype ('a, 'b) spF\<^sub>\<nu> = InF (outF: "('a, 'b, ('a, 'b) spF\<^sub>\<nu>) spF\<^sub>\<mu>")
  19.178 -
  19.179 -codatatype 'b JF = Ctor (dtor: "('b, 'b JF) F")
  19.180 -
  19.181 -(* Definition of run for an arbitrary final coalgebra as codomain: *)
  19.182 -
  19.183 -primrec
  19.184 -  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" 
  19.185 -where
  19.186 -  "runF\<^sub>\<mu> (GetF f) s = (runF\<^sub>\<mu> o f) (shd s) (stl s)"
  19.187 -| "runF\<^sub>\<mu> (PutF x) s = (x, s)"
  19.188 -
  19.189 -primcorec runF\<^sub>\<nu> :: "('a, 'b) spF\<^sub>\<nu> \<Rightarrow> 'a stream \<Rightarrow> 'b JF" where
  19.190 -  "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))"
  19.191 -
  19.192 -end
    20.1 --- a/src/HOL/BNF_Examples/TreeFI.thy	Thu Sep 11 19:20:23 2014 +0200
    20.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.3 @@ -1,46 +0,0 @@
    20.4 -(*  Title:      HOL/BNF_Examples/TreeFI.thy
    20.5 -    Author:     Dmitriy Traytel, TU Muenchen
    20.6 -    Author:     Andrei Popescu, TU Muenchen
    20.7 -    Copyright   2012
    20.8 -
    20.9 -Finitely branching possibly infinite trees.
   20.10 -*)
   20.11 -
   20.12 -header {* Finitely Branching Possibly Infinite Trees *}
   20.13 -
   20.14 -theory TreeFI
   20.15 -imports Main
   20.16 -begin
   20.17 -
   20.18 -codatatype 'a treeFI = Tree (lab: 'a) (sub: "'a treeFI list")
   20.19 -
   20.20 -(* Tree reverse:*)
   20.21 -primcorec trev where
   20.22 -  "lab (trev t) = lab t"
   20.23 -| "sub (trev t) = map trev (rev (sub t))"
   20.24 -
   20.25 -lemma treeFI_coinduct:
   20.26 -  assumes *: "phi x y"
   20.27 -  and step: "\<And>a b. phi a b \<Longrightarrow>
   20.28 -     lab a = lab b \<and>
   20.29 -     length (sub a) = length (sub b) \<and>
   20.30 -     (\<forall>i < length (sub a). phi (nth (sub a) i) (nth (sub b) i))"
   20.31 -  shows "x = y"
   20.32 -using * proof (coinduction arbitrary: x y)
   20.33 -  case (Eq_treeFI t1 t2)
   20.34 -  from conjunct1[OF conjunct2[OF step[OF Eq_treeFI]]] conjunct2[OF conjunct2[OF step[OF Eq_treeFI]]]
   20.35 -  have "list_all2 phi (sub t1) (sub t2)"
   20.36 -  proof (induction "sub t1" "sub t2" arbitrary: t1 t2 rule: list_induct2)
   20.37 -    case (Cons x xs y ys)
   20.38 -    note sub = Cons(3,4)[symmetric] and phi = mp[OF spec[OF Cons(5)], unfolded sub]
   20.39 -      and IH = Cons(2)[of "Tree (lab t1) (tl (sub t1))" "Tree (lab t2) (tl (sub t2))",
   20.40 -        unfolded sub, simplified]
   20.41 -    from phi[of 0] show ?case unfolding sub by (auto intro!: IH dest: phi[simplified, OF Suc_mono])
   20.42 -  qed simp
   20.43 -  with conjunct1[OF step[OF Eq_treeFI]] show ?case by simp
   20.44 -qed
   20.45 -
   20.46 -lemma trev_trev: "trev (trev tr) = tr"
   20.47 -  by (coinduction arbitrary: tr rule: treeFI_coinduct) (auto simp add: rev_map)
   20.48 -
   20.49 -end
    21.1 --- a/src/HOL/BNF_Examples/TreeFsetI.thy	Thu Sep 11 19:20:23 2014 +0200
    21.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.3 @@ -1,25 +0,0 @@
    21.4 -(*  Title:      HOL/BNF_Examples/TreeFsetI.thy
    21.5 -    Author:     Dmitriy Traytel, TU Muenchen
    21.6 -    Author:     Andrei Popescu, TU Muenchen
    21.7 -    Copyright   2012
    21.8 -
    21.9 -Finitely branching possibly infinite trees, with sets of children.
   21.10 -*)
   21.11 -
   21.12 -header {* Finitely Branching Possibly Infinite Trees, with Sets of Children *}
   21.13 -
   21.14 -theory TreeFsetI
   21.15 -imports "~~/src/HOL/Library/FSet"
   21.16 -begin
   21.17 -
   21.18 -codatatype 'a treeFsetI = Tree (lab: 'a) (sub: "'a treeFsetI fset")
   21.19 -
   21.20 -(* tree map (contrived example): *)
   21.21 -primcorec tmap where
   21.22 -"lab (tmap f t) = f (lab t)" |
   21.23 -"sub (tmap f t) = fimage (tmap f) (sub t)"
   21.24 -
   21.25 -lemma "tmap (f o g) x = tmap f (tmap g x)"
   21.26 -  by (coinduction arbitrary: x) (auto simp: rel_fset_alt)
   21.27 -
   21.28 -end
    22.1 --- a/src/HOL/BNF_Examples/Verilog.thy	Thu Sep 11 19:20:23 2014 +0200
    22.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    22.3 @@ -1,138 +0,0 @@
    22.4 -(*  Title:      HOL/Datatype_Benchmark/Verilog.thy
    22.5 -
    22.6 -Example from Daryl: a Verilog grammar.
    22.7 -*)
    22.8 -
    22.9 -theory Verilog imports Main begin
   22.10 -
   22.11 -datatype
   22.12 -  Source_text
   22.13 -     = module string "string list" "Module_item list"
   22.14 -     | Source_textMeta string
   22.15 -and
   22.16 -  Module_item
   22.17 -     = "declaration" Declaration
   22.18 -     | initial Statement
   22.19 -     | always Statement
   22.20 -     | assign Lvalue Expression
   22.21 -     | Module_itemMeta string
   22.22 -and
   22.23 -  Declaration
   22.24 -     = reg_declaration "Range option" "string list"
   22.25 -     | net_declaration "Range option" "string list"
   22.26 -     | input_declaration "Range option" "string list"
   22.27 -     | output_declaration "Range option" "string list"
   22.28 -     | DeclarationMeta string
   22.29 -and
   22.30 -  Range = range Expression Expression | RangeMeta string
   22.31 -and
   22.32 -  Statement
   22.33 -     = clock_statement Clock Statement_or_null
   22.34 -     | blocking_assignment Lvalue Expression
   22.35 -     | non_blocking_assignment Lvalue Expression
   22.36 -     | conditional_statement
   22.37 -          Expression Statement_or_null "Statement_or_null option"
   22.38 -     | case_statement Expression "Case_item list"
   22.39 -     | while_loop Expression Statement
   22.40 -     | repeat_loop Expression Statement
   22.41 -     | for_loop
   22.42 -          Lvalue Expression Expression Lvalue Expression Statement
   22.43 -     | forever_loop Statement
   22.44 -     | disable string
   22.45 -     | seq_block "string option" "Statement list"
   22.46 -     | StatementMeta string
   22.47 -and
   22.48 -  Statement_or_null
   22.49 -     = statement Statement | null_statement | Statement_or_nullMeta string
   22.50 -and
   22.51 -  Clock
   22.52 -     = posedge string
   22.53 -     | negedge string
   22.54 -     | clock string
   22.55 -     | ClockMeta string
   22.56 -and
   22.57 -  Case_item
   22.58 -     = case_item "Expression list" Statement_or_null
   22.59 -     | default_case_item Statement_or_null
   22.60 -     | Case_itemMeta string
   22.61 -and
   22.62 -  Expression
   22.63 -     = plus Expression Expression
   22.64 -     | minus Expression Expression
   22.65 -     | lshift Expression Expression
   22.66 -     | rshift Expression Expression
   22.67 -     | lt Expression Expression
   22.68 -     | leq Expression Expression
   22.69 -     | gt Expression Expression
   22.70 -     | geq Expression Expression
   22.71 -     | logeq Expression Expression
   22.72 -     | logneq Expression Expression
   22.73 -     | caseeq Expression Expression
   22.74 -     | caseneq Expression Expression
   22.75 -     | bitand Expression Expression
   22.76 -     | bitxor Expression Expression
   22.77 -     | bitor Expression Expression
   22.78 -     | logand Expression Expression
   22.79 -     | logor Expression Expression
   22.80 -     | conditional Expression Expression Expression
   22.81 -     | positive Primary
   22.82 -     | negative Primary
   22.83 -     | lognot Primary
   22.84 -     | bitnot Primary
   22.85 -     | reducand Primary
   22.86 -     | reducxor Primary
   22.87 -     | reducor Primary
   22.88 -     | reducnand Primary
   22.89 -     | reducxnor Primary
   22.90 -     | reducnor Primary
   22.91 -     | primary Primary
   22.92 -     | ExpressionMeta string
   22.93 -and
   22.94 -  Primary
   22.95 -     = primary_number Number
   22.96 -     | primary_IDENTIFIER string
   22.97 -     | primary_bit_select string Expression
   22.98 -     | primary_part_select string Expression Expression
   22.99 -     | primary_gen_bit_select Expression Expression
  22.100 -     | primary_gen_part_select Expression Expression Expression
  22.101 -     | primary_concatenation Concatenation
  22.102 -     | primary_multiple_concatenation Multiple_concatenation
  22.103 -     | brackets Expression
  22.104 -     | PrimaryMeta string
  22.105 -and
  22.106 -  Lvalue
  22.107 -     = lvalue string
  22.108 -     | lvalue_bit_select string Expression
  22.109 -     | lvalue_part_select string Expression Expression
  22.110 -     | lvalue_concatenation Concatenation
  22.111 -     | LvalueMeta string
  22.112 -and
  22.113 -  Number
  22.114 -     = decimal string
  22.115 -     | based "string option" string
  22.116 -     | NumberMeta string
  22.117 -and
  22.118 -  Concatenation
  22.119 -     = concatenation "Expression list" | ConcatenationMeta string
  22.120 -and
  22.121 -  Multiple_concatenation
  22.122 -     = multiple_concatenation Expression "Expression list"
  22.123 -     | Multiple_concatenationMeta string
  22.124 -and
  22.125 -  meta
  22.126 -     = Meta_Source_text Source_text
  22.127 -     | Meta_Module_item Module_item
  22.128 -     | Meta_Declaration Declaration
  22.129 -     | Meta_Range Range
  22.130 -     | Meta_Statement Statement
  22.131 -     | Meta_Statement_or_null Statement_or_null
  22.132 -     | Meta_Clock Clock
  22.133 -     | Meta_Case_item Case_item
  22.134 -     | Meta_Expression Expression
  22.135 -     | Meta_Primary Primary
  22.136 -     | Meta_Lvalue Lvalue
  22.137 -     | Meta_Number Number
  22.138 -     | Meta_Concatenation Concatenation
  22.139 -     | Meta_Multiple_concatenation Multiple_concatenation
  22.140 -
  22.141 -end
    23.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.2 +++ b/src/HOL/Datatype_Examples/Brackin.thy	Thu Sep 11 19:26:59 2014 +0200
    23.3 @@ -0,0 +1,41 @@
    23.4 +(*  Title:      HOL/Datatype_Benchmark/Brackin.thy
    23.5 +
    23.6 +A couple of datatypes from Steve Brackin's work.
    23.7 +*)
    23.8 +
    23.9 +theory Brackin imports Main begin
   23.10 +
   23.11 +datatype T =
   23.12 +    X1 | X2 | X3 | X4 | X5 | X6 | X7 | X8 | X9 | X10 | X11 |
   23.13 +    X12 | X13 | X14 | X15 | X16 | X17 | X18 | X19 | X20 | X21 |
   23.14 +    X22 | X23 | X24 | X25 | X26 | X27 | X28 | X29 | X30 | X31 |
   23.15 +    X32 | X33 | X34
   23.16 +
   23.17 +datatype ('a, 'b, 'c) TY1 =
   23.18 +      NoF
   23.19 +    | Fk 'a "('a, 'b, 'c) TY2"
   23.20 +and ('a, 'b, 'c) TY2 =
   23.21 +      Ta bool
   23.22 +    | Td bool
   23.23 +    | Tf "('a, 'b, 'c) TY1"
   23.24 +    | Tk bool
   23.25 +    | Tp bool
   23.26 +    | App 'a "('a, 'b, 'c) TY1" "('a, 'b, 'c) TY2" "('a, 'b, 'c) TY3"
   23.27 +    | Pair "('a, 'b, 'c) TY2" "('a, 'b, 'c) TY2"
   23.28 +and ('a, 'b, 'c) TY3 =
   23.29 +      NoS
   23.30 +    | Fresh "('a, 'b, 'c) TY2"
   23.31 +    | Trustworthy 'a
   23.32 +    | PrivateKey 'a 'b 'c
   23.33 +    | PublicKey 'a 'b 'c
   23.34 +    | Conveyed 'a "('a, 'b, 'c) TY2"
   23.35 +    | Possesses 'a "('a, 'b, 'c) TY2"
   23.36 +    | Received 'a "('a, 'b, 'c) TY2"
   23.37 +    | Recognizes 'a "('a, 'b, 'c) TY2"
   23.38 +    | NeverMalFromSelf 'a 'b "('a, 'b, 'c) TY2"
   23.39 +    | Sends 'a "('a, 'b, 'c) TY2" 'b
   23.40 +    | SharedSecret 'a "('a, 'b, 'c) TY2" 'b
   23.41 +    | Believes 'a "('a, 'b, 'c) TY3"
   23.42 +    | And "('a, 'b, 'c) TY3" "('a, 'b, 'c) TY3"
   23.43 +
   23.44 +end
    24.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.2 +++ b/src/HOL/Datatype_Examples/Compat.thy	Thu Sep 11 19:26:59 2014 +0200
    24.3 @@ -0,0 +1,236 @@
    24.4 +(*  Title:      HOL/Datatype_Examples/Compat.thy
    24.5 +    Author:     Jasmin Blanchette, TU Muenchen
    24.6 +    Copyright   2014
    24.7 +
    24.8 +Tests for compatibility with the old datatype package.
    24.9 +*)
   24.10 +
   24.11 +header \<open> Tests for Compatibility with the Old Datatype Package \<close>
   24.12 +
   24.13 +theory Compat
   24.14 +imports Main
   24.15 +begin
   24.16 +
   24.17 +subsection \<open> Viewing and Registering New-Style Datatypes as Old-Style Ones \<close>
   24.18 +
   24.19 +ML \<open>
   24.20 +fun check_len n xs label =
   24.21 +  length xs = n orelse error ("Expected length " ^ string_of_int (length xs) ^ " for " ^ label);
   24.22 +
   24.23 +fun check_lens (n1, n2, n3) (xs1, xs2, xs3) =
   24.24 +  check_len n1 xs1 "old" andalso check_len n2 xs2 "unfold" andalso check_len n3 xs3 "keep";
   24.25 +
   24.26 +fun get_descrs thy lens T_name =
   24.27 +  (these (Option.map #descr (Old_Datatype_Data.get_info thy T_name)),
   24.28 +   these (Option.map #descr (BNF_LFP_Compat.get_info thy BNF_LFP_Compat.Unfold_Nesting T_name)),
   24.29 +   these (Option.map #descr (BNF_LFP_Compat.get_info thy BNF_LFP_Compat.Keep_Nesting T_name)))
   24.30 +  |> tap (check_lens lens);
   24.31 +\<close>
   24.32 +
   24.33 +old_datatype 'a old_lst = Old_Nl | Old_Cns 'a "'a old_lst"
   24.34 +
   24.35 +ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name old_lst}; \<close>
   24.36 +
   24.37 +datatype_new 'a lst = Nl | Cns 'a "'a lst"
   24.38 +
   24.39 +ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name lst}; \<close>
   24.40 +
   24.41 +datatype_compat lst
   24.42 +
   24.43 +ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name lst}; \<close>
   24.44 +
   24.45 +datatype_new 'b w = W | W' "'b w \<times> 'b list"
   24.46 +
   24.47 +(* no support for sums of products:
   24.48 +datatype_compat w
   24.49 +*)
   24.50 +
   24.51 +ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name w}; \<close>
   24.52 +
   24.53 +datatype_new ('c, 'b) s = L 'c | R 'b
   24.54 +
   24.55 +ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name s}; \<close>
   24.56 +
   24.57 +datatype_new 'd x = X | X' "('d x lst, 'd list) s"
   24.58 +
   24.59 +ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name x}; \<close>
   24.60 +
   24.61 +datatype_compat s
   24.62 +
   24.63 +ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name s}; \<close>
   24.64 +ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name x}; \<close>
   24.65 +
   24.66 +datatype_compat x
   24.67 +
   24.68 +ML \<open> get_descrs @{theory} (3, 3, 1) @{type_name x}; \<close>
   24.69 +
   24.70 +thm x.induct x.rec
   24.71 +thm compat_x.induct compat_x.rec
   24.72 +
   24.73 +datatype_new 'a tttre = TTTre 'a "'a tttre lst lst lst"
   24.74 +
   24.75 +ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name tttre}; \<close>
   24.76 +
   24.77 +datatype_compat tttre
   24.78 +
   24.79 +ML \<open> get_descrs @{theory} (4, 4, 1) @{type_name tttre}; \<close>
   24.80 +
   24.81 +thm tttre.induct tttre.rec
   24.82 +thm compat_tttre.induct compat_tttre.rec
   24.83 +
   24.84 +datatype_new 'a ftre = FEmp | FTre "'a \<Rightarrow> 'a ftre lst"
   24.85 +
   24.86 +ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name ftre}; \<close>
   24.87 +
   24.88 +datatype_compat ftre
   24.89 +
   24.90 +ML \<open> get_descrs @{theory} (2, 2, 1) @{type_name ftre}; \<close>
   24.91 +
   24.92 +thm ftre.induct ftre.rec
   24.93 +thm compat_ftre.induct compat_ftre.rec
   24.94 +
   24.95 +datatype_new 'a btre = BTre 'a "'a btre lst" "'a btre lst"
   24.96 +
   24.97 +ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name btre}; \<close>
   24.98 +
   24.99 +datatype_compat btre
  24.100 +
  24.101 +ML \<open> get_descrs @{theory} (3, 3, 1) @{type_name btre}; \<close>
  24.102 +
  24.103 +thm btre.induct btre.rec
  24.104 +thm compat_btre.induct compat_btre.rec
  24.105 +
  24.106 +datatype_new 'a foo = Foo | Foo' 'a "'a bar" and 'a bar = Bar | Bar' 'a "'a foo"
  24.107 +
  24.108 +ML \<open> get_descrs @{theory} (0, 2, 2) @{type_name foo}; \<close>
  24.109 +ML \<open> get_descrs @{theory} (0, 2, 2) @{type_name bar}; \<close>
  24.110 +
  24.111 +datatype_compat foo bar
  24.112 +
  24.113 +ML \<open> get_descrs @{theory} (2, 2, 2) @{type_name foo}; \<close>
  24.114 +ML \<open> get_descrs @{theory} (2, 2, 2) @{type_name bar}; \<close>
  24.115 +
  24.116 +datatype_new 'a tre = Tre 'a "'a tre lst"
  24.117 +
  24.118 +ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name tre}; \<close>
  24.119 +
  24.120 +datatype_compat tre
  24.121 +
  24.122 +ML \<open> get_descrs @{theory} (2, 2, 1) @{type_name tre}; \<close>
  24.123 +
  24.124 +thm tre.induct tre.rec
  24.125 +thm compat_tre.induct compat_tre.rec
  24.126 +
  24.127 +datatype_new 'a f = F 'a and 'a g = G 'a
  24.128 +
  24.129 +ML \<open> get_descrs @{theory} (0, 2, 2) @{type_name f}; \<close>
  24.130 +ML \<open> get_descrs @{theory} (0, 2, 2) @{type_name g}; \<close>
  24.131 +
  24.132 +datatype_new h = H "h f" | H'
  24.133 +
  24.134 +ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name h}; \<close>
  24.135 +
  24.136 +datatype_compat f g
  24.137 +
  24.138 +ML \<open> get_descrs @{theory} (2, 2, 2) @{type_name f}; \<close>
  24.139 +ML \<open> get_descrs @{theory} (2, 2, 2) @{type_name g}; \<close>
  24.140 +ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name h}; \<close>
  24.141 +
  24.142 +datatype_compat h
  24.143 +
  24.144 +ML \<open> get_descrs @{theory} (3, 3, 1) @{type_name h}; \<close>
  24.145 +
  24.146 +thm h.induct h.rec
  24.147 +thm compat_h.induct compat_h.rec
  24.148 +
  24.149 +datatype_new myunit = MyUnity
  24.150 +
  24.151 +ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name myunit}; \<close>
  24.152 +
  24.153 +datatype_compat myunit
  24.154 +
  24.155 +ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name myunit}; \<close>
  24.156 +
  24.157 +datatype_new mylist = MyNil | MyCons nat mylist
  24.158 +
  24.159 +ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name mylist}; \<close>
  24.160 +
  24.161 +datatype_compat mylist
  24.162 +
  24.163 +ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name mylist}; \<close>
  24.164 +
  24.165 +datatype_new foo' = FooNil | FooCons bar' foo' and bar' = Bar
  24.166 +
  24.167 +ML \<open> get_descrs @{theory} (0, 2, 2) @{type_name foo'}; \<close>
  24.168 +ML \<open> get_descrs @{theory} (0, 2, 2) @{type_name bar'}; \<close>
  24.169 +
  24.170 +datatype_compat bar' foo'
  24.171 +
  24.172 +ML \<open> get_descrs @{theory} (2, 2, 2) @{type_name foo'}; \<close>
  24.173 +ML \<open> get_descrs @{theory} (2, 2, 2) @{type_name bar'}; \<close>
  24.174 +
  24.175 +old_datatype funky = Funky "funky tre" | Funky'
  24.176 +
  24.177 +ML \<open> get_descrs @{theory} (3, 3, 3) @{type_name funky}; \<close>
  24.178 +
  24.179 +old_datatype fnky = Fnky "nat tre"
  24.180 +
  24.181 +ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name fnky}; \<close>
  24.182 +
  24.183 +datatype_new tree = Tree "tree foo"
  24.184 +
  24.185 +ML \<open> get_descrs @{theory} (0, 1, 1) @{type_name tree}; \<close>
  24.186 +
  24.187 +datatype_compat tree
  24.188 +
  24.189 +ML \<open> get_descrs @{theory} (3, 3, 1) @{type_name tree}; \<close>
  24.190 +
  24.191 +thm tree.induct tree.rec
  24.192 +thm compat_tree.induct compat_tree.rec
  24.193 +
  24.194 +
  24.195 +subsection \<open> Creating New-Style Datatypes Using Old-Style Interfaces \<close>
  24.196 +
  24.197 +ML \<open>
  24.198 +val l_specs =
  24.199 +  [((@{binding l}, [("'a", @{sort type})], NoSyn),
  24.200 +   [(@{binding N}, [], NoSyn),
  24.201 +    (@{binding C}, [@{typ 'a}, Type (Sign.full_name @{theory} @{binding l}, [@{typ 'a}])], NoSyn)])];
  24.202 +\<close>
  24.203 +
  24.204 +setup \<open> snd o BNF_LFP_Compat.add_datatype BNF_LFP_Compat.Unfold_Nesting l_specs; \<close>
  24.205 +
  24.206 +ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name l}; \<close>
  24.207 +
  24.208 +thm l.exhaust l.map l.induct l.rec l.size
  24.209 +
  24.210 +ML \<open>
  24.211 +val t_specs =
  24.212 +  [((@{binding t}, [("'b", @{sort type})], NoSyn),
  24.213 +   [(@{binding T}, [@{typ 'b}, Type (@{type_name l},
  24.214 +       [Type (Sign.full_name @{theory} @{binding t}, [@{typ 'b}])])], NoSyn)])];
  24.215 +\<close>
  24.216 +
  24.217 +setup \<open> snd o BNF_LFP_Compat.add_datatype BNF_LFP_Compat.Unfold_Nesting t_specs; \<close>
  24.218 +
  24.219 +ML \<open> get_descrs @{theory} (2, 2, 1) @{type_name t}; \<close>
  24.220 +
  24.221 +thm t.exhaust t.map t.induct t.rec t.size
  24.222 +thm compat_t.induct compat_t.rec
  24.223 +
  24.224 +ML \<open>
  24.225 +val ft_specs =
  24.226 +  [((@{binding ft}, [("'a", @{sort type})], NoSyn),
  24.227 +   [(@{binding FT0}, [], NoSyn),
  24.228 +    (@{binding FT}, [@{typ 'a} --> Type (Sign.full_name @{theory} @{binding ft}, [@{typ 'a}])],
  24.229 +     NoSyn)])];
  24.230 +\<close>
  24.231 +
  24.232 +setup \<open> snd o BNF_LFP_Compat.add_datatype BNF_LFP_Compat.Unfold_Nesting ft_specs; \<close>
  24.233 +
  24.234 +ML \<open> get_descrs @{theory} (1, 1, 1) @{type_name ft}; \<close>
  24.235 +
  24.236 +thm ft.exhaust ft.induct ft.rec ft.size
  24.237 +thm compat_ft.induct compat_ft.rec
  24.238 +
  24.239 +end
    25.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    25.2 +++ b/src/HOL/Datatype_Examples/Derivation_Trees/DTree.thy	Thu Sep 11 19:26:59 2014 +0200
    25.3 @@ -0,0 +1,90 @@
    25.4 +(*  Title:      HOL/Datatype_Examples/Derivation_Trees/DTree.thy
    25.5 +    Author:     Andrei Popescu, TU Muenchen
    25.6 +    Copyright   2012
    25.7 +
    25.8 +Derivation trees with nonterminal internal nodes and terminal leaves.
    25.9 +*)
   25.10 +
   25.11 +header {* Trees with Nonterminal Internal Nodes and Terminal Leaves *}
   25.12 +
   25.13 +theory DTree
   25.14 +imports Prelim
   25.15 +begin
   25.16 +
   25.17 +typedecl N
   25.18 +typedecl T
   25.19 +
   25.20 +codatatype dtree = NNode (root: N) (ccont: "(T + dtree) fset")
   25.21 +
   25.22 +subsection{* Transporting the Characteristic Lemmas from @{text "fset"} to @{text "set"} *}
   25.23 +
   25.24 +definition "Node n as \<equiv> NNode n (the_inv fset as)"
   25.25 +definition "cont \<equiv> fset o ccont"
   25.26 +definition "unfold rt ct \<equiv> corec_dtree rt (the_inv fset o image (map_sum id Inr) o ct)"
   25.27 +definition "corec rt ct \<equiv> corec_dtree rt (the_inv fset o ct)"
   25.28 +
   25.29 +lemma finite_cont[simp]: "finite (cont tr)"
   25.30 +  unfolding cont_def comp_apply by (cases tr, clarsimp)
   25.31 +
   25.32 +lemma Node_root_cont[simp]:
   25.33 +  "Node (root tr) (cont tr) = tr"
   25.34 +  unfolding Node_def cont_def comp_apply
   25.35 +  apply (rule trans[OF _ dtree.collapse])
   25.36 +  apply (rule arg_cong2[OF refl the_inv_into_f_f[unfolded inj_on_def]])
   25.37 +  apply (simp_all add: fset_inject)
   25.38 +  done
   25.39 +
   25.40 +lemma dtree_simps[simp]:
   25.41 +assumes "finite as" and "finite as'"
   25.42 +shows "Node n as = Node n' as' \<longleftrightarrow> n = n' \<and> as = as'"
   25.43 +using assms dtree.inject unfolding Node_def
   25.44 +by (metis fset_to_fset)
   25.45 +
   25.46 +lemma dtree_cases[elim, case_names Node Choice]:
   25.47 +assumes Node: "\<And> n as. \<lbrakk>finite as; tr = Node n as\<rbrakk> \<Longrightarrow> phi"
   25.48 +shows phi
   25.49 +apply(cases rule: dtree.exhaust[of tr])
   25.50 +using Node unfolding Node_def
   25.51 +by (metis Node Node_root_cont finite_cont)
   25.52 +
   25.53 +lemma dtree_sel_ctr[simp]:
   25.54 +"root (Node n as) = n"
   25.55 +"finite as \<Longrightarrow> cont (Node n as) = as"
   25.56 +unfolding Node_def cont_def by auto
   25.57 +
   25.58 +lemmas root_Node = dtree_sel_ctr(1)
   25.59 +lemmas cont_Node = dtree_sel_ctr(2)
   25.60 +
   25.61 +lemma dtree_cong:
   25.62 +assumes "root tr = root tr'" and "cont tr = cont tr'"
   25.63 +shows "tr = tr'"
   25.64 +by (metis Node_root_cont assms)
   25.65 +
   25.66 +lemma rel_set_cont:
   25.67 +"rel_set \<chi> (cont tr1) (cont tr2) = rel_fset \<chi> (ccont tr1) (ccont tr2)"
   25.68 +unfolding cont_def comp_def rel_fset_fset ..
   25.69 +
   25.70 +lemma dtree_coinduct[elim, consumes 1, case_names Lift, induct pred: "HOL.eq"]:
   25.71 +assumes phi: "\<phi> tr1 tr2" and
   25.72 +Lift: "\<And> tr1 tr2. \<phi> tr1 tr2 \<Longrightarrow>
   25.73 +                  root tr1 = root tr2 \<and> rel_set (rel_sum op = \<phi>) (cont tr1) (cont tr2)"
   25.74 +shows "tr1 = tr2"
   25.75 +using phi apply(elim dtree.coinduct)
   25.76 +apply(rule Lift[unfolded rel_set_cont]) .
   25.77 +
   25.78 +lemma unfold:
   25.79 +"root (unfold rt ct b) = rt b"
   25.80 +"finite (ct b) \<Longrightarrow> cont (unfold rt ct b) = image (id \<oplus> unfold rt ct) (ct b)"
   25.81 +using dtree.corec_sel[of rt "the_inv fset o image (map_sum id Inr) o ct" b] unfolding unfold_def
   25.82 +apply blast
   25.83 +unfolding cont_def comp_def
   25.84 +by (simp add: case_sum_o_inj map_sum.compositionality image_image)
   25.85 +
   25.86 +lemma corec:
   25.87 +"root (corec rt ct b) = rt b"
   25.88 +"finite (ct b) \<Longrightarrow> cont (corec rt ct b) = image (id \<oplus> ([[id, corec rt ct]])) (ct b)"
   25.89 +using dtree.corec_sel[of rt "the_inv fset \<circ> ct" b] unfolding corec_def
   25.90 +unfolding cont_def comp_def id_def
   25.91 +by simp_all
   25.92 +
   25.93 +end
    26.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    26.2 +++ b/src/HOL/Datatype_Examples/Derivation_Trees/Gram_Lang.thy	Thu Sep 11 19:26:59 2014 +0200
    26.3 @@ -0,0 +1,1357 @@
    26.4 +(*  Title:      HOL/Datatype_Examples/Derivation_Trees/Gram_Lang.thy
    26.5 +    Author:     Andrei Popescu, TU Muenchen
    26.6 +    Copyright   2012
    26.7 +
    26.8 +Language of a grammar.
    26.9 +*)
   26.10 +
   26.11 +header {* Language of a Grammar *}
   26.12 +
   26.13 +theory Gram_Lang
   26.14 +imports DTree "~~/src/HOL/Library/Infinite_Set"
   26.15 +begin
   26.16 +
   26.17 +
   26.18 +(* We assume that the sets of terminals, and the left-hand sides of
   26.19 +productions are finite and that the grammar has no unused nonterminals. *)
   26.20 +consts P :: "(N \<times> (T + N) set) set"
   26.21 +axiomatization where
   26.22 +    finite_N: "finite (UNIV::N set)"
   26.23 +and finite_in_P: "\<And> n tns. (n,tns) \<in> P \<longrightarrow> finite tns"
   26.24 +and used: "\<And> n. \<exists> tns. (n,tns) \<in> P"
   26.25 +
   26.26 +
   26.27 +subsection{* Tree Basics: frontier, interior, etc. *}
   26.28 +
   26.29 +
   26.30 +(* Frontier *)
   26.31 +
   26.32 +inductive inFr :: "N set \<Rightarrow> dtree \<Rightarrow> T \<Rightarrow> bool" where
   26.33 +Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr ns tr t"
   26.34 +|
   26.35 +Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inFr ns tr1 t\<rbrakk> \<Longrightarrow> inFr ns tr t"
   26.36 +
   26.37 +definition "Fr ns tr \<equiv> {t. inFr ns tr t}"
   26.38 +
   26.39 +lemma inFr_root_in: "inFr ns tr t \<Longrightarrow> root tr \<in> ns"
   26.40 +by (metis inFr.simps)
   26.41 +
   26.42 +lemma inFr_mono:
   26.43 +assumes "inFr ns tr t" and "ns \<subseteq> ns'"
   26.44 +shows "inFr ns' tr t"
   26.45 +using assms apply(induct arbitrary: ns' rule: inFr.induct)
   26.46 +using Base Ind by (metis inFr.simps set_mp)+
   26.47 +
   26.48 +lemma inFr_Ind_minus:
   26.49 +assumes "inFr ns1 tr1 t" and "Inr tr1 \<in> cont tr"
   26.50 +shows "inFr (insert (root tr) ns1) tr t"
   26.51 +using assms apply(induct rule: inFr.induct)
   26.52 +  apply (metis inFr.simps insert_iff)
   26.53 +  by (metis inFr.simps inFr_mono insertI1 subset_insertI)
   26.54 +
   26.55 +(* alternative definition *)
   26.56 +inductive inFr2 :: "N set \<Rightarrow> dtree \<Rightarrow> T \<Rightarrow> bool" where
   26.57 +Base: "\<lbrakk>root tr \<in> ns; Inl t \<in> cont tr\<rbrakk> \<Longrightarrow> inFr2 ns tr t"
   26.58 +|
   26.59 +Ind: "\<lbrakk>Inr tr1 \<in> cont tr; inFr2 ns1 tr1 t\<rbrakk>
   26.60 +      \<Longrightarrow> inFr2 (insert (root tr) ns1) tr t"
   26.61 +
   26.62 +lemma inFr2_root_in: "inFr2 ns tr t \<Longrightarrow> root tr \<in> ns"
   26.63 +apply(induct rule: inFr2.induct) by auto
   26.64 +
   26.65 +lemma inFr2_mono:
   26.66 +assumes "inFr2 ns tr t" and "ns \<subseteq> ns'"
   26.67 +shows "inFr2 ns' tr t"
   26.68 +using assms apply(induct arbitrary: ns' rule: inFr2.induct)
   26.69 +using Base Ind
   26.70 +apply (metis subsetD) by (metis inFr2.simps insert_absorb insert_subset)
   26.71 +
   26.72 +lemma inFr2_Ind:
   26.73 +assumes "inFr2 ns tr1 t" and "root tr \<in> ns" and "Inr tr1 \<in> cont tr"
   26.74 +shows "inFr2 ns tr t"
   26.75 +using assms apply(induct rule: inFr2.induct)
   26.76 +  apply (metis inFr2.simps insert_absorb)
   26.77 +  by (metis inFr2.simps insert_absorb)
   26.78 +
   26.79 +lemma inFr_inFr2:
   26.80 +"inFr = inFr2"
   26.81 +apply (rule ext)+  apply(safe)
   26.82 +  apply(erule inFr.induct)
   26.83 +    apply (metis (lifting) inFr2.Base)
   26.84 +    apply (metis (lifting) inFr2_Ind)
   26.85 +  apply(erule inFr2.induct)
   26.86 +    apply (metis (lifting) inFr.Base)
   26.87 +    apply (metis (lifting) inFr_Ind_minus)
   26.88 +done
   26.89 +
   26.90 +lemma not_root_inFr:
   26.91 +assumes "root tr \<notin> ns"
   26.92 +shows "\<not> inFr ns tr t"
   26.93 +by (metis assms inFr_root_in)
   26.94 +
   26.95 +lemma not_root_Fr:
   26.96 +assumes "root tr \<notin> ns"
   26.97 +shows "Fr ns tr = {}"
   26.98 +using not_root_inFr[OF assms] unfolding Fr_def by auto
   26.99 +
  26.100 +
  26.101 +(* Interior *)
  26.102 +
  26.103 +inductive inItr :: "N set \<Rightarrow> dtree \<Rightarrow> N \<Rightarrow> bool" where
  26.104 +Base: "root tr \<in> ns \<Longrightarrow> inItr ns tr (root tr)"
  26.105 +|
  26.106 +Ind: "\<lbrakk>root tr \<in> ns; Inr tr1 \<in> cont tr; inItr ns tr1 n\<rbrakk> \<Longrightarrow> inItr ns tr n"
  26.107 +
  26.108 +definition "Itr ns tr \<equiv> {n. inItr ns tr n}"
  26.109 +
  26.110 +lemma inItr_root_in: "inItr ns tr n \<Longrightarrow> root tr \<in> ns"
  26.111 +by (metis inItr.simps)
  26.112 +
  26.113 +lemma inItr_mono:
  26.114 +assumes "inItr ns tr n" and "ns \<subseteq> ns'"
  26.115 +shows "inItr ns' tr n"
  26.116 +using assms apply(induct arbitrary: ns' rule: inItr.induct)
  26.117 +using Base Ind by (metis inItr.simps set_mp)+
  26.118 +
  26.119 +
  26.120 +(* The subtree relation *)
  26.121 +
  26.122 +inductive subtr where
  26.123 +Refl: "root tr \<in> ns \<Longrightarrow> subtr ns tr tr"
  26.124 +|
  26.125 +Step: "\<lbrakk>root tr3 \<in> ns; subtr ns tr1 tr2; Inr tr2 \<in> cont tr3\<rbrakk> \<Longrightarrow> subtr ns tr1 tr3"
  26.126 +
  26.127 +lemma subtr_rootL_in:
  26.128 +assumes "subtr ns tr1 tr2"
  26.129 +shows "root tr1 \<in> ns"
  26.130 +using assms apply(induct rule: subtr.induct) by auto
  26.131 +
  26.132 +lemma subtr_rootR_in:
  26.133 +assumes "subtr ns tr1 tr2"
  26.134 +shows "root tr2 \<in> ns"
  26.135 +using assms apply(induct rule: subtr.induct) by auto
  26.136 +
  26.137 +lemmas subtr_roots_in = subtr_rootL_in subtr_rootR_in
  26.138 +
  26.139 +lemma subtr_mono:
  26.140 +assumes "subtr ns tr1 tr2" and "ns \<subseteq> ns'"
  26.141 +shows "subtr ns' tr1 tr2"
  26.142 +using assms apply(induct arbitrary: ns' rule: subtr.induct)
  26.143 +using Refl Step by (metis subtr.simps set_mp)+
  26.144 +
  26.145 +lemma subtr_trans_Un:
  26.146 +assumes "subtr ns12 tr1 tr2" and "subtr ns23 tr2 tr3"
  26.147 +shows "subtr (ns12 \<union> ns23) tr1 tr3"
  26.148 +proof-
  26.149 +  have "subtr ns23 tr2 tr3  \<Longrightarrow>
  26.150 +        (\<forall> ns12 tr1. subtr ns12 tr1 tr2 \<longrightarrow> subtr (ns12 \<union> ns23) tr1 tr3)"
  26.151 +  apply(induct  rule: subtr.induct, safe)
  26.152 +    apply (metis subtr_mono sup_commute sup_ge2)
  26.153 +    by (metis (lifting) Step UnI2)
  26.154 +  thus ?thesis using assms by auto
  26.155 +qed
  26.156 +
  26.157 +lemma subtr_trans:
  26.158 +assumes "subtr ns tr1 tr2" and "subtr ns tr2 tr3"
  26.159 +shows "subtr ns tr1 tr3"
  26.160 +using subtr_trans_Un[OF assms] by simp
  26.161 +
  26.162 +lemma subtr_StepL:
  26.163 +assumes r: "root tr1 \<in> ns" and tr12: "Inr tr1 \<in> cont tr2" and s: "subtr ns tr2 tr3"
  26.164 +shows "subtr ns tr1 tr3"
  26.165 +apply(rule subtr_trans[OF _ s])
  26.166 +apply(rule Step[of tr2 ns tr1 tr1])
  26.167 +apply(rule subtr_rootL_in[OF s])
  26.168 +apply(rule Refl[OF r])
  26.169 +apply(rule tr12)
  26.170 +done
  26.171 +
  26.172 +(* alternative definition: *)
  26.173 +inductive subtr2 where
  26.174 +Refl: "root tr \<in> ns \<Longrightarrow> subtr2 ns tr tr"
  26.175 +|
  26.176 +Step: "\<lbrakk>root tr1 \<in> ns; Inr tr1 \<in> cont tr2; subtr2 ns tr2 tr3\<rbrakk> \<Longrightarrow> subtr2 ns tr1 tr3"
  26.177 +
  26.178 +lemma subtr2_rootL_in:
  26.179 +assumes "subtr2 ns tr1 tr2"
  26.180 +shows "root tr1 \<in> ns"
  26.181 +using assms apply(induct rule: subtr2.induct) by auto
  26.182 +
  26.183 +lemma subtr2_rootR_in:
  26.184 +assumes "subtr2 ns tr1 tr2"
  26.185 +shows "root tr2 \<in> ns"
  26.186 +using assms apply(induct rule: subtr2.induct) by auto
  26.187 +
  26.188 +lemmas subtr2_roots_in = subtr2_rootL_in subtr2_rootR_in
  26.189 +
  26.190 +lemma subtr2_mono:
  26.191 +assumes "subtr2 ns tr1 tr2" and "ns \<subseteq> ns'"
  26.192 +shows "subtr2 ns' tr1 tr2"
  26.193 +using assms apply(induct arbitrary: ns' rule: subtr2.induct)
  26.194 +using Refl Step by (metis subtr2.simps set_mp)+
  26.195 +
  26.196 +lemma subtr2_trans_Un:
  26.197 +assumes "subtr2 ns12 tr1 tr2" and "subtr2 ns23 tr2 tr3"
  26.198 +shows "subtr2 (ns12 \<union> ns23) tr1 tr3"
  26.199 +proof-
  26.200 +  have "subtr2 ns12 tr1 tr2  \<Longrightarrow>
  26.201 +        (\<forall> ns23 tr3. subtr2 ns23 tr2 tr3 \<longrightarrow> subtr2 (ns12 \<union> ns23) tr1 tr3)"
  26.202 +  apply(induct  rule: subtr2.induct, safe)
  26.203 +    apply (metis subtr2_mono sup_commute sup_ge2)
  26.204 +    by (metis Un_iff subtr2.simps)
  26.205 +  thus ?thesis using assms by auto
  26.206 +qed
  26.207 +
  26.208 +lemma subtr2_trans:
  26.209 +assumes "subtr2 ns tr1 tr2" and "subtr2 ns tr2 tr3"
  26.210 +shows "subtr2 ns tr1 tr3"
  26.211 +using subtr2_trans_Un[OF assms] by simp
  26.212 +
  26.213 +lemma subtr2_StepR:
  26.214 +assumes r: "root tr3 \<in> ns" and tr23: "Inr tr2 \<in> cont tr3" and s: "subtr2 ns tr1 tr2"
  26.215 +shows "subtr2 ns tr1 tr3"
  26.216 +apply(rule subtr2_trans[OF s])
  26.217 +apply(rule Step[of _ _ tr3])
  26.218 +apply(rule subtr2_rootR_in[OF s])
  26.219 +apply(rule tr23)
  26.220 +apply(rule Refl[OF r])
  26.221 +done
  26.222 +
  26.223 +lemma subtr_subtr2:
  26.224 +"subtr = subtr2"
  26.225 +apply (rule ext)+  apply(safe)
  26.226 +  apply(erule subtr.induct)
  26.227 +    apply (metis (lifting) subtr2.Refl)
  26.228 +    apply (metis (lifting) subtr2_StepR)
  26.229 +  apply(erule subtr2.induct)
  26.230 +    apply (metis (lifting) subtr.Refl)
  26.231 +    apply (metis (lifting) subtr_StepL)
  26.232 +done
  26.233 +
  26.234 +lemma subtr_inductL[consumes 1, case_names Refl Step]:
  26.235 +assumes s: "subtr ns tr1 tr2" and Refl: "\<And>ns tr. \<phi> ns tr tr"
  26.236 +and Step:
  26.237 +"\<And>ns tr1 tr2 tr3.
  26.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"
  26.239 +shows "\<phi> ns tr1 tr2"
  26.240 +using s unfolding subtr_subtr2 apply(rule subtr2.induct)
  26.241 +using Refl Step unfolding subtr_subtr2 by auto
  26.242 +
  26.243 +lemma subtr_UNIV_inductL[consumes 1, case_names Refl Step]:
  26.244 +assumes s: "subtr UNIV tr1 tr2" and Refl: "\<And>tr. \<phi> tr tr"
  26.245 +and Step:
  26.246 +"\<And>tr1 tr2 tr3.
  26.247 +   \<lbrakk>Inr tr1 \<in> cont tr2; subtr UNIV tr2 tr3; \<phi> tr2 tr3\<rbrakk> \<Longrightarrow> \<phi> tr1 tr3"
  26.248 +shows "\<phi> tr1 tr2"
  26.249 +using s apply(induct rule: subtr_inductL)
  26.250 +apply(rule Refl) using Step subtr_mono by (metis subset_UNIV)
  26.251 +
  26.252 +(* Subtree versus frontier: *)
  26.253 +lemma subtr_inFr:
  26.254 +assumes "inFr ns tr t" and "subtr ns tr tr1"
  26.255 +shows "inFr ns tr1 t"
  26.256 +proof-
  26.257 +  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inFr ns tr t \<longrightarrow> inFr ns tr1 t)"
  26.258 +  apply(induct rule: subtr.induct, safe) by (metis inFr.Ind)
  26.259 +  thus ?thesis using assms by auto
  26.260 +qed
  26.261 +
  26.262 +corollary Fr_subtr:
  26.263 +"Fr ns tr = \<Union> {Fr ns tr' | tr'. subtr ns tr' tr}"
  26.264 +unfolding Fr_def proof safe
  26.265 +  fix t assume t: "inFr ns tr t"  hence "root tr \<in> ns" by (rule inFr_root_in)
  26.266 +  thus "t \<in> \<Union>{{t. inFr ns tr' t} |tr'. subtr ns tr' tr}"
  26.267 +  apply(intro UnionI[of "{t. inFr ns tr t}" _ t]) using t subtr.Refl by auto
  26.268 +qed(metis subtr_inFr)
  26.269 +
  26.270 +lemma inFr_subtr:
  26.271 +assumes "inFr ns tr t"
  26.272 +shows "\<exists> tr'. subtr ns tr' tr \<and> Inl t \<in> cont tr'"
  26.273 +using assms apply(induct rule: inFr.induct) apply safe
  26.274 +  apply (metis subtr.Refl)
  26.275 +  by (metis (lifting) subtr.Step)
  26.276 +
  26.277 +corollary Fr_subtr_cont:
  26.278 +"Fr ns tr = \<Union> {Inl -` cont tr' | tr'. subtr ns tr' tr}"
  26.279 +unfolding Fr_def
  26.280 +apply safe
  26.281 +apply (frule inFr_subtr)
  26.282 +apply auto
  26.283 +by (metis inFr.Base subtr_inFr subtr_rootL_in)
  26.284 +
  26.285 +(* Subtree versus interior: *)
  26.286 +lemma subtr_inItr:
  26.287 +assumes "inItr ns tr n" and "subtr ns tr tr1"
  26.288 +shows "inItr ns tr1 n"
  26.289 +proof-
  26.290 +  have "subtr ns tr tr1 \<Longrightarrow> (\<forall> t. inItr ns tr n \<longrightarrow> inItr ns tr1 n)"
  26.291 +  apply(induct rule: subtr.induct, safe) by (metis inItr.Ind)
  26.292 +  thus ?thesis using assms by auto
  26.293 +qed
  26.294 +
  26.295 +corollary Itr_subtr:
  26.296 +"Itr ns tr = \<Union> {Itr ns tr' | tr'. subtr ns tr' tr}"
  26.297 +unfolding Itr_def apply safe
  26.298 +apply (metis (lifting, mono_tags) UnionI inItr_root_in mem_Collect_eq subtr.Refl)
  26.299 +by (metis subtr_inItr)
  26.300 +
  26.301 +lemma inItr_subtr:
  26.302 +assumes "inItr ns tr n"
  26.303 +shows "\<exists> tr'. subtr ns tr' tr \<and> root tr' = n"
  26.304 +using assms apply(induct rule: inItr.induct) apply safe
  26.305 +  apply (metis subtr.Refl)
  26.306 +  by (metis (lifting) subtr.Step)
  26.307 +
  26.308 +corollary Itr_subtr_cont:
  26.309 +"Itr ns tr = {root tr' | tr'. subtr ns tr' tr}"
  26.310 +unfolding Itr_def apply safe
  26.311 +  apply (metis (lifting, mono_tags) inItr_subtr)
  26.312 +  by (metis inItr.Base subtr_inItr subtr_rootL_in)
  26.313 +
  26.314 +
  26.315 +subsection{* The Immediate Subtree Function *}
  26.316 +
  26.317 +(* production of: *)
  26.318 +abbreviation "prodOf tr \<equiv> (id \<oplus> root) ` (cont tr)"
  26.319 +(* subtree of: *)
  26.320 +definition "subtrOf tr n \<equiv> SOME tr'. Inr tr' \<in> cont tr \<and> root tr' = n"
  26.321 +
  26.322 +lemma subtrOf:
  26.323 +assumes n: "Inr n \<in> prodOf tr"
  26.324 +shows "Inr (subtrOf tr n) \<in> cont tr \<and> root (subtrOf tr n) = n"
  26.325 +proof-
  26.326 +  obtain tr' where "Inr tr' \<in> cont tr \<and> root tr' = n"
  26.327 +  using n unfolding image_def by (metis (lifting) Inr_oplus_elim assms)
  26.328 +  thus ?thesis unfolding subtrOf_def by(rule someI)
  26.329 +qed
  26.330 +
  26.331 +lemmas Inr_subtrOf = subtrOf[THEN conjunct1]
  26.332 +lemmas root_subtrOf[simp] = subtrOf[THEN conjunct2]
  26.333 +
  26.334 +lemma Inl_prodOf: "Inl -` (prodOf tr) = Inl -` (cont tr)"
  26.335 +proof safe
  26.336 +  fix t ttr assume "Inl t = (id \<oplus> root) ttr" and "ttr \<in> cont tr"
  26.337 +  thus "t \<in> Inl -` cont tr" by(cases ttr, auto)
  26.338 +next
  26.339 +  fix t assume "Inl t \<in> cont tr" thus "t \<in> Inl -` prodOf tr"
  26.340 +  by (metis (lifting) id_def image_iff map_sum.simps(1) vimageI2)
  26.341 +qed
  26.342 +
  26.343 +lemma root_prodOf:
  26.344 +assumes "Inr tr' \<in> cont tr"
  26.345 +shows "Inr (root tr') \<in> prodOf tr"
  26.346 +by (metis (lifting) assms image_iff map_sum.simps(2))
  26.347 +
  26.348 +
  26.349 +subsection{* Well-Formed Derivation Trees *}
  26.350 +
  26.351 +hide_const wf
  26.352 +
  26.353 +coinductive wf where
  26.354 +dtree: "\<lbrakk>(root tr, (id \<oplus> root) ` (cont tr)) \<in> P; inj_on root (Inr -` cont tr);
  26.355 +        \<And> tr'. tr' \<in> Inr -` (cont tr) \<Longrightarrow> wf tr'\<rbrakk> \<Longrightarrow> wf tr"
  26.356 +
  26.357 +(* destruction rules: *)
  26.358 +lemma wf_P:
  26.359 +assumes "wf tr"
  26.360 +shows "(root tr, (id \<oplus> root) ` (cont tr)) \<in> P"
  26.361 +using assms wf.simps[of tr] by auto
  26.362 +
  26.363 +lemma wf_inj_on:
  26.364 +assumes "wf tr"
  26.365 +shows "inj_on root (Inr -` cont tr)"
  26.366 +using assms wf.simps[of tr] by auto
  26.367 +
  26.368 +lemma wf_inj[simp]:
  26.369 +assumes "wf tr" and "Inr tr1 \<in> cont tr" and "Inr tr2 \<in> cont tr"
  26.370 +shows "root tr1 = root tr2 \<longleftrightarrow> tr1 = tr2"
  26.371 +using assms wf_inj_on unfolding inj_on_def by auto
  26.372 +
  26.373 +lemma wf_cont:
  26.374 +assumes "wf tr" and "Inr tr' \<in> cont tr"
  26.375 +shows "wf tr'"
  26.376 +using assms wf.simps[of tr] by auto
  26.377 +
  26.378 +
  26.379 +(* coinduction:*)
  26.380 +lemma wf_coind[elim, consumes 1, case_names Hyp]:
  26.381 +assumes phi: "\<phi> tr"
  26.382 +and Hyp:
  26.383 +"\<And> tr. \<phi> tr \<Longrightarrow>
  26.384 +       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
  26.385 +       inj_on root (Inr -` cont tr) \<and>
  26.386 +       (\<forall> tr' \<in> Inr -` (cont tr). \<phi> tr' \<or> wf tr')"
  26.387 +shows "wf tr"
  26.388 +apply(rule wf.coinduct[of \<phi> tr, OF phi])
  26.389 +using Hyp by blast
  26.390 +
  26.391 +lemma wf_raw_coind[elim, consumes 1, case_names Hyp]:
  26.392 +assumes phi: "\<phi> tr"
  26.393 +and Hyp:
  26.394 +"\<And> tr. \<phi> tr \<Longrightarrow>
  26.395 +       (root tr, image (id \<oplus> root) (cont tr)) \<in> P \<and>
  26.396 +       inj_on root (Inr -` cont tr) \<and>
  26.397 +       (\<forall> tr' \<in> Inr -` (cont tr). \<phi> tr')"
  26.398 +shows "wf tr"
  26.399 +using phi apply(induct rule: wf_coind)
  26.400 +using Hyp by (metis (mono_tags))
  26.401 +
  26.402 +lemma wf_subtr_inj_on:
  26.403 +assumes d: "wf tr1" and s: "subtr ns tr tr1"
  26.404 +shows "inj_on root (Inr -` cont tr)"
  26.405 +using s d apply(induct rule: subtr.induct)
  26.406 +apply (metis (lifting) wf_inj_on) by (metis wf_cont)
  26.407 +
  26.408 +lemma wf_subtr_P:
  26.409 +assumes d: "wf tr1" and s: "subtr ns tr tr1"
  26.410 +shows "(root tr, (id \<oplus> root) ` cont tr) \<in> P"
  26.411 +using s d apply(induct rule: subtr.induct)
  26.412 +apply (metis (lifting) wf_P) by (metis wf_cont)
  26.413 +
  26.414 +lemma subtrOf_root[simp]:
  26.415 +assumes tr: "wf tr" and cont: "Inr tr' \<in> cont tr"
  26.416 +shows "subtrOf tr (root tr') = tr'"
  26.417 +proof-
  26.418 +  have 0: "Inr (subtrOf tr (root tr')) \<in> cont tr" using Inr_subtrOf
  26.419 +  by (metis (lifting) cont root_prodOf)
  26.420 +  have "root (subtrOf tr (root tr')) = root tr'"
  26.421 +  using root_subtrOf by (metis (lifting) cont root_prodOf)
  26.422 +  thus ?thesis unfolding wf_inj[OF tr 0 cont] .
  26.423 +qed
  26.424 +
  26.425 +lemma surj_subtrOf:
  26.426 +assumes "wf tr" and 0: "Inr tr' \<in> cont tr"
  26.427 +shows "\<exists> n. Inr n \<in> prodOf tr \<and> subtrOf tr n = tr'"
  26.428 +apply(rule exI[of _ "root tr'"])
  26.429 +using root_prodOf[OF 0] subtrOf_root[OF assms] by simp
  26.430 +
  26.431 +lemma wf_subtr:
  26.432 +assumes "wf tr1" and "subtr ns tr tr1"
  26.433 +shows "wf tr"
  26.434 +proof-
  26.435 +  have "(\<exists> ns tr1. wf tr1 \<and> subtr ns tr tr1) \<Longrightarrow> wf tr"
  26.436 +  proof (induct rule: wf_raw_coind)
  26.437 +    case (Hyp tr)
  26.438 +    then obtain ns tr1 where tr1: "wf tr1" and tr_tr1: "subtr ns tr tr1" by auto
  26.439 +    show ?case proof safe
  26.440 +      show "(root tr, (id \<oplus> root) ` cont tr) \<in> P" using wf_subtr_P[OF tr1 tr_tr1] .
  26.441 +    next
  26.442 +      show "inj_on root (Inr -` cont tr)" using wf_subtr_inj_on[OF tr1 tr_tr1] .
  26.443 +    next
  26.444 +      fix tr' assume tr': "Inr tr' \<in> cont tr"
  26.445 +      have tr_tr1: "subtr (ns \<union> {root tr'}) tr tr1" using subtr_mono[OF tr_tr1] by auto
  26.446 +      have "subtr (ns \<union> {root tr'}) tr' tr1" using subtr_StepL[OF _ tr' tr_tr1] by auto
  26.447 +      thus "\<exists>ns' tr1. wf tr1 \<and> subtr ns' tr' tr1" using tr1 by blast
  26.448 +    qed
  26.449 +  qed
  26.450 +  thus ?thesis using assms by auto
  26.451 +qed
  26.452 +
  26.453 +
  26.454 +subsection{* Default Trees *}
  26.455 +
  26.456 +(* Pick a left-hand side of a production for each nonterminal *)
  26.457 +definition S where "S n \<equiv> SOME tns. (n,tns) \<in> P"
  26.458 +
  26.459 +lemma S_P: "(n, S n) \<in> P"
  26.460 +using used unfolding S_def by(rule someI_ex)
  26.461 +
  26.462 +lemma finite_S: "finite (S n)"
  26.463 +using S_P finite_in_P by auto
  26.464 +
  26.465 +
  26.466 +(* The default tree of a nonterminal *)
  26.467 +definition deftr :: "N \<Rightarrow> dtree" where
  26.468 +"deftr \<equiv> unfold id S"
  26.469 +
  26.470 +lemma deftr_simps[simp]:
  26.471 +"root (deftr n) = n"
  26.472 +"cont (deftr n) = image (id \<oplus> deftr) (S n)"
  26.473 +using unfold(1)[of id S n] unfold(2)[of S n id, OF finite_S]
  26.474 +unfolding deftr_def by simp_all
  26.475 +
  26.476 +lemmas root_deftr = deftr_simps(1)
  26.477 +lemmas cont_deftr = deftr_simps(2)
  26.478 +
  26.479 +lemma root_o_deftr[simp]: "root o deftr = id"
  26.480 +by (rule ext, auto)
  26.481 +
  26.482 +lemma wf_deftr: "wf (deftr n)"
  26.483 +proof-
  26.484 +  {fix tr assume "\<exists> n. tr = deftr n" hence "wf tr"
  26.485 +   apply(induct rule: wf_raw_coind) apply safe
  26.486 +   unfolding deftr_simps image_comp map_sum.comp id_comp
  26.487 +   root_o_deftr map_sum.id image_id id_apply apply(rule S_P)
  26.488 +   unfolding inj_on_def by auto
  26.489 +  }
  26.490 +  thus ?thesis by auto
  26.491 +qed
  26.492 +
  26.493 +
  26.494 +subsection{* Hereditary Substitution *}
  26.495 +
  26.496 +(* Auxiliary concept: The root-ommiting frontier: *)
  26.497 +definition "inFrr ns tr t \<equiv> \<exists> tr'. Inr tr' \<in> cont tr \<and> inFr ns tr' t"
  26.498 +definition "Frr ns tr \<equiv> {t. \<exists> tr'. Inr tr' \<in> cont tr \<and> t \<in> Fr ns tr'}"
  26.499 +
  26.500 +context
  26.501 +fixes tr0 :: dtree
  26.502 +begin
  26.503 +
  26.504 +definition "hsubst_r tr \<equiv> root tr"
  26.505 +definition "hsubst_c tr \<equiv> if root tr = root tr0 then cont tr0 else cont tr"
  26.506 +
  26.507 +(* Hereditary substitution: *)
  26.508 +definition hsubst :: "dtree \<Rightarrow> dtree" where
  26.509 +"hsubst \<equiv> unfold hsubst_r hsubst_c"
  26.510 +
  26.511 +lemma finite_hsubst_c: "finite (hsubst_c n)"
  26.512 +unfolding hsubst_c_def by (metis (full_types) finite_cont)
  26.513 +
  26.514 +lemma root_hsubst[simp]: "root (hsubst tr) = root tr"
  26.515 +using unfold(1)[of hsubst_r hsubst_c tr] unfolding hsubst_def hsubst_r_def by simp
  26.516 +
  26.517 +lemma root_o_subst[simp]: "root o hsubst = root"
  26.518 +unfolding comp_def root_hsubst ..
  26.519 +
  26.520 +lemma cont_hsubst_eq[simp]:
  26.521 +assumes "root tr = root tr0"
  26.522 +shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr0)"
  26.523 +apply(subst id_comp[symmetric, of id]) unfolding id_comp
  26.524 +using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
  26.525 +unfolding hsubst_def hsubst_c_def using assms by simp
  26.526 +
  26.527 +lemma hsubst_eq:
  26.528 +assumes "root tr = root tr0"
  26.529 +shows "hsubst tr = hsubst tr0"
  26.530 +apply(rule dtree_cong) using assms cont_hsubst_eq by auto
  26.531 +
  26.532 +lemma cont_hsubst_neq[simp]:
  26.533 +assumes "root tr \<noteq> root tr0"
  26.534 +shows "cont (hsubst tr) = (id \<oplus> hsubst) ` (cont tr)"
  26.535 +apply(subst id_comp[symmetric, of id]) unfolding id_comp
  26.536 +using unfold(2)[of hsubst_c tr hsubst_r, OF finite_hsubst_c]
  26.537 +unfolding hsubst_def hsubst_c_def using assms by simp
  26.538 +
  26.539 +lemma Inl_cont_hsubst_eq[simp]:
  26.540 +assumes "root tr = root tr0"
  26.541 +shows "Inl -` cont (hsubst tr) = Inl -` (cont tr0)"
  26.542 +unfolding cont_hsubst_eq[OF assms] by simp
  26.543 +
  26.544 +lemma Inr_cont_hsubst_eq[simp]:
  26.545 +assumes "root tr = root tr0"
  26.546 +shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr0"
  26.547 +unfolding cont_hsubst_eq[OF assms] by simp
  26.548 +
  26.549 +lemma Inl_cont_hsubst_neq[simp]:
  26.550 +assumes "root tr \<noteq> root tr0"
  26.551 +shows "Inl -` cont (hsubst tr) = Inl -` (cont tr)"
  26.552 +unfolding cont_hsubst_neq[OF assms] by simp
  26.553 +
  26.554 +lemma Inr_cont_hsubst_neq[simp]:
  26.555 +assumes "root tr \<noteq> root tr0"
  26.556 +shows "Inr -` cont (hsubst tr) = hsubst ` Inr -` cont tr"
  26.557 +unfolding cont_hsubst_neq[OF assms] by simp
  26.558 +
  26.559 +lemma wf_hsubst:
  26.560 +assumes tr0: "wf tr0" and tr: "wf tr"
  26.561 +shows "wf (hsubst tr)"
  26.562 +proof-
  26.563 +  {fix tr1 have "(\<exists> tr. wf tr \<and> tr1 = hsubst tr) \<Longrightarrow> wf tr1"
  26.564 +   proof (induct rule: wf_raw_coind)
  26.565 +     case (Hyp tr1) then obtain tr
  26.566 +     where dtr: "wf tr" and tr1: "tr1 = hsubst tr" by auto
  26.567 +     show ?case unfolding tr1 proof safe
  26.568 +       show "(root (hsubst tr), prodOf (hsubst tr)) \<in> P"
  26.569 +       unfolding tr1 apply(cases "root tr = root tr0")
  26.570 +       using  wf_P[OF dtr] wf_P[OF tr0]
  26.571 +       by (auto simp add: image_comp map_sum.comp)
  26.572 +       show "inj_on root (Inr -` cont (hsubst tr))"
  26.573 +       apply(cases "root tr = root tr0") using wf_inj_on[OF dtr] wf_inj_on[OF tr0]
  26.574 +       unfolding inj_on_def by (auto, blast)
  26.575 +       fix tr' assume "Inr tr' \<in> cont (hsubst tr)"
  26.576 +       thus "\<exists>tra. wf tra \<and> tr' = hsubst tra"
  26.577 +       apply(cases "root tr = root tr0", simp_all)
  26.578 +         apply (metis wf_cont tr0)
  26.579 +         by (metis dtr wf_cont)
  26.580 +     qed
  26.581 +   qed
  26.582 +  }
  26.583 +  thus ?thesis using assms by blast
  26.584 +qed
  26.585 +
  26.586 +lemma Frr: "Frr ns tr = {t. inFrr ns tr t}"
  26.587 +unfolding inFrr_def Frr_def Fr_def by auto
  26.588 +
  26.589 +lemma inFr_hsubst_imp:
  26.590 +assumes "inFr ns (hsubst tr) t"
  26.591 +shows "t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
  26.592 +       inFr (ns - {root tr0}) tr t"
  26.593 +proof-
  26.594 +  {fix tr1
  26.595 +   have "inFr ns tr1 t \<Longrightarrow>
  26.596 +   (\<And> tr. tr1 = hsubst tr \<Longrightarrow> (t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t \<or>
  26.597 +                              inFr (ns - {root tr0}) tr t))"
  26.598 +   proof(induct rule: inFr.induct)
  26.599 +     case (Base tr1 ns t tr)
  26.600 +     hence rtr: "root tr1 \<in> ns" and t_tr1: "Inl t \<in> cont tr1" and tr1: "tr1 = hsubst tr"
  26.601 +     by auto
  26.602 +     show ?case
  26.603 +     proof(cases "root tr1 = root tr0")
  26.604 +       case True
  26.605 +       hence "t \<in> Inl -` (cont tr0)" using t_tr1 unfolding tr1 by auto
  26.606 +       thus ?thesis by simp
  26.607 +     next
  26.608 +       case False
  26.609 +       hence "inFr (ns - {root tr0}) tr t" using t_tr1 unfolding tr1 apply simp
  26.610 +       by (metis Base.prems Diff_iff root_hsubst inFr.Base rtr singletonE)
  26.611 +       thus ?thesis by simp
  26.612 +     qed
  26.613 +   next
  26.614 +     case (Ind tr1 ns tr1' t) note IH = Ind(4)
  26.615 +     have rtr1: "root tr1 \<in> ns" and tr1'_tr1: "Inr tr1' \<in> cont tr1"
  26.616 +     and t_tr1': "inFr ns tr1' t" and tr1: "tr1 = hsubst tr" using Ind by auto
  26.617 +     have rtr1: "root tr1 = root tr" unfolding tr1 by simp
  26.618 +     show ?case
  26.619 +     proof(cases "root tr1 = root tr0")
  26.620 +       case True
  26.621 +       then obtain tr' where tr'_tr0: "Inr tr' \<in> cont tr0" and tr1': "tr1' = hsubst tr'"
  26.622 +       using tr1'_tr1 unfolding tr1 by auto
  26.623 +       show ?thesis using IH[OF tr1'] proof (elim disjE)
  26.624 +         assume "inFr (ns - {root tr0}) tr' t"
  26.625 +         thus ?thesis using tr'_tr0 unfolding inFrr_def by auto
  26.626 +       qed auto
  26.627 +     next
  26.628 +       case False
  26.629 +       then obtain tr' where tr'_tr: "Inr tr' \<in> cont tr" and tr1': "tr1' = hsubst tr'"
  26.630 +       using tr1'_tr1 unfolding tr1 by auto
  26.631 +       show ?thesis using IH[OF tr1'] proof (elim disjE)
  26.632 +         assume "inFr (ns - {root tr0}) tr' t"
  26.633 +         thus ?thesis using tr'_tr unfolding inFrr_def
  26.634 +         by (metis Diff_iff False Ind(1) empty_iff inFr2_Ind inFr_inFr2 insert_iff rtr1)
  26.635 +       qed auto
  26.636 +     qed
  26.637 +   qed
  26.638 +  }
  26.639 +  thus ?thesis using assms by auto
  26.640 +qed
  26.641 +
  26.642 +lemma inFr_hsubst_notin:
  26.643 +assumes "inFr ns tr t" and "root tr0 \<notin> ns"
  26.644 +shows "inFr ns (hsubst tr) t"
  26.645 +using assms apply(induct rule: inFr.induct)
  26.646 +apply (metis Inl_cont_hsubst_neq inFr2.Base inFr_inFr2 root_hsubst vimageD vimageI2)
  26.647 +by (metis (lifting) Inr_cont_hsubst_neq inFr.Ind rev_image_eqI root_hsubst vimageD vimageI2)
  26.648 +
  26.649 +lemma inFr_hsubst_minus:
  26.650 +assumes "inFr (ns - {root tr0}) tr t"
  26.651 +shows "inFr ns (hsubst tr) t"
  26.652 +proof-
  26.653 +  have 1: "inFr (ns - {root tr0}) (hsubst tr) t"
  26.654 +  using inFr_hsubst_notin[OF assms] by simp
  26.655 +  show ?thesis using inFr_mono[OF 1] by auto
  26.656 +qed
  26.657 +
  26.658 +lemma inFr_self_hsubst:
  26.659 +assumes "root tr0 \<in> ns"
  26.660 +shows
  26.661 +"inFr ns (hsubst tr0) t \<longleftrightarrow>
  26.662 + t \<in> Inl -` (cont tr0) \<or> inFrr (ns - {root tr0}) tr0 t"
  26.663 +(is "?A \<longleftrightarrow> ?B \<or> ?C")
  26.664 +apply(intro iffI)
  26.665 +apply (metis inFr_hsubst_imp Diff_iff inFr_root_in insertI1) proof(elim disjE)
  26.666 +  assume ?B thus ?A apply(intro inFr.Base) using assms by auto
  26.667 +next
  26.668 +  assume ?C then obtain tr where
  26.669 +  tr_tr0: "Inr tr \<in> cont tr0" and t_tr: "inFr (ns - {root tr0}) tr t"
  26.670 +  unfolding inFrr_def by auto
  26.671 +  def tr1 \<equiv> "hsubst tr"
  26.672 +  have 1: "inFr ns tr1 t" using t_tr unfolding tr1_def using inFr_hsubst_minus by auto
  26.673 +  have "Inr tr1 \<in> cont (hsubst tr0)" unfolding tr1_def using tr_tr0 by auto
  26.674 +  thus ?A using 1 inFr.Ind assms by (metis root_hsubst)
  26.675 +qed
  26.676 +
  26.677 +lemma Fr_self_hsubst:
  26.678 +assumes "root tr0 \<in> ns"
  26.679 +shows "Fr ns (hsubst tr0) = Inl -` (cont tr0) \<union> Frr (ns - {root tr0}) tr0"
  26.680 +using inFr_self_hsubst[OF assms] unfolding Frr Fr_def by auto
  26.681 +
  26.682 +end (* context *)
  26.683 +
  26.684 +
  26.685 +subsection{* Regular Trees *}
  26.686 +
  26.687 +definition "reg f tr \<equiv> \<forall> tr'. subtr UNIV tr' tr \<longrightarrow> tr' = f (root tr')"
  26.688 +definition "regular tr \<equiv> \<exists> f. reg f tr"
  26.689 +
  26.690 +lemma reg_def2: "reg f tr \<longleftrightarrow> (\<forall> ns tr'. subtr ns tr' tr \<longrightarrow> tr' = f (root tr'))"
  26.691 +unfolding reg_def using subtr_mono by (metis subset_UNIV)
  26.692 +
  26.693 +lemma regular_def2: "regular tr \<longleftrightarrow> (\<exists> f. reg f tr \<and> (\<forall> n. root (f n) = n))"
  26.694 +unfolding regular_def proof safe
  26.695 +  fix f assume f: "reg f tr"
  26.696 +  def g \<equiv> "\<lambda> n. if inItr UNIV tr n then f n else deftr n"
  26.697 +  show "\<exists>g. reg g tr \<and> (\<forall>n. root (g n) = n)"
  26.698 +  apply(rule exI[of _ g])
  26.699 +  using f deftr_simps(1) unfolding g_def reg_def apply safe
  26.700 +    apply (metis (lifting) inItr.Base subtr_inItr subtr_rootL_in)
  26.701 +    by (metis (full_types) inItr_subtr)
  26.702 +qed auto
  26.703 +
  26.704 +lemma reg_root:
  26.705 +assumes "reg f tr"
  26.706 +shows "f (root tr) = tr"
  26.707 +using assms unfolding reg_def
  26.708 +by (metis (lifting) iso_tuple_UNIV_I subtr.Refl)
  26.709 +
  26.710 +
  26.711 +lemma reg_Inr_cont:
  26.712 +assumes "reg f tr" and "Inr tr' \<in> cont tr"
  26.713 +shows "reg f tr'"
  26.714 +by (metis (lifting) assms iso_tuple_UNIV_I reg_def subtr.Step)
  26.715 +
  26.716 +lemma reg_subtr:
  26.717 +assumes "reg f tr" and "subtr ns tr' tr"
  26.718 +shows "reg f tr'"
  26.719 +using assms unfolding reg_def using subtr_trans[of UNIV tr] UNIV_I
  26.720 +by (metis UNIV_eq_I UnCI Un_upper1 iso_tuple_UNIV_I subtr_mono subtr_trans)
  26.721 +
  26.722 +lemma regular_subtr:
  26.723 +assumes r: "regular tr" and s: "subtr ns tr' tr"
  26.724 +shows "regular tr'"
  26.725 +using r reg_subtr[OF _ s] unfolding regular_def by auto
  26.726 +
  26.727 +lemma subtr_deftr:
  26.728 +assumes "subtr ns tr' (deftr n)"
  26.729 +shows "tr' = deftr (root tr')"
  26.730 +proof-
  26.731 +  {fix tr have "subtr ns tr' tr \<Longrightarrow> (\<forall> n. tr = deftr n \<longrightarrow> tr' = deftr (root tr'))"
  26.732 +   apply (induct rule: subtr.induct)
  26.733 +   proof(metis (lifting) deftr_simps(1), safe)
  26.734 +     fix tr3 ns tr1 tr2 n
  26.735 +     assume 1: "root (deftr n) \<in> ns" and 2: "subtr ns tr1 tr2"
  26.736 +     and IH: "\<forall>n. tr2 = deftr n \<longrightarrow> tr1 = deftr (root tr1)"
  26.737 +     and 3: "Inr tr2 \<in> cont (deftr n)"
  26.738 +     have "tr2 \<in> deftr ` UNIV"
  26.739 +     using 3 unfolding deftr_simps image_def
  26.740 +     by (metis (lifting, full_types) 3 CollectI Inr_oplus_iff cont_deftr
  26.741 +         iso_tuple_UNIV_I)
  26.742 +     then obtain n where "tr2 = deftr n" by auto
  26.743 +     thus "tr1 = deftr (root tr1)" using IH by auto
  26.744 +   qed
  26.745 +  }
  26.746 +  thus ?thesis using assms by auto
  26.747 +qed
  26.748 +
  26.749 +lemma reg_deftr: "reg deftr (deftr n)"
  26.750 +unfolding reg_def using subtr_deftr by auto
  26.751 +
  26.752 +lemma wf_subtrOf_Union:
  26.753 +assumes "wf tr"
  26.754 +shows "\<Union>{K tr' |tr'. Inr tr' \<in> cont tr} =
  26.755 +       \<Union>{K (subtrOf tr n) |n. Inr n \<in> prodOf tr}"
  26.756 +unfolding Union_eq Bex_def mem_Collect_eq proof safe
  26.757 +  fix x xa tr'
  26.758 +  assume x: "x \<in> K tr'" and tr'_tr: "Inr tr' \<in> cont tr"
  26.759 +  show "\<exists>X. (\<exists>n. X = K (subtrOf tr n) \<and> Inr n \<in> prodOf tr) \<and> x \<in> X"
  26.760 +  apply(rule exI[of _ "K (subtrOf tr (root tr'))"]) apply(intro conjI)
  26.761 +    apply(rule exI[of _ "root tr'"]) apply (metis (lifting) root_prodOf tr'_tr)
  26.762 +    by (metis (lifting) assms subtrOf_root tr'_tr x)
  26.763 +next
  26.764 +  fix x X n ttr
  26.765 +  assume x: "x \<in> K (subtrOf tr n)" and n: "Inr n = (id \<oplus> root) ttr" and ttr: "ttr \<in> cont tr"
  26.766 +  show "\<exists>X. (\<exists>tr'. X = K tr' \<and> Inr tr' \<in> cont tr) \<and> x \<in> X"
  26.767 +  apply(rule exI[of _ "K (subtrOf tr n)"]) apply(intro conjI)
  26.768 +    apply(rule exI[of _ "subtrOf tr n"]) apply (metis imageI n subtrOf ttr)
  26.769 +    using x .
  26.770 +qed
  26.771 +
  26.772 +
  26.773 +
  26.774 +
  26.775 +subsection {* Paths in a Regular Tree *}
  26.776 +
  26.777 +inductive path :: "(N \<Rightarrow> dtree) \<Rightarrow> N list \<Rightarrow> bool" for f where
  26.778 +Base: "path f [n]"
  26.779 +|
  26.780 +Ind: "\<lbrakk>path f (n1 # nl); Inr (f n1) \<in> cont (f n)\<rbrakk>
  26.781 +      \<Longrightarrow> path f (n # n1 # nl)"
  26.782 +
  26.783 +lemma path_NE:
  26.784 +assumes "path f nl"
  26.785 +shows "nl \<noteq> Nil"
  26.786 +using assms apply(induct rule: path.induct) by auto
  26.787 +
  26.788 +lemma path_post:
  26.789 +assumes f: "path f (n # nl)" and nl: "nl \<noteq> []"
  26.790 +shows "path f nl"
  26.791 +proof-
  26.792 +  obtain n1 nl1 where nl: "nl = n1 # nl1" using nl by (cases nl, auto)
  26.793 +  show ?thesis using assms unfolding nl using path.simps by (metis (lifting) list.inject)
  26.794 +qed
  26.795 +
  26.796 +lemma path_post_concat:
  26.797 +assumes "path f (nl1 @ nl2)" and "nl2 \<noteq> Nil"
  26.798 +shows "path f nl2"
  26.799 +using assms apply (induct nl1)
  26.800 +apply (metis append_Nil) by (metis Nil_is_append_conv append_Cons path_post)
  26.801 +
  26.802 +lemma path_concat:
  26.803 +assumes "path f nl1" and "path f ((last nl1) # nl2)"
  26.804 +shows "path f (nl1 @ nl2)"
  26.805 +using assms apply(induct rule: path.induct) apply simp
  26.806 +by (metis append_Cons last.simps list.simps(3) path.Ind)
  26.807 +
  26.808 +lemma path_distinct:
  26.809 +assumes "path f nl"
  26.810 +shows "\<exists> nl'. path f nl' \<and> hd nl' = hd nl \<and> last nl' = last nl \<and>
  26.811 +              set nl' \<subseteq> set nl \<and> distinct nl'"
  26.812 +using assms proof(induct rule: length_induct)
  26.813 +  case (1 nl)  hence p_nl: "path f nl" by simp
  26.814 +  then obtain n nl1 where nl: "nl = n # nl1" by (metis list.exhaust path_NE)
  26.815 +  show ?case
  26.816 +  proof(cases nl1)
  26.817 +    case Nil
  26.818 +    show ?thesis apply(rule exI[of _ nl]) using path.Base unfolding nl Nil by simp
  26.819 +  next
  26.820 +    case (Cons n1 nl2)
  26.821 +    hence p1: "path f nl1" by (metis list.simps(3) nl p_nl path_post)
  26.822 +    show ?thesis
  26.823 +    proof(cases "n \<in> set nl1")
  26.824 +      case False
  26.825 +      obtain nl1' where p1': "path f nl1'" and hd_nl1': "hd nl1' = hd nl1" and
  26.826 +      l_nl1': "last nl1' = last nl1" and d_nl1': "distinct nl1'"
  26.827 +      and s_nl1': "set nl1' \<subseteq> set nl1"
  26.828 +      using 1(1)[THEN allE[of _ nl1]] p1 unfolding nl by auto
  26.829 +      obtain nl2' where nl1': "nl1' = n1 # nl2'" using path_NE[OF p1'] hd_nl1'
  26.830 +      unfolding Cons by(cases nl1', auto)
  26.831 +      show ?thesis apply(intro exI[of _ "n # nl1'"]) unfolding nl proof safe
  26.832 +        show "path f (n # nl1')" unfolding nl1'
  26.833 +        apply(rule path.Ind, metis nl1' p1')
  26.834 +        by (metis (lifting) Cons list.inject nl p1 p_nl path.simps path_NE)
  26.835 +      qed(insert l_nl1' Cons nl1' s_nl1' d_nl1' False, auto)
  26.836 +    next
  26.837 +      case True
  26.838 +      then obtain nl11 nl12 where nl1: "nl1 = nl11 @ n # nl12"
  26.839 +      by (metis split_list)
  26.840 +      have p12: "path f (n # nl12)"
  26.841 +      apply(rule path_post_concat[of _ "n # nl11"]) using p_nl[unfolded nl nl1] by auto
  26.842 +      obtain nl12' where p1': "path f nl12'" and hd_nl12': "hd nl12' = n" and
  26.843 +      l_nl12': "last nl12' = last (n # nl12)" and d_nl12': "distinct nl12'"
  26.844 +      and s_nl12': "set nl12' \<subseteq> {n} \<union> set nl12"
  26.845 +      using 1(1)[THEN allE[of _ "n # nl12"]] p12 unfolding nl nl1 by auto
  26.846 +      thus ?thesis apply(intro exI[of _ nl12']) unfolding nl nl1 by auto
  26.847 +    qed
  26.848 +  qed
  26.849 +qed
  26.850 +
  26.851 +lemma path_subtr:
  26.852 +assumes f: "\<And> n. root (f n) = n"
  26.853 +and p: "path f nl"
  26.854 +shows "subtr (set nl) (f (last nl)) (f (hd nl))"
  26.855 +using p proof (induct rule: path.induct)
  26.856 +  case (Ind n1 nl n)  let ?ns1 = "insert n1 (set nl)"
  26.857 +  have "path f (n1 # nl)"
  26.858 +  and "subtr ?ns1 (f (last (n1 # nl))) (f n1)"
  26.859 +  and fn1: "Inr (f n1) \<in> cont (f n)" using Ind by simp_all
  26.860 +  hence fn1_flast:  "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n1)"
  26.861 +  by (metis subset_insertI subtr_mono)
  26.862 +  have 1: "last (n # n1 # nl) = last (n1 # nl)" by auto
  26.863 +  have "subtr (insert n ?ns1) (f (last (n1 # nl))) (f n)"
  26.864 +  using f subtr.Step[OF _ fn1_flast fn1] by auto
  26.865 +  thus ?case unfolding 1 by simp
  26.866 +qed (metis f list.sel(1) last_ConsL last_in_set not_Cons_self2 subtr.Refl)
  26.867 +
  26.868 +lemma reg_subtr_path_aux:
  26.869 +assumes f: "reg f tr" and n: "subtr ns tr1 tr"
  26.870 +shows "\<exists> nl. path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
  26.871 +using n f proof(induct rule: subtr.induct)
  26.872 +  case (Refl tr ns)
  26.873 +  thus ?case
  26.874 +  apply(intro exI[of _ "[root tr]"]) apply simp by (metis (lifting) path.Base reg_root)
  26.875 +next
  26.876 +  case (Step tr ns tr2 tr1)
  26.877 +  hence rtr: "root tr \<in> ns" and tr1_tr: "Inr tr1 \<in> cont tr"
  26.878 +  and tr2_tr1: "subtr ns tr2 tr1" and tr: "reg f tr" by auto
  26.879 +  have tr1: "reg f tr1" using reg_subtr[OF tr] rtr tr1_tr
  26.880 +  by (metis (lifting) Step.prems iso_tuple_UNIV_I reg_def subtr.Step)
  26.881 +  obtain nl where nl: "path f nl" and f_nl: "f (hd nl) = tr1"
  26.882 +  and last_nl: "f (last nl) = tr2" and set: "set nl \<subseteq> ns" using Step(3)[OF tr1] by auto
  26.883 +  have 0: "path f (root tr # nl)" apply (subst path.simps)
  26.884 +  using f_nl nl reg_root tr tr1_tr by (metis list.sel(1) neq_Nil_conv)
  26.885 +  show ?case apply(rule exI[of _ "(root tr) # nl"])
  26.886 +  using 0 reg_root tr last_nl nl path_NE rtr set by auto
  26.887 +qed
  26.888 +
  26.889 +lemma reg_subtr_path:
  26.890 +assumes f: "reg f tr" and n: "subtr ns tr1 tr"
  26.891 +shows "\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns"
  26.892 +using reg_subtr_path_aux[OF assms] path_distinct[of f]
  26.893 +by (metis (lifting) order_trans)
  26.894 +
  26.895 +lemma subtr_iff_path:
  26.896 +assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
  26.897 +shows "subtr ns tr1 tr \<longleftrightarrow>
  26.898 +       (\<exists> nl. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and> set nl \<subseteq> ns)"
  26.899 +proof safe
  26.900 +  fix nl assume p: "path f nl" and nl: "set nl \<subseteq> ns"
  26.901 +  have "subtr (set nl) (f (last nl)) (f (hd nl))"
  26.902 +  apply(rule path_subtr) using p f by simp_all
  26.903 +  thus "subtr ns (f (last nl)) (f (hd nl))"
  26.904 +  using subtr_mono nl by auto
  26.905 +qed(insert reg_subtr_path[OF r], auto)
  26.906 +
  26.907 +lemma inFr_iff_path:
  26.908 +assumes r: "reg f tr" and f: "\<And> n. root (f n) = n"
  26.909 +shows
  26.910 +"inFr ns tr t \<longleftrightarrow>
  26.911 + (\<exists> nl tr1. distinct nl \<and> path f nl \<and> f (hd nl) = tr \<and> f (last nl) = tr1 \<and>
  26.912 +            set nl \<subseteq> ns \<and> Inl t \<in> cont tr1)"
  26.913 +apply safe
  26.914 +apply (metis (no_types) inFr_subtr r reg_subtr_path)
  26.915 +by (metis f inFr.Base path_subtr subtr_inFr subtr_mono subtr_rootL_in)
  26.916 +
  26.917 +
  26.918 +
  26.919 +subsection{* The Regular Cut of a Tree *}
  26.920 +
  26.921 +context fixes tr0 :: dtree
  26.922 +begin
  26.923 +
  26.924 +(* Picking a subtree of a certain root: *)
  26.925 +definition "pick n \<equiv> SOME tr. subtr UNIV tr tr0 \<and> root tr = n"
  26.926 +
  26.927 +lemma pick:
  26.928 +assumes "inItr UNIV tr0 n"
  26.929 +shows "subtr UNIV (pick n) tr0 \<and> root (pick n) = n"
  26.930 +proof-
  26.931 +  have "\<exists> tr. subtr UNIV tr tr0 \<and> root tr = n"
  26.932 +  using assms by (metis (lifting) inItr_subtr)
  26.933 +  thus ?thesis unfolding pick_def by(rule someI_ex)
  26.934 +qed
  26.935 +
  26.936 +lemmas subtr_pick = pick[THEN conjunct1]
  26.937 +lemmas root_pick = pick[THEN conjunct2]
  26.938 +
  26.939 +lemma wf_pick:
  26.940 +assumes tr0: "wf tr0" and n: "inItr UNIV tr0 n"
  26.941 +shows "wf (pick n)"
  26.942 +using wf_subtr[OF tr0 subtr_pick[OF n]] .
  26.943 +
  26.944 +definition "H_r n \<equiv> root (pick n)"
  26.945 +definition "H_c n \<equiv> (id \<oplus> root) ` cont (pick n)"
  26.946 +
  26.947 +(* The regular tree of a function: *)
  26.948 +definition H :: "N \<Rightarrow> dtree" where
  26.949 +"H \<equiv> unfold H_r H_c"
  26.950 +
  26.951 +lemma finite_H_c: "finite (H_c n)"
  26.952 +unfolding H_c_def by (metis finite_cont finite_imageI)
  26.953 +
  26.954 +lemma root_H_pick: "root (H n) = root (pick n)"
  26.955 +using unfold(1)[of H_r H_c n] unfolding H_def H_r_def by simp
  26.956 +
  26.957 +lemma root_H[simp]:
  26.958 +assumes "inItr UNIV tr0 n"
  26.959 +shows "root (H n) = n"
  26.960 +unfolding root_H_pick root_pick[OF assms] ..
  26.961 +
  26.962 +lemma cont_H[simp]:
  26.963 +"cont (H n) = (id \<oplus> (H o root)) ` cont (pick n)"
  26.964 +apply(subst id_comp[symmetric, of id]) unfolding map_sum.comp[symmetric]
  26.965 +unfolding image_comp [symmetric] H_c_def [symmetric]
  26.966 +using unfold(2) [of H_c n H_r, OF finite_H_c]
  26.967 +unfolding H_def ..
  26.968 +
  26.969 +lemma Inl_cont_H[simp]:
  26.970 +"Inl -` (cont (H n)) = Inl -` (cont (pick n))"
  26.971 +unfolding cont_H by simp
  26.972 +
  26.973 +lemma Inr_cont_H:
  26.974 +"Inr -` (cont (H n)) = (H \<circ> root) ` (Inr -` cont (pick n))"
  26.975 +unfolding cont_H by simp
  26.976 +
  26.977 +lemma subtr_H:
  26.978 +assumes n: "inItr UNIV tr0 n" and "subtr UNIV tr1 (H n)"
  26.979 +shows "\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = H n1"
  26.980 +proof-
  26.981 +  {fix tr ns assume "subtr UNIV tr1 tr"
  26.982 +   hence "tr = H n \<longrightarrow> (\<exists> n1. inItr UNIV tr0 n1 \<and> tr1 = H n1)"
  26.983 +   proof (induct rule: subtr_UNIV_inductL)
  26.984 +     case (Step tr2 tr1 tr)
  26.985 +     show ?case proof
  26.986 +       assume "tr = H n"
  26.987 +       then obtain n1 where tr2: "Inr tr2 \<in> cont tr1"
  26.988 +       and tr1_tr: "subtr UNIV tr1 tr" and n1: "inItr UNIV tr0 n1" and tr1: "tr1 = H n1"
  26.989 +       using Step by auto
  26.990 +       obtain tr2' where tr2: "tr2 = H (root tr2')"
  26.991 +       and tr2': "Inr tr2' \<in> cont (pick n1)"
  26.992 +       using tr2 Inr_cont_H[of n1]
  26.993 +       unfolding tr1 image_def comp_def using vimage_eq by auto
  26.994 +       have "inItr UNIV tr0 (root tr2')"
  26.995 +       using inItr.Base inItr.Ind n1 pick subtr_inItr tr2' by (metis iso_tuple_UNIV_I)
  26.996 +       thus "\<exists>n2. inItr UNIV tr0 n2 \<and> tr2 = H n2" using tr2 by blast
  26.997 +     qed
  26.998 +   qed(insert n, auto)
  26.999 +  }
 26.1000 +  thus ?thesis using assms by auto
 26.1001 +qed
 26.1002 +
 26.1003 +lemma root_H_root:
 26.1004 +assumes n: "inItr UNIV tr0 n" and t_tr: "t_tr \<in> cont (pick n)"
 26.1005 +shows "(id \<oplus> (root \<circ> H \<circ> root)) t_tr = (id \<oplus> root) t_tr"
 26.1006 +using assms apply(cases t_tr)
 26.1007 +  apply (metis (lifting) map_sum.simps(1))
 26.1008 +  using pick H_def H_r_def unfold(1)
 26.1009 +      inItr.Base comp_apply subtr_StepL subtr_inItr map_sum.simps(2)
 26.1010 +  by (metis UNIV_I)
 26.1011 +
 26.1012 +lemma H_P:
 26.1013 +assumes tr0: "wf tr0" and n: "inItr UNIV tr0 n"
 26.1014 +shows "(n, (id \<oplus> root) ` cont (H n)) \<in> P" (is "?L \<in> P")
 26.1015 +proof-
 26.1016 +  have "?L = (n, (id \<oplus> root) ` cont (pick n))"
 26.1017 +  unfolding cont_H image_comp map_sum.comp id_comp comp_assoc[symmetric]
 26.1018 +  unfolding Pair_eq apply(rule conjI[OF refl]) apply(rule image_cong[OF refl])
 26.1019 +  by (rule root_H_root[OF n])
 26.1020 +  moreover have "... \<in> P" by (metis (lifting) wf_pick root_pick wf_P n tr0)
 26.1021 +  ultimately show ?thesis by simp
 26.1022 +qed
 26.1023 +
 26.1024 +lemma wf_H:
 26.1025 +assumes tr0: "wf tr0" and "inItr UNIV tr0 n"
 26.1026 +shows "wf (H n)"
 26.1027 +proof-
 26.1028 +  {fix tr have "\<exists> n. inItr UNIV tr0 n \<and> tr = H n \<Longrightarrow> wf tr"
 26.1029 +   proof (induct rule: wf_raw_coind)
 26.1030 +     case (Hyp tr)
 26.1031 +     then obtain n where n: "inItr UNIV tr0 n" and tr: "tr = H n" by auto
 26.1032 +     show ?case apply safe
 26.1033 +     apply (metis (lifting) H_P root_H n tr tr0)
 26.1034 +     unfolding tr Inr_cont_H unfolding inj_on_def apply clarsimp using root_H
 26.1035 +     apply (metis UNIV_I inItr.Base n pick subtr2.simps subtr_inItr subtr_subtr2)
 26.1036 +     by (metis n subtr.Refl subtr_StepL subtr_H tr UNIV_I)
 26.1037 +   qed
 26.1038 +  }
 26.1039 +  thus ?thesis using assms by blast
 26.1040 +qed
 26.1041 +
 26.1042 +(* The regular cut of a tree: *)
 26.1043 +definition "rcut \<equiv> H (root tr0)"
 26.1044 +
 26.1045 +lemma reg_rcut: "reg H rcut"
 26.1046 +unfolding reg_def rcut_def
 26.1047 +by (metis inItr.Base root_H subtr_H UNIV_I)
 26.1048 +
 26.1049 +lemma rcut_reg:
 26.1050 +assumes "reg H tr0"
 26.1051 +shows "rcut = tr0"
 26.1052 +using assms unfolding rcut_def reg_def by (metis subtr.Refl UNIV_I)
 26.1053 +
 26.1054 +lemma rcut_eq: "rcut = tr0 \<longleftrightarrow> reg H tr0"
 26.1055 +using reg_rcut rcut_reg by metis
 26.1056 +
 26.1057 +lemma regular_rcut: "regular rcut"
 26.1058 +using reg_rcut unfolding regular_def by blast
 26.1059 +
 26.1060 +lemma Fr_rcut: "Fr UNIV rcut \<subseteq> Fr UNIV tr0"
 26.1061 +proof safe
 26.1062 +  fix t assume "t \<in> Fr UNIV rcut"
 26.1063 +  then obtain tr where t: "Inl t \<in> cont tr" and tr: "subtr UNIV tr (H (root tr0))"
 26.1064 +  using Fr_subtr[of UNIV "H (root tr0)"] unfolding rcut_def
 26.1065 +  by (metis (full_types) Fr_def inFr_subtr mem_Collect_eq)
 26.1066 +  obtain n where n: "inItr UNIV tr0 n" and tr: "tr = H n" using tr
 26.1067 +  by (metis (lifting) inItr.Base subtr_H UNIV_I)
 26.1068 +  have "Inl t \<in> cont (pick n)" using t using Inl_cont_H[of n] unfolding tr
 26.1069 +  by (metis (lifting) vimageD vimageI2)
 26.1070 +  moreover have "subtr UNIV (pick n) tr0" using subtr_pick[OF n] ..
 26.1071 +  ultimately show "t \<in> Fr UNIV tr0" unfolding Fr_subtr_cont by auto
 26.1072 +qed
 26.1073 +
 26.1074 +lemma wf_rcut:
 26.1075 +assumes "wf tr0"
 26.1076 +shows "wf rcut"
 26.1077 +unfolding rcut_def using wf_H[OF assms inItr.Base] by simp
 26.1078 +
 26.1079 +lemma root_rcut[simp]: "root rcut = root tr0"
 26.1080 +unfolding rcut_def
 26.1081 +by (metis (lifting) root_H inItr.Base reg_def reg_root subtr_rootR_in)
 26.1082 +
 26.1083 +end (* context *)
 26.1084 +
 26.1085 +
 26.1086 +subsection{* Recursive Description of the Regular Tree Frontiers *}
 26.1087 +
 26.1088 +lemma regular_inFr:
 26.1089 +assumes r: "regular tr" and In: "root tr \<in> ns"
 26.1090 +and t: "inFr ns tr t"
 26.1091 +shows "t \<in> Inl -` (cont tr) \<or>
 26.1092 +       (\<exists> tr'. Inr tr' \<in> cont tr \<and> inFr (ns - {root tr}) tr' t)"
 26.1093 +(is "?L \<or> ?R")
 26.1094 +proof-
 26.1095 +  obtain f where r: "reg f tr" and f: "\<And>n. root (f n) = n"
 26.1096 +  using r unfolding regular_def2 by auto
 26.1097 +  obtain nl tr1 where d_nl: "distinct nl" and p: "path f nl" and hd_nl: "f (hd nl) = tr"
 26.1098 +  and l_nl: "f (last nl) = tr1" and s_nl: "set nl \<subseteq> ns" and t_tr1: "Inl t \<in> cont tr1"
 26.1099 +  using t unfolding inFr_iff_path[OF r f] by auto
 26.1100 +  obtain n nl1 where nl: "nl = n # nl1" by (metis (lifting) p path.simps)
 26.1101 +  hence f_n: "f n = tr" using hd_nl by simp
 26.1102 +  have n_nl1: "n \<notin> set nl1" using d_nl unfolding nl by auto
 26.1103 +  show ?thesis
 26.1104 +  proof(cases nl1)
 26.1105 +    case Nil hence "tr = tr1" using f_n l_nl unfolding nl by simp
 26.1106 +    hence ?L using t_tr1 by simp thus ?thesis by simp
 26.1107 +  next
 26.1108 +    case (Cons n1 nl2) note nl1 = Cons
 26.1109 +    have 1: "last nl1 = last nl" "hd nl1 = n1" unfolding nl nl1 by simp_all
 26.1110 +    have p1: "path f nl1" and n1_tr: "Inr (f n1) \<in> cont tr"
 26.1111 +    using path.simps[of f nl] p f_n unfolding nl nl1 by auto
 26.1112 +    have r1: "reg f (f n1)" using reg_Inr_cont[OF r n1_tr] .
 26.1113 +    have 0: "inFr (set nl1) (f n1) t" unfolding inFr_iff_path[OF r1 f]
 26.1114 +    apply(intro exI[of _ nl1], intro exI[of _ tr1])
 26.1115 +    using d_nl unfolding 1 l_nl unfolding nl using p1 t_tr1 by auto
 26.1116 +    have root_tr: "root tr = n" by (metis f f_n)
 26.1117 +    have "inFr (ns - {root tr}) (f n1) t" apply(rule inFr_mono[OF 0])
 26.1118 +    using s_nl unfolding root_tr unfolding nl using n_nl1 by auto
 26.1119 +    thus ?thesis using n1_tr by auto
 26.1120 +  qed
 26.1121 +qed
 26.1122 +
 26.1123 +lemma regular_Fr:
 26.1124 +assumes r: "regular tr" and In: "root tr \<in> ns"
 26.1125 +shows "Fr ns tr =
 26.1126 +       Inl -` (cont tr) \<union>
 26.1127 +       \<Union> {Fr (ns - {root tr}) tr' | tr'. Inr tr' \<in> cont tr}"
 26.1128 +unfolding Fr_def
 26.1129 +using In inFr.Base regular_inFr[OF assms] apply safe
 26.1130 +apply (simp, metis (full_types) mem_Collect_eq)
 26.1131 +apply simp
 26.1132 +by (simp, metis (lifting) inFr_Ind_minus insert_Diff)
 26.1133 +
 26.1134 +
 26.1135 +subsection{* The Generated Languages *}
 26.1136 +
 26.1137 +(* The (possibly inifinite tree) generated language *)
 26.1138 +definition "L ns n \<equiv> {Fr ns tr | tr. wf tr \<and> root tr = n}"
 26.1139 +
 26.1140 +(* The regular-tree generated language *)
 26.1141 +definition "Lr ns n \<equiv> {Fr ns tr | tr. wf tr \<and> root tr = n \<and> regular tr}"
 26.1142 +
 26.1143 +lemma L_rec_notin:
 26.1144 +assumes "n \<notin> ns"
 26.1145 +shows "L ns n = {{}}"
 26.1146 +using assms unfolding L_def apply safe
 26.1147 +  using not_root_Fr apply force
 26.1148 +  apply(rule exI[of _ "deftr n"])
 26.1149 +  by (metis (no_types) wf_deftr not_root_Fr root_deftr)
 26.1150 +
 26.1151 +lemma Lr_rec_notin:
 26.1152 +assumes "n \<notin> ns"
 26.1153 +shows "Lr ns n = {{}}"
 26.1154 +using assms unfolding Lr_def apply safe
 26.1155 +  using not_root_Fr apply force
 26.1156 +  apply(rule exI[of _ "deftr n"])
 26.1157 +  by (metis (no_types) regular_def wf_deftr not_root_Fr reg_deftr root_deftr)
 26.1158 +
 26.1159 +lemma wf_subtrOf:
 26.1160 +assumes "wf tr" and "Inr n \<in> prodOf tr"
 26.1161 +shows "wf (subtrOf tr n)"
 26.1162 +by (metis assms wf_cont subtrOf)
 26.1163 +
 26.1164 +lemma Lr_rec_in:
 26.1165 +assumes n: "n \<in> ns"
 26.1166 +shows "Lr ns n \<subseteq>
 26.1167 +{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
 26.1168 +    (n,tns) \<in> P \<and>
 26.1169 +    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n')}"
 26.1170 +(is "Lr ns n \<subseteq> {?F tns K | tns K. (n,tns) \<in> P \<and> ?\<phi> tns K}")
 26.1171 +proof safe
 26.1172 +  fix ts assume "ts \<in> Lr ns n"
 26.1173 +  then obtain tr where dtr: "wf tr" and r: "root tr = n" and tr: "regular tr"
 26.1174 +  and ts: "ts = Fr ns tr" unfolding Lr_def by auto
 26.1175 +  def tns \<equiv> "(id \<oplus> root) ` (cont tr)"
 26.1176 +  def K \<equiv> "\<lambda> n'. Fr (ns - {n}) (subtrOf tr n')"
 26.1177 +  show "\<exists>tns K. ts = ?F tns K \<and> (n, tns) \<in> P \<and> ?\<phi> tns K"
 26.1178 +  apply(rule exI[of _ tns], rule exI[of _ K]) proof(intro conjI allI impI)
 26.1179 +    show "ts = Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns}"
 26.1180 +    unfolding ts regular_Fr[OF tr n[unfolded r[symmetric]]]
 26.1181 +    unfolding tns_def K_def r[symmetric]
 26.1182 +    unfolding Inl_prodOf wf_subtrOf_Union[OF dtr] ..
 26.1183 +    show "(n, tns) \<in> P" unfolding tns_def r[symmetric] using wf_P[OF dtr] .
 26.1184 +    fix n' assume "Inr n' \<in> tns" thus "K n' \<in> Lr (ns - {n}) n'"
 26.1185 +    unfolding K_def Lr_def mem_Collect_eq apply(intro exI[of _ "subtrOf tr n'"])
 26.1186 +    using dtr tr apply(intro conjI refl)  unfolding tns_def
 26.1187 +      apply(erule wf_subtrOf[OF dtr])
 26.1188 +      apply (metis subtrOf)
 26.1189 +      by (metis Inr_subtrOf UNIV_I regular_subtr subtr.simps)
 26.1190 +  qed
 26.1191 +qed
 26.1192 +
 26.1193 +lemma hsubst_aux:
 26.1194 +fixes n ftr tns
 26.1195 +assumes n: "n \<in> ns" and tns: "finite tns" and
 26.1196 +1: "\<And> n'. Inr n' \<in> tns \<Longrightarrow> wf (ftr n')"
 26.1197 +defines "tr \<equiv> Node n ((id \<oplus> ftr) ` tns)"  defines "tr' \<equiv> hsubst tr tr"
 26.1198 +shows "Fr ns tr' = Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
 26.1199 +(is "_ = ?B") proof-
 26.1200 +  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
 26.1201 +  unfolding tr_def using tns by auto
 26.1202 +  have Frr: "Frr (ns - {n}) tr = \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
 26.1203 +  unfolding Frr_def ctr by auto
 26.1204 +  have "Fr ns tr' = Inl -` (cont tr) \<union> Frr (ns - {n}) tr"
 26.1205 +  using Fr_self_hsubst[OF n[unfolded rtr[symmetric]]] unfolding tr'_def rtr ..
 26.1206 +  also have "... = ?B" unfolding ctr Frr by simp
 26.1207 +  finally show ?thesis .
 26.1208 +qed
 26.1209 +
 26.1210 +lemma L_rec_in:
 26.1211 +assumes n: "n \<in> ns"
 26.1212 +shows "
 26.1213 +{Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
 26.1214 +    (n,tns) \<in> P \<and>
 26.1215 +    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n')}
 26.1216 + \<subseteq> L ns n"
 26.1217 +proof safe
 26.1218 +  fix tns K
 26.1219 +  assume P: "(n, tns) \<in> P" and 0: "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> L (ns - {n}) n'"
 26.1220 +  {fix n' assume "Inr n' \<in> tns"
 26.1221 +   hence "K n' \<in> L (ns - {n}) n'" using 0 by auto
 26.1222 +   hence "\<exists> tr'. K n' = Fr (ns - {n}) tr' \<and> wf tr' \<and> root tr' = n'"
 26.1223 +   unfolding L_def mem_Collect_eq by auto
 26.1224 +  }
 26.1225 +  then obtain ftr where 0: "\<And> n'. Inr n' \<in> tns \<Longrightarrow>
 26.1226 +  K n' = Fr (ns - {n}) (ftr n') \<and> wf (ftr n') \<and> root (ftr n') = n'"
 26.1227 +  by metis
 26.1228 +  def tr \<equiv> "Node n ((id \<oplus> ftr) ` tns)"  def tr' \<equiv> "hsubst tr tr"
 26.1229 +  have rtr: "root tr = n" and ctr: "cont tr = (id \<oplus> ftr) ` tns"
 26.1230 +  unfolding tr_def by (simp, metis P cont_Node finite_imageI finite_in_P)
 26.1231 +  have prtr: "prodOf tr = tns" apply(rule Inl_Inr_image_cong)
 26.1232 +  unfolding ctr apply simp apply simp apply safe
 26.1233 +  using 0 unfolding image_def apply force apply simp by (metis 0 vimageI2)
 26.1234 +  have 1: "{K n' |n'. Inr n' \<in> tns} = {Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns}"
 26.1235 +  using 0 by auto
 26.1236 +  have dtr: "wf tr" apply(rule wf.dtree)
 26.1237 +    apply (metis (lifting) P prtr rtr)
 26.1238 +    unfolding inj_on_def ctr using 0 by auto
 26.1239 +  hence dtr': "wf tr'" unfolding tr'_def by (metis wf_hsubst)
 26.1240 +  have tns: "finite tns" using finite_in_P P by simp
 26.1241 +  have "Inl -` tns \<union> \<Union>{Fr (ns - {n}) (ftr n') |n'. Inr n' \<in> tns} \<in> L ns n"
 26.1242 +  unfolding L_def mem_Collect_eq apply(intro exI[of _ tr'] conjI)
 26.1243 +  using dtr' 0 hsubst_aux[OF assms tns, of ftr] unfolding tr_def tr'_def by auto
 26.1244 +  thus "Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} \<in> L ns n" unfolding 1 .
 26.1245 +qed
 26.1246 +
 26.1247 +lemma card_N: "(n::N) \<in> ns \<Longrightarrow> card (ns - {n}) < card ns"
 26.1248 +by (metis finite_N Diff_UNIV Diff_infinite_finite card_Diff1_less finite.emptyI)
 26.1249 +
 26.1250 +function LL where
 26.1251 +"LL ns n =
 26.1252 + (if n \<notin> ns then {{}} else
 26.1253 + {Inl -` tns \<union> (\<Union> {K n' | n'. Inr n' \<in> tns}) | tns K.
 26.1254 +    (n,tns) \<in> P \<and>
 26.1255 +    (\<forall> n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n')})"
 26.1256 +by(pat_completeness, auto)
 26.1257 +termination apply(relation "inv_image (measure card) fst")
 26.1258 +using card_N by auto
 26.1259 +
 26.1260 +declare LL.simps[code]
 26.1261 +declare LL.simps[simp del]
 26.1262 +
 26.1263 +lemma Lr_LL: "Lr ns n \<subseteq> LL ns n"
 26.1264 +proof (induct ns arbitrary: n rule: measure_induct[of card])
 26.1265 +  case (1 ns n) show ?case proof(cases "n \<in> ns")
 26.1266 +    case False thus ?thesis unfolding Lr_rec_notin[OF False] by (simp add: LL.simps)
 26.1267 +  next
 26.1268 +    case True show ?thesis apply(rule subset_trans)
 26.1269 +    using Lr_rec_in[OF True] apply assumption
 26.1270 +    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
 26.1271 +      fix tns K
 26.1272 +      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
 26.1273 +      assume "(n, tns) \<in> P"
 26.1274 +      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> Lr (ns - {n}) n'"
 26.1275 +      thus "\<exists>tnsa Ka.
 26.1276 +             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
 26.1277 +             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
 26.1278 +             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> LL (ns - {n}) n')"
 26.1279 +      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
 26.1280 +    qed
 26.1281 +  qed
 26.1282 +qed
 26.1283 +
 26.1284 +lemma LL_L: "LL ns n \<subseteq> L ns n"
 26.1285 +proof (induct ns arbitrary: n rule: measure_induct[of card])
 26.1286 +  case (1 ns n) show ?case proof(cases "n \<in> ns")
 26.1287 +    case False thus ?thesis unfolding L_rec_notin[OF False] by (simp add: LL.simps)
 26.1288 +  next
 26.1289 +    case True show ?thesis apply(rule subset_trans)
 26.1290 +    prefer 2 using L_rec_in[OF True] apply assumption
 26.1291 +    unfolding LL.simps[of ns n] using True 1 card_N proof clarsimp
 26.1292 +      fix tns K
 26.1293 +      assume "n \<in> ns" hence c: "card (ns - {n}) < card ns" using card_N by blast
 26.1294 +      assume "(n, tns) \<in> P"
 26.1295 +      and "\<forall>n'. Inr n' \<in> tns \<longrightarrow> K n' \<in> LL (ns - {n}) n'"
 26.1296 +      thus "\<exists>tnsa Ka.
 26.1297 +             Inl -` tns \<union> \<Union>{K n' |n'. Inr n' \<in> tns} =
 26.1298 +             Inl -` tnsa \<union> \<Union>{Ka n' |n'. Inr n' \<in> tnsa} \<and>
 26.1299 +             (n, tnsa) \<in> P \<and> (\<forall>n'. Inr n' \<in> tnsa \<longrightarrow> Ka n' \<in> L (ns - {n}) n')"
 26.1300 +      apply(intro exI[of _ tns] exI[of _ K]) using c 1 by auto
 26.1301 +    qed
 26.1302 +  qed
 26.1303 +qed
 26.1304 +
 26.1305 +(* The subsumpsion relation between languages *)
 26.1306 +definition "subs L1 L2 \<equiv> \<forall> ts2 \<in> L2. \<exists> ts1 \<in> L1. ts1 \<subseteq> ts2"
 26.1307 +
 26.1308 +lemma incl_subs[simp]: "L2 \<subseteq> L1 \<Longrightarrow> subs L1 L2"
 26.1309 +unfolding subs_def by auto
 26.1310 +
 26.1311 +lemma subs_refl[simp]: "subs L1 L1" unfolding subs_def by auto
 26.1312 +
 26.1313 +lemma subs_trans: "\<lbrakk>subs L1 L2; subs L2 L3\<rbrakk> \<Longrightarrow> subs L1 L3"
 26.1314 +unfolding subs_def by (metis subset_trans)
 26.1315 +
 26.1316 +(* Language equivalence *)
 26.1317 +definition "leqv L1 L2 \<equiv> subs L1 L2 \<and> subs L2 L1"
 26.1318 +
 26.1319 +lemma subs_leqv[simp]: "leqv L1 L2 \<Longrightarrow> subs L1 L2"
 26.1320 +unfolding leqv_def by auto
 26.1321 +
 26.1322 +lemma subs_leqv_sym[simp]: "leqv L1 L2 \<Longrightarrow> subs L2 L1"
 26.1323 +unfolding leqv_def by auto
 26.1324 +
 26.1325 +lemma leqv_refl[simp]: "leqv L1 L1" unfolding leqv_def by auto
 26.1326 +
 26.1327 +lemma leqv_trans:
 26.1328 +assumes 12: "leqv L1 L2" and 23: "leqv L2 L3"
 26.1329 +shows "leqv L1 L3"
 26.1330 +using assms unfolding leqv_def by (metis (lifting) subs_trans)
 26.1331 +
 26.1332 +lemma leqv_sym: "leqv L1 L2 \<Longrightarrow> leqv L2 L1"
 26.1333 +unfolding leqv_def by auto
 26.1334 +
 26.1335 +lemma leqv_Sym: "leqv L1 L2 \<longleftrightarrow> leqv L2 L1"
 26.1336 +unfolding leqv_def by auto
 26.1337 +
 26.1338 +lemma Lr_incl_L: "Lr ns ts \<subseteq> L ns ts"
 26.1339 +unfolding Lr_def L_def by auto
 26.1340 +
 26.1341 +lemma Lr_subs_L: "subs (Lr UNIV ts) (L UNIV ts)"
 26.1342 +unfolding subs_def proof safe
 26.1343 +  fix ts2 assume "ts2 \<in> L UNIV ts"
 26.1344 +  then obtain tr where ts2: "ts2 = Fr UNIV tr" and dtr: "wf tr" and rtr: "root tr = ts"
 26.1345 +  unfolding L_def by auto
 26.1346 +  thus "\<exists>ts1\<in>Lr UNIV ts. ts1 \<subseteq> ts2"
 26.1347 +  apply(intro bexI[of _ "Fr UNIV (rcut tr)"])
 26.1348 +  unfolding Lr_def L_def using Fr_rcut wf_rcut root_rcut regular_rcut by auto
 26.1349 +qed
 26.1350 +
 26.1351 +lemma Lr_leqv_L: "leqv (Lr UNIV ts) (L UNIV ts)"
 26.1352 +using Lr_subs_L unfolding leqv_def by (metis (lifting) Lr_incl_L incl_subs)
 26.1353 +
 26.1354 +lemma LL_leqv_L: "leqv (LL UNIV ts) (L UNIV ts)"
 26.1355 +by (metis (lifting) LL_L Lr_LL Lr_subs_L incl_subs leqv_def subs_trans)
 26.1356 +
 26.1357 +lemma LL_leqv_Lr: "leqv (LL UNIV ts) (Lr UNIV ts)"
 26.1358 +using Lr_leqv_L LL_leqv_L by (metis leqv_Sym leqv_trans)
 26.1359 +
 26.1360 +end
    27.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    27.2 +++ b/src/HOL/Datatype_Examples/Derivation_Trees/Parallel.thy	Thu Sep 11 19:26:59 2014 +0200
    27.3 @@ -0,0 +1,147 @@
    27.4 +(*  Title:      HOL/Datatype_Examples/Derivation_Trees/Parallel.thy
    27.5 +    Author:     Andrei Popescu, TU Muenchen
    27.6 +    Copyright   2012
    27.7 +
    27.8 +Parallel composition.
    27.9 +*)
   27.10 +
   27.11 +header {* Parallel Composition *}
   27.12 +
   27.13 +theory Parallel
   27.14 +imports DTree
   27.15 +begin
   27.16 +
   27.17 +no_notation plus_class.plus (infixl "+" 65)
   27.18 +
   27.19 +consts Nplus :: "N \<Rightarrow> N \<Rightarrow> N" (infixl "+" 60)
   27.20 +
   27.21 +axiomatization where
   27.22 +    Nplus_comm: "(a::N) + b = b + (a::N)"
   27.23 +and Nplus_assoc: "((a::N) + b) + c = a + (b + c)"
   27.24 +
   27.25 +subsection{* Corecursive Definition of Parallel Composition *}
   27.26 +
   27.27 +fun par_r where "par_r (tr1,tr2) = root tr1 + root tr2"
   27.28 +fun par_c where
   27.29 +"par_c (tr1,tr2) =
   27.30 + Inl ` (Inl -` (cont tr1 \<union> cont tr2)) \<union>
   27.31 + Inr ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
   27.32 +
   27.33 +declare par_r.simps[simp del]  declare par_c.simps[simp del]
   27.34 +
   27.35 +definition par :: "dtree \<times> dtree \<Rightarrow> dtree" where
   27.36 +"par \<equiv> unfold par_r par_c"
   27.37 +
   27.38 +abbreviation par_abbr (infixr "\<parallel>" 80) where "tr1 \<parallel> tr2 \<equiv> par (tr1, tr2)"
   27.39 +
   27.40 +lemma finite_par_c: "finite (par_c (tr1, tr2))"
   27.41 +unfolding par_c.simps apply(rule finite_UnI)
   27.42 +  apply (metis finite_Un finite_cont finite_imageI finite_vimageI inj_Inl)
   27.43 +  apply(intro finite_imageI finite_cartesian_product finite_vimageI)
   27.44 +  using finite_cont by auto
   27.45 +
   27.46 +lemma root_par: "root (tr1 \<parallel> tr2) = root tr1 + root tr2"
   27.47 +using unfold(1)[of par_r par_c "(tr1,tr2)"] unfolding par_def par_r.simps by simp
   27.48 +
   27.49 +lemma cont_par:
   27.50 +"cont (tr1 \<parallel> tr2) = (id \<oplus> par) ` par_c (tr1,tr2)"
   27.51 +using unfold(2)[of par_c "(tr1,tr2)" par_r, OF finite_par_c]
   27.52 +unfolding par_def ..
   27.53 +
   27.54 +lemma Inl_cont_par[simp]:
   27.55 +"Inl -` (cont (tr1 \<parallel> tr2)) = Inl -` (cont tr1 \<union> cont tr2)"
   27.56 +unfolding cont_par par_c.simps by auto
   27.57 +
   27.58 +lemma Inr_cont_par[simp]:
   27.59 +"Inr -` (cont (tr1 \<parallel> tr2)) = par ` (Inr -` cont tr1 \<times> Inr -` cont tr2)"
   27.60 +unfolding cont_par par_c.simps by auto
   27.61 +
   27.62 +lemma Inl_in_cont_par:
   27.63 +"Inl t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (Inl t \<in> cont tr1 \<or> Inl t \<in> cont tr2)"
   27.64 +using Inl_cont_par[of tr1 tr2] unfolding vimage_def by auto
   27.65 +
   27.66 +lemma Inr_in_cont_par:
   27.67 +"Inr t \<in> cont (tr1 \<parallel> tr2) \<longleftrightarrow> (t \<in> par ` (Inr -` cont tr1 \<times> Inr -` cont tr2))"
   27.68 +using Inr_cont_par[of tr1 tr2] unfolding vimage_def by auto
   27.69 +
   27.70 +
   27.71 +subsection{* Structural Coinduction Proofs *}
   27.72 +
   27.73 +lemma rel_set_rel_sum_eq[simp]:
   27.74 +"rel_set (rel_sum (op =) \<phi>) A1 A2 \<longleftrightarrow>
   27.75 + Inl -` A1 = Inl -` A2 \<and> rel_set \<phi> (Inr -` A1) (Inr -` A2)"
   27.76 +unfolding rel_set_rel_sum rel_set_eq ..
   27.77 +
   27.78 +(* Detailed proofs of commutativity and associativity: *)
   27.79 +theorem par_com: "tr1 \<parallel> tr2 = tr2 \<parallel> tr1"
   27.80 +proof-
   27.81 +  let ?\<theta> = "\<lambda> trA trB. \<exists> tr1 tr2. trA = tr1 \<parallel> tr2 \<and> trB = tr2 \<parallel> tr1"
   27.82 +  {fix trA trB
   27.83 +   assume "?\<theta> trA trB" hence "trA = trB"
   27.84 +   apply (induct rule: dtree_coinduct)
   27.85 +   unfolding rel_set_rel_sum rel_set_eq unfolding rel_set_def proof safe
   27.86 +     fix tr1 tr2  show "root (tr1 \<parallel> tr2) = root (tr2 \<parallel> tr1)"
   27.87 +     unfolding root_par by (rule Nplus_comm)
   27.88 +   next
   27.89 +     fix n tr1 tr2 assume "Inl n \<in> cont (tr1 \<parallel> tr2)" thus "n \<in> Inl -` (cont (tr2 \<parallel> tr1))"
   27.90 +     unfolding Inl_in_cont_par by auto
   27.91 +   next
   27.92 +     fix n tr1 tr2 assume "Inl n \<in> cont (tr2 \<parallel> tr1)" thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2))"
   27.93 +     unfolding Inl_in_cont_par by auto
   27.94 +   next
   27.95 +     fix tr1 tr2 trA' assume "Inr trA' \<in> cont (tr1 \<parallel> tr2)"
   27.96 +     then obtain tr1' tr2' where "trA' = tr1' \<parallel> tr2'"
   27.97 +     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
   27.98 +     unfolding Inr_in_cont_par by auto
   27.99 +     thus "\<exists> trB' \<in> Inr -` (cont (tr2 \<parallel> tr1)). ?\<theta> trA' trB'"
  27.100 +     apply(intro bexI[of _ "tr2' \<parallel> tr1'"]) unfolding Inr_in_cont_par by auto
  27.101 +   next
  27.102 +     fix tr1 tr2 trB' assume "Inr trB' \<in> cont (tr2 \<parallel> tr1)"
  27.103 +     then obtain tr1' tr2' where "trB' = tr2' \<parallel> tr1'"
  27.104 +     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
  27.105 +     unfolding Inr_in_cont_par by auto
  27.106 +     thus "\<exists> trA' \<in> Inr -` (cont (tr1 \<parallel> tr2)). ?\<theta> trA' trB'"
  27.107 +     apply(intro bexI[of _ "tr1' \<parallel> tr2'"]) unfolding Inr_in_cont_par by auto
  27.108 +   qed
  27.109 +  }
  27.110 +  thus ?thesis by blast
  27.111 +qed
  27.112 +
  27.113 +lemma par_assoc: "(tr1 \<parallel> tr2) \<parallel> tr3 = tr1 \<parallel> (tr2 \<parallel> tr3)"
  27.114 +proof-
  27.115 +  let ?\<theta> =
  27.116 +  "\<lambda> trA trB. \<exists> tr1 tr2 tr3. trA = (tr1 \<parallel> tr2) \<parallel> tr3 \<and> trB = tr1 \<parallel> (tr2 \<parallel> tr3)"
  27.117 +  {fix trA trB
  27.118 +   assume "?\<theta> trA trB" hence "trA = trB"
  27.119 +   apply (induct rule: dtree_coinduct)
  27.120 +   unfolding rel_set_rel_sum rel_set_eq unfolding rel_set_def proof safe
  27.121 +     fix tr1 tr2 tr3  show "root ((tr1 \<parallel> tr2) \<parallel> tr3) = root (tr1 \<parallel> (tr2 \<parallel> tr3))"
  27.122 +     unfolding root_par by (rule Nplus_assoc)
  27.123 +   next
  27.124 +     fix n tr1 tr2 tr3 assume "Inl n \<in> (cont ((tr1 \<parallel> tr2) \<parallel> tr3))"
  27.125 +     thus "n \<in> Inl -` (cont (tr1 \<parallel> tr2 \<parallel> tr3))" unfolding Inl_in_cont_par by simp
  27.126 +   next
  27.127 +     fix n tr1 tr2 tr3 assume "Inl n \<in> (cont (tr1 \<parallel> tr2 \<parallel> tr3))"
  27.128 +     thus "n \<in> Inl -` (cont ((tr1 \<parallel> tr2) \<parallel> tr3))" unfolding Inl_in_cont_par by simp
  27.129 +   next
  27.130 +     fix trA' tr1 tr2 tr3 assume "Inr trA' \<in> cont ((tr1 \<parallel> tr2) \<parallel> tr3)"
  27.131 +     then obtain tr1' tr2' tr3' where "trA' = (tr1' \<parallel> tr2') \<parallel> tr3'"
  27.132 +     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
  27.133 +     and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
  27.134 +     thus "\<exists> trB' \<in> Inr -` (cont (tr1 \<parallel> tr2 \<parallel> tr3)). ?\<theta> trA' trB'"
  27.135 +     apply(intro bexI[of _ "tr1' \<parallel> tr2' \<parallel> tr3'"])
  27.136 +     unfolding Inr_in_cont_par by auto
  27.137 +   next
  27.138 +     fix trB' tr1 tr2 tr3 assume "Inr trB' \<in> cont (tr1 \<parallel> tr2 \<parallel> tr3)"
  27.139 +     then obtain tr1' tr2' tr3' where "trB' = tr1' \<parallel> (tr2' \<parallel> tr3')"
  27.140 +     and "Inr tr1' \<in> cont tr1" and "Inr tr2' \<in> cont tr2"
  27.141 +     and "Inr tr3' \<in> cont tr3" unfolding Inr_in_cont_par by auto
  27.142 +     thus "\<exists> trA' \<in> Inr -` cont ((tr1 \<parallel> tr2) \<parallel> tr3). ?\<theta> trA' trB'"
  27.143 +     apply(intro bexI[of _ "(tr1' \<parallel> tr2') \<parallel> tr3'"])
  27.144 +     unfolding Inr_in_cont_par by auto
  27.145 +   qed
  27.146 +  }
  27.147 +  thus ?thesis by blast
  27.148 +qed
  27.149 +
  27.150 +end
    28.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    28.2 +++ b/src/HOL/Datatype_Examples/Derivation_Trees/Prelim.thy	Thu Sep 11 19:26:59 2014 +0200
    28.3 @@ -0,0 +1,64 @@
    28.4 +(*  Title:      HOL/Datatype_Examples/Derivation_Trees/Prelim.thy
    28.5 +    Author:     Andrei Popescu, TU Muenchen
    28.6 +    Copyright   2012
    28.7 +
    28.8 +Preliminaries.
    28.9 +*)
   28.10 +
   28.11 +header {* Preliminaries *}
   28.12 +
   28.13 +theory Prelim
   28.14 +imports "~~/src/HOL/Library/FSet"
   28.15 +begin
   28.16 +
   28.17 +notation BNF_Def.convol ("\<langle>(_,/ _)\<rangle>")
   28.18 +
   28.19 +declare fset_to_fset[simp]
   28.20 +
   28.21 +lemma fst_snd_convol_o[simp]: "\<langle>fst o s, snd o s\<rangle> = s"
   28.22 +apply(rule ext) by (simp add: convol_def)
   28.23 +
   28.24 +abbreviation sm_abbrev (infix "\<oplus>" 60)
   28.25 +where "f \<oplus> g \<equiv> Sum_Type.map_sum f g"
   28.26 +
   28.27 +lemma map_sum_InlD: "(f \<oplus> g) z = Inl x \<Longrightarrow> \<exists>y. z = Inl y \<and> f y = x"
   28.28 +by (cases z) auto
   28.29 +
   28.30 +lemma map_sum_InrD: "(f \<oplus> g) z = Inr x \<Longrightarrow> \<exists>y. z = Inr y \<and> g y = x"
   28.31 +by (cases z) auto
   28.32 +
   28.33 +abbreviation case_sum_abbrev ("[[_,_]]" 800)
   28.34 +where "[[f,g]] \<equiv> Sum_Type.case_sum f g"
   28.35 +
   28.36 +lemma Inl_oplus_elim:
   28.37 +assumes "Inl tr \<in> (id \<oplus> f) ` tns"
   28.38 +shows "Inl tr \<in> tns"
   28.39 +using assms apply clarify by (case_tac x, auto)
   28.40 +
   28.41 +lemma Inl_oplus_iff[simp]: "Inl tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> Inl tr \<in> tns"
   28.42 +using Inl_oplus_elim
   28.43 +by (metis id_def image_iff map_sum.simps(1))
   28.44 +
   28.45 +lemma Inl_m_oplus[simp]: "Inl -` (id \<oplus> f) ` tns = Inl -` tns"
   28.46 +using Inl_oplus_iff unfolding vimage_def by auto
   28.47 +
   28.48 +lemma Inr_oplus_elim:
   28.49 +assumes "Inr tr \<in> (id \<oplus> f) ` tns"
   28.50 +shows "\<exists> n. Inr n \<in> tns \<and> f n = tr"
   28.51 +using assms apply clarify by (case_tac x, auto)
   28.52 +
   28.53 +lemma Inr_oplus_iff[simp]:
   28.54 +"Inr tr \<in> (id \<oplus> f) ` tns \<longleftrightarrow> (\<exists> n. Inr n \<in> tns \<and> f n = tr)"
   28.55 +apply (rule iffI)
   28.56 + apply (metis Inr_oplus_elim)
   28.57 +by (metis image_iff map_sum.simps(2))
   28.58 +
   28.59 +lemma Inr_m_oplus[simp]: "Inr -` (id \<oplus> f) ` tns = f ` (Inr -` tns)"
   28.60 +using Inr_oplus_iff unfolding vimage_def by auto
   28.61 +
   28.62 +lemma Inl_Inr_image_cong:
   28.63 +assumes "Inl -` A = Inl -` B" and "Inr -` A = Inr -` B"
   28.64 +shows "A = B"
   28.65 +apply safe using assms apply(case_tac x, auto) by(case_tac x, auto)
   28.66 +
   28.67 +end
   28.68 \ No newline at end of file
    29.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    29.2 +++ b/src/HOL/Datatype_Examples/Instructions.thy	Thu Sep 11 19:26:59 2014 +0200
    29.3 @@ -0,0 +1,162 @@
    29.4 +(*  Title:      HOL/Datatype_Benchmark/Instructions.thy
    29.5 +
    29.6 +Example from Konrad: 68000 instruction set.
    29.7 +*)
    29.8 +
    29.9 +theory Instructions imports Main begin
   29.10 +
   29.11 +datatype Size = Byte | Word | Long
   29.12 +
   29.13 +datatype DataRegister =
   29.14 +  RegD0
   29.15 +| RegD1
   29.16 +| RegD2
   29.17 +| RegD3
   29.18 +| RegD4
   29.19 +| RegD5
   29.20 +| RegD6
   29.21 +| RegD7
   29.22 +
   29.23 +datatype AddressRegister =
   29.24 +  RegA0
   29.25 +| RegA1
   29.26 +| RegA2
   29.27 +| RegA3
   29.28 +| RegA4
   29.29 +| RegA5
   29.30 +| RegA6
   29.31 +| RegA7
   29.32 +
   29.33 +datatype DataOrAddressRegister =
   29.34 +  data DataRegister
   29.35 +| address AddressRegister
   29.36 +
   29.37 +datatype Condition =
   29.38 +  Hi
   29.39 +| Ls
   29.40 +| Cc
   29.41 +| Cs
   29.42 +| Ne
   29.43 +| Eq
   29.44 +| Vc
   29.45 +| Vs
   29.46 +| Pl
   29.47 +| Mi
   29.48 +| Ge
   29.49 +| Lt
   29.50 +| Gt
   29.51 +| Le
   29.52 +
   29.53 +datatype AddressingMode =
   29.54 +  immediate nat
   29.55 +| direct DataOrAddressRegister
   29.56 +| indirect AddressRegister
   29.57 +| postinc AddressRegister
   29.58 +| predec AddressRegister
   29.59 +| indirectdisp nat AddressRegister
   29.60 +| indirectindex nat AddressRegister DataOrAddressRegister Size
   29.61 +| absolute nat
   29.62 +| pcdisp nat
   29.63 +| pcindex nat DataOrAddressRegister Size
   29.64 +
   29.65 +datatype M68kInstruction =
   29.66 +  ABCD AddressingMode AddressingMode
   29.67 +| ADD Size AddressingMode AddressingMode
   29.68 +| ADDA Size AddressingMode AddressRegister
   29.69 +| ADDI Size nat AddressingMode
   29.70 +| ADDQ Size nat AddressingMode
   29.71 +| ADDX Size AddressingMode AddressingMode
   29.72 +| AND Size AddressingMode AddressingMode
   29.73 +| ANDI Size nat AddressingMode
   29.74 +| ANDItoCCR nat
   29.75 +| ANDItoSR nat
   29.76 +| ASL Size AddressingMode DataRegister
   29.77 +| ASLW AddressingMode
   29.78 +| ASR Size AddressingMode DataRegister
   29.79 +| ASRW AddressingMode
   29.80 +| Bcc Condition Size nat
   29.81 +| BTST Size AddressingMode AddressingMode
   29.82 +| BCHG Size AddressingMode AddressingMode
   29.83 +| BCLR Size AddressingMode AddressingMode
   29.84 +| BSET Size AddressingMode AddressingMode
   29.85 +| BRA Size nat
   29.86 +| BSR Size nat
   29.87 +| CHK AddressingMode DataRegister
   29.88 +| CLR Size AddressingMode
   29.89 +| CMP Size AddressingMode DataRegister
   29.90 +| CMPA Size AddressingMode AddressRegister
   29.91 +| CMPI Size nat AddressingMode
   29.92 +| CMPM Size AddressRegister AddressRegister
   29.93 +| DBT DataRegister nat
   29.94 +| DBF DataRegister nat
   29.95 +| DBcc Condition DataRegister nat
   29.96 +| DIVS AddressingMode DataRegister
   29.97 +| DIVU AddressingMode DataRegister
   29.98 +| EOR Size DataRegister AddressingMode
   29.99 +| EORI Size nat AddressingMode
  29.100 +| EORItoCCR nat
  29.101 +| EORItoSR nat
  29.102 +| EXG DataOrAddressRegister DataOrAddressRegister
  29.103 +| EXT Size DataRegister
  29.104 +| ILLEGAL
  29.105 +| JMP AddressingMode
  29.106 +| JSR AddressingMode
  29.107 +| LEA AddressingMode AddressRegister
  29.108 +| LINK AddressRegister nat
  29.109 +| LSL Size AddressingMode DataRegister
  29.110 +| LSLW AddressingMode
  29.111 +| LSR Size AddressingMode DataRegister
  29.112 +| LSRW AddressingMode
  29.113 +| MOVE Size AddressingMode AddressingMode
  29.114 +| MOVEtoCCR AddressingMode
  29.115 +| MOVEtoSR AddressingMode
  29.116 +| MOVEfromSR AddressingMode
  29.117 +| MOVEtoUSP AddressingMode
  29.118 +| MOVEfromUSP AddressingMode
  29.119 +| MOVEA Size AddressingMode AddressRegister
  29.120 +| MOVEMto Size AddressingMode "DataOrAddressRegister list"
  29.121 +| MOVEMfrom Size "DataOrAddressRegister list" AddressingMode
  29.122 +| MOVEP Size AddressingMode AddressingMode
  29.123 +| MOVEQ nat DataRegister
  29.124 +| MULS AddressingMode DataRegister
  29.125 +| MULU AddressingMode DataRegister
  29.126 +| NBCD AddressingMode
  29.127 +| NEG Size AddressingMode
  29.128 +| NEGX Size AddressingMode
  29.129 +| NOP
  29.130 +| NOT Size AddressingMode
  29.131 +| OR Size AddressingMode AddressingMode
  29.132 +| ORI Size nat AddressingMode
  29.133 +| ORItoCCR nat
  29.134 +| ORItoSR nat
  29.135 +| PEA AddressingMode
  29.136 +| RESET
  29.137 +| ROL Size AddressingMode DataRegister
  29.138 +| ROLW AddressingMode
  29.139 +| ROR Size AddressingMode DataRegister
  29.140 +| RORW AddressingMode
  29.141 +| ROXL Size AddressingMode DataRegister
  29.142 +| ROXLW AddressingMode
  29.143 +| ROXR Size AddressingMode DataRegister
  29.144 +| ROXRW AddressingMode
  29.145 +| RTE
  29.146 +| RTR
  29.147 +| RTS
  29.148 +| SBCD AddressingMode AddressingMode
  29.149 +| ST AddressingMode
  29.150 +| SF AddressingMode
  29.151 +| Scc Condition AddressingMode
  29.152 +| STOP nat
  29.153 +| SUB Size AddressingMode AddressingMode
  29.154 +| SUBA Size AddressingMode AddressingMode
  29.155 +| SUBI Size nat AddressingMode
  29.156 +| SUBQ Size nat AddressingMode
  29.157 +| SUBX Size AddressingMode AddressingMode
  29.158 +| SWAP DataRegister
  29.159 +| TAS AddressingMode
  29.160 +| TRAP nat
  29.161 +| TRAPV
  29.162 +| TST Size AddressingMode
  29.163 +| UNLK AddressRegister
  29.164 +
  29.165 +end
    30.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    30.2 +++ b/src/HOL/Datatype_Examples/IsaFoR_Datatypes.thy	Thu Sep 11 19:26:59 2014 +0200
    30.3 @@ -0,0 +1,380 @@
    30.4 +(*  Title:      HOL/Datatype_Examples/IsaFoR_Datatypes.thy
    30.5 +    Author:     Rene Thiemann, UIBK
    30.6 +    Copyright   2014
    30.7 +
    30.8 +Benchmark consisting of datatypes defined in IsaFoR.
    30.9 +*)
   30.10 +
   30.11 +header {* Benchmark Consisting of Datatypes Defined in IsaFoR *}
   30.12 +
   30.13 +theory IsaFoR_Datatypes
   30.14 +imports Real
   30.15 +begin
   30.16 +
   30.17 +datatype_new (discs_sels) ('f, 'l) lab =
   30.18 +    Lab "('f, 'l) lab" 'l
   30.19 +  | FunLab "('f, 'l) lab" "('f, 'l) lab list"
   30.20 +  | UnLab 'f
   30.21 +  | Sharp "('f, 'l) lab"
   30.22 +
   30.23 +datatype_new (discs_sels) 'f projL = Projection "(('f \<times> nat) \<times> nat) list"
   30.24 +
   30.25 +datatype_new (discs_sels) ('f, 'v) "term" = Var 'v | Fun 'f "('f, 'v) term list"
   30.26 +datatype_new (discs_sels) ('f, 'v) ctxt =
   30.27 +    Hole ("\<box>")
   30.28 +  | More 'f "('f, 'v) term list" "('f, 'v) ctxt" "('f, 'v) term list"
   30.29 +
   30.30 +type_synonym ('f, 'v) rule = "('f, 'v) term \<times> ('f, 'v) term"
   30.31 +type_synonym ('f, 'v) trs  = "('f, 'v) rule set"
   30.32 +
   30.33 +type_synonym ('f, 'v) rules = "('f, 'v) rule list"
   30.34 +type_synonym ('f, 'l, 'v) ruleLL  = "(('f, 'l) lab, 'v) rule"
   30.35 +type_synonym ('f, 'l, 'v) trsLL   = "(('f, 'l) lab, 'v) rules"
   30.36 +type_synonym ('f, 'l, 'v) termsLL = "(('f, 'l) lab, 'v) term list"
   30.37 +
   30.38 +datatype_new (discs_sels) pos = Empty ("\<epsilon>") | PCons "nat" "pos" (infixr "<#" 70)
   30.39 +
   30.40 +type_synonym  ('f, 'v) prseq = "(pos \<times> ('f, 'v) rule \<times> bool \<times> ('f, 'v) term) list"
   30.41 +type_synonym  ('f, 'v) rseq = "(pos \<times> ('f, 'v) rule \<times> ('f, 'v) term) list"
   30.42 +
   30.43 +type_synonym ('f, 'l, 'v) rseqL   = "((('f, 'l) lab, 'v) rule \<times> (('f, 'l) lab, 'v) rseq) list"
   30.44 +type_synonym ('f, 'l, 'v) dppLL   =
   30.45 +  "bool \<times> bool \<times> ('f, 'l, 'v) trsLL \<times> ('f, 'l, 'v) trsLL \<times>
   30.46 +  ('f, 'l, 'v) termsLL \<times>
   30.47 +  ('f, 'l, 'v) trsLL \<times> ('f, 'l, 'v) trsLL"
   30.48 +
   30.49 +type_synonym ('f, 'l, 'v) qreltrsLL =
   30.50 +  "bool \<times> ('f, 'l, 'v) termsLL \<times> ('f, 'l, 'v) trsLL \<times> ('f, 'l, 'v) trsLL"
   30.51 +
   30.52 +type_synonym ('f, 'l, 'v) qtrsLL =
   30.53 +  "bool \<times> ('f, 'l, 'v) termsLL \<times> ('f, 'l, 'v) trsLL"
   30.54 +
   30.55 +datatype_new (discs_sels) location = H | A | B | R
   30.56 +
   30.57 +type_synonym ('f, 'v) forb_pattern = "('f, 'v) ctxt \<times> ('f, 'v) term \<times> location"
   30.58 +type_synonym ('f, 'v) forb_patterns = "('f, 'v) forb_pattern set"
   30.59 +
   30.60 +type_synonym ('f, 'l, 'v) fptrsLL =
   30.61 +  "(('f, 'l) lab, 'v) forb_pattern list \<times> ('f, 'l, 'v) trsLL"
   30.62 +
   30.63 +type_synonym ('f, 'l, 'v) prob = "('f, 'l, 'v) qreltrsLL + ('f, 'l, 'v) dppLL"
   30.64 +
   30.65 +type_synonym ('f, 'a) lpoly_inter = "'f \<times> nat \<Rightarrow> ('a \<times> 'a list)"
   30.66 +type_synonym ('f, 'a) lpoly_interL = "(('f \<times> nat) \<times> ('a \<times> 'a list)) list"
   30.67 +
   30.68 +type_synonym 'v monom = "('v \<times> nat) list"
   30.69 +type_synonym ('v, 'a) poly = "('v monom \<times> 'a) list"
   30.70 +type_synonym ('f, 'a) poly_inter_list = "(('f \<times> nat) \<times> (nat, 'a) poly) list"
   30.71 +type_synonym 'a vec = "'a list"
   30.72 +type_synonym 'a mat = "'a vec list"
   30.73 +
   30.74 +datatype_new (discs_sels) arctic = MinInfty | Num_arc int
   30.75 +datatype_new (discs_sels) 'a arctic_delta = MinInfty_delta | Num_arc_delta 'a
   30.76 +datatype_new (discs_sels) order_tag = Lex | Mul
   30.77 +
   30.78 +type_synonym 'f status_prec_repr = "(('f \<times> nat) \<times> (nat \<times> order_tag)) list"
   30.79 +
   30.80 +datatype_new (discs_sels) af_entry =
   30.81 +    Collapse nat
   30.82 +  | AFList "nat list"
   30.83 +
   30.84 +type_synonym 'f afs_list = "(('f \<times> nat) \<times> af_entry) list"
   30.85 +type_synonym 'f prec_weight_repr = "(('f \<times> nat) \<times> (nat \<times> nat \<times> (nat list option))) list \<times> nat"
   30.86 +
   30.87 +datatype_new (discs_sels) 'f redtriple_impl =
   30.88 +    Int_carrier "('f, int) lpoly_interL"
   30.89 +  | Int_nl_carrier "('f, int) poly_inter_list"
   30.90 +  | Rat_carrier "('f, rat) lpoly_interL"
   30.91 +  | Rat_nl_carrier rat "('f, rat) poly_inter_list"
   30.92 +  | Real_carrier "('f, real) lpoly_interL"
   30.93 +  | Real_nl_carrier real "('f, real) poly_inter_list"
   30.94 +  | Arctic_carrier "('f, arctic) lpoly_interL"
   30.95 +  | Arctic_rat_carrier "('f, rat arctic_delta) lpoly_interL"
   30.96 +  | Int_mat_carrier nat nat "('f, int mat) lpoly_interL"
   30.97 +  | Rat_mat_carrier nat nat "('f, rat mat) lpoly_interL"
   30.98 +  | Real_mat_carrier nat nat "('f, real mat) lpoly_interL"
   30.99 +  | Arctic_mat_carrier nat "('f, arctic mat) lpoly_interL"
  30.100 +  | Arctic_rat_mat_carrier nat "('f, rat arctic_delta mat) lpoly_interL"
  30.101 +  | RPO "'f status_prec_repr" "'f afs_list"
  30.102 +  | KBO "'f prec_weight_repr" "'f afs_list"
  30.103 +
  30.104 +datatype_new (discs_sels) list_order_type = MS_Ext | Max_Ext | Min_Ext  | Dms_Ext
  30.105 +type_synonym 'f scnp_af = "(('f \<times> nat) \<times> (nat \<times> nat) list) list"
  30.106 +
  30.107 +datatype_new (discs_sels) 'f root_redtriple_impl = SCNP list_order_type "'f scnp_af" "'f redtriple_impl"
  30.108 +
  30.109 +type_synonym 'f sig_map_list = "(('f \<times> nat) \<times> 'f list) list"
  30.110 +type_synonym ('f, 'v) uncurry_info = "'f \<times> 'f sig_map_list \<times> ('f, 'v) rules \<times> ('f, 'v) rules"
  30.111 +
  30.112 +datatype_new (discs_sels) arithFun =
  30.113 +    Arg nat
  30.114 +  | Const nat
  30.115 +  | Sum "arithFun list"
  30.116 +  | Max "arithFun list"
  30.117 +  | Min "arithFun list"
  30.118 +  | Prod "arithFun list"
  30.119 +  | IfEqual arithFun arithFun arithFun arithFun
  30.120 +
  30.121 +datatype_new (discs_sels) 'f sl_inter = SL_Inter nat "(('f \<times> nat) \<times> arithFun) list"
  30.122 +datatype_new (discs_sels) ('f, 'v) sl_variant =
  30.123 +    Rootlab "('f \<times> nat) option"
  30.124 +  | Finitelab "'f sl_inter"
  30.125 +  | QuasiFinitelab "'f sl_inter" 'v
  30.126 +
  30.127 +type_synonym ('f, 'v) crit_pair_joins = "(('f, 'v) term \<times> ('f, 'v) rseq \<times> ('f, 'v) term \<times> ('f, 'v) rseq) list"
  30.128 +
  30.129 +datatype_new (discs_sels) 'f join_info = Guided "('f, string) crit_pair_joins" | Join_NF | Join_BFS nat
  30.130 +
  30.131 +type_synonym unknown_info = string
  30.132 +
  30.133 +type_synonym dummy_prf = unit
  30.134 +
  30.135 +datatype_new (discs_sels) ('f, 'v) complex_constant_removal_prf = Complex_Constant_Removal_Proof
  30.136 +  "('f, 'v) term"
  30.137 +  "(('f, 'v) rule \<times> ('f, 'v) rule) list"
  30.138 +
  30.139 +datatype_new (discs_sels) ('f, 'v) cond_constraint =
  30.140 +    CC_cond bool "('f, 'v) rule"
  30.141 +  | CC_rewr "('f, 'v) term" "('f, 'v) term"
  30.142 +  | CC_impl "('f, 'v) cond_constraint list" "('f, 'v) cond_constraint"
  30.143 +  | CC_all 'v "('f, 'v) cond_constraint"
  30.144 +
  30.145 +type_synonym ('f, 'v, 'w) gsubstL = "('v \<times> ('f, 'w) term) list"
  30.146 +type_synonym ('f, 'v) substL = "('f, 'v, 'v) gsubstL"
  30.147 +
  30.148 +datatype_new (discs_sels) ('f, 'v) cond_constraint_prf =
  30.149 +    Final
  30.150 +  | Delete_Condition "('f, 'v) cond_constraint" "('f, 'v) cond_constraint_prf"
  30.151 +  | Different_Constructor "('f, 'v) cond_constraint"
  30.152 +  | Same_Constructor "('f, 'v) cond_constraint" "('f, 'v) cond_constraint" "('f, 'v) cond_constraint_prf"
  30.153 +  | Variable_Equation 'v "('f, 'v) term" "('f, 'v) cond_constraint" "('f, 'v) cond_constraint_prf"
  30.154 +  | Funarg_Into_Var "('f, 'v) cond_constraint" nat 'v "('f, 'v) cond_constraint" "('f, 'v) cond_constraint_prf"
  30.155 +  | Simplify_Condition "('f, 'v) cond_constraint" "('f, 'v) substL" "('f, 'v) cond_constraint" "('f, 'v) cond_constraint_prf"
  30.156 +  | Induction "('f, 'v) cond_constraint" "('f, 'v) cond_constraint list" "(('f, 'v) rule \<times> (('f, 'v) term \<times> 'v list) list \<times> ('f, 'v) cond_constraint \<times> ('f, 'v) cond_constraint_prf) list"
  30.157 +
  30.158 +datatype_new (discs_sels) ('f, 'v) cond_red_pair_prf =
  30.159 +  Cond_Red_Pair_Prf
  30.160 +    'f "(('f, 'v) cond_constraint \<times> ('f, 'v) rules \<times> ('f, 'v) cond_constraint_prf) list" nat nat
  30.161 +
  30.162 +datatype_new (discs_sels) ('q, 'f) ta_rule = TA_rule 'f "'q list" 'q ("_ _ \<rightarrow> _")
  30.163 +datatype_new (discs_sels) ('q, 'f) tree_automaton = Tree_Automaton "'q list" "('q, 'f) ta_rule list" "('q \<times> 'q) list"
  30.164 +datatype_new (discs_sels) 'q ta_relation =
  30.165 +    Decision_Proc
  30.166 +  | Id_Relation
  30.167 +  | Some_Relation "('q \<times> 'q) list"
  30.168 +
  30.169 +datatype_new (discs_sels) boundstype = Roof | Match
  30.170 +datatype_new (discs_sels) ('f, 'q) bounds_info = Bounds_Info boundstype nat "'q list" "('q, 'f \<times> nat) tree_automaton" "'q ta_relation"
  30.171 +
  30.172 +datatype_new (discs_sels) ('f, 'v) pat_eqv_prf =
  30.173 +    Pat_Dom_Renaming "('f, 'v) substL"
  30.174 +  | Pat_Irrelevant "('f, 'v) substL" "('f, 'v) substL"
  30.175 +  | Pat_Simplify "('f, 'v) substL" "('f, 'v) substL"
  30.176 +
  30.177 +datatype_new (discs_sels) pat_rule_pos = Pat_Base | Pat_Pump | Pat_Close
  30.178 +
  30.179 +datatype_new (discs_sels) ('f, 'v) pat_rule_prf =
  30.180 +    Pat_OrigRule "('f, 'v) rule" bool
  30.181 +  | Pat_InitPump "('f, 'v) pat_rule_prf" "('f, 'v) substL" "('f, 'v) substL"
  30.182 +  | Pat_InitPumpCtxt "('f, 'v) pat_rule_prf" "('f, 'v) substL" pos 'v
  30.183 +  | Pat_Equiv "('f, 'v) pat_rule_prf" bool "('f, 'v) pat_eqv_prf"
  30.184 +  | Pat_Narrow "('f, 'v) pat_rule_prf" "('f, 'v) pat_rule_prf" pos
  30.185 +  | Pat_Inst "('f, 'v) pat_rule_prf" "('f, 'v) substL" pat_rule_pos
  30.186 +  | Pat_Rewr "('f, 'v) pat_rule_prf" "('f, 'v) term \<times> ('f, 'v) rseq" pat_rule_pos 'v
  30.187 +  | Pat_Exp_Sigma "('f, 'v) pat_rule_prf" nat
  30.188 +
  30.189 +datatype_new (discs_sels) ('f, 'v) non_loop_prf =
  30.190 +    Non_Loop_Prf "('f, 'v) pat_rule_prf" "('f, 'v) substL" "('f, 'v) substL" nat nat pos
  30.191 +
  30.192 +datatype_new (discs_sels) ('f, 'l, 'v) problem =
  30.193 +    SN_TRS "('f, 'l, 'v) qreltrsLL"
  30.194 +  | SN_FP_TRS "('f, 'l, 'v) fptrsLL"
  30.195 +  | Finite_DPP "('f, 'l, 'v) dppLL"
  30.196 +  | Unknown_Problem unknown_info
  30.197 +  | Not_SN_TRS "('f, 'l, 'v) qtrsLL"
  30.198 +  | Not_RelSN_TRS "('f, 'l, 'v) qreltrsLL"
  30.199 +  | Infinite_DPP "('f, 'l, 'v) dppLL"
  30.200 +  | Not_SN_FP_TRS "('f, 'l, 'v) fptrsLL"
  30.201 +
  30.202 +declare [[bnf_timing]]
  30.203 +
  30.204 +datatype_new (discs_sels) ('f, 'l, 'v, 'a, 'b, 'c, 'd, 'e) generic_assm_proof =
  30.205 +    SN_assm_proof "('f, 'l, 'v) qreltrsLL" 'a
  30.206 +  | Finite_assm_proof "('f, 'l, 'v) dppLL" 'b
  30.207 +  | SN_FP_assm_proof "('f, 'l, 'v) fptrsLL" 'c
  30.208 +  | Not_SN_assm_proof "('f, 'l, 'v) qtrsLL" 'a
  30.209 +  | Infinite_assm_proof "('f, 'l, 'v) dppLL" 'b
  30.210 +  | Not_RelSN_assm_proof "('f, 'l, 'v) qreltrsLL" 'c
  30.211 +  | Not_SN_FP_assm_proof "('f, 'l, 'v) fptrsLL" 'd
  30.212 +  | Unknown_assm_proof unknown_info 'e
  30.213 +
  30.214 +type_synonym ('f, 'l, 'v, 'a, 'b, 'c, 'd) assm_proof = "('f, 'l, 'v, 'a, 'b, 'c, dummy_prf, 'd) generic_assm_proof"
  30.215 +
  30.216 +datatype_new (discs_sels) ('f, 'l, 'v) assm =
  30.217 +    SN_assm "('f, 'l, 'v) problem list" "('f, 'l, 'v) qreltrsLL"
  30.218 +  | SN_FP_assm "('f, 'l, 'v) problem list" "('f, 'l, 'v) fptrsLL"
  30.219 +  | Finite_assm "('f, 'l, 'v) problem list" "('f, 'l, 'v) dppLL"
  30.220 +  | Unknown_assm "('f, 'l, 'v) problem list" unknown_info
  30.221 +  | Not_SN_assm "('f, 'l, 'v) problem list" "('f, 'l, 'v) qtrsLL"
  30.222 +  | Not_RelSN_assm "('f, 'l, 'v) problem list" "('f, 'l, 'v) qreltrsLL"
  30.223 +  | Not_SN_FP_assm "('f, 'l, 'v) problem list" "('f, 'l, 'v) fptrsLL"
  30.224 +  | Infinite_assm "('f, 'l, 'v) problem list" "('f, 'l, 'v) dppLL"
  30.225 +
  30.226 +fun satisfied :: "('f, 'l, 'v) problem \<Rightarrow> bool" where
  30.227 +  "satisfied (SN_TRS t) = (t = t)"
  30.228 +| "satisfied (SN_FP_TRS t) = (t \<noteq> t)"
  30.229 +| "satisfied (Finite_DPP d) = (d \<noteq> d)"
  30.230 +| "satisfied (Unknown_Problem s) = (s = ''foo'')"
  30.231 +| "satisfied (Not_SN_TRS (nfs, q, r)) = (length q = length r)"
  30.232 +| "satisfied (Not_RelSN_TRS (nfs, q, r, rw)) = (r = rw)"
  30.233 +| "satisfied (Infinite_DPP d) = (d = d)"
  30.234 +| "satisfied (Not_SN_FP_TRS t) = (t = t)"
  30.235 +
  30.236 +fun collect_assms :: "('tp \<Rightarrow> ('f, 'l, 'v) assm list)
  30.237 +  \<Rightarrow> ('dpp \<Rightarrow> ('f, 'l, 'v) assm list)
  30.238 +  \<Rightarrow> ('fptp \<Rightarrow> ('f, 'l, 'v) assm list)
  30.239 +  \<Rightarrow> ('unk \<Rightarrow> ('f, 'l, 'v) assm list)
  30.240 +  \<Rightarrow> ('f, 'l, 'v, 'tp, 'dpp, 'fptp, 'unk) assm_proof \<Rightarrow> ('f, 'l, 'v) assm list" where
  30.241 +  "collect_assms tp dpp fptp unk (SN_assm_proof t prf) = tp prf"
  30.242 +| "collect_assms tp dpp fptp unk (SN_FP_assm_proof t prf) = fptp prf"
  30.243 +| "collect_assms tp dpp fptp unk (Finite_assm_proof d prf) = dpp prf"
  30.244 +| "collect_assms tp dpp fptp unk (Unknown_assm_proof p prf) = unk prf"
  30.245 +| "collect_assms _ _ _ _ _ = []"
  30.246 +
  30.247 +fun collect_neg_assms :: "('tp \<Rightarrow> ('f, 'l, 'v) assm list)
  30.248 +  \<Rightarrow> ('dpp \<Rightarrow> ('f, 'l, 'v) assm list)
  30.249 +  \<Rightarrow> ('rtp \<Rightarrow> ('f, 'l, 'v) assm list)
  30.250 +  \<Rightarrow> ('fptp \<Rightarrow> ('f, 'l, 'v) assm list)
  30.251 +  \<Rightarrow> ('unk \<Rightarrow> ('f, 'l, 'v) assm list)
  30.252 +  \<Rightarrow> ('f, 'l, 'v, 'tp, 'dpp, 'rtp, 'fptp, 'unk) generic_assm_proof \<Rightarrow> ('f, 'l, 'v) assm list" where
  30.253 +  "collect_neg_assms tp dpp rtp fptp unk (Not_SN_assm_proof t prf) = tp prf"
  30.254 +| "collect_neg_assms tp dpp rtp fptp unk (Infinite_assm_proof d prf) = dpp prf"
  30.255 +| "collect_neg_assms tp dpp rtp fptp unk (Not_RelSN_assm_proof t prf) = rtp prf"
  30.256 +| "collect_neg_assms tp dpp rtp fptp unk (Not_SN_FP_assm_proof t prf) = fptp prf"
  30.257 +| "collect_neg_assms tp dpp rtp fptp unk (Unknown_assm_proof p prf) = unk prf"
  30.258 +| "collect_neg_assms tp dpp rtp fptp unk _ = []"
  30.259 +
  30.260 +datatype_new (discs_sels) ('f, 'l, 'v) dp_nontermination_proof =
  30.261 +    DP_Loop "(('f, 'l) lab, 'v) term" "(('f, 'l) lab, 'v) prseq" "(('f, 'l) lab, 'v) substL" "(('f, 'l) lab, 'v) ctxt"
  30.262 +  | DP_Nonloop "(('f, 'l) lab, 'v) non_loop_prf"
  30.263 +  | DP_Rule_Removal "('f, 'l, 'v) trsLL option" "('f, 'l, 'v) trsLL option" "('f, 'l, 'v) dp_nontermination_proof"
  30.264 +  | DP_Q_Increase "('f, 'l, 'v) termsLL" "('f, 'l, 'v) dp_nontermination_proof"
  30.265 +  | DP_Q_Reduction "('f, 'l, 'v) termsLL" "('f, 'l, 'v) dp_nontermination_proof"
  30.266 +  | DP_Termination_Switch "('f, 'l) lab join_info" "('f, 'l, 'v) dp_nontermination_proof"
  30.267 +  | DP_Instantiation "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_nontermination_proof"
  30.268 +  | DP_Rewriting "('f, 'l, 'v) trsLL option" "('f, 'l, 'v) ruleLL" "('f, 'l, 'v) ruleLL" "('f, 'l, 'v) ruleLL" "(('f, 'l) lab, 'v) rule" pos "('f, 'l, 'v) dp_nontermination_proof"
  30.269 +  | DP_Narrowing "('f, 'l, 'v) ruleLL" pos "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_nontermination_proof"
  30.270 +  | DP_Assume_Infinite  "('f, 'l, 'v) dppLL"
  30.271 +      "('f, 'l, 'v, ('f, 'l, 'v) trs_nontermination_proof,
  30.272 +       ('f, 'l, 'v) dp_nontermination_proof,
  30.273 +       ('f, 'l, 'v) reltrs_nontermination_proof,
  30.274 +       ('f, 'l, 'v) fp_nontermination_proof,
  30.275 +       ('f, 'l, 'v) neg_unknown_proof) generic_assm_proof list"
  30.276 +and ('f, 'l, 'v) "trs_nontermination_proof" =
  30.277 +    TRS_Loop "(('f, 'l) lab, 'v) term" "(('f, 'l) lab, 'v) rseq" "(('f, 'l) lab, 'v) substL" "(('f, 'l) lab, 'v) ctxt"
  30.278 +  | TRS_Not_Well_Formed
  30.279 +  | TRS_Rule_Removal "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trs_nontermination_proof"
  30.280 +  | TRS_String_Reversal "('f, 'l, 'v) trs_nontermination_proof"
  30.281 +  | TRS_DP_Trans "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_nontermination_proof"
  30.282 +  | TRS_Nonloop "(('f, 'l) lab, 'v) non_loop_prf"
  30.283 +  | TRS_Q_Increase "('f, 'l, 'v) termsLL" "('f, 'l, 'v) trs_nontermination_proof"
  30.284 +  | TRS_Assume_Not_SN  "('f, 'l, 'v) qtrsLL"
  30.285 +      "('f, 'l, 'v, ('f, 'l, 'v) trs_nontermination_proof,
  30.286 +       ('f, 'l, 'v) dp_nontermination_proof,
  30.287 +       ('f, 'l, 'v) reltrs_nontermination_proof,
  30.288 +       ('f, 'l, 'v) fp_nontermination_proof,
  30.289 +       ('f, 'l, 'v) neg_unknown_proof) generic_assm_proof list"
  30.290 +and ('f, 'l, 'v)"reltrs_nontermination_proof" =
  30.291 +    Rel_Loop "(('f, 'l) lab, 'v) term" "(('f, 'l) lab, 'v) prseq" "(('f, 'l) lab, 'v) substL" "(('f, 'l) lab, 'v) ctxt"
  30.292 +  | Rel_Not_Well_Formed
  30.293 +  | Rel_Rule_Removal "('f, 'l, 'v) trsLL option" "('f, 'l, 'v) trsLL option" "('f, 'l, 'v) reltrs_nontermination_proof"
  30.294 +  | Rel_R_Not_SN "('f, 'l, 'v) trs_nontermination_proof"
  30.295 +  | Rel_TRS_Assume_Not_SN  "('f, 'l, 'v) qreltrsLL"
  30.296 +      "('f, 'l, 'v, ('f, 'l, 'v) trs_nontermination_proof,
  30.297 +       ('f, 'l, 'v) dp_nontermination_proof,
  30.298 +       ('f, 'l, 'v) reltrs_nontermination_proof,
  30.299 +       ('f, 'l, 'v) fp_nontermination_proof,
  30.300 +       ('f, 'l, 'v) neg_unknown_proof) generic_assm_proof list"
  30.301 +and ('f, 'l, 'v) "fp_nontermination_proof" =
  30.302 +    FPTRS_Loop "(('f, 'l) lab, 'v) term" "(('f, 'l) lab, 'v) rseq" "(('f, 'l) lab, 'v) substL" "(('f, 'l) lab, 'v) ctxt"
  30.303 +  | FPTRS_Rule_Removal "('f, 'l, 'v) trsLL" "('f, 'l, 'v) fp_nontermination_proof"
  30.304 +  | FPTRS_Assume_Not_SN  "('f, 'l, 'v) fptrsLL"
  30.305 +      "('f, 'l, 'v, ('f, 'l, 'v) trs_nontermination_proof,
  30.306 +       ('f, 'l, 'v) dp_nontermination_proof,
  30.307 +       ('f, 'l, 'v) reltrs_nontermination_proof,
  30.308 +       ('f, 'l, 'v) fp_nontermination_proof,
  30.309 +       ('f, 'l, 'v) neg_unknown_proof) generic_assm_proof list"
  30.310 +and ('f, 'l, 'v) neg_unknown_proof =
  30.311 +    Assume_NT_Unknown unknown_info
  30.312 +      "('f, 'l, 'v, ('f, 'l, 'v) trs_nontermination_proof,
  30.313 +       ('f, 'l, 'v) dp_nontermination_proof,
  30.314 +       ('f, 'l, 'v) reltrs_nontermination_proof,
  30.315 +       ('f, 'l, 'v) fp_nontermination_proof,
  30.316 +       ('f, 'l, 'v) neg_unknown_proof) generic_assm_proof list"
  30.317 +
  30.318 +datatype_new (discs_sels) ('f, 'l, 'v) dp_termination_proof =
  30.319 +    P_is_Empty
  30.320 +  | Subterm_Criterion_Proc "('f, 'l) lab projL" "('f, 'l, 'v) rseqL"
  30.321 +      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
  30.322 +  | Redpair_Proc "('f, 'l) lab root_redtriple_impl + ('f, 'l) lab redtriple_impl" "('f, 'l, 'v) trsLL"  "('f, 'l, 'v) dp_termination_proof"
  30.323 +  | Redpair_UR_Proc "('f, 'l) lab root_redtriple_impl + ('f, 'l) lab redtriple_impl"
  30.324 +      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
  30.325 +  | Usable_Rules_Proc "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
  30.326 +  | Dep_Graph_Proc "(('f, 'l, 'v) dp_termination_proof option \<times> ('f, 'l, 'v) trsLL) list"
  30.327 +  | Mono_Redpair_Proc "('f, 'l) lab redtriple_impl"
  30.328 +      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
  30.329 +  | Mono_Redpair_UR_Proc "('f, 'l) lab redtriple_impl"
  30.330 +      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
  30.331 +  | Size_Change_Subterm_Proc "((('f, 'l) lab, 'v) rule \<times> ((nat \<times> nat) list \<times> (nat \<times> nat) list)) list"
  30.332 +  | Size_Change_Redpair_Proc "('f, 'l) lab redtriple_impl" "('f, 'l, 'v) trsLL option"
  30.333 +      "((('f, 'l) lab, 'v) rule \<times> ((nat \<times> nat) list \<times> (nat \<times> nat) list)) list"
  30.334 +  | Uncurry_Proc "nat option" "(('f, 'l) lab, 'v) uncurry_info"
  30.335 +      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
  30.336 +  | Fcc_Proc "('f, 'l) lab" "(('f, 'l) lab, 'v) ctxt list"
  30.337 +      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
  30.338 +  | Split_Proc
  30.339 +      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL"
  30.340 +      "('f, 'l, 'v) dp_termination_proof" "('f, 'l, 'v) dp_termination_proof"
  30.341 +  | Semlab_Proc
  30.342 +      "(('f, 'l) lab, 'v) sl_variant" "('f, 'l, 'v) trsLL"
  30.343 +      "(('f, 'l) lab, 'v) term list" "('f, 'l, 'v) trsLL"
  30.344 +      "('f, 'l, 'v) dp_termination_proof"
  30.345 +  | Switch_Innermost_Proc "('f, 'l) lab join_info" "('f, 'l, 'v) dp_termination_proof"
  30.346 +  | Rewriting_Proc
  30.347 +      "('f, 'l, 'v) trsLL option" "('f, 'l, 'v) ruleLL" "('f, 'l, 'v) ruleLL"
  30.348 +      "('f, 'l, 'v) ruleLL" "('f, 'l, 'v) ruleLL" pos "('f, 'l, 'v) dp_termination_proof"
  30.349 +  | Instantiation_Proc "('f, 'l, 'v) ruleLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
  30.350 +  | Forward_Instantiation_Proc
  30.351 +      "('f, 'l, 'v) ruleLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL option" "('f, 'l, 'v) dp_termination_proof"
  30.352 +  | Narrowing_Proc "('f, 'l, 'v) ruleLL" pos "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
  30.353 +  | Assume_Finite
  30.354 +      "('f, 'l, 'v) dppLL" "('f, 'l, 'v, ('f, 'l, 'v) trs_termination_proof, ('f, 'l, 'v) dp_termination_proof, ('f, 'l, 'v) fptrs_termination_proof, ('f, 'l, 'v) unknown_proof) assm_proof list"
  30.355 +  | Unlab_Proc "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) dp_termination_proof"
  30.356 +  | Q_Reduction_Proc "('f, 'l, 'v) termsLL" "('f, 'l, 'v) dp_termination_proof"
  30.357 +  | Complex_Constant_Removal_Proc "(('f, 'l) lab, 'v) complex_constant_removal_prf" "('f, 'l, 'v) dp_termination_proof"
  30.358 +  | General_Redpair_Proc
  30.359 +      "('f, 'l) lab redtriple_impl" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trsLL"
  30.360 +      "(('f, 'l) lab, 'v) cond_red_pair_prf" "('f, 'l, 'v) dp_termination_proof list"
  30.361 +  | To_Trs_Proc "('f, 'l, 'v) trs_termination_proof"
  30.362 +and ('f, 'l, 'v) trs_termination_proof =
  30.363 +    DP_Trans bool bool "(('f, 'l) lab, 'v) rules" "('f, 'l, 'v) dp_termination_proof"
  30.364 +  | Rule_Removal "('f, 'l) lab redtriple_impl" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trs_termination_proof"
  30.365 +  | String_Reversal "('f, 'l, 'v) trs_termination_proof"
  30.366 +  | Bounds "(('f, 'l) lab, 'v) bounds_info"
  30.367 +  | Uncurry "(('f, 'l) lab, 'v) uncurry_info" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trs_termination_proof"
  30.368 +  | Semlab
  30.369 +      "(('f, 'l) lab, 'v) sl_variant" "(('f, 'l) lab, 'v) term list"
  30.370 +      "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trs_termination_proof"
  30.371 +  | R_is_Empty
  30.372 +  | Fcc "(('f, 'l) lab, 'v) ctxt list" "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trs_termination_proof"
  30.373 +  | Split "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trs_termination_proof" "('f, 'l, 'v) trs_termination_proof"
  30.374 +  | Switch_Innermost "('f, 'l) lab join_info" "('f, 'l, 'v) trs_termination_proof"
  30.375 +  | Drop_Equality "('f, 'l, 'v) trs_termination_proof"
  30.376 +  | Remove_Nonapplicable_Rules "('f, 'l, 'v) trsLL" "('f, 'l, 'v) trs_termination_proof"
  30.377 +  | Assume_SN "('f, 'l, 'v) qreltrsLL" "('f, 'l, 'v, ('f, 'l, 'v) trs_termination_proof, ('f, 'l, 'v) dp_termination_proof, ('f, 'l, 'v) fptrs_termination_proof, ('f, 'l, 'v) unknown_proof) assm_proof list"
  30.378 +and ('f, 'l, 'v) unknown_proof =
  30.379 +    Assume_Unknown unknown_info "('f, 'l, 'v, ('f, 'l, 'v) trs_termination_proof, ('f, 'l, 'v) dp_termination_proof, ('f, 'l, 'v) fptrs_termination_proof, ('f, 'l, 'v) unknown_proof) assm_proof list"
  30.380 +and ('f, 'l, 'v) fptrs_termination_proof =
  30.381 +    Assume_FP_SN "('f, 'l, 'v) fptrsLL" "('f, 'l, 'v, ('f, 'l, 'v) trs_termination_proof, ('f, 'l, 'v) dp_termination_proof, ('f, 'l, 'v) fptrs_termination_proof, ('f, 'l, 'v) unknown_proof) assm_proof list"
  30.382 +
  30.383 +end
    31.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    31.2 +++ b/src/HOL/Datatype_Examples/Koenig.thy	Thu Sep 11 19:26:59 2014 +0200
    31.3 @@ -0,0 +1,122 @@
    31.4 +(*  Title:      HOL/Datatype_Examples/Koenig.thy
    31.5 +    Author:     Dmitriy Traytel, TU Muenchen
    31.6 +    Author:     Andrei Popescu, TU Muenchen
    31.7 +    Copyright   2012
    31.8 +
    31.9 +Koenig's lemma.
   31.10 +*)
   31.11 +
   31.12 +header {* Koenig's Lemma *}
   31.13 +
   31.14 +theory Koenig
   31.15 +imports TreeFI Stream
   31.16 +begin
   31.17 +
   31.18 +(* infinite trees: *)
   31.19 +coinductive infiniteTr where
   31.20 +"\<lbrakk>tr' \<in> set (sub tr); infiniteTr tr'\<rbrakk> \<Longrightarrow> infiniteTr tr"
   31.21 +
   31.22 +lemma infiniteTr_strong_coind[consumes 1, case_names sub]:
   31.23 +assumes *: "phi tr" and
   31.24 +**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set (sub tr). phi tr' \<or> infiniteTr tr'"
   31.25 +shows "infiniteTr tr"
   31.26 +using assms by (elim infiniteTr.coinduct) blast
   31.27 +
   31.28 +lemma infiniteTr_coind[consumes 1, case_names sub, induct pred: infiniteTr]:
   31.29 +assumes *: "phi tr" and
   31.30 +**: "\<And> tr. phi tr \<Longrightarrow> \<exists> tr' \<in> set (sub tr). phi tr'"
   31.31 +shows "infiniteTr tr"
   31.32 +using assms by (elim infiniteTr.coinduct) blast
   31.33 +
   31