merged
authorhaftmann
Fri Jun 19 21:08:07 2009 +0200 (2009-06-19)
changeset 31726ffd2dc631d88
parent 31722 caa89b41dcf2
parent 31725 f08507464b9d
child 31728 60317e5211a2
merged
NEWS
src/HOL/Import/import_package.ML
src/HOL/IsaMakefile
src/HOL/Nominal/nominal_package.ML
src/HOL/Tools/datatype_package/datatype_package.ML
src/HOL/Tools/function_package/fundef_package.ML
src/HOL/Tools/inductive_package.ML
src/HOL/Tools/inductive_set_package.ML
src/HOL/Tools/old_primrec_package.ML
src/HOL/Tools/primrec_package.ML
src/HOL/Tools/recdef_package.ML
src/HOL/Tools/record_package.ML
src/HOL/Tools/specification_package.ML
src/HOL/Tools/typecopy_package.ML
src/HOL/Tools/typedef_package.ML
     1.1 --- a/NEWS	Fri Jun 19 20:22:46 2009 +0200
     1.2 +++ b/NEWS	Fri Jun 19 21:08:07 2009 +0200
     1.3 @@ -43,6 +43,16 @@
     1.4  * Constants Set.Pow and Set.image now with authentic syntax; object-logic definitions
     1.5  Set.Pow_def and Set.image_def.  INCOMPATIBILITY.
     1.6  
     1.7 +* Discontinued ancient tradition to suffix certain ML module names with "_package", e.g.:
     1.8 +
     1.9 +    DatatypePackage ~> Datatype
    1.10 +    InductivePackage ~> Inductive
    1.11 +
    1.12 +    etc.
    1.13 +
    1.14 +INCOMPATIBILITY.
    1.15 +
    1.16 +
    1.17  * NewNumberTheory: Jeremy Avigad's new version of part of NumberTheory.
    1.18  If possible, use NewNumberTheory, not NumberTheory.
    1.19  
     2.1 --- a/src/HOL/FunDef.thy	Fri Jun 19 20:22:46 2009 +0200
     2.2 +++ b/src/HOL/FunDef.thy	Fri Jun 19 21:08:07 2009 +0200
     2.3 @@ -17,7 +17,7 @@
     2.4    ("Tools/function_package/sum_tree.ML")
     2.5    ("Tools/function_package/mutual.ML")
     2.6    ("Tools/function_package/pattern_split.ML")
     2.7 -  ("Tools/function_package/fundef_package.ML")
     2.8 +  ("Tools/function_package/fundef.ML")
     2.9    ("Tools/function_package/auto_term.ML")
    2.10    ("Tools/function_package/measure_functions.ML")
    2.11    ("Tools/function_package/lexicographic_order.ML")
    2.12 @@ -112,12 +112,12 @@
    2.13  use "Tools/function_package/mutual.ML"
    2.14  use "Tools/function_package/pattern_split.ML"
    2.15  use "Tools/function_package/auto_term.ML"
    2.16 -use "Tools/function_package/fundef_package.ML"
    2.17 +use "Tools/function_package/fundef.ML"
    2.18  use "Tools/function_package/fundef_datatype.ML"
    2.19  use "Tools/function_package/induction_scheme.ML"
    2.20  
    2.21  setup {* 
    2.22 -  FundefPackage.setup 
    2.23 +  Fundef.setup 
    2.24    #> FundefDatatype.setup
    2.25    #> InductionScheme.setup
    2.26  *}
     3.1 --- a/src/HOL/Hilbert_Choice.thy	Fri Jun 19 20:22:46 2009 +0200
     3.2 +++ b/src/HOL/Hilbert_Choice.thy	Fri Jun 19 21:08:07 2009 +0200
     3.3 @@ -7,7 +7,7 @@
     3.4  
     3.5  theory Hilbert_Choice
     3.6  imports Nat Wellfounded Plain
     3.7 -uses ("Tools/meson.ML") ("Tools/specification_package.ML")
     3.8 +uses ("Tools/meson.ML") ("Tools/choice_specification.ML")
     3.9  begin
    3.10  
    3.11  subsection {* Hilbert's epsilon *}
    3.12 @@ -596,7 +596,7 @@
    3.13  lemma exE_some: "[| Ex P ; c == Eps P |] ==> P c"
    3.14    by (simp only: someI_ex)
    3.15  
    3.16 -use "Tools/specification_package.ML"
    3.17 +use "Tools/choice_specification.ML"
    3.18  
    3.19  
    3.20  end
     4.1 --- a/src/HOL/HoareParallel/OG_Syntax.thy	Fri Jun 19 20:22:46 2009 +0200
     4.2 +++ b/src/HOL/HoareParallel/OG_Syntax.thy	Fri Jun 19 21:08:07 2009 +0200
     4.3 @@ -95,7 +95,7 @@
     4.4        | annbexp_tr' _ _ = raise Match;
     4.5  
     4.6      fun upd_tr' (x_upd, T) =
     4.7 -      (case try (unsuffix RecordPackage.updateN) x_upd of
     4.8 +      (case try (unsuffix Record.updateN) x_upd of
     4.9          SOME x => (x, if T = dummyT then T else Term.domain_type T)
    4.10        | NONE => raise Match);
    4.11  
     5.1 --- a/src/HOL/HoareParallel/RG_Syntax.thy	Fri Jun 19 20:22:46 2009 +0200
     5.2 +++ b/src/HOL/HoareParallel/RG_Syntax.thy	Fri Jun 19 21:08:07 2009 +0200
     5.3 @@ -68,7 +68,7 @@
     5.4        | bexp_tr' _ _ = raise Match;
     5.5  
     5.6      fun upd_tr' (x_upd, T) =
     5.7 -      (case try (unsuffix RecordPackage.updateN) x_upd of
     5.8 +      (case try (unsuffix Record.updateN) x_upd of
     5.9          SOME x => (x, if T = dummyT then T else Term.domain_type T)
    5.10        | NONE => raise Match);
    5.11  
     6.1 --- a/src/HOL/Imperative_HOL/Heap_Monad.thy	Fri Jun 19 20:22:46 2009 +0200
     6.2 +++ b/src/HOL/Imperative_HOL/Heap_Monad.thy	Fri Jun 19 21:08:07 2009 +0200
     6.3 @@ -318,7 +318,7 @@
     6.4        val dummy_case_term = IVar dummy_name;
     6.5        (*assumption: dummy values are not relevant for serialization*)
     6.6        val unitt = IConst (unit', (([], []), []));
     6.7 -      fun dest_abs ((v, ty) `|-> t, _) = ((v, ty), t)
     6.8 +      fun dest_abs ((v, ty) `|=> t, _) = ((v, ty), t)
     6.9          | dest_abs (t, ty) =
    6.10              let
    6.11                val vs = Code_Thingol.fold_varnames cons t [];
    6.12 @@ -337,7 +337,7 @@
    6.13                  then tr_bind' [(x1, ty1), (x2, ty2)]
    6.14                  else force t
    6.15              | _ => force t;
    6.16 -    in (dummy_name, dummy_type) `|-> ICase (((IVar dummy_name, dummy_type),
    6.17 +    in (dummy_name, dummy_type) `|=> ICase (((IVar dummy_name, dummy_type),
    6.18        [(unitt, tr_bind' ts)]), dummy_case_term) end
    6.19    and imp_monad_bind' bind' return' unit' (const as (c, (_, tys))) ts = if c = bind' then case (ts, tys)
    6.20       of ([t1, t2], ty1 :: ty2 :: _) => imp_monad_bind'' bind' return' unit' [(t1, ty1), (t2, ty2)]
    6.21 @@ -349,7 +349,7 @@
    6.22      | imp_monad_bind bind' return' unit' (t as _ `$ _) = (case unfold_app t
    6.23         of (IConst const, ts) => imp_monad_bind' bind' return' unit' const ts
    6.24          | (t, ts) => imp_monad_bind bind' return' unit' t `$$ map (imp_monad_bind bind' return' unit') ts)
    6.25 -    | imp_monad_bind bind' return' unit' (v_ty `|-> t) = v_ty `|-> imp_monad_bind bind' return' unit' t
    6.26 +    | imp_monad_bind bind' return' unit' (v_ty `|=> t) = v_ty `|=> imp_monad_bind bind' return' unit' t
    6.27      | imp_monad_bind bind' return' unit' (ICase (((t, ty), pats), t0)) = ICase
    6.28          (((imp_monad_bind bind' return' unit' t, ty), (map o pairself) (imp_monad_bind bind' return' unit') pats), imp_monad_bind bind' return' unit' t0);
    6.29  
     7.1 --- a/src/HOL/Import/HOL4Setup.thy	Fri Jun 19 20:22:46 2009 +0200
     7.2 +++ b/src/HOL/Import/HOL4Setup.thy	Fri Jun 19 21:08:07 2009 +0200
     7.3 @@ -1,10 +1,9 @@
     7.4  (*  Title:      HOL/Import/HOL4Setup.thy
     7.5 -    ID:         $Id$
     7.6      Author:     Sebastian Skalberg (TU Muenchen)
     7.7  *)
     7.8  
     7.9  theory HOL4Setup imports MakeEqual ImportRecorder
    7.10 -  uses ("proof_kernel.ML") ("replay.ML") ("hol4rews.ML") ("import_package.ML") begin
    7.11 +  uses ("proof_kernel.ML") ("replay.ML") ("hol4rews.ML") ("import.ML") begin
    7.12  
    7.13  section {* General Setup *}
    7.14  
    7.15 @@ -162,8 +161,8 @@
    7.16  
    7.17  use "proof_kernel.ML"
    7.18  use "replay.ML"
    7.19 -use "import_package.ML"
    7.20 +use "import.ML"
    7.21  
    7.22 -setup ImportPackage.setup
    7.23 +setup Import.setup
    7.24  
    7.25  end
     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/src/HOL/Import/import.ML	Fri Jun 19 21:08:07 2009 +0200
     8.3 @@ -0,0 +1,71 @@
     8.4 +(*  Title:      HOL/Import/import.ML
     8.5 +    Author:     Sebastian Skalberg (TU Muenchen)
     8.6 +*)
     8.7 +
     8.8 +signature IMPORT =
     8.9 +sig
    8.10 +    val debug      : bool ref
    8.11 +    val import_tac : Proof.context -> string * string -> tactic
    8.12 +    val setup      : theory -> theory
    8.13 +end
    8.14 +
    8.15 +structure ImportData = TheoryDataFun
    8.16 +(
    8.17 +  type T = ProofKernel.thm option array option
    8.18 +  val empty = NONE
    8.19 +  val copy = I
    8.20 +  val extend = I
    8.21 +  fun merge _ _ = NONE
    8.22 +)
    8.23 +
    8.24 +structure Import :> IMPORT =
    8.25 +struct
    8.26 +
    8.27 +val debug = ref false
    8.28 +fun message s = if !debug then writeln s else ()
    8.29 +
    8.30 +fun import_tac ctxt (thyname, thmname) =
    8.31 +    if ! quick_and_dirty
    8.32 +    then SkipProof.cheat_tac (ProofContext.theory_of ctxt)
    8.33 +    else
    8.34 +     fn th =>
    8.35 +        let
    8.36 +            val thy = ProofContext.theory_of ctxt
    8.37 +            val prem = hd (prems_of th)
    8.38 +            val _ = message ("Import_tac: thyname=" ^ thyname ^ ", thmname=" ^ thmname)
    8.39 +            val _ = message ("Import trying to prove " ^ Syntax.string_of_term ctxt prem)
    8.40 +            val int_thms = case ImportData.get thy of
    8.41 +                               NONE => fst (Replay.setup_int_thms thyname thy)
    8.42 +                             | SOME a => a
    8.43 +            val proof = snd (ProofKernel.import_proof thyname thmname thy) thy
    8.44 +            val hol4thm = snd (Replay.replay_proof int_thms thyname thmname proof thy)
    8.45 +            val thm = snd (ProofKernel.to_isa_thm hol4thm)
    8.46 +            val rew = ProofKernel.rewrite_hol4_term (concl_of thm) thy
    8.47 +            val thm = equal_elim rew thm
    8.48 +            val prew = ProofKernel.rewrite_hol4_term prem thy
    8.49 +            val prem' = #2 (Logic.dest_equals (prop_of prew))
    8.50 +            val _ = message ("Import proved " ^ Display.string_of_thm thm)
    8.51 +            val thm = ProofKernel.disambiguate_frees thm
    8.52 +            val _ = message ("Disambiguate: " ^ Display.string_of_thm thm)
    8.53 +        in
    8.54 +            case Shuffler.set_prop thy prem' [("",thm)] of
    8.55 +                SOME (_,thm) =>
    8.56 +                let
    8.57 +                    val _ = if prem' aconv (prop_of thm)
    8.58 +                            then message "import: Terms match up"
    8.59 +                            else message "import: Terms DO NOT match up"
    8.60 +                    val thm' = equal_elim (symmetric prew) thm
    8.61 +                    val res = bicompose true (false,thm',0) 1 th
    8.62 +                in
    8.63 +                    res
    8.64 +                end
    8.65 +              | NONE => (message "import: set_prop didn't succeed"; no_tac th)
    8.66 +        end
    8.67 +
    8.68 +val setup = Method.setup @{binding import}
    8.69 +  (Scan.lift (Args.name -- Args.name) >>
    8.70 +    (fn arg => fn ctxt => SIMPLE_METHOD (import_tac ctxt arg)))
    8.71 +  "import HOL4 theorem"
    8.72 +
    8.73 +end
    8.74 +
     9.1 --- a/src/HOL/Import/import_package.ML	Fri Jun 19 20:22:46 2009 +0200
     9.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     9.3 @@ -1,71 +0,0 @@
     9.4 -(*  Title:      HOL/Import/import_package.ML
     9.5 -    Author:     Sebastian Skalberg (TU Muenchen)
     9.6 -*)
     9.7 -
     9.8 -signature IMPORT_PACKAGE =
     9.9 -sig
    9.10 -    val debug      : bool ref
    9.11 -    val import_tac : Proof.context -> string * string -> tactic
    9.12 -    val setup      : theory -> theory
    9.13 -end
    9.14 -
    9.15 -structure ImportData = TheoryDataFun
    9.16 -(
    9.17 -  type T = ProofKernel.thm option array option
    9.18 -  val empty = NONE
    9.19 -  val copy = I
    9.20 -  val extend = I
    9.21 -  fun merge _ _ = NONE
    9.22 -)
    9.23 -
    9.24 -structure ImportPackage :> IMPORT_PACKAGE =
    9.25 -struct
    9.26 -
    9.27 -val debug = ref false
    9.28 -fun message s = if !debug then writeln s else ()
    9.29 -
    9.30 -fun import_tac ctxt (thyname, thmname) =
    9.31 -    if ! quick_and_dirty
    9.32 -    then SkipProof.cheat_tac (ProofContext.theory_of ctxt)
    9.33 -    else
    9.34 -     fn th =>
    9.35 -        let
    9.36 -            val thy = ProofContext.theory_of ctxt
    9.37 -            val prem = hd (prems_of th)
    9.38 -            val _ = message ("Import_tac: thyname=" ^ thyname ^ ", thmname=" ^ thmname)
    9.39 -            val _ = message ("Import trying to prove " ^ Syntax.string_of_term ctxt prem)
    9.40 -            val int_thms = case ImportData.get thy of
    9.41 -                               NONE => fst (Replay.setup_int_thms thyname thy)
    9.42 -                             | SOME a => a
    9.43 -            val proof = snd (ProofKernel.import_proof thyname thmname thy) thy
    9.44 -            val hol4thm = snd (Replay.replay_proof int_thms thyname thmname proof thy)
    9.45 -            val thm = snd (ProofKernel.to_isa_thm hol4thm)
    9.46 -            val rew = ProofKernel.rewrite_hol4_term (concl_of thm) thy
    9.47 -            val thm = equal_elim rew thm
    9.48 -            val prew = ProofKernel.rewrite_hol4_term prem thy
    9.49 -            val prem' = #2 (Logic.dest_equals (prop_of prew))
    9.50 -            val _ = message ("Import proved " ^ Display.string_of_thm thm)
    9.51 -            val thm = ProofKernel.disambiguate_frees thm
    9.52 -            val _ = message ("Disambiguate: " ^ Display.string_of_thm thm)
    9.53 -        in
    9.54 -            case Shuffler.set_prop thy prem' [("",thm)] of
    9.55 -                SOME (_,thm) =>
    9.56 -                let
    9.57 -                    val _ = if prem' aconv (prop_of thm)
    9.58 -                            then message "import: Terms match up"
    9.59 -                            else message "import: Terms DO NOT match up"
    9.60 -                    val thm' = equal_elim (symmetric prew) thm
    9.61 -                    val res = bicompose true (false,thm',0) 1 th
    9.62 -                in
    9.63 -                    res
    9.64 -                end
    9.65 -              | NONE => (message "import: set_prop didn't succeed"; no_tac th)
    9.66 -        end
    9.67 -
    9.68 -val setup = Method.setup @{binding import}
    9.69 -  (Scan.lift (Args.name -- Args.name) >>
    9.70 -    (fn arg => fn ctxt => SIMPLE_METHOD (import_tac ctxt arg)))
    9.71 -  "import HOL4 theorem"
    9.72 -
    9.73 -end
    9.74 -
    10.1 --- a/src/HOL/Import/proof_kernel.ML	Fri Jun 19 20:22:46 2009 +0200
    10.2 +++ b/src/HOL/Import/proof_kernel.ML	Fri Jun 19 21:08:07 2009 +0200
    10.3 @@ -2021,7 +2021,7 @@
    10.4                                  snd (get_defname thyname name thy)) thy1 names
    10.5              fun new_name name = fst (get_defname thyname name thy1)
    10.6              val names' = map (fn name => (new_name name,name,false)) names
    10.7 -            val (thy',res) = SpecificationPackage.add_specification NONE
    10.8 +            val (thy',res) = Choice_Specification.add_specification NONE
    10.9                                   names'
   10.10                                   (thy1,th)
   10.11              val _ = ImportRecorder.add_specification names' th
   10.12 @@ -2091,7 +2091,7 @@
   10.13              val tsyn = mk_syn thy tycname
   10.14              val typ = (tycname,tnames,tsyn)
   10.15              val ((_, typedef_info), thy') =
   10.16 -              TypedefPackage.add_typedef false (SOME (Binding.name thmname))
   10.17 +              Typedef.add_typedef false (SOME (Binding.name thmname))
   10.18                  (Binding.name tycname, tnames, tsyn) c NONE (rtac th2 1) thy
   10.19              val _ = ImportRecorder.add_typedef (SOME thmname) typ c NONE th2
   10.20  
   10.21 @@ -2179,7 +2179,7 @@
   10.22              val tsyn = mk_syn thy tycname
   10.23              val typ = (tycname,tnames,tsyn)
   10.24              val ((_, typedef_info), thy') =
   10.25 -              TypedefPackage.add_typedef false NONE (Binding.name tycname,tnames,tsyn) c
   10.26 +              Typedef.add_typedef false NONE (Binding.name tycname,tnames,tsyn) c
   10.27                  (SOME(Binding.name rep_name,Binding.name abs_name)) (rtac th2 1) thy
   10.28              val _ = ImportRecorder.add_typedef NONE typ c (SOME(rep_name,abs_name)) th2
   10.29              val fulltyname = Sign.intern_type thy' tycname
    11.1 --- a/src/HOL/Import/replay.ML	Fri Jun 19 20:22:46 2009 +0200
    11.2 +++ b/src/HOL/Import/replay.ML	Fri Jun 19 21:08:07 2009 +0200
    11.3 @@ -329,7 +329,7 @@
    11.4  	and rp (ThmEntry (thyname', thmname', aborted, History history)) thy = rps history thy	    
    11.5  	  | rp (DeltaEntry ds) thy = fold delta ds thy
    11.6  	and delta (Specification (names, th)) thy = 
    11.7 -	    fst (SpecificationPackage.add_specification NONE names (thy,th_of thy th))
    11.8 +	    fst (Choice_Specification.add_specification NONE names (thy,th_of thy th))
    11.9  	  | delta (Hol_mapping (thyname, thmname, isaname)) thy = 
   11.10  	    add_hol4_mapping thyname thmname isaname thy
   11.11  	  | delta (Hol_pending (thyname, thmname, th)) thy = 
   11.12 @@ -344,7 +344,7 @@
   11.13  	  | delta (Hol_theorem (thyname, thmname, th)) thy =
   11.14  	    add_hol4_theorem thyname thmname ([], th_of thy th) thy
   11.15  	  | delta (Typedef (thmname, (t, vs, mx), c, repabs, th)) thy = 
   11.16 -	    snd (TypedefPackage.add_typedef false (Option.map Binding.name thmname) (Binding.name t, vs, mx) c
   11.17 +	    snd (Typedef.add_typedef false (Option.map Binding.name thmname) (Binding.name t, vs, mx) c
   11.18          (Option.map (pairself Binding.name) repabs) (rtac (th_of thy th) 1) thy)
   11.19  	  | delta (Hol_type_mapping (thyname, tycname, fulltyname)) thy =  
   11.20  	    add_hol4_type_mapping thyname tycname true fulltyname thy
    12.1 --- a/src/HOL/Inductive.thy	Fri Jun 19 20:22:46 2009 +0200
    12.2 +++ b/src/HOL/Inductive.thy	Fri Jun 19 21:08:07 2009 +0200
    12.3 @@ -7,7 +7,7 @@
    12.4  theory Inductive 
    12.5  imports Lattices Sum_Type
    12.6  uses
    12.7 -  ("Tools/inductive_package.ML")
    12.8 +  ("Tools/inductive.ML")
    12.9    "Tools/dseq.ML"
   12.10    ("Tools/inductive_codegen.ML")
   12.11    ("Tools/datatype_package/datatype_aux.ML")
   12.12 @@ -15,9 +15,9 @@
   12.13    ("Tools/datatype_package/datatype_rep_proofs.ML")
   12.14    ("Tools/datatype_package/datatype_abs_proofs.ML")
   12.15    ("Tools/datatype_package/datatype_case.ML")
   12.16 -  ("Tools/datatype_package/datatype_package.ML")
   12.17 -  ("Tools/old_primrec_package.ML")
   12.18 -  ("Tools/primrec_package.ML")
   12.19 +  ("Tools/datatype_package/datatype.ML")
   12.20 +  ("Tools/old_primrec.ML")
   12.21 +  ("Tools/primrec.ML")
   12.22    ("Tools/datatype_package/datatype_codegen.ML")
   12.23  begin
   12.24  
   12.25 @@ -320,8 +320,8 @@
   12.26  val le_fun_def = @{thm le_fun_def} RS @{thm eq_reflection}
   12.27  *}
   12.28  
   12.29 -use "Tools/inductive_package.ML"
   12.30 -setup InductivePackage.setup
   12.31 +use "Tools/inductive.ML"
   12.32 +setup Inductive.setup
   12.33  
   12.34  theorems [mono] =
   12.35    imp_refl disj_mono conj_mono ex_mono all_mono if_bool_eq_conj
   12.36 @@ -340,11 +340,11 @@
   12.37  use "Tools/datatype_package/datatype_rep_proofs.ML"
   12.38  use "Tools/datatype_package/datatype_abs_proofs.ML"
   12.39  use "Tools/datatype_package/datatype_case.ML"
   12.40 -use "Tools/datatype_package/datatype_package.ML"
   12.41 -setup DatatypePackage.setup
   12.42 +use "Tools/datatype_package/datatype.ML"
   12.43 +setup Datatype.setup
   12.44  
   12.45 -use "Tools/old_primrec_package.ML"
   12.46 -use "Tools/primrec_package.ML"
   12.47 +use "Tools/old_primrec.ML"
   12.48 +use "Tools/primrec.ML"
   12.49  
   12.50  use "Tools/datatype_package/datatype_codegen.ML"
   12.51  setup DatatypeCodegen.setup
   12.52 @@ -364,7 +364,7 @@
   12.53    fun fun_tr ctxt [cs] =
   12.54      let
   12.55        val x = Free (Name.variant (Term.add_free_names cs []) "x", dummyT);
   12.56 -      val ft = DatatypeCase.case_tr true DatatypePackage.datatype_of_constr
   12.57 +      val ft = DatatypeCase.case_tr true Datatype.datatype_of_constr
   12.58                   ctxt [x, cs]
   12.59      in lambda x ft end
   12.60  in [("_lam_pats_syntax", fun_tr)] end
    13.1 --- a/src/HOL/IsaMakefile	Fri Jun 19 20:22:46 2009 +0200
    13.2 +++ b/src/HOL/IsaMakefile	Fri Jun 19 21:08:07 2009 +0200
    13.3 @@ -146,7 +146,7 @@
    13.4    Tools/datatype_package/datatype_aux.ML \
    13.5    Tools/datatype_package/datatype_case.ML \
    13.6    Tools/datatype_package/datatype_codegen.ML \
    13.7 -  Tools/datatype_package/datatype_package.ML \
    13.8 +  Tools/datatype_package/datatype.ML \
    13.9    Tools/datatype_package/datatype_prop.ML \
   13.10    Tools/datatype_package/datatype_realizer.ML \
   13.11    Tools/datatype_package/datatype_rep_proofs.ML \
   13.12 @@ -159,7 +159,7 @@
   13.13    Tools/function_package/fundef_core.ML \
   13.14    Tools/function_package/fundef_datatype.ML \
   13.15    Tools/function_package/fundef_lib.ML \
   13.16 -  Tools/function_package/fundef_package.ML \
   13.17 +  Tools/function_package/fundef.ML \
   13.18    Tools/function_package/induction_scheme.ML \
   13.19    Tools/function_package/inductive_wrap.ML \
   13.20    Tools/function_package/lexicographic_order.ML \
   13.21 @@ -172,24 +172,24 @@
   13.22    Tools/function_package/sum_tree.ML \
   13.23    Tools/function_package/termination.ML \
   13.24    Tools/inductive_codegen.ML \
   13.25 -  Tools/inductive_package.ML \
   13.26 +  Tools/inductive.ML \
   13.27    Tools/inductive_realizer.ML \
   13.28 -  Tools/inductive_set_package.ML \
   13.29 +  Tools/inductive_set.ML \
   13.30    Tools/lin_arith.ML \
   13.31    Tools/nat_arith.ML \
   13.32 -  Tools/old_primrec_package.ML \
   13.33 -  Tools/primrec_package.ML \
   13.34 +  Tools/old_primrec.ML \
   13.35 +  Tools/primrec.ML \
   13.36    Tools/prop_logic.ML \
   13.37 -  Tools/record_package.ML \
   13.38 +  Tools/record.ML \
   13.39    Tools/refute.ML \
   13.40    Tools/refute_isar.ML \
   13.41    Tools/rewrite_hol_proof.ML \
   13.42    Tools/sat_funcs.ML \
   13.43    Tools/sat_solver.ML \
   13.44    Tools/split_rule.ML \
   13.45 -  Tools/typecopy_package.ML \
   13.46 +  Tools/typecopy.ML \
   13.47    Tools/typedef_codegen.ML \
   13.48 -  Tools/typedef_package.ML \
   13.49 +  Tools/typedef.ML \
   13.50    Transitive_Closure.thy \
   13.51    Typedef.thy \
   13.52    Wellfounded.thy \
   13.53 @@ -251,13 +251,13 @@
   13.54    Tools/Qelim/generated_cooper.ML \
   13.55    Tools/Qelim/presburger.ML \
   13.56    Tools/Qelim/qelim.ML \
   13.57 -  Tools/recdef_package.ML \
   13.58 +  Tools/recdef.ML \
   13.59    Tools/res_atp.ML \
   13.60    Tools/res_axioms.ML \
   13.61    Tools/res_clause.ML \
   13.62    Tools/res_hol_clause.ML \
   13.63    Tools/res_reconstruct.ML \
   13.64 -  Tools/specification_package.ML \
   13.65 +  Tools/choice_specification.ML \
   13.66    Tools/string_code.ML \
   13.67    Tools/string_syntax.ML \
   13.68    Tools/TFL/casesplit.ML \
   13.69 @@ -424,7 +424,7 @@
   13.70  IMPORTER_FILES = Import/lazy_seq.ML Import/proof_kernel.ML Import/replay.ML \
   13.71    Import/shuffler.ML Import/MakeEqual.thy Import/HOL4Setup.thy \
   13.72    Import/HOL4Syntax.thy Import/HOL4Compat.thy Import/import_syntax.ML \
   13.73 -  Import/hol4rews.ML Import/import_package.ML Import/ROOT.ML
   13.74 +  Import/hol4rews.ML Import/import.ML Import/ROOT.ML
   13.75  
   13.76  IMPORTER_HOLLIGHT_FILES = Import/proof_kernel.ML Import/replay.ML \
   13.77    Import/shuffler.ML Import/MakeEqual.thy Import/HOL4Setup.thy \
   13.78 @@ -981,7 +981,7 @@
   13.79    Nominal/nominal_induct.ML \
   13.80    Nominal/nominal_inductive.ML \
   13.81    Nominal/nominal_inductive2.ML \
   13.82 -  Nominal/nominal_package.ML \
   13.83 +  Nominal/nominal.ML \
   13.84    Nominal/nominal_permeq.ML \
   13.85    Nominal/nominal_primrec.ML \
   13.86    Nominal/nominal_thmdecls.ML \
    14.1 --- a/src/HOL/Isar_examples/Hoare.thy	Fri Jun 19 20:22:46 2009 +0200
    14.2 +++ b/src/HOL/Isar_examples/Hoare.thy	Fri Jun 19 21:08:07 2009 +0200
    14.3 @@ -260,7 +260,7 @@
    14.4        | bexp_tr' _ _ = raise Match;
    14.5  
    14.6      fun upd_tr' (x_upd, T) =
    14.7 -      (case try (unsuffix RecordPackage.updateN) x_upd of
    14.8 +      (case try (unsuffix Record.updateN) x_upd of
    14.9          SOME x => (x, if T = dummyT then T else Term.domain_type T)
   14.10        | NONE => raise Match);
   14.11  
    15.1 --- a/src/HOL/List.thy	Fri Jun 19 20:22:46 2009 +0200
    15.2 +++ b/src/HOL/List.thy	Fri Jun 19 21:08:07 2009 +0200
    15.3 @@ -363,7 +363,7 @@
    15.4        val case2 = Syntax.const "_case1" $ Syntax.const Term.dummy_patternN
    15.5                                          $ NilC;
    15.6        val cs = Syntax.const "_case2" $ case1 $ case2
    15.7 -      val ft = DatatypeCase.case_tr false DatatypePackage.datatype_of_constr
    15.8 +      val ft = DatatypeCase.case_tr false Datatype.datatype_of_constr
    15.9                   ctxt [x, cs]
   15.10      in lambda x ft end;
   15.11  
    16.1 --- a/src/HOL/Nominal/Nominal.thy	Fri Jun 19 20:22:46 2009 +0200
    16.2 +++ b/src/HOL/Nominal/Nominal.thy	Fri Jun 19 21:08:07 2009 +0200
    16.3 @@ -3,7 +3,7 @@
    16.4  uses
    16.5    ("nominal_thmdecls.ML")
    16.6    ("nominal_atoms.ML")
    16.7 -  ("nominal_package.ML")
    16.8 +  ("nominal.ML")
    16.9    ("nominal_induct.ML") 
   16.10    ("nominal_permeq.ML")
   16.11    ("nominal_fresh_fun.ML")
   16.12 @@ -3670,7 +3670,7 @@
   16.13  lemma allE_Nil: assumes "\<forall>x. P x" obtains "P []"
   16.14    using assms ..
   16.15  
   16.16 -use "nominal_package.ML"
   16.17 +use "nominal.ML"
   16.18  
   16.19  (******************************************************)
   16.20  (* primitive recursive functions on nominal datatypes *)
    17.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.2 +++ b/src/HOL/Nominal/nominal.ML	Fri Jun 19 21:08:07 2009 +0200
    17.3 @@ -0,0 +1,2095 @@
    17.4 +(*  Title:      HOL/Nominal/nominal.ML
    17.5 +    Author:     Stefan Berghofer and Christian Urban, TU Muenchen
    17.6 +
    17.7 +Nominal datatype package for Isabelle/HOL.
    17.8 +*)
    17.9 +
   17.10 +signature NOMINAL =
   17.11 +sig
   17.12 +  val add_nominal_datatype : DatatypeAux.datatype_config -> string list ->
   17.13 +    (string list * bstring * mixfix *
   17.14 +      (bstring * string list * mixfix) list) list -> theory -> theory
   17.15 +  type descr
   17.16 +  type nominal_datatype_info
   17.17 +  val get_nominal_datatypes : theory -> nominal_datatype_info Symtab.table
   17.18 +  val get_nominal_datatype : theory -> string -> nominal_datatype_info option
   17.19 +  val mk_perm: typ list -> term -> term -> term
   17.20 +  val perm_of_pair: term * term -> term
   17.21 +  val mk_not_sym: thm list -> thm list
   17.22 +  val perm_simproc: simproc
   17.23 +  val fresh_const: typ -> typ -> term
   17.24 +  val fresh_star_const: typ -> typ -> term
   17.25 +end
   17.26 +
   17.27 +structure Nominal : NOMINAL =
   17.28 +struct
   17.29 +
   17.30 +val finite_emptyI = thm "finite.emptyI";
   17.31 +val finite_Diff = thm "finite_Diff";
   17.32 +val finite_Un = thm "finite_Un";
   17.33 +val Un_iff = thm "Un_iff";
   17.34 +val In0_eq = thm "In0_eq";
   17.35 +val In1_eq = thm "In1_eq";
   17.36 +val In0_not_In1 = thm "In0_not_In1";
   17.37 +val In1_not_In0 = thm "In1_not_In0";
   17.38 +val Un_assoc = thm "Un_assoc";
   17.39 +val Collect_disj_eq = thm "Collect_disj_eq";
   17.40 +val empty_def = thm "empty_def";
   17.41 +val empty_iff = thm "empty_iff";
   17.42 +
   17.43 +open DatatypeAux;
   17.44 +open NominalAtoms;
   17.45 +
   17.46 +(** FIXME: Datatype should export this function **)
   17.47 +
   17.48 +local
   17.49 +
   17.50 +fun dt_recs (DtTFree _) = []
   17.51 +  | dt_recs (DtType (_, dts)) = List.concat (map dt_recs dts)
   17.52 +  | dt_recs (DtRec i) = [i];
   17.53 +
   17.54 +fun dt_cases (descr: descr) (_, args, constrs) =
   17.55 +  let
   17.56 +    fun the_bname i = Long_Name.base_name (#1 (valOf (AList.lookup (op =) descr i)));
   17.57 +    val bnames = map the_bname (distinct op = (List.concat (map dt_recs args)));
   17.58 +  in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
   17.59 +
   17.60 +
   17.61 +fun induct_cases descr =
   17.62 +  DatatypeProp.indexify_names (List.concat (map (dt_cases descr) (map #2 descr)));
   17.63 +
   17.64 +fun exhaust_cases descr i = dt_cases descr (valOf (AList.lookup (op =) descr i));
   17.65 +
   17.66 +in
   17.67 +
   17.68 +fun mk_case_names_induct descr = RuleCases.case_names (induct_cases descr);
   17.69 +
   17.70 +fun mk_case_names_exhausts descr new =
   17.71 +  map (RuleCases.case_names o exhaust_cases descr o #1)
   17.72 +    (List.filter (fn ((_, (name, _, _))) => name mem_string new) descr);
   17.73 +
   17.74 +end;
   17.75 +
   17.76 +(* theory data *)
   17.77 +
   17.78 +type descr = (int * (string * dtyp list * (string * (dtyp list * dtyp) list) list)) list;
   17.79 +
   17.80 +type nominal_datatype_info =
   17.81 +  {index : int,
   17.82 +   descr : descr,
   17.83 +   sorts : (string * sort) list,
   17.84 +   rec_names : string list,
   17.85 +   rec_rewrites : thm list,
   17.86 +   induction : thm,
   17.87 +   distinct : thm list,
   17.88 +   inject : thm list};
   17.89 +
   17.90 +structure NominalDatatypesData = TheoryDataFun
   17.91 +(
   17.92 +  type T = nominal_datatype_info Symtab.table;
   17.93 +  val empty = Symtab.empty;
   17.94 +  val copy = I;
   17.95 +  val extend = I;
   17.96 +  fun merge _ tabs : T = Symtab.merge (K true) tabs;
   17.97 +);
   17.98 +
   17.99 +val get_nominal_datatypes = NominalDatatypesData.get;
  17.100 +val put_nominal_datatypes = NominalDatatypesData.put;
  17.101 +val map_nominal_datatypes = NominalDatatypesData.map;
  17.102 +val get_nominal_datatype = Symtab.lookup o get_nominal_datatypes;
  17.103 +
  17.104 +
  17.105 +(**** make datatype info ****)
  17.106 +
  17.107 +fun make_dt_info descr sorts induct reccomb_names rec_thms
  17.108 +    (((i, (_, (tname, _, _))), distinct), inject) =
  17.109 +  (tname,
  17.110 +   {index = i,
  17.111 +    descr = descr,
  17.112 +    sorts = sorts,
  17.113 +    rec_names = reccomb_names,
  17.114 +    rec_rewrites = rec_thms,
  17.115 +    induction = induct,
  17.116 +    distinct = distinct,
  17.117 +    inject = inject});
  17.118 +
  17.119 +(*******************************)
  17.120 +
  17.121 +val (_ $ (_ $ (_ $ (distinct_f $ _) $ _))) = hd (prems_of distinct_lemma);
  17.122 +
  17.123 +
  17.124 +(** simplification procedure for sorting permutations **)
  17.125 +
  17.126 +val dj_cp = thm "dj_cp";
  17.127 +
  17.128 +fun dest_permT (Type ("fun", [Type ("List.list", [Type ("*", [T, _])]),
  17.129 +      Type ("fun", [_, U])])) = (T, U);
  17.130 +
  17.131 +fun permTs_of (Const ("Nominal.perm", T) $ t $ u) = fst (dest_permT T) :: permTs_of u
  17.132 +  | permTs_of _ = [];
  17.133 +
  17.134 +fun perm_simproc' thy ss (Const ("Nominal.perm", T) $ t $ (u as Const ("Nominal.perm", U) $ r $ s)) =
  17.135 +      let
  17.136 +        val (aT as Type (a, []), S) = dest_permT T;
  17.137 +        val (bT as Type (b, []), _) = dest_permT U
  17.138 +      in if aT mem permTs_of u andalso aT <> bT then
  17.139 +          let
  17.140 +            val cp = cp_inst_of thy a b;
  17.141 +            val dj = dj_thm_of thy b a;
  17.142 +            val dj_cp' = [cp, dj] MRS dj_cp;
  17.143 +            val cert = SOME o cterm_of thy
  17.144 +          in
  17.145 +            SOME (mk_meta_eq (Drule.instantiate' [SOME (ctyp_of thy S)]
  17.146 +              [cert t, cert r, cert s] dj_cp'))
  17.147 +          end
  17.148 +        else NONE
  17.149 +      end
  17.150 +  | perm_simproc' thy ss _ = NONE;
  17.151 +
  17.152 +val perm_simproc =
  17.153 +  Simplifier.simproc (the_context ()) "perm_simp" ["pi1 \<bullet> (pi2 \<bullet> x)"] perm_simproc';
  17.154 +
  17.155 +val meta_spec = thm "meta_spec";
  17.156 +
  17.157 +fun projections rule =
  17.158 +  ProjectRule.projections (ProofContext.init (Thm.theory_of_thm rule)) rule
  17.159 +  |> map (standard #> RuleCases.save rule);
  17.160 +
  17.161 +val supp_prod = thm "supp_prod";
  17.162 +val fresh_prod = thm "fresh_prod";
  17.163 +val supports_fresh = thm "supports_fresh";
  17.164 +val supports_def = thm "Nominal.supports_def";
  17.165 +val fresh_def = thm "fresh_def";
  17.166 +val supp_def = thm "supp_def";
  17.167 +val rev_simps = thms "rev.simps";
  17.168 +val app_simps = thms "append.simps";
  17.169 +val at_fin_set_supp = thm "at_fin_set_supp";
  17.170 +val at_fin_set_fresh = thm "at_fin_set_fresh";
  17.171 +val abs_fun_eq1 = thm "abs_fun_eq1";
  17.172 +
  17.173 +val collect_simp = rewrite_rule [mk_meta_eq mem_Collect_eq];
  17.174 +
  17.175 +fun mk_perm Ts t u =
  17.176 +  let
  17.177 +    val T = fastype_of1 (Ts, t);
  17.178 +    val U = fastype_of1 (Ts, u)
  17.179 +  in Const ("Nominal.perm", T --> U --> U) $ t $ u end;
  17.180 +
  17.181 +fun perm_of_pair (x, y) =
  17.182 +  let
  17.183 +    val T = fastype_of x;
  17.184 +    val pT = mk_permT T
  17.185 +  in Const ("List.list.Cons", HOLogic.mk_prodT (T, T) --> pT --> pT) $
  17.186 +    HOLogic.mk_prod (x, y) $ Const ("List.list.Nil", pT)
  17.187 +  end;
  17.188 +
  17.189 +fun mk_not_sym ths = maps (fn th => case prop_of th of
  17.190 +    _ $ (Const ("Not", _) $ (Const ("op =", _) $ _ $ _)) => [th, th RS not_sym]
  17.191 +  | _ => [th]) ths;
  17.192 +
  17.193 +fun fresh_const T U = Const ("Nominal.fresh", T --> U --> HOLogic.boolT);
  17.194 +fun fresh_star_const T U =
  17.195 +  Const ("Nominal.fresh_star", HOLogic.mk_setT T --> U --> HOLogic.boolT);
  17.196 +
  17.197 +fun gen_add_nominal_datatype prep_typ config new_type_names dts thy =
  17.198 +  let
  17.199 +    (* this theory is used just for parsing *)
  17.200 +
  17.201 +    val tmp_thy = thy |>
  17.202 +      Theory.copy |>
  17.203 +      Sign.add_types (map (fn (tvs, tname, mx, _) =>
  17.204 +        (Binding.name tname, length tvs, mx)) dts);
  17.205 +
  17.206 +    val atoms = atoms_of thy;
  17.207 +
  17.208 +    fun prep_constr ((constrs, sorts), (cname, cargs, mx)) =
  17.209 +      let val (cargs', sorts') = Library.foldl (prep_typ tmp_thy) (([], sorts), cargs)
  17.210 +      in (constrs @ [(cname, cargs', mx)], sorts') end
  17.211 +
  17.212 +    fun prep_dt_spec ((dts, sorts), (tvs, tname, mx, constrs)) =
  17.213 +      let val (constrs', sorts') = Library.foldl prep_constr (([], sorts), constrs)
  17.214 +      in (dts @ [(tvs, tname, mx, constrs')], sorts') end
  17.215 +
  17.216 +    val (dts', sorts) = Library.foldl prep_dt_spec (([], []), dts);
  17.217 +    val tyvars = map (map (fn s =>
  17.218 +      (s, the (AList.lookup (op =) sorts s))) o #1) dts';
  17.219 +
  17.220 +    fun inter_sort thy S S' = Type.inter_sort (Sign.tsig_of thy) (S, S');
  17.221 +    fun augment_sort_typ thy S =
  17.222 +      let val S = Sign.certify_sort thy S
  17.223 +      in map_type_tfree (fn (s, S') => TFree (s,
  17.224 +        if member (op = o apsnd fst) sorts s then inter_sort thy S S' else S'))
  17.225 +      end;
  17.226 +    fun augment_sort thy S = map_types (augment_sort_typ thy S);
  17.227 +
  17.228 +    val types_syntax = map (fn (tvs, tname, mx, constrs) => (tname, mx)) dts';
  17.229 +    val constr_syntax = map (fn (tvs, tname, mx, constrs) =>
  17.230 +      map (fn (cname, cargs, mx) => (cname, mx)) constrs) dts';
  17.231 +
  17.232 +    val ps = map (fn (_, n, _, _) =>
  17.233 +      (Sign.full_bname tmp_thy n, Sign.full_bname tmp_thy (n ^ "_Rep"))) dts;
  17.234 +    val rps = map Library.swap ps;
  17.235 +
  17.236 +    fun replace_types (Type ("Nominal.ABS", [T, U])) =
  17.237 +          Type ("fun", [T, Type ("Nominal.noption", [replace_types U])])
  17.238 +      | replace_types (Type (s, Ts)) =
  17.239 +          Type (getOpt (AList.lookup op = ps s, s), map replace_types Ts)
  17.240 +      | replace_types T = T;
  17.241 +
  17.242 +    val dts'' = map (fn (tvs, tname, mx, constrs) => (tvs, Binding.name (tname ^ "_Rep"), NoSyn,
  17.243 +      map (fn (cname, cargs, mx) => (Binding.name (cname ^ "_Rep"),
  17.244 +        map replace_types cargs, NoSyn)) constrs)) dts';
  17.245 +
  17.246 +    val new_type_names' = map (fn n => n ^ "_Rep") new_type_names;
  17.247 +    val full_new_type_names' = map (Sign.full_bname thy) new_type_names';
  17.248 +
  17.249 +    val ({induction, ...},thy1) =
  17.250 +      Datatype.add_datatype config new_type_names' dts'' thy;
  17.251 +
  17.252 +    val SOME {descr, ...} = Symtab.lookup
  17.253 +      (Datatype.get_datatypes thy1) (hd full_new_type_names');
  17.254 +    fun nth_dtyp i = typ_of_dtyp descr sorts (DtRec i);
  17.255 +
  17.256 +    val big_name = space_implode "_" new_type_names;
  17.257 +
  17.258 +
  17.259 +    (**** define permutation functions ****)
  17.260 +
  17.261 +    val permT = mk_permT (TFree ("'x", HOLogic.typeS));
  17.262 +    val pi = Free ("pi", permT);
  17.263 +    val perm_types = map (fn (i, _) =>
  17.264 +      let val T = nth_dtyp i
  17.265 +      in permT --> T --> T end) descr;
  17.266 +    val perm_names' = DatatypeProp.indexify_names (map (fn (i, _) =>
  17.267 +      "perm_" ^ name_of_typ (nth_dtyp i)) descr);
  17.268 +    val perm_names = replicate (length new_type_names) "Nominal.perm" @
  17.269 +      map (Sign.full_bname thy1) (List.drop (perm_names', length new_type_names));
  17.270 +    val perm_names_types = perm_names ~~ perm_types;
  17.271 +    val perm_names_types' = perm_names' ~~ perm_types;
  17.272 +
  17.273 +    val perm_eqs = maps (fn (i, (_, _, constrs)) =>
  17.274 +      let val T = nth_dtyp i
  17.275 +      in map (fn (cname, dts) =>
  17.276 +        let
  17.277 +          val Ts = map (typ_of_dtyp descr sorts) dts;
  17.278 +          val names = Name.variant_list ["pi"] (DatatypeProp.make_tnames Ts);
  17.279 +          val args = map Free (names ~~ Ts);
  17.280 +          val c = Const (cname, Ts ---> T);
  17.281 +          fun perm_arg (dt, x) =
  17.282 +            let val T = type_of x
  17.283 +            in if is_rec_type dt then
  17.284 +                let val (Us, _) = strip_type T
  17.285 +                in list_abs (map (pair "x") Us,
  17.286 +                  Free (nth perm_names_types' (body_index dt)) $ pi $
  17.287 +                    list_comb (x, map (fn (i, U) =>
  17.288 +                      Const ("Nominal.perm", permT --> U --> U) $
  17.289 +                        (Const ("List.rev", permT --> permT) $ pi) $
  17.290 +                        Bound i) ((length Us - 1 downto 0) ~~ Us)))
  17.291 +                end
  17.292 +              else Const ("Nominal.perm", permT --> T --> T) $ pi $ x
  17.293 +            end;
  17.294 +        in
  17.295 +          (Attrib.empty_binding, HOLogic.mk_Trueprop (HOLogic.mk_eq
  17.296 +            (Free (nth perm_names_types' i) $
  17.297 +               Free ("pi", mk_permT (TFree ("'x", HOLogic.typeS))) $
  17.298 +               list_comb (c, args),
  17.299 +             list_comb (c, map perm_arg (dts ~~ args)))))
  17.300 +        end) constrs
  17.301 +      end) descr;
  17.302 +
  17.303 +    val (perm_simps, thy2) =
  17.304 +      Primrec.add_primrec_overloaded
  17.305 +        (map (fn (s, sT) => (s, sT, false))
  17.306 +           (List.take (perm_names' ~~ perm_names_types, length new_type_names)))
  17.307 +        (map (fn s => (Binding.name s, NONE, NoSyn)) perm_names') perm_eqs thy1;
  17.308 +
  17.309 +    (**** prove that permutation functions introduced by unfolding are ****)
  17.310 +    (**** equivalent to already existing permutation functions         ****)
  17.311 +
  17.312 +    val _ = warning ("length descr: " ^ string_of_int (length descr));
  17.313 +    val _ = warning ("length new_type_names: " ^ string_of_int (length new_type_names));
  17.314 +
  17.315 +    val perm_indnames = DatatypeProp.make_tnames (map body_type perm_types);
  17.316 +    val perm_fun_def = PureThy.get_thm thy2 "perm_fun_def";
  17.317 +
  17.318 +    val unfolded_perm_eq_thms =
  17.319 +      if length descr = length new_type_names then []
  17.320 +      else map standard (List.drop (split_conj_thm
  17.321 +        (Goal.prove_global thy2 [] []
  17.322 +          (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  17.323 +            (map (fn (c as (s, T), x) =>
  17.324 +               let val [T1, T2] = binder_types T
  17.325 +               in HOLogic.mk_eq (Const c $ pi $ Free (x, T2),
  17.326 +                 Const ("Nominal.perm", T) $ pi $ Free (x, T2))
  17.327 +               end)
  17.328 +             (perm_names_types ~~ perm_indnames))))
  17.329 +          (fn _ => EVERY [indtac induction perm_indnames 1,
  17.330 +            ALLGOALS (asm_full_simp_tac
  17.331 +              (simpset_of thy2 addsimps [perm_fun_def]))])),
  17.332 +        length new_type_names));
  17.333 +
  17.334 +    (**** prove [] \<bullet> t = t ****)
  17.335 +
  17.336 +    val _ = warning "perm_empty_thms";
  17.337 +
  17.338 +    val perm_empty_thms = List.concat (map (fn a =>
  17.339 +      let val permT = mk_permT (Type (a, []))
  17.340 +      in map standard (List.take (split_conj_thm
  17.341 +        (Goal.prove_global thy2 [] []
  17.342 +          (augment_sort thy2 [pt_class_of thy2 a]
  17.343 +            (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  17.344 +              (map (fn ((s, T), x) => HOLogic.mk_eq
  17.345 +                  (Const (s, permT --> T --> T) $
  17.346 +                     Const ("List.list.Nil", permT) $ Free (x, T),
  17.347 +                   Free (x, T)))
  17.348 +               (perm_names ~~
  17.349 +                map body_type perm_types ~~ perm_indnames)))))
  17.350 +          (fn _ => EVERY [indtac induction perm_indnames 1,
  17.351 +            ALLGOALS (asm_full_simp_tac (simpset_of thy2))])),
  17.352 +        length new_type_names))
  17.353 +      end)
  17.354 +      atoms);
  17.355 +
  17.356 +    (**** prove (pi1 @ pi2) \<bullet> t = pi1 \<bullet> (pi2 \<bullet> t) ****)
  17.357 +
  17.358 +    val _ = warning "perm_append_thms";
  17.359 +
  17.360 +    (*FIXME: these should be looked up statically*)
  17.361 +    val at_pt_inst = PureThy.get_thm thy2 "at_pt_inst";
  17.362 +    val pt2 = PureThy.get_thm thy2 "pt2";
  17.363 +
  17.364 +    val perm_append_thms = List.concat (map (fn a =>
  17.365 +      let
  17.366 +        val permT = mk_permT (Type (a, []));
  17.367 +        val pi1 = Free ("pi1", permT);
  17.368 +        val pi2 = Free ("pi2", permT);
  17.369 +        val pt_inst = pt_inst_of thy2 a;
  17.370 +        val pt2' = pt_inst RS pt2;
  17.371 +        val pt2_ax = PureThy.get_thm thy2 (Long_Name.map_base_name (fn s => "pt_" ^ s ^ "2") a);
  17.372 +      in List.take (map standard (split_conj_thm
  17.373 +        (Goal.prove_global thy2 [] []
  17.374 +           (augment_sort thy2 [pt_class_of thy2 a]
  17.375 +             (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  17.376 +                (map (fn ((s, T), x) =>
  17.377 +                    let val perm = Const (s, permT --> T --> T)
  17.378 +                    in HOLogic.mk_eq
  17.379 +                      (perm $ (Const ("List.append", permT --> permT --> permT) $
  17.380 +                         pi1 $ pi2) $ Free (x, T),
  17.381 +                       perm $ pi1 $ (perm $ pi2 $ Free (x, T)))
  17.382 +                    end)
  17.383 +                  (perm_names ~~
  17.384 +                   map body_type perm_types ~~ perm_indnames)))))
  17.385 +           (fn _ => EVERY [indtac induction perm_indnames 1,
  17.386 +              ALLGOALS (asm_full_simp_tac (simpset_of thy2 addsimps [pt2', pt2_ax]))]))),
  17.387 +         length new_type_names)
  17.388 +      end) atoms);
  17.389 +
  17.390 +    (**** prove pi1 ~ pi2 ==> pi1 \<bullet> t = pi2 \<bullet> t ****)
  17.391 +
  17.392 +    val _ = warning "perm_eq_thms";
  17.393 +
  17.394 +    val pt3 = PureThy.get_thm thy2 "pt3";
  17.395 +    val pt3_rev = PureThy.get_thm thy2 "pt3_rev";
  17.396 +
  17.397 +    val perm_eq_thms = List.concat (map (fn a =>
  17.398 +      let
  17.399 +        val permT = mk_permT (Type (a, []));
  17.400 +        val pi1 = Free ("pi1", permT);
  17.401 +        val pi2 = Free ("pi2", permT);
  17.402 +        val at_inst = at_inst_of thy2 a;
  17.403 +        val pt_inst = pt_inst_of thy2 a;
  17.404 +        val pt3' = pt_inst RS pt3;
  17.405 +        val pt3_rev' = at_inst RS (pt_inst RS pt3_rev);
  17.406 +        val pt3_ax = PureThy.get_thm thy2 (Long_Name.map_base_name (fn s => "pt_" ^ s ^ "3") a);
  17.407 +      in List.take (map standard (split_conj_thm
  17.408 +        (Goal.prove_global thy2 [] []
  17.409 +          (augment_sort thy2 [pt_class_of thy2 a] (Logic.mk_implies
  17.410 +             (HOLogic.mk_Trueprop (Const ("Nominal.prm_eq",
  17.411 +                permT --> permT --> HOLogic.boolT) $ pi1 $ pi2),
  17.412 +              HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  17.413 +                (map (fn ((s, T), x) =>
  17.414 +                    let val perm = Const (s, permT --> T --> T)
  17.415 +                    in HOLogic.mk_eq
  17.416 +                      (perm $ pi1 $ Free (x, T),
  17.417 +                       perm $ pi2 $ Free (x, T))
  17.418 +                    end)
  17.419 +                  (perm_names ~~
  17.420 +                   map body_type perm_types ~~ perm_indnames))))))
  17.421 +           (fn _ => EVERY [indtac induction perm_indnames 1,
  17.422 +              ALLGOALS (asm_full_simp_tac (simpset_of thy2 addsimps [pt3', pt3_rev', pt3_ax]))]))),
  17.423 +         length new_type_names)
  17.424 +      end) atoms);
  17.425 +
  17.426 +    (**** prove pi1 \<bullet> (pi2 \<bullet> t) = (pi1 \<bullet> pi2) \<bullet> (pi1 \<bullet> t) ****)
  17.427 +
  17.428 +    val cp1 = PureThy.get_thm thy2 "cp1";
  17.429 +    val dj_cp = PureThy.get_thm thy2 "dj_cp";
  17.430 +    val pt_perm_compose = PureThy.get_thm thy2 "pt_perm_compose";
  17.431 +    val pt_perm_compose_rev = PureThy.get_thm thy2 "pt_perm_compose_rev";
  17.432 +    val dj_perm_perm_forget = PureThy.get_thm thy2 "dj_perm_perm_forget";
  17.433 +
  17.434 +    fun composition_instance name1 name2 thy =
  17.435 +      let
  17.436 +        val cp_class = cp_class_of thy name1 name2;
  17.437 +        val pt_class =
  17.438 +          if name1 = name2 then [pt_class_of thy name1]
  17.439 +          else [];
  17.440 +        val permT1 = mk_permT (Type (name1, []));
  17.441 +        val permT2 = mk_permT (Type (name2, []));
  17.442 +        val Ts = map body_type perm_types;
  17.443 +        val cp_inst = cp_inst_of thy name1 name2;
  17.444 +        val simps = simpset_of thy addsimps (perm_fun_def ::
  17.445 +          (if name1 <> name2 then
  17.446 +             let val dj = dj_thm_of thy name2 name1
  17.447 +             in [dj RS (cp_inst RS dj_cp), dj RS dj_perm_perm_forget] end
  17.448 +           else
  17.449 +             let
  17.450 +               val at_inst = at_inst_of thy name1;
  17.451 +               val pt_inst = pt_inst_of thy name1;
  17.452 +             in
  17.453 +               [cp_inst RS cp1 RS sym,
  17.454 +                at_inst RS (pt_inst RS pt_perm_compose) RS sym,
  17.455 +                at_inst RS (pt_inst RS pt_perm_compose_rev) RS sym]
  17.456 +            end))
  17.457 +        val sort = Sign.certify_sort thy (cp_class :: pt_class);
  17.458 +        val thms = split_conj_thm (Goal.prove_global thy [] []
  17.459 +          (augment_sort thy sort
  17.460 +            (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  17.461 +              (map (fn ((s, T), x) =>
  17.462 +                  let
  17.463 +                    val pi1 = Free ("pi1", permT1);
  17.464 +                    val pi2 = Free ("pi2", permT2);
  17.465 +                    val perm1 = Const (s, permT1 --> T --> T);
  17.466 +                    val perm2 = Const (s, permT2 --> T --> T);
  17.467 +                    val perm3 = Const ("Nominal.perm", permT1 --> permT2 --> permT2)
  17.468 +                  in HOLogic.mk_eq
  17.469 +                    (perm1 $ pi1 $ (perm2 $ pi2 $ Free (x, T)),
  17.470 +                     perm2 $ (perm3 $ pi1 $ pi2) $ (perm1 $ pi1 $ Free (x, T)))
  17.471 +                  end)
  17.472 +                (perm_names ~~ Ts ~~ perm_indnames)))))
  17.473 +          (fn _ => EVERY [indtac induction perm_indnames 1,
  17.474 +             ALLGOALS (asm_full_simp_tac simps)]))
  17.475 +      in
  17.476 +        fold (fn (s, tvs) => fn thy => AxClass.prove_arity
  17.477 +            (s, map (inter_sort thy sort o snd) tvs, [cp_class])
  17.478 +            (Class.intro_classes_tac [] THEN ALLGOALS (resolve_tac thms)) thy)
  17.479 +          (full_new_type_names' ~~ tyvars) thy
  17.480 +      end;
  17.481 +
  17.482 +    val (perm_thmss,thy3) = thy2 |>
  17.483 +      fold (fn name1 => fold (composition_instance name1) atoms) atoms |>
  17.484 +      fold (fn atom => fn thy =>
  17.485 +        let val pt_name = pt_class_of thy atom
  17.486 +        in
  17.487 +          fold (fn (s, tvs) => fn thy => AxClass.prove_arity
  17.488 +              (s, map (inter_sort thy [pt_name] o snd) tvs, [pt_name])
  17.489 +              (EVERY
  17.490 +                [Class.intro_classes_tac [],
  17.491 +                 resolve_tac perm_empty_thms 1,
  17.492 +                 resolve_tac perm_append_thms 1,
  17.493 +                 resolve_tac perm_eq_thms 1, assume_tac 1]) thy)
  17.494 +            (full_new_type_names' ~~ tyvars) thy
  17.495 +        end) atoms |>
  17.496 +      PureThy.add_thmss
  17.497 +        [((Binding.name (space_implode "_" new_type_names ^ "_unfolded_perm_eq"),
  17.498 +          unfolded_perm_eq_thms), [Simplifier.simp_add]),
  17.499 +         ((Binding.name (space_implode "_" new_type_names ^ "_perm_empty"),
  17.500 +          perm_empty_thms), [Simplifier.simp_add]),
  17.501 +         ((Binding.name (space_implode "_" new_type_names ^ "_perm_append"),
  17.502 +          perm_append_thms), [Simplifier.simp_add]),
  17.503 +         ((Binding.name (space_implode "_" new_type_names ^ "_perm_eq"),
  17.504 +          perm_eq_thms), [Simplifier.simp_add])];
  17.505 +
  17.506 +    (**** Define representing sets ****)
  17.507 +
  17.508 +    val _ = warning "representing sets";
  17.509 +
  17.510 +    val rep_set_names = DatatypeProp.indexify_names
  17.511 +      (map (fn (i, _) => name_of_typ (nth_dtyp i) ^ "_set") descr);
  17.512 +    val big_rep_name =
  17.513 +      space_implode "_" (DatatypeProp.indexify_names (List.mapPartial
  17.514 +        (fn (i, ("Nominal.noption", _, _)) => NONE
  17.515 +          | (i, _) => SOME (name_of_typ (nth_dtyp i))) descr)) ^ "_set";
  17.516 +    val _ = warning ("big_rep_name: " ^ big_rep_name);
  17.517 +
  17.518 +    fun strip_option (dtf as DtType ("fun", [dt, DtRec i])) =
  17.519 +          (case AList.lookup op = descr i of
  17.520 +             SOME ("Nominal.noption", _, [(_, [dt']), _]) =>
  17.521 +               apfst (cons dt) (strip_option dt')
  17.522 +           | _ => ([], dtf))
  17.523 +      | strip_option (DtType ("fun", [dt, DtType ("Nominal.noption", [dt'])])) =
  17.524 +          apfst (cons dt) (strip_option dt')
  17.525 +      | strip_option dt = ([], dt);
  17.526 +
  17.527 +    val dt_atomTs = distinct op = (map (typ_of_dtyp descr sorts)
  17.528 +      (List.concat (map (fn (_, (_, _, cs)) => List.concat
  17.529 +        (map (List.concat o map (fst o strip_option) o snd) cs)) descr)));
  17.530 +    val dt_atoms = map (fst o dest_Type) dt_atomTs;
  17.531 +
  17.532 +    fun make_intr s T (cname, cargs) =
  17.533 +      let
  17.534 +        fun mk_prem (dt, (j, j', prems, ts)) =
  17.535 +          let
  17.536 +            val (dts, dt') = strip_option dt;
  17.537 +            val (dts', dt'') = strip_dtyp dt';
  17.538 +            val Ts = map (typ_of_dtyp descr sorts) dts;
  17.539 +            val Us = map (typ_of_dtyp descr sorts) dts';
  17.540 +            val T = typ_of_dtyp descr sorts dt'';
  17.541 +            val free = mk_Free "x" (Us ---> T) j;
  17.542 +            val free' = app_bnds free (length Us);
  17.543 +            fun mk_abs_fun (T, (i, t)) =
  17.544 +              let val U = fastype_of t
  17.545 +              in (i + 1, Const ("Nominal.abs_fun", [T, U, T] --->
  17.546 +                Type ("Nominal.noption", [U])) $ mk_Free "y" T i $ t)
  17.547 +              end
  17.548 +          in (j + 1, j' + length Ts,
  17.549 +            case dt'' of
  17.550 +                DtRec k => list_all (map (pair "x") Us,
  17.551 +                  HOLogic.mk_Trueprop (Free (List.nth (rep_set_names, k),
  17.552 +                    T --> HOLogic.boolT) $ free')) :: prems
  17.553 +              | _ => prems,
  17.554 +            snd (List.foldr mk_abs_fun (j', free) Ts) :: ts)
  17.555 +          end;
  17.556 +
  17.557 +        val (_, _, prems, ts) = List.foldr mk_prem (1, 1, [], []) cargs;
  17.558 +        val concl = HOLogic.mk_Trueprop (Free (s, T --> HOLogic.boolT) $
  17.559 +          list_comb (Const (cname, map fastype_of ts ---> T), ts))
  17.560 +      in Logic.list_implies (prems, concl)
  17.561 +      end;
  17.562 +
  17.563 +    val (intr_ts, (rep_set_names', recTs')) =
  17.564 +      apfst List.concat (apsnd ListPair.unzip (ListPair.unzip (List.mapPartial
  17.565 +        (fn ((_, ("Nominal.noption", _, _)), _) => NONE
  17.566 +          | ((i, (_, _, constrs)), rep_set_name) =>
  17.567 +              let val T = nth_dtyp i
  17.568 +              in SOME (map (make_intr rep_set_name T) constrs,
  17.569 +                (rep_set_name, T))
  17.570 +              end)
  17.571 +                (descr ~~ rep_set_names))));
  17.572 +    val rep_set_names'' = map (Sign.full_bname thy3) rep_set_names';
  17.573 +
  17.574 +    val ({raw_induct = rep_induct, intrs = rep_intrs, ...}, thy4) =
  17.575 +        Inductive.add_inductive_global (serial_string ())
  17.576 +          {quiet_mode = false, verbose = false, kind = Thm.internalK,
  17.577 +           alt_name = Binding.name big_rep_name, coind = false, no_elim = true, no_ind = false,
  17.578 +           skip_mono = true, fork_mono = false}
  17.579 +          (map (fn (s, T) => ((Binding.name s, T --> HOLogic.boolT), NoSyn))
  17.580 +             (rep_set_names' ~~ recTs'))
  17.581 +          [] (map (fn x => (Attrib.empty_binding, x)) intr_ts) [] thy3;
  17.582 +
  17.583 +    (**** Prove that representing set is closed under permutation ****)
  17.584 +
  17.585 +    val _ = warning "proving closure under permutation...";
  17.586 +
  17.587 +    val abs_perm = PureThy.get_thms thy4 "abs_perm";
  17.588 +
  17.589 +    val perm_indnames' = List.mapPartial
  17.590 +      (fn (x, (_, ("Nominal.noption", _, _))) => NONE | (x, _) => SOME x)
  17.591 +      (perm_indnames ~~ descr);
  17.592 +
  17.593 +    fun mk_perm_closed name = map (fn th => standard (th RS mp))
  17.594 +      (List.take (split_conj_thm (Goal.prove_global thy4 [] []
  17.595 +        (augment_sort thy4
  17.596 +          (pt_class_of thy4 name :: map (cp_class_of thy4 name) (dt_atoms \ name))
  17.597 +          (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map
  17.598 +            (fn ((s, T), x) =>
  17.599 +               let
  17.600 +                 val S = Const (s, T --> HOLogic.boolT);
  17.601 +                 val permT = mk_permT (Type (name, []))
  17.602 +               in HOLogic.mk_imp (S $ Free (x, T),
  17.603 +                 S $ (Const ("Nominal.perm", permT --> T --> T) $
  17.604 +                   Free ("pi", permT) $ Free (x, T)))
  17.605 +               end) (rep_set_names'' ~~ recTs' ~~ perm_indnames')))))
  17.606 +        (fn _ => EVERY
  17.607 +           [indtac rep_induct [] 1,
  17.608 +            ALLGOALS (simp_tac (simpset_of thy4 addsimps
  17.609 +              (symmetric perm_fun_def :: abs_perm))),
  17.610 +            ALLGOALS (resolve_tac rep_intrs THEN_ALL_NEW assume_tac)])),
  17.611 +        length new_type_names));
  17.612 +
  17.613 +    val perm_closed_thmss = map mk_perm_closed atoms;
  17.614 +
  17.615 +    (**** typedef ****)
  17.616 +
  17.617 +    val _ = warning "defining type...";
  17.618 +
  17.619 +    val (typedefs, thy6) =
  17.620 +      thy4
  17.621 +      |> fold_map (fn ((((name, mx), tvs), (cname, U)), name') => fn thy =>
  17.622 +          Typedef.add_typedef false (SOME (Binding.name name'))
  17.623 +            (Binding.name name, map fst tvs, mx)
  17.624 +            (Const ("Collect", (U --> HOLogic.boolT) --> HOLogic.mk_setT U) $
  17.625 +               Const (cname, U --> HOLogic.boolT)) NONE
  17.626 +            (rtac exI 1 THEN rtac CollectI 1 THEN
  17.627 +              QUIET_BREADTH_FIRST (has_fewer_prems 1)
  17.628 +              (resolve_tac rep_intrs 1)) thy |> (fn ((_, r), thy) =>
  17.629 +        let
  17.630 +          val permT = mk_permT
  17.631 +            (TFree (Name.variant (map fst tvs) "'a", HOLogic.typeS));
  17.632 +          val pi = Free ("pi", permT);
  17.633 +          val T = Type (Sign.intern_type thy name, map TFree tvs);
  17.634 +        in apfst (pair r o hd)
  17.635 +          (PureThy.add_defs_unchecked true [((Binding.name ("prm_" ^ name ^ "_def"), Logic.mk_equals
  17.636 +            (Const ("Nominal.perm", permT --> T --> T) $ pi $ Free ("x", T),
  17.637 +             Const (Sign.intern_const thy ("Abs_" ^ name), U --> T) $
  17.638 +               (Const ("Nominal.perm", permT --> U --> U) $ pi $
  17.639 +                 (Const (Sign.intern_const thy ("Rep_" ^ name), T --> U) $
  17.640 +                   Free ("x", T))))), [])] thy)
  17.641 +        end))
  17.642 +          (types_syntax ~~ tyvars ~~
  17.643 +            List.take (rep_set_names'' ~~ recTs', length new_type_names) ~~
  17.644 +            new_type_names);
  17.645 +
  17.646 +    val perm_defs = map snd typedefs;
  17.647 +    val Abs_inverse_thms = map (collect_simp o #Abs_inverse o fst) typedefs;
  17.648 +    val Rep_inverse_thms = map (#Rep_inverse o fst) typedefs;
  17.649 +    val Rep_thms = map (collect_simp o #Rep o fst) typedefs;
  17.650 +
  17.651 +
  17.652 +    (** prove that new types are in class pt_<name> **)
  17.653 +
  17.654 +    val _ = warning "prove that new types are in class pt_<name> ...";
  17.655 +
  17.656 +    fun pt_instance (atom, perm_closed_thms) =
  17.657 +      fold (fn ((((((Abs_inverse, Rep_inverse), Rep),
  17.658 +        perm_def), name), tvs), perm_closed) => fn thy =>
  17.659 +          let
  17.660 +            val pt_class = pt_class_of thy atom;
  17.661 +            val sort = Sign.certify_sort thy
  17.662 +              (pt_class :: map (cp_class_of thy atom) (dt_atoms \ atom))
  17.663 +          in AxClass.prove_arity
  17.664 +            (Sign.intern_type thy name,
  17.665 +              map (inter_sort thy sort o snd) tvs, [pt_class])
  17.666 +            (EVERY [Class.intro_classes_tac [],
  17.667 +              rewrite_goals_tac [perm_def],
  17.668 +              asm_full_simp_tac (simpset_of thy addsimps [Rep_inverse]) 1,
  17.669 +              asm_full_simp_tac (simpset_of thy addsimps
  17.670 +                [Rep RS perm_closed RS Abs_inverse]) 1,
  17.671 +              asm_full_simp_tac (HOL_basic_ss addsimps [PureThy.get_thm thy
  17.672 +                ("pt_" ^ Long_Name.base_name atom ^ "3")]) 1]) thy
  17.673 +          end)
  17.674 +        (Abs_inverse_thms ~~ Rep_inverse_thms ~~ Rep_thms ~~ perm_defs ~~
  17.675 +           new_type_names ~~ tyvars ~~ perm_closed_thms);
  17.676 +
  17.677 +
  17.678 +    (** prove that new types are in class cp_<name1>_<name2> **)
  17.679 +
  17.680 +    val _ = warning "prove that new types are in class cp_<name1>_<name2> ...";
  17.681 +
  17.682 +    fun cp_instance (atom1, perm_closed_thms1) (atom2, perm_closed_thms2) thy =
  17.683 +      let
  17.684 +        val cp_class = cp_class_of thy atom1 atom2;
  17.685 +        val sort = Sign.certify_sort thy
  17.686 +          (pt_class_of thy atom1 :: map (cp_class_of thy atom1) (dt_atoms \ atom1) @
  17.687 +           (if atom1 = atom2 then [cp_class_of thy atom1 atom1] else
  17.688 +            pt_class_of thy atom2 :: map (cp_class_of thy atom2) (dt_atoms \ atom2)));
  17.689 +        val cp1' = cp_inst_of thy atom1 atom2 RS cp1
  17.690 +      in fold (fn ((((((Abs_inverse, Rep),
  17.691 +        perm_def), name), tvs), perm_closed1), perm_closed2) => fn thy =>
  17.692 +          AxClass.prove_arity
  17.693 +            (Sign.intern_type thy name,
  17.694 +              map (inter_sort thy sort o snd) tvs, [cp_class])
  17.695 +            (EVERY [Class.intro_classes_tac [],
  17.696 +              rewrite_goals_tac [perm_def],
  17.697 +              asm_full_simp_tac (simpset_of thy addsimps
  17.698 +                ((Rep RS perm_closed1 RS Abs_inverse) ::
  17.699 +                 (if atom1 = atom2 then []
  17.700 +                  else [Rep RS perm_closed2 RS Abs_inverse]))) 1,
  17.701 +              cong_tac 1,
  17.702 +              rtac refl 1,
  17.703 +              rtac cp1' 1]) thy)
  17.704 +        (Abs_inverse_thms ~~ Rep_thms ~~ perm_defs ~~ new_type_names ~~
  17.705 +           tyvars ~~ perm_closed_thms1 ~~ perm_closed_thms2) thy
  17.706 +      end;
  17.707 +
  17.708 +    val thy7 = fold (fn x => fn thy => thy |>
  17.709 +      pt_instance x |>
  17.710 +      fold (cp_instance x) (atoms ~~ perm_closed_thmss))
  17.711 +        (atoms ~~ perm_closed_thmss) thy6;
  17.712 +
  17.713 +    (**** constructors ****)
  17.714 +
  17.715 +    fun mk_abs_fun (x, t) =
  17.716 +      let
  17.717 +        val T = fastype_of x;
  17.718 +        val U = fastype_of t
  17.719 +      in
  17.720 +        Const ("Nominal.abs_fun", T --> U --> T -->
  17.721 +          Type ("Nominal.noption", [U])) $ x $ t
  17.722 +      end;
  17.723 +
  17.724 +    val (ty_idxs, _) = List.foldl
  17.725 +      (fn ((i, ("Nominal.noption", _, _)), p) => p
  17.726 +        | ((i, _), (ty_idxs, j)) => (ty_idxs @ [(i, j)], j + 1)) ([], 0) descr;
  17.727 +
  17.728 +    fun reindex (DtType (s, dts)) = DtType (s, map reindex dts)
  17.729 +      | reindex (DtRec i) = DtRec (the (AList.lookup op = ty_idxs i))
  17.730 +      | reindex dt = dt;
  17.731 +
  17.732 +    fun strip_suffix i s = implode (List.take (explode s, size s - i));
  17.733 +
  17.734 +    (** strips the "_Rep" in type names *)
  17.735 +    fun strip_nth_name i s =
  17.736 +      let val xs = Long_Name.explode s;
  17.737 +      in Long_Name.implode (Library.nth_map (length xs - i) (strip_suffix 4) xs) end;
  17.738 +
  17.739 +    val (descr'', ndescr) = ListPair.unzip (map_filter
  17.740 +      (fn (i, ("Nominal.noption", _, _)) => NONE
  17.741 +        | (i, (s, dts, constrs)) =>
  17.742 +             let
  17.743 +               val SOME index = AList.lookup op = ty_idxs i;
  17.744 +               val (constrs2, constrs1) =
  17.745 +                 map_split (fn (cname, cargs) =>
  17.746 +                   apsnd (pair (strip_nth_name 2 (strip_nth_name 1 cname)))
  17.747 +                   (fold_map (fn dt => fn dts =>
  17.748 +                     let val (dts', dt') = strip_option dt
  17.749 +                     in ((length dts, length dts'), dts @ dts' @ [reindex dt']) end)
  17.750 +                       cargs [])) constrs
  17.751 +             in SOME ((index, (strip_nth_name 1 s,  map reindex dts, constrs1)),
  17.752 +               (index, constrs2))
  17.753 +             end) descr);
  17.754 +
  17.755 +    val (descr1, descr2) = chop (length new_type_names) descr'';
  17.756 +    val descr' = [descr1, descr2];
  17.757 +
  17.758 +    fun partition_cargs idxs xs = map (fn (i, j) =>
  17.759 +      (List.take (List.drop (xs, i), j), List.nth (xs, i + j))) idxs;
  17.760 +
  17.761 +    val pdescr = map (fn ((i, (s, dts, constrs)), (_, idxss)) => (i, (s, dts,
  17.762 +      map (fn ((cname, cargs), idxs) => (cname, partition_cargs idxs cargs))
  17.763 +        (constrs ~~ idxss)))) (descr'' ~~ ndescr);
  17.764 +
  17.765 +    fun nth_dtyp' i = typ_of_dtyp descr'' sorts (DtRec i);
  17.766 +
  17.767 +    val rep_names = map (fn s =>
  17.768 +      Sign.intern_const thy7 ("Rep_" ^ s)) new_type_names;
  17.769 +    val abs_names = map (fn s =>
  17.770 +      Sign.intern_const thy7 ("Abs_" ^ s)) new_type_names;
  17.771 +
  17.772 +    val recTs = get_rec_types descr'' sorts;
  17.773 +    val newTs' = Library.take (length new_type_names, recTs');
  17.774 +    val newTs = Library.take (length new_type_names, recTs);
  17.775 +
  17.776 +    val full_new_type_names = map (Sign.full_bname thy) new_type_names;
  17.777 +
  17.778 +    fun make_constr_def tname T T' ((thy, defs, eqns),
  17.779 +        (((cname_rep, _), (cname, cargs)), (cname', mx))) =
  17.780 +      let
  17.781 +        fun constr_arg ((dts, dt), (j, l_args, r_args)) =
  17.782 +          let
  17.783 +            val xs = map (fn (dt, i) => mk_Free "x" (typ_of_dtyp descr'' sorts dt) i)
  17.784 +              (dts ~~ (j upto j + length dts - 1))
  17.785 +            val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts)
  17.786 +          in
  17.787 +            (j + length dts + 1,
  17.788 +             xs @ x :: l_args,
  17.789 +             List.foldr mk_abs_fun
  17.790 +               (case dt of
  17.791 +                  DtRec k => if k < length new_type_names then
  17.792 +                      Const (List.nth (rep_names, k), typ_of_dtyp descr'' sorts dt -->
  17.793 +                        typ_of_dtyp descr sorts dt) $ x
  17.794 +                    else error "nested recursion not (yet) supported"
  17.795 +                | _ => x) xs :: r_args)
  17.796 +          end
  17.797 +
  17.798 +        val (_, l_args, r_args) = List.foldr constr_arg (1, [], []) cargs;
  17.799 +        val abs_name = Sign.intern_const thy ("Abs_" ^ tname);
  17.800 +        val rep_name = Sign.intern_const thy ("Rep_" ^ tname);
  17.801 +        val constrT = map fastype_of l_args ---> T;
  17.802 +        val lhs = list_comb (Const (cname, constrT), l_args);
  17.803 +        val rhs = list_comb (Const (cname_rep, map fastype_of r_args ---> T'), r_args);
  17.804 +        val def = Logic.mk_equals (lhs, Const (abs_name, T' --> T) $ rhs);
  17.805 +        val eqn = HOLogic.mk_Trueprop (HOLogic.mk_eq
  17.806 +          (Const (rep_name, T --> T') $ lhs, rhs));
  17.807 +        val def_name = (Long_Name.base_name cname) ^ "_def";
  17.808 +        val ([def_thm], thy') = thy |>
  17.809 +          Sign.add_consts_i [(Binding.name cname', constrT, mx)] |>
  17.810 +          (PureThy.add_defs false o map Thm.no_attributes) [(Binding.name def_name, def)]
  17.811 +      in (thy', defs @ [def_thm], eqns @ [eqn]) end;
  17.812 +
  17.813 +    fun dt_constr_defs ((thy, defs, eqns, dist_lemmas), ((((((_, (_, _, constrs)),
  17.814 +        (_, (_, _, constrs'))), tname), T), T'), constr_syntax)) =
  17.815 +      let
  17.816 +        val rep_const = cterm_of thy
  17.817 +          (Const (Sign.intern_const thy ("Rep_" ^ tname), T --> T'));
  17.818 +        val dist = standard (cterm_instantiate [(cterm_of thy distinct_f, rep_const)] distinct_lemma);
  17.819 +        val (thy', defs', eqns') = Library.foldl (make_constr_def tname T T')
  17.820 +          ((Sign.add_path tname thy, defs, []), constrs ~~ constrs' ~~ constr_syntax)
  17.821 +      in
  17.822 +        (parent_path (#flat_names config) thy', defs', eqns @ [eqns'], dist_lemmas @ [dist])
  17.823 +      end;
  17.824 +
  17.825 +    val (thy8, constr_defs, constr_rep_eqns, dist_lemmas) = Library.foldl dt_constr_defs
  17.826 +      ((thy7, [], [], []), List.take (descr, length new_type_names) ~~
  17.827 +        List.take (pdescr, length new_type_names) ~~
  17.828 +        new_type_names ~~ newTs ~~ newTs' ~~ constr_syntax);
  17.829 +
  17.830 +    val abs_inject_thms = map (collect_simp o #Abs_inject o fst) typedefs
  17.831 +    val rep_inject_thms = map (#Rep_inject o fst) typedefs
  17.832 +
  17.833 +    (* prove theorem  Rep_i (Constr_j ...) = Constr'_j ...  *)
  17.834 +
  17.835 +    fun prove_constr_rep_thm eqn =
  17.836 +      let
  17.837 +        val inj_thms = map (fn r => r RS iffD1) abs_inject_thms;
  17.838 +        val rewrites = constr_defs @ map mk_meta_eq Rep_inverse_thms
  17.839 +      in Goal.prove_global thy8 [] [] eqn (fn _ => EVERY
  17.840 +        [resolve_tac inj_thms 1,
  17.841 +         rewrite_goals_tac rewrites,
  17.842 +         rtac refl 3,
  17.843 +         resolve_tac rep_intrs 2,
  17.844 +         REPEAT (resolve_tac Rep_thms 1)])
  17.845 +      end;
  17.846 +
  17.847 +    val constr_rep_thmss = map (map prove_constr_rep_thm) constr_rep_eqns;
  17.848 +
  17.849 +    (* prove theorem  pi \<bullet> Rep_i x = Rep_i (pi \<bullet> x) *)
  17.850 +
  17.851 +    fun prove_perm_rep_perm (atom, perm_closed_thms) = map (fn th =>
  17.852 +      let
  17.853 +        val _ $ (_ $ (Rep $ x)) = Logic.unvarify (prop_of th);
  17.854 +        val Type ("fun", [T, U]) = fastype_of Rep;
  17.855 +        val permT = mk_permT (Type (atom, []));
  17.856 +        val pi = Free ("pi", permT);
  17.857 +      in
  17.858 +        Goal.prove_global thy8 [] []
  17.859 +          (augment_sort thy8
  17.860 +            (pt_class_of thy8 atom :: map (cp_class_of thy8 atom) (dt_atoms \ atom))
  17.861 +            (HOLogic.mk_Trueprop (HOLogic.mk_eq
  17.862 +              (Const ("Nominal.perm", permT --> U --> U) $ pi $ (Rep $ x),
  17.863 +               Rep $ (Const ("Nominal.perm", permT --> T --> T) $ pi $ x)))))
  17.864 +          (fn _ => simp_tac (HOL_basic_ss addsimps (perm_defs @ Abs_inverse_thms @
  17.865 +            perm_closed_thms @ Rep_thms)) 1)
  17.866 +      end) Rep_thms;
  17.867 +
  17.868 +    val perm_rep_perm_thms = List.concat (map prove_perm_rep_perm
  17.869 +      (atoms ~~ perm_closed_thmss));
  17.870 +
  17.871 +    (* prove distinctness theorems *)
  17.872 +
  17.873 +    val distinct_props = DatatypeProp.make_distincts descr' sorts;
  17.874 +    val dist_rewrites = map2 (fn rep_thms => fn dist_lemma =>
  17.875 +      dist_lemma :: rep_thms @ [In0_eq, In1_eq, In0_not_In1, In1_not_In0])
  17.876 +        constr_rep_thmss dist_lemmas;
  17.877 +
  17.878 +    fun prove_distinct_thms _ (_, []) = []
  17.879 +      | prove_distinct_thms (p as (rep_thms, dist_lemma)) (k, t :: ts) =
  17.880 +          let
  17.881 +            val dist_thm = Goal.prove_global thy8 [] [] t (fn _ =>
  17.882 +              simp_tac (simpset_of thy8 addsimps (dist_lemma :: rep_thms)) 1)
  17.883 +          in dist_thm :: standard (dist_thm RS not_sym) ::
  17.884 +            prove_distinct_thms p (k, ts)
  17.885 +          end;
  17.886 +
  17.887 +    val distinct_thms = map2 prove_distinct_thms
  17.888 +      (constr_rep_thmss ~~ dist_lemmas) distinct_props;
  17.889 +
  17.890 +    (** prove equations for permutation functions **)
  17.891 +
  17.892 +    val perm_simps' = map (fn (((i, (_, _, constrs)), tname), constr_rep_thms) =>
  17.893 +      let val T = nth_dtyp' i
  17.894 +      in List.concat (map (fn (atom, perm_closed_thms) =>
  17.895 +          map (fn ((cname, dts), constr_rep_thm) =>
  17.896 +        let
  17.897 +          val cname = Sign.intern_const thy8
  17.898 +            (Long_Name.append tname (Long_Name.base_name cname));
  17.899 +          val permT = mk_permT (Type (atom, []));
  17.900 +          val pi = Free ("pi", permT);
  17.901 +
  17.902 +          fun perm t =
  17.903 +            let val T = fastype_of t
  17.904 +            in Const ("Nominal.perm", permT --> T --> T) $ pi $ t end;
  17.905 +
  17.906 +          fun constr_arg ((dts, dt), (j, l_args, r_args)) =
  17.907 +            let
  17.908 +              val Ts = map (typ_of_dtyp descr'' sorts) dts;
  17.909 +              val xs = map (fn (T, i) => mk_Free "x" T i)
  17.910 +                (Ts ~~ (j upto j + length dts - 1))
  17.911 +              val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts)
  17.912 +            in
  17.913 +              (j + length dts + 1,
  17.914 +               xs @ x :: l_args,
  17.915 +               map perm (xs @ [x]) @ r_args)
  17.916 +            end
  17.917 +
  17.918 +          val (_, l_args, r_args) = List.foldr constr_arg (1, [], []) dts;
  17.919 +          val c = Const (cname, map fastype_of l_args ---> T)
  17.920 +        in
  17.921 +          Goal.prove_global thy8 [] []
  17.922 +            (augment_sort thy8
  17.923 +              (pt_class_of thy8 atom :: map (cp_class_of thy8 atom) (dt_atoms \ atom))
  17.924 +              (HOLogic.mk_Trueprop (HOLogic.mk_eq
  17.925 +                (perm (list_comb (c, l_args)), list_comb (c, r_args)))))
  17.926 +            (fn _ => EVERY
  17.927 +              [simp_tac (simpset_of thy8 addsimps (constr_rep_thm :: perm_defs)) 1,
  17.928 +               simp_tac (HOL_basic_ss addsimps (Rep_thms @ Abs_inverse_thms @
  17.929 +                 constr_defs @ perm_closed_thms)) 1,
  17.930 +               TRY (simp_tac (HOL_basic_ss addsimps
  17.931 +                 (symmetric perm_fun_def :: abs_perm)) 1),
  17.932 +               TRY (simp_tac (HOL_basic_ss addsimps
  17.933 +                 (perm_fun_def :: perm_defs @ Rep_thms @ Abs_inverse_thms @
  17.934 +                    perm_closed_thms)) 1)])
  17.935 +        end) (constrs ~~ constr_rep_thms)) (atoms ~~ perm_closed_thmss))
  17.936 +      end) (List.take (pdescr, length new_type_names) ~~ new_type_names ~~ constr_rep_thmss);
  17.937 +
  17.938 +    (** prove injectivity of constructors **)
  17.939 +
  17.940 +    val rep_inject_thms' = map (fn th => th RS sym) rep_inject_thms;
  17.941 +    val alpha = PureThy.get_thms thy8 "alpha";
  17.942 +    val abs_fresh = PureThy.get_thms thy8 "abs_fresh";
  17.943 +
  17.944 +    val pt_cp_sort =
  17.945 +      map (pt_class_of thy8) dt_atoms @
  17.946 +      maps (fn s => map (cp_class_of thy8 s) (dt_atoms \ s)) dt_atoms;
  17.947 +
  17.948 +    val inject_thms = map (fn (((i, (_, _, constrs)), tname), constr_rep_thms) =>
  17.949 +      let val T = nth_dtyp' i
  17.950 +      in List.mapPartial (fn ((cname, dts), constr_rep_thm) =>
  17.951 +        if null dts then NONE else SOME
  17.952 +        let
  17.953 +          val cname = Sign.intern_const thy8
  17.954 +            (Long_Name.append tname (Long_Name.base_name cname));
  17.955 +
  17.956 +          fun make_inj ((dts, dt), (j, args1, args2, eqs)) =
  17.957 +            let
  17.958 +              val Ts_idx = map (typ_of_dtyp descr'' sorts) dts ~~ (j upto j + length dts - 1);
  17.959 +              val xs = map (fn (T, i) => mk_Free "x" T i) Ts_idx;
  17.960 +              val ys = map (fn (T, i) => mk_Free "y" T i) Ts_idx;
  17.961 +              val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts);
  17.962 +              val y = mk_Free "y" (typ_of_dtyp descr'' sorts dt) (j + length dts)
  17.963 +            in
  17.964 +              (j + length dts + 1,
  17.965 +               xs @ (x :: args1), ys @ (y :: args2),
  17.966 +               HOLogic.mk_eq
  17.967 +                 (List.foldr mk_abs_fun x xs, List.foldr mk_abs_fun y ys) :: eqs)
  17.968 +            end;
  17.969 +
  17.970 +          val (_, args1, args2, eqs) = List.foldr make_inj (1, [], [], []) dts;
  17.971 +          val Ts = map fastype_of args1;
  17.972 +          val c = Const (cname, Ts ---> T)
  17.973 +        in
  17.974 +          Goal.prove_global thy8 [] []
  17.975 +            (augment_sort thy8 pt_cp_sort
  17.976 +              (HOLogic.mk_Trueprop (HOLogic.mk_eq
  17.977 +                (HOLogic.mk_eq (list_comb (c, args1), list_comb (c, args2)),
  17.978 +                 foldr1 HOLogic.mk_conj eqs))))
  17.979 +            (fn _ => EVERY
  17.980 +               [asm_full_simp_tac (simpset_of thy8 addsimps (constr_rep_thm ::
  17.981 +                  rep_inject_thms')) 1,
  17.982 +                TRY (asm_full_simp_tac (HOL_basic_ss addsimps (fresh_def :: supp_def ::
  17.983 +                  alpha @ abs_perm @ abs_fresh @ rep_inject_thms @
  17.984 +                  perm_rep_perm_thms)) 1)])
  17.985 +        end) (constrs ~~ constr_rep_thms)
  17.986 +      end) (List.take (pdescr, length new_type_names) ~~ new_type_names ~~ constr_rep_thmss);
  17.987 +
  17.988 +    (** equations for support and freshness **)
  17.989 +
  17.990 +    val (supp_thms, fresh_thms) = ListPair.unzip (map ListPair.unzip
  17.991 +      (map (fn ((((i, (_, _, constrs)), tname), inject_thms'), perm_thms') =>
  17.992 +      let val T = nth_dtyp' i
  17.993 +      in List.concat (map (fn (cname, dts) => map (fn atom =>
  17.994 +        let
  17.995 +          val cname = Sign.intern_const thy8
  17.996 +            (Long_Name.append tname (Long_Name.base_name cname));
  17.997 +          val atomT = Type (atom, []);
  17.998 +
  17.999 +          fun process_constr ((dts, dt), (j, args1, args2)) =
 17.1000 +            let
 17.1001 +              val Ts_idx = map (typ_of_dtyp descr'' sorts) dts ~~ (j upto j + length dts - 1);
 17.1002 +              val xs = map (fn (T, i) => mk_Free "x" T i) Ts_idx;
 17.1003 +              val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts)
 17.1004 +            in
 17.1005 +              (j + length dts + 1,
 17.1006 +               xs @ (x :: args1), List.foldr mk_abs_fun x xs :: args2)
 17.1007 +            end;
 17.1008 +
 17.1009 +          val (_, args1, args2) = List.foldr process_constr (1, [], []) dts;
 17.1010 +          val Ts = map fastype_of args1;
 17.1011 +          val c = list_comb (Const (cname, Ts ---> T), args1);
 17.1012 +          fun supp t =
 17.1013 +            Const ("Nominal.supp", fastype_of t --> HOLogic.mk_setT atomT) $ t;
 17.1014 +          fun fresh t = fresh_const atomT (fastype_of t) $ Free ("a", atomT) $ t;
 17.1015 +          val supp_thm = Goal.prove_global thy8 [] []
 17.1016 +            (augment_sort thy8 pt_cp_sort
 17.1017 +              (HOLogic.mk_Trueprop (HOLogic.mk_eq
 17.1018 +                (supp c,
 17.1019 +                 if null dts then HOLogic.mk_set atomT []
 17.1020 +                 else foldr1 (HOLogic.mk_binop @{const_name Un}) (map supp args2)))))
 17.1021 +            (fn _ =>
 17.1022 +              simp_tac (HOL_basic_ss addsimps (supp_def ::
 17.1023 +                 Un_assoc :: de_Morgan_conj :: Collect_disj_eq :: finite_Un ::
 17.1024 +                 symmetric empty_def :: finite_emptyI :: simp_thms @
 17.1025 +                 abs_perm @ abs_fresh @ inject_thms' @ perm_thms')) 1)
 17.1026 +        in
 17.1027 +          (supp_thm,
 17.1028 +           Goal.prove_global thy8 [] [] (augment_sort thy8 pt_cp_sort
 17.1029 +             (HOLogic.mk_Trueprop (HOLogic.mk_eq
 17.1030 +               (fresh c,
 17.1031 +                if null dts then HOLogic.true_const
 17.1032 +                else foldr1 HOLogic.mk_conj (map fresh args2)))))
 17.1033 +             (fn _ =>
 17.1034 +               simp_tac (HOL_ss addsimps [Un_iff, empty_iff, fresh_def, supp_thm]) 1))
 17.1035 +        end) atoms) constrs)
 17.1036 +      end) (List.take (pdescr, length new_type_names) ~~ new_type_names ~~ inject_thms ~~ perm_simps')));
 17.1037 +
 17.1038 +    (**** weak induction theorem ****)
 17.1039 +
 17.1040 +    fun mk_indrule_lemma ((prems, concls), (((i, _), T), U)) =
 17.1041 +      let
 17.1042 +        val Rep_t = Const (List.nth (rep_names, i), T --> U) $
 17.1043 +          mk_Free "x" T i;
 17.1044 +
 17.1045 +        val Abs_t =  Const (List.nth (abs_names, i), U --> T)
 17.1046 +
 17.1047 +      in (prems @ [HOLogic.imp $
 17.1048 +            (Const (List.nth (rep_set_names'', i), U --> HOLogic.boolT) $ Rep_t) $
 17.1049 +              (mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ (Abs_t $ Rep_t))],
 17.1050 +          concls @ [mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ mk_Free "x" T i])
 17.1051 +      end;
 17.1052 +
 17.1053 +    val (indrule_lemma_prems, indrule_lemma_concls) =
 17.1054 +      Library.foldl mk_indrule_lemma (([], []), (descr'' ~~ recTs ~~ recTs'));
 17.1055 +
 17.1056 +    val indrule_lemma = Goal.prove_global thy8 [] []
 17.1057 +      (Logic.mk_implies
 17.1058 +        (HOLogic.mk_Trueprop (mk_conj indrule_lemma_prems),
 17.1059 +         HOLogic.mk_Trueprop (mk_conj indrule_lemma_concls))) (fn _ => EVERY
 17.1060 +           [REPEAT (etac conjE 1),
 17.1061 +            REPEAT (EVERY
 17.1062 +              [TRY (rtac conjI 1), full_simp_tac (HOL_basic_ss addsimps Rep_inverse_thms) 1,
 17.1063 +               etac mp 1, resolve_tac Rep_thms 1])]);
 17.1064 +
 17.1065 +    val Ps = map head_of (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of indrule_lemma)));
 17.1066 +    val frees = if length Ps = 1 then [Free ("P", snd (dest_Var (hd Ps)))] else
 17.1067 +      map (Free o apfst fst o dest_Var) Ps;
 17.1068 +    val indrule_lemma' = cterm_instantiate
 17.1069 +      (map (cterm_of thy8) Ps ~~ map (cterm_of thy8) frees) indrule_lemma;
 17.1070 +
 17.1071 +    val Abs_inverse_thms' = map (fn r => r RS subst) Abs_inverse_thms;
 17.1072 +
 17.1073 +    val dt_induct_prop = DatatypeProp.make_ind descr' sorts;
 17.1074 +    val dt_induct = Goal.prove_global thy8 []
 17.1075 +      (Logic.strip_imp_prems dt_induct_prop) (Logic.strip_imp_concl dt_induct_prop)
 17.1076 +      (fn {prems, ...} => EVERY
 17.1077 +        [rtac indrule_lemma' 1,
 17.1078 +         (indtac rep_induct [] THEN_ALL_NEW ObjectLogic.atomize_prems_tac) 1,
 17.1079 +         EVERY (map (fn (prem, r) => (EVERY
 17.1080 +           [REPEAT (eresolve_tac Abs_inverse_thms' 1),
 17.1081 +            simp_tac (HOL_basic_ss addsimps [symmetric r]) 1,
 17.1082 +            DEPTH_SOLVE_1 (ares_tac [prem] 1 ORELSE etac allE 1)]))
 17.1083 +                (prems ~~ constr_defs))]);
 17.1084 +
 17.1085 +    val case_names_induct = mk_case_names_induct descr'';
 17.1086 +
 17.1087 +    (**** prove that new datatypes have finite support ****)
 17.1088 +
 17.1089 +    val _ = warning "proving finite support for the new datatype";
 17.1090 +
 17.1091 +    val indnames = DatatypeProp.make_tnames recTs;
 17.1092 +
 17.1093 +    val abs_supp = PureThy.get_thms thy8 "abs_supp";
 17.1094 +    val supp_atm = PureThy.get_thms thy8 "supp_atm";
 17.1095 +
 17.1096 +    val finite_supp_thms = map (fn atom =>
 17.1097 +      let val atomT = Type (atom, [])
 17.1098 +      in map standard (List.take
 17.1099 +        (split_conj_thm (Goal.prove_global thy8 [] []
 17.1100 +           (augment_sort thy8 (fs_class_of thy8 atom :: pt_cp_sort)
 17.1101 +             (HOLogic.mk_Trueprop
 17.1102 +               (foldr1 HOLogic.mk_conj (map (fn (s, T) =>
 17.1103 +                 Const ("Finite_Set.finite", HOLogic.mk_setT atomT --> HOLogic.boolT) $
 17.1104 +                   (Const ("Nominal.supp", T --> HOLogic.mk_setT atomT) $ Free (s, T)))
 17.1105 +                   (indnames ~~ recTs)))))
 17.1106 +           (fn _ => indtac dt_induct indnames 1 THEN
 17.1107 +            ALLGOALS (asm_full_simp_tac (simpset_of thy8 addsimps
 17.1108 +              (abs_supp @ supp_atm @
 17.1109 +               PureThy.get_thms thy8 ("fs_" ^ Long_Name.base_name atom ^ "1") @
 17.1110 +               List.concat supp_thms))))),
 17.1111 +         length new_type_names))
 17.1112 +      end) atoms;
 17.1113 +
 17.1114 +    val simp_atts = replicate (length new_type_names) [Simplifier.simp_add];
 17.1115 +
 17.1116 +	(* Function to add both the simp and eqvt attributes *)
 17.1117 +        (* These two attributes are duplicated on all the types in the mutual nominal datatypes *)
 17.1118 +
 17.1119 +    val simp_eqvt_atts = replicate (length new_type_names) [Simplifier.simp_add, NominalThmDecls.eqvt_add];
 17.1120 + 
 17.1121 +    val (_, thy9) = thy8 |>
 17.1122 +      Sign.add_path big_name |>
 17.1123 +      PureThy.add_thms [((Binding.name "induct", dt_induct), [case_names_induct])] ||>>
 17.1124 +      PureThy.add_thmss [((Binding.name "inducts", projections dt_induct), [case_names_induct])] ||>
 17.1125 +      Sign.parent_path ||>>
 17.1126 +      DatatypeAux.store_thmss_atts "distinct" new_type_names simp_atts distinct_thms ||>>
 17.1127 +      DatatypeAux.store_thmss "constr_rep" new_type_names constr_rep_thmss ||>>
 17.1128 +      DatatypeAux.store_thmss_atts "perm" new_type_names simp_eqvt_atts perm_simps' ||>>
 17.1129 +      DatatypeAux.store_thmss "inject" new_type_names inject_thms ||>>
 17.1130 +      DatatypeAux.store_thmss "supp" new_type_names supp_thms ||>>
 17.1131 +      DatatypeAux.store_thmss_atts "fresh" new_type_names simp_atts fresh_thms ||>
 17.1132 +      fold (fn (atom, ths) => fn thy =>
 17.1133 +        let
 17.1134 +          val class = fs_class_of thy atom;
 17.1135 +          val sort = Sign.certify_sort thy (class :: pt_cp_sort)
 17.1136 +        in fold (fn Type (s, Ts) => AxClass.prove_arity
 17.1137 +          (s, map (inter_sort thy sort o snd o dest_TFree) Ts, [class])
 17.1138 +          (Class.intro_classes_tac [] THEN resolve_tac ths 1)) newTs thy
 17.1139 +        end) (atoms ~~ finite_supp_thms);
 17.1140 +
 17.1141 +    (**** strong induction theorem ****)
 17.1142 +
 17.1143 +    val pnames = if length descr'' = 1 then ["P"]
 17.1144 +      else map (fn i => "P" ^ string_of_int i) (1 upto length descr'');
 17.1145 +    val ind_sort = if null dt_atomTs then HOLogic.typeS
 17.1146 +      else Sign.certify_sort thy9 (map (fs_class_of thy9) dt_atoms);
 17.1147 +    val fsT = TFree ("'n", ind_sort);
 17.1148 +    val fsT' = TFree ("'n", HOLogic.typeS);
 17.1149 +
 17.1150 +    val fresh_fs = map (fn (s, T) => (T, Free (s, fsT' --> HOLogic.mk_setT T)))
 17.1151 +      (DatatypeProp.indexify_names (replicate (length dt_atomTs) "f") ~~ dt_atomTs);
 17.1152 +
 17.1153 +    fun make_pred fsT i T =
 17.1154 +      Free (List.nth (pnames, i), fsT --> T --> HOLogic.boolT);
 17.1155 +
 17.1156 +    fun mk_fresh1 xs [] = []
 17.1157 +      | mk_fresh1 xs ((y as (_, T)) :: ys) = map (fn x => HOLogic.mk_Trueprop
 17.1158 +            (HOLogic.mk_not (HOLogic.mk_eq (Free y, Free x))))
 17.1159 +              (filter (fn (_, U) => T = U) (rev xs)) @
 17.1160 +          mk_fresh1 (y :: xs) ys;
 17.1161 +
 17.1162 +    fun mk_fresh2 xss [] = []
 17.1163 +      | mk_fresh2 xss ((p as (ys, _)) :: yss) = List.concat (map (fn y as (_, T) =>
 17.1164 +            map (fn (_, x as (_, U)) => HOLogic.mk_Trueprop
 17.1165 +              (fresh_const T U $ Free y $ Free x)) (rev xss @ yss)) ys) @
 17.1166 +          mk_fresh2 (p :: xss) yss;
 17.1167 +
 17.1168 +    fun make_ind_prem fsT f k T ((cname, cargs), idxs) =
 17.1169 +      let
 17.1170 +        val recs = List.filter is_rec_type cargs;
 17.1171 +        val Ts = map (typ_of_dtyp descr'' sorts) cargs;
 17.1172 +        val recTs' = map (typ_of_dtyp descr'' sorts) recs;
 17.1173 +        val tnames = Name.variant_list pnames (DatatypeProp.make_tnames Ts);
 17.1174 +        val rec_tnames = map fst (List.filter (is_rec_type o snd) (tnames ~~ cargs));
 17.1175 +        val frees = tnames ~~ Ts;
 17.1176 +        val frees' = partition_cargs idxs frees;
 17.1177 +        val z = (Name.variant tnames "z", fsT);
 17.1178 +
 17.1179 +        fun mk_prem ((dt, s), T) =
 17.1180 +          let
 17.1181 +            val (Us, U) = strip_type T;
 17.1182 +            val l = length Us
 17.1183 +          in list_all (z :: map (pair "x") Us, HOLogic.mk_Trueprop
 17.1184 +            (make_pred fsT (body_index dt) U $ Bound l $ app_bnds (Free (s, T)) l))
 17.1185 +          end;
 17.1186 +
 17.1187 +        val prems = map mk_prem (recs ~~ rec_tnames ~~ recTs');
 17.1188 +        val prems' = map (fn p as (_, T) => HOLogic.mk_Trueprop
 17.1189 +            (f T (Free p) (Free z))) (List.concat (map fst frees')) @
 17.1190 +          mk_fresh1 [] (List.concat (map fst frees')) @
 17.1191 +          mk_fresh2 [] frees'
 17.1192 +
 17.1193 +      in list_all_free (frees @ [z], Logic.list_implies (prems' @ prems,
 17.1194 +        HOLogic.mk_Trueprop (make_pred fsT k T $ Free z $
 17.1195 +          list_comb (Const (cname, Ts ---> T), map Free frees))))
 17.1196 +      end;
 17.1197 +
 17.1198 +    val ind_prems = List.concat (map (fn (((i, (_, _, constrs)), (_, idxss)), T) =>
 17.1199 +      map (make_ind_prem fsT (fn T => fn t => fn u =>
 17.1200 +        fresh_const T fsT $ t $ u) i T)
 17.1201 +          (constrs ~~ idxss)) (descr'' ~~ ndescr ~~ recTs));
 17.1202 +    val tnames = DatatypeProp.make_tnames recTs;
 17.1203 +    val zs = Name.variant_list tnames (replicate (length descr'') "z");
 17.1204 +    val ind_concl = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop "op &")
 17.1205 +      (map (fn ((((i, _), T), tname), z) =>
 17.1206 +        make_pred fsT i T $ Free (z, fsT) $ Free (tname, T))
 17.1207 +        (descr'' ~~ recTs ~~ tnames ~~ zs)));
 17.1208 +    val induct = Logic.list_implies (ind_prems, ind_concl);
 17.1209 +
 17.1210 +    val ind_prems' =
 17.1211 +      map (fn (_, f as Free (_, T)) => list_all_free ([("x", fsT')],
 17.1212 +        HOLogic.mk_Trueprop (Const ("Finite_Set.finite",
 17.1213 +          (snd (split_last (binder_types T)) --> HOLogic.boolT) -->
 17.1214 +            HOLogic.boolT) $ (f $ Free ("x", fsT'))))) fresh_fs @
 17.1215 +      List.concat (map (fn (((i, (_, _, constrs)), (_, idxss)), T) =>
 17.1216 +        map (make_ind_prem fsT' (fn T => fn t => fn u => HOLogic.Not $
 17.1217 +          HOLogic.mk_mem (t, the (AList.lookup op = fresh_fs T) $ u)) i T)
 17.1218 +            (constrs ~~ idxss)) (descr'' ~~ ndescr ~~ recTs));
 17.1219 +    val ind_concl' = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop "op &")
 17.1220 +      (map (fn ((((i, _), T), tname), z) =>
 17.1221 +        make_pred fsT' i T $ Free (z, fsT') $ Free (tname, T))
 17.1222 +        (descr'' ~~ recTs ~~ tnames ~~ zs)));
 17.1223 +    val induct' = Logic.list_implies (ind_prems', ind_concl');
 17.1224 +
 17.1225 +    val aux_ind_vars =
 17.1226 +      (DatatypeProp.indexify_names (replicate (length dt_atomTs) "pi") ~~
 17.1227 +       map mk_permT dt_atomTs) @ [("z", fsT')];
 17.1228 +    val aux_ind_Ts = rev (map snd aux_ind_vars);
 17.1229 +    val aux_ind_concl = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop "op &")
 17.1230 +      (map (fn (((i, _), T), tname) =>
 17.1231 +        HOLogic.list_all (aux_ind_vars, make_pred fsT' i T $ Bound 0 $
 17.1232 +          fold_rev (mk_perm aux_ind_Ts) (map Bound (length dt_atomTs downto 1))
 17.1233 +            (Free (tname, T))))
 17.1234 +        (descr'' ~~ recTs ~~ tnames)));
 17.1235 +
 17.1236 +    val fin_set_supp = map (fn s =>
 17.1237 +      at_inst_of thy9 s RS at_fin_set_supp) dt_atoms;
 17.1238 +    val fin_set_fresh = map (fn s =>
 17.1239 +      at_inst_of thy9 s RS at_fin_set_fresh) dt_atoms;
 17.1240 +    val pt1_atoms = map (fn Type (s, _) =>
 17.1241 +      PureThy.get_thm thy9 ("pt_" ^ Long_Name.base_name s ^ "1")) dt_atomTs;
 17.1242 +    val pt2_atoms = map (fn Type (s, _) =>
 17.1243 +      PureThy.get_thm thy9 ("pt_" ^ Long_Name.base_name s ^ "2") RS sym) dt_atomTs;
 17.1244 +    val exists_fresh' = PureThy.get_thms thy9 "exists_fresh'";
 17.1245 +    val fs_atoms = PureThy.get_thms thy9 "fin_supp";
 17.1246 +    val abs_supp = PureThy.get_thms thy9 "abs_supp";
 17.1247 +    val perm_fresh_fresh = PureThy.get_thms thy9 "perm_fresh_fresh";
 17.1248 +    val calc_atm = PureThy.get_thms thy9 "calc_atm";
 17.1249 +    val fresh_atm = PureThy.get_thms thy9 "fresh_atm";
 17.1250 +    val fresh_left = PureThy.get_thms thy9 "fresh_left";
 17.1251 +    val perm_swap = PureThy.get_thms thy9 "perm_swap";
 17.1252 +
 17.1253 +    fun obtain_fresh_name' ths ts T (freshs1, freshs2, ctxt) =
 17.1254 +      let
 17.1255 +        val p = foldr1 HOLogic.mk_prod (ts @ freshs1);
 17.1256 +        val ex = Goal.prove ctxt [] [] (HOLogic.mk_Trueprop
 17.1257 +            (HOLogic.exists_const T $ Abs ("x", T,
 17.1258 +              fresh_const T (fastype_of p) $
 17.1259 +                Bound 0 $ p)))
 17.1260 +          (fn _ => EVERY
 17.1261 +            [resolve_tac exists_fresh' 1,
 17.1262 +             simp_tac (HOL_ss addsimps (supp_prod :: finite_Un :: fs_atoms @
 17.1263 +               fin_set_supp @ ths)) 1]);
 17.1264 +        val (([cx], ths), ctxt') = Obtain.result
 17.1265 +          (fn _ => EVERY
 17.1266 +            [etac exE 1,
 17.1267 +             full_simp_tac (HOL_ss addsimps (fresh_prod :: fresh_atm)) 1,
 17.1268 +             REPEAT (etac conjE 1)])
 17.1269 +          [ex] ctxt
 17.1270 +      in (freshs1 @ [term_of cx], freshs2 @ ths, ctxt') end;
 17.1271 +
 17.1272 +    fun fresh_fresh_inst thy a b =
 17.1273 +      let
 17.1274 +        val T = fastype_of a;
 17.1275 +        val SOME th = find_first (fn th => case prop_of th of
 17.1276 +            _ $ (_ $ (Const (_, Type (_, [U, _])) $ _ $ _)) $ _ => U = T
 17.1277 +          | _ => false) perm_fresh_fresh
 17.1278 +      in
 17.1279 +        Drule.instantiate' []
 17.1280 +          [SOME (cterm_of thy a), NONE, SOME (cterm_of thy b)] th
 17.1281 +      end;
 17.1282 +
 17.1283 +    val fs_cp_sort =
 17.1284 +      map (fs_class_of thy9) dt_atoms @
 17.1285 +      maps (fn s => map (cp_class_of thy9 s) (dt_atoms \ s)) dt_atoms;
 17.1286 +
 17.1287 +    (**********************************************************************
 17.1288 +      The subgoals occurring in the proof of induct_aux have the
 17.1289 +      following parameters:
 17.1290 +
 17.1291 +        x_1 ... x_k p_1 ... p_m z
 17.1292 +
 17.1293 +      where
 17.1294 +
 17.1295 +        x_i : constructor arguments (introduced by weak induction rule)
 17.1296 +        p_i : permutations (one for each atom type in the data type)
 17.1297 +        z   : freshness context
 17.1298 +    ***********************************************************************)
 17.1299 +
 17.1300 +    val _ = warning "proving strong induction theorem ...";
 17.1301 +
 17.1302 +    val induct_aux = Goal.prove_global thy9 []
 17.1303 +        (map (augment_sort thy9 fs_cp_sort) ind_prems')
 17.1304 +        (augment_sort thy9 fs_cp_sort ind_concl') (fn {prems, context} =>
 17.1305 +      let
 17.1306 +        val (prems1, prems2) = chop (length dt_atomTs) prems;
 17.1307 +        val ind_ss2 = HOL_ss addsimps
 17.1308 +          finite_Diff :: abs_fresh @ abs_supp @ fs_atoms;
 17.1309 +        val ind_ss1 = ind_ss2 addsimps fresh_left @ calc_atm @
 17.1310 +          fresh_atm @ rev_simps @ app_simps;
 17.1311 +        val ind_ss3 = HOL_ss addsimps abs_fun_eq1 ::
 17.1312 +          abs_perm @ calc_atm @ perm_swap;
 17.1313 +        val ind_ss4 = HOL_basic_ss addsimps fresh_left @ prems1 @
 17.1314 +          fin_set_fresh @ calc_atm;
 17.1315 +        val ind_ss5 = HOL_basic_ss addsimps pt1_atoms;
 17.1316 +        val ind_ss6 = HOL_basic_ss addsimps flat perm_simps';
 17.1317 +        val th = Goal.prove context [] []
 17.1318 +          (augment_sort thy9 fs_cp_sort aux_ind_concl)
 17.1319 +          (fn {context = context1, ...} =>
 17.1320 +             EVERY (indtac dt_induct tnames 1 ::
 17.1321 +               maps (fn ((_, (_, _, constrs)), (_, constrs')) =>
 17.1322 +                 map (fn ((cname, cargs), is) =>
 17.1323 +                   REPEAT (rtac allI 1) THEN
 17.1324 +                   SUBPROOF (fn {prems = iprems, params, concl,
 17.1325 +                       context = context2, ...} =>
 17.1326 +                     let
 17.1327 +                       val concl' = term_of concl;
 17.1328 +                       val _ $ (_ $ _ $ u) = concl';
 17.1329 +                       val U = fastype_of u;
 17.1330 +                       val (xs, params') =
 17.1331 +                         chop (length cargs) (map term_of params);
 17.1332 +                       val Ts = map fastype_of xs;
 17.1333 +                       val cnstr = Const (cname, Ts ---> U);
 17.1334 +                       val (pis, z) = split_last params';
 17.1335 +                       val mk_pi = fold_rev (mk_perm []) pis;
 17.1336 +                       val xs' = partition_cargs is xs;
 17.1337 +                       val xs'' = map (fn (ts, u) => (map mk_pi ts, mk_pi u)) xs';
 17.1338 +                       val ts = maps (fn (ts, u) => ts @ [u]) xs'';
 17.1339 +                       val (freshs1, freshs2, context3) = fold (fn t =>
 17.1340 +                         let val T = fastype_of t
 17.1341 +                         in obtain_fresh_name' prems1
 17.1342 +                           (the (AList.lookup op = fresh_fs T) $ z :: ts) T
 17.1343 +                         end) (maps fst xs') ([], [], context2);
 17.1344 +                       val freshs1' = unflat (map fst xs') freshs1;
 17.1345 +                       val freshs2' = map (Simplifier.simplify ind_ss4)
 17.1346 +                         (mk_not_sym freshs2);
 17.1347 +                       val ind_ss1' = ind_ss1 addsimps freshs2';
 17.1348 +                       val ind_ss3' = ind_ss3 addsimps freshs2';
 17.1349 +                       val rename_eq =
 17.1350 +                         if forall (null o fst) xs' then []
 17.1351 +                         else [Goal.prove context3 [] []
 17.1352 +                           (HOLogic.mk_Trueprop (HOLogic.mk_eq
 17.1353 +                             (list_comb (cnstr, ts),
 17.1354 +                              list_comb (cnstr, maps (fn ((bs, t), cs) =>
 17.1355 +                                cs @ [fold_rev (mk_perm []) (map perm_of_pair
 17.1356 +                                  (bs ~~ cs)) t]) (xs'' ~~ freshs1')))))
 17.1357 +                           (fn _ => EVERY
 17.1358 +                              (simp_tac (HOL_ss addsimps flat inject_thms) 1 ::
 17.1359 +                               REPEAT (FIRSTGOAL (rtac conjI)) ::
 17.1360 +                               maps (fn ((bs, t), cs) =>
 17.1361 +                                 if null bs then []
 17.1362 +                                 else rtac sym 1 :: maps (fn (b, c) =>
 17.1363 +                                   [rtac trans 1, rtac sym 1,
 17.1364 +                                    rtac (fresh_fresh_inst thy9 b c) 1,
 17.1365 +                                    simp_tac ind_ss1' 1,
 17.1366 +                                    simp_tac ind_ss2 1,
 17.1367 +                                    simp_tac ind_ss3' 1]) (bs ~~ cs))
 17.1368 +                                 (xs'' ~~ freshs1')))];
 17.1369 +                       val th = Goal.prove context3 [] [] concl' (fn _ => EVERY
 17.1370 +                         [simp_tac (ind_ss6 addsimps rename_eq) 1,
 17.1371 +                          cut_facts_tac iprems 1,
 17.1372 +                          (resolve_tac prems THEN_ALL_NEW
 17.1373 +                            SUBGOAL (fn (t, i) => case Logic.strip_assums_concl t of
 17.1374 +                                _ $ (Const ("Nominal.fresh", _) $ _ $ _) =>
 17.1375 +                                  simp_tac ind_ss1' i
 17.1376 +                              | _ $ (Const ("Not", _) $ _) =>
 17.1377 +                                  resolve_tac freshs2' i
 17.1378 +                              | _ => asm_simp_tac (HOL_basic_ss addsimps
 17.1379 +                                  pt2_atoms addsimprocs [perm_simproc]) i)) 1])
 17.1380 +                       val final = ProofContext.export context3 context2 [th]
 17.1381 +                     in
 17.1382 +                       resolve_tac final 1
 17.1383 +                     end) context1 1) (constrs ~~ constrs')) (descr'' ~~ ndescr)))
 17.1384 +      in
 17.1385 +        EVERY
 17.1386 +          [cut_facts_tac [th] 1,
 17.1387 +           REPEAT (eresolve_tac [conjE, @{thm allE_Nil}] 1),
 17.1388 +           REPEAT (etac allE 1),
 17.1389 +           REPEAT (TRY (rtac conjI 1) THEN asm_full_simp_tac ind_ss5 1)]
 17.1390 +      end);
 17.1391 +
 17.1392 +    val induct_aux' = Thm.instantiate ([],
 17.1393 +      map (fn (s, v as Var (_, T)) =>
 17.1394 +        (cterm_of thy9 v, cterm_of thy9 (Free (s, T))))
 17.1395 +          (pnames ~~ map head_of (HOLogic.dest_conj
 17.1396 +             (HOLogic.dest_Trueprop (concl_of induct_aux)))) @
 17.1397 +      map (fn (_, f) =>
 17.1398 +        let val f' = Logic.varify f
 17.1399 +        in (cterm_of thy9 f',
 17.1400 +          cterm_of thy9 (Const ("Nominal.supp", fastype_of f')))
 17.1401 +        end) fresh_fs) induct_aux;
 17.1402 +
 17.1403 +    val induct = Goal.prove_global thy9 []
 17.1404 +      (map (augment_sort thy9 fs_cp_sort) ind_prems)
 17.1405 +      (augment_sort thy9 fs_cp_sort ind_concl)
 17.1406 +      (fn {prems, ...} => EVERY
 17.1407 +         [rtac induct_aux' 1,
 17.1408 +          REPEAT (resolve_tac fs_atoms 1),
 17.1409 +          REPEAT ((resolve_tac prems THEN_ALL_NEW
 17.1410 +            (etac meta_spec ORELSE' full_simp_tac (HOL_basic_ss addsimps [fresh_def]))) 1)])
 17.1411 +
 17.1412 +    val (_, thy10) = thy9 |>
 17.1413 +      Sign.add_path big_name |>
 17.1414 +      PureThy.add_thms [((Binding.name "strong_induct'", induct_aux), [])] ||>>
 17.1415 +      PureThy.add_thms [((Binding.name "strong_induct", induct), [case_names_induct])] ||>>
 17.1416 +      PureThy.add_thmss [((Binding.name "strong_inducts", projections induct), [case_names_induct])];
 17.1417 +
 17.1418 +    (**** recursion combinator ****)
 17.1419 +
 17.1420 +    val _ = warning "defining recursion combinator ...";
 17.1421 +
 17.1422 +    val used = List.foldr OldTerm.add_typ_tfree_names [] recTs;
 17.1423 +
 17.1424 +    val (rec_result_Ts', rec_fn_Ts') = DatatypeProp.make_primrec_Ts descr' sorts used;
 17.1425 +
 17.1426 +    val rec_sort = if null dt_atomTs then HOLogic.typeS else
 17.1427 +      Sign.certify_sort thy10 pt_cp_sort;
 17.1428 +
 17.1429 +    val rec_result_Ts = map (fn TFree (s, _) => TFree (s, rec_sort)) rec_result_Ts';
 17.1430 +    val rec_fn_Ts = map (typ_subst_atomic (rec_result_Ts' ~~ rec_result_Ts)) rec_fn_Ts';
 17.1431 +
 17.1432 +    val rec_set_Ts = map (fn (T1, T2) =>
 17.1433 +      rec_fn_Ts @ [T1, T2] ---> HOLogic.boolT) (recTs ~~ rec_result_Ts);
 17.1434 +
 17.1435 +    val big_rec_name = big_name ^ "_rec_set";
 17.1436 +    val rec_set_names' =
 17.1437 +      if length descr'' = 1 then [big_rec_name] else
 17.1438 +        map ((curry (op ^) (big_rec_name ^ "_")) o string_of_int)
 17.1439 +          (1 upto (length descr''));
 17.1440 +    val rec_set_names =  map (Sign.full_bname thy10) rec_set_names';
 17.1441 +
 17.1442 +    val rec_fns = map (uncurry (mk_Free "f"))
 17.1443 +      (rec_fn_Ts ~~ (1 upto (length rec_fn_Ts)));
 17.1444 +    val rec_sets' = map (fn c => list_comb (Free c, rec_fns))
 17.1445 +      (rec_set_names' ~~ rec_set_Ts);
 17.1446 +    val rec_sets = map (fn c => list_comb (Const c, rec_fns))
 17.1447 +      (rec_set_names ~~ rec_set_Ts);
 17.1448 +
 17.1449 +    (* introduction rules for graph of recursion function *)
 17.1450 +
 17.1451 +    val rec_preds = map (fn (a, T) =>
 17.1452 +      Free (a, T --> HOLogic.boolT)) (pnames ~~ rec_result_Ts);
 17.1453 +
 17.1454 +    fun mk_fresh3 rs [] = []
 17.1455 +      | mk_fresh3 rs ((p as (ys, z)) :: yss) = List.concat (map (fn y as (_, T) =>
 17.1456 +            List.mapPartial (fn ((_, (_, x)), r as (_, U)) => if z = x then NONE
 17.1457 +              else SOME (HOLogic.mk_Trueprop
 17.1458 +                (fresh_const T U $ Free y $ Free r))) rs) ys) @
 17.1459 +          mk_fresh3 rs yss;
 17.1460 +
 17.1461 +    (* FIXME: avoid collisions with other variable names? *)
 17.1462 +    val rec_ctxt = Free ("z", fsT');
 17.1463 +
 17.1464 +    fun make_rec_intr T p rec_set ((rec_intr_ts, rec_prems, rec_prems',
 17.1465 +          rec_eq_prems, l), ((cname, cargs), idxs)) =
 17.1466 +      let
 17.1467 +        val Ts = map (typ_of_dtyp descr'' sorts) cargs;
 17.1468 +        val frees = map (fn i => "x" ^ string_of_int i) (1 upto length Ts) ~~ Ts;
 17.1469 +        val frees' = partition_cargs idxs frees;
 17.1470 +        val binders = List.concat (map fst frees');
 17.1471 +        val atomTs = distinct op = (maps (map snd o fst) frees');
 17.1472 +        val recs = List.mapPartial
 17.1473 +          (fn ((_, DtRec i), p) => SOME (i, p) | _ => NONE)
 17.1474 +          (partition_cargs idxs cargs ~~ frees');
 17.1475 +        val frees'' = map (fn i => "y" ^ string_of_int i) (1 upto length recs) ~~
 17.1476 +          map (fn (i, _) => List.nth (rec_result_Ts, i)) recs;
 17.1477 +        val prems1 = map (fn ((i, (_, x)), y) => HOLogic.mk_Trueprop
 17.1478 +          (List.nth (rec_sets', i) $ Free x $ Free y)) (recs ~~ frees'');
 17.1479 +        val prems2 =
 17.1480 +          map (fn f => map (fn p as (_, T) => HOLogic.mk_Trueprop
 17.1481 +            (fresh_const T (fastype_of f) $ Free p $ f)) binders) rec_fns;
 17.1482 +        val prems3 = mk_fresh1 [] binders @ mk_fresh2 [] frees';
 17.1483 +        val prems4 = map (fn ((i, _), y) =>
 17.1484 +          HOLogic.mk_Trueprop (List.nth (rec_preds, i) $ Free y)) (recs ~~ frees'');
 17.1485 +        val prems5 = mk_fresh3 (recs ~~ frees'') frees';
 17.1486 +        val prems6 = maps (fn aT => map (fn y as (_, T) => HOLogic.mk_Trueprop
 17.1487 +          (Const ("Finite_Set.finite", HOLogic.mk_setT aT --> HOLogic.boolT) $
 17.1488 +             (Const ("Nominal.supp", T --> HOLogic.mk_setT aT) $ Free y)))
 17.1489 +               frees'') atomTs;
 17.1490 +        val prems7 = map (fn x as (_, T) => HOLogic.mk_Trueprop
 17.1491 +          (fresh_const T fsT' $ Free x $ rec_ctxt)) binders;
 17.1492 +        val result = list_comb (List.nth (rec_fns, l), map Free (frees @ frees''));
 17.1493 +        val result_freshs = map (fn p as (_, T) =>
 17.1494 +          fresh_const T (fastype_of result) $ Free p $ result) binders;
 17.1495 +        val P = HOLogic.mk_Trueprop (p $ result)
 17.1496 +      in
 17.1497 +        (rec_intr_ts @ [Logic.list_implies (List.concat prems2 @ prems3 @ prems1,
 17.1498 +           HOLogic.mk_Trueprop (rec_set $
 17.1499 +             list_comb (Const (cname, Ts ---> T), map Free frees) $ result))],
 17.1500 +         rec_prems @ [list_all_free (frees @ frees'', Logic.list_implies (prems4, P))],
 17.1501 +         rec_prems' @ map (fn fr => list_all_free (frees @ frees'',
 17.1502 +           Logic.list_implies (List.nth (prems2, l) @ prems3 @ prems5 @ prems7 @ prems6 @ [P],
 17.1503 +             HOLogic.mk_Trueprop fr))) result_freshs,
 17.1504 +         rec_eq_prems @ [List.concat prems2 @ prems3],
 17.1505 +         l + 1)
 17.1506 +      end;
 17.1507 +
 17.1508 +    val (rec_intr_ts, rec_prems, rec_prems', rec_eq_prems, _) =
 17.1509 +      Library.foldl (fn (x, ((((d, d'), T), p), rec_set)) =>
 17.1510 +        Library.foldl (make_rec_intr T p rec_set) (x, #3 (snd d) ~~ snd d'))
 17.1511 +          (([], [], [], [], 0), descr'' ~~ ndescr ~~ recTs ~~ rec_preds ~~ rec_sets');
 17.1512 +
 17.1513 +    val ({intrs = rec_intrs, elims = rec_elims, raw_induct = rec_induct, ...}, thy11) =
 17.1514 +      thy10 |>
 17.1515 +        Inductive.add_inductive_global (serial_string ())
 17.1516 +          {quiet_mode = #quiet config, verbose = false, kind = Thm.internalK,
 17.1517 +           alt_name = Binding.name big_rec_name, coind = false, no_elim = false, no_ind = false,
 17.1518 +           skip_mono = true, fork_mono = false}
 17.1519 +          (map (fn (s, T) => ((Binding.name s, T), NoSyn)) (rec_set_names' ~~ rec_set_Ts))
 17.1520 +          (map dest_Free rec_fns)
 17.1521 +          (map (fn x => (Attrib.empty_binding, x)) rec_intr_ts) [] ||>
 17.1522 +      PureThy.hide_fact true (Long_Name.append (Sign.full_bname thy10 big_rec_name) "induct");
 17.1523 +
 17.1524 +    (** equivariance **)
 17.1525 +
 17.1526 +    val fresh_bij = PureThy.get_thms thy11 "fresh_bij";
 17.1527 +    val perm_bij = PureThy.get_thms thy11 "perm_bij";
 17.1528 +
 17.1529 +    val (rec_equiv_thms, rec_equiv_thms') = ListPair.unzip (map (fn aT =>
 17.1530 +      let
 17.1531 +        val permT = mk_permT aT;
 17.1532 +        val pi = Free ("pi", permT);
 17.1533 +        val rec_fns_pi = map (mk_perm [] pi o uncurry (mk_Free "f"))
 17.1534 +          (rec_fn_Ts ~~ (1 upto (length rec_fn_Ts)));
 17.1535 +        val rec_sets_pi = map (fn c => list_comb (Const c, rec_fns_pi))
 17.1536 +          (rec_set_names ~~ rec_set_Ts);
 17.1537 +        val ps = map (fn ((((T, U), R), R'), i) =>
 17.1538 +          let
 17.1539 +            val x = Free ("x" ^ string_of_int i, T);
 17.1540 +            val y = Free ("y" ^ string_of_int i, U)
 17.1541 +          in
 17.1542 +            (R $ x $ y, R' $ mk_perm [] pi x $ mk_perm [] pi y)
 17.1543 +          end) (recTs ~~ rec_result_Ts ~~ rec_sets ~~ rec_sets_pi ~~ (1 upto length recTs));
 17.1544 +        val ths = map (fn th => standard (th RS mp)) (split_conj_thm
 17.1545 +          (Goal.prove_global thy11 [] []
 17.1546 +            (augment_sort thy1 pt_cp_sort
 17.1547 +              (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map HOLogic.mk_imp ps))))
 17.1548 +            (fn _ => rtac rec_induct 1 THEN REPEAT
 17.1549 +               (simp_tac (Simplifier.theory_context thy11 HOL_basic_ss
 17.1550 +                  addsimps flat perm_simps'
 17.1551 +                  addsimprocs [NominalPermeq.perm_simproc_app]) 1 THEN
 17.1552 +                (resolve_tac rec_intrs THEN_ALL_NEW
 17.1553 +                 asm_simp_tac (HOL_ss addsimps (fresh_bij @ perm_bij))) 1))))
 17.1554 +        val ths' = map (fn ((P, Q), th) =>
 17.1555 +          Goal.prove_global thy11 [] []
 17.1556 +            (augment_sort thy1 pt_cp_sort
 17.1557 +              (Logic.mk_implies (HOLogic.mk_Trueprop Q, HOLogic.mk_Trueprop P)))
 17.1558 +            (fn _ => dtac (Thm.instantiate ([],
 17.1559 +                 [(cterm_of thy11 (Var (("pi", 0), permT)),
 17.1560 +                   cterm_of thy11 (Const ("List.rev", permT --> permT) $ pi))]) th) 1 THEN
 17.1561 +               NominalPermeq.perm_simp_tac HOL_ss 1)) (ps ~~ ths)
 17.1562 +      in (ths, ths') end) dt_atomTs);
 17.1563 +
 17.1564 +    (** finite support **)
 17.1565 +
 17.1566 +    val rec_fin_supp_thms = map (fn aT =>
 17.1567 +      let
 17.1568 +        val name = Long_Name.base_name (fst (dest_Type aT));
 17.1569 +        val fs_name = PureThy.get_thm thy11 ("fs_" ^ name ^ "1");
 17.1570 +        val aset = HOLogic.mk_setT aT;
 17.1571 +        val finite = Const ("Finite_Set.finite", aset --> HOLogic.boolT);
 17.1572 +        val fins = map (fn (f, T) => HOLogic.mk_Trueprop
 17.1573 +          (finite $ (Const ("Nominal.supp", T --> aset) $ f)))
 17.1574 +            (rec_fns ~~ rec_fn_Ts)
 17.1575 +      in
 17.1576 +        map (fn th => standard (th RS mp)) (split_conj_thm
 17.1577 +          (Goal.prove_global thy11 []
 17.1578 +            (map (augment_sort thy11 fs_cp_sort) fins)
 17.1579 +            (augment_sort thy11 fs_cp_sort
 17.1580 +              (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
 17.1581 +                (map (fn (((T, U), R), i) =>
 17.1582 +                   let
 17.1583 +                     val x = Free ("x" ^ string_of_int i, T);
 17.1584 +                     val y = Free ("y" ^ string_of_int i, U)
 17.1585 +                   in
 17.1586 +                     HOLogic.mk_imp (R $ x $ y,
 17.1587 +                       finite $ (Const ("Nominal.supp", U --> aset) $ y))
 17.1588 +                   end) (recTs ~~ rec_result_Ts ~~ rec_sets ~~
 17.1589 +                     (1 upto length recTs))))))
 17.1590 +            (fn {prems = fins, ...} =>
 17.1591 +              (rtac rec_induct THEN_ALL_NEW cut_facts_tac fins) 1 THEN REPEAT
 17.1592 +               (NominalPermeq.finite_guess_tac (HOL_ss addsimps [fs_name]) 1))))
 17.1593 +      end) dt_atomTs;
 17.1594 +
 17.1595 +    (** freshness **)
 17.1596 +
 17.1597 +    val finite_premss = map (fn aT =>
 17.1598 +      map (fn (f, T) => HOLogic.mk_Trueprop
 17.1599 +        (Const ("Finite_Set.finite", HOLogic.mk_setT aT --> HOLogic.boolT) $
 17.1600 +           (Const ("Nominal.supp", T --> HOLogic.mk_setT aT) $ f)))
 17.1601 +           (rec_fns ~~ rec_fn_Ts)) dt_atomTs;
 17.1602 +
 17.1603 +    val rec_fns' = map (augment_sort thy11 fs_cp_sort) rec_fns;
 17.1604 +
 17.1605 +    val rec_fresh_thms = map (fn ((aT, eqvt_ths), finite_prems) =>
 17.1606 +      let
 17.1607 +        val name = Long_Name.base_name (fst (dest_Type aT));
 17.1608 +        val fs_name = PureThy.get_thm thy11 ("fs_" ^ name ^ "1");
 17.1609 +        val a = Free ("a", aT);
 17.1610 +        val freshs = map (fn (f, fT) => HOLogic.mk_Trueprop
 17.1611 +          (fresh_const aT fT $ a $ f)) (rec_fns ~~ rec_fn_Ts)
 17.1612 +      in
 17.1613 +        map (fn (((T, U), R), eqvt_th) =>
 17.1614 +          let
 17.1615 +            val x = Free ("x", augment_sort_typ thy11 fs_cp_sort T);
 17.1616 +            val y = Free ("y", U);
 17.1617 +            val y' = Free ("y'", U)
 17.1618 +          in
 17.1619 +            standard (Goal.prove (ProofContext.init thy11) []
 17.1620 +              (map (augment_sort thy11 fs_cp_sort)
 17.1621 +                (finite_prems @
 17.1622 +                   [HOLogic.mk_Trueprop (R $ x $ y),
 17.1623 +                    HOLogic.mk_Trueprop (HOLogic.mk_all ("y'", U,
 17.1624 +                      HOLogic.mk_imp (R $ x $ y', HOLogic.mk_eq (y', y)))),
 17.1625 +                    HOLogic.mk_Trueprop (fresh_const aT T $ a $ x)] @
 17.1626 +                 freshs))
 17.1627 +              (HOLogic.mk_Trueprop (fresh_const aT U $ a $ y))
 17.1628 +              (fn {prems, context} =>
 17.1629 +                 let
 17.1630 +                   val (finite_prems, rec_prem :: unique_prem ::
 17.1631 +                     fresh_prems) = chop (length finite_prems) prems;
 17.1632 +                   val unique_prem' = unique_prem RS spec RS mp;
 17.1633 +                   val unique = [unique_prem', unique_prem' RS sym] MRS trans;
 17.1634 +                   val _ $ (_ $ (_ $ S $ _)) $ _ = prop_of supports_fresh;
 17.1635 +                   val tuple = foldr1 HOLogic.mk_prod (x :: rec_fns')
 17.1636 +                 in EVERY
 17.1637 +                   [rtac (Drule.cterm_instantiate
 17.1638 +                      [(cterm_of thy11 S,
 17.1639 +                        cterm_of thy11 (Const ("Nominal.supp",
 17.1640 +                          fastype_of tuple --> HOLogic.mk_setT aT) $ tuple))]
 17.1641 +                      supports_fresh) 1,
 17.1642 +                    simp_tac (HOL_basic_ss addsimps
 17.1643 +                      [supports_def, symmetric fresh_def, fresh_prod]) 1,
 17.1644 +                    REPEAT_DETERM (resolve_tac [allI, impI] 1),
 17.1645 +                    REPEAT_DETERM (etac conjE 1),
 17.1646 +                    rtac unique 1,
 17.1647 +                    SUBPROOF (fn {prems = prems', params = [a, b], ...} => EVERY
 17.1648 +                      [cut_facts_tac [rec_prem] 1,
 17.1649 +                       rtac (Thm.instantiate ([],
 17.1650 +                         [(cterm_of thy11 (Var (("pi", 0), mk_permT aT)),
 17.1651 +                           cterm_of thy11 (perm_of_pair (term_of a, term_of b)))]) eqvt_th) 1,
 17.1652 +                       asm_simp_tac (HOL_ss addsimps
 17.1653 +                         (prems' @ perm_swap @ perm_fresh_fresh)) 1]) context 1,
 17.1654 +                    rtac rec_prem 1,
 17.1655 +                    simp_tac (HOL_ss addsimps (fs_name ::
 17.1656 +                      supp_prod :: finite_Un :: finite_prems)) 1,
 17.1657 +                    simp_tac (HOL_ss addsimps (symmetric fresh_def ::
 17.1658 +                      fresh_prod :: fresh_prems)) 1]
 17.1659 +                 end))
 17.1660 +          end) (recTs ~~ rec_result_Ts ~~ rec_sets ~~ eqvt_ths)
 17.1661 +      end) (dt_atomTs ~~ rec_equiv_thms' ~~ finite_premss);
 17.1662 +
 17.1663 +    (** uniqueness **)
 17.1664 +
 17.1665 +    val fun_tuple = foldr1 HOLogic.mk_prod (rec_ctxt :: rec_fns);
 17.1666 +    val fun_tupleT = fastype_of fun_tuple;
 17.1667 +    val rec_unique_frees =
 17.1668 +      DatatypeProp.indexify_names (replicate (length recTs) "x") ~~ recTs;
 17.1669 +    val rec_unique_frees'' = map (fn (s, T) => (s ^ "'", T)) rec_unique_frees;
 17.1670 +    val rec_unique_frees' =
 17.1671 +      DatatypeProp.indexify_names (replicate (length recTs) "y") ~~ rec_result_Ts;
 17.1672 +    val rec_unique_concls = map (fn ((x, U), R) =>
 17.1673 +        Const ("Ex1", (U --> HOLogic.boolT) --> HOLogic.boolT) $
 17.1674 +          Abs ("y", U, R $ Free x $ Bound 0))
 17.1675 +      (rec_unique_frees ~~ rec_result_Ts ~~ rec_sets);
 17.1676 +
 17.1677 +    val induct_aux_rec = Drule.cterm_instantiate
 17.1678 +      (map (pairself (cterm_of thy11) o apsnd (augment_sort thy11 fs_cp_sort))
 17.1679 +         (map (fn (aT, f) => (Logic.varify f, Abs ("z", HOLogic.unitT,
 17.1680 +            Const ("Nominal.supp", fun_tupleT --> HOLogic.mk_setT aT) $ fun_tuple)))
 17.1681 +              fresh_fs @
 17.1682 +          map (fn (((P, T), (x, U)), Q) =>
 17.1683 +           (Var ((P, 0), Logic.varifyT (fsT' --> T --> HOLogic.boolT)),
 17.1684 +            Abs ("z", HOLogic.unitT, absfree (x, U, Q))))
 17.1685 +              (pnames ~~ recTs ~~ rec_unique_frees ~~ rec_unique_concls) @
 17.1686 +          map (fn (s, T) => (Var ((s, 0), Logic.varifyT T), Free (s, T)))
 17.1687 +            rec_unique_frees)) induct_aux;
 17.1688 +
 17.1689 +    fun obtain_fresh_name vs ths rec_fin_supp T (freshs1, freshs2, ctxt) =
 17.1690 +      let
 17.1691 +        val p = foldr1 HOLogic.mk_prod (vs @ freshs1);
 17.1692 +        val ex = Goal.prove ctxt [] [] (HOLogic.mk_Trueprop
 17.1693 +            (HOLogic.exists_const T $ Abs ("x", T,
 17.1694 +              fresh_const T (fastype_of p) $ Bound 0 $ p)))
 17.1695 +          (fn _ => EVERY
 17.1696 +            [cut_facts_tac ths 1,
 17.1697 +             REPEAT_DETERM (dresolve_tac (the (AList.lookup op = rec_fin_supp T)) 1),
 17.1698 +             resolve_tac exists_fresh' 1,
 17.1699 +             asm_simp_tac (HOL_ss addsimps (supp_prod :: finite_Un :: fs_atoms)) 1]);
 17.1700 +        val (([cx], ths), ctxt') = Obtain.result
 17.1701 +          (fn _ => EVERY
 17.1702 +            [etac exE 1,
 17.1703 +             full_simp_tac (HOL_ss addsimps (fresh_prod :: fresh_atm)) 1,
 17.1704 +             REPEAT (etac conjE 1)])
 17.1705 +          [ex] ctxt
 17.1706 +      in (freshs1 @ [term_of cx], freshs2 @ ths, ctxt') end;
 17.1707 +
 17.1708 +    val finite_ctxt_prems = map (fn aT =>
 17.1709 +      HOLogic.mk_Trueprop
 17.1710 +        (Const ("Finite_Set.finite", HOLogic.mk_setT aT --> HOLogic.boolT) $
 17.1711 +           (Const ("Nominal.supp", fsT' --> HOLogic.mk_setT aT) $ rec_ctxt))) dt_atomTs;
 17.1712 +
 17.1713 +    val rec_unique_thms = split_conj_thm (Goal.prove
 17.1714 +      (ProofContext.init thy11) (map fst rec_unique_frees)
 17.1715 +      (map (augment_sort thy11 fs_cp_sort)
 17.1716 +        (List.concat finite_premss @ finite_ctxt_prems @ rec_prems @ rec_prems'))
 17.1717 +      (augment_sort thy11 fs_cp_sort
 17.1718 +        (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj rec_unique_concls)))
 17.1719 +      (fn {prems, context} =>
 17.1720 +         let
 17.1721 +           val k = length rec_fns;
 17.1722 +           val (finite_thss, ths1) = fold_map (fn T => fn xs =>
 17.1723 +             apfst (pair T) (chop k xs)) dt_atomTs prems;
 17.1724 +           val (finite_ctxt_ths, ths2) = chop (length dt_atomTs) ths1;
 17.1725 +           val (P_ind_ths, fcbs) = chop k ths2;
 17.1726 +           val P_ths = map (fn th => th RS mp) (split_conj_thm
 17.1727 +             (Goal.prove context
 17.1728 +               (map fst (rec_unique_frees'' @ rec_unique_frees')) []
 17.1729 +               (augment_sort thy11 fs_cp_sort
 17.1730 +                 (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
 17.1731 +                    (map (fn (((x, y), S), P) => HOLogic.mk_imp
 17.1732 +                      (S $ Free x $ Free y, P $ (Free y)))
 17.1733 +                        (rec_unique_frees'' ~~ rec_unique_frees' ~~
 17.1734 +                           rec_sets ~~ rec_preds)))))
 17.1735 +               (fn _ =>
 17.1736 +                  rtac rec_induct 1 THEN
 17.1737 +                  REPEAT ((resolve_tac P_ind_ths THEN_ALL_NEW assume_tac) 1))));
 17.1738 +           val rec_fin_supp_thms' = map
 17.1739 +             (fn (ths, (T, fin_ths)) => (T, map (curry op MRS fin_ths) ths))
 17.1740 +             (rec_fin_supp_thms ~~ finite_thss);
 17.1741 +         in EVERY
 17.1742 +           ([rtac induct_aux_rec 1] @
 17.1743 +            maps (fn ((_, finite_ths), finite_th) =>
 17.1744 +              [cut_facts_tac (finite_th :: finite_ths) 1,
 17.1745 +               asm_simp_tac (HOL_ss addsimps [supp_prod, finite_Un]) 1])
 17.1746 +                (finite_thss ~~ finite_ctxt_ths) @
 17.1747 +            maps (fn ((_, idxss), elim) => maps (fn idxs =>
 17.1748 +              [full_simp_tac (HOL_ss addsimps [symmetric fresh_def, supp_prod, Un_iff]) 1,
 17.1749 +               REPEAT_DETERM (eresolve_tac [conjE, ex1E] 1),
 17.1750 +               rtac ex1I 1,
 17.1751 +               (resolve_tac rec_intrs THEN_ALL_NEW atac) 1,
 17.1752 +               rotate_tac ~1 1,
 17.1753 +               ((DETERM o etac elim) THEN_ALL_NEW full_simp_tac
 17.1754 +                  (HOL_ss addsimps List.concat distinct_thms)) 1] @
 17.1755 +               (if null idxs then [] else [hyp_subst_tac 1,
 17.1756 +                SUBPROOF (fn {asms, concl, prems = prems', params, context = context', ...} =>
 17.1757 +                  let
 17.1758 +                    val SOME prem = find_first (can (HOLogic.dest_eq o
 17.1759 +                      HOLogic.dest_Trueprop o prop_of)) prems';
 17.1760 +                    val _ $ (_ $ lhs $ rhs) = prop_of prem;
 17.1761 +                    val _ $ (_ $ lhs' $ rhs') = term_of concl;
 17.1762 +                    val rT = fastype_of lhs';
 17.1763 +                    val (c, cargsl) = strip_comb lhs;
 17.1764 +                    val cargsl' = partition_cargs idxs cargsl;
 17.1765 +                    val boundsl = List.concat (map fst cargsl');
 17.1766 +                    val (_, cargsr) = strip_comb rhs;
 17.1767 +                    val cargsr' = partition_cargs idxs cargsr;
 17.1768 +                    val boundsr = List.concat (map fst cargsr');
 17.1769 +                    val (params1, _ :: params2) =
 17.1770 +                      chop (length params div 2) (map term_of params);
 17.1771 +                    val params' = params1 @ params2;
 17.1772 +                    val rec_prems = filter (fn th => case prop_of th of
 17.1773 +                        _ $ p => (case head_of p of
 17.1774 +                          Const (s, _) => s mem rec_set_names
 17.1775 +                        | _ => false)
 17.1776 +                      | _ => false) prems';
 17.1777 +                    val fresh_prems = filter (fn th => case prop_of th of
 17.1778 +                        _ $ (Const ("Nominal.fresh", _) $ _ $ _) => true
 17.1779 +                      | _ $ (Const ("Not", _) $ _) => true
 17.1780 +                      | _ => false) prems';
 17.1781 +                    val Ts = map fastype_of boundsl;
 17.1782 +
 17.1783 +                    val _ = warning "step 1: obtaining fresh names";
 17.1784 +                    val (freshs1, freshs2, context'') = fold
 17.1785 +                      (obtain_fresh_name (rec_ctxt :: rec_fns' @ params')
 17.1786 +                         (List.concat (map snd finite_thss) @
 17.1787 +                            finite_ctxt_ths @ rec_prems)
 17.1788 +                         rec_fin_supp_thms')
 17.1789 +                      Ts ([], [], context');
 17.1790 +                    val pi1 = map perm_of_pair (boundsl ~~ freshs1);
 17.1791 +                    val rpi1 = rev pi1;
 17.1792 +                    val pi2 = map perm_of_pair (boundsr ~~ freshs1);
 17.1793 +                    val rpi2 = rev pi2;
 17.1794 +
 17.1795 +                    val fresh_prems' = mk_not_sym fresh_prems;
 17.1796 +                    val freshs2' = mk_not_sym freshs2;
 17.1797 +
 17.1798 +                    (** as, bs, cs # K as ts, K bs us **)
 17.1799 +                    val _ = warning "step 2: as, bs, cs # K as ts, K bs us";
 17.1800 +                    val prove_fresh_ss = HOL_ss addsimps
 17.1801 +                      (finite_Diff :: List.concat fresh_thms @
 17.1802 +                       fs_atoms @ abs_fresh @ abs_supp @ fresh_atm);
 17.1803 +                    (* FIXME: avoid asm_full_simp_tac ? *)
 17.1804 +                    fun prove_fresh ths y x = Goal.prove context'' [] []
 17.1805 +                      (HOLogic.mk_Trueprop (fresh_const
 17.1806 +                         (fastype_of x) (fastype_of y) $ x $ y))
 17.1807 +                      (fn _ => cut_facts_tac ths 1 THEN asm_full_simp_tac prove_fresh_ss 1);
 17.1808 +                    val constr_fresh_thms =
 17.1809 +                      map (prove_fresh fresh_prems lhs) boundsl @
 17.1810 +                      map (prove_fresh fresh_prems rhs) boundsr @
 17.1811 +                      map (prove_fresh freshs2 lhs) freshs1 @
 17.1812 +                      map (prove_fresh freshs2 rhs) freshs1;
 17.1813 +
 17.1814 +                    (** pi1 o (K as ts) = pi2 o (K bs us) **)
 17.1815 +                    val _ = warning "step 3: pi1 o (K as ts) = pi2 o (K bs us)";
 17.1816 +                    val pi1_pi2_eq = Goal.prove context'' [] []
 17.1817 +                      (HOLogic.mk_Trueprop (HOLogic.mk_eq
 17.1818 +                        (fold_rev (mk_perm []) pi1 lhs, fold_rev (mk_perm []) pi2 rhs)))
 17.1819 +                      (fn _ => EVERY
 17.1820 +                         [cut_facts_tac constr_fresh_thms 1,
 17.1821 +                          asm_simp_tac (HOL_basic_ss addsimps perm_fresh_fresh) 1,
 17.1822 +                          rtac prem 1]);
 17.1823 +
 17.1824 +                    (** pi1 o ts = pi2 o us **)
 17.1825 +                    val _ = warning "step 4: pi1 o ts = pi2 o us";
 17.1826 +                    val pi1_pi2_eqs = map (fn (t, u) =>
 17.1827 +                      Goal.prove context'' [] []
 17.1828 +                        (HOLogic.mk_Trueprop (HOLogic.mk_eq
 17.1829 +                          (fold_rev (mk_perm []) pi1 t, fold_rev (mk_perm []) pi2 u)))
 17.1830 +                        (fn _ => EVERY
 17.1831 +                           [cut_facts_tac [pi1_pi2_eq] 1,
 17.1832 +                            asm_full_simp_tac (HOL_ss addsimps
 17.1833 +                              (calc_atm @ List.concat perm_simps' @
 17.1834 +                               fresh_prems' @ freshs2' @ abs_perm @
 17.1835 +                               alpha @ List.concat inject_thms)) 1]))
 17.1836 +                        (map snd cargsl' ~~ map snd cargsr');
 17.1837 +
 17.1838 +                    (** pi1^-1 o pi2 o us = ts **)
 17.1839 +                    val _ = warning "step 5: pi1^-1 o pi2 o us = ts";
 17.1840 +                    val rpi1_pi2_eqs = map (fn ((t, u), eq) =>
 17.1841 +                      Goal.prove context'' [] []
 17.1842 +                        (HOLogic.mk_Trueprop (HOLogic.mk_eq
 17.1843 +                          (fold_rev (mk_perm []) (rpi1 @ pi2) u, t)))
 17.1844 +                        (fn _ => simp_tac (HOL_ss addsimps
 17.1845 +                           ((eq RS sym) :: perm_swap)) 1))
 17.1846 +                        (map snd cargsl' ~~ map snd cargsr' ~~ pi1_pi2_eqs);
 17.1847 +
 17.1848 +                    val (rec_prems1, rec_prems2) =
 17.1849 +                      chop (length rec_prems div 2) rec_prems;
 17.1850 +
 17.1851 +                    (** (ts, pi1^-1 o pi2 o vs) in rec_set **)
 17.1852 +                    val _ = warning "step 6: (ts, pi1^-1 o pi2 o vs) in rec_set";
 17.1853 +                    val rec_prems' = map (fn th =>
 17.1854 +                      let
 17.1855 +                        val _ $ (S $ x $ y) = prop_of th;
 17.1856 +                        val Const (s, _) = head_of S;
 17.1857 +                        val k = find_index (equal s) rec_set_names;
 17.1858 +                        val pi = rpi1 @ pi2;
 17.1859 +                        fun mk_pi z = fold_rev (mk_perm []) pi z;
 17.1860 +                        fun eqvt_tac p =
 17.1861 +                          let
 17.1862 +                            val U as Type (_, [Type (_, [T, _])]) = fastype_of p;
 17.1863 +                            val l = find_index (equal T) dt_atomTs;
 17.1864 +                            val th = List.nth (List.nth (rec_equiv_thms', l), k);
 17.1865 +                            val th' = Thm.instantiate ([],
 17.1866 +                              [(cterm_of thy11 (Var (("pi", 0), U)),
 17.1867 +                                cterm_of thy11 p)]) th;
 17.1868 +                          in rtac th' 1 end;
 17.1869 +                        val th' = Goal.prove context'' [] []
 17.1870 +                          (HOLogic.mk_Trueprop (S $ mk_pi x $ mk_pi y))
 17.1871 +                          (fn _ => EVERY
 17.1872 +                             (map eqvt_tac pi @
 17.1873 +                              [simp_tac (HOL_ss addsimps (fresh_prems' @ freshs2' @
 17.1874 +                                 perm_swap @ perm_fresh_fresh)) 1,
 17.1875 +                               rtac th 1]))
 17.1876 +                      in
 17.1877 +                        Simplifier.simplify
 17.1878 +                          (HOL_basic_ss addsimps rpi1_pi2_eqs) th'
 17.1879 +                      end) rec_prems2;
 17.1880 +
 17.1881 +                    val ihs = filter (fn th => case prop_of th of
 17.1882 +                      _ $ (Const ("All", _) $ _) => true | _ => false) prems';
 17.1883 +
 17.1884 +                    (** pi1 o rs = pi2 o vs , rs = pi1^-1 o pi2 o vs **)
 17.1885 +                    val _ = warning "step 7: pi1 o rs = pi2 o vs , rs = pi1^-1 o pi2 o vs";
 17.1886 +                    val rec_eqns = map (fn (th, ih) =>
 17.1887 +                      let
 17.1888 +                        val th' = th RS (ih RS spec RS mp) RS sym;
 17.1889 +                        val _ $ (_ $ lhs $ rhs) = prop_of th';
 17.1890 +                        fun strip_perm (_ $ _ $ t) = strip_perm t
 17.1891 +                          | strip_perm t = t;
 17.1892 +                      in
 17.1893 +                        Goal.prove context'' [] []
 17.1894 +                           (HOLogic.mk_Trueprop (HOLogic.mk_eq
 17.1895 +                              (fold_rev (mk_perm []) pi1 lhs,
 17.1896 +                               fold_rev (mk_perm []) pi2 (strip_perm rhs))))
 17.1897 +                           (fn _ => simp_tac (HOL_basic_ss addsimps
 17.1898 +                              (th' :: perm_swap)) 1)
 17.1899 +                      end) (rec_prems' ~~ ihs);
 17.1900 +
 17.1901 +                    (** as # rs **)
 17.1902 +                    val _ = warning "step 8: as # rs";
 17.1903 +                    val rec_freshs = List.concat
 17.1904 +                      (map (fn (rec_prem, ih) =>
 17.1905 +                        let
 17.1906 +                          val _ $ (S $ x $ (y as Free (_, T))) =
 17.1907 +                            prop_of rec_prem;
 17.1908 +                          val k = find_index (equal S) rec_sets;
 17.1909 +                          val atoms = List.concat (List.mapPartial (fn (bs, z) =>
 17.1910 +                            if z = x then NONE else SOME bs) cargsl')
 17.1911 +                        in
 17.1912 +                          map (fn a as Free (_, aT) =>
 17.1913 +                            let val l = find_index (equal aT) dt_atomTs;
 17.1914 +                            in
 17.1915 +                              Goal.prove context'' [] []
 17.1916 +                                (HOLogic.mk_Trueprop (fresh_const aT T $ a $ y))
 17.1917 +                                (fn _ => EVERY
 17.1918 +                                   (rtac (List.nth (List.nth (rec_fresh_thms, l), k)) 1 ::
 17.1919 +                                    map (fn th => rtac th 1)
 17.1920 +                                      (snd (List.nth (finite_thss, l))) @
 17.1921 +                                    [rtac rec_prem 1, rtac ih 1,
 17.1922 +                                     REPEAT_DETERM (resolve_tac fresh_prems 1)]))
 17.1923 +                            end) atoms
 17.1924 +                        end) (rec_prems1 ~~ ihs));
 17.1925 +
 17.1926 +                    (** as # fK as ts rs , bs # fK bs us vs **)
 17.1927 +                    val _ = warning "step 9: as # fK as ts rs , bs # fK bs us vs";
 17.1928 +                    fun prove_fresh_result (a as Free (_, aT)) =
 17.1929 +                      Goal.prove context'' [] []
 17.1930 +                        (HOLogic.mk_Trueprop (fresh_const aT rT $ a $ rhs'))
 17.1931 +                        (fn _ => EVERY
 17.1932 +                           [resolve_tac fcbs 1,
 17.1933 +                            REPEAT_DETERM (resolve_tac
 17.1934 +                              (fresh_prems @ rec_freshs) 1),
 17.1935 +                            REPEAT_DETERM (resolve_tac (maps snd rec_fin_supp_thms') 1
 17.1936 +                              THEN resolve_tac rec_prems 1),
 17.1937 +                            resolve_tac P_ind_ths 1,
 17.1938 +                            REPEAT_DETERM (resolve_tac (P_ths @ rec_prems) 1)]);
 17.1939 +
 17.1940 +                    val fresh_results'' = map prove_fresh_result boundsl;
 17.1941 +
 17.1942 +                    fun prove_fresh_result'' ((a as Free (_, aT), b), th) =
 17.1943 +                      let val th' = Goal.prove context'' [] []
 17.1944 +                        (HOLogic.mk_Trueprop (fresh_const aT rT $
 17.1945 +                            fold_rev (mk_perm []) (rpi2 @ pi1) a $
 17.1946 +                            fold_rev (mk_perm []) (rpi2 @ pi1) rhs'))
 17.1947 +                        (fn _ => simp_tac (HOL_ss addsimps fresh_bij) 1 THEN
 17.1948 +                           rtac th 1)
 17.1949 +                      in
 17.1950 +                        Goal.prove context'' [] []
 17.1951 +                          (HOLogic.mk_Trueprop (fresh_const aT rT $ b $ lhs'))
 17.1952 +                          (fn _ => EVERY
 17.1953 +                             [cut_facts_tac [th'] 1,
 17.1954 +                              full_simp_tac (Simplifier.theory_context thy11 HOL_ss
 17.1955 +                                addsimps rec_eqns @ pi1_pi2_eqs @ perm_swap
 17.1956 +                                addsimprocs [NominalPermeq.perm_simproc_app]) 1,
 17.1957 +                              full_simp_tac (HOL_ss addsimps (calc_atm @
 17.1958 +                                fresh_prems' @ freshs2' @ perm_fresh_fresh)) 1])
 17.1959 +                      end;
 17.1960 +
 17.1961 +                    val fresh_results = fresh_results'' @ map prove_fresh_result''
 17.1962 +                      (boundsl ~~ boundsr ~~ fresh_results'');
 17.1963 +
 17.1964 +                    (** cs # fK as ts rs , cs # fK bs us vs **)
 17.1965 +                    val _ = warning "step 10: cs # fK as ts rs , cs # fK bs us vs";
 17.1966 +                    fun prove_fresh_result' recs t (a as Free (_, aT)) =
 17.1967 +                      Goal.prove context'' [] []
 17.1968 +                        (HOLogic.mk_Trueprop (fresh_const aT rT $ a $ t))
 17.1969 +                        (fn _ => EVERY
 17.1970 +                          [cut_facts_tac recs 1,
 17.1971 +                           REPEAT_DETERM (dresolve_tac
 17.1972 +                             (the (AList.lookup op = rec_fin_supp_thms' aT)) 1),
 17.1973 +                           NominalPermeq.fresh_guess_tac
 17.1974 +                             (HOL_ss addsimps (freshs2 @
 17.1975 +                                fs_atoms @ fresh_atm @
 17.1976 +                                List.concat (map snd finite_thss))) 1]);
 17.1977 +
 17.1978 +                    val fresh_results' =
 17.1979 +                      map (prove_fresh_result' rec_prems1 rhs') freshs1 @
 17.1980 +                      map (prove_fresh_result' rec_prems2 lhs') freshs1;
 17.1981 +
 17.1982 +                    (** pi1 o (fK as ts rs) = pi2 o (fK bs us vs) **)
 17.1983 +                    val _ = warning "step 11: pi1 o (fK as ts rs) = pi2 o (fK bs us vs)";
 17.1984 +                    val pi1_pi2_result = Goal.prove context'' [] []
 17.1985 +                      (HOLogic.mk_Trueprop (HOLogic.mk_eq
 17.1986 +                        (fold_rev (mk_perm []) pi1 rhs', fold_rev (mk_perm []) pi2 lhs')))
 17.1987 +                      (fn _ => simp_tac (Simplifier.context context'' HOL_ss
 17.1988 +                           addsimps pi1_pi2_eqs @ rec_eqns
 17.1989 +                           addsimprocs [NominalPermeq.perm_simproc_app]) 1 THEN
 17.1990 +                         TRY (simp_tac (HOL_ss addsimps
 17.1991 +                           (fresh_prems' @ freshs2' @ calc_atm @ perm_fresh_fresh)) 1));
 17.1992 +
 17.1993 +                    val _ = warning "final result";
 17.1994 +                    val final = Goal.prove context'' [] [] (term_of concl)
 17.1995 +                      (fn _ => cut_facts_tac [pi1_pi2_result RS sym] 1 THEN
 17.1996 +                        full_simp_tac (HOL_basic_ss addsimps perm_fresh_fresh @
 17.1997 +                          fresh_results @ fresh_results') 1);
 17.1998 +                    val final' = ProofContext.export context'' context' [final];
 17.1999 +                    val _ = warning "finished!"
 17.2000 +                  in
 17.2001 +                    resolve_tac final' 1
 17.2002 +                  end) context 1])) idxss) (ndescr ~~ rec_elims))
 17.2003 +         end));
 17.2004 +
 17.2005 +    val rec_total_thms = map (fn r => r RS theI') rec_unique_thms;
 17.2006 +
 17.2007 +    (* define primrec combinators *)
 17.2008 +
 17.2009 +    val big_reccomb_name = (space_implode "_" new_type_names) ^ "_rec";
 17.2010 +    val reccomb_names = map (Sign.full_bname thy11)
 17.2011 +      (if length descr'' = 1 then [big_reccomb_name] else
 17.2012 +        (map ((curry (op ^) (big_reccomb_name ^ "_")) o string_of_int)
 17.2013 +          (1 upto (length descr''))));
 17.2014 +    val reccombs = map (fn ((name, T), T') => list_comb
 17.2015 +      (Const (name, rec_fn_Ts @ [T] ---> T'), rec_fns))
 17.2016 +        (reccomb_names ~~ recTs ~~ rec_result_Ts);
 17.2017 +
 17.2018 +    val (reccomb_defs, thy12) =
 17.2019 +      thy11
 17.2020 +      |> Sign.add_consts_i (map (fn ((name, T), T') =>
 17.2021 +          (Binding.name (Long_Name.base_name name), rec_fn_Ts @ [T] ---> T', NoSyn))
 17.2022 +          (reccomb_names ~~ recTs ~~ rec_result_Ts))
 17.2023 +      |> (PureThy.add_defs false o map Thm.no_attributes) (map (fn ((((name, comb), set), T), T') =>
 17.2024 +          (Binding.name (Long_Name.base_name name ^ "_def"), Logic.mk_equals (comb, absfree ("x", T,
 17.2025 +           Const ("The", (T' --> HOLogic.boolT) --> T') $ absfree ("y", T',
 17.2026 +             set $ Free ("x", T) $ Free ("y", T'))))))
 17.2027 +               (reccomb_names ~~ reccombs ~~ rec_sets ~~ recTs ~~ rec_result_Ts));
 17.2028 +
 17.2029 +    (* prove characteristic equations for primrec combinators *)
 17.2030 +
 17.2031 +    val rec_thms = map (fn (prems, concl) =>
 17.2032 +      let
 17.2033 +        val _ $ (_ $ (_ $ x) $ _) = concl;
 17.2034 +        val (_, cargs) = strip_comb x;
 17.2035 +        val ps = map (fn (x as Free (_, T), i) =>
 17.2036 +          (Free ("x" ^ string_of_int i, T), x)) (cargs ~~ (1 upto length cargs));
 17.2037 +        val concl' = subst_atomic_types (rec_result_Ts' ~~ rec_result_Ts) concl;
 17.2038 +        val prems' = List.concat finite_premss @ finite_ctxt_prems @
 17.2039 +          rec_prems @ rec_prems' @ map (subst_atomic ps) prems;
 17.2040 +        fun solve rules prems = resolve_tac rules THEN_ALL_NEW
 17.2041 +          (resolve_tac prems THEN_ALL_NEW atac)
 17.2042 +      in
 17.2043 +        Goal.prove_global thy12 []
 17.2044 +          (map (augment_sort thy12 fs_cp_sort) prems')
 17.2045 +          (augment_sort thy12 fs_cp_sort concl')
 17.2046 +          (fn {prems, ...} => EVERY
 17.2047 +            [rewrite_goals_tac reccomb_defs,
 17.2048 +             rtac the1_equality 1,
 17.2049 +             solve rec_unique_thms prems 1,
 17.2050 +             resolve_tac rec_intrs 1,
 17.2051 +             REPEAT (solve (prems @ rec_total_thms) prems 1)])
 17.2052 +      end) (rec_eq_prems ~~
 17.2053 +        DatatypeProp.make_primrecs new_type_names descr' sorts thy12);
 17.2054 +
 17.2055 +    val dt_infos = map (make_dt_info pdescr sorts induct reccomb_names rec_thms)
 17.2056 +      ((0 upto length descr1 - 1) ~~ descr1 ~~ distinct_thms ~~ inject_thms);
 17.2057 +
 17.2058 +    (* FIXME: theorems are stored in database for testing only *)
 17.2059 +    val (_, thy13) = thy12 |>
 17.2060 +      PureThy.add_thmss
 17.2061 +        [((Binding.name "rec_equiv", List.concat rec_equiv_thms), []),
 17.2062 +         ((Binding.name "rec_equiv'", List.concat rec_equiv_thms'), []),
 17.2063 +         ((Binding.name "rec_fin_supp", List.concat rec_fin_supp_thms), []),
 17.2064 +         ((Binding.name "rec_fresh", List.concat rec_fresh_thms), []),
 17.2065 +         ((Binding.name "rec_unique", map standard rec_unique_thms), []),
 17.2066 +         ((Binding.name "recs", rec_thms), [])] ||>
 17.2067 +      Sign.parent_path ||>
 17.2068 +      map_nominal_datatypes (fold Symtab.update dt_infos);
 17.2069 +
 17.2070 +  in
 17.2071 +    thy13
 17.2072 +  end;
 17.2073 +
 17.2074 +val add_nominal_datatype = gen_add_nominal_datatype Datatype.read_typ;
 17.2075 +
 17.2076 +
 17.2077 +(* FIXME: The following stuff should be exported by Datatype *)
 17.2078 +
 17.2079 +local structure P = OuterParse and K = OuterKeyword in
 17.2080 +
 17.2081 +val datatype_decl =
 17.2082 +  Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.type_args -- P.name -- P.opt_infix --
 17.2083 +    (P.$$$ "=" |-- P.enum1 "|" (P.name -- Scan.repeat P.typ -- P.opt_mixfix));
 17.2084 +
 17.2085 +fun mk_datatype args =
 17.2086 +  let
 17.2087 +    val names = map (fn ((((NONE, _), t), _), _) => t | ((((SOME t, _), _), _), _) => t) args;
 17.2088 +    val specs = map (fn ((((_, vs), t), mx), cons) =>
 17.2089 +      (vs, t, mx, map (fn ((x, y), z) => (x, y, z)) cons)) args;
 17.2090 +  in add_nominal_datatype DatatypeAux.default_datatype_config names specs end;
 17.2091 +
 17.2092 +val _ =
 17.2093 +  OuterSyntax.command "nominal_datatype" "define inductive datatypes" K.thy_decl
 17.2094 +    (P.and_list1 datatype_decl >> (Toplevel.theory o mk_datatype));
 17.2095 +
 17.2096 +end;
 17.2097 +
 17.2098 +end
    18.1 --- a/src/HOL/Nominal/nominal_atoms.ML	Fri Jun 19 20:22:46 2009 +0200
    18.2 +++ b/src/HOL/Nominal/nominal_atoms.ML	Fri Jun 19 21:08:07 2009 +0200
    18.3 @@ -101,7 +101,7 @@
    18.4      val (_,thy1) = 
    18.5      fold_map (fn ak => fn thy => 
    18.6            let val dt = ([], Binding.name ak, NoSyn, [(Binding.name ak, [@{typ nat}], NoSyn)])
    18.7 -              val ({inject,case_thms,...},thy1) = DatatypePackage.add_datatype
    18.8 +              val ({inject,case_thms,...},thy1) = Datatype.add_datatype
    18.9                  DatatypeAux.default_datatype_config [ak] [dt] thy
   18.10                val inject_flat = flat inject
   18.11                val ak_type = Type (Sign.intern_type thy1 ak,[])
   18.12 @@ -191,7 +191,7 @@
   18.13          thy |> Sign.add_consts_i [(Binding.name ("swap_" ^ ak_name), swapT, NoSyn)] 
   18.14              |> PureThy.add_defs_unchecked true [((Binding.name name, def2),[])]
   18.15              |> snd
   18.16 -            |> OldPrimrecPackage.add_primrec_unchecked_i "" [(("", def1),[])]
   18.17 +            |> OldPrimrec.add_primrec_unchecked_i "" [(("", def1),[])]
   18.18        end) ak_names_types thy1;
   18.19      
   18.20      (* declares a permutation function for every atom-kind acting  *)
   18.21 @@ -219,7 +219,7 @@
   18.22                      Const (swap_name, swapT) $ x $ (Const (qu_prm_name, prmT) $ xs $ a)));
   18.23        in
   18.24          thy |> Sign.add_consts_i [(Binding.name prm_name, mk_permT T --> T --> T, NoSyn)] 
   18.25 -            |> OldPrimrecPackage.add_primrec_unchecked_i "" [(("", def1), []),(("", def2), [])]
   18.26 +            |> OldPrimrec.add_primrec_unchecked_i "" [(("", def1), []),(("", def2), [])]
   18.27        end) ak_names_types thy3;
   18.28      
   18.29      (* defines permutation functions for all combinations of atom-kinds; *)
    19.1 --- a/src/HOL/Nominal/nominal_inductive.ML	Fri Jun 19 20:22:46 2009 +0200
    19.2 +++ b/src/HOL/Nominal/nominal_inductive.ML	Fri Jun 19 21:08:07 2009 +0200
    19.3 @@ -53,7 +53,7 @@
    19.4  fun add_binders thy i (t as (_ $ _)) bs = (case strip_comb t of
    19.5        (Const (s, T), ts) => (case strip_type T of
    19.6          (Ts, Type (tname, _)) =>
    19.7 -          (case NominalPackage.get_nominal_datatype thy tname of
    19.8 +          (case Nominal.get_nominal_datatype thy tname of
    19.9               NONE => fold (add_binders thy i) ts bs
   19.10             | SOME {descr, index, ...} => (case AList.lookup op =
   19.11                   (#3 (the (AList.lookup op = descr index))) s of
   19.12 @@ -148,11 +148,11 @@
   19.13    let
   19.14      val thy = ProofContext.theory_of ctxt;
   19.15      val ({names, ...}, {raw_induct, intrs, elims, ...}) =
   19.16 -      InductivePackage.the_inductive ctxt (Sign.intern_const thy s);
   19.17 -    val ind_params = InductivePackage.params_of raw_induct;
   19.18 +      Inductive.the_inductive ctxt (Sign.intern_const thy s);
   19.19 +    val ind_params = Inductive.params_of raw_induct;
   19.20      val raw_induct = atomize_induct ctxt raw_induct;
   19.21      val elims = map (atomize_induct ctxt) elims;
   19.22 -    val monos = InductivePackage.get_monos ctxt;
   19.23 +    val monos = Inductive.get_monos ctxt;
   19.24      val eqvt_thms = NominalThmDecls.get_eqvt_thms ctxt;
   19.25      val _ = (case names \\ fold (Term.add_const_names o Thm.prop_of) eqvt_thms [] of
   19.26          [] => ()
   19.27 @@ -230,7 +230,7 @@
   19.28            else NONE) xs @ mk_distinct xs;
   19.29  
   19.30      fun mk_fresh (x, T) = HOLogic.mk_Trueprop
   19.31 -      (NominalPackage.fresh_const T fsT $ x $ Bound 0);
   19.32 +      (Nominal.fresh_const T fsT $ x $ Bound 0);
   19.33  
   19.34      val (prems', prems'') = split_list (map (fn (params, bvars, prems, (p, ts)) =>
   19.35        let
   19.36 @@ -254,7 +254,7 @@
   19.37      val concl = HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
   19.38        (map (fn (prem, (p, ts)) => HOLogic.mk_imp (prem,
   19.39          HOLogic.list_all (ind_vars, lift_pred p
   19.40 -          (map (fold_rev (NominalPackage.mk_perm ind_Ts)
   19.41 +          (map (fold_rev (Nominal.mk_perm ind_Ts)
   19.42              (map Bound (length atomTs downto 1))) ts)))) concls));
   19.43  
   19.44      val concl' = HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
   19.45 @@ -268,7 +268,7 @@
   19.46               else map_term (split_conj (K o I) names) prem prem) prems, q))))
   19.47          (mk_distinct bvars @
   19.48           maps (fn (t, T) => map (fn (u, U) => HOLogic.mk_Trueprop
   19.49 -           (NominalPackage.fresh_const U T $ u $ t)) bvars)
   19.50 +           (Nominal.fresh_const U T $ u $ t)) bvars)
   19.51               (ts ~~ binder_types (fastype_of p)))) prems;
   19.52  
   19.53      val perm_pi_simp = PureThy.get_thms thy "perm_pi_simp";
   19.54 @@ -296,7 +296,7 @@
   19.55          val p = foldr1 HOLogic.mk_prod (map protect ts @ freshs1);
   19.56          val ex = Goal.prove ctxt [] [] (HOLogic.mk_Trueprop
   19.57              (HOLogic.exists_const T $ Abs ("x", T,
   19.58 -              NominalPackage.fresh_const T (fastype_of p) $
   19.59 +              Nominal.fresh_const T (fastype_of p) $
   19.60                  Bound 0 $ p)))
   19.61            (fn _ => EVERY
   19.62              [resolve_tac exists_fresh' 1,
   19.63 @@ -325,13 +325,13 @@
   19.64                     (fn (Bound i, T) => (nth params' (length params' - i), T)
   19.65                       | (t, T) => (t, T)) bvars;
   19.66                   val pi_bvars = map (fn (t, _) =>
   19.67 -                   fold_rev (NominalPackage.mk_perm []) pis t) bvars';
   19.68 +                   fold_rev (Nominal.mk_perm []) pis t) bvars';
   19.69                   val (P, ts) = strip_comb (HOLogic.dest_Trueprop (term_of concl));
   19.70                   val (freshs1, freshs2, ctxt'') = fold
   19.71                     (obtain_fresh_name (ts @ pi_bvars))
   19.72                     (map snd bvars') ([], [], ctxt');
   19.73 -                 val freshs2' = NominalPackage.mk_not_sym freshs2;
   19.74 -                 val pis' = map NominalPackage.perm_of_pair (pi_bvars ~~ freshs1);
   19.75 +                 val freshs2' = Nominal.mk_not_sym freshs2;
   19.76 +                 val pis' = map Nominal.perm_of_pair (pi_bvars ~~ freshs1);
   19.77                   fun concat_perm pi1 pi2 =
   19.78                     let val T = fastype_of pi1
   19.79                     in if T = fastype_of pi2 then
   19.80 @@ -343,11 +343,11 @@
   19.81                     (Vartab.empty, Vartab.empty);
   19.82                   val ihyp' = Thm.instantiate ([], map (pairself (cterm_of thy))
   19.83                     (map (Envir.subst_vars env) vs ~~
   19.84 -                    map (fold_rev (NominalPackage.mk_perm [])
   19.85 +                    map (fold_rev (Nominal.mk_perm [])
   19.86                        (rev pis' @ pis)) params' @ [z])) ihyp;
   19.87                   fun mk_pi th =
   19.88                     Simplifier.simplify (HOL_basic_ss addsimps [@{thm id_apply}]
   19.89 -                       addsimprocs [NominalPackage.perm_simproc])
   19.90 +                       addsimprocs [Nominal.perm_simproc])
   19.91                       (Simplifier.simplify eqvt_ss
   19.92                         (fold_rev (mk_perm_bool o cterm_of thy)
   19.93                           (rev pis' @ pis) th));
   19.94 @@ -369,13 +369,13 @@
   19.95                         | _ $ (_ $ (_ $ lhs $ rhs)) =>
   19.96                             (curry (HOLogic.mk_not o HOLogic.mk_eq), lhs, rhs));
   19.97                       val th'' = Goal.prove ctxt'' [] [] (HOLogic.mk_Trueprop
   19.98 -                         (bop (fold_rev (NominalPackage.mk_perm []) pis lhs)
   19.99 -                            (fold_rev (NominalPackage.mk_perm []) pis rhs)))
  19.100 +                         (bop (fold_rev (Nominal.mk_perm []) pis lhs)
  19.101 +                            (fold_rev (Nominal.mk_perm []) pis rhs)))
  19.102                         (fn _ => simp_tac (HOL_basic_ss addsimps
  19.103                            (fresh_bij @ perm_bij)) 1 THEN rtac th' 1)
  19.104                     in Simplifier.simplify (eqvt_ss addsimps fresh_atm) th'' end)
  19.105                       vc_compat_ths;
  19.106 -                 val vc_compat_ths'' = NominalPackage.mk_not_sym vc_compat_ths';
  19.107 +                 val vc_compat_ths'' = Nominal.mk_not_sym vc_compat_ths';
  19.108                   (** Since swap_simps simplifies (pi :: 'a prm) o (x :: 'b) to x **)
  19.109                   (** we have to pre-simplify the rewrite rules                   **)
  19.110                   val swap_simps_ss = HOL_ss addsimps swap_simps @
  19.111 @@ -383,14 +383,14 @@
  19.112                        (vc_compat_ths'' @ freshs2');
  19.113                   val th = Goal.prove ctxt'' [] []
  19.114                     (HOLogic.mk_Trueprop (list_comb (P $ hd ts,
  19.115 -                     map (fold (NominalPackage.mk_perm []) pis') (tl ts))))
  19.116 +                     map (fold (Nominal.mk_perm []) pis') (tl ts))))
  19.117                     (fn _ => EVERY ([simp_tac eqvt_ss 1, rtac ihyp' 1,
  19.118                       REPEAT_DETERM_N (nprems_of ihyp - length gprems)
  19.119                         (simp_tac swap_simps_ss 1),
  19.120                       REPEAT_DETERM_N (length gprems)
  19.121                         (simp_tac (HOL_basic_ss
  19.122                            addsimps [inductive_forall_def']
  19.123 -                          addsimprocs [NominalPackage.perm_simproc]) 1 THEN
  19.124 +                          addsimprocs [Nominal.perm_simproc]) 1 THEN
  19.125                          resolve_tac gprems2 1)]));
  19.126                   val final = Goal.prove ctxt'' [] [] (term_of concl)
  19.127                     (fn _ => cut_facts_tac [th] 1 THEN full_simp_tac (HOL_ss
  19.128 @@ -435,7 +435,7 @@
  19.129               ((ps, qs, is, map (curry subst_bounds (rev ts)) prems), ctxt')
  19.130             end) (prems ~~ avoids) ctxt')
  19.131        end)
  19.132 -        (InductivePackage.partition_rules' raw_induct (intrs ~~ avoids') ~~
  19.133 +        (Inductive.partition_rules' raw_induct (intrs ~~ avoids') ~~
  19.134           elims);
  19.135  
  19.136      val cases_prems' =
  19.137 @@ -448,7 +448,7 @@
  19.138                    (Logic.list_implies
  19.139                      (mk_distinct qs @
  19.140                       maps (fn (t, T) => map (fn u => HOLogic.mk_Trueprop
  19.141 -                      (NominalPackage.fresh_const T (fastype_of u) $ t $ u))
  19.142 +                      (Nominal.fresh_const T (fastype_of u) $ t $ u))
  19.143                          args) qs,
  19.144                       HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  19.145                         (map HOLogic.dest_Trueprop prems))),
  19.146 @@ -499,13 +499,13 @@
  19.147                      chop (length vc_compat_ths - length args * length qs)
  19.148                        (map (first_order_mrs hyps2) vc_compat_ths);
  19.149                    val vc_compat_ths' =
  19.150 -                    NominalPackage.mk_not_sym vc_compat_ths1 @
  19.151 +                    Nominal.mk_not_sym vc_compat_ths1 @
  19.152                      flat (fst (fold_map inst_fresh hyps1 vc_compat_ths2));
  19.153                    val (freshs1, freshs2, ctxt3) = fold
  19.154                      (obtain_fresh_name (args @ map fst qs @ params'))
  19.155                      (map snd qs) ([], [], ctxt2);
  19.156 -                  val freshs2' = NominalPackage.mk_not_sym freshs2;
  19.157 -                  val pis = map (NominalPackage.perm_of_pair)
  19.158 +                  val freshs2' = Nominal.mk_not_sym freshs2;
  19.159 +                  val pis = map (Nominal.perm_of_pair)
  19.160                      ((freshs1 ~~ map fst qs) @ (params' ~~ freshs1));
  19.161                    val mk_pis = fold_rev mk_perm_bool (map (cterm_of thy) pis);
  19.162                    val obj = cterm_of thy (foldr1 HOLogic.mk_conj (map (map_aterms
  19.163 @@ -513,7 +513,7 @@
  19.164                             if x mem args then x
  19.165                             else (case AList.lookup op = tab x of
  19.166                               SOME y => y
  19.167 -                           | NONE => fold_rev (NominalPackage.mk_perm []) pis x)
  19.168 +                           | NONE => fold_rev (Nominal.mk_perm []) pis x)
  19.169                         | x => x) o HOLogic.dest_Trueprop o prop_of) case_hyps));
  19.170                    val inst = Thm.first_order_match (Thm.dest_arg
  19.171                      (Drule.strip_imp_concl (hd (cprems_of case_hyp))), obj);
  19.172 @@ -522,7 +522,7 @@
  19.173                         rtac (Thm.instantiate inst case_hyp) 1 THEN
  19.174                         SUBPROOF (fn {prems = fresh_hyps, ...} =>
  19.175                           let
  19.176 -                           val fresh_hyps' = NominalPackage.mk_not_sym fresh_hyps;
  19.177 +                           val fresh_hyps' = Nominal.mk_not_sym fresh_hyps;
  19.178                             val case_ss = cases_eqvt_ss addsimps freshs2' @
  19.179                               simp_fresh_atm (vc_compat_ths' @ fresh_hyps');
  19.180                             val fresh_fresh_ss = case_ss addsimps perm_fresh_fresh;
  19.181 @@ -548,13 +548,13 @@
  19.182          val rec_name = space_implode "_" (map Long_Name.base_name names);
  19.183          val rec_qualified = Binding.qualify false rec_name;
  19.184          val ind_case_names = RuleCases.case_names induct_cases;
  19.185 -        val induct_cases' = InductivePackage.partition_rules' raw_induct
  19.186 +        val induct_cases' = Inductive.partition_rules' raw_induct
  19.187            (intrs ~~ induct_cases); 
  19.188          val thss' = map (map atomize_intr) thss;
  19.189 -        val thsss = InductivePackage.partition_rules' raw_induct (intrs ~~ thss');
  19.190 +        val thsss = Inductive.partition_rules' raw_induct (intrs ~~ thss');
  19.191          val strong_raw_induct =
  19.192 -          mk_ind_proof ctxt thss' |> InductivePackage.rulify;
  19.193 -        val strong_cases = map (mk_cases_proof ##> InductivePackage.rulify)
  19.194 +          mk_ind_proof ctxt thss' |> Inductive.rulify;
  19.195 +        val strong_cases = map (mk_cases_proof ##> Inductive.rulify)
  19.196            (thsss ~~ elims ~~ cases_prems ~~ cases_prems');
  19.197          val strong_induct =
  19.198            if length names > 1 then
  19.199 @@ -587,17 +587,17 @@
  19.200    let
  19.201      val thy = ProofContext.theory_of ctxt;
  19.202      val ({names, ...}, {raw_induct, intrs, elims, ...}) =
  19.203 -      InductivePackage.the_inductive ctxt (Sign.intern_const thy s);
  19.204 +      Inductive.the_inductive ctxt (Sign.intern_const thy s);
  19.205      val raw_induct = atomize_induct ctxt raw_induct;
  19.206      val elims = map (atomize_induct ctxt) elims;
  19.207      val intrs = map atomize_intr intrs;
  19.208 -    val monos = InductivePackage.get_monos ctxt;
  19.209 -    val intrs' = InductivePackage.unpartition_rules intrs
  19.210 +    val monos = Inductive.get_monos ctxt;
  19.211 +    val intrs' = Inductive.unpartition_rules intrs
  19.212        (map (fn (((s, ths), (_, k)), th) =>
  19.213 -           (s, ths ~~ InductivePackage.infer_intro_vars th k ths))
  19.214 -         (InductivePackage.partition_rules raw_induct intrs ~~
  19.215 -          InductivePackage.arities_of raw_induct ~~ elims));
  19.216 -    val k = length (InductivePackage.params_of raw_induct);
  19.217 +           (s, ths ~~ Inductive.infer_intro_vars th k ths))
  19.218 +         (Inductive.partition_rules raw_induct intrs ~~
  19.219 +          Inductive.arities_of raw_induct ~~ elims));
  19.220 +    val k = length (Inductive.params_of raw_induct);
  19.221      val atoms' = NominalAtoms.atoms_of thy;
  19.222      val atoms =
  19.223        if null xatoms then atoms' else
  19.224 @@ -635,7 +635,7 @@
  19.225              val prems'' = map (fn th => Simplifier.simplify eqvt_ss
  19.226                (mk_perm_bool (cterm_of thy pi) th)) prems';
  19.227              val intr' = Drule.cterm_instantiate (map (cterm_of thy) vs ~~
  19.228 -               map (cterm_of thy o NominalPackage.mk_perm [] pi o term_of) params)
  19.229 +               map (cterm_of thy o Nominal.mk_perm [] pi o term_of) params)
  19.230                 intr
  19.231            in (rtac intr' THEN_ALL_NEW (TRY o resolve_tac prems'')) 1
  19.232            end) ctxt' 1 st
  19.233 @@ -655,7 +655,7 @@
  19.234                val (ts1, ts2) = chop k ts
  19.235              in
  19.236                HOLogic.mk_imp (p, list_comb (h, ts1 @
  19.237 -                map (NominalPackage.mk_perm [] pi') ts2))
  19.238 +                map (Nominal.mk_perm [] pi') ts2))
  19.239              end) ps)))
  19.240            (fn {context, ...} => EVERY (rtac raw_induct 1 :: map (fn intr_vs =>
  19.241                full_simp_tac eqvt_ss 1 THEN
    20.1 --- a/src/HOL/Nominal/nominal_inductive2.ML	Fri Jun 19 20:22:46 2009 +0200
    20.2 +++ b/src/HOL/Nominal/nominal_inductive2.ML	Fri Jun 19 21:08:07 2009 +0200
    20.3 @@ -56,7 +56,7 @@
    20.4  fun add_binders thy i (t as (_ $ _)) bs = (case strip_comb t of
    20.5        (Const (s, T), ts) => (case strip_type T of
    20.6          (Ts, Type (tname, _)) =>
    20.7 -          (case NominalPackage.get_nominal_datatype thy tname of
    20.8 +          (case Nominal.get_nominal_datatype thy tname of
    20.9               NONE => fold (add_binders thy i) ts bs
   20.10             | SOME {descr, index, ...} => (case AList.lookup op =
   20.11                   (#3 (the (AList.lookup op = descr index))) s of
   20.12 @@ -154,11 +154,11 @@
   20.13    let
   20.14      val thy = ProofContext.theory_of ctxt;
   20.15      val ({names, ...}, {raw_induct, intrs, elims, ...}) =
   20.16 -      InductivePackage.the_inductive ctxt (Sign.intern_const thy s);
   20.17 -    val ind_params = InductivePackage.params_of raw_induct;
   20.18 +      Inductive.the_inductive ctxt (Sign.intern_const thy s);
   20.19 +    val ind_params = Inductive.params_of raw_induct;
   20.20      val raw_induct = atomize_induct ctxt raw_induct;
   20.21      val elims = map (atomize_induct ctxt) elims;
   20.22 -    val monos = InductivePackage.get_monos ctxt;
   20.23 +    val monos = Inductive.get_monos ctxt;
   20.24      val eqvt_thms = NominalThmDecls.get_eqvt_thms ctxt;
   20.25      val _ = (case names \\ fold (Term.add_const_names o Thm.prop_of) eqvt_thms [] of
   20.26          [] => ()
   20.27 @@ -249,7 +249,7 @@
   20.28        | lift_prem t = t;
   20.29  
   20.30      fun mk_fresh (x, T) = HOLogic.mk_Trueprop
   20.31 -      (NominalPackage.fresh_star_const T fsT $ x $ Bound 0);
   20.32 +      (Nominal.fresh_star_const T fsT $ x $ Bound 0);
   20.33  
   20.34      val (prems', prems'') = split_list (map (fn (params, sets, prems, (p, ts)) =>
   20.35        let
   20.36 @@ -270,7 +270,7 @@
   20.37      val concl = HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
   20.38        (map (fn (prem, (p, ts)) => HOLogic.mk_imp (prem,
   20.39          HOLogic.list_all (ind_vars, lift_pred p
   20.40 -          (map (fold_rev (NominalPackage.mk_perm ind_Ts)
   20.41 +          (map (fold_rev (Nominal.mk_perm ind_Ts)
   20.42              (map Bound (length atomTs downto 1))) ts)))) concls));
   20.43  
   20.44      val concl' = HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
   20.45 @@ -283,7 +283,7 @@
   20.46               if null (preds_of ps prem) then SOME prem
   20.47               else map_term (split_conj (K o I) names) prem prem) prems, q))))
   20.48          (maps (fn (t, T) => map (fn (u, U) => HOLogic.mk_Trueprop
   20.49 -           (NominalPackage.fresh_star_const U T $ u $ t)) sets)
   20.50 +           (Nominal.fresh_star_const U T $ u $ t)) sets)
   20.51               (ts ~~ binder_types (fastype_of p)) @
   20.52           map (fn (u, U) => HOLogic.mk_Trueprop (Const (@{const_name finite},
   20.53             HOLogic.mk_setT U --> HOLogic.boolT) $ u)) sets) |>
   20.54 @@ -339,7 +339,7 @@
   20.55          val th2' =
   20.56            Goal.prove ctxt [] []
   20.57              (list_all (map (pair "pi") pTs, HOLogic.mk_Trueprop
   20.58 -               (f $ fold_rev (NominalPackage.mk_perm (rev pTs))
   20.59 +               (f $ fold_rev (Nominal.mk_perm (rev pTs))
   20.60                    (pis1 @ pi :: pis2) l $ r)))
   20.61              (fn _ => cut_facts_tac [th2] 1 THEN
   20.62                 full_simp_tac (HOL_basic_ss addsimps perm_set_forget) 1) |>
   20.63 @@ -364,7 +364,7 @@
   20.64                   val params' = map term_of cparams'
   20.65                   val sets' = map (apfst (curry subst_bounds (rev params'))) sets;
   20.66                   val pi_sets = map (fn (t, _) =>
   20.67 -                   fold_rev (NominalPackage.mk_perm []) pis t) sets';
   20.68 +                   fold_rev (Nominal.mk_perm []) pis t) sets';
   20.69                   val (P, ts) = strip_comb (HOLogic.dest_Trueprop (term_of concl));
   20.70                   val gprems1 = List.mapPartial (fn (th, t) =>
   20.71                     if null (preds_of ps t) then SOME th
   20.72 @@ -380,7 +380,7 @@
   20.73                     in
   20.74                       Goal.prove ctxt' [] []
   20.75                         (HOLogic.mk_Trueprop (list_comb (h,
   20.76 -                          map (fold_rev (NominalPackage.mk_perm []) pis) ts)))
   20.77 +                          map (fold_rev (Nominal.mk_perm []) pis) ts)))
   20.78                         (fn _ => simp_tac (HOL_basic_ss addsimps
   20.79                            (fresh_star_bij @ finite_ineq)) 1 THEN rtac th' 1)
   20.80                     end) vc_compat_ths vc_compat_vs;
   20.81 @@ -400,11 +400,11 @@
   20.82                     end;
   20.83                   val pis'' = fold_rev (concat_perm #> map) pis' pis;
   20.84                   val ihyp' = inst_params thy vs_ihypt ihyp
   20.85 -                   (map (fold_rev (NominalPackage.mk_perm [])
   20.86 +                   (map (fold_rev (Nominal.mk_perm [])
   20.87                        (pis' @ pis) #> cterm_of thy) params' @ [cterm_of thy z]);
   20.88                   fun mk_pi th =
   20.89                     Simplifier.simplify (HOL_basic_ss addsimps [@{thm id_apply}]
   20.90 -                       addsimprocs [NominalPackage.perm_simproc])
   20.91 +                       addsimprocs [Nominal.perm_simproc])
   20.92                       (Simplifier.simplify eqvt_ss
   20.93                         (fold_rev (mk_perm_bool o cterm_of thy)
   20.94                           (pis' @ pis) th));
   20.95 @@ -419,13 +419,13 @@
   20.96                       (fresh_ths2 ~~ sets);
   20.97                   val th = Goal.prove ctxt'' [] []
   20.98                     (HOLogic.mk_Trueprop (list_comb (P $ hd ts,
   20.99 -                     map (fold_rev (NominalPackage.mk_perm []) pis') (tl ts))))
  20.100 +                     map (fold_rev (Nominal.mk_perm []) pis') (tl ts))))
  20.101                     (fn _ => EVERY ([simp_tac eqvt_ss 1, rtac ihyp' 1] @
  20.102                       map (fn th => rtac th 1) fresh_ths3 @
  20.103                       [REPEAT_DETERM_N (length gprems)
  20.104                         (simp_tac (HOL_basic_ss
  20.105                            addsimps [inductive_forall_def']
  20.106 -                          addsimprocs [NominalPackage.perm_simproc]) 1 THEN
  20.107 +                          addsimprocs [Nominal.perm_simproc]) 1 THEN
  20.108                          resolve_tac gprems2 1)]));
  20.109                   val final = Goal.prove ctxt'' [] [] (term_of concl)
  20.110                     (fn _ => cut_facts_tac [th] 1 THEN full_simp_tac (HOL_ss
  20.111 @@ -450,12 +450,12 @@
  20.112          val rec_name = space_implode "_" (map Long_Name.base_name names);
  20.113          val rec_qualified = Binding.qualify false rec_name;
  20.114          val ind_case_names = RuleCases.case_names induct_cases;
  20.115 -        val induct_cases' = InductivePackage.partition_rules' raw_induct
  20.116 +        val induct_cases' = Inductive.partition_rules' raw_induct
  20.117            (intrs ~~ induct_cases); 
  20.118          val thss' = map (map atomize_intr) thss;
  20.119 -        val thsss = InductivePackage.partition_rules' raw_induct (intrs ~~ thss');
  20.120 +        val thsss = Inductive.partition_rules' raw_induct (intrs ~~ thss');
  20.121          val strong_raw_induct =
  20.122 -          mk_ind_proof ctxt thss' |> InductivePackage.rulify;
  20.123 +          mk_ind_proof ctxt thss' |> Inductive.rulify;
  20.124          val strong_induct =
  20.125            if length names > 1 then
  20.126              (strong_raw_induct, [ind_case_names, RuleCases.consumes 0])
    21.1 --- a/src/HOL/Nominal/nominal_package.ML	Fri Jun 19 20:22:46 2009 +0200
    21.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    21.3 @@ -1,2095 +0,0 @@
    21.4 -(*  Title:      HOL/Nominal/nominal_package.ML
    21.5 -    Author:     Stefan Berghofer and Christian Urban, TU Muenchen
    21.6 -
    21.7 -Nominal datatype package for Isabelle/HOL.
    21.8 -*)
    21.9 -
   21.10 -signature NOMINAL_PACKAGE =
   21.11 -sig
   21.12 -  val add_nominal_datatype : DatatypeAux.datatype_config -> string list ->
   21.13 -    (string list * bstring * mixfix *
   21.14 -      (bstring * string list * mixfix) list) list -> theory -> theory
   21.15 -  type descr
   21.16 -  type nominal_datatype_info
   21.17 -  val get_nominal_datatypes : theory -> nominal_datatype_info Symtab.table
   21.18 -  val get_nominal_datatype : theory -> string -> nominal_datatype_info option
   21.19 -  val mk_perm: typ list -> term -> term -> term
   21.20 -  val perm_of_pair: term * term -> term
   21.21 -  val mk_not_sym: thm list -> thm list
   21.22 -  val perm_simproc: simproc
   21.23 -  val fresh_const: typ -> typ -> term
   21.24 -  val fresh_star_const: typ -> typ -> term
   21.25 -end
   21.26 -
   21.27 -structure NominalPackage : NOMINAL_PACKAGE =
   21.28 -struct
   21.29 -
   21.30 -val finite_emptyI = thm "finite.emptyI";
   21.31 -val finite_Diff = thm "finite_Diff";
   21.32 -val finite_Un = thm "finite_Un";
   21.33 -val Un_iff = thm "Un_iff";
   21.34 -val In0_eq = thm "In0_eq";
   21.35 -val In1_eq = thm "In1_eq";
   21.36 -val In0_not_In1 = thm "In0_not_In1";
   21.37 -val In1_not_In0 = thm "In1_not_In0";
   21.38 -val Un_assoc = thm "Un_assoc";
   21.39 -val Collect_disj_eq = thm "Collect_disj_eq";
   21.40 -val empty_def = thm "empty_def";
   21.41 -val empty_iff = thm "empty_iff";
   21.42 -
   21.43 -open DatatypeAux;
   21.44 -open NominalAtoms;
   21.45 -
   21.46 -(** FIXME: DatatypePackage should export this function **)
   21.47 -
   21.48 -local
   21.49 -
   21.50 -fun dt_recs (DtTFree _) = []
   21.51 -  | dt_recs (DtType (_, dts)) = List.concat (map dt_recs dts)
   21.52 -  | dt_recs (DtRec i) = [i];
   21.53 -
   21.54 -fun dt_cases (descr: descr) (_, args, constrs) =
   21.55 -  let
   21.56 -    fun the_bname i = Long_Name.base_name (#1 (valOf (AList.lookup (op =) descr i)));
   21.57 -    val bnames = map the_bname (distinct op = (List.concat (map dt_recs args)));
   21.58 -  in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
   21.59 -
   21.60 -
   21.61 -fun induct_cases descr =
   21.62 -  DatatypeProp.indexify_names (List.concat (map (dt_cases descr) (map #2 descr)));
   21.63 -
   21.64 -fun exhaust_cases descr i = dt_cases descr (valOf (AList.lookup (op =) descr i));
   21.65 -
   21.66 -in
   21.67 -
   21.68 -fun mk_case_names_induct descr = RuleCases.case_names (induct_cases descr);
   21.69 -
   21.70 -fun mk_case_names_exhausts descr new =
   21.71 -  map (RuleCases.case_names o exhaust_cases descr o #1)
   21.72 -    (List.filter (fn ((_, (name, _, _))) => name mem_string new) descr);
   21.73 -
   21.74 -end;
   21.75 -
   21.76 -(* theory data *)
   21.77 -
   21.78 -type descr = (int * (string * dtyp list * (string * (dtyp list * dtyp) list) list)) list;
   21.79 -
   21.80 -type nominal_datatype_info =
   21.81 -  {index : int,
   21.82 -   descr : descr,
   21.83 -   sorts : (string * sort) list,
   21.84 -   rec_names : string list,
   21.85 -   rec_rewrites : thm list,
   21.86 -   induction : thm,
   21.87 -   distinct : thm list,
   21.88 -   inject : thm list};
   21.89 -
   21.90 -structure NominalDatatypesData = TheoryDataFun
   21.91 -(
   21.92 -  type T = nominal_datatype_info Symtab.table;
   21.93 -  val empty = Symtab.empty;
   21.94 -  val copy = I;
   21.95 -  val extend = I;
   21.96 -  fun merge _ tabs : T = Symtab.merge (K true) tabs;
   21.97 -);
   21.98 -
   21.99 -val get_nominal_datatypes = NominalDatatypesData.get;
  21.100 -val put_nominal_datatypes = NominalDatatypesData.put;
  21.101 -val map_nominal_datatypes = NominalDatatypesData.map;
  21.102 -val get_nominal_datatype = Symtab.lookup o get_nominal_datatypes;
  21.103 -
  21.104 -
  21.105 -(**** make datatype info ****)
  21.106 -
  21.107 -fun make_dt_info descr sorts induct reccomb_names rec_thms
  21.108 -    (((i, (_, (tname, _, _))), distinct), inject) =
  21.109 -  (tname,
  21.110 -   {index = i,
  21.111 -    descr = descr,
  21.112 -    sorts = sorts,
  21.113 -    rec_names = reccomb_names,
  21.114 -    rec_rewrites = rec_thms,
  21.115 -    induction = induct,
  21.116 -    distinct = distinct,
  21.117 -    inject = inject});
  21.118 -
  21.119 -(*******************************)
  21.120 -
  21.121 -val (_ $ (_ $ (_ $ (distinct_f $ _) $ _))) = hd (prems_of distinct_lemma);
  21.122 -
  21.123 -
  21.124 -(** simplification procedure for sorting permutations **)
  21.125 -
  21.126 -val dj_cp = thm "dj_cp";
  21.127 -
  21.128 -fun dest_permT (Type ("fun", [Type ("List.list", [Type ("*", [T, _])]),
  21.129 -      Type ("fun", [_, U])])) = (T, U);
  21.130 -
  21.131 -fun permTs_of (Const ("Nominal.perm", T) $ t $ u) = fst (dest_permT T) :: permTs_of u
  21.132 -  | permTs_of _ = [];
  21.133 -
  21.134 -fun perm_simproc' thy ss (Const ("Nominal.perm", T) $ t $ (u as Const ("Nominal.perm", U) $ r $ s)) =
  21.135 -      let
  21.136 -        val (aT as Type (a, []), S) = dest_permT T;
  21.137 -        val (bT as Type (b, []), _) = dest_permT U
  21.138 -      in if aT mem permTs_of u andalso aT <> bT then
  21.139 -          let
  21.140 -            val cp = cp_inst_of thy a b;
  21.141 -            val dj = dj_thm_of thy b a;
  21.142 -            val dj_cp' = [cp, dj] MRS dj_cp;
  21.143 -            val cert = SOME o cterm_of thy
  21.144 -          in
  21.145 -            SOME (mk_meta_eq (Drule.instantiate' [SOME (ctyp_of thy S)]
  21.146 -              [cert t, cert r, cert s] dj_cp'))
  21.147 -          end
  21.148 -        else NONE
  21.149 -      end
  21.150 -  | perm_simproc' thy ss _ = NONE;
  21.151 -
  21.152 -val perm_simproc =
  21.153 -  Simplifier.simproc (the_context ()) "perm_simp" ["pi1 \<bullet> (pi2 \<bullet> x)"] perm_simproc';
  21.154 -
  21.155 -val meta_spec = thm "meta_spec";
  21.156 -
  21.157 -fun projections rule =
  21.158 -  ProjectRule.projections (ProofContext.init (Thm.theory_of_thm rule)) rule
  21.159 -  |> map (standard #> RuleCases.save rule);
  21.160 -
  21.161 -val supp_prod = thm "supp_prod";
  21.162 -val fresh_prod = thm "fresh_prod";
  21.163 -val supports_fresh = thm "supports_fresh";
  21.164 -val supports_def = thm "Nominal.supports_def";
  21.165 -val fresh_def = thm "fresh_def";
  21.166 -val supp_def = thm "supp_def";
  21.167 -val rev_simps = thms "rev.simps";
  21.168 -val app_simps = thms "append.simps";
  21.169 -val at_fin_set_supp = thm "at_fin_set_supp";
  21.170 -val at_fin_set_fresh = thm "at_fin_set_fresh";
  21.171 -val abs_fun_eq1 = thm "abs_fun_eq1";
  21.172 -
  21.173 -val collect_simp = rewrite_rule [mk_meta_eq mem_Collect_eq];
  21.174 -
  21.175 -fun mk_perm Ts t u =
  21.176 -  let
  21.177 -    val T = fastype_of1 (Ts, t);
  21.178 -    val U = fastype_of1 (Ts, u)
  21.179 -  in Const ("Nominal.perm", T --> U --> U) $ t $ u end;
  21.180 -
  21.181 -fun perm_of_pair (x, y) =
  21.182 -  let
  21.183 -    val T = fastype_of x;
  21.184 -    val pT = mk_permT T
  21.185 -  in Const ("List.list.Cons", HOLogic.mk_prodT (T, T) --> pT --> pT) $
  21.186 -    HOLogic.mk_prod (x, y) $ Const ("List.list.Nil", pT)
  21.187 -  end;
  21.188 -
  21.189 -fun mk_not_sym ths = maps (fn th => case prop_of th of
  21.190 -    _ $ (Const ("Not", _) $ (Const ("op =", _) $ _ $ _)) => [th, th RS not_sym]
  21.191 -  | _ => [th]) ths;
  21.192 -
  21.193 -fun fresh_const T U = Const ("Nominal.fresh", T --> U --> HOLogic.boolT);
  21.194 -fun fresh_star_const T U =
  21.195 -  Const ("Nominal.fresh_star", HOLogic.mk_setT T --> U --> HOLogic.boolT);
  21.196 -
  21.197 -fun gen_add_nominal_datatype prep_typ config new_type_names dts thy =
  21.198 -  let
  21.199 -    (* this theory is used just for parsing *)
  21.200 -
  21.201 -    val tmp_thy = thy |>
  21.202 -      Theory.copy |>
  21.203 -      Sign.add_types (map (fn (tvs, tname, mx, _) =>
  21.204 -        (Binding.name tname, length tvs, mx)) dts);
  21.205 -
  21.206 -    val atoms = atoms_of thy;
  21.207 -
  21.208 -    fun prep_constr ((constrs, sorts), (cname, cargs, mx)) =
  21.209 -      let val (cargs', sorts') = Library.foldl (prep_typ tmp_thy) (([], sorts), cargs)
  21.210 -      in (constrs @ [(cname, cargs', mx)], sorts') end
  21.211 -
  21.212 -    fun prep_dt_spec ((dts, sorts), (tvs, tname, mx, constrs)) =
  21.213 -      let val (constrs', sorts') = Library.foldl prep_constr (([], sorts), constrs)
  21.214 -      in (dts @ [(tvs, tname, mx, constrs')], sorts') end
  21.215 -
  21.216 -    val (dts', sorts) = Library.foldl prep_dt_spec (([], []), dts);
  21.217 -    val tyvars = map (map (fn s =>
  21.218 -      (s, the (AList.lookup (op =) sorts s))) o #1) dts';
  21.219 -
  21.220 -    fun inter_sort thy S S' = Type.inter_sort (Sign.tsig_of thy) (S, S');
  21.221 -    fun augment_sort_typ thy S =
  21.222 -      let val S = Sign.certify_sort thy S
  21.223 -      in map_type_tfree (fn (s, S') => TFree (s,
  21.224 -        if member (op = o apsnd fst) sorts s then inter_sort thy S S' else S'))
  21.225 -      end;
  21.226 -    fun augment_sort thy S = map_types (augment_sort_typ thy S);
  21.227 -
  21.228 -    val types_syntax = map (fn (tvs, tname, mx, constrs) => (tname, mx)) dts';
  21.229 -    val constr_syntax = map (fn (tvs, tname, mx, constrs) =>
  21.230 -      map (fn (cname, cargs, mx) => (cname, mx)) constrs) dts';
  21.231 -
  21.232 -    val ps = map (fn (_, n, _, _) =>
  21.233 -      (Sign.full_bname tmp_thy n, Sign.full_bname tmp_thy (n ^ "_Rep"))) dts;
  21.234 -    val rps = map Library.swap ps;
  21.235 -
  21.236 -    fun replace_types (Type ("Nominal.ABS", [T, U])) =
  21.237 -          Type ("fun", [T, Type ("Nominal.noption", [replace_types U])])
  21.238 -      | replace_types (Type (s, Ts)) =
  21.239 -          Type (getOpt (AList.lookup op = ps s, s), map replace_types Ts)
  21.240 -      | replace_types T = T;
  21.241 -
  21.242 -    val dts'' = map (fn (tvs, tname, mx, constrs) => (tvs, Binding.name (tname ^ "_Rep"), NoSyn,
  21.243 -      map (fn (cname, cargs, mx) => (Binding.name (cname ^ "_Rep"),
  21.244 -        map replace_types cargs, NoSyn)) constrs)) dts';
  21.245 -
  21.246 -    val new_type_names' = map (fn n => n ^ "_Rep") new_type_names;
  21.247 -    val full_new_type_names' = map (Sign.full_bname thy) new_type_names';
  21.248 -
  21.249 -    val ({induction, ...},thy1) =
  21.250 -      DatatypePackage.add_datatype config new_type_names' dts'' thy;
  21.251 -
  21.252 -    val SOME {descr, ...} = Symtab.lookup
  21.253 -      (DatatypePackage.get_datatypes thy1) (hd full_new_type_names');
  21.254 -    fun nth_dtyp i = typ_of_dtyp descr sorts (DtRec i);
  21.255 -
  21.256 -    val big_name = space_implode "_" new_type_names;
  21.257 -
  21.258 -
  21.259 -    (**** define permutation functions ****)
  21.260 -
  21.261 -    val permT = mk_permT (TFree ("'x", HOLogic.typeS));
  21.262 -    val pi = Free ("pi", permT);
  21.263 -    val perm_types = map (fn (i, _) =>
  21.264 -      let val T = nth_dtyp i
  21.265 -      in permT --> T --> T end) descr;
  21.266 -    val perm_names' = DatatypeProp.indexify_names (map (fn (i, _) =>
  21.267 -      "perm_" ^ name_of_typ (nth_dtyp i)) descr);
  21.268 -    val perm_names = replicate (length new_type_names) "Nominal.perm" @
  21.269 -      map (Sign.full_bname thy1) (List.drop (perm_names', length new_type_names));
  21.270 -    val perm_names_types = perm_names ~~ perm_types;
  21.271 -    val perm_names_types' = perm_names' ~~ perm_types;
  21.272 -
  21.273 -    val perm_eqs = maps (fn (i, (_, _, constrs)) =>
  21.274 -      let val T = nth_dtyp i
  21.275 -      in map (fn (cname, dts) =>
  21.276 -        let
  21.277 -          val Ts = map (typ_of_dtyp descr sorts) dts;
  21.278 -          val names = Name.variant_list ["pi"] (DatatypeProp.make_tnames Ts);
  21.279 -          val args = map Free (names ~~ Ts);
  21.280 -          val c = Const (cname, Ts ---> T);
  21.281 -          fun perm_arg (dt, x) =
  21.282 -            let val T = type_of x
  21.283 -            in if is_rec_type dt then
  21.284 -                let val (Us, _) = strip_type T
  21.285 -                in list_abs (map (pair "x") Us,
  21.286 -                  Free (nth perm_names_types' (body_index dt)) $ pi $
  21.287 -                    list_comb (x, map (fn (i, U) =>
  21.288 -                      Const ("Nominal.perm", permT --> U --> U) $
  21.289 -                        (Const ("List.rev", permT --> permT) $ pi) $
  21.290 -                        Bound i) ((length Us - 1 downto 0) ~~ Us)))
  21.291 -                end
  21.292 -              else Const ("Nominal.perm", permT --> T --> T) $ pi $ x
  21.293 -            end;
  21.294 -        in
  21.295 -          (Attrib.empty_binding, HOLogic.mk_Trueprop (HOLogic.mk_eq
  21.296 -            (Free (nth perm_names_types' i) $
  21.297 -               Free ("pi", mk_permT (TFree ("'x", HOLogic.typeS))) $
  21.298 -               list_comb (c, args),
  21.299 -             list_comb (c, map perm_arg (dts ~~ args)))))
  21.300 -        end) constrs
  21.301 -      end) descr;
  21.302 -
  21.303 -    val (perm_simps, thy2) =
  21.304 -      PrimrecPackage.add_primrec_overloaded
  21.305 -        (map (fn (s, sT) => (s, sT, false))
  21.306 -           (List.take (perm_names' ~~ perm_names_types, length new_type_names)))
  21.307 -        (map (fn s => (Binding.name s, NONE, NoSyn)) perm_names') perm_eqs thy1;
  21.308 -
  21.309 -    (**** prove that permutation functions introduced by unfolding are ****)
  21.310 -    (**** equivalent to already existing permutation functions         ****)
  21.311 -
  21.312 -    val _ = warning ("length descr: " ^ string_of_int (length descr));
  21.313 -    val _ = warning ("length new_type_names: " ^ string_of_int (length new_type_names));
  21.314 -
  21.315 -    val perm_indnames = DatatypeProp.make_tnames (map body_type perm_types);
  21.316 -    val perm_fun_def = PureThy.get_thm thy2 "perm_fun_def";
  21.317 -
  21.318 -    val unfolded_perm_eq_thms =
  21.319 -      if length descr = length new_type_names then []
  21.320 -      else map standard (List.drop (split_conj_thm
  21.321 -        (Goal.prove_global thy2 [] []
  21.322 -          (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  21.323 -            (map (fn (c as (s, T), x) =>
  21.324 -               let val [T1, T2] = binder_types T
  21.325 -               in HOLogic.mk_eq (Const c $ pi $ Free (x, T2),
  21.326 -                 Const ("Nominal.perm", T) $ pi $ Free (x, T2))
  21.327 -               end)
  21.328 -             (perm_names_types ~~ perm_indnames))))
  21.329 -          (fn _ => EVERY [indtac induction perm_indnames 1,
  21.330 -            ALLGOALS (asm_full_simp_tac
  21.331 -              (simpset_of thy2 addsimps [perm_fun_def]))])),
  21.332 -        length new_type_names));
  21.333 -
  21.334 -    (**** prove [] \<bullet> t = t ****)
  21.335 -
  21.336 -    val _ = warning "perm_empty_thms";
  21.337 -
  21.338 -    val perm_empty_thms = List.concat (map (fn a =>
  21.339 -      let val permT = mk_permT (Type (a, []))
  21.340 -      in map standard (List.take (split_conj_thm
  21.341 -        (Goal.prove_global thy2 [] []
  21.342 -          (augment_sort thy2 [pt_class_of thy2 a]
  21.343 -            (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  21.344 -              (map (fn ((s, T), x) => HOLogic.mk_eq
  21.345 -                  (Const (s, permT --> T --> T) $
  21.346 -                     Const ("List.list.Nil", permT) $ Free (x, T),
  21.347 -                   Free (x, T)))
  21.348 -               (perm_names ~~
  21.349 -                map body_type perm_types ~~ perm_indnames)))))
  21.350 -          (fn _ => EVERY [indtac induction perm_indnames 1,
  21.351 -            ALLGOALS (asm_full_simp_tac (simpset_of thy2))])),
  21.352 -        length new_type_names))
  21.353 -      end)
  21.354 -      atoms);
  21.355 -
  21.356 -    (**** prove (pi1 @ pi2) \<bullet> t = pi1 \<bullet> (pi2 \<bullet> t) ****)
  21.357 -
  21.358 -    val _ = warning "perm_append_thms";
  21.359 -
  21.360 -    (*FIXME: these should be looked up statically*)
  21.361 -    val at_pt_inst = PureThy.get_thm thy2 "at_pt_inst";
  21.362 -    val pt2 = PureThy.get_thm thy2 "pt2";
  21.363 -
  21.364 -    val perm_append_thms = List.concat (map (fn a =>
  21.365 -      let
  21.366 -        val permT = mk_permT (Type (a, []));
  21.367 -        val pi1 = Free ("pi1", permT);
  21.368 -        val pi2 = Free ("pi2", permT);
  21.369 -        val pt_inst = pt_inst_of thy2 a;
  21.370 -        val pt2' = pt_inst RS pt2;
  21.371 -        val pt2_ax = PureThy.get_thm thy2 (Long_Name.map_base_name (fn s => "pt_" ^ s ^ "2") a);
  21.372 -      in List.take (map standard (split_conj_thm
  21.373 -        (Goal.prove_global thy2 [] []
  21.374 -           (augment_sort thy2 [pt_class_of thy2 a]
  21.375 -             (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  21.376 -                (map (fn ((s, T), x) =>
  21.377 -                    let val perm = Const (s, permT --> T --> T)
  21.378 -                    in HOLogic.mk_eq
  21.379 -                      (perm $ (Const ("List.append", permT --> permT --> permT) $
  21.380 -                         pi1 $ pi2) $ Free (x, T),
  21.381 -                       perm $ pi1 $ (perm $ pi2 $ Free (x, T)))
  21.382 -                    end)
  21.383 -                  (perm_names ~~
  21.384 -                   map body_type perm_types ~~ perm_indnames)))))
  21.385 -           (fn _ => EVERY [indtac induction perm_indnames 1,
  21.386 -              ALLGOALS (asm_full_simp_tac (simpset_of thy2 addsimps [pt2', pt2_ax]))]))),
  21.387 -         length new_type_names)
  21.388 -      end) atoms);
  21.389 -
  21.390 -    (**** prove pi1 ~ pi2 ==> pi1 \<bullet> t = pi2 \<bullet> t ****)
  21.391 -
  21.392 -    val _ = warning "perm_eq_thms";
  21.393 -
  21.394 -    val pt3 = PureThy.get_thm thy2 "pt3";
  21.395 -    val pt3_rev = PureThy.get_thm thy2 "pt3_rev";
  21.396 -
  21.397 -    val perm_eq_thms = List.concat (map (fn a =>
  21.398 -      let
  21.399 -        val permT = mk_permT (Type (a, []));
  21.400 -        val pi1 = Free ("pi1", permT);
  21.401 -        val pi2 = Free ("pi2", permT);
  21.402 -        val at_inst = at_inst_of thy2 a;
  21.403 -        val pt_inst = pt_inst_of thy2 a;
  21.404 -        val pt3' = pt_inst RS pt3;
  21.405 -        val pt3_rev' = at_inst RS (pt_inst RS pt3_rev);
  21.406 -        val pt3_ax = PureThy.get_thm thy2 (Long_Name.map_base_name (fn s => "pt_" ^ s ^ "3") a);
  21.407 -      in List.take (map standard (split_conj_thm
  21.408 -        (Goal.prove_global thy2 [] []
  21.409 -          (augment_sort thy2 [pt_class_of thy2 a] (Logic.mk_implies
  21.410 -             (HOLogic.mk_Trueprop (Const ("Nominal.prm_eq",
  21.411 -                permT --> permT --> HOLogic.boolT) $ pi1 $ pi2),
  21.412 -              HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  21.413 -                (map (fn ((s, T), x) =>
  21.414 -                    let val perm = Const (s, permT --> T --> T)
  21.415 -                    in HOLogic.mk_eq
  21.416 -                      (perm $ pi1 $ Free (x, T),
  21.417 -                       perm $ pi2 $ Free (x, T))
  21.418 -                    end)
  21.419 -                  (perm_names ~~
  21.420 -                   map body_type perm_types ~~ perm_indnames))))))
  21.421 -           (fn _ => EVERY [indtac induction perm_indnames 1,
  21.422 -              ALLGOALS (asm_full_simp_tac (simpset_of thy2 addsimps [pt3', pt3_rev', pt3_ax]))]))),
  21.423 -         length new_type_names)
  21.424 -      end) atoms);
  21.425 -
  21.426 -    (**** prove pi1 \<bullet> (pi2 \<bullet> t) = (pi1 \<bullet> pi2) \<bullet> (pi1 \<bullet> t) ****)
  21.427 -
  21.428 -    val cp1 = PureThy.get_thm thy2 "cp1";
  21.429 -    val dj_cp = PureThy.get_thm thy2 "dj_cp";
  21.430 -    val pt_perm_compose = PureThy.get_thm thy2 "pt_perm_compose";
  21.431 -    val pt_perm_compose_rev = PureThy.get_thm thy2 "pt_perm_compose_rev";
  21.432 -    val dj_perm_perm_forget = PureThy.get_thm thy2 "dj_perm_perm_forget";
  21.433 -
  21.434 -    fun composition_instance name1 name2 thy =
  21.435 -      let
  21.436 -        val cp_class = cp_class_of thy name1 name2;
  21.437 -        val pt_class =
  21.438 -          if name1 = name2 then [pt_class_of thy name1]
  21.439 -          else [];
  21.440 -        val permT1 = mk_permT (Type (name1, []));
  21.441 -        val permT2 = mk_permT (Type (name2, []));
  21.442 -        val Ts = map body_type perm_types;
  21.443 -        val cp_inst = cp_inst_of thy name1 name2;
  21.444 -        val simps = simpset_of thy addsimps (perm_fun_def ::
  21.445 -          (if name1 <> name2 then
  21.446 -             let val dj = dj_thm_of thy name2 name1
  21.447 -             in [dj RS (cp_inst RS dj_cp), dj RS dj_perm_perm_forget] end
  21.448 -           else
  21.449 -             let
  21.450 -               val at_inst = at_inst_of thy name1;
  21.451 -               val pt_inst = pt_inst_of thy name1;
  21.452 -             in
  21.453 -               [cp_inst RS cp1 RS sym,
  21.454 -                at_inst RS (pt_inst RS pt_perm_compose) RS sym,
  21.455 -                at_inst RS (pt_inst RS pt_perm_compose_rev) RS sym]
  21.456 -            end))
  21.457 -        val sort = Sign.certify_sort thy (cp_class :: pt_class);
  21.458 -        val thms = split_conj_thm (Goal.prove_global thy [] []
  21.459 -          (augment_sort thy sort
  21.460 -            (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  21.461 -              (map (fn ((s, T), x) =>
  21.462 -                  let
  21.463 -                    val pi1 = Free ("pi1", permT1);
  21.464 -                    val pi2 = Free ("pi2", permT2);
  21.465 -                    val perm1 = Const (s, permT1 --> T --> T);
  21.466 -                    val perm2 = Const (s, permT2 --> T --> T);
  21.467 -                    val perm3 = Const ("Nominal.perm", permT1 --> permT2 --> permT2)
  21.468 -                  in HOLogic.mk_eq
  21.469 -                    (perm1 $ pi1 $ (perm2 $ pi2 $ Free (x, T)),
  21.470 -                     perm2 $ (perm3 $ pi1 $ pi2) $ (perm1 $ pi1 $ Free (x, T)))
  21.471 -                  end)
  21.472 -                (perm_names ~~ Ts ~~ perm_indnames)))))
  21.473 -          (fn _ => EVERY [indtac induction perm_indnames 1,
  21.474 -             ALLGOALS (asm_full_simp_tac simps)]))
  21.475 -      in
  21.476 -        fold (fn (s, tvs) => fn thy => AxClass.prove_arity
  21.477 -            (s, map (inter_sort thy sort o snd) tvs, [cp_class])
  21.478 -            (Class.intro_classes_tac [] THEN ALLGOALS (resolve_tac thms)) thy)
  21.479 -          (full_new_type_names' ~~ tyvars) thy
  21.480 -      end;
  21.481 -
  21.482 -    val (perm_thmss,thy3) = thy2 |>
  21.483 -      fold (fn name1 => fold (composition_instance name1) atoms) atoms |>
  21.484 -      fold (fn atom => fn thy =>
  21.485 -        let val pt_name = pt_class_of thy atom
  21.486 -        in
  21.487 -          fold (fn (s, tvs) => fn thy => AxClass.prove_arity
  21.488 -              (s, map (inter_sort thy [pt_name] o snd) tvs, [pt_name])
  21.489 -              (EVERY
  21.490 -                [Class.intro_classes_tac [],
  21.491 -                 resolve_tac perm_empty_thms 1,
  21.492 -                 resolve_tac perm_append_thms 1,
  21.493 -                 resolve_tac perm_eq_thms 1, assume_tac 1]) thy)
  21.494 -            (full_new_type_names' ~~ tyvars) thy
  21.495 -        end) atoms |>
  21.496 -      PureThy.add_thmss
  21.497 -        [((Binding.name (space_implode "_" new_type_names ^ "_unfolded_perm_eq"),
  21.498 -          unfolded_perm_eq_thms), [Simplifier.simp_add]),
  21.499 -         ((Binding.name (space_implode "_" new_type_names ^ "_perm_empty"),
  21.500 -          perm_empty_thms), [Simplifier.simp_add]),
  21.501 -         ((Binding.name (space_implode "_" new_type_names ^ "_perm_append"),
  21.502 -          perm_append_thms), [Simplifier.simp_add]),
  21.503 -         ((Binding.name (space_implode "_" new_type_names ^ "_perm_eq"),
  21.504 -          perm_eq_thms), [Simplifier.simp_add])];
  21.505 -
  21.506 -    (**** Define representing sets ****)
  21.507 -
  21.508 -    val _ = warning "representing sets";
  21.509 -
  21.510 -    val rep_set_names = DatatypeProp.indexify_names
  21.511 -      (map (fn (i, _) => name_of_typ (nth_dtyp i) ^ "_set") descr);
  21.512 -    val big_rep_name =
  21.513 -      space_implode "_" (DatatypeProp.indexify_names (List.mapPartial
  21.514 -        (fn (i, ("Nominal.noption", _, _)) => NONE
  21.515 -          | (i, _) => SOME (name_of_typ (nth_dtyp i))) descr)) ^ "_set";
  21.516 -    val _ = warning ("big_rep_name: " ^ big_rep_name);
  21.517 -
  21.518 -    fun strip_option (dtf as DtType ("fun", [dt, DtRec i])) =
  21.519 -          (case AList.lookup op = descr i of
  21.520 -             SOME ("Nominal.noption", _, [(_, [dt']), _]) =>
  21.521 -               apfst (cons dt) (strip_option dt')
  21.522 -           | _ => ([], dtf))
  21.523 -      | strip_option (DtType ("fun", [dt, DtType ("Nominal.noption", [dt'])])) =
  21.524 -          apfst (cons dt) (strip_option dt')
  21.525 -      | strip_option dt = ([], dt);
  21.526 -
  21.527 -    val dt_atomTs = distinct op = (map (typ_of_dtyp descr sorts)
  21.528 -      (List.concat (map (fn (_, (_, _, cs)) => List.concat
  21.529 -        (map (List.concat o map (fst o strip_option) o snd) cs)) descr)));
  21.530 -    val dt_atoms = map (fst o dest_Type) dt_atomTs;
  21.531 -
  21.532 -    fun make_intr s T (cname, cargs) =
  21.533 -      let
  21.534 -        fun mk_prem (dt, (j, j', prems, ts)) =
  21.535 -          let
  21.536 -            val (dts, dt') = strip_option dt;
  21.537 -            val (dts', dt'') = strip_dtyp dt';
  21.538 -            val Ts = map (typ_of_dtyp descr sorts) dts;
  21.539 -            val Us = map (typ_of_dtyp descr sorts) dts';
  21.540 -            val T = typ_of_dtyp descr sorts dt'';
  21.541 -            val free = mk_Free "x" (Us ---> T) j;
  21.542 -            val free' = app_bnds free (length Us);
  21.543 -            fun mk_abs_fun (T, (i, t)) =
  21.544 -              let val U = fastype_of t
  21.545 -              in (i + 1, Const ("Nominal.abs_fun", [T, U, T] --->
  21.546 -                Type ("Nominal.noption", [U])) $ mk_Free "y" T i $ t)
  21.547 -              end
  21.548 -          in (j + 1, j' + length Ts,
  21.549 -            case dt'' of
  21.550 -                DtRec k => list_all (map (pair "x") Us,
  21.551 -                  HOLogic.mk_Trueprop (Free (List.nth (rep_set_names, k),
  21.552 -                    T --> HOLogic.boolT) $ free')) :: prems
  21.553 -              | _ => prems,
  21.554 -            snd (List.foldr mk_abs_fun (j', free) Ts) :: ts)
  21.555 -          end;
  21.556 -
  21.557 -        val (_, _, prems, ts) = List.foldr mk_prem (1, 1, [], []) cargs;
  21.558 -        val concl = HOLogic.mk_Trueprop (Free (s, T --> HOLogic.boolT) $
  21.559 -          list_comb (Const (cname, map fastype_of ts ---> T), ts))
  21.560 -      in Logic.list_implies (prems, concl)
  21.561 -      end;
  21.562 -
  21.563 -    val (intr_ts, (rep_set_names', recTs')) =
  21.564 -      apfst List.concat (apsnd ListPair.unzip (ListPair.unzip (List.mapPartial
  21.565 -        (fn ((_, ("Nominal.noption", _, _)), _) => NONE
  21.566 -          | ((i, (_, _, constrs)), rep_set_name) =>
  21.567 -              let val T = nth_dtyp i
  21.568 -              in SOME (map (make_intr rep_set_name T) constrs,
  21.569 -                (rep_set_name, T))
  21.570 -              end)
  21.571 -                (descr ~~ rep_set_names))));
  21.572 -    val rep_set_names'' = map (Sign.full_bname thy3) rep_set_names';
  21.573 -
  21.574 -    val ({raw_induct = rep_induct, intrs = rep_intrs, ...}, thy4) =
  21.575 -        InductivePackage.add_inductive_global (serial_string ())
  21.576 -          {quiet_mode = false, verbose = false, kind = Thm.internalK,
  21.577 -           alt_name = Binding.name big_rep_name, coind = false, no_elim = true, no_ind = false,
  21.578 -           skip_mono = true, fork_mono = false}
  21.579 -          (map (fn (s, T) => ((Binding.name s, T --> HOLogic.boolT), NoSyn))
  21.580 -             (rep_set_names' ~~ recTs'))
  21.581 -          [] (map (fn x => (Attrib.empty_binding, x)) intr_ts) [] thy3;
  21.582 -
  21.583 -    (**** Prove that representing set is closed under permutation ****)
  21.584 -
  21.585 -    val _ = warning "proving closure under permutation...";
  21.586 -
  21.587 -    val abs_perm = PureThy.get_thms thy4 "abs_perm";
  21.588 -
  21.589 -    val perm_indnames' = List.mapPartial
  21.590 -      (fn (x, (_, ("Nominal.noption", _, _))) => NONE | (x, _) => SOME x)
  21.591 -      (perm_indnames ~~ descr);
  21.592 -
  21.593 -    fun mk_perm_closed name = map (fn th => standard (th RS mp))
  21.594 -      (List.take (split_conj_thm (Goal.prove_global thy4 [] []
  21.595 -        (augment_sort thy4
  21.596 -          (pt_class_of thy4 name :: map (cp_class_of thy4 name) (dt_atoms \ name))
  21.597 -          (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map
  21.598 -            (fn ((s, T), x) =>
  21.599 -               let
  21.600 -                 val S = Const (s, T --> HOLogic.boolT);
  21.601 -                 val permT = mk_permT (Type (name, []))
  21.602 -               in HOLogic.mk_imp (S $ Free (x, T),
  21.603 -                 S $ (Const ("Nominal.perm", permT --> T --> T) $
  21.604 -                   Free ("pi", permT) $ Free (x, T)))
  21.605 -               end) (rep_set_names'' ~~ recTs' ~~ perm_indnames')))))
  21.606 -        (fn _ => EVERY
  21.607 -           [indtac rep_induct [] 1,
  21.608 -            ALLGOALS (simp_tac (simpset_of thy4 addsimps
  21.609 -              (symmetric perm_fun_def :: abs_perm))),
  21.610 -            ALLGOALS (resolve_tac rep_intrs THEN_ALL_NEW assume_tac)])),
  21.611 -        length new_type_names));
  21.612 -
  21.613 -    val perm_closed_thmss = map mk_perm_closed atoms;
  21.614 -
  21.615 -    (**** typedef ****)
  21.616 -
  21.617 -    val _ = warning "defining type...";
  21.618 -
  21.619 -    val (typedefs, thy6) =
  21.620 -      thy4
  21.621 -      |> fold_map (fn ((((name, mx), tvs), (cname, U)), name') => fn thy =>
  21.622 -          TypedefPackage.add_typedef false (SOME (Binding.name name'))
  21.623 -            (Binding.name name, map fst tvs, mx)
  21.624 -            (Const ("Collect", (U --> HOLogic.boolT) --> HOLogic.mk_setT U) $
  21.625 -               Const (cname, U --> HOLogic.boolT)) NONE
  21.626 -            (rtac exI 1 THEN rtac CollectI 1 THEN
  21.627 -              QUIET_BREADTH_FIRST (has_fewer_prems 1)
  21.628 -              (resolve_tac rep_intrs 1)) thy |> (fn ((_, r), thy) =>
  21.629 -        let
  21.630 -          val permT = mk_permT
  21.631 -            (TFree (Name.variant (map fst tvs) "'a", HOLogic.typeS));
  21.632 -          val pi = Free ("pi", permT);
  21.633 -          val T = Type (Sign.intern_type thy name, map TFree tvs);
  21.634 -        in apfst (pair r o hd)
  21.635 -          (PureThy.add_defs_unchecked true [((Binding.name ("prm_" ^ name ^ "_def"), Logic.mk_equals
  21.636 -            (Const ("Nominal.perm", permT --> T --> T) $ pi $ Free ("x", T),
  21.637 -             Const (Sign.intern_const thy ("Abs_" ^ name), U --> T) $
  21.638 -               (Const ("Nominal.perm", permT --> U --> U) $ pi $
  21.639 -                 (Const (Sign.intern_const thy ("Rep_" ^ name), T --> U) $
  21.640 -                   Free ("x", T))))), [])] thy)
  21.641 -        end))
  21.642 -          (types_syntax ~~ tyvars ~~
  21.643 -            List.take (rep_set_names'' ~~ recTs', length new_type_names) ~~
  21.644 -            new_type_names);
  21.645 -
  21.646 -    val perm_defs = map snd typedefs;
  21.647 -    val Abs_inverse_thms = map (collect_simp o #Abs_inverse o fst) typedefs;
  21.648 -    val Rep_inverse_thms = map (#Rep_inverse o fst) typedefs;
  21.649 -    val Rep_thms = map (collect_simp o #Rep o fst) typedefs;
  21.650 -
  21.651 -
  21.652 -    (** prove that new types are in class pt_<name> **)
  21.653 -
  21.654 -    val _ = warning "prove that new types are in class pt_<name> ...";
  21.655 -
  21.656 -    fun pt_instance (atom, perm_closed_thms) =
  21.657 -      fold (fn ((((((Abs_inverse, Rep_inverse), Rep),
  21.658 -        perm_def), name), tvs), perm_closed) => fn thy =>
  21.659 -          let
  21.660 -            val pt_class = pt_class_of thy atom;
  21.661 -            val sort = Sign.certify_sort thy
  21.662 -              (pt_class :: map (cp_class_of thy atom) (dt_atoms \ atom))
  21.663 -          in AxClass.prove_arity
  21.664 -            (Sign.intern_type thy name,
  21.665 -              map (inter_sort thy sort o snd) tvs, [pt_class])
  21.666 -            (EVERY [Class.intro_classes_tac [],
  21.667 -              rewrite_goals_tac [perm_def],
  21.668 -              asm_full_simp_tac (simpset_of thy addsimps [Rep_inverse]) 1,
  21.669 -              asm_full_simp_tac (simpset_of thy addsimps
  21.670 -                [Rep RS perm_closed RS Abs_inverse]) 1,
  21.671 -              asm_full_simp_tac (HOL_basic_ss addsimps [PureThy.get_thm thy
  21.672 -                ("pt_" ^ Long_Name.base_name atom ^ "3")]) 1]) thy
  21.673 -          end)
  21.674 -        (Abs_inverse_thms ~~ Rep_inverse_thms ~~ Rep_thms ~~ perm_defs ~~
  21.675 -           new_type_names ~~ tyvars ~~ perm_closed_thms);
  21.676 -
  21.677 -
  21.678 -    (** prove that new types are in class cp_<name1>_<name2> **)
  21.679 -
  21.680 -    val _ = warning "prove that new types are in class cp_<name1>_<name2> ...";
  21.681 -
  21.682 -    fun cp_instance (atom1, perm_closed_thms1) (atom2, perm_closed_thms2) thy =
  21.683 -      let
  21.684 -        val cp_class = cp_class_of thy atom1 atom2;
  21.685 -        val sort = Sign.certify_sort thy
  21.686 -          (pt_class_of thy atom1 :: map (cp_class_of thy atom1) (dt_atoms \ atom1) @
  21.687 -           (if atom1 = atom2 then [cp_class_of thy atom1 atom1] else
  21.688 -            pt_class_of thy atom2 :: map (cp_class_of thy atom2) (dt_atoms \ atom2)));
  21.689 -        val cp1' = cp_inst_of thy atom1 atom2 RS cp1
  21.690 -      in fold (fn ((((((Abs_inverse, Rep),
  21.691 -        perm_def), name), tvs), perm_closed1), perm_closed2) => fn thy =>
  21.692 -          AxClass.prove_arity
  21.693 -            (Sign.intern_type thy name,
  21.694 -              map (inter_sort thy sort o snd) tvs, [cp_class])
  21.695 -            (EVERY [Class.intro_classes_tac [],
  21.696 -              rewrite_goals_tac [perm_def],
  21.697 -              asm_full_simp_tac (simpset_of thy addsimps
  21.698 -                ((Rep RS perm_closed1 RS Abs_inverse) ::
  21.699 -                 (if atom1 = atom2 then []
  21.700 -                  else [Rep RS perm_closed2 RS Abs_inverse]))) 1,
  21.701 -              cong_tac 1,
  21.702 -              rtac refl 1,
  21.703 -              rtac cp1' 1]) thy)
  21.704 -        (Abs_inverse_thms ~~ Rep_thms ~~ perm_defs ~~ new_type_names ~~
  21.705 -           tyvars ~~ perm_closed_thms1 ~~ perm_closed_thms2) thy
  21.706 -      end;
  21.707 -
  21.708 -    val thy7 = fold (fn x => fn thy => thy |>
  21.709 -      pt_instance x |>
  21.710 -      fold (cp_instance x) (atoms ~~ perm_closed_thmss))
  21.711 -        (atoms ~~ perm_closed_thmss) thy6;
  21.712 -
  21.713 -    (**** constructors ****)
  21.714 -
  21.715 -    fun mk_abs_fun (x, t) =
  21.716 -      let
  21.717 -        val T = fastype_of x;
  21.718 -        val U = fastype_of t
  21.719 -      in
  21.720 -        Const ("Nominal.abs_fun", T --> U --> T -->
  21.721 -          Type ("Nominal.noption", [U])) $ x $ t
  21.722 -      end;
  21.723 -
  21.724 -    val (ty_idxs, _) = List.foldl
  21.725 -      (fn ((i, ("Nominal.noption", _, _)), p) => p
  21.726 -        | ((i, _), (ty_idxs, j)) => (ty_idxs @ [(i, j)], j + 1)) ([], 0) descr;
  21.727 -
  21.728 -    fun reindex (DtType (s, dts)) = DtType (s, map reindex dts)
  21.729 -      | reindex (DtRec i) = DtRec (the (AList.lookup op = ty_idxs i))
  21.730 -      | reindex dt = dt;
  21.731 -
  21.732 -    fun strip_suffix i s = implode (List.take (explode s, size s - i));
  21.733 -
  21.734 -    (** strips the "_Rep" in type names *)
  21.735 -    fun strip_nth_name i s =
  21.736 -      let val xs = Long_Name.explode s;
  21.737 -      in Long_Name.implode (Library.nth_map (length xs - i) (strip_suffix 4) xs) end;
  21.738 -
  21.739 -    val (descr'', ndescr) = ListPair.unzip (map_filter
  21.740 -      (fn (i, ("Nominal.noption", _, _)) => NONE
  21.741 -        | (i, (s, dts, constrs)) =>
  21.742 -             let
  21.743 -               val SOME index = AList.lookup op = ty_idxs i;
  21.744 -               val (constrs2, constrs1) =
  21.745 -                 map_split (fn (cname, cargs) =>
  21.746 -                   apsnd (pair (strip_nth_name 2 (strip_nth_name 1 cname)))
  21.747 -                   (fold_map (fn dt => fn dts =>
  21.748 -                     let val (dts', dt') = strip_option dt
  21.749 -                     in ((length dts, length dts'), dts @ dts' @ [reindex dt']) end)
  21.750 -                       cargs [])) constrs
  21.751 -             in SOME ((index, (strip_nth_name 1 s,  map reindex dts, constrs1)),
  21.752 -               (index, constrs2))
  21.753 -             end) descr);
  21.754 -
  21.755 -    val (descr1, descr2) = chop (length new_type_names) descr'';
  21.756 -    val descr' = [descr1, descr2];
  21.757 -
  21.758 -    fun partition_cargs idxs xs = map (fn (i, j) =>
  21.759 -      (List.take (List.drop (xs, i), j), List.nth (xs, i + j))) idxs;
  21.760 -
  21.761 -    val pdescr = map (fn ((i, (s, dts, constrs)), (_, idxss)) => (i, (s, dts,
  21.762 -      map (fn ((cname, cargs), idxs) => (cname, partition_cargs idxs cargs))
  21.763 -        (constrs ~~ idxss)))) (descr'' ~~ ndescr);
  21.764 -
  21.765 -    fun nth_dtyp' i = typ_of_dtyp descr'' sorts (DtRec i);
  21.766 -
  21.767 -    val rep_names = map (fn s =>
  21.768 -      Sign.intern_const thy7 ("Rep_" ^ s)) new_type_names;
  21.769 -    val abs_names = map (fn s =>
  21.770 -      Sign.intern_const thy7 ("Abs_" ^ s)) new_type_names;
  21.771 -
  21.772 -    val recTs = get_rec_types descr'' sorts;
  21.773 -    val newTs' = Library.take (length new_type_names, recTs');
  21.774 -    val newTs = Library.take (length new_type_names, recTs);
  21.775 -
  21.776 -    val full_new_type_names = map (Sign.full_bname thy) new_type_names;
  21.777 -
  21.778 -    fun make_constr_def tname T T' ((thy, defs, eqns),
  21.779 -        (((cname_rep, _), (cname, cargs)), (cname', mx))) =
  21.780 -      let
  21.781 -        fun constr_arg ((dts, dt), (j, l_args, r_args)) =
  21.782 -          let
  21.783 -            val xs = map (fn (dt, i) => mk_Free "x" (typ_of_dtyp descr'' sorts dt) i)
  21.784 -              (dts ~~ (j upto j + length dts - 1))
  21.785 -            val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts)
  21.786 -          in
  21.787 -            (j + length dts + 1,
  21.788 -             xs @ x :: l_args,
  21.789 -             List.foldr mk_abs_fun
  21.790 -               (case dt of
  21.791 -                  DtRec k => if k < length new_type_names then
  21.792 -                      Const (List.nth (rep_names, k), typ_of_dtyp descr'' sorts dt -->
  21.793 -                        typ_of_dtyp descr sorts dt) $ x
  21.794 -                    else error "nested recursion not (yet) supported"
  21.795 -                | _ => x) xs :: r_args)
  21.796 -          end
  21.797 -
  21.798 -        val (_, l_args, r_args) = List.foldr constr_arg (1, [], []) cargs;
  21.799 -        val abs_name = Sign.intern_const thy ("Abs_" ^ tname);
  21.800 -        val rep_name = Sign.intern_const thy ("Rep_" ^ tname);
  21.801 -        val constrT = map fastype_of l_args ---> T;
  21.802 -        val lhs = list_comb (Const (cname, constrT), l_args);
  21.803 -        val rhs = list_comb (Const (cname_rep, map fastype_of r_args ---> T'), r_args);
  21.804 -        val def = Logic.mk_equals (lhs, Const (abs_name, T' --> T) $ rhs);
  21.805 -        val eqn = HOLogic.mk_Trueprop (HOLogic.mk_eq
  21.806 -          (Const (rep_name, T --> T') $ lhs, rhs));
  21.807 -        val def_name = (Long_Name.base_name cname) ^ "_def";
  21.808 -        val ([def_thm], thy') = thy |>
  21.809 -          Sign.add_consts_i [(Binding.name cname', constrT, mx)] |>
  21.810 -          (PureThy.add_defs false o map Thm.no_attributes) [(Binding.name def_name, def)]
  21.811 -      in (thy', defs @ [def_thm], eqns @ [eqn]) end;
  21.812 -
  21.813 -    fun dt_constr_defs ((thy, defs, eqns, dist_lemmas), ((((((_, (_, _, constrs)),
  21.814 -        (_, (_, _, constrs'))), tname), T), T'), constr_syntax)) =
  21.815 -      let
  21.816 -        val rep_const = cterm_of thy
  21.817 -          (Const (Sign.intern_const thy ("Rep_" ^ tname), T --> T'));
  21.818 -        val dist = standard (cterm_instantiate [(cterm_of thy distinct_f, rep_const)] distinct_lemma);
  21.819 -        val (thy', defs', eqns') = Library.foldl (make_constr_def tname T T')
  21.820 -          ((Sign.add_path tname thy, defs, []), constrs ~~ constrs' ~~ constr_syntax)
  21.821 -      in
  21.822 -        (parent_path (#flat_names config) thy', defs', eqns @ [eqns'], dist_lemmas @ [dist])
  21.823 -      end;
  21.824 -
  21.825 -    val (thy8, constr_defs, constr_rep_eqns, dist_lemmas) = Library.foldl dt_constr_defs
  21.826 -      ((thy7, [], [], []), List.take (descr, length new_type_names) ~~
  21.827 -        List.take (pdescr, length new_type_names) ~~
  21.828 -        new_type_names ~~ newTs ~~ newTs' ~~ constr_syntax);
  21.829 -
  21.830 -    val abs_inject_thms = map (collect_simp o #Abs_inject o fst) typedefs
  21.831 -    val rep_inject_thms = map (#Rep_inject o fst) typedefs
  21.832 -
  21.833 -    (* prove theorem  Rep_i (Constr_j ...) = Constr'_j ...  *)
  21.834 -
  21.835 -    fun prove_constr_rep_thm eqn =
  21.836 -      let
  21.837 -        val inj_thms = map (fn r => r RS iffD1) abs_inject_thms;
  21.838 -        val rewrites = constr_defs @ map mk_meta_eq Rep_inverse_thms
  21.839 -      in Goal.prove_global thy8 [] [] eqn (fn _ => EVERY
  21.840 -        [resolve_tac inj_thms 1,
  21.841 -         rewrite_goals_tac rewrites,
  21.842 -         rtac refl 3,
  21.843 -         resolve_tac rep_intrs 2,
  21.844 -         REPEAT (resolve_tac Rep_thms 1)])
  21.845 -      end;
  21.846 -
  21.847 -    val constr_rep_thmss = map (map prove_constr_rep_thm) constr_rep_eqns;
  21.848 -
  21.849 -    (* prove theorem  pi \<bullet> Rep_i x = Rep_i (pi \<bullet> x) *)
  21.850 -
  21.851 -    fun prove_perm_rep_perm (atom, perm_closed_thms) = map (fn th =>
  21.852 -      let
  21.853 -        val _ $ (_ $ (Rep $ x)) = Logic.unvarify (prop_of th);
  21.854 -        val Type ("fun", [T, U]) = fastype_of Rep;
  21.855 -        val permT = mk_permT (Type (atom, []));
  21.856 -        val pi = Free ("pi", permT);
  21.857 -      in
  21.858 -        Goal.prove_global thy8 [] []
  21.859 -          (augment_sort thy8
  21.860 -            (pt_class_of thy8 atom :: map (cp_class_of thy8 atom) (dt_atoms \ atom))
  21.861 -            (HOLogic.mk_Trueprop (HOLogic.mk_eq
  21.862 -              (Const ("Nominal.perm", permT --> U --> U) $ pi $ (Rep $ x),
  21.863 -               Rep $ (Const ("Nominal.perm", permT --> T --> T) $ pi $ x)))))
  21.864 -          (fn _ => simp_tac (HOL_basic_ss addsimps (perm_defs @ Abs_inverse_thms @
  21.865 -            perm_closed_thms @ Rep_thms)) 1)
  21.866 -      end) Rep_thms;
  21.867 -
  21.868 -    val perm_rep_perm_thms = List.concat (map prove_perm_rep_perm
  21.869 -      (atoms ~~ perm_closed_thmss));
  21.870 -
  21.871 -    (* prove distinctness theorems *)
  21.872 -
  21.873 -    val distinct_props = DatatypeProp.make_distincts descr' sorts;
  21.874 -    val dist_rewrites = map2 (fn rep_thms => fn dist_lemma =>
  21.875 -      dist_lemma :: rep_thms @ [In0_eq, In1_eq, In0_not_In1, In1_not_In0])
  21.876 -        constr_rep_thmss dist_lemmas;
  21.877 -
  21.878 -    fun prove_distinct_thms _ (_, []) = []
  21.879 -      | prove_distinct_thms (p as (rep_thms, dist_lemma)) (k, t :: ts) =
  21.880 -          let
  21.881 -            val dist_thm = Goal.prove_global thy8 [] [] t (fn _ =>
  21.882 -              simp_tac (simpset_of thy8 addsimps (dist_lemma :: rep_thms)) 1)
  21.883 -          in dist_thm :: standard (dist_thm RS not_sym) ::
  21.884 -            prove_distinct_thms p (k, ts)
  21.885 -          end;
  21.886 -
  21.887 -    val distinct_thms = map2 prove_distinct_thms
  21.888 -      (constr_rep_thmss ~~ dist_lemmas) distinct_props;
  21.889 -
  21.890 -    (** prove equations for permutation functions **)
  21.891 -
  21.892 -    val perm_simps' = map (fn (((i, (_, _, constrs)), tname), constr_rep_thms) =>
  21.893 -      let val T = nth_dtyp' i
  21.894 -      in List.concat (map (fn (atom, perm_closed_thms) =>
  21.895 -          map (fn ((cname, dts), constr_rep_thm) =>
  21.896 -        let
  21.897 -          val cname = Sign.intern_const thy8
  21.898 -            (Long_Name.append tname (Long_Name.base_name cname));
  21.899 -          val permT = mk_permT (Type (atom, []));
  21.900 -          val pi = Free ("pi", permT);
  21.901 -
  21.902 -          fun perm t =
  21.903 -            let val T = fastype_of t
  21.904 -            in Const ("Nominal.perm", permT --> T --> T) $ pi $ t end;
  21.905 -
  21.906 -          fun constr_arg ((dts, dt), (j, l_args, r_args)) =
  21.907 -            let
  21.908 -              val Ts = map (typ_of_dtyp descr'' sorts) dts;
  21.909 -              val xs = map (fn (T, i) => mk_Free "x" T i)
  21.910 -                (Ts ~~ (j upto j + length dts - 1))
  21.911 -              val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts)
  21.912 -            in
  21.913 -              (j + length dts + 1,
  21.914 -               xs @ x :: l_args,
  21.915 -               map perm (xs @ [x]) @ r_args)
  21.916 -            end
  21.917 -
  21.918 -          val (_, l_args, r_args) = List.foldr constr_arg (1, [], []) dts;
  21.919 -          val c = Const (cname, map fastype_of l_args ---> T)
  21.920 -        in
  21.921 -          Goal.prove_global thy8 [] []
  21.922 -            (augment_sort thy8
  21.923 -              (pt_class_of thy8 atom :: map (cp_class_of thy8 atom) (dt_atoms \ atom))
  21.924 -              (HOLogic.mk_Trueprop (HOLogic.mk_eq
  21.925 -                (perm (list_comb (c, l_args)), list_comb (c, r_args)))))
  21.926 -            (fn _ => EVERY
  21.927 -              [simp_tac (simpset_of thy8 addsimps (constr_rep_thm :: perm_defs)) 1,
  21.928 -               simp_tac (HOL_basic_ss addsimps (Rep_thms @ Abs_inverse_thms @
  21.929 -                 constr_defs @ perm_closed_thms)) 1,
  21.930 -               TRY (simp_tac (HOL_basic_ss addsimps
  21.931 -                 (symmetric perm_fun_def :: abs_perm)) 1),
  21.932 -               TRY (simp_tac (HOL_basic_ss addsimps
  21.933 -                 (perm_fun_def :: perm_defs @ Rep_thms @ Abs_inverse_thms @
  21.934 -                    perm_closed_thms)) 1)])
  21.935 -        end) (constrs ~~ constr_rep_thms)) (atoms ~~ perm_closed_thmss))
  21.936 -      end) (List.take (pdescr, length new_type_names) ~~ new_type_names ~~ constr_rep_thmss);
  21.937 -
  21.938 -    (** prove injectivity of constructors **)
  21.939 -
  21.940 -    val rep_inject_thms' = map (fn th => th RS sym) rep_inject_thms;
  21.941 -    val alpha = PureThy.get_thms thy8 "alpha";
  21.942 -    val abs_fresh = PureThy.get_thms thy8 "abs_fresh";
  21.943 -
  21.944 -    val pt_cp_sort =
  21.945 -      map (pt_class_of thy8) dt_atoms @
  21.946 -      maps (fn s => map (cp_class_of thy8 s) (dt_atoms \ s)) dt_atoms;
  21.947 -
  21.948 -    val inject_thms = map (fn (((i, (_, _, constrs)), tname), constr_rep_thms) =>
  21.949 -      let val T = nth_dtyp' i
  21.950 -      in List.mapPartial (fn ((cname, dts), constr_rep_thm) =>
  21.951 -        if null dts then NONE else SOME
  21.952 -        let
  21.953 -          val cname = Sign.intern_const thy8
  21.954 -            (Long_Name.append tname (Long_Name.base_name cname));
  21.955 -
  21.956 -          fun make_inj ((dts, dt), (j, args1, args2, eqs)) =
  21.957 -            let
  21.958 -              val Ts_idx = map (typ_of_dtyp descr'' sorts) dts ~~ (j upto j + length dts - 1);
  21.959 -              val xs = map (fn (T, i) => mk_Free "x" T i) Ts_idx;
  21.960 -              val ys = map (fn (T, i) => mk_Free "y" T i) Ts_idx;
  21.961 -              val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts);
  21.962 -              val y = mk_Free "y" (typ_of_dtyp descr'' sorts dt) (j + length dts)
  21.963 -            in
  21.964 -              (j + length dts + 1,
  21.965 -               xs @ (x :: args1), ys @ (y :: args2),
  21.966 -               HOLogic.mk_eq
  21.967 -                 (List.foldr mk_abs_fun x xs, List.foldr mk_abs_fun y ys) :: eqs)
  21.968 -            end;
  21.969 -
  21.970 -          val (_, args1, args2, eqs) = List.foldr make_inj (1, [], [], []) dts;
  21.971 -          val Ts = map fastype_of args1;
  21.972 -          val c = Const (cname, Ts ---> T)
  21.973 -        in
  21.974 -          Goal.prove_global thy8 [] []
  21.975 -            (augment_sort thy8 pt_cp_sort
  21.976 -              (HOLogic.mk_Trueprop (HOLogic.mk_eq
  21.977 -                (HOLogic.mk_eq (list_comb (c, args1), list_comb (c, args2)),
  21.978 -                 foldr1 HOLogic.mk_conj eqs))))
  21.979 -            (fn _ => EVERY
  21.980 -               [asm_full_simp_tac (simpset_of thy8 addsimps (constr_rep_thm ::
  21.981 -                  rep_inject_thms')) 1,
  21.982 -                TRY (asm_full_simp_tac (HOL_basic_ss addsimps (fresh_def :: supp_def ::
  21.983 -                  alpha @ abs_perm @ abs_fresh @ rep_inject_thms @
  21.984 -                  perm_rep_perm_thms)) 1)])
  21.985 -        end) (constrs ~~ constr_rep_thms)
  21.986 -      end) (List.take (pdescr, length new_type_names) ~~ new_type_names ~~ constr_rep_thmss);
  21.987 -
  21.988 -    (** equations for support and freshness **)
  21.989 -
  21.990 -    val (supp_thms, fresh_thms) = ListPair.unzip (map ListPair.unzip
  21.991 -      (map (fn ((((i, (_, _, constrs)), tname), inject_thms'), perm_thms') =>
  21.992 -      let val T = nth_dtyp' i
  21.993 -      in List.concat (map (fn (cname, dts) => map (fn atom =>
  21.994 -        let
  21.995 -          val cname = Sign.intern_const thy8
  21.996 -            (Long_Name.append tname (Long_Name.base_name cname));
  21.997 -          val atomT = Type (atom, []);
  21.998 -
  21.999 -          fun process_constr ((dts, dt), (j, args1, args2)) =
 21.1000 -            let
 21.1001 -              val Ts_idx = map (typ_of_dtyp descr'' sorts) dts ~~ (j upto j + length dts - 1);
 21.1002 -              val xs = map (fn (T, i) => mk_Free "x" T i) Ts_idx;
 21.1003 -              val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts)
 21.1004 -            in
 21.1005 -              (j + length dts + 1,
 21.1006 -               xs @ (x :: args1), List.foldr mk_abs_fun x xs :: args2)
 21.1007 -            end;
 21.1008 -
 21.1009 -          val (_, args1, args2) = List.foldr process_constr (1, [], []) dts;
 21.1010 -          val Ts = map fastype_of args1;
 21.1011 -          val c = list_comb (Const (cname, Ts ---> T), args1);
 21.1012 -          fun supp t =
 21.1013 -            Const ("Nominal.supp", fastype_of t --> HOLogic.mk_setT atomT) $ t;
 21.1014 -          fun fresh t = fresh_const atomT (fastype_of t) $ Free ("a", atomT) $ t;
 21.1015 -          val supp_thm = Goal.prove_global thy8 [] []
 21.1016 -            (augment_sort thy8 pt_cp_sort
 21.1017 -              (HOLogic.mk_Trueprop (HOLogic.mk_eq
 21.1018 -                (supp c,
 21.1019 -                 if null dts then HOLogic.mk_set atomT []
 21.1020 -                 else foldr1 (HOLogic.mk_binop @{const_name Un}) (map supp args2)))))
 21.1021 -            (fn _ =>
 21.1022 -              simp_tac (HOL_basic_ss addsimps (supp_def ::
 21.1023 -                 Un_assoc :: de_Morgan_conj :: Collect_disj_eq :: finite_Un ::
 21.1024 -                 symmetric empty_def :: finite_emptyI :: simp_thms @
 21.1025 -                 abs_perm @ abs_fresh @ inject_thms' @ perm_thms')) 1)
 21.1026 -        in
 21.1027 -          (supp_thm,
 21.1028 -           Goal.prove_global thy8 [] [] (augment_sort thy8 pt_cp_sort
 21.1029 -             (HOLogic.mk_Trueprop (HOLogic.mk_eq
 21.1030 -               (fresh c,
 21.1031 -                if null dts then HOLogic.true_const
 21.1032 -                else foldr1 HOLogic.mk_conj (map fresh args2)))))
 21.1033 -             (fn _ =>
 21.1034 -               simp_tac (HOL_ss addsimps [Un_iff, empty_iff, fresh_def, supp_thm]) 1))
 21.1035 -        end) atoms) constrs)
 21.1036 -      end) (List.take (pdescr, length new_type_names) ~~ new_type_names ~~ inject_thms ~~ perm_simps')));
 21.1037 -
 21.1038 -    (**** weak induction theorem ****)
 21.1039 -
 21.1040 -    fun mk_indrule_lemma ((prems, concls), (((i, _), T), U)) =
 21.1041 -      let
 21.1042 -        val Rep_t = Const (List.nth (rep_names, i), T --> U) $
 21.1043 -          mk_Free "x" T i;
 21.1044 -
 21.1045 -        val Abs_t =  Const (List.nth (abs_names, i), U --> T)
 21.1046 -
 21.1047 -      in (prems @ [HOLogic.imp $
 21.1048 -            (Const (List.nth (rep_set_names'', i), U --> HOLogic.boolT) $ Rep_t) $
 21.1049 -              (mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ (Abs_t $ Rep_t))],
 21.1050 -          concls @ [mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ mk_Free "x" T i])
 21.1051 -      end;
 21.1052 -
 21.1053 -    val (indrule_lemma_prems, indrule_lemma_concls) =
 21.1054 -      Library.foldl mk_indrule_lemma (([], []), (descr'' ~~ recTs ~~ recTs'));
 21.1055 -
 21.1056 -    val indrule_lemma = Goal.prove_global thy8 [] []
 21.1057 -      (Logic.mk_implies
 21.1058 -        (HOLogic.mk_Trueprop (mk_conj indrule_lemma_prems),
 21.1059 -         HOLogic.mk_Trueprop (mk_conj indrule_lemma_concls))) (fn _ => EVERY
 21.1060 -           [REPEAT (etac conjE 1),
 21.1061 -            REPEAT (EVERY
 21.1062 -              [TRY (rtac conjI 1), full_simp_tac (HOL_basic_ss addsimps Rep_inverse_thms) 1,
 21.1063 -               etac mp 1, resolve_tac Rep_thms 1])]);
 21.1064 -
 21.1065 -    val Ps = map head_of (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of indrule_lemma)));
 21.1066 -    val frees = if length Ps = 1 then [Free ("P", snd (dest_Var (hd Ps)))] else
 21.1067 -      map (Free o apfst fst o dest_Var) Ps;
 21.1068 -    val indrule_lemma' = cterm_instantiate
 21.1069 -      (map (cterm_of thy8) Ps ~~ map (cterm_of thy8) frees) indrule_lemma;
 21.1070 -
 21.1071 -    val Abs_inverse_thms' = map (fn r => r RS subst) Abs_inverse_thms;
 21.1072 -
 21.1073 -    val dt_induct_prop = DatatypeProp.make_ind descr' sorts;
 21.1074 -    val dt_induct = Goal.prove_global thy8 []
 21.1075 -      (Logic.strip_imp_prems dt_induct_prop) (Logic.strip_imp_concl dt_induct_prop)
 21.1076 -      (fn {prems, ...} => EVERY
 21.1077 -        [rtac indrule_lemma' 1,
 21.1078 -         (indtac rep_induct [] THEN_ALL_NEW ObjectLogic.atomize_prems_tac) 1,
 21.1079 -         EVERY (map (fn (prem, r) => (EVERY
 21.1080 -           [REPEAT (eresolve_tac Abs_inverse_thms' 1),
 21.1081 -            simp_tac (HOL_basic_ss addsimps [symmetric r]) 1,
 21.1082 -            DEPTH_SOLVE_1 (ares_tac [prem] 1 ORELSE etac allE 1)]))
 21.1083 -                (prems ~~ constr_defs))]);
 21.1084 -
 21.1085 -    val case_names_induct = mk_case_names_induct descr'';
 21.1086 -
 21.1087 -    (**** prove that new datatypes have finite support ****)
 21.1088 -
 21.1089 -    val _ = warning "proving finite support for the new datatype";
 21.1090 -
 21.1091 -    val indnames = DatatypeProp.make_tnames recTs;
 21.1092 -
 21.1093 -    val abs_supp = PureThy.get_thms thy8 "abs_supp";
 21.1094 -    val supp_atm = PureThy.get_thms thy8 "supp_atm";
 21.1095 -
 21.1096 -    val finite_supp_thms = map (fn atom =>
 21.1097 -      let val atomT = Type (atom, [])
 21.1098 -      in map standard (List.take
 21.1099 -        (split_conj_thm (Goal.prove_global thy8 [] []
 21.1100 -           (augment_sort thy8 (fs_class_of thy8 atom :: pt_cp_sort)
 21.1101 -             (HOLogic.mk_Trueprop
 21.1102 -               (foldr1 HOLogic.mk_conj (map (fn (s, T) =>
 21.1103 -                 Const ("Finite_Set.finite", HOLogic.mk_setT atomT --> HOLogic.boolT) $
 21.1104 -                   (Const ("Nominal.supp", T --> HOLogic.mk_setT atomT) $ Free (s, T)))
 21.1105 -                   (indnames ~~ recTs)))))
 21.1106 -           (fn _ => indtac dt_induct indnames 1 THEN
 21.1107 -            ALLGOALS (asm_full_simp_tac (simpset_of thy8 addsimps
 21.1108 -              (abs_supp @ supp_atm @
 21.1109 -               PureThy.get_thms thy8 ("fs_" ^ Long_Name.base_name atom ^ "1") @
 21.1110 -               List.concat supp_thms))))),
 21.1111 -         length new_type_names))
 21.1112 -      end) atoms;
 21.1113 -
 21.1114 -    val simp_atts = replicate (length new_type_names) [Simplifier.simp_add];
 21.1115 -
 21.1116 -	(* Function to add both the simp and eqvt attributes *)
 21.1117 -        (* These two attributes are duplicated on all the types in the mutual nominal datatypes *)
 21.1118 -
 21.1119 -    val simp_eqvt_atts = replicate (length new_type_names) [Simplifier.simp_add, NominalThmDecls.eqvt_add];
 21.1120 - 
 21.1121 -    val (_, thy9) = thy8 |>
 21.1122 -      Sign.add_path big_name |>
 21.1123 -      PureThy.add_thms [((Binding.name "induct", dt_induct), [case_names_induct])] ||>>
 21.1124 -      PureThy.add_thmss [((Binding.name "inducts", projections dt_induct), [case_names_induct])] ||>
 21.1125 -      Sign.parent_path ||>>
 21.1126 -      DatatypeAux.store_thmss_atts "distinct" new_type_names simp_atts distinct_thms ||>>
 21.1127 -      DatatypeAux.store_thmss "constr_rep" new_type_names constr_rep_thmss ||>>
 21.1128 -      DatatypeAux.store_thmss_atts "perm" new_type_names simp_eqvt_atts perm_simps' ||>>
 21.1129 -      DatatypeAux.store_thmss "inject" new_type_names inject_thms ||>>
 21.1130 -      DatatypeAux.store_thmss "supp" new_type_names supp_thms ||>>
 21.1131 -      DatatypeAux.store_thmss_atts "fresh" new_type_names simp_atts fresh_thms ||>
 21.1132 -      fold (fn (atom, ths) => fn thy =>
 21.1133 -        let
 21.1134 -          val class = fs_class_of thy atom;
 21.1135 -          val sort = Sign.certify_sort thy (class :: pt_cp_sort)
 21.1136 -        in fold (fn Type (s, Ts) => AxClass.prove_arity
 21.1137 -          (s, map (inter_sort thy sort o snd o dest_TFree) Ts, [class])
 21.1138 -          (Class.intro_classes_tac [] THEN resolve_tac ths 1)) newTs thy
 21.1139 -        end) (atoms ~~ finite_supp_thms);
 21.1140 -
 21.1141 -    (**** strong induction theorem ****)
 21.1142 -
 21.1143 -    val pnames = if length descr'' = 1 then ["P"]
 21.1144 -      else map (fn i => "P" ^ string_of_int i) (1 upto length descr'');
 21.1145 -    val ind_sort = if null dt_atomTs then HOLogic.typeS
 21.1146 -      else Sign.certify_sort thy9 (map (fs_class_of thy9) dt_atoms);
 21.1147 -    val fsT = TFree ("'n", ind_sort);
 21.1148 -    val fsT' = TFree ("'n", HOLogic.typeS);
 21.1149 -
 21.1150 -    val fresh_fs = map (fn (s, T) => (T, Free (s, fsT' --> HOLogic.mk_setT T)))
 21.1151 -      (DatatypeProp.indexify_names (replicate (length dt_atomTs) "f") ~~ dt_atomTs);
 21.1152 -
 21.1153 -    fun make_pred fsT i T =
 21.1154 -      Free (List.nth (pnames, i), fsT --> T --> HOLogic.boolT);
 21.1155 -
 21.1156 -    fun mk_fresh1 xs [] = []
 21.1157 -      | mk_fresh1 xs ((y as (_, T)) :: ys) = map (fn x => HOLogic.mk_Trueprop
 21.1158 -            (HOLogic.mk_not (HOLogic.mk_eq (Free y, Free x))))
 21.1159 -              (filter (fn (_, U) => T = U) (rev xs)) @
 21.1160 -          mk_fresh1 (y :: xs) ys;
 21.1161 -
 21.1162 -    fun mk_fresh2 xss [] = []
 21.1163 -      | mk_fresh2 xss ((p as (ys, _)) :: yss) = List.concat (map (fn y as (_, T) =>
 21.1164 -            map (fn (_, x as (_, U)) => HOLogic.mk_Trueprop
 21.1165 -              (fresh_const T U $ Free y $ Free x)) (rev xss @ yss)) ys) @
 21.1166 -          mk_fresh2 (p :: xss) yss;
 21.1167 -
 21.1168 -    fun make_ind_prem fsT f k T ((cname, cargs), idxs) =
 21.1169 -      let
 21.1170 -        val recs = List.filter is_rec_type cargs;
 21.1171 -        val Ts = map (typ_of_dtyp descr'' sorts) cargs;
 21.1172 -        val recTs' = map (typ_of_dtyp descr'' sorts) recs;
 21.1173 -        val tnames = Name.variant_list pnames (DatatypeProp.make_tnames Ts);
 21.1174 -        val rec_tnames = map fst (List.filter (is_rec_type o snd) (tnames ~~ cargs));
 21.1175 -        val frees = tnames ~~ Ts;
 21.1176 -        val frees' = partition_cargs idxs frees;
 21.1177 -        val z = (Name.variant tnames "z", fsT);
 21.1178 -
 21.1179 -        fun mk_prem ((dt, s), T) =
 21.1180 -          let
 21.1181 -            val (Us, U) = strip_type T;
 21.1182 -            val l = length Us
 21.1183 -          in list_all (z :: map (pair "x") Us, HOLogic.mk_Trueprop
 21.1184 -            (make_pred fsT (body_index dt) U $ Bound l $ app_bnds (Free (s, T)) l))
 21.1185 -          end;
 21.1186 -
 21.1187 -        val prems = map mk_prem (recs ~~ rec_tnames ~~ recTs');
 21.1188 -        val prems' = map (fn p as (_, T) => HOLogic.mk_Trueprop
 21.1189 -            (f T (Free p) (Free z))) (List.concat (map fst frees')) @
 21.1190 -          mk_fresh1 [] (List.concat (map fst frees')) @
 21.1191 -          mk_fresh2 [] frees'
 21.1192 -
 21.1193 -      in list_all_free (frees @ [z], Logic.list_implies (prems' @ prems,
 21.1194 -        HOLogic.mk_Trueprop (make_pred fsT k T $ Free z $
 21.1195 -          list_comb (Const (cname, Ts ---> T), map Free frees))))
 21.1196 -      end;
 21.1197 -
 21.1198 -    val ind_prems = List.concat (map (fn (((i, (_, _, constrs)), (_, idxss)), T) =>
 21.1199 -      map (make_ind_prem fsT (fn T => fn t => fn u =>
 21.1200 -        fresh_const T fsT $ t $ u) i T)
 21.1201 -          (constrs ~~ idxss)) (descr'' ~~ ndescr ~~ recTs));
 21.1202 -    val tnames = DatatypeProp.make_tnames recTs;
 21.1203 -    val zs = Name.variant_list tnames (replicate (length descr'') "z");
 21.1204 -    val ind_concl = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop "op &")
 21.1205 -      (map (fn ((((i, _), T), tname), z) =>
 21.1206 -        make_pred fsT i T $ Free (z, fsT) $ Free (tname, T))
 21.1207 -        (descr'' ~~ recTs ~~ tnames ~~ zs)));
 21.1208 -    val induct = Logic.list_implies (ind_prems, ind_concl);
 21.1209 -
 21.1210 -    val ind_prems' =
 21.1211 -      map (fn (_, f as Free (_, T)) => list_all_free ([("x", fsT')],
 21.1212 -        HOLogic.mk_Trueprop (Const ("Finite_Set.finite",
 21.1213 -          (snd (split_last (binder_types T)) --> HOLogic.boolT) -->
 21.1214 -            HOLogic.boolT) $ (f $ Free ("x", fsT'))))) fresh_fs @
 21.1215 -      List.concat (map (fn (((i, (_, _, constrs)), (_, idxss)), T) =>
 21.1216 -        map (make_ind_prem fsT' (fn T => fn t => fn u => HOLogic.Not $
 21.1217 -          HOLogic.mk_mem (t, the (AList.lookup op = fresh_fs T) $ u)) i T)
 21.1218 -            (constrs ~~ idxss)) (descr'' ~~ ndescr ~~ recTs));
 21.1219 -    val ind_concl' = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop "op &")
 21.1220 -      (map (fn ((((i, _), T), tname), z) =>
 21.1221 -        make_pred fsT' i T $ Free (z, fsT') $ Free (tname, T))
 21.1222 -        (descr'' ~~ recTs ~~ tnames ~~ zs)));
 21.1223 -    val induct' = Logic.list_implies (ind_prems', ind_concl');
 21.1224 -
 21.1225 -    val aux_ind_vars =
 21.1226 -      (DatatypeProp.indexify_names (replicate (length dt_atomTs) "pi") ~~
 21.1227 -       map mk_permT dt_atomTs) @ [("z", fsT')];
 21.1228 -    val aux_ind_Ts = rev (map snd aux_ind_vars);
 21.1229 -    val aux_ind_concl = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop "op &")
 21.1230 -      (map (fn (((i, _), T), tname) =>
 21.1231 -        HOLogic.list_all (aux_ind_vars, make_pred fsT' i T $ Bound 0 $
 21.1232 -          fold_rev (mk_perm aux_ind_Ts) (map Bound (length dt_atomTs downto 1))
 21.1233 -            (Free (tname, T))))
 21.1234 -        (descr'' ~~ recTs ~~ tnames)));
 21.1235 -
 21.1236 -    val fin_set_supp = map (fn s =>
 21.1237 -      at_inst_of thy9 s RS at_fin_set_supp) dt_atoms;
 21.1238 -    val fin_set_fresh = map (fn s =>
 21.1239 -      at_inst_of thy9 s RS at_fin_set_fresh) dt_atoms;
 21.1240 -    val pt1_atoms = map (fn Type (s, _) =>
 21.1241 -      PureThy.get_thm thy9 ("pt_" ^ Long_Name.base_name s ^ "1")) dt_atomTs;
 21.1242 -    val pt2_atoms = map (fn Type (s, _) =>
 21.1243 -      PureThy.get_thm thy9 ("pt_" ^ Long_Name.base_name s ^ "2") RS sym) dt_atomTs;
 21.1244 -    val exists_fresh' = PureThy.get_thms thy9 "exists_fresh'";
 21.1245 -    val fs_atoms = PureThy.get_thms thy9 "fin_supp";
 21.1246 -    val abs_supp = PureThy.get_thms thy9 "abs_supp";
 21.1247 -    val perm_fresh_fresh = PureThy.get_thms thy9 "perm_fresh_fresh";
 21.1248 -    val calc_atm = PureThy.get_thms thy9 "calc_atm";
 21.1249 -    val fresh_atm = PureThy.get_thms thy9 "fresh_atm";
 21.1250 -    val fresh_left = PureThy.get_thms thy9 "fresh_left";
 21.1251 -    val perm_swap = PureThy.get_thms thy9 "perm_swap";
 21.1252 -
 21.1253 -    fun obtain_fresh_name' ths ts T (freshs1, freshs2, ctxt) =
 21.1254 -      let
 21.1255 -        val p = foldr1 HOLogic.mk_prod (ts @ freshs1);
 21.1256 -        val ex = Goal.prove ctxt [] [] (HOLogic.mk_Trueprop
 21.1257 -            (HOLogic.exists_const T $ Abs ("x", T,
 21.1258 -              fresh_const T (fastype_of p) $
 21.1259 -                Bound 0 $ p)))
 21.1260 -          (fn _ => EVERY
 21.1261 -            [resolve_tac exists_fresh' 1,
 21.1262 -             simp_tac (HOL_ss addsimps (supp_prod :: finite_Un :: fs_atoms @
 21.1263 -               fin_set_supp @ ths)) 1]);
 21.1264 -        val (([cx], ths), ctxt') = Obtain.result
 21.1265 -          (fn _ => EVERY
 21.1266 -            [etac exE 1,
 21.1267 -             full_simp_tac (HOL_ss addsimps (fresh_prod :: fresh_atm)) 1,
 21.1268 -             REPEAT (etac conjE 1)])
 21.1269 -          [ex] ctxt
 21.1270 -      in (freshs1 @ [term_of cx], freshs2 @ ths, ctxt') end;
 21.1271 -
 21.1272 -    fun fresh_fresh_inst thy a b =
 21.1273 -      let
 21.1274 -        val T = fastype_of a;
 21.1275 -        val SOME th = find_first (fn th => case prop_of th of
 21.1276 -            _ $ (_ $ (Const (_, Type (_, [U, _])) $ _ $ _)) $ _ => U = T
 21.1277 -          | _ => false) perm_fresh_fresh
 21.1278 -      in
 21.1279 -        Drule.instantiate' []
 21.1280 -          [SOME (cterm_of thy a), NONE, SOME (cterm_of thy b)] th
 21.1281 -      end;
 21.1282 -
 21.1283 -    val fs_cp_sort =
 21.1284 -      map (fs_class_of thy9) dt_atoms @
 21.1285 -      maps (fn s => map (cp_class_of thy9 s) (dt_atoms \ s)) dt_atoms;
 21.1286 -
 21.1287 -    (**********************************************************************
 21.1288 -      The subgoals occurring in the proof of induct_aux have the
 21.1289 -      following parameters:
 21.1290 -
 21.1291 -        x_1 ... x_k p_1 ... p_m z
 21.1292 -
 21.1293 -      where
 21.1294 -
 21.1295 -        x_i : constructor arguments (introduced by weak induction rule)
 21.1296 -        p_i : permutations (one for each atom type in the data type)
 21.1297 -        z   : freshness context
 21.1298 -    ***********************************************************************)
 21.1299 -
 21.1300 -    val _ = warning "proving strong induction theorem ...";
 21.1301 -
 21.1302 -    val induct_aux = Goal.prove_global thy9 []
 21.1303 -        (map (augment_sort thy9 fs_cp_sort) ind_prems')
 21.1304 -        (augment_sort thy9 fs_cp_sort ind_concl') (fn {prems, context} =>
 21.1305 -      let
 21.1306 -        val (prems1, prems2) = chop (length dt_atomTs) prems;
 21.1307 -        val ind_ss2 = HOL_ss addsimps
 21.1308 -          finite_Diff :: abs_fresh @ abs_supp @ fs_atoms;
 21.1309 -        val ind_ss1 = ind_ss2 addsimps fresh_left @ calc_atm @
 21.1310 -          fresh_atm @ rev_simps @ app_simps;
 21.1311 -        val ind_ss3 = HOL_ss addsimps abs_fun_eq1 ::
 21.1312 -          abs_perm @ calc_atm @ perm_swap;
 21.1313 -        val ind_ss4 = HOL_basic_ss addsimps fresh_left @ prems1 @
 21.1314 -          fin_set_fresh @ calc_atm;
 21.1315 -        val ind_ss5 = HOL_basic_ss addsimps pt1_atoms;
 21.1316 -        val ind_ss6 = HOL_basic_ss addsimps flat perm_simps';
 21.1317 -        val th = Goal.prove context [] []
 21.1318 -          (augment_sort thy9 fs_cp_sort aux_ind_concl)
 21.1319 -          (fn {context = context1, ...} =>
 21.1320 -             EVERY (indtac dt_induct tnames 1 ::
 21.1321 -               maps (fn ((_, (_, _, constrs)), (_, constrs')) =>
 21.1322 -                 map (fn ((cname, cargs), is) =>
 21.1323 -                   REPEAT (rtac allI 1) THEN
 21.1324 -                   SUBPROOF (fn {prems = iprems, params, concl,
 21.1325 -                       context = context2, ...} =>
 21.1326 -                     let
 21.1327 -                       val concl' = term_of concl;
 21.1328 -                       val _ $ (_ $ _ $ u) = concl';
 21.1329 -                       val U = fastype_of u;
 21.1330 -                       val (xs, params') =
 21.1331 -                         chop (length cargs) (map term_of params);
 21.1332 -                       val Ts = map fastype_of xs;
 21.1333 -                       val cnstr = Const (cname, Ts ---> U);
 21.1334 -                       val (pis, z) = split_last params';
 21.1335 -                       val mk_pi = fold_rev (mk_perm []) pis;
 21.1336 -                       val xs' = partition_cargs is xs;
 21.1337 -                       val xs'' = map (fn (ts, u) => (map mk_pi ts, mk_pi u)) xs';
 21.1338 -                       val ts = maps (fn (ts, u) => ts @ [u]) xs'';
 21.1339 -                       val (freshs1, freshs2, context3) = fold (fn t =>
 21.1340 -                         let val T = fastype_of t
 21.1341 -                         in obtain_fresh_name' prems1
 21.1342 -                           (the (AList.lookup op = fresh_fs T) $ z :: ts) T
 21.1343 -                         end) (maps fst xs') ([], [], context2);
 21.1344 -                       val freshs1' = unflat (map fst xs') freshs1;
 21.1345 -                       val freshs2' = map (Simplifier.simplify ind_ss4)
 21.1346 -                         (mk_not_sym freshs2);
 21.1347 -                       val ind_ss1' = ind_ss1 addsimps freshs2';
 21.1348 -                       val ind_ss3' = ind_ss3 addsimps freshs2';
 21.1349 -                       val rename_eq =
 21.1350 -                         if forall (null o fst) xs' then []
 21.1351 -                         else [Goal.prove context3 [] []
 21.1352 -                           (HOLogic.mk_Trueprop (HOLogic.mk_eq
 21.1353 -                             (list_comb (cnstr, ts),
 21.1354 -                              list_comb (cnstr, maps (fn ((bs, t), cs) =>
 21.1355 -                                cs @ [fold_rev (mk_perm []) (map perm_of_pair
 21.1356 -                                  (bs ~~ cs)) t]) (xs'' ~~ freshs1')))))
 21.1357 -                           (fn _ => EVERY
 21.1358 -                              (simp_tac (HOL_ss addsimps flat inject_thms) 1 ::
 21.1359 -                               REPEAT (FIRSTGOAL (rtac conjI)) ::
 21.1360 -                               maps (fn ((bs, t), cs) =>
 21.1361 -                                 if null bs then []
 21.1362 -                                 else rtac sym 1 :: maps (fn (b, c) =>
 21.1363 -                                   [rtac trans 1, rtac sym 1,
 21.1364 -                                    rtac (fresh_fresh_inst thy9 b c) 1,
 21.1365 -                                    simp_tac ind_ss1' 1,
 21.1366 -                                    simp_tac ind_ss2 1,
 21.1367 -                                    simp_tac ind_ss3' 1]) (bs ~~ cs))
 21.1368 -                                 (xs'' ~~ freshs1')))];
 21.1369 -                       val th = Goal.prove context3 [] [] concl' (fn _ => EVERY
 21.1370 -                         [simp_tac (ind_ss6 addsimps rename_eq) 1,
 21.1371 -                          cut_facts_tac iprems 1,
 21.1372 -                          (resolve_tac prems THEN_ALL_NEW
 21.1373 -                            SUBGOAL (fn (t, i) => case Logic.strip_assums_concl t of
 21.1374 -                                _ $ (Const ("Nominal.fresh", _) $ _ $ _) =>
 21.1375 -                                  simp_tac ind_ss1' i
 21.1376 -                              | _ $ (Const ("Not", _) $ _) =>
 21.1377 -                                  resolve_tac freshs2' i
 21.1378 -                              | _ => asm_simp_tac (HOL_basic_ss addsimps
 21.1379 -                                  pt2_atoms addsimprocs [perm_simproc]) i)) 1])
 21.1380 -                       val final = ProofContext.export context3 context2 [th]
 21.1381 -                     in
 21.1382 -                       resolve_tac final 1
 21.1383 -                     end) context1 1) (constrs ~~ constrs')) (descr'' ~~ ndescr)))
 21.1384 -      in
 21.1385 -        EVERY
 21.1386 -          [cut_facts_tac [th] 1,
 21.1387 -           REPEAT (eresolve_tac [conjE, @{thm allE_Nil}] 1),
 21.1388 -           REPEAT (etac allE 1),
 21.1389 -           REPEAT (TRY (rtac conjI 1) THEN asm_full_simp_tac ind_ss5 1)]
 21.1390 -      end);
 21.1391 -
 21.1392 -    val induct_aux' = Thm.instantiate ([],
 21.1393 -      map (fn (s, v as Var (_, T)) =>
 21.1394 -        (cterm_of thy9 v, cterm_of thy9 (Free (s, T))))
 21.1395 -          (pnames ~~ map head_of (HOLogic.dest_conj
 21.1396 -             (HOLogic.dest_Trueprop (concl_of induct_aux)))) @
 21.1397 -      map (fn (_, f) =>
 21.1398 -        let val f' = Logic.varify f
 21.1399 -        in (cterm_of thy9 f',
 21.1400 -          cterm_of thy9 (Const ("Nominal.supp", fastype_of f')))
 21.1401 -        end) fresh_fs) induct_aux;
 21.1402 -
 21.1403 -    val induct = Goal.prove_global thy9 []
 21.1404 -      (map (augment_sort thy9 fs_cp_sort) ind_prems)
 21.1405 -      (augment_sort thy9 fs_cp_sort ind_concl)
 21.1406 -      (fn {prems, ...} => EVERY
 21.1407 -         [rtac induct_aux' 1,
 21.1408 -          REPEAT (resolve_tac fs_atoms 1),
 21.1409 -          REPEAT ((resolve_tac prems THEN_ALL_NEW
 21.1410 -            (etac meta_spec ORELSE' full_simp_tac (HOL_basic_ss addsimps [fresh_def]))) 1)])
 21.1411 -
 21.1412 -    val (_, thy10) = thy9 |>
 21.1413 -      Sign.add_path big_name |>
 21.1414 -      PureThy.add_thms [((Binding.name "strong_induct'", induct_aux), [])] ||>>
 21.1415 -      PureThy.add_thms [((Binding.name "strong_induct", induct), [case_names_induct])] ||>>
 21.1416 -      PureThy.add_thmss [((Binding.name "strong_inducts", projections induct), [case_names_induct])];
 21.1417 -
 21.1418 -    (**** recursion combinator ****)
 21.1419 -
 21.1420 -    val _ = warning "defining recursion combinator ...";
 21.1421 -
 21.1422 -    val used = List.foldr OldTerm.add_typ_tfree_names [] recTs;
 21.1423 -
 21.1424 -    val (rec_result_Ts', rec_fn_Ts') = DatatypeProp.make_primrec_Ts descr' sorts used;
 21.1425 -
 21.1426 -    val rec_sort = if null dt_atomTs then HOLogic.typeS else
 21.1427 -      Sign.certify_sort thy10 pt_cp_sort;
 21.1428 -
 21.1429 -    val rec_result_Ts = map (fn TFree (s, _) => TFree (s, rec_sort)) rec_result_Ts';
 21.1430 -    val rec_fn_Ts = map (typ_subst_atomic (rec_result_Ts' ~~ rec_result_Ts)) rec_fn_Ts';
 21.1431 -
 21.1432 -    val rec_set_Ts = map (fn (T1, T2) =>
 21.1433 -      rec_fn_Ts @ [T1, T2] ---> HOLogic.boolT) (recTs ~~ rec_result_Ts);
 21.1434 -
 21.1435 -    val big_rec_name = big_name ^ "_rec_set";
 21.1436 -    val rec_set_names' =
 21.1437 -      if length descr'' = 1 then [big_rec_name] else
 21.1438 -        map ((curry (op ^) (big_rec_name ^ "_")) o string_of_int)
 21.1439 -          (1 upto (length descr''));
 21.1440 -    val rec_set_names =  map (Sign.full_bname thy10) rec_set_names';
 21.1441 -
 21.1442 -    val rec_fns = map (uncurry (mk_Free "f"))
 21.1443 -      (rec_fn_Ts ~~ (1 upto (length rec_fn_Ts)));
 21.1444 -    val rec_sets' = map (fn c => list_comb (Free c, rec_fns))
 21.1445 -      (rec_set_names' ~~ rec_set_Ts);
 21.1446 -    val rec_sets = map (fn c => list_comb (Const c, rec_fns))
 21.1447 -      (rec_set_names ~~ rec_set_Ts);
 21.1448 -
 21.1449 -    (* introduction rules for graph of recursion function *)
 21.1450 -
 21.1451 -    val rec_preds = map (fn (a, T) =>
 21.1452 -      Free (a, T --> HOLogic.boolT)) (pnames ~~ rec_result_Ts);
 21.1453 -
 21.1454 -    fun mk_fresh3 rs [] = []
 21.1455 -      | mk_fresh3 rs ((p as (ys, z)) :: yss) = List.concat (map (fn y as (_, T) =>
 21.1456 -            List.mapPartial (fn ((_, (_, x)), r as (_, U)) => if z = x then NONE
 21.1457 -              else SOME (HOLogic.mk_Trueprop
 21.1458 -                (fresh_const T U $ Free y $ Free r))) rs) ys) @
 21.1459 -          mk_fresh3 rs yss;
 21.1460 -
 21.1461 -    (* FIXME: avoid collisions with other variable names? *)
 21.1462 -    val rec_ctxt = Free ("z", fsT');
 21.1463 -
 21.1464 -    fun make_rec_intr T p rec_set ((rec_intr_ts, rec_prems, rec_prems',
 21.1465 -          rec_eq_prems, l), ((cname, cargs), idxs)) =
 21.1466 -      let
 21.1467 -        val Ts = map (typ_of_dtyp descr'' sorts) cargs;
 21.1468 -        val frees = map (fn i => "x" ^ string_of_int i) (1 upto length Ts) ~~ Ts;
 21.1469 -        val frees' = partition_cargs idxs frees;
 21.1470 -        val binders = List.concat (map fst frees');
 21.1471 -        val atomTs = distinct op = (maps (map snd o fst) frees');
 21.1472 -        val recs = List.mapPartial
 21.1473 -          (fn ((_, DtRec i), p) => SOME (i, p) | _ => NONE)
 21.1474 -          (partition_cargs idxs cargs ~~ frees');
 21.1475 -        val frees'' = map (fn i => "y" ^ string_of_int i) (1 upto length recs) ~~
 21.1476 -          map (fn (i, _) => List.nth (rec_result_Ts, i)) recs;
 21.1477 -        val prems1 = map (fn ((i, (_, x)), y) => HOLogic.mk_Trueprop
 21.1478 -          (List.nth (rec_sets', i) $ Free x $ Free y)) (recs ~~ frees'');
 21.1479 -        val prems2 =
 21.1480 -          map (fn f => map (fn p as (_, T) => HOLogic.mk_Trueprop
 21.1481 -            (fresh_const T (fastype_of f) $ Free p $ f)) binders) rec_fns;
 21.1482 -        val prems3 = mk_fresh1 [] binders @ mk_fresh2 [] frees';
 21.1483 -        val prems4 = map (fn ((i, _), y) =>
 21.1484 -          HOLogic.mk_Trueprop (List.nth (rec_preds, i) $ Free y)) (recs ~~ frees'');
 21.1485 -        val prems5 = mk_fresh3 (recs ~~ frees'') frees';
 21.1486 -        val prems6 = maps (fn aT => map (fn y as (_, T) => HOLogic.mk_Trueprop
 21.1487 -          (Const ("Finite_Set.finite", HOLogic.mk_setT aT --> HOLogic.boolT) $
 21.1488 -             (Const ("Nominal.supp", T --> HOLogic.mk_setT aT) $ Free y)))
 21.1489 -               frees'') atomTs;
 21.1490 -        val prems7 = map (fn x as (_, T) => HOLogic.mk_Trueprop
 21.1491 -          (fresh_const T fsT' $ Free x $ rec_ctxt)) binders;
 21.1492 -        val result = list_comb (List.nth (rec_fns, l), map Free (frees @ frees''));
 21.1493 -        val result_freshs = map (fn p as (_, T) =>
 21.1494 -          fresh_const T (fastype_of result) $ Free p $ result) binders;
 21.1495 -        val P = HOLogic.mk_Trueprop (p $ result)
 21.1496 -      in
 21.1497 -        (rec_intr_ts @ [Logic.list_implies (List.concat prems2 @ prems3 @ prems1,
 21.1498 -           HOLogic.mk_Trueprop (rec_set $
 21.1499 -             list_comb (Const (cname, Ts ---> T), map Free frees) $ result))],
 21.1500 -         rec_prems @ [list_all_free (frees @ frees'', Logic.list_implies (prems4, P))],
 21.1501 -         rec_prems' @ map (fn fr => list_all_free (frees @ frees'',
 21.1502 -           Logic.list_implies (List.nth (prems2, l) @ prems3 @ prems5 @ prems7 @ prems6 @ [P],
 21.1503 -             HOLogic.mk_Trueprop fr))) result_freshs,
 21.1504 -         rec_eq_prems @ [List.concat prems2 @ prems3],
 21.1505 -         l + 1)
 21.1506 -      end;
 21.1507 -
 21.1508 -    val (rec_intr_ts, rec_prems, rec_prems', rec_eq_prems, _) =
 21.1509 -      Library.foldl (fn (x, ((((d, d'), T), p), rec_set)) =>
 21.1510 -        Library.foldl (make_rec_intr T p rec_set) (x, #3 (snd d) ~~ snd d'))
 21.1511 -          (([], [], [], [], 0), descr'' ~~ ndescr ~~ recTs ~~ rec_preds ~~ rec_sets');
 21.1512 -
 21.1513 -    val ({intrs = rec_intrs, elims = rec_elims, raw_induct = rec_induct, ...}, thy11) =
 21.1514 -      thy10 |>
 21.1515 -        InductivePackage.add_inductive_global (serial_string ())
 21.1516 -          {quiet_mode = #quiet config, verbose = false, kind = Thm.internalK,
 21.1517 -           alt_name = Binding.name big_rec_name, coind = false, no_elim = false, no_ind = false,
 21.1518 -           skip_mono = true, fork_mono = false}
 21.1519 -          (map (fn (s, T) => ((Binding.name s, T), NoSyn)) (rec_set_names' ~~ rec_set_Ts))
 21.1520 -          (map dest_Free rec_fns)
 21.1521 -          (map (fn x => (Attrib.empty_binding, x)) rec_intr_ts) [] ||>
 21.1522 -      PureThy.hide_fact true (Long_Name.append (Sign.full_bname thy10 big_rec_name) "induct");
 21.1523 -
 21.1524 -    (** equivariance **)
 21.1525 -
 21.1526 -    val fresh_bij = PureThy.get_thms thy11 "fresh_bij";
 21.1527 -    val perm_bij = PureThy.get_thms thy11 "perm_bij";
 21.1528 -
 21.1529 -    val (rec_equiv_thms, rec_equiv_thms') = ListPair.unzip (map (fn aT =>
 21.1530 -      let
 21.1531 -        val permT = mk_permT aT;
 21.1532 -        val pi = Free ("pi", permT);
 21.1533 -        val rec_fns_pi = map (mk_perm [] pi o uncurry (mk_Free "f"))
 21.1534 -          (rec_fn_Ts ~~ (1 upto (length rec_fn_Ts)));
 21.1535 -        val rec_sets_pi = map (fn c => list_comb (Const c, rec_fns_pi))
 21.1536 -          (rec_set_names ~~ rec_set_Ts);
 21.1537 -        val ps = map (fn ((((T, U), R), R'), i) =>
 21.1538 -          let
 21.1539 -            val x = Free ("x" ^ string_of_int i, T);
 21.1540 -            val y = Free ("y" ^ string_of_int i, U)
 21.1541 -          in
 21.1542 -            (R $ x $ y, R' $ mk_perm [] pi x $ mk_perm [] pi y)
 21.1543 -          end) (recTs ~~ rec_result_Ts ~~ rec_sets ~~ rec_sets_pi ~~ (1 upto length recTs));
 21.1544 -        val ths = map (fn th => standard (th RS mp)) (split_conj_thm
 21.1545 -          (Goal.prove_global thy11 [] []
 21.1546 -            (augment_sort thy1 pt_cp_sort
 21.1547 -              (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map HOLogic.mk_imp ps))))
 21.1548 -            (fn _ => rtac rec_induct 1 THEN REPEAT
 21.1549 -               (simp_tac (Simplifier.theory_context thy11 HOL_basic_ss
 21.1550 -                  addsimps flat perm_simps'
 21.1551 -                  addsimprocs [NominalPermeq.perm_simproc_app]) 1 THEN
 21.1552 -                (resolve_tac rec_intrs THEN_ALL_NEW
 21.1553 -                 asm_simp_tac (HOL_ss addsimps (fresh_bij @ perm_bij))) 1))))
 21.1554 -        val ths' = map (fn ((P, Q), th) =>
 21.1555 -          Goal.prove_global thy11 [] []
 21.1556 -            (augment_sort thy1 pt_cp_sort
 21.1557 -              (Logic.mk_implies (HOLogic.mk_Trueprop Q, HOLogic.mk_Trueprop P)))
 21.1558 -            (fn _ => dtac (Thm.instantiate ([],
 21.1559 -                 [(cterm_of thy11 (Var (("pi", 0), permT)),
 21.1560 -                   cterm_of thy11 (Const ("List.rev", permT --> permT) $ pi))]) th) 1 THEN
 21.1561 -               NominalPermeq.perm_simp_tac HOL_ss 1)) (ps ~~ ths)
 21.1562 -      in (ths, ths') end) dt_atomTs);
 21.1563 -
 21.1564 -    (** finite support **)
 21.1565 -
 21.1566 -    val rec_fin_supp_thms = map (fn aT =>
 21.1567 -      let
 21.1568 -        val name = Long_Name.base_name (fst (dest_Type aT));
 21.1569 -        val fs_name = PureThy.get_thm thy11 ("fs_" ^ name ^ "1");
 21.1570 -        val aset = HOLogic.mk_setT aT;
 21.1571 -        val finite = Const ("Finite_Set.finite", aset --> HOLogic.boolT);
 21.1572 -        val fins = map (fn (f, T) => HOLogic.mk_Trueprop
 21.1573 -          (finite $ (Const ("Nominal.supp", T --> aset) $ f)))
 21.1574 -            (rec_fns ~~ rec_fn_Ts)
 21.1575 -      in
 21.1576 -        map (fn th => standard (th RS mp)) (split_conj_thm
 21.1577 -          (Goal.prove_global thy11 []
 21.1578 -            (map (augment_sort thy11 fs_cp_sort) fins)
 21.1579 -            (augment_sort thy11 fs_cp_sort
 21.1580 -              (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
 21.1581 -                (map (fn (((T, U), R), i) =>
 21.1582 -                   let
 21.1583 -                     val x = Free ("x" ^ string_of_int i, T);
 21.1584 -                     val y = Free ("y" ^ string_of_int i, U)
 21.1585 -                   in
 21.1586 -                     HOLogic.mk_imp (R $ x $ y,
 21.1587 -                       finite $ (Const ("Nominal.supp", U --> aset) $ y))
 21.1588 -                   end) (recTs ~~ rec_result_Ts ~~ rec_sets ~~
 21.1589 -                     (1 upto length recTs))))))
 21.1590 -            (fn {prems = fins, ...} =>
 21.1591 -              (rtac rec_induct THEN_ALL_NEW cut_facts_tac fins) 1 THEN REPEAT
 21.1592 -               (NominalPermeq.finite_guess_tac (HOL_ss addsimps [fs_name]) 1))))
 21.1593 -      end) dt_atomTs;
 21.1594 -
 21.1595 -    (** freshness **)
 21.1596 -
 21.1597 -    val finite_premss = map (fn aT =>
 21.1598 -      map (fn (f, T) => HOLogic.mk_Trueprop
 21.1599 -        (Const ("Finite_Set.finite", HOLogic.mk_setT aT --> HOLogic.boolT) $
 21.1600 -           (Const ("Nominal.supp", T --> HOLogic.mk_setT aT) $ f)))
 21.1601 -           (rec_fns ~~ rec_fn_Ts)) dt_atomTs;
 21.1602 -
 21.1603 -    val rec_fns' = map (augment_sort thy11 fs_cp_sort) rec_fns;
 21.1604 -
 21.1605 -    val rec_fresh_thms = map (fn ((aT, eqvt_ths), finite_prems) =>
 21.1606 -      let
 21.1607 -        val name = Long_Name.base_name (fst (dest_Type aT));
 21.1608 -        val fs_name = PureThy.get_thm thy11 ("fs_" ^ name ^ "1");
 21.1609 -        val a = Free ("a", aT);
 21.1610 -        val freshs = map (fn (f, fT) => HOLogic.mk_Trueprop
 21.1611 -          (fresh_const aT fT $ a $ f)) (rec_fns ~~ rec_fn_Ts)
 21.1612 -      in
 21.1613 -        map (fn (((T, U), R), eqvt_th) =>
 21.1614 -          let
 21.1615 -            val x = Free ("x", augment_sort_typ thy11 fs_cp_sort T);
 21.1616 -            val y = Free ("y", U);
 21.1617 -            val y' = Free ("y'", U)
 21.1618 -          in
 21.1619 -            standard (Goal.prove (ProofContext.init thy11) []
 21.1620 -              (map (augment_sort thy11 fs_cp_sort)
 21.1621 -                (finite_prems @
 21.1622 -                   [HOLogic.mk_Trueprop (R $ x $ y),
 21.1623 -                    HOLogic.mk_Trueprop (HOLogic.mk_all ("y'", U,
 21.1624 -                      HOLogic.mk_imp (R $ x $ y', HOLogic.mk_eq (y', y)))),
 21.1625 -                    HOLogic.mk_Trueprop (fresh_const aT T $ a $ x)] @
 21.1626 -                 freshs))
 21.1627 -              (HOLogic.mk_Trueprop (fresh_const aT U $ a $ y))
 21.1628 -              (fn {prems, context} =>
 21.1629 -                 let
 21.1630 -                   val (finite_prems, rec_prem :: unique_prem ::
 21.1631 -                     fresh_prems) = chop (length finite_prems) prems;
 21.1632 -                   val unique_prem' = unique_prem RS spec RS mp;
 21.1633 -                   val unique = [unique_prem', unique_prem' RS sym] MRS trans;
 21.1634 -                   val _ $ (_ $ (_ $ S $ _)) $ _ = prop_of supports_fresh;
 21.1635 -                   val tuple = foldr1 HOLogic.mk_prod (x :: rec_fns')
 21.1636 -                 in EVERY
 21.1637 -                   [rtac (Drule.cterm_instantiate
 21.1638 -                      [(cterm_of thy11 S,
 21.1639 -                        cterm_of thy11 (Const ("Nominal.supp",
 21.1640 -                          fastype_of tuple --> HOLogic.mk_setT aT) $ tuple))]
 21.1641 -                      supports_fresh) 1,
 21.1642 -                    simp_tac (HOL_basic_ss addsimps
 21.1643 -                      [supports_def, symmetric fresh_def, fresh_prod]) 1,
 21.1644 -                    REPEAT_DETERM (resolve_tac [allI, impI] 1),
 21.1645 -                    REPEAT_DETERM (etac conjE 1),
 21.1646 -                    rtac unique 1,
 21.1647 -                    SUBPROOF (fn {prems = prems', params = [a, b], ...} => EVERY
 21.1648 -                      [cut_facts_tac [rec_prem] 1,
 21.1649 -                       rtac (Thm.instantiate ([],
 21.1650 -                         [(cterm_of thy11 (Var (("pi", 0), mk_permT aT)),
 21.1651 -                           cterm_of thy11 (perm_of_pair (term_of a, term_of b)))]) eqvt_th) 1,
 21.1652 -                       asm_simp_tac (HOL_ss addsimps
 21.1653 -                         (prems' @ perm_swap @ perm_fresh_fresh)) 1]) context 1,
 21.1654 -                    rtac rec_prem 1,
 21.1655 -                    simp_tac (HOL_ss addsimps (fs_name ::
 21.1656 -                      supp_prod :: finite_Un :: finite_prems)) 1,
 21.1657 -                    simp_tac (HOL_ss addsimps (symmetric fresh_def ::
 21.1658 -                      fresh_prod :: fresh_prems)) 1]
 21.1659 -                 end))
 21.1660 -          end) (recTs ~~ rec_result_Ts ~~ rec_sets ~~ eqvt_ths)
 21.1661 -      end) (dt_atomTs ~~ rec_equiv_thms' ~~ finite_premss);
 21.1662 -
 21.1663 -    (** uniqueness **)
 21.1664 -
 21.1665 -    val fun_tuple = foldr1 HOLogic.mk_prod (rec_ctxt :: rec_fns);
 21.1666 -    val fun_tupleT = fastype_of fun_tuple;
 21.1667 -    val rec_unique_frees =
 21.1668 -      DatatypeProp.indexify_names (replicate (length recTs) "x") ~~ recTs;
 21.1669 -    val rec_unique_frees'' = map (fn (s, T) => (s ^ "'", T)) rec_unique_frees;
 21.1670 -    val rec_unique_frees' =
 21.1671 -      DatatypeProp.indexify_names (replicate (length recTs) "y") ~~ rec_result_Ts;
 21.1672 -    val rec_unique_concls = map (fn ((x, U), R) =>
 21.1673 -        Const ("Ex1", (U --> HOLogic.boolT) --> HOLogic.boolT) $
 21.1674 -          Abs ("y", U, R $ Free x $ Bound 0))
 21.1675 -      (rec_unique_frees ~~ rec_result_Ts ~~ rec_sets);
 21.1676 -
 21.1677 -    val induct_aux_rec = Drule.cterm_instantiate
 21.1678 -      (map (pairself (cterm_of thy11) o apsnd (augment_sort thy11 fs_cp_sort))
 21.1679 -         (map (fn (aT, f) => (Logic.varify f, Abs ("z", HOLogic.unitT,
 21.1680 -            Const ("Nominal.supp", fun_tupleT --> HOLogic.mk_setT aT) $ fun_tuple)))
 21.1681 -              fresh_fs @
 21.1682 -          map (fn (((P, T), (x, U)), Q) =>
 21.1683 -           (Var ((P, 0), Logic.varifyT (fsT' --> T --> HOLogic.boolT)),
 21.1684 -            Abs ("z", HOLogic.unitT, absfree (x, U, Q))))
 21.1685 -              (pnames ~~ recTs ~~ rec_unique_frees ~~ rec_unique_concls) @
 21.1686 -          map (fn (s, T) => (Var ((s, 0), Logic.varifyT T), Free (s, T)))
 21.1687 -            rec_unique_frees)) induct_aux;
 21.1688 -
 21.1689 -    fun obtain_fresh_name vs ths rec_fin_supp T (freshs1, freshs2, ctxt) =
 21.1690 -      let
 21.1691 -        val p = foldr1 HOLogic.mk_prod (vs @ freshs1);
 21.1692 -        val ex = Goal.prove ctxt [] [] (HOLogic.mk_Trueprop
 21.1693 -            (HOLogic.exists_const T $ Abs ("x", T,
 21.1694 -              fresh_const T (fastype_of p) $ Bound 0 $ p)))
 21.1695 -          (fn _ => EVERY
 21.1696 -            [cut_facts_tac ths 1,
 21.1697 -             REPEAT_DETERM (dresolve_tac (the (AList.lookup op = rec_fin_supp T)) 1),
 21.1698 -             resolve_tac exists_fresh' 1,
 21.1699 -             asm_simp_tac (HOL_ss addsimps (supp_prod :: finite_Un :: fs_atoms)) 1]);
 21.1700 -        val (([cx], ths), ctxt') = Obtain.result
 21.1701 -          (fn _ => EVERY
 21.1702 -            [etac exE 1,
 21.1703 -             full_simp_tac (HOL_ss addsimps (fresh_prod :: fresh_atm)) 1,
 21.1704 -             REPEAT (etac conjE 1)])
 21.1705 -          [ex] ctxt
 21.1706 -      in (freshs1 @ [term_of cx], freshs2 @ ths, ctxt') end;
 21.1707 -
 21.1708 -    val finite_ctxt_prems = map (fn aT =>
 21.1709 -      HOLogic.mk_Trueprop
 21.1710 -        (Const ("Finite_Set.finite", HOLogic.mk_setT aT --> HOLogic.boolT) $
 21.1711 -           (Const ("Nominal.supp", fsT' --> HOLogic.mk_setT aT) $ rec_ctxt))) dt_atomTs;
 21.1712 -
 21.1713 -    val rec_unique_thms = split_conj_thm (Goal.prove
 21.1714 -      (ProofContext.init thy11) (map fst rec_unique_frees)
 21.1715 -      (map (augment_sort thy11 fs_cp_sort)
 21.1716 -        (List.concat finite_premss @ finite_ctxt_prems @ rec_prems @ rec_prems'))
 21.1717 -      (augment_sort thy11 fs_cp_sort
 21.1718 -        (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj rec_unique_concls)))
 21.1719 -      (fn {prems, context} =>
 21.1720 -         let
 21.1721 -           val k = length rec_fns;
 21.1722 -           val (finite_thss, ths1) = fold_map (fn T => fn xs =>
 21.1723 -             apfst (pair T) (chop k xs)) dt_atomTs prems;
 21.1724 -           val (finite_ctxt_ths, ths2) = chop (length dt_atomTs) ths1;
 21.1725 -           val (P_ind_ths, fcbs) = chop k ths2;
 21.1726 -           val P_ths = map (fn th => th RS mp) (split_conj_thm
 21.1727 -             (Goal.prove context
 21.1728 -               (map fst (rec_unique_frees'' @ rec_unique_frees')) []
 21.1729 -               (augment_sort thy11 fs_cp_sort
 21.1730 -                 (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
 21.1731 -                    (map (fn (((x, y), S), P) => HOLogic.mk_imp
 21.1732 -                      (S $ Free x $ Free y, P $ (Free y)))
 21.1733 -                        (rec_unique_frees'' ~~ rec_unique_frees' ~~
 21.1734 -                           rec_sets ~~ rec_preds)))))
 21.1735 -               (fn _ =>
 21.1736 -                  rtac rec_induct 1 THEN
 21.1737 -                  REPEAT ((resolve_tac P_ind_ths THEN_ALL_NEW assume_tac) 1))));
 21.1738 -           val rec_fin_supp_thms' = map
 21.1739 -             (fn (ths, (T, fin_ths)) => (T, map (curry op MRS fin_ths) ths))
 21.1740 -             (rec_fin_supp_thms ~~ finite_thss);
 21.1741 -         in EVERY
 21.1742 -           ([rtac induct_aux_rec 1] @
 21.1743 -            maps (fn ((_, finite_ths), finite_th) =>
 21.1744 -              [cut_facts_tac (finite_th :: finite_ths) 1,
 21.1745 -               asm_simp_tac (HOL_ss addsimps [supp_prod, finite_Un]) 1])
 21.1746 -                (finite_thss ~~ finite_ctxt_ths) @
 21.1747 -            maps (fn ((_, idxss), elim) => maps (fn idxs =>
 21.1748 -              [full_simp_tac (HOL_ss addsimps [symmetric fresh_def, supp_prod, Un_iff]) 1,
 21.1749 -               REPEAT_DETERM (eresolve_tac [conjE, ex1E] 1),
 21.1750 -               rtac ex1I 1,
 21.1751 -               (resolve_tac rec_intrs THEN_ALL_NEW atac) 1,
 21.1752 -               rotate_tac ~1 1,
 21.1753 -               ((DETERM o etac elim) THEN_ALL_NEW full_simp_tac
 21.1754 -                  (HOL_ss addsimps List.concat distinct_thms)) 1] @
 21.1755 -               (if null idxs then [] else [hyp_subst_tac 1,
 21.1756 -                SUBPROOF (fn {asms, concl, prems = prems', params, context = context', ...} =>
 21.1757 -                  let
 21.1758 -                    val SOME prem = find_first (can (HOLogic.dest_eq o
 21.1759 -                      HOLogic.dest_Trueprop o prop_of)) prems';
 21.1760 -                    val _ $ (_ $ lhs $ rhs) = prop_of prem;
 21.1761 -                    val _ $ (_ $ lhs' $ rhs') = term_of concl;
 21.1762 -                    val rT = fastype_of lhs';
 21.1763 -                    val (c, cargsl) = strip_comb lhs;
 21.1764 -                    val cargsl' = partition_cargs idxs cargsl;
 21.1765 -                    val boundsl = List.concat (map fst cargsl');
 21.1766 -                    val (_, cargsr) = strip_comb rhs;
 21.1767 -                    val cargsr' = partition_cargs idxs cargsr;
 21.1768 -                    val boundsr = List.concat (map fst cargsr');
 21.1769 -                    val (params1, _ :: params2) =
 21.1770 -                      chop (length params div 2) (map term_of params);
 21.1771 -                    val params' = params1 @ params2;
 21.1772 -                    val rec_prems = filter (fn th => case prop_of th of
 21.1773 -                        _ $ p => (case head_of p of
 21.1774 -                          Const (s, _) => s mem rec_set_names
 21.1775 -                        | _ => false)
 21.1776 -                      | _ => false) prems';
 21.1777 -                    val fresh_prems = filter (fn th => case prop_of th of
 21.1778 -                        _ $ (Const ("Nominal.fresh", _) $ _ $ _) => true
 21.1779 -                      | _ $ (Const ("Not", _) $ _) => true
 21.1780 -                      | _ => false) prems';
 21.1781 -                    val Ts = map fastype_of boundsl;
 21.1782 -
 21.1783 -                    val _ = warning "step 1: obtaining fresh names";
 21.1784 -                    val (freshs1, freshs2, context'') = fold
 21.1785 -                      (obtain_fresh_name (rec_ctxt :: rec_fns' @ params')
 21.1786 -                         (List.concat (map snd finite_thss) @
 21.1787 -                            finite_ctxt_ths @ rec_prems)
 21.1788 -                         rec_fin_supp_thms')
 21.1789 -                      Ts ([], [], context');
 21.1790 -                    val pi1 = map perm_of_pair (boundsl ~~ freshs1);
 21.1791 -                    val rpi1 = rev pi1;
 21.1792 -                    val pi2 = map perm_of_pair (boundsr ~~ freshs1);
 21.1793 -                    val rpi2 = rev pi2;
 21.1794 -
 21.1795 -                    val fresh_prems' = mk_not_sym fresh_prems;
 21.1796 -                    val freshs2' = mk_not_sym freshs2;
 21.1797 -
 21.1798 -                    (** as, bs, cs # K as ts, K bs us **)
 21.1799 -                    val _ = warning "step 2: as, bs, cs # K as ts, K bs us";
 21.1800 -                    val prove_fresh_ss = HOL_ss addsimps
 21.1801 -                      (finite_Diff :: List.concat fresh_thms @
 21.1802 -                       fs_atoms @ abs_fresh @ abs_supp @ fresh_atm);
 21.1803 -                    (* FIXME: avoid asm_full_simp_tac ? *)
 21.1804 -                    fun prove_fresh ths y x = Goal.prove context'' [] []
 21.1805 -                      (HOLogic.mk_Trueprop (fresh_const
 21.1806 -                         (fastype_of x) (fastype_of y) $ x $ y))
 21.1807 -                      (fn _ => cut_facts_tac ths 1 THEN asm_full_simp_tac prove_fresh_ss 1);
 21.1808 -                    val constr_fresh_thms =
 21.1809 -                      map (prove_fresh fresh_prems lhs) boundsl @
 21.1810 -                      map (prove_fresh fresh_prems rhs) boundsr @
 21.1811 -                      map (prove_fresh freshs2 lhs) freshs1 @
 21.1812 -                      map (prove_fresh freshs2 rhs) freshs1;
 21.1813 -
 21.1814 -                    (** pi1 o (K as ts) = pi2 o (K bs us) **)
 21.1815 -                    val _ = warning "step 3: pi1 o (K as ts) = pi2 o (K bs us)";
 21.1816 -                    val pi1_pi2_eq = Goal.prove context'' [] []
 21.1817 -                      (HOLogic.mk_Trueprop (HOLogic.mk_eq
 21.1818 -                        (fold_rev (mk_perm []) pi1 lhs, fold_rev (mk_perm []) pi2 rhs)))
 21.1819 -                      (fn _ => EVERY
 21.1820 -                         [cut_facts_tac constr_fresh_thms 1,
 21.1821 -                          asm_simp_tac (HOL_basic_ss addsimps perm_fresh_fresh) 1,
 21.1822 -                          rtac prem 1]);
 21.1823 -
 21.1824 -                    (** pi1 o ts = pi2 o us **)
 21.1825 -                    val _ = warning "step 4: pi1 o ts = pi2 o us";
 21.1826 -                    val pi1_pi2_eqs = map (fn (t, u) =>
 21.1827 -                      Goal.prove context'' [] []
 21.1828 -                        (HOLogic.mk_Trueprop (HOLogic.mk_eq
 21.1829 -                          (fold_rev (mk_perm []) pi1 t, fold_rev (mk_perm []) pi2 u)))
 21.1830 -                        (fn _ => EVERY
 21.1831 -                           [cut_facts_tac [pi1_pi2_eq] 1,
 21.1832 -                            asm_full_simp_tac (HOL_ss addsimps
 21.1833 -                              (calc_atm @ List.concat perm_simps' @
 21.1834 -                               fresh_prems' @ freshs2' @ abs_perm @
 21.1835 -                               alpha @ List.concat inject_thms)) 1]))
 21.1836 -                        (map snd cargsl' ~~ map snd cargsr');
 21.1837 -
 21.1838 -                    (** pi1^-1 o pi2 o us = ts **)
 21.1839 -                    val _ = warning "step 5: pi1^-1 o pi2 o us = ts";
 21.1840 -                    val rpi1_pi2_eqs = map (fn ((t, u), eq) =>
 21.1841 -                      Goal.prove context'' [] []
 21.1842 -                        (HOLogic.mk_Trueprop (HOLogic.mk_eq
 21.1843 -                          (fold_rev (mk_perm []) (rpi1 @ pi2) u, t)))
 21.1844 -                        (fn _ => simp_tac (HOL_ss addsimps
 21.1845 -                           ((eq RS sym) :: perm_swap)) 1))
 21.1846 -                        (map snd cargsl' ~~ map snd cargsr' ~~ pi1_pi2_eqs);
 21.1847 -
 21.1848 -                    val (rec_prems1, rec_prems2) =
 21.1849 -                      chop (length rec_prems div 2) rec_prems;
 21.1850 -
 21.1851 -                    (** (ts, pi1^-1 o pi2 o vs) in rec_set **)
 21.1852 -                    val _ = warning "step 6: (ts, pi1^-1 o pi2 o vs) in rec_set";
 21.1853 -                    val rec_prems' = map (fn th =>
 21.1854 -                      let
 21.1855 -                        val _ $ (S $ x $ y) = prop_of th;
 21.1856 -                        val Const (s, _) = head_of S;
 21.1857 -                        val k = find_index (equal s) rec_set_names;
 21.1858 -                        val pi = rpi1 @ pi2;
 21.1859 -                        fun mk_pi z = fold_rev (mk_perm []) pi z;
 21.1860 -                        fun eqvt_tac p =
 21.1861 -                          let
 21.1862 -                            val U as Type (_, [Type (_, [T, _])]) = fastype_of p;
 21.1863 -                            val l = find_index (equal T) dt_atomTs;
 21.1864 -                            val th = List.nth (List.nth (rec_equiv_thms', l), k);
 21.1865 -                            val th' = Thm.instantiate ([],
 21.1866 -                              [(cterm_of thy11 (Var (("pi", 0), U)),
 21.1867 -                                cterm_of thy11 p)]) th;
 21.1868 -                          in rtac th' 1 end;
 21.1869 -                        val th' = Goal.prove context'' [] []
 21.1870 -                          (HOLogic.mk_Trueprop (S $ mk_pi x $ mk_pi y))
 21.1871 -                          (fn _ => EVERY
 21.1872 -                             (map eqvt_tac pi @
 21.1873 -                              [simp_tac (HOL_ss addsimps (fresh_prems' @ freshs2' @
 21.1874 -                                 perm_swap @ perm_fresh_fresh)) 1,
 21.1875 -                               rtac th 1]))
 21.1876 -                      in
 21.1877 -                        Simplifier.simplify
 21.1878 -                          (HOL_basic_ss addsimps rpi1_pi2_eqs) th'
 21.1879 -                      end) rec_prems2;
 21.1880 -
 21.1881 -                    val ihs = filter (fn th => case prop_of th of
 21.1882 -                      _ $ (Const ("All", _) $ _) => true | _ => false) prems';
 21.1883 -
 21.1884 -                    (** pi1 o rs = pi2 o vs , rs = pi1^-1 o pi2 o vs **)
 21.1885 -                    val _ = warning "step 7: pi1 o rs = pi2 o vs , rs = pi1^-1 o pi2 o vs";
 21.1886 -                    val rec_eqns = map (fn (th, ih) =>
 21.1887 -                      let
 21.1888 -                        val th' = th RS (ih RS spec RS mp) RS sym;
 21.1889 -                        val _ $ (_ $ lhs $ rhs) = prop_of th';
 21.1890 -                        fun strip_perm (_ $ _ $ t) = strip_perm t
 21.1891 -                          | strip_perm t = t;
 21.1892 -                      in
 21.1893 -                        Goal.prove context'' [] []
 21.1894 -                           (HOLogic.mk_Trueprop (HOLogic.mk_eq
 21.1895 -                              (fold_rev (mk_perm []) pi1 lhs,
 21.1896 -                               fold_rev (mk_perm []) pi2 (strip_perm rhs))))
 21.1897 -                           (fn _ => simp_tac (HOL_basic_ss addsimps
 21.1898 -                              (th' :: perm_swap)) 1)
 21.1899 -                      end) (rec_prems' ~~ ihs);
 21.1900 -
 21.1901 -                    (** as # rs **)
 21.1902 -                    val _ = warning "step 8: as # rs";
 21.1903 -                    val rec_freshs = List.concat
 21.1904 -                      (map (fn (rec_prem, ih) =>
 21.1905 -                        let
 21.1906 -                          val _ $ (S $ x $ (y as Free (_, T))) =
 21.1907 -                            prop_of rec_prem;
 21.1908 -                          val k = find_index (equal S) rec_sets;
 21.1909 -                          val atoms = List.concat (List.mapPartial (fn (bs, z) =>
 21.1910 -                            if z = x then NONE else SOME bs) cargsl')
 21.1911 -                        in
 21.1912 -                          map (fn a as Free (_, aT) =>
 21.1913 -                            let val l = find_index (equal aT) dt_atomTs;
 21.1914 -                            in
 21.1915 -                              Goal.prove context'' [] []
 21.1916 -                                (HOLogic.mk_Trueprop (fresh_const aT T $ a $ y))
 21.1917 -                                (fn _ => EVERY
 21.1918 -                                   (rtac (List.nth (List.nth (rec_fresh_thms, l), k)) 1 ::
 21.1919 -                                    map (fn th => rtac th 1)
 21.1920 -                                      (snd (List.nth (finite_thss, l))) @
 21.1921 -                                    [rtac rec_prem 1, rtac ih 1,
 21.1922 -                                     REPEAT_DETERM (resolve_tac fresh_prems 1)]))
 21.1923 -                            end) atoms
 21.1924 -                        end) (rec_prems1 ~~ ihs));
 21.1925 -
 21.1926 -                    (** as # fK as ts rs , bs # fK bs us vs **)
 21.1927 -                    val _ = warning "step 9: as # fK as ts rs , bs # fK bs us vs";
 21.1928 -                    fun prove_fresh_result (a as Free (_, aT)) =
 21.1929 -                      Goal.prove context'' [] []
 21.1930 -                        (HOLogic.mk_Trueprop (fresh_const aT rT $ a $ rhs'))
 21.1931 -                        (fn _ => EVERY
 21.1932 -                           [resolve_tac fcbs 1,
 21.1933 -                            REPEAT_DETERM (resolve_tac
 21.1934 -                              (fresh_prems @ rec_freshs) 1),
 21.1935 -                            REPEAT_DETERM (resolve_tac (maps snd rec_fin_supp_thms') 1
 21.1936 -                              THEN resolve_tac rec_prems 1),
 21.1937 -                            resolve_tac P_ind_ths 1,
 21.1938 -                            REPEAT_DETERM (resolve_tac (P_ths @ rec_prems) 1)]);
 21.1939 -
 21.1940 -                    val fresh_results'' = map prove_fresh_result boundsl;
 21.1941 -
 21.1942 -                    fun prove_fresh_result'' ((a as Free (_, aT), b), th) =
 21.1943 -                      let val th' = Goal.prove context'' [] []
 21.1944 -                        (HOLogic.mk_Trueprop (fresh_const aT rT $
 21.1945 -                            fold_rev (mk_perm []) (rpi2 @ pi1) a $
 21.1946 -                            fold_rev (mk_perm []) (rpi2 @ pi1) rhs'))
 21.1947 -                        (fn _ => simp_tac (HOL_ss addsimps fresh_bij) 1 THEN
 21.1948 -                           rtac th 1)
 21.1949 -                      in
 21.1950 -                        Goal.prove context'' [] []
 21.1951 -                          (HOLogic.mk_Trueprop (fresh_const aT rT $ b $ lhs'))
 21.1952 -                          (fn _ => EVERY
 21.1953 -                             [cut_facts_tac [th'] 1,
 21.1954 -                              full_simp_tac (Simplifier.theory_context thy11 HOL_ss
 21.1955 -                                addsimps rec_eqns @ pi1_pi2_eqs @ perm_swap
 21.1956 -                                addsimprocs [NominalPermeq.perm_simproc_app]) 1,
 21.1957 -                              full_simp_tac (HOL_ss addsimps (calc_atm @
 21.1958 -                                fresh_prems' @ freshs2' @ perm_fresh_fresh)) 1])
 21.1959 -                      end;
 21.1960 -
 21.1961 -                    val fresh_results = fresh_results'' @ map prove_fresh_result''
 21.1962 -                      (boundsl ~~ boundsr ~~ fresh_results'');
 21.1963 -
 21.1964 -                    (** cs # fK as ts rs , cs # fK bs us vs **)
 21.1965 -                    val _ = warning "step 10: cs # fK as ts rs , cs # fK bs us vs";
 21.1966 -                    fun prove_fresh_result' recs t (a as Free (_, aT)) =
 21.1967 -                      Goal.prove context'' [] []
 21.1968 -                        (HOLogic.mk_Trueprop (fresh_const aT rT $ a $ t))
 21.1969 -                        (fn _ => EVERY
 21.1970 -                          [cut_facts_tac recs 1,
 21.1971 -                           REPEAT_DETERM (dresolve_tac
 21.1972 -                             (the (AList.lookup op = rec_fin_supp_thms' aT)) 1),
 21.1973 -                           NominalPermeq.fresh_guess_tac
 21.1974 -                             (HOL_ss addsimps (freshs2 @
 21.1975 -                                fs_atoms @ fresh_atm @
 21.1976 -                                List.concat (map snd finite_thss))) 1]);
 21.1977 -
 21.1978 -                    val fresh_results' =
 21.1979 -                      map (prove_fresh_result' rec_prems1 rhs') freshs1 @
 21.1980 -                      map (prove_fresh_result' rec_prems2 lhs') freshs1;
 21.1981 -
 21.1982 -                    (** pi1 o (fK as ts rs) = pi2 o (fK bs us vs) **)
 21.1983 -                    val _ = warning "step 11: pi1 o (fK as ts rs) = pi2 o (fK bs us vs)";
 21.1984 -                    val pi1_pi2_result = Goal.prove context'' [] []
 21.1985 -                      (HOLogic.mk_Trueprop (HOLogic.mk_eq
 21.1986 -                        (fold_rev (mk_perm []) pi1 rhs', fold_rev (mk_perm []) pi2 lhs')))
 21.1987 -                      (fn _ => simp_tac (Simplifier.context context'' HOL_ss
 21.1988 -                           addsimps pi1_pi2_eqs @ rec_eqns
 21.1989 -                           addsimprocs [NominalPermeq.perm_simproc_app]) 1 THEN
 21.1990 -                         TRY (simp_tac (HOL_ss addsimps
 21.1991 -                           (fresh_prems' @ freshs2' @ calc_atm @ perm_fresh_fresh)) 1));
 21.1992 -
 21.1993 -                    val _ = warning "final result";
 21.1994 -                    val final = Goal.prove context'' [] [] (term_of concl)
 21.1995 -                      (fn _ => cut_facts_tac [pi1_pi2_result RS sym] 1 THEN
 21.1996 -                        full_simp_tac (HOL_basic_ss addsimps perm_fresh_fresh @
 21.1997 -                          fresh_results @ fresh_results') 1);
 21.1998 -                    val final' = ProofContext.export context'' context' [final];
 21.1999 -                    val _ = warning "finished!"
 21.2000 -                  in
 21.2001 -                    resolve_tac final' 1
 21.2002 -                  end) context 1])) idxss) (ndescr ~~ rec_elims))
 21.2003 -         end));
 21.2004 -
 21.2005 -    val rec_total_thms = map (fn r => r RS theI') rec_unique_thms;
 21.2006 -
 21.2007 -    (* define primrec combinators *)
 21.2008 -
 21.2009 -    val big_reccomb_name = (space_implode "_" new_type_names) ^ "_rec";
 21.2010 -    val reccomb_names = map (Sign.full_bname thy11)
 21.2011 -      (if length descr'' = 1 then [big_reccomb_name] else
 21.2012 -        (map ((curry (op ^) (big_reccomb_name ^ "_")) o string_of_int)
 21.2013 -          (1 upto (length descr''))));
 21.2014 -    val reccombs = map (fn ((name, T), T') => list_comb
 21.2015 -      (Const (name, rec_fn_Ts @ [T] ---> T'), rec_fns))
 21.2016 -        (reccomb_names ~~ recTs ~~ rec_result_Ts);
 21.2017 -
 21.2018 -    val (reccomb_defs, thy12) =
 21.2019 -      thy11
 21.2020 -      |> Sign.add_consts_i (map (fn ((name, T), T') =>
 21.2021 -          (Binding.name (Long_Name.base_name name), rec_fn_Ts @ [T] ---> T', NoSyn))
 21.2022 -          (reccomb_names ~~ recTs ~~ rec_result_Ts))
 21.2023 -      |> (PureThy.add_defs false o map Thm.no_attributes) (map (fn ((((name, comb), set), T), T') =>
 21.2024 -          (Binding.name (Long_Name.base_name name ^ "_def"), Logic.mk_equals (comb, absfree ("x", T,
 21.2025 -           Const ("The", (T' --> HOLogic.boolT) --> T') $ absfree ("y", T',
 21.2026 -             set $ Free ("x", T) $ Free ("y", T'))))))
 21.2027 -               (reccomb_names ~~ reccombs ~~ rec_sets ~~ recTs ~~ rec_result_Ts));
 21.2028 -
 21.2029 -    (* prove characteristic equations for primrec combinators *)
 21.2030 -
 21.2031 -    val rec_thms = map (fn (prems, concl) =>
 21.2032 -      let
 21.2033 -        val _ $ (_ $ (_ $ x) $ _) = concl;
 21.2034 -        val (_, cargs) = strip_comb x;
 21.2035 -        val ps = map (fn (x as Free (_, T), i) =>
 21.2036 -          (Free ("x" ^ string_of_int i, T), x)) (cargs ~~ (1 upto length cargs));
 21.2037 -        val concl' = subst_atomic_types (rec_result_Ts' ~~ rec_result_Ts) concl;
 21.2038 -        val prems' = List.concat finite_premss @ finite_ctxt_prems @
 21.2039 -          rec_prems @ rec_prems' @ map (subst_atomic ps) prems;
 21.2040 -        fun solve rules prems = resolve_tac rules THEN_ALL_NEW
 21.2041 -          (resolve_tac prems THEN_ALL_NEW atac)
 21.2042 -      in
 21.2043 -        Goal.prove_global thy12 []
 21.2044 -          (map (augment_sort thy12 fs_cp_sort) prems')
 21.2045 -          (augment_sort thy12 fs_cp_sort concl')
 21.2046 -          (fn {prems, ...} => EVERY
 21.2047 -            [rewrite_goals_tac reccomb_defs,
 21.2048 -             rtac the1_equality 1,
 21.2049 -             solve rec_unique_thms prems 1,
 21.2050 -             resolve_tac rec_intrs 1,
 21.2051 -             REPEAT (solve (prems @ rec_total_thms) prems 1)])
 21.2052 -      end) (rec_eq_prems ~~
 21.2053 -        DatatypeProp.make_primrecs new_type_names descr' sorts thy12);
 21.2054 -
 21.2055 -    val dt_infos = map (make_dt_info pdescr sorts induct reccomb_names rec_thms)
 21.2056 -      ((0 upto length descr1 - 1) ~~ descr1 ~~ distinct_thms ~~ inject_thms);
 21.2057 -
 21.2058 -    (* FIXME: theorems are stored in database for testing only *)
 21.2059 -    val (_, thy13) = thy12 |>
 21.2060 -      PureThy.add_thmss
 21.2061 -        [((Binding.name "rec_equiv", List.concat rec_equiv_thms), []),
 21.2062 -         ((Binding.name "rec_equiv'", List.concat rec_equiv_thms'), []),
 21.2063 -         ((Binding.name "rec_fin_supp", List.concat rec_fin_supp_thms), []),
 21.2064 -         ((Binding.name "rec_fresh", List.concat rec_fresh_thms), []),
 21.2065 -         ((Binding.name "rec_unique", map standard rec_unique_thms), []),
 21.2066 -         ((Binding.name "recs", rec_thms), [])] ||>
 21.2067 -      Sign.parent_path ||>
 21.2068 -      map_nominal_datatypes (fold Symtab.update dt_infos);
 21.2069 -
 21.2070 -  in
 21.2071 -    thy13
 21.2072 -  end;
 21.2073 -
 21.2074 -val add_nominal_datatype = gen_add_nominal_datatype DatatypePackage.read_typ;
 21.2075 -
 21.2076 -
 21.2077 -(* FIXME: The following stuff should be exported by DatatypePackage *)
 21.2078 -
 21.2079 -local structure P = OuterParse and K = OuterKeyword in
 21.2080 -
 21.2081 -val datatype_decl =
 21.2082 -  Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.type_args -- P.name -- P.opt_infix --
 21.2083 -    (P.$$$ "=" |-- P.enum1 "|" (P.name -- Scan.repeat P.typ -- P.opt_mixfix));
 21.2084 -
 21.2085 -fun mk_datatype args =
 21.2086 -  let
 21.2087 -    val names = map (fn ((((NONE, _), t), _), _) => t | ((((SOME t, _), _), _), _) => t) args;
 21.2088 -    val specs = map (fn ((((_, vs), t), mx), cons) =>
 21.2089 -      (vs, t, mx, map (fn ((x, y), z) => (x, y, z)) cons)) args;
 21.2090 -  in add_nominal_datatype DatatypeAux.default_datatype_config names specs end;
 21.2091 -
 21.2092 -val _ =
 21.2093 -  OuterSyntax.command "nominal_datatype" "define inductive datatypes" K.thy_decl
 21.2094 -    (P.and_list1 datatype_decl >> (Toplevel.theory o mk_datatype));
 21.2095 -
 21.2096 -end;
 21.2097 -
 21.2098 -end
    22.1 --- a/src/HOL/Nominal/nominal_primrec.ML	Fri Jun 19 20:22:46 2009 +0200
    22.2 +++ b/src/HOL/Nominal/nominal_primrec.ML	Fri Jun 19 21:08:07 2009 +0200
    22.3 @@ -3,7 +3,7 @@
    22.4      Author:     Stefan Berghofer, TU Muenchen
    22.5  
    22.6  Package for defining functions on nominal datatypes by primitive recursion.
    22.7 -Taken from HOL/Tools/primrec_package.ML
    22.8 +Taken from HOL/Tools/primrec.ML
    22.9  *)
   22.10  
   22.11  signature NOMINAL_PRIMREC =
   22.12 @@ -223,7 +223,7 @@
   22.13  
   22.14  (* find datatypes which contain all datatypes in tnames' *)
   22.15  
   22.16 -fun find_dts (dt_info : NominalPackage.nominal_datatype_info Symtab.table) _ [] = []
   22.17 +fun find_dts (dt_info : Nominal.nominal_datatype_info Symtab.table) _ [] = []
   22.18    | find_dts dt_info tnames' (tname::tnames) =
   22.19        (case Symtab.lookup dt_info tname of
   22.20            NONE => primrec_err (quote tname ^ " is not a nominal datatype")
   22.21 @@ -247,7 +247,7 @@
   22.22      val eqns' = map unquantify spec'
   22.23      val eqns = fold_rev (process_eqn lthy (fn v => Variable.is_fixed lthy v
   22.24        orelse exists (fn ((w, _), _) => v = Binding.name_of w) fixes)) spec' [];
   22.25 -    val dt_info = NominalPackage.get_nominal_datatypes (ProofContext.theory_of lthy);
   22.26 +    val dt_info = Nominal.get_nominal_datatypes (ProofContext.theory_of lthy);
   22.27      val lsrs :: lsrss = maps (fn (_, (_, _, eqns)) =>
   22.28        map (fn (_, (ls, _, rs, _, _)) => ls @ rs) eqns) eqns
   22.29      val _ =
    23.1 --- a/src/HOL/Product_Type.thy	Fri Jun 19 20:22:46 2009 +0200
    23.2 +++ b/src/HOL/Product_Type.thy	Fri Jun 19 21:08:07 2009 +0200
    23.3 @@ -9,7 +9,7 @@
    23.4  imports Inductive
    23.5  uses
    23.6    ("Tools/split_rule.ML")
    23.7 -  ("Tools/inductive_set_package.ML")
    23.8 +  ("Tools/inductive_set.ML")
    23.9    ("Tools/inductive_realizer.ML")
   23.10    ("Tools/datatype_package/datatype_realizer.ML")
   23.11  begin
   23.12 @@ -1151,8 +1151,8 @@
   23.13  use "Tools/inductive_realizer.ML"
   23.14  setup InductiveRealizer.setup
   23.15  
   23.16 -use "Tools/inductive_set_package.ML"
   23.17 -setup InductiveSetPackage.setup
   23.18 +use "Tools/inductive_set.ML"
   23.19 +setup Inductive_Set.setup
   23.20  
   23.21  use "Tools/datatype_package/datatype_realizer.ML"
   23.22  setup DatatypeRealizer.setup
    24.1 --- a/src/HOL/Recdef.thy	Fri Jun 19 20:22:46 2009 +0200
    24.2 +++ b/src/HOL/Recdef.thy	Fri Jun 19 21:08:07 2009 +0200
    24.3 @@ -16,7 +16,7 @@
    24.4    ("Tools/TFL/thry.ML")
    24.5    ("Tools/TFL/tfl.ML")
    24.6    ("Tools/TFL/post.ML")
    24.7 -  ("Tools/recdef_package.ML")
    24.8 +  ("Tools/recdef.ML")
    24.9  begin
   24.10  
   24.11  text{** This form avoids giant explosions in proofs.  NOTE USE OF ==*}
   24.12 @@ -76,8 +76,8 @@
   24.13  use "Tools/TFL/thry.ML"
   24.14  use "Tools/TFL/tfl.ML"
   24.15  use "Tools/TFL/post.ML"
   24.16 -use "Tools/recdef_package.ML"
   24.17 -setup RecdefPackage.setup
   24.18 +use "Tools/recdef.ML"
   24.19 +setup Recdef.setup
   24.20  
   24.21  lemmas [recdef_simp] =
   24.22    inv_image_def
    25.1 --- a/src/HOL/Record.thy	Fri Jun 19 20:22:46 2009 +0200
    25.2 +++ b/src/HOL/Record.thy	Fri Jun 19 21:08:07 2009 +0200
    25.3 @@ -1,5 +1,4 @@
    25.4  (*  Title:      HOL/Record.thy
    25.5 -    ID:         $Id$
    25.6      Author:     Wolfgang Naraschewski, Norbert Schirmer and Markus Wenzel, TU Muenchen
    25.7  *)
    25.8  
    25.9 @@ -7,7 +6,7 @@
   25.10  
   25.11  theory Record
   25.12  imports Product_Type
   25.13 -uses ("Tools/record_package.ML")
   25.14 +uses ("Tools/record.ML")
   25.15  begin
   25.16  
   25.17  lemma prop_subst: "s = t \<Longrightarrow> PROP P t \<Longrightarrow> PROP P s"
   25.18 @@ -56,7 +55,7 @@
   25.19    "_record_scheme"      :: "[fields, 'a] => 'a"                 ("(3\<lparr>_,/ (2\<dots> =/ _)\<rparr>)")
   25.20    "_record_update"      :: "['a, updates] => 'b"                ("_/(3\<lparr>_\<rparr>)" [900,0] 900)
   25.21  
   25.22 -use "Tools/record_package.ML"
   25.23 -setup RecordPackage.setup
   25.24 +use "Tools/record.ML"
   25.25 +setup Record.setup
   25.26  
   25.27  end
    26.1 --- a/src/HOL/Statespace/state_fun.ML	Fri Jun 19 20:22:46 2009 +0200
    26.2 +++ b/src/HOL/Statespace/state_fun.ML	Fri Jun 19 21:08:07 2009 +0200
    26.3 @@ -74,7 +74,7 @@
    26.4  val string_eq_simp_tac =
    26.5       simp_tac (HOL_basic_ss 
    26.6                   addsimps (thms "list.inject"@thms "char.inject"@simp_thms)
    26.7 -                 addsimprocs [DatatypePackage.distinct_simproc,lazy_conj_simproc]
    26.8 +                 addsimprocs [Datatype.distinct_simproc,lazy_conj_simproc]
    26.9                   addcongs [thm "block_conj_cong"])
   26.10  end;
   26.11  
   26.12 @@ -89,7 +89,7 @@
   26.13  in
   26.14  val lookup_ss = (HOL_basic_ss 
   26.15                   addsimps (thms "list.inject"@thms "char.inject"@simp_thms@rules)
   26.16 -                 addsimprocs [DatatypePackage.distinct_simproc,lazy_conj_simproc]
   26.17 +                 addsimprocs [Datatype.distinct_simproc,lazy_conj_simproc]
   26.18                   addcongs [thm "block_conj_cong"]
   26.19                   addSolver StateSpace.distinctNameSolver) 
   26.20  end;
   26.21 @@ -167,7 +167,7 @@
   26.22  val meta_ext = thm "StateFun.meta_ext";
   26.23  val o_apply = thm "Fun.o_apply";
   26.24  val ss' = (HOL_ss addsimps (update_apply::o_apply::thms "list.inject"@thms "char.inject")
   26.25 -                 addsimprocs [DatatypePackage.distinct_simproc,lazy_conj_simproc,StateSpace.distinct_simproc]
   26.26 +                 addsimprocs [Datatype.distinct_simproc,lazy_conj_simproc,StateSpace.distinct_simproc]
   26.27                   addcongs [thm "block_conj_cong"]);
   26.28  in
   26.29  val update_simproc =
   26.30 @@ -267,7 +267,7 @@
   26.31  val swap_ex_eq = thm "StateFun.swap_ex_eq";
   26.32  fun is_selector thy T sel =
   26.33       let 
   26.34 -       val (flds,more) = RecordPackage.get_recT_fields thy T 
   26.35 +       val (flds,more) = Record.get_recT_fields thy T 
   26.36       in member (fn (s,(n,_)) => n=s) (more::flds) sel
   26.37       end;
   26.38  in
   26.39 @@ -340,7 +340,7 @@
   26.40    | mkName (TFree (x,_)) = mkUpper (Long_Name.base_name x)
   26.41    | mkName (TVar ((x,_),_)) = mkUpper (Long_Name.base_name x);
   26.42  
   26.43 -fun is_datatype thy n = is_some (Symtab.lookup (DatatypePackage.get_datatypes thy) n);
   26.44 +fun is_datatype thy n = is_some (Symtab.lookup (Datatype.get_datatypes thy) n);
   26.45  
   26.46  fun mk_map "List.list" = Syntax.const "List.map"
   26.47    | mk_map n = Syntax.const ("StateFun.map_" ^ Long_Name.base_name n);
    27.1 --- a/src/HOL/Statespace/state_space.ML	Fri Jun 19 20:22:46 2009 +0200
    27.2 +++ b/src/HOL/Statespace/state_space.ML	Fri Jun 19 21:08:07 2009 +0200
    27.3 @@ -585,8 +585,8 @@
    27.4    end
    27.5    handle ERROR msg => cat_error msg ("Failed to define statespace " ^ quote name);
    27.6  
    27.7 -val define_statespace = gen_define_statespace RecordPackage.read_typ NONE;
    27.8 -val define_statespace_i = gen_define_statespace RecordPackage.cert_typ;
    27.9 +val define_statespace = gen_define_statespace Record.read_typ NONE;
   27.10 +val define_statespace_i = gen_define_statespace Record.cert_typ;
   27.11  
   27.12  
   27.13  (*** parse/print - translations ***)
    28.1 --- a/src/HOL/Tools/TFL/casesplit.ML	Fri Jun 19 20:22:46 2009 +0200
    28.2 +++ b/src/HOL/Tools/TFL/casesplit.ML	Fri Jun 19 21:08:07 2009 +0200
    28.3 @@ -90,7 +90,7 @@
    28.4  (* get the case_thm (my version) from a type *)
    28.5  fun case_thm_of_ty sgn ty  =
    28.6      let
    28.7 -      val dtypestab = DatatypePackage.get_datatypes sgn;
    28.8 +      val dtypestab = Datatype.get_datatypes sgn;
    28.9        val ty_str = case ty of
   28.10                       Type(ty_str, _) => ty_str
   28.11                     | TFree(s,_)  => error ("Free type: " ^ s)
    29.1 --- a/src/HOL/Tools/TFL/tfl.ML	Fri Jun 19 20:22:46 2009 +0200
    29.2 +++ b/src/HOL/Tools/TFL/tfl.ML	Fri Jun 19 21:08:07 2009 +0200
    29.3 @@ -446,7 +446,7 @@
    29.4         slow.*)
    29.5       val case_ss = Simplifier.theory_context theory
    29.6         (HOL_basic_ss addcongs
    29.7 -         (map (#weak_case_cong o snd) o Symtab.dest o DatatypePackage.get_datatypes) theory addsimps case_rewrites)
    29.8 +         (map (#weak_case_cong o snd) o Symtab.dest o Datatype.get_datatypes) theory addsimps case_rewrites)
    29.9       val corollaries' = map (Simplifier.simplify case_ss) corollaries
   29.10       val extract = R.CONTEXT_REWRITE_RULE
   29.11                       (f, [R], @{thm cut_apply}, meta_tflCongs@context_congs)
    30.1 --- a/src/HOL/Tools/TFL/thry.ML	Fri Jun 19 20:22:46 2009 +0200
    30.2 +++ b/src/HOL/Tools/TFL/thry.ML	Fri Jun 19 21:08:07 2009 +0200
    30.3 @@ -60,20 +60,20 @@
    30.4   *---------------------------------------------------------------------------*)
    30.5  
    30.6  fun match_info thy dtco =
    30.7 -  case (DatatypePackage.get_datatype thy dtco,
    30.8 -         DatatypePackage.get_datatype_constrs thy dtco) of
    30.9 +  case (Datatype.get_datatype thy dtco,
   30.10 +         Datatype.get_datatype_constrs thy dtco) of
   30.11        (SOME { case_name, ... }, SOME constructors) =>
   30.12          SOME {case_const = Const (case_name, Sign.the_const_type thy case_name), constructors = map Const constructors}
   30.13      | _ => NONE;
   30.14  
   30.15 -fun induct_info thy dtco = case DatatypePackage.get_datatype thy dtco of
   30.16 +fun induct_info thy dtco = case Datatype.get_datatype thy dtco of
   30.17          NONE => NONE
   30.18        | SOME {nchotomy, ...} =>
   30.19            SOME {nchotomy = nchotomy,
   30.20 -                constructors = (map Const o the o DatatypePackage.get_datatype_constrs thy) dtco};
   30.21 +                constructors = (map Const o the o Datatype.get_datatype_constrs thy) dtco};
   30.22  
   30.23  fun extract_info thy =
   30.24 - let val infos = (map snd o Symtab.dest o DatatypePackage.get_datatypes) thy
   30.25 + let val infos = (map snd o Symtab.dest o Datatype.get_datatypes) thy
   30.26   in {case_congs = map (mk_meta_eq o #case_cong) infos,
   30.27       case_rewrites = List.concat (map (map mk_meta_eq o #case_rewrites) infos)}
   30.28   end;
    31.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    31.2 +++ b/src/HOL/Tools/choice_specification.ML	Fri Jun 19 21:08:07 2009 +0200
    31.3 @@ -0,0 +1,257 @@
    31.4 +(*  Title:      HOL/Tools/choice_specification.ML
    31.5 +    Author:     Sebastian Skalberg, TU Muenchen
    31.6 +
    31.7 +Package for defining constants by specification.
    31.8 +*)
    31.9 +
   31.10 +signature CHOICE_SPECIFICATION =
   31.11 +sig
   31.12 +  val add_specification: string option -> (bstring * xstring * bool) list ->
   31.13 +    theory * thm -> theory * thm
   31.14 +end
   31.15 +
   31.16 +structure Choice_Specification: CHOICE_SPECIFICATION =
   31.17 +struct
   31.18 +
   31.19 +(* actual code *)
   31.20 +
   31.21 +local
   31.22 +    fun mk_definitional [] arg = arg
   31.23 +      | mk_definitional ((thname,cname,covld)::cos) (thy,thm) =
   31.24 +        case HOLogic.dest_Trueprop (concl_of thm) of
   31.25 +            Const("Ex",_) $ P =>
   31.26 +            let
   31.27 +                val ctype = domain_type (type_of P)
   31.28 +                val cname_full = Sign.intern_const thy cname
   31.29 +                val cdefname = if thname = ""
   31.30 +                               then Thm.def_name (Long_Name.base_name cname)
   31.31 +                               else thname
   31.32 +                val def_eq = Logic.mk_equals (Const(cname_full,ctype),
   31.33 +                                              HOLogic.choice_const ctype $  P)
   31.34 +                val (thms, thy') = PureThy.add_defs covld [((Binding.name cdefname, def_eq),[])] thy
   31.35 +                val thm' = [thm,hd thms] MRS @{thm exE_some}
   31.36 +            in
   31.37 +                mk_definitional cos (thy',thm')
   31.38 +            end
   31.39 +          | _ => raise THM ("Internal error: Bad specification theorem",0,[thm])
   31.40 +
   31.41 +    fun mk_axiomatic axname cos arg =
   31.42 +        let
   31.43 +            fun process [] (thy,tm) =
   31.44 +                let
   31.45 +                    val (thms, thy') = PureThy.add_axioms [((Binding.name axname, HOLogic.mk_Trueprop tm),[])] thy
   31.46 +                in
   31.47 +                    (thy',hd thms)
   31.48 +                end
   31.49 +              | process ((thname,cname,covld)::cos) (thy,tm) =
   31.50 +                case tm of
   31.51 +                    Const("Ex",_) $ P =>
   31.52 +                    let
   31.53 +                        val ctype = domain_type (type_of P)
   31.54 +                        val cname_full = Sign.intern_const thy cname
   31.55 +                        val cdefname = if thname = ""
   31.56 +                                       then Thm.def_name (Long_Name.base_name cname)
   31.57 +                                       else thname
   31.58 +                        val co = Const(cname_full,ctype)
   31.59 +                        val thy' = Theory.add_finals_i covld [co] thy
   31.60 +                        val tm' = case P of
   31.61 +                                      Abs(_, _, bodt) => subst_bound (co, bodt)
   31.62 +                                    | _ => P $ co
   31.63 +                    in
   31.64 +                        process cos (thy',tm')
   31.65 +                    end
   31.66 +                  | _ => raise TERM ("Internal error: Bad specification theorem",[tm])
   31.67 +        in
   31.68 +            process cos arg
   31.69 +        end
   31.70 +
   31.71 +in
   31.72 +fun proc_exprop axiomatic cos arg =
   31.73 +    case axiomatic of
   31.74 +        SOME axname => mk_axiomatic axname cos (apsnd (HOLogic.dest_Trueprop o concl_of) arg)
   31.75 +      | NONE => mk_definitional cos arg
   31.76 +end
   31.77 +
   31.78 +fun add_specification axiomatic cos arg =
   31.79 +    arg |> apsnd Thm.freezeT
   31.80 +        |> proc_exprop axiomatic cos
   31.81 +        |> apsnd standard
   31.82 +
   31.83 +
   31.84 +(* Collect all intances of constants in term *)
   31.85 +
   31.86 +fun collect_consts (        t $ u,tms) = collect_consts (u,collect_consts (t,tms))
   31.87 +  | collect_consts (   Abs(_,_,t),tms) = collect_consts (t,tms)
   31.88 +  | collect_consts (tm as Const _,tms) = insert (op aconv) tm tms
   31.89 +  | collect_consts (            _,tms) = tms
   31.90 +
   31.91 +(* Complementing Type.varify... *)
   31.92 +
   31.93 +fun unvarify t fmap =
   31.94 +    let
   31.95 +        val fmap' = map Library.swap fmap
   31.96 +        fun unthaw (f as (a, S)) =
   31.97 +            (case AList.lookup (op =) fmap' a of
   31.98 +                 NONE => TVar f
   31.99 +               | SOME (b, _) => TFree (b, S))
  31.100 +    in
  31.101 +        map_types (map_type_tvar unthaw) t
  31.102 +    end
  31.103 +
  31.104 +(* The syntactic meddling needed to setup add_specification for work *)
  31.105 +
  31.106 +fun process_spec axiomatic cos alt_props thy =
  31.107 +    let
  31.108 +        fun zip3 [] [] [] = []
  31.109 +          | zip3 (x::xs) (y::ys) (z::zs) = (x,y,z)::zip3 xs ys zs
  31.110 +          | zip3 _ _ _ = error "Choice_Specification.process_spec internal error"
  31.111 +
  31.112 +        fun myfoldr f [x] = x
  31.113 +          | myfoldr f (x::xs) = f (x,myfoldr f xs)
  31.114 +          | myfoldr f [] = error "Choice_Specification.process_spec internal error"
  31.115 +
  31.116 +        val rew_imps = alt_props |>
  31.117 +          map (ObjectLogic.atomize o Thm.cterm_of thy o Syntax.read_prop_global thy o snd)
  31.118 +        val props' = rew_imps |>
  31.119 +          map (HOLogic.dest_Trueprop o term_of o snd o Thm.dest_equals o cprop_of)
  31.120 +
  31.121 +        fun proc_single prop =
  31.122 +            let
  31.123 +                val frees = OldTerm.term_frees prop
  31.124 +                val _ = forall (fn v => Sign.of_sort thy (type_of v,HOLogic.typeS)) frees
  31.125 +                  orelse error "Specificaton: Only free variables of sort 'type' allowed"
  31.126 +                val prop_closed = List.foldr (fn ((vname,T),prop) => HOLogic.mk_all (vname,T,prop)) prop (map dest_Free frees)
  31.127 +            in
  31.128 +                (prop_closed,frees)
  31.129 +            end
  31.130 +
  31.131 +        val props'' = map proc_single props'
  31.132 +        val frees = map snd props''
  31.133 +        val prop  = myfoldr HOLogic.mk_conj (map fst props'')
  31.134 +        val cprop = cterm_of thy (HOLogic.mk_Trueprop prop)
  31.135 +
  31.136 +        val (vmap, prop_thawed) = Type.varify [] prop
  31.137 +        val thawed_prop_consts = collect_consts (prop_thawed,[])
  31.138 +        val (altcos,overloaded) = Library.split_list cos
  31.139 +        val (names,sconsts) = Library.split_list altcos
  31.140 +        val consts = map (Syntax.read_term_global thy) sconsts
  31.141 +        val _ = not (Library.exists (not o Term.is_Const) consts)
  31.142 +          orelse error "Specification: Non-constant found as parameter"
  31.143 +
  31.144 +        fun proc_const c =
  31.145 +            let
  31.146 +                val (_, c') = Type.varify [] c
  31.147 +                val (cname,ctyp) = dest_Const c'
  31.148 +            in
  31.149 +                case List.filter (fn t => let val (name,typ) = dest_Const t
  31.150 +                                     in name = cname andalso Sign.typ_equiv thy (typ, ctyp)
  31.151 +                                     end) thawed_prop_consts of
  31.152 +                    [] => error ("Specification: No suitable instances of constant \"" ^ Syntax.string_of_term_global thy c ^ "\" found")
  31.153 +                  | [cf] => unvarify cf vmap
  31.154 +                  | _ => error ("Specification: Several variations of \"" ^ Syntax.string_of_term_global thy c ^ "\" found (try applying explicit type constraints)")
  31.155 +            end
  31.156 +        val proc_consts = map proc_const consts
  31.157 +        fun mk_exist (c,prop) =
  31.158 +            let
  31.159 +                val T = type_of c
  31.160 +                val cname = Long_Name.base_name (fst (dest_Const c))
  31.161 +                val vname = if Syntax.is_identifier cname
  31.162 +                            then cname
  31.163 +                            else "x"
  31.164 +            in
  31.165 +                HOLogic.exists_const T $ Abs(vname,T,Term.abstract_over (c,prop))
  31.166 +            end
  31.167 +        val ex_prop = List.foldr mk_exist prop proc_consts
  31.168 +        val cnames = map (fst o dest_Const) proc_consts
  31.169 +        fun post_process (arg as (thy,thm)) =
  31.170 +            let
  31.171 +                fun inst_all thy (thm,v) =
  31.172 +                    let
  31.173 +                        val cv = cterm_of thy v
  31.174 +                        val cT = ctyp_of_term cv
  31.175 +                        val spec' = instantiate' [SOME cT] [NONE,SOME cv] spec
  31.176 +                    in
  31.177 +                        thm RS spec'
  31.178 +                    end
  31.179 +                fun remove_alls frees thm =
  31.180 +                    Library.foldl (inst_all (Thm.theory_of_thm thm)) (thm,frees)
  31.181 +                fun process_single ((name,atts),rew_imp,frees) args =
  31.182 +                    let
  31.183 +                        fun undo_imps thm =
  31.184 +                            equal_elim (symmetric rew_imp) thm
  31.185 +
  31.186 +                        fun add_final (arg as (thy, thm)) =
  31.187 +                            if name = ""
  31.188 +                            then arg |> Library.swap
  31.189 +                            else (writeln ("  " ^ name ^ ": " ^ (Display.string_of_thm thm));
  31.190 +                                  PureThy.store_thm (Binding.name name, thm) thy)
  31.191 +                    in
  31.192 +                        args |> apsnd (remove_alls frees)
  31.193 +                             |> apsnd undo_imps
  31.194 +                             |> apsnd standard
  31.195 +                             |> Thm.theory_attributes (map (Attrib.attribute thy) atts)
  31.196 +                             |> add_final
  31.197 +                             |> Library.swap
  31.198 +                    end
  31.199 +
  31.200 +                fun process_all [proc_arg] args =
  31.201 +                    process_single proc_arg args
  31.202 +                  | process_all (proc_arg::rest) (thy,thm) =
  31.203 +                    let
  31.204 +                        val single_th = thm RS conjunct1
  31.205 +                        val rest_th   = thm RS conjunct2
  31.206 +                        val (thy',_)  = process_single proc_arg (thy,single_th)
  31.207 +                    in
  31.208 +                        process_all rest (thy',rest_th)
  31.209 +                    end
  31.210 +                  | process_all [] _ = error "Choice_Specification.process_spec internal error"
  31.211 +                val alt_names = map fst alt_props
  31.212 +                val _ = if exists (fn(name,_) => not (name = "")) alt_names
  31.213 +                        then writeln "specification"
  31.214 +                        else ()
  31.215 +            in
  31.216 +                arg |> apsnd Thm.freezeT
  31.217 +                    |> process_all (zip3 alt_names rew_imps frees)
  31.218 +            end
  31.219 +
  31.220 +      fun after_qed [[thm]] = ProofContext.theory (fn thy =>
  31.221 +        #1 (post_process (add_specification axiomatic (zip3 names cnames overloaded) (thy, thm))));
  31.222 +    in
  31.223 +      thy
  31.224 +      |> ProofContext.init
  31.225 +      |> Proof.theorem_i NONE after_qed [[(HOLogic.mk_Trueprop ex_prop, [])]]
  31.226 +    end;
  31.227 +
  31.228 +
  31.229 +(* outer syntax *)
  31.230 +
  31.231 +local structure P = OuterParse and K = OuterKeyword in
  31.232 +
  31.233 +val opt_name = Scan.optional (P.name --| P.$$$ ":") ""
  31.234 +val opt_overloaded = P.opt_keyword "overloaded";
  31.235 +
  31.236 +val specification_decl =
  31.237 +  P.$$$ "(" |-- Scan.repeat1 (opt_name -- P.term -- opt_overloaded) --| P.$$$ ")" --
  31.238 +          Scan.repeat1 ((SpecParse.opt_thm_name ":" >> apfst Binding.name_of) -- P.prop)
  31.239 +
  31.240 +val _ =
  31.241 +  OuterSyntax.command "specification" "define constants by specification" K.thy_goal
  31.242 +    (specification_decl >> (fn (cos,alt_props) =>
  31.243 +                               Toplevel.print o (Toplevel.theory_to_proof
  31.244 +                                                     (process_spec NONE cos alt_props))))
  31.245 +
  31.246 +val ax_specification_decl =
  31.247 +    P.name --
  31.248 +    (P.$$$ "(" |-- Scan.repeat1 (opt_name -- P.term -- opt_overloaded) --| P.$$$ ")" --
  31.249 +           Scan.repeat1 ((SpecParse.opt_thm_name ":" >> apfst Binding.name_of) -- P.prop))
  31.250 +
  31.251 +val _ =
  31.252 +  OuterSyntax.command "ax_specification" "define constants by specification" K.thy_goal
  31.253 +    (ax_specification_decl >> (fn (axname,(cos,alt_props)) =>
  31.254 +                               Toplevel.print o (Toplevel.theory_to_proof
  31.255 +                                                     (process_spec (SOME axname) cos alt_props))))
  31.256 +
  31.257 +end
  31.258 +
  31.259 +
  31.260 +end
    32.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    32.2 +++ b/src/HOL/Tools/datatype_package/datatype.ML	Fri Jun 19 21:08:07 2009 +0200
    32.3 @@ -0,0 +1,705 @@
    32.4 +(*  Title:      HOL/Tools/datatype.ML
    32.5 +    Author:     Stefan Berghofer, TU Muenchen
    32.6 +
    32.7 +Datatype package for Isabelle/HOL.
    32.8 +*)
    32.9 +
   32.10 +signature DATATYPE =
   32.11 +sig
   32.12 +  type datatype_config = DatatypeAux.datatype_config
   32.13 +  type datatype_info = DatatypeAux.datatype_info
   32.14 +  type descr = DatatypeAux.descr
   32.15 +  val get_datatypes : theory -> datatype_info Symtab.table
   32.16 +  val get_datatype : theory -> string -> datatype_info option
   32.17 +  val the_datatype : theory -> string -> datatype_info
   32.18 +  val datatype_of_constr : theory -> string -> datatype_info option
   32.19 +  val datatype_of_case : theory -> string -> datatype_info option
   32.20 +  val the_datatype_spec : theory -> string -> (string * sort) list * (string * typ list) list
   32.21 +  val the_datatype_descr : theory -> string list
   32.22 +    -> descr * (string * sort) list * string list
   32.23 +      * (string list * string list) * (typ list * typ list)
   32.24 +  val get_datatype_constrs : theory -> string -> (string * typ) list option
   32.25 +  val distinct_simproc : simproc
   32.26 +  val make_case :  Proof.context -> bool -> string list -> term ->
   32.27 +    (term * term) list -> term * (term * (int * bool)) list
   32.28 +  val strip_case : Proof.context -> bool -> term -> (term * (term * term) list) option
   32.29 +  val read_typ: theory ->
   32.30 +    (typ list * (string * sort) list) * string -> typ list * (string * sort) list
   32.31 +  val interpretation : (datatype_config -> string list -> theory -> theory) -> theory -> theory
   32.32 +  type rules = {distinct : thm list list,
   32.33 +    inject : thm list list,
   32.34 +    exhaustion : thm list,
   32.35 +    rec_thms : thm list,
   32.36 +    case_thms : thm list list,
   32.37 +    split_thms : (thm * thm) list,
   32.38 +    induction : thm,
   32.39 +    simps : thm list}
   32.40 +  val rep_datatype : datatype_config -> (rules -> Proof.context -> Proof.context)
   32.41 +    -> string list option -> term list -> theory -> Proof.state;
   32.42 +  val rep_datatype_cmd : string list option -> string list -> theory -> Proof.state
   32.43 +  val add_datatype : datatype_config -> string list -> (string list * binding * mixfix *
   32.44 +    (binding * typ list * mixfix) list) list -> theory -> rules * theory
   32.45 +  val add_datatype_cmd : string list -> (string list * binding * mixfix *
   32.46 +    (binding * string list * mixfix) list) list -> theory -> rules * theory
   32.47 +  val setup: theory -> theory
   32.48 +  val print_datatypes : theory -> unit
   32.49 +end;
   32.50 +
   32.51 +structure Datatype : DATATYPE =
   32.52 +struct
   32.53 +
   32.54 +open DatatypeAux;
   32.55 +
   32.56 +
   32.57 +(* theory data *)
   32.58 +
   32.59 +structure DatatypesData = TheoryDataFun
   32.60 +(
   32.61 +  type T =
   32.62 +    {types: datatype_info Symtab.table,
   32.63 +     constrs: datatype_info Symtab.table,
   32.64 +     cases: datatype_info Symtab.table};
   32.65 +
   32.66 +  val empty =
   32.67 +    {types = Symtab.empty, constrs = Symtab.empty, cases = Symtab.empty};
   32.68 +  val copy = I;
   32.69 +  val extend = I;
   32.70 +  fun merge _
   32.71 +    ({types = types1, constrs = constrs1, cases = cases1},
   32.72 +     {types = types2, constrs = constrs2, cases = cases2}) =
   32.73 +    {types = Symtab.merge (K true) (types1, types2),
   32.74 +     constrs = Symtab.merge (K true) (constrs1, constrs2),
   32.75 +     cases = Symtab.merge (K true) (cases1, cases2)};
   32.76 +);
   32.77 +
   32.78 +val get_datatypes = #types o DatatypesData.get;
   32.79 +val map_datatypes = DatatypesData.map;
   32.80 +
   32.81 +fun print_datatypes thy =
   32.82 +  Pretty.writeln (Pretty.strs ("datatypes:" ::
   32.83 +    map #1 (NameSpace.extern_table (Sign.type_space thy, get_datatypes thy))));
   32.84 +
   32.85 +
   32.86 +(** theory information about datatypes **)
   32.87 +
   32.88 +fun put_dt_infos (dt_infos : (string * datatype_info) list) =
   32.89 +  map_datatypes (fn {types, constrs, cases} =>
   32.90 +    {types = fold Symtab.update dt_infos types,
   32.91 +     constrs = fold Symtab.default (*conservative wrt. overloaded constructors*)
   32.92 +       (maps (fn (_, info as {descr, index, ...}) => map (rpair info o fst)
   32.93 +          (#3 (the (AList.lookup op = descr index)))) dt_infos) constrs,
   32.94 +     cases = fold Symtab.update
   32.95 +       (map (fn (_, info as {case_name, ...}) => (case_name, info)) dt_infos)
   32.96 +       cases});
   32.97 +
   32.98 +val get_datatype = Symtab.lookup o get_datatypes;
   32.99 +
  32.100 +fun the_datatype thy name = (case get_datatype thy name of
  32.101 +      SOME info => info
  32.102 +    | NONE => error ("Unknown datatype " ^ quote name));
  32.103 +
  32.104 +val datatype_of_constr = Symtab.lookup o #constrs o DatatypesData.get;
  32.105 +val datatype_of_case = Symtab.lookup o #cases o DatatypesData.get;
  32.106 +
  32.107 +fun get_datatype_descr thy dtco =
  32.108 +  get_datatype thy dtco
  32.109 +  |> Option.map (fn info as { descr, index, ... } =>
  32.110 +       (info, (((fn SOME (_, dtys, cos) => (dtys, cos)) o AList.lookup (op =) descr) index)));
  32.111 +
  32.112 +fun the_datatype_spec thy dtco =
  32.113 +  let
  32.114 +    val info as { descr, index, sorts = raw_sorts, ... } = the_datatype thy dtco;
  32.115 +    val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr index;
  32.116 +    val sorts = map ((fn v => (v, (the o AList.lookup (op =) raw_sorts) v))
  32.117 +      o DatatypeAux.dest_DtTFree) dtys;
  32.118 +    val cos = map
  32.119 +      (fn (co, tys) => (co, map (DatatypeAux.typ_of_dtyp descr sorts) tys)) raw_cos;
  32.120 +  in (sorts, cos) end;
  32.121 +
  32.122 +fun the_datatype_descr thy (raw_tycos as raw_tyco :: _) =
  32.123 +  let
  32.124 +    val info = the_datatype thy raw_tyco;
  32.125 +    val descr = #descr info;
  32.126 +
  32.127 +    val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr (#index info);
  32.128 +    val vs = map ((fn v => (v, (the o AList.lookup (op =) (#sorts info)) v))
  32.129 +      o dest_DtTFree) dtys;
  32.130 +
  32.131 +    fun is_DtTFree (DtTFree _) = true
  32.132 +      | is_DtTFree _ = false
  32.133 +    val k = find_index (fn (_, (_, dTs, _)) => not (forall is_DtTFree dTs)) descr;
  32.134 +    val protoTs as (dataTs, _) = chop k descr
  32.135 +      |> (pairself o map) (fn (_, (tyco, dTs, _)) => (tyco, map (typ_of_dtyp descr vs) dTs));
  32.136 +    
  32.137 +    val tycos = map fst dataTs;
  32.138 +    val _ = if gen_eq_set (op =) (tycos, raw_tycos) then ()
  32.139 +      else error ("Type constructors " ^ commas (map quote raw_tycos)
  32.140 +        ^ "do not belong exhaustively to one mutual recursive datatype");
  32.141 +
  32.142 +    val (Ts, Us) = (pairself o map) Type protoTs;
  32.143 +
  32.144 +    val names = map Long_Name.base_name (the_default tycos (#alt_names info));
  32.145 +    val (auxnames, _) = Name.make_context names
  32.146 +      |> fold_map (yield_singleton Name.variants o name_of_typ) Us
  32.147 +
  32.148 +  in (descr, vs, tycos, (names, auxnames), (Ts, Us)) end;
  32.149 +
  32.150 +fun get_datatype_constrs thy dtco =
  32.151 +  case try (the_datatype_spec thy) dtco
  32.152 +   of SOME (sorts, cos) =>
  32.153 +        let
  32.154 +          fun subst (v, sort) = TVar ((v, 0), sort);
  32.155 +          fun subst_ty (TFree v) = subst v
  32.156 +            | subst_ty ty = ty;
  32.157 +          val dty = Type (dtco, map subst sorts);
  32.158 +          fun mk_co (co, tys) = (co, map (Term.map_atyps subst_ty) tys ---> dty);
  32.159 +        in SOME (map mk_co cos) end
  32.160 +    | NONE => NONE;
  32.161 +
  32.162 +
  32.163 +(** induct method setup **)
  32.164 +
  32.165 +(* case names *)
  32.166 +
  32.167 +local
  32.168 +
  32.169 +fun dt_recs (DtTFree _) = []
  32.170 +  | dt_recs (DtType (_, dts)) = maps dt_recs dts
  32.171 +  | dt_recs (DtRec i) = [i];
  32.172 +
  32.173 +fun dt_cases (descr: descr) (_, args, constrs) =
  32.174 +  let
  32.175 +    fun the_bname i = Long_Name.base_name (#1 (the (AList.lookup (op =) descr i)));
  32.176 +    val bnames = map the_bname (distinct (op =) (maps dt_recs args));
  32.177 +  in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
  32.178 +
  32.179 +
  32.180 +fun induct_cases descr =
  32.181 +  DatatypeProp.indexify_names (maps (dt_cases descr) (map #2 descr));
  32.182 +
  32.183 +fun exhaust_cases descr i = dt_cases descr (the (AList.lookup (op =) descr i));
  32.184 +
  32.185 +in
  32.186 +
  32.187 +fun mk_case_names_induct descr = RuleCases.case_names (induct_cases descr);
  32.188 +
  32.189 +fun mk_case_names_exhausts descr new =
  32.190 +  map (RuleCases.case_names o exhaust_cases descr o #1)
  32.191 +    (filter (fn ((_, (name, _, _))) => member (op =) new name) descr);
  32.192 +
  32.193 +end;
  32.194 +
  32.195 +fun add_rules simps case_thms rec_thms inject distinct
  32.196 +                  weak_case_congs cong_att =
  32.197 +  PureThy.add_thmss [((Binding.name "simps", simps), []),
  32.198 +    ((Binding.empty, flat case_thms @
  32.199 +          flat distinct @ rec_thms), [Simplifier.simp_add]),
  32.200 +    ((Binding.empty, rec_thms), [Code.add_default_eqn_attribute]),
  32.201 +    ((Binding.empty, flat inject), [iff_add]),
  32.202 +    ((Binding.empty, map (fn th => th RS notE) (flat distinct)), [Classical.safe_elim NONE]),
  32.203 +    ((Binding.empty, weak_case_congs), [cong_att])]
  32.204 +  #> snd;
  32.205 +
  32.206 +
  32.207 +(* add_cases_induct *)
  32.208 +
  32.209 +fun add_cases_induct infos induction thy =
  32.210 +  let
  32.211 +    val inducts = ProjectRule.projections (ProofContext.init thy) induction;
  32.212 +
  32.213 +    fun named_rules (name, {index, exhaustion, ...}: datatype_info) =
  32.214 +      [((Binding.empty, nth inducts index), [Induct.induct_type name]),
  32.215 +       ((Binding.empty, exhaustion), [Induct.cases_type name])];
  32.216 +    fun unnamed_rule i =
  32.217 +      ((Binding.empty, nth inducts i), [Thm.kind_internal, Induct.induct_type ""]);
  32.218 +  in
  32.219 +    thy |> PureThy.add_thms
  32.220 +      (maps named_rules infos @
  32.221 +        map unnamed_rule (length infos upto length inducts - 1)) |> snd
  32.222 +    |> PureThy.add_thmss [((Binding.name "inducts", inducts), [])] |> snd
  32.223 +  end;
  32.224 +
  32.225 +
  32.226 +
  32.227 +(**** simplification procedure for showing distinctness of constructors ****)
  32.228 +
  32.229 +fun stripT (i, Type ("fun", [_, T])) = stripT (i + 1, T)
  32.230 +  | stripT p = p;
  32.231 +
  32.232 +fun stripC (i, f $ x) = stripC (i + 1, f)
  32.233 +  | stripC p = p;
  32.234 +
  32.235 +val distinctN = "constr_distinct";
  32.236 +
  32.237 +fun distinct_rule thy ss tname eq_t = case #distinct (the_datatype thy tname) of
  32.238 +    FewConstrs thms => Goal.prove (Simplifier.the_context ss) [] [] eq_t (K
  32.239 +      (EVERY [rtac eq_reflection 1, rtac iffI 1, rtac notE 1,
  32.240 +        atac 2, resolve_tac thms 1, etac FalseE 1]))
  32.241 +  | ManyConstrs (thm, simpset) =>
  32.242 +      let
  32.243 +        val [In0_inject, In1_inject, In0_not_In1, In1_not_In0] =
  32.244 +          map (PureThy.get_thm (ThyInfo.the_theory "Datatype" thy))
  32.245 +            ["In0_inject", "In1_inject", "In0_not_In1", "In1_not_In0"];
  32.246 +      in
  32.247 +        Goal.prove (Simplifier.the_context ss) [] [] eq_t (K
  32.248 +        (EVERY [rtac eq_reflection 1, rtac iffI 1, dtac thm 1,
  32.249 +          full_simp_tac (Simplifier.inherit_context ss simpset) 1,
  32.250 +          REPEAT (dresolve_tac [In0_inject, In1_inject] 1),
  32.251 +          eresolve_tac [In0_not_In1 RS notE, In1_not_In0 RS notE] 1,
  32.252 +          etac FalseE 1]))
  32.253 +      end;
  32.254 +
  32.255 +fun distinct_proc thy ss (t as Const ("op =", _) $ t1 $ t2) =
  32.256 +  (case (stripC (0, t1), stripC (0, t2)) of
  32.257 +     ((i, Const (cname1, T1)), (j, Const (cname2, T2))) =>
  32.258 +         (case (stripT (0, T1), stripT (0, T2)) of
  32.259 +            ((i', Type (tname1, _)), (j', Type (tname2, _))) =>
  32.260 +                if tname1 = tname2 andalso not (cname1 = cname2) andalso i = i' andalso j = j' then
  32.261 +                   (case (get_datatype_descr thy) tname1 of
  32.262 +                      SOME (_, (_, constrs)) => let val cnames = map fst constrs
  32.263 +                        in if cname1 mem cnames andalso cname2 mem cnames then
  32.264 +                             SOME (distinct_rule thy ss tname1
  32.265 +                               (Logic.mk_equals (t, Const ("False", HOLogic.boolT))))
  32.266 +                           else NONE
  32.267 +                        end
  32.268 +                    | NONE => NONE)
  32.269 +                else NONE
  32.270 +          | _ => NONE)
  32.271 +   | _ => NONE)
  32.272 +  | distinct_proc _ _ _ = NONE;
  32.273 +
  32.274 +val distinct_simproc =
  32.275 +  Simplifier.simproc @{theory HOL} distinctN ["s = t"] distinct_proc;
  32.276 +
  32.277 +val dist_ss = HOL_ss addsimprocs [distinct_simproc];
  32.278 +
  32.279 +val simproc_setup =
  32.280 +  Simplifier.map_simpset (fn ss => ss addsimprocs [distinct_simproc]);
  32.281 +
  32.282 +
  32.283 +(**** translation rules for case ****)
  32.284 +
  32.285 +fun make_case ctxt = DatatypeCase.make_case
  32.286 +  (datatype_of_constr (ProofContext.theory_of ctxt)) ctxt;
  32.287 +
  32.288 +fun strip_case ctxt = DatatypeCase.strip_case
  32.289 +  (datatype_of_case (ProofContext.theory_of ctxt));
  32.290 +
  32.291 +fun add_case_tr' case_names thy =
  32.292 +  Sign.add_advanced_trfuns ([], [],
  32.293 +    map (fn case_name =>
  32.294 +      let val case_name' = Sign.const_syntax_name thy case_name
  32.295 +      in (case_name', DatatypeCase.case_tr' datatype_of_case case_name')
  32.296 +      end) case_names, []) thy;
  32.297 +
  32.298 +val trfun_setup =
  32.299 +  Sign.add_advanced_trfuns ([],
  32.300 +    [("_case_syntax", DatatypeCase.case_tr true datatype_of_constr)],
  32.301 +    [], []);
  32.302 +
  32.303 +
  32.304 +(* prepare types *)
  32.305 +
  32.306 +fun read_typ thy ((Ts, sorts), str) =
  32.307 +  let
  32.308 +    val ctxt = ProofContext.init thy
  32.309 +      |> fold (Variable.declare_typ o TFree) sorts;
  32.310 +    val T = Syntax.read_typ ctxt str;
  32.311 +  in (Ts @ [T], Term.add_tfreesT T sorts) end;
  32.312 +
  32.313 +fun cert_typ sign ((Ts, sorts), raw_T) =
  32.314 +  let
  32.315 +    val T = Type.no_tvars (Sign.certify_typ sign raw_T) handle
  32.316 +      TYPE (msg, _, _) => error msg;
  32.317 +    val sorts' = Term.add_tfreesT T sorts;
  32.318 +  in (Ts @ [T],
  32.319 +      case duplicates (op =) (map fst sorts') of
  32.320 +         [] => sorts'
  32.321 +       | dups => error ("Inconsistent sort constraints for " ^ commas dups))
  32.322 +  end;
  32.323 +
  32.324 +
  32.325 +(**** make datatype info ****)
  32.326 +
  32.327 +fun make_dt_info alt_names descr sorts induct reccomb_names rec_thms
  32.328 +    (((((((((i, (_, (tname, _, _))), case_name), case_thms),
  32.329 +      exhaustion_thm), distinct_thm), inject), nchotomy), case_cong), weak_case_cong) =
  32.330 +  (tname,
  32.331 +   {index = i,
  32.332 +    alt_names = alt_names,
  32.333 +    descr = descr,
  32.334 +    sorts = sorts,
  32.335 +    rec_names = reccomb_names,
  32.336 +    rec_rewrites = rec_thms,
  32.337 +    case_name = case_name,
  32.338 +    case_rewrites = case_thms,
  32.339 +    induction = induct,
  32.340 +    exhaustion = exhaustion_thm,
  32.341 +    distinct = distinct_thm,
  32.342 +    inject = inject,
  32.343 +    nchotomy = nchotomy,
  32.344 +    case_cong = case_cong,
  32.345 +    weak_case_cong = weak_case_cong});
  32.346 +
  32.347 +type rules = {distinct : thm list list,
  32.348 +  inject : thm list list,
  32.349 +  exhaustion : thm list,
  32.350 +  rec_thms : thm list,
  32.351 +  case_thms : thm list list,
  32.352 +  split_thms : (thm * thm) list,
  32.353 +  induction : thm,
  32.354 +  simps : thm list}
  32.355 +
  32.356 +structure DatatypeInterpretation = InterpretationFun
  32.357 +  (type T = datatype_config * string list val eq: T * T -> bool = eq_snd op =);
  32.358 +fun interpretation f = DatatypeInterpretation.interpretation (uncurry f);
  32.359 +
  32.360 +
  32.361 +(******************* definitional introduction of datatypes *******************)
  32.362 +
  32.363 +fun add_datatype_def (config : datatype_config) new_type_names descr sorts types_syntax constr_syntax dt_info
  32.364 +    case_names_induct case_names_exhausts thy =
  32.365 +  let
  32.366 +    val _ = message config ("Proofs for datatype(s) " ^ commas_quote new_type_names);
  32.367 +
  32.368 +    val ((inject, distinct, dist_rewrites, simproc_dists, induct), thy2) = thy |>
  32.369 +      DatatypeRepProofs.representation_proofs config dt_info new_type_names descr sorts
  32.370 +        types_syntax constr_syntax case_names_induct;
  32.371 +
  32.372 +    val (casedist_thms, thy3) = DatatypeAbsProofs.prove_casedist_thms config new_type_names descr
  32.373 +      sorts induct case_names_exhausts thy2;
  32.374 +    val ((reccomb_names, rec_thms), thy4) = DatatypeAbsProofs.prove_primrec_thms
  32.375 +      config new_type_names descr sorts dt_info inject dist_rewrites
  32.376 +      (Simplifier.theory_context thy3 dist_ss) induct thy3;
  32.377 +    val ((case_thms, case_names), thy6) = DatatypeAbsProofs.prove_case_thms
  32.378 +      config new_type_names descr sorts reccomb_names rec_thms thy4;
  32.379 +    val (split_thms, thy7) = DatatypeAbsProofs.prove_split_thms config new_type_names
  32.380 +      descr sorts inject dist_rewrites casedist_thms case_thms thy6;
  32.381 +    val (nchotomys, thy8) = DatatypeAbsProofs.prove_nchotomys config new_type_names
  32.382 +      descr sorts casedist_thms thy7;
  32.383 +    val (case_congs, thy9) = DatatypeAbsProofs.prove_case_congs new_type_names
  32.384 +      descr sorts nchotomys case_thms thy8;
  32.385 +    val (weak_case_congs, thy10) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
  32.386 +      descr sorts thy9;
  32.387 +
  32.388 +    val dt_infos = map
  32.389 +      (make_dt_info (SOME new_type_names) (flat descr) sorts induct reccomb_names rec_thms)
  32.390 +      ((0 upto length (hd descr) - 1) ~~ (hd descr) ~~ case_names ~~ case_thms ~~
  32.391 +        casedist_thms ~~ simproc_dists ~~ inject ~~ nchotomys ~~ case_congs ~~ weak_case_congs);
  32.392 +
  32.393 +    val simps = flat (distinct @ inject @ case_thms) @ rec_thms;
  32.394 +
  32.395 +    val thy12 =
  32.396 +      thy10
  32.397 +      |> add_case_tr' case_names
  32.398 +      |> Sign.add_path (space_implode "_" new_type_names)
  32.399 +      |> add_rules simps case_thms rec_thms inject distinct
  32.400 +          weak_case_congs (Simplifier.attrib (op addcongs))
  32.401 +      |> put_dt_infos dt_infos
  32.402 +      |> add_cases_induct dt_infos induct
  32.403 +      |> Sign.parent_path
  32.404 +      |> store_thmss "splits" new_type_names (map (fn (x, y) => [x, y]) split_thms) |> snd
  32.405 +      |> DatatypeInterpretation.data (config, map fst dt_infos);
  32.406 +  in
  32.407 +    ({distinct = distinct,
  32.408 +      inject = inject,
  32.409 +      exhaustion = casedist_thms,
  32.410 +      rec_thms = rec_thms,
  32.411 +      case_thms = case_thms,
  32.412 +      split_thms = split_thms,
  32.413 +      induction = induct,
  32.414 +      simps = simps}, thy12)
  32.415 +  end;
  32.416 +
  32.417 +
  32.418 +(*********************** declare existing type as datatype *********************)
  32.419 +
  32.420 +fun prove_rep_datatype (config : datatype_config) alt_names new_type_names descr sorts induct inject half_distinct thy =
  32.421 +  let
  32.422 +    val ((_, [induct']), _) =
  32.423 +      Variable.importT_thms [induct] (Variable.thm_context induct);
  32.424 +
  32.425 +    fun err t = error ("Ill-formed predicate in induction rule: " ^
  32.426 +      Syntax.string_of_term_global thy t);
  32.427 +
  32.428 +    fun get_typ (t as _ $ Var (_, Type (tname, Ts))) =
  32.429 +          ((tname, map (fst o dest_TFree) Ts) handle TERM _ => err t)
  32.430 +      | get_typ t = err t;
  32.431 +    val dtnames = map get_typ (HOLogic.dest_conj (HOLogic.dest_Trueprop (Thm.concl_of induct')));
  32.432 +
  32.433 +    val dt_info = get_datatypes thy;
  32.434 +
  32.435 +    val distinct = (map o maps) (fn thm => [thm, thm RS not_sym]) half_distinct;
  32.436 +    val (case_names_induct, case_names_exhausts) =
  32.437 +      (mk_case_names_induct descr, mk_case_names_exhausts descr (map #1 dtnames));
  32.438 +
  32.439 +    val _ = message config ("Proofs for datatype(s) " ^ commas_quote new_type_names);
  32.440 +
  32.441 +    val (casedist_thms, thy2) = thy |>
  32.442 +      DatatypeAbsProofs.prove_casedist_thms config new_type_names [descr] sorts induct
  32.443 +        case_names_exhausts;
  32.444 +    val ((reccomb_names, rec_thms), thy3) = DatatypeAbsProofs.prove_primrec_thms
  32.445 +      config new_type_names [descr] sorts dt_info inject distinct
  32.446 +      (Simplifier.theory_context thy2 dist_ss) induct thy2;
  32.447 +    val ((case_thms, case_names), thy4) = DatatypeAbsProofs.prove_case_thms
  32.448 +      config new_type_names [descr] sorts reccomb_names rec_thms thy3;
  32.449 +    val (split_thms, thy5) = DatatypeAbsProofs.prove_split_thms
  32.450 +      config new_type_names [descr] sorts inject distinct casedist_thms case_thms thy4;
  32.451 +    val (nchotomys, thy6) = DatatypeAbsProofs.prove_nchotomys config new_type_names
  32.452 +      [descr] sorts casedist_thms thy5;
  32.453 +    val (case_congs, thy7) = DatatypeAbsProofs.prove_case_congs new_type_names
  32.454 +      [descr] sorts nchotomys case_thms thy6;
  32.455 +    val (weak_case_congs, thy8) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
  32.456 +      [descr] sorts thy7;
  32.457 +
  32.458 +    val ((_, [induct']), thy10) =
  32.459 +      thy8
  32.460 +      |> store_thmss "inject" new_type_names inject
  32.461 +      ||>> store_thmss "distinct" new_type_names distinct
  32.462 +      ||> Sign.add_path (space_implode "_" new_type_names)
  32.463 +      ||>> PureThy.add_thms [((Binding.name "induct", induct), [case_names_induct])];
  32.464 +
  32.465 +    val dt_infos = map (make_dt_info alt_names descr sorts induct' reccomb_names rec_thms)
  32.466 +      ((0 upto length descr - 1) ~~ descr ~~ case_names ~~ case_thms ~~ casedist_thms ~~
  32.467 +        map FewConstrs distinct ~~ inject ~~ nchotomys ~~ case_congs ~~ weak_case_congs);
  32.468 +
  32.469 +    val simps = flat (distinct @ inject @ case_thms) @ rec_thms;
  32.470 +
  32.471 +    val thy11 =
  32.472 +      thy10
  32.473 +      |> add_case_tr' case_names
  32.474 +      |> add_rules simps case_thms rec_thms inject distinct
  32.475 +           weak_case_congs (Simplifier.attrib (op addcongs))
  32.476 +      |> put_dt_infos dt_infos
  32.477 +      |> add_cases_induct dt_infos induct'
  32.478 +      |> Sign.parent_path
  32.479 +      |> store_thmss "splits" new_type_names (map (fn (x, y) => [x, y]) split_thms)
  32.480 +      |> snd
  32.481 +      |> DatatypeInterpretation.data (config, map fst dt_infos);
  32.482 +  in
  32.483 +    ({distinct = distinct,
  32.484 +      inject = inject,
  32.485 +      exhaustion = casedist_thms,
  32.486 +      rec_thms = rec_thms,
  32.487 +      case_thms = case_thms,
  32.488 +      split_thms = split_thms,
  32.489 +      induction = induct',
  32.490 +      simps = simps}, thy11)
  32.491 +  end;
  32.492 +
  32.493 +fun gen_rep_datatype prep_term (config : datatype_config) after_qed alt_names raw_ts thy =
  32.494 +  let
  32.495 +    fun constr_of_term (Const (c, T)) = (c, T)
  32.496 +      | constr_of_term t =
  32.497 +          error ("Not a constant: " ^ Syntax.string_of_term_global thy t);
  32.498 +    fun no_constr (c, T) = error ("Bad constructor: "
  32.499 +      ^ Sign.extern_const thy c ^ "::"
  32.500 +      ^ Syntax.string_of_typ_global thy T);
  32.501 +    fun type_of_constr (cT as (_, T)) =
  32.502 +      let
  32.503 +        val frees = OldTerm.typ_tfrees T;
  32.504 +        val (tyco, vs) = ((apsnd o map) (dest_TFree) o dest_Type o snd o strip_type) T
  32.505 +          handle TYPE _ => no_constr cT
  32.506 +        val _ = if has_duplicates (eq_fst (op =)) vs then no_constr cT else ();
  32.507 +        val _ = if length frees <> length vs then no_constr cT else ();
  32.508 +      in (tyco, (vs, cT)) end;
  32.509 +
  32.510 +    val raw_cs = AList.group (op =) (map (type_of_constr o constr_of_term o prep_term thy) raw_ts);
  32.511 +    val _ = case map_filter (fn (tyco, _) =>
  32.512 +        if Symtab.defined (get_datatypes thy) tyco then SOME tyco else NONE) raw_cs
  32.513 +     of [] => ()
  32.514 +      | tycos => error ("Type(s) " ^ commas (map quote tycos)
  32.515 +          ^ " already represented inductivly");
  32.516 +    val raw_vss = maps (map (map snd o fst) o snd) raw_cs;
  32.517 +    val ms = case distinct (op =) (map length raw_vss)
  32.518 +     of [n] => 0 upto n - 1
  32.519 +      | _ => error ("Different types in given constructors");
  32.520 +    fun inter_sort m = map (fn xs => nth xs m) raw_vss
  32.521 +      |> Library.foldr1 (Sorts.inter_sort (Sign.classes_of thy))
  32.522 +    val sorts = map inter_sort ms;
  32.523 +    val vs = Name.names Name.context Name.aT sorts;
  32.524 +
  32.525 +    fun norm_constr (raw_vs, (c, T)) = (c, map_atyps
  32.526 +      (TFree o (the o AList.lookup (op =) (map fst raw_vs ~~ vs)) o fst o dest_TFree) T);
  32.527 +
  32.528 +    val cs = map (apsnd (map norm_constr)) raw_cs;
  32.529 +    val dtyps_of_typ = map (dtyp_of_typ (map (rpair (map fst vs) o fst) cs))
  32.530 +      o fst o strip_type;
  32.531 +    val new_type_names = map Long_Name.base_name (the_default (map fst cs) alt_names);
  32.532 +
  32.533 +    fun mk_spec (i, (tyco, constr)) = (i, (tyco,
  32.534 +      map (DtTFree o fst) vs,
  32.535 +      (map o apsnd) dtyps_of_typ constr))
  32.536 +    val descr = map_index mk_spec cs;
  32.537 +    val injs = DatatypeProp.make_injs [descr] vs;
  32.538 +    val half_distincts = map snd (DatatypeProp.make_distincts [descr] vs);
  32.539 +    val ind = DatatypeProp.make_ind [descr] vs;
  32.540 +    val rules = (map o map o map) Logic.close_form [[[ind]], injs, half_distincts];
  32.541 +
  32.542 +    fun after_qed' raw_thms =
  32.543 +      let
  32.544 +        val [[[induct]], injs, half_distincts] =
  32.545 +          unflat rules (map Drule.zero_var_indexes_list raw_thms);
  32.546 +            (*FIXME somehow dubious*)
  32.547 +      in
  32.548 +        ProofContext.theory_result
  32.549 +          (prove_rep_datatype config alt_names new_type_names descr vs induct injs half_distincts)
  32.550 +        #-> after_qed
  32.551 +      end;
  32.552 +  in
  32.553 +    thy
  32.554 +    |> ProofContext.init
  32.555 +    |> Proof.theorem_i NONE after_qed' ((map o map) (rpair []) (flat rules))
  32.556 +  end;
  32.557 +
  32.558 +val rep_datatype = gen_rep_datatype Sign.cert_term;
  32.559 +val rep_datatype_cmd = gen_rep_datatype Syntax.read_term_global default_datatype_config (K I);
  32.560 +
  32.561 +
  32.562 +
  32.563 +(******************************** add datatype ********************************)
  32.564 +
  32.565 +fun gen_add_datatype prep_typ (config : datatype_config) new_type_names dts thy =
  32.566 +  let
  32.567 +    val _ = Theory.requires thy "Datatype" "datatype definitions";
  32.568 +
  32.569 +    (* this theory is used just for parsing *)
  32.570 +
  32.571 +    val tmp_thy = thy |>
  32.572 +      Theory.copy |>
  32.573 +      Sign.add_types (map (fn (tvs, tname, mx, _) =>
  32.574 +        (tname, length tvs, mx)) dts);
  32.575 +
  32.576 +    val (tyvars, _, _, _)::_ = dts;
  32.577 +    val (new_dts, types_syntax) = ListPair.unzip (map (fn (tvs, tname, mx, _) =>
  32.578 +      let val full_tname = Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname)
  32.579 +      in (case duplicates (op =) tvs of
  32.580 +            [] => if eq_set (tyvars, tvs) then ((full_tname, tvs), (tname, mx))
  32.581 +                  else error ("Mutually recursive datatypes must have same type parameters")
  32.582 +          | dups => error ("Duplicate parameter(s) for datatype " ^ quote (Binding.str_of tname) ^
  32.583 +              " : " ^ commas dups))
  32.584 +      end) dts);
  32.585 +
  32.586 +    val _ = (case duplicates (op =) (map fst new_dts) @ duplicates (op =) new_type_names of
  32.587 +      [] => () | dups => error ("Duplicate datatypes: " ^ commas dups));
  32.588 +
  32.589 +    fun prep_dt_spec ((tvs, tname, mx, constrs), tname') (dts', constr_syntax, sorts, i) =
  32.590 +      let
  32.591 +        fun prep_constr (cname, cargs, mx') (constrs, constr_syntax', sorts') =
  32.592 +          let
  32.593 +            val (cargs', sorts'') = Library.foldl (prep_typ tmp_thy) (([], sorts'), cargs);
  32.594 +            val _ = (case fold (curry OldTerm.add_typ_tfree_names) cargs' [] \\ tvs of
  32.595 +                [] => ()
  32.596 +              | vs => error ("Extra type variables on rhs: " ^ commas vs))
  32.597 +          in (constrs @ [((if #flat_names config then Sign.full_name tmp_thy else
  32.598 +                Sign.full_name_path tmp_thy tname')
  32.599 +                  (Binding.map_name (Syntax.const_name mx') cname),
  32.600 +                   map (dtyp_of_typ new_dts) cargs')],
  32.601 +              constr_syntax' @ [(cname, mx')], sorts'')
  32.602 +          end handle ERROR msg => cat_error msg
  32.603 +           ("The error above occured in constructor " ^ quote (Binding.str_of cname) ^
  32.604 +            " of datatype " ^ quote (Binding.str_of tname));
  32.605 +
  32.606 +        val (constrs', constr_syntax', sorts') =
  32.607 +          fold prep_constr constrs ([], [], sorts)
  32.608 +
  32.609 +      in
  32.610 +        case duplicates (op =) (map fst constrs') of
  32.611 +           [] =>
  32.612 +             (dts' @ [(i, (Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname),
  32.613 +                map DtTFree tvs, constrs'))],
  32.614 +              constr_syntax @ [constr_syntax'], sorts', i + 1)
  32.615 +         | dups => error ("Duplicate constructors " ^ commas dups ^
  32.616 +             " in datatype " ^ quote (Binding.str_of tname))
  32.617 +      end;
  32.618 +
  32.619 +    val (dts', constr_syntax, sorts', i) =
  32.620 +      fold prep_dt_spec (dts ~~ new_type_names) ([], [], [], 0);
  32.621 +    val sorts = sorts' @ (map (rpair (Sign.defaultS tmp_thy)) (tyvars \\ map fst sorts'));
  32.622 +    val dt_info = get_datatypes thy;
  32.623 +    val (descr, _) = unfold_datatypes tmp_thy dts' sorts dt_info dts' i;
  32.624 +    val _ = check_nonempty descr handle (exn as Datatype_Empty s) =>
  32.625 +      if #strict config then error ("Nonemptiness check failed for datatype " ^ s)
  32.626 +      else raise exn;
  32.627 +
  32.628 +    val descr' = flat descr;
  32.629 +    val case_names_induct = mk_case_names_induct descr';
  32.630 +    val case_names_exhausts = mk_case_names_exhausts descr' (map #1 new_dts);
  32.631 +  in
  32.632 +    add_datatype_def
  32.633 +      (config : datatype_config) new_type_names descr sorts types_syntax constr_syntax dt_info
  32.634 +      case_names_induct case_names_exhausts thy
  32.635 +  end;
  32.636 +
  32.637 +val add_datatype = gen_add_datatype cert_typ;
  32.638 +val add_datatype_cmd = gen_add_datatype read_typ default_datatype_config;
  32.639 +
  32.640 +
  32.641 +
  32.642 +(** package setup **)
  32.643 +
  32.644 +(* setup theory *)
  32.645 +
  32.646 +val setup =
  32.647 +  DatatypeRepProofs.distinctness_limit_setup #>
  32.648 +  simproc_setup #>
  32.649 +  trfun_setup #>
  32.650 +  DatatypeInterpretation.init;
  32.651 +
  32.652 +
  32.653 +(* outer syntax *)
  32.654 +
  32.655 +local structure P = OuterParse and K = OuterKeyword in
  32.656 +
  32.657 +val datatype_decl =
  32.658 +  Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.type_args -- P.binding -- P.opt_infix --
  32.659 +    (P.$$$ "=" |-- P.enum1 "|" (P.binding -- Scan.repeat P.typ -- P.opt_mixfix));
  32.660 +
  32.661 +fun mk_datatype args =
  32.662 +  let
  32.663 +    val names = map
  32.664 +      (fn ((((NONE, _), t), _), _) => Binding.name_of t | ((((SOME t, _), _), _), _) => t) args;
  32.665 +    val specs = map (fn ((((_, vs), t), mx), cons) =>
  32.666 +      (vs, t, mx, map (fn ((x, y), z) => (x, y, z)) cons)) args;
  32.667 +  in snd o add_datatype_cmd names specs end;
  32.668 +
  32.669 +val _ =
  32.670 +  OuterSyntax.command "datatype" "define inductive datatypes" K.thy_decl
  32.671 +    (P.and_list1 datatype_decl >> (Toplevel.theory o mk_datatype));
  32.672 +
  32.673 +val _ =
  32.674 +  OuterSyntax.command "rep_datatype" "represent existing types inductively" K.thy_goal
  32.675 +    (Scan.option (P.$$$ "(" |-- Scan.repeat1 P.name --| P.$$$ ")") -- Scan.repeat1 P.term
  32.676 +      >> (fn (alt_names, ts) => Toplevel.print
  32.677 +           o Toplevel.theory_to_proof (rep_datatype_cmd alt_names ts)));
  32.678 +
  32.679 +end;
  32.680 +
  32.681 +
  32.682 +(* document antiquotation *)
  32.683 +
  32.684 +val _ = ThyOutput.antiquotation "datatype" Args.tyname
  32.685 +  (fn {source = src, context = ctxt, ...} => fn dtco =>
  32.686 +    let
  32.687 +      val thy = ProofContext.theory_of ctxt;
  32.688 +      val (vs, cos) = the_datatype_spec thy dtco;
  32.689 +      val ty = Type (dtco, map TFree vs);
  32.690 +      fun pretty_typ_bracket (ty as Type (_, _ :: _)) =
  32.691 +            Pretty.enclose "(" ")" [Syntax.pretty_typ ctxt ty]
  32.692 +        | pretty_typ_bracket ty =
  32.693 +            Syntax.pretty_typ ctxt ty;
  32.694 +      fun pretty_constr (co, tys) =
  32.695 +        (Pretty.block o Pretty.breaks)
  32.696 +          (Syntax.pretty_term ctxt (Const (co, tys ---> ty)) ::
  32.697 +            map pretty_typ_bracket tys);
  32.698 +      val pretty_datatype =
  32.699 +        Pretty.block
  32.700 +          (Pretty.command "datatype" :: Pretty.brk 1 ::
  32.701 +           Syntax.pretty_typ ctxt ty ::
  32.702 +           Pretty.str " =" :: Pretty.brk 1 ::
  32.703 +           flat (separate [Pretty.brk 1, Pretty.str "| "]
  32.704 +             (map (single o pretty_constr) cos)));
  32.705 +    in ThyOutput.output (ThyOutput.maybe_pretty_source (K pretty_datatype) src [()]) end);
  32.706 +
  32.707 +end;
  32.708 +
    33.1 --- a/src/HOL/Tools/datatype_package/datatype_abs_proofs.ML	Fri Jun 19 20:22:46 2009 +0200
    33.2 +++ b/src/HOL/Tools/datatype_package/datatype_abs_proofs.ML	Fri Jun 19 21:08:07 2009 +0200
    33.3 @@ -155,7 +155,7 @@
    33.4          (([], 0), descr' ~~ recTs ~~ rec_sets');
    33.5  
    33.6      val ({intrs = rec_intrs, elims = rec_elims, ...}, thy1) =
    33.7 -        InductivePackage.add_inductive_global (serial_string ())
    33.8 +        Inductive.add_inductive_global (serial_string ())
    33.9            {quiet_mode = #quiet config, verbose = false, kind = Thm.internalK,
   33.10              alt_name = Binding.name big_rec_name', coind = false, no_elim = false, no_ind = true,
   33.11              skip_mono = true, fork_mono = false}
    34.1 --- a/src/HOL/Tools/datatype_package/datatype_codegen.ML	Fri Jun 19 20:22:46 2009 +0200
    34.2 +++ b/src/HOL/Tools/datatype_package/datatype_codegen.ML	Fri Jun 19 21:08:07 2009 +0200
    34.3 @@ -276,12 +276,12 @@
    34.4  
    34.5  fun datatype_codegen thy defs dep module brack t gr = (case strip_comb t of
    34.6     (c as Const (s, T), ts) =>
    34.7 -     (case DatatypePackage.datatype_of_case thy s of
    34.8 +     (case Datatype.datatype_of_case thy s of
    34.9          SOME {index, descr, ...} =>
   34.10            if is_some (get_assoc_code thy (s, T)) then NONE else
   34.11            SOME (pretty_case thy defs dep module brack
   34.12              (#3 (the (AList.lookup op = descr index))) c ts gr )
   34.13 -      | NONE => case (DatatypePackage.datatype_of_constr thy s, strip_type T) of
   34.14 +      | NONE => case (Datatype.datatype_of_constr thy s, strip_type T) of
   34.15          (SOME {index, descr, ...}, (_, U as Type (tyname, _))) =>
   34.16            if is_some (get_assoc_code thy (s, T)) then NONE else
   34.17            let
   34.18 @@ -296,7 +296,7 @@
   34.19   | _ => NONE);
   34.20  
   34.21  fun datatype_tycodegen thy defs dep module brack (Type (s, Ts)) gr =
   34.22 -      (case DatatypePackage.get_datatype thy s of
   34.23 +      (case Datatype.get_datatype thy s of
   34.24           NONE => NONE
   34.25         | SOME {descr, sorts, ...} =>
   34.26             if is_some (get_assoc_type thy s) then NONE else
   34.27 @@ -331,7 +331,7 @@
   34.28  fun mk_case_cert thy tyco =
   34.29    let
   34.30      val raw_thms =
   34.31 -      (#case_rewrites o DatatypePackage.the_datatype thy) tyco;
   34.32 +      (#case_rewrites o Datatype.the_datatype thy) tyco;
   34.33      val thms as hd_thm :: _ = raw_thms
   34.34        |> Conjunction.intr_balanced
   34.35        |> Thm.unvarify
   34.36 @@ -364,8 +364,8 @@
   34.37  
   34.38  fun mk_eq_eqns thy dtco =
   34.39    let
   34.40 -    val (vs, cos) = DatatypePackage.the_datatype_spec thy dtco;
   34.41 -    val { descr, index, inject = inject_thms, ... } = DatatypePackage.the_datatype thy dtco;
   34.42 +    val (vs, cos) = Datatype.the_datatype_spec thy dtco;
   34.43 +    val { descr, index, inject = inject_thms, ... } = Datatype.the_datatype thy dtco;
   34.44      val ty = Type (dtco, map TFree vs);
   34.45      fun mk_eq (t1, t2) = Const (@{const_name eq_class.eq}, ty --> ty --> HOLogic.boolT)
   34.46        $ t1 $ t2;
   34.47 @@ -383,7 +383,7 @@
   34.48      val refl = HOLogic.mk_Trueprop (true_eq (Free ("x", ty), Free ("x", ty)));
   34.49      val simpset = Simplifier.context (ProofContext.init thy) (HOL_basic_ss
   34.50        addsimps (map Simpdata.mk_eq (@{thm eq} :: @{thm eq_True} :: inject_thms))
   34.51 -      addsimprocs [DatatypePackage.distinct_simproc]);
   34.52 +      addsimprocs [Datatype.distinct_simproc]);
   34.53      fun prove prop = SkipProof.prove_global thy [] [] prop (K (ALLGOALS (simp_tac simpset)))
   34.54        |> Simpdata.mk_eq;
   34.55    in map (rpair true o prove) (triv_injects @ injects @ distincts) @ [(prove refl, false)] end;
   34.56 @@ -428,11 +428,11 @@
   34.57  
   34.58  fun add_all_code config dtcos thy =
   34.59    let
   34.60 -    val (vs :: _, coss) = (split_list o map (DatatypePackage.the_datatype_spec thy)) dtcos;
   34.61 +    val (vs :: _, coss) = (split_list o map (Datatype.the_datatype_spec thy)) dtcos;
   34.62      val any_css = map2 (mk_constr_consts thy vs) dtcos coss;
   34.63      val css = if exists is_none any_css then []
   34.64        else map_filter I any_css;
   34.65 -    val case_rewrites = maps (#case_rewrites o DatatypePackage.the_datatype thy) dtcos;
   34.66 +    val case_rewrites = maps (#case_rewrites o Datatype.the_datatype thy) dtcos;
   34.67      val certs = map (mk_case_cert thy) dtcos;
   34.68    in
   34.69      if null css then thy
   34.70 @@ -450,6 +450,6 @@
   34.71  val setup = 
   34.72    add_codegen "datatype" datatype_codegen
   34.73    #> add_tycodegen "datatype" datatype_tycodegen
   34.74 -  #> DatatypePackage.interpretation add_all_code
   34.75 +  #> Datatype.interpretation add_all_code
   34.76  
   34.77  end;
    35.1 --- a/src/HOL/Tools/datatype_package/datatype_package.ML	Fri Jun 19 20:22:46 2009 +0200
    35.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    35.3 @@ -1,705 +0,0 @@
    35.4 -(*  Title:      HOL/Tools/datatype_package.ML
    35.5 -    Author:     Stefan Berghofer, TU Muenchen
    35.6 -
    35.7 -Datatype package for Isabelle/HOL.
    35.8 -*)
    35.9 -
   35.10 -signature DATATYPE_PACKAGE =
   35.11 -sig
   35.12 -  type datatype_config = DatatypeAux.datatype_config
   35.13 -  type datatype_info = DatatypeAux.datatype_info
   35.14 -  type descr = DatatypeAux.descr
   35.15 -  val get_datatypes : theory -> datatype_info Symtab.table
   35.16 -  val get_datatype : theory -> string -> datatype_info option
   35.17 -  val the_datatype : theory -> string -> datatype_info
   35.18 -  val datatype_of_constr : theory -> string -> datatype_info option
   35.19 -  val datatype_of_case : theory -> string -> datatype_info option
   35.20 -  val the_datatype_spec : theory -> string -> (string * sort) list * (string * typ list) list
   35.21 -  val the_datatype_descr : theory -> string list
   35.22 -    -> descr * (string * sort) list * string list
   35.23 -      * (string list * string list) * (typ list * typ list)
   35.24 -  val get_datatype_constrs : theory -> string -> (string * typ) list option
   35.25 -  val distinct_simproc : simproc
   35.26 -  val make_case :  Proof.context -> bool -> string list -> term ->
   35.27 -    (term * term) list -> term * (term * (int * bool)) list
   35.28 -  val strip_case : Proof.context -> bool -> term -> (term * (term * term) list) option
   35.29 -  val read_typ: theory ->
   35.30 -    (typ list * (string * sort) list) * string -> typ list * (string * sort) list
   35.31 -  val interpretation : (datatype_config -> string list -> theory -> theory) -> theory -> theory
   35.32 -  type rules = {distinct : thm list list,
   35.33 -    inject : thm list list,
   35.34 -    exhaustion : thm list,
   35.35 -    rec_thms : thm list,
   35.36 -    case_thms : thm list list,
   35.37 -    split_thms : (thm * thm) list,
   35.38 -    induction : thm,
   35.39 -    simps : thm list}
   35.40 -  val rep_datatype : datatype_config -> (rules -> Proof.context -> Proof.context)
   35.41 -    -> string list option -> term list -> theory -> Proof.state;
   35.42 -  val rep_datatype_cmd : string list option -> string list -> theory -> Proof.state
   35.43 -  val add_datatype : datatype_config -> string list -> (string list * binding * mixfix *
   35.44 -    (binding * typ list * mixfix) list) list -> theory -> rules * theory
   35.45 -  val add_datatype_cmd : string list -> (string list * binding * mixfix *
   35.46 -    (binding * string list * mixfix) list) list -> theory -> rules * theory
   35.47 -  val setup: theory -> theory
   35.48 -  val print_datatypes : theory -> unit
   35.49 -end;
   35.50 -
   35.51 -structure DatatypePackage : DATATYPE_PACKAGE =
   35.52 -struct
   35.53 -
   35.54 -open DatatypeAux;
   35.55 -
   35.56 -
   35.57 -(* theory data *)
   35.58 -
   35.59 -structure DatatypesData = TheoryDataFun
   35.60 -(
   35.61 -  type T =
   35.62 -    {types: datatype_info Symtab.table,
   35.63 -     constrs: datatype_info Symtab.table,
   35.64 -     cases: datatype_info Symtab.table};
   35.65 -
   35.66 -  val empty =
   35.67 -    {types = Symtab.empty, constrs = Symtab.empty, cases = Symtab.empty};
   35.68 -  val copy = I;
   35.69 -  val extend = I;
   35.70 -  fun merge _
   35.71 -    ({types = types1, constrs = constrs1, cases = cases1},
   35.72 -     {types = types2, constrs = constrs2, cases = cases2}) =
   35.73 -    {types = Symtab.merge (K true) (types1, types2),
   35.74 -     constrs = Symtab.merge (K true) (constrs1, constrs2),
   35.75 -     cases = Symtab.merge (K true) (cases1, cases2)};
   35.76 -);
   35.77 -
   35.78 -val get_datatypes = #types o DatatypesData.get;
   35.79 -val map_datatypes = DatatypesData.map;
   35.80 -
   35.81 -fun print_datatypes thy =
   35.82 -  Pretty.writeln (Pretty.strs ("datatypes:" ::
   35.83 -    map #1 (NameSpace.extern_table (Sign.type_space thy, get_datatypes thy))));
   35.84 -
   35.85 -
   35.86 -(** theory information about datatypes **)
   35.87 -
   35.88 -fun put_dt_infos (dt_infos : (string * datatype_info) list) =
   35.89 -  map_datatypes (fn {types, constrs, cases} =>
   35.90 -    {types = fold Symtab.update dt_infos types,
   35.91 -     constrs = fold Symtab.default (*conservative wrt. overloaded constructors*)
   35.92 -       (maps (fn (_, info as {descr, index, ...}) => map (rpair info o fst)
   35.93 -          (#3 (the (AList.lookup op = descr index)))) dt_infos) constrs,
   35.94 -     cases = fold Symtab.update
   35.95 -       (map (fn (_, info as {case_name, ...}) => (case_name, info)) dt_infos)
   35.96 -       cases});
   35.97 -
   35.98 -val get_datatype = Symtab.lookup o get_datatypes;
   35.99 -
  35.100 -fun the_datatype thy name = (case get_datatype thy name of
  35.101 -      SOME info => info
  35.102 -    | NONE => error ("Unknown datatype " ^ quote name));
  35.103 -
  35.104 -val datatype_of_constr = Symtab.lookup o #constrs o DatatypesData.get;
  35.105 -val datatype_of_case = Symtab.lookup o #cases o DatatypesData.get;
  35.106 -
  35.107 -fun get_datatype_descr thy dtco =
  35.108 -  get_datatype thy dtco
  35.109 -  |> Option.map (fn info as { descr, index, ... } =>
  35.110 -       (info, (((fn SOME (_, dtys, cos) => (dtys, cos)) o AList.lookup (op =) descr) index)));
  35.111 -
  35.112 -fun the_datatype_spec thy dtco =
  35.113 -  let
  35.114 -    val info as { descr, index, sorts = raw_sorts, ... } = the_datatype thy dtco;
  35.115 -    val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr index;
  35.116 -    val sorts = map ((fn v => (v, (the o AList.lookup (op =) raw_sorts) v))
  35.117 -      o DatatypeAux.dest_DtTFree) dtys;
  35.118 -    val cos = map
  35.119 -      (fn (co, tys) => (co, map (DatatypeAux.typ_of_dtyp descr sorts) tys)) raw_cos;
  35.120 -  in (sorts, cos) end;
  35.121 -
  35.122 -fun the_datatype_descr thy (raw_tycos as raw_tyco :: _) =
  35.123 -  let
  35.124 -    val info = the_datatype thy raw_tyco;
  35.125 -    val descr = #descr info;
  35.126 -
  35.127 -    val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr (#index info);
  35.128 -    val vs = map ((fn v => (v, (the o AList.lookup (op =) (#sorts info)) v))
  35.129 -      o dest_DtTFree) dtys;
  35.130 -
  35.131 -    fun is_DtTFree (DtTFree _) = true
  35.132 -      | is_DtTFree _ = false
  35.133 -    val k = find_index (fn (_, (_, dTs, _)) => not (forall is_DtTFree dTs)) descr;
  35.134 -    val protoTs as (dataTs, _) = chop k descr
  35.135 -      |> (pairself o map) (fn (_, (tyco, dTs, _)) => (tyco, map (typ_of_dtyp descr vs) dTs));
  35.136 -    
  35.137 -    val tycos = map fst dataTs;
  35.138 -    val _ = if gen_eq_set (op =) (tycos, raw_tycos) then ()
  35.139 -      else error ("Type constructors " ^ commas (map quote raw_tycos)
  35.140 -        ^ "do not belong exhaustively to one mutual recursive datatype");
  35.141 -
  35.142 -    val (Ts, Us) = (pairself o map) Type protoTs;
  35.143 -
  35.144 -    val names = map Long_Name.base_name (the_default tycos (#alt_names info));
  35.145 -    val (auxnames, _) = Name.make_context names
  35.146 -      |> fold_map (yield_singleton Name.variants o name_of_typ) Us
  35.147 -
  35.148 -  in (descr, vs, tycos, (names, auxnames), (Ts, Us)) end;
  35.149 -
  35.150 -fun get_datatype_constrs thy dtco =
  35.151 -  case try (the_datatype_spec thy) dtco
  35.152 -   of SOME (sorts, cos) =>
  35.153 -        let
  35.154 -          fun subst (v, sort) = TVar ((v, 0), sort);
  35.155 -          fun subst_ty (TFree v) = subst v
  35.156 -            | subst_ty ty = ty;
  35.157 -          val dty = Type (dtco, map subst sorts);
  35.158 -          fun mk_co (co, tys) = (co, map (Term.map_atyps subst_ty) tys ---> dty);
  35.159 -        in SOME (map mk_co cos) end
  35.160 -    | NONE => NONE;
  35.161 -
  35.162 -
  35.163 -(** induct method setup **)
  35.164 -
  35.165 -(* case names *)
  35.166 -
  35.167 -local
  35.168 -
  35.169 -fun dt_recs (DtTFree _) = []
  35.170 -  | dt_recs (DtType (_, dts)) = maps dt_recs dts
  35.171 -  | dt_recs (DtRec i) = [i];
  35.172 -
  35.173 -fun dt_cases (descr: descr) (_, args, constrs) =
  35.174 -  let
  35.175 -    fun the_bname i = Long_Name.base_name (#1 (the (AList.lookup (op =) descr i)));
  35.176 -    val bnames = map the_bname (distinct (op =) (maps dt_recs args));
  35.177 -  in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
  35.178 -
  35.179 -
  35.180 -fun induct_cases descr =
  35.181 -  DatatypeProp.indexify_names (maps (dt_cases descr) (map #2 descr));
  35.182 -
  35.183 -fun exhaust_cases descr i = dt_cases descr (the (AList.lookup (op =) descr i));
  35.184 -
  35.185 -in
  35.186 -
  35.187 -fun mk_case_names_induct descr = RuleCases.case_names (induct_cases descr);
  35.188 -
  35.189 -fun mk_case_names_exhausts descr new =
  35.190 -  map (RuleCases.case_names o exhaust_cases descr o #1)
  35.191 -    (filter (fn ((_, (name, _, _))) => member (op =) new name) descr);
  35.192 -
  35.193 -end;
  35.194 -
  35.195 -fun add_rules simps case_thms rec_thms inject distinct
  35.196 -                  weak_case_congs cong_att =
  35.197 -  PureThy.add_thmss [((Binding.name "simps", simps), []),
  35.198 -    ((Binding.empty, flat case_thms @
  35.199 -          flat distinct @ rec_thms), [Simplifier.simp_add]),
  35.200 -    ((Binding.empty, rec_thms), [Code.add_default_eqn_attribute]),
  35.201 -    ((Binding.empty, flat inject), [iff_add]),
  35.202 -    ((Binding.empty, map (fn th => th RS notE) (flat distinct)), [Classical.safe_elim NONE]),
  35.203 -    ((Binding.empty, weak_case_congs), [cong_att])]
  35.204 -  #> snd;
  35.205 -
  35.206 -
  35.207 -(* add_cases_induct *)
  35.208 -
  35.209 -fun add_cases_induct infos induction thy =
  35.210 -  let
  35.211 -    val inducts = ProjectRule.projections (ProofContext.init thy) induction;
  35.212 -
  35.213 -    fun named_rules (name, {index, exhaustion, ...}: datatype_info) =
  35.214 -      [((Binding.empty, nth inducts index), [Induct.induct_type name]),
  35.215 -       ((Binding.empty, exhaustion), [Induct.cases_type name])];
  35.216 -    fun unnamed_rule i =
  35.217 -      ((Binding.empty, nth inducts i), [Thm.kind_internal, Induct.induct_type ""]);
  35.218 -  in
  35.219 -    thy |> PureThy.add_thms
  35.220 -      (maps named_rules infos @
  35.221 -        map unnamed_rule (length infos upto length inducts - 1)) |> snd
  35.222 -    |> PureThy.add_thmss [((Binding.name "inducts", inducts), [])] |> snd
  35.223 -  end;
  35.224 -
  35.225 -
  35.226 -
  35.227 -(**** simplification procedure for showing distinctness of constructors ****)
  35.228 -
  35.229 -fun stripT (i, Type ("fun", [_, T])) = stripT (i + 1, T)
  35.230 -  | stripT p = p;
  35.231 -
  35.232 -fun stripC (i, f $ x) = stripC (i + 1, f)
  35.233 -  | stripC p = p;
  35.234 -
  35.235 -val distinctN = "constr_distinct";
  35.236 -
  35.237 -fun distinct_rule thy ss tname eq_t = case #distinct (the_datatype thy tname) of
  35.238 -    FewConstrs thms => Goal.prove (Simplifier.the_context ss) [] [] eq_t (K
  35.239 -      (EVERY [rtac eq_reflection 1, rtac iffI 1, rtac notE 1,
  35.240 -        atac 2, resolve_tac thms 1, etac FalseE 1]))
  35.241 -  | ManyConstrs (thm, simpset) =>
  35.242 -      let
  35.243 -        val [In0_inject, In1_inject, In0_not_In1, In1_not_In0] =
  35.244 -          map (PureThy.get_thm (ThyInfo.the_theory "Datatype" thy))
  35.245 -            ["In0_inject", "In1_inject", "In0_not_In1", "In1_not_In0"];
  35.246 -      in
  35.247 -        Goal.prove (Simplifier.the_context ss) [] [] eq_t (K
  35.248 -        (EVERY [rtac eq_reflection 1, rtac iffI 1, dtac thm 1,
  35.249 -          full_simp_tac (Simplifier.inherit_context ss simpset) 1,
  35.250 -          REPEAT (dresolve_tac [In0_inject, In1_inject] 1),
  35.251 -          eresolve_tac [In0_not_In1 RS notE, In1_not_In0 RS notE] 1,
  35.252 -          etac FalseE 1]))
  35.253 -      end;
  35.254 -
  35.255 -fun distinct_proc thy ss (t as Const ("op =", _) $ t1 $ t2) =
  35.256 -  (case (stripC (0, t1), stripC (0, t2)) of
  35.257 -     ((i, Const (cname1, T1)), (j, Const (cname2, T2))) =>
  35.258 -         (case (stripT (0, T1), stripT (0, T2)) of
  35.259 -            ((i', Type (tname1, _)), (j', Type (tname2, _))) =>
  35.260 -                if tname1 = tname2 andalso not (cname1 = cname2) andalso i = i' andalso j = j' then
  35.261 -                   (case (get_datatype_descr thy) tname1 of
  35.262 -                      SOME (_, (_, constrs)) => let val cnames = map fst constrs
  35.263 -                        in if cname1 mem cnames andalso cname2 mem cnames then
  35.264 -                             SOME (distinct_rule thy ss tname1
  35.265 -                               (Logic.mk_equals (t, Const ("False", HOLogic.boolT))))
  35.266 -                           else NONE
  35.267 -                        end
  35.268 -                    | NONE => NONE)
  35.269 -                else NONE
  35.270 -          | _ => NONE)
  35.271 -   | _ => NONE)
  35.272 -  | distinct_proc _ _ _ = NONE;
  35.273 -
  35.274 -val distinct_simproc =
  35.275 -  Simplifier.simproc @{theory HOL} distinctN ["s = t"] distinct_proc;
  35.276 -
  35.277 -val dist_ss = HOL_ss addsimprocs [distinct_simproc];
  35.278 -
  35.279 -val simproc_setup =
  35.280 -  Simplifier.map_simpset (fn ss => ss addsimprocs [distinct_simproc]);
  35.281 -
  35.282 -
  35.283 -(**** translation rules for case ****)
  35.284 -
  35.285 -fun make_case ctxt = DatatypeCase.make_case
  35.286 -  (datatype_of_constr (ProofContext.theory_of ctxt)) ctxt;
  35.287 -
  35.288 -fun strip_case ctxt = DatatypeCase.strip_case
  35.289 -  (datatype_of_case (ProofContext.theory_of ctxt));
  35.290 -
  35.291 -fun add_case_tr' case_names thy =
  35.292 -  Sign.add_advanced_trfuns ([], [],
  35.293 -    map (fn case_name =>
  35.294 -      let val case_name' = Sign.const_syntax_name thy case_name
  35.295 -      in (case_name', DatatypeCase.case_tr' datatype_of_case case_name')
  35.296 -      end) case_names, []) thy;
  35.297 -
  35.298 -val trfun_setup =
  35.299 -  Sign.add_advanced_trfuns ([],
  35.300 -    [("_case_syntax", DatatypeCase.case_tr true datatype_of_constr)],
  35.301 -    [], []);
  35.302 -
  35.303 -
  35.304 -(* prepare types *)
  35.305 -
  35.306 -fun read_typ thy ((Ts, sorts), str) =
  35.307 -  let
  35.308 -    val ctxt = ProofContext.init thy
  35.309 -      |> fold (Variable.declare_typ o TFree) sorts;
  35.310 -    val T = Syntax.read_typ ctxt str;
  35.311 -  in (Ts @ [T], Term.add_tfreesT T sorts) end;
  35.312 -
  35.313 -fun cert_typ sign ((Ts, sorts), raw_T) =
  35.314 -  let
  35.315 -    val T = Type.no_tvars (Sign.certify_typ sign raw_T) handle
  35.316 -      TYPE (msg, _, _) => error msg;
  35.317 -    val sorts' = Term.add_tfreesT T sorts;
  35.318 -  in (Ts @ [T],
  35.319 -      case duplicates (op =) (map fst sorts') of
  35.320 -         [] => sorts'
  35.321 -       | dups => error ("Inconsistent sort constraints for " ^ commas dups))
  35.322 -  end;
  35.323 -
  35.324 -
  35.325 -(**** make datatype info ****)
  35.326 -
  35.327 -fun make_dt_info alt_names descr sorts induct reccomb_names rec_thms
  35.328 -    (((((((((i, (_, (tname, _, _))), case_name), case_thms),
  35.329 -      exhaustion_thm), distinct_thm), inject), nchotomy), case_cong), weak_case_cong) =
  35.330 -  (tname,
  35.331 -   {index = i,
  35.332 -    alt_names = alt_names,
  35.333 -    descr = descr,
  35.334 -    sorts = sorts,
  35.335 -    rec_names = reccomb_names,
  35.336 -    rec_rewrites = rec_thms,
  35.337 -    case_name = case_name,
  35.338 -    case_rewrites = case_thms,
  35.339 -    induction = induct,
  35.340 -    exhaustion = exhaustion_thm,
  35.341 -    distinct = distinct_thm,
  35.342 -    inject = inject,
  35.343 -    nchotomy = nchotomy,
  35.344 -    case_cong = case_cong,
  35.345 -    weak_case_cong = weak_case_cong});
  35.346 -
  35.347 -type rules = {distinct : thm list list,
  35.348 -  inject : thm list list,
  35.349 -  exhaustion : thm list,
  35.350 -  rec_thms : thm list,
  35.351 -  case_thms : thm list list,
  35.352 -  split_thms : (thm * thm) list,
  35.353 -  induction : thm,
  35.354 -  simps : thm list}
  35.355 -
  35.356 -structure DatatypeInterpretation = InterpretationFun
  35.357 -  (type T = datatype_config * string list val eq: T * T -> bool = eq_snd op =);
  35.358 -fun interpretation f = DatatypeInterpretation.interpretation (uncurry f);
  35.359 -
  35.360 -
  35.361 -(******************* definitional introduction of datatypes *******************)
  35.362 -
  35.363 -fun add_datatype_def (config : datatype_config) new_type_names descr sorts types_syntax constr_syntax dt_info
  35.364 -    case_names_induct case_names_exhausts thy =
  35.365 -  let
  35.366 -    val _ = message config ("Proofs for datatype(s) " ^ commas_quote new_type_names);
  35.367 -
  35.368 -    val ((inject, distinct, dist_rewrites, simproc_dists, induct), thy2) = thy |>
  35.369 -      DatatypeRepProofs.representation_proofs config dt_info new_type_names descr sorts
  35.370 -        types_syntax constr_syntax case_names_induct;
  35.371 -
  35.372 -    val (casedist_thms, thy3) = DatatypeAbsProofs.prove_casedist_thms config new_type_names descr
  35.373 -      sorts induct case_names_exhausts thy2;
  35.374 -    val ((reccomb_names, rec_thms), thy4) = DatatypeAbsProofs.prove_primrec_thms
  35.375 -      config new_type_names descr sorts dt_info inject dist_rewrites
  35.376 -      (Simplifier.theory_context thy3 dist_ss) induct thy3;
  35.377 -    val ((case_thms, case_names), thy6) = DatatypeAbsProofs.prove_case_thms
  35.378 -      config new_type_names descr sorts reccomb_names rec_thms thy4;
  35.379 -    val (split_thms, thy7) = DatatypeAbsProofs.prove_split_thms config new_type_names
  35.380 -      descr sorts inject dist_rewrites casedist_thms case_thms thy6;
  35.381 -    val (nchotomys, thy8) = DatatypeAbsProofs.prove_nchotomys config new_type_names
  35.382 -      descr sorts casedist_thms thy7;
  35.383 -    val (case_congs, thy9) = DatatypeAbsProofs.prove_case_congs new_type_names
  35.384 -      descr sorts nchotomys case_thms thy8;
  35.385 -    val (weak_case_congs, thy10) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
  35.386 -      descr sorts thy9;
  35.387 -
  35.388 -    val dt_infos = map
  35.389 -      (make_dt_info (SOME new_type_names) (flat descr) sorts induct reccomb_names rec_thms)
  35.390 -      ((0 upto length (hd descr) - 1) ~~ (hd descr) ~~ case_names ~~ case_thms ~~
  35.391 -        casedist_thms ~~ simproc_dists ~~ inject ~~ nchotomys ~~ case_congs ~~ weak_case_congs);
  35.392 -
  35.393 -    val simps = flat (distinct @ inject @ case_thms) @ rec_thms;
  35.394 -
  35.395 -    val thy12 =
  35.396 -      thy10
  35.397 -      |> add_case_tr' case_names
  35.398 -      |> Sign.add_path (space_implode "_" new_type_names)
  35.399 -      |> add_rules simps case_thms rec_thms inject distinct
  35.400 -          weak_case_congs (Simplifier.attrib (op addcongs))
  35.401 -      |> put_dt_infos dt_infos
  35.402 -      |> add_cases_induct dt_infos induct
  35.403 -      |> Sign.parent_path
  35.404 -      |> store_thmss "splits" new_type_names (map (fn (x, y) => [x, y]) split_thms) |> snd
  35.405 -      |> DatatypeInterpretation.data (config, map fst dt_infos);
  35.406 -  in
  35.407 -    ({distinct = distinct,
  35.408 -      inject = inject,
  35.409 -      exhaustion = casedist_thms,
  35.410 -      rec_thms = rec_thms,
  35.411 -      case_thms = case_thms,
  35.412 -      split_thms = split_thms,
  35.413 -      induction = induct,
  35.414 -      simps = simps}, thy12)
  35.415 -  end;
  35.416 -
  35.417 -
  35.418 -(*********************** declare existing type as datatype *********************)
  35.419 -
  35.420 -fun prove_rep_datatype (config : datatype_config) alt_names new_type_names descr sorts induct inject half_distinct thy =
  35.421 -  let
  35.422 -    val ((_, [induct']), _) =
  35.423 -      Variable.importT_thms [induct] (Variable.thm_context induct);
  35.424 -
  35.425 -    fun err t = error ("Ill-formed predicate in induction rule: " ^
  35.426 -      Syntax.string_of_term_global thy t);
  35.427 -
  35.428 -    fun get_typ (t as _ $ Var (_, Type (tname, Ts))) =
  35.429 -          ((tname, map (fst o dest_TFree) Ts) handle TERM _ => err t)
  35.430 -      | get_typ t = err t;
  35.431 -    val dtnames = map get_typ (HOLogic.dest_conj (HOLogic.dest_Trueprop (Thm.concl_of induct')));
  35.432 -
  35.433 -    val dt_info = get_datatypes thy;
  35.434 -
  35.435 -    val distinct = (map o maps) (fn thm => [thm, thm RS not_sym]) half_distinct;
  35.436 -    val (case_names_induct, case_names_exhausts) =
  35.437 -      (mk_case_names_induct descr, mk_case_names_exhausts descr (map #1 dtnames));
  35.438 -
  35.439 -    val _ = message config ("Proofs for datatype(s) " ^ commas_quote new_type_names);
  35.440 -
  35.441 -    val (casedist_thms, thy2) = thy |>
  35.442 -      DatatypeAbsProofs.prove_casedist_thms config new_type_names [descr] sorts induct
  35.443 -        case_names_exhausts;
  35.444 -    val ((reccomb_names, rec_thms), thy3) = DatatypeAbsProofs.prove_primrec_thms
  35.445 -      config new_type_names [descr] sorts dt_info inject distinct
  35.446 -      (Simplifier.theory_context thy2 dist_ss) induct thy2;
  35.447 -    val ((case_thms, case_names), thy4) = DatatypeAbsProofs.prove_case_thms
  35.448 -      config new_type_names [descr] sorts reccomb_names rec_thms thy3;
  35.449 -    val (split_thms, thy5) = DatatypeAbsProofs.prove_split_thms
  35.450 -      config new_type_names [descr] sorts inject distinct casedist_thms case_thms thy4;
  35.451 -    val (nchotomys, thy6) = DatatypeAbsProofs.prove_nchotomys config new_type_names
  35.452 -      [descr] sorts casedist_thms thy5;
  35.453 -    val (case_congs, thy7) = DatatypeAbsProofs.prove_case_congs new_type_names
  35.454 -      [descr] sorts nchotomys case_thms thy6;
  35.455 -    val (weak_case_congs, thy8) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
  35.456 -      [descr] sorts thy7;
  35.457 -
  35.458 -    val ((_, [induct']), thy10) =
  35.459 -      thy8
  35.460 -      |> store_thmss "inject" new_type_names inject
  35.461 -      ||>> store_thmss "distinct" new_type_names distinct
  35.462 -      ||> Sign.add_path (space_implode "_" new_type_names)
  35.463 -      ||>> PureThy.add_thms [((Binding.name "induct", induct), [case_names_induct])];
  35.464 -
  35.465 -    val dt_infos = map (make_dt_info alt_names descr sorts induct' reccomb_names rec_thms)
  35.466 -      ((0 upto length descr - 1) ~~ descr ~~ case_names ~~ case_thms ~~ casedist_thms ~~
  35.467 -        map FewConstrs distinct ~~ inject ~~ nchotomys ~~ case_congs ~~ weak_case_congs);
  35.468 -
  35.469 -    val simps = flat (distinct @ inject @ case_thms) @ rec_thms;
  35.470 -
  35.471 -    val thy11 =
  35.472 -      thy10
  35.473 -      |> add_case_tr' case_names
  35.474 -      |> add_rules simps case_thms rec_thms inject distinct
  35.475 -           weak_case_congs (Simplifier.attrib (op addcongs))
  35.476 -      |> put_dt_infos dt_infos
  35.477 -      |> add_cases_induct dt_infos induct'
  35.478 -      |> Sign.parent_path
  35.479 -      |> store_thmss "splits" new_type_names (map (fn (x, y) => [x, y]) split_thms)
  35.480 -      |> snd
  35.481 -      |> DatatypeInterpretation.data (config, map fst dt_infos);
  35.482 -  in
  35.483 -    ({distinct = distinct,
  35.484 -      inject = inject,
  35.485 -      exhaustion = casedist_thms,
  35.486 -      rec_thms = rec_thms,
  35.487 -      case_thms = case_thms,
  35.488 -      split_thms = split_thms,
  35.489 -      induction = induct',
  35.490 -      simps = simps}, thy11)
  35.491 -  end;
  35.492 -
  35.493 -fun gen_rep_datatype prep_term (config : datatype_config) after_qed alt_names raw_ts thy =
  35.494 -  let
  35.495 -    fun constr_of_term (Const (c, T)) = (c, T)
  35.496 -      | constr_of_term t =
  35.497 -          error ("Not a constant: " ^ Syntax.string_of_term_global thy t);
  35.498 -    fun no_constr (c, T) = error ("Bad constructor: "
  35.499 -      ^ Sign.extern_const thy c ^ "::"
  35.500 -      ^ Syntax.string_of_typ_global thy T);
  35.501 -    fun type_of_constr (cT as (_, T)) =
  35.502 -      let
  35.503 -        val frees = OldTerm.typ_tfrees T;
  35.504 -        val (tyco, vs) = ((apsnd o map) (dest_TFree) o dest_Type o snd o strip_type) T
  35.505 -          handle TYPE _ => no_constr cT
  35.506 -        val _ = if has_duplicates (eq_fst (op =)) vs then no_constr cT else ();
  35.507 -        val _ = if length frees <> length vs then no_constr cT else ();
  35.508 -      in (tyco, (vs, cT)) end;
  35.509 -
  35.510 -    val raw_cs = AList.group (op =) (map (type_of_constr o constr_of_term o prep_term thy) raw_ts);
  35.511 -    val _ = case map_filter (fn (tyco, _) =>
  35.512 -        if Symtab.defined (get_datatypes thy) tyco then SOME tyco else NONE) raw_cs
  35.513 -     of [] => ()
  35.514 -      | tycos => error ("Type(s) " ^ commas (map quote tycos)
  35.515 -          ^ " already represented inductivly");
  35.516 -    val raw_vss = maps (map (map snd o fst) o snd) raw_cs;
  35.517 -    val ms = case distinct (op =) (map length raw_vss)
  35.518 -     of [n] => 0 upto n - 1
  35.519 -      | _ => error ("Different types in given constructors");
  35.520 -    fun inter_sort m = map (fn xs => nth xs m) raw_vss
  35.521 -      |> Library.foldr1 (Sorts.inter_sort (Sign.classes_of thy))
  35.522 -    val sorts = map inter_sort ms;
  35.523 -    val vs = Name.names Name.context Name.aT sorts;
  35.524 -
  35.525 -    fun norm_constr (raw_vs, (c, T)) = (c, map_atyps
  35.526 -      (TFree o (the o AList.lookup (op =) (map fst raw_vs ~~ vs)) o fst o dest_TFree) T);
  35.527 -
  35.528 -    val cs = map (apsnd (map norm_constr)) raw_cs;
  35.529 -    val dtyps_of_typ = map (dtyp_of_typ (map (rpair (map fst vs) o fst) cs))
  35.530 -      o fst o strip_type;
  35.531 -    val new_type_names = map Long_Name.base_name (the_default (map fst cs) alt_names);
  35.532 -
  35.533 -    fun mk_spec (i, (tyco, constr)) = (i, (tyco,
  35.534 -      map (DtTFree o fst) vs,
  35.535 -      (map o apsnd) dtyps_of_typ constr))
  35.536 -    val descr = map_index mk_spec cs;
  35.537 -    val injs = DatatypeProp.make_injs [descr] vs;
  35.538 -    val half_distincts = map snd (DatatypeProp.make_distincts [descr] vs);
  35.539 -    val ind = DatatypeProp.make_ind [descr] vs;
  35.540 -    val rules = (map o map o map) Logic.close_form [[[ind]], injs, half_distincts];
  35.541 -
  35.542 -    fun after_qed' raw_thms =
  35.543 -      let
  35.544 -        val [[[induct]], injs, half_distincts] =
  35.545 -          unflat rules (map Drule.zero_var_indexes_list raw_thms);
  35.546 -            (*FIXME somehow dubious*)
  35.547 -      in
  35.548 -        ProofContext.theory_result
  35.549 -          (prove_rep_datatype config alt_names new_type_names descr vs induct injs half_distincts)
  35.550 -        #-> after_qed
  35.551 -      end;
  35.552 -  in
  35.553 -    thy
  35.554 -    |> ProofContext.init
  35.555 -    |> Proof.theorem_i NONE after_qed' ((map o map) (rpair []) (flat rules))
  35.556 -  end;
  35.557 -
  35.558 -val rep_datatype = gen_rep_datatype Sign.cert_term;
  35.559 -val rep_datatype_cmd = gen_rep_datatype Syntax.read_term_global default_datatype_config (K I);
  35.560 -
  35.561 -
  35.562 -
  35.563 -(******************************** add datatype ********************************)
  35.564 -
  35.565 -fun gen_add_datatype prep_typ (config : datatype_config) new_type_names dts thy =
  35.566 -  let
  35.567 -    val _ = Theory.requires thy "Datatype" "datatype definitions";
  35.568 -
  35.569 -    (* this theory is used just for parsing *)
  35.570 -
  35.571 -    val tmp_thy = thy |>
  35.572 -      Theory.copy |>
  35.573 -      Sign.add_types (map (fn (tvs, tname, mx, _) =>
  35.574 -        (tname, length tvs, mx)) dts);
  35.575 -
  35.576 -    val (tyvars, _, _, _)::_ = dts;
  35.577 -    val (new_dts, types_syntax) = ListPair.unzip (map (fn (tvs, tname, mx, _) =>
  35.578 -      let val full_tname = Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname)
  35.579 -      in (case duplicates (op =) tvs of
  35.580 -            [] => if eq_set (tyvars, tvs) then ((full_tname, tvs), (tname, mx))
  35.581 -                  else error ("Mutually recursive datatypes must have same type parameters")
  35.582 -          | dups => error ("Duplicate parameter(s) for datatype " ^ quote (Binding.str_of tname) ^
  35.583 -              " : " ^ commas dups))
  35.584 -      end) dts);
  35.585 -
  35.586 -    val _ = (case duplicates (op =) (map fst new_dts) @ duplicates (op =) new_type_names of
  35.587 -      [] => () | dups => error ("Duplicate datatypes: " ^ commas dups));
  35.588 -
  35.589 -    fun prep_dt_spec ((tvs, tname, mx, constrs), tname') (dts', constr_syntax, sorts, i) =
  35.590 -      let
  35.591 -        fun prep_constr (cname, cargs, mx') (constrs, constr_syntax', sorts') =
  35.592 -          let
  35.593 -            val (cargs', sorts'') = Library.foldl (prep_typ tmp_thy) (([], sorts'), cargs);
  35.594 -            val _ = (case fold (curry OldTerm.add_typ_tfree_names) cargs' [] \\ tvs of
  35.595 -                [] => ()
  35.596 -              | vs => error ("Extra type variables on rhs: " ^ commas vs))
  35.597 -          in (constrs @ [((if #flat_names config then Sign.full_name tmp_thy else
  35.598 -                Sign.full_name_path tmp_thy tname')
  35.599 -                  (Binding.map_name (Syntax.const_name mx') cname),
  35.600 -                   map (dtyp_of_typ new_dts) cargs')],
  35.601 -              constr_syntax' @ [(cname, mx')], sorts'')
  35.602 -          end handle ERROR msg => cat_error msg
  35.603 -           ("The error above occured in constructor " ^ quote (Binding.str_of cname) ^
  35.604 -            " of datatype " ^ quote (Binding.str_of tname));
  35.605 -
  35.606 -        val (constrs', constr_syntax', sorts') =
  35.607 -          fold prep_constr constrs ([], [], sorts)
  35.608 -
  35.609 -      in
  35.610 -        case duplicates (op =) (map fst constrs') of
  35.611 -           [] =>
  35.612 -             (dts' @ [(i, (Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname),
  35.613 -                map DtTFree tvs, constrs'))],
  35.614 -              constr_syntax @ [constr_syntax'], sorts', i + 1)
  35.615 -         | dups => error ("Duplicate constructors " ^ commas dups ^
  35.616 -             " in datatype " ^ quote (Binding.str_of tname))
  35.617 -      end;
  35.618 -
  35.619 -    val (dts', constr_syntax, sorts', i) =
  35.620 -      fold prep_dt_spec (dts ~~ new_type_names) ([], [], [], 0);
  35.621 -    val sorts = sorts' @ (map (rpair (Sign.defaultS tmp_thy)) (tyvars \\ map fst sorts'));
  35.622 -    val dt_info = get_datatypes thy;
  35.623 -    val (descr, _) = unfold_datatypes tmp_thy dts' sorts dt_info dts' i;
  35.624 -    val _ = check_nonempty descr handle (exn as Datatype_Empty s) =>
  35.625 -      if #strict config then error ("Nonemptiness check failed for datatype " ^ s)
  35.626 -      else raise exn;
  35.627 -
  35.628 -    val descr' = flat descr;
  35.629 -    val case_names_induct = mk_case_names_induct descr';
  35.630 -    val case_names_exhausts = mk_case_names_exhausts descr' (map #1 new_dts);
  35.631 -  in
  35.632 -    add_datatype_def
  35.633 -      (config : datatype_config) new_type_names descr sorts types_syntax constr_syntax dt_info
  35.634 -      case_names_induct case_names_exhausts thy
  35.635 -  end;
  35.636 -
  35.637 -val add_datatype = gen_add_datatype cert_typ;
  35.638 -val add_datatype_cmd = gen_add_datatype read_typ default_datatype_config;
  35.639 -
  35.640 -
  35.641 -
  35.642 -(** package setup **)
  35.643 -
  35.644 -(* setup theory *)
  35.645 -
  35.646 -val setup =
  35.647 -  DatatypeRepProofs.distinctness_limit_setup #>
  35.648 -  simproc_setup #>
  35.649 -  trfun_setup #>
  35.650 -  DatatypeInterpretation.init;
  35.651 -
  35.652 -
  35.653 -(* outer syntax *)
  35.654 -
  35.655 -local structure P = OuterParse and K = OuterKeyword in
  35.656 -
  35.657 -val datatype_decl =
  35.658 -  Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.type_args -- P.binding -- P.opt_infix --
  35.659 -    (P.$$$ "=" |-- P.enum1 "|" (P.binding -- Scan.repeat P.typ -- P.opt_mixfix));
  35.660 -
  35.661 -fun mk_datatype args =
  35.662 -  let
  35.663 -    val names = map
  35.664 -      (fn ((((NONE, _), t), _), _) => Binding.name_of t | ((((SOME t, _), _), _), _) => t) args;
  35.665 -    val specs = map (fn ((((_, vs), t), mx), cons) =>
  35.666 -      (vs, t, mx, map (fn ((x, y), z) => (x, y, z)) cons)) args;
  35.667 -  in snd o add_datatype_cmd names specs end;
  35.668 -
  35.669 -val _ =
  35.670 -  OuterSyntax.command "datatype" "define inductive datatypes" K.thy_decl
  35.671 -    (P.and_list1 datatype_decl >> (Toplevel.theory o mk_datatype));
  35.672 -
  35.673 -val _ =
  35.674 -  OuterSyntax.command "rep_datatype" "represent existing types inductively" K.thy_goal
  35.675 -    (Scan.option (P.$$$ "(" |-- Scan.repeat1 P.name --| P.$$$ ")") -- Scan.repeat1 P.term
  35.676 -      >> (fn (alt_names, ts) => Toplevel.print
  35.677 -           o Toplevel.theory_to_proof (rep_datatype_cmd alt_names ts)));
  35.678 -
  35.679 -end;
  35.680 -
  35.681 -
  35.682 -(* document antiquotation *)
  35.683 -
  35.684 -val _ = ThyOutput.antiquotation "datatype" Args.tyname
  35.685 -  (fn {source = src, context = ctxt, ...} => fn dtco =>
  35.686 -    let
  35.687 -      val thy = ProofContext.theory_of ctxt;
  35.688 -      val (vs, cos) = the_datatype_spec thy dtco;
  35.689 -      val ty = Type (dtco, map TFree vs);
  35.690 -      fun pretty_typ_bracket (ty as Type (_, _ :: _)) =
  35.691 -            Pretty.enclose "(" ")" [Syntax.pretty_typ ctxt ty]
  35.692 -        | pretty_typ_bracket ty =
  35.693 -            Syntax.pretty_typ ctxt ty;
  35.694 -      fun pretty_constr (co, tys) =
  35.695 -        (Pretty.block o Pretty.breaks)
  35.696 -          (Syntax.pretty_term ctxt (Const (co, tys ---> ty)) ::
  35.697 -            map pretty_typ_bracket tys);
  35.698 -      val pretty_datatype =
  35.699 -        Pretty.block
  35.700 -          (Pretty.command "datatype" :: Pretty.brk 1 ::
  35.701 -           Syntax.pretty_typ ctxt ty ::
  35.702 -           Pretty.str " =" :: Pretty.brk 1 ::
  35.703 -           flat (separate [Pretty.brk 1, Pretty.str "| "]
  35.704 -             (map (single o pretty_constr) cos)));
  35.705 -    in ThyOutput.output (ThyOutput.maybe_pretty_source (K pretty_datatype) src [()]) end);
  35.706 -
  35.707 -end;
  35.708 -
    36.1 --- a/src/HOL/Tools/datatype_package/datatype_realizer.ML	Fri Jun 19 20:22:46 2009 +0200
    36.2 +++ b/src/HOL/Tools/datatype_package/datatype_realizer.ML	Fri Jun 19 21:08:07 2009 +0200
    36.3 @@ -217,7 +217,7 @@
    36.4    if ! Proofterm.proofs < 2 then thy
    36.5    else let
    36.6      val _ = message config "Adding realizers for induction and case analysis ..."
    36.7 -    val infos = map (DatatypePackage.the_datatype thy) names;
    36.8 +    val infos = map (Datatype.the_datatype thy) names;
    36.9      val info :: _ = infos;
   36.10    in
   36.11      thy
   36.12 @@ -225,6 +225,6 @@
   36.13      |> fold_rev (make_casedists (#sorts info)) infos
   36.14    end;
   36.15  
   36.16 -val setup = DatatypePackage.interpretation add_dt_realizers;
   36.17 +val setup = Datatype.interpretation add_dt_realizers;
   36.18  
   36.19  end;
    37.1 --- a/src/HOL/Tools/datatype_package/datatype_rep_proofs.ML	Fri Jun 19 20:22:46 2009 +0200
    37.2 +++ b/src/HOL/Tools/datatype_package/datatype_rep_proofs.ML	Fri Jun 19 21:08:07 2009 +0200
    37.3 @@ -183,7 +183,7 @@
    37.4          ((1 upto (length constrs)) ~~ constrs)) (descr' ~~ rep_set_names');
    37.5  
    37.6      val ({raw_induct = rep_induct, intrs = rep_intrs, ...}, thy2) =
    37.7 -        InductivePackage.add_inductive_global (serial_string ())
    37.8 +        Inductive.add_inductive_global (serial_string ())
    37.9            {quiet_mode = #quiet config, verbose = false, kind = Thm.internalK,
   37.10             alt_name = Binding.name big_rec_name, coind = false, no_elim = true, no_ind = false,
   37.11             skip_mono = true, fork_mono = false}
   37.12 @@ -195,7 +195,7 @@
   37.13      val (typedefs, thy3) = thy2 |>
   37.14        parent_path (#flat_names config) |>
   37.15        fold_map (fn ((((name, mx), tvs), c), name') =>
   37.16 -          TypedefPackage.add_typedef false (SOME (Binding.name name')) (name, tvs, mx)
   37.17 +          Typedef.add_typedef false (SOME (Binding.name name')) (name, tvs, mx)
   37.18              (Collect $ Const (c, UnivT')) NONE
   37.19              (rtac exI 1 THEN rtac CollectI 1 THEN
   37.20                QUIET_BREADTH_FIRST (has_fewer_prems 1)
    38.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    38.2 +++ b/src/HOL/Tools/function_package/fundef.ML	Fri Jun 19 21:08:07 2009 +0200
    38.3 @@ -0,0 +1,226 @@
    38.4 +(*  Title:      HOL/Tools/function_package/fundef.ML
    38.5 +    Author:     Alexander Krauss, TU Muenchen
    38.6 +
    38.7 +A package for general recursive function definitions.
    38.8 +Isar commands.
    38.9 +*)
   38.10 +
   38.11 +signature FUNDEF =
   38.12 +sig
   38.13 +    val add_fundef :  (binding * typ option * mixfix) list
   38.14 +                       -> (Attrib.binding * term) list
   38.15 +                       -> FundefCommon.fundef_config
   38.16 +                       -> local_theory
   38.17 +                       -> Proof.state
   38.18 +    val add_fundef_cmd :  (binding * string option * mixfix) list
   38.19 +                      -> (Attrib.binding * string) list
   38.20 +                      -> FundefCommon.fundef_config
   38.21 +                      -> local_theory
   38.22 +                      -> Proof.state
   38.23 +
   38.24 +    val termination_proof : term option -> local_theory -> Proof.state
   38.25 +    val termination_proof_cmd : string option -> local_theory -> Proof.state
   38.26 +    val termination : term option -> local_theory -> Proof.state
   38.27 +    val termination_cmd : string option -> local_theory -> Proof.state
   38.28 +
   38.29 +    val setup : theory -> theory
   38.30 +    val get_congs : Proof.context -> thm list
   38.31 +end
   38.32 +
   38.33 +
   38.34 +structure Fundef : FUNDEF =
   38.35 +struct
   38.36 +
   38.37 +open FundefLib
   38.38 +open FundefCommon
   38.39 +
   38.40 +val simp_attribs = map (Attrib.internal o K)
   38.41 +    [Simplifier.simp_add,
   38.42 +     Code.add_default_eqn_attribute,
   38.43 +     Nitpick_Const_Simp_Thms.add,
   38.44 +     Quickcheck_RecFun_Simp_Thms.add]
   38.45 +
   38.46 +val psimp_attribs = map (Attrib.internal o K)
   38.47 +    [Simplifier.simp_add,
   38.48 +     Nitpick_Const_Psimp_Thms.add]
   38.49 +
   38.50 +fun note_theorem ((name, atts), ths) =
   38.51 +  LocalTheory.note Thm.generatedK ((Binding.qualified_name name, atts), ths)
   38.52 +
   38.53 +fun mk_defname fixes = fixes |> map (fst o fst) |> space_implode "_"
   38.54 +
   38.55 +fun add_simps fnames post sort extra_qualify label moreatts simps lthy =
   38.56 +    let
   38.57 +      val spec = post simps
   38.58 +                   |> map (apfst (apsnd (fn ats => moreatts @ ats)))
   38.59 +                   |> map (apfst (apfst extra_qualify))
   38.60 +
   38.61 +      val (saved_spec_simps, lthy) =
   38.62 +        fold_map (LocalTheory.note Thm.generatedK) spec lthy
   38.63 +
   38.64 +      val saved_simps = flat (map snd saved_spec_simps)
   38.65 +      val simps_by_f = sort saved_simps
   38.66 +
   38.67 +      fun add_for_f fname simps =
   38.68 +        note_theorem ((Long_Name.qualify fname label, []), simps) #> snd
   38.69 +    in
   38.70 +      (saved_simps,
   38.71 +       fold2 add_for_f fnames simps_by_f lthy)
   38.72 +    end
   38.73 +
   38.74 +fun gen_add_fundef is_external prep default_constraint fixspec eqns config lthy =
   38.75 +    let
   38.76 +      val constrn_fxs = map (fn (b, T, mx) => (b, SOME (the_default default_constraint T), mx))
   38.77 +      val ((fixes0, spec0), ctxt') = prep (constrn_fxs fixspec) eqns lthy
   38.78 +      val fixes = map (apfst (apfst Binding.name_of)) fixes0;
   38.79 +      val spec = map (fn (bnd, prop) => (bnd, [prop])) spec0;
   38.80 +      val (eqs, post, sort_cont, cnames) = FundefCommon.get_preproc lthy config ctxt' fixes spec
   38.81 +
   38.82 +      val defname = mk_defname fixes
   38.83 +
   38.84 +      val ((goalstate, cont), lthy) =
   38.85 +          FundefMutual.prepare_fundef_mutual config defname fixes eqs lthy
   38.86 +
   38.87 +      fun afterqed [[proof]] lthy =
   38.88 +        let
   38.89 +          val FundefResult {fs, R, psimps, trsimps,  simple_pinducts, termination,
   38.90 +                            domintros, cases, ...} =
   38.91 +          cont (Thm.close_derivation proof)
   38.92 +
   38.93 +          val fnames = map (fst o fst) fixes
   38.94 +          val qualify = Long_Name.qualify defname
   38.95 +          val addsmps = add_simps fnames post sort_cont
   38.96 +
   38.97 +          val (((psimps', pinducts'), (_, [termination'])), lthy) =
   38.98 +            lthy
   38.99 +            |> addsmps (Binding.qualify false "partial") "psimps"
  38.100 +                 psimp_attribs psimps
  38.101 +            ||> fold_option (snd oo addsmps I "simps" simp_attribs) trsimps
  38.102 +            ||>> note_theorem ((qualify "pinduct",
  38.103 +                   [Attrib.internal (K (RuleCases.case_names cnames)),
  38.104 +                    Attrib.internal (K (RuleCases.consumes 1)),
  38.105 +                    Attrib.internal (K (Induct.induct_pred ""))]), simple_pinducts)
  38.106 +            ||>> note_theorem ((qualify "termination", []), [termination])
  38.107 +            ||> (snd o note_theorem ((qualify "cases",
  38.108 +                   [Attrib.internal (K (RuleCases.case_names cnames))]), [cases]))
  38.109 +            ||> fold_option (snd oo curry note_theorem (qualify "domintros", [])) domintros
  38.110 +
  38.111 +          val cdata = FundefCtxData { add_simps=addsmps, case_names=cnames, psimps=psimps',
  38.112 +                                      pinducts=snd pinducts', termination=termination',
  38.113 +                                      fs=fs, R=R, defname=defname }
  38.114 +          val _ =
  38.115 +            if not is_external then ()
  38.116 +            else Specification.print_consts lthy (K false) (map fst fixes)
  38.117 +        in
  38.118 +          lthy
  38.119 +          |> LocalTheory.declaration (add_fundef_data o morph_fundef_data cdata)
  38.120 +        end
  38.121 +    in
  38.122 +      lthy
  38.123 +        |> is_external ? LocalTheory.set_group (serial_string ())
  38.124 +        |> Proof.theorem_i NONE afterqed [[(Logic.unprotect (concl_of goalstate), [])]]
  38.125 +        |> Proof.refine (Method.primitive_text (fn _ => goalstate)) |> Seq.hd
  38.126 +    end
  38.127 +
  38.128 +val add_fundef = gen_add_fundef false Specification.check_spec (TypeInfer.anyT HOLogic.typeS)
  38.129 +val add_fundef_cmd = gen_add_fundef true Specification.read_spec "_::type"
  38.130 +
  38.131 +fun gen_termination_proof prep_term raw_term_opt lthy =
  38.132 +    let
  38.133 +      val term_opt = Option.map (prep_term lthy) raw_term_opt
  38.134 +      val data = the (case term_opt of
  38.135 +                        SOME t => (import_fundef_data t lthy
  38.136 +                          handle Option.Option =>
  38.137 +                            error ("Not a function: " ^ quote (Syntax.string_of_term lthy t)))
  38.138 +                      | NONE => (import_last_fundef lthy handle Option.Option => error "Not a function"))
  38.139 +
  38.140 +        val FundefCtxData { termination, R, add_simps, case_names, psimps,
  38.141 +                            pinducts, defname, ...} = data
  38.142 +        val domT = domain_type (fastype_of R)
  38.143 +        val goal = HOLogic.mk_Trueprop
  38.144 +                     (HOLogic.mk_all ("x", domT, mk_acc domT R $ Free ("x", domT)))
  38.145 +        fun afterqed [[totality]] lthy =
  38.146 +          let
  38.147 +            val totality = Thm.close_derivation totality
  38.148 +            val remove_domain_condition =
  38.149 +              full_simplify (HOL_basic_ss addsimps [totality, True_implies_equals])
  38.150 +            val tsimps = map remove_domain_condition psimps
  38.151 +            val tinduct = map remove_domain_condition pinducts
  38.152 +            val qualify = Long_Name.qualify defname;
  38.153 +          in
  38.154 +            lthy
  38.155 +            |> add_simps I "simps" simp_attribs tsimps |> snd
  38.156 +            |> note_theorem
  38.157 +               ((qualify "induct",
  38.158 +                 [Attrib.internal (K (RuleCases.case_names case_names))]),
  38.159 +                tinduct) |> snd
  38.160 +          end
  38.161 +    in
  38.162 +      lthy
  38.163 +      |> ProofContext.note_thmss ""
  38.164 +         [((Binding.empty, [ContextRules.rule_del]), [([allI], [])])] |> snd
  38.165 +      |> ProofContext.note_thmss ""
  38.166 +         [((Binding.empty, [ContextRules.intro_bang (SOME 1)]), [([allI], [])])] |> snd
  38.167 +      |> ProofContext.note_thmss ""
  38.168 +         [((Binding.name "termination", [ContextRules.intro_bang (SOME 0)]),
  38.169 +           [([Goal.norm_result termination], [])])] |> snd
  38.170 +      |> Proof.theorem_i NONE afterqed [[(goal, [])]]
  38.171 +    end
  38.172 +
  38.173 +val termination_proof = gen_termination_proof Syntax.check_term;
  38.174 +val termination_proof_cmd = gen_termination_proof Syntax.read_term;
  38.175 +
  38.176 +fun termination term_opt lthy =
  38.177 +  lthy
  38.178 +  |> LocalTheory.set_group (serial_string ())
  38.179 +  |> termination_proof term_opt;
  38.180 +
  38.181 +fun termination_cmd term_opt lthy =
  38.182 +  lthy
  38.183 +  |> LocalTheory.set_group (serial_string ())
  38.184 +  |> termination_proof_cmd term_opt;
  38.185 +
  38.186 +
  38.187 +(* Datatype hook to declare datatype congs as "fundef_congs" *)
  38.188 +
  38.189 +
  38.190 +fun add_case_cong n thy =
  38.191 +    Context.theory_map (FundefCtxTree.map_fundef_congs (Thm.add_thm
  38.192 +                          (Datatype.get_datatype thy n |> the
  38.193 +                           |> #case_cong
  38.194 +                           |> safe_mk_meta_eq)))
  38.195 +                       thy
  38.196 +
  38.197 +val setup_case_cong = Datatype.interpretation (K (fold add_case_cong))
  38.198 +
  38.199 +
  38.200 +(* setup *)
  38.201 +
  38.202 +val setup =
  38.203 +  Attrib.setup @{binding fundef_cong}
  38.204 +    (Attrib.add_del FundefCtxTree.cong_add FundefCtxTree.cong_del)
  38.205 +    "declaration of congruence rule for function definitions"
  38.206 +  #> setup_case_cong
  38.207 +  #> FundefRelation.setup
  38.208 +  #> FundefCommon.TerminationSimps.setup
  38.209 +
  38.210 +val get_congs = FundefCtxTree.get_fundef_congs
  38.211 +
  38.212 +
  38.213 +(* outer syntax *)
  38.214 +
  38.215 +local structure P = OuterParse and K = OuterKeyword in
  38.216 +
  38.217 +val _ =
  38.218 +  OuterSyntax.local_theory_to_proof "function" "define general recursive functions" K.thy_goal
  38.219 +  (fundef_parser default_config
  38.220 +     >> (fn ((config, fixes), statements) => add_fundef_cmd fixes statements config));
  38.221 +
  38.222 +val _ =
  38.223 +  OuterSyntax.local_theory_to_proof "termination" "prove termination of a recursive function" K.thy_goal
  38.224 +  (Scan.option P.term >> termination_cmd);
  38.225 +
  38.226 +end;
  38.227 +
  38.228 +
  38.229 +end
    39.1 --- a/src/HOL/Tools/function_package/fundef_datatype.ML	Fri Jun 19 20:22:46 2009 +0200
    39.2 +++ b/src/HOL/Tools/function_package/fundef_datatype.ML	Fri Jun 19 21:08:07 2009 +0200
    39.3 @@ -40,7 +40,7 @@
    39.4            let
    39.5              val (hd, args) = strip_comb t
    39.6            in
    39.7 -            (((case DatatypePackage.datatype_of_constr thy (fst (dest_Const hd)) of
    39.8 +            (((case Datatype.datatype_of_constr thy (fst (dest_Const hd)) of
    39.9                   SOME _ => ()
   39.10                 | NONE => err "Non-constructor pattern")