renamed modules defining old datatypes, as a step towards having 'datatype_new' take 'datatype's place
authorblanchet
Mon Sep 01 16:17:46 2014 +0200 (2014-09-01)
changeset 581128081087096ad
parent 58111 82db9ad610b9
child 58113 ab6220d6cf70
renamed modules defining old datatypes, as a step towards having 'datatype_new' take 'datatype's place
src/Doc/ROOT
src/Doc/Tutorial/ToyList/ToyList.thy
src/Doc/Tutorial/ToyList/ToyList1.txt
src/Doc/Tutorial/ToyList/ToyList_Test.thy
src/HOL/BNF_Examples/Compat.thy
src/HOL/BNF_FP_Base.thy
src/HOL/Datatype.thy
src/HOL/Extraction.thy
src/HOL/HOLCF/Tools/Domain/domain_constructors.ML
src/HOL/HOLCF/Tools/Domain/domain_induction.ML
src/HOL/HOLCF/ex/Pattern_Match.thy
src/HOL/Induct/SList.thy
src/HOL/Induct/Sexp.thy
src/HOL/Inductive.thy
src/HOL/Library/Countable.thy
src/HOL/Library/Old_SMT/old_smt_normalize.ML
src/HOL/Nominal/nominal_atoms.ML
src/HOL/Nominal/nominal_datatype.ML
src/HOL/Nominal/nominal_inductive.ML
src/HOL/Nominal/nominal_inductive2.ML
src/HOL/Nominal/nominal_primrec.ML
src/HOL/Num.thy
src/HOL/Old_Datatype.thy
src/HOL/Option.thy
src/HOL/SPARK/Tools/spark_vcs.ML
src/HOL/Statespace/state_fun.ML
src/HOL/Tools/BNF/bnf_fp_def_sugar.ML
src/HOL/Tools/BNF/bnf_fp_n2m_sugar.ML
src/HOL/Tools/BNF/bnf_lfp_compat.ML
src/HOL/Tools/BNF/bnf_lfp_rec_sugar.ML
src/HOL/Tools/Datatype/datatype.ML
src/HOL/Tools/Datatype/datatype_aux.ML
src/HOL/Tools/Datatype/datatype_codegen.ML
src/HOL/Tools/Datatype/datatype_data.ML
src/HOL/Tools/Datatype/datatype_prop.ML
src/HOL/Tools/Datatype/datatype_realizer.ML
src/HOL/Tools/Datatype/primrec.ML
src/HOL/Tools/Datatype/rep_datatype.ML
src/HOL/Tools/Function/function.ML
src/HOL/Tools/Function/old_size.ML
src/HOL/Tools/Function/size.ML
src/HOL/Tools/Lifting/lifting_def.ML
src/HOL/Tools/Old_Datatype/old_datatype.ML
src/HOL/Tools/Old_Datatype/old_datatype_aux.ML
src/HOL/Tools/Old_Datatype/old_datatype_codegen.ML
src/HOL/Tools/Old_Datatype/old_datatype_data.ML
src/HOL/Tools/Old_Datatype/old_datatype_prop.ML
src/HOL/Tools/Old_Datatype/old_datatype_realizer.ML
src/HOL/Tools/Old_Datatype/old_primrec.ML
src/HOL/Tools/Old_Datatype/old_rep_datatype.ML
src/HOL/Tools/Quickcheck/abstract_generators.ML
src/HOL/Tools/Quickcheck/exhaustive_generators.ML
src/HOL/Tools/Quickcheck/narrowing_generators.ML
src/HOL/Tools/Quickcheck/quickcheck_common.ML
src/HOL/Tools/Quickcheck/random_generators.ML
src/HOL/Tools/SMT/smt_normalize.ML
src/HOL/Tools/TFL/casesplit.ML
src/HOL/Tools/TFL/tfl.ML
src/HOL/Tools/TFL/thry.ML
src/HOL/Tools/inductive_realizer.ML
     1.1 --- a/src/Doc/ROOT	Mon Sep 01 16:17:46 2014 +0200
     1.2 +++ b/src/Doc/ROOT	Mon Sep 01 16:17:46 2014 +0200
     1.3 @@ -435,4 +435,3 @@
     1.4      "tutorial.sty"
     1.5      "typedef.pdf"
     1.6      "types0.tex"
     1.7 -
     2.1 --- a/src/Doc/Tutorial/ToyList/ToyList.thy	Mon Sep 01 16:17:46 2014 +0200
     2.2 +++ b/src/Doc/Tutorial/ToyList/ToyList.thy	Mon Sep 01 16:17:46 2014 +0200
     2.3 @@ -1,5 +1,5 @@
     2.4  theory ToyList
     2.5 -imports Datatype
     2.6 +imports Old_Datatype
     2.7  begin
     2.8  
     2.9  text{*\noindent
     3.1 --- a/src/Doc/Tutorial/ToyList/ToyList1.txt	Mon Sep 01 16:17:46 2014 +0200
     3.2 +++ b/src/Doc/Tutorial/ToyList/ToyList1.txt	Mon Sep 01 16:17:46 2014 +0200
     3.3 @@ -1,5 +1,5 @@
     3.4  theory ToyList
     3.5 -imports Datatype
     3.6 +imports Old_Datatype
     3.7  begin
     3.8  
     3.9  datatype 'a list = Nil                          ("[]")
     4.1 --- a/src/Doc/Tutorial/ToyList/ToyList_Test.thy	Mon Sep 01 16:17:46 2014 +0200
     4.2 +++ b/src/Doc/Tutorial/ToyList/ToyList_Test.thy	Mon Sep 01 16:17:46 2014 +0200
     4.3 @@ -1,5 +1,5 @@
     4.4  theory ToyList_Test
     4.5 -imports Datatype
     4.6 +imports Old_Datatype
     4.7  begin
     4.8  
     4.9  ML {*
    4.10 @@ -10,4 +10,3 @@
    4.11  *}
    4.12  
    4.13  end
    4.14 -
     5.1 --- a/src/HOL/BNF_Examples/Compat.thy	Mon Sep 01 16:17:46 2014 +0200
     5.2 +++ b/src/HOL/BNF_Examples/Compat.thy	Mon Sep 01 16:17:46 2014 +0200
     5.3 @@ -80,6 +80,6 @@
     5.4  datatype_new tree = Tree "tree foo"
     5.5  datatype_compat tree
     5.6  
     5.7 -ML {* Datatype_Data.get_info @{theory} @{type_name tree} *}
     5.8 +ML {* Old_Datatype_Data.get_info @{theory} @{type_name tree} *}
     5.9  
    5.10  end
     6.1 --- a/src/HOL/BNF_FP_Base.thy	Mon Sep 01 16:17:46 2014 +0200
     6.2 +++ b/src/HOL/BNF_FP_Base.thy	Mon Sep 01 16:17:46 2014 +0200
     6.3 @@ -205,8 +205,8 @@
     6.4  ML_file "Tools/BNF/bnf_fp_n2m.ML"
     6.5  ML_file "Tools/BNF/bnf_fp_n2m_sugar.ML"
     6.6  
     6.7 -ML_file "Tools/Function/size.ML"
     6.8 -setup Size.setup
     6.9 +ML_file "Tools/Function/old_size.ML"
    6.10 +setup Old_Size.setup
    6.11  
    6.12  lemma size_bool[code]: "size (b\<Colon>bool) = 0"
    6.13    by (cases b) auto
     7.1 --- a/src/HOL/Datatype.thy	Mon Sep 01 16:17:46 2014 +0200
     7.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.3 @@ -1,524 +0,0 @@
     7.4 -(*  Title:      HOL/Datatype.thy
     7.5 -    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     7.6 -    Author:     Stefan Berghofer and Markus Wenzel, TU Muenchen
     7.7 -*)
     7.8 -
     7.9 -header {* Datatype package: constructing datatypes from Cartesian Products and Disjoint Sums *}
    7.10 -
    7.11 -theory Datatype
    7.12 -imports Product_Type Sum_Type Nat
    7.13 -keywords "datatype" :: thy_decl
    7.14 -begin
    7.15 -
    7.16 -subsection {* The datatype universe *}
    7.17 -
    7.18 -definition "Node = {p. EX f x k. p = (f :: nat => 'b + nat, x ::'a + nat) & f k = Inr 0}"
    7.19 -
    7.20 -typedef ('a, 'b) node = "Node :: ((nat => 'b + nat) * ('a + nat)) set"
    7.21 -  morphisms Rep_Node Abs_Node
    7.22 -  unfolding Node_def by auto
    7.23 -
    7.24 -text{*Datatypes will be represented by sets of type @{text node}*}
    7.25 -
    7.26 -type_synonym 'a item        = "('a, unit) node set"
    7.27 -type_synonym ('a, 'b) dtree = "('a, 'b) node set"
    7.28 -
    7.29 -consts
    7.30 -  Push      :: "[('b + nat), nat => ('b + nat)] => (nat => ('b + nat))"
    7.31 -
    7.32 -  Push_Node :: "[('b + nat), ('a, 'b) node] => ('a, 'b) node"
    7.33 -  ndepth    :: "('a, 'b) node => nat"
    7.34 -
    7.35 -  Atom      :: "('a + nat) => ('a, 'b) dtree"
    7.36 -  Leaf      :: "'a => ('a, 'b) dtree"
    7.37 -  Numb      :: "nat => ('a, 'b) dtree"
    7.38 -  Scons     :: "[('a, 'b) dtree, ('a, 'b) dtree] => ('a, 'b) dtree"
    7.39 -  In0       :: "('a, 'b) dtree => ('a, 'b) dtree"
    7.40 -  In1       :: "('a, 'b) dtree => ('a, 'b) dtree"
    7.41 -  Lim       :: "('b => ('a, 'b) dtree) => ('a, 'b) dtree"
    7.42 -
    7.43 -  ntrunc    :: "[nat, ('a, 'b) dtree] => ('a, 'b) dtree"
    7.44 -
    7.45 -  uprod     :: "[('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set"
    7.46 -  usum      :: "[('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set"
    7.47 -
    7.48 -  Split     :: "[[('a, 'b) dtree, ('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c"
    7.49 -  Case      :: "[[('a, 'b) dtree]=>'c, [('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c"
    7.50 -
    7.51 -  dprod     :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set]
    7.52 -                => (('a, 'b) dtree * ('a, 'b) dtree)set"
    7.53 -  dsum      :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set]
    7.54 -                => (('a, 'b) dtree * ('a, 'b) dtree)set"
    7.55 -
    7.56 -
    7.57 -defs
    7.58 -
    7.59 -  Push_Node_def:  "Push_Node == (%n x. Abs_Node (apfst (Push n) (Rep_Node x)))"
    7.60 -
    7.61 -  (*crude "lists" of nats -- needed for the constructions*)
    7.62 -  Push_def:   "Push == (%b h. case_nat b h)"
    7.63 -
    7.64 -  (** operations on S-expressions -- sets of nodes **)
    7.65 -
    7.66 -  (*S-expression constructors*)
    7.67 -  Atom_def:   "Atom == (%x. {Abs_Node((%k. Inr 0, x))})"
    7.68 -  Scons_def:  "Scons M N == (Push_Node (Inr 1) ` M) Un (Push_Node (Inr (Suc 1)) ` N)"
    7.69 -
    7.70 -  (*Leaf nodes, with arbitrary or nat labels*)
    7.71 -  Leaf_def:   "Leaf == Atom o Inl"
    7.72 -  Numb_def:   "Numb == Atom o Inr"
    7.73 -
    7.74 -  (*Injections of the "disjoint sum"*)
    7.75 -  In0_def:    "In0(M) == Scons (Numb 0) M"
    7.76 -  In1_def:    "In1(M) == Scons (Numb 1) M"
    7.77 -
    7.78 -  (*Function spaces*)
    7.79 -  Lim_def: "Lim f == Union {z. ? x. z = Push_Node (Inl x) ` (f x)}"
    7.80 -
    7.81 -  (*the set of nodes with depth less than k*)
    7.82 -  ndepth_def: "ndepth(n) == (%(f,x). LEAST k. f k = Inr 0) (Rep_Node n)"
    7.83 -  ntrunc_def: "ntrunc k N == {n. n:N & ndepth(n)<k}"
    7.84 -
    7.85 -  (*products and sums for the "universe"*)
    7.86 -  uprod_def:  "uprod A B == UN x:A. UN y:B. { Scons x y }"
    7.87 -  usum_def:   "usum A B == In0`A Un In1`B"
    7.88 -
    7.89 -  (*the corresponding eliminators*)
    7.90 -  Split_def:  "Split c M == THE u. EX x y. M = Scons x y & u = c x y"
    7.91 -
    7.92 -  Case_def:   "Case c d M == THE u.  (EX x . M = In0(x) & u = c(x))
    7.93 -                                  | (EX y . M = In1(y) & u = d(y))"
    7.94 -
    7.95 -
    7.96 -  (** equality for the "universe" **)
    7.97 -
    7.98 -  dprod_def:  "dprod r s == UN (x,x'):r. UN (y,y'):s. {(Scons x y, Scons x' y')}"
    7.99 -
   7.100 -  dsum_def:   "dsum r s == (UN (x,x'):r. {(In0(x),In0(x'))}) Un
   7.101 -                          (UN (y,y'):s. {(In1(y),In1(y'))})"
   7.102 -
   7.103 -
   7.104 -
   7.105 -lemma apfst_convE: 
   7.106 -    "[| q = apfst f p;  !!x y. [| p = (x,y);  q = (f(x),y) |] ==> R  
   7.107 -     |] ==> R"
   7.108 -by (force simp add: apfst_def)
   7.109 -
   7.110 -(** Push -- an injection, analogous to Cons on lists **)
   7.111 -
   7.112 -lemma Push_inject1: "Push i f = Push j g  ==> i=j"
   7.113 -apply (simp add: Push_def fun_eq_iff) 
   7.114 -apply (drule_tac x=0 in spec, simp) 
   7.115 -done
   7.116 -
   7.117 -lemma Push_inject2: "Push i f = Push j g  ==> f=g"
   7.118 -apply (auto simp add: Push_def fun_eq_iff) 
   7.119 -apply (drule_tac x="Suc x" in spec, simp) 
   7.120 -done
   7.121 -
   7.122 -lemma Push_inject:
   7.123 -    "[| Push i f =Push j g;  [| i=j;  f=g |] ==> P |] ==> P"
   7.124 -by (blast dest: Push_inject1 Push_inject2) 
   7.125 -
   7.126 -lemma Push_neq_K0: "Push (Inr (Suc k)) f = (%z. Inr 0) ==> P"
   7.127 -by (auto simp add: Push_def fun_eq_iff split: nat.split_asm)
   7.128 -
   7.129 -lemmas Abs_Node_inj = Abs_Node_inject [THEN [2] rev_iffD1]
   7.130 -
   7.131 -
   7.132 -(*** Introduction rules for Node ***)
   7.133 -
   7.134 -lemma Node_K0_I: "(%k. Inr 0, a) : Node"
   7.135 -by (simp add: Node_def)
   7.136 -
   7.137 -lemma Node_Push_I: "p: Node ==> apfst (Push i) p : Node"
   7.138 -apply (simp add: Node_def Push_def) 
   7.139 -apply (fast intro!: apfst_conv nat.case(2)[THEN trans])
   7.140 -done
   7.141 -
   7.142 -
   7.143 -subsection{*Freeness: Distinctness of Constructors*}
   7.144 -
   7.145 -(** Scons vs Atom **)
   7.146 -
   7.147 -lemma Scons_not_Atom [iff]: "Scons M N \<noteq> Atom(a)"
   7.148 -unfolding Atom_def Scons_def Push_Node_def One_nat_def
   7.149 -by (blast intro: Node_K0_I Rep_Node [THEN Node_Push_I] 
   7.150 -         dest!: Abs_Node_inj 
   7.151 -         elim!: apfst_convE sym [THEN Push_neq_K0])  
   7.152 -
   7.153 -lemmas Atom_not_Scons [iff] = Scons_not_Atom [THEN not_sym]
   7.154 -
   7.155 -
   7.156 -(*** Injectiveness ***)
   7.157 -
   7.158 -(** Atomic nodes **)
   7.159 -
   7.160 -lemma inj_Atom: "inj(Atom)"
   7.161 -apply (simp add: Atom_def)
   7.162 -apply (blast intro!: inj_onI Node_K0_I dest!: Abs_Node_inj)
   7.163 -done
   7.164 -lemmas Atom_inject = inj_Atom [THEN injD]
   7.165 -
   7.166 -lemma Atom_Atom_eq [iff]: "(Atom(a)=Atom(b)) = (a=b)"
   7.167 -by (blast dest!: Atom_inject)
   7.168 -
   7.169 -lemma inj_Leaf: "inj(Leaf)"
   7.170 -apply (simp add: Leaf_def o_def)
   7.171 -apply (rule inj_onI)
   7.172 -apply (erule Atom_inject [THEN Inl_inject])
   7.173 -done
   7.174 -
   7.175 -lemmas Leaf_inject [dest!] = inj_Leaf [THEN injD]
   7.176 -
   7.177 -lemma inj_Numb: "inj(Numb)"
   7.178 -apply (simp add: Numb_def o_def)
   7.179 -apply (rule inj_onI)
   7.180 -apply (erule Atom_inject [THEN Inr_inject])
   7.181 -done
   7.182 -
   7.183 -lemmas Numb_inject [dest!] = inj_Numb [THEN injD]
   7.184 -
   7.185 -
   7.186 -(** Injectiveness of Push_Node **)
   7.187 -
   7.188 -lemma Push_Node_inject:
   7.189 -    "[| Push_Node i m =Push_Node j n;  [| i=j;  m=n |] ==> P  
   7.190 -     |] ==> P"
   7.191 -apply (simp add: Push_Node_def)
   7.192 -apply (erule Abs_Node_inj [THEN apfst_convE])
   7.193 -apply (rule Rep_Node [THEN Node_Push_I])+
   7.194 -apply (erule sym [THEN apfst_convE]) 
   7.195 -apply (blast intro: Rep_Node_inject [THEN iffD1] trans sym elim!: Push_inject)
   7.196 -done
   7.197 -
   7.198 -
   7.199 -(** Injectiveness of Scons **)
   7.200 -
   7.201 -lemma Scons_inject_lemma1: "Scons M N <= Scons M' N' ==> M<=M'"
   7.202 -unfolding Scons_def One_nat_def
   7.203 -by (blast dest!: Push_Node_inject)
   7.204 -
   7.205 -lemma Scons_inject_lemma2: "Scons M N <= Scons M' N' ==> N<=N'"
   7.206 -unfolding Scons_def One_nat_def
   7.207 -by (blast dest!: Push_Node_inject)
   7.208 -
   7.209 -lemma Scons_inject1: "Scons M N = Scons M' N' ==> M=M'"
   7.210 -apply (erule equalityE)
   7.211 -apply (iprover intro: equalityI Scons_inject_lemma1)
   7.212 -done
   7.213 -
   7.214 -lemma Scons_inject2: "Scons M N = Scons M' N' ==> N=N'"
   7.215 -apply (erule equalityE)
   7.216 -apply (iprover intro: equalityI Scons_inject_lemma2)
   7.217 -done
   7.218 -
   7.219 -lemma Scons_inject:
   7.220 -    "[| Scons M N = Scons M' N';  [| M=M';  N=N' |] ==> P |] ==> P"
   7.221 -by (iprover dest: Scons_inject1 Scons_inject2)
   7.222 -
   7.223 -lemma Scons_Scons_eq [iff]: "(Scons M N = Scons M' N') = (M=M' & N=N')"
   7.224 -by (blast elim!: Scons_inject)
   7.225 -
   7.226 -(*** Distinctness involving Leaf and Numb ***)
   7.227 -
   7.228 -(** Scons vs Leaf **)
   7.229 -
   7.230 -lemma Scons_not_Leaf [iff]: "Scons M N \<noteq> Leaf(a)"
   7.231 -unfolding Leaf_def o_def by (rule Scons_not_Atom)
   7.232 -
   7.233 -lemmas Leaf_not_Scons  [iff] = Scons_not_Leaf [THEN not_sym]
   7.234 -
   7.235 -(** Scons vs Numb **)
   7.236 -
   7.237 -lemma Scons_not_Numb [iff]: "Scons M N \<noteq> Numb(k)"
   7.238 -unfolding Numb_def o_def by (rule Scons_not_Atom)
   7.239 -
   7.240 -lemmas Numb_not_Scons [iff] = Scons_not_Numb [THEN not_sym]
   7.241 -
   7.242 -
   7.243 -(** Leaf vs Numb **)
   7.244 -
   7.245 -lemma Leaf_not_Numb [iff]: "Leaf(a) \<noteq> Numb(k)"
   7.246 -by (simp add: Leaf_def Numb_def)
   7.247 -
   7.248 -lemmas Numb_not_Leaf [iff] = Leaf_not_Numb [THEN not_sym]
   7.249 -
   7.250 -
   7.251 -(*** ndepth -- the depth of a node ***)
   7.252 -
   7.253 -lemma ndepth_K0: "ndepth (Abs_Node(%k. Inr 0, x)) = 0"
   7.254 -by (simp add: ndepth_def  Node_K0_I [THEN Abs_Node_inverse] Least_equality)
   7.255 -
   7.256 -lemma ndepth_Push_Node_aux:
   7.257 -     "case_nat (Inr (Suc i)) f k = Inr 0 --> Suc(LEAST x. f x = Inr 0) <= k"
   7.258 -apply (induct_tac "k", auto)
   7.259 -apply (erule Least_le)
   7.260 -done
   7.261 -
   7.262 -lemma ndepth_Push_Node: 
   7.263 -    "ndepth (Push_Node (Inr (Suc i)) n) = Suc(ndepth(n))"
   7.264 -apply (insert Rep_Node [of n, unfolded Node_def])
   7.265 -apply (auto simp add: ndepth_def Push_Node_def
   7.266 -                 Rep_Node [THEN Node_Push_I, THEN Abs_Node_inverse])
   7.267 -apply (rule Least_equality)
   7.268 -apply (auto simp add: Push_def ndepth_Push_Node_aux)
   7.269 -apply (erule LeastI)
   7.270 -done
   7.271 -
   7.272 -
   7.273 -(*** ntrunc applied to the various node sets ***)
   7.274 -
   7.275 -lemma ntrunc_0 [simp]: "ntrunc 0 M = {}"
   7.276 -by (simp add: ntrunc_def)
   7.277 -
   7.278 -lemma ntrunc_Atom [simp]: "ntrunc (Suc k) (Atom a) = Atom(a)"
   7.279 -by (auto simp add: Atom_def ntrunc_def ndepth_K0)
   7.280 -
   7.281 -lemma ntrunc_Leaf [simp]: "ntrunc (Suc k) (Leaf a) = Leaf(a)"
   7.282 -unfolding Leaf_def o_def by (rule ntrunc_Atom)
   7.283 -
   7.284 -lemma ntrunc_Numb [simp]: "ntrunc (Suc k) (Numb i) = Numb(i)"
   7.285 -unfolding Numb_def o_def by (rule ntrunc_Atom)
   7.286 -
   7.287 -lemma ntrunc_Scons [simp]: 
   7.288 -    "ntrunc (Suc k) (Scons M N) = Scons (ntrunc k M) (ntrunc k N)"
   7.289 -unfolding Scons_def ntrunc_def One_nat_def
   7.290 -by (auto simp add: ndepth_Push_Node)
   7.291 -
   7.292 -
   7.293 -
   7.294 -(** Injection nodes **)
   7.295 -
   7.296 -lemma ntrunc_one_In0 [simp]: "ntrunc (Suc 0) (In0 M) = {}"
   7.297 -apply (simp add: In0_def)
   7.298 -apply (simp add: Scons_def)
   7.299 -done
   7.300 -
   7.301 -lemma ntrunc_In0 [simp]: "ntrunc (Suc(Suc k)) (In0 M) = In0 (ntrunc (Suc k) M)"
   7.302 -by (simp add: In0_def)
   7.303 -
   7.304 -lemma ntrunc_one_In1 [simp]: "ntrunc (Suc 0) (In1 M) = {}"
   7.305 -apply (simp add: In1_def)
   7.306 -apply (simp add: Scons_def)
   7.307 -done
   7.308 -
   7.309 -lemma ntrunc_In1 [simp]: "ntrunc (Suc(Suc k)) (In1 M) = In1 (ntrunc (Suc k) M)"
   7.310 -by (simp add: In1_def)
   7.311 -
   7.312 -
   7.313 -subsection{*Set Constructions*}
   7.314 -
   7.315 -
   7.316 -(*** Cartesian Product ***)
   7.317 -
   7.318 -lemma uprodI [intro!]: "[| M:A;  N:B |] ==> Scons M N : uprod A B"
   7.319 -by (simp add: uprod_def)
   7.320 -
   7.321 -(*The general elimination rule*)
   7.322 -lemma uprodE [elim!]:
   7.323 -    "[| c : uprod A B;   
   7.324 -        !!x y. [| x:A;  y:B;  c = Scons x y |] ==> P  
   7.325 -     |] ==> P"
   7.326 -by (auto simp add: uprod_def) 
   7.327 -
   7.328 -
   7.329 -(*Elimination of a pair -- introduces no eigenvariables*)
   7.330 -lemma uprodE2: "[| Scons M N : uprod A B;  [| M:A;  N:B |] ==> P |] ==> P"
   7.331 -by (auto simp add: uprod_def)
   7.332 -
   7.333 -
   7.334 -(*** Disjoint Sum ***)
   7.335 -
   7.336 -lemma usum_In0I [intro]: "M:A ==> In0(M) : usum A B"
   7.337 -by (simp add: usum_def)
   7.338 -
   7.339 -lemma usum_In1I [intro]: "N:B ==> In1(N) : usum A B"
   7.340 -by (simp add: usum_def)
   7.341 -
   7.342 -lemma usumE [elim!]: 
   7.343 -    "[| u : usum A B;   
   7.344 -        !!x. [| x:A;  u=In0(x) |] ==> P;  
   7.345 -        !!y. [| y:B;  u=In1(y) |] ==> P  
   7.346 -     |] ==> P"
   7.347 -by (auto simp add: usum_def)
   7.348 -
   7.349 -
   7.350 -(** Injection **)
   7.351 -
   7.352 -lemma In0_not_In1 [iff]: "In0(M) \<noteq> In1(N)"
   7.353 -unfolding In0_def In1_def One_nat_def by auto
   7.354 -
   7.355 -lemmas In1_not_In0 [iff] = In0_not_In1 [THEN not_sym]
   7.356 -
   7.357 -lemma In0_inject: "In0(M) = In0(N) ==>  M=N"
   7.358 -by (simp add: In0_def)
   7.359 -
   7.360 -lemma In1_inject: "In1(M) = In1(N) ==>  M=N"
   7.361 -by (simp add: In1_def)
   7.362 -
   7.363 -lemma In0_eq [iff]: "(In0 M = In0 N) = (M=N)"
   7.364 -by (blast dest!: In0_inject)
   7.365 -
   7.366 -lemma In1_eq [iff]: "(In1 M = In1 N) = (M=N)"
   7.367 -by (blast dest!: In1_inject)
   7.368 -
   7.369 -lemma inj_In0: "inj In0"
   7.370 -by (blast intro!: inj_onI)
   7.371 -
   7.372 -lemma inj_In1: "inj In1"
   7.373 -by (blast intro!: inj_onI)
   7.374 -
   7.375 -
   7.376 -(*** Function spaces ***)
   7.377 -
   7.378 -lemma Lim_inject: "Lim f = Lim g ==> f = g"
   7.379 -apply (simp add: Lim_def)
   7.380 -apply (rule ext)
   7.381 -apply (blast elim!: Push_Node_inject)
   7.382 -done
   7.383 -
   7.384 -
   7.385 -(*** proving equality of sets and functions using ntrunc ***)
   7.386 -
   7.387 -lemma ntrunc_subsetI: "ntrunc k M <= M"
   7.388 -by (auto simp add: ntrunc_def)
   7.389 -
   7.390 -lemma ntrunc_subsetD: "(!!k. ntrunc k M <= N) ==> M<=N"
   7.391 -by (auto simp add: ntrunc_def)
   7.392 -
   7.393 -(*A generalized form of the take-lemma*)
   7.394 -lemma ntrunc_equality: "(!!k. ntrunc k M = ntrunc k N) ==> M=N"
   7.395 -apply (rule equalityI)
   7.396 -apply (rule_tac [!] ntrunc_subsetD)
   7.397 -apply (rule_tac [!] ntrunc_subsetI [THEN [2] subset_trans], auto) 
   7.398 -done
   7.399 -
   7.400 -lemma ntrunc_o_equality: 
   7.401 -    "[| !!k. (ntrunc(k) o h1) = (ntrunc(k) o h2) |] ==> h1=h2"
   7.402 -apply (rule ntrunc_equality [THEN ext])
   7.403 -apply (simp add: fun_eq_iff) 
   7.404 -done
   7.405 -
   7.406 -
   7.407 -(*** Monotonicity ***)
   7.408 -
   7.409 -lemma uprod_mono: "[| A<=A';  B<=B' |] ==> uprod A B <= uprod A' B'"
   7.410 -by (simp add: uprod_def, blast)
   7.411 -
   7.412 -lemma usum_mono: "[| A<=A';  B<=B' |] ==> usum A B <= usum A' B'"
   7.413 -by (simp add: usum_def, blast)
   7.414 -
   7.415 -lemma Scons_mono: "[| M<=M';  N<=N' |] ==> Scons M N <= Scons M' N'"
   7.416 -by (simp add: Scons_def, blast)
   7.417 -
   7.418 -lemma In0_mono: "M<=N ==> In0(M) <= In0(N)"
   7.419 -by (simp add: In0_def Scons_mono)
   7.420 -
   7.421 -lemma In1_mono: "M<=N ==> In1(M) <= In1(N)"
   7.422 -by (simp add: In1_def Scons_mono)
   7.423 -
   7.424 -
   7.425 -(*** Split and Case ***)
   7.426 -
   7.427 -lemma Split [simp]: "Split c (Scons M N) = c M N"
   7.428 -by (simp add: Split_def)
   7.429 -
   7.430 -lemma Case_In0 [simp]: "Case c d (In0 M) = c(M)"
   7.431 -by (simp add: Case_def)
   7.432 -
   7.433 -lemma Case_In1 [simp]: "Case c d (In1 N) = d(N)"
   7.434 -by (simp add: Case_def)
   7.435 -
   7.436 -
   7.437 -
   7.438 -(**** UN x. B(x) rules ****)
   7.439 -
   7.440 -lemma ntrunc_UN1: "ntrunc k (UN x. f(x)) = (UN x. ntrunc k (f x))"
   7.441 -by (simp add: ntrunc_def, blast)
   7.442 -
   7.443 -lemma Scons_UN1_x: "Scons (UN x. f x) M = (UN x. Scons (f x) M)"
   7.444 -by (simp add: Scons_def, blast)
   7.445 -
   7.446 -lemma Scons_UN1_y: "Scons M (UN x. f x) = (UN x. Scons M (f x))"
   7.447 -by (simp add: Scons_def, blast)
   7.448 -
   7.449 -lemma In0_UN1: "In0(UN x. f(x)) = (UN x. In0(f(x)))"
   7.450 -by (simp add: In0_def Scons_UN1_y)
   7.451 -
   7.452 -lemma In1_UN1: "In1(UN x. f(x)) = (UN x. In1(f(x)))"
   7.453 -by (simp add: In1_def Scons_UN1_y)
   7.454 -
   7.455 -
   7.456 -(*** Equality for Cartesian Product ***)
   7.457 -
   7.458 -lemma dprodI [intro!]: 
   7.459 -    "[| (M,M'):r;  (N,N'):s |] ==> (Scons M N, Scons M' N') : dprod r s"
   7.460 -by (auto simp add: dprod_def)
   7.461 -
   7.462 -(*The general elimination rule*)
   7.463 -lemma dprodE [elim!]: 
   7.464 -    "[| c : dprod r s;   
   7.465 -        !!x y x' y'. [| (x,x') : r;  (y,y') : s;  
   7.466 -                        c = (Scons x y, Scons x' y') |] ==> P  
   7.467 -     |] ==> P"
   7.468 -by (auto simp add: dprod_def)
   7.469 -
   7.470 -
   7.471 -(*** Equality for Disjoint Sum ***)
   7.472 -
   7.473 -lemma dsum_In0I [intro]: "(M,M'):r ==> (In0(M), In0(M')) : dsum r s"
   7.474 -by (auto simp add: dsum_def)
   7.475 -
   7.476 -lemma dsum_In1I [intro]: "(N,N'):s ==> (In1(N), In1(N')) : dsum r s"
   7.477 -by (auto simp add: dsum_def)
   7.478 -
   7.479 -lemma dsumE [elim!]: 
   7.480 -    "[| w : dsum r s;   
   7.481 -        !!x x'. [| (x,x') : r;  w = (In0(x), In0(x')) |] ==> P;  
   7.482 -        !!y y'. [| (y,y') : s;  w = (In1(y), In1(y')) |] ==> P  
   7.483 -     |] ==> P"
   7.484 -by (auto simp add: dsum_def)
   7.485 -
   7.486 -
   7.487 -(*** Monotonicity ***)
   7.488 -
   7.489 -lemma dprod_mono: "[| r<=r';  s<=s' |] ==> dprod r s <= dprod r' s'"
   7.490 -by blast
   7.491 -
   7.492 -lemma dsum_mono: "[| r<=r';  s<=s' |] ==> dsum r s <= dsum r' s'"
   7.493 -by blast
   7.494 -
   7.495 -
   7.496 -(*** Bounding theorems ***)
   7.497 -
   7.498 -lemma dprod_Sigma: "(dprod (A <*> B) (C <*> D)) <= (uprod A C) <*> (uprod B D)"
   7.499 -by blast
   7.500 -
   7.501 -lemmas dprod_subset_Sigma = subset_trans [OF dprod_mono dprod_Sigma]
   7.502 -
   7.503 -(*Dependent version*)
   7.504 -lemma dprod_subset_Sigma2:
   7.505 -     "(dprod (Sigma A B) (Sigma C D)) <=
   7.506 -      Sigma (uprod A C) (Split (%x y. uprod (B x) (D y)))"
   7.507 -by auto
   7.508 -
   7.509 -lemma dsum_Sigma: "(dsum (A <*> B) (C <*> D)) <= (usum A C) <*> (usum B D)"
   7.510 -by blast
   7.511 -
   7.512 -lemmas dsum_subset_Sigma = subset_trans [OF dsum_mono dsum_Sigma]
   7.513 -
   7.514 -
   7.515 -text {* hides popular names *}
   7.516 -hide_type (open) node item
   7.517 -hide_const (open) Push Node Atom Leaf Numb Lim Split Case
   7.518 -
   7.519 -ML_file "Tools/Datatype/datatype.ML"
   7.520 -
   7.521 -ML_file "Tools/inductive_realizer.ML"
   7.522 -setup InductiveRealizer.setup
   7.523 -
   7.524 -ML_file "Tools/Datatype/datatype_realizer.ML"
   7.525 -setup Datatype_Realizer.setup
   7.526 -
   7.527 -end
     8.1 --- a/src/HOL/Extraction.thy	Mon Sep 01 16:17:46 2014 +0200
     8.2 +++ b/src/HOL/Extraction.thy	Mon Sep 01 16:17:46 2014 +0200
     8.3 @@ -5,7 +5,7 @@
     8.4  header {* Program extraction for HOL *}
     8.5  
     8.6  theory Extraction
     8.7 -imports Datatype Option
     8.8 +imports Option
     8.9  begin
    8.10  
    8.11  ML_file "Tools/rewrite_hol_proof.ML"
     9.1 --- a/src/HOL/HOLCF/Tools/Domain/domain_constructors.ML	Mon Sep 01 16:17:46 2014 +0200
     9.2 +++ b/src/HOL/HOLCF/Tools/Domain/domain_constructors.ML	Mon Sep 01 16:17:46 2014 +0200
     9.3 @@ -113,7 +113,7 @@
     9.4      : (term list * term list) =
     9.5    let
     9.6      val Ts = map snd args
     9.7 -    val ns = Name.variant_list taken (Datatype_Prop.make_tnames Ts)
     9.8 +    val ns = Name.variant_list taken (Old_Datatype_Prop.make_tnames Ts)
     9.9      val vs = map Free (ns ~~ Ts)
    9.10      val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs))
    9.11    in
    9.12 @@ -167,7 +167,7 @@
    9.13      fun vars_of args =
    9.14        let
    9.15          val Ts = map snd args
    9.16 -        val ns = Datatype_Prop.make_tnames Ts
    9.17 +        val ns = Old_Datatype_Prop.make_tnames Ts
    9.18        in
    9.19          map Free (ns ~~ Ts)
    9.20        end
    9.21 @@ -409,7 +409,7 @@
    9.22      val tns = map fst (Term.add_tfreesT lhsT [])
    9.23      val resultT = TFree (singleton (Name.variant_list tns) "'t", @{sort pcpo})
    9.24      fun fTs T = map (fn (_, args) => map snd args -->> T) spec
    9.25 -    val fns = Datatype_Prop.indexify_names (map (K "f") spec)
    9.26 +    val fns = Old_Datatype_Prop.indexify_names (map (K "f") spec)
    9.27      val fs = map Free (fns ~~ fTs resultT)
    9.28      fun caseT T = fTs T -->> (lhsT ->> T)
    9.29  
    9.30 @@ -424,7 +424,7 @@
    9.31        fun one_con f (_, args) =
    9.32          let
    9.33            val Ts = map snd args
    9.34 -          val ns = Name.variant_list fns (Datatype_Prop.make_tnames Ts)
    9.35 +          val ns = Name.variant_list fns (Old_Datatype_Prop.make_tnames Ts)
    9.36            val vs = map Free (ns ~~ Ts)
    9.37          in
    9.38            lambda_args (map fst args ~~ vs) (list_ccomb (f, vs))
    9.39 @@ -606,7 +606,7 @@
    9.40          fun sel_apps_of (i, (con, args: (bool * term option * typ) list)) =
    9.41            let
    9.42              val Ts : typ list = map #3 args
    9.43 -            val ns : string list = Datatype_Prop.make_tnames Ts
    9.44 +            val ns : string list = Old_Datatype_Prop.make_tnames Ts
    9.45              val vs : term list = map Free (ns ~~ Ts)
    9.46              val con_app : term = list_ccomb (con, vs)
    9.47              val vs' : (bool * term) list = map #1 args ~~ vs
    10.1 --- a/src/HOL/HOLCF/Tools/Domain/domain_induction.ML	Mon Sep 01 16:17:46 2014 +0200
    10.2 +++ b/src/HOL/HOLCF/Tools/Domain/domain_induction.ML	Mon Sep 01 16:17:46 2014 +0200
    10.3 @@ -63,7 +63,7 @@
    10.4        fun prove_take_app (con_const, args) =
    10.5          let
    10.6            val Ts = map snd args
    10.7 -          val ns = Name.variant_list ["n"] (Datatype_Prop.make_tnames Ts)
    10.8 +          val ns = Name.variant_list ["n"] (Old_Datatype_Prop.make_tnames Ts)
    10.9            val vs = map Free (ns ~~ Ts)
   10.10            val lhs = mk_capply (take_const $ n', list_ccomb (con_const, vs))
   10.11            val rhs = list_ccomb (con_const, map2 (map_of_arg thy) vs Ts)
   10.12 @@ -108,8 +108,8 @@
   10.13    val {take_consts, take_induct_thms, ...} = take_info
   10.14  
   10.15    val newTs = map #absT iso_infos
   10.16 -  val P_names = Datatype_Prop.indexify_names (map (K "P") newTs)
   10.17 -  val x_names = Datatype_Prop.indexify_names (map (K "x") newTs)
   10.18 +  val P_names = Old_Datatype_Prop.indexify_names (map (K "P") newTs)
   10.19 +  val x_names = Old_Datatype_Prop.indexify_names (map (K "x") newTs)
   10.20    val P_types = map (fn T => T --> HOLogic.boolT) newTs
   10.21    val Ps = map Free (P_names ~~ P_types)
   10.22    val xs = map Free (x_names ~~ newTs)
   10.23 @@ -118,7 +118,7 @@
   10.24    fun con_assm defined p (con, args) =
   10.25      let
   10.26        val Ts = map snd args
   10.27 -      val ns = Name.variant_list P_names (Datatype_Prop.make_tnames Ts)
   10.28 +      val ns = Name.variant_list P_names (Old_Datatype_Prop.make_tnames Ts)
   10.29        val vs = map Free (ns ~~ Ts)
   10.30        val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs))
   10.31        fun ind_hyp (v, T) t =
   10.32 @@ -255,7 +255,7 @@
   10.33  
   10.34    val {take_consts, take_0_thms, take_lemma_thms, ...} = take_info
   10.35  
   10.36 -  val R_names = Datatype_Prop.indexify_names (map (K "R") newTs)
   10.37 +  val R_names = Old_Datatype_Prop.indexify_names (map (K "R") newTs)
   10.38    val R_types = map (fn T => T --> T --> boolT) newTs
   10.39    val Rs = map Free (R_names ~~ R_types)
   10.40    val n = Free ("n", natT)
   10.41 @@ -272,7 +272,7 @@
   10.42      fun one_con T (con, args) =
   10.43        let
   10.44          val Ts = map snd args
   10.45 -        val ns1 = Name.variant_list reserved (Datatype_Prop.make_tnames Ts)
   10.46 +        val ns1 = Name.variant_list reserved (Old_Datatype_Prop.make_tnames Ts)
   10.47          val ns2 = map (fn n => n^"'") ns1
   10.48          val vs1 = map Free (ns1 ~~ Ts)
   10.49          val vs2 = map Free (ns2 ~~ Ts)
    11.1 --- a/src/HOL/HOLCF/ex/Pattern_Match.thy	Mon Sep 01 16:17:46 2014 +0200
    11.2 +++ b/src/HOL/HOLCF/ex/Pattern_Match.thy	Mon Sep 01 16:17:46 2014 +0200
    11.3 @@ -423,7 +423,7 @@
    11.4      : (term list * term list) =
    11.5    let
    11.6      val Ts = map snd args;
    11.7 -    val ns = Name.variant_list taken (Datatype_Prop.make_tnames Ts);
    11.8 +    val ns = Name.variant_list taken (Old_Datatype_Prop.make_tnames Ts);
    11.9      val vs = map Free (ns ~~ Ts);
   11.10      val nonlazy = map snd (filter_out (fst o fst) (args ~~ vs));
   11.11    in
   11.12 @@ -473,10 +473,10 @@
   11.13            val Ts = map snd args;
   11.14            val Vs =
   11.15                (map (K "'t") args)
   11.16 -              |> Datatype_Prop.indexify_names
   11.17 +              |> Old_Datatype_Prop.indexify_names
   11.18                |> Name.variant_list tns
   11.19                |> map (fn t => TFree (t, @{sort pcpo}));
   11.20 -          val patNs = Datatype_Prop.indexify_names (map (K "pat") args);
   11.21 +          val patNs = Old_Datatype_Prop.indexify_names (map (K "pat") args);
   11.22            val patTs = map2 (fn T => fn V => T ->> mk_matchT V) Ts Vs;
   11.23            val pats = map Free (patNs ~~ patTs);
   11.24            val fail = mk_fail (mk_tupleT Vs);
   11.25 @@ -539,10 +539,10 @@
   11.26            val Ts = map snd args;
   11.27            val Vs =
   11.28                (map (K "'t") args)
   11.29 -              |> Datatype_Prop.indexify_names
   11.30 +              |> Old_Datatype_Prop.indexify_names
   11.31                |> Name.variant_list (rn::tns)
   11.32                |> map (fn t => TFree (t, @{sort pcpo}));
   11.33 -          val patNs = Datatype_Prop.indexify_names (map (K "pat") args);
   11.34 +          val patNs = Old_Datatype_Prop.indexify_names (map (K "pat") args);
   11.35            val patTs = map2 (fn T => fn V => T ->> mk_matchT V) Ts Vs;
   11.36            val pats = map Free (patNs ~~ patTs);
   11.37            val k = Free ("rhs", mk_tupleT Vs ->> R);
    12.1 --- a/src/HOL/Induct/SList.thy	Mon Sep 01 16:17:46 2014 +0200
    12.2 +++ b/src/HOL/Induct/SList.thy	Mon Sep 01 16:17:46 2014 +0200
    12.3 @@ -59,8 +59,8 @@
    12.4    morphisms Rep_List Abs_List
    12.5    unfolding List_def by (blast intro: list.NIL_I)
    12.6  
    12.7 -abbreviation "Case == Datatype.Case"
    12.8 -abbreviation "Split == Datatype.Split"
    12.9 +abbreviation "Case == Old_Datatype.Case"
   12.10 +abbreviation "Split == Old_Datatype.Split"
   12.11  
   12.12  definition
   12.13    List_case :: "['b, ['a item, 'a item]=>'b, 'a item] => 'b" where
    13.1 --- a/src/HOL/Induct/Sexp.thy	Mon Sep 01 16:17:46 2014 +0200
    13.2 +++ b/src/HOL/Induct/Sexp.thy	Mon Sep 01 16:17:46 2014 +0200
    13.3 @@ -10,9 +10,9 @@
    13.4  imports Main
    13.5  begin
    13.6  
    13.7 -type_synonym 'a item = "'a Datatype.item"
    13.8 -abbreviation "Leaf == Datatype.Leaf"
    13.9 -abbreviation "Numb == Datatype.Numb"
   13.10 +type_synonym 'a item = "'a Old_Datatype.item"
   13.11 +abbreviation "Leaf == Old_Datatype.Leaf"
   13.12 +abbreviation "Numb == Old_Datatype.Numb"
   13.13  
   13.14  inductive_set
   13.15    sexp      :: "'a item set"
    14.1 --- a/src/HOL/Inductive.thy	Mon Sep 01 16:17:46 2014 +0200
    14.2 +++ b/src/HOL/Inductive.thy	Mon Sep 01 16:17:46 2014 +0200
    14.3 @@ -271,12 +271,12 @@
    14.4  
    14.5  text {* Package setup. *}
    14.6  
    14.7 -ML_file "Tools/Datatype/datatype_aux.ML"
    14.8 -ML_file "Tools/Datatype/datatype_prop.ML"
    14.9 -ML_file "Tools/Datatype/datatype_data.ML" setup Datatype_Data.setup
   14.10 -ML_file "Tools/Datatype/rep_datatype.ML"
   14.11 -ML_file "Tools/Datatype/datatype_codegen.ML"
   14.12 -ML_file "Tools/Datatype/primrec.ML"
   14.13 +ML_file "Tools/Old_Datatype/old_datatype_aux.ML"
   14.14 +ML_file "Tools/Old_Datatype/old_datatype_prop.ML"
   14.15 +ML_file "Tools/Old_Datatype/old_datatype_data.ML" setup Old_Datatype_Data.setup
   14.16 +ML_file "Tools/Old_Datatype/old_rep_datatype.ML"
   14.17 +ML_file "Tools/Old_Datatype/old_datatype_codegen.ML"
   14.18 +ML_file "Tools/Old_Datatype/old_primrec.ML"
   14.19  
   14.20  ML_file "Tools/BNF/bnf_fp_rec_sugar_util.ML"
   14.21  ML_file "Tools/BNF/bnf_lfp_rec_sugar.ML"
    15.1 --- a/src/HOL/Library/Countable.thy	Mon Sep 01 16:17:46 2014 +0200
    15.2 +++ b/src/HOL/Library/Countable.thy	Mon Sep 01 16:17:46 2014 +0200
    15.3 @@ -173,29 +173,29 @@
    15.4  
    15.5  subsection {* Automatically proving countability of datatypes *}
    15.6  
    15.7 -inductive finite_item :: "'a Datatype.item \<Rightarrow> bool" where
    15.8 +inductive finite_item :: "'a Old_Datatype.item \<Rightarrow> bool" where
    15.9    undefined: "finite_item undefined"
   15.10 -| In0: "finite_item x \<Longrightarrow> finite_item (Datatype.In0 x)"
   15.11 -| In1: "finite_item x \<Longrightarrow> finite_item (Datatype.In1 x)"
   15.12 -| Leaf: "finite_item (Datatype.Leaf a)"
   15.13 -| Scons: "\<lbrakk>finite_item x; finite_item y\<rbrakk> \<Longrightarrow> finite_item (Datatype.Scons x y)"
   15.14 +| In0: "finite_item x \<Longrightarrow> finite_item (Old_Datatype.In0 x)"
   15.15 +| In1: "finite_item x \<Longrightarrow> finite_item (Old_Datatype.In1 x)"
   15.16 +| Leaf: "finite_item (Old_Datatype.Leaf a)"
   15.17 +| Scons: "\<lbrakk>finite_item x; finite_item y\<rbrakk> \<Longrightarrow> finite_item (Old_Datatype.Scons x y)"
   15.18  
   15.19  function
   15.20 -  nth_item :: "nat \<Rightarrow> ('a::countable) Datatype.item"
   15.21 +  nth_item :: "nat \<Rightarrow> ('a::countable) Old_Datatype.item"
   15.22  where
   15.23    "nth_item 0 = undefined"
   15.24  | "nth_item (Suc n) =
   15.25    (case sum_decode n of
   15.26      Inl i \<Rightarrow>
   15.27      (case sum_decode i of
   15.28 -      Inl j \<Rightarrow> Datatype.In0 (nth_item j)
   15.29 -    | Inr j \<Rightarrow> Datatype.In1 (nth_item j))
   15.30 +      Inl j \<Rightarrow> Old_Datatype.In0 (nth_item j)
   15.31 +    | Inr j \<Rightarrow> Old_Datatype.In1 (nth_item j))
   15.32    | Inr i \<Rightarrow>
   15.33      (case sum_decode i of
   15.34 -      Inl j \<Rightarrow> Datatype.Leaf (from_nat j)
   15.35 +      Inl j \<Rightarrow> Old_Datatype.Leaf (from_nat j)
   15.36      | Inr j \<Rightarrow>
   15.37        (case prod_decode j of
   15.38 -        (a, b) \<Rightarrow> Datatype.Scons (nth_item a) (nth_item b))))"
   15.39 +        (a, b) \<Rightarrow> Old_Datatype.Scons (nth_item a) (nth_item b))))"
   15.40  by pat_completeness auto
   15.41  
   15.42  lemma le_sum_encode_Inl: "x \<le> y \<Longrightarrow> x \<le> sum_encode (Inl y)"
   15.43 @@ -218,33 +218,31 @@
   15.44  next
   15.45    case (In0 x)
   15.46    then obtain n where "nth_item n = x" by fast
   15.47 -  hence "nth_item (Suc (sum_encode (Inl (sum_encode (Inl n)))))
   15.48 -    = Datatype.In0 x" by simp
   15.49 +  hence "nth_item (Suc (sum_encode (Inl (sum_encode (Inl n))))) = Old_Datatype.In0 x" by simp
   15.50    thus ?case ..
   15.51  next
   15.52    case (In1 x)
   15.53    then obtain n where "nth_item n = x" by fast
   15.54 -  hence "nth_item (Suc (sum_encode (Inl (sum_encode (Inr n)))))
   15.55 -    = Datatype.In1 x" by simp
   15.56 +  hence "nth_item (Suc (sum_encode (Inl (sum_encode (Inr n))))) = Old_Datatype.In1 x" by simp
   15.57    thus ?case ..
   15.58  next
   15.59    case (Leaf a)
   15.60 -  have "nth_item (Suc (sum_encode (Inr (sum_encode (Inl (to_nat a))))))
   15.61 -    = Datatype.Leaf a" by simp
   15.62 +  have "nth_item (Suc (sum_encode (Inr (sum_encode (Inl (to_nat a)))))) = Old_Datatype.Leaf a"
   15.63 +    by simp
   15.64    thus ?case ..
   15.65  next
   15.66    case (Scons x y)
   15.67    then obtain i j where "nth_item i = x" and "nth_item j = y" by fast
   15.68    hence "nth_item
   15.69 -    (Suc (sum_encode (Inr (sum_encode (Inr (prod_encode (i, j)))))))
   15.70 -      = Datatype.Scons x y" by simp
   15.71 +    (Suc (sum_encode (Inr (sum_encode (Inr (prod_encode (i, j))))))) = Old_Datatype.Scons x y"
   15.72 +    by simp
   15.73    thus ?case ..
   15.74  qed
   15.75  
   15.76  theorem countable_datatype:
   15.77 -  fixes Rep :: "'b \<Rightarrow> ('a::countable) Datatype.item"
   15.78 -  fixes Abs :: "('a::countable) Datatype.item \<Rightarrow> 'b"
   15.79 -  fixes rep_set :: "('a::countable) Datatype.item \<Rightarrow> bool"
   15.80 +  fixes Rep :: "'b \<Rightarrow> ('a::countable) Old_Datatype.item"
   15.81 +  fixes Abs :: "('a::countable) Old_Datatype.item \<Rightarrow> 'b"
   15.82 +  fixes rep_set :: "('a::countable) Old_Datatype.item \<Rightarrow> bool"
   15.83    assumes type: "type_definition Rep Abs (Collect rep_set)"
   15.84    assumes finite_item: "\<And>x. rep_set x \<Longrightarrow> finite_item x"
   15.85    shows "OFCLASS('b, countable_class)"
    16.1 --- a/src/HOL/Library/Old_SMT/old_smt_normalize.ML	Mon Sep 01 16:17:46 2014 +0200
    16.2 +++ b/src/HOL/Library/Old_SMT/old_smt_normalize.ML	Mon Sep 01 16:17:46 2014 +0200
    16.3 @@ -158,7 +158,7 @@
    16.4      | @{const HOL.implies} $ _ $ _ => dest_cond_eq (Thm.dest_arg ct)
    16.5      | _ => raise CTERM ("no equation", [ct]))
    16.6  
    16.7 -  fun get_constrs thy (Type (n, _)) = these (Datatype_Data.get_constrs thy n)
    16.8 +  fun get_constrs thy (Type (n, _)) = these (Old_Datatype_Data.get_constrs thy n)
    16.9      | get_constrs _ _ = []
   16.10  
   16.11    fun is_constr thy (n, T) =
    17.1 --- a/src/HOL/Nominal/nominal_atoms.ML	Mon Sep 01 16:17:46 2014 +0200
    17.2 +++ b/src/HOL/Nominal/nominal_atoms.ML	Mon Sep 01 16:17:46 2014 +0200
    17.3 @@ -100,9 +100,10 @@
    17.4      val (_,thy1) = 
    17.5      fold_map (fn ak => fn thy => 
    17.6            let val dt = ((Binding.name ak, [], NoSyn), [(Binding.name ak, [@{typ nat}], NoSyn)])
    17.7 -              val (dt_names, thy1) = Datatype.add_datatype Datatype_Aux.default_config [dt] thy;
    17.8 +              val (dt_names, thy1) =
    17.9 +                Old_Datatype.add_datatype Old_Datatype_Aux.default_config [dt] thy;
   17.10              
   17.11 -              val injects = maps (#inject o Datatype_Data.the_info thy1) dt_names;
   17.12 +              val injects = maps (#inject o Old_Datatype_Data.the_info thy1) dt_names;
   17.13                val ak_type = Type (Sign.intern_type thy1 ak,[])
   17.14                val ak_sign = Sign.intern_const thy1 ak 
   17.15                
   17.16 @@ -190,7 +191,7 @@
   17.17          val def2 = Logic.mk_equals (cswap $ ab $ c, cswap_akname $ ab $ c)
   17.18        in
   17.19          thy' |>
   17.20 -        Primrec.add_primrec_global
   17.21 +        Old_Primrec.add_primrec_global
   17.22            [(Binding.name swap_name, SOME swapT, NoSyn)]
   17.23            [(Attrib.empty_binding, def1)] ||>
   17.24          Sign.parent_path ||>>
   17.25 @@ -224,7 +225,7 @@
   17.26                      Const (swap_name, swapT) $ x $ (prm $ xs $ a)));
   17.27        in
   17.28          thy' |>
   17.29 -        Primrec.add_primrec_global
   17.30 +        Old_Primrec.add_primrec_global
   17.31            [(Binding.name prm_name, SOME prmT, NoSyn)]
   17.32            [(Attrib.empty_binding, def1), (Attrib.empty_binding, def2)] ||>
   17.33          Sign.parent_path
    18.1 --- a/src/HOL/Nominal/nominal_datatype.ML	Mon Sep 01 16:17:46 2014 +0200
    18.2 +++ b/src/HOL/Nominal/nominal_datatype.ML	Mon Sep 01 16:17:46 2014 +0200
    18.3 @@ -6,8 +6,9 @@
    18.4  
    18.5  signature NOMINAL_DATATYPE =
    18.6  sig
    18.7 -  val nominal_datatype : Datatype_Aux.config -> Datatype.spec list -> theory -> theory
    18.8 -  val nominal_datatype_cmd : Datatype_Aux.config -> Datatype.spec_cmd list -> theory -> theory
    18.9 +  val nominal_datatype : Old_Datatype_Aux.config -> Old_Datatype.spec list -> theory -> theory
   18.10 +  val nominal_datatype_cmd : Old_Datatype_Aux.config -> Old_Datatype.spec_cmd list -> theory ->
   18.11 +    theory
   18.12    type descr
   18.13    type nominal_datatype_info
   18.14    val get_nominal_datatypes : theory -> nominal_datatype_info Symtab.table
   18.15 @@ -42,8 +43,8 @@
   18.16  (* theory data *)
   18.17  
   18.18  type descr =
   18.19 -  (int * (string * Datatype_Aux.dtyp list *
   18.20 -      (string * (Datatype_Aux.dtyp list * Datatype_Aux.dtyp) list) list)) list;
   18.21 +  (int * (string * Old_Datatype_Aux.dtyp list *
   18.22 +      (string * (Old_Datatype_Aux.dtyp list * Old_Datatype_Aux.dtyp) list) list)) list;
   18.23  
   18.24  type nominal_datatype_info =
   18.25    {index : int,
   18.26 @@ -83,7 +84,7 @@
   18.27  
   18.28  (*******************************)
   18.29  
   18.30 -val (_ $ (_ $ (_ $ (distinct_f $ _) $ _))) = hd (prems_of Datatype.distinct_lemma);
   18.31 +val (_ $ (_ $ (_ $ (distinct_f $ _) $ _))) = hd (prems_of Old_Datatype.distinct_lemma);
   18.32  
   18.33  
   18.34  (** simplification procedure for sorting permutations **)
   18.35 @@ -199,10 +200,10 @@
   18.36  
   18.37      val new_type_names' = map (fn n => n ^ "_Rep") new_type_names;
   18.38  
   18.39 -    val (full_new_type_names',thy1) = Datatype.add_datatype config dts'' thy;
   18.40 +    val (full_new_type_names',thy1) = Old_Datatype.add_datatype config dts'' thy;
   18.41  
   18.42 -    val {descr, induct, ...} = Datatype_Data.the_info thy1 (hd full_new_type_names');
   18.43 -    fun nth_dtyp i = Datatype_Aux.typ_of_dtyp descr (Datatype_Aux.DtRec i);
   18.44 +    val {descr, induct, ...} = Old_Datatype_Data.the_info thy1 (hd full_new_type_names');
   18.45 +    fun nth_dtyp i = Old_Datatype_Aux.typ_of_dtyp descr (Old_Datatype_Aux.DtRec i);
   18.46  
   18.47      val big_name = space_implode "_" new_type_names;
   18.48  
   18.49 @@ -214,8 +215,8 @@
   18.50      val perm_types = map (fn (i, _) =>
   18.51        let val T = nth_dtyp i
   18.52        in permT --> T --> T end) descr;
   18.53 -    val perm_names' = Datatype_Prop.indexify_names (map (fn (i, _) =>
   18.54 -      "perm_" ^ Datatype_Aux.name_of_typ (nth_dtyp i)) descr);
   18.55 +    val perm_names' = Old_Datatype_Prop.indexify_names (map (fn (i, _) =>
   18.56 +      "perm_" ^ Old_Datatype_Aux.name_of_typ (nth_dtyp i)) descr);
   18.57      val perm_names = replicate (length new_type_names) @{const_name Nominal.perm} @
   18.58        map (Sign.full_bname thy1) (List.drop (perm_names', length new_type_names));
   18.59      val perm_names_types = perm_names ~~ perm_types;
   18.60 @@ -225,17 +226,17 @@
   18.61        let val T = nth_dtyp i
   18.62        in map (fn (cname, dts) =>
   18.63          let
   18.64 -          val Ts = map (Datatype_Aux.typ_of_dtyp descr) dts;
   18.65 -          val names = Name.variant_list ["pi"] (Datatype_Prop.make_tnames Ts);
   18.66 +          val Ts = map (Old_Datatype_Aux.typ_of_dtyp descr) dts;
   18.67 +          val names = Name.variant_list ["pi"] (Old_Datatype_Prop.make_tnames Ts);
   18.68            val args = map Free (names ~~ Ts);
   18.69            val c = Const (cname, Ts ---> T);
   18.70            fun perm_arg (dt, x) =
   18.71              let val T = type_of x
   18.72 -            in if Datatype_Aux.is_rec_type dt then
   18.73 +            in if Old_Datatype_Aux.is_rec_type dt then
   18.74                  let val Us = binder_types T
   18.75                  in
   18.76                    fold_rev (Term.abs o pair "x") Us
   18.77 -                    (Free (nth perm_names_types' (Datatype_Aux.body_index dt)) $ pi $
   18.78 +                    (Free (nth perm_names_types' (Old_Datatype_Aux.body_index dt)) $ pi $
   18.79                        list_comb (x, map (fn (i, U) =>
   18.80                          Const (@{const_name Nominal.perm}, permT --> U --> U) $
   18.81                            (Const (@{const_name rev}, permT --> permT) $ pi) $
   18.82 @@ -253,7 +254,7 @@
   18.83        end) descr;
   18.84  
   18.85      val (perm_simps, thy2) =
   18.86 -      Primrec.add_primrec_overloaded
   18.87 +      Old_Primrec.add_primrec_overloaded
   18.88          (map (fn (s, sT) => (s, sT, false))
   18.89             (List.take (perm_names' ~~ perm_names_types, length new_type_names)))
   18.90          (map (fn s => (Binding.name s, NONE, NoSyn)) perm_names') perm_eqs thy1;
   18.91 @@ -264,12 +265,12 @@
   18.92      val _ = warning ("length descr: " ^ string_of_int (length descr));
   18.93      val _ = warning ("length new_type_names: " ^ string_of_int (length new_type_names));
   18.94  
   18.95 -    val perm_indnames = Datatype_Prop.make_tnames (map body_type perm_types);
   18.96 +    val perm_indnames = Old_Datatype_Prop.make_tnames (map body_type perm_types);
   18.97      val perm_fun_def = Simpdata.mk_eq @{thm perm_fun_def};
   18.98  
   18.99      val unfolded_perm_eq_thms =
  18.100        if length descr = length new_type_names then []
  18.101 -      else map Drule.export_without_context (List.drop (Datatype_Aux.split_conj_thm
  18.102 +      else map Drule.export_without_context (List.drop (Old_Datatype_Aux.split_conj_thm
  18.103          (Goal.prove_global_future thy2 [] []
  18.104            (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  18.105              (map (fn (c as (s, T), x) =>
  18.106 @@ -278,7 +279,7 @@
  18.107                   Const (@{const_name Nominal.perm}, T) $ pi $ Free (x, T2))
  18.108                 end)
  18.109               (perm_names_types ~~ perm_indnames))))
  18.110 -          (fn {context = ctxt, ...} => EVERY [Datatype_Aux.ind_tac induct perm_indnames 1,
  18.111 +          (fn {context = ctxt, ...} => EVERY [Old_Datatype_Aux.ind_tac induct perm_indnames 1,
  18.112              ALLGOALS (asm_full_simp_tac (ctxt addsimps [perm_fun_def]))])),
  18.113          length new_type_names));
  18.114  
  18.115 @@ -288,7 +289,7 @@
  18.116  
  18.117      val perm_empty_thms = maps (fn a =>
  18.118        let val permT = mk_permT (Type (a, []))
  18.119 -      in map Drule.export_without_context (List.take (Datatype_Aux.split_conj_thm
  18.120 +      in map Drule.export_without_context (List.take (Old_Datatype_Aux.split_conj_thm
  18.121          (Goal.prove_global_future thy2 [] []
  18.122            (augment_sort thy2 [pt_class_of thy2 a]
  18.123              (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  18.124 @@ -298,7 +299,7 @@
  18.125                     Free (x, T)))
  18.126                 (perm_names ~~
  18.127                  map body_type perm_types ~~ perm_indnames)))))
  18.128 -          (fn {context = ctxt, ...} => EVERY [Datatype_Aux.ind_tac induct perm_indnames 1,
  18.129 +          (fn {context = ctxt, ...} => EVERY [Old_Datatype_Aux.ind_tac induct perm_indnames 1,
  18.130              ALLGOALS (asm_full_simp_tac ctxt)])),
  18.131          length new_type_names))
  18.132        end)
  18.133 @@ -320,7 +321,7 @@
  18.134          val pt_inst = pt_inst_of thy2 a;
  18.135          val pt2' = pt_inst RS pt2;
  18.136          val pt2_ax = Global_Theory.get_thm thy2 (Long_Name.map_base_name (fn s => "pt_" ^ s ^ "2") a);
  18.137 -      in List.take (map Drule.export_without_context (Datatype_Aux.split_conj_thm
  18.138 +      in List.take (map Drule.export_without_context (Old_Datatype_Aux.split_conj_thm
  18.139          (Goal.prove_global_future thy2 [] []
  18.140             (augment_sort thy2 [pt_class_of thy2 a]
  18.141               (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  18.142 @@ -333,7 +334,7 @@
  18.143                      end)
  18.144                    (perm_names ~~
  18.145                     map body_type perm_types ~~ perm_indnames)))))
  18.146 -           (fn {context = ctxt, ...} => EVERY [Datatype_Aux.ind_tac induct perm_indnames 1,
  18.147 +           (fn {context = ctxt, ...} => EVERY [Old_Datatype_Aux.ind_tac induct perm_indnames 1,
  18.148                ALLGOALS (asm_full_simp_tac (ctxt addsimps [pt2', pt2_ax]))]))),
  18.149           length new_type_names)
  18.150        end) atoms;
  18.151 @@ -355,7 +356,7 @@
  18.152          val pt3' = pt_inst RS pt3;
  18.153          val pt3_rev' = at_inst RS (pt_inst RS pt3_rev);
  18.154          val pt3_ax = Global_Theory.get_thm thy2 (Long_Name.map_base_name (fn s => "pt_" ^ s ^ "3") a);
  18.155 -      in List.take (map Drule.export_without_context (Datatype_Aux.split_conj_thm
  18.156 +      in List.take (map Drule.export_without_context (Old_Datatype_Aux.split_conj_thm
  18.157          (Goal.prove_global_future thy2 [] []
  18.158            (augment_sort thy2 [pt_class_of thy2 a] (Logic.mk_implies
  18.159               (HOLogic.mk_Trueprop (Const (@{const_name Nominal.prm_eq},
  18.160 @@ -369,7 +370,7 @@
  18.161                      end)
  18.162                    (perm_names ~~
  18.163                     map body_type perm_types ~~ perm_indnames))))))
  18.164 -           (fn {context = ctxt, ...} => EVERY [Datatype_Aux.ind_tac induct perm_indnames 1,
  18.165 +           (fn {context = ctxt, ...} => EVERY [Old_Datatype_Aux.ind_tac induct perm_indnames 1,
  18.166                ALLGOALS (asm_full_simp_tac (ctxt addsimps [pt3', pt3_rev', pt3_ax]))]))),
  18.167           length new_type_names)
  18.168        end) atoms;
  18.169 @@ -406,7 +407,7 @@
  18.170                  at_inst RS (pt_inst RS pt_perm_compose_rev) RS sym]
  18.171              end))
  18.172          val sort = Sign.minimize_sort thy (Sign.certify_sort thy (cp_class :: pt_class));
  18.173 -        val thms = Datatype_Aux.split_conj_thm (Goal.prove_global_future thy [] []
  18.174 +        val thms = Old_Datatype_Aux.split_conj_thm (Goal.prove_global_future thy [] []
  18.175            (augment_sort thy sort
  18.176              (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  18.177                (map (fn ((s, T), x) =>
  18.178 @@ -421,7 +422,7 @@
  18.179                       perm2 $ (perm3 $ pi1 $ pi2) $ (perm1 $ pi1 $ Free (x, T)))
  18.180                    end)
  18.181                  (perm_names ~~ Ts ~~ perm_indnames)))))
  18.182 -          (fn {context = ctxt, ...} => EVERY [Datatype_Aux.ind_tac induct perm_indnames 1,
  18.183 +          (fn {context = ctxt, ...} => EVERY [Old_Datatype_Aux.ind_tac induct perm_indnames 1,
  18.184               ALLGOALS (asm_full_simp_tac (simps ctxt))]))
  18.185        in
  18.186          fold (fn (s, tvs) => fn thy => Axclass.prove_arity
  18.187 @@ -459,25 +460,25 @@
  18.188      val _ = warning "representing sets";
  18.189  
  18.190      val rep_set_names =
  18.191 -      Datatype_Prop.indexify_names
  18.192 -        (map (fn (i, _) => Datatype_Aux.name_of_typ (nth_dtyp i) ^ "_set") descr);
  18.193 +      Old_Datatype_Prop.indexify_names
  18.194 +        (map (fn (i, _) => Old_Datatype_Aux.name_of_typ (nth_dtyp i) ^ "_set") descr);
  18.195      val big_rep_name =
  18.196 -      space_implode "_" (Datatype_Prop.indexify_names (map_filter
  18.197 +      space_implode "_" (Old_Datatype_Prop.indexify_names (map_filter
  18.198          (fn (i, (@{type_name noption}, _, _)) => NONE
  18.199 -          | (i, _) => SOME (Datatype_Aux.name_of_typ (nth_dtyp i))) descr)) ^ "_set";
  18.200 +          | (i, _) => SOME (Old_Datatype_Aux.name_of_typ (nth_dtyp i))) descr)) ^ "_set";
  18.201      val _ = warning ("big_rep_name: " ^ big_rep_name);
  18.202  
  18.203 -    fun strip_option (dtf as Datatype_Aux.DtType ("fun", [dt, Datatype_Aux.DtRec i])) =
  18.204 +    fun strip_option (dtf as Old_Datatype_Aux.DtType ("fun", [dt, Old_Datatype_Aux.DtRec i])) =
  18.205            (case AList.lookup op = descr i of
  18.206               SOME (@{type_name noption}, _, [(_, [dt']), _]) =>
  18.207                 apfst (cons dt) (strip_option dt')
  18.208             | _ => ([], dtf))
  18.209 -      | strip_option (Datatype_Aux.DtType ("fun",
  18.210 -            [dt, Datatype_Aux.DtType (@{type_name noption}, [dt'])])) =
  18.211 +      | strip_option (Old_Datatype_Aux.DtType ("fun",
  18.212 +            [dt, Old_Datatype_Aux.DtType (@{type_name noption}, [dt'])])) =
  18.213            apfst (cons dt) (strip_option dt')
  18.214        | strip_option dt = ([], dt);
  18.215  
  18.216 -    val dt_atomTs = distinct op = (map (Datatype_Aux.typ_of_dtyp descr)
  18.217 +    val dt_atomTs = distinct op = (map (Old_Datatype_Aux.typ_of_dtyp descr)
  18.218        (maps (fn (_, (_, _, cs)) => maps (maps (fst o strip_option) o snd) cs) descr));
  18.219      val dt_atoms = map (fst o dest_Type) dt_atomTs;
  18.220  
  18.221 @@ -486,20 +487,20 @@
  18.222          fun mk_prem dt (j, j', prems, ts) =
  18.223            let
  18.224              val (dts, dt') = strip_option dt;
  18.225 -            val (dts', dt'') = Datatype_Aux.strip_dtyp dt';
  18.226 -            val Ts = map (Datatype_Aux.typ_of_dtyp descr) dts;
  18.227 -            val Us = map (Datatype_Aux.typ_of_dtyp descr) dts';
  18.228 -            val T = Datatype_Aux.typ_of_dtyp descr dt'';
  18.229 -            val free = Datatype_Aux.mk_Free "x" (Us ---> T) j;
  18.230 -            val free' = Datatype_Aux.app_bnds free (length Us);
  18.231 +            val (dts', dt'') = Old_Datatype_Aux.strip_dtyp dt';
  18.232 +            val Ts = map (Old_Datatype_Aux.typ_of_dtyp descr) dts;
  18.233 +            val Us = map (Old_Datatype_Aux.typ_of_dtyp descr) dts';
  18.234 +            val T = Old_Datatype_Aux.typ_of_dtyp descr dt'';
  18.235 +            val free = Old_Datatype_Aux.mk_Free "x" (Us ---> T) j;
  18.236 +            val free' = Old_Datatype_Aux.app_bnds free (length Us);
  18.237              fun mk_abs_fun T (i, t) =
  18.238                let val U = fastype_of t
  18.239                in (i + 1, Const (@{const_name Nominal.abs_fun}, [T, U, T] --->
  18.240 -                Type (@{type_name noption}, [U])) $ Datatype_Aux.mk_Free "y" T i $ t)
  18.241 +                Type (@{type_name noption}, [U])) $ Old_Datatype_Aux.mk_Free "y" T i $ t)
  18.242                end
  18.243            in (j + 1, j' + length Ts,
  18.244              case dt'' of
  18.245 -                Datatype_Aux.DtRec k => Logic.list_all (map (pair "x") Us,
  18.246 +                Old_Datatype_Aux.DtRec k => Logic.list_all (map (pair "x") Us,
  18.247                    HOLogic.mk_Trueprop (Free (nth rep_set_names k,
  18.248                      T --> HOLogic.boolT) $ free')) :: prems
  18.249                | _ => prems,
  18.250 @@ -545,7 +546,7 @@
  18.251        (perm_indnames ~~ descr);
  18.252  
  18.253      fun mk_perm_closed name = map (fn th => Drule.export_without_context (th RS mp))
  18.254 -      (List.take (Datatype_Aux.split_conj_thm (Goal.prove_global_future thy4 [] []
  18.255 +      (List.take (Old_Datatype_Aux.split_conj_thm (Goal.prove_global_future thy4 [] []
  18.256          (augment_sort thy4
  18.257            (pt_class_of thy4 name :: map (cp_class_of thy4 name) (remove (op =) name dt_atoms))
  18.258            (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map
  18.259 @@ -558,7 +559,7 @@
  18.260                     Free ("pi", permT) $ Free (x, T)))
  18.261                 end) (rep_set_names'' ~~ recTs' ~~ perm_indnames')))))
  18.262          (fn {context = ctxt, ...} => EVERY
  18.263 -           [Datatype_Aux.ind_tac rep_induct [] 1,
  18.264 +           [Old_Datatype_Aux.ind_tac rep_induct [] 1,
  18.265              ALLGOALS (simp_tac (ctxt addsimps
  18.266                (Thm.symmetric perm_fun_def :: abs_perm))),
  18.267              ALLGOALS (resolve_tac rep_intrs THEN_ALL_NEW assume_tac)])),
  18.268 @@ -680,8 +681,9 @@
  18.269        (fn ((i, (@{type_name noption}, _, _)), p) => p
  18.270          | ((i, _), (ty_idxs, j)) => (ty_idxs @ [(i, j)], j + 1)) ([], 0) descr;
  18.271  
  18.272 -    fun reindex (Datatype_Aux.DtType (s, dts)) = Datatype_Aux.DtType (s, map reindex dts)
  18.273 -      | reindex (Datatype_Aux.DtRec i) = Datatype_Aux.DtRec (the (AList.lookup op = ty_idxs i))
  18.274 +    fun reindex (Old_Datatype_Aux.DtType (s, dts)) = Old_Datatype_Aux.DtType (s, map reindex dts)
  18.275 +      | reindex (Old_Datatype_Aux.DtRec i) =
  18.276 +        Old_Datatype_Aux.DtRec (the (AList.lookup op = ty_idxs i))
  18.277        | reindex dt = dt;
  18.278  
  18.279      fun strip_suffix i s = implode (List.take (raw_explode s, size s - i));  (* FIXME Symbol.explode (?) *)
  18.280 @@ -717,14 +719,14 @@
  18.281        map (fn ((cname, cargs), idxs) => (cname, partition_cargs idxs cargs))
  18.282          (constrs ~~ idxss)))) (descr'' ~~ ndescr);
  18.283  
  18.284 -    fun nth_dtyp' i = Datatype_Aux.typ_of_dtyp descr'' (Datatype_Aux.DtRec i);
  18.285 +    fun nth_dtyp' i = Old_Datatype_Aux.typ_of_dtyp descr'' (Old_Datatype_Aux.DtRec i);
  18.286  
  18.287      val rep_names = map (fn s =>
  18.288        Sign.intern_const thy7 ("Rep_" ^ s)) new_type_names;
  18.289      val abs_names = map (fn s =>
  18.290        Sign.intern_const thy7 ("Abs_" ^ s)) new_type_names;
  18.291  
  18.292 -    val recTs = Datatype_Aux.get_rec_types descr'';
  18.293 +    val recTs = Old_Datatype_Aux.get_rec_types descr'';
  18.294      val newTs' = take (length new_type_names) recTs';
  18.295      val newTs = take (length new_type_names) recTs;
  18.296  
  18.297 @@ -736,17 +738,20 @@
  18.298          fun constr_arg (dts, dt) (j, l_args, r_args) =
  18.299            let
  18.300              val xs =
  18.301 -              map (fn (dt, i) => Datatype_Aux.mk_Free "x" (Datatype_Aux.typ_of_dtyp descr'' dt) i)
  18.302 +              map (fn (dt, i) =>
  18.303 +                  Old_Datatype_Aux.mk_Free "x" (Old_Datatype_Aux.typ_of_dtyp descr'' dt) i)
  18.304                  (dts ~~ (j upto j + length dts - 1))
  18.305 -            val x = Datatype_Aux.mk_Free "x" (Datatype_Aux.typ_of_dtyp descr'' dt) (j + length dts)
  18.306 +            val x =
  18.307 +              Old_Datatype_Aux.mk_Free "x" (Old_Datatype_Aux.typ_of_dtyp descr'' dt)
  18.308 +                (j + length dts)
  18.309            in
  18.310              (j + length dts + 1,
  18.311               xs @ x :: l_args,
  18.312               fold_rev mk_abs_fun xs
  18.313                 (case dt of
  18.314 -                  Datatype_Aux.DtRec k => if k < length new_type_names then
  18.315 -                      Const (nth rep_names k, Datatype_Aux.typ_of_dtyp descr'' dt -->
  18.316 -                        Datatype_Aux.typ_of_dtyp descr dt) $ x
  18.317 +                  Old_Datatype_Aux.DtRec k => if k < length new_type_names then
  18.318 +                      Const (nth rep_names k, Old_Datatype_Aux.typ_of_dtyp descr'' dt -->
  18.319 +                        Old_Datatype_Aux.typ_of_dtyp descr dt) $ x
  18.320                      else error "nested recursion not (yet) supported"
  18.321                  | _ => x) :: r_args)
  18.322            end
  18.323 @@ -773,7 +778,7 @@
  18.324            (Const (Sign.intern_const thy ("Rep_" ^ tname), T --> T'));
  18.325          val dist =
  18.326            Drule.export_without_context
  18.327 -            (cterm_instantiate [(cterm_of thy distinct_f, rep_const)] Datatype.distinct_lemma);
  18.328 +            (cterm_instantiate [(cterm_of thy distinct_f, rep_const)] Old_Datatype.distinct_lemma);
  18.329          val (thy', defs', eqns') = fold (make_constr_def tname T T')
  18.330            (constrs ~~ constrs' ~~ constr_syntax) (Sign.add_path tname thy, defs, [])
  18.331        in
  18.332 @@ -829,7 +834,7 @@
  18.333  
  18.334      (* prove distinctness theorems *)
  18.335  
  18.336 -    val distinct_props = Datatype_Prop.make_distincts descr';
  18.337 +    val distinct_props = Old_Datatype_Prop.make_distincts descr';
  18.338      val dist_rewrites = map2 (fn rep_thms => fn dist_lemma =>
  18.339        dist_lemma :: rep_thms @ [In0_eq, In1_eq, In0_not_In1, In1_not_In0])
  18.340          constr_rep_thmss dist_lemmas;
  18.341 @@ -865,12 +870,13 @@
  18.342  
  18.343            fun constr_arg (dts, dt) (j, l_args, r_args) =
  18.344              let
  18.345 -              val Ts = map (Datatype_Aux.typ_of_dtyp descr'') dts;
  18.346 +              val Ts = map (Old_Datatype_Aux.typ_of_dtyp descr'') dts;
  18.347                val xs =
  18.348 -                map (fn (T, i) => Datatype_Aux.mk_Free "x" T i)
  18.349 +                map (fn (T, i) => Old_Datatype_Aux.mk_Free "x" T i)
  18.350                    (Ts ~~ (j upto j + length dts - 1));
  18.351                val x =
  18.352 -                Datatype_Aux.mk_Free "x" (Datatype_Aux.typ_of_dtyp descr'' dt) (j + length dts);
  18.353 +                Old_Datatype_Aux.mk_Free "x" (Old_Datatype_Aux.typ_of_dtyp descr'' dt)
  18.354 +                  (j + length dts);
  18.355              in
  18.356                (j + length dts + 1,
  18.357                 xs @ x :: l_args,
  18.358 @@ -918,13 +924,15 @@
  18.359            fun make_inj (dts, dt) (j, args1, args2, eqs) =
  18.360              let
  18.361                val Ts_idx =
  18.362 -                map (Datatype_Aux.typ_of_dtyp descr'') dts ~~ (j upto j + length dts - 1);
  18.363 -              val xs = map (fn (T, i) => Datatype_Aux.mk_Free "x" T i) Ts_idx;
  18.364 -              val ys = map (fn (T, i) => Datatype_Aux.mk_Free "y" T i) Ts_idx;
  18.365 +                map (Old_Datatype_Aux.typ_of_dtyp descr'') dts ~~ (j upto j + length dts - 1);
  18.366 +              val xs = map (fn (T, i) => Old_Datatype_Aux.mk_Free "x" T i) Ts_idx;
  18.367 +              val ys = map (fn (T, i) => Old_Datatype_Aux.mk_Free "y" T i) Ts_idx;
  18.368                val x =
  18.369 -                Datatype_Aux.mk_Free "x" (Datatype_Aux.typ_of_dtyp descr'' dt) (j + length dts);
  18.370 +                Old_Datatype_Aux.mk_Free "x" (Old_Datatype_Aux.typ_of_dtyp descr'' dt)
  18.371 +                  (j + length dts);
  18.372                val y =
  18.373 -                Datatype_Aux.mk_Free "y" (Datatype_Aux.typ_of_dtyp descr'' dt) (j + length dts);
  18.374 +                Old_Datatype_Aux.mk_Free "y" (Old_Datatype_Aux.typ_of_dtyp descr'' dt)
  18.375 +                  (j + length dts);
  18.376              in
  18.377                (j + length dts + 1,
  18.378                 xs @ (x :: args1), ys @ (y :: args2),
  18.379 @@ -965,10 +973,11 @@
  18.380            fun process_constr (dts, dt) (j, args1, args2) =
  18.381              let
  18.382                val Ts_idx =
  18.383 -                map (Datatype_Aux.typ_of_dtyp descr'') dts ~~ (j upto j + length dts - 1);
  18.384 -              val xs = map (fn (T, i) => Datatype_Aux.mk_Free "x" T i) Ts_idx;
  18.385 +                map (Old_Datatype_Aux.typ_of_dtyp descr'') dts ~~ (j upto j + length dts - 1);
  18.386 +              val xs = map (fn (T, i) => Old_Datatype_Aux.mk_Free "x" T i) Ts_idx;
  18.387                val x =
  18.388 -                Datatype_Aux.mk_Free "x" (Datatype_Aux.typ_of_dtyp descr'' dt) (j + length dts);
  18.389 +                Old_Datatype_Aux.mk_Free "x" (Old_Datatype_Aux.typ_of_dtyp descr'' dt)
  18.390 +                  (j + length dts);
  18.391              in
  18.392                (j + length dts + 1,
  18.393                 xs @ (x :: args1), fold_rev mk_abs_fun xs x :: args2)
  18.394 @@ -1007,16 +1016,17 @@
  18.395  
  18.396      fun mk_indrule_lemma (((i, _), T), U) (prems, concls) =
  18.397        let
  18.398 -        val Rep_t = Const (nth rep_names i, T --> U) $ Datatype_Aux.mk_Free "x" T i;
  18.399 +        val Rep_t = Const (nth rep_names i, T --> U) $ Old_Datatype_Aux.mk_Free "x" T i;
  18.400  
  18.401          val Abs_t =  Const (nth abs_names i, U --> T);
  18.402  
  18.403        in
  18.404          (prems @ [HOLogic.imp $
  18.405              (Const (nth rep_set_names'' i, U --> HOLogic.boolT) $ Rep_t) $
  18.406 -              (Datatype_Aux.mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ (Abs_t $ Rep_t))],
  18.407 +              (Old_Datatype_Aux.mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ (Abs_t $ Rep_t))],
  18.408           concls @
  18.409 -           [Datatype_Aux.mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ Datatype_Aux.mk_Free "x" T i])
  18.410 +           [Old_Datatype_Aux.mk_Free "P" (T --> HOLogic.boolT) (i + 1) $
  18.411 +              Old_Datatype_Aux.mk_Free "x" T i])
  18.412        end;
  18.413  
  18.414      val (indrule_lemma_prems, indrule_lemma_concls) =
  18.415 @@ -1024,8 +1034,8 @@
  18.416  
  18.417      val indrule_lemma = Goal.prove_global_future thy8 [] []
  18.418        (Logic.mk_implies
  18.419 -        (HOLogic.mk_Trueprop (Datatype_Aux.mk_conj indrule_lemma_prems),
  18.420 -         HOLogic.mk_Trueprop (Datatype_Aux.mk_conj indrule_lemma_concls)))
  18.421 +        (HOLogic.mk_Trueprop (Old_Datatype_Aux.mk_conj indrule_lemma_prems),
  18.422 +         HOLogic.mk_Trueprop (Old_Datatype_Aux.mk_conj indrule_lemma_concls)))
  18.423           (fn {context = ctxt, ...} => EVERY
  18.424             [REPEAT (etac conjE 1),
  18.425              REPEAT (EVERY
  18.426 @@ -1041,25 +1051,25 @@
  18.427  
  18.428      val Abs_inverse_thms' = map (fn r => r RS subst) Abs_inverse_thms;
  18.429  
  18.430 -    val dt_induct_prop = Datatype_Prop.make_ind descr';
  18.431 +    val dt_induct_prop = Old_Datatype_Prop.make_ind descr';
  18.432      val dt_induct = Goal.prove_global_future thy8 []
  18.433        (Logic.strip_imp_prems dt_induct_prop) (Logic.strip_imp_concl dt_induct_prop)
  18.434        (fn {prems, context = ctxt} => EVERY
  18.435          [rtac indrule_lemma' 1,
  18.436 -         (Datatype_Aux.ind_tac rep_induct [] THEN_ALL_NEW Object_Logic.atomize_prems_tac ctxt) 1,
  18.437 +         (Old_Datatype_Aux.ind_tac rep_induct [] THEN_ALL_NEW Object_Logic.atomize_prems_tac ctxt) 1,
  18.438           EVERY (map (fn (prem, r) => (EVERY
  18.439             [REPEAT (eresolve_tac Abs_inverse_thms' 1),
  18.440              simp_tac (put_simpset HOL_basic_ss ctxt addsimps [Thm.symmetric r]) 1,
  18.441              DEPTH_SOLVE_1 (ares_tac [prem] 1 ORELSE etac allE 1)]))
  18.442                  (prems ~~ constr_defs))]);
  18.443  
  18.444 -    val case_names_induct = Datatype_Data.mk_case_names_induct descr'';
  18.445 +    val case_names_induct = Old_Datatype_Data.mk_case_names_induct descr'';
  18.446  
  18.447      (**** prove that new datatypes have finite support ****)
  18.448  
  18.449      val _ = warning "proving finite support for the new datatype";
  18.450  
  18.451 -    val indnames = Datatype_Prop.make_tnames recTs;
  18.452 +    val indnames = Old_Datatype_Prop.make_tnames recTs;
  18.453  
  18.454      val abs_supp = Global_Theory.get_thms thy8 "abs_supp";
  18.455      val supp_atm = Global_Theory.get_thms thy8 "supp_atm";
  18.456 @@ -1067,14 +1077,14 @@
  18.457      val finite_supp_thms = map (fn atom =>
  18.458        let val atomT = Type (atom, [])
  18.459        in map Drule.export_without_context (List.take
  18.460 -        (Datatype_Aux.split_conj_thm (Goal.prove_global_future thy8 [] []
  18.461 +        (Old_Datatype_Aux.split_conj_thm (Goal.prove_global_future thy8 [] []
  18.462             (augment_sort thy8 (fs_class_of thy8 atom :: pt_cp_sort)
  18.463               (HOLogic.mk_Trueprop
  18.464                 (foldr1 HOLogic.mk_conj (map (fn (s, T) =>
  18.465                   Const (@{const_name finite}, HOLogic.mk_setT atomT --> HOLogic.boolT) $
  18.466                     (Const (@{const_name Nominal.supp}, T --> HOLogic.mk_setT atomT) $ Free (s, T)))
  18.467                     (indnames ~~ recTs)))))
  18.468 -           (fn {context = ctxt, ...} => Datatype_Aux.ind_tac dt_induct indnames 1 THEN
  18.469 +           (fn {context = ctxt, ...} => Old_Datatype_Aux.ind_tac dt_induct indnames 1 THEN
  18.470              ALLGOALS (asm_full_simp_tac (ctxt addsimps
  18.471                (abs_supp @ supp_atm @
  18.472                 Global_Theory.get_thms thy8 ("fs_" ^ Long_Name.base_name atom ^ "1") @
  18.473 @@ -1094,12 +1104,12 @@
  18.474        Global_Theory.add_thms [((Binding.name "induct", dt_induct), [case_names_induct])] ||>>
  18.475        Global_Theory.add_thmss [((Binding.name "inducts", projections dt_induct), [case_names_induct])] ||>
  18.476        Sign.parent_path ||>>
  18.477 -      Datatype_Aux.store_thmss_atts "distinct" new_type_names simp_atts distinct_thms ||>>
  18.478 -      Datatype_Aux.store_thmss "constr_rep" new_type_names constr_rep_thmss ||>>
  18.479 -      Datatype_Aux.store_thmss_atts "perm" new_type_names simp_eqvt_atts perm_simps' ||>>
  18.480 -      Datatype_Aux.store_thmss "inject" new_type_names inject_thms ||>>
  18.481 -      Datatype_Aux.store_thmss "supp" new_type_names supp_thms ||>>
  18.482 -      Datatype_Aux.store_thmss_atts "fresh" new_type_names simp_atts fresh_thms ||>
  18.483 +      Old_Datatype_Aux.store_thmss_atts "distinct" new_type_names simp_atts distinct_thms ||>>
  18.484 +      Old_Datatype_Aux.store_thmss "constr_rep" new_type_names constr_rep_thmss ||>>
  18.485 +      Old_Datatype_Aux.store_thmss_atts "perm" new_type_names simp_eqvt_atts perm_simps' ||>>
  18.486 +      Old_Datatype_Aux.store_thmss "inject" new_type_names inject_thms ||>>
  18.487 +      Old_Datatype_Aux.store_thmss "supp" new_type_names supp_thms ||>>
  18.488 +      Old_Datatype_Aux.store_thmss_atts "fresh" new_type_names simp_atts fresh_thms ||>
  18.489        fold (fn (atom, ths) => fn thy =>
  18.490          let
  18.491            val class = fs_class_of thy atom;
  18.492 @@ -1119,7 +1129,7 @@
  18.493      val fsT' = TFree ("'n", @{sort type});
  18.494  
  18.495      val fresh_fs = map (fn (s, T) => (T, Free (s, fsT' --> HOLogic.mk_setT T)))
  18.496 -      (Datatype_Prop.indexify_names (replicate (length dt_atomTs) "f") ~~ dt_atomTs);
  18.497 +      (Old_Datatype_Prop.indexify_names (replicate (length dt_atomTs) "f") ~~ dt_atomTs);
  18.498  
  18.499      fun make_pred fsT i T = Free (nth pnames i, fsT --> T --> HOLogic.boolT);
  18.500  
  18.501 @@ -1137,11 +1147,11 @@
  18.502  
  18.503      fun make_ind_prem fsT f k T ((cname, cargs), idxs) =
  18.504        let
  18.505 -        val recs = filter Datatype_Aux.is_rec_type cargs;
  18.506 -        val Ts = map (Datatype_Aux.typ_of_dtyp descr'') cargs;
  18.507 -        val recTs' = map (Datatype_Aux.typ_of_dtyp descr'') recs;
  18.508 -        val tnames = Name.variant_list pnames (Datatype_Prop.make_tnames Ts);
  18.509 -        val rec_tnames = map fst (filter (Datatype_Aux.is_rec_type o snd) (tnames ~~ cargs));
  18.510 +        val recs = filter Old_Datatype_Aux.is_rec_type cargs;
  18.511 +        val Ts = map (Old_Datatype_Aux.typ_of_dtyp descr'') cargs;
  18.512 +        val recTs' = map (Old_Datatype_Aux.typ_of_dtyp descr'') recs;
  18.513 +        val tnames = Name.variant_list pnames (Old_Datatype_Prop.make_tnames Ts);
  18.514 +        val rec_tnames = map fst (filter (Old_Datatype_Aux.is_rec_type o snd) (tnames ~~ cargs));
  18.515          val frees = tnames ~~ Ts;
  18.516          val frees' = partition_cargs idxs frees;
  18.517          val z = (singleton (Name.variant_list tnames) "z", fsT);
  18.518 @@ -1153,8 +1163,8 @@
  18.519            in
  18.520              Logic.list_all (z :: map (pair "x") Us,
  18.521                HOLogic.mk_Trueprop
  18.522 -                (make_pred fsT (Datatype_Aux.body_index dt) U $ Bound l $
  18.523 -                  Datatype_Aux.app_bnds (Free (s, T)) l))
  18.524 +                (make_pred fsT (Old_Datatype_Aux.body_index dt) U $ Bound l $
  18.525 +                  Old_Datatype_Aux.app_bnds (Free (s, T)) l))
  18.526            end;
  18.527  
  18.528          val prems = map mk_prem (recs ~~ rec_tnames ~~ recTs');
  18.529 @@ -1174,7 +1184,7 @@
  18.530        map (make_ind_prem fsT (fn T => fn t => fn u =>
  18.531          fresh_const T fsT $ t $ u) i T)
  18.532            (constrs ~~ idxss)) (descr'' ~~ ndescr ~~ recTs);
  18.533 -    val tnames = Datatype_Prop.make_tnames recTs;
  18.534 +    val tnames = Old_Datatype_Prop.make_tnames recTs;
  18.535      val zs = Name.variant_list tnames (replicate (length descr'') "z");
  18.536      val ind_concl = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop @{const_name HOL.conj})
  18.537        (map (fn ((((i, _), T), tname), z) =>
  18.538 @@ -1198,7 +1208,7 @@
  18.539      val induct' = Logic.list_implies (ind_prems', ind_concl');
  18.540  
  18.541      val aux_ind_vars =
  18.542 -      (Datatype_Prop.indexify_names (replicate (length dt_atomTs) "pi") ~~
  18.543 +      (Old_Datatype_Prop.indexify_names (replicate (length dt_atomTs) "pi") ~~
  18.544         map mk_permT dt_atomTs) @ [("z", fsT')];
  18.545      val aux_ind_Ts = rev (map snd aux_ind_vars);
  18.546      val aux_ind_concl = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop @{const_name HOL.conj})
  18.547 @@ -1292,7 +1302,7 @@
  18.548          val th = Goal.prove context [] []
  18.549            (augment_sort thy9 fs_cp_sort aux_ind_concl)
  18.550            (fn {context = context1, ...} =>
  18.551 -             EVERY (Datatype_Aux.ind_tac dt_induct tnames 1 ::
  18.552 +             EVERY (Old_Datatype_Aux.ind_tac dt_induct tnames 1 ::
  18.553                 maps (fn ((_, (_, _, constrs)), (_, constrs')) =>
  18.554                   map (fn ((cname, cargs), is) =>
  18.555                     REPEAT (rtac allI 1) THEN
  18.556 @@ -1397,7 +1407,7 @@
  18.557  
  18.558      val used = fold Term.add_tfree_namesT recTs [];
  18.559  
  18.560 -    val (rec_result_Ts', rec_fn_Ts') = Datatype_Prop.make_primrec_Ts descr' used;
  18.561 +    val (rec_result_Ts', rec_fn_Ts') = Old_Datatype_Prop.make_primrec_Ts descr' used;
  18.562  
  18.563      val rec_sort = if null dt_atomTs then @{sort type} else
  18.564        Sign.minimize_sort thy10 (Sign.certify_sort thy10 pt_cp_sort);
  18.565 @@ -1415,7 +1425,7 @@
  18.566            (1 upto (length descr''));
  18.567      val rec_set_names =  map (Sign.full_bname thy10) rec_set_names';
  18.568  
  18.569 -    val rec_fns = map (uncurry (Datatype_Aux.mk_Free "f"))
  18.570 +    val rec_fns = map (uncurry (Old_Datatype_Aux.mk_Free "f"))
  18.571        (rec_fn_Ts ~~ (1 upto (length rec_fn_Ts)));
  18.572      val rec_sets' = map (fn c => list_comb (Free c, rec_fns))
  18.573        (rec_set_names' ~~ rec_set_Ts);
  18.574 @@ -1440,13 +1450,13 @@
  18.575      fun make_rec_intr T p rec_set ((cname, cargs), idxs)
  18.576          (rec_intr_ts, rec_prems, rec_prems', rec_eq_prems, l) =
  18.577        let
  18.578 -        val Ts = map (Datatype_Aux.typ_of_dtyp descr'') cargs;
  18.579 +        val Ts = map (Old_Datatype_Aux.typ_of_dtyp descr'') cargs;
  18.580          val frees = map (fn i => "x" ^ string_of_int i) (1 upto length Ts) ~~ Ts;
  18.581          val frees' = partition_cargs idxs frees;
  18.582          val binders = maps fst frees';
  18.583          val atomTs = distinct op = (maps (map snd o fst) frees');
  18.584          val recs = map_filter
  18.585 -          (fn ((_, Datatype_Aux.DtRec i), p) => SOME (i, p) | _ => NONE)
  18.586 +          (fn ((_, Old_Datatype_Aux.DtRec i), p) => SOME (i, p) | _ => NONE)
  18.587            (partition_cargs idxs cargs ~~ frees');
  18.588          val frees'' = map (fn i => "y" ^ string_of_int i) (1 upto length recs) ~~
  18.589            map (fn (i, _) => nth rec_result_Ts i) recs;
  18.590 @@ -1508,7 +1518,7 @@
  18.591        let
  18.592          val permT = mk_permT aT;
  18.593          val pi = Free ("pi", permT);
  18.594 -        val rec_fns_pi = map (mk_perm [] pi o uncurry (Datatype_Aux.mk_Free "f"))
  18.595 +        val rec_fns_pi = map (mk_perm [] pi o uncurry (Old_Datatype_Aux.mk_Free "f"))
  18.596            (rec_fn_Ts ~~ (1 upto (length rec_fn_Ts)));
  18.597          val rec_sets_pi = map (fn c => list_comb (Const c, rec_fns_pi))
  18.598            (rec_set_names ~~ rec_set_Ts);
  18.599 @@ -1519,16 +1529,17 @@
  18.600            in
  18.601              (R $ x $ y, R' $ mk_perm [] pi x $ mk_perm [] pi y)
  18.602            end) (recTs ~~ rec_result_Ts ~~ rec_sets ~~ rec_sets_pi ~~ (1 upto length recTs));
  18.603 -        val ths = map (fn th => Drule.export_without_context (th RS mp)) (Datatype_Aux.split_conj_thm
  18.604 -          (Goal.prove_global_future thy11 [] []
  18.605 -            (augment_sort thy1 pt_cp_sort
  18.606 -              (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map HOLogic.mk_imp ps))))
  18.607 -            (fn {context = ctxt, ...} => rtac rec_induct 1 THEN REPEAT
  18.608 -               (simp_tac (put_simpset HOL_basic_ss ctxt
  18.609 -                  addsimps flat perm_simps'
  18.610 -                  addsimprocs [NominalPermeq.perm_simproc_app]) 1 THEN
  18.611 -                (resolve_tac rec_intrs THEN_ALL_NEW
  18.612 -                 asm_simp_tac (put_simpset HOL_ss ctxt addsimps (fresh_bij @ perm_bij))) 1))))
  18.613 +        val ths = map (fn th => Drule.export_without_context (th RS mp))
  18.614 +          (Old_Datatype_Aux.split_conj_thm
  18.615 +            (Goal.prove_global_future thy11 [] []
  18.616 +              (augment_sort thy1 pt_cp_sort
  18.617 +                (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map HOLogic.mk_imp ps))))
  18.618 +              (fn {context = ctxt, ...} => rtac rec_induct 1 THEN REPEAT
  18.619 +                 (simp_tac (put_simpset HOL_basic_ss ctxt
  18.620 +                    addsimps flat perm_simps'
  18.621 +                    addsimprocs [NominalPermeq.perm_simproc_app]) 1 THEN
  18.622 +                  (resolve_tac rec_intrs THEN_ALL_NEW
  18.623 +                   asm_simp_tac (put_simpset HOL_ss ctxt addsimps (fresh_bij @ perm_bij))) 1))))
  18.624          val ths' = map (fn ((P, Q), th) =>
  18.625            Goal.prove_global_future thy11 [] []
  18.626              (augment_sort thy1 pt_cp_sort
  18.627 @@ -1551,7 +1562,7 @@
  18.628            (finite $ (Const (@{const_name Nominal.supp}, T --> aset) $ f)))
  18.629              (rec_fns ~~ rec_fn_Ts)
  18.630        in
  18.631 -        map (fn th => Drule.export_without_context (th RS mp)) (Datatype_Aux.split_conj_thm
  18.632 +        map (fn th => Drule.export_without_context (th RS mp)) (Old_Datatype_Aux.split_conj_thm
  18.633            (Goal.prove_global_future thy11 []
  18.634              (map (augment_sort thy11 fs_cp_sort) fins)
  18.635              (augment_sort thy11 fs_cp_sort
  18.636 @@ -1643,10 +1654,10 @@
  18.637      val fun_tuple = foldr1 HOLogic.mk_prod (rec_ctxt :: rec_fns);
  18.638      val fun_tupleT = fastype_of fun_tuple;
  18.639      val rec_unique_frees =
  18.640 -      Datatype_Prop.indexify_names (replicate (length recTs) "x") ~~ recTs;
  18.641 +      Old_Datatype_Prop.indexify_names (replicate (length recTs) "x") ~~ recTs;
  18.642      val rec_unique_frees'' = map (fn (s, T) => (s ^ "'", T)) rec_unique_frees;
  18.643      val rec_unique_frees' =
  18.644 -      Datatype_Prop.indexify_names (replicate (length recTs) "y") ~~ rec_result_Ts;
  18.645 +      Old_Datatype_Prop.indexify_names (replicate (length recTs) "y") ~~ rec_result_Ts;
  18.646      val rec_unique_concls = map (fn ((x, U), R) =>
  18.647          Const (@{const_name Ex1}, (U --> HOLogic.boolT) --> HOLogic.boolT) $
  18.648            Abs ("y", U, R $ Free x $ Bound 0))
  18.649 @@ -1688,7 +1699,7 @@
  18.650          (Const (@{const_name finite}, HOLogic.mk_setT aT --> HOLogic.boolT) $
  18.651             (Const (@{const_name Nominal.supp}, fsT' --> HOLogic.mk_setT aT) $ rec_ctxt))) dt_atomTs;
  18.652  
  18.653 -    val rec_unique_thms = Datatype_Aux.split_conj_thm (Goal.prove
  18.654 +    val rec_unique_thms = Old_Datatype_Aux.split_conj_thm (Goal.prove
  18.655        (Proof_Context.init_global thy11) (map fst rec_unique_frees)
  18.656        (map (augment_sort thy11 fs_cp_sort)
  18.657          (flat finite_premss @ finite_ctxt_prems @ rec_prems @ rec_prems'))
  18.658 @@ -1701,7 +1712,7 @@
  18.659               apfst (pair T) (chop k xs)) dt_atomTs prems;
  18.660             val (finite_ctxt_ths, ths2) = chop (length dt_atomTs) ths1;
  18.661             val (P_ind_ths, fcbs) = chop k ths2;
  18.662 -           val P_ths = map (fn th => th RS mp) (Datatype_Aux.split_conj_thm
  18.663 +           val P_ths = map (fn th => th RS mp) (Old_Datatype_Aux.split_conj_thm
  18.664               (Goal.prove context
  18.665                 (map fst (rec_unique_frees'' @ rec_unique_frees')) []
  18.666                 (augment_sort thy11 fs_cp_sort
  18.667 @@ -2027,7 +2038,7 @@
  18.668               resolve_tac rec_intrs 1,
  18.669               REPEAT (solve (prems @ rec_total_thms) prems 1)])
  18.670        end) (rec_eq_prems ~~
  18.671 -        Datatype_Prop.make_primrecs reccomb_names descr' thy12);
  18.672 +        Old_Datatype_Prop.make_primrecs reccomb_names descr' thy12);
  18.673  
  18.674      val dt_infos = map_index (make_dt_info pdescr induct reccomb_names rec_thms)
  18.675        (descr1 ~~ distinct_thms ~~ inject_thms);
  18.676 @@ -2047,12 +2058,12 @@
  18.677      thy13
  18.678    end;
  18.679  
  18.680 -val nominal_datatype = gen_nominal_datatype Datatype.check_specs;
  18.681 -val nominal_datatype_cmd = gen_nominal_datatype Datatype.read_specs;
  18.682 +val nominal_datatype = gen_nominal_datatype Old_Datatype.check_specs;
  18.683 +val nominal_datatype_cmd = gen_nominal_datatype Old_Datatype.read_specs;
  18.684  
  18.685  val _ =
  18.686    Outer_Syntax.command @{command_spec "nominal_datatype"} "define nominal datatypes"
  18.687 -    (Parse.and_list1 Datatype.spec_cmd >>
  18.688 -      (Toplevel.theory o nominal_datatype_cmd Datatype_Aux.default_config));
  18.689 +    (Parse.and_list1 Old_Datatype.spec_cmd >>
  18.690 +      (Toplevel.theory o nominal_datatype_cmd Old_Datatype_Aux.default_config));
  18.691  
  18.692  end
    19.1 --- a/src/HOL/Nominal/nominal_inductive.ML	Mon Sep 01 16:17:46 2014 +0200
    19.2 +++ b/src/HOL/Nominal/nominal_inductive.ML	Mon Sep 01 16:17:46 2014 +0200
    19.3 @@ -244,7 +244,7 @@
    19.4        end) prems);
    19.5  
    19.6      val ind_vars =
    19.7 -      (Datatype_Prop.indexify_names (replicate (length atomTs) "pi") ~~
    19.8 +      (Old_Datatype_Prop.indexify_names (replicate (length atomTs) "pi") ~~
    19.9         map NominalAtoms.mk_permT atomTs) @ [("z", fsT)];
   19.10      val ind_Ts = rev (map snd ind_vars);
   19.11  
   19.12 @@ -645,7 +645,7 @@
   19.13      val thss = map (fn atom =>
   19.14        let val pi' = Free (pi, NominalAtoms.mk_permT (Type (atom, [])))
   19.15        in map (fn th => zero_var_indexes (th RS mp))
   19.16 -        (Datatype_Aux.split_conj_thm (Goal.prove ctxt' [] []
   19.17 +        (Old_Datatype_Aux.split_conj_thm (Goal.prove ctxt' [] []
   19.18            (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map (fn p =>
   19.19              let
   19.20                val (h, ts) = strip_comb p;
    20.1 --- a/src/HOL/Nominal/nominal_inductive2.ML	Mon Sep 01 16:17:46 2014 +0200
    20.2 +++ b/src/HOL/Nominal/nominal_inductive2.ML	Mon Sep 01 16:17:46 2014 +0200
    20.3 @@ -261,7 +261,7 @@
    20.4        in abs_params params' prem end) prems);
    20.5  
    20.6      val ind_vars =
    20.7 -      (Datatype_Prop.indexify_names (replicate (length atomTs) "pi") ~~
    20.8 +      (Old_Datatype_Prop.indexify_names (replicate (length atomTs) "pi") ~~
    20.9         map NominalAtoms.mk_permT atomTs) @ [("z", fsT)];
   20.10      val ind_Ts = rev (map snd ind_vars);
   20.11  
    21.1 --- a/src/HOL/Nominal/nominal_primrec.ML	Mon Sep 01 16:17:46 2014 +0200
    21.2 +++ b/src/HOL/Nominal/nominal_primrec.ML	Mon Sep 01 16:17:46 2014 +0200
    21.3 @@ -154,12 +154,12 @@
    21.4                (fnames', fnss', (Const (@{const_name undefined}, dummyT))::fns))
    21.5          | SOME (ls, cargs', rs, rhs, eq) =>
    21.6              let
    21.7 -              val recs = filter (Datatype_Aux.is_rec_type o snd) (cargs' ~~ cargs);
    21.8 +              val recs = filter (Old_Datatype_Aux.is_rec_type o snd) (cargs' ~~ cargs);
    21.9                val rargs = map fst recs;
   21.10                val subs = map (rpair dummyT o fst)
   21.11                  (rev (Term.rename_wrt_term rhs rargs));
   21.12                val (rhs', (fnames'', fnss'')) = subst (map2 (fn (x, y) => fn z =>
   21.13 -                (Free x, (Datatype_Aux.body_index y, Free z))) recs subs) rhs (fnames', fnss')
   21.14 +                (Free x, (Old_Datatype_Aux.body_index y, Free z))) recs subs) rhs (fnames', fnss')
   21.15                    handle RecError s => primrec_eq_err lthy s eq
   21.16              in (fnames'', fnss'', fold_rev absfree (cargs' @ subs) rhs' :: fns)
   21.17              end)
   21.18 @@ -190,7 +190,7 @@
   21.19       NONE =>
   21.20         let
   21.21           val dummy_fns = map (fn (_, cargs) => Const (@{const_name undefined},
   21.22 -           replicate (length cargs + length (filter Datatype_Aux.is_rec_type cargs))
   21.23 +           replicate (length cargs + length (filter Old_Datatype_Aux.is_rec_type cargs))
   21.24               dummyT ---> HOLogic.unitT)) constrs;
   21.25           val _ = warning ("No function definition for datatype " ^ quote tname)
   21.26         in
    22.1 --- a/src/HOL/Num.thy	Mon Sep 01 16:17:46 2014 +0200
    22.2 +++ b/src/HOL/Num.thy	Mon Sep 01 16:17:46 2014 +0200
    22.3 @@ -6,7 +6,7 @@
    22.4  header {* Binary Numerals *}
    22.5  
    22.6  theory Num
    22.7 -imports Datatype BNF_LFP
    22.8 +imports Old_Datatype BNF_LFP
    22.9  begin
   22.10  
   22.11  subsection {* The @{text num} type *}
    23.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    23.2 +++ b/src/HOL/Old_Datatype.thy	Mon Sep 01 16:17:46 2014 +0200
    23.3 @@ -0,0 +1,523 @@
    23.4 +(*  Title:      HOL/Old_Datatype.thy
    23.5 +    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    23.6 +    Author:     Stefan Berghofer and Markus Wenzel, TU Muenchen
    23.7 +*)
    23.8 +
    23.9 +header {* Old Datatype package: constructing datatypes from Cartesian Products and Disjoint Sums *}
   23.10 +
   23.11 +theory Old_Datatype
   23.12 +imports Product_Type Sum_Type Nat
   23.13 +keywords "datatype" :: thy_decl
   23.14 +begin
   23.15 +
   23.16 +subsection {* The datatype universe *}
   23.17 +
   23.18 +definition "Node = {p. EX f x k. p = (f :: nat => 'b + nat, x ::'a + nat) & f k = Inr 0}"
   23.19 +
   23.20 +typedef ('a, 'b) node = "Node :: ((nat => 'b + nat) * ('a + nat)) set"
   23.21 +  morphisms Rep_Node Abs_Node
   23.22 +  unfolding Node_def by auto
   23.23 +
   23.24 +text{*Datatypes will be represented by sets of type @{text node}*}
   23.25 +
   23.26 +type_synonym 'a item        = "('a, unit) node set"
   23.27 +type_synonym ('a, 'b) dtree = "('a, 'b) node set"
   23.28 +
   23.29 +consts
   23.30 +  Push      :: "[('b + nat), nat => ('b + nat)] => (nat => ('b + nat))"
   23.31 +
   23.32 +  Push_Node :: "[('b + nat), ('a, 'b) node] => ('a, 'b) node"
   23.33 +  ndepth    :: "('a, 'b) node => nat"
   23.34 +
   23.35 +  Atom      :: "('a + nat) => ('a, 'b) dtree"
   23.36 +  Leaf      :: "'a => ('a, 'b) dtree"
   23.37 +  Numb      :: "nat => ('a, 'b) dtree"
   23.38 +  Scons     :: "[('a, 'b) dtree, ('a, 'b) dtree] => ('a, 'b) dtree"
   23.39 +  In0       :: "('a, 'b) dtree => ('a, 'b) dtree"
   23.40 +  In1       :: "('a, 'b) dtree => ('a, 'b) dtree"
   23.41 +  Lim       :: "('b => ('a, 'b) dtree) => ('a, 'b) dtree"
   23.42 +
   23.43 +  ntrunc    :: "[nat, ('a, 'b) dtree] => ('a, 'b) dtree"
   23.44 +
   23.45 +  uprod     :: "[('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set"
   23.46 +  usum      :: "[('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set"
   23.47 +
   23.48 +  Split     :: "[[('a, 'b) dtree, ('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c"
   23.49 +  Case      :: "[[('a, 'b) dtree]=>'c, [('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c"
   23.50 +
   23.51 +  dprod     :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set]
   23.52 +                => (('a, 'b) dtree * ('a, 'b) dtree)set"
   23.53 +  dsum      :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set]
   23.54 +                => (('a, 'b) dtree * ('a, 'b) dtree)set"
   23.55 +
   23.56 +
   23.57 +defs
   23.58 +
   23.59 +  Push_Node_def:  "Push_Node == (%n x. Abs_Node (apfst (Push n) (Rep_Node x)))"
   23.60 +
   23.61 +  (*crude "lists" of nats -- needed for the constructions*)
   23.62 +  Push_def:   "Push == (%b h. case_nat b h)"
   23.63 +
   23.64 +  (** operations on S-expressions -- sets of nodes **)
   23.65 +
   23.66 +  (*S-expression constructors*)
   23.67 +  Atom_def:   "Atom == (%x. {Abs_Node((%k. Inr 0, x))})"
   23.68 +  Scons_def:  "Scons M N == (Push_Node (Inr 1) ` M) Un (Push_Node (Inr (Suc 1)) ` N)"
   23.69 +
   23.70 +  (*Leaf nodes, with arbitrary or nat labels*)
   23.71 +  Leaf_def:   "Leaf == Atom o Inl"
   23.72 +  Numb_def:   "Numb == Atom o Inr"
   23.73 +
   23.74 +  (*Injections of the "disjoint sum"*)
   23.75 +  In0_def:    "In0(M) == Scons (Numb 0) M"
   23.76 +  In1_def:    "In1(M) == Scons (Numb 1) M"
   23.77 +
   23.78 +  (*Function spaces*)
   23.79 +  Lim_def: "Lim f == Union {z. ? x. z = Push_Node (Inl x) ` (f x)}"
   23.80 +
   23.81 +  (*the set of nodes with depth less than k*)
   23.82 +  ndepth_def: "ndepth(n) == (%(f,x). LEAST k. f k = Inr 0) (Rep_Node n)"
   23.83 +  ntrunc_def: "ntrunc k N == {n. n:N & ndepth(n)<k}"
   23.84 +
   23.85 +  (*products and sums for the "universe"*)
   23.86 +  uprod_def:  "uprod A B == UN x:A. UN y:B. { Scons x y }"
   23.87 +  usum_def:   "usum A B == In0`A Un In1`B"
   23.88 +
   23.89 +  (*the corresponding eliminators*)
   23.90 +  Split_def:  "Split c M == THE u. EX x y. M = Scons x y & u = c x y"
   23.91 +
   23.92 +  Case_def:   "Case c d M == THE u.  (EX x . M = In0(x) & u = c(x))
   23.93 +                                  | (EX y . M = In1(y) & u = d(y))"
   23.94 +
   23.95 +
   23.96 +  (** equality for the "universe" **)
   23.97 +
   23.98 +  dprod_def:  "dprod r s == UN (x,x'):r. UN (y,y'):s. {(Scons x y, Scons x' y')}"
   23.99 +
  23.100 +  dsum_def:   "dsum r s == (UN (x,x'):r. {(In0(x),In0(x'))}) Un
  23.101 +                          (UN (y,y'):s. {(In1(y),In1(y'))})"
  23.102 +
  23.103 +
  23.104 +
  23.105 +lemma apfst_convE: 
  23.106 +    "[| q = apfst f p;  !!x y. [| p = (x,y);  q = (f(x),y) |] ==> R  
  23.107 +     |] ==> R"
  23.108 +by (force simp add: apfst_def)
  23.109 +
  23.110 +(** Push -- an injection, analogous to Cons on lists **)
  23.111 +
  23.112 +lemma Push_inject1: "Push i f = Push j g  ==> i=j"
  23.113 +apply (simp add: Push_def fun_eq_iff) 
  23.114 +apply (drule_tac x=0 in spec, simp) 
  23.115 +done
  23.116 +
  23.117 +lemma Push_inject2: "Push i f = Push j g  ==> f=g"
  23.118 +apply (auto simp add: Push_def fun_eq_iff) 
  23.119 +apply (drule_tac x="Suc x" in spec, simp) 
  23.120 +done
  23.121 +
  23.122 +lemma Push_inject:
  23.123 +    "[| Push i f =Push j g;  [| i=j;  f=g |] ==> P |] ==> P"
  23.124 +by (blast dest: Push_inject1 Push_inject2) 
  23.125 +
  23.126 +lemma Push_neq_K0: "Push (Inr (Suc k)) f = (%z. Inr 0) ==> P"
  23.127 +by (auto simp add: Push_def fun_eq_iff split: nat.split_asm)
  23.128 +
  23.129 +lemmas Abs_Node_inj = Abs_Node_inject [THEN [2] rev_iffD1]
  23.130 +
  23.131 +
  23.132 +(*** Introduction rules for Node ***)
  23.133 +
  23.134 +lemma Node_K0_I: "(%k. Inr 0, a) : Node"
  23.135 +by (simp add: Node_def)
  23.136 +
  23.137 +lemma Node_Push_I: "p: Node ==> apfst (Push i) p : Node"
  23.138 +apply (simp add: Node_def Push_def) 
  23.139 +apply (fast intro!: apfst_conv nat.case(2)[THEN trans])
  23.140 +done
  23.141 +
  23.142 +
  23.143 +subsection{*Freeness: Distinctness of Constructors*}
  23.144 +
  23.145 +(** Scons vs Atom **)
  23.146 +
  23.147 +lemma Scons_not_Atom [iff]: "Scons M N \<noteq> Atom(a)"
  23.148 +unfolding Atom_def Scons_def Push_Node_def One_nat_def
  23.149 +by (blast intro: Node_K0_I Rep_Node [THEN Node_Push_I] 
  23.150 +         dest!: Abs_Node_inj 
  23.151 +         elim!: apfst_convE sym [THEN Push_neq_K0])  
  23.152 +
  23.153 +lemmas Atom_not_Scons [iff] = Scons_not_Atom [THEN not_sym]
  23.154 +
  23.155 +
  23.156 +(*** Injectiveness ***)
  23.157 +
  23.158 +(** Atomic nodes **)
  23.159 +
  23.160 +lemma inj_Atom: "inj(Atom)"
  23.161 +apply (simp add: Atom_def)
  23.162 +apply (blast intro!: inj_onI Node_K0_I dest!: Abs_Node_inj)
  23.163 +done
  23.164 +lemmas Atom_inject = inj_Atom [THEN injD]
  23.165 +
  23.166 +lemma Atom_Atom_eq [iff]: "(Atom(a)=Atom(b)) = (a=b)"
  23.167 +by (blast dest!: Atom_inject)
  23.168 +
  23.169 +lemma inj_Leaf: "inj(Leaf)"
  23.170 +apply (simp add: Leaf_def o_def)
  23.171 +apply (rule inj_onI)
  23.172 +apply (erule Atom_inject [THEN Inl_inject])
  23.173 +done
  23.174 +
  23.175 +lemmas Leaf_inject [dest!] = inj_Leaf [THEN injD]
  23.176 +
  23.177 +lemma inj_Numb: "inj(Numb)"
  23.178 +apply (simp add: Numb_def o_def)
  23.179 +apply (rule inj_onI)
  23.180 +apply (erule Atom_inject [THEN Inr_inject])
  23.181 +done
  23.182 +
  23.183 +lemmas Numb_inject [dest!] = inj_Numb [THEN injD]
  23.184 +
  23.185 +
  23.186 +(** Injectiveness of Push_Node **)
  23.187 +
  23.188 +lemma Push_Node_inject:
  23.189 +    "[| Push_Node i m =Push_Node j n;  [| i=j;  m=n |] ==> P  
  23.190 +     |] ==> P"
  23.191 +apply (simp add: Push_Node_def)
  23.192 +apply (erule Abs_Node_inj [THEN apfst_convE])
  23.193 +apply (rule Rep_Node [THEN Node_Push_I])+
  23.194 +apply (erule sym [THEN apfst_convE]) 
  23.195 +apply (blast intro: Rep_Node_inject [THEN iffD1] trans sym elim!: Push_inject)
  23.196 +done
  23.197 +
  23.198 +
  23.199 +(** Injectiveness of Scons **)
  23.200 +
  23.201 +lemma Scons_inject_lemma1: "Scons M N <= Scons M' N' ==> M<=M'"
  23.202 +unfolding Scons_def One_nat_def
  23.203 +by (blast dest!: Push_Node_inject)
  23.204 +
  23.205 +lemma Scons_inject_lemma2: "Scons M N <= Scons M' N' ==> N<=N'"
  23.206 +unfolding Scons_def One_nat_def
  23.207 +by (blast dest!: Push_Node_inject)
  23.208 +
  23.209 +lemma Scons_inject1: "Scons M N = Scons M' N' ==> M=M'"
  23.210 +apply (erule equalityE)
  23.211 +apply (iprover intro: equalityI Scons_inject_lemma1)
  23.212 +done
  23.213 +
  23.214 +lemma Scons_inject2: "Scons M N = Scons M' N' ==> N=N'"
  23.215 +apply (erule equalityE)
  23.216 +apply (iprover intro: equalityI Scons_inject_lemma2)
  23.217 +done
  23.218 +
  23.219 +lemma Scons_inject:
  23.220 +    "[| Scons M N = Scons M' N';  [| M=M';  N=N' |] ==> P |] ==> P"
  23.221 +by (iprover dest: Scons_inject1 Scons_inject2)
  23.222 +
  23.223 +lemma Scons_Scons_eq [iff]: "(Scons M N = Scons M' N') = (M=M' & N=N')"
  23.224 +by (blast elim!: Scons_inject)
  23.225 +
  23.226 +(*** Distinctness involving Leaf and Numb ***)
  23.227 +
  23.228 +(** Scons vs Leaf **)
  23.229 +
  23.230 +lemma Scons_not_Leaf [iff]: "Scons M N \<noteq> Leaf(a)"
  23.231 +unfolding Leaf_def o_def by (rule Scons_not_Atom)
  23.232 +
  23.233 +lemmas Leaf_not_Scons  [iff] = Scons_not_Leaf [THEN not_sym]
  23.234 +
  23.235 +(** Scons vs Numb **)
  23.236 +
  23.237 +lemma Scons_not_Numb [iff]: "Scons M N \<noteq> Numb(k)"
  23.238 +unfolding Numb_def o_def by (rule Scons_not_Atom)
  23.239 +
  23.240 +lemmas Numb_not_Scons [iff] = Scons_not_Numb [THEN not_sym]
  23.241 +
  23.242 +
  23.243 +(** Leaf vs Numb **)
  23.244 +
  23.245 +lemma Leaf_not_Numb [iff]: "Leaf(a) \<noteq> Numb(k)"
  23.246 +by (simp add: Leaf_def Numb_def)
  23.247 +
  23.248 +lemmas Numb_not_Leaf [iff] = Leaf_not_Numb [THEN not_sym]
  23.249 +
  23.250 +
  23.251 +(*** ndepth -- the depth of a node ***)
  23.252 +
  23.253 +lemma ndepth_K0: "ndepth (Abs_Node(%k. Inr 0, x)) = 0"
  23.254 +by (simp add: ndepth_def  Node_K0_I [THEN Abs_Node_inverse] Least_equality)
  23.255 +
  23.256 +lemma ndepth_Push_Node_aux:
  23.257 +     "case_nat (Inr (Suc i)) f k = Inr 0 --> Suc(LEAST x. f x = Inr 0) <= k"
  23.258 +apply (induct_tac "k", auto)
  23.259 +apply (erule Least_le)
  23.260 +done
  23.261 +
  23.262 +lemma ndepth_Push_Node: 
  23.263 +    "ndepth (Push_Node (Inr (Suc i)) n) = Suc(ndepth(n))"
  23.264 +apply (insert Rep_Node [of n, unfolded Node_def])
  23.265 +apply (auto simp add: ndepth_def Push_Node_def
  23.266 +                 Rep_Node [THEN Node_Push_I, THEN Abs_Node_inverse])
  23.267 +apply (rule Least_equality)
  23.268 +apply (auto simp add: Push_def ndepth_Push_Node_aux)
  23.269 +apply (erule LeastI)
  23.270 +done
  23.271 +
  23.272 +
  23.273 +(*** ntrunc applied to the various node sets ***)
  23.274 +
  23.275 +lemma ntrunc_0 [simp]: "ntrunc 0 M = {}"
  23.276 +by (simp add: ntrunc_def)
  23.277 +
  23.278 +lemma ntrunc_Atom [simp]: "ntrunc (Suc k) (Atom a) = Atom(a)"
  23.279 +by (auto simp add: Atom_def ntrunc_def ndepth_K0)
  23.280 +
  23.281 +lemma ntrunc_Leaf [simp]: "ntrunc (Suc k) (Leaf a) = Leaf(a)"
  23.282 +unfolding Leaf_def o_def by (rule ntrunc_Atom)
  23.283 +
  23.284 +lemma ntrunc_Numb [simp]: "ntrunc (Suc k) (Numb i) = Numb(i)"
  23.285 +unfolding Numb_def o_def by (rule ntrunc_Atom)
  23.286 +
  23.287 +lemma ntrunc_Scons [simp]: 
  23.288 +    "ntrunc (Suc k) (Scons M N) = Scons (ntrunc k M) (ntrunc k N)"
  23.289 +unfolding Scons_def ntrunc_def One_nat_def
  23.290 +by (auto simp add: ndepth_Push_Node)
  23.291 +
  23.292 +
  23.293 +
  23.294 +(** Injection nodes **)
  23.295 +
  23.296 +lemma ntrunc_one_In0 [simp]: "ntrunc (Suc 0) (In0 M) = {}"
  23.297 +apply (simp add: In0_def)
  23.298 +apply (simp add: Scons_def)
  23.299 +done
  23.300 +
  23.301 +lemma ntrunc_In0 [simp]: "ntrunc (Suc(Suc k)) (In0 M) = In0 (ntrunc (Suc k) M)"
  23.302 +by (simp add: In0_def)
  23.303 +
  23.304 +lemma ntrunc_one_In1 [simp]: "ntrunc (Suc 0) (In1 M) = {}"
  23.305 +apply (simp add: In1_def)
  23.306 +apply (simp add: Scons_def)
  23.307 +done
  23.308 +
  23.309 +lemma ntrunc_In1 [simp]: "ntrunc (Suc(Suc k)) (In1 M) = In1 (ntrunc (Suc k) M)"
  23.310 +by (simp add: In1_def)
  23.311 +
  23.312 +
  23.313 +subsection{*Set Constructions*}
  23.314 +
  23.315 +
  23.316 +(*** Cartesian Product ***)
  23.317 +
  23.318 +lemma uprodI [intro!]: "[| M:A;  N:B |] ==> Scons M N : uprod A B"
  23.319 +by (simp add: uprod_def)
  23.320 +
  23.321 +(*The general elimination rule*)
  23.322 +lemma uprodE [elim!]:
  23.323 +    "[| c : uprod A B;   
  23.324 +        !!x y. [| x:A;  y:B;  c = Scons x y |] ==> P  
  23.325 +     |] ==> P"
  23.326 +by (auto simp add: uprod_def) 
  23.327 +
  23.328 +
  23.329 +(*Elimination of a pair -- introduces no eigenvariables*)
  23.330 +lemma uprodE2: "[| Scons M N : uprod A B;  [| M:A;  N:B |] ==> P |] ==> P"
  23.331 +by (auto simp add: uprod_def)
  23.332 +
  23.333 +
  23.334 +(*** Disjoint Sum ***)
  23.335 +
  23.336 +lemma usum_In0I [intro]: "M:A ==> In0(M) : usum A B"
  23.337 +by (simp add: usum_def)
  23.338 +
  23.339 +lemma usum_In1I [intro]: "N:B ==> In1(N) : usum A B"
  23.340 +by (simp add: usum_def)
  23.341 +
  23.342 +lemma usumE [elim!]: 
  23.343 +    "[| u : usum A B;   
  23.344 +        !!x. [| x:A;  u=In0(x) |] ==> P;  
  23.345 +        !!y. [| y:B;  u=In1(y) |] ==> P  
  23.346 +     |] ==> P"
  23.347 +by (auto simp add: usum_def)
  23.348 +
  23.349 +
  23.350 +(** Injection **)
  23.351 +
  23.352 +lemma In0_not_In1 [iff]: "In0(M) \<noteq> In1(N)"
  23.353 +unfolding In0_def In1_def One_nat_def by auto
  23.354 +
  23.355 +lemmas In1_not_In0 [iff] = In0_not_In1 [THEN not_sym]
  23.356 +
  23.357 +lemma In0_inject: "In0(M) = In0(N) ==>  M=N"
  23.358 +by (simp add: In0_def)
  23.359 +
  23.360 +lemma In1_inject: "In1(M) = In1(N) ==>  M=N"
  23.361 +by (simp add: In1_def)
  23.362 +
  23.363 +lemma In0_eq [iff]: "(In0 M = In0 N) = (M=N)"
  23.364 +by (blast dest!: In0_inject)
  23.365 +
  23.366 +lemma In1_eq [iff]: "(In1 M = In1 N) = (M=N)"
  23.367 +by (blast dest!: In1_inject)
  23.368 +
  23.369 +lemma inj_In0: "inj In0"
  23.370 +by (blast intro!: inj_onI)
  23.371 +
  23.372 +lemma inj_In1: "inj In1"
  23.373 +by (blast intro!: inj_onI)
  23.374 +
  23.375 +
  23.376 +(*** Function spaces ***)
  23.377 +
  23.378 +lemma Lim_inject: "Lim f = Lim g ==> f = g"
  23.379 +apply (simp add: Lim_def)
  23.380 +apply (rule ext)
  23.381 +apply (blast elim!: Push_Node_inject)
  23.382 +done
  23.383 +
  23.384 +
  23.385 +(*** proving equality of sets and functions using ntrunc ***)
  23.386 +
  23.387 +lemma ntrunc_subsetI: "ntrunc k M <= M"
  23.388 +by (auto simp add: ntrunc_def)
  23.389 +
  23.390 +lemma ntrunc_subsetD: "(!!k. ntrunc k M <= N) ==> M<=N"
  23.391 +by (auto simp add: ntrunc_def)
  23.392 +
  23.393 +(*A generalized form of the take-lemma*)
  23.394 +lemma ntrunc_equality: "(!!k. ntrunc k M = ntrunc k N) ==> M=N"
  23.395 +apply (rule equalityI)
  23.396 +apply (rule_tac [!] ntrunc_subsetD)
  23.397 +apply (rule_tac [!] ntrunc_subsetI [THEN [2] subset_trans], auto) 
  23.398 +done
  23.399 +
  23.400 +lemma ntrunc_o_equality: 
  23.401 +    "[| !!k. (ntrunc(k) o h1) = (ntrunc(k) o h2) |] ==> h1=h2"
  23.402 +apply (rule ntrunc_equality [THEN ext])
  23.403 +apply (simp add: fun_eq_iff) 
  23.404 +done
  23.405 +
  23.406 +
  23.407 +(*** Monotonicity ***)
  23.408 +
  23.409 +lemma uprod_mono: "[| A<=A';  B<=B' |] ==> uprod A B <= uprod A' B'"
  23.410 +by (simp add: uprod_def, blast)
  23.411 +
  23.412 +lemma usum_mono: "[| A<=A';  B<=B' |] ==> usum A B <= usum A' B'"
  23.413 +by (simp add: usum_def, blast)
  23.414 +
  23.415 +lemma Scons_mono: "[| M<=M';  N<=N' |] ==> Scons M N <= Scons M' N'"
  23.416 +by (simp add: Scons_def, blast)
  23.417 +
  23.418 +lemma In0_mono: "M<=N ==> In0(M) <= In0(N)"
  23.419 +by (simp add: In0_def Scons_mono)
  23.420 +
  23.421 +lemma In1_mono: "M<=N ==> In1(M) <= In1(N)"
  23.422 +by (simp add: In1_def Scons_mono)
  23.423 +
  23.424 +
  23.425 +(*** Split and Case ***)
  23.426 +
  23.427 +lemma Split [simp]: "Split c (Scons M N) = c M N"
  23.428 +by (simp add: Split_def)
  23.429 +
  23.430 +lemma Case_In0 [simp]: "Case c d (In0 M) = c(M)"
  23.431 +by (simp add: Case_def)
  23.432 +
  23.433 +lemma Case_In1 [simp]: "Case c d (In1 N) = d(N)"
  23.434 +by (simp add: Case_def)
  23.435 +
  23.436 +
  23.437 +
  23.438 +(**** UN x. B(x) rules ****)
  23.439 +
  23.440 +lemma ntrunc_UN1: "ntrunc k (UN x. f(x)) = (UN x. ntrunc k (f x))"
  23.441 +by (simp add: ntrunc_def, blast)
  23.442 +
  23.443 +lemma Scons_UN1_x: "Scons (UN x. f x) M = (UN x. Scons (f x) M)"
  23.444 +by (simp add: Scons_def, blast)
  23.445 +
  23.446 +lemma Scons_UN1_y: "Scons M (UN x. f x) = (UN x. Scons M (f x))"
  23.447 +by (simp add: Scons_def, blast)
  23.448 +
  23.449 +lemma In0_UN1: "In0(UN x. f(x)) = (UN x. In0(f(x)))"
  23.450 +by (simp add: In0_def Scons_UN1_y)
  23.451 +
  23.452 +lemma In1_UN1: "In1(UN x. f(x)) = (UN x. In1(f(x)))"
  23.453 +by (simp add: In1_def Scons_UN1_y)
  23.454 +
  23.455 +
  23.456 +(*** Equality for Cartesian Product ***)
  23.457 +
  23.458 +lemma dprodI [intro!]: 
  23.459 +    "[| (M,M'):r;  (N,N'):s |] ==> (Scons M N, Scons M' N') : dprod r s"
  23.460 +by (auto simp add: dprod_def)
  23.461 +
  23.462 +(*The general elimination rule*)
  23.463 +lemma dprodE [elim!]: 
  23.464 +    "[| c : dprod r s;   
  23.465 +        !!x y x' y'. [| (x,x') : r;  (y,y') : s;  
  23.466 +                        c = (Scons x y, Scons x' y') |] ==> P  
  23.467 +     |] ==> P"
  23.468 +by (auto simp add: dprod_def)
  23.469 +
  23.470 +
  23.471 +(*** Equality for Disjoint Sum ***)
  23.472 +
  23.473 +lemma dsum_In0I [intro]: "(M,M'):r ==> (In0(M), In0(M')) : dsum r s"
  23.474 +by (auto simp add: dsum_def)
  23.475 +
  23.476 +lemma dsum_In1I [intro]: "(N,N'):s ==> (In1(N), In1(N')) : dsum r s"
  23.477 +by (auto simp add: dsum_def)
  23.478 +
  23.479 +lemma dsumE [elim!]: 
  23.480 +    "[| w : dsum r s;   
  23.481 +        !!x x'. [| (x,x') : r;  w = (In0(x), In0(x')) |] ==> P;  
  23.482 +        !!y y'. [| (y,y') : s;  w = (In1(y), In1(y')) |] ==> P  
  23.483 +     |] ==> P"
  23.484 +by (auto simp add: dsum_def)
  23.485 +
  23.486 +
  23.487 +(*** Monotonicity ***)
  23.488 +
  23.489 +lemma dprod_mono: "[| r<=r';  s<=s' |] ==> dprod r s <= dprod r' s'"
  23.490 +by blast
  23.491 +
  23.492 +lemma dsum_mono: "[| r<=r';  s<=s' |] ==> dsum r s <= dsum r' s'"
  23.493 +by blast
  23.494 +
  23.495 +
  23.496 +(*** Bounding theorems ***)
  23.497 +
  23.498 +lemma dprod_Sigma: "(dprod (A <*> B) (C <*> D)) <= (uprod A C) <*> (uprod B D)"
  23.499 +by blast
  23.500 +
  23.501 +lemmas dprod_subset_Sigma = subset_trans [OF dprod_mono dprod_Sigma]
  23.502 +
  23.503 +(*Dependent version*)
  23.504 +lemma dprod_subset_Sigma2:
  23.505 +    "(dprod (Sigma A B) (Sigma C D)) <= Sigma (uprod A C) (Split (%x y. uprod (B x) (D y)))"
  23.506 +by auto
  23.507 +
  23.508 +lemma dsum_Sigma: "(dsum (A <*> B) (C <*> D)) <= (usum A C) <*> (usum B D)"
  23.509 +by blast
  23.510 +
  23.511 +lemmas dsum_subset_Sigma = subset_trans [OF dsum_mono dsum_Sigma]
  23.512 +
  23.513 +
  23.514 +text {* hides popular names *}
  23.515 +hide_type (open) node item
  23.516 +hide_const (open) Push Node Atom Leaf Numb Lim Split Case
  23.517 +
  23.518 +ML_file "Tools/Old_Datatype/old_datatype.ML"
  23.519 +
  23.520 +ML_file "Tools/inductive_realizer.ML"
  23.521 +setup InductiveRealizer.setup
  23.522 +
  23.523 +ML_file "Tools/Old_Datatype/old_datatype_realizer.ML"
  23.524 +setup Old_Datatype_Realizer.setup
  23.525 +
  23.526 +end
    24.1 --- a/src/HOL/Option.thy	Mon Sep 01 16:17:46 2014 +0200
    24.2 +++ b/src/HOL/Option.thy	Mon Sep 01 16:17:46 2014 +0200
    24.3 @@ -5,7 +5,7 @@
    24.4  header {* Datatype option *}
    24.5  
    24.6  theory Option
    24.7 -imports BNF_LFP Datatype Finite_Set
    24.8 +imports BNF_LFP Old_Datatype Finite_Set
    24.9  begin
   24.10  
   24.11  datatype_new 'a option =
    25.1 --- a/src/HOL/SPARK/Tools/spark_vcs.ML	Mon Sep 01 16:17:46 2014 +0200
    25.2 +++ b/src/HOL/SPARK/Tools/spark_vcs.ML	Mon Sep 01 16:17:46 2014 +0200
    25.3 @@ -173,8 +173,8 @@
    25.4  
    25.5  fun add_enum_type tyname tyname' thy =
    25.6    let
    25.7 -    val {case_name, ...} = the (Datatype_Data.get_info thy tyname');
    25.8 -    val cs = map Const (the (Datatype_Data.get_constrs thy tyname'));
    25.9 +    val {case_name, ...} = the (Old_Datatype_Data.get_info thy tyname');
   25.10 +    val cs = map Const (the (Old_Datatype_Data.get_constrs thy tyname'));
   25.11      val k = length cs;
   25.12      val T = Type (tyname', []);
   25.13      val p = Const (@{const_name pos}, T --> HOLogic.intT);
   25.14 @@ -209,7 +209,7 @@
   25.15        (fn _ =>
   25.16           rtac @{thm subset_antisym} 1 THEN
   25.17           rtac @{thm subsetI} 1 THEN
   25.18 -         Datatype_Aux.exh_tac (K (#exhaust (Datatype_Data.the_info
   25.19 +         Old_Datatype_Aux.exh_tac (K (#exhaust (Old_Datatype_Data.the_info
   25.20             (Proof_Context.theory_of lthy) tyname'))) 1 THEN
   25.21           ALLGOALS (asm_full_simp_tac lthy));
   25.22  
   25.23 @@ -320,14 +320,14 @@
   25.24                  val tyname = Sign.full_name thy tyb
   25.25                in
   25.26                  (thy |>
   25.27 -                 Datatype.add_datatype {strict = true, quiet = true}
   25.28 +                 Old_Datatype.add_datatype {strict = true, quiet = true}
   25.29                     [((tyb, [], NoSyn),
   25.30                       map (fn s => (Binding.name s, [], NoSyn)) els)] |> snd |>
   25.31                   add_enum_type s tyname,
   25.32                   tyname)
   25.33                end
   25.34            | SOME (T as Type (tyname, []), cmap) =>
   25.35 -              (case Datatype_Data.get_constrs thy tyname of
   25.36 +              (case Old_Datatype_Data.get_constrs thy tyname of
   25.37                   NONE => assoc_ty_err thy T s "is not a datatype"
   25.38                 | SOME cs =>
   25.39                     let val (prfx', _) = strip_prfx s
   25.40 @@ -338,7 +338,7 @@
   25.41                       | SOME msg => assoc_ty_err thy T s msg
   25.42                     end)
   25.43            | SOME (T, _) => assoc_ty_err thy T s "is not a datatype");
   25.44 -        val cs = map Const (the (Datatype_Data.get_constrs thy' tyname));
   25.45 +        val cs = map Const (the (Old_Datatype_Data.get_constrs thy' tyname));
   25.46        in
   25.47          ((fold (Symtab.update_new o apsnd (rpair s)) (els ~~ cs) tab,
   25.48            fold Name.declare els ctxt),
   25.49 @@ -888,7 +888,7 @@
   25.50                  handle Symtab.DUP _ => error ("SPARK type " ^ s ^
   25.51                    " already associated with type")) |>
   25.52          (fn thy' =>
   25.53 -           case Datatype_Data.get_constrs thy' tyname of
   25.54 +           case Old_Datatype_Data.get_constrs thy' tyname of
   25.55               NONE => (case get_record_info thy' T of
   25.56                 NONE => thy'
   25.57               | SOME {fields, ...} =>
    26.1 --- a/src/HOL/Statespace/state_fun.ML	Mon Sep 01 16:17:46 2014 +0200
    26.2 +++ b/src/HOL/Statespace/state_fun.ML	Mon Sep 01 16:17:46 2014 +0200
    26.3 @@ -339,7 +339,7 @@
    26.4    | mkName (TFree (x,_)) = mkUpper (Long_Name.base_name x)
    26.5    | mkName (TVar ((x,_),_)) = mkUpper (Long_Name.base_name x);
    26.6  
    26.7 -fun is_datatype thy = is_some o Datatype_Data.get_info thy;
    26.8 +fun is_datatype thy = is_some o Old_Datatype_Data.get_info thy;
    26.9  
   26.10  fun mk_map @{type_name List.list} = Syntax.const @{const_name List.map}
   26.11    | mk_map n = Syntax.const ("StateFun.map_" ^ Long_Name.base_name n);
    27.1 --- a/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML	Mon Sep 01 16:17:46 2014 +0200
    27.2 +++ b/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML	Mon Sep 01 16:17:46 2014 +0200
    27.3 @@ -1210,7 +1210,7 @@
    27.4                 is_some (fp_sugar_of no_defs_lthy bad_tc) then
    27.5                error ("Inadmissible " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^
    27.6                  " in type expression " ^ fake_T_backdrop)
    27.7 -            else if is_some (Datatype_Data.get_info (Proof_Context.theory_of no_defs_lthy)
    27.8 +            else if is_some (Old_Datatype_Data.get_info (Proof_Context.theory_of no_defs_lthy)
    27.9                  bad_tc) then
   27.10                error ("Unsupported " ^ co_prefix fp ^ "recursive occurrence of type " ^ fake_T ^
   27.11                  " via the old-style datatype " ^ quote bad_tc ^ " in type expression " ^
    28.1 --- a/src/HOL/Tools/BNF/bnf_fp_n2m_sugar.ML	Mon Sep 01 16:17:46 2014 +0200
    28.2 +++ b/src/HOL/Tools/BNF/bnf_fp_n2m_sugar.ML	Mon Sep 01 16:17:46 2014 +0200
    28.3 @@ -329,7 +329,7 @@
    28.4      fun not_co_datatype0 T = error (qsoty T ^ " is not a " ^ co_prefix fp ^ "datatype");
    28.5      fun not_co_datatype (T as Type (s, _)) =
    28.6          if fp = Least_FP andalso
    28.7 -           is_some (Datatype_Data.get_info (Proof_Context.theory_of lthy) s) then
    28.8 +           is_some (Old_Datatype_Data.get_info (Proof_Context.theory_of lthy) s) then
    28.9            error (qsoty T ^ " is not a new-style datatype (cf. \"datatype_new\")")
   28.10          else
   28.11            not_co_datatype0 T
    29.1 --- a/src/HOL/Tools/BNF/bnf_lfp_compat.ML	Mon Sep 01 16:17:46 2014 +0200
    29.2 +++ b/src/HOL/Tools/BNF/bnf_lfp_compat.ML	Mon Sep 01 16:17:46 2014 +0200
    29.3 @@ -28,8 +28,9 @@
    29.4      val kks = map fst desc;
    29.5      val perm_kks = sort int_ord kks;
    29.6  
    29.7 -    fun perm_dtyp (Datatype_Aux.DtType (s, Ds)) = Datatype_Aux.DtType (s, map perm_dtyp Ds)
    29.8 -      | perm_dtyp (Datatype_Aux.DtRec kk) = Datatype_Aux.DtRec (find_index (curry (op =) kk) kks)
    29.9 +    fun perm_dtyp (Old_Datatype_Aux.DtType (s, Ds)) = Old_Datatype_Aux.DtType (s, map perm_dtyp Ds)
   29.10 +      | perm_dtyp (Old_Datatype_Aux.DtRec kk) =
   29.11 +        Old_Datatype_Aux.DtRec (find_index (curry (op =) kk) kks)
   29.12        | perm_dtyp D = D
   29.13    in
   29.14      if perm_kks = kks then
   29.15 @@ -68,7 +69,7 @@
   29.16  
   29.17      val nn_fp = length fpTs;
   29.18  
   29.19 -    val mk_dtyp = Datatype_Aux.dtyp_of_typ (map (apsnd (map Term.dest_TFree) o dest_Type) fpTs);
   29.20 +    val mk_dtyp = Old_Datatype_Aux.dtyp_of_typ (map (apsnd (map Term.dest_TFree) o dest_Type) fpTs);
   29.21  
   29.22      fun mk_ctr_descr Ts = mk_ctr Ts #> dest_Const ##> (binder_types #> map mk_dtyp);
   29.23      fun mk_typ_descr index (Type (T_name, Ts)) ({ctrs, ...} : ctr_sugar) =
   29.24 @@ -76,9 +77,9 @@
   29.25  
   29.26      val fp_ctr_sugars = map (#ctr_sugar o lfp_sugar_of) fpT_names;
   29.27      val orig_descr = map3 mk_typ_descr (0 upto nn_fp - 1) fpTs fp_ctr_sugars;
   29.28 -    val all_infos = Datatype_Data.get_all thy;
   29.29 +    val all_infos = Old_Datatype_Data.get_all thy;
   29.30      val (orig_descr' :: nested_descrs, _) =
   29.31 -      Datatype_Aux.unfold_datatypes lthy orig_descr all_infos orig_descr nn_fp;
   29.32 +      Old_Datatype_Aux.unfold_datatypes lthy orig_descr all_infos orig_descr nn_fp;
   29.33  
   29.34      fun cliquify_descr [] = []
   29.35        | cliquify_descr [entry] = [[entry]]
   29.36 @@ -90,7 +91,7 @@
   29.37              else
   29.38                (case Symtab.lookup all_infos T_name1 of
   29.39                  SOME {descr, ...} =>
   29.40 -                length (filter_out (exists Datatype_Aux.is_rec_type o #2 o snd) descr)
   29.41 +                length (filter_out (exists Old_Datatype_Aux.is_rec_type o #2 o snd) descr)
   29.42                | NONE => raise Fail "unknown old-style datatype");
   29.43          in
   29.44            chop nn full_descr ||> cliquify_descr |> op ::
   29.45 @@ -102,15 +103,15 @@
   29.46        split_list (flat (map_index (fn (i, descr) => map (pair i) descr)
   29.47          (maps cliquify_descr descrs)));
   29.48  
   29.49 -    val dest_dtyp = Datatype_Aux.typ_of_dtyp descr;
   29.50 +    val dest_dtyp = Old_Datatype_Aux.typ_of_dtyp descr;
   29.51  
   29.52 -    val Ts = Datatype_Aux.get_rec_types descr;
   29.53 +    val Ts = Old_Datatype_Aux.get_rec_types descr;
   29.54      val nn = length Ts;
   29.55  
   29.56      val fp_sugars0 = map (lfp_sugar_of o fst o dest_Type) Ts;
   29.57      val ctr_Tsss = map (map (map dest_dtyp o snd) o #3 o snd) descr;
   29.58      val kkssss =
   29.59 -      map (map (map (fn Datatype_Aux.DtRec kk => [kk] | _ => []) o snd) o #3 o snd) descr;
   29.60 +      map (map (map (fn Old_Datatype_Aux.DtRec kk => [kk] | _ => []) o snd) o #3 o snd) descr;
   29.61  
   29.62      val callers = map (fn kk => Var ((Name.uu, kk), @{typ "unit => unit"})) (0 upto nn - 1);
   29.63  
   29.64 @@ -175,8 +176,8 @@
   29.65          end);
   29.66  
   29.67      val register_interpret =
   29.68 -      Datatype_Data.register infos
   29.69 -      #> Datatype_Data.interpretation_data (Datatype_Aux.default_config, map fst infos)
   29.70 +      Old_Datatype_Data.register infos
   29.71 +      #> Old_Datatype_Data.interpretation_data (Old_Datatype_Aux.default_config, map fst infos)
   29.72    in
   29.73      lthy
   29.74      |> Local_Theory.raw_theory register_interpret
    30.1 --- a/src/HOL/Tools/BNF/bnf_lfp_rec_sugar.ML	Mon Sep 01 16:17:46 2014 +0200
    30.2 +++ b/src/HOL/Tools/BNF/bnf_lfp_rec_sugar.ML	Mon Sep 01 16:17:46 2014 +0200
    30.3 @@ -444,7 +444,7 @@
    30.4        |> map (maps (map_filter (find_rec_calls has_call)));
    30.5  
    30.6      fun is_only_old_datatype (Type (s, _)) =
    30.7 -        is_some (Datatype_Data.get_info thy s) andalso not (is_new_datatype lthy0 s)
    30.8 +        is_some (Old_Datatype_Data.get_info thy s) andalso not (is_new_datatype lthy0 s)
    30.9        | is_only_old_datatype _ = false;
   30.10  
   30.11      val _ = if exists is_only_old_datatype arg_Ts then raise OLD_PRIMREC () else ();
   30.12 @@ -561,8 +561,8 @@
   30.13    end
   30.14    handle OLD_PRIMREC () => old_primrec raw_fixes raw_specs lthy |>> apsnd single;
   30.15  
   30.16 -val add_primrec = gen_primrec Primrec.add_primrec Specification.check_spec [];
   30.17 -val add_primrec_cmd = gen_primrec Primrec.add_primrec_cmd Specification.read_spec;
   30.18 +val add_primrec = gen_primrec Old_Primrec.add_primrec Specification.check_spec [];
   30.19 +val add_primrec_cmd = gen_primrec Old_Primrec.add_primrec_cmd Specification.read_spec;
   30.20  
   30.21  fun add_primrec_global fixes specs =
   30.22    Named_Target.theory_init
    31.1 --- a/src/HOL/Tools/Datatype/datatype.ML	Mon Sep 01 16:17:46 2014 +0200
    31.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    31.3 @@ -1,799 +0,0 @@
    31.4 -(*  Title:      HOL/Tools/Datatype/datatype.ML
    31.5 -    Author:     Stefan Berghofer, TU Muenchen
    31.6 -
    31.7 -Datatype package: definitional introduction of datatypes
    31.8 -with proof of characteristic theorems: injectivity / distinctness
    31.9 -of constructors and induction.  Main interface to datatypes
   31.10 -after full bootstrap of datatype package.
   31.11 -*)
   31.12 -
   31.13 -signature DATATYPE =
   31.14 -sig
   31.15 -  val distinct_lemma: thm
   31.16 -  type spec =
   31.17 -    (binding * (string * sort) list * mixfix) *
   31.18 -    (binding * typ list * mixfix) list
   31.19 -  type spec_cmd =
   31.20 -    (binding * (string * string option) list * mixfix) *
   31.21 -    (binding * string list * mixfix) list
   31.22 -  val read_specs: spec_cmd list -> theory -> spec list * Proof.context
   31.23 -  val check_specs: spec list -> theory -> spec list * Proof.context
   31.24 -  val add_datatype: Datatype_Aux.config -> spec list -> theory -> string list * theory
   31.25 -  val add_datatype_cmd: Datatype_Aux.config -> spec_cmd list -> theory -> string list * theory
   31.26 -  val spec_cmd: spec_cmd parser
   31.27 -end;
   31.28 -
   31.29 -structure Datatype : DATATYPE =
   31.30 -struct
   31.31 -
   31.32 -(** auxiliary **)
   31.33 -
   31.34 -val distinct_lemma = @{lemma "f x \<noteq> f y ==> x \<noteq> y" by iprover};
   31.35 -val (_ $ (_ $ (_ $ (distinct_f $ _) $ _))) = hd (prems_of distinct_lemma);
   31.36 -
   31.37 -fun exh_thm_of (dt_info : Datatype_Aux.info Symtab.table) tname =
   31.38 -  #exhaust (the (Symtab.lookup dt_info tname));
   31.39 -
   31.40 -val In0_inject = @{thm In0_inject};
   31.41 -val In1_inject = @{thm In1_inject};
   31.42 -val Scons_inject = @{thm Scons_inject};
   31.43 -val Leaf_inject = @{thm Leaf_inject};
   31.44 -val In0_eq = @{thm In0_eq};
   31.45 -val In1_eq = @{thm In1_eq};
   31.46 -val In0_not_In1 = @{thm In0_not_In1};
   31.47 -val In1_not_In0 = @{thm In1_not_In0};
   31.48 -val Lim_inject = @{thm Lim_inject};
   31.49 -val Inl_inject = @{thm Inl_inject};
   31.50 -val Inr_inject = @{thm Inr_inject};
   31.51 -val Suml_inject = @{thm Suml_inject};
   31.52 -val Sumr_inject = @{thm Sumr_inject};
   31.53 -
   31.54 -val datatype_injI =
   31.55 -  @{lemma "(!!x. ALL y. f x = f y --> x = y) ==> inj f" by (simp add: inj_on_def)};
   31.56 -
   31.57 -
   31.58 -(** proof of characteristic theorems **)
   31.59 -
   31.60 -fun representation_proofs (config : Datatype_Aux.config) (dt_info : Datatype_Aux.info Symtab.table)
   31.61 -    descr types_syntax constr_syntax case_names_induct thy =
   31.62 -  let
   31.63 -    val descr' = flat descr;
   31.64 -    val new_type_names = map (Binding.name_of o fst) types_syntax;
   31.65 -    val big_name = space_implode "_" new_type_names;
   31.66 -    val thy1 = Sign.add_path big_name thy;
   31.67 -    val big_rec_name = "rep_set_" ^ big_name;
   31.68 -    val rep_set_names' =
   31.69 -      if length descr' = 1 then [big_rec_name]
   31.70 -      else map (prefix (big_rec_name ^ "_") o string_of_int) (1 upto length descr');
   31.71 -    val rep_set_names = map (Sign.full_bname thy1) rep_set_names';
   31.72 -
   31.73 -    val tyvars = map (fn (_, (_, Ts, _)) => map Datatype_Aux.dest_DtTFree Ts) (hd descr);
   31.74 -    val leafTs' = Datatype_Aux.get_nonrec_types descr';
   31.75 -    val branchTs = Datatype_Aux.get_branching_types descr';
   31.76 -    val branchT =
   31.77 -      if null branchTs then HOLogic.unitT
   31.78 -      else Balanced_Tree.make (fn (T, U) => Type (@{type_name Sum_Type.sum}, [T, U])) branchTs;
   31.79 -    val arities = remove (op =) 0 (Datatype_Aux.get_arities descr');
   31.80 -    val unneeded_vars =
   31.81 -      subtract (op =) (fold Term.add_tfreesT (leafTs' @ branchTs) []) (hd tyvars);
   31.82 -    val leafTs = leafTs' @ map TFree unneeded_vars;
   31.83 -    val recTs = Datatype_Aux.get_rec_types descr';
   31.84 -    val (newTs, oldTs) = chop (length (hd descr)) recTs;
   31.85 -    val sumT =
   31.86 -      if null leafTs then HOLogic.unitT
   31.87 -      else Balanced_Tree.make (fn (T, U) => Type (@{type_name Sum_Type.sum}, [T, U])) leafTs;
   31.88 -    val Univ_elT = HOLogic.mk_setT (Type (@{type_name Datatype.node}, [sumT, branchT]));
   31.89 -    val UnivT = HOLogic.mk_setT Univ_elT;
   31.90 -    val UnivT' = Univ_elT --> HOLogic.boolT;
   31.91 -    val Collect = Const (@{const_name Collect}, UnivT' --> UnivT);
   31.92 -
   31.93 -    val In0 = Const (@{const_name Datatype.In0}, Univ_elT --> Univ_elT);
   31.94 -    val In1 = Const (@{const_name Datatype.In1}, Univ_elT --> Univ_elT);
   31.95 -    val Leaf = Const (@{const_name Datatype.Leaf}, sumT --> Univ_elT);
   31.96 -    val Lim = Const (@{const_name Datatype.Lim}, (branchT --> Univ_elT) --> Univ_elT);
   31.97 -
   31.98 -    (* make injections needed for embedding types in leaves *)
   31.99 -
  31.100 -    fun mk_inj T' x =
  31.101 -      let
  31.102 -        fun mk_inj' T n i =
  31.103 -          if n = 1 then x
  31.104 -          else
  31.105 -            let
  31.106 -              val n2 = n div 2;
  31.107 -              val Type (_, [T1, T2]) = T;
  31.108 -            in
  31.109 -              if i <= n2
  31.110 -              then Const (@{const_name Inl}, T1 --> T) $ mk_inj' T1 n2 i
  31.111 -              else Const (@{const_name Inr}, T2 --> T) $ mk_inj' T2 (n - n2) (i - n2)
  31.112 -            end;
  31.113 -      in mk_inj' sumT (length leafTs) (1 + find_index (fn T'' => T'' = T') leafTs) end;
  31.114 -
  31.115 -    (* make injections for constructors *)
  31.116 -
  31.117 -    fun mk_univ_inj ts = Balanced_Tree.access
  31.118 -      {left = fn t => In0 $ t,
  31.119 -        right = fn t => In1 $ t,
  31.120 -        init =
  31.121 -          if ts = [] then Const (@{const_name undefined}, Univ_elT)
  31.122 -          else foldr1 (HOLogic.mk_binop @{const_name Datatype.Scons}) ts};
  31.123 -
  31.124 -    (* function spaces *)
  31.125 -
  31.126 -    fun mk_fun_inj T' x =
  31.127 -      let
  31.128 -        fun mk_inj T n i =
  31.129 -          if n = 1 then x
  31.130 -          else
  31.131 -            let
  31.132 -              val n2 = n div 2;
  31.133 -              val Type (_, [T1, T2]) = T;
  31.134 -              fun mkT U = (U --> Univ_elT) --> T --> Univ_elT;
  31.135 -            in
  31.136 -              if i <= n2 then Const (@{const_name Sum_Type.Suml}, mkT T1) $ mk_inj T1 n2 i
  31.137 -              else Const (@{const_name Sum_Type.Sumr}, mkT T2) $ mk_inj T2 (n - n2) (i - n2)
  31.138 -            end;
  31.139 -      in mk_inj branchT (length branchTs) (1 + find_index (fn T'' => T'' = T') branchTs) end;
  31.140 -
  31.141 -    fun mk_lim t Ts = fold_rev (fn T => fn t => Lim $ mk_fun_inj T (Abs ("x", T, t))) Ts t;
  31.142 -
  31.143 -    (************** generate introduction rules for representing set **********)
  31.144 -
  31.145 -    val _ = Datatype_Aux.message config "Constructing representing sets ...";
  31.146 -
  31.147 -    (* make introduction rule for a single constructor *)
  31.148 -
  31.149 -    fun make_intr s n (i, (_, cargs)) =
  31.150 -      let
  31.151 -        fun mk_prem dt (j, prems, ts) =
  31.152 -          (case Datatype_Aux.strip_dtyp dt of
  31.153 -            (dts, Datatype_Aux.DtRec k) =>
  31.154 -              let
  31.155 -                val Ts = map (Datatype_Aux.typ_of_dtyp descr') dts;
  31.156 -                val free_t =
  31.157 -                  Datatype_Aux.app_bnds (Datatype_Aux.mk_Free "x" (Ts ---> Univ_elT) j) (length Ts)
  31.158 -              in
  31.159 -                (j + 1, Logic.list_all (map (pair "x") Ts,
  31.160 -                  HOLogic.mk_Trueprop
  31.161 -                    (Free (nth rep_set_names' k, UnivT') $ free_t)) :: prems,
  31.162 -                mk_lim free_t Ts :: ts)
  31.163 -              end
  31.164 -          | _ =>
  31.165 -              let val T = Datatype_Aux.typ_of_dtyp descr' dt
  31.166 -              in (j + 1, prems, (Leaf $ mk_inj T (Datatype_Aux.mk_Free "x" T j)) :: ts) end);
  31.167 -
  31.168 -        val (_, prems, ts) = fold_rev mk_prem cargs (1, [], []);
  31.169 -        val concl = HOLogic.mk_Trueprop (Free (s, UnivT') $ mk_univ_inj ts n i);
  31.170 -      in Logic.list_implies (prems, concl) end;
  31.171 -
  31.172 -    val intr_ts = maps (fn ((_, (_, _, constrs)), rep_set_name) =>
  31.173 -      map (make_intr rep_set_name (length constrs))
  31.174 -        ((1 upto length constrs) ~~ constrs)) (descr' ~~ rep_set_names');
  31.175 -
  31.176 -    val ({raw_induct = rep_induct, intrs = rep_intrs, ...}, thy2) =
  31.177 -      thy1
  31.178 -      |> Sign.map_naming Name_Space.conceal
  31.179 -      |> Inductive.add_inductive_global
  31.180 -          {quiet_mode = #quiet config, verbose = false, alt_name = Binding.name big_rec_name,
  31.181 -           coind = false, no_elim = true, no_ind = false, skip_mono = true}
  31.182 -          (map (fn s => ((Binding.name s, UnivT'), NoSyn)) rep_set_names') []
  31.183 -          (map (fn x => (Attrib.empty_binding, x)) intr_ts) []
  31.184 -      ||> Sign.restore_naming thy1;
  31.185 -
  31.186 -    (********************************* typedef ********************************)
  31.187 -
  31.188 -    val (typedefs, thy3) = thy2
  31.189 -      |> Sign.parent_path
  31.190 -      |> fold_map
  31.191 -        (fn (((name, mx), tvs), c) =>
  31.192 -          Typedef.add_typedef_global (name, tvs, mx)
  31.193 -            (Collect $ Const (c, UnivT')) NONE
  31.194 -            (rtac exI 1 THEN rtac CollectI 1 THEN
  31.195 -              QUIET_BREADTH_FIRST (has_fewer_prems 1)
  31.196 -              (resolve_tac rep_intrs 1)))
  31.197 -        (types_syntax ~~ tyvars ~~ take (length newTs) rep_set_names)
  31.198 -      ||> Sign.add_path big_name;
  31.199 -
  31.200 -    (*********************** definition of constructors ***********************)
  31.201 -
  31.202 -    val big_rep_name = big_name ^ "_Rep_";
  31.203 -    val rep_names' = map (fn i => big_rep_name ^ string_of_int i) (1 upto length (flat (tl descr)));
  31.204 -    val all_rep_names =
  31.205 -      map (#Rep_name o #1 o #2) typedefs @
  31.206 -      map (Sign.full_bname thy3) rep_names';
  31.207 -
  31.208 -    (* isomorphism declarations *)
  31.209 -
  31.210 -    val iso_decls = map (fn (T, s) => (Binding.name s, T --> Univ_elT, NoSyn))
  31.211 -      (oldTs ~~ rep_names');
  31.212 -
  31.213 -    (* constructor definitions *)
  31.214 -
  31.215 -    fun make_constr_def (typedef: Typedef.info) T n
  31.216 -        ((cname, cargs), (cname', mx)) (thy, defs, eqns, i) =
  31.217 -      let
  31.218 -        fun constr_arg dt (j, l_args, r_args) =
  31.219 -          let
  31.220 -            val T = Datatype_Aux.typ_of_dtyp descr' dt;
  31.221 -            val free_t = Datatype_Aux.mk_Free "x" T j;
  31.222 -          in
  31.223 -            (case (Datatype_Aux.strip_dtyp dt, strip_type T) of
  31.224 -              ((_, Datatype_Aux.DtRec m), (Us, U)) =>
  31.225 -                (j + 1, free_t :: l_args, mk_lim
  31.226 -                  (Const (nth all_rep_names m, U --> Univ_elT) $
  31.227 -                    Datatype_Aux.app_bnds free_t (length Us)) Us :: r_args)
  31.228 -            | _ => (j + 1, free_t :: l_args, (Leaf $ mk_inj T free_t) :: r_args))
  31.229 -          end;
  31.230 -
  31.231 -        val (_, l_args, r_args) = fold_rev constr_arg cargs (1, [], []);
  31.232 -        val constrT = map (Datatype_Aux.typ_of_dtyp descr') cargs ---> T;
  31.233 -        val ({Abs_name, Rep_name, ...}, _) = typedef;
  31.234 -        val lhs = list_comb (Const (cname, constrT), l_args);
  31.235 -        val rhs = mk_univ_inj r_args n i;
  31.236 -        val def = Logic.mk_equals (lhs, Const (Abs_name, Univ_elT --> T) $ rhs);
  31.237 -        val def_name = Thm.def_name (Long_Name.base_name cname);
  31.238 -        val eqn =
  31.239 -          HOLogic.mk_Trueprop (HOLogic.mk_eq (Const (Rep_name, T --> Univ_elT) $ lhs, rhs));
  31.240 -        val ([def_thm], thy') =
  31.241 -          thy
  31.242 -          |> Sign.add_consts [(cname', constrT, mx)]
  31.243 -          |> (Global_Theory.add_defs false o map Thm.no_attributes) [(Binding.name def_name, def)];
  31.244 -
  31.245 -      in (thy', defs @ [def_thm], eqns @ [eqn], i + 1) end;
  31.246 -
  31.247 -    (* constructor definitions for datatype *)
  31.248 -
  31.249 -    fun dt_constr_defs (((((_, (_, _, constrs)), tname), typedef: Typedef.info), T), constr_syntax)
  31.250 -        (thy, defs, eqns, rep_congs, dist_lemmas) =
  31.251 -      let
  31.252 -        val _ $ (_ $ (cong_f $ _) $ _) = concl_of arg_cong;
  31.253 -        val rep_const = cterm_of thy (Const (#Rep_name (#1 typedef), T --> Univ_elT));
  31.254 -        val cong' = cterm_instantiate [(cterm_of thy cong_f, rep_const)] arg_cong;
  31.255 -        val dist = cterm_instantiate [(cterm_of thy distinct_f, rep_const)] distinct_lemma;
  31.256 -        val (thy', defs', eqns', _) =
  31.257 -          fold (make_constr_def typedef T (length constrs))
  31.258 -            (constrs ~~ constr_syntax) (Sign.add_path tname thy, defs, [], 1);
  31.259 -      in
  31.260 -        (Sign.parent_path thy', defs', eqns @ [eqns'],
  31.261 -          rep_congs @ [cong'], dist_lemmas @ [dist])
  31.262 -      end;
  31.263 -
  31.264 -    val (thy4, constr_defs, constr_rep_eqns, rep_congs, dist_lemmas) =
  31.265 -      fold dt_constr_defs
  31.266 -        (hd descr ~~ new_type_names ~~ map #2 typedefs ~~ newTs ~~ constr_syntax)
  31.267 -        (thy3 |> Sign.add_consts iso_decls |> Sign.parent_path, [], [], [], []);
  31.268 -
  31.269 -
  31.270 -    (*********** isomorphisms for new types (introduced by typedef) ***********)
  31.271 -
  31.272 -    val _ = Datatype_Aux.message config "Proving isomorphism properties ...";
  31.273 -
  31.274 -    val collect_simp = rewrite_rule (Proof_Context.init_global thy4) [mk_meta_eq mem_Collect_eq];
  31.275 -
  31.276 -    val newT_iso_axms = typedefs |> map (fn (_, (_, {Abs_inverse, Rep_inverse, Rep, ...})) =>
  31.277 -      (collect_simp Abs_inverse, Rep_inverse, collect_simp Rep));
  31.278 -
  31.279 -    val newT_iso_inj_thms = typedefs |> map (fn (_, (_, {Abs_inject, Rep_inject, ...})) =>
  31.280 -      (collect_simp Abs_inject RS iffD1, Rep_inject RS iffD1));
  31.281 -
  31.282 -    (********* isomorphisms between existing types and "unfolded" types *******)
  31.283 -
  31.284 -    (*---------------------------------------------------------------------*)
  31.285 -    (* isomorphisms are defined using primrec-combinators:                 *)
  31.286 -    (* generate appropriate functions for instantiating primrec-combinator *)
  31.287 -    (*                                                                     *)
  31.288 -    (*   e.g.  Rep_dt_i = list_rec ... (%h t y. In1 (Scons (Leaf h) y))    *)
  31.289 -    (*                                                                     *)
  31.290 -    (* also generate characteristic equations for isomorphisms             *)
  31.291 -    (*                                                                     *)
  31.292 -    (*   e.g.  Rep_dt_i (cons h t) = In1 (Scons (Rep_dt_j h) (Rep_dt_i t)) *)
  31.293 -    (*---------------------------------------------------------------------*)
  31.294 -
  31.295 -    fun make_iso_def k ks n (cname, cargs) (fs, eqns, i) =
  31.296 -      let
  31.297 -        val argTs = map (Datatype_Aux.typ_of_dtyp descr') cargs;
  31.298 -        val T = nth recTs k;
  31.299 -        val rep_const = Const (nth all_rep_names k, T --> Univ_elT);
  31.300 -        val constr = Const (cname, argTs ---> T);
  31.301 -
  31.302 -        fun process_arg ks' dt (i2, i2', ts, Ts) =
  31.303 -          let
  31.304 -            val T' = Datatype_Aux.typ_of_dtyp descr' dt;
  31.305 -            val (Us, U) = strip_type T'
  31.306 -          in
  31.307 -            (case Datatype_Aux.strip_dtyp dt of
  31.308 -              (_, Datatype_Aux.DtRec j) =>
  31.309 -                if member (op =) ks' j then
  31.310 -                  (i2 + 1, i2' + 1, ts @ [mk_lim (Datatype_Aux.app_bnds
  31.311 -                     (Datatype_Aux.mk_Free "y" (Us ---> Univ_elT) i2') (length Us)) Us],
  31.312 -                   Ts @ [Us ---> Univ_elT])
  31.313 -                else
  31.314 -                  (i2 + 1, i2', ts @ [mk_lim
  31.315 -                     (Const (nth all_rep_names j, U --> Univ_elT) $
  31.316 -                        Datatype_Aux.app_bnds (Datatype_Aux.mk_Free "x" T' i2) (length Us)) Us], Ts)
  31.317 -            | _ => (i2 + 1, i2', ts @ [Leaf $ mk_inj T' (Datatype_Aux.mk_Free "x" T' i2)], Ts))
  31.318 -          end;
  31.319 -
  31.320 -        val (i2, i2', ts, Ts) = fold (process_arg ks) cargs (1, 1, [], []);
  31.321 -        val xs = map (uncurry (Datatype_Aux.mk_Free "x")) (argTs ~~ (1 upto (i2 - 1)));
  31.322 -        val ys = map (uncurry (Datatype_Aux.mk_Free "y")) (Ts ~~ (1 upto (i2' - 1)));
  31.323 -        val f = fold_rev lambda (xs @ ys) (mk_univ_inj ts n i);
  31.324 -
  31.325 -        val (_, _, ts', _) = fold (process_arg []) cargs (1, 1, [], []);
  31.326 -        val eqn = HOLogic.mk_Trueprop (HOLogic.mk_eq
  31.327 -          (rep_const $ list_comb (constr, xs), mk_univ_inj ts' n i))
  31.328 -
  31.329 -      in (fs @ [f], eqns @ [eqn], i + 1) end;
  31.330 -
  31.331 -    (* define isomorphisms for all mutually recursive datatypes in list ds *)
  31.332 -
  31.333 -    fun make_iso_defs ds (thy, char_thms) =
  31.334 -      let
  31.335 -        val ks = map fst ds;
  31.336 -        val (_, (tname, _, _)) = hd ds;
  31.337 -        val {rec_rewrites, rec_names, ...} = the (Symtab.lookup dt_info tname);
  31.338 -
  31.339 -        fun process_dt (k, (_, _, constrs)) (fs, eqns, isos) =
  31.340 -          let
  31.341 -            val (fs', eqns', _) = fold (make_iso_def k ks (length constrs)) constrs (fs, eqns, 1);
  31.342 -            val iso = (nth recTs k, nth all_rep_names k);
  31.343 -          in (fs', eqns', isos @ [iso]) end;
  31.344 -
  31.345 -        val (fs, eqns, isos) = fold process_dt ds ([], [], []);
  31.346 -        val fTs = map fastype_of fs;
  31.347 -        val defs =
  31.348 -          map (fn (rec_name, (T, iso_name)) =>
  31.349 -            (Binding.name (Thm.def_name (Long_Name.base_name iso_name)),
  31.350 -              Logic.mk_equals (Const (iso_name, T --> Univ_elT),
  31.351 -                list_comb (Const (rec_name, fTs @ [T] ---> Univ_elT), fs)))) (rec_names ~~ isos);
  31.352 -        val (def_thms, thy') =
  31.353 -          (Global_Theory.add_defs false o map Thm.no_attributes) defs thy;
  31.354 -
  31.355 -        (* prove characteristic equations *)
  31.356 -
  31.357 -        val rewrites = def_thms @ map mk_meta_eq rec_rewrites;
  31.358 -        val char_thms' =
  31.359 -          map (fn eqn => Goal.prove_sorry_global thy' [] [] eqn
  31.360 -            (fn {context = ctxt, ...} => EVERY [rewrite_goals_tac ctxt rewrites, rtac refl 1])) eqns;
  31.361 -
  31.362 -      in (thy', char_thms' @ char_thms) end;
  31.363 -
  31.364 -    val (thy5, iso_char_thms) =
  31.365 -      fold_rev make_iso_defs (tl descr) (Sign.add_path big_name thy4, []);
  31.366 -
  31.367 -    (* prove isomorphism properties *)
  31.368 -
  31.369 -    fun mk_funs_inv thy thm =
  31.370 -      let
  31.371 -        val prop = Thm.prop_of thm;
  31.372 -        val _ $ (_ $ ((S as Const (_, Type (_, [U, _]))) $ _ )) $
  31.373 -          (_ $ (_ $ (r $ (a $ _)) $ _)) = Type.legacy_freeze prop;
  31.374 -        val used = Term.add_tfree_names a [];
  31.375 -
  31.376 -        fun mk_thm i =
  31.377 -          let
  31.378 -            val Ts = map (TFree o rpair @{sort type}) (Name.variant_list used (replicate i "'t"));
  31.379 -            val f = Free ("f", Ts ---> U);
  31.380 -          in
  31.381 -            Goal.prove_sorry_global thy [] []
  31.382 -              (Logic.mk_implies
  31.383 -                (HOLogic.mk_Trueprop (HOLogic.list_all
  31.384 -                   (map (pair "x") Ts, S $ Datatype_Aux.app_bnds f i)),
  31.385 -                 HOLogic.mk_Trueprop (HOLogic.mk_eq (fold_rev (Term.abs o pair "x") Ts
  31.386 -                   (r $ (a $ Datatype_Aux.app_bnds f i)), f))))
  31.387 -              (fn _ => EVERY [REPEAT_DETERM_N i (rtac @{thm ext} 1),
  31.388 -                 REPEAT (etac allE 1), rtac thm 1, atac 1])
  31.389 -          end
  31.390 -      in map (fn r => r RS subst) (thm :: map mk_thm arities) end;
  31.391 -
  31.392 -    (* prove  inj Rep_dt_i  and  Rep_dt_i x : rep_set_dt_i *)
  31.393 -
  31.394 -    val fun_congs =
  31.395 -      map (fn T => make_elim (Drule.instantiate' [SOME (ctyp_of thy5 T)] [] fun_cong)) branchTs;
  31.396 -
  31.397 -    fun prove_iso_thms ds (inj_thms, elem_thms) =
  31.398 -      let
  31.399 -        val (_, (tname, _, _)) = hd ds;
  31.400 -        val induct = #induct (the (Symtab.lookup dt_info tname));
  31.401 -
  31.402 -        fun mk_ind_concl (i, _) =
  31.403 -          let
  31.404 -            val T = nth recTs i;
  31.405 -            val Rep_t = Const (nth all_rep_names i, T --> Univ_elT);
  31.406 -            val rep_set_name = nth rep_set_names i;
  31.407 -            val concl1 =
  31.408 -              HOLogic.all_const T $ Abs ("y", T, HOLogic.imp $
  31.409 -                HOLogic.mk_eq (Rep_t $ Datatype_Aux.mk_Free "x" T i, Rep_t $ Bound 0) $
  31.410 -                  HOLogic.mk_eq (Datatype_Aux.mk_Free "x" T i, Bound 0));
  31.411 -            val concl2 = Const (rep_set_name, UnivT') $ (Rep_t $ Datatype_Aux.mk_Free "x" T i);
  31.412 -          in (concl1, concl2) end;
  31.413 -
  31.414 -        val (ind_concl1, ind_concl2) = split_list (map mk_ind_concl ds);
  31.415 -
  31.416 -        val rewrites = map mk_meta_eq iso_char_thms;
  31.417 -        val inj_thms' = map snd newT_iso_inj_thms @ map (fn r => r RS @{thm injD}) inj_thms;
  31.418 -
  31.419 -        val inj_thm =
  31.420 -          Goal.prove_sorry_global thy5 [] []
  31.421 -            (HOLogic.mk_Trueprop (Datatype_Aux.mk_conj ind_concl1))
  31.422 -            (fn {context = ctxt, ...} => EVERY
  31.423 -              [(Datatype_Aux.ind_tac induct [] THEN_ALL_NEW Object_Logic.atomize_prems_tac ctxt) 1,
  31.424 -               REPEAT (EVERY
  31.425 -                 [rtac allI 1, rtac impI 1,
  31.426 -                  Datatype_Aux.exh_tac (exh_thm_of dt_info) 1,
  31.427 -                  REPEAT (EVERY
  31.428 -                    [hyp_subst_tac ctxt 1,
  31.429 -                     rewrite_goals_tac ctxt rewrites,
  31.430 -                     REPEAT (dresolve_tac [In0_inject, In1_inject] 1),
  31.431 -                     (eresolve_tac [In0_not_In1 RS notE, In1_not_In0 RS notE] 1)
  31.432 -                     ORELSE (EVERY
  31.433 -                       [REPEAT (eresolve_tac (Scons_inject ::
  31.434 -                          map make_elim [Leaf_inject, Inl_inject, Inr_inject]) 1),
  31.435 -                        REPEAT (cong_tac 1), rtac refl 1,
  31.436 -                        REPEAT (atac 1 ORELSE (EVERY
  31.437 -                          [REPEAT (rtac @{thm ext} 1),
  31.438 -                           REPEAT (eresolve_tac (mp :: allE ::
  31.439 -                             map make_elim (Suml_inject :: Sumr_inject ::
  31.440 -                               Lim_inject :: inj_thms') @ fun_congs) 1),
  31.441 -                           atac 1]))])])])]);
  31.442 -
  31.443 -        val inj_thms'' = map (fn r => r RS datatype_injI) (Datatype_Aux.split_conj_thm inj_thm);
  31.444 -
  31.445 -        val elem_thm =
  31.446 -          Goal.prove_sorry_global thy5 [] []
  31.447 -            (HOLogic.mk_Trueprop (Datatype_Aux.mk_conj ind_concl2))
  31.448 -            (fn {context = ctxt, ...} =>
  31.449 -              EVERY [
  31.450 -                (Datatype_Aux.ind_tac induct [] THEN_ALL_NEW Object_Logic.atomize_prems_tac ctxt) 1,
  31.451 -                rewrite_goals_tac ctxt rewrites,
  31.452 -                REPEAT ((resolve_tac rep_intrs THEN_ALL_NEW
  31.453 -                  ((REPEAT o etac allE) THEN' ares_tac elem_thms)) 1)]);
  31.454 -
  31.455 -      in (inj_thms'' @ inj_thms, elem_thms @ Datatype_Aux.split_conj_thm elem_thm) end;
  31.456 -
  31.457 -    val (iso_inj_thms_unfolded, iso_elem_thms) =
  31.458 -      fold_rev prove_iso_thms (tl descr) ([], map #3 newT_iso_axms);
  31.459 -    val iso_inj_thms =
  31.460 -      map snd newT_iso_inj_thms @ map (fn r => r RS @{thm injD}) iso_inj_thms_unfolded;
  31.461 -
  31.462 -    (* prove  rep_set_dt_i x --> x : range Rep_dt_i *)
  31.463 -
  31.464 -    fun mk_iso_t (((set_name, iso_name), i), T) =
  31.465 -      let val isoT = T --> Univ_elT in
  31.466 -        HOLogic.imp $
  31.467 -          (Const (set_name, UnivT') $ Datatype_Aux.mk_Free "x" Univ_elT i) $
  31.468 -            (if i < length newTs then @{term True}
  31.469 -             else HOLogic.mk_mem (Datatype_Aux.mk_Free "x" Univ_elT i,
  31.470 -               Const (@{const_name image}, isoT --> HOLogic.mk_setT T --> UnivT) $
  31.471 -                 Const (iso_name, isoT) $ Const (@{const_abbrev UNIV}, HOLogic.mk_setT T)))
  31.472 -      end;
  31.473 -
  31.474 -    val iso_t = HOLogic.mk_Trueprop (Datatype_Aux.mk_conj (map mk_iso_t
  31.475 -      (rep_set_names ~~ all_rep_names ~~ (0 upto (length descr' - 1)) ~~ recTs)));
  31.476 -
  31.477 -    (* all the theorems are proved by one single simultaneous induction *)
  31.478 -
  31.479 -    val range_eqs = map (fn r => mk_meta_eq (r RS @{thm range_ex1_eq})) iso_inj_thms_unfolded;
  31.480 -
  31.481 -    val iso_thms =
  31.482 -      if length descr = 1 then []
  31.483 -      else
  31.484 -        drop (length newTs) (Datatype_Aux.split_conj_thm
  31.485 -          (Goal.prove_sorry_global thy5 [] [] iso_t (fn {context = ctxt, ...} => EVERY
  31.486 -             [(Datatype_Aux.ind_tac rep_induct [] THEN_ALL_NEW Object_Logic.atomize_prems_tac ctxt) 1,
  31.487 -              REPEAT (rtac TrueI 1),
  31.488 -              rewrite_goals_tac ctxt (mk_meta_eq @{thm choice_eq} ::
  31.489 -                Thm.symmetric (mk_meta_eq @{thm fun_eq_iff}) :: range_eqs),
  31.490 -              rewrite_goals_tac ctxt (map Thm.symmetric range_eqs),
  31.491 -              REPEAT (EVERY
  31.492 -                [REPEAT (eresolve_tac ([rangeE, @{thm ex1_implies_ex} RS exE] @
  31.493 -                   maps (mk_funs_inv thy5 o #1) newT_iso_axms) 1),
  31.494 -                 TRY (hyp_subst_tac ctxt 1),
  31.495 -                 rtac (sym RS range_eqI) 1,
  31.496 -                 resolve_tac iso_char_thms 1])])));
  31.497 -
  31.498 -    val Abs_inverse_thms' =
  31.499 -      map #1 newT_iso_axms @
  31.500 -      map2 (fn r_inj => fn r => @{thm f_the_inv_into_f} OF [r_inj, r RS mp])
  31.501 -        iso_inj_thms_unfolded iso_thms;
  31.502 -
  31.503 -    val Abs_inverse_thms = maps (mk_funs_inv thy5) Abs_inverse_thms';
  31.504 -
  31.505 -    (******************* freeness theorems for constructors *******************)
  31.506 -
  31.507 -    val _ = Datatype_Aux.message config "Proving freeness of constructors ...";
  31.508 -
  31.509 -    (* prove theorem  Rep_i (Constr_j ...) = Inj_j ...  *)
  31.510 -
  31.511 -    fun prove_constr_rep_thm eqn =
  31.512 -      let
  31.513 -        val inj_thms = map fst newT_iso_inj_thms;
  31.514 -        val rewrites = @{thm o_def} :: constr_defs @ map (mk_meta_eq o #2) newT_iso_axms;
  31.515 -      in
  31.516 -        Goal.prove_sorry_global thy5 [] [] eqn
  31.517 -        (fn {context = ctxt, ...} => EVERY
  31.518 -          [resolve_tac inj_thms 1,
  31.519 -           rewrite_goals_tac ctxt rewrites,
  31.520 -           rtac refl 3,
  31.521 -           resolve_tac rep_intrs 2,
  31.522 -           REPEAT (resolve_tac iso_elem_thms 1)])
  31.523 -      end;
  31.524 -
  31.525 -    (*--------------------------------------------------------------*)
  31.526 -    (* constr_rep_thms and rep_congs are used to prove distinctness *)
  31.527 -    (* of constructors.                                             *)
  31.528 -    (*--------------------------------------------------------------*)
  31.529 -
  31.530 -    val constr_rep_thms = map (map prove_constr_rep_thm) constr_rep_eqns;
  31.531 -
  31.532 -    val dist_rewrites =
  31.533 -      map (fn (rep_thms, dist_lemma) =>
  31.534 -        dist_lemma :: (rep_thms @ [In0_eq, In1_eq, In0_not_In1, In1_not_In0]))
  31.535 -          (constr_rep_thms ~~ dist_lemmas);
  31.536 -
  31.537 -    fun prove_distinct_thms dist_rewrites' =
  31.538 -      let
  31.539 -        fun prove [] = []
  31.540 -          | prove (t :: ts) =
  31.541 -              let
  31.542 -                val dist_thm = Goal.prove_sorry_global thy5 [] [] t (fn {context = ctxt, ...} =>
  31.543 -                  EVERY [simp_tac (put_simpset HOL_ss ctxt addsimps dist_rewrites') 1])
  31.544 -              in dist_thm :: Drule.zero_var_indexes (dist_thm RS not_sym) :: prove ts end;
  31.545 -      in prove end;
  31.546 -
  31.547 -    val distinct_thms =
  31.548 -      map2 (prove_distinct_thms) dist_rewrites (Datatype_Prop.make_distincts descr);
  31.549 -
  31.550 -    (* prove injectivity of constructors *)
  31.551 -
  31.552 -    fun prove_constr_inj_thm rep_thms t =
  31.553 -      let
  31.554 -        val inj_thms = Scons_inject ::
  31.555 -          map make_elim
  31.556 -            (iso_inj_thms @
  31.557 -              [In0_inject, In1_inject, Leaf_inject, Inl_inject, Inr_inject,
  31.558 -               Lim_inject, Suml_inject, Sumr_inject])
  31.559 -      in
  31.560 -        Goal.prove_sorry_global thy5 [] [] t
  31.561 -          (fn {context = ctxt, ...} => EVERY
  31.562 -            [rtac iffI 1,
  31.563 -             REPEAT (etac conjE 2), hyp_subst_tac ctxt 2, rtac refl 2,
  31.564 -             dresolve_tac rep_congs 1, dtac @{thm box_equals} 1,
  31.565 -             REPEAT (resolve_tac rep_thms 1),
  31.566 -             REPEAT (eresolve_tac inj_thms 1),
  31.567 -             REPEAT (ares_tac [conjI] 1 ORELSE (EVERY [REPEAT (rtac @{thm ext} 1),
  31.568 -               REPEAT (eresolve_tac (make_elim fun_cong :: inj_thms) 1),
  31.569 -               atac 1]))])
  31.570 -      end;
  31.571 -
  31.572 -    val constr_inject =
  31.573 -      map (fn (ts, thms) => map (prove_constr_inj_thm thms) ts)
  31.574 -        (Datatype_Prop.make_injs descr ~~ constr_rep_thms);
  31.575 -
  31.576 -    val ((constr_inject', distinct_thms'), thy6) =
  31.577 -      thy5
  31.578 -      |> Sign.parent_path
  31.579 -      |> Datatype_Aux.store_thmss "inject" new_type_names constr_inject
  31.580 -      ||>> Datatype_Aux.store_thmss "distinct" new_type_names distinct_thms;
  31.581 -
  31.582 -    (*************************** induction theorem ****************************)
  31.583 -
  31.584 -    val _ = Datatype_Aux.message config "Proving induction rule for datatypes ...";
  31.585 -
  31.586 -    val Rep_inverse_thms =
  31.587 -      map (fn (_, iso, _) => iso RS subst) newT_iso_axms @
  31.588 -      map (fn r => r RS @{thm the_inv_f_f} RS subst) iso_inj_thms_unfolded;
  31.589 -    val Rep_inverse_thms' = map (fn r => r RS @{thm the_inv_f_f}) iso_inj_thms_unfolded;
  31.590 -
  31.591 -    fun mk_indrule_lemma (i, _) T =
  31.592 -      let
  31.593 -        val Rep_t = Const (nth all_rep_names i, T --> Univ_elT) $ Datatype_Aux.mk_Free "x" T i;
  31.594 -        val Abs_t =
  31.595 -          if i < length newTs then
  31.596 -            Const (#Abs_name (#1 (#2 (nth typedefs i))), Univ_elT --> T)
  31.597 -          else
  31.598 -            Const (@{const_name the_inv_into},
  31.599 -              [HOLogic.mk_setT T, T --> Univ_elT, Univ_elT] ---> T) $
  31.600 -            HOLogic.mk_UNIV T $ Const (nth all_rep_names i, T --> Univ_elT);
  31.601 -        val prem =
  31.602 -          HOLogic.imp $
  31.603 -            (Const (nth rep_set_names i, UnivT') $ Rep_t) $
  31.604 -              (Datatype_Aux.mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ (Abs_t $ Rep_t));
  31.605 -        val concl =
  31.606 -          Datatype_Aux.mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ Datatype_Aux.mk_Free "x" T i;
  31.607 -      in (prem, concl) end;
  31.608 -
  31.609 -    val (indrule_lemma_prems, indrule_lemma_concls) =
  31.610 -      split_list (map2 mk_indrule_lemma descr' recTs);
  31.611 -
  31.612 -    val cert = cterm_of thy6;
  31.613 -
  31.614 -    val indrule_lemma =
  31.615 -      Goal.prove_sorry_global thy6 [] []
  31.616 -        (Logic.mk_implies
  31.617 -          (HOLogic.mk_Trueprop (Datatype_Aux.mk_conj indrule_lemma_prems),
  31.618 -           HOLogic.mk_Trueprop (Datatype_Aux.mk_conj indrule_lemma_concls)))
  31.619 -        (fn _ =>
  31.620 -          EVERY
  31.621 -           [REPEAT (etac conjE 1),
  31.622 -            REPEAT (EVERY
  31.623 -              [TRY (rtac conjI 1), resolve_tac Rep_inverse_thms 1,
  31.624 -               etac mp 1, resolve_tac iso_elem_thms 1])]);
  31.625 -
  31.626 -    val Ps = map head_of (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of indrule_lemma)));
  31.627 -    val frees =
  31.628 -      if length Ps = 1 then [Free ("P", snd (dest_Var (hd Ps)))]
  31.629 -      else map (Free o apfst fst o dest_Var) Ps;
  31.630 -    val indrule_lemma' = cterm_instantiate (map cert Ps ~~ map cert frees) indrule_lemma;
  31.631 -
  31.632 -    val dt_induct_prop = Datatype_Prop.make_ind descr;
  31.633 -    val dt_induct =
  31.634 -      Goal.prove_sorry_global thy6 []
  31.635 -      (Logic.strip_imp_prems dt_induct_prop)
  31.636 -      (Logic.strip_imp_concl dt_induct_prop)
  31.637 -      (fn {context = ctxt, prems, ...} =>
  31.638 -        EVERY
  31.639 -          [rtac indrule_lemma' 1,
  31.640 -           (Datatype_Aux.ind_tac rep_induct [] THEN_ALL_NEW Object_Logic.atomize_prems_tac ctxt) 1,
  31.641 -           EVERY (map (fn (prem, r) => (EVERY
  31.642 -             [REPEAT (eresolve_tac Abs_inverse_thms 1),
  31.643 -              simp_tac (put_simpset HOL_basic_ss ctxt
  31.644 -                addsimps (Thm.symmetric r :: Rep_inverse_thms')) 1,
  31.645 -              DEPTH_SOLVE_1 (ares_tac [prem] 1 ORELSE etac allE 1)]))
  31.646 -                  (prems ~~ (constr_defs @ map mk_meta_eq iso_char_thms)))]);
  31.647 -
  31.648 -    val ([(_, [dt_induct'])], thy7) =
  31.649 -      thy6
  31.650 -      |> Global_Theory.note_thmss ""
  31.651 -        [((Binding.qualify true big_name (Binding.name "induct"), [case_names_induct]),
  31.652 -          [([dt_induct], [])])];
  31.653 -  in
  31.654 -    ((constr_inject', distinct_thms', dt_induct'), thy7)
  31.655 -  end;
  31.656 -
  31.657 -
  31.658 -
  31.659 -(** datatype definition **)
  31.660 -
  31.661 -(* specifications *)
  31.662 -
  31.663 -type spec = (binding * (string * sort) list * mixfix) * (binding * typ list * mixfix) list;
  31.664 -
  31.665 -type spec_cmd =
  31.666 -  (binding * (string * string option) list * mixfix) * (binding * string list * mixfix) list;
  31.667 -
  31.668 -local
  31.669 -
  31.670 -fun parse_spec ctxt ((b, args, mx), constrs) =
  31.671 -  ((b, map (apsnd (Typedecl.read_constraint ctxt)) args, mx),
  31.672 -    constrs |> map (fn (c, Ts, mx') => (c, map (Syntax.parse_typ ctxt) Ts, mx')));
  31.673 -
  31.674 -fun check_specs ctxt (specs: spec list) =
  31.675 -  let
  31.676 -    fun prep_spec ((tname, args, mx), constrs) tys =
  31.677 -      let
  31.678 -        val (args', tys1) = chop (length args) tys;
  31.679 -        val (constrs', tys3) = (constrs, tys1) |-> fold_map (fn (cname, cargs, mx') => fn tys2 =>
  31.680 -          let val (cargs', tys3) = chop (length cargs) tys2;
  31.681 -          in ((cname, cargs', mx'), tys3) end);
  31.682 -      in (((tname, map dest_TFree args', mx), constrs'), tys3) end;
  31.683 -
  31.684 -    val all_tys =
  31.685 -      specs |> maps (fn ((_, args, _), cs) => map TFree args @ maps #2 cs)
  31.686 -      |> Syntax.check_typs ctxt;
  31.687 -
  31.688 -  in #1 (fold_map prep_spec specs all_tys) end;
  31.689 -
  31.690 -fun prep_specs parse raw_specs thy =
  31.691 -  let
  31.692 -    val ctxt = thy
  31.693 -      |> Sign.add_types_global (map (fn ((b, args, mx), _) => (b, length args, mx)) raw_specs)
  31.694 -      |> Proof_Context.init_global
  31.695 -      |> fold (fn ((_, args, _), _) => fold (fn (a, _) =>
  31.696 -          Variable.declare_typ (TFree (a, dummyS))) args) raw_specs;
  31.697 -    val specs = check_specs ctxt (map (parse ctxt) raw_specs);
  31.698 -  in (specs, ctxt) end;
  31.699 -
  31.700 -in
  31.701 -
  31.702 -val read_specs = prep_specs parse_spec;
  31.703 -val check_specs = prep_specs (K I);
  31.704 -
  31.705 -end;
  31.706 -
  31.707 -
  31.708 -(* main commands *)
  31.709 -
  31.710 -fun gen_add_datatype prep_specs config raw_specs thy =
  31.711 -  let
  31.712 -    val _ = Theory.requires thy (Context.theory_name @{theory}) "datatype definitions";
  31.713 -
  31.714 -    val (dts, spec_ctxt) = prep_specs raw_specs thy;
  31.715 -    val ((_, tyvars, _), _) :: _ = dts;
  31.716 -    val string_of_tyvar = Syntax.string_of_typ spec_ctxt o TFree;
  31.717 -
  31.718 -    val (new_dts, types_syntax) = dts |> map (fn ((tname, tvs, mx), _) =>
  31.719 -      let val full_tname = Sign.full_name thy tname in
  31.720 -        (case duplicates (op =) tvs of
  31.721 -          [] =>
  31.722 -            if eq_set (op =) (tyvars, tvs) then ((full_tname, tvs), (tname, mx))
  31.723 -            else error "Mutually recursive datatypes must have same type parameters"
  31.724 -        | dups =>
  31.725 -            error ("Duplicate parameter(s) for datatype " ^ Binding.print tname ^
  31.726 -              " : " ^ commas (map string_of_tyvar dups)))
  31.727 -      end) |> split_list;
  31.728 -    val dt_names = map fst new_dts;
  31.729 -
  31.730 -    val _ =
  31.731 -      (case duplicates (op =) (map fst new_dts) of
  31.732 -        [] => ()
  31.733 -      | dups => error ("Duplicate datatypes: " ^ commas_quote dups));
  31.734 -
  31.735 -    fun prep_dt_spec ((tname, tvs, _), constrs) (dts', constr_syntax, i) =
  31.736 -      let
  31.737 -        fun prep_constr (cname, cargs, mx) (constrs, constr_syntax') =
  31.738 -          let
  31.739 -            val _ =
  31.740 -              (case subtract (op =) tvs (fold Term.add_tfreesT cargs []) of
  31.741 -                [] => ()
  31.742 -              | vs => error ("Extra type variables on rhs: " ^ commas (map string_of_tyvar vs)));
  31.743 -            val c = Sign.full_name_path thy (Binding.name_of tname) cname;
  31.744 -          in
  31.745 -            (constrs @ [(c, map (Datatype_Aux.dtyp_of_typ new_dts) cargs)],
  31.746 -              constr_syntax' @ [(cname, mx)])
  31.747 -          end handle ERROR msg =>
  31.748 -            cat_error msg ("The error above occurred in constructor " ^ Binding.print cname ^
  31.749 -              " of datatype " ^ Binding.print tname);
  31.750 -
  31.751 -        val (constrs', constr_syntax') = fold prep_constr constrs ([], []);
  31.752 -      in
  31.753 -        (case duplicates (op =) (map fst constrs') of
  31.754 -          [] =>
  31.755 -            (dts' @ [(i, (Sign.full_name thy tname, map Datatype_Aux.DtTFree tvs, constrs'))],
  31.756 -              constr_syntax @ [constr_syntax'], i + 1)
  31.757 -        | dups =>
  31.758 -            error ("Duplicate constructors " ^ commas_quote dups ^
  31.759 -              " in datatype " ^ Binding.print tname))
  31.760 -      end;
  31.761 -
  31.762 -    val (dts', constr_syntax, i) = fold prep_dt_spec dts ([], [], 0);
  31.763 -
  31.764 -    val dt_info = Datatype_Data.get_all thy;
  31.765 -    val (descr, _) = Datatype_Aux.unfold_datatypes spec_ctxt dts' dt_info dts' i;
  31.766 -    val _ =
  31.767 -      Datatype_Aux.check_nonempty descr
  31.768 -        handle (exn as Datatype_Aux.Datatype_Empty s) =>
  31.769 -          if #strict config then error ("Nonemptiness check failed for datatype " ^ quote s)
  31.770 -          else reraise exn;
  31.771 -
  31.772 -    val _ =
  31.773 -      Datatype_Aux.message config
  31.774 -        ("Constructing datatype(s) " ^ commas_quote (map (Binding.name_of o #1 o #1) dts));
  31.775 -  in
  31.776 -    thy
  31.777 -    |> representation_proofs config dt_info descr types_syntax constr_syntax
  31.778 -      (Datatype_Data.mk_case_names_induct (flat descr))
  31.779 -    |-> (fn (inject, distinct, induct) =>
  31.780 -      Rep_Datatype.derive_datatype_props config dt_names descr induct inject distinct)
  31.781 -  end;
  31.782 -
  31.783 -val add_datatype = gen_add_datatype check_specs;
  31.784 -val add_datatype_cmd = gen_add_datatype read_specs;
  31.785 -
  31.786 -
  31.787 -(* outer syntax *)
  31.788 -
  31.789 -val spec_cmd =
  31.790 -  Parse.type_args_constrained -- Parse.binding -- Parse.opt_mixfix --
  31.791 -  (@{keyword "="} |-- Parse.enum1 "|" (Parse.binding -- Scan.repeat Parse.typ -- Parse.opt_mixfix))
  31.792 -  >> (fn (((vs, t), mx), cons) => ((t, vs, mx), map Parse.triple1 cons));
  31.793 -
  31.794 -val _ =
  31.795 -  Outer_Syntax.command @{command_spec "datatype"} "define inductive datatypes"
  31.796 -    (Parse.and_list1 spec_cmd
  31.797 -      >> (Toplevel.theory o (snd oo add_datatype_cmd Datatype_Aux.default_config)));
  31.798 -
  31.799 -
  31.800 -open Datatype_Data;
  31.801 -
  31.802 -end;
    32.1 --- a/src/HOL/Tools/Datatype/datatype_aux.ML	Mon Sep 01 16:17:46 2014 +0200
    32.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    32.3 @@ -1,402 +0,0 @@
    32.4 -(*  Title:      HOL/Tools/Datatype/datatype_aux.ML
    32.5 -    Author:     Stefan Berghofer, TU Muenchen
    32.6 -
    32.7 -Datatype package: auxiliary data structures and functions.
    32.8 -*)
    32.9 -
   32.10 -signature DATATYPE_COMMON =
   32.11 -sig
   32.12 -  type config = {strict : bool, quiet : bool}
   32.13 -  val default_config : config
   32.14 -  datatype dtyp =
   32.15 -      DtTFree of string * sort
   32.16 -    | DtType of string * dtyp list
   32.17 -    | DtRec of int
   32.18 -  type descr = (int * (string * dtyp list * (string * dtyp list) list)) list
   32.19 -  type info =
   32.20 -   {index : int,
   32.21 -    descr : descr,
   32.22 -    inject : thm list,
   32.23 -    distinct : thm list,
   32.24 -    induct : thm,
   32.25 -    inducts : thm list,
   32.26 -    exhaust : thm,
   32.27 -    nchotomy : thm,
   32.28 -    rec_names : string list,
   32.29 -    rec_rewrites : thm list,
   32.30 -    case_name : string,
   32.31 -    case_rewrites : thm list,
   32.32 -    case_cong : thm,
   32.33 -    case_cong_weak : thm,
   32.34 -    split : thm,
   32.35 -    split_asm: thm}
   32.36 -end
   32.37 -
   32.38 -signature DATATYPE_AUX =
   32.39 -sig
   32.40 -  include DATATYPE_COMMON
   32.41 -
   32.42 -  val message : config -> string -> unit
   32.43 -
   32.44 -  val store_thmss_atts : string -> string list -> attribute list list -> thm list list
   32.45 -    -> theory -> thm list list * theory
   32.46 -  val store_thmss : string -> string list -> thm list list -> theory -> thm list list * theory
   32.47 -  val store_thms_atts : string -> string list -> attribute list list -> thm list
   32.48 -    -> theory -> thm list * theory
   32.49 -  val store_thms : string -> string list -> thm list -> theory -> thm list * theory
   32.50 -
   32.51 -  val split_conj_thm : thm -> thm list
   32.52 -  val mk_conj : term list -> term
   32.53 -  val mk_disj : term list -> term
   32.54 -
   32.55 -  val app_bnds : term -> int -> term
   32.56 -
   32.57 -  val ind_tac : thm -> string list -> int -> tactic
   32.58 -  val exh_tac : (string -> thm) -> int -> tactic
   32.59 -
   32.60 -  exception Datatype
   32.61 -  exception Datatype_Empty of string
   32.62 -  val name_of_typ : typ -> string
   32.63 -  val dtyp_of_typ : (string * (string * sort) list) list -> typ -> dtyp
   32.64 -  val mk_Free : string -> typ -> int -> term
   32.65 -  val is_rec_type : dtyp -> bool
   32.66 -  val typ_of_dtyp : descr -> dtyp -> typ
   32.67 -  val dest_DtTFree : dtyp -> string * sort
   32.68 -  val dest_DtRec : dtyp -> int
   32.69 -  val strip_dtyp : dtyp -> dtyp list * dtyp
   32.70 -  val body_index : dtyp -> int
   32.71 -  val mk_fun_dtyp : dtyp list -> dtyp -> dtyp
   32.72 -  val get_nonrec_types : descr -> typ list
   32.73 -  val get_branching_types : descr -> typ list
   32.74 -  val get_arities : descr -> int list
   32.75 -  val get_rec_types : descr -> typ list
   32.76 -  val interpret_construction : descr -> (string * sort) list ->
   32.77 -    {atyp: typ -> 'a, dtyp: typ list -> int * bool -> string * typ list -> 'a} ->
   32.78 -    ((string * typ list) * (string * 'a list) list) list
   32.79 -  val check_nonempty : descr list -> unit
   32.80 -  val unfold_datatypes : Proof.context -> descr -> info Symtab.table ->
   32.81 -    descr -> int -> descr list * int
   32.82 -  val find_shortest_path : descr -> int -> (string * int) option
   32.83 -end;
   32.84 -
   32.85 -structure Datatype_Aux : DATATYPE_AUX =
   32.86 -struct
   32.87 -
   32.88 -(* datatype option flags *)
   32.89 -
   32.90 -type config = {strict : bool, quiet : bool};
   32.91 -val default_config : config = {strict = true, quiet = false};
   32.92 -
   32.93 -fun message ({quiet = true, ...} : config) s = writeln s
   32.94 -  | message _ _ = ();
   32.95 -
   32.96 -
   32.97 -(* store theorems in theory *)
   32.98 -
   32.99 -fun store_thmss_atts name tnames attss thmss =
  32.100 -  fold_map (fn ((tname, atts), thms) =>
  32.101 -    Global_Theory.note_thmss ""
  32.102 -      [((Binding.qualify true tname (Binding.name name), atts), [(thms, [])])]
  32.103 -    #-> (fn [(_, res)] => pair res)) (tnames ~~ attss ~~ thmss);
  32.104 -
  32.105 -fun store_thmss name tnames = store_thmss_atts name tnames (replicate (length tnames) []);
  32.106 -
  32.107 -fun store_thms_atts name tnames attss thms =
  32.108 -  fold_map (fn ((tname, atts), thm) =>
  32.109 -    Global_Theory.note_thmss ""
  32.110 -      [((Binding.qualify true tname (Binding.name name), atts), [([thm], [])])]
  32.111 -    #-> (fn [(_, [res])] => pair res)) (tnames ~~ attss ~~ thms);
  32.112 -
  32.113 -fun store_thms name tnames = store_thms_atts name tnames (replicate (length tnames) []);
  32.114 -
  32.115 -
  32.116 -(* split theorem thm_1 & ... & thm_n into n theorems *)
  32.117 -
  32.118 -fun split_conj_thm th =
  32.119 -  ((th RS conjunct1) :: split_conj_thm (th RS conjunct2)) handle THM _ => [th];
  32.120 -
  32.121 -val mk_conj = foldr1 (HOLogic.mk_binop @{const_name HOL.conj});
  32.122 -val mk_disj = foldr1 (HOLogic.mk_binop @{const_name HOL.disj});
  32.123 -
  32.124 -fun app_bnds t i = list_comb (t, map Bound (i - 1 downto 0));
  32.125 -
  32.126 -
  32.127 -(* instantiate induction rule *)
  32.128 -
  32.129 -fun ind_tac indrule indnames = CSUBGOAL (fn (cgoal, i) =>
  32.130 -  let
  32.131 -    val cert = cterm_of (Thm.theory_of_cterm cgoal);
  32.132 -    val goal = term_of cgoal;
  32.133 -    val ts = HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of indrule));
  32.134 -    val ts' = HOLogic.dest_conj (HOLogic.dest_Trueprop (Logic.strip_imp_concl goal));
  32.135 -    val getP =
  32.136 -      if can HOLogic.dest_imp (hd ts)
  32.137 -      then apfst SOME o HOLogic.dest_imp
  32.138 -      else pair NONE;
  32.139 -    val flt =
  32.140 -      if null indnames then I
  32.141 -      else filter (member (op =) indnames o fst);
  32.142 -    fun abstr (t1, t2) =
  32.143 -      (case t1 of
  32.144 -        NONE =>
  32.145 -          (case flt (Term.add_frees t2 []) of
  32.146 -            [(s, T)] => SOME (absfree (s, T) t2)
  32.147 -          | _ => NONE)
  32.148 -      | SOME (_ $ t') => SOME (Abs ("x", fastype_of t', abstract_over (t', t2))));
  32.149 -    val insts =
  32.150 -      map_filter (fn (t, u) =>
  32.151 -        (case abstr (getP u) of
  32.152 -          NONE => NONE
  32.153 -        | SOME u' => SOME (t |> getP |> snd |> head_of |> cert, cert u'))) (ts ~~ ts');
  32.154 -    val indrule' = cterm_instantiate insts indrule;
  32.155 -  in rtac indrule' i end);
  32.156 -
  32.157 -
  32.158 -(* perform exhaustive case analysis on last parameter of subgoal i *)
  32.159 -
  32.160 -fun exh_tac exh_thm_of = CSUBGOAL (fn (cgoal, i) =>
  32.161 -  let
  32.162 -    val thy = Thm.theory_of_cterm cgoal;
  32.163 -    val goal = term_of cgoal;
  32.164 -    val params = Logic.strip_params goal;
  32.165 -    val (_, Type (tname, _)) = hd (rev params);
  32.166 -    val exhaustion = Thm.lift_rule cgoal (exh_thm_of tname);
  32.167 -    val prem' = hd (prems_of exhaustion);
  32.168 -    val _ $ (_ $ lhs $ _) = hd (rev (Logic.strip_assums_hyp prem'));
  32.169 -    val exhaustion' =
  32.170 -      cterm_instantiate [(cterm_of thy (head_of lhs),
  32.171 -        cterm_of thy (fold_rev (fn (_, T) => fn t => Abs ("z", T, t)) params (Bound 0)))] exhaustion;
  32.172 -  in compose_tac (false, exhaustion', nprems_of exhaustion) i end);
  32.173 -
  32.174 -
  32.175 -(********************** Internal description of datatypes *********************)
  32.176 -
  32.177 -datatype dtyp =
  32.178 -    DtTFree of string * sort
  32.179 -  | DtType of string * dtyp list
  32.180 -  | DtRec of int;
  32.181 -
  32.182 -(* information about datatypes *)
  32.183 -
  32.184 -(* index, datatype name, type arguments, constructor name, types of constructor's arguments *)
  32.185 -type descr = (int * (string * dtyp list * (string * dtyp list) list)) list;
  32.186 -
  32.187 -type info =
  32.188 -  {index : int,
  32.189 -   descr : descr,
  32.190 -   inject : thm list,
  32.191 -   distinct : thm list,
  32.192 -   induct : thm,
  32.193 -   inducts : thm list,
  32.194 -   exhaust : thm,
  32.195 -   nchotomy : thm,
  32.196 -   rec_names : string list,
  32.197 -   rec_rewrites : thm list,
  32.198 -   case_name : string,
  32.199 -   case_rewrites : thm list,
  32.200 -   case_cong : thm,
  32.201 -   case_cong_weak : thm,
  32.202 -   split : thm,
  32.203 -   split_asm: thm};
  32.204 -
  32.205 -fun mk_Free s T i = Free (s ^ string_of_int i, T);
  32.206 -
  32.207 -fun subst_DtTFree _ substs (T as DtTFree a) = the_default T (AList.lookup (op =) substs a)
  32.208 -  | subst_DtTFree i substs (DtType (name, ts)) = DtType (name, map (subst_DtTFree i substs) ts)
  32.209 -  | subst_DtTFree i _ (DtRec j) = DtRec (i + j);
  32.210 -
  32.211 -exception Datatype;
  32.212 -exception Datatype_Empty of string;
  32.213 -
  32.214 -fun dest_DtTFree (DtTFree a) = a
  32.215 -  | dest_DtTFree _ = raise Datatype;
  32.216 -
  32.217 -fun dest_DtRec (DtRec i) = i
  32.218 -  | dest_DtRec _ = raise Datatype;
  32.219 -
  32.220 -fun is_rec_type (DtType (_, dts)) = exists is_rec_type dts
  32.221 -  | is_rec_type (DtRec _) = true
  32.222 -  | is_rec_type _ = false;
  32.223 -
  32.224 -fun strip_dtyp (DtType ("fun", [T, U])) = apfst (cons T) (strip_dtyp U)
  32.225 -  | strip_dtyp T = ([], T);
  32.226 -
  32.227 -val body_index = dest_DtRec o snd o strip_dtyp;
  32.228 -
  32.229 -fun mk_fun_dtyp [] U = U
  32.230 -  | mk_fun_dtyp (T :: Ts) U = DtType ("fun", [T, mk_fun_dtyp Ts U]);
  32.231 -
  32.232 -fun name_of_typ (Type (s, Ts)) =
  32.233 -      let val s' = Long_Name.base_name s in
  32.234 -        space_implode "_"
  32.235 -          (filter_out (equal "") (map name_of_typ Ts) @
  32.236 -            [if Symbol_Pos.is_identifier s' then s' else "x"])
  32.237 -      end
  32.238 -  | name_of_typ _ = "";
  32.239 -
  32.240 -fun dtyp_of_typ _ (TFree a) = DtTFree a
  32.241 -  | dtyp_of_typ _ (TVar _) = error "Illegal schematic type variable(s)"
  32.242 -  | dtyp_of_typ new_dts (Type (tname, Ts)) =
  32.243 -      (case AList.lookup (op =) new_dts tname of
  32.244 -        NONE => DtType (tname, map (dtyp_of_typ new_dts) Ts)
  32.245 -      | SOME vs =>
  32.246 -          if map (try dest_TFree) Ts = map SOME vs then
  32.247 -            DtRec (find_index (curry op = tname o fst) new_dts)
  32.248 -          else error ("Illegal occurrence of recursive type " ^ quote tname));
  32.249 -
  32.250 -fun typ_of_dtyp descr (DtTFree a) = TFree a
  32.251 -  | typ_of_dtyp descr (DtRec i) =
  32.252 -      let val (s, ds, _) = the (AList.lookup (op =) descr i)
  32.253 -      in Type (s, map (typ_of_dtyp descr) ds) end
  32.254 -  | typ_of_dtyp descr (DtType (s, ds)) = Type (s, map (typ_of_dtyp descr) ds);
  32.255 -
  32.256 -(* find all non-recursive types in datatype description *)
  32.257 -
  32.258 -fun get_nonrec_types descr =
  32.259 -  map (typ_of_dtyp descr) (fold (fn (_, (_, _, constrs)) =>
  32.260 -    fold (fn (_, cargs) => union (op =) (filter_out is_rec_type cargs)) constrs) descr []);
  32.261 -
  32.262 -(* get all recursive types in datatype description *)
  32.263 -
  32.264 -fun get_rec_types descr = map (fn (_ , (s, ds, _)) =>
  32.265 -  Type (s, map (typ_of_dtyp descr) ds)) descr;
  32.266 -
  32.267 -(* get all branching types *)
  32.268 -
  32.269 -fun get_branching_types descr =
  32.270 -  map (typ_of_dtyp descr)
  32.271 -    (fold
  32.272 -      (fn (_, (_, _, constrs)) =>
  32.273 -        fold (fn (_, cargs) => fold (strip_dtyp #> fst #> fold (insert op =)) cargs) constrs)
  32.274 -      descr []);
  32.275 -
  32.276 -fun get_arities descr =
  32.277 -  fold
  32.278 -    (fn (_, (_, _, constrs)) =>
  32.279 -      fold (fn (_, cargs) =>
  32.280 -        fold (insert op =) (map (length o fst o strip_dtyp) (filter is_rec_type cargs))) constrs)
  32.281 -    descr [];
  32.282 -
  32.283 -(* interpret construction of datatype *)
  32.284 -
  32.285 -fun interpret_construction descr vs {atyp, dtyp} =
  32.286 -  let
  32.287 -    val typ_of =
  32.288 -      typ_of_dtyp descr #>
  32.289 -      map_atyps (fn TFree (a, _) => TFree (a, the (AList.lookup (op =) vs a)) | T => T);
  32.290 -    fun interpT dT =
  32.291 -      (case strip_dtyp dT of
  32.292 -        (dTs, DtRec l) =>
  32.293 -          let
  32.294 -            val (tyco, dTs', _) = the (AList.lookup (op =) descr l);
  32.295 -            val Ts = map typ_of dTs;
  32.296 -            val Ts' = map typ_of dTs';
  32.297 -            val is_proper = forall (can dest_TFree) Ts';
  32.298 -          in dtyp Ts (l, is_proper) (tyco, Ts') end
  32.299 -      | _ => atyp (typ_of dT));
  32.300 -    fun interpC (c, dTs) = (c, map interpT dTs);
  32.301 -    fun interpD (_, (tyco, dTs, cs)) = ((tyco, map typ_of dTs), map interpC cs);
  32.302 -  in map interpD descr end;
  32.303 -
  32.304 -(* nonemptiness check for datatypes *)
  32.305 -
  32.306 -fun check_nonempty descr =
  32.307 -  let
  32.308 -    val descr' = flat descr;
  32.309 -    fun is_nonempty_dt is i =
  32.310 -      let
  32.311 -        val (_, _, constrs) = the (AList.lookup (op =) descr' i);
  32.312 -        fun arg_nonempty (_, DtRec i) =
  32.313 -              if member (op =) is i then false
  32.314 -              else is_nonempty_dt (i :: is) i
  32.315 -          | arg_nonempty _ = true;
  32.316 -      in exists (forall (arg_nonempty o strip_dtyp) o snd) constrs end
  32.317 -    val _ = hd descr |> forall (fn (i, (s, _, _)) =>
  32.318 -      is_nonempty_dt [i] i orelse raise Datatype_Empty s)
  32.319 -  in () end;
  32.320 -
  32.321 -(* unfold a list of mutually recursive datatype specifications *)
  32.322 -(* all types of the form DtType (dt_name, [..., DtRec _, ...]) *)
  32.323 -(* need to be unfolded                                         *)
  32.324 -
  32.325 -fun unfold_datatypes ctxt orig_descr (dt_info : info Symtab.table) descr i =
  32.326 -  let
  32.327 -    fun typ_error T msg =
  32.328 -      error ("Non-admissible type expression\n" ^
  32.329 -        Syntax.string_of_typ ctxt (typ_of_dtyp (orig_descr @ descr) T) ^ "\n" ^ msg);
  32.330 -
  32.331 -    fun get_dt_descr T i tname dts =
  32.332 -      (case Symtab.lookup dt_info tname of
  32.333 -        NONE =>
  32.334 -          typ_error T (quote tname ^ " is not a datatype - can't use it in nested recursion")
  32.335 -      | SOME {index, descr, ...} =>
  32.336 -          let
  32.337 -            val (_, vars, _) = the (AList.lookup (op =) descr index);
  32.338 -            val subst = map dest_DtTFree vars ~~ dts
  32.339 -              handle ListPair.UnequalLengths =>
  32.340 -                typ_error T ("Type constructor " ^ quote tname ^
  32.341 -                  " used with wrong number of arguments");
  32.342 -          in
  32.343 -            (i + index,
  32.344 -              map (fn (j, (tn, args, cs)) =>
  32.345 -                (i + j, (tn, map (subst_DtTFree i subst) args,
  32.346 -                  map (apsnd (map (subst_DtTFree i subst))) cs))) descr)
  32.347 -          end);
  32.348 -
  32.349 -    (* unfold a single constructor argument *)
  32.350 -
  32.351 -    fun unfold_arg T (i, Ts, descrs) =
  32.352 -      if is_rec_type T then
  32.353 -        let val (Us, U) = strip_dtyp T in
  32.354 -          if exists is_rec_type Us then
  32.355 -            typ_error T "Non-strictly positive recursive occurrence of type"
  32.356 -          else
  32.357 -            (case U of
  32.358 -              DtType (tname, dts) =>
  32.359 -                let
  32.360 -                  val (index, descr) = get_dt_descr T i tname dts;
  32.361 -                  val (descr', i') =
  32.362 -                    unfold_datatypes ctxt orig_descr dt_info descr (i + length descr);
  32.363 -                in (i', Ts @ [mk_fun_dtyp Us (DtRec index)], descrs @ descr') end
  32.364 -            | _ => (i, Ts @ [T], descrs))
  32.365 -        end
  32.366 -      else (i, Ts @ [T], descrs);
  32.367 -
  32.368 -    (* unfold a constructor *)
  32.369 -
  32.370 -    fun unfold_constr (cname, cargs) (i, constrs, descrs) =
  32.371 -      let val (i', cargs', descrs') = fold unfold_arg cargs (i, [], descrs)
  32.372 -      in (i', constrs @ [(cname, cargs')], descrs') end;
  32.373 -
  32.374 -    (* unfold a single datatype *)
  32.375 -
  32.376 -    fun unfold_datatype (j, (tname, tvars, constrs)) (i, dtypes, descrs) =
  32.377 -      let val (i', constrs', descrs') = fold unfold_constr constrs (i, [], descrs)
  32.378 -      in (i', dtypes @ [(j, (tname, tvars, constrs'))], descrs') end;
  32.379 -
  32.380 -    val (i', descr', descrs) = fold unfold_datatype descr (i, [], []);
  32.381 -
  32.382 -  in (descr' :: descrs, i') end;
  32.383 -
  32.384 -(* find shortest path to constructor with no recursive arguments *)
  32.385 -
  32.386 -fun find_nonempty descr is i =
  32.387 -  let
  32.388 -    fun arg_nonempty (_, DtRec i) =
  32.389 -          if member (op =) is i
  32.390 -          then NONE
  32.391 -          else Option.map (Integer.add 1 o snd) (find_nonempty descr (i :: is) i)
  32.392 -      | arg_nonempty _ = SOME 0;
  32.393 -    fun max_inf (SOME i) (SOME j) = SOME (Integer.max i j)
  32.394 -      | max_inf _ _ = NONE;
  32.395 -    fun max xs = fold max_inf xs (SOME 0);
  32.396 -    val (_, _, constrs) = the (AList.lookup (op =) descr i);
  32.397 -    val xs =
  32.398 -      sort (int_ord o pairself snd)
  32.399 -        (map_filter (fn (s, dts) => Option.map (pair s)
  32.400 -          (max (map (arg_nonempty o strip_dtyp) dts))) constrs)
  32.401 -  in if null xs then NONE else SOME (hd xs) end;
  32.402 -
  32.403 -fun find_shortest_path descr i = find_nonempty descr [i] i;
  32.404 -
  32.405 -end;
    33.1 --- a/src/HOL/Tools/Datatype/datatype_codegen.ML	Mon Sep 01 16:17:46 2014 +0200
    33.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    33.3 @@ -1,25 +0,0 @@
    33.4 -(*  Title:      HOL/Tools/Datatype/datatype_codegen.ML
    33.5 -    Author:     Stefan Berghofer and Florian Haftmann, TU Muenchen
    33.6 -
    33.7 -Code generator facilities for inductive datatypes.
    33.8 -*)
    33.9 -
   33.10 -signature DATATYPE_CODEGEN =
   33.11 -sig
   33.12 -end;
   33.13 -
   33.14 -structure Datatype_Codegen : DATATYPE_CODEGEN =
   33.15 -struct
   33.16 -
   33.17 -fun add_code_for_datatype fcT_name thy =
   33.18 -  let
   33.19 -    val ctxt = Proof_Context.init_global thy
   33.20 -    val SOME {ctrs, injects, distincts, case_thms, ...} = Ctr_Sugar.ctr_sugar_of ctxt fcT_name
   33.21 -    val Type (_, As) = body_type (fastype_of (hd ctrs))
   33.22 -  in
   33.23 -    Ctr_Sugar_Code.add_ctr_code fcT_name As (map dest_Const ctrs) injects distincts case_thms thy
   33.24 -  end;
   33.25 -
   33.26 -val _ = Theory.setup (Datatype_Data.interpretation (K (fold add_code_for_datatype)));
   33.27 -
   33.28 -end;
    34.1 --- a/src/HOL/Tools/Datatype/datatype_data.ML	Mon Sep 01 16:17:46 2014 +0200
    34.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    34.3 @@ -1,292 +0,0 @@
    34.4 -(*  Title:      HOL/Tools/Datatype/datatype_data.ML
    34.5 -    Author:     Stefan Berghofer, TU Muenchen
    34.6 -
    34.7 -Datatype package bookkeeping.
    34.8 -*)
    34.9 -
   34.10 -signature DATATYPE_DATA =
   34.11 -sig
   34.12 -  include DATATYPE_COMMON
   34.13 -
   34.14 -  val get_all : theory -> info Symtab.table
   34.15 -  val get_info : theory -> string -> info option
   34.16 -  val the_info : theory -> string -> info
   34.17 -  val info_of_constr : theory -> string * typ -> info option
   34.18 -  val info_of_constr_permissive : theory -> string * typ -> info option
   34.19 -  val info_of_case : theory -> string -> info option
   34.20 -  val register: (string * info) list -> theory -> theory
   34.21 -  val the_spec : theory -> string -> (string * sort) list * (string * typ list) list
   34.22 -  val the_descr : theory -> string list ->
   34.23 -    descr * (string * sort) list * string list * string *
   34.24 -    (string list * string list) * (typ list * typ list)
   34.25 -  val all_distincts : theory -> typ list -> thm list list
   34.26 -  val get_constrs : theory -> string -> (string * typ) list option
   34.27 -  val mk_case_names_induct: descr -> attribute
   34.28 -  val mk_case_names_exhausts: descr -> string list -> attribute list
   34.29 -  val interpretation : (config -> string list -> theory -> theory) -> theory -> theory
   34.30 -  val interpretation_data : config * string list -> theory -> theory
   34.31 -  val setup: theory -> theory
   34.32 -end;
   34.33 -
   34.34 -structure Datatype_Data: DATATYPE_DATA =
   34.35 -struct
   34.36 -
   34.37 -(** theory data **)
   34.38 -
   34.39 -(* data management *)
   34.40 -
   34.41 -structure Data = Theory_Data
   34.42 -(
   34.43 -  type T =
   34.44 -    {types: Datatype_Aux.info Symtab.table,
   34.45 -     constrs: (string * Datatype_Aux.info) list Symtab.table,
   34.46 -     cases: Datatype_Aux.info Symtab.table};
   34.47 -
   34.48 -  val empty =
   34.49 -    {types = Symtab.empty, constrs = Symtab.empty, cases = Symtab.empty};
   34.50 -  val extend = I;
   34.51 -  fun merge
   34.52 -    ({types = types1, constrs = constrs1, cases = cases1},
   34.53 -     {types = types2, constrs = constrs2, cases = cases2}) : T =
   34.54 -    {types = Symtab.merge (K true) (types1, types2),
   34.55 -     constrs = Symtab.join (K (AList.merge (op =) (K true))) (constrs1, constrs2),
   34.56 -     cases = Symtab.merge (K true) (cases1, cases2)};
   34.57 -);
   34.58 -
   34.59 -val get_all = #types o Data.get;
   34.60 -val get_info = Symtab.lookup o get_all;
   34.61 -
   34.62 -fun the_info thy name =
   34.63 -  (case get_info thy name of
   34.64 -    SOME info => info
   34.65 -  | NONE => error ("Unknown datatype " ^ quote name));
   34.66 -
   34.67 -fun info_of_constr thy (c, T) =
   34.68 -  let
   34.69 -    val tab = Symtab.lookup_list (#constrs (Data.get thy)) c;
   34.70 -  in
   34.71 -    (case body_type T of
   34.72 -      Type (tyco, _) => AList.lookup (op =) tab tyco
   34.73 -    | _ => NONE)
   34.74 -  end;
   34.75 -
   34.76 -fun info_of_constr_permissive thy (c, T) =
   34.77 -  let
   34.78 -    val tab = Symtab.lookup_list (#constrs (Data.get thy)) c;
   34.79 -    val hint = (case body_type T of Type (tyco, _) => SOME tyco | _ => NONE);
   34.80 -    val default = if null tab then NONE else SOME (snd (List.last tab));
   34.81 -    (*conservative wrt. overloaded constructors*)
   34.82 -  in
   34.83 -    (case hint of
   34.84 -      NONE => default
   34.85 -    | SOME tyco =>
   34.86 -        (case AList.lookup (op =) tab tyco of
   34.87 -          NONE => default (*permissive*)
   34.88 -        | SOME info => SOME info))
   34.89 -  end;
   34.90 -
   34.91 -val info_of_case = Symtab.lookup o #cases o Data.get;
   34.92 -
   34.93 -fun ctrs_of_exhaust exhaust =
   34.94 -  Logic.strip_imp_prems (prop_of exhaust) |>
   34.95 -  map (head_of o snd o HOLogic.dest_eq o HOLogic.dest_Trueprop o the_single
   34.96 -    o Logic.strip_assums_hyp);
   34.97 -
   34.98 -fun case_of_case_rewrite case_rewrite =
   34.99 -  head_of (fst (HOLogic.dest_eq (HOLogic.dest_Trueprop (prop_of case_rewrite))));
  34.100 -
  34.101 -fun ctr_sugar_of_info ({exhaust, nchotomy, inject, distinct, case_rewrites, case_cong,
  34.102 -    case_cong_weak, split, split_asm, ...} : Datatype_Aux.info) =
  34.103 -  {ctrs = ctrs_of_exhaust exhaust,
  34.104 -   casex = case_of_case_rewrite (hd case_rewrites),
  34.105 -   discs = [],
  34.106 -   selss = [],
  34.107 -   exhaust = exhaust,
  34.108 -   nchotomy = nchotomy,
  34.109 -   injects = inject,
  34.110 -   distincts = distinct,
  34.111 -   case_thms = case_rewrites,
  34.112 -   case_cong = case_cong,
  34.113 -   case_cong_weak = case_cong_weak,
  34.114 -   split = split,
  34.115 -   split_asm = split_asm,
  34.116 -   disc_defs = [],
  34.117 -   disc_thmss = [],
  34.118 -   discIs = [],
  34.119 -   sel_defs = [],
  34.120 -   sel_thmss = [],
  34.121 -   distinct_discsss = [],
  34.122 -   exhaust_discs = [],
  34.123 -   exhaust_sels = [],
  34.124 -   collapses = [],
  34.125 -   expands = [],
  34.126 -   split_sels = [],
  34.127 -   split_sel_asms = [],
  34.128 -   case_eq_ifs = []};
  34.129 -
  34.130 -fun register dt_infos =
  34.131 -  Data.map (fn {types, constrs, cases} =>
  34.132 -    {types = types |> fold Symtab.update dt_infos,
  34.133 -     constrs = constrs |> fold (fn (constr, dtname_info) =>
  34.134 -         Symtab.map_default (constr, []) (cons dtname_info))
  34.135 -       (maps (fn (dtname, info as {descr, index, ...}) =>
  34.136 -          map (rpair (dtname, info) o fst) (#3 (the (AList.lookup op = descr index)))) dt_infos),
  34.137 -     cases = cases |> fold Symtab.update
  34.138 -       (map (fn (_, info as {case_name, ...}) => (case_name, info)) dt_infos)}) #>
  34.139 -  fold (fn (key, info) =>
  34.140 -    Ctr_Sugar.default_register_ctr_sugar_global key (ctr_sugar_of_info info)) dt_infos;
  34.141 -
  34.142 -
  34.143 -(* complex queries *)
  34.144 -
  34.145 -fun the_spec thy dtco =
  34.146 -  let
  34.147 -    val {descr, index, ...} = the_info thy dtco;
  34.148 -    val (_, dtys, raw_cos) = the (AList.lookup (op =) descr index);
  34.149 -    val args = map Datatype_Aux.dest_DtTFree dtys;
  34.150 -    val cos = map (fn (co, tys) => (co, map (Datatype_Aux.typ_of_dtyp descr) tys)) raw_cos;
  34.151 -  in (args, cos) end;
  34.152 -
  34.153 -fun the_descr thy (raw_tycos as raw_tyco :: _) =
  34.154 -  let
  34.155 -    val info = the_info thy raw_tyco;
  34.156 -    val descr = #descr info;
  34.157 -
  34.158 -    val (_, dtys, _) = the (AList.lookup (op =) descr (#index info));
  34.159 -    val vs = map Datatype_Aux.dest_DtTFree dtys;
  34.160 -
  34.161 -    fun is_DtTFree (Datatype_Aux.DtTFree _) = true
  34.162 -      | is_DtTFree _ = false;
  34.163 -    val k = find_index (fn (_, (_, dTs, _)) => not (forall is_DtTFree dTs)) descr;
  34.164 -    val protoTs as (dataTs, _) =
  34.165 -      chop k descr
  34.166 -      |> (pairself o map)
  34.167 -        (fn (_, (tyco, dTs, _)) => (tyco, map (Datatype_Aux.typ_of_dtyp descr) dTs));
  34.168 -
  34.169 -    val tycos = map fst dataTs;
  34.170 -    val _ =
  34.171 -      if eq_set (op =) (tycos, raw_tycos) then ()
  34.172 -      else
  34.173 -        error ("Type constructors " ^ commas_quote raw_tycos ^
  34.174 -          " do not belong exhaustively to one mutual recursive datatype");
  34.175 -
  34.176 -    val (Ts, Us) = (pairself o map) Type protoTs;
  34.177 -
  34.178 -    val names = map Long_Name.base_name tycos;
  34.179 -    val (auxnames, _) =
  34.180 -      Name.make_context names
  34.181 -      |> fold_map (Name.variant o Datatype_Aux.name_of_typ) Us;
  34.182 -    val prefix = space_implode "_" names;
  34.183 -
  34.184 -  in (descr, vs, tycos, prefix, (names, auxnames), (Ts, Us)) end;
  34.185 -
  34.186 -fun all_distincts thy Ts =
  34.187 -  let
  34.188 -    fun add_tycos (Type (tyco, Ts)) = insert (op =) tyco #> fold add_tycos Ts
  34.189 -      | add_tycos _ = I;
  34.190 -    val tycos = fold add_tycos Ts [];
  34.191 -  in map_filter (Option.map #distinct o get_info thy) tycos end;
  34.192 -
  34.193 -fun get_constrs thy dtco =
  34.194 -  (case try (the_spec thy) dtco of
  34.195 -    SOME (args, cos) =>
  34.196 -      let
  34.197 -        fun subst (v, sort) = TVar ((v, 0), sort);
  34.198 -        fun subst_ty (TFree v) = subst v
  34.199 -          | subst_ty ty = ty;
  34.200 -        val dty = Type (dtco, map subst args);
  34.201 -        fun mk_co (co, tys) = (co, map (Term.map_atyps subst_ty) tys ---> dty);
  34.202 -      in SOME (map mk_co cos) end
  34.203 -  | NONE => NONE);
  34.204 -
  34.205 -
  34.206 -
  34.207 -(** various auxiliary **)
  34.208 -
  34.209 -(* case names *)
  34.210 -
  34.211 -local
  34.212 -
  34.213 -fun dt_recs (Datatype_Aux.DtTFree _) = []
  34.214 -  | dt_recs (Datatype_Aux.DtType (_, dts)) = maps dt_recs dts
  34.215 -  | dt_recs (Datatype_Aux.DtRec i) = [i];
  34.216 -
  34.217 -fun dt_cases (descr: Datatype_Aux.descr) (_, args, constrs) =
  34.218 -  let
  34.219 -    fun the_bname i = Long_Name.base_name (#1 (the (AList.lookup (op =) descr i)));
  34.220 -    val bnames = map the_bname (distinct (op =) (maps dt_recs args));
  34.221 -  in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
  34.222 -
  34.223 -fun induct_cases descr =
  34.224 -  Datatype_Prop.indexify_names (maps (dt_cases descr) (map #2 descr));
  34.225 -
  34.226 -fun exhaust_cases descr i = dt_cases descr (the (AList.lookup (op =) descr i));
  34.227 -
  34.228 -in
  34.229 -
  34.230 -fun mk_case_names_induct descr = Rule_Cases.case_names (induct_cases descr);
  34.231 -
  34.232 -fun mk_case_names_exhausts descr new =
  34.233 -  map (Rule_Cases.case_names o exhaust_cases descr o #1)
  34.234 -    (filter (fn ((_, (name, _, _))) => member (op =) new name) descr);
  34.235 -
  34.236 -end;
  34.237 -
  34.238 -
  34.239 -
  34.240 -(** document antiquotation **)
  34.241 -
  34.242 -val antiq_setup =
  34.243 -  Thy_Output.antiquotation @{binding datatype} (Args.type_name {proper = true, strict = true})
  34.244 -    (fn {source = src, context = ctxt, ...} => fn dtco =>
  34.245 -      let
  34.246 -        val thy = Proof_Context.theory_of ctxt;
  34.247 -        val (vs, cos) = the_spec thy dtco;
  34.248 -        val ty = Type (dtco, map TFree vs);
  34.249 -        val pretty_typ_bracket = Syntax.pretty_typ (Config.put pretty_priority 1001 ctxt);
  34.250 -        fun pretty_constr (co, tys) =
  34.251 -          Pretty.block (Pretty.breaks
  34.252 -            (Syntax.pretty_term ctxt (Const (co, tys ---> ty)) ::
  34.253 -              map pretty_typ_bracket tys));
  34.254 -        val pretty_datatype =
  34.255 -          Pretty.block
  34.256 -           (Pretty.keyword1 "datatype" :: Pretty.brk 1 ::
  34.257 -            Syntax.pretty_typ ctxt ty ::
  34.258 -            Pretty.str " =" :: Pretty.brk 1 ::
  34.259 -            flat (separate [Pretty.brk 1, Pretty.str "| "] (map (single o pretty_constr) cos)));
  34.260 -      in
  34.261 -        Thy_Output.output ctxt
  34.262 -          (Thy_Output.maybe_pretty_source (K (K pretty_datatype)) ctxt src [()])
  34.263 -      end);
  34.264 -
  34.265 -
  34.266 -
  34.267 -(** abstract theory extensions relative to a datatype characterisation **)
  34.268 -
  34.269 -structure Datatype_Interpretation = Interpretation
  34.270 -(
  34.271 -  type T = Datatype_Aux.config * string list;
  34.272 -  val eq: T * T -> bool = eq_snd (op =);
  34.273 -);
  34.274 -
  34.275 -fun with_repaired_path f config (type_names as name :: _) thy =
  34.276 -  thy
  34.277 -  |> Sign.root_path
  34.278 -  |> Sign.add_path (Long_Name.qualifier name)
  34.279 -  |> f config type_names
  34.280 -  |> Sign.restore_naming thy;
  34.281 -
  34.282 -fun interpretation f = Datatype_Interpretation.interpretation (uncurry (with_repaired_path f));
  34.283 -val interpretation_data = Datatype_Interpretation.data;
  34.284 -
  34.285 -
  34.286 -
  34.287 -(** setup theory **)
  34.288 -
  34.289 -val setup =
  34.290 -  antiq_setup #>
  34.291 -  Datatype_Interpretation.init;
  34.292 -
  34.293 -open Datatype_Aux;
  34.294 -
  34.295 -end;
    35.1 --- a/src/HOL/Tools/Datatype/datatype_prop.ML	Mon Sep 01 16:17:46 2014 +0200
    35.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    35.3 @@ -1,427 +0,0 @@
    35.4 -(*  Title:      HOL/Tools/Datatype/datatype_prop.ML
    35.5 -    Author:     Stefan Berghofer, TU Muenchen
    35.6 -
    35.7 -Datatype package: characteristic properties of datatypes.
    35.8 -*)
    35.9 -
   35.10 -signature DATATYPE_PROP =
   35.11 -sig
   35.12 -  type descr = Datatype_Aux.descr
   35.13 -  val indexify_names: string list -> string list
   35.14 -  val make_tnames: typ list -> string list
   35.15 -  val make_injs : descr list -> term list list
   35.16 -  val make_distincts : descr list -> term list list (*no symmetric inequalities*)
   35.17 -  val make_ind : descr list -> term
   35.18 -  val make_casedists : descr list -> term list
   35.19 -  val make_primrec_Ts : descr list -> string list -> typ list * typ list
   35.20 -  val make_primrecs : string list -> descr list -> theory -> term list
   35.21 -  val make_cases : string list -> descr list -> theory -> term list list
   35.22 -  val make_splits : string list -> descr list -> theory -> (term * term) list
   35.23 -  val make_case_combs : string list -> descr list -> theory -> string -> term list
   35.24 -  val make_case_cong_weaks : string list -> descr list -> theory -> term list
   35.25 -  val make_case_congs : string list -> descr list -> theory -> term list
   35.26 -  val make_nchotomys : descr list -> term list
   35.27 -end;
   35.28 -
   35.29 -structure Datatype_Prop : DATATYPE_PROP =
   35.30 -struct
   35.31 -
   35.32 -type descr = Datatype_Aux.descr;
   35.33 -
   35.34 -
   35.35 -val indexify_names = Case_Translation.indexify_names;
   35.36 -val make_tnames = Case_Translation.make_tnames;
   35.37 -
   35.38 -fun make_tnames Ts =
   35.39 -  let
   35.40 -    fun type_name (TFree (name, _)) = unprefix "'" name
   35.41 -      | type_name (Type (name, _)) =
   35.42 -          let val name' = Long_Name.base_name name
   35.43 -          in if Symbol_Pos.is_identifier name' then name' else "x" end;
   35.44 -  in indexify_names (map type_name Ts) end;
   35.45 -
   35.46 -
   35.47 -(************************* injectivity of constructors ************************)
   35.48 -
   35.49 -fun make_injs descr =
   35.50 -  let
   35.51 -    val descr' = flat descr;
   35.52 -    fun make_inj T (cname, cargs) =
   35.53 -      if null cargs then I
   35.54 -      else
   35.55 -        let
   35.56 -          val Ts = map (Datatype_Aux.typ_of_dtyp descr') cargs;
   35.57 -          val constr_t = Const (cname, Ts ---> T);
   35.58 -          val tnames = make_tnames Ts;
   35.59 -          val frees = map Free (tnames ~~ Ts);
   35.60 -          val frees' = map Free (map (suffix "'") tnames ~~ Ts);
   35.61 -        in
   35.62 -          cons (HOLogic.mk_Trueprop (HOLogic.mk_eq
   35.63 -            (HOLogic.mk_eq (list_comb (constr_t, frees), list_comb (constr_t, frees')),
   35.64 -             foldr1 (HOLogic.mk_binop @{const_name HOL.conj})
   35.65 -               (map HOLogic.mk_eq (frees ~~ frees')))))
   35.66 -        end;
   35.67 -  in
   35.68 -    map2 (fn d => fn T => fold_rev (make_inj T) (#3 (snd d)) [])
   35.69 -      (hd descr) (take (length (hd descr)) (Datatype_Aux.get_rec_types descr'))
   35.70 -  end;
   35.71 -
   35.72 -
   35.73 -(************************* distinctness of constructors ***********************)
   35.74 -
   35.75 -fun make_distincts descr =
   35.76 -  let
   35.77 -    val descr' = flat descr;
   35.78 -    val recTs = Datatype_Aux.get_rec_types descr';
   35.79 -    val newTs = take (length (hd descr)) recTs;
   35.80 -
   35.81 -    fun prep_constr (cname, cargs) = (cname, map (Datatype_Aux.typ_of_dtyp descr') cargs);
   35.82 -
   35.83 -    fun make_distincts' _ [] = []
   35.84 -      | make_distincts' T ((cname, cargs) :: constrs) =
   35.85 -          let
   35.86 -            val frees = map Free (make_tnames cargs ~~ cargs);
   35.87 -            val t = list_comb (Const (cname, cargs ---> T), frees);
   35.88 -
   35.89 -            fun make_distincts'' (cname', cargs') =
   35.90 -              let
   35.91 -                val frees' = map Free (map (suffix "'") (make_tnames cargs') ~~ cargs');
   35.92 -                val t' = list_comb (Const (cname', cargs' ---> T), frees');
   35.93 -              in
   35.94 -                HOLogic.mk_Trueprop (HOLogic.Not $ HOLogic.mk_eq (t, t'))
   35.95 -              end;
   35.96 -          in map make_distincts'' constrs @ make_distincts' T constrs end;
   35.97 -  in
   35.98 -    map2 (fn ((_, (_, _, constrs))) => fn T =>
   35.99 -      make_distincts' T (map prep_constr constrs)) (hd descr) newTs
  35.100 -  end;
  35.101 -
  35.102 -
  35.103 -(********************************* induction **********************************)
  35.104 -
  35.105 -fun make_ind descr =
  35.106 -  let
  35.107 -    val descr' = flat descr;
  35.108 -    val recTs = Datatype_Aux.get_rec_types descr';
  35.109 -    val pnames =
  35.110 -      if length descr' = 1 then ["P"]
  35.111 -      else map (fn i => "P" ^ string_of_int i) (1 upto length descr');
  35.112 -
  35.113 -    fun make_pred i T =
  35.114 -      let val T' = T --> HOLogic.boolT
  35.115 -      in Free (nth pnames i, T') end;
  35.116 -
  35.117 -    fun make_ind_prem k T (cname, cargs) =
  35.118 -      let
  35.119 -        fun mk_prem ((dt, s), T) =
  35.120 -          let val (Us, U) = strip_type T
  35.121 -          in
  35.122 -            Logic.list_all (map (pair "x") Us,
  35.123 -              HOLogic.mk_Trueprop
  35.124 -                (make_pred (Datatype_Aux.body_index dt) U $
  35.125 -                  Datatype_Aux.app_bnds (Free (s, T)) (length Us)))
  35.126 -          end;
  35.127 -
  35.128 -        val recs = filter Datatype_Aux.is_rec_type cargs;
  35.129 -        val Ts = map (Datatype_Aux.typ_of_dtyp descr') cargs;
  35.130 -        val recTs' = map (Datatype_Aux.typ_of_dtyp descr') recs;
  35.131 -        val tnames = Name.variant_list pnames (make_tnames Ts);
  35.132 -        val rec_tnames = map fst (filter (Datatype_Aux.is_rec_type o snd) (tnames ~~ cargs));
  35.133 -        val frees = tnames ~~ Ts;
  35.134 -        val prems = map mk_prem (recs ~~ rec_tnames ~~ recTs');
  35.135 -      in
  35.136 -        fold_rev (Logic.all o Free) frees
  35.137 -          (Logic.list_implies (prems,
  35.138 -            HOLogic.mk_Trueprop (make_pred k T $
  35.139 -              list_comb (Const (cname, Ts ---> T), map Free frees))))
  35.140 -      end;
  35.141 -
  35.142 -    val prems =
  35.143 -      maps (fn ((i, (_, _, constrs)), T) => map (make_ind_prem i T) constrs) (descr' ~~ recTs);
  35.144 -    val tnames = make_tnames recTs;
  35.145 -    val concl =
  35.146 -      HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop @{const_name HOL.conj})
  35.147 -        (map (fn (((i, _), T), tname) => make_pred i T $ Free (tname, T))
  35.148 -          (descr' ~~ recTs ~~ tnames)));
  35.149 -
  35.150 -  in Logic.list_implies (prems, concl) end;
  35.151 -
  35.152 -(******************************* case distinction *****************************)
  35.153 -
  35.154 -fun make_casedists descr =
  35.155 -  let
  35.156 -    val descr' = flat descr;
  35.157 -
  35.158 -    fun make_casedist_prem T (cname, cargs) =
  35.159 -      let
  35.160 -        val Ts = map (Datatype_Aux.typ_of_dtyp descr') cargs;
  35.161 -        val frees = Name.variant_list ["P", "y"] (make_tnames Ts) ~~ Ts;
  35.162 -        val free_ts = map Free frees;
  35.163 -      in
  35.164 -        fold_rev (Logic.all o Free) frees
  35.165 -          (Logic.mk_implies (HOLogic.mk_Trueprop
  35.166 -            (HOLogic.mk_eq (Free ("y", T), list_comb (Const (cname, Ts ---> T), free_ts))),
  35.167 -              HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT))))
  35.168 -      end;
  35.169 -
  35.170 -    fun make_casedist ((_, (_, _, constrs))) T =
  35.171 -      let val prems = map (make_casedist_prem T) constrs
  35.172 -      in Logic.list_implies (prems, HOLogic.mk_Trueprop (Free ("P", HOLogic.boolT))) end;
  35.173 -
  35.174 -  in
  35.175 -    map2 make_casedist (hd descr)
  35.176 -      (take (length (hd descr)) (Datatype_Aux.get_rec_types descr'))
  35.177 -  end;
  35.178 -
  35.179 -(*************** characteristic equations for primrec combinator **************)
  35.180 -
  35.181 -fun make_primrec_Ts descr used =
  35.182 -  let
  35.183 -    val descr' = flat descr;
  35.184 -
  35.185 -    val rec_result_Ts =
  35.186 -      map TFree
  35.187 -        (Name.variant_list used (replicate (length descr') "'t") ~~
  35.188 -          replicate (length descr') @{sort type});
  35.189 -
  35.190 -    val reccomb_fn_Ts = maps (fn (i, (_, _, constrs)) =>
  35.191 -      map (fn (_, cargs) =>
  35.192 -        let
  35.193 -          val Ts = map (Datatype_Aux.typ_of_dtyp descr') cargs;
  35.194 -          val recs = filter (Datatype_Aux.is_rec_type o fst) (cargs ~~ Ts);
  35.195 -
  35.196 -          fun mk_argT (dt, T) =
  35.197 -            binder_types T ---> nth rec_result_Ts (Datatype_Aux.body_index dt);
  35.198 -
  35.199 -          val argTs = Ts @ map mk_argT recs
  35.200 -        in argTs ---> nth rec_result_Ts i end) constrs) descr';
  35.201 -
  35.202 -  in (rec_result_Ts, reccomb_fn_Ts) end;
  35.203 -
  35.204 -fun make_primrecs reccomb_names descr thy =
  35.205 -  let
  35.206 -    val descr' = flat descr;
  35.207 -    val recTs = Datatype_Aux.get_rec_types descr';
  35.208 -    val used = fold Term.add_tfree_namesT recTs [];
  35.209 -
  35.210 -    val (rec_result_Ts, reccomb_fn_Ts) = make_primrec_Ts descr used;
  35.211 -
  35.212 -    val rec_fns =
  35.213 -      map (uncurry (Datatype_Aux.mk_Free "f"))
  35.214 -        (reccomb_fn_Ts ~~ (1 upto (length reccomb_fn_Ts)));
  35.215 -
  35.216 -    val reccombs =
  35.217 -      map (fn ((name, T), T') => list_comb (Const (name, reccomb_fn_Ts @ [T] ---> T'), rec_fns))
  35.218 -        (reccomb_names ~~ recTs ~~ rec_result_Ts);
  35.219 -
  35.220 -    fun make_primrec T comb_t (cname, cargs) (ts, f :: fs) =
  35.221 -      let
  35.222 -        val recs = filter Datatype_Aux.is_rec_type cargs;
  35.223 -        val Ts = map (Datatype_Aux.typ_of_dtyp descr') cargs;
  35.224 -        val recTs' = map (Datatype_Aux.typ_of_dtyp descr') recs;
  35.225 -        val tnames = make_tnames Ts;
  35.226 -        val rec_tnames = map fst (filter (Datatype_Aux.is_rec_type o snd) (tnames ~~ cargs));
  35.227 -        val frees = map Free (tnames ~~ Ts);
  35.228 -        val frees' = map Free (rec_tnames ~~ recTs');
  35.229 -
  35.230 -        fun mk_reccomb ((dt, T), t) =
  35.231 -          let val (Us, U) = strip_type T in
  35.232 -            fold_rev (Term.abs o pair "x") Us
  35.233 -              (nth reccombs (Datatype_Aux.body_index dt) $ Datatype_Aux.app_bnds t (length Us))
  35.234 -          end;
  35.235 -
  35.236 -        val reccombs' = map mk_reccomb (recs ~~ recTs' ~~ frees');
  35.237 -
  35.238 -      in
  35.239 -        (ts @ [HOLogic.mk_Trueprop
  35.240 -          (HOLogic.mk_eq (comb_t $ list_comb (Const (cname, Ts ---> T), frees),
  35.241 -            list_comb (f, frees @ reccombs')))], fs)
  35.242 -      end;
  35.243 -  in
  35.244 -    fold (fn ((dt, T), comb_t) => fold (make_primrec T comb_t) (#3 (snd dt)))
  35.245 -      (descr' ~~ recTs ~~ reccombs) ([], rec_fns)
  35.246 -    |> fst
  35.247 -  end;
  35.248 -
  35.249 -(****************** make terms of form  t_case f1 ... fn  *********************)
  35.250 -
  35.251 -fun make_case_combs case_names descr thy fname =
  35.252 -  let
  35.253 -    val descr' = flat descr;
  35.254 -    val recTs = Datatype_Aux.get_rec_types descr';
  35.255 -    val used = fold Term.add_tfree_namesT recTs [];
  35.256 -    val newTs = take (length (hd descr)) recTs;
  35.257 -    val T' = TFree (singleton (Name.variant_list used) "'t", @{sort type});
  35.258 -
  35.259 -    val case_fn_Ts = map (fn (i, (_, _, constrs)) =>
  35.260 -      map (fn (_, cargs) =>
  35.261 -        let val Ts = map (Datatype_Aux.typ_of_dtyp descr') cargs
  35.262 -        in Ts ---> T' end) constrs) (hd descr);
  35.263 -  in
  35.264 -    map (fn ((name, Ts), T) => list_comb
  35.265 -      (Const (name, Ts @ [T] ---> T'),
  35.266 -        map (uncurry (Datatype_Aux.mk_Free fname)) (Ts ~~ (1 upto length Ts))))
  35.267 -          (case_names ~~ case_fn_Ts ~~ newTs)
  35.268 -  end;
  35.269 -
  35.270 -(**************** characteristic equations for case combinator ****************)
  35.271 -
  35.272 -fun make_cases case_names descr thy =
  35.273 -  let
  35.274 -    val descr' = flat descr;
  35.275 -    val recTs = Datatype_Aux.get_rec_types descr';
  35.276 -    val newTs = take (length (hd descr)) recTs;
  35.277 -
  35.278 -    fun make_case T comb_t ((cname, cargs), f) =
  35.279 -      let
  35.280 -        val Ts = map (Datatype_Aux.typ_of_dtyp descr') cargs;
  35.281 -        val frees = map Free ((make_tnames Ts) ~~ Ts);
  35.282 -      in
  35.283 -        HOLogic.mk_Trueprop
  35.284 -          (HOLogic.mk_eq (comb_t $ list_comb (Const (cname, Ts ---> T), frees),
  35.285 -            list_comb (f, frees)))
  35.286 -      end;
  35.287 -  in
  35.288 -    map (fn (((_, (_, _, constrs)), T), comb_t) =>
  35.289 -      map (make_case T comb_t) (constrs ~~ snd (strip_comb comb_t)))
  35.290 -        (hd descr ~~ newTs ~~ make_case_combs case_names descr thy "f")
  35.291 -  end;
  35.292 -
  35.293 -
  35.294 -(*************************** the "split" - equations **************************)
  35.295 -
  35.296 -fun make_splits case_names descr thy =
  35.297 -  let
  35.298 -    val descr' = flat descr;
  35.299 -    val recTs = Datatype_Aux.get_rec_types descr';
  35.300 -    val used' = fold Term.add_tfree_namesT recTs [];
  35.301 -    val newTs = take (length (hd descr)) recTs;
  35.302 -    val T' = TFree (singleton (Name.variant_list used') "'t", @{sort type});
  35.303 -    val P = Free ("P", T' --> HOLogic.boolT);
  35.304 -
  35.305 -    fun make_split (((_, (_, _, constrs)), T), comb_t) =
  35.306 -      let
  35.307 -        val (_, fs) = strip_comb comb_t;
  35.308 -        val used = ["P", "x"] @ map (fst o dest_Free) fs;
  35.309 -
  35.310 -        fun process_constr ((cname, cargs), f) (t1s, t2s) =
  35.311 -          let
  35.312 -            val Ts = map (Datatype_Aux.typ_of_dtyp descr') cargs;
  35.313 -            val frees = map Free (Name.variant_list used (make_tnames Ts) ~~ Ts);
  35.314 -            val eqn = HOLogic.mk_eq (Free ("x", T), list_comb (Const (cname, Ts ---> T), frees));
  35.315 -            val P' = P $ list_comb (f, frees);
  35.316 -          in
  35.317 -           (fold_rev (fn Free (s, T) => fn t => HOLogic.mk_all (s, T, t)) frees
  35.318 -             (HOLogic.imp $ eqn $ P') :: t1s,
  35.319 -            fold_rev (fn Free (s, T) => fn t => HOLogic.mk_exists (s, T, t)) frees
  35.320 -             (HOLogic.conj $ eqn $ (HOLogic.Not $ P')) :: t2s)
  35.321 -          end;
  35.322 -
  35.323 -        val (t1s, t2s) = fold_rev process_constr (constrs ~~ fs) ([], []);
  35.324 -        val lhs = P $ (comb_t $ Free ("x", T));
  35.325 -      in
  35.326 -        (HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, Datatype_Aux.mk_conj t1s)),
  35.327 -         HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, HOLogic.Not $ Datatype_Aux.mk_disj t2s)))
  35.328 -      end
  35.329 -
  35.330 -  in
  35.331 -    map make_split (hd descr ~~ newTs ~~ make_case_combs case_names descr thy "f")
  35.332 -  end;
  35.333 -
  35.334 -(************************* additional rules for TFL ***************************)
  35.335 -
  35.336 -fun make_case_cong_weaks case_names descr thy =
  35.337 -  let
  35.338 -    val case_combs = make_case_combs case_names descr thy "f";
  35.339 -
  35.340 -    fun mk_case_cong comb =
  35.341 -      let
  35.342 -        val Type ("fun", [T, _]) = fastype_of comb;
  35.343 -        val M = Free ("M", T);
  35.344 -        val M' = Free ("M'", T);
  35.345 -      in
  35.346 -        Logic.mk_implies (HOLogic.mk_Trueprop (HOLogic.mk_eq (M, M')),
  35.347 -          HOLogic.mk_Trueprop (HOLogic.mk_eq (comb $ M, comb $ M')))
  35.348 -      end;
  35.349 -  in
  35.350 -    map mk_case_cong case_combs
  35.351 -  end;
  35.352 -
  35.353 -
  35.354 -(*---------------------------------------------------------------------------
  35.355 - * Structure of case congruence theorem looks like this:
  35.356 - *
  35.357 - *    (M = M')
  35.358 - *    ==> (!!x1,...,xk. (M' = C1 x1..xk) ==> (f1 x1..xk = g1 x1..xk))
  35.359 - *    ==> ...
  35.360 - *    ==> (!!x1,...,xj. (M' = Cn x1..xj) ==> (fn x1..xj = gn x1..xj))
  35.361 - *    ==>
  35.362 - *      (ty_case f1..fn M = ty_case g1..gn M')
  35.363 - *---------------------------------------------------------------------------*)
  35.364 -
  35.365 -fun make_case_congs case_names descr thy =
  35.366 -  let
  35.367 -    val case_combs = make_case_combs case_names descr thy "f";
  35.368 -    val case_combs' = make_case_combs case_names descr thy "g";
  35.369 -
  35.370 -    fun mk_case_cong ((comb, comb'), (_, (_, _, constrs))) =
  35.371 -      let
  35.372 -        val Type ("fun", [T, _]) = fastype_of comb;
  35.373 -        val (_, fs) = strip_comb comb;
  35.374 -        val (_, gs) = strip_comb comb';
  35.375 -        val used = ["M", "M'"] @ map (fst o dest_Free) (fs @ gs);
  35.376 -        val M = Free ("M", T);
  35.377 -        val M' = Free ("M'", T);
  35.378 -
  35.379 -        fun mk_clause ((f, g), (cname, _)) =
  35.380 -          let
  35.381 -            val Ts = binder_types (fastype_of f);
  35.382 -            val tnames = Name.variant_list used (make_tnames Ts);
  35.383 -            val frees = map Free (tnames ~~ Ts);
  35.384 -          in
  35.385 -            fold_rev Logic.all frees
  35.386 -              (Logic.mk_implies
  35.387 -                (HOLogic.mk_Trueprop
  35.388 -                  (HOLogic.mk_eq (M', list_comb (Const (cname, Ts ---> T), frees))),
  35.389 -                 HOLogic.mk_Trueprop
  35.390 -                  (HOLogic.mk_eq (list_comb (f, frees), list_comb (g, frees)))))
  35.391 -          end;
  35.392 -      in
  35.393 -        Logic.list_implies (HOLogic.mk_Trueprop (HOLogic.mk_eq (M, M')) ::
  35.394 -          map mk_clause (fs ~~ gs ~~ constrs),
  35.395 -            HOLogic.mk_Trueprop (HOLogic.mk_eq (comb $ M, comb' $ M')))
  35.396 -      end;
  35.397 -  in
  35.398 -    map mk_case_cong (case_combs ~~ case_combs' ~~ hd descr)
  35.399 -  end;
  35.400 -
  35.401 -(*---------------------------------------------------------------------------
  35.402 - * Structure of exhaustion theorem looks like this:
  35.403 - *
  35.404 - *    !v. (? y1..yi. v = C1 y1..yi) | ... | (? y1..yj. v = Cn y1..yj)
  35.405 - *---------------------------------------------------------------------------*)
  35.406 -
  35.407 -fun make_nchotomys descr =
  35.408 -  let
  35.409 -    val descr' = flat descr;
  35.410 -    val recTs = Datatype_Aux.get_rec_types descr';
  35.411 -    val newTs = take (length (hd descr)) recTs;
  35.412 -
  35.413 -    fun mk_eqn T (cname, cargs) =
  35.414 -      let
  35.415 -        val Ts = map (Datatype_Aux.typ_of_dtyp descr') cargs;
  35.416 -        val tnames = Name.variant_list ["v"] (make_tnames Ts);
  35.417 -        val frees = tnames ~~ Ts;
  35.418 -      in
  35.419 -        fold_rev (fn (s, T') => fn t => HOLogic.mk_exists (s, T', t)) frees
  35.420 -          (HOLogic.mk_eq (Free ("v", T),
  35.421 -            list_comb (Const (cname, Ts ---> T), map Free frees)))
  35.422 -      end;
  35.423 -  in
  35.424 -    map (fn ((_, (_, _, constrs)), T) =>
  35.425 -        HOLogic.mk_Trueprop
  35.426 -          (HOLogic.mk_all ("v", T, Datatype_Aux.mk_disj (map (mk_eqn T) constrs))))
  35.427 -      (hd descr ~~ newTs)
  35.428 -  end;
  35.429 -
  35.430 -end;
    36.1 --- a/src/HOL/Tools/Datatype/datatype_realizer.ML	Mon Sep 01 16:17:46 2014 +0200
    36.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    36.3 @@ -1,246 +0,0 @@
    36.4 -(*  Title:      HOL/Tools/Datatype/datatype_realizer.ML
    36.5 -    Author:     Stefan Berghofer, TU Muenchen
    36.6 -
    36.7 -Program extraction from proofs involving datatypes:
    36.8 -realizers for induction and case analysis.
    36.9 -*)
   36.10 -
   36.11 -signature DATATYPE_REALIZER =
   36.12 -sig
   36.13 -  val add_dt_realizers: Datatype_Aux.config -> string list -> theory -> theory
   36.14 -  val setup: theory -> theory
   36.15 -end;
   36.16 -
   36.17 -structure Datatype_Realizer : DATATYPE_REALIZER =
   36.18 -struct
   36.19 -
   36.20 -fun subsets i j =
   36.21 -  if i <= j then
   36.22 -    let val is = subsets (i+1) j
   36.23 -    in map (fn ks => i::ks) is @ is end
   36.24 -  else [[]];
   36.25 -
   36.26 -fun is_unit t = body_type (fastype_of t) = HOLogic.unitT;
   36.27 -
   36.28 -fun tname_of (Type (s, _)) = s
   36.29 -  | tname_of _ = "";
   36.30 -
   36.31 -fun make_ind ({descr, rec_names, rec_rewrites, induct, ...} : Datatype_Aux.info) is thy =
   36.32 -  let
   36.33 -    val ctxt = Proof_Context.init_global thy;
   36.34 -    val cert = cterm_of thy;
   36.35 -
   36.36 -    val recTs = Datatype_Aux.get_rec_types descr;
   36.37 -    val pnames =
   36.38 -      if length descr = 1 then ["P"]
   36.39 -      else map (fn i => "P" ^ string_of_int i) (1 upto length descr);
   36.40 -
   36.41 -    val rec_result_Ts = map (fn ((i, _), P) =>
   36.42 -        if member (op =) is i then TFree ("'" ^ P, @{sort type}) else HOLogic.unitT)
   36.43 -      (descr ~~ pnames);
   36.44 -
   36.45 -    fun make_pred i T U r x =
   36.46 -      if member (op =) is i then
   36.47 -        Free (nth pnames i, T --> U --> HOLogic.boolT) $ r $ x
   36.48 -      else Free (nth pnames i, U --> HOLogic.boolT) $ x;
   36.49 -
   36.50 -    fun mk_all i s T t =
   36.51 -      if member (op =) is i then Logic.all (Free (s, T)) t else t;
   36.52 -
   36.53 -    val (prems, rec_fns) = split_list (flat (fst (fold_map
   36.54 -      (fn ((i, (_, _, constrs)), T) => fold_map (fn (cname, cargs) => fn j =>
   36.55 -        let
   36.56 -          val Ts = map (Datatype_Aux.typ_of_dtyp descr) cargs;
   36.57 -          val tnames = Name.variant_list pnames (Datatype_Prop.make_tnames Ts);
   36.58 -          val recs = filter (Datatype_Aux.is_rec_type o fst o fst) (cargs ~~ tnames ~~ Ts);
   36.59 -          val frees = tnames ~~ Ts;
   36.60 -
   36.61 -          fun mk_prems vs [] =
   36.62 -                let
   36.63 -                  val rT = nth (rec_result_Ts) i;
   36.64 -                  val vs' = filter_out is_unit vs;
   36.65 -                  val f = Datatype_Aux.mk_Free "f" (map fastype_of vs' ---> rT) j;
   36.66 -                  val f' =
   36.67 -                    Envir.eta_contract (fold_rev (absfree o dest_Free) vs
   36.68 -                      (if member (op =) is i then list_comb (f, vs') else HOLogic.unit));
   36.69 -                in
   36.70 -                  (HOLogic.mk_Trueprop (make_pred i rT T (list_comb (f, vs'))
   36.71 -                    (list_comb (Const (cname, Ts ---> T), map Free frees))), f')
   36.72 -                end
   36.73 -            | mk_prems vs (((dt, s), T) :: ds) =
   36.74 -                let
   36.75 -                  val k = Datatype_Aux.body_index dt;
   36.76 -                  val (Us, U) = strip_type T;
   36.77 -                  val i = length Us;
   36.78 -                  val rT = nth (rec_result_Ts) k;
   36.79 -                  val r = Free ("r" ^ s, Us ---> rT);
   36.80 -                  val (p, f) = mk_prems (vs @ [r]) ds;
   36.81 -                in
   36.82 -                  (mk_all k ("r" ^ s) (Us ---> rT) (Logic.mk_implies
   36.83 -                    (Logic.list_all (map (pair "x") Us, HOLogic.mk_Trueprop
   36.84 -                      (make_pred k rT U (Datatype_Aux.app_bnds r i)
   36.85 -                        (Datatype_Aux.app_bnds (Free (s, T)) i))), p)), f)
   36.86 -                end;
   36.87 -        in (apfst (fold_rev (Logic.all o Free) frees) (mk_prems (map Free frees) recs), j + 1) end)
   36.88 -          constrs) (descr ~~ recTs) 1)));
   36.89 -
   36.90 -    fun mk_proj _ [] t = t
   36.91 -      | mk_proj j (i :: is) t =
   36.92 -          if null is then t
   36.93 -          else if (j: int) = i then HOLogic.mk_fst t
   36.94 -          else mk_proj j is (HOLogic.mk_snd t);
   36.95 -
   36.96 -    val tnames = Datatype_Prop.make_tnames recTs;
   36.97 -    val fTs = map fastype_of rec_fns;
   36.98 -    val ps = map (fn ((((i, _), T), U), s) => Abs ("x", T, make_pred i U T
   36.99 -      (list_comb (Const (s, fTs ---> T --> U), rec_fns) $ Bound 0) (Bound 0)))
  36.100 -        (descr ~~ recTs ~~ rec_result_Ts ~~ rec_names);
  36.101 -    val r =
  36.102 -      if null is then Extraction.nullt
  36.103 -      else
  36.104 -        foldr1 HOLogic.mk_prod (map_filter (fn (((((i, _), T), U), s), tname) =>
  36.105 -          if member (op =) is i then SOME
  36.106 -            (list_comb (Const (s, fTs ---> T --> U), rec_fns) $ Free (tname, T))
  36.107 -          else NONE) (descr ~~ recTs ~~ rec_result_Ts ~~ rec_names ~~ tnames));
  36.108 -    val concl =
  36.109 -      HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop @{const_name HOL.conj})
  36.110 -        (map (fn ((((i, _), T), U), tname) =>
  36.111 -          make_pred i U T (mk_proj i is r) (Free (tname, T)))
  36.112 -            (descr ~~ recTs ~~ rec_result_Ts ~~ tnames)));
  36.113 -    val inst = map (pairself cert) (map head_of (HOLogic.dest_conj
  36.114 -      (HOLogic.dest_Trueprop (concl_of induct))) ~~ ps);
  36.115 -
  36.116 -    val thm =
  36.117 -      Goal.prove_internal ctxt (map cert prems) (cert concl)
  36.118 -        (fn prems =>
  36.119 -           EVERY [
  36.120 -            rewrite_goals_tac ctxt (map mk_meta_eq [@{thm fst_conv}, @{thm snd_conv}]),
  36.121 -            rtac (cterm_instantiate inst induct) 1,
  36.122 -            ALLGOALS (Object_Logic.atomize_prems_tac ctxt),
  36.123 -            rewrite_goals_tac ctxt (@{thm o_def} :: map mk_meta_eq rec_rewrites),
  36.124 -            REPEAT ((resolve_tac prems THEN_ALL_NEW (fn i =>
  36.125 -              REPEAT (etac allE i) THEN atac i)) 1)])
  36.126 -      |> Drule.export_without_context;
  36.127 -
  36.128 -    val ind_name = Thm.derivation_name induct;
  36.129 -    val vs = map (nth pnames) is;
  36.130 -    val (thm', thy') = thy
  36.131 -      |> Sign.root_path
  36.132 -      |> Global_Theory.store_thm
  36.133 -        (Binding.qualified_name (space_implode "_" (ind_name :: vs @ ["correctness"])), thm)
  36.134 -      ||> Sign.restore_naming thy;
  36.135 -
  36.136 -    val ivs = rev (Term.add_vars (Logic.varify_global (Datatype_Prop.make_ind [descr])) []);
  36.137 -    val rvs = rev (Thm.fold_terms Term.add_vars thm' []);
  36.138 -    val ivs1 = map Var (filter_out (fn (_, T) => @{type_name bool} = tname_of (body_type T)) ivs);
  36.139 -    val ivs2 = map (fn (ixn, _) => Var (ixn, the (AList.lookup (op =) rvs ixn))) ivs;
  36.140 -
  36.141 -    val prf =
  36.142 -      Extraction.abs_corr_shyps thy' induct vs ivs2
  36.143 -        (fold_rev (fn (f, p) => fn prf =>
  36.144 -            (case head_of (strip_abs_body f) of
  36.145 -              Free (s, T) =>
  36.146 -                let val T' = Logic.varifyT_global T in
  36.147 -                  Abst (s, SOME T', Proofterm.prf_abstract_over
  36.148 -                    (Var ((s, 0), T')) (AbsP ("H", SOME p, prf)))
  36.149 -                end
  36.150 -            | _ => AbsP ("H", SOME p, prf)))
  36.151 -          (rec_fns ~~ prems_of thm)
  36.152 -          (Proofterm.proof_combP
  36.153 -            (Reconstruct.proof_of thm', map PBound (length prems - 1 downto 0))));
  36.154 -
  36.155 -    val r' =
  36.156 -      if null is then r
  36.157 -      else
  36.158 -        Logic.varify_global (fold_rev lambda
  36.159 -          (map Logic.unvarify_global ivs1 @ filter_out is_unit
  36.160 -              (map (head_of o strip_abs_body) rec_fns)) r);
  36.161 -
  36.162 -  in Extraction.add_realizers_i [(ind_name, (vs, r', prf))] thy' end;
  36.163 -
  36.164 -
  36.165 -fun make_casedists ({index, descr, case_name, case_rewrites, exhaust, ...} : Datatype_Aux.info)
  36.166 -    thy =
  36.167 -  let
  36.168 -    val ctxt = Proof_Context.init_global thy;
  36.169 -    val cert = cterm_of thy;
  36.170 -    val rT = TFree ("'P", @{sort type});
  36.171 -    val rT' = TVar (("'P", 0), @{sort type});
  36.172 -
  36.173 -    fun make_casedist_prem T (cname, cargs) =
  36.174 -      let
  36.175 -        val Ts = map (Datatype_Aux.typ_of_dtyp descr) cargs;
  36.176 -        val frees = Name.variant_list ["P", "y"] (Datatype_Prop.make_tnames Ts) ~~ Ts;
  36.177 -        val free_ts = map Free frees;
  36.178 -        val r = Free ("r" ^ Long_Name.base_name cname, Ts ---> rT)
  36.179 -      in
  36.180 -        (r, fold_rev Logic.all free_ts
  36.181 -          (Logic.mk_implies (HOLogic.mk_Trueprop
  36.182 -            (HOLogic.mk_eq (Free ("y", T), list_comb (Const (cname, Ts ---> T), free_ts))),
  36.183 -              HOLogic.mk_Trueprop (Free ("P", rT --> HOLogic.boolT) $
  36.184 -                list_comb (r, free_ts)))))
  36.185 -      end;
  36.186 -
  36.187 -    val SOME (_, _, constrs) = AList.lookup (op =) descr index;
  36.188 -    val T = nth (Datatype_Aux.get_rec_types descr) index;
  36.189 -    val (rs, prems) = split_list (map (make_casedist_prem T) constrs);
  36.190 -    val r = Const (case_name, map fastype_of rs ---> T --> rT);
  36.191 -
  36.192 -    val y = Var (("y", 0), Logic.varifyT_global T);
  36.193 -    val y' = Free ("y", T);
  36.194 -
  36.195 -    val thm =
  36.196 -      Goal.prove_internal ctxt (map cert prems)
  36.197 -        (cert (HOLogic.mk_Trueprop (Free ("P", rT --> HOLogic.boolT) $ list_comb (r, rs @ [y']))))
  36.198 -        (fn prems =>
  36.199 -           EVERY [
  36.200 -            rtac (cterm_instantiate [(cert y, cert y')] exhaust) 1,
  36.201 -            ALLGOALS (EVERY'
  36.202 -              [asm_simp_tac (put_simpset HOL_basic_ss ctxt addsimps case_rewrites),
  36.203 -               resolve_tac prems, asm_simp_tac (put_simpset HOL_basic_ss ctxt)])])
  36.204 -      |> Drule.export_without_context;
  36.205 -
  36.206 -    val exh_name = Thm.derivation_name exhaust;
  36.207 -    val (thm', thy') = thy
  36.208 -      |> Sign.root_path
  36.209 -      |> Global_Theory.store_thm (Binding.qualified_name (exh_name ^ "_P_correctness"), thm)
  36.210 -      ||> Sign.restore_naming thy;
  36.211 -
  36.212 -    val P = Var (("P", 0), rT' --> HOLogic.boolT);
  36.213 -    val prf =
  36.214 -      Extraction.abs_corr_shyps thy' exhaust ["P"] [y, P]
  36.215 -        (fold_rev (fn (p, r) => fn prf =>
  36.216 -            Proofterm.forall_intr_proof' (Logic.varify_global r)
  36.217 -              (AbsP ("H", SOME (Logic.varify_global p), prf)))
  36.218 -          (prems ~~ rs)
  36.219 -          (Proofterm.proof_combP
  36.220 -            (Reconstruct.proof_of thm', map PBound (length prems - 1 downto 0))));
  36.221 -    val prf' =
  36.222 -      Extraction.abs_corr_shyps thy' exhaust []
  36.223 -        (map Var (Term.add_vars (prop_of exhaust) [])) (Reconstruct.proof_of exhaust);
  36.224 -    val r' =
  36.225 -      Logic.varify_global (Abs ("y", T,
  36.226 -        (fold_rev (Term.abs o dest_Free) rs
  36.227 -          (list_comb (r, map Bound ((length rs - 1 downto 0) @ [length rs]))))));
  36.228 -  in
  36.229 -    Extraction.add_realizers_i
  36.230 -      [(exh_name, (["P"], r', prf)),
  36.231 -       (exh_name, ([], Extraction.nullt, prf'))] thy'
  36.232 -  end;
  36.233 -
  36.234 -fun add_dt_realizers config names thy =
  36.235 -  if not (Proofterm.proofs_enabled ()) then thy
  36.236 -  else
  36.237 -    let
  36.238 -      val _ = Datatype_Aux.message config "Adding realizers for induction and case analysis ...";
  36.239 -      val infos = map (Datatype_Data.the_info thy) names;
  36.240 -      val info :: _ = infos;
  36.241 -    in
  36.242 -      thy
  36.243 -      |> fold_rev (make_ind info) (subsets 0 (length (#descr info) - 1))
  36.244 -      |> fold_rev make_casedists infos
  36.245 -    end;
  36.246 -
  36.247 -val setup = Datatype_Data.interpretation add_dt_realizers;
  36.248 -
  36.249 -end;
    37.1 --- a/src/HOL/Tools/Datatype/primrec.ML	Mon Sep 01 16:17:46 2014 +0200
    37.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    37.3 @@ -1,311 +0,0 @@
    37.4 -(*  Title:      HOL/Tools/Datatype/primrec.ML
    37.5 -    Author:     Norbert Voelker, FernUni Hagen
    37.6 -    Author:     Stefan Berghofer, TU Muenchen
    37.7 -    Author:     Florian Haftmann, TU Muenchen
    37.8 -
    37.9 -Primitive recursive functions on datatypes.
   37.10 -*)
   37.11 -
   37.12 -signature PRIMREC =
   37.13 -sig
   37.14 -  val add_primrec: (binding * typ option * mixfix) list ->
   37.15 -    (Attrib.binding * term) list -> local_theory -> (term list * thm list) * local_theory
   37.16 -  val add_primrec_cmd: (binding * string option * mixfix) list ->
   37.17 -    (Attrib.binding * string) list -> local_theory -> (term list * thm list) * local_theory
   37.18 -  val add_primrec_global: (binding * typ option * mixfix) list ->
   37.19 -    (Attrib.binding * term) list -> theory -> (term list * thm list) * theory
   37.20 -  val add_primrec_overloaded: (string * (string * typ) * bool) list ->
   37.21 -    (binding * typ option * mixfix) list ->
   37.22 -    (Attrib.binding * term) list -> theory -> (term list * thm list) * theory
   37.23 -  val add_primrec_simple: ((binding * typ) * mixfix) list -> term list ->
   37.24 -    local_theory -> (string * (term list * thm list)) * local_theory
   37.25 -end;
   37.26 -
   37.27 -structure Primrec : PRIMREC =
   37.28 -struct
   37.29 -
   37.30 -exception PrimrecError of string * term option;
   37.31 -
   37.32 -fun primrec_error msg = raise PrimrecError (msg, NONE);
   37.33 -fun primrec_error_eqn msg eqn = raise PrimrecError (msg, SOME eqn);
   37.34 -
   37.35 -
   37.36 -(* preprocessing of equations *)
   37.37 -
   37.38 -fun process_eqn is_fixed spec rec_fns =
   37.39 -  let
   37.40 -    val (vs, Ts) = split_list (strip_qnt_vars @{const_name Pure.all} spec);
   37.41 -    val body = strip_qnt_body @{const_name Pure.all} spec;
   37.42 -    val (vs', _) = fold_map Name.variant vs (Name.make_context (fold_aterms
   37.43 -      (fn Free (v, _) => insert (op =) v | _ => I) body []));
   37.44 -    val eqn = curry subst_bounds (map2 (curry Free) vs' Ts |> rev) body;
   37.45 -    val (lhs, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop eqn)
   37.46 -      handle TERM _ => primrec_error "not a proper equation";
   37.47 -    val (recfun, args) = strip_comb lhs;
   37.48 -    val fname =
   37.49 -      (case recfun of
   37.50 -        Free (v, _) =>
   37.51 -          if is_fixed v then v
   37.52 -          else primrec_error "illegal head of function equation"
   37.53 -      | _ => primrec_error "illegal head of function equation");
   37.54 -
   37.55 -    val (ls', rest)  = take_prefix is_Free args;
   37.56 -    val (middle, rs') = take_suffix is_Free rest;
   37.57 -    val rpos = length ls';
   37.58 -
   37.59 -    val (constr, cargs') =
   37.60 -      if null middle then primrec_error "constructor missing"
   37.61 -      else strip_comb (hd middle);
   37.62 -    val (cname, T) = dest_Const constr
   37.63 -      handle TERM _ => primrec_error "ill-formed constructor";
   37.64 -    val (tname, _) = dest_Type (body_type T) handle TYPE _ =>
   37.65 -      primrec_error "cannot determine datatype associated with function"
   37.66 -
   37.67 -    val (ls, cargs, rs) =
   37.68 -      (map dest_Free ls', map dest_Free cargs', map dest_Free rs')
   37.69 -      handle TERM _ => primrec_error "illegal argument in pattern";
   37.70 -    val lfrees = ls @ rs @ cargs;
   37.71 -
   37.72 -    fun check_vars _ [] = ()
   37.73 -      | check_vars s vars = primrec_error (s ^ commas_quote (map fst vars)) eqn;
   37.74 -  in
   37.75 -    if length middle > 1 then
   37.76 -      primrec_error "more than one non-variable in pattern"
   37.77 -    else
   37.78 -     (check_vars "repeated variable names in pattern: " (duplicates (op =) lfrees);
   37.79 -      check_vars "extra variables on rhs: "
   37.80 -        (Term.add_frees rhs [] |> subtract (op =) lfrees
   37.81 -          |> filter_out (is_fixed o fst));
   37.82 -      (case AList.lookup (op =) rec_fns fname of
   37.83 -        NONE =>
   37.84 -          (fname, (tname, rpos, [(cname, (ls, cargs, rs, rhs, eqn))])) :: rec_fns
   37.85 -      | SOME (_, rpos', eqns) =>
   37.86 -          if AList.defined (op =) eqns cname then
   37.87 -            primrec_error "constructor already occurred as pattern"
   37.88 -          else if rpos <> rpos' then
   37.89 -            primrec_error "position of recursive argument inconsistent"
   37.90 -          else
   37.91 -            AList.update (op =)
   37.92 -              (fname, (tname, rpos, (cname, (ls, cargs, rs, rhs, eqn)) :: eqns))
   37.93 -              rec_fns))
   37.94 -  end handle PrimrecError (msg, NONE) => primrec_error_eqn msg spec;
   37.95 -
   37.96 -fun process_fun descr eqns (i, fname) (fnames, fnss) =
   37.97 -  let
   37.98 -    val (_, (tname, _, constrs)) = nth descr i;
   37.99 -
  37.100 -    (* substitute "fname ls x rs" by "y ls rs" for (x, (_, y)) in subs *)
  37.101 -
  37.102 -    fun subst [] t fs = (t, fs)
  37.103 -      | subst subs (Abs (a, T, t)) fs =
  37.104 -          fs
  37.105 -          |> subst subs t
  37.106 -          |-> (fn t' => pair (Abs (a, T, t')))
  37.107 -      | subst subs (t as (_ $ _)) fs =
  37.108 -          let
  37.109 -            val (f, ts) = strip_comb t;
  37.110 -          in
  37.111 -            if is_Free f
  37.112 -              andalso member (fn ((v, _), (w, _)) => v = w) eqns (dest_Free f) then
  37.113 -              let
  37.114 -                val (fname', _) = dest_Free f;
  37.115 -                val (_, rpos, _) = the (AList.lookup (op =) eqns fname');
  37.116 -                val (ls, rs) = chop rpos ts
  37.117 -                val (x', rs') =
  37.118 -                  (case rs of
  37.119 -                    x' :: rs => (x', rs)
  37.120 -                  | [] => primrec_error ("not enough arguments in recursive application\n" ^
  37.121 -                      "of function " ^ quote fname' ^ " on rhs"));
  37.122 -                val (x, xs) = strip_comb x';
  37.123 -              in
  37.124 -                (case AList.lookup (op =) subs x of
  37.125 -                  NONE =>
  37.126 -                    fs
  37.127 -                    |> fold_map (subst subs) ts
  37.128 -                    |-> (fn ts' => pair (list_comb (f, ts')))
  37.129 -                | SOME (i', y) =>
  37.130 -                    fs
  37.131 -                    |> fold_map (subst subs) (xs @ ls @ rs')
  37.132 -                    ||> process_fun descr eqns (i', fname')
  37.133 -                    |-> (fn ts' => pair (list_comb (y, ts'))))
  37.134 -              end
  37.135 -            else
  37.136 -              fs
  37.137 -              |> fold_map (subst subs) (f :: ts)
  37.138 -              |-> (fn f' :: ts' => pair (list_comb (f', ts')))
  37.139 -          end
  37.140 -      | subst _ t fs = (t, fs);
  37.141 -
  37.142 -    (* translate rec equations into function arguments suitable for rec comb *)
  37.143 -
  37.144 -    fun trans eqns (cname, cargs) (fnames', fnss', fns) =
  37.145 -      (case AList.lookup (op =) eqns cname of
  37.146 -        NONE => (warning ("No equation for constructor " ^ quote cname ^
  37.147 -          "\nin definition of function " ^ quote fname);
  37.148 -            (fnames', fnss', (Const (@{const_name undefined}, dummyT)) :: fns))
  37.149 -      | SOME (ls, cargs', rs, rhs, eq) =>
  37.150 -          let
  37.151 -            val recs = filter (Datatype_Aux.is_rec_type o snd) (cargs' ~~ cargs);
  37.152 -            val rargs = map fst recs;
  37.153 -            val subs = map (rpair dummyT o fst)
  37.154 -              (rev (Term.rename_wrt_term rhs rargs));
  37.155 -            val (rhs', (fnames'', fnss'')) = subst (map2 (fn (x, y) => fn z =>
  37.156 -              (Free x, (Datatype_Aux.body_index y, Free z))) recs subs) rhs (fnames', fnss')
  37.157 -                handle PrimrecError (s, NONE) => primrec_error_eqn s eq
  37.158 -          in
  37.159 -            (fnames'', fnss'', fold_rev absfree (cargs' @ subs @ ls @ rs) rhs' :: fns)
  37.160 -          end)
  37.161 -
  37.162 -  in
  37.163 -    (case AList.lookup (op =) fnames i of
  37.164 -      NONE =>
  37.165 -        if exists (fn (_, v) => fname = v) fnames then
  37.166 -          primrec_error ("inconsistent functions for datatype " ^ quote tname)
  37.167 -        else
  37.168 -          let
  37.169 -            val (_, _, eqns) = the (AList.lookup (op =) eqns fname);
  37.170 -            val (fnames', fnss', fns) = fold_rev (trans eqns) constrs
  37.171 -              ((i, fname) :: fnames, fnss, [])
  37.172 -          in
  37.173 -            (fnames', (i, (fname, #1 (snd (hd eqns)), fns)) :: fnss')
  37.174 -          end
  37.175 -    | SOME fname' =>
  37.176 -        if fname = fname' then (fnames, fnss)
  37.177 -        else primrec_error ("inconsistent functions for datatype " ^ quote tname))
  37.178 -  end;
  37.179 -
  37.180 -
  37.181 -(* prepare functions needed for definitions *)
  37.182 -
  37.183 -fun get_fns fns ((i : int, (tname, _, constrs)), rec_name) (fs, defs) =
  37.184 -  (case AList.lookup (op =) fns i of
  37.185 -    NONE =>
  37.186 -      let
  37.187 -        val dummy_fns = map (fn (_, cargs) => Const (@{const_name undefined},
  37.188 -          replicate (length cargs + length (filter Datatype_Aux.is_rec_type cargs))
  37.189 -            dummyT ---> HOLogic.unitT)) constrs;
  37.190 -        val _ = warning ("No function definition for datatype " ^ quote tname)
  37.191 -      in
  37.192 -        (dummy_fns @ fs, defs)
  37.193 -      end
  37.194 -  | SOME (fname, ls, fs') => (fs' @ fs, (fname, ls, rec_name, tname) :: defs));
  37.195 -
  37.196 -
  37.197 -(* make definition *)
  37.198 -
  37.199 -fun make_def ctxt fixes fs (fname, ls, rec_name, tname) =
  37.200 -  let
  37.201 -    val SOME (var, varT) = get_first (fn ((b, T), mx) =>
  37.202 -      if Binding.name_of b = fname then SOME ((b, mx), T) else NONE) fixes;
  37.203 -    val def_name = Thm.def_name (Long_Name.base_name fname);
  37.204 -    val raw_rhs = fold_rev (fn T => fn t => Abs ("", T, t)) (map snd ls @ [dummyT])
  37.205 -      (list_comb (Const (rec_name, dummyT), fs @ map Bound (0 :: (length ls downto 1))))
  37.206 -    val rhs = singleton (Syntax.check_terms ctxt) (Type.constraint varT raw_rhs);
  37.207 -  in (var, ((Binding.conceal (Binding.name def_name), []), rhs)) end;
  37.208 -
  37.209 -
  37.210 -(* find datatypes which contain all datatypes in tnames' *)
  37.211 -
  37.212 -fun find_dts _ _ [] = []
  37.213 -  | find_dts dt_info tnames' (tname :: tnames) =
  37.214 -      (case Symtab.lookup dt_info tname of
  37.215 -        NONE => primrec_error (quote tname ^ " is not a datatype")
  37.216 -      | SOME (dt : Datatype_Aux.info) =>
  37.217 -          if subset (op =) (tnames', map (#1 o snd) (#descr dt)) then
  37.218 -            (tname, dt) :: (find_dts dt_info tnames' tnames)
  37.219 -          else find_dts dt_info tnames' tnames);
  37.220 -
  37.221 -
  37.222 -(* distill primitive definition(s) from primrec specification *)
  37.223 -
  37.224 -fun distill ctxt fixes eqs =
  37.225 -  let
  37.226 -    val eqns = fold_rev (process_eqn (fn v => Variable.is_fixed ctxt v
  37.227 -      orelse exists (fn ((w, _), _) => v = Binding.name_of w) fixes)) eqs [];
  37.228 -    val tnames = distinct (op =) (map (#1 o snd) eqns);
  37.229 -    val dts = find_dts (Datatype_Data.get_all (Proof_Context.theory_of ctxt)) tnames tnames;
  37.230 -    val main_fns = map (fn (tname, {index, ...}) =>
  37.231 -      (index, (fst o the o find_first (fn (_, x) => #1 x = tname)) eqns)) dts;
  37.232 -    val {descr, rec_names, rec_rewrites, ...} =
  37.233 -      if null dts then primrec_error
  37.234 -        ("datatypes " ^ commas_quote tnames ^ "\nare not mutually recursive")
  37.235 -      else snd (hd dts);
  37.236 -    val (fnames, fnss) = fold_rev (process_fun descr eqns) main_fns ([], []);
  37.237 -    val (fs, raw_defs) = fold_rev (get_fns fnss) (descr ~~ rec_names) ([], []);
  37.238 -    val defs = map (make_def ctxt fixes fs) raw_defs;
  37.239 -    val names = map snd fnames;
  37.240 -    val names_eqns = map fst eqns;
  37.241 -    val _ =
  37.242 -      if eq_set (op =) (names, names_eqns) then ()
  37.243 -      else primrec_error ("functions " ^ commas_quote names_eqns ^
  37.244 -        "\nare not mutually recursive");
  37.245 -    val rec_rewrites' = map mk_meta_eq rec_rewrites;
  37.246 -    val prefix = space_implode "_" (map (Long_Name.base_name o #1) raw_defs);
  37.247 -    fun prove ctxt defs =
  37.248 -      let
  37.249 -        val frees = fold (Variable.add_free_names ctxt) eqs [];
  37.250 -        val rewrites = rec_rewrites' @ map (snd o snd) defs;
  37.251 -      in
  37.252 -        map (fn eq => Goal.prove ctxt frees [] eq
  37.253 -          (fn {context = ctxt', ...} => EVERY [rewrite_goals_tac ctxt' rewrites, rtac refl 1])) eqs
  37.254 -      end;
  37.255 -  in ((prefix, (fs, defs)), prove) end
  37.256 -  handle PrimrecError (msg, some_eqn) =>
  37.257 -    error ("Primrec definition error:\n" ^ msg ^
  37.258 -      (case some_eqn of
  37.259 -        SOME eqn => "\nin\n" ^ quote (Syntax.string_of_term ctxt eqn)
  37.260 -      | NONE => ""));
  37.261 -
  37.262 -
  37.263 -(* primrec definition *)
  37.264 -
  37.265 -fun add_primrec_simple fixes ts lthy =
  37.266 -  let
  37.267 -    val ((prefix, (_, defs)), prove) = distill lthy fixes ts;
  37.268 -  in
  37.269 -    lthy
  37.270 -    |> fold_map Local_Theory.define defs
  37.271 -    |-> (fn defs => `(fn lthy => (prefix, (map fst defs, prove lthy defs))))
  37.272 -  end;
  37.273 -
  37.274 -local
  37.275 -
  37.276 -fun gen_primrec prep_spec raw_fixes raw_spec lthy =
  37.277 -  let
  37.278 -    val (fixes, spec) = fst (prep_spec raw_fixes raw_spec lthy);
  37.279 -    fun attr_bindings prefix = map (fn ((b, attrs), _) =>
  37.280 -      (Binding.qualify false prefix b, Code.add_default_eqn_attrib :: attrs)) spec;
  37.281 -    fun simp_attr_binding prefix =
  37.282 -      (Binding.qualify true prefix (Binding.name "simps"), @{attributes [simp, nitpick_simp]});
  37.283 -  in
  37.284 -    lthy
  37.285 -    |> add_primrec_simple fixes (map snd spec)
  37.286 -    |-> (fn (prefix, (ts, simps)) =>
  37.287 -      Spec_Rules.add Spec_Rules.Equational (ts, simps)
  37.288 -      #> fold_map Local_Theory.note (attr_bindings prefix ~~ map single simps)
  37.289 -      #-> (fn simps' => Local_Theory.note (simp_attr_binding prefix, maps snd simps')
  37.290 -      #>> (fn (_, simps'') => (ts, simps''))))
  37.291 -  end;
  37.292 -
  37.293 -in
  37.294 -
  37.295 -val add_primrec = gen_primrec Specification.check_spec;
  37.296 -val add_primrec_cmd = gen_primrec Specification.read_spec;
  37.297 -
  37.298 -end;
  37.299 -
  37.300 -fun add_primrec_global fixes specs thy =
  37.301 -  let
  37.302 -    val lthy = Named_Target.theory_init thy;
  37.303 -    val ((ts, simps), lthy') = add_primrec fixes specs lthy;
  37.304 -    val simps' = Proof_Context.export lthy' lthy simps;
  37.305 -  in ((ts, simps'), Local_Theory.exit_global lthy') end;
  37.306 -
  37.307 -fun add_primrec_overloaded ops fixes specs thy =
  37.308 -  let
  37.309 -    val lthy = Overloading.overloading ops thy;
  37.310 -    val ((ts, simps), lthy') = add_primrec fixes specs lthy;
  37.311 -    val simps' = Proof_Context.export lthy' lthy simps;
  37.312 -  in ((ts, simps'), Local_Theory.exit_global lthy') end;
  37.313 -
  37.314 -end;
    38.1 --- a/src/HOL/Tools/Datatype/rep_datatype.ML	Mon Sep 01 16:17:46 2014 +0200
    38.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    38.3 @@ -1,673 +0,0 @@
    38.4 -(*  Title:      HOL/Tools/Datatype/rep_datatype.ML
    38.5 -    Author:     Stefan Berghofer, TU Muenchen
    38.6 -
    38.7 -Representation of existing types as datatypes: proofs and definitions
    38.8 -independent of concrete representation of datatypes (i.e. requiring
    38.9 -only abstract properties: injectivity / distinctness of constructors
   38.10 -and induction).
   38.11 -*)
   38.12 -
   38.13 -signature REP_DATATYPE =
   38.14 -sig
   38.15 -  val derive_datatype_props : Datatype_Aux.config -> string list -> Datatype_Aux.descr list ->
   38.16 -    thm -> thm list list -> thm list list -> theory -> string list * theory
   38.17 -  val rep_datatype : Datatype_Aux.config -> (string list -> Proof.context -> Proof.context) ->
   38.18 -    term list -> theory -> Proof.state
   38.19 -  val rep_datatype_cmd : Datatype_Aux.config -> (string list -> Proof.context -> Proof.context) ->
   38.20 -    string list -> theory -> Proof.state
   38.21 -end;
   38.22 -
   38.23 -structure Rep_Datatype: REP_DATATYPE =
   38.24 -struct
   38.25 -
   38.26 -(** derived definitions and proofs **)
   38.27 -
   38.28 -(* case distinction theorems *)
   38.29 -
   38.30 -fun prove_casedist_thms (config : Datatype_Aux.config)
   38.31 -    new_type_names descr induct case_names_exhausts thy =
   38.32 -  let
   38.33 -    val _ = Datatype_Aux.message config "Proving case distinction theorems ...";
   38.34 -
   38.35 -    val descr' = flat descr;
   38.36 -    val recTs = Datatype_Aux.get_rec_types descr';
   38.37 -    val newTs = take (length (hd descr)) recTs;
   38.38 -
   38.39 -    val maxidx = Thm.maxidx_of induct;
   38.40 -    val induct_Ps = map head_of (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct)));
   38.41 -
   38.42 -    fun prove_casedist_thm (i, (T, t)) =
   38.43 -      let
   38.44 -        val dummyPs = map (fn (Var (_, Type (_, [T', T'']))) =>
   38.45 -          Abs ("z", T', Const (@{const_name True}, T''))) induct_Ps;
   38.46 -        val P =
   38.47 -          Abs ("z", T, HOLogic.imp $ HOLogic.mk_eq (Var (("a", maxidx + 1), T), Bound 0) $
   38.48 -            Var (("P", 0), HOLogic.boolT));
   38.49 -        val insts = take i dummyPs @ (P :: drop (i + 1) dummyPs);
   38.50 -        val cert = cterm_of thy;
   38.51 -        val insts' = map cert induct_Ps ~~ map cert insts;
   38.52 -        val induct' =
   38.53 -          refl RS
   38.54 -            (nth (Datatype_Aux.split_conj_thm (cterm_instantiate insts' induct)) i RSN (2, rev_mp));
   38.55 -      in
   38.56 -        Goal.prove_sorry_global thy []
   38.57 -          (Logic.strip_imp_prems t)
   38.58 -          (Logic.strip_imp_concl t)
   38.59 -          (fn {prems, ...} =>
   38.60 -            EVERY
   38.61 -              [rtac induct' 1,
   38.62 -               REPEAT (rtac TrueI 1),
   38.63 -               REPEAT ((rtac impI 1) THEN (eresolve_tac prems 1)),
   38.64 -               REPEAT (rtac TrueI 1)])
   38.65 -      end;
   38.66 -
   38.67 -    val casedist_thms =
   38.68 -      map_index prove_casedist_thm (newTs ~~ Datatype_Prop.make_casedists descr);
   38.69 -  in
   38.70 -    thy
   38.71 -    |> Datatype_Aux.store_thms_atts "exhaust" new_type_names
   38.72 -        (map single case_names_exhausts) casedist_thms
   38.73 -  end;
   38.74 -
   38.75 -
   38.76 -(* primrec combinators *)
   38.77 -
   38.78 -fun prove_primrec_thms (config : Datatype_Aux.config) new_type_names descr
   38.79 -    injects_of constr_inject (dist_rewrites, other_dist_rewrites) induct thy =
   38.80 -  let
   38.81 -    val _ = Datatype_Aux.message config "Constructing primrec combinators ...";
   38.82 -
   38.83 -    val big_name = space_implode "_" new_type_names;
   38.84 -    val thy0 = Sign.add_path big_name thy;
   38.85 -
   38.86 -    val descr' = flat descr;
   38.87 -    val recTs = Datatype_Aux.get_rec_types descr';
   38.88 -    val used = fold Term.add_tfree_namesT recTs [];
   38.89 -    val newTs = take (length (hd descr)) recTs;
   38.90 -
   38.91 -    val induct_Ps = map head_of (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of induct)));
   38.92 -
   38.93 -    val big_rec_name' = "rec_set_" ^ big_name;
   38.94 -    val rec_set_names' =
   38.95 -      if length descr' = 1 then [big_rec_name']
   38.96 -      else map (prefix (big_rec_name' ^ "_") o string_of_int) (1 upto length descr');
   38.97 -    val rec_set_names = map (Sign.full_bname thy0) rec_set_names';
   38.98 -
   38.99 -    val (rec_result_Ts, reccomb_fn_Ts) = Datatype_Prop.make_primrec_Ts descr used;
  38.100 -
  38.101 -    val rec_set_Ts =
  38.102 -      map (fn (T1, T2) => (reccomb_fn_Ts @ [T1, T2]) ---> HOLogic.boolT) (recTs ~~ rec_result_Ts);
  38.103 -
  38.104 -    val rec_fns =
  38.105 -      map (uncurry (Datatype_Aux.mk_Free "f")) (reccomb_fn_Ts ~~ (1 upto length reccomb_fn_Ts));
  38.106 -    val rec_sets' =
  38.107 -      map (fn c => list_comb (Free c, rec_fns)) (rec_set_names' ~~ rec_set_Ts);
  38.108 -    val rec_sets =
  38.109 -      map (fn c => list_comb (Const c, rec_fns)) (rec_set_names ~~ rec_set_Ts);
  38.110 -
  38.111 -    (* introduction rules for graph of primrec function *)
  38.112 -
  38.113 -    fun make_rec_intr T rec_set (cname, cargs) (rec_intr_ts, l) =
  38.114 -      let
  38.115 -        fun mk_prem (dt, U) (j, k, prems, t1s, t2s) =
  38.116 -          let val free1 = Datatype_Aux.mk_Free "x" U j in
  38.117 -            (case (Datatype_Aux.strip_dtyp dt, strip_type U) of
  38.118 -              ((_, Datatype_Aux.DtRec m), (Us, _)) =>
  38.119 -                let
  38.120 -                  val free2 = Datatype_Aux.mk_Free "y" (Us ---> nth rec_result_Ts m) k;
  38.121 -                  val i = length Us;
  38.122 -                in
  38.123 -                  (j + 1, k + 1,
  38.124 -                    HOLogic.mk_Trueprop (HOLogic.list_all
  38.125 -                      (map (pair "x") Us, nth rec_sets' m $
  38.126 -                        Datatype_Aux.app_bnds free1 i $ Datatype_Aux.app_bnds free2 i)) :: prems,
  38.127 -                    free1 :: t1s, free2 :: t2s)
  38.128 -                end
  38.129 -            | _ => (j + 1, k, prems, free1 :: t1s, t2s))
  38.130 -          end;
  38.131 -
  38.132 -        val Ts = map (Datatype_Aux.typ_of_dtyp descr') cargs;
  38.133 -        val (_, _, prems, t1s, t2s) = fold_rev mk_prem (cargs ~~ Ts) (1, 1, [], [], []);
  38.134 -
  38.135 -      in
  38.136 -        (rec_intr_ts @
  38.137 -          [Logic.list_implies (prems, HOLogic.mk_Trueprop
  38.138 -            (rec_set $ list_comb (Const (cname, Ts ---> T), t1s) $
  38.139 -              list_comb (nth rec_fns l, t1s @ t2s)))], l + 1)
  38.140 -      end;
  38.141 -
  38.142 -    val (rec_intr_ts, _) =
  38.143 -      fold (fn ((d, T), set_name) =>
  38.144 -        fold (make_rec_intr T set_name) (#3 (snd d))) (descr' ~~ recTs ~~ rec_sets') ([], 0);
  38.145 -
  38.146 -    val ({intrs = rec_intrs, elims = rec_elims, ...}, thy1) =
  38.147 -      thy0
  38.148 -      |> Sign.map_naming Name_Space.conceal
  38.149 -      |> Inductive.add_inductive_global
  38.150 -          {quiet_mode = #quiet config, verbose = false, alt_name = Binding.name big_rec_name',
  38.151 -            coind = false, no_elim = false, no_ind = true, skip_mono = true}
  38.152 -          (map (fn (s, T) => ((Binding.name s, T), NoSyn)) (rec_set_names' ~~ rec_set_Ts))
  38.153 -          (map dest_Free rec_fns)
  38.154 -          (map (fn x => (Attrib.empty_binding, x)) rec_intr_ts) []
  38.155 -      ||> Sign.restore_naming thy0;
  38.156 -
  38.157 -    (* prove uniqueness and termination of primrec combinators *)
  38.158 -
  38.159 -    val _ = Datatype_Aux.message config "Proving termination and uniqueness of primrec functions ...";
  38.160 -
  38.161 -    fun mk_unique_tac ctxt ((((i, (tname, _, constrs)), elim), T), T') (tac, intrs) =
  38.162 -      let
  38.163 -        val distinct_tac =
  38.164 -          if i < length newTs then
  38.165 -            full_simp_tac (put_simpset HOL_ss ctxt addsimps (nth dist_rewrites i)) 1
  38.166 -          else full_simp_tac (put_simpset HOL_ss ctxt addsimps (flat other_dist_rewrites)) 1;
  38.167 -
  38.168 -        val inject =
  38.169 -          map (fn r => r RS iffD1)
  38.170 -            (if i < length newTs then nth constr_inject i else injects_of tname);
  38.171 -
  38.172 -        fun mk_unique_constr_tac n (cname, cargs) (tac, intr :: intrs, j) =
  38.173 -          let
  38.174 -            val k = length (filter Datatype_Aux.is_rec_type cargs);
  38.175 -          in
  38.176 -            (EVERY
  38.177 -              [DETERM tac,
  38.178 -                REPEAT (etac @{thm ex1E} 1), rtac @{thm ex1I} 1,
  38.179 -                DEPTH_SOLVE_1 (ares_tac [intr] 1),
  38.180 -                REPEAT_DETERM_N k (etac thin_rl 1 THEN rotate_tac 1 1),
  38.181 -                etac elim 1,
  38.182 -                REPEAT_DETERM_N j distinct_tac,
  38.183 -                TRY (dresolve_tac inject 1),
  38.184 -                REPEAT (etac conjE 1), hyp_subst_tac ctxt 1,
  38.185 -                REPEAT (EVERY [etac allE 1, dtac mp 1, atac 1]),
  38.186 -                TRY (hyp_subst_tac ctxt 1),
  38.187 -                rtac refl 1,
  38.188 -                REPEAT_DETERM_N (n - j - 1) distinct_tac],
  38.189 -              intrs, j + 1)
  38.190 -          end;
  38.191 -
  38.192 -        val (tac', intrs', _) =
  38.193 -          fold (mk_unique_constr_tac (length constrs)) constrs (tac, intrs, 0);
  38.194 -      in (tac', intrs') end;
  38.195 -
  38.196 -    val rec_unique_thms =
  38.197 -      let
  38.198 -        val rec_unique_ts =
  38.199 -          map (fn (((set_t, T1), T2), i) =>
  38.200 -            Const (@{const_name Ex1}, (T2 --> HOLogic.boolT) --> HOLogic.boolT) $
  38.201 -              absfree ("y", T2) (set_t $ Datatype_Aux.mk_Free "x" T1 i $ Free ("y", T2)))
  38.202 -                (rec_sets ~~ recTs ~~ rec_result_Ts ~~ (1 upto length recTs));
  38.203 -        val cert = cterm_of thy1;
  38.204 -        val insts =
  38.205 -          map (fn ((i, T), t) => absfree ("x" ^ string_of_int i, T) t)
  38.206 -            ((1 upto length recTs) ~~ recTs ~~ rec_unique_ts);
  38.207 -        val induct' = cterm_instantiate (map cert induct_Ps ~~ map cert insts) induct;
  38.208 -      in
  38.209 -        Datatype_Aux.split_conj_thm (Goal.prove_sorry_global thy1 [] []
  38.210 -          (HOLogic.mk_Trueprop (Datatype_Aux.mk_conj rec_unique_ts))
  38.211 -          (fn {context = ctxt, ...} =>
  38.212 -            #1 (fold (mk_unique_tac ctxt) (descr' ~~ rec_elims ~~ recTs ~~ rec_result_Ts)
  38.213 -              (((rtac induct' THEN_ALL_NEW Object_Logic.atomize_prems_tac ctxt) 1 THEN
  38.214 -                  rewrite_goals_tac ctxt [mk_meta_eq @{thm choice_eq}], rec_intrs)))))
  38.215 -      end;
  38.216 -
  38.217 -    val rec_total_thms = map (fn r => r RS @{thm theI'}) rec_unique_thms;
  38.218 -
  38.219 -    (* define primrec combinators *)
  38.220 -
  38.221 -    val big_reccomb_name = "rec_" ^ space_implode "_" new_type_names;
  38.222 -    val reccomb_names =
  38.223 -      map (Sign.full_bname thy1)
  38.224 -        (if length descr' = 1 then [big_reccomb_name]
  38.225 -         else map (prefix (big_reccomb_name ^ "_") o string_of_int) (1 upto length descr'));
  38.226 -    val reccombs =
  38.227 -      map (fn ((name, T), T') => Const (name, reccomb_fn_Ts @ [T] ---> T'))
  38.228 -        (reccomb_names ~~ recTs ~~ rec_result_Ts);
  38.229 -
  38.230 -    val (reccomb_defs, thy2) =
  38.231 -      thy1
  38.232 -      |> Sign.add_consts (map (fn ((name, T), T') =>
  38.233 -            (Binding.name (Long_Name.base_name name), reccomb_fn_Ts @ [T] ---> T', NoSyn))
  38.234 -            (reccomb_names ~~ recTs ~~ rec_result_Ts))
  38.235 -      |> (Global_Theory.add_defs false o map Thm.no_attributes)
  38.236 -          (map
  38.237 -            (fn ((((name, comb), set), T), T') =>
  38.238 -              (Binding.name (Thm.def_name (Long_Name.base_name name)),
  38.239 -                Logic.mk_equals (comb, fold_rev lambda rec_fns (absfree ("x", T)
  38.240 -                 (Const (@{const_name The}, (T' --> HOLogic.boolT) --> T') $ absfree ("y", T')
  38.241 -                   (set $ Free ("x", T) $ Free ("y", T')))))))
  38.242 -            (reccomb_names ~~ reccombs ~~ rec_sets ~~ recTs ~~ rec_result_Ts))
  38.243 -      ||> Sign.parent_path;
  38.244 -
  38.245 -
  38.246 -    (* prove characteristic equations for primrec combinators *)
  38.247 -
  38.248 -    val _ = Datatype_Aux.message config "Proving characteristic theorems for primrec combinators ...";
  38.249 -
  38.250 -    val rec_thms =
  38.251 -      map (fn t =>
  38.252 -        Goal.prove_sorry_global thy2 [] [] t
  38.253 -          (fn {context = ctxt, ...} => EVERY
  38.254 -            [rewrite_goals_tac ctxt reccomb_defs,
  38.255 -             rtac @{thm the1_equality} 1,
  38.256 -             resolve_tac rec_unique_thms 1,
  38.257 -             resolve_tac rec_intrs 1,
  38.258 -             REPEAT (rtac allI 1 ORELSE resolve_tac rec_total_thms 1)]))
  38.259 -       (Datatype_Prop.make_primrecs reccomb_names descr thy2);
  38.260 -  in
  38.261 -    thy2
  38.262 -    |> Sign.add_path (space_implode "_" new_type_names)
  38.263 -    |> Global_Theory.note_thmss ""
  38.264 -      [((Binding.name "rec", [Named_Theorems.add @{named_theorems nitpick_simp}]),
  38.265 -          [(rec_thms, [])])]
  38.266 -    ||> Sign.parent_path
  38.267 -    |-> (fn thms => pair (reccomb_names, maps #2 thms))
  38.268 -  end;
  38.269 -
  38.270 -
  38.271 -(* case combinators *)
  38.272 -
  38.273 -fun prove_case_thms (config : Datatype_Aux.config)
  38.274 -    new_type_names descr reccomb_names primrec_thms thy =
  38.275 -  let
  38.276 -    val _ = Datatype_Aux.message config "Proving characteristic theorems for case combinators ...";
  38.277 -
  38.278 -    val ctxt = Proof_Context.init_global thy;
  38.279 -    val thy1 = Sign.add_path (space_implode "_" new_type_names) thy;
  38.280 -
  38.281 -    val descr' = flat descr;
  38.282 -    val recTs = Datatype_Aux.get_rec_types descr';
  38.283 -    val used = fold Term.add_tfree_namesT recTs [];
  38.284 -    val newTs = take (length (hd descr)) recTs;
  38.285 -    val T' = TFree (singleton (Name.variant_list used) "'t", @{sort type});
  38.286 -
  38.287 -    fun mk_dummyT dt = binder_types (Datatype_Aux.typ_of_dtyp descr' dt) ---> T';
  38.288 -
  38.289 -    val case_dummy_fns =
  38.290 -      map (fn (_, (_, _, constrs)) => map (fn (_, cargs) =>
  38.291 -        let
  38.292 -          val Ts = map (Datatype_Aux.typ_of_dtyp descr') cargs;
  38.293 -          val Ts' = map mk_dummyT (filter Datatype_Aux.is_rec_type cargs)
  38.294 -        in Const (@{const_name undefined}, Ts @ Ts' ---> T') end) constrs) descr';
  38.295 -
  38.296 -    val case_names0 = map (fn s => Sign.full_bname thy1 ("case_" ^ s)) new_type_names;
  38.297 -
  38.298 -    (* define case combinators via primrec combinators *)
  38.299 -
  38.300 -    fun def_case ((((i, (_, _, constrs)), T as Type (Tcon, _)), name), recname) (defs, thy) =
  38.301 -      if is_some (Ctr_Sugar.ctr_sugar_of ctxt Tcon) then
  38.302 -        (defs, thy)
  38.303 -      else
  38.304 -        let
  38.305 -          val (fns1, fns2) = split_list (map (fn ((_, cargs), j) =>
  38.306 -            let
  38.307 -              val Ts = map (Datatype_Aux.typ_of_dtyp descr') cargs;
  38.308 -              val Ts' = Ts @ map mk_dummyT (filter Datatype_Aux.is_rec_type cargs);
  38.309 -              val frees' = map2 (Datatype_Aux.mk_Free "x") Ts' (1 upto length Ts');
  38.310 -              val frees = take (length cargs) frees';
  38.311 -              val free = Datatype_Aux.mk_Free "f" (Ts ---> T') j;
  38.312 -            in
  38.313 -              (free, fold_rev (absfree o dest_Free) frees' (list_comb (free, frees)))
  38.314 -            end) (constrs ~~ (1 upto length constrs)));
  38.315 -
  38.316 -          val caseT = map (snd o dest_Free) fns1 @ [T] ---> T';
  38.317 -          val fns = flat (take i case_dummy_fns) @ fns2 @ flat (drop (i + 1) case_dummy_fns);
  38.318 -          val reccomb = Const (recname, (map fastype_of fns) @ [T] ---> T');
  38.319 -          val decl = ((Binding.name (Long_Name.base_name name), caseT), NoSyn);
  38.320 -          val def =
  38.321 -            (Binding.name (Thm.def_name (Long_Name.base_name name)),
  38.322 -              Logic.mk_equals (Const (name, caseT),
  38.323 -                fold_rev lambda fns1
  38.324 -                  (list_comb (reccomb,
  38.325 -                    flat (take i case_dummy_fns) @ fns2 @ flat (drop (i + 1) case_dummy_fns)))));
  38.326 -          val ([def_thm], thy') =
  38.327 -            thy
  38.328 -            |> Sign.declare_const_global decl |> snd
  38.329 -            |> (Global_Theory.add_defs false o map Thm.no_attributes) [def];
  38.330 -        in (defs @ [def_thm], thy') end;
  38.331 -
  38.332 -    val (case_defs, thy2) =
  38.333 -      fold def_case (hd descr ~~ newTs ~~ case_names0 ~~ take (length newTs) reccomb_names)
  38.334 -        ([], thy1);
  38.335 -
  38.336 -    fun prove_case t =
  38.337 -      Goal.prove_sorry_global thy2 [] [] t (fn {context = ctxt, ...} =>
  38.338 -        EVERY [rewrite_goals_tac ctxt (case_defs @ map mk_meta_eq primrec_thms), rtac refl 1]);
  38.339 -
  38.340 -    fun prove_cases (Type (Tcon, _)) ts =
  38.341 -      (case Ctr_Sugar.ctr_sugar_of ctxt Tcon of
  38.342 -        SOME {case_thms, ...} => case_thms
  38.343 -      | NONE => map prove_case ts);
  38.344 -
  38.345 -    val case_thms =
  38.346 -      map2 prove_cases newTs (Datatype_Prop.make_cases case_names0 descr thy2);
  38.347 -
  38.348 -    fun case_name_of (th :: _) =
  38.349 -      fst (dest_Const (head_of (fst (HOLogic.dest_eq (HOLogic.dest_Trueprop (prop_of th))))));
  38.350 -
  38.351 -    val case_names = map case_name_of case_thms;
  38.352 -  in
  38.353 -    thy2
  38.354 -    |> Context.theory_map
  38.355 -        ((fold o fold) (Named_Theorems.add_thm @{named_theorems nitpick_simp}) case_thms)
  38.356 -    |> Sign.parent_path
  38.357 -    |> Datatype_Aux.store_thmss "case" new_type_names case_thms
  38.358 -    |-> (fn thmss => pair (thmss, case_names))
  38.359 -  end;
  38.360 -
  38.361 -
  38.362 -(* case splitting *)
  38.363 -
  38.364 -fun prove_split_thms (config : Datatype_Aux.config)
  38.365 -    new_type_names case_names descr constr_inject dist_rewrites casedist_thms case_thms thy =
  38.366 -  let
  38.367 -    val _ = Datatype_Aux.message config "Proving equations for case splitting ...";
  38.368 -
  38.369 -    val descr' = flat descr;
  38.370 -    val recTs = Datatype_Aux.get_rec_types descr';
  38.371 -    val newTs = take (length (hd descr)) recTs;
  38.372 -
  38.373 -    fun prove_split_thms ((((((t1, t2), inject), dist_rewrites'), exhaustion), case_thms'), T) =
  38.374 -      let
  38.375 -        val cert = cterm_of thy;
  38.376 -        val _ $ (_ $ lhs $ _) = hd (Logic.strip_assums_hyp (hd (prems_of exhaustion)));
  38.377 -        val exhaustion' = cterm_instantiate [(cert lhs, cert (Free ("x", T)))] exhaustion;
  38.378 -        fun tac ctxt =
  38.379 -          EVERY [rtac exhaustion' 1,
  38.380 -            ALLGOALS (asm_simp_tac
  38.381 -              (put_simpset HOL_ss ctxt addsimps (dist_rewrites' @ inject @ case_thms')))];
  38.382 -      in
  38.383 -        (Goal.prove_sorry_global thy [] [] t1 (tac o #context),
  38.384 -         Goal.prove_sorry_global thy [] [] t2 (tac o #context))
  38.385 -      end;
  38.386 -
  38.387 -    val split_thm_pairs =
  38.388 -      map prove_split_thms
  38.389 -        (Datatype_Prop.make_splits case_names descr thy ~~ constr_inject ~~
  38.390 -          dist_rewrites ~~ casedist_thms ~~ case_thms ~~ newTs);
  38.391 -
  38.392 -    val (split_thms, split_asm_thms) = split_list split_thm_pairs
  38.393 -
  38.394 -  in
  38.395 -    thy
  38.396 -    |> Datatype_Aux.store_thms "split" new_type_names split_thms
  38.397 -    ||>> Datatype_Aux.store_thms "split_asm" new_type_names split_asm_thms
  38.398 -    |-> (fn (thms1, thms2) => pair (thms1 ~~ thms2))
  38.399 -  end;
  38.400 -
  38.401 -fun prove_case_cong_weaks new_type_names case_names descr thy =
  38.402 -  let
  38.403 -    fun prove_case_cong_weak t =
  38.404 -     Goal.prove_sorry_global thy [] (Logic.strip_imp_prems t) (Logic.strip_imp_concl t)
  38.405 -       (fn {prems, ...} => EVERY [rtac (hd prems RS arg_cong) 1]);
  38.406 -
  38.407 -    val case_cong_weaks =
  38.408 -      map prove_case_cong_weak (Datatype_Prop.make_case_cong_weaks case_names descr thy);
  38.409 -
  38.410 -  in thy |> Datatype_Aux.store_thms "case_cong_weak" new_type_names case_cong_weaks end;
  38.411 -
  38.412 -
  38.413 -(* additional theorems for TFL *)
  38.414 -
  38.415 -fun prove_nchotomys (config : Datatype_Aux.config) new_type_names descr casedist_thms thy =
  38.416 -  let
  38.417 -    val _ = Datatype_Aux.message config "Proving additional theorems for TFL ...";
  38.418 -
  38.419 -    fun prove_nchotomy (t, exhaustion) =
  38.420 -      let
  38.421 -        (* For goal i, select the correct disjunct to attack, then prove it *)
  38.422 -        fun tac ctxt i 0 =
  38.423 -              EVERY [TRY (rtac disjI1 i), hyp_subst_tac ctxt i, REPEAT (rtac exI i), rtac refl i]
  38.424 -          | tac ctxt i n = rtac disjI2 i THEN tac ctxt i (n - 1);
  38.425 -      in
  38.426 -        Goal.prove_sorry_global thy [] [] t
  38.427 -          (fn {context = ctxt, ...} =>
  38.428 -            EVERY [rtac allI 1,
  38.429 -             Datatype_Aux.exh_tac (K exhaustion) 1,
  38.430 -             ALLGOALS (fn i => tac ctxt i (i - 1))])
  38.431 -      end;
  38.432 -
  38.433 -    val nchotomys =
  38.434 -      map prove_nchotomy (Datatype_Prop.make_nchotomys descr ~~ casedist_thms);
  38.435 -
  38.436 -  in thy |> Datatype_Aux.store_thms "nchotomy" new_type_names nchotomys end;
  38.437 -
  38.438 -fun prove_case_congs new_type_names case_names descr nchotomys case_thms thy =
  38.439 -  let
  38.440 -    fun prove_case_cong ((t, nchotomy), case_rewrites) =
  38.441 -      let
  38.442 -        val Const (@{const_name Pure.imp}, _) $ tm $ _ = t;
  38.443 -        val Const (@{const_name Trueprop}, _) $ (Const (@{const_name HOL.eq}, _) $ _ $ Ma) = tm;
  38.444 -        val cert = cterm_of thy;
  38.445 -        val nchotomy' = nchotomy RS spec;
  38.446 -        val [v] = Term.add_vars (concl_of nchotomy') [];
  38.447 -        val nchotomy'' = cterm_instantiate [(cert (Var v), cert Ma)] nchotomy';
  38.448 -      in
  38.449 -        Goal.prove_sorry_global thy [] (Logic.strip_imp_prems t) (Logic.strip_imp_concl t)
  38.450 -          (fn {context = ctxt, prems, ...} =>
  38.451 -            let
  38.452 -              val simplify = asm_simp_tac (put_simpset HOL_ss ctxt addsimps (prems @ case_rewrites))
  38.453 -            in
  38.454 -              EVERY [
  38.455 -                simp_tac (put_simpset HOL_ss ctxt addsimps [hd prems]) 1,
  38.456 -                cut_tac nchotomy'' 1,
  38.457 -                REPEAT (etac disjE 1 THEN REPEAT (etac exE 1) THEN simplify 1),
  38.458 -                REPEAT (etac exE 1) THEN simplify 1 (* Get last disjunct *)]
  38.459 -            end)
  38.460 -      end;
  38.461 -
  38.462 -    val case_congs =
  38.463 -      map prove_case_cong
  38.464 -        (Datatype_Prop.make_case_congs case_names descr thy ~~ nchotomys ~~ case_thms);
  38.465 -
  38.466 -  in thy |> Datatype_Aux.store_thms "case_cong" new_type_names case_congs end;
  38.467 -
  38.468 -
  38.469 -
  38.470 -(** derive datatype props **)
  38.471 -
  38.472 -local
  38.473 -
  38.474 -fun make_dt_info descr induct inducts rec_names rec_rewrites
  38.475 -    (index, (((((((((((_, (tname, _, _))), inject), distinct),
  38.476 -      exhaust), nchotomy), case_name), case_rewrites), case_cong), case_cong_weak),
  38.477 -        (split, split_asm))) =
  38.478 -  (tname,
  38.479 -   {index = index,
  38.480 -    descr = descr,
  38.481 -    inject = inject,
  38.482 -    distinct = distinct,
  38.483 -    induct = induct,
  38.484 -    inducts = inducts,
  38.485 -    exhaust = exhaust,
  38.486 -    nchotomy = nchotomy,
  38.487 -    rec_names = rec_names,
  38.488 -    rec_rewrites = rec_rewrites,
  38.489 -    case_name = case_name,
  38.490 -    case_rewrites = case_rewrites,
  38.491 -    case_cong = case_cong,
  38.492 -    case_cong_weak = case_cong_weak,
  38.493 -    split = split,
  38.494 -    split_asm = split_asm});
  38.495 -
  38.496 -in
  38.497 -
  38.498 -fun derive_datatype_props config dt_names descr induct inject distinct thy2 =
  38.499 -  let
  38.500 -    val flat_descr = flat descr;
  38.501 -    val new_type_names = map Long_Name.base_name dt_names;
  38.502 -    val _ =
  38.503 -      Datatype_Aux.message config
  38.504 -        ("Deriving properties for datatype(s) " ^ commas_quote new_type_names);
  38.505 -
  38.506 -    val (exhaust, thy3) = thy2
  38.507 -      |> prove_casedist_thms config new_type_names descr induct
  38.508 -        (Datatype_Data.mk_case_names_exhausts flat_descr dt_names);
  38.509 -    val (nchotomys, thy4) = thy3
  38.510 -      |> prove_nchotomys config new_type_names descr exhaust;
  38.511 -    val ((rec_names, rec_rewrites), thy5) = thy4
  38.512 -      |> prove_primrec_thms config new_type_names descr
  38.513 -        (#inject o the o Symtab.lookup (Datatype_Data.get_all thy4)) inject
  38.514 -        (distinct, Datatype_Data.all_distincts thy2 (Datatype_Aux.get_rec_types flat_descr)) induct;
  38.515 -    val ((case_rewrites, case_names), thy6) = thy5
  38.516 -      |> prove_case_thms config new_type_names descr rec_names rec_rewrites;
  38.517 -    val (case_congs, thy7) = thy6
  38.518 -      |> prove_case_congs new_type_names case_names descr nchotomys case_rewrites;
  38.519 -    val (case_cong_weaks, thy8) = thy7
  38.520 -      |> prove_case_cong_weaks new_type_names case_names descr;
  38.521 -    val (splits, thy9) = thy8
  38.522 -      |> prove_split_thms config new_type_names case_names descr
  38.523 -        inject distinct exhaust case_rewrites;
  38.524 -
  38.525 -    val inducts = Project_Rule.projections (Proof_Context.init_global thy2) induct;
  38.526 -    val dt_infos =
  38.527 -      map_index
  38.528 -        (make_dt_info flat_descr induct inducts rec_names rec_rewrites)
  38.529 -        (hd descr ~~ inject ~~ distinct ~~ exhaust ~~ nchotomys ~~
  38.530 -          case_names ~~ case_rewrites ~~ case_congs ~~ case_cong_weaks ~~ splits);
  38.531 -    val dt_names = map fst dt_infos;
  38.532 -    val prfx = Binding.qualify true (space_implode "_" new_type_names);
  38.533 -    val simps = flat (inject @ distinct @ case_rewrites) @ rec_rewrites;
  38.534 -    val named_rules = flat (map_index (fn (i, tname) =>
  38.535 -      [((Binding.empty, [Induct.induct_type tname]), [([nth inducts i], [])]),
  38.536 -       ((Binding.empty, [Induct.cases_type tname]), [([nth exhaust i], [])])]) dt_names);
  38.537 -    val unnamed_rules = map (fn induct =>
  38.538 -      ((Binding.empty, [Rule_Cases.inner_rule, Induct.induct_type ""]), [([induct], [])]))
  38.539 -        (drop (length dt_names) inducts);
  38.540 -
  38.541 -    val ctxt = Proof_Context.init_global thy9;
  38.542 -    val case_combs =
  38.543 -      map (Proof_Context.read_const {proper = true, strict = true} ctxt) case_names;
  38.544 -    val constrss = map (fn (dtname, {descr, index, ...}) =>
  38.545 -      map (Proof_Context.read_const {proper = true, strict = true} ctxt o fst)
  38.546 -        (#3 (the (AList.lookup op = descr index)))) dt_infos;
  38.547 -  in
  38.548 -    thy9
  38.549 -    |> Global_Theory.note_thmss ""
  38.550 -      ([((prfx (Binding.name "simps"), []), [(simps, [])]),
  38.551 -        ((prfx (Binding.name "inducts"), []), [(inducts, [])]),
  38.552 -        ((prfx (Binding.name "splits"), []), [(maps (fn (x, y) => [x, y]) splits, [])]),
  38.553 -        ((Binding.empty, [Simplifier.simp_add]),
  38.554 -          [(flat case_rewrites @ flat distinct @ rec_rewrites, [])]),
  38.555 -        ((Binding.empty, [Code.add_default_eqn_attribute]), [(rec_rewrites, [])]),
  38.556 -        ((Binding.empty, [iff_add]), [(flat inject, [])]),
  38.557 -        ((Binding.empty, [Classical.safe_elim NONE]),
  38.558 -          [(map (fn th => th RS notE) (flat distinct), [])]),
  38.559 -        ((Binding.empty, [Simplifier.cong_add]), [(case_cong_weaks, [])]),
  38.560 -        ((Binding.empty, [Induct.induct_simp_add]), [(flat (distinct @ inject), [])])] @
  38.561 -          named_rules @ unnamed_rules)
  38.562 -    |> snd
  38.563 -    |> Datatype_Data.register dt_infos
  38.564 -    |> Context.theory_map (fold2 Case_Translation.register case_combs constrss)
  38.565 -    |> Datatype_Data.interpretation_data (config, dt_names)
  38.566 -    |> pair dt_names
  38.567 -  end;
  38.568 -
  38.569 -end;
  38.570 -
  38.571 -
  38.572 -
  38.573 -(** declare existing type as datatype **)
  38.574 -
  38.575 -local
  38.576 -
  38.577 -fun prove_rep_datatype config dt_names descr raw_inject half_distinct raw_induct thy1 =
  38.578 -  let
  38.579 -    val raw_distinct = (map o maps) (fn thm => [thm, thm RS not_sym]) half_distinct;
  38.580 -    val new_type_names = map Long_Name.base_name dt_names;
  38.581 -    val prfx = Binding.qualify true (space_implode "_" new_type_names);
  38.582 -    val (((inject, distinct), [(_, [induct])]), thy2) =
  38.583 -      thy1
  38.584 -      |> Datatype_Aux.store_thmss "inject" new_type_names raw_inject
  38.585 -      ||>> Datatype_Aux.store_thmss "distinct" new_type_names raw_distinct
  38.586 -      ||>> Global_Theory.note_thmss ""
  38.587 -        [((prfx (Binding.name "induct"), [Datatype_Data.mk_case_names_induct descr]),
  38.588 -          [([raw_induct], [])])];
  38.589 -  in
  38.590 -    thy2
  38.591 -    |> derive_datatype_props config dt_names [descr] induct inject distinct
  38.592 - end;
  38.593 -
  38.594 -fun gen_rep_datatype prep_term config after_qed raw_ts thy =
  38.595 -  let
  38.596 -    val ctxt = Proof_Context.init_global thy;
  38.597 -
  38.598 -    fun constr_of_term (Const (c, T)) = (c, T)
  38.599 -      | constr_of_term t = error ("Not a constant: " ^ Syntax.string_of_term ctxt t);
  38.600 -    fun no_constr (c, T) =
  38.601 -      error ("Bad constructor: " ^ Proof_Context.markup_const ctxt c ^ "::" ^
  38.602 -        Syntax.string_of_typ ctxt T);
  38.603 -    fun type_of_constr (cT as (_, T)) =
  38.604 -      let
  38.605 -        val frees = Term.add_tfreesT T [];
  38.606 -        val (tyco, vs) = (apsnd o map) dest_TFree (dest_Type (body_type T))
  38.607 -          handle TYPE _ => no_constr cT
  38.608 -        val _ = if has_duplicates (eq_fst (op =)) vs then no_constr cT else ();
  38.609 -        val _ = if length frees <> length vs then no_constr cT else ();
  38.610 -      in (tyco, (vs, cT)) end;
  38.611 -
  38.612 -    val raw_cs =
  38.613 -      AList.group (op =) (map (type_of_constr o constr_of_term o prep_term thy) raw_ts);
  38.614 -    val _ =
  38.615 -      (case map_filter (fn (tyco, _) =>
  38.616 -          if Symtab.defined (Datatype_Data.get_all thy) tyco then SOME tyco else NONE) raw_cs of
  38.617 -        [] => ()
  38.618 -      | tycos => error ("Type(s) " ^ commas_quote tycos ^ " already represented inductively"));
  38.619 -    val raw_vss = maps (map (map snd o fst) o snd) raw_cs;
  38.620 -    val ms =
  38.621 -      (case distinct (op =) (map length raw_vss) of
  38.622 -         [n] => 0 upto n - 1
  38.623 -      | _ => error "Different types in given constructors");
  38.624 -    fun inter_sort m =
  38.625 -      map (fn xs => nth xs m) raw_vss
  38.626 -      |> foldr1 (Sorts.inter_sort (Sign.classes_of thy));
  38.627 -    val sorts = map inter_sort ms;
  38.628 -    val vs = Name.invent_names Name.context Name.aT sorts;
  38.629 -
  38.630 -    fun norm_constr (raw_vs, (c, T)) =
  38.631 -      (c, map_atyps
  38.632 -        (TFree o (the o AList.lookup (op =) (map fst raw_vs ~~ vs)) o fst o dest_TFree) T);
  38.633 -
  38.634 -    val cs = map (apsnd (map norm_constr)) raw_cs;
  38.635 -    val dtyps_of_typ = map (Datatype_Aux.dtyp_of_typ (map (rpair vs o fst) cs)) o binder_types;
  38.636 -    val dt_names = map fst cs;
  38.637 -
  38.638 -    fun mk_spec (i, (tyco, constr)) =
  38.639 -      (i, (tyco, map Datatype_Aux.DtTFree vs, (map o apsnd) dtyps_of_typ constr));
  38.640 -    val descr = map_index mk_spec cs;
  38.641 -    val injs = Datatype_Prop.make_injs [descr];
  38.642 -    val half_distincts = Datatype_Prop.make_distincts [descr];
  38.643 -    val ind = Datatype_Prop.make_ind [descr];
  38.644 -    val rules = (map o map o map) Logic.close_form [[[ind]], injs, half_distincts];
  38.645 -
  38.646 -    fun after_qed' raw_thms =
  38.647 -      let
  38.648 -        val [[[raw_induct]], raw_inject, half_distinct] =
  38.649 -          unflat rules (map Drule.zero_var_indexes_list raw_thms);
  38.650 -            (*FIXME somehow dubious*)
  38.651 -      in
  38.652 -        Proof_Context.background_theory_result  (* FIXME !? *)
  38.653 -          (prove_rep_datatype config dt_names descr raw_inject half_distinct raw_induct)
  38.654 -        #-> after_qed
  38.655 -      end;
  38.656 -  in
  38.657 -    ctxt
  38.658 -    |> Proof.theorem NONE after_qed' ((map o map) (rpair []) (flat rules))
  38.659 -  end;
  38.660 -
  38.661 -in
  38.662 -
  38.663 -val rep_datatype = gen_rep_datatype Sign.cert_term;
  38.664 -val rep_datatype_cmd = gen_rep_datatype Syntax.read_term_global;
  38.665 -
  38.666 -end;
  38.667 -
  38.668 -
  38.669 -(* outer syntax *)
  38.670 -
  38.671 -val _ =
  38.672 -  Outer_Syntax.command @{command_spec "rep_datatype"} "represent existing types inductively"
  38.673 -    (Scan.repeat1 Parse.term >> (fn ts =>
  38.674 -      Toplevel.theory_to_proof (rep_datatype_cmd Datatype_Aux.default_config (K I) ts)));
  38.675 -
  38.676 -end;
    39.1 --- a/src/HOL/Tools/Function/function.ML	Mon Sep 01 16:17:46 2014 +0200
    39.2 +++ b/src/HOL/Tools/Function/function.ML	Mon Sep 01 16:17:46 2014 +0200
    39.3 @@ -267,14 +267,14 @@
    39.4  
    39.5  fun add_case_cong n thy =
    39.6    let
    39.7 -    val cong = #case_cong (Datatype_Data.the_info thy n)
    39.8 +    val cong = #case_cong (Old_Datatype_Data.the_info thy n)
    39.9        |> safe_mk_meta_eq
   39.10    in
   39.11      Context.theory_map
   39.12        (Function_Ctx_Tree.map_function_congs (Thm.add_thm cong)) thy
   39.13    end
   39.14  
   39.15 -val setup_case_cong = Datatype_Data.interpretation (K (fold add_case_cong))
   39.16 +val setup_case_cong = Old_Datatype_Data.interpretation (K (fold add_case_cong))
   39.17  
   39.18  
   39.19  (* setup *)
    40.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    40.2 +++ b/src/HOL/Tools/Function/old_size.ML	Mon Sep 01 16:17:46 2014 +0200
    40.3 @@ -0,0 +1,233 @@
    40.4 +(*  Title:      HOL/Tools/Function/old_size.ML
    40.5 +    Author:     Stefan Berghofer, Florian Haftmann, TU Muenchen
    40.6 +
    40.7 +Size functions for old-style datatypes.
    40.8 +*)
    40.9 +
   40.10 +signature OLD_SIZE =
   40.11 +sig
   40.12 +  val setup: theory -> theory
   40.13 +end;
   40.14 +
   40.15 +structure Old_Size: OLD_SIZE =
   40.16 +struct
   40.17 +
   40.18 +fun plus (t1, t2) = Const (@{const_name Groups.plus},
   40.19 +  HOLogic.natT --> HOLogic.natT --> HOLogic.natT) $ t1 $ t2;
   40.20 +
   40.21 +fun size_of_type f g h (T as Type (s, Ts)) =
   40.22 +      (case f s of
   40.23 +         SOME t => SOME t
   40.24 +       | NONE => (case g s of
   40.25 +           SOME size_name =>
   40.26 +             SOME (list_comb (Const (size_name,
   40.27 +               map (fn U => U --> HOLogic.natT) Ts @ [T] ---> HOLogic.natT),
   40.28 +                 map (size_of_type' f g h) Ts))
   40.29 +         | NONE => NONE))
   40.30 +  | size_of_type _ _ h (TFree (s, _)) = h s
   40.31 +and size_of_type' f g h T = (case size_of_type f g h T of
   40.32 +      NONE => Abs ("x", T, HOLogic.zero)
   40.33 +    | SOME t => t);
   40.34 +
   40.35 +fun is_poly thy (Old_Datatype_Aux.DtType (name, dts)) =
   40.36 +      is_some (BNF_LFP_Size.lookup_size_global thy name) andalso exists (is_poly thy) dts
   40.37 +  | is_poly _ _ = true;
   40.38 +
   40.39 +fun constrs_of thy name =
   40.40 +  let
   40.41 +    val {descr, index, ...} = Old_Datatype_Data.the_info thy name
   40.42 +    val SOME (_, _, constrs) = AList.lookup op = descr index
   40.43 +  in constrs end;
   40.44 +
   40.45 +val app = curry (list_comb o swap);
   40.46 +
   40.47 +fun prove_size_thms (info : Old_Datatype_Aux.info) new_type_names thy =
   40.48 +  let
   40.49 +    val {descr, rec_names, rec_rewrites, induct, ...} = info;
   40.50 +    val l = length new_type_names;
   40.51 +    val descr' = List.take (descr, l);
   40.52 +    val tycos = map (#1 o snd) descr';
   40.53 +  in
   40.54 +    if forall (fn tyco => can (Sign.arity_sorts thy tyco) [HOLogic.class_size]) tycos then
   40.55 +      (* nothing to do -- the "size" function is already defined *)
   40.56 +      thy
   40.57 +    else
   40.58 +      let
   40.59 +        val recTs = Old_Datatype_Aux.get_rec_types descr;
   40.60 +        val (recTs1, recTs2) = chop l recTs;
   40.61 +        val (_, (_, paramdts, _)) :: _ = descr;
   40.62 +        val paramTs = map (Old_Datatype_Aux.typ_of_dtyp descr) paramdts;
   40.63 +        val ((param_size_fs, param_size_fTs), f_names) = paramTs |>
   40.64 +          map (fn T as TFree (s, _) =>
   40.65 +            let
   40.66 +              val name = "f" ^ unprefix "'" s;
   40.67 +              val U = T --> HOLogic.natT
   40.68 +            in
   40.69 +              (((s, Free (name, U)), U), name)
   40.70 +            end) |> split_list |>> split_list;
   40.71 +        val param_size = AList.lookup op = param_size_fs;
   40.72 +
   40.73 +        val extra_rewrites = descr |> map (#1 o snd) |> distinct op = |>
   40.74 +          map_filter (Option.map (fst o snd) o BNF_LFP_Size.lookup_size_global thy) |> flat;
   40.75 +        val extra_size = Option.map fst o BNF_LFP_Size.lookup_size_global thy;
   40.76 +
   40.77 +        val (((size_names, size_fns), def_names), def_names') =
   40.78 +          recTs1 |> map (fn T as Type (s, _) =>
   40.79 +            let
   40.80 +              val s' = "size_" ^ Long_Name.base_name s;
   40.81 +              val s'' = Sign.full_bname thy s';
   40.82 +            in
   40.83 +              (s'',
   40.84 +               (list_comb (Const (s'', param_size_fTs @ [T] ---> HOLogic.natT),
   40.85 +                  map snd param_size_fs),
   40.86 +                (s' ^ "_def", s' ^ "_overloaded_def")))
   40.87 +            end) |> split_list ||>> split_list ||>> split_list;
   40.88 +        val overloaded_size_fns = map HOLogic.size_const recTs1;
   40.89 +
   40.90 +        (* instantiation for primrec combinator *)
   40.91 +        fun size_of_constr b size_ofp ((_, cargs), (_, cargs')) =
   40.92 +          let
   40.93 +            val Ts = map (Old_Datatype_Aux.typ_of_dtyp descr) cargs;
   40.94 +            val k = length (filter Old_Datatype_Aux.is_rec_type cargs);
   40.95 +            val (ts, _, _) = fold_rev (fn ((dt, dt'), T) => fn (us, i, j) =>
   40.96 +              if Old_Datatype_Aux.is_rec_type dt then (Bound i :: us, i + 1, j + 1)
   40.97 +              else
   40.98 +                (if b andalso is_poly thy dt' then
   40.99 +                   case size_of_type (K NONE) extra_size size_ofp T of
  40.100 +                     NONE => us | SOME sz => sz $ Bound j :: us
  40.101 +                 else us, i, j + 1))
  40.102 +                  (cargs ~~ cargs' ~~ Ts) ([], 0, k);
  40.103 +            val t =
  40.104 +              if null ts andalso (not b orelse not (exists (is_poly thy) cargs'))
  40.105 +              then HOLogic.zero
  40.106 +              else foldl1 plus (ts @ [HOLogic.Suc_zero])
  40.107 +          in
  40.108 +            fold_rev (fn T => fn t' => Abs ("x", T, t')) (Ts @ replicate k HOLogic.natT) t
  40.109 +          end;
  40.110 +
  40.111 +        val fs = maps (fn (_, (name, _, constrs)) =>
  40.112 +          map (size_of_constr true param_size) (constrs ~~ constrs_of thy name)) descr;
  40.113 +        val fs' = maps (fn (n, (name, _, constrs)) =>
  40.114 +          map (size_of_constr (l <= n) (K NONE)) (constrs ~~ constrs_of thy name)) descr;
  40.115 +        val fTs = map fastype_of fs;
  40.116 +
  40.117 +        val (rec_combs1, rec_combs2) = chop l (map (fn (T, rec_name) =>
  40.118 +          Const (rec_name, fTs @ [T] ---> HOLogic.natT))
  40.119 +            (recTs ~~ rec_names));
  40.120 +
  40.121 +        fun define_overloaded (def_name, eq) lthy =
  40.122 +          let
  40.123 +            val (Free (c, _), rhs) = (Logic.dest_equals o Syntax.check_term lthy) eq;
  40.124 +            val (thm, lthy') = lthy
  40.125 +              |> Local_Theory.define ((Binding.name c, NoSyn), ((Binding.name def_name, []), rhs))
  40.126 +              |-> (fn (t, (_, thm)) => Spec_Rules.add Spec_Rules.Equational ([t], [thm]) #> pair thm);
  40.127 +            val ctxt_thy = Proof_Context.init_global (Proof_Context.theory_of lthy');
  40.128 +            val thm' = singleton (Proof_Context.export lthy' ctxt_thy) thm;
  40.129 +          in (thm', lthy') end;
  40.130 +
  40.131 +        val ((size_def_thms, size_def_thms'), thy') =
  40.132 +          thy
  40.133 +          |> Sign.add_consts (map (fn (s, T) => (Binding.name (Long_Name.base_name s),
  40.134 +              param_size_fTs @ [T] ---> HOLogic.natT, NoSyn))
  40.135 +            (size_names ~~ recTs1))
  40.136 +          |> Global_Theory.add_defs false
  40.137 +            (map (Thm.no_attributes o apsnd (Logic.mk_equals o apsnd (app fs)))
  40.138 +               (map Binding.name def_names ~~ (size_fns ~~ rec_combs1)))
  40.139 +          ||> Class.instantiation (tycos, map dest_TFree paramTs, [HOLogic.class_size])
  40.140 +          ||>> fold_map define_overloaded
  40.141 +            (def_names' ~~ map Logic.mk_equals (overloaded_size_fns ~~ map (app fs') rec_combs1))
  40.142 +          ||> Class.prove_instantiation_instance (K (Class.intro_classes_tac []))
  40.143 +          ||> Local_Theory.exit_global;
  40.144 +
  40.145 +        val ctxt = Proof_Context.init_global thy';
  40.146 +
  40.147 +        val simpset1 =
  40.148 +          put_simpset HOL_basic_ss ctxt addsimps @{thm Nat.add_0} :: @{thm Nat.add_0_right} ::
  40.149 +            size_def_thms @ size_def_thms' @ rec_rewrites @ extra_rewrites;
  40.150 +        val xs = map (fn i => "x" ^ string_of_int i) (1 upto length recTs2);
  40.151 +
  40.152 +        fun mk_unfolded_size_eq tab size_ofp fs (p as (_, T), r) =
  40.153 +          HOLogic.mk_eq (app fs r $ Free p,
  40.154 +            the (size_of_type tab extra_size size_ofp T) $ Free p);
  40.155 +
  40.156 +        fun prove_unfolded_size_eqs size_ofp fs =
  40.157 +          if null recTs2 then []
  40.158 +          else Old_Datatype_Aux.split_conj_thm (Goal.prove_sorry ctxt xs []
  40.159 +            (HOLogic.mk_Trueprop (Old_Datatype_Aux.mk_conj (replicate l @{term True} @
  40.160 +               map (mk_unfolded_size_eq (AList.lookup op =
  40.161 +                   (new_type_names ~~ map (app fs) rec_combs1)) size_ofp fs)
  40.162 +                 (xs ~~ recTs2 ~~ rec_combs2))))
  40.163 +            (fn _ => (Old_Datatype_Aux.ind_tac induct xs THEN_ALL_NEW asm_simp_tac simpset1) 1));
  40.164 +
  40.165 +        val unfolded_size_eqs1 = prove_unfolded_size_eqs param_size fs;
  40.166 +        val unfolded_size_eqs2 = prove_unfolded_size_eqs (K NONE) fs';
  40.167 +
  40.168 +        (* characteristic equations for size functions *)
  40.169 +        fun gen_mk_size_eq p size_of size_ofp size_const T (cname, cargs) =
  40.170 +          let
  40.171 +            val Ts = map (Old_Datatype_Aux.typ_of_dtyp descr) cargs;
  40.172 +            val tnames = Name.variant_list f_names (Old_Datatype_Prop.make_tnames Ts);
  40.173 +            val ts = map_filter (fn (sT as (_, T), dt) =>
  40.174 +              Option.map (fn sz => sz $ Free sT)
  40.175 +                (if p dt then size_of_type size_of extra_size size_ofp T
  40.176 +                 else NONE)) (tnames ~~ Ts ~~ cargs)
  40.177 +          in
  40.178 +            HOLogic.mk_Trueprop (HOLogic.mk_eq
  40.179 +              (size_const $ list_comb (Const (cname, Ts ---> T),
  40.180 +                 map2 (curry Free) tnames Ts),
  40.181 +               if null ts then HOLogic.zero
  40.182 +               else foldl1 plus (ts @ [HOLogic.Suc_zero])))
  40.183 +          end;
  40.184 +
  40.185 +        val simpset2 =
  40.186 +          put_simpset HOL_basic_ss ctxt
  40.187 +            addsimps (rec_rewrites @ size_def_thms @ unfolded_size_eqs1);
  40.188 +        val simpset3 =
  40.189 +          put_simpset HOL_basic_ss ctxt
  40.190 +            addsimps (rec_rewrites @ size_def_thms' @ unfolded_size_eqs2);
  40.191 +
  40.192 +        fun prove_size_eqs p size_fns size_ofp simpset =
  40.193 +          maps (fn (((_, (_, _, constrs)), size_const), T) =>
  40.194 +            map (fn constr => Drule.export_without_context (Goal.prove_sorry ctxt [] []
  40.195 +              (gen_mk_size_eq p (AList.lookup op = (new_type_names ~~ size_fns))
  40.196 +                 size_ofp size_const T constr)
  40.197 +              (fn _ => simp_tac simpset 1))) constrs)
  40.198 +            (descr' ~~ size_fns ~~ recTs1);
  40.199 +
  40.200 +        val size_eqns = prove_size_eqs (is_poly thy') size_fns param_size simpset2 @
  40.201 +          prove_size_eqs Old_Datatype_Aux.is_rec_type overloaded_size_fns (K NONE) simpset3;
  40.202 +
  40.203 +        val ([(_, size_thms)], thy'') = thy'
  40.204 +          |> Global_Theory.note_thmss ""
  40.205 +            [((Binding.name "size",
  40.206 +                [Simplifier.simp_add, Named_Theorems.add @{named_theorems nitpick_simp},
  40.207 +                 Thm.declaration_attribute (fn thm =>
  40.208 +                   Context.mapping (Code.add_default_eqn thm) I)]),
  40.209 +              [(size_eqns, [])])];
  40.210 +
  40.211 +      in
  40.212 +        fold2 (fn new_type_name => fn size_name =>
  40.213 +            BNF_LFP_Size.register_size_global new_type_name size_name size_thms [])
  40.214 +          new_type_names size_names thy''
  40.215 +      end
  40.216 +  end;
  40.217 +
  40.218 +fun add_size_thms _ (new_type_names as name :: _) thy =
  40.219 +  let
  40.220 +    val info as {descr, ...} = Old_Datatype_Data.the_info thy name;
  40.221 +    val prefix = space_implode "_" (map Long_Name.base_name new_type_names);
  40.222 +    val no_size = exists (fn (_, (_, _, constrs)) => exists (fn (_, cargs) => exists (fn dt =>
  40.223 +      Old_Datatype_Aux.is_rec_type dt andalso
  40.224 +        not (null (fst (Old_Datatype_Aux.strip_dtyp dt)))) cargs) constrs) descr
  40.225 +  in
  40.226 +    if no_size then thy
  40.227 +    else
  40.228 +      thy
  40.229 +      |> Sign.add_path prefix
  40.230 +      |> prove_size_thms info new_type_names
  40.231 +      |> Sign.restore_naming thy
  40.232 +  end;
  40.233 +
  40.234 +val setup = Old_Datatype_Data.interpretation add_size_thms;
  40.235 +
  40.236 +end;
    41.1 --- a/src/HOL/Tools/Function/size.ML	Mon Sep 01 16:17:46 2014 +0200
    41.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    41.3 @@ -1,233 +0,0 @@
    41.4 -(*  Title:      HOL/Tools/Function/size.ML
    41.5 -    Author:     Stefan Berghofer, Florian Haftmann, TU Muenchen
    41.6 -
    41.7 -Size functions for datatypes.
    41.8 -*)
    41.9 -
   41.10 -signature SIZE =
   41.11 -sig
   41.12 -  val setup: theory -> theory
   41.13 -end;
   41.14 -
   41.15 -structure Size: SIZE =
   41.16 -struct
   41.17 -
   41.18 -fun plus (t1, t2) = Const (@{const_name Groups.plus},
   41.19 -  HOLogic.natT --> HOLogic.natT --> HOLogic.natT) $ t1 $ t2;
   41.20 -
   41.21 -fun size_of_type f g h (T as Type (s, Ts)) =
   41.22 -      (case f s of
   41.23 -         SOME t => SOME t
   41.24 -       | NONE => (case g s of
   41.25 -           SOME size_name =>
   41.26 -             SOME (list_comb (Const (size_name,
   41.27 -               map (fn U => U --> HOLogic.natT) Ts @ [T] ---> HOLogic.natT),
   41.28 -                 map (size_of_type' f g h) Ts))
   41.29 -         | NONE => NONE))
   41.30 -  | size_of_type _ _ h (TFree (s, _)) = h s
   41.31 -and size_of_type' f g h T = (case size_of_type f g h T of
   41.32 -      NONE => Abs ("x", T, HOLogic.zero)
   41.33 -    | SOME t => t);
   41.34 -
   41.35 -fun is_poly thy (Datatype_Aux.DtType (name, dts)) =
   41.36 -      is_some (BNF_LFP_Size.lookup_size_global thy name) andalso exists (is_poly thy) dts
   41.37 -  | is_poly _ _ = true;
   41.38 -
   41.39 -fun constrs_of thy name =
   41.40 -  let
   41.41 -    val {descr, index, ...} = Datatype_Data.the_info thy name
   41.42 -    val SOME (_, _, constrs) = AList.lookup op = descr index
   41.43 -  in constrs end;
   41.44 -
   41.45 -val app = curry (list_comb o swap);
   41.46 -
   41.47 -fun prove_size_thms (info : Datatype_Aux.info) new_type_names thy =
   41.48 -  let
   41.49 -    val {descr, rec_names, rec_rewrites, induct, ...} = info;
   41.50 -    val l = length new_type_names;
   41.51 -    val descr' = List.take (descr, l);
   41.52 -    val tycos = map (#1 o snd) descr';
   41.53 -  in
   41.54 -    if forall (fn tyco => can (Sign.arity_sorts thy tyco) [HOLogic.class_size]) tycos then
   41.55 -      (* nothing to do -- the "size" function is already defined *)
   41.56 -      thy
   41.57 -    else
   41.58 -      let
   41.59 -        val recTs = Datatype_Aux.get_rec_types descr;
   41.60 -        val (recTs1, recTs2) = chop l recTs;
   41.61 -        val (_, (_, paramdts, _)) :: _ = descr;
   41.62 -        val paramTs = map (Datatype_Aux.typ_of_dtyp descr) paramdts;
   41.63 -        val ((param_size_fs, param_size_fTs), f_names) = paramTs |>
   41.64 -          map (fn T as TFree (s, _) =>
   41.65 -            let
   41.66 -              val name = "f" ^ unprefix "'" s;
   41.67 -              val U = T --> HOLogic.natT
   41.68 -            in
   41.69 -              (((s, Free (name, U)), U), name)
   41.70 -            end) |> split_list |>> split_list;
   41.71 -        val param_size = AList.lookup op = param_size_fs;
   41.72 -
   41.73 -        val extra_rewrites = descr |> map (#1 o snd) |> distinct op = |>
   41.74 -          map_filter (Option.map (fst o snd) o BNF_LFP_Size.lookup_size_global thy) |> flat;
   41.75 -        val extra_size = Option.map fst o BNF_LFP_Size.lookup_size_global thy;
   41.76 -
   41.77 -        val (((size_names, size_fns), def_names), def_names') =
   41.78 -          recTs1 |> map (fn T as Type (s, _) =>
   41.79 -            let
   41.80 -              val s' = "size_" ^ Long_Name.base_name s;
   41.81 -              val s'' = Sign.full_bname thy s';
   41.82 -            in
   41.83 -              (s'',
   41.84 -               (list_comb (Const (s'', param_size_fTs @ [T] ---> HOLogic.natT),
   41.85 -                  map snd param_size_fs),
   41.86 -                (s' ^ "_def", s' ^ "_overloaded_def")))
   41.87 -            end) |> split_list ||>> split_list ||>> split_list;
   41.88 -        val overloaded_size_fns = map HOLogic.size_const recTs1;
   41.89 -
   41.90 -        (* instantiation for primrec combinator *)
   41.91 -        fun size_of_constr b size_ofp ((_, cargs), (_, cargs')) =
   41.92 -          let
   41.93 -            val Ts = map (Datatype_Aux.typ_of_dtyp descr) cargs;
   41.94 -            val k = length (filter Datatype_Aux.is_rec_type cargs);
   41.95 -            val (ts, _, _) = fold_rev (fn ((dt, dt'), T) => fn (us, i, j) =>
   41.96 -              if Datatype_Aux.is_rec_type dt then (Bound i :: us, i + 1, j + 1)
   41.97 -              else
   41.98 -                (if b andalso is_poly thy dt' then
   41.99 -                   case size_of_type (K NONE) extra_size size_ofp T of
  41.100 -                     NONE => us | SOME sz => sz $ Bound j :: us
  41.101 -                 else us, i, j + 1))
  41.102 -                  (cargs ~~ cargs' ~~ Ts) ([], 0, k);
  41.103 -            val t =
  41.104 -              if null ts andalso (not b orelse not (exists (is_poly thy) cargs'))
  41.105 -              then HOLogic.zero
  41.106 -              else foldl1 plus (ts @ [HOLogic.Suc_zero])
  41.107 -          in
  41.108 -            fold_rev (fn T => fn t' => Abs ("x", T, t')) (Ts @ replicate k HOLogic.natT) t
  41.109 -          end;
  41.110 -
  41.111 -        val fs = maps (fn (_, (name, _, constrs)) =>
  41.112 -          map (size_of_constr true param_size) (constrs ~~ constrs_of thy name)) descr;
  41.113 -        val fs' = maps (fn (n, (name, _, constrs)) =>
  41.114 -          map (size_of_constr (l <= n) (K NONE)) (constrs ~~ constrs_of thy name)) descr;
  41.115 -        val fTs = map fastype_of fs;
  41.116 -
  41.117 -        val (rec_combs1, rec_combs2) = chop l (map (fn (T, rec_name) =>
  41.118 -          Const (rec_name, fTs @ [T] ---> HOLogic.natT))
  41.119 -            (recTs ~~ rec_names));
  41.120 -
  41.121 -        fun define_overloaded (def_name, eq) lthy =
  41.122 -          let
  41.123 -            val (Free (c, _), rhs) = (Logic.dest_equals o Syntax.check_term lthy) eq;
  41.124 -            val (thm, lthy') = lthy
  41.125 -              |> Local_Theory.define ((Binding.name c, NoSyn), ((Binding.name def_name, []), rhs))
  41.126 -              |-> (fn (t, (_, thm)) => Spec_Rules.add Spec_Rules.Equational ([t], [thm]) #> pair thm);
  41.127 -            val ctxt_thy = Proof_Context.init_global (Proof_Context.theory_of lthy');
  41.128 -            val thm' = singleton (Proof_Context.export lthy' ctxt_thy) thm;
  41.129 -          in (thm', lthy') end;
  41.130 -
  41.131 -        val ((size_def_thms, size_def_thms'), thy') =
  41.132 -          thy
  41.133 -          |> Sign.add_consts (map (fn (s, T) => (Binding.name (Long_Name.base_name s),
  41.134 -              param_size_fTs @ [T] ---> HOLogic.natT, NoSyn))
  41.135 -            (size_names ~~ recTs1))
  41.136 -          |> Global_Theory.add_defs false
  41.137 -            (map (Thm.no_attributes o apsnd (Logic.mk_equals o apsnd (app fs)))
  41.138 -               (map Binding.name def_names ~~ (size_fns ~~ rec_combs1)))
  41.139 -          ||> Class.instantiation (tycos, map dest_TFree paramTs, [HOLogic.class_size])
  41.140 -          ||>> fold_map define_overloaded
  41.141 -            (def_names' ~~ map Logic.mk_equals (overloaded_size_fns ~~ map (app fs') rec_combs1))
  41.142 -          ||> Class.prove_instantiation_instance (K (Class.intro_classes_tac []))
  41.143 -          ||> Local_Theory.exit_global;
  41.144 -
  41.145 -        val ctxt = Proof_Context.init_global thy';
  41.146 -
  41.147 -        val simpset1 =
  41.148 -          put_simpset HOL_basic_ss ctxt addsimps @{thm Nat.add_0} :: @{thm Nat.add_0_right} ::
  41.149 -            size_def_thms @ size_def_thms' @ rec_rewrites @ extra_rewrites;
  41.150 -        val xs = map (fn i => "x" ^ string_of_int i) (1 upto length recTs2);
  41.151 -
  41.152 -        fun mk_unfolded_size_eq tab size_ofp fs (p as (_, T), r) =
  41.153 -          HOLogic.mk_eq (app fs r $ Free p,
  41.154 -            the (size_of_type tab extra_size size_ofp T) $ Free p);
  41.155 -
  41.156 -        fun prove_unfolded_size_eqs size_ofp fs =
  41.157 -          if null recTs2 then []
  41.158 -          else Datatype_Aux.split_conj_thm (Goal.prove_sorry ctxt xs []
  41.159 -            (HOLogic.mk_Trueprop (Datatype_Aux.mk_conj (replicate l @{term True} @
  41.160 -               map (mk_unfolded_size_eq (AList.lookup op =
  41.161 -                   (new_type_names ~~ map (app fs) rec_combs1)) size_ofp fs)
  41.162 -                 (xs ~~ recTs2 ~~ rec_combs2))))
  41.163 -            (fn _ => (Datatype_Aux.ind_tac induct xs THEN_ALL_NEW asm_simp_tac simpset1) 1));
  41.164 -
  41.165 -        val unfolded_size_eqs1 = prove_unfolded_size_eqs param_size fs;
  41.166 -        val unfolded_size_eqs2 = prove_unfolded_size_eqs (K NONE) fs';
  41.167 -
  41.168 -        (* characteristic equations for size functions *)
  41.169 -        fun gen_mk_size_eq p size_of size_ofp size_const T (cname, cargs) =
  41.170 -          let
  41.171 -            val Ts = map (Datatype_Aux.typ_of_dtyp descr) cargs;
  41.172 -            val tnames = Name.variant_list f_names (Datatype_Prop.make_tnames Ts);
  41.173 -            val ts = map_filter (fn (sT as (_, T), dt) =>
  41.174 -              Option.map (fn sz => sz $ Free sT)
  41.175 -                (if p dt then size_of_type size_of extra_size size_ofp T
  41.176 -                 else NONE)) (tnames ~~ Ts ~~ cargs)
  41.177 -          in
  41.178 -            HOLogic.mk_Trueprop (HOLogic.mk_eq
  41.179 -              (size_const $ list_comb (Const (cname, Ts ---> T),
  41.180 -                 map2 (curry Free) tnames Ts),
  41.181 -               if null ts then HOLogic.zero
  41.182 -               else foldl1 plus (ts @ [HOLogic.Suc_zero])))
  41.183 -          end;
  41.184 -
  41.185 -        val simpset2 =
  41.186 -          put_simpset HOL_basic_ss ctxt
  41.187 -            addsimps (rec_rewrites @ size_def_thms @ unfolded_size_eqs1);
  41.188 -        val simpset3 =
  41.189 -          put_simpset HOL_basic_ss ctxt
  41.190 -            addsimps (rec_rewrites @ size_def_thms' @ unfolded_size_eqs2);
  41.191 -
  41.192 -        fun prove_size_eqs p size_fns size_ofp simpset =
  41.193 -          maps (fn (((_, (_, _, constrs)), size_const), T) =>
  41.194 -            map (fn constr => Drule.export_without_context (Goal.prove_sorry ctxt [] []
  41.195 -              (gen_mk_size_eq p (AList.lookup op = (new_type_names ~~ size_fns))
  41.196 -                 size_ofp size_const T constr)
  41.197 -              (fn _ => simp_tac simpset 1))) constrs)
  41.198 -            (descr' ~~ size_fns ~~ recTs1);
  41.199 -
  41.200 -        val size_eqns = prove_size_eqs (is_poly thy') size_fns param_size simpset2 @
  41.201 -          prove_size_eqs Datatype_Aux.is_rec_type overloaded_size_fns (K NONE) simpset3;
  41.202 -
  41.203 -        val ([(_, size_thms)], thy'') = thy'
  41.204 -          |> Global_Theory.note_thmss ""
  41.205 -            [((Binding.name "size",
  41.206 -                [Simplifier.simp_add, Named_Theorems.add @{named_theorems nitpick_simp},
  41.207 -                 Thm.declaration_attribute (fn thm =>
  41.208 -                   Context.mapping (Code.add_default_eqn thm) I)]),
  41.209 -              [(size_eqns, [])])];
  41.210 -
  41.211 -      in
  41.212 -        fold2 (fn new_type_name => fn size_name =>
  41.213 -            BNF_LFP_Size.register_size_global new_type_name size_name size_thms [])
  41.214 -          new_type_names size_names thy''
  41.215 -      end
  41.216 -  end;
  41.217 -
  41.218 -fun add_size_thms _ (new_type_names as name :: _) thy =
  41.219 -  let
  41.220 -    val info as {descr, ...} = Datatype_Data.the_info thy name;
  41.221 -    val prefix = space_implode "_" (map Long_Name.base_name new_type_names);
  41.222 -    val no_size = exists (fn (_, (_, _, constrs)) => exists (fn (_, cargs) => exists (fn dt =>
  41.223 -      Datatype_Aux.is_rec_type dt andalso
  41.224 -        not (null (fst (Datatype_Aux.strip_dtyp dt)))) cargs) constrs) descr
  41.225 -  in
  41.226 -    if no_size then thy
  41.227 -    else
  41.228 -      thy
  41.229 -      |> Sign.add_path prefix
  41.230 -      |> prove_size_thms info new_type_names
  41.231 -      |> Sign.restore_naming thy
  41.232 -  end;
  41.233 -
  41.234 -val setup = Datatype_Data.interpretation add_size_thms;
  41.235 -
  41.236 -end;
    42.1 --- a/src/HOL/Tools/Lifting/lifting_def.ML	Mon Sep 01 16:17:46 2014 +0200
    42.2 +++ b/src/HOL/Tools/Lifting/lifting_def.ML	Mon Sep 01 16:17:46 2014 +0200
    42.3 @@ -585,7 +585,7 @@
    42.4        | rename t _ = t
    42.5  
    42.6      val (fixed_def_t, _) = yield_singleton (Variable.importT_terms) term ctxt
    42.7 -    val new_names = Datatype_Prop.make_tnames (all_typs fixed_def_t)
    42.8 +    val new_names = Old_Datatype_Prop.make_tnames (all_typs fixed_def_t)
    42.9    in
   42.10      rename term new_names
   42.11    end
    43.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    43.2 +++ b/src/HOL/Tools/Old_Datatype/old_datatype.ML	Mon Sep 01 16:17:46 2014 +0200
    43.3 @@ -0,0 +1,802 @@
    43.4 +(*  Title:      HOL/Tools/Old_Datatype/old_datatype.ML
    43.5 +    Author:     Stefan Berghofer, TU Muenchen
    43.6 +
    43.7 +Datatype package: definitional introduction of datatypes
    43.8 +with proof of characteristic theorems: injectivity / distinctness
    43.9 +of constructors and induction.  Main interface to datatypes
   43.10 +after full bootstrap of datatype package.
   43.11 +*)
   43.12 +
   43.13 +signature OLD_DATATYPE =
   43.14 +sig
   43.15 +  val distinct_lemma: thm
   43.16 +  type spec =
   43.17 +    (binding * (string * sort) list * mixfix) *
   43.18 +    (binding * typ list * mixfix) list
   43.19 +  type spec_cmd =
   43.20 +    (binding * (string * string option) list * mixfix) *
   43.21 +    (binding * string list * mixfix) list
   43.22 +  val read_specs: spec_cmd list -> theory -> spec list * Proof.context
   43.23 +  val check_specs: spec list -> theory -> spec list * Proof.context
   43.24 +  val add_datatype: Old_Datatype_Aux.config -> spec list -> theory -> string list * theory
   43.25 +  val add_datatype_cmd: Old_Datatype_Aux.config -> spec_cmd list -> theory -> string list * theory
   43.26 +  val spec_cmd: spec_cmd parser
   43.27 +end;
   43.28 +
   43.29 +structure Old_Datatype : OLD_DATATYPE =
   43.30 +struct
   43.31 +
   43.32 +(** auxiliary **)
   43.33 +
   43.34 +val distinct_lemma = @{lemma "f x \<noteq> f y ==> x \<noteq> y" by iprover};
   43.35 +val (_ $ (_ $ (_ $ (distinct_f $ _) $ _))) = hd (prems_of distinct_lemma);
   43.36 +
   43.37 +fun exh_thm_of (dt_info : Old_Datatype_Aux.info Symtab.table) tname =
   43.38 +  #exhaust (the (Symtab.lookup dt_info tname));
   43.39 +
   43.40 +val In0_inject = @{thm In0_inject};
   43.41 +val In1_inject = @{thm In1_inject};
   43.42 +val Scons_inject = @{thm Scons_inject};
   43.43 +val Leaf_inject = @{thm Leaf_inject};
   43.44 +val In0_eq = @{thm In0_eq};
   43.45 +val In1_eq = @{thm In1_eq};
   43.46 +val In0_not_In1 = @{thm In0_not_In1};
   43.47 +val In1_not_In0 = @{thm In1_not_In0};
   43.48 +val Lim_inject = @{thm Lim_inject};
   43.49 +val Inl_inject = @{thm Inl_inject};
   43.50 +val Inr_inject = @{thm Inr_inject};
   43.51 +val Suml_inject = @{thm Suml_inject};
   43.52 +val Sumr_inject = @{thm Sumr_inject};
   43.53 +
   43.54 +val datatype_injI =
   43.55 +  @{lemma "(!!x. ALL y. f x = f y --> x = y) ==> inj f" by (simp add: inj_on_def)};
   43.56 +
   43.57 +
   43.58 +(** proof of characteristic theorems **)
   43.59 +
   43.60 +fun representation_proofs (config : Old_Datatype_Aux.config)
   43.61 +    (dt_info : Old_Datatype_Aux.info Symtab.table) descr types_syntax constr_syntax case_names_induct
   43.62 +    thy =
   43.63 +  let
   43.64 +    val descr' = flat descr;
   43.65 +    val new_type_names = map (Binding.name_of o fst) types_syntax;
   43.66 +    val big_name = space_implode "_" new_type_names;
   43.67 +    val thy1 = Sign.add_path big_name thy;
   43.68 +    val big_rec_name = "rep_set_" ^ big_name;
   43.69 +    val rep_set_names' =
   43.70 +      if length descr' = 1 then [big_rec_name]
   43.71 +      else map (prefix (big_rec_name ^ "_") o string_of_int) (1 upto length descr');
   43.72 +    val rep_set_names = map (Sign.full_bname thy1) rep_set_names';
   43.73 +
   43.74 +    val tyvars = map (fn (_, (_, Ts, _)) => map Old_Datatype_Aux.dest_DtTFree Ts) (hd descr);
   43.75 +    val leafTs' = Old_Datatype_Aux.get_nonrec_types descr';
   43.76 +    val branchTs = Old_Datatype_Aux.get_branching_types descr';
   43.77 +    val branchT =
   43.78 +      if null branchTs then HOLogic.unitT
   43.79 +      else Balanced_Tree.make (fn (T, U) => Type (@{type_name Sum_Type.sum}, [T, U])) branchTs;
   43.80 +    val arities = remove (op =) 0 (Old_Datatype_Aux.get_arities descr');
   43.81 +    val unneeded_vars =
   43.82 +      subtract (op =) (fold Term.add_tfreesT (leafTs' @ branchTs) []) (hd tyvars);
   43.83 +    val leafTs = leafTs' @ map TFree unneeded_vars;
   43.84 +    val recTs = Old_Datatype_Aux.get_rec_types descr';
   43.85 +    val (newTs, oldTs) = chop (length (hd descr)) recTs;
   43.86 +    val sumT =
   43.87 +      if null leafTs then HOLogic.unitT
   43.88 +      else Balanced_Tree.make (fn (T, U) => Type (@{type_name Sum_Type.sum}, [T, U])) leafTs;
   43.89 +    val Univ_elT = HOLogic.mk_setT (Type (@{type_name Old_Datatype.node}, [sumT, branchT]));
   43.90 +    val UnivT = HOLogic.mk_setT Univ_elT;
   43.91 +    val UnivT' = Univ_elT --> HOLogic.boolT;
   43.92 +    val Collect = Const (@{const_name Collect}, UnivT' --> UnivT);
   43.93 +
   43.94 +    val In0 = Const (@{const_name Old_Datatype.In0}, Univ_elT --> Univ_elT);
   43.95 +    val In1 = Const (@{const_name Old_Datatype.In1}, Univ_elT --> Univ_elT);
   43.96 +    val Leaf = Const (@{const_name Old_Datatype.Leaf}, sumT --> Univ_elT);
   43.97 +    val Lim = Const (@{const_name Old_Datatype.Lim}, (branchT --> Univ_elT) --> Univ_elT);
   43.98 +
   43.99 +    (* make injections needed for embedding types in leaves *)
  43.100 +
  43.101 +    fun mk_inj T' x =
  43.102 +      let
  43.103 +        fun mk_inj' T n i =
  43.104 +          if n = 1 then x
  43.105 +          else
  43.106 +            let
  43.107 +              val n2 = n div 2;
  43.108 +              val Type (_, [T1, T2]) = T;
  43.109 +            in
  43.110 +              if i <= n2
  43.111 +              then Const (@{const_name Inl}, T1 --> T) $ mk_inj' T1 n2 i
  43.112 +              else Const (@{const_name Inr}, T2 --> T) $ mk_inj' T2 (n - n2) (i - n2)
  43.113 +            end;
  43.114 +      in mk_inj' sumT (length leafTs) (1 + find_index (fn T'' => T'' = T') leafTs) end;
  43.115 +
  43.116 +    (* make injections for constructors *)
  43.117 +
  43.118 +    fun mk_univ_inj ts = Balanced_Tree.access
  43.119 +      {left = fn t => In0 $ t,
  43.120 +        right = fn t => In1 $ t,
  43.121 +        init =
  43.122 +          if ts = [] then Const (@{const_name undefined}, Univ_elT)
  43.123 +          else foldr1 (HOLogic.mk_binop @{const_name Old_Datatype.Scons}) ts};
  43.124 +
  43.125 +    (* function spaces *)
  43.126 +
  43.127 +    fun mk_fun_inj T' x =
  43.128 +      let
  43.129 +        fun mk_inj T n i =
  43.130 +          if n = 1 then x
  43.131 +          else
  43.132 +            let
  43.133 +              val n2 = n div 2;
  43.134 +              val Type (_, [T1, T2]) = T;
  43.135 +              fun mkT U = (U --> Univ_elT) --> T --> Univ_elT;
  43.136 +            in
  43.137 +              if i <= n2 then Const (@{const_name Sum_Type.Suml}, mkT T1) $ mk_inj T1 n2 i
  43.138 +              else Const (@{const_name Sum_Type.Sumr}, mkT T2) $ mk_inj T2 (n - n2) (i - n2)
  43.139 +            end;
  43.140 +      in mk_inj branchT (length branchTs) (1 + find_index (fn T'' => T'' = T') branchTs) end;
  43.141 +
  43.142 +    fun mk_lim t Ts = fold_rev (fn T => fn t => Lim $ mk_fun_inj T (Abs ("x", T, t))) Ts t;
  43.143 +
  43.144 +    (************** generate introduction rules for representing set **********)
  43.145 +
  43.146 +    val _ = Old_Datatype_Aux.message config "Constructing representing sets ...";
  43.147 +
  43.148 +    (* make introduction rule for a single constructor *)
  43.149 +
  43.150 +    fun make_intr s n (i, (_, cargs)) =
  43.151 +      let
  43.152 +        fun mk_prem dt (j, prems, ts) =
  43.153 +          (case Old_Datatype_Aux.strip_dtyp dt of
  43.154 +            (dts, Old_Datatype_Aux.DtRec k) =>
  43.155 +              let
  43.156 +                val Ts = map (Old_Datatype_Aux.typ_of_dtyp descr') dts;
  43.157 +                val free_t =
  43.158 +                  Old_Datatype_Aux.app_bnds (Old_Datatype_Aux.mk_Free "x" (Ts ---> Univ_elT) j)
  43.159 +                    (length Ts)
  43.160 +              in
  43.161 +                (j + 1, Logic.list_all (map (pair "x") Ts,
  43.162 +                  HOLogic.mk_Trueprop
  43.163 +                    (Free (nth rep_set_names' k, UnivT') $ free_t)) :: prems,
  43.164 +                mk_lim free_t Ts :: ts)
  43.165 +              end
  43.166 +          | _ =>
  43.167 +              let val T = Old_Datatype_Aux.typ_of_dtyp descr' dt
  43.168 +              in (j + 1, prems, (Leaf $ mk_inj T (Old_Datatype_Aux.mk_Free "x" T j)) :: ts) end);
  43.169 +
  43.170 +        val (_, prems, ts) = fold_rev mk_prem cargs (1, [], []);
  43.171 +        val concl = HOLogic.mk_Trueprop (Free (s, UnivT') $ mk_univ_inj ts n i);
  43.172 +      in Logic.list_implies (prems, concl) end;
  43.173 +
  43.174 +    val intr_ts = maps (fn ((_, (_, _, constrs)), rep_set_name) =>
  43.175 +      map (make_intr rep_set_name (length constrs))
  43.176 +        ((1 upto length constrs) ~~ constrs)) (descr' ~~ rep_set_names');
  43.177 +
  43.178 +    val ({raw_induct = rep_induct, intrs = rep_intrs, ...}, thy2) =
  43.179 +      thy1
  43.180 +      |> Sign.map_naming Name_Space.conceal
  43.181 +      |> Inductive.add_inductive_global
  43.182 +          {quiet_mode = #quiet config, verbose = false, alt_name = Binding.name big_rec_name,
  43.183 +           coind = false, no_elim = true, no_ind = false, skip_mono = true}
  43.184 +          (map (fn s => ((Binding.name s, UnivT'), NoSyn)) rep_set_names') []
  43.185 +          (map (fn x => (Attrib.empty_binding, x)) intr_ts) []
  43.186 +      ||> Sign.restore_naming thy1;
  43.187 +
  43.188 +    (********************************* typedef ********************************)
  43.189 +
  43.190 +    val (typedefs, thy3) = thy2
  43.191 +      |> Sign.parent_path
  43.192 +      |> fold_map
  43.193 +        (fn (((name, mx), tvs), c) =>
  43.194 +          Typedef.add_typedef_global (name, tvs, mx)
  43.195 +            (Collect $ Const (c, UnivT')) NONE
  43.196 +            (rtac exI 1 THEN rtac CollectI 1 THEN
  43.197 +              QUIET_BREADTH_FIRST (has_fewer_prems 1)
  43.198 +              (resolve_tac rep_intrs 1)))
  43.199 +        (types_syntax ~~ tyvars ~~ take (length newTs) rep_set_names)
  43.200 +      ||> Sign.add_path big_name;
  43.201 +
  43.202 +    (*********************** definition of constructors ***********************)
  43.203 +
  43.204 +    val big_rep_name = big_name ^ "_Rep_";
  43.205 +    val rep_names' = map (fn i => big_rep_name ^ string_of_int i) (1 upto length (flat (tl descr)));
  43.206 +    val all_rep_names =
  43.207 +      map (#Rep_name o #1 o #2) typedefs @
  43.208 +      map (Sign.full_bname thy3) rep_names';
  43.209 +
  43.210 +    (* isomorphism declarations *)
  43.211 +
  43.212 +    val iso_decls = map (fn (T, s) => (Binding.name s, T --> Univ_elT, NoSyn))
  43.213 +      (oldTs ~~ rep_names');
  43.214 +
  43.215 +    (* constructor definitions *)
  43.216 +
  43.217 +    fun make_constr_def (typedef: Typedef.info) T n
  43.218 +        ((cname, cargs), (cname', mx)) (thy, defs, eqns, i) =
  43.219 +      let
  43.220 +        fun constr_arg dt (j, l_args, r_args) =
  43.221 +          let
  43.222 +            val T = Old_Datatype_Aux.typ_of_dtyp descr' dt;
  43.223 +            val free_t = Old_Datatype_Aux.mk_Free "x" T j;
  43.224 +          in
  43.225 +            (case (Old_Datatype_Aux.strip_dtyp dt, strip_type T) of
  43.226 +              ((_, Old_Datatype_Aux.DtRec m), (Us, U)) =>
  43.227 +                (j + 1, free_t :: l_args, mk_lim
  43.228 +                  (Const (nth all_rep_names m, U --> Univ_elT) $
  43.229 +                    Old_Datatype_Aux.app_bnds free_t (length Us)) Us :: r_args)
  43.230 +            | _ => (j + 1, free_t :: l_args, (Leaf $ mk_inj T free_t) :: r_args))
  43.231 +          end;
  43.232 +
  43.233 +        val (_, l_args, r_args) = fold_rev constr_arg cargs (1, [], []);
  43.234 +        val constrT = map (Old_Datatype_Aux.typ_of_dtyp descr') cargs ---> T;
  43.235 +        val ({Abs_name, Rep_name, ...}, _) = typedef;
  43.236 +        val lhs = list_comb (Const (cname, constrT), l_args);
  43.237 +        val rhs = mk_univ_inj r_args n i;
  43.238 +        val def = Logic.mk_equals (lhs, Const (Abs_name, Univ_elT --> T) $ rhs);
  43.239 +        val def_name = Thm.def_name (Long_Name.base_name cname);
  43.240 +        val eqn =
  43.241 +          HOLogic.mk_Trueprop (HOLogic.mk_eq (Const (Rep_name, T --> Univ_elT) $ lhs, rhs));
  43.242 +        val ([def_thm], thy') =
  43.243 +          thy
  43.244 +          |> Sign.add_consts [(cname', constrT, mx)]
  43.245 +          |> (Global_Theory.add_defs false o map Thm.no_attributes) [(Binding.name def_name, def)];
  43.246 +
  43.247 +      in (thy', defs @ [def_thm], eqns @ [eqn], i + 1) end;
  43.248 +
  43.249 +    (* constructor definitions for datatype *)
  43.250 +
  43.251 +    fun dt_constr_defs (((((_, (_, _, constrs)), tname), typedef: Typedef.info), T), constr_syntax)
  43.252 +        (thy, defs, eqns, rep_congs, dist_lemmas) =
  43.253 +      let
  43.254 +        val _ $ (_ $ (cong_f $ _) $ _) = concl_of arg_cong;
  43.255 +        val rep_const = cterm_of thy (Const (#Rep_name (#1 typedef), T --> Univ_elT));
  43.256 +        val cong' = cterm_instantiate [(cterm_of thy cong_f, rep_const)] arg_cong;
  43.257 +        val dist = cterm_instantiate [(cterm_of thy distinct_f, rep_const)] distinct_lemma;
  43.258 +        val (thy', defs', eqns', _) =
  43.259 +          fold (make_constr_def typedef T (length constrs))
  43.260 +            (constrs ~~ constr_syntax) (Sign.add_path tname thy, defs, [], 1);
  43.261 +      in
  43.262 +        (Sign.parent_path thy', defs', eqns @ [eqns'],
  43.263 +          rep_congs @ [cong'], dist_lemmas @ [dist])
  43.264 +      end;
  43.265 +
  43.266 +    val (thy4, constr_defs, constr_rep_eqns, rep_congs, dist_lemmas) =
  43.267 +      fold dt_constr_defs
  43.268 +        (hd descr ~~ new_type_names ~~ map #2 typedefs ~~ newTs ~~ constr_syntax)
  43.269 +        (thy3 |> Sign.add_consts iso_decls |> Sign.parent_path, [], [], [], []);
  43.270 +
  43.271 +
  43.272 +    (*********** isomorphisms for new types (introduced by typedef) ***********)
  43.273 +
  43.274 +    val _ = Old_Datatype_Aux.message config "Proving isomorphism properties ...";
  43.275 +
  43.276 +    val collect_simp = rewrite_rule (Proof_Context.init_global thy4) [mk_meta_eq mem_Collect_eq];
  43.277 +
  43.278 +    val newT_iso_axms = typedefs |> map (fn (_, (_, {Abs_inverse, Rep_inverse, Rep, ...})) =>
  43.279 +      (collect_simp Abs_inverse, Rep_inverse, collect_simp Rep));
  43.280 +
  43.281 +    val newT_iso_inj_thms = typedefs |> map (fn (_, (_, {Abs_inject, Rep_inject, ...})) =>
  43.282 +      (collect_simp Abs_inject RS iffD1, Rep_inject RS iffD1));
  43.283 +
  43.284 +    (********* isomorphisms between existing types and "unfolded" types *******)
  43.285 +
  43.286 +    (*---------------------------------------------------------------------*)
  43.287 +    (* isomorphisms are defined using primrec-combinators:                 *)
  43.288 +    (* generate appropriate functions for instantiating primrec-combinator *)
  43.289 +    (*                                                                     *)
  43.290 +    (*   e.g.  Rep_dt_i = list_rec ... (%h t y. In1 (Scons (Leaf h) y))    *)
  43.291 +    (*                                                                     *)
  43.292 +    (* also generate characteristic equations for isomorphisms             *)
  43.293 +    (*                                                                     *)
  43.294 +    (*   e.g.  Rep_dt_i (cons h t) = In1 (Scons (Rep_dt_j h) (Rep_dt_i t)) *)
  43.295 +    (*---------------------------------------------------------------------*)
  43.296 +
  43.297 +    fun make_iso_def k ks n (cname, cargs) (fs, eqns, i) =
  43.298 +      let
  43.299 +        val argTs = map (Old_Datatype_Aux.typ_of_dtyp descr') cargs;
  43.300 +        val T = nth recTs k;
  43.301 +        val rep_const = Const (nth all_rep_names k, T --> Univ_elT);
  43.302 +        val constr = Const (cname, argTs ---> T);
  43.303 +
  43.304 +        fun process_arg ks' dt (i2, i2', ts, Ts) =
  43.305 +          let
  43.306 +            val T' = Old_Datatype_Aux.typ_of_dtyp descr' dt;
  43.307 +            val (Us, U) = strip_type T'
  43.308 +          in
  43.309 +            (case Old_Datatype_Aux.strip_dtyp dt of
  43.310 +              (_, Old_Datatype_Aux.DtRec j) =>
  43.311 +                if member (op =) ks' j then
  43.312 +                  (i2 + 1, i2' + 1, ts @ [mk_lim (Old_Datatype_Aux.app_bnds
  43.313 +                     (Old_Datatype_Aux.mk_Free "y" (Us ---> Univ_elT) i2') (length Us)) Us],
  43.314 +                   Ts @ [Us ---> Univ_elT])
  43.315 +                else
  43.316 +                  (i2 + 1, i2', ts @ [mk_lim
  43.317 +                     (Const (nth all_rep_names j, U --> Univ_elT) $
  43.318 +                        Old_Datatype_Aux.app_bnds
  43.319 +                          (Old_Datatype_Aux.mk_Free "x" T' i2) (length Us)) Us], Ts)
  43.320 +            | _ => (i2 + 1, i2', ts @ [Leaf $ mk_inj T' (Old_Datatype_Aux.mk_Free "x" T' i2)], Ts))
  43.321 +          end;
  43.322 +
  43.323 +        val (i2, i2', ts, Ts) = fold (process_arg ks) cargs (1, 1, [], []);
  43.324 +        val xs = map (uncurry (Old_Datatype_Aux.mk_Free "x")) (argTs ~~ (1 upto (i2 - 1)));
  43.325 +        val ys = map (uncurry (Old_Datatype_Aux.mk_Free "y")) (Ts ~~ (1 upto (i2' - 1)));
  43.326 +        val f = fold_rev lambda (xs @ ys) (mk_univ_inj ts n i);
  43.327 +
  43.328 +        val (_, _, ts', _) = fold (process_arg []) cargs (1, 1, [], []);
  43.329 +        val eqn = HOLogic.mk_Trueprop (HOLogic.mk_eq
  43.330 +          (rep_const $ list_comb (constr, xs), mk_univ_inj ts' n i))
  43.331 +
  43.332 +      in (fs @ [f], eqns @ [eqn], i + 1) end;
  43.333 +
  43.334 +    (* define isomorphisms for all mutually recursive datatypes in list ds *)
  43.335 +
  43.336 +    fun make_iso_defs ds (thy, char_thms) =
  43.337 +      let
  43.338 +        val ks = map fst ds;
  43.339 +        val (_, (tname, _, _)) = hd ds;
  43.340 +        val {rec_rewrites, rec_names, ...} = the (Symtab.lookup dt_info tname);
  43.341 +
  43.342 +        fun process_dt (k, (_, _, constrs)) (fs, eqns, isos) =
  43.343 +          let
  43.344 +            val (fs', eqns', _) = fold (make_iso_def k ks (length constrs)) constrs (fs, eqns, 1);
  43.345 +            val iso = (nth recTs k, nth all_rep_names k);
  43.346 +          in (fs', eqns', isos @ [iso]) end;
  43.347 +
  43.348 +        val (fs, eqns, isos) = fold process_dt ds ([], [], []);
  43.349 +        val fTs = map fastype_of fs;
  43.350 +        val defs =
  43.351 +          map (fn (rec_name, (T, iso_name)) =>
  43.352 +            (Binding.name (Thm.def_name (Long_Name.base_name iso_name)),
  43.353 +              Logic.mk_equals (Const (iso_name, T --> Univ_elT),
  43.354 +                list_comb (Const (rec_name, fTs @ [T] ---> Univ_elT), fs)))) (rec_names ~~ isos);
  43.355 +        val (def_thms, thy') =
  43.356 +          (Global_Theory.add_defs false o map Thm.no_attributes) defs thy;
  43.357 +
  43.358 +        (* prove characteristic equations *)
  43.359 +
  43.360 +        val rewrites = def_thms @ map mk_meta_eq rec_rewrites;
  43.361 +        val char_thms' =
  43.362 +          map (fn eqn => Goal.prove_sorry_global thy' [] [] eqn
  43.363 +            (fn {context = ctxt, ...} => EVERY [rewrite_goals_tac ctxt rewrites, rtac refl 1])) eqns;
  43.364 +
  43.365 +      in (thy', char_thms' @ char_thms) end;
  43.366 +
  43.367 +    val (thy5, iso_char_thms) =
  43.368 +      fold_rev make_iso_defs (tl descr) (Sign.add_path big_name thy4, []);
  43.369 +
  43.370 +    (* prove isomorphism properties *)
  43.371 +
  43.372 +    fun mk_funs_inv thy thm =
  43.373 +      let
  43.374 +        val prop = Thm.prop_of thm;
  43.375 +        val _ $ (_ $ ((S as Const (_, Type (_, [U, _]))) $ _ )) $
  43.376 +          (_ $ (_ $ (r $ (a $ _)) $ _)) = Type.legacy_freeze prop;
  43.377 +        val used = Term.add_tfree_names a [];
  43.378 +
  43.379 +        fun mk_thm i =
  43.380 +          let
  43.381 +            val Ts = map (TFree o rpair @{sort type}) (Name.variant_list used (replicate i "'t"));
  43.382 +            val f = Free ("f", Ts ---> U);
  43.383 +          in
  43.384 +            Goal.prove_sorry_global thy [] []
  43.385 +              (Logic.mk_implies
  43.386 +                (HOLogic.mk_Trueprop (HOLogic.list_all
  43.387 +                   (map (pair "x") Ts, S $ Old_Datatype_Aux.app_bnds f i)),
  43.388 +                 HOLogic.mk_Trueprop (HOLogic.mk_eq (fold_rev (Term.abs o pair "x") Ts
  43.389 +                   (r $ (a $ Old_Datatype_Aux.app_bnds f i)), f))))
  43.390 +              (fn _ => EVERY [REPEAT_DETERM_N i (rtac @{thm ext} 1),
  43.391 +                 REPEAT (etac allE 1), rtac thm 1, atac 1])
  43.392 +          end
  43.393 +      in map (fn r => r RS subst) (thm :: map mk_thm arities) end;
  43.394 +
  43.395 +    (* prove  inj Rep_dt_i  and  Rep_dt_i x : rep_set_dt_i *)
  43.396 +
  43.397 +    val fun_congs =
  43.398 +      map (fn T => make_elim (Drule.instantiate' [SOME (ctyp_of thy5 T)] [] fun_cong)) branchTs;
  43.399 +
  43.400 +    fun prove_iso_thms ds (inj_thms, elem_thms) =
  43.401 +      let
  43.402 +        val (_, (tname, _, _)) = hd ds;
  43.403 +        val induct = #induct (the (Symtab.lookup dt_info tname));
  43.404 +
  43.405 +        fun mk_ind_concl (i, _) =
  43.406 +          let
  43.407 +            val T = nth recTs i;
  43.408 +            val Rep_t = Const (nth all_rep_names i, T --> Univ_elT);
  43.409 +            val rep_set_name = nth rep_set_names i;
  43.410 +            val concl1 =
  43.411 +              HOLogic.all_const T $ Abs ("y", T, HOLogic.imp $
  43.412 +                HOLogic.mk_eq (Rep_t $ Old_Datatype_Aux.mk_Free "x" T i, Rep_t $ Bound 0) $
  43.413 +                  HOLogic.mk_eq (Old_Datatype_Aux.mk_Free "x" T i, Bound 0));
  43.414 +            val concl2 = Const (rep_set_name, UnivT') $ (Rep_t $ Old_Datatype_Aux.mk_Free "x" T i);
  43.415 +          in (concl1, concl2) end;
  43.416 +
  43.417 +        val (ind_concl1, ind_concl2) = split_list (map mk_ind_concl ds);
  43.418 +
  43.419 +        val rewrites = map mk_meta_eq iso_char_thms;
  43.420 +        val inj_thms' = map snd newT_iso_inj_thms @ map (fn r => r RS @{thm injD}) inj_thms;
  43.421 +
  43.422 +        val inj_thm =
  43.423 +          Goal.prove_sorry_global thy5 [] []
  43.424 +            (HOLogic.mk_Trueprop (Old_Datatype_Aux.mk_conj ind_concl1))
  43.425 +            (fn {context = ctxt, ...} => EVERY
  43.426 +              [(Old_Datatype_Aux.ind_tac induct [] THEN_ALL_NEW Object_Logic.atomize_prems_tac ctxt) 1,
  43.427 +               REPEAT (EVERY
  43.428 +                 [rtac allI 1, rtac impI 1,
  43.429 +                  Old_Datatype_Aux.exh_tac (exh_thm_of dt_info) 1,
  43.430 +                  REPEAT (EVERY
  43.431 +                    [hyp_subst_tac ctxt 1,
  43.432 +                     rewrite_goals_tac ctxt rewrites,
  43.433 +                     REPEAT (dresolve_tac [In0_inject, In1_inject] 1),
  43.434 +                     (eresolve_tac [In0_not_In1 RS notE, In1_not_In0 RS notE] 1)
  43.435 +                     ORELSE (EVERY
  43.436 +                       [REPEAT (eresolve_tac (Scons_inject ::
  43.437 +                          map make_elim [Leaf_inject, Inl_inject, Inr_inject]) 1),
  43.438 +                        REPEAT (cong_tac 1), rtac refl 1,
  43.439 +                        REPEAT (atac 1 ORELSE (EVERY
  43.440 +                          [REPEAT (rtac @{thm ext} 1),
  43.441 +                           REPEAT (eresolve_tac (mp :: allE ::
  43.442 +                             map make_elim (Suml_inject :: Sumr_inject ::
  43.443 +                               Lim_inject :: inj_thms') @ fun_congs) 1),
  43.444 +                           atac 1]))])])])]);
  43.445 +
  43.446 +        val inj_thms'' = map (fn r => r RS datatype_injI) (Old_Datatype_Aux.split_conj_thm inj_thm);
  43.447 +
  43.448 +        val elem_thm =
  43.449 +          Goal.prove_sorry_global thy5 [] []
  43.450 +            (HOLogic.mk_Trueprop (Old_Datatype_Aux.mk_conj ind_concl2))
  43.451 +            (fn {context = ctxt, ...} =>
  43.452 +              EVERY [
  43.453 +                (Old_Datatype_Aux.ind_tac induct [] THEN_ALL_NEW Object_Logic.atomize_prems_tac ctxt) 1,
  43.454 +                rewrite_goals_tac ctxt rewrites,
  43.455 +                REPEAT ((resolve_tac rep_intrs THEN_ALL_NEW
  43.456 +                  ((REPEAT o etac allE) THEN' ares_tac elem_thms)) 1)]);
  43.457 +
  43.458 +      in (inj_thms'' @ inj_thms, elem_thms @ Old_Datatype_Aux.split_conj_thm elem_thm) end;
  43.459 +
  43.460 +    val (iso_inj_thms_unfolded, iso_elem_thms) =
  43.461 +      fold_rev prove_iso_thms (tl descr) ([], map #3 newT_iso_axms);
  43.462 +    val iso_inj_thms =
  43.463 +      map snd newT_iso_inj_thms @ map (fn r => r RS @{thm injD}) iso_inj_thms_unfolded;
  43.464 +
  43.465 +    (* prove  rep_set_dt_i x --> x : range Rep_dt_i *)
  43.466 +
  43.467 +    fun mk_iso_t (((set_name, iso_name), i), T) =
  43.468 +      let val isoT = T --> Univ_elT in
  43.469 +        HOLogic.imp $
  43.470 +          (Const (set_name, UnivT') $ Old_Datatype_Aux.mk_Free "x" Univ_elT i) $
  43.471 +            (if i < length newTs then @{term True}
  43.472 +             else HOLogic.mk_mem (Old_Datatype_Aux.mk_Free "x" Univ_elT i,
  43.473 +               Const (@{const_name image}, isoT --> HOLogic.mk_setT T --> UnivT) $
  43.474 +                 Const (iso_name, isoT) $ Const (@{const_abbrev UNIV}, HOLogic.mk_setT T)))
  43.475 +      end;
  43.476 +
  43.477 +    val iso_t = HOLogic.mk_Trueprop (Old_Datatype_Aux.mk_conj (map mk_iso_t
  43.478 +      (rep_set_names ~~ all_rep_names ~~ (0 upto (length descr' - 1)) ~~ recTs)));
  43.479 +
  43.480 +    (* all the theorems are proved by one single simultaneous induction *)
  43.481 +
  43.482 +    val range_eqs = map (fn r => mk_meta_eq (r RS @{thm range_ex1_eq})) iso_inj_thms_unfolded;
  43.483 +
  43.484 +    val iso_thms =
  43.485 +      if length descr = 1 then []
  43.486 +      else
  43.487 +        drop (length newTs) (Old_Datatype_Aux.split_conj_thm
  43.488 +          (Goal.prove_sorry_global thy5 [] [] iso_t (fn {context = ctxt, ...} => EVERY
  43.489 +             [(Old_Datatype_Aux.ind_tac rep_induct [] THEN_ALL_NEW
  43.490 +                 Object_Logic.atomize_prems_tac ctxt) 1,
  43.491 +              REPEAT (rtac TrueI 1),
  43.492 +              rewrite_goals_tac ctxt (mk_meta_eq @{thm choice_eq} ::
  43.493 +                Thm.symmetric (mk_meta_eq @{thm fun_eq_iff}) :: range_eqs),
  43.494 +              rewrite_goals_tac ctxt (map Thm.symmetric range_eqs),
  43.495 +              REPEAT (EVERY
  43.496 +                [REPEAT (eresolve_tac ([rangeE, @{thm ex1_implies_ex} RS exE] @
  43.497 +                   maps (mk_funs_inv thy5 o #1) newT_iso_axms) 1),
  43.498 +                 TRY (hyp_subst_tac ctxt 1),
  43.499 +                 rtac (sym RS range_eqI) 1,
  43.500 +                 resolve_tac iso_char_thms 1])])));
  43.501 +
  43.502 +    val Abs_inverse_thms' =
  43.503 +      map #1 newT_iso_axms @
  43.504 +      map2 (fn r_inj => fn r => @{thm f_the_inv_into_f} OF [r_inj, r RS mp])
  43.505 +        iso_inj_thms_unfolded iso_thms;
  43.506 +
  43.507 +    val Abs_inverse_thms = maps (mk_funs_inv thy5) Abs_inverse_thms';
  43.508 +
  43.509 +    (******************* freeness theorems for constructors *******************)
  43.510 +
  43.511 +    val _ = Old_Datatype_Aux.message config "Proving freeness of constructors ...";
  43.512 +
  43.513 +    (* prove theorem  Rep_i (Constr_j ...) = Inj_j ...  *)
  43.514 +
  43.515 +    fun prove_constr_rep_thm eqn =
  43.516 +      let
  43.517 +        val inj_thms = map fst newT_iso_inj_thms;
  43.518 +        val rewrites = @{thm o_def} :: constr_defs @ map (mk_meta_eq o #2) newT_iso_axms;
  43.519 +      in
  43.520 +        Goal.prove_sorry_global thy5 [] [] eqn
  43.521 +        (fn {context = ctxt, ...} => EVERY
  43.522 +          [resolve_tac inj_thms 1,
  43.523 +           rewrite_goals_tac ctxt rewrites,
  43.524 +           rtac refl 3,
  43.525 +           resolve_tac rep_intrs 2,
  43.526 +           REPEAT (resolve_tac iso_elem_thms 1)])
  43.527 +      end;
  43.528 +
  43.529 +    (*--------------------------------------------------------------*)
  43.530 +    (* constr_rep_thms and rep_congs are used to prove distinctness *)
  43.531 +    (* of constructors.                                             *)
  43.532 +    (*--------------------------------------------------------------*)
  43.533 +
  43.534 +    val constr_rep_thms = map (map prove_constr_rep_thm) constr_rep_eqns;
  43.535 +
  43.536 +    val dist_rewrites =
  43.537 +      map (fn (rep_thms, dist_lemma) =>
  43.538 +        dist_lemma :: (rep_thms @ [In0_eq, In1_eq, In0_not_In1, In1_not_In0]))
  43.539 +          (constr_rep_thms ~~ dist_lemmas);
  43.540 +
  43.541 +    fun prove_distinct_thms dist_rewrites' =
  43.542 +      let
  43.543 +        fun prove [] = []
  43.544 +          | prove (t :: ts) =
  43.545 +              let
  43.546 +                val dist_thm = Goal.prove_sorry_global thy5 [] [] t (fn {context = ctxt, ...} =>
  43.547 +                  EVERY [simp_tac (put_simpset HOL_ss ctxt addsimps dist_rewrites') 1])
  43.548 +              in dist_thm :: Drule.zero_var_indexes (dist_thm RS not_sym) :: prove ts end;
  43.549 +      in prove end;
  43.550 +
  43.551 +    val distinct_thms =
  43.552 +      map2 (prove_distinct_thms) dist_rewrites (Old_Datatype_Prop.make_distincts descr);
  43.553 +
  43.554 +    (* prove injectivity of constructors *)
  43.555 +
  43.556 +    fun prove_constr_inj_thm rep_thms t =
  43.557 +      let
  43.558 +        val inj_thms = Scons_inject ::
  43.559 +          map make_elim
  43.560 +            (iso_inj_thms @
  43.561 +              [In0_inject, In1_inject, Leaf_inject, Inl_inject, Inr_inject,
  43.562 +               Lim_inject, Suml_inject, Sumr_inject])
  43.563 +      in
  43.564 +        Goal.prove_sorry_global thy5 [] [] t
  43.565 +          (fn {context = ctxt, ...} => EVERY
  43.566 +            [rtac iffI 1,
  43.567 +             REPEAT (etac conjE 2), hyp_subst_tac ctxt 2, rtac refl 2,
  43.568 +             dresolve_tac rep_congs 1, dtac @{thm box_equals} 1,
  43.569 +             REPEAT (resolve_tac rep_thms 1),
  43.570 +             REPEAT (eresolve_tac inj_thms 1),
  43.571 +             REPEAT (ares_tac [conjI] 1 ORELSE (EVERY [REPEAT (rtac @{thm ext} 1),
  43.572 +               REPEAT (eresolve_tac (make_elim fun_cong :: inj_thms) 1),
  43.573 +               atac 1]))])
  43.574 +      end;
  43.575 +
  43.576 +    val constr_inject =
  43.577 +      map (fn (ts, thms) => map (prove_constr_inj_thm thms) ts)
  43.578 +        (Old_Datatype_Prop.make_injs descr ~~ constr_rep_thms);
  43.579 +
  43.580 +    val ((constr_inject', distinct_thms'), thy6) =
  43.581 +      thy5
  43.582 +      |> Sign.parent_path
  43.583 +      |> Old_Datatype_Aux.store_thmss "inject" new_type_names constr_inject
  43.584 +      ||>> Old_Datatype_Aux.store_thmss "distinct" new_type_names distinct_thms;
  43.585 +
  43.586 +    (*************************** induction theorem ****************************)
  43.587 +
  43.588 +    val _ = Old_Datatype_Aux.message config "Proving induction rule for datatypes ...";
  43.589 +
  43.590 +    val Rep_inverse_thms =
  43.591 +      map (fn (_, iso, _) => iso RS subst) newT_iso_axms @
  43.592 +      map (fn r => r RS @{thm the_inv_f_f} RS subst) iso_inj_thms_unfolded;
  43.593 +    val Rep_inverse_thms' = map (fn r => r RS @{thm the_inv_f_f}) iso_inj_thms_unfolded;
  43.594 +
  43.595 +    fun mk_indrule_lemma (i, _) T =
  43.596 +      let
  43.597 +        val Rep_t = Const (nth all_rep_names i, T --> Univ_elT) $ Old_Datatype_Aux.mk_Free "x" T i;
  43.598 +        val Abs_t =
  43.599 +          if i < length newTs then
  43.600 +            Const (#Abs_name (#1 (#2 (nth typedefs i))), Univ_elT --> T)
  43.601 +          else
  43.602 +            Const (@{const_name the_inv_into},
  43.603 +              [HOLogic.mk_setT T, T --> Univ_elT, Univ_elT] ---> T) $
  43.604 +            HOLogic.mk_UNIV T $ Const (nth all_rep_names i, T --> Univ_elT);
  43.605 +        val prem =
  43.606 +          HOLogic.imp $
  43.607 +            (Const (nth rep_set_names i, UnivT') $ Rep_t) $
  43.608 +              (Old_Datatype_Aux.mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ (Abs_t $ Rep_t));
  43.609 +        val concl =
  43.610 +          Old_Datatype_Aux.mk_Free "P" (T --> HOLogic.boolT) (i + 1) $
  43.611 +            Old_Datatype_Aux.mk_Free "x" T i;
  43.612 +      in (prem, concl) end;
  43.613 +
  43.614 +    val (indrule_lemma_prems, indrule_lemma_concls) =
  43.615 +      split_list (map2 mk_indrule_lemma descr' recTs);
  43.616 +
  43.617 +    val cert = cterm_of thy6;
  43.618 +
  43.619 +    val indrule_lemma =
  43.620 +      Goal.prove_sorry_global thy6 [] []
  43.621 +        (Logic.mk_implies
  43.622 +          (HOLogic.mk_Trueprop (Old_Datatype_Aux.mk_conj indrule_lemma_prems),
  43.623 +           HOLogic.mk_Trueprop (Old_Datatype_Aux.mk_conj indrule_lemma_concls)))
  43.624 +        (fn _ =>
  43.625 +          EVERY
  43.626 +           [REPEAT (etac conjE 1),
  43.627 +            REPEAT (EVERY
  43.628 +              [TRY (rtac conjI 1), resolve_tac Rep_inverse_thms 1,
  43.629 +               etac mp 1, resolve_tac iso_elem_thms 1])]);
  43.630 +
  43.631 +    val Ps = map head_of (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of indrule_lemma)));
  43.632 +    val frees =
  43.633 +      if length Ps = 1 then [Free ("P", snd (dest_Var (hd Ps)))]
  43.634 +      else map (Free o apfst fst o dest_Var) Ps;
  43.635 +    val indrule_lemma' = cterm_instantiate (map cert Ps ~~ map cert frees) indrule_lemma;
  43.636 +
  43.637 +    val dt_induct_prop = Old_Datatype_Prop.make_ind descr;
  43.638 +    val dt_induct =
  43.639 +      Goal.prove_sorry_global thy6 []
  43.640 +      (Logic.strip_imp_prems dt_induct_prop)
  43.641 +      (Logic.strip_imp_concl dt_induct_prop)
  43.642 +      (fn {context = ctxt, prems, ...} =>
  43.643 +        EVERY
  43.644 +          [rtac indrule_lemma' 1,
  43.645 +           (Old_Datatype_Aux.ind_tac rep_induct [] THEN_ALL_NEW
  43.646 +              Object_Logic.atomize_prems_tac ctxt) 1,
  43.647 +           EVERY (map (fn (prem, r) => (EVERY
  43.648 +             [REPEAT (eresolve_tac Abs_inverse_thms 1),
  43.649 +              simp_tac (put_simpset HOL_basic_ss ctxt
  43.650 +                addsimps (Thm.symmetric r :: Rep_inverse_thms')) 1,
  43.651 +              DEPTH_SOLVE_1 (ares_tac [prem] 1 ORELSE etac allE 1)]))
  43.652 +                  (prems ~~ (constr_defs @ map mk_meta_eq iso_char_thms)))]);
  43.653 +
  43.654 +    val ([(_, [dt_induct'])], thy7) =
  43.655 +      thy6
  43.656 +      |> Global_Theory.note_thmss ""
  43.657 +        [((Binding.qualify true big_name (Binding.name "induct"), [case_names_induct]),
  43.658 +          [([dt_induct], [])])];
  43.659 +  in
  43.660 +    ((constr_inject', distinct_thms', dt_induct'), thy7)
  43.661 +  end;
  43.662 +
  43.663 +
  43.664 +
  43.665 +(** datatype definition **)
  43.666 +
  43.667 +(* specifications *)
  43.668 +
  43.669 +type spec = (binding * (string * sort) list * mixfix) * (binding * typ list * mixfix) list;
  43.670 +
  43.671 +type spec_cmd =
  43.672 +  (binding * (string * string option) list * mixfix) * (binding * string list * mixfix) list;
  43.673 +
  43.674 +local
  43.675 +
  43.676 +fun parse_spec ctxt ((b, args, mx), constrs) =
  43.677 +  ((b, map (apsnd (Typedecl.read_constraint ctxt)) args, mx),
  43.678 +    constrs |> map (fn (c, Ts, mx') => (c, map (Syntax.parse_typ ctxt) Ts, mx')));
  43.679 +
  43.680 +fun check_specs ctxt (specs: spec list) =
  43.681 +  let
  43.682 +    fun prep_spec ((tname, args, mx), constrs) tys =
  43.683 +      let
  43.684 +        val (args', tys1) = chop (length args) tys;
  43.685 +        val (constrs', tys3) = (constrs, tys1) |-> fold_map (fn (cname, cargs, mx') => fn tys2 =>
  43.686 +          let val (cargs', tys3) = chop (length cargs) tys2;
  43.687 +          in ((cname, cargs', mx'), tys3) end);
  43.688 +      in (((tname, map dest_TFree args', mx), constrs'), tys3) end;
  43.689 +
  43.690 +    val all_tys =
  43.691 +      specs |> maps (fn ((_, args, _), cs) => map TFree args @ maps #2 cs)
  43.692 +      |> Syntax.check_typs ctxt;
  43.693 +
  43.694 +  in #1 (fold_map prep_spec specs all_tys) end;
  43.695 +
  43.696 +fun prep_specs parse raw_specs thy =
  43.697 +  let
  43.698 +    val ctxt = thy
  43.699 +      |> Sign.add_types_global (map (fn ((b, args, mx), _) => (b, length args, mx)) raw_specs)
  43.700 +      |> Proof_Context.init_global
  43.701 +      |> fold (fn ((_, args, _), _) => fold (fn (a, _) =>
  43.702 +          Variable.declare_typ (TFree (a, dummyS))) args) raw_specs;
  43.703 +    val specs = check_specs ctxt (map (parse ctxt) raw_specs);
  43.704 +  in (specs, ctxt) end;
  43.705 +
  43.706 +in
  43.707 +
  43.708 +val read_specs = prep_specs parse_spec;
  43.709 +val check_specs = prep_specs (K I);
  43.710 +
  43.711 +end;
  43.712 +
  43.713 +
  43.714 +(* main commands *)
  43.715 +
  43.716 +fun gen_add_datatype prep_specs config raw_specs thy =
  43.717 +  let
  43.718 +    val _ = Theory.requires thy (Context.theory_name @{theory}) "datatype definitions";
  43.719 +
  43.720 +    val (dts, spec_ctxt) = prep_specs raw_specs thy;
  43.721 +    val ((_, tyvars, _), _) :: _ = dts;
  43.722 +    val string_of_tyvar = Syntax.string_of_typ spec_ctxt o TFree;
  43.723 +
  43.724 +    val (new_dts, types_syntax) = dts |> map (fn ((tname, tvs, mx), _) =>
  43.725 +      let val full_tname = Sign.full_name thy tname in
  43.726 +        (case duplicates (op =) tvs of
  43.727 +          [] =>
  43.728 +            if eq_set (op =) (tyvars, tvs) then ((full_tname, tvs), (tname, mx))
  43.729 +            else error "Mutually recursive datatypes must have same type parameters"
  43.730 +        | dups =>
  43.731 +            error ("Duplicate parameter(s) for datatype " ^ Binding.print tname ^
  43.732 +              " : " ^ commas (map string_of_tyvar dups)))
  43.733 +      end) |> split_list;
  43.734 +    val dt_names = map fst new_dts;
  43.735 +
  43.736 +    val _ =
  43.737 +      (case duplicates (op =) (map fst new_dts) of
  43.738 +        [] => ()
  43.739 +      | dups => error ("Duplicate datatypes: " ^ commas_quote dups));
  43.740 +
  43.741 +    fun prep_dt_spec ((tname, tvs, _), constrs) (dts', constr_syntax, i) =
  43.742 +      let
  43.743 +        fun prep_constr (cname, cargs, mx) (constrs, constr_syntax') =
  43.744 +          let
  43.745 +            val _ =
  43.746 +              (case subtract (op =) tvs (fold Term.add_tfreesT cargs []) of
  43.747 +                [] => ()
  43.748 +              | vs => error ("Extra type variables on rhs: " ^ commas (map string_of_tyvar vs)));
  43.749 +            val c = Sign.full_name_path thy (Binding.name_of tname) cname;
  43.750 +          in
  43.751 +            (constrs @ [(c, map (Old_Datatype_Aux.dtyp_of_typ new_dts) cargs)],
  43.752 +              constr_syntax' @ [(cname, mx)])
  43.753 +          end handle ERROR msg =>
  43.754 +            cat_error msg ("The error above occurred in constructor " ^ Binding.print cname ^
  43.755 +              " of datatype " ^ Binding.print tname);
  43.756 +
  43.757 +        val (constrs', constr_syntax') = fold prep_constr constrs ([], []);
  43.758 +      in
  43.759 +        (case duplicates (op =) (map fst constrs') of
  43.760 +          [] =>
  43.761 +            (dts' @ [(i, (Sign.full_name thy tname, map Old_Datatype_Aux.DtTFree tvs, constrs'))],
  43.762 +              constr_syntax @ [constr_syntax'], i + 1)
  43.763 +        | dups =>
  43.764 +            error ("Duplicate constructors " ^ commas_quote dups ^
  43.765 +              " in datatype " ^ Binding.print tname))
  43.766 +      end;
  43.767 +
  43.768 +    val (dts', constr_syntax, i) = fold prep_dt_spec dts ([], [], 0);
  43.769 +
  43.770 +    val dt_info = Old_Datatype_Data.get_all thy;
  43.771 +    val (descr, _) = Old_Datatype_Aux.unfold_datatypes spec_ctxt dts' dt_info dts' i;
  43.772 +    val _ =
  43.773 +      Old_Datatype_Aux.check_nonempty descr
  43.774 +        handle (exn as Old_Datatype_Aux.Datatype_Empty s) =>
  43.775 +          if #strict config then error ("Nonemptiness check failed for datatype " ^ quote s)
  43.776 +          else reraise exn;
  43.777 +
  43.778 +    val _ =
  43.779 +      Old_Datatype_Aux.message config
  43.780 +        ("Constructing datatype(s) " ^ commas_quote (map (Binding.name_of o #1 o #1) dts));
  43.781 +  in
  43.782 +    thy
  43.783 +    |> representation_proofs config dt_info descr types_syntax constr_syntax
  43.784 +      (Old_Datatype_Data.mk_case_names_induct (flat descr))
  43.785 +    |-> (fn (inject, distinct, induct) =>
  43.786 +      Old_Rep_Datatype.derive_datatype_props config dt_names descr induct inject distinct)
  43.787 +  end;
  43.788 +
  43.789 +val add_datatype = gen_add_datatype check_specs;
  43.790 +val add_datatype_cmd = gen_add_datatype read_specs;
  43.791 +
  43.792 +
  43.793 +(* outer syntax *)
  43.794 +
  43.795 +val spec_cmd =
  43.796 +  Parse.type_args_constrained -- Parse.binding -- Parse.opt_mixfix --
  43.797 +  (@{keyword "="} |-- Parse.enum1 "|" (Parse.binding -- Scan.repeat Parse.typ -- Parse.opt_mixfix))
  43.798 +  >> (fn (((vs, t), mx), cons) => ((t, vs, mx), map Parse.triple1 cons));
  43.799 +
  43.800 +val _ =
  43.801 +  Outer_Syntax.command @{command_spec "datatype"} "define inductive datatypes"
  43.802 +    (Parse.and_list1 spec_cmd
  43.803 +      >> (Toplevel.theory o (snd oo add_datatype_cmd Old_Datatype_Aux.default_config)));
  43.804 +
  43.805 +end;
    44.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    44.2 +++ b/src/HOL/Tools/Old_Datatype/old_datatype_aux.ML	Mon Sep 01 16:17:46 2014 +0200
    44.3 @@ -0,0 +1,402 @@
    44.4 +(*  Title:      HOL/Tools/Old_Datatype/old_datatype_aux.ML
    44.5 +    Author:     Stefan Berghofer, TU Muenchen
    44.6 +
    44.7 +Datatype package: auxiliary data structures and functions.
    44.8 +*)
    44.9 +
   44.10 +signature OLD_DATATYPE_COMMON =
   44.11 +sig
   44.12 +  type config = {strict : bool, quiet : bool}
   44.13 +  val default_config : config
   44.14 +  datatype dtyp =
   44.15 +      DtTFree of string * sort
   44.16 +    | DtType of string * dtyp list
   44.17 +    | DtRec of int
   44.18 +  type descr = (int * (string * dtyp list * (string * dtyp list) list)) list
   44.19 +  type info =
   44.20 +   {index : int,
   44.21 +    descr : descr,
   44.22 +    inject : thm list,
   44.23 +    distinct : thm list,
   44.24 +    induct : thm,
   44.25 +    inducts : thm list,
   44.26 +    exhaust : thm,
   44.27 +    nchotomy : thm,
   44.28 +    rec_names : string list,
   44.29 +    rec_rewrites : thm list,
   44.30 +    case_name : string,
   44.31 +    case_rewrites : thm list,
   44.32 +    case_cong : thm,
   44.33 +    case_cong_weak : thm,
   44.34 +    split : thm,
   44.35 +    split_asm: thm}
   44.36 +end
   44.37 +
   44.38 +signature OLD_DATATYPE_AUX =
   44.39 +sig
   44.40 +  include OLD_DATATYPE_COMMON
   44.41 +
   44.42 +  val message : config -> string -> unit
   44.43 +
   44.44 +  val store_thmss_atts : string -> string list -> attribute list list -> thm list list
   44.45 +    -> theory -> thm list list * theory
   44.46 +  val store_thmss : string -> string list -> thm list list -> theory -> thm list list * theory
   44.47 +  val store_thms_atts : string -> string list -> attribute list list -> thm list
   44.48 +    -> theory -> thm list * theory
   44.49 +  val store_thms : string -> string list -> thm list -> theory -> thm list * theory
   44.50 +
   44.51 +  val split_conj_thm : thm -> thm list
   44.52 +  val mk_conj : term list -> term
   44.53 +  val mk_disj : term list -> term
   44.54 +
   44.55 +  val app_bnds : term -> int -> term
   44.56 +
   44.57 +  val ind_tac : thm -> string list -> int -> tactic
   44.58 +  val exh_tac : (string -> thm) -> int -> tactic
   44.59 +
   44.60 +  exception Datatype
   44.61 +  exception Datatype_Empty of string
   44.62 +  val name_of_typ : typ -> string
   44.63 +  val dtyp_of_typ : (string * (string * sort) list) list -> typ -> dtyp
   44.64 +  val mk_Free : string -> typ -> int -> term
   44.65 +  val is_rec_type : dtyp -> bool
   44.66 +  val typ_of_dtyp : descr -> dtyp -> typ
   44.67 +  val dest_DtTFree : dtyp -> string * sort
   44.68 +  val dest_DtRec : dtyp -> int
   44.69 +  val strip_dtyp : dtyp -> dtyp list * dtyp
   44.70 +  val body_index : dtyp -> int
   44.71 +  val mk_fun_dtyp : dtyp list -> dtyp -> dtyp
   44.72 +  val get_nonrec_types : descr -> typ list
   44.73 +  val get_branching_types : descr -> typ list
   44.74 +  val get_arities : descr -> int list
   44.75 +  val get_rec_types : descr -> typ list
   44.76 +  val interpret_construction : descr -> (string * sort) list ->
   44.77 +    {atyp: typ -> 'a, dtyp: typ list -> int * bool -> string * typ list -> 'a} ->
   44.78 +    ((string * typ list) * (string * 'a list) list) list
   44.79 +  val check_nonempty : descr list -> unit
   44.80 +  val unfold_datatypes : Proof.context -> descr -> info Symtab.table ->
   44.81 +    descr -> int -> descr list * int
   44.82 +  val find_shortest_path : descr -> int -> (string * int) option
   44.83 +end;
   44.84 +
   44.85 +structure Old_Datatype_Aux : OLD_DATATYPE_AUX =
   44.86 +struct
   44.87 +
   44.88 +(* datatype option flags *)
   44.89 +
   44.90 +type config = {strict : bool, quiet : bool};
   44.91 +val default_config : config = {strict = true, quiet = false};
   44.92 +
   44.93 +fun message ({quiet = true, ...} : config) s = writeln s
   44.94 +  | message _ _ = ();
   44.95 +
   44.96 +
   44.97 +(* store theorems in theory *)
   44.98 +
   44.99 +fun store_thmss_atts name tnames attss thmss =
  44.100 +  fold_map (fn ((tname, atts), thms) =>
  44.101 +    Global_Theory.note_thmss ""
  44.102 +      [((Binding.qualify true tname (Binding.name name), atts), [(thms, [])])]
  44.103 +    #-> (fn [(_, res)] => pair res)) (tnames ~~ attss ~~ thmss);
  44.104 +
  44.105 +fun store_thmss name tnames = store_thmss_atts name tnames (replicate (length tnames) []);
  44.106 +
  44.107 +fun store_thms_atts name tnames attss thms =
  44.108 +  fold_map (fn ((tname, atts), thm) =>
  44.109 +    Global_Theory.note_thmss ""
  44.110 +      [((Binding.qualify true tname (Binding.name name), atts), [([thm], [])])]
  44.111 +    #-> (fn [(_, [res])] => pair res)) (tnames ~~ attss ~~ thms);
  44.112 +
  44.113 +fun store_thms name tnames = store_thms_atts name tnames (replicate (length tnames) []);
  44.114 +
  44.115 +
  44.116 +(* split theorem thm_1 & ... & thm_n into n theorems *)
  44.117 +
  44.118 +fun split_conj_thm th =
  44.119 +  ((th RS conjunct1) :: split_conj_thm (th RS conjunct2)) handle THM _ => [th];
  44.120 +
  44.121 +val mk_conj = foldr1 (HOLogic.mk_binop @{const_name HOL.conj});
  44.122 +val mk_disj = foldr1 (HOLogic.mk_binop @{const_name HOL.disj});
  44.123 +
  44.124 +fun app_bnds t i = list_comb (t, map Bound (i - 1 downto 0));
  44.125 +
  44.126 +
  44.127 +(* instantiate induction rule *)
  44.128 +
  44.129 +fun ind_tac indrule indnames = CSUBGOAL (fn (cgoal, i) =>
  44.130 +  let
  44.131 +    val cert = cterm_of (Thm.theory_of_cterm cgoal);
  44.132 +    val goal = term_of cgoal;
  44.133 +    val ts = HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of indrule));
  44.134 +    val ts' = HOLogic.dest_conj (HOLogic.dest_Trueprop (Logic.strip_imp_concl goal));
  44.135 +    val getP =
  44.136 +      if can HOLogic.dest_imp (hd ts)
  44.137 +      then apfst SOME o HOLogic.dest_imp
  44.138 +      else pair NONE;
  44.139 +    val flt =
  44.140 +      if null indnames then I
  44.141 +      else filter (member (op =) indnames o fst);
  44.142 +    fun abstr (t1, t2) =
  44.143 +      (case t1 of
  44.144 +        NONE =>
  44.145 +          (case flt (Term.add_frees t2 []) of
  44.146 +            [(s, T)] => SOME (absfree (s, T) t2)
  44.147 +          | _ => NONE)
  44.148 +      | SOME (_ $ t') => SOME (Abs ("x", fastype_of t', abstract_over (t', t2))));
  44.149 +    val insts =
  44.150 +      map_filter (fn (t, u) =>
  44.151 +        (case abstr (getP u) of
  44.152 +          NONE => NONE
  44.153 +        | SOME u' => SOME (t |> getP |> snd |> head_of |> cert, cert u'))) (ts ~~ ts');
  44.154 +    val indrule' = cterm_instantiate insts indrule;
  44.155 +  in rtac indrule' i end);
  44.156 +
  44.157 +
  44.158 +(* perform exhaustive case analysis on last parameter of subgoal i *)
  44.159 +
  44.160 +fun exh_tac exh_thm_of = CSUBGOAL (fn (cgoal, i) =>
  44.161 +  let
  44.162 +    val thy = Thm.theory_of_cterm cgoal;
  44.163 +    val goal = term_of cgoal;
  44.164 +    val params = Logic.strip_params goal;
  44.165 +    val (_, Type (tname, _)) = hd (rev params);
  44.166 +    val exhaustion = Thm.lift_rule cgoal (exh_thm_of tname);
  44.167 +    val prem' = hd (prems_of exhaustion);
  44.168 +    val _ $ (_ $ lhs $ _) = hd (rev (Logic.strip_assums_hyp prem'));
  44.169 +    val exhaustion' =
  44.170 +      cterm_instantiate [(cterm_of thy (head_of lhs),
  44.171 +        cterm_of thy (fold_rev (fn (_, T) => fn t => Abs ("z", T, t)) params (Bound 0)))] exhaustion;
  44.172 +  in compose_tac (false, exhaustion', nprems_of exhaustion) i end);
  44.173 +
  44.174 +
  44.175 +(********************** Internal description of datatypes *********************)
  44.176 +
  44.177 +datatype dtyp =
  44.178 +    DtTFree of string * sort
  44.179 +  | DtType of string * dtyp list
  44.180 +  | DtRec of int;
  44.181 +
  44.182 +(* information about datatypes *)
  44.183 +
  44.184 +(* index, datatype name, type arguments, constructor name, types of constructor's arguments *)
  44.185 +type descr = (int * (string * dtyp list * (string * dtyp list) list)) list;
  44.186 +
  44.187 +type info =
  44.188 +  {index : int,
  44.189 +   descr : descr,
  44.190 +   inject : thm list,
  44.191 +   distinct : thm list,
  44.192 +   induct : thm,
  44.193 +   inducts : thm list,
  44.194 +   exhaust : thm,
  44.195 +   nchotomy : thm,
  44.196 +   rec_names : string list,
  44.197 +   rec_rewrites : thm list,
  44.198 +   case_name : string,
  44.199 +   case_rewrites : thm list,
  44.200 +   case_cong : thm,
  44.201 +   case_cong_weak : thm,
  44.202 +   split : thm,
  44.203 +   split_asm: thm};
  44.204 +
  44.205 +fun mk_Free s T i = Free (s ^ string_of_int i, T);
  44.206 +
  44.207 +fun subst_DtTFree _ substs (T as DtTFree a) = the_default T (AList.lookup (op =) substs a)
  44.208 +  | subst_DtTFree i substs (DtType (name, ts)) = DtType (name, map (subst_DtTFree i substs) ts)
  44.209 +  | subst_DtTFree i _ (DtRec j) = DtRec (i + j);
  44.210 +
  44.211 +exception Datatype;
  44.212 +exception Datatype_Empty of string;
  44.213 +
  44.214 +fun dest_DtTFree (DtTFree a) = a
  44.215 +  | dest_DtTFree _ = raise Datatype;
  44.216 +
  44.217 +fun dest_DtRec (DtRec i) = i
  44.218 +  | dest_DtRec _ = raise Datatype;
  44.219 +
  44.220 +fun is_rec_type (DtType (_, dts)) = exists is_rec_type dts
  44.221 +  | is_rec_type (DtRec _) = true
  44.222 +  | is_rec_type _ = false;
  44.223 +
  44.224 +fun strip_dtyp (DtType ("fun", [T, U])) = apfst (cons T) (strip_dtyp U)
  44.225 +  | strip_dtyp T = ([], T);
  44.226 +
  44.227 +val body_index = dest_DtRec o snd o strip_dtyp;
  44.228 +
  44.229 +fun mk_fun_dtyp [] U = U
  44.230 +  | mk_fun_dtyp (T :: Ts) U = DtType ("fun", [T, mk_fun_dtyp Ts U]);
  44.231 +
  44.232 +fun name_of_typ (Type (s, Ts)) =
  44.233 +      let val s' = Long_Name.base_name s in
  44.234 +        space_implode "_"
  44.235 +          (filter_out (equal "") (map name_of_typ Ts) @
  44.236 +            [if Symbol_Pos.is_identifier s' then s' else "x"])
  44.237 +      end
  44.238 +  | name_of_typ _ = "";
  44.239 +
  44.240 +fun dtyp_of_typ _ (TFree a) = DtTFree a
  44.241 +  | dtyp_of_typ _ (TVar _) = error "Illegal schematic type variable(s)"
  44.242 +  | dtyp_of_typ new_dts (Type (tname, Ts)) =
  44.243 +      (case AList.lookup (op =) new_dts tname of
  44.244 +        NONE => DtType (tname, map (dtyp_of_typ new_dts) Ts)
  44.245 +      | SOME vs =>
  44.246 +          if map (try dest_TFree) Ts = map SOME vs then
  44.247 +            DtRec (find_index (curry op = tname o fst) new_dts)
  44.248 +          else error ("Illegal occurrence of recursive type " ^ quote tname));
  44.249 +
  44.250 +fun typ_of_dtyp descr (DtTFree a) = TFree a
  44.251 +  | typ_of_dtyp descr (DtRec i) =
  44.252 +      let val (s, ds, _) = the (AList.lookup (op =) descr i)
  44.253 +      in Type (s, map (typ_of_dtyp descr) ds) end
  44.254 +  | typ_of_dtyp descr (DtType (s, ds)) = Type (s, map (typ_of_dtyp descr) ds);
  44.255 +
  44.256 +(* find all non-recursive types in datatype description *)
  44.257 +
  44.258 +fun get_nonrec_types descr =
  44.259 +  map (typ_of_dtyp descr) (fold (fn (_, (_, _, constrs)) =>
  44.260 +    fold (fn (_, cargs) => union (op =) (filter_out is_rec_type cargs)) constrs) descr []);
  44.261 +
  44.262 +(* get all recursive types in datatype description *)
  44.263 +
  44.264 +fun get_rec_types descr = map (fn (_ , (s, ds, _)) =>
  44.265 +  Type (s, map (typ_of_dtyp descr) ds)) descr;
  44.266 +
  44.267 +(* get all branching types *)
  44.268 +
  44.269 +fun get_branching_types descr =
  44.270 +  map (typ_of_dtyp descr)
  44.271 +    (fold
  44.272 +      (fn (_, (_, _, constrs)) =>
  44.273 +        fold (fn (_, cargs) => fold (strip_dtyp #> fst #> fold (insert op =)) cargs) constrs)
  44.274 +      descr []);
  44.275 +
  44.276 +fun get_arities descr =
  44.277 +  fold
  44.278 +    (fn (_, (_, _, constrs)) =>
  44.279 +      fold (fn (_, cargs) =>
  44.280 +        fold (insert op =) (map (length o fst o strip_dtyp) (filter is_rec_type cargs))) constrs)
  44.281 +    descr [];
  44.282 +
  44.283 +(* interpret construction of datatype *)
  44.284 +
  44.285 +fun interpret_construction descr vs {atyp, dtyp} =
  44.286 +  let
  44.287 +    val typ_of =
  44.288 +      typ_of_dtyp descr #>
  44.289 +      map_atyps (fn TFree (a, _) => TFree (a, the (AList.lookup (op =) vs a)) | T => T);
  44.290 +    fun interpT dT =
  44.291 +      (case strip_dtyp dT of
  44.292 +        (dTs, DtRec l) =>
  44.293 +          let
  44.294 +            val (tyco, dTs', _) = the (AList.lookup (op =) descr l);
  44.295 +            val Ts = map typ_of dTs;
  44.296 +            val Ts' = map typ_of dTs';
  44.297 +            val is_proper = forall (can dest_TFree) Ts';
  44.298 +          in dtyp Ts (l, is_proper) (tyco, Ts') end
  44.299 +      | _ => atyp (typ_of dT));
  44.300 +    fun interpC (c, dTs) = (c, map interpT dTs);
  44.301 +    fun interpD (_, (tyco, dTs, cs)) = ((tyco, map typ_of dTs), map interpC cs);
  44.302 +  in map interpD descr end;
  44.303 +
  44.304 +(* nonemptiness check for datatypes *)
  44.305 +
  44.306 +fun check_nonempty descr =
  44.307 +  let
  44.308 +    val descr' = flat descr;
  44.309 +    fun is_nonempty_dt is i =
  44.310 +      let
  44.311 +        val (_, _, constrs) = the (AList.lookup (op =) descr' i);
  44.312 +        fun arg_nonempty (_, DtRec i) =
  44.313 +              if member (op =) is i then false
  44.314 +              else is_nonempty_dt (i :: is) i
  44.315 +          | arg_nonempty _ = true;
  44.316 +      in exists (forall (arg_nonempty o strip_dtyp) o snd) constrs end
  44.317 +    val _ = hd descr |> forall (fn (i, (s, _, _)) =>
  44.318 +      is_nonempty_dt [i] i orelse raise Datatype_Empty s)
  44.319 +  in () end;
  44.320 +
  44.321 +(* unfold a list of mutually recursive datatype specifications *)
  44.322 +(* all types of the form DtType (dt_name, [..., DtRec _, ...]) *)
  44.323 +(* need to be unfolded                                         *)
  44.324 +
  44.325 +fun unfold_datatypes ctxt orig_descr (dt_info : info Symtab.table) descr i =
  44.326 +  let
  44.327 +    fun typ_error T msg =
  44.328 +      error ("Non-admissible type expression\n" ^
  44.329 +        Syntax.string_of_typ ctxt (typ_of_dtyp (orig_descr @ descr) T) ^ "\n" ^ msg);
  44.330 +
  44.331 +    fun get_dt_descr T i tname dts =
  44.332 +      (case Symtab.lookup dt_info tname of
  44.333 +        NONE =>
  44.334 +          typ_error T (quote tname ^ " is not a datatype - can't use it in nested recursion")
  44.335 +      | SOME {index, descr, ...} =>
  44.336 +          let
  44.337 +            val (_, vars, _) = the (AList.lookup (op =) descr index);
  44.338 +            val subst = map dest_DtTFree vars ~~ dts
  44.339 +              handle ListPair.UnequalLengths =>
  44.340 +                typ_error T ("Type constructor " ^ quote tname ^
  44.341 +                  " used with wrong number of arguments");
  44.342 +          in
  44.343 +            (i + index,
  44.344 +              map (fn (j, (tn, args, cs)) =>
  44.345 +                (i + j, (tn, map (subst_DtTFree i subst) args,
  44.346 +                  map (apsnd (map (subst_DtTFree i subst))) cs))) descr)
  44.347 +          end);
  44.348 +
  44.349 +    (* unfold a single constructor argument *)
  44.350 +
  44.351 +    fun unfold_arg T (i, Ts, descrs) =
  44.352 +      if is_rec_type T then
  44.353 +        let val (Us, U) = strip_dtyp T in
  44.354 +          if exists is_rec_type Us then
  44.355 +            typ_error T "Non-strictly positive recursive occurrence of type"
  44.356 +          else
  44.357 +            (case U of
  44.358 +              DtType (tname, dts) =>
  44.359 +                let
  44.360 +                  val (index, descr) = get_dt_descr T i tname dts;
  44.361 +                  val (descr', i') =
  44.362 +                    unfold_datatypes ctxt orig_descr dt_info descr (i + length descr);
  44.363 +                in (i', Ts @ [mk_fun_dtyp Us (DtRec index)], descrs @ descr') end
  44.364 +            | _ => (i, Ts @ [T], descrs))
  44.365 +        end
  44.366 +      else (i, Ts @ [T], descrs);
  44.367 +
  44.368 +    (* unfold a constructor *)
  44.369 +
  44.370 +    fun unfold_constr (cname, cargs) (i, constrs, descrs) =
  44.371 +      let val (i', cargs', descrs') = fold unfold_arg cargs (i, [], descrs)
  44.372 +      in (i', constrs @ [(cname, cargs')], descrs') end;
  44.373 +
  44.374 +    (* unfold a single datatype *)
  44.375 +
  44.376 +    fun unfold_datatype (j, (tname, tvars, constrs)) (i, dtypes, descrs) =
  44.377 +      let val (i', constrs', descrs') = fold unfold_constr constrs (i, [], descrs)
  44.378 +      in (i', dtypes @ [(j, (tname, tvars, constrs'))], descrs') end;
  44.379 +
  44.380 +    val (i', descr', descrs) = fold unfold_datatype descr (i, [], []);
  44.381 +
  44.382 +  in (descr' :: descrs, i') end;
  44.383 +
  44.384 +(* find shortest path to constructor with no recursive arguments *)
  44.385 +
  44.386 +fun find_nonempty descr is i =
  44.387 +  let
  44.388 +    fun arg_nonempty (_, DtRec i) =
  44.389 +          if member (op =) is i
  44.390 +          then NONE
  44.391 +          else Option.map (Integer.add 1 o snd) (find_nonempty descr (i :: is) i)
  44.392 +      | arg_nonempty _ = SOME 0;
  44.393 +    fun max_inf (SOME i) (SOME j) = SOME (Integer.max i j)
  44.394 +      | max_inf _ _ = NONE;
  44.395 +    fun max xs = fold max_inf xs (SOME 0);
  44.396 +    val (_, _, constrs) = the (AList.lookup (op =) descr i);
  44.397 +    val xs =
  44.398 +      sort (int_ord o pairself snd)
  44.399 +        (map_filter (fn (s, dts) => Option.map (pair s)
  44.400 +          (max (map (arg_nonempty o strip_dtyp) dts))) constrs)
  44.401 +  in if null xs then NONE else SOME (hd xs) end;
  44.402 +
  44.403 +fun find_shortest_path descr i = find_nonempty descr [i] i;
  44.404 +
  44.405 +end;
    45.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    45.2 +++ b/src/HOL/Tools/Old_Datatype/old_datatype_codegen.ML	Mon Sep 01 16:17:46 2014 +0200
    45.3 @@ -0,0 +1,25 @@
    45.4 +(*  Title:      HOL/Tools/Old_Datatype/old_datatype_codegen.ML
    45.5 +    Author:     Stefan Berghofer and Florian Haftmann, TU Muenchen
    45.6 +
    45.7 +Code generator facilities for inductive datatypes.
    45.8 +*)
    45.9 +
   45.10 +signature OLD_DATATYPE_CODEGEN =
   45.11 +sig
   45.12 +end;
   45.13 +
   45.14 +structure Old_Datatype_Codegen : OLD_DATATYPE_CODEGEN =
   45.15 +struct
   45.16 +
   45.17 +fun add_code_for_datatype fcT_name thy =
   45.18 +  let
   45.19 +    val ctxt = Proof_Context.init_global thy
   45.20 +    val SOME {ctrs, injects, distincts, case_thms, ...} = Ctr_Sugar.ctr_sugar_of ctxt fcT_name
   45.21 +    val Type (_, As) = body_type (fastype_of (hd ctrs))
   45.22 +  in
   45.23 +    Ctr_Sugar_Code.add_ctr_code fcT_name As (map dest_Const ctrs) injects distincts case_thms thy
   45.24 +  end;
   45.25 +
   45.26 +val _ = Theory.setup (Old_Datatype_Data.interpretation (K (fold add_code_for_datatype)));
   45.27 +
   45.28 +end;
    46.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    46.2 +++ b/src/HOL/Tools/Old_Datatype/old_datatype_data.ML	Mon Sep 01 16:17:46 2014 +0200
    46.3 @@ -0,0 +1,292 @@
    46.4 +(*  Title:      HOL/Tools/Old_Datatype/old_datatype_data.ML
    46.5 +    Author:     Stefan Berghofer, TU Muenchen
    46.6 +
    46.7 +Datatype package bookkeeping.
    46.8 +*)
    46.9 +
   46.10 +signature OLD_DATATYPE_DATA =
   46.11 +sig
   46.12 +  include OLD_DATATYPE_COMMON
   46.13 +
   46.14 +  val get_all : theory -> info Symtab.table
   46.15 +  val get_info : theory -> string -> info option
   46.16 +  val the_info : theory -> string -> info
   46.17 +  val info_of_constr : theory -> string * typ -> info option
   46.18 +  val info_of_constr_permissive : theory -> string * typ -> info option
   46.19 +  val info_of_case : theory -> string -> info option
   46.20 +  val register: (string * info) list -> theory -> theory
   46.21 +  val the_spec : theory -> string -> (string * sort) list * (string * typ list) list
   46.22 +  val the_descr : theory -> string list ->
   46.23 +    descr * (string * sort) list * string list * string *
   46.24 +    (string list * string list) * (typ list * typ list)
   46.25 +  val all_distincts : theory -> typ list -> thm list list
   46.26 +  val get_constrs : theory -> string -> (string * typ) list option
   46.27 +  val mk_case_names_induct: descr -> attribute
   46.28 +  val mk_case_names_exhausts: descr -> string list -> attribute list
   46.29 +  val interpretation : (config -> string list -> theory -> theory) -> theory -> theory
   46.30 +  val interpretation_data : config * string list -> theory -> theory
   46.31 +  val setup: theory -> theory
   46.32 +end;
   46.33 +
   46.34 +structure Old_Datatype_Data: OLD_DATATYPE_DATA =
   46.35 +struct
   46.36 +
   46.37 +(** theory data **)
   46.38 +
   46.39 +(* data management *)
   46.40 +
   46.41 +structure Data = Theory_Data
   46.42 +(
   46.43 +  type T =
   46.44 +    {types: Old_Datatype_Aux.info Symtab.table,
   46.45 +     constrs: (string * Old_Datatype_Aux.info) list Symtab.table,
   46.46 +     cases: Old_Datatype_Aux.info Symtab.table};
   46.47 +
   46.48 +  val empty =
   46.49 +    {types = Symtab.empty, constrs = Symtab.empty, cases = Symtab.empty};
   46.50 +  val extend = I;
   46.51 +  fun merge
   46.52 +    ({types = types1, constrs = constrs1, cases = cases1},
   46.53 +     {types = types2, constrs = constrs2, cases = cases2}) : T =
   46.54 +    {types = Symtab.merge (K true) (types1, types2),
   46.55 +     constrs = Symtab.join (K (AList.merge (op =) (K true))) (constrs1, constrs2),
   46.56 +     cases = Symtab.merge (K true) (cases1, cases2)};
   46.57 +);
   46.58 +
   46.59 +val get_all = #types o Data.get;
   46.60 +val get_info = Symtab.lookup o get_all;
   46.61 +
   46.62 +fun the_info thy name =
   46.63 +  (case get_info thy name of
   46.64 +    SOME info => info
   46.65 +  | NONE => error ("Unknown datatype " ^ quote name));
   46.66 +
   46.67 +fun info_of_constr thy (c, T) =
   46.68 +  let
   46.69 +    val tab = Symtab.lookup_list (#constrs (Data.get thy)) c;
   46.70 +  in
   46.71 +    (case body_type T of
   46.72 +      Type (tyco, _) => AList.lookup (op =) tab tyco
   46.73 +    | _ => NONE)
   46.74 +  end;
   46.75 +
   46.76 +fun info_of_constr_permissive thy (c, T) =
   46.77 +  let
   46.78 +    val tab = Symtab.lookup_list (#constrs (Data.get thy)) c;
   46.79 +    val hint = (case body_type T of Type (tyco, _) => SOME tyco | _ => NONE);
   46.80 +    val default = if null tab then NONE else SOME (snd (List.last tab));
   46.81 +    (*conservative wrt. overloaded constructors*)
   46.82 +  in
   46.83 +    (case hint of
   46.84 +      NONE => default
   46.85 +    | SOME tyco =>
   46.86 +        (case AList.lookup (op =) tab tyco of
   46.87 +          NONE => default (*permissive*)
   46.88 +        | SOME info => SOME info))
   46.89 +  end;
   46.90 +
   46.91 +val info_of_case = Symtab.lookup o #cases o Data.get;
   46.92 +
   46.93 +fun ctrs_of_exhaust exhaust =
   46.94 +  Logic.strip_imp_prems (prop_of exhaust) |>
   46.95 +  map (head_of o snd o HOLogic.dest_eq o HOLogic.dest_Trueprop o the_single
   46.96 +    o Logic.strip_assums_hyp);
   46.97 +
   46.98 +fun case_of_case_rewrite case_rewrite =
   46.99 +  head_of (fst (HOLogic.dest_eq (HOLogic.dest_Trueprop (prop_of case_rewrite))));
  46.100 +
  46.101 +fun ctr_sugar_of_info ({exhaust, nchotomy, inject, distinct, case_rewrites, case_cong,
  46.102 +    case_cong_weak, split, split_asm, ...} : Old_Datatype_Aux.info) =
  46.103 +  {ctrs = ctrs_of_exhaust exhaust,
  46.104 +   casex = case_of_case_rewrite (hd case_rewrites),
  46.105 +   discs = [],
  46.106 +   selss = [],
  46.107 +   exhaust = exhaust,
  46.108 +   nchotomy = nchotomy,
  46.109 +   injects = inject,
  46.110 +   distincts = distinct,
  46.111 +   case_thms = case_rewrites,
  46.112 +   case_cong = case_cong,
  46.113 +   case_cong_weak = case_cong_weak,
  46.114 +   split = split,
  46.115 +   split_asm = split_asm,
  46.116 +   disc_defs = [],
  46.117 +   disc_thmss = [],
  46.118 +   discIs = [],
  46.119 +   sel_defs = [],
  46.120 +   sel_thmss = [],
  46.121 +   distinct_discsss = [],
  46.122 +   exhaust_discs = [],
  46.123 +   exhaust_sels = [],
  46.124 +   collapses = [],
  46.125 +   expands = [],
  46.126 +   split_sels = [],
  46.127 +   split_sel_asms = [],
  46.128 +   case_eq_ifs = []};
  46.129 +
  46.130 +fun register dt_infos =
  46.131 +  Data.map (fn {types, constrs, cases} =>
  46.132 +    {types = types |> fold Symtab.update dt_infos,
  46.133 +     constrs = constrs |> fold (fn (constr, dtname_info) =>
  46.134 +         Symtab.map_default (constr, []) (cons dtname_info))
  46.135 +       (maps (fn (dtname, info as {descr, index, ...}) =>
  46.136 +          map (rpair (dtname, info) o fst) (#3 (the (AList.lookup op = descr index)))) dt_infos),
  46.137 +     cases = cases |> fold Symtab.update
  46.138 +       (map (fn (_, info as {case_name, ...}) => (case_name, info)) dt_infos)}) #>
  46.139 +  fold (fn (key, info) =>
  46.140 +    Ctr_Sugar.default_register_ctr_sugar_global key (ctr_sugar_of_info info)) dt_infos;
  46.141 +
  46.142 +
  46.143 +(* complex queries *)
  46.144 +
  46.145 +fun the_spec thy dtco =
  46.146 +  let
  46.147 +    val {descr, index, ...} = the_info thy dtco;
  46.148 +    val (_, dtys, raw_cos) = the (AList.lookup (op =) descr index);
  46.149 +    val args = map Old_Datatype_Aux.dest_DtTFree dtys;
  46.150 +    val cos = map (fn (co, tys) => (co, map (Old_Datatype_Aux.typ_of_dtyp descr) tys)) raw_cos;
  46.151 +  in (args, cos) end;
  46.152 +
  46.153 +fun the_descr thy (raw_tycos as raw_tyco :: _) =
  46.154 +  let
  46.155 +    val info = the_info thy raw_tyco;
  46.156 +    val descr = #descr info;
  46.157 +
  46.158 +    val (_, dtys, _) = the (AList.lookup (op =) descr (#index info));
  46.159 +    val vs = map Old_Datatype_Aux.dest_DtTFree dtys;
  46.160 +
  46.161 +    fun is_DtTFree (Old_Datatype_Aux.DtTFree _) = true
  46.162 +      | is_DtTFree _ = false;
  46.163 +    val k = find_index (fn (_, (_, dTs, _)) => not (forall is_DtTFree dTs)) descr;
  46.164 +    val protoTs as (dataTs, _) =
  46.165 +      chop k descr
  46.166 +      |> (pairself o map)
  46.167 +        (fn (_, (tyco, dTs, _)) => (tyco, map (Old_Datatype_Aux.typ_of_dtyp descr) dTs));
  46.168 +
  46.169 +    val tycos = map fst dataTs;
  46.170 +    val _ =
  46.171 +      if eq_set (op =) (tycos, raw_tycos) then ()
  46.172 +      else
  46.173 +        error ("Type constructors " ^ commas_quote raw_tycos ^
  46.174 +          " do not belong exhaustively to one mutual recursive datatype");
  46.175 +
  46.176 +    val (Ts, Us) = (pairself o map) Type protoTs;
  46.177 +
  46.178 +    val names = map Long_Name.base_name tycos;
  46.179 +    val (auxnames, _) =