discontinued ancient tradition to suffix certain ML module names with "_package"
authorhaftmann
Fri Jun 19 17:23:21 2009 +0200 (2009-06-19)
changeset 31723f5cafe803b55
parent 31717 d1f7b6245a75
child 31724 9b5a128cdb5c
discontinued ancient tradition to suffix certain ML module names with "_package"
NEWS
src/HOL/FunDef.thy
src/HOL/Hilbert_Choice.thy
src/HOL/HoareParallel/OG_Syntax.thy
src/HOL/HoareParallel/RG_Syntax.thy
src/HOL/Import/HOL4Setup.thy
src/HOL/Import/import.ML
src/HOL/Import/import_package.ML
src/HOL/Import/proof_kernel.ML
src/HOL/Import/replay.ML
src/HOL/Inductive.thy
src/HOL/IsaMakefile
src/HOL/Isar_examples/Hoare.thy
src/HOL/List.thy
src/HOL/Nominal/Nominal.thy
src/HOL/Nominal/nominal.ML
src/HOL/Nominal/nominal_atoms.ML
src/HOL/Nominal/nominal_inductive.ML
src/HOL/Nominal/nominal_inductive2.ML
src/HOL/Nominal/nominal_package.ML
src/HOL/Nominal/nominal_primrec.ML
src/HOL/Product_Type.thy
src/HOL/Recdef.thy
src/HOL/Record.thy
src/HOL/Statespace/state_fun.ML
src/HOL/Statespace/state_space.ML
src/HOL/Tools/TFL/casesplit.ML
src/HOL/Tools/TFL/tfl.ML
src/HOL/Tools/TFL/thry.ML
src/HOL/Tools/choice_specification.ML
src/HOL/Tools/datatype_package/datatype.ML
src/HOL/Tools/datatype_package/datatype_abs_proofs.ML
src/HOL/Tools/datatype_package/datatype_codegen.ML
src/HOL/Tools/datatype_package/datatype_package.ML
src/HOL/Tools/datatype_package/datatype_realizer.ML
src/HOL/Tools/datatype_package/datatype_rep_proofs.ML
src/HOL/Tools/function_package/fundef.ML
src/HOL/Tools/function_package/fundef_datatype.ML
src/HOL/Tools/function_package/fundef_package.ML
src/HOL/Tools/function_package/inductive_wrap.ML
src/HOL/Tools/function_package/pattern_split.ML
src/HOL/Tools/function_package/size.ML
src/HOL/Tools/inductive.ML
src/HOL/Tools/inductive_codegen.ML
src/HOL/Tools/inductive_package.ML
src/HOL/Tools/inductive_realizer.ML
src/HOL/Tools/inductive_set.ML
src/HOL/Tools/inductive_set_package.ML
src/HOL/Tools/old_primrec.ML
src/HOL/Tools/old_primrec_package.ML
src/HOL/Tools/primrec.ML
src/HOL/Tools/primrec_package.ML
src/HOL/Tools/quickcheck_generators.ML
src/HOL/Tools/recdef.ML
src/HOL/Tools/recdef_package.ML
src/HOL/Tools/record.ML
src/HOL/Tools/record_package.ML
src/HOL/Tools/refute.ML
src/HOL/Tools/res_atp.ML
src/HOL/Tools/specification_package.ML
src/HOL/Tools/typecopy.ML
src/HOL/Tools/typecopy_package.ML
src/HOL/Tools/typedef.ML
src/HOL/Tools/typedef_codegen.ML
src/HOL/Tools/typedef_package.ML
src/HOL/Typedef.thy
src/HOL/Typerep.thy
src/HOL/ex/Records.thy
src/HOL/ex/predicate_compile.ML
     1.1 --- a/NEWS	Thu Jun 18 18:31:14 2009 -0700
     1.2 +++ b/NEWS	Fri Jun 19 17:23:21 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  
    1.18  *** ML ***
    1.19  
     2.1 --- a/src/HOL/FunDef.thy	Thu Jun 18 18:31:14 2009 -0700
     2.2 +++ b/src/HOL/FunDef.thy	Fri Jun 19 17:23:21 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	Thu Jun 18 18:31:14 2009 -0700
     3.2 +++ b/src/HOL/Hilbert_Choice.thy	Fri Jun 19 17:23:21 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	Thu Jun 18 18:31:14 2009 -0700
     4.2 +++ b/src/HOL/HoareParallel/OG_Syntax.thy	Fri Jun 19 17:23:21 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	Thu Jun 18 18:31:14 2009 -0700
     5.2 +++ b/src/HOL/HoareParallel/RG_Syntax.thy	Fri Jun 19 17:23:21 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/Import/HOL4Setup.thy	Thu Jun 18 18:31:14 2009 -0700
     6.2 +++ b/src/HOL/Import/HOL4Setup.thy	Fri Jun 19 17:23:21 2009 +0200
     6.3 @@ -1,10 +1,9 @@
     6.4  (*  Title:      HOL/Import/HOL4Setup.thy
     6.5 -    ID:         $Id$
     6.6      Author:     Sebastian Skalberg (TU Muenchen)
     6.7  *)
     6.8  
     6.9  theory HOL4Setup imports MakeEqual ImportRecorder
    6.10 -  uses ("proof_kernel.ML") ("replay.ML") ("hol4rews.ML") ("import_package.ML") begin
    6.11 +  uses ("proof_kernel.ML") ("replay.ML") ("hol4rews.ML") ("import.ML") begin
    6.12  
    6.13  section {* General Setup *}
    6.14  
    6.15 @@ -162,8 +161,8 @@
    6.16  
    6.17  use "proof_kernel.ML"
    6.18  use "replay.ML"
    6.19 -use "import_package.ML"
    6.20 +use "import.ML"
    6.21  
    6.22 -setup ImportPackage.setup
    6.23 +setup Import.setup
    6.24  
    6.25  end
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOL/Import/import.ML	Fri Jun 19 17:23:21 2009 +0200
     7.3 @@ -0,0 +1,71 @@
     7.4 +(*  Title:      HOL/Import/import.ML
     7.5 +    Author:     Sebastian Skalberg (TU Muenchen)
     7.6 +*)
     7.7 +
     7.8 +signature IMPORT =
     7.9 +sig
    7.10 +    val debug      : bool ref
    7.11 +    val import_tac : Proof.context -> string * string -> tactic
    7.12 +    val setup      : theory -> theory
    7.13 +end
    7.14 +
    7.15 +structure ImportData = TheoryDataFun
    7.16 +(
    7.17 +  type T = ProofKernel.thm option array option
    7.18 +  val empty = NONE
    7.19 +  val copy = I
    7.20 +  val extend = I
    7.21 +  fun merge _ _ = NONE
    7.22 +)
    7.23 +
    7.24 +structure Import :> IMPORT =
    7.25 +struct
    7.26 +
    7.27 +val debug = ref false
    7.28 +fun message s = if !debug then writeln s else ()
    7.29 +
    7.30 +fun import_tac ctxt (thyname, thmname) =
    7.31 +    if ! quick_and_dirty
    7.32 +    then SkipProof.cheat_tac (ProofContext.theory_of ctxt)
    7.33 +    else
    7.34 +     fn th =>
    7.35 +        let
    7.36 +            val thy = ProofContext.theory_of ctxt
    7.37 +            val prem = hd (prems_of th)
    7.38 +            val _ = message ("Import_tac: thyname=" ^ thyname ^ ", thmname=" ^ thmname)
    7.39 +            val _ = message ("Import trying to prove " ^ Syntax.string_of_term ctxt prem)
    7.40 +            val int_thms = case ImportData.get thy of
    7.41 +                               NONE => fst (Replay.setup_int_thms thyname thy)
    7.42 +                             | SOME a => a
    7.43 +            val proof = snd (ProofKernel.import_proof thyname thmname thy) thy
    7.44 +            val hol4thm = snd (Replay.replay_proof int_thms thyname thmname proof thy)
    7.45 +            val thm = snd (ProofKernel.to_isa_thm hol4thm)
    7.46 +            val rew = ProofKernel.rewrite_hol4_term (concl_of thm) thy
    7.47 +            val thm = equal_elim rew thm
    7.48 +            val prew = ProofKernel.rewrite_hol4_term prem thy
    7.49 +            val prem' = #2 (Logic.dest_equals (prop_of prew))
    7.50 +            val _ = message ("Import proved " ^ Display.string_of_thm thm)
    7.51 +            val thm = ProofKernel.disambiguate_frees thm
    7.52 +            val _ = message ("Disambiguate: " ^ Display.string_of_thm thm)
    7.53 +        in
    7.54 +            case Shuffler.set_prop thy prem' [("",thm)] of
    7.55 +                SOME (_,thm) =>
    7.56 +                let
    7.57 +                    val _ = if prem' aconv (prop_of thm)
    7.58 +                            then message "import: Terms match up"
    7.59 +                            else message "import: Terms DO NOT match up"
    7.60 +                    val thm' = equal_elim (symmetric prew) thm
    7.61 +                    val res = bicompose true (false,thm',0) 1 th
    7.62 +                in
    7.63 +                    res
    7.64 +                end
    7.65 +              | NONE => (message "import: set_prop didn't succeed"; no_tac th)
    7.66 +        end
    7.67 +
    7.68 +val setup = Method.setup @{binding import}
    7.69 +  (Scan.lift (Args.name -- Args.name) >>
    7.70 +    (fn arg => fn ctxt => SIMPLE_METHOD (import_tac ctxt arg)))
    7.71 +  "import HOL4 theorem"
    7.72 +
    7.73 +end
    7.74 +
     8.1 --- a/src/HOL/Import/import_package.ML	Thu Jun 18 18:31:14 2009 -0700
     8.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.3 @@ -1,71 +0,0 @@
     8.4 -(*  Title:      HOL/Import/import_package.ML
     8.5 -    Author:     Sebastian Skalberg (TU Muenchen)
     8.6 -*)
     8.7 -
     8.8 -signature IMPORT_PACKAGE =
     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 ImportPackage :> IMPORT_PACKAGE =
    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/proof_kernel.ML	Thu Jun 18 18:31:14 2009 -0700
     9.2 +++ b/src/HOL/Import/proof_kernel.ML	Fri Jun 19 17:23:21 2009 +0200
     9.3 @@ -2021,7 +2021,7 @@
     9.4                                  snd (get_defname thyname name thy)) thy1 names
     9.5              fun new_name name = fst (get_defname thyname name thy1)
     9.6              val names' = map (fn name => (new_name name,name,false)) names
     9.7 -            val (thy',res) = SpecificationPackage.add_specification NONE
     9.8 +            val (thy',res) = Choice_Specification.add_specification NONE
     9.9                                   names'
    9.10                                   (thy1,th)
    9.11              val _ = ImportRecorder.add_specification names' th
    9.12 @@ -2091,7 +2091,7 @@
    9.13              val tsyn = mk_syn thy tycname
    9.14              val typ = (tycname,tnames,tsyn)
    9.15              val ((_, typedef_info), thy') =
    9.16 -              TypedefPackage.add_typedef false (SOME (Binding.name thmname))
    9.17 +              Typedef.add_typedef false (SOME (Binding.name thmname))
    9.18                  (Binding.name tycname, tnames, tsyn) c NONE (rtac th2 1) thy
    9.19              val _ = ImportRecorder.add_typedef (SOME thmname) typ c NONE th2
    9.20  
    9.21 @@ -2179,7 +2179,7 @@
    9.22              val tsyn = mk_syn thy tycname
    9.23              val typ = (tycname,tnames,tsyn)
    9.24              val ((_, typedef_info), thy') =
    9.25 -              TypedefPackage.add_typedef false NONE (Binding.name tycname,tnames,tsyn) c
    9.26 +              Typedef.add_typedef false NONE (Binding.name tycname,tnames,tsyn) c
    9.27                  (SOME(Binding.name rep_name,Binding.name abs_name)) (rtac th2 1) thy
    9.28              val _ = ImportRecorder.add_typedef NONE typ c (SOME(rep_name,abs_name)) th2
    9.29              val fulltyname = Sign.intern_type thy' tycname
    10.1 --- a/src/HOL/Import/replay.ML	Thu Jun 18 18:31:14 2009 -0700
    10.2 +++ b/src/HOL/Import/replay.ML	Fri Jun 19 17:23:21 2009 +0200
    10.3 @@ -329,7 +329,7 @@
    10.4  	and rp (ThmEntry (thyname', thmname', aborted, History history)) thy = rps history thy	    
    10.5  	  | rp (DeltaEntry ds) thy = fold delta ds thy
    10.6  	and delta (Specification (names, th)) thy = 
    10.7 -	    fst (SpecificationPackage.add_specification NONE names (thy,th_of thy th))
    10.8 +	    fst (Choice_Specification.add_specification NONE names (thy,th_of thy th))
    10.9  	  | delta (Hol_mapping (thyname, thmname, isaname)) thy = 
   10.10  	    add_hol4_mapping thyname thmname isaname thy
   10.11  	  | delta (Hol_pending (thyname, thmname, th)) thy = 
   10.12 @@ -344,7 +344,7 @@
   10.13  	  | delta (Hol_theorem (thyname, thmname, th)) thy =
   10.14  	    add_hol4_theorem thyname thmname ([], th_of thy th) thy
   10.15  	  | delta (Typedef (thmname, (t, vs, mx), c, repabs, th)) thy = 
   10.16 -	    snd (TypedefPackage.add_typedef false (Option.map Binding.name thmname) (Binding.name t, vs, mx) c
   10.17 +	    snd (Typedef.add_typedef false (Option.map Binding.name thmname) (Binding.name t, vs, mx) c
   10.18          (Option.map (pairself Binding.name) repabs) (rtac (th_of thy th) 1) thy)
   10.19  	  | delta (Hol_type_mapping (thyname, tycname, fulltyname)) thy =  
   10.20  	    add_hol4_type_mapping thyname tycname true fulltyname thy
    11.1 --- a/src/HOL/Inductive.thy	Thu Jun 18 18:31:14 2009 -0700
    11.2 +++ b/src/HOL/Inductive.thy	Fri Jun 19 17:23:21 2009 +0200
    11.3 @@ -7,7 +7,7 @@
    11.4  theory Inductive 
    11.5  imports Lattices Sum_Type
    11.6  uses
    11.7 -  ("Tools/inductive_package.ML")
    11.8 +  ("Tools/inductive.ML")
    11.9    "Tools/dseq.ML"
   11.10    ("Tools/inductive_codegen.ML")
   11.11    ("Tools/datatype_package/datatype_aux.ML")
   11.12 @@ -15,9 +15,9 @@
   11.13    ("Tools/datatype_package/datatype_rep_proofs.ML")
   11.14    ("Tools/datatype_package/datatype_abs_proofs.ML")
   11.15    ("Tools/datatype_package/datatype_case.ML")
   11.16 -  ("Tools/datatype_package/datatype_package.ML")
   11.17 -  ("Tools/old_primrec_package.ML")
   11.18 -  ("Tools/primrec_package.ML")
   11.19 +  ("Tools/datatype_package/datatype.ML")
   11.20 +  ("Tools/old_primrec.ML")
   11.21 +  ("Tools/primrec.ML")
   11.22    ("Tools/datatype_package/datatype_codegen.ML")
   11.23  begin
   11.24  
   11.25 @@ -320,8 +320,8 @@
   11.26  val le_fun_def = @{thm le_fun_def} RS @{thm eq_reflection}
   11.27  *}
   11.28  
   11.29 -use "Tools/inductive_package.ML"
   11.30 -setup InductivePackage.setup
   11.31 +use "Tools/inductive.ML"
   11.32 +setup Inductive.setup
   11.33  
   11.34  theorems [mono] =
   11.35    imp_refl disj_mono conj_mono ex_mono all_mono if_bool_eq_conj
   11.36 @@ -340,11 +340,11 @@
   11.37  use "Tools/datatype_package/datatype_rep_proofs.ML"
   11.38  use "Tools/datatype_package/datatype_abs_proofs.ML"
   11.39  use "Tools/datatype_package/datatype_case.ML"
   11.40 -use "Tools/datatype_package/datatype_package.ML"
   11.41 -setup DatatypePackage.setup
   11.42 +use "Tools/datatype_package/datatype.ML"
   11.43 +setup Datatype.setup
   11.44  
   11.45 -use "Tools/old_primrec_package.ML"
   11.46 -use "Tools/primrec_package.ML"
   11.47 +use "Tools/old_primrec.ML"
   11.48 +use "Tools/primrec.ML"
   11.49  
   11.50  use "Tools/datatype_package/datatype_codegen.ML"
   11.51  setup DatatypeCodegen.setup
   11.52 @@ -364,7 +364,7 @@
   11.53    fun fun_tr ctxt [cs] =
   11.54      let
   11.55        val x = Free (Name.variant (Term.add_free_names cs []) "x", dummyT);
   11.56 -      val ft = DatatypeCase.case_tr true DatatypePackage.datatype_of_constr
   11.57 +      val ft = DatatypeCase.case_tr true Datatype.datatype_of_constr
   11.58                   ctxt [x, cs]
   11.59      in lambda x ft end
   11.60  in [("_lam_pats_syntax", fun_tr)] end
    12.1 --- a/src/HOL/IsaMakefile	Thu Jun 18 18:31:14 2009 -0700
    12.2 +++ b/src/HOL/IsaMakefile	Fri Jun 19 17:23:21 2009 +0200
    12.3 @@ -145,7 +145,7 @@
    12.4    Tools/datatype_package/datatype_aux.ML \
    12.5    Tools/datatype_package/datatype_case.ML \
    12.6    Tools/datatype_package/datatype_codegen.ML \
    12.7 -  Tools/datatype_package/datatype_package.ML \
    12.8 +  Tools/datatype_package/datatype.ML \
    12.9    Tools/datatype_package/datatype_prop.ML \
   12.10    Tools/datatype_package/datatype_realizer.ML \
   12.11    Tools/datatype_package/datatype_rep_proofs.ML \
   12.12 @@ -158,7 +158,7 @@
   12.13    Tools/function_package/fundef_core.ML \
   12.14    Tools/function_package/fundef_datatype.ML \
   12.15    Tools/function_package/fundef_lib.ML \
   12.16 -  Tools/function_package/fundef_package.ML \
   12.17 +  Tools/function_package/fundef.ML \
   12.18    Tools/function_package/induction_scheme.ML \
   12.19    Tools/function_package/inductive_wrap.ML \
   12.20    Tools/function_package/lexicographic_order.ML \
   12.21 @@ -171,24 +171,24 @@
   12.22    Tools/function_package/sum_tree.ML \
   12.23    Tools/function_package/termination.ML \
   12.24    Tools/inductive_codegen.ML \
   12.25 -  Tools/inductive_package.ML \
   12.26 +  Tools/inductive.ML \
   12.27    Tools/inductive_realizer.ML \
   12.28 -  Tools/inductive_set_package.ML \
   12.29 +  Tools/inductive_set.ML \
   12.30    Tools/lin_arith.ML \
   12.31    Tools/nat_arith.ML \
   12.32 -  Tools/old_primrec_package.ML \
   12.33 -  Tools/primrec_package.ML \
   12.34 +  Tools/old_primrec.ML \
   12.35 +  Tools/primrec.ML \
   12.36    Tools/prop_logic.ML \
   12.37 -  Tools/record_package.ML \
   12.38 +  Tools/record.ML \
   12.39    Tools/refute.ML \
   12.40    Tools/refute_isar.ML \
   12.41    Tools/rewrite_hol_proof.ML \
   12.42    Tools/sat_funcs.ML \
   12.43    Tools/sat_solver.ML \
   12.44    Tools/split_rule.ML \
   12.45 -  Tools/typecopy_package.ML \
   12.46 +  Tools/typecopy.ML \
   12.47    Tools/typedef_codegen.ML \
   12.48 -  Tools/typedef_package.ML \
   12.49 +  Tools/typedef.ML \
   12.50    Transitive_Closure.thy \
   12.51    Typedef.thy \
   12.52    Wellfounded.thy \
   12.53 @@ -250,13 +250,13 @@
   12.54    Tools/Qelim/generated_cooper.ML \
   12.55    Tools/Qelim/presburger.ML \
   12.56    Tools/Qelim/qelim.ML \
   12.57 -  Tools/recdef_package.ML \
   12.58 +  Tools/recdef.ML \
   12.59    Tools/res_atp.ML \
   12.60    Tools/res_axioms.ML \
   12.61    Tools/res_clause.ML \
   12.62    Tools/res_hol_clause.ML \
   12.63    Tools/res_reconstruct.ML \
   12.64 -  Tools/specification_package.ML \
   12.65 +  Tools/choice_specification.ML \
   12.66    Tools/string_code.ML \
   12.67    Tools/string_syntax.ML \
   12.68    Tools/TFL/casesplit.ML \
   12.69 @@ -423,7 +423,7 @@
   12.70  IMPORTER_FILES = Import/lazy_seq.ML Import/proof_kernel.ML Import/replay.ML \
   12.71    Import/shuffler.ML Import/MakeEqual.thy Import/HOL4Setup.thy \
   12.72    Import/HOL4Syntax.thy Import/HOL4Compat.thy Import/import_syntax.ML \
   12.73 -  Import/hol4rews.ML Import/import_package.ML Import/ROOT.ML
   12.74 +  Import/hol4rews.ML Import/import.ML Import/ROOT.ML
   12.75  
   12.76  IMPORTER_HOLLIGHT_FILES = Import/proof_kernel.ML Import/replay.ML \
   12.77    Import/shuffler.ML Import/MakeEqual.thy Import/HOL4Setup.thy \
   12.78 @@ -968,7 +968,7 @@
   12.79    Nominal/nominal_induct.ML \
   12.80    Nominal/nominal_inductive.ML \
   12.81    Nominal/nominal_inductive2.ML \
   12.82 -  Nominal/nominal_package.ML \
   12.83 +  Nominal/nominal.ML \
   12.84    Nominal/nominal_permeq.ML \
   12.85    Nominal/nominal_primrec.ML \
   12.86    Nominal/nominal_thmdecls.ML \
    13.1 --- a/src/HOL/Isar_examples/Hoare.thy	Thu Jun 18 18:31:14 2009 -0700
    13.2 +++ b/src/HOL/Isar_examples/Hoare.thy	Fri Jun 19 17:23:21 2009 +0200
    13.3 @@ -260,7 +260,7 @@
    13.4        | bexp_tr' _ _ = raise Match;
    13.5  
    13.6      fun upd_tr' (x_upd, T) =
    13.7 -      (case try (unsuffix RecordPackage.updateN) x_upd of
    13.8 +      (case try (unsuffix Record.updateN) x_upd of
    13.9          SOME x => (x, if T = dummyT then T else Term.domain_type T)
   13.10        | NONE => raise Match);
   13.11  
    14.1 --- a/src/HOL/List.thy	Thu Jun 18 18:31:14 2009 -0700
    14.2 +++ b/src/HOL/List.thy	Fri Jun 19 17:23:21 2009 +0200
    14.3 @@ -363,7 +363,7 @@
    14.4        val case2 = Syntax.const "_case1" $ Syntax.const Term.dummy_patternN
    14.5                                          $ NilC;
    14.6        val cs = Syntax.const "_case2" $ case1 $ case2
    14.7 -      val ft = DatatypeCase.case_tr false DatatypePackage.datatype_of_constr
    14.8 +      val ft = DatatypeCase.case_tr false Datatype.datatype_of_constr
    14.9                   ctxt [x, cs]
   14.10      in lambda x ft end;
   14.11  
    15.1 --- a/src/HOL/Nominal/Nominal.thy	Thu Jun 18 18:31:14 2009 -0700
    15.2 +++ b/src/HOL/Nominal/Nominal.thy	Fri Jun 19 17:23:21 2009 +0200
    15.3 @@ -3,7 +3,7 @@
    15.4  uses
    15.5    ("nominal_thmdecls.ML")
    15.6    ("nominal_atoms.ML")
    15.7 -  ("nominal_package.ML")
    15.8 +  ("nominal.ML")
    15.9    ("nominal_induct.ML") 
   15.10    ("nominal_permeq.ML")
   15.11    ("nominal_fresh_fun.ML")
   15.12 @@ -3670,7 +3670,7 @@
   15.13  lemma allE_Nil: assumes "\<forall>x. P x" obtains "P []"
   15.14    using assms ..
   15.15  
   15.16 -use "nominal_package.ML"
   15.17 +use "nominal.ML"
   15.18  
   15.19  (******************************************************)
   15.20  (* primitive recursive functions on nominal datatypes *)
    16.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    16.2 +++ b/src/HOL/Nominal/nominal.ML	Fri Jun 19 17:23:21 2009 +0200
    16.3 @@ -0,0 +1,2095 @@
    16.4 +(*  Title:      HOL/Nominal/nominal.ML
    16.5 +    Author:     Stefan Berghofer and Christian Urban, TU Muenchen
    16.6 +
    16.7 +Nominal datatype package for Isabelle/HOL.
    16.8 +*)
    16.9 +
   16.10 +signature NOMINAL =
   16.11 +sig
   16.12 +  val add_nominal_datatype : DatatypeAux.datatype_config -> string list ->
   16.13 +    (string list * bstring * mixfix *
   16.14 +      (bstring * string list * mixfix) list) list -> theory -> theory
   16.15 +  type descr
   16.16 +  type nominal_datatype_info
   16.17 +  val get_nominal_datatypes : theory -> nominal_datatype_info Symtab.table
   16.18 +  val get_nominal_datatype : theory -> string -> nominal_datatype_info option
   16.19 +  val mk_perm: typ list -> term -> term -> term
   16.20 +  val perm_of_pair: term * term -> term
   16.21 +  val mk_not_sym: thm list -> thm list
   16.22 +  val perm_simproc: simproc
   16.23 +  val fresh_const: typ -> typ -> term
   16.24 +  val fresh_star_const: typ -> typ -> term
   16.25 +end
   16.26 +
   16.27 +structure Nominal : NOMINAL =
   16.28 +struct
   16.29 +
   16.30 +val finite_emptyI = thm "finite.emptyI";
   16.31 +val finite_Diff = thm "finite_Diff";
   16.32 +val finite_Un = thm "finite_Un";
   16.33 +val Un_iff = thm "Un_iff";
   16.34 +val In0_eq = thm "In0_eq";
   16.35 +val In1_eq = thm "In1_eq";
   16.36 +val In0_not_In1 = thm "In0_not_In1";
   16.37 +val In1_not_In0 = thm "In1_not_In0";
   16.38 +val Un_assoc = thm "Un_assoc";
   16.39 +val Collect_disj_eq = thm "Collect_disj_eq";
   16.40 +val empty_def = thm "empty_def";
   16.41 +val empty_iff = thm "empty_iff";
   16.42 +
   16.43 +open DatatypeAux;
   16.44 +open NominalAtoms;
   16.45 +
   16.46 +(** FIXME: Datatype should export this function **)
   16.47 +
   16.48 +local
   16.49 +
   16.50 +fun dt_recs (DtTFree _) = []
   16.51 +  | dt_recs (DtType (_, dts)) = List.concat (map dt_recs dts)
   16.52 +  | dt_recs (DtRec i) = [i];
   16.53 +
   16.54 +fun dt_cases (descr: descr) (_, args, constrs) =
   16.55 +  let
   16.56 +    fun the_bname i = Long_Name.base_name (#1 (valOf (AList.lookup (op =) descr i)));
   16.57 +    val bnames = map the_bname (distinct op = (List.concat (map dt_recs args)));
   16.58 +  in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
   16.59 +
   16.60 +
   16.61 +fun induct_cases descr =
   16.62 +  DatatypeProp.indexify_names (List.concat (map (dt_cases descr) (map #2 descr)));
   16.63 +
   16.64 +fun exhaust_cases descr i = dt_cases descr (valOf (AList.lookup (op =) descr i));
   16.65 +
   16.66 +in
   16.67 +
   16.68 +fun mk_case_names_induct descr = RuleCases.case_names (induct_cases descr);
   16.69 +
   16.70 +fun mk_case_names_exhausts descr new =
   16.71 +  map (RuleCases.case_names o exhaust_cases descr o #1)
   16.72 +    (List.filter (fn ((_, (name, _, _))) => name mem_string new) descr);
   16.73 +
   16.74 +end;
   16.75 +
   16.76 +(* theory data *)
   16.77 +
   16.78 +type descr = (int * (string * dtyp list * (string * (dtyp list * dtyp) list) list)) list;
   16.79 +
   16.80 +type nominal_datatype_info =
   16.81 +  {index : int,
   16.82 +   descr : descr,
   16.83 +   sorts : (string * sort) list,
   16.84 +   rec_names : string list,
   16.85 +   rec_rewrites : thm list,
   16.86 +   induction : thm,
   16.87 +   distinct : thm list,
   16.88 +   inject : thm list};
   16.89 +
   16.90 +structure NominalDatatypesData = TheoryDataFun
   16.91 +(
   16.92 +  type T = nominal_datatype_info Symtab.table;
   16.93 +  val empty = Symtab.empty;
   16.94 +  val copy = I;
   16.95 +  val extend = I;
   16.96 +  fun merge _ tabs : T = Symtab.merge (K true) tabs;
   16.97 +);
   16.98 +
   16.99 +val get_nominal_datatypes = NominalDatatypesData.get;
  16.100 +val put_nominal_datatypes = NominalDatatypesData.put;
  16.101 +val map_nominal_datatypes = NominalDatatypesData.map;
  16.102 +val get_nominal_datatype = Symtab.lookup o get_nominal_datatypes;
  16.103 +
  16.104 +
  16.105 +(**** make datatype info ****)
  16.106 +
  16.107 +fun make_dt_info descr sorts induct reccomb_names rec_thms
  16.108 +    (((i, (_, (tname, _, _))), distinct), inject) =
  16.109 +  (tname,
  16.110 +   {index = i,
  16.111 +    descr = descr,
  16.112 +    sorts = sorts,
  16.113 +    rec_names = reccomb_names,
  16.114 +    rec_rewrites = rec_thms,
  16.115 +    induction = induct,
  16.116 +    distinct = distinct,
  16.117 +    inject = inject});
  16.118 +
  16.119 +(*******************************)
  16.120 +
  16.121 +val (_ $ (_ $ (_ $ (distinct_f $ _) $ _))) = hd (prems_of distinct_lemma);
  16.122 +
  16.123 +
  16.124 +(** simplification procedure for sorting permutations **)
  16.125 +
  16.126 +val dj_cp = thm "dj_cp";
  16.127 +
  16.128 +fun dest_permT (Type ("fun", [Type ("List.list", [Type ("*", [T, _])]),
  16.129 +      Type ("fun", [_, U])])) = (T, U);
  16.130 +
  16.131 +fun permTs_of (Const ("Nominal.perm", T) $ t $ u) = fst (dest_permT T) :: permTs_of u
  16.132 +  | permTs_of _ = [];
  16.133 +
  16.134 +fun perm_simproc' thy ss (Const ("Nominal.perm", T) $ t $ (u as Const ("Nominal.perm", U) $ r $ s)) =
  16.135 +      let
  16.136 +        val (aT as Type (a, []), S) = dest_permT T;
  16.137 +        val (bT as Type (b, []), _) = dest_permT U
  16.138 +      in if aT mem permTs_of u andalso aT <> bT then
  16.139 +          let
  16.140 +            val cp = cp_inst_of thy a b;
  16.141 +            val dj = dj_thm_of thy b a;
  16.142 +            val dj_cp' = [cp, dj] MRS dj_cp;
  16.143 +            val cert = SOME o cterm_of thy
  16.144 +          in
  16.145 +            SOME (mk_meta_eq (Drule.instantiate' [SOME (ctyp_of thy S)]
  16.146 +              [cert t, cert r, cert s] dj_cp'))
  16.147 +          end
  16.148 +        else NONE
  16.149 +      end
  16.150 +  | perm_simproc' thy ss _ = NONE;
  16.151 +
  16.152 +val perm_simproc =
  16.153 +  Simplifier.simproc (the_context ()) "perm_simp" ["pi1 \<bullet> (pi2 \<bullet> x)"] perm_simproc';
  16.154 +
  16.155 +val meta_spec = thm "meta_spec";
  16.156 +
  16.157 +fun projections rule =
  16.158 +  ProjectRule.projections (ProofContext.init (Thm.theory_of_thm rule)) rule
  16.159 +  |> map (standard #> RuleCases.save rule);
  16.160 +
  16.161 +val supp_prod = thm "supp_prod";
  16.162 +val fresh_prod = thm "fresh_prod";
  16.163 +val supports_fresh = thm "supports_fresh";
  16.164 +val supports_def = thm "Nominal.supports_def";
  16.165 +val fresh_def = thm "fresh_def";
  16.166 +val supp_def = thm "supp_def";
  16.167 +val rev_simps = thms "rev.simps";
  16.168 +val app_simps = thms "append.simps";
  16.169 +val at_fin_set_supp = thm "at_fin_set_supp";
  16.170 +val at_fin_set_fresh = thm "at_fin_set_fresh";
  16.171 +val abs_fun_eq1 = thm "abs_fun_eq1";
  16.172 +
  16.173 +val collect_simp = rewrite_rule [mk_meta_eq mem_Collect_eq];
  16.174 +
  16.175 +fun mk_perm Ts t u =
  16.176 +  let
  16.177 +    val T = fastype_of1 (Ts, t);
  16.178 +    val U = fastype_of1 (Ts, u)
  16.179 +  in Const ("Nominal.perm", T --> U --> U) $ t $ u end;
  16.180 +
  16.181 +fun perm_of_pair (x, y) =
  16.182 +  let
  16.183 +    val T = fastype_of x;
  16.184 +    val pT = mk_permT T
  16.185 +  in Const ("List.list.Cons", HOLogic.mk_prodT (T, T) --> pT --> pT) $
  16.186 +    HOLogic.mk_prod (x, y) $ Const ("List.list.Nil", pT)
  16.187 +  end;
  16.188 +
  16.189 +fun mk_not_sym ths = maps (fn th => case prop_of th of
  16.190 +    _ $ (Const ("Not", _) $ (Const ("op =", _) $ _ $ _)) => [th, th RS not_sym]
  16.191 +  | _ => [th]) ths;
  16.192 +
  16.193 +fun fresh_const T U = Const ("Nominal.fresh", T --> U --> HOLogic.boolT);
  16.194 +fun fresh_star_const T U =
  16.195 +  Const ("Nominal.fresh_star", HOLogic.mk_setT T --> U --> HOLogic.boolT);
  16.196 +
  16.197 +fun gen_add_nominal_datatype prep_typ config new_type_names dts thy =
  16.198 +  let
  16.199 +    (* this theory is used just for parsing *)
  16.200 +
  16.201 +    val tmp_thy = thy |>
  16.202 +      Theory.copy |>
  16.203 +      Sign.add_types (map (fn (tvs, tname, mx, _) =>
  16.204 +        (Binding.name tname, length tvs, mx)) dts);
  16.205 +
  16.206 +    val atoms = atoms_of thy;
  16.207 +
  16.208 +    fun prep_constr ((constrs, sorts), (cname, cargs, mx)) =
  16.209 +      let val (cargs', sorts') = Library.foldl (prep_typ tmp_thy) (([], sorts), cargs)
  16.210 +      in (constrs @ [(cname, cargs', mx)], sorts') end
  16.211 +
  16.212 +    fun prep_dt_spec ((dts, sorts), (tvs, tname, mx, constrs)) =
  16.213 +      let val (constrs', sorts') = Library.foldl prep_constr (([], sorts), constrs)
  16.214 +      in (dts @ [(tvs, tname, mx, constrs')], sorts') end
  16.215 +
  16.216 +    val (dts', sorts) = Library.foldl prep_dt_spec (([], []), dts);
  16.217 +    val tyvars = map (map (fn s =>
  16.218 +      (s, the (AList.lookup (op =) sorts s))) o #1) dts';
  16.219 +
  16.220 +    fun inter_sort thy S S' = Type.inter_sort (Sign.tsig_of thy) (S, S');
  16.221 +    fun augment_sort_typ thy S =
  16.222 +      let val S = Sign.certify_sort thy S
  16.223 +      in map_type_tfree (fn (s, S') => TFree (s,
  16.224 +        if member (op = o apsnd fst) sorts s then inter_sort thy S S' else S'))
  16.225 +      end;
  16.226 +    fun augment_sort thy S = map_types (augment_sort_typ thy S);
  16.227 +
  16.228 +    val types_syntax = map (fn (tvs, tname, mx, constrs) => (tname, mx)) dts';
  16.229 +    val constr_syntax = map (fn (tvs, tname, mx, constrs) =>
  16.230 +      map (fn (cname, cargs, mx) => (cname, mx)) constrs) dts';
  16.231 +
  16.232 +    val ps = map (fn (_, n, _, _) =>
  16.233 +      (Sign.full_bname tmp_thy n, Sign.full_bname tmp_thy (n ^ "_Rep"))) dts;
  16.234 +    val rps = map Library.swap ps;
  16.235 +
  16.236 +    fun replace_types (Type ("Nominal.ABS", [T, U])) =
  16.237 +          Type ("fun", [T, Type ("Nominal.noption", [replace_types U])])
  16.238 +      | replace_types (Type (s, Ts)) =
  16.239 +          Type (getOpt (AList.lookup op = ps s, s), map replace_types Ts)
  16.240 +      | replace_types T = T;
  16.241 +
  16.242 +    val dts'' = map (fn (tvs, tname, mx, constrs) => (tvs, Binding.name (tname ^ "_Rep"), NoSyn,
  16.243 +      map (fn (cname, cargs, mx) => (Binding.name (cname ^ "_Rep"),
  16.244 +        map replace_types cargs, NoSyn)) constrs)) dts';
  16.245 +
  16.246 +    val new_type_names' = map (fn n => n ^ "_Rep") new_type_names;
  16.247 +    val full_new_type_names' = map (Sign.full_bname thy) new_type_names';
  16.248 +
  16.249 +    val ({induction, ...},thy1) =
  16.250 +      Datatype.add_datatype config new_type_names' dts'' thy;
  16.251 +
  16.252 +    val SOME {descr, ...} = Symtab.lookup
  16.253 +      (Datatype.get_datatypes thy1) (hd full_new_type_names');
  16.254 +    fun nth_dtyp i = typ_of_dtyp descr sorts (DtRec i);
  16.255 +
  16.256 +    val big_name = space_implode "_" new_type_names;
  16.257 +
  16.258 +
  16.259 +    (**** define permutation functions ****)
  16.260 +
  16.261 +    val permT = mk_permT (TFree ("'x", HOLogic.typeS));
  16.262 +    val pi = Free ("pi", permT);
  16.263 +    val perm_types = map (fn (i, _) =>
  16.264 +      let val T = nth_dtyp i
  16.265 +      in permT --> T --> T end) descr;
  16.266 +    val perm_names' = DatatypeProp.indexify_names (map (fn (i, _) =>
  16.267 +      "perm_" ^ name_of_typ (nth_dtyp i)) descr);
  16.268 +    val perm_names = replicate (length new_type_names) "Nominal.perm" @
  16.269 +      map (Sign.full_bname thy1) (List.drop (perm_names', length new_type_names));
  16.270 +    val perm_names_types = perm_names ~~ perm_types;
  16.271 +    val perm_names_types' = perm_names' ~~ perm_types;
  16.272 +
  16.273 +    val perm_eqs = maps (fn (i, (_, _, constrs)) =>
  16.274 +      let val T = nth_dtyp i
  16.275 +      in map (fn (cname, dts) =>
  16.276 +        let
  16.277 +          val Ts = map (typ_of_dtyp descr sorts) dts;
  16.278 +          val names = Name.variant_list ["pi"] (DatatypeProp.make_tnames Ts);
  16.279 +          val args = map Free (names ~~ Ts);
  16.280 +          val c = Const (cname, Ts ---> T);
  16.281 +          fun perm_arg (dt, x) =
  16.282 +            let val T = type_of x
  16.283 +            in if is_rec_type dt then
  16.284 +                let val (Us, _) = strip_type T
  16.285 +                in list_abs (map (pair "x") Us,
  16.286 +                  Free (nth perm_names_types' (body_index dt)) $ pi $
  16.287 +                    list_comb (x, map (fn (i, U) =>
  16.288 +                      Const ("Nominal.perm", permT --> U --> U) $
  16.289 +                        (Const ("List.rev", permT --> permT) $ pi) $
  16.290 +                        Bound i) ((length Us - 1 downto 0) ~~ Us)))
  16.291 +                end
  16.292 +              else Const ("Nominal.perm", permT --> T --> T) $ pi $ x
  16.293 +            end;
  16.294 +        in
  16.295 +          (Attrib.empty_binding, HOLogic.mk_Trueprop (HOLogic.mk_eq
  16.296 +            (Free (nth perm_names_types' i) $
  16.297 +               Free ("pi", mk_permT (TFree ("'x", HOLogic.typeS))) $
  16.298 +               list_comb (c, args),
  16.299 +             list_comb (c, map perm_arg (dts ~~ args)))))
  16.300 +        end) constrs
  16.301 +      end) descr;
  16.302 +
  16.303 +    val (perm_simps, thy2) =
  16.304 +      Primrec.add_primrec_overloaded
  16.305 +        (map (fn (s, sT) => (s, sT, false))
  16.306 +           (List.take (perm_names' ~~ perm_names_types, length new_type_names)))
  16.307 +        (map (fn s => (Binding.name s, NONE, NoSyn)) perm_names') perm_eqs thy1;
  16.308 +
  16.309 +    (**** prove that permutation functions introduced by unfolding are ****)
  16.310 +    (**** equivalent to already existing permutation functions         ****)
  16.311 +
  16.312 +    val _ = warning ("length descr: " ^ string_of_int (length descr));
  16.313 +    val _ = warning ("length new_type_names: " ^ string_of_int (length new_type_names));
  16.314 +
  16.315 +    val perm_indnames = DatatypeProp.make_tnames (map body_type perm_types);
  16.316 +    val perm_fun_def = PureThy.get_thm thy2 "perm_fun_def";
  16.317 +
  16.318 +    val unfolded_perm_eq_thms =
  16.319 +      if length descr = length new_type_names then []
  16.320 +      else map standard (List.drop (split_conj_thm
  16.321 +        (Goal.prove_global thy2 [] []
  16.322 +          (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  16.323 +            (map (fn (c as (s, T), x) =>
  16.324 +               let val [T1, T2] = binder_types T
  16.325 +               in HOLogic.mk_eq (Const c $ pi $ Free (x, T2),
  16.326 +                 Const ("Nominal.perm", T) $ pi $ Free (x, T2))
  16.327 +               end)
  16.328 +             (perm_names_types ~~ perm_indnames))))
  16.329 +          (fn _ => EVERY [indtac induction perm_indnames 1,
  16.330 +            ALLGOALS (asm_full_simp_tac
  16.331 +              (simpset_of thy2 addsimps [perm_fun_def]))])),
  16.332 +        length new_type_names));
  16.333 +
  16.334 +    (**** prove [] \<bullet> t = t ****)
  16.335 +
  16.336 +    val _ = warning "perm_empty_thms";
  16.337 +
  16.338 +    val perm_empty_thms = List.concat (map (fn a =>
  16.339 +      let val permT = mk_permT (Type (a, []))
  16.340 +      in map standard (List.take (split_conj_thm
  16.341 +        (Goal.prove_global thy2 [] []
  16.342 +          (augment_sort thy2 [pt_class_of thy2 a]
  16.343 +            (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  16.344 +              (map (fn ((s, T), x) => HOLogic.mk_eq
  16.345 +                  (Const (s, permT --> T --> T) $
  16.346 +                     Const ("List.list.Nil", permT) $ Free (x, T),
  16.347 +                   Free (x, T)))
  16.348 +               (perm_names ~~
  16.349 +                map body_type perm_types ~~ perm_indnames)))))
  16.350 +          (fn _ => EVERY [indtac induction perm_indnames 1,
  16.351 +            ALLGOALS (asm_full_simp_tac (simpset_of thy2))])),
  16.352 +        length new_type_names))
  16.353 +      end)
  16.354 +      atoms);
  16.355 +
  16.356 +    (**** prove (pi1 @ pi2) \<bullet> t = pi1 \<bullet> (pi2 \<bullet> t) ****)
  16.357 +
  16.358 +    val _ = warning "perm_append_thms";
  16.359 +
  16.360 +    (*FIXME: these should be looked up statically*)
  16.361 +    val at_pt_inst = PureThy.get_thm thy2 "at_pt_inst";
  16.362 +    val pt2 = PureThy.get_thm thy2 "pt2";
  16.363 +
  16.364 +    val perm_append_thms = List.concat (map (fn a =>
  16.365 +      let
  16.366 +        val permT = mk_permT (Type (a, []));
  16.367 +        val pi1 = Free ("pi1", permT);
  16.368 +        val pi2 = Free ("pi2", permT);
  16.369 +        val pt_inst = pt_inst_of thy2 a;
  16.370 +        val pt2' = pt_inst RS pt2;
  16.371 +        val pt2_ax = PureThy.get_thm thy2 (Long_Name.map_base_name (fn s => "pt_" ^ s ^ "2") a);
  16.372 +      in List.take (map standard (split_conj_thm
  16.373 +        (Goal.prove_global thy2 [] []
  16.374 +           (augment_sort thy2 [pt_class_of thy2 a]
  16.375 +             (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  16.376 +                (map (fn ((s, T), x) =>
  16.377 +                    let val perm = Const (s, permT --> T --> T)
  16.378 +                    in HOLogic.mk_eq
  16.379 +                      (perm $ (Const ("List.append", permT --> permT --> permT) $
  16.380 +                         pi1 $ pi2) $ Free (x, T),
  16.381 +                       perm $ pi1 $ (perm $ pi2 $ Free (x, T)))
  16.382 +                    end)
  16.383 +                  (perm_names ~~
  16.384 +                   map body_type perm_types ~~ perm_indnames)))))
  16.385 +           (fn _ => EVERY [indtac induction perm_indnames 1,
  16.386 +              ALLGOALS (asm_full_simp_tac (simpset_of thy2 addsimps [pt2', pt2_ax]))]))),
  16.387 +         length new_type_names)
  16.388 +      end) atoms);
  16.389 +
  16.390 +    (**** prove pi1 ~ pi2 ==> pi1 \<bullet> t = pi2 \<bullet> t ****)
  16.391 +
  16.392 +    val _ = warning "perm_eq_thms";
  16.393 +
  16.394 +    val pt3 = PureThy.get_thm thy2 "pt3";
  16.395 +    val pt3_rev = PureThy.get_thm thy2 "pt3_rev";
  16.396 +
  16.397 +    val perm_eq_thms = List.concat (map (fn a =>
  16.398 +      let
  16.399 +        val permT = mk_permT (Type (a, []));
  16.400 +        val pi1 = Free ("pi1", permT);
  16.401 +        val pi2 = Free ("pi2", permT);
  16.402 +        val at_inst = at_inst_of thy2 a;
  16.403 +        val pt_inst = pt_inst_of thy2 a;
  16.404 +        val pt3' = pt_inst RS pt3;
  16.405 +        val pt3_rev' = at_inst RS (pt_inst RS pt3_rev);
  16.406 +        val pt3_ax = PureThy.get_thm thy2 (Long_Name.map_base_name (fn s => "pt_" ^ s ^ "3") a);
  16.407 +      in List.take (map standard (split_conj_thm
  16.408 +        (Goal.prove_global thy2 [] []
  16.409 +          (augment_sort thy2 [pt_class_of thy2 a] (Logic.mk_implies
  16.410 +             (HOLogic.mk_Trueprop (Const ("Nominal.prm_eq",
  16.411 +                permT --> permT --> HOLogic.boolT) $ pi1 $ pi2),
  16.412 +              HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  16.413 +                (map (fn ((s, T), x) =>
  16.414 +                    let val perm = Const (s, permT --> T --> T)
  16.415 +                    in HOLogic.mk_eq
  16.416 +                      (perm $ pi1 $ Free (x, T),
  16.417 +                       perm $ pi2 $ Free (x, T))
  16.418 +                    end)
  16.419 +                  (perm_names ~~
  16.420 +                   map body_type perm_types ~~ perm_indnames))))))
  16.421 +           (fn _ => EVERY [indtac induction perm_indnames 1,
  16.422 +              ALLGOALS (asm_full_simp_tac (simpset_of thy2 addsimps [pt3', pt3_rev', pt3_ax]))]))),
  16.423 +         length new_type_names)
  16.424 +      end) atoms);
  16.425 +
  16.426 +    (**** prove pi1 \<bullet> (pi2 \<bullet> t) = (pi1 \<bullet> pi2) \<bullet> (pi1 \<bullet> t) ****)
  16.427 +
  16.428 +    val cp1 = PureThy.get_thm thy2 "cp1";
  16.429 +    val dj_cp = PureThy.get_thm thy2 "dj_cp";
  16.430 +    val pt_perm_compose = PureThy.get_thm thy2 "pt_perm_compose";
  16.431 +    val pt_perm_compose_rev = PureThy.get_thm thy2 "pt_perm_compose_rev";
  16.432 +    val dj_perm_perm_forget = PureThy.get_thm thy2 "dj_perm_perm_forget";
  16.433 +
  16.434 +    fun composition_instance name1 name2 thy =
  16.435 +      let
  16.436 +        val cp_class = cp_class_of thy name1 name2;
  16.437 +        val pt_class =
  16.438 +          if name1 = name2 then [pt_class_of thy name1]
  16.439 +          else [];
  16.440 +        val permT1 = mk_permT (Type (name1, []));
  16.441 +        val permT2 = mk_permT (Type (name2, []));
  16.442 +        val Ts = map body_type perm_types;
  16.443 +        val cp_inst = cp_inst_of thy name1 name2;
  16.444 +        val simps = simpset_of thy addsimps (perm_fun_def ::
  16.445 +          (if name1 <> name2 then
  16.446 +             let val dj = dj_thm_of thy name2 name1
  16.447 +             in [dj RS (cp_inst RS dj_cp), dj RS dj_perm_perm_forget] end
  16.448 +           else
  16.449 +             let
  16.450 +               val at_inst = at_inst_of thy name1;
  16.451 +               val pt_inst = pt_inst_of thy name1;
  16.452 +             in
  16.453 +               [cp_inst RS cp1 RS sym,
  16.454 +                at_inst RS (pt_inst RS pt_perm_compose) RS sym,
  16.455 +                at_inst RS (pt_inst RS pt_perm_compose_rev) RS sym]
  16.456 +            end))
  16.457 +        val sort = Sign.certify_sort thy (cp_class :: pt_class);
  16.458 +        val thms = split_conj_thm (Goal.prove_global thy [] []
  16.459 +          (augment_sort thy sort
  16.460 +            (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  16.461 +              (map (fn ((s, T), x) =>
  16.462 +                  let
  16.463 +                    val pi1 = Free ("pi1", permT1);
  16.464 +                    val pi2 = Free ("pi2", permT2);
  16.465 +                    val perm1 = Const (s, permT1 --> T --> T);
  16.466 +                    val perm2 = Const (s, permT2 --> T --> T);
  16.467 +                    val perm3 = Const ("Nominal.perm", permT1 --> permT2 --> permT2)
  16.468 +                  in HOLogic.mk_eq
  16.469 +                    (perm1 $ pi1 $ (perm2 $ pi2 $ Free (x, T)),
  16.470 +                     perm2 $ (perm3 $ pi1 $ pi2) $ (perm1 $ pi1 $ Free (x, T)))
  16.471 +                  end)
  16.472 +                (perm_names ~~ Ts ~~ perm_indnames)))))
  16.473 +          (fn _ => EVERY [indtac induction perm_indnames 1,
  16.474 +             ALLGOALS (asm_full_simp_tac simps)]))
  16.475 +      in
  16.476 +        fold (fn (s, tvs) => fn thy => AxClass.prove_arity
  16.477 +            (s, map (inter_sort thy sort o snd) tvs, [cp_class])
  16.478 +            (Class.intro_classes_tac [] THEN ALLGOALS (resolve_tac thms)) thy)
  16.479 +          (full_new_type_names' ~~ tyvars) thy
  16.480 +      end;
  16.481 +
  16.482 +    val (perm_thmss,thy3) = thy2 |>
  16.483 +      fold (fn name1 => fold (composition_instance name1) atoms) atoms |>
  16.484 +      fold (fn atom => fn thy =>
  16.485 +        let val pt_name = pt_class_of thy atom
  16.486 +        in
  16.487 +          fold (fn (s, tvs) => fn thy => AxClass.prove_arity
  16.488 +              (s, map (inter_sort thy [pt_name] o snd) tvs, [pt_name])
  16.489 +              (EVERY
  16.490 +                [Class.intro_classes_tac [],
  16.491 +                 resolve_tac perm_empty_thms 1,
  16.492 +                 resolve_tac perm_append_thms 1,
  16.493 +                 resolve_tac perm_eq_thms 1, assume_tac 1]) thy)
  16.494 +            (full_new_type_names' ~~ tyvars) thy
  16.495 +        end) atoms |>
  16.496 +      PureThy.add_thmss
  16.497 +        [((Binding.name (space_implode "_" new_type_names ^ "_unfolded_perm_eq"),
  16.498 +          unfolded_perm_eq_thms), [Simplifier.simp_add]),
  16.499 +         ((Binding.name (space_implode "_" new_type_names ^ "_perm_empty"),
  16.500 +          perm_empty_thms), [Simplifier.simp_add]),
  16.501 +         ((Binding.name (space_implode "_" new_type_names ^ "_perm_append"),
  16.502 +          perm_append_thms), [Simplifier.simp_add]),
  16.503 +         ((Binding.name (space_implode "_" new_type_names ^ "_perm_eq"),
  16.504 +          perm_eq_thms), [Simplifier.simp_add])];
  16.505 +
  16.506 +    (**** Define representing sets ****)
  16.507 +
  16.508 +    val _ = warning "representing sets";
  16.509 +
  16.510 +    val rep_set_names = DatatypeProp.indexify_names
  16.511 +      (map (fn (i, _) => name_of_typ (nth_dtyp i) ^ "_set") descr);
  16.512 +    val big_rep_name =
  16.513 +      space_implode "_" (DatatypeProp.indexify_names (List.mapPartial
  16.514 +        (fn (i, ("Nominal.noption", _, _)) => NONE
  16.515 +          | (i, _) => SOME (name_of_typ (nth_dtyp i))) descr)) ^ "_set";
  16.516 +    val _ = warning ("big_rep_name: " ^ big_rep_name);
  16.517 +
  16.518 +    fun strip_option (dtf as DtType ("fun", [dt, DtRec i])) =
  16.519 +          (case AList.lookup op = descr i of
  16.520 +             SOME ("Nominal.noption", _, [(_, [dt']), _]) =>
  16.521 +               apfst (cons dt) (strip_option dt')
  16.522 +           | _ => ([], dtf))
  16.523 +      | strip_option (DtType ("fun", [dt, DtType ("Nominal.noption", [dt'])])) =
  16.524 +          apfst (cons dt) (strip_option dt')
  16.525 +      | strip_option dt = ([], dt);
  16.526 +
  16.527 +    val dt_atomTs = distinct op = (map (typ_of_dtyp descr sorts)
  16.528 +      (List.concat (map (fn (_, (_, _, cs)) => List.concat
  16.529 +        (map (List.concat o map (fst o strip_option) o snd) cs)) descr)));
  16.530 +    val dt_atoms = map (fst o dest_Type) dt_atomTs;
  16.531 +
  16.532 +    fun make_intr s T (cname, cargs) =
  16.533 +      let
  16.534 +        fun mk_prem (dt, (j, j', prems, ts)) =
  16.535 +          let
  16.536 +            val (dts, dt') = strip_option dt;
  16.537 +            val (dts', dt'') = strip_dtyp dt';
  16.538 +            val Ts = map (typ_of_dtyp descr sorts) dts;
  16.539 +            val Us = map (typ_of_dtyp descr sorts) dts';
  16.540 +            val T = typ_of_dtyp descr sorts dt'';
  16.541 +            val free = mk_Free "x" (Us ---> T) j;
  16.542 +            val free' = app_bnds free (length Us);
  16.543 +            fun mk_abs_fun (T, (i, t)) =
  16.544 +              let val U = fastype_of t
  16.545 +              in (i + 1, Const ("Nominal.abs_fun", [T, U, T] --->
  16.546 +                Type ("Nominal.noption", [U])) $ mk_Free "y" T i $ t)
  16.547 +              end
  16.548 +          in (j + 1, j' + length Ts,
  16.549 +            case dt'' of
  16.550 +                DtRec k => list_all (map (pair "x") Us,
  16.551 +                  HOLogic.mk_Trueprop (Free (List.nth (rep_set_names, k),
  16.552 +                    T --> HOLogic.boolT) $ free')) :: prems
  16.553 +              | _ => prems,
  16.554 +            snd (List.foldr mk_abs_fun (j', free) Ts) :: ts)
  16.555 +          end;
  16.556 +
  16.557 +        val (_, _, prems, ts) = List.foldr mk_prem (1, 1, [], []) cargs;
  16.558 +        val concl = HOLogic.mk_Trueprop (Free (s, T --> HOLogic.boolT) $
  16.559 +          list_comb (Const (cname, map fastype_of ts ---> T), ts))
  16.560 +      in Logic.list_implies (prems, concl)
  16.561 +      end;
  16.562 +
  16.563 +    val (intr_ts, (rep_set_names', recTs')) =
  16.564 +      apfst List.concat (apsnd ListPair.unzip (ListPair.unzip (List.mapPartial
  16.565 +        (fn ((_, ("Nominal.noption", _, _)), _) => NONE
  16.566 +          | ((i, (_, _, constrs)), rep_set_name) =>
  16.567 +              let val T = nth_dtyp i
  16.568 +              in SOME (map (make_intr rep_set_name T) constrs,
  16.569 +                (rep_set_name, T))
  16.570 +              end)
  16.571 +                (descr ~~ rep_set_names))));
  16.572 +    val rep_set_names'' = map (Sign.full_bname thy3) rep_set_names';
  16.573 +
  16.574 +    val ({raw_induct = rep_induct, intrs = rep_intrs, ...}, thy4) =
  16.575 +        Inductive.add_inductive_global (serial_string ())
  16.576 +          {quiet_mode = false, verbose = false, kind = Thm.internalK,
  16.577 +           alt_name = Binding.name big_rep_name, coind = false, no_elim = true, no_ind = false,
  16.578 +           skip_mono = true, fork_mono = false}
  16.579 +          (map (fn (s, T) => ((Binding.name s, T --> HOLogic.boolT), NoSyn))
  16.580 +             (rep_set_names' ~~ recTs'))
  16.581 +          [] (map (fn x => (Attrib.empty_binding, x)) intr_ts) [] thy3;
  16.582 +
  16.583 +    (**** Prove that representing set is closed under permutation ****)
  16.584 +
  16.585 +    val _ = warning "proving closure under permutation...";
  16.586 +
  16.587 +    val abs_perm = PureThy.get_thms thy4 "abs_perm";
  16.588 +
  16.589 +    val perm_indnames' = List.mapPartial
  16.590 +      (fn (x, (_, ("Nominal.noption", _, _))) => NONE | (x, _) => SOME x)
  16.591 +      (perm_indnames ~~ descr);
  16.592 +
  16.593 +    fun mk_perm_closed name = map (fn th => standard (th RS mp))
  16.594 +      (List.take (split_conj_thm (Goal.prove_global thy4 [] []
  16.595 +        (augment_sort thy4
  16.596 +          (pt_class_of thy4 name :: map (cp_class_of thy4 name) (dt_atoms \ name))
  16.597 +          (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map
  16.598 +            (fn ((s, T), x) =>
  16.599 +               let
  16.600 +                 val S = Const (s, T --> HOLogic.boolT);
  16.601 +                 val permT = mk_permT (Type (name, []))
  16.602 +               in HOLogic.mk_imp (S $ Free (x, T),
  16.603 +                 S $ (Const ("Nominal.perm", permT --> T --> T) $
  16.604 +                   Free ("pi", permT) $ Free (x, T)))
  16.605 +               end) (rep_set_names'' ~~ recTs' ~~ perm_indnames')))))
  16.606 +        (fn _ => EVERY
  16.607 +           [indtac rep_induct [] 1,
  16.608 +            ALLGOALS (simp_tac (simpset_of thy4 addsimps
  16.609 +              (symmetric perm_fun_def :: abs_perm))),
  16.610 +            ALLGOALS (resolve_tac rep_intrs THEN_ALL_NEW assume_tac)])),
  16.611 +        length new_type_names));
  16.612 +
  16.613 +    val perm_closed_thmss = map mk_perm_closed atoms;
  16.614 +
  16.615 +    (**** typedef ****)
  16.616 +
  16.617 +    val _ = warning "defining type...";
  16.618 +
  16.619 +    val (typedefs, thy6) =
  16.620 +      thy4
  16.621 +      |> fold_map (fn ((((name, mx), tvs), (cname, U)), name') => fn thy =>
  16.622 +          Typedef.add_typedef false (SOME (Binding.name name'))
  16.623 +            (Binding.name name, map fst tvs, mx)
  16.624 +            (Const ("Collect", (U --> HOLogic.boolT) --> HOLogic.mk_setT U) $
  16.625 +               Const (cname, U --> HOLogic.boolT)) NONE
  16.626 +            (rtac exI 1 THEN rtac CollectI 1 THEN
  16.627 +              QUIET_BREADTH_FIRST (has_fewer_prems 1)
  16.628 +              (resolve_tac rep_intrs 1)) thy |> (fn ((_, r), thy) =>
  16.629 +        let
  16.630 +          val permT = mk_permT
  16.631 +            (TFree (Name.variant (map fst tvs) "'a", HOLogic.typeS));
  16.632 +          val pi = Free ("pi", permT);
  16.633 +          val T = Type (Sign.intern_type thy name, map TFree tvs);
  16.634 +        in apfst (pair r o hd)
  16.635 +          (PureThy.add_defs_unchecked true [((Binding.name ("prm_" ^ name ^ "_def"), Logic.mk_equals
  16.636 +            (Const ("Nominal.perm", permT --> T --> T) $ pi $ Free ("x", T),
  16.637 +             Const (Sign.intern_const thy ("Abs_" ^ name), U --> T) $
  16.638 +               (Const ("Nominal.perm", permT --> U --> U) $ pi $
  16.639 +                 (Const (Sign.intern_const thy ("Rep_" ^ name), T --> U) $
  16.640 +                   Free ("x", T))))), [])] thy)
  16.641 +        end))
  16.642 +          (types_syntax ~~ tyvars ~~
  16.643 +            List.take (rep_set_names'' ~~ recTs', length new_type_names) ~~
  16.644 +            new_type_names);
  16.645 +
  16.646 +    val perm_defs = map snd typedefs;
  16.647 +    val Abs_inverse_thms = map (collect_simp o #Abs_inverse o fst) typedefs;
  16.648 +    val Rep_inverse_thms = map (#Rep_inverse o fst) typedefs;
  16.649 +    val Rep_thms = map (collect_simp o #Rep o fst) typedefs;
  16.650 +
  16.651 +
  16.652 +    (** prove that new types are in class pt_<name> **)
  16.653 +
  16.654 +    val _ = warning "prove that new types are in class pt_<name> ...";
  16.655 +
  16.656 +    fun pt_instance (atom, perm_closed_thms) =
  16.657 +      fold (fn ((((((Abs_inverse, Rep_inverse), Rep),
  16.658 +        perm_def), name), tvs), perm_closed) => fn thy =>
  16.659 +          let
  16.660 +            val pt_class = pt_class_of thy atom;
  16.661 +            val sort = Sign.certify_sort thy
  16.662 +              (pt_class :: map (cp_class_of thy atom) (dt_atoms \ atom))
  16.663 +          in AxClass.prove_arity
  16.664 +            (Sign.intern_type thy name,
  16.665 +              map (inter_sort thy sort o snd) tvs, [pt_class])
  16.666 +            (EVERY [Class.intro_classes_tac [],
  16.667 +              rewrite_goals_tac [perm_def],
  16.668 +              asm_full_simp_tac (simpset_of thy addsimps [Rep_inverse]) 1,
  16.669 +              asm_full_simp_tac (simpset_of thy addsimps
  16.670 +                [Rep RS perm_closed RS Abs_inverse]) 1,
  16.671 +              asm_full_simp_tac (HOL_basic_ss addsimps [PureThy.get_thm thy
  16.672 +                ("pt_" ^ Long_Name.base_name atom ^ "3")]) 1]) thy
  16.673 +          end)
  16.674 +        (Abs_inverse_thms ~~ Rep_inverse_thms ~~ Rep_thms ~~ perm_defs ~~
  16.675 +           new_type_names ~~ tyvars ~~ perm_closed_thms);
  16.676 +
  16.677 +
  16.678 +    (** prove that new types are in class cp_<name1>_<name2> **)
  16.679 +
  16.680 +    val _ = warning "prove that new types are in class cp_<name1>_<name2> ...";
  16.681 +
  16.682 +    fun cp_instance (atom1, perm_closed_thms1) (atom2, perm_closed_thms2) thy =
  16.683 +      let
  16.684 +        val cp_class = cp_class_of thy atom1 atom2;
  16.685 +        val sort = Sign.certify_sort thy
  16.686 +          (pt_class_of thy atom1 :: map (cp_class_of thy atom1) (dt_atoms \ atom1) @
  16.687 +           (if atom1 = atom2 then [cp_class_of thy atom1 atom1] else
  16.688 +            pt_class_of thy atom2 :: map (cp_class_of thy atom2) (dt_atoms \ atom2)));
  16.689 +        val cp1' = cp_inst_of thy atom1 atom2 RS cp1
  16.690 +      in fold (fn ((((((Abs_inverse, Rep),
  16.691 +        perm_def), name), tvs), perm_closed1), perm_closed2) => fn thy =>
  16.692 +          AxClass.prove_arity
  16.693 +            (Sign.intern_type thy name,
  16.694 +              map (inter_sort thy sort o snd) tvs, [cp_class])
  16.695 +            (EVERY [Class.intro_classes_tac [],
  16.696 +              rewrite_goals_tac [perm_def],
  16.697 +              asm_full_simp_tac (simpset_of thy addsimps
  16.698 +                ((Rep RS perm_closed1 RS Abs_inverse) ::
  16.699 +                 (if atom1 = atom2 then []
  16.700 +                  else [Rep RS perm_closed2 RS Abs_inverse]))) 1,
  16.701 +              cong_tac 1,
  16.702 +              rtac refl 1,
  16.703 +              rtac cp1' 1]) thy)
  16.704 +        (Abs_inverse_thms ~~ Rep_thms ~~ perm_defs ~~ new_type_names ~~
  16.705 +           tyvars ~~ perm_closed_thms1 ~~ perm_closed_thms2) thy
  16.706 +      end;
  16.707 +
  16.708 +    val thy7 = fold (fn x => fn thy => thy |>
  16.709 +      pt_instance x |>
  16.710 +      fold (cp_instance x) (atoms ~~ perm_closed_thmss))
  16.711 +        (atoms ~~ perm_closed_thmss) thy6;
  16.712 +
  16.713 +    (**** constructors ****)
  16.714 +
  16.715 +    fun mk_abs_fun (x, t) =
  16.716 +      let
  16.717 +        val T = fastype_of x;
  16.718 +        val U = fastype_of t
  16.719 +      in
  16.720 +        Const ("Nominal.abs_fun", T --> U --> T -->
  16.721 +          Type ("Nominal.noption", [U])) $ x $ t
  16.722 +      end;
  16.723 +
  16.724 +    val (ty_idxs, _) = List.foldl
  16.725 +      (fn ((i, ("Nominal.noption", _, _)), p) => p
  16.726 +        | ((i, _), (ty_idxs, j)) => (ty_idxs @ [(i, j)], j + 1)) ([], 0) descr;
  16.727 +
  16.728 +    fun reindex (DtType (s, dts)) = DtType (s, map reindex dts)
  16.729 +      | reindex (DtRec i) = DtRec (the (AList.lookup op = ty_idxs i))
  16.730 +      | reindex dt = dt;
  16.731 +
  16.732 +    fun strip_suffix i s = implode (List.take (explode s, size s - i));
  16.733 +
  16.734 +    (** strips the "_Rep" in type names *)
  16.735 +    fun strip_nth_name i s =
  16.736 +      let val xs = Long_Name.explode s;
  16.737 +      in Long_Name.implode (Library.nth_map (length xs - i) (strip_suffix 4) xs) end;
  16.738 +
  16.739 +    val (descr'', ndescr) = ListPair.unzip (map_filter
  16.740 +      (fn (i, ("Nominal.noption", _, _)) => NONE
  16.741 +        | (i, (s, dts, constrs)) =>
  16.742 +             let
  16.743 +               val SOME index = AList.lookup op = ty_idxs i;
  16.744 +               val (constrs2, constrs1) =
  16.745 +                 map_split (fn (cname, cargs) =>
  16.746 +                   apsnd (pair (strip_nth_name 2 (strip_nth_name 1 cname)))
  16.747 +                   (fold_map (fn dt => fn dts =>
  16.748 +                     let val (dts', dt') = strip_option dt
  16.749 +                     in ((length dts, length dts'), dts @ dts' @ [reindex dt']) end)
  16.750 +                       cargs [])) constrs
  16.751 +             in SOME ((index, (strip_nth_name 1 s,  map reindex dts, constrs1)),
  16.752 +               (index, constrs2))
  16.753 +             end) descr);
  16.754 +
  16.755 +    val (descr1, descr2) = chop (length new_type_names) descr'';
  16.756 +    val descr' = [descr1, descr2];
  16.757 +
  16.758 +    fun partition_cargs idxs xs = map (fn (i, j) =>
  16.759 +      (List.take (List.drop (xs, i), j), List.nth (xs, i + j))) idxs;
  16.760 +
  16.761 +    val pdescr = map (fn ((i, (s, dts, constrs)), (_, idxss)) => (i, (s, dts,
  16.762 +      map (fn ((cname, cargs), idxs) => (cname, partition_cargs idxs cargs))
  16.763 +        (constrs ~~ idxss)))) (descr'' ~~ ndescr);
  16.764 +
  16.765 +    fun nth_dtyp' i = typ_of_dtyp descr'' sorts (DtRec i);
  16.766 +
  16.767 +    val rep_names = map (fn s =>
  16.768 +      Sign.intern_const thy7 ("Rep_" ^ s)) new_type_names;
  16.769 +    val abs_names = map (fn s =>
  16.770 +      Sign.intern_const thy7 ("Abs_" ^ s)) new_type_names;
  16.771 +
  16.772 +    val recTs = get_rec_types descr'' sorts;
  16.773 +    val newTs' = Library.take (length new_type_names, recTs');
  16.774 +    val newTs = Library.take (length new_type_names, recTs);
  16.775 +
  16.776 +    val full_new_type_names = map (Sign.full_bname thy) new_type_names;
  16.777 +
  16.778 +    fun make_constr_def tname T T' ((thy, defs, eqns),
  16.779 +        (((cname_rep, _), (cname, cargs)), (cname', mx))) =
  16.780 +      let
  16.781 +        fun constr_arg ((dts, dt), (j, l_args, r_args)) =
  16.782 +          let
  16.783 +            val xs = map (fn (dt, i) => mk_Free "x" (typ_of_dtyp descr'' sorts dt) i)
  16.784 +              (dts ~~ (j upto j + length dts - 1))
  16.785 +            val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts)
  16.786 +          in
  16.787 +            (j + length dts + 1,
  16.788 +             xs @ x :: l_args,
  16.789 +             List.foldr mk_abs_fun
  16.790 +               (case dt of
  16.791 +                  DtRec k => if k < length new_type_names then
  16.792 +                      Const (List.nth (rep_names, k), typ_of_dtyp descr'' sorts dt -->
  16.793 +                        typ_of_dtyp descr sorts dt) $ x
  16.794 +                    else error "nested recursion not (yet) supported"
  16.795 +                | _ => x) xs :: r_args)
  16.796 +          end
  16.797 +
  16.798 +        val (_, l_args, r_args) = List.foldr constr_arg (1, [], []) cargs;
  16.799 +        val abs_name = Sign.intern_const thy ("Abs_" ^ tname);
  16.800 +        val rep_name = Sign.intern_const thy ("Rep_" ^ tname);
  16.801 +        val constrT = map fastype_of l_args ---> T;
  16.802 +        val lhs = list_comb (Const (cname, constrT), l_args);
  16.803 +        val rhs = list_comb (Const (cname_rep, map fastype_of r_args ---> T'), r_args);
  16.804 +        val def = Logic.mk_equals (lhs, Const (abs_name, T' --> T) $ rhs);
  16.805 +        val eqn = HOLogic.mk_Trueprop (HOLogic.mk_eq
  16.806 +          (Const (rep_name, T --> T') $ lhs, rhs));
  16.807 +        val def_name = (Long_Name.base_name cname) ^ "_def";
  16.808 +        val ([def_thm], thy') = thy |>
  16.809 +          Sign.add_consts_i [(Binding.name cname', constrT, mx)] |>
  16.810 +          (PureThy.add_defs false o map Thm.no_attributes) [(Binding.name def_name, def)]
  16.811 +      in (thy', defs @ [def_thm], eqns @ [eqn]) end;
  16.812 +
  16.813 +    fun dt_constr_defs ((thy, defs, eqns, dist_lemmas), ((((((_, (_, _, constrs)),
  16.814 +        (_, (_, _, constrs'))), tname), T), T'), constr_syntax)) =
  16.815 +      let
  16.816 +        val rep_const = cterm_of thy
  16.817 +          (Const (Sign.intern_const thy ("Rep_" ^ tname), T --> T'));
  16.818 +        val dist = standard (cterm_instantiate [(cterm_of thy distinct_f, rep_const)] distinct_lemma);
  16.819 +        val (thy', defs', eqns') = Library.foldl (make_constr_def tname T T')
  16.820 +          ((Sign.add_path tname thy, defs, []), constrs ~~ constrs' ~~ constr_syntax)
  16.821 +      in
  16.822 +        (parent_path (#flat_names config) thy', defs', eqns @ [eqns'], dist_lemmas @ [dist])
  16.823 +      end;
  16.824 +
  16.825 +    val (thy8, constr_defs, constr_rep_eqns, dist_lemmas) = Library.foldl dt_constr_defs
  16.826 +      ((thy7, [], [], []), List.take (descr, length new_type_names) ~~
  16.827 +        List.take (pdescr, length new_type_names) ~~
  16.828 +        new_type_names ~~ newTs ~~ newTs' ~~ constr_syntax);
  16.829 +
  16.830 +    val abs_inject_thms = map (collect_simp o #Abs_inject o fst) typedefs
  16.831 +    val rep_inject_thms = map (#Rep_inject o fst) typedefs
  16.832 +
  16.833 +    (* prove theorem  Rep_i (Constr_j ...) = Constr'_j ...  *)
  16.834 +
  16.835 +    fun prove_constr_rep_thm eqn =
  16.836 +      let
  16.837 +        val inj_thms = map (fn r => r RS iffD1) abs_inject_thms;
  16.838 +        val rewrites = constr_defs @ map mk_meta_eq Rep_inverse_thms
  16.839 +      in Goal.prove_global thy8 [] [] eqn (fn _ => EVERY
  16.840 +        [resolve_tac inj_thms 1,
  16.841 +         rewrite_goals_tac rewrites,
  16.842 +         rtac refl 3,
  16.843 +         resolve_tac rep_intrs 2,
  16.844 +         REPEAT (resolve_tac Rep_thms 1)])
  16.845 +      end;
  16.846 +
  16.847 +    val constr_rep_thmss = map (map prove_constr_rep_thm) constr_rep_eqns;
  16.848 +
  16.849 +    (* prove theorem  pi \<bullet> Rep_i x = Rep_i (pi \<bullet> x) *)
  16.850 +
  16.851 +    fun prove_perm_rep_perm (atom, perm_closed_thms) = map (fn th =>
  16.852 +      let
  16.853 +        val _ $ (_ $ (Rep $ x)) = Logic.unvarify (prop_of th);
  16.854 +        val Type ("fun", [T, U]) = fastype_of Rep;
  16.855 +        val permT = mk_permT (Type (atom, []));
  16.856 +        val pi = Free ("pi", permT);
  16.857 +      in
  16.858 +        Goal.prove_global thy8 [] []
  16.859 +          (augment_sort thy8
  16.860 +            (pt_class_of thy8 atom :: map (cp_class_of thy8 atom) (dt_atoms \ atom))
  16.861 +            (HOLogic.mk_Trueprop (HOLogic.mk_eq
  16.862 +              (Const ("Nominal.perm", permT --> U --> U) $ pi $ (Rep $ x),
  16.863 +               Rep $ (Const ("Nominal.perm", permT --> T --> T) $ pi $ x)))))
  16.864 +          (fn _ => simp_tac (HOL_basic_ss addsimps (perm_defs @ Abs_inverse_thms @
  16.865 +            perm_closed_thms @ Rep_thms)) 1)
  16.866 +      end) Rep_thms;
  16.867 +
  16.868 +    val perm_rep_perm_thms = List.concat (map prove_perm_rep_perm
  16.869 +      (atoms ~~ perm_closed_thmss));
  16.870 +
  16.871 +    (* prove distinctness theorems *)
  16.872 +
  16.873 +    val distinct_props = DatatypeProp.make_distincts descr' sorts;
  16.874 +    val dist_rewrites = map2 (fn rep_thms => fn dist_lemma =>
  16.875 +      dist_lemma :: rep_thms @ [In0_eq, In1_eq, In0_not_In1, In1_not_In0])
  16.876 +        constr_rep_thmss dist_lemmas;
  16.877 +
  16.878 +    fun prove_distinct_thms _ (_, []) = []
  16.879 +      | prove_distinct_thms (p as (rep_thms, dist_lemma)) (k, t :: ts) =
  16.880 +          let
  16.881 +            val dist_thm = Goal.prove_global thy8 [] [] t (fn _ =>
  16.882 +              simp_tac (simpset_of thy8 addsimps (dist_lemma :: rep_thms)) 1)
  16.883 +          in dist_thm :: standard (dist_thm RS not_sym) ::
  16.884 +            prove_distinct_thms p (k, ts)
  16.885 +          end;
  16.886 +
  16.887 +    val distinct_thms = map2 prove_distinct_thms
  16.888 +      (constr_rep_thmss ~~ dist_lemmas) distinct_props;
  16.889 +
  16.890 +    (** prove equations for permutation functions **)
  16.891 +
  16.892 +    val perm_simps' = map (fn (((i, (_, _, constrs)), tname), constr_rep_thms) =>
  16.893 +      let val T = nth_dtyp' i
  16.894 +      in List.concat (map (fn (atom, perm_closed_thms) =>
  16.895 +          map (fn ((cname, dts), constr_rep_thm) =>
  16.896 +        let
  16.897 +          val cname = Sign.intern_const thy8
  16.898 +            (Long_Name.append tname (Long_Name.base_name cname));
  16.899 +          val permT = mk_permT (Type (atom, []));
  16.900 +          val pi = Free ("pi", permT);
  16.901 +
  16.902 +          fun perm t =
  16.903 +            let val T = fastype_of t
  16.904 +            in Const ("Nominal.perm", permT --> T --> T) $ pi $ t end;
  16.905 +
  16.906 +          fun constr_arg ((dts, dt), (j, l_args, r_args)) =
  16.907 +            let
  16.908 +              val Ts = map (typ_of_dtyp descr'' sorts) dts;
  16.909 +              val xs = map (fn (T, i) => mk_Free "x" T i)
  16.910 +                (Ts ~~ (j upto j + length dts - 1))
  16.911 +              val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts)
  16.912 +            in
  16.913 +              (j + length dts + 1,
  16.914 +               xs @ x :: l_args,
  16.915 +               map perm (xs @ [x]) @ r_args)
  16.916 +            end
  16.917 +
  16.918 +          val (_, l_args, r_args) = List.foldr constr_arg (1, [], []) dts;
  16.919 +          val c = Const (cname, map fastype_of l_args ---> T)
  16.920 +        in
  16.921 +          Goal.prove_global thy8 [] []
  16.922 +            (augment_sort thy8
  16.923 +              (pt_class_of thy8 atom :: map (cp_class_of thy8 atom) (dt_atoms \ atom))
  16.924 +              (HOLogic.mk_Trueprop (HOLogic.mk_eq
  16.925 +                (perm (list_comb (c, l_args)), list_comb (c, r_args)))))
  16.926 +            (fn _ => EVERY
  16.927 +              [simp_tac (simpset_of thy8 addsimps (constr_rep_thm :: perm_defs)) 1,
  16.928 +               simp_tac (HOL_basic_ss addsimps (Rep_thms @ Abs_inverse_thms @
  16.929 +                 constr_defs @ perm_closed_thms)) 1,
  16.930 +               TRY (simp_tac (HOL_basic_ss addsimps
  16.931 +                 (symmetric perm_fun_def :: abs_perm)) 1),
  16.932 +               TRY (simp_tac (HOL_basic_ss addsimps
  16.933 +                 (perm_fun_def :: perm_defs @ Rep_thms @ Abs_inverse_thms @
  16.934 +                    perm_closed_thms)) 1)])
  16.935 +        end) (constrs ~~ constr_rep_thms)) (atoms ~~ perm_closed_thmss))
  16.936 +      end) (List.take (pdescr, length new_type_names) ~~ new_type_names ~~ constr_rep_thmss);
  16.937 +
  16.938 +    (** prove injectivity of constructors **)
  16.939 +
  16.940 +    val rep_inject_thms' = map (fn th => th RS sym) rep_inject_thms;
  16.941 +    val alpha = PureThy.get_thms thy8 "alpha";
  16.942 +    val abs_fresh = PureThy.get_thms thy8 "abs_fresh";
  16.943 +
  16.944 +    val pt_cp_sort =
  16.945 +      map (pt_class_of thy8) dt_atoms @
  16.946 +      maps (fn s => map (cp_class_of thy8 s) (dt_atoms \ s)) dt_atoms;
  16.947 +
  16.948 +    val inject_thms = map (fn (((i, (_, _, constrs)), tname), constr_rep_thms) =>
  16.949 +      let val T = nth_dtyp' i
  16.950 +      in List.mapPartial (fn ((cname, dts), constr_rep_thm) =>
  16.951 +        if null dts then NONE else SOME
  16.952 +        let
  16.953 +          val cname = Sign.intern_const thy8
  16.954 +            (Long_Name.append tname (Long_Name.base_name cname));
  16.955 +
  16.956 +          fun make_inj ((dts, dt), (j, args1, args2, eqs)) =
  16.957 +            let
  16.958 +              val Ts_idx = map (typ_of_dtyp descr'' sorts) dts ~~ (j upto j + length dts - 1);
  16.959 +              val xs = map (fn (T, i) => mk_Free "x" T i) Ts_idx;
  16.960 +              val ys = map (fn (T, i) => mk_Free "y" T i) Ts_idx;
  16.961 +              val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts);
  16.962 +              val y = mk_Free "y" (typ_of_dtyp descr'' sorts dt) (j + length dts)
  16.963 +            in
  16.964 +              (j + length dts + 1,
  16.965 +               xs @ (x :: args1), ys @ (y :: args2),
  16.966 +               HOLogic.mk_eq
  16.967 +                 (List.foldr mk_abs_fun x xs, List.foldr mk_abs_fun y ys) :: eqs)
  16.968 +            end;
  16.969 +
  16.970 +          val (_, args1, args2, eqs) = List.foldr make_inj (1, [], [], []) dts;
  16.971 +          val Ts = map fastype_of args1;
  16.972 +          val c = Const (cname, Ts ---> T)
  16.973 +        in
  16.974 +          Goal.prove_global thy8 [] []
  16.975 +            (augment_sort thy8 pt_cp_sort
  16.976 +              (HOLogic.mk_Trueprop (HOLogic.mk_eq
  16.977 +                (HOLogic.mk_eq (list_comb (c, args1), list_comb (c, args2)),
  16.978 +                 foldr1 HOLogic.mk_conj eqs))))
  16.979 +            (fn _ => EVERY
  16.980 +               [asm_full_simp_tac (simpset_of thy8 addsimps (constr_rep_thm ::
  16.981 +                  rep_inject_thms')) 1,
  16.982 +                TRY (asm_full_simp_tac (HOL_basic_ss addsimps (fresh_def :: supp_def ::
  16.983 +                  alpha @ abs_perm @ abs_fresh @ rep_inject_thms @
  16.984 +                  perm_rep_perm_thms)) 1)])
  16.985 +        end) (constrs ~~ constr_rep_thms)
  16.986 +      end) (List.take (pdescr, length new_type_names) ~~ new_type_names ~~ constr_rep_thmss);
  16.987 +
  16.988 +    (** equations for support and freshness **)
  16.989 +
  16.990 +    val (supp_thms, fresh_thms) = ListPair.unzip (map ListPair.unzip
  16.991 +      (map (fn ((((i, (_, _, constrs)), tname), inject_thms'), perm_thms') =>
  16.992 +      let val T = nth_dtyp' i
  16.993 +      in List.concat (map (fn (cname, dts) => map (fn atom =>
  16.994 +        let
  16.995 +          val cname = Sign.intern_const thy8
  16.996 +            (Long_Name.append tname (Long_Name.base_name cname));
  16.997 +          val atomT = Type (atom, []);
  16.998 +
  16.999 +          fun process_constr ((dts, dt), (j, args1, args2)) =
 16.1000 +            let
 16.1001 +              val Ts_idx = map (typ_of_dtyp descr'' sorts) dts ~~ (j upto j + length dts - 1);
 16.1002 +              val xs = map (fn (T, i) => mk_Free "x" T i) Ts_idx;
 16.1003 +              val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts)
 16.1004 +            in
 16.1005 +              (j + length dts + 1,
 16.1006 +               xs @ (x :: args1), List.foldr mk_abs_fun x xs :: args2)
 16.1007 +            end;
 16.1008 +
 16.1009 +          val (_, args1, args2) = List.foldr process_constr (1, [], []) dts;
 16.1010 +          val Ts = map fastype_of args1;
 16.1011 +          val c = list_comb (Const (cname, Ts ---> T), args1);
 16.1012 +          fun supp t =
 16.1013 +            Const ("Nominal.supp", fastype_of t --> HOLogic.mk_setT atomT) $ t;
 16.1014 +          fun fresh t = fresh_const atomT (fastype_of t) $ Free ("a", atomT) $ t;
 16.1015 +          val supp_thm = Goal.prove_global thy8 [] []
 16.1016 +            (augment_sort thy8 pt_cp_sort
 16.1017 +              (HOLogic.mk_Trueprop (HOLogic.mk_eq
 16.1018 +                (supp c,
 16.1019 +                 if null dts then HOLogic.mk_set atomT []
 16.1020 +                 else foldr1 (HOLogic.mk_binop @{const_name Un}) (map supp args2)))))
 16.1021 +            (fn _ =>
 16.1022 +              simp_tac (HOL_basic_ss addsimps (supp_def ::
 16.1023 +                 Un_assoc :: de_Morgan_conj :: Collect_disj_eq :: finite_Un ::
 16.1024 +                 symmetric empty_def :: finite_emptyI :: simp_thms @
 16.1025 +                 abs_perm @ abs_fresh @ inject_thms' @ perm_thms')) 1)
 16.1026 +        in
 16.1027 +          (supp_thm,
 16.1028 +           Goal.prove_global thy8 [] [] (augment_sort thy8 pt_cp_sort
 16.1029 +             (HOLogic.mk_Trueprop (HOLogic.mk_eq
 16.1030 +               (fresh c,
 16.1031 +                if null dts then HOLogic.true_const
 16.1032 +                else foldr1 HOLogic.mk_conj (map fresh args2)))))
 16.1033 +             (fn _ =>
 16.1034 +               simp_tac (HOL_ss addsimps [Un_iff, empty_iff, fresh_def, supp_thm]) 1))
 16.1035 +        end) atoms) constrs)
 16.1036 +      end) (List.take (pdescr, length new_type_names) ~~ new_type_names ~~ inject_thms ~~ perm_simps')));
 16.1037 +
 16.1038 +    (**** weak induction theorem ****)
 16.1039 +
 16.1040 +    fun mk_indrule_lemma ((prems, concls), (((i, _), T), U)) =
 16.1041 +      let
 16.1042 +        val Rep_t = Const (List.nth (rep_names, i), T --> U) $
 16.1043 +          mk_Free "x" T i;
 16.1044 +
 16.1045 +        val Abs_t =  Const (List.nth (abs_names, i), U --> T)
 16.1046 +
 16.1047 +      in (prems @ [HOLogic.imp $
 16.1048 +            (Const (List.nth (rep_set_names'', i), U --> HOLogic.boolT) $ Rep_t) $
 16.1049 +              (mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ (Abs_t $ Rep_t))],
 16.1050 +          concls @ [mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ mk_Free "x" T i])
 16.1051 +      end;
 16.1052 +
 16.1053 +    val (indrule_lemma_prems, indrule_lemma_concls) =
 16.1054 +      Library.foldl mk_indrule_lemma (([], []), (descr'' ~~ recTs ~~ recTs'));
 16.1055 +
 16.1056 +    val indrule_lemma = Goal.prove_global thy8 [] []
 16.1057 +      (Logic.mk_implies
 16.1058 +        (HOLogic.mk_Trueprop (mk_conj indrule_lemma_prems),
 16.1059 +         HOLogic.mk_Trueprop (mk_conj indrule_lemma_concls))) (fn _ => EVERY
 16.1060 +           [REPEAT (etac conjE 1),
 16.1061 +            REPEAT (EVERY
 16.1062 +              [TRY (rtac conjI 1), full_simp_tac (HOL_basic_ss addsimps Rep_inverse_thms) 1,
 16.1063 +               etac mp 1, resolve_tac Rep_thms 1])]);
 16.1064 +
 16.1065 +    val Ps = map head_of (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of indrule_lemma)));
 16.1066 +    val frees = if length Ps = 1 then [Free ("P", snd (dest_Var (hd Ps)))] else
 16.1067 +      map (Free o apfst fst o dest_Var) Ps;
 16.1068 +    val indrule_lemma' = cterm_instantiate
 16.1069 +      (map (cterm_of thy8) Ps ~~ map (cterm_of thy8) frees) indrule_lemma;
 16.1070 +
 16.1071 +    val Abs_inverse_thms' = map (fn r => r RS subst) Abs_inverse_thms;
 16.1072 +
 16.1073 +    val dt_induct_prop = DatatypeProp.make_ind descr' sorts;
 16.1074 +    val dt_induct = Goal.prove_global thy8 []
 16.1075 +      (Logic.strip_imp_prems dt_induct_prop) (Logic.strip_imp_concl dt_induct_prop)
 16.1076 +      (fn {prems, ...} => EVERY
 16.1077 +        [rtac indrule_lemma' 1,
 16.1078 +         (indtac rep_induct [] THEN_ALL_NEW ObjectLogic.atomize_prems_tac) 1,
 16.1079 +         EVERY (map (fn (prem, r) => (EVERY
 16.1080 +           [REPEAT (eresolve_tac Abs_inverse_thms' 1),
 16.1081 +            simp_tac (HOL_basic_ss addsimps [symmetric r]) 1,
 16.1082 +            DEPTH_SOLVE_1 (ares_tac [prem] 1 ORELSE etac allE 1)]))
 16.1083 +                (prems ~~ constr_defs))]);
 16.1084 +
 16.1085 +    val case_names_induct = mk_case_names_induct descr'';
 16.1086 +
 16.1087 +    (**** prove that new datatypes have finite support ****)
 16.1088 +
 16.1089 +    val _ = warning "proving finite support for the new datatype";
 16.1090 +
 16.1091 +    val indnames = DatatypeProp.make_tnames recTs;
 16.1092 +
 16.1093 +    val abs_supp = PureThy.get_thms thy8 "abs_supp";
 16.1094 +    val supp_atm = PureThy.get_thms thy8 "supp_atm";
 16.1095 +
 16.1096 +    val finite_supp_thms = map (fn atom =>
 16.1097 +      let val atomT = Type (atom, [])
 16.1098 +      in map standard (List.take
 16.1099 +        (split_conj_thm (Goal.prove_global thy8 [] []
 16.1100 +           (augment_sort thy8 (fs_class_of thy8 atom :: pt_cp_sort)
 16.1101 +             (HOLogic.mk_Trueprop
 16.1102 +               (foldr1 HOLogic.mk_conj (map (fn (s, T) =>
 16.1103 +                 Const ("Finite_Set.finite", HOLogic.mk_setT atomT --> HOLogic.boolT) $
 16.1104 +                   (Const ("Nominal.supp", T --> HOLogic.mk_setT atomT) $ Free (s, T)))
 16.1105 +                   (indnames ~~ recTs)))))
 16.1106 +           (fn _ => indtac dt_induct indnames 1 THEN
 16.1107 +            ALLGOALS (asm_full_simp_tac (simpset_of thy8 addsimps
 16.1108 +              (abs_supp @ supp_atm @
 16.1109 +               PureThy.get_thms thy8 ("fs_" ^ Long_Name.base_name atom ^ "1") @
 16.1110 +               List.concat supp_thms))))),
 16.1111 +         length new_type_names))
 16.1112 +      end) atoms;
 16.1113 +
 16.1114 +    val simp_atts = replicate (length new_type_names) [Simplifier.simp_add];
 16.1115 +
 16.1116 +	(* Function to add both the simp and eqvt attributes *)
 16.1117 +        (* These two attributes are duplicated on all the types in the mutual nominal datatypes *)
 16.1118 +
 16.1119 +    val simp_eqvt_atts = replicate (length new_type_names) [Simplifier.simp_add, NominalThmDecls.eqvt_add];
 16.1120 + 
 16.1121 +    val (_, thy9) = thy8 |>
 16.1122 +      Sign.add_path big_name |>
 16.1123 +      PureThy.add_thms [((Binding.name "induct", dt_induct), [case_names_induct])] ||>>
 16.1124 +      PureThy.add_thmss [((Binding.name "inducts", projections dt_induct), [case_names_induct])] ||>
 16.1125 +      Sign.parent_path ||>>
 16.1126 +      DatatypeAux.store_thmss_atts "distinct" new_type_names simp_atts distinct_thms ||>>
 16.1127 +      DatatypeAux.store_thmss "constr_rep" new_type_names constr_rep_thmss ||>>
 16.1128 +      DatatypeAux.store_thmss_atts "perm" new_type_names simp_eqvt_atts perm_simps' ||>>
 16.1129 +      DatatypeAux.store_thmss "inject" new_type_names inject_thms ||>>
 16.1130 +      DatatypeAux.store_thmss "supp" new_type_names supp_thms ||>>
 16.1131 +      DatatypeAux.store_thmss_atts "fresh" new_type_names simp_atts fresh_thms ||>
 16.1132 +      fold (fn (atom, ths) => fn thy =>
 16.1133 +        let
 16.1134 +          val class = fs_class_of thy atom;
 16.1135 +          val sort = Sign.certify_sort thy (class :: pt_cp_sort)
 16.1136 +        in fold (fn Type (s, Ts) => AxClass.prove_arity
 16.1137 +          (s, map (inter_sort thy sort o snd o dest_TFree) Ts, [class])
 16.1138 +          (Class.intro_classes_tac [] THEN resolve_tac ths 1)) newTs thy
 16.1139 +        end) (atoms ~~ finite_supp_thms);
 16.1140 +
 16.1141 +    (**** strong induction theorem ****)
 16.1142 +
 16.1143 +    val pnames = if length descr'' = 1 then ["P"]
 16.1144 +      else map (fn i => "P" ^ string_of_int i) (1 upto length descr'');
 16.1145 +    val ind_sort = if null dt_atomTs then HOLogic.typeS
 16.1146 +      else Sign.certify_sort thy9 (map (fs_class_of thy9) dt_atoms);
 16.1147 +    val fsT = TFree ("'n", ind_sort);
 16.1148 +    val fsT' = TFree ("'n", HOLogic.typeS);
 16.1149 +
 16.1150 +    val fresh_fs = map (fn (s, T) => (T, Free (s, fsT' --> HOLogic.mk_setT T)))
 16.1151 +      (DatatypeProp.indexify_names (replicate (length dt_atomTs) "f") ~~ dt_atomTs);
 16.1152 +
 16.1153 +    fun make_pred fsT i T =
 16.1154 +      Free (List.nth (pnames, i), fsT --> T --> HOLogic.boolT);
 16.1155 +
 16.1156 +    fun mk_fresh1 xs [] = []
 16.1157 +      | mk_fresh1 xs ((y as (_, T)) :: ys) = map (fn x => HOLogic.mk_Trueprop
 16.1158 +            (HOLogic.mk_not (HOLogic.mk_eq (Free y, Free x))))
 16.1159 +              (filter (fn (_, U) => T = U) (rev xs)) @
 16.1160 +          mk_fresh1 (y :: xs) ys;
 16.1161 +
 16.1162 +    fun mk_fresh2 xss [] = []
 16.1163 +      | mk_fresh2 xss ((p as (ys, _)) :: yss) = List.concat (map (fn y as (_, T) =>
 16.1164 +            map (fn (_, x as (_, U)) => HOLogic.mk_Trueprop
 16.1165 +              (fresh_const T U $ Free y $ Free x)) (rev xss @ yss)) ys) @
 16.1166 +          mk_fresh2 (p :: xss) yss;
 16.1167 +
 16.1168 +    fun make_ind_prem fsT f k T ((cname, cargs), idxs) =
 16.1169 +      let
 16.1170 +        val recs = List.filter is_rec_type cargs;
 16.1171 +        val Ts = map (typ_of_dtyp descr'' sorts) cargs;
 16.1172 +        val recTs' = map (typ_of_dtyp descr'' sorts) recs;
 16.1173 +        val tnames = Name.variant_list pnames (DatatypeProp.make_tnames Ts);
 16.1174 +        val rec_tnames = map fst (List.filter (is_rec_type o snd) (tnames ~~ cargs));
 16.1175 +        val frees = tnames ~~ Ts;
 16.1176 +        val frees' = partition_cargs idxs frees;
 16.1177 +        val z = (Name.variant tnames "z", fsT);
 16.1178 +
 16.1179 +        fun mk_prem ((dt, s), T) =
 16.1180 +          let
 16.1181 +            val (Us, U) = strip_type T;
 16.1182 +            val l = length Us
 16.1183 +          in list_all (z :: map (pair "x") Us, HOLogic.mk_Trueprop
 16.1184 +            (make_pred fsT (body_index dt) U $ Bound l $ app_bnds (Free (s, T)) l))
 16.1185 +          end;
 16.1186 +
 16.1187 +        val prems = map mk_prem (recs ~~ rec_tnames ~~ recTs');
 16.1188 +        val prems' = map (fn p as (_, T) => HOLogic.mk_Trueprop
 16.1189 +            (f T (Free p) (Free z))) (List.concat (map fst frees')) @
 16.1190 +          mk_fresh1 [] (List.concat (map fst frees')) @
 16.1191 +          mk_fresh2 [] frees'
 16.1192 +
 16.1193 +      in list_all_free (frees @ [z], Logic.list_implies (prems' @ prems,
 16.1194 +        HOLogic.mk_Trueprop (make_pred fsT k T $ Free z $
 16.1195 +          list_comb (Const (cname, Ts ---> T), map Free frees))))
 16.1196 +      end;
 16.1197 +
 16.1198 +    val ind_prems = List.concat (map (fn (((i, (_, _, constrs)), (_, idxss)), T) =>
 16.1199 +      map (make_ind_prem fsT (fn T => fn t => fn u =>
 16.1200 +        fresh_const T fsT $ t $ u) i T)
 16.1201 +          (constrs ~~ idxss)) (descr'' ~~ ndescr ~~ recTs));
 16.1202 +    val tnames = DatatypeProp.make_tnames recTs;
 16.1203 +    val zs = Name.variant_list tnames (replicate (length descr'') "z");
 16.1204 +    val ind_concl = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop "op &")
 16.1205 +      (map (fn ((((i, _), T), tname), z) =>
 16.1206 +        make_pred fsT i T $ Free (z, fsT) $ Free (tname, T))
 16.1207 +        (descr'' ~~ recTs ~~ tnames ~~ zs)));
 16.1208 +    val induct = Logic.list_implies (ind_prems, ind_concl);
 16.1209 +
 16.1210 +    val ind_prems' =
 16.1211 +      map (fn (_, f as Free (_, T)) => list_all_free ([("x", fsT')],
 16.1212 +        HOLogic.mk_Trueprop (Const ("Finite_Set.finite",
 16.1213 +          (snd (split_last (binder_types T)) --> HOLogic.boolT) -->
 16.1214 +            HOLogic.boolT) $ (f $ Free ("x", fsT'))))) fresh_fs @
 16.1215 +      List.concat (map (fn (((i, (_, _, constrs)), (_, idxss)), T) =>
 16.1216 +        map (make_ind_prem fsT' (fn T => fn t => fn u => HOLogic.Not $
 16.1217 +          HOLogic.mk_mem (t, the (AList.lookup op = fresh_fs T) $ u)) i T)
 16.1218 +            (constrs ~~ idxss)) (descr'' ~~ ndescr ~~ recTs));
 16.1219 +    val ind_concl' = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop "op &")
 16.1220 +      (map (fn ((((i, _), T), tname), z) =>
 16.1221 +        make_pred fsT' i T $ Free (z, fsT') $ Free (tname, T))
 16.1222 +        (descr'' ~~ recTs ~~ tnames ~~ zs)));
 16.1223 +    val induct' = Logic.list_implies (ind_prems', ind_concl');
 16.1224 +
 16.1225 +    val aux_ind_vars =
 16.1226 +      (DatatypeProp.indexify_names (replicate (length dt_atomTs) "pi") ~~
 16.1227 +       map mk_permT dt_atomTs) @ [("z", fsT')];
 16.1228 +    val aux_ind_Ts = rev (map snd aux_ind_vars);
 16.1229 +    val aux_ind_concl = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop "op &")
 16.1230 +      (map (fn (((i, _), T), tname) =>
 16.1231 +        HOLogic.list_all (aux_ind_vars, make_pred fsT' i T $ Bound 0 $
 16.1232 +          fold_rev (mk_perm aux_ind_Ts) (map Bound (length dt_atomTs downto 1))
 16.1233 +            (Free (tname, T))))
 16.1234 +        (descr'' ~~ recTs ~~ tnames)));
 16.1235 +
 16.1236 +    val fin_set_supp = map (fn s =>
 16.1237 +      at_inst_of thy9 s RS at_fin_set_supp) dt_atoms;
 16.1238 +    val fin_set_fresh = map (fn s =>
 16.1239 +      at_inst_of thy9 s RS at_fin_set_fresh) dt_atoms;
 16.1240 +    val pt1_atoms = map (fn Type (s, _) =>
 16.1241 +      PureThy.get_thm thy9 ("pt_" ^ Long_Name.base_name s ^ "1")) dt_atomTs;
 16.1242 +    val pt2_atoms = map (fn Type (s, _) =>
 16.1243 +      PureThy.get_thm thy9 ("pt_" ^ Long_Name.base_name s ^ "2") RS sym) dt_atomTs;
 16.1244 +    val exists_fresh' = PureThy.get_thms thy9 "exists_fresh'";
 16.1245 +    val fs_atoms = PureThy.get_thms thy9 "fin_supp";
 16.1246 +    val abs_supp = PureThy.get_thms thy9 "abs_supp";
 16.1247 +    val perm_fresh_fresh = PureThy.get_thms thy9 "perm_fresh_fresh";
 16.1248 +    val calc_atm = PureThy.get_thms thy9 "calc_atm";
 16.1249 +    val fresh_atm = PureThy.get_thms thy9 "fresh_atm";
 16.1250 +    val fresh_left = PureThy.get_thms thy9 "fresh_left";
 16.1251 +    val perm_swap = PureThy.get_thms thy9 "perm_swap";
 16.1252 +
 16.1253 +    fun obtain_fresh_name' ths ts T (freshs1, freshs2, ctxt) =
 16.1254 +      let
 16.1255 +        val p = foldr1 HOLogic.mk_prod (ts @ freshs1);
 16.1256 +        val ex = Goal.prove ctxt [] [] (HOLogic.mk_Trueprop
 16.1257 +            (HOLogic.exists_const T $ Abs ("x", T,
 16.1258 +              fresh_const T (fastype_of p) $
 16.1259 +                Bound 0 $ p)))
 16.1260 +          (fn _ => EVERY
 16.1261 +            [resolve_tac exists_fresh' 1,
 16.1262 +             simp_tac (HOL_ss addsimps (supp_prod :: finite_Un :: fs_atoms @
 16.1263 +               fin_set_supp @ ths)) 1]);
 16.1264 +        val (([cx], ths), ctxt') = Obtain.result
 16.1265 +          (fn _ => EVERY
 16.1266 +            [etac exE 1,
 16.1267 +             full_simp_tac (HOL_ss addsimps (fresh_prod :: fresh_atm)) 1,
 16.1268 +             REPEAT (etac conjE 1)])
 16.1269 +          [ex] ctxt
 16.1270 +      in (freshs1 @ [term_of cx], freshs2 @ ths, ctxt') end;
 16.1271 +
 16.1272 +    fun fresh_fresh_inst thy a b =
 16.1273 +      let
 16.1274 +        val T = fastype_of a;
 16.1275 +        val SOME th = find_first (fn th => case prop_of th of
 16.1276 +            _ $ (_ $ (Const (_, Type (_, [U, _])) $ _ $ _)) $ _ => U = T
 16.1277 +          | _ => false) perm_fresh_fresh
 16.1278 +      in
 16.1279 +        Drule.instantiate' []
 16.1280 +          [SOME (cterm_of thy a), NONE, SOME (cterm_of thy b)] th
 16.1281 +      end;
 16.1282 +
 16.1283 +    val fs_cp_sort =
 16.1284 +      map (fs_class_of thy9) dt_atoms @
 16.1285 +      maps (fn s => map (cp_class_of thy9 s) (dt_atoms \ s)) dt_atoms;
 16.1286 +
 16.1287 +    (**********************************************************************
 16.1288 +      The subgoals occurring in the proof of induct_aux have the
 16.1289 +      following parameters:
 16.1290 +
 16.1291 +        x_1 ... x_k p_1 ... p_m z
 16.1292 +
 16.1293 +      where
 16.1294 +
 16.1295 +        x_i : constructor arguments (introduced by weak induction rule)
 16.1296 +        p_i : permutations (one for each atom type in the data type)
 16.1297 +        z   : freshness context
 16.1298 +    ***********************************************************************)
 16.1299 +
 16.1300 +    val _ = warning "proving strong induction theorem ...";
 16.1301 +
 16.1302 +    val induct_aux = Goal.prove_global thy9 []
 16.1303 +        (map (augment_sort thy9 fs_cp_sort) ind_prems')
 16.1304 +        (augment_sort thy9 fs_cp_sort ind_concl') (fn {prems, context} =>
 16.1305 +      let
 16.1306 +        val (prems1, prems2) = chop (length dt_atomTs) prems;
 16.1307 +        val ind_ss2 = HOL_ss addsimps
 16.1308 +          finite_Diff :: abs_fresh @ abs_supp @ fs_atoms;
 16.1309 +        val ind_ss1 = ind_ss2 addsimps fresh_left @ calc_atm @
 16.1310 +          fresh_atm @ rev_simps @ app_simps;
 16.1311 +        val ind_ss3 = HOL_ss addsimps abs_fun_eq1 ::
 16.1312 +          abs_perm @ calc_atm @ perm_swap;
 16.1313 +        val ind_ss4 = HOL_basic_ss addsimps fresh_left @ prems1 @
 16.1314 +          fin_set_fresh @ calc_atm;
 16.1315 +        val ind_ss5 = HOL_basic_ss addsimps pt1_atoms;
 16.1316 +        val ind_ss6 = HOL_basic_ss addsimps flat perm_simps';
 16.1317 +        val th = Goal.prove context [] []
 16.1318 +          (augment_sort thy9 fs_cp_sort aux_ind_concl)
 16.1319 +          (fn {context = context1, ...} =>
 16.1320 +             EVERY (indtac dt_induct tnames 1 ::
 16.1321 +               maps (fn ((_, (_, _, constrs)), (_, constrs')) =>
 16.1322 +                 map (fn ((cname, cargs), is) =>
 16.1323 +                   REPEAT (rtac allI 1) THEN
 16.1324 +                   SUBPROOF (fn {prems = iprems, params, concl,
 16.1325 +                       context = context2, ...} =>
 16.1326 +                     let
 16.1327 +                       val concl' = term_of concl;
 16.1328 +                       val _ $ (_ $ _ $ u) = concl';
 16.1329 +                       val U = fastype_of u;
 16.1330 +                       val (xs, params') =
 16.1331 +                         chop (length cargs) (map term_of params);
 16.1332 +                       val Ts = map fastype_of xs;
 16.1333 +                       val cnstr = Const (cname, Ts ---> U);
 16.1334 +                       val (pis, z) = split_last params';
 16.1335 +                       val mk_pi = fold_rev (mk_perm []) pis;
 16.1336 +                       val xs' = partition_cargs is xs;
 16.1337 +                       val xs'' = map (fn (ts, u) => (map mk_pi ts, mk_pi u)) xs';
 16.1338 +                       val ts = maps (fn (ts, u) => ts @ [u]) xs'';
 16.1339 +                       val (freshs1, freshs2, context3) = fold (fn t =>
 16.1340 +                         let val T = fastype_of t
 16.1341 +                         in obtain_fresh_name' prems1
 16.1342 +                           (the (AList.lookup op = fresh_fs T) $ z :: ts) T
 16.1343 +                         end) (maps fst xs') ([], [], context2);
 16.1344 +                       val freshs1' = unflat (map fst xs') freshs1;
 16.1345 +                       val freshs2' = map (Simplifier.simplify ind_ss4)
 16.1346 +                         (mk_not_sym freshs2);
 16.1347 +                       val ind_ss1' = ind_ss1 addsimps freshs2';
 16.1348 +                       val ind_ss3' = ind_ss3 addsimps freshs2';
 16.1349 +                       val rename_eq =
 16.1350 +                         if forall (null o fst) xs' then []
 16.1351 +                         else [Goal.prove context3 [] []
 16.1352 +                           (HOLogic.mk_Trueprop (HOLogic.mk_eq
 16.1353 +                             (list_comb (cnstr, ts),
 16.1354 +                              list_comb (cnstr, maps (fn ((bs, t), cs) =>
 16.1355 +                                cs @ [fold_rev (mk_perm []) (map perm_of_pair
 16.1356 +                                  (bs ~~ cs)) t]) (xs'' ~~ freshs1')))))
 16.1357 +                           (fn _ => EVERY
 16.1358 +                              (simp_tac (HOL_ss addsimps flat inject_thms) 1 ::
 16.1359 +                               REPEAT (FIRSTGOAL (rtac conjI)) ::
 16.1360 +                               maps (fn ((bs, t), cs) =>
 16.1361 +                                 if null bs then []
 16.1362 +                                 else rtac sym 1 :: maps (fn (b, c) =>
 16.1363 +                                   [rtac trans 1, rtac sym 1,
 16.1364 +                                    rtac (fresh_fresh_inst thy9 b c) 1,
 16.1365 +                                    simp_tac ind_ss1' 1,
 16.1366 +                                    simp_tac ind_ss2 1,
 16.1367 +                                    simp_tac ind_ss3' 1]) (bs ~~ cs))
 16.1368 +                                 (xs'' ~~ freshs1')))];
 16.1369 +                       val th = Goal.prove context3 [] [] concl' (fn _ => EVERY
 16.1370 +                         [simp_tac (ind_ss6 addsimps rename_eq) 1,
 16.1371 +                          cut_facts_tac iprems 1,
 16.1372 +                          (resolve_tac prems THEN_ALL_NEW
 16.1373 +                            SUBGOAL (fn (t, i) => case Logic.strip_assums_concl t of
 16.1374 +                                _ $ (Const ("Nominal.fresh", _) $ _ $ _) =>
 16.1375 +                                  simp_tac ind_ss1' i
 16.1376 +                              | _ $ (Const ("Not", _) $ _) =>
 16.1377 +                                  resolve_tac freshs2' i
 16.1378 +                              | _ => asm_simp_tac (HOL_basic_ss addsimps
 16.1379 +                                  pt2_atoms addsimprocs [perm_simproc]) i)) 1])
 16.1380 +                       val final = ProofContext.export context3 context2 [th]
 16.1381 +                     in
 16.1382 +                       resolve_tac final 1
 16.1383 +                     end) context1 1) (constrs ~~ constrs')) (descr'' ~~ ndescr)))
 16.1384 +      in
 16.1385 +        EVERY
 16.1386 +          [cut_facts_tac [th] 1,
 16.1387 +           REPEAT (eresolve_tac [conjE, @{thm allE_Nil}] 1),
 16.1388 +           REPEAT (etac allE 1),
 16.1389 +           REPEAT (TRY (rtac conjI 1) THEN asm_full_simp_tac ind_ss5 1)]
 16.1390 +      end);
 16.1391 +
 16.1392 +    val induct_aux' = Thm.instantiate ([],
 16.1393 +      map (fn (s, v as Var (_, T)) =>
 16.1394 +        (cterm_of thy9 v, cterm_of thy9 (Free (s, T))))
 16.1395 +          (pnames ~~ map head_of (HOLogic.dest_conj
 16.1396 +             (HOLogic.dest_Trueprop (concl_of induct_aux)))) @
 16.1397 +      map (fn (_, f) =>
 16.1398 +        let val f' = Logic.varify f
 16.1399 +        in (cterm_of thy9 f',
 16.1400 +          cterm_of thy9 (Const ("Nominal.supp", fastype_of f')))
 16.1401 +        end) fresh_fs) induct_aux;
 16.1402 +
 16.1403 +    val induct = Goal.prove_global thy9 []
 16.1404 +      (map (augment_sort thy9 fs_cp_sort) ind_prems)
 16.1405 +      (augment_sort thy9 fs_cp_sort ind_concl)
 16.1406 +      (fn {prems, ...} => EVERY
 16.1407 +         [rtac induct_aux' 1,
 16.1408 +          REPEAT (resolve_tac fs_atoms 1),
 16.1409 +          REPEAT ((resolve_tac prems THEN_ALL_NEW
 16.1410 +            (etac meta_spec ORELSE' full_simp_tac (HOL_basic_ss addsimps [fresh_def]))) 1)])
 16.1411 +
 16.1412 +    val (_, thy10) = thy9 |>
 16.1413 +      Sign.add_path big_name |>
 16.1414 +      PureThy.add_thms [((Binding.name "strong_induct'", induct_aux), [])] ||>>
 16.1415 +      PureThy.add_thms [((Binding.name "strong_induct", induct), [case_names_induct])] ||>>
 16.1416 +      PureThy.add_thmss [((Binding.name "strong_inducts", projections induct), [case_names_induct])];
 16.1417 +
 16.1418 +    (**** recursion combinator ****)
 16.1419 +
 16.1420 +    val _ = warning "defining recursion combinator ...";
 16.1421 +
 16.1422 +    val used = List.foldr OldTerm.add_typ_tfree_names [] recTs;
 16.1423 +
 16.1424 +    val (rec_result_Ts', rec_fn_Ts') = DatatypeProp.make_primrec_Ts descr' sorts used;
 16.1425 +
 16.1426 +    val rec_sort = if null dt_atomTs then HOLogic.typeS else
 16.1427 +      Sign.certify_sort thy10 pt_cp_sort;
 16.1428 +
 16.1429 +    val rec_result_Ts = map (fn TFree (s, _) => TFree (s, rec_sort)) rec_result_Ts';
 16.1430 +    val rec_fn_Ts = map (typ_subst_atomic (rec_result_Ts' ~~ rec_result_Ts)) rec_fn_Ts';
 16.1431 +
 16.1432 +    val rec_set_Ts = map (fn (T1, T2) =>
 16.1433 +      rec_fn_Ts @ [T1, T2] ---> HOLogic.boolT) (recTs ~~ rec_result_Ts);
 16.1434 +
 16.1435 +    val big_rec_name = big_name ^ "_rec_set";
 16.1436 +    val rec_set_names' =
 16.1437 +      if length descr'' = 1 then [big_rec_name] else
 16.1438 +        map ((curry (op ^) (big_rec_name ^ "_")) o string_of_int)
 16.1439 +          (1 upto (length descr''));
 16.1440 +    val rec_set_names =  map (Sign.full_bname thy10) rec_set_names';
 16.1441 +
 16.1442 +    val rec_fns = map (uncurry (mk_Free "f"))
 16.1443 +      (rec_fn_Ts ~~ (1 upto (length rec_fn_Ts)));
 16.1444 +    val rec_sets' = map (fn c => list_comb (Free c, rec_fns))
 16.1445 +      (rec_set_names' ~~ rec_set_Ts);
 16.1446 +    val rec_sets = map (fn c => list_comb (Const c, rec_fns))
 16.1447 +      (rec_set_names ~~ rec_set_Ts);
 16.1448 +
 16.1449 +    (* introduction rules for graph of recursion function *)
 16.1450 +
 16.1451 +    val rec_preds = map (fn (a, T) =>
 16.1452 +      Free (a, T --> HOLogic.boolT)) (pnames ~~ rec_result_Ts);
 16.1453 +
 16.1454 +    fun mk_fresh3 rs [] = []
 16.1455 +      | mk_fresh3 rs ((p as (ys, z)) :: yss) = List.concat (map (fn y as (_, T) =>
 16.1456 +            List.mapPartial (fn ((_, (_, x)), r as (_, U)) => if z = x then NONE
 16.1457 +              else SOME (HOLogic.mk_Trueprop
 16.1458 +                (fresh_const T U $ Free y $ Free r))) rs) ys) @
 16.1459 +          mk_fresh3 rs yss;
 16.1460 +
 16.1461 +    (* FIXME: avoid collisions with other variable names? *)
 16.1462 +    val rec_ctxt = Free ("z", fsT');
 16.1463 +
 16.1464 +    fun make_rec_intr T p rec_set ((rec_intr_ts, rec_prems, rec_prems',
 16.1465 +          rec_eq_prems, l), ((cname, cargs), idxs)) =
 16.1466 +      let
 16.1467 +        val Ts = map (typ_of_dtyp descr'' sorts) cargs;
 16.1468 +        val frees = map (fn i => "x" ^ string_of_int i) (1 upto length Ts) ~~ Ts;
 16.1469 +        val frees' = partition_cargs idxs frees;
 16.1470 +        val binders = List.concat (map fst frees');
 16.1471 +        val atomTs = distinct op = (maps (map snd o fst) frees');
 16.1472 +        val recs = List.mapPartial
 16.1473 +          (fn ((_, DtRec i), p) => SOME (i, p) | _ => NONE)
 16.1474 +          (partition_cargs idxs cargs ~~ frees');
 16.1475 +        val frees'' = map (fn i => "y" ^ string_of_int i) (1 upto length recs) ~~
 16.1476 +          map (fn (i, _) => List.nth (rec_result_Ts, i)) recs;
 16.1477 +        val prems1 = map (fn ((i, (_, x)), y) => HOLogic.mk_Trueprop
 16.1478 +          (List.nth (rec_sets', i) $ Free x $ Free y)) (recs ~~ frees'');
 16.1479 +        val prems2 =
 16.1480 +          map (fn f => map (fn p as (_, T) => HOLogic.mk_Trueprop
 16.1481 +            (fresh_const T (fastype_of f) $ Free p $ f)) binders) rec_fns;
 16.1482 +        val prems3 = mk_fresh1 [] binders @ mk_fresh2 [] frees';
 16.1483 +        val prems4 = map (fn ((i, _), y) =>
 16.1484 +          HOLogic.mk_Trueprop (List.nth (rec_preds, i) $ Free y)) (recs ~~ frees'');
 16.1485 +        val prems5 = mk_fresh3 (recs ~~ frees'') frees';
 16.1486 +        val prems6 = maps (fn aT => map (fn y as (_, T) => HOLogic.mk_Trueprop
 16.1487 +          (Const ("Finite_Set.finite", HOLogic.mk_setT aT --> HOLogic.boolT) $
 16.1488 +             (Const ("Nominal.supp", T --> HOLogic.mk_setT aT) $ Free y)))
 16.1489 +               frees'') atomTs;
 16.1490 +        val prems7 = map (fn x as (_, T) => HOLogic.mk_Trueprop
 16.1491 +          (fresh_const T fsT' $ Free x $ rec_ctxt)) binders;
 16.1492 +        val result = list_comb (List.nth (rec_fns, l), map Free (frees @ frees''));
 16.1493 +        val result_freshs = map (fn p as (_, T) =>
 16.1494 +          fresh_const T (fastype_of result) $ Free p $ result) binders;
 16.1495 +        val P = HOLogic.mk_Trueprop (p $ result)
 16.1496 +      in
 16.1497 +        (rec_intr_ts @ [Logic.list_implies (List.concat prems2 @ prems3 @ prems1,
 16.1498 +           HOLogic.mk_Trueprop (rec_set $
 16.1499 +             list_comb (Const (cname, Ts ---> T), map Free frees) $ result))],
 16.1500 +         rec_prems @ [list_all_free (frees @ frees'', Logic.list_implies (prems4, P))],
 16.1501 +         rec_prems' @ map (fn fr => list_all_free (frees @ frees'',
 16.1502 +           Logic.list_implies (List.nth (prems2, l) @ prems3 @ prems5 @ prems7 @ prems6 @ [P],
 16.1503 +             HOLogic.mk_Trueprop fr))) result_freshs,
 16.1504 +         rec_eq_prems @ [List.concat prems2 @ prems3],
 16.1505 +         l + 1)
 16.1506 +      end;
 16.1507 +
 16.1508 +    val (rec_intr_ts, rec_prems, rec_prems', rec_eq_prems, _) =
 16.1509 +      Library.foldl (fn (x, ((((d, d'), T), p), rec_set)) =>
 16.1510 +        Library.foldl (make_rec_intr T p rec_set) (x, #3 (snd d) ~~ snd d'))
 16.1511 +          (([], [], [], [], 0), descr'' ~~ ndescr ~~ recTs ~~ rec_preds ~~ rec_sets');
 16.1512 +
 16.1513 +    val ({intrs = rec_intrs, elims = rec_elims, raw_induct = rec_induct, ...}, thy11) =
 16.1514 +      thy10 |>
 16.1515 +        Inductive.add_inductive_global (serial_string ())
 16.1516 +          {quiet_mode = #quiet config, verbose = false, kind = Thm.internalK,
 16.1517 +           alt_name = Binding.name big_rec_name, coind = false, no_elim = false, no_ind = false,
 16.1518 +           skip_mono = true, fork_mono = false}
 16.1519 +          (map (fn (s, T) => ((Binding.name s, T), NoSyn)) (rec_set_names' ~~ rec_set_Ts))
 16.1520 +          (map dest_Free rec_fns)
 16.1521 +          (map (fn x => (Attrib.empty_binding, x)) rec_intr_ts) [] ||>
 16.1522 +      PureThy.hide_fact true (Long_Name.append (Sign.full_bname thy10 big_rec_name) "induct");
 16.1523 +
 16.1524 +    (** equivariance **)
 16.1525 +
 16.1526 +    val fresh_bij = PureThy.get_thms thy11 "fresh_bij";
 16.1527 +    val perm_bij = PureThy.get_thms thy11 "perm_bij";
 16.1528 +
 16.1529 +    val (rec_equiv_thms, rec_equiv_thms') = ListPair.unzip (map (fn aT =>
 16.1530 +      let
 16.1531 +        val permT = mk_permT aT;
 16.1532 +        val pi = Free ("pi", permT);
 16.1533 +        val rec_fns_pi = map (mk_perm [] pi o uncurry (mk_Free "f"))
 16.1534 +          (rec_fn_Ts ~~ (1 upto (length rec_fn_Ts)));
 16.1535 +        val rec_sets_pi = map (fn c => list_comb (Const c, rec_fns_pi))
 16.1536 +          (rec_set_names ~~ rec_set_Ts);
 16.1537 +        val ps = map (fn ((((T, U), R), R'), i) =>
 16.1538 +          let
 16.1539 +            val x = Free ("x" ^ string_of_int i, T);
 16.1540 +            val y = Free ("y" ^ string_of_int i, U)
 16.1541 +          in
 16.1542 +            (R $ x $ y, R' $ mk_perm [] pi x $ mk_perm [] pi y)
 16.1543 +          end) (recTs ~~ rec_result_Ts ~~ rec_sets ~~ rec_sets_pi ~~ (1 upto length recTs));
 16.1544 +        val ths = map (fn th => standard (th RS mp)) (split_conj_thm
 16.1545 +          (Goal.prove_global thy11 [] []
 16.1546 +            (augment_sort thy1 pt_cp_sort
 16.1547 +              (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map HOLogic.mk_imp ps))))
 16.1548 +            (fn _ => rtac rec_induct 1 THEN REPEAT
 16.1549 +               (simp_tac (Simplifier.theory_context thy11 HOL_basic_ss
 16.1550 +                  addsimps flat perm_simps'
 16.1551 +                  addsimprocs [NominalPermeq.perm_simproc_app]) 1 THEN
 16.1552 +                (resolve_tac rec_intrs THEN_ALL_NEW
 16.1553 +                 asm_simp_tac (HOL_ss addsimps (fresh_bij @ perm_bij))) 1))))
 16.1554 +        val ths' = map (fn ((P, Q), th) =>
 16.1555 +          Goal.prove_global thy11 [] []
 16.1556 +            (augment_sort thy1 pt_cp_sort
 16.1557 +              (Logic.mk_implies (HOLogic.mk_Trueprop Q, HOLogic.mk_Trueprop P)))
 16.1558 +            (fn _ => dtac (Thm.instantiate ([],
 16.1559 +                 [(cterm_of thy11 (Var (("pi", 0), permT)),
 16.1560 +                   cterm_of thy11 (Const ("List.rev", permT --> permT) $ pi))]) th) 1 THEN
 16.1561 +               NominalPermeq.perm_simp_tac HOL_ss 1)) (ps ~~ ths)
 16.1562 +      in (ths, ths') end) dt_atomTs);
 16.1563 +
 16.1564 +    (** finite support **)
 16.1565 +
 16.1566 +    val rec_fin_supp_thms = map (fn aT =>
 16.1567 +      let
 16.1568 +        val name = Long_Name.base_name (fst (dest_Type aT));
 16.1569 +        val fs_name = PureThy.get_thm thy11 ("fs_" ^ name ^ "1");
 16.1570 +        val aset = HOLogic.mk_setT aT;
 16.1571 +        val finite = Const ("Finite_Set.finite", aset --> HOLogic.boolT);
 16.1572 +        val fins = map (fn (f, T) => HOLogic.mk_Trueprop
 16.1573 +          (finite $ (Const ("Nominal.supp", T --> aset) $ f)))
 16.1574 +            (rec_fns ~~ rec_fn_Ts)
 16.1575 +      in
 16.1576 +        map (fn th => standard (th RS mp)) (split_conj_thm
 16.1577 +          (Goal.prove_global thy11 []
 16.1578 +            (map (augment_sort thy11 fs_cp_sort) fins)
 16.1579 +            (augment_sort thy11 fs_cp_sort
 16.1580 +              (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
 16.1581 +                (map (fn (((T, U), R), i) =>
 16.1582 +                   let
 16.1583 +                     val x = Free ("x" ^ string_of_int i, T);
 16.1584 +                     val y = Free ("y" ^ string_of_int i, U)
 16.1585 +                   in
 16.1586 +                     HOLogic.mk_imp (R $ x $ y,
 16.1587 +                       finite $ (Const ("Nominal.supp", U --> aset) $ y))
 16.1588 +                   end) (recTs ~~ rec_result_Ts ~~ rec_sets ~~
 16.1589 +                     (1 upto length recTs))))))
 16.1590 +            (fn {prems = fins, ...} =>
 16.1591 +              (rtac rec_induct THEN_ALL_NEW cut_facts_tac fins) 1 THEN REPEAT
 16.1592 +               (NominalPermeq.finite_guess_tac (HOL_ss addsimps [fs_name]) 1))))
 16.1593 +      end) dt_atomTs;
 16.1594 +
 16.1595 +    (** freshness **)
 16.1596 +
 16.1597 +    val finite_premss = map (fn aT =>
 16.1598 +      map (fn (f, T) => HOLogic.mk_Trueprop
 16.1599 +        (Const ("Finite_Set.finite", HOLogic.mk_setT aT --> HOLogic.boolT) $
 16.1600 +           (Const ("Nominal.supp", T --> HOLogic.mk_setT aT) $ f)))
 16.1601 +           (rec_fns ~~ rec_fn_Ts)) dt_atomTs;
 16.1602 +
 16.1603 +    val rec_fns' = map (augment_sort thy11 fs_cp_sort) rec_fns;
 16.1604 +
 16.1605 +    val rec_fresh_thms = map (fn ((aT, eqvt_ths), finite_prems) =>
 16.1606 +      let
 16.1607 +        val name = Long_Name.base_name (fst (dest_Type aT));
 16.1608 +        val fs_name = PureThy.get_thm thy11 ("fs_" ^ name ^ "1");
 16.1609 +        val a = Free ("a", aT);
 16.1610 +        val freshs = map (fn (f, fT) => HOLogic.mk_Trueprop
 16.1611 +          (fresh_const aT fT $ a $ f)) (rec_fns ~~ rec_fn_Ts)
 16.1612 +      in
 16.1613 +        map (fn (((T, U), R), eqvt_th) =>
 16.1614 +          let
 16.1615 +            val x = Free ("x", augment_sort_typ thy11 fs_cp_sort T);
 16.1616 +            val y = Free ("y", U);
 16.1617 +            val y' = Free ("y'", U)
 16.1618 +          in
 16.1619 +            standard (Goal.prove (ProofContext.init thy11) []
 16.1620 +              (map (augment_sort thy11 fs_cp_sort)
 16.1621 +                (finite_prems @
 16.1622 +                   [HOLogic.mk_Trueprop (R $ x $ y),
 16.1623 +                    HOLogic.mk_Trueprop (HOLogic.mk_all ("y'", U,
 16.1624 +                      HOLogic.mk_imp (R $ x $ y', HOLogic.mk_eq (y', y)))),
 16.1625 +                    HOLogic.mk_Trueprop (fresh_const aT T $ a $ x)] @
 16.1626 +                 freshs))
 16.1627 +              (HOLogic.mk_Trueprop (fresh_const aT U $ a $ y))
 16.1628 +              (fn {prems, context} =>
 16.1629 +                 let
 16.1630 +                   val (finite_prems, rec_prem :: unique_prem ::
 16.1631 +                     fresh_prems) = chop (length finite_prems) prems;
 16.1632 +                   val unique_prem' = unique_prem RS spec RS mp;
 16.1633 +                   val unique = [unique_prem', unique_prem' RS sym] MRS trans;
 16.1634 +                   val _ $ (_ $ (_ $ S $ _)) $ _ = prop_of supports_fresh;
 16.1635 +                   val tuple = foldr1 HOLogic.mk_prod (x :: rec_fns')
 16.1636 +                 in EVERY
 16.1637 +                   [rtac (Drule.cterm_instantiate
 16.1638 +                      [(cterm_of thy11 S,
 16.1639 +                        cterm_of thy11 (Const ("Nominal.supp",
 16.1640 +                          fastype_of tuple --> HOLogic.mk_setT aT) $ tuple))]
 16.1641 +                      supports_fresh) 1,
 16.1642 +                    simp_tac (HOL_basic_ss addsimps
 16.1643 +                      [supports_def, symmetric fresh_def, fresh_prod]) 1,
 16.1644 +                    REPEAT_DETERM (resolve_tac [allI, impI] 1),
 16.1645 +                    REPEAT_DETERM (etac conjE 1),
 16.1646 +                    rtac unique 1,
 16.1647 +                    SUBPROOF (fn {prems = prems', params = [a, b], ...} => EVERY
 16.1648 +                      [cut_facts_tac [rec_prem] 1,
 16.1649 +                       rtac (Thm.instantiate ([],
 16.1650 +                         [(cterm_of thy11 (Var (("pi", 0), mk_permT aT)),
 16.1651 +                           cterm_of thy11 (perm_of_pair (term_of a, term_of b)))]) eqvt_th) 1,
 16.1652 +                       asm_simp_tac (HOL_ss addsimps
 16.1653 +                         (prems' @ perm_swap @ perm_fresh_fresh)) 1]) context 1,
 16.1654 +                    rtac rec_prem 1,
 16.1655 +                    simp_tac (HOL_ss addsimps (fs_name ::
 16.1656 +                      supp_prod :: finite_Un :: finite_prems)) 1,
 16.1657 +                    simp_tac (HOL_ss addsimps (symmetric fresh_def ::
 16.1658 +                      fresh_prod :: fresh_prems)) 1]
 16.1659 +                 end))
 16.1660 +          end) (recTs ~~ rec_result_Ts ~~ rec_sets ~~ eqvt_ths)
 16.1661 +      end) (dt_atomTs ~~ rec_equiv_thms' ~~ finite_premss);
 16.1662 +
 16.1663 +    (** uniqueness **)
 16.1664 +
 16.1665 +    val fun_tuple = foldr1 HOLogic.mk_prod (rec_ctxt :: rec_fns);
 16.1666 +    val fun_tupleT = fastype_of fun_tuple;
 16.1667 +    val rec_unique_frees =
 16.1668 +      DatatypeProp.indexify_names (replicate (length recTs) "x") ~~ recTs;
 16.1669 +    val rec_unique_frees'' = map (fn (s, T) => (s ^ "'", T)) rec_unique_frees;
 16.1670 +    val rec_unique_frees' =
 16.1671 +      DatatypeProp.indexify_names (replicate (length recTs) "y") ~~ rec_result_Ts;
 16.1672 +    val rec_unique_concls = map (fn ((x, U), R) =>
 16.1673 +        Const ("Ex1", (U --> HOLogic.boolT) --> HOLogic.boolT) $
 16.1674 +          Abs ("y", U, R $ Free x $ Bound 0))
 16.1675 +      (rec_unique_frees ~~ rec_result_Ts ~~ rec_sets);
 16.1676 +
 16.1677 +    val induct_aux_rec = Drule.cterm_instantiate
 16.1678 +      (map (pairself (cterm_of thy11) o apsnd (augment_sort thy11 fs_cp_sort))
 16.1679 +         (map (fn (aT, f) => (Logic.varify f, Abs ("z", HOLogic.unitT,
 16.1680 +            Const ("Nominal.supp", fun_tupleT --> HOLogic.mk_setT aT) $ fun_tuple)))
 16.1681 +              fresh_fs @
 16.1682 +          map (fn (((P, T), (x, U)), Q) =>
 16.1683 +           (Var ((P, 0), Logic.varifyT (fsT' --> T --> HOLogic.boolT)),
 16.1684 +            Abs ("z", HOLogic.unitT, absfree (x, U, Q))))
 16.1685 +              (pnames ~~ recTs ~~ rec_unique_frees ~~ rec_unique_concls) @
 16.1686 +          map (fn (s, T) => (Var ((s, 0), Logic.varifyT T), Free (s, T)))
 16.1687 +            rec_unique_frees)) induct_aux;
 16.1688 +
 16.1689 +    fun obtain_fresh_name vs ths rec_fin_supp T (freshs1, freshs2, ctxt) =
 16.1690 +      let
 16.1691 +        val p = foldr1 HOLogic.mk_prod (vs @ freshs1);
 16.1692 +        val ex = Goal.prove ctxt [] [] (HOLogic.mk_Trueprop
 16.1693 +            (HOLogic.exists_const T $ Abs ("x", T,
 16.1694 +              fresh_const T (fastype_of p) $ Bound 0 $ p)))
 16.1695 +          (fn _ => EVERY
 16.1696 +            [cut_facts_tac ths 1,
 16.1697 +             REPEAT_DETERM (dresolve_tac (the (AList.lookup op = rec_fin_supp T)) 1),
 16.1698 +             resolve_tac exists_fresh' 1,
 16.1699 +             asm_simp_tac (HOL_ss addsimps (supp_prod :: finite_Un :: fs_atoms)) 1]);
 16.1700 +        val (([cx], ths), ctxt') = Obtain.result
 16.1701 +          (fn _ => EVERY
 16.1702 +            [etac exE 1,
 16.1703 +             full_simp_tac (HOL_ss addsimps (fresh_prod :: fresh_atm)) 1,
 16.1704 +             REPEAT (etac conjE 1)])
 16.1705 +          [ex] ctxt
 16.1706 +      in (freshs1 @ [term_of cx], freshs2 @ ths, ctxt') end;
 16.1707 +
 16.1708 +    val finite_ctxt_prems = map (fn aT =>
 16.1709 +      HOLogic.mk_Trueprop
 16.1710 +        (Const ("Finite_Set.finite", HOLogic.mk_setT aT --> HOLogic.boolT) $
 16.1711 +           (Const ("Nominal.supp", fsT' --> HOLogic.mk_setT aT) $ rec_ctxt))) dt_atomTs;
 16.1712 +
 16.1713 +    val rec_unique_thms = split_conj_thm (Goal.prove
 16.1714 +      (ProofContext.init thy11) (map fst rec_unique_frees)
 16.1715 +      (map (augment_sort thy11 fs_cp_sort)
 16.1716 +        (List.concat finite_premss @ finite_ctxt_prems @ rec_prems @ rec_prems'))
 16.1717 +      (augment_sort thy11 fs_cp_sort
 16.1718 +        (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj rec_unique_concls)))
 16.1719 +      (fn {prems, context} =>
 16.1720 +         let
 16.1721 +           val k = length rec_fns;
 16.1722 +           val (finite_thss, ths1) = fold_map (fn T => fn xs =>
 16.1723 +             apfst (pair T) (chop k xs)) dt_atomTs prems;
 16.1724 +           val (finite_ctxt_ths, ths2) = chop (length dt_atomTs) ths1;
 16.1725 +           val (P_ind_ths, fcbs) = chop k ths2;
 16.1726 +           val P_ths = map (fn th => th RS mp) (split_conj_thm
 16.1727 +             (Goal.prove context
 16.1728 +               (map fst (rec_unique_frees'' @ rec_unique_frees')) []
 16.1729 +               (augment_sort thy11 fs_cp_sort
 16.1730 +                 (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
 16.1731 +                    (map (fn (((x, y), S), P) => HOLogic.mk_imp
 16.1732 +                      (S $ Free x $ Free y, P $ (Free y)))
 16.1733 +                        (rec_unique_frees'' ~~ rec_unique_frees' ~~
 16.1734 +                           rec_sets ~~ rec_preds)))))
 16.1735 +               (fn _ =>
 16.1736 +                  rtac rec_induct 1 THEN
 16.1737 +                  REPEAT ((resolve_tac P_ind_ths THEN_ALL_NEW assume_tac) 1))));
 16.1738 +           val rec_fin_supp_thms' = map
 16.1739 +             (fn (ths, (T, fin_ths)) => (T, map (curry op MRS fin_ths) ths))
 16.1740 +             (rec_fin_supp_thms ~~ finite_thss);
 16.1741 +         in EVERY
 16.1742 +           ([rtac induct_aux_rec 1] @
 16.1743 +            maps (fn ((_, finite_ths), finite_th) =>
 16.1744 +              [cut_facts_tac (finite_th :: finite_ths) 1,
 16.1745 +               asm_simp_tac (HOL_ss addsimps [supp_prod, finite_Un]) 1])
 16.1746 +                (finite_thss ~~ finite_ctxt_ths) @
 16.1747 +            maps (fn ((_, idxss), elim) => maps (fn idxs =>
 16.1748 +              [full_simp_tac (HOL_ss addsimps [symmetric fresh_def, supp_prod, Un_iff]) 1,
 16.1749 +               REPEAT_DETERM (eresolve_tac [conjE, ex1E] 1),
 16.1750 +               rtac ex1I 1,
 16.1751 +               (resolve_tac rec_intrs THEN_ALL_NEW atac) 1,
 16.1752 +               rotate_tac ~1 1,
 16.1753 +               ((DETERM o etac elim) THEN_ALL_NEW full_simp_tac
 16.1754 +                  (HOL_ss addsimps List.concat distinct_thms)) 1] @
 16.1755 +               (if null idxs then [] else [hyp_subst_tac 1,
 16.1756 +                SUBPROOF (fn {asms, concl, prems = prems', params, context = context', ...} =>
 16.1757 +                  let
 16.1758 +                    val SOME prem = find_first (can (HOLogic.dest_eq o
 16.1759 +                      HOLogic.dest_Trueprop o prop_of)) prems';
 16.1760 +                    val _ $ (_ $ lhs $ rhs) = prop_of prem;
 16.1761 +                    val _ $ (_ $ lhs' $ rhs') = term_of concl;
 16.1762 +                    val rT = fastype_of lhs';
 16.1763 +                    val (c, cargsl) = strip_comb lhs;
 16.1764 +                    val cargsl' = partition_cargs idxs cargsl;
 16.1765 +                    val boundsl = List.concat (map fst cargsl');
 16.1766 +                    val (_, cargsr) = strip_comb rhs;
 16.1767 +                    val cargsr' = partition_cargs idxs cargsr;
 16.1768 +                    val boundsr = List.concat (map fst cargsr');
 16.1769 +                    val (params1, _ :: params2) =
 16.1770 +                      chop (length params div 2) (map term_of params);
 16.1771 +                    val params' = params1 @ params2;
 16.1772 +                    val rec_prems = filter (fn th => case prop_of th of
 16.1773 +                        _ $ p => (case head_of p of
 16.1774 +                          Const (s, _) => s mem rec_set_names
 16.1775 +                        | _ => false)
 16.1776 +                      | _ => false) prems';
 16.1777 +                    val fresh_prems = filter (fn th => case prop_of th of
 16.1778 +                        _ $ (Const ("Nominal.fresh", _) $ _ $ _) => true
 16.1779 +                      | _ $ (Const ("Not", _) $ _) => true
 16.1780 +                      | _ => false) prems';
 16.1781 +                    val Ts = map fastype_of boundsl;
 16.1782 +
 16.1783 +                    val _ = warning "step 1: obtaining fresh names";
 16.1784 +                    val (freshs1, freshs2, context'') = fold
 16.1785 +                      (obtain_fresh_name (rec_ctxt :: rec_fns' @ params')
 16.1786 +                         (List.concat (map snd finite_thss) @
 16.1787 +                            finite_ctxt_ths @ rec_prems)
 16.1788 +                         rec_fin_supp_thms')
 16.1789 +                      Ts ([], [], context');
 16.1790 +                    val pi1 = map perm_of_pair (boundsl ~~ freshs1);
 16.1791 +                    val rpi1 = rev pi1;
 16.1792 +                    val pi2 = map perm_of_pair (boundsr ~~ freshs1);
 16.1793 +                    val rpi2 = rev pi2;
 16.1794 +
 16.1795 +                    val fresh_prems' = mk_not_sym fresh_prems;
 16.1796 +                    val freshs2' = mk_not_sym freshs2;
 16.1797 +
 16.1798 +                    (** as, bs, cs # K as ts, K bs us **)
 16.1799 +                    val _ = warning "step 2: as, bs, cs # K as ts, K bs us";
 16.1800 +                    val prove_fresh_ss = HOL_ss addsimps
 16.1801 +                      (finite_Diff :: List.concat fresh_thms @
 16.1802 +                       fs_atoms @ abs_fresh @ abs_supp @ fresh_atm);
 16.1803 +                    (* FIXME: avoid asm_full_simp_tac ? *)
 16.1804 +                    fun prove_fresh ths y x = Goal.prove context'' [] []
 16.1805 +                      (HOLogic.mk_Trueprop (fresh_const
 16.1806 +                         (fastype_of x) (fastype_of y) $ x $ y))
 16.1807 +                      (fn _ => cut_facts_tac ths 1 THEN asm_full_simp_tac prove_fresh_ss 1);
 16.1808 +                    val constr_fresh_thms =
 16.1809 +                      map (prove_fresh fresh_prems lhs) boundsl @
 16.1810 +                      map (prove_fresh fresh_prems rhs) boundsr @
 16.1811 +                      map (prove_fresh freshs2 lhs) freshs1 @
 16.1812 +                      map (prove_fresh freshs2 rhs) freshs1;
 16.1813 +
 16.1814 +                    (** pi1 o (K as ts) = pi2 o (K bs us) **)
 16.1815 +                    val _ = warning "step 3: pi1 o (K as ts) = pi2 o (K bs us)";
 16.1816 +                    val pi1_pi2_eq = Goal.prove context'' [] []
 16.1817 +                      (HOLogic.mk_Trueprop (HOLogic.mk_eq
 16.1818 +                        (fold_rev (mk_perm []) pi1 lhs, fold_rev (mk_perm []) pi2 rhs)))
 16.1819 +                      (fn _ => EVERY
 16.1820 +                         [cut_facts_tac constr_fresh_thms 1,
 16.1821 +                          asm_simp_tac (HOL_basic_ss addsimps perm_fresh_fresh) 1,
 16.1822 +                          rtac prem 1]);
 16.1823 +
 16.1824 +                    (** pi1 o ts = pi2 o us **)
 16.1825 +                    val _ = warning "step 4: pi1 o ts = pi2 o us";
 16.1826 +                    val pi1_pi2_eqs = map (fn (t, u) =>
 16.1827 +                      Goal.prove context'' [] []
 16.1828 +                        (HOLogic.mk_Trueprop (HOLogic.mk_eq
 16.1829 +                          (fold_rev (mk_perm []) pi1 t, fold_rev (mk_perm []) pi2 u)))
 16.1830 +                        (fn _ => EVERY
 16.1831 +                           [cut_facts_tac [pi1_pi2_eq] 1,
 16.1832 +                            asm_full_simp_tac (HOL_ss addsimps
 16.1833 +                              (calc_atm @ List.concat perm_simps' @
 16.1834 +                               fresh_prems' @ freshs2' @ abs_perm @
 16.1835 +                               alpha @ List.concat inject_thms)) 1]))
 16.1836 +                        (map snd cargsl' ~~ map snd cargsr');
 16.1837 +
 16.1838 +                    (** pi1^-1 o pi2 o us = ts **)
 16.1839 +                    val _ = warning "step 5: pi1^-1 o pi2 o us = ts";
 16.1840 +                    val rpi1_pi2_eqs = map (fn ((t, u), eq) =>
 16.1841 +                      Goal.prove context'' [] []
 16.1842 +                        (HOLogic.mk_Trueprop (HOLogic.mk_eq
 16.1843 +                          (fold_rev (mk_perm []) (rpi1 @ pi2) u, t)))
 16.1844 +                        (fn _ => simp_tac (HOL_ss addsimps
 16.1845 +                           ((eq RS sym) :: perm_swap)) 1))
 16.1846 +                        (map snd cargsl' ~~ map snd cargsr' ~~ pi1_pi2_eqs);
 16.1847 +
 16.1848 +                    val (rec_prems1, rec_prems2) =
 16.1849 +                      chop (length rec_prems div 2) rec_prems;
 16.1850 +
 16.1851 +                    (** (ts, pi1^-1 o pi2 o vs) in rec_set **)
 16.1852 +                    val _ = warning "step 6: (ts, pi1^-1 o pi2 o vs) in rec_set";
 16.1853 +                    val rec_prems' = map (fn th =>
 16.1854 +                      let
 16.1855 +                        val _ $ (S $ x $ y) = prop_of th;
 16.1856 +                        val Const (s, _) = head_of S;
 16.1857 +                        val k = find_index (equal s) rec_set_names;
 16.1858 +                        val pi = rpi1 @ pi2;
 16.1859 +                        fun mk_pi z = fold_rev (mk_perm []) pi z;
 16.1860 +                        fun eqvt_tac p =
 16.1861 +                          let
 16.1862 +                            val U as Type (_, [Type (_, [T, _])]) = fastype_of p;
 16.1863 +                            val l = find_index (equal T) dt_atomTs;
 16.1864 +                            val th = List.nth (List.nth (rec_equiv_thms', l), k);
 16.1865 +                            val th' = Thm.instantiate ([],
 16.1866 +                              [(cterm_of thy11 (Var (("pi", 0), U)),
 16.1867 +                                cterm_of thy11 p)]) th;
 16.1868 +                          in rtac th' 1 end;
 16.1869 +                        val th' = Goal.prove context'' [] []
 16.1870 +                          (HOLogic.mk_Trueprop (S $ mk_pi x $ mk_pi y))
 16.1871 +                          (fn _ => EVERY
 16.1872 +                             (map eqvt_tac pi @
 16.1873 +                              [simp_tac (HOL_ss addsimps (fresh_prems' @ freshs2' @
 16.1874 +                                 perm_swap @ perm_fresh_fresh)) 1,
 16.1875 +                               rtac th 1]))
 16.1876 +                      in
 16.1877 +                        Simplifier.simplify
 16.1878 +                          (HOL_basic_ss addsimps rpi1_pi2_eqs) th'
 16.1879 +                      end) rec_prems2;
 16.1880 +
 16.1881 +                    val ihs = filter (fn th => case prop_of th of
 16.1882 +                      _ $ (Const ("All", _) $ _) => true | _ => false) prems';
 16.1883 +
 16.1884 +                    (** pi1 o rs = pi2 o vs , rs = pi1^-1 o pi2 o vs **)
 16.1885 +                    val _ = warning "step 7: pi1 o rs = pi2 o vs , rs = pi1^-1 o pi2 o vs";
 16.1886 +                    val rec_eqns = map (fn (th, ih) =>
 16.1887 +                      let
 16.1888 +                        val th' = th RS (ih RS spec RS mp) RS sym;
 16.1889 +                        val _ $ (_ $ lhs $ rhs) = prop_of th';
 16.1890 +                        fun strip_perm (_ $ _ $ t) = strip_perm t
 16.1891 +                          | strip_perm t = t;
 16.1892 +                      in
 16.1893 +                        Goal.prove context'' [] []
 16.1894 +                           (HOLogic.mk_Trueprop (HOLogic.mk_eq
 16.1895 +                              (fold_rev (mk_perm []) pi1 lhs,
 16.1896 +                               fold_rev (mk_perm []) pi2 (strip_perm rhs))))
 16.1897 +                           (fn _ => simp_tac (HOL_basic_ss addsimps
 16.1898 +                              (th' :: perm_swap)) 1)
 16.1899 +                      end) (rec_prems' ~~ ihs);
 16.1900 +
 16.1901 +                    (** as # rs **)
 16.1902 +                    val _ = warning "step 8: as # rs";
 16.1903 +                    val rec_freshs = List.concat
 16.1904 +                      (map (fn (rec_prem, ih) =>
 16.1905 +                        let
 16.1906 +                          val _ $ (S $ x $ (y as Free (_, T))) =
 16.1907 +                            prop_of rec_prem;
 16.1908 +                          val k = find_index (equal S) rec_sets;
 16.1909 +                          val atoms = List.concat (List.mapPartial (fn (bs, z) =>
 16.1910 +                            if z = x then NONE else SOME bs) cargsl')
 16.1911 +                        in
 16.1912 +                          map (fn a as Free (_, aT) =>
 16.1913 +                            let val l = find_index (equal aT) dt_atomTs;
 16.1914 +                            in
 16.1915 +                              Goal.prove context'' [] []
 16.1916 +                                (HOLogic.mk_Trueprop (fresh_const aT T $ a $ y))
 16.1917 +                                (fn _ => EVERY
 16.1918 +                                   (rtac (List.nth (List.nth (rec_fresh_thms, l), k)) 1 ::
 16.1919 +                                    map (fn th => rtac th 1)
 16.1920 +                                      (snd (List.nth (finite_thss, l))) @
 16.1921 +                                    [rtac rec_prem 1, rtac ih 1,
 16.1922 +                                     REPEAT_DETERM (resolve_tac fresh_prems 1)]))
 16.1923 +                            end) atoms
 16.1924 +                        end) (rec_prems1 ~~ ihs));
 16.1925 +
 16.1926 +                    (** as # fK as ts rs , bs # fK bs us vs **)
 16.1927 +                    val _ = warning "step 9: as # fK as ts rs , bs # fK bs us vs";
 16.1928 +                    fun prove_fresh_result (a as Free (_, aT)) =
 16.1929 +                      Goal.prove context'' [] []
 16.1930 +                        (HOLogic.mk_Trueprop (fresh_const aT rT $ a $ rhs'))
 16.1931 +                        (fn _ => EVERY
 16.1932 +                           [resolve_tac fcbs 1,
 16.1933 +                            REPEAT_DETERM (resolve_tac
 16.1934 +                              (fresh_prems @ rec_freshs) 1),
 16.1935 +                            REPEAT_DETERM (resolve_tac (maps snd rec_fin_supp_thms') 1
 16.1936 +                              THEN resolve_tac rec_prems 1),
 16.1937 +                            resolve_tac P_ind_ths 1,
 16.1938 +                            REPEAT_DETERM (resolve_tac (P_ths @ rec_prems) 1)]);
 16.1939 +
 16.1940 +                    val fresh_results'' = map prove_fresh_result boundsl;
 16.1941 +
 16.1942 +                    fun prove_fresh_result'' ((a as Free (_, aT), b), th) =
 16.1943 +                      let val th' = Goal.prove context'' [] []
 16.1944 +                        (HOLogic.mk_Trueprop (fresh_const aT rT $
 16.1945 +                            fold_rev (mk_perm []) (rpi2 @ pi1) a $
 16.1946 +                            fold_rev (mk_perm []) (rpi2 @ pi1) rhs'))
 16.1947 +                        (fn _ => simp_tac (HOL_ss addsimps fresh_bij) 1 THEN
 16.1948 +                           rtac th 1)
 16.1949 +                      in
 16.1950 +                        Goal.prove context'' [] []
 16.1951 +                          (HOLogic.mk_Trueprop (fresh_const aT rT $ b $ lhs'))
 16.1952 +                          (fn _ => EVERY
 16.1953 +                             [cut_facts_tac [th'] 1,
 16.1954 +                              full_simp_tac (Simplifier.theory_context thy11 HOL_ss
 16.1955 +                                addsimps rec_eqns @ pi1_pi2_eqs @ perm_swap
 16.1956 +                                addsimprocs [NominalPermeq.perm_simproc_app]) 1,
 16.1957 +                              full_simp_tac (HOL_ss addsimps (calc_atm @
 16.1958 +                                fresh_prems' @ freshs2' @ perm_fresh_fresh)) 1])
 16.1959 +                      end;
 16.1960 +
 16.1961 +                    val fresh_results = fresh_results'' @ map prove_fresh_result''
 16.1962 +                      (boundsl ~~ boundsr ~~ fresh_results'');
 16.1963 +
 16.1964 +                    (** cs # fK as ts rs , cs # fK bs us vs **)
 16.1965 +                    val _ = warning "step 10: cs # fK as ts rs , cs # fK bs us vs";
 16.1966 +                    fun prove_fresh_result' recs t (a as Free (_, aT)) =
 16.1967 +                      Goal.prove context'' [] []
 16.1968 +                        (HOLogic.mk_Trueprop (fresh_const aT rT $ a $ t))
 16.1969 +                        (fn _ => EVERY
 16.1970 +                          [cut_facts_tac recs 1,
 16.1971 +                           REPEAT_DETERM (dresolve_tac
 16.1972 +                             (the (AList.lookup op = rec_fin_supp_thms' aT)) 1),
 16.1973 +                           NominalPermeq.fresh_guess_tac
 16.1974 +                             (HOL_ss addsimps (freshs2 @
 16.1975 +                                fs_atoms @ fresh_atm @
 16.1976 +                                List.concat (map snd finite_thss))) 1]);
 16.1977 +
 16.1978 +                    val fresh_results' =
 16.1979 +                      map (prove_fresh_result' rec_prems1 rhs') freshs1 @
 16.1980 +                      map (prove_fresh_result' rec_prems2 lhs') freshs1;
 16.1981 +
 16.1982 +                    (** pi1 o (fK as ts rs) = pi2 o (fK bs us vs) **)
 16.1983 +                    val _ = warning "step 11: pi1 o (fK as ts rs) = pi2 o (fK bs us vs)";
 16.1984 +                    val pi1_pi2_result = Goal.prove context'' [] []
 16.1985 +                      (HOLogic.mk_Trueprop (HOLogic.mk_eq
 16.1986 +                        (fold_rev (mk_perm []) pi1 rhs', fold_rev (mk_perm []) pi2 lhs')))
 16.1987 +                      (fn _ => simp_tac (Simplifier.context context'' HOL_ss
 16.1988 +                           addsimps pi1_pi2_eqs @ rec_eqns
 16.1989 +                           addsimprocs [NominalPermeq.perm_simproc_app]) 1 THEN
 16.1990 +                         TRY (simp_tac (HOL_ss addsimps
 16.1991 +                           (fresh_prems' @ freshs2' @ calc_atm @ perm_fresh_fresh)) 1));
 16.1992 +
 16.1993 +                    val _ = warning "final result";
 16.1994 +                    val final = Goal.prove context'' [] [] (term_of concl)
 16.1995 +                      (fn _ => cut_facts_tac [pi1_pi2_result RS sym] 1 THEN
 16.1996 +                        full_simp_tac (HOL_basic_ss addsimps perm_fresh_fresh @
 16.1997 +                          fresh_results @ fresh_results') 1);
 16.1998 +                    val final' = ProofContext.export context'' context' [final];
 16.1999 +                    val _ = warning "finished!"
 16.2000 +                  in
 16.2001 +                    resolve_tac final' 1
 16.2002 +                  end) context 1])) idxss) (ndescr ~~ rec_elims))
 16.2003 +         end));
 16.2004 +
 16.2005 +    val rec_total_thms = map (fn r => r RS theI') rec_unique_thms;
 16.2006 +
 16.2007 +    (* define primrec combinators *)
 16.2008 +
 16.2009 +    val big_reccomb_name = (space_implode "_" new_type_names) ^ "_rec";
 16.2010 +    val reccomb_names = map (Sign.full_bname thy11)
 16.2011 +      (if length descr'' = 1 then [big_reccomb_name] else
 16.2012 +        (map ((curry (op ^) (big_reccomb_name ^ "_")) o string_of_int)
 16.2013 +          (1 upto (length descr''))));
 16.2014 +    val reccombs = map (fn ((name, T), T') => list_comb
 16.2015 +      (Const (name, rec_fn_Ts @ [T] ---> T'), rec_fns))
 16.2016 +        (reccomb_names ~~ recTs ~~ rec_result_Ts);
 16.2017 +
 16.2018 +    val (reccomb_defs, thy12) =
 16.2019 +      thy11
 16.2020 +      |> Sign.add_consts_i (map (fn ((name, T), T') =>
 16.2021 +          (Binding.name (Long_Name.base_name name), rec_fn_Ts @ [T] ---> T', NoSyn))
 16.2022 +          (reccomb_names ~~ recTs ~~ rec_result_Ts))
 16.2023 +      |> (PureThy.add_defs false o map Thm.no_attributes) (map (fn ((((name, comb), set), T), T') =>
 16.2024 +          (Binding.name (Long_Name.base_name name ^ "_def"), Logic.mk_equals (comb, absfree ("x", T,
 16.2025 +           Const ("The", (T' --> HOLogic.boolT) --> T') $ absfree ("y", T',
 16.2026 +             set $ Free ("x", T) $ Free ("y", T'))))))
 16.2027 +               (reccomb_names ~~ reccombs ~~ rec_sets ~~ recTs ~~ rec_result_Ts));
 16.2028 +
 16.2029 +    (* prove characteristic equations for primrec combinators *)
 16.2030 +
 16.2031 +    val rec_thms = map (fn (prems, concl) =>
 16.2032 +      let
 16.2033 +        val _ $ (_ $ (_ $ x) $ _) = concl;
 16.2034 +        val (_, cargs) = strip_comb x;
 16.2035 +        val ps = map (fn (x as Free (_, T), i) =>
 16.2036 +          (Free ("x" ^ string_of_int i, T), x)) (cargs ~~ (1 upto length cargs));
 16.2037 +        val concl' = subst_atomic_types (rec_result_Ts' ~~ rec_result_Ts) concl;
 16.2038 +        val prems' = List.concat finite_premss @ finite_ctxt_prems @
 16.2039 +          rec_prems @ rec_prems' @ map (subst_atomic ps) prems;
 16.2040 +        fun solve rules prems = resolve_tac rules THEN_ALL_NEW
 16.2041 +          (resolve_tac prems THEN_ALL_NEW atac)
 16.2042 +      in
 16.2043 +        Goal.prove_global thy12 []
 16.2044 +          (map (augment_sort thy12 fs_cp_sort) prems')
 16.2045 +          (augment_sort thy12 fs_cp_sort concl')
 16.2046 +          (fn {prems, ...} => EVERY
 16.2047 +            [rewrite_goals_tac reccomb_defs,
 16.2048 +             rtac the1_equality 1,
 16.2049 +             solve rec_unique_thms prems 1,
 16.2050 +             resolve_tac rec_intrs 1,
 16.2051 +             REPEAT (solve (prems @ rec_total_thms) prems 1)])
 16.2052 +      end) (rec_eq_prems ~~
 16.2053 +        DatatypeProp.make_primrecs new_type_names descr' sorts thy12);
 16.2054 +
 16.2055 +    val dt_infos = map (make_dt_info pdescr sorts induct reccomb_names rec_thms)
 16.2056 +      ((0 upto length descr1 - 1) ~~ descr1 ~~ distinct_thms ~~ inject_thms);
 16.2057 +
 16.2058 +    (* FIXME: theorems are stored in database for testing only *)
 16.2059 +    val (_, thy13) = thy12 |>
 16.2060 +      PureThy.add_thmss
 16.2061 +        [((Binding.name "rec_equiv", List.concat rec_equiv_thms), []),
 16.2062 +         ((Binding.name "rec_equiv'", List.concat rec_equiv_thms'), []),
 16.2063 +         ((Binding.name "rec_fin_supp", List.concat rec_fin_supp_thms), []),
 16.2064 +         ((Binding.name "rec_fresh", List.concat rec_fresh_thms), []),
 16.2065 +         ((Binding.name "rec_unique", map standard rec_unique_thms), []),
 16.2066 +         ((Binding.name "recs", rec_thms), [])] ||>
 16.2067 +      Sign.parent_path ||>
 16.2068 +      map_nominal_datatypes (fold Symtab.update dt_infos);
 16.2069 +
 16.2070 +  in
 16.2071 +    thy13
 16.2072 +  end;
 16.2073 +
 16.2074 +val add_nominal_datatype = gen_add_nominal_datatype Datatype.read_typ;
 16.2075 +
 16.2076 +
 16.2077 +(* FIXME: The following stuff should be exported by Datatype *)
 16.2078 +
 16.2079 +local structure P = OuterParse and K = OuterKeyword in
 16.2080 +
 16.2081 +val datatype_decl =
 16.2082 +  Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.type_args -- P.name -- P.opt_infix --
 16.2083 +    (P.$$$ "=" |-- P.enum1 "|" (P.name -- Scan.repeat P.typ -- P.opt_mixfix));
 16.2084 +
 16.2085 +fun mk_datatype args =
 16.2086 +  let
 16.2087 +    val names = map (fn ((((NONE, _), t), _), _) => t | ((((SOME t, _), _), _), _) => t) args;
 16.2088 +    val specs = map (fn ((((_, vs), t), mx), cons) =>
 16.2089 +      (vs, t, mx, map (fn ((x, y), z) => (x, y, z)) cons)) args;
 16.2090 +  in add_nominal_datatype DatatypeAux.default_datatype_config names specs end;
 16.2091 +
 16.2092 +val _ =
 16.2093 +  OuterSyntax.command "nominal_datatype" "define inductive datatypes" K.thy_decl
 16.2094 +    (P.and_list1 datatype_decl >> (Toplevel.theory o mk_datatype));
 16.2095 +
 16.2096 +end;
 16.2097 +
 16.2098 +end
    17.1 --- a/src/HOL/Nominal/nominal_atoms.ML	Thu Jun 18 18:31:14 2009 -0700
    17.2 +++ b/src/HOL/Nominal/nominal_atoms.ML	Fri Jun 19 17:23:21 2009 +0200
    17.3 @@ -101,7 +101,7 @@
    17.4      val (_,thy1) = 
    17.5      fold_map (fn ak => fn thy => 
    17.6            let val dt = ([], Binding.name ak, NoSyn, [(Binding.name ak, [@{typ nat}], NoSyn)])
    17.7 -              val ({inject,case_thms,...},thy1) = DatatypePackage.add_datatype
    17.8 +              val ({inject,case_thms,...},thy1) = Datatype.add_datatype
    17.9                  DatatypeAux.default_datatype_config [ak] [dt] thy
   17.10                val inject_flat = flat inject
   17.11                val ak_type = Type (Sign.intern_type thy1 ak,[])
   17.12 @@ -191,7 +191,7 @@
   17.13          thy |> Sign.add_consts_i [(Binding.name ("swap_" ^ ak_name), swapT, NoSyn)] 
   17.14              |> PureThy.add_defs_unchecked true [((Binding.name name, def2),[])]
   17.15              |> snd
   17.16 -            |> OldPrimrecPackage.add_primrec_unchecked_i "" [(("", def1),[])]
   17.17 +            |> OldPrimrec.add_primrec_unchecked_i "" [(("", def1),[])]
   17.18        end) ak_names_types thy1;
   17.19      
   17.20      (* declares a permutation function for every atom-kind acting  *)
   17.21 @@ -219,7 +219,7 @@
   17.22                      Const (swap_name, swapT) $ x $ (Const (qu_prm_name, prmT) $ xs $ a)));
   17.23        in
   17.24          thy |> Sign.add_consts_i [(Binding.name prm_name, mk_permT T --> T --> T, NoSyn)] 
   17.25 -            |> OldPrimrecPackage.add_primrec_unchecked_i "" [(("", def1), []),(("", def2), [])]
   17.26 +            |> OldPrimrec.add_primrec_unchecked_i "" [(("", def1), []),(("", def2), [])]
   17.27        end) ak_names_types thy3;
   17.28      
   17.29      (* defines permutation functions for all combinations of atom-kinds; *)
    18.1 --- a/src/HOL/Nominal/nominal_inductive.ML	Thu Jun 18 18:31:14 2009 -0700
    18.2 +++ b/src/HOL/Nominal/nominal_inductive.ML	Fri Jun 19 17:23:21 2009 +0200
    18.3 @@ -53,7 +53,7 @@
    18.4  fun add_binders thy i (t as (_ $ _)) bs = (case strip_comb t of
    18.5        (Const (s, T), ts) => (case strip_type T of
    18.6          (Ts, Type (tname, _)) =>
    18.7 -          (case NominalPackage.get_nominal_datatype thy tname of
    18.8 +          (case Nominal.get_nominal_datatype thy tname of
    18.9               NONE => fold (add_binders thy i) ts bs
   18.10             | SOME {descr, index, ...} => (case AList.lookup op =
   18.11                   (#3 (the (AList.lookup op = descr index))) s of
   18.12 @@ -148,11 +148,11 @@
   18.13    let
   18.14      val thy = ProofContext.theory_of ctxt;
   18.15      val ({names, ...}, {raw_induct, intrs, elims, ...}) =
   18.16 -      InductivePackage.the_inductive ctxt (Sign.intern_const thy s);
   18.17 -    val ind_params = InductivePackage.params_of raw_induct;
   18.18 +      Inductive.the_inductive ctxt (Sign.intern_const thy s);
   18.19 +    val ind_params = Inductive.params_of raw_induct;
   18.20      val raw_induct = atomize_induct ctxt raw_induct;
   18.21      val elims = map (atomize_induct ctxt) elims;
   18.22 -    val monos = InductivePackage.get_monos ctxt;
   18.23 +    val monos = Inductive.get_monos ctxt;
   18.24      val eqvt_thms = NominalThmDecls.get_eqvt_thms ctxt;
   18.25      val _ = (case names \\ fold (Term.add_const_names o Thm.prop_of) eqvt_thms [] of
   18.26          [] => ()
   18.27 @@ -230,7 +230,7 @@
   18.28            else NONE) xs @ mk_distinct xs;
   18.29  
   18.30      fun mk_fresh (x, T) = HOLogic.mk_Trueprop
   18.31 -      (NominalPackage.fresh_const T fsT $ x $ Bound 0);
   18.32 +      (Nominal.fresh_const T fsT $ x $ Bound 0);
   18.33  
   18.34      val (prems', prems'') = split_list (map (fn (params, bvars, prems, (p, ts)) =>
   18.35        let
   18.36 @@ -254,7 +254,7 @@
   18.37      val concl = HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
   18.38        (map (fn (prem, (p, ts)) => HOLogic.mk_imp (prem,
   18.39          HOLogic.list_all (ind_vars, lift_pred p
   18.40 -          (map (fold_rev (NominalPackage.mk_perm ind_Ts)
   18.41 +          (map (fold_rev (Nominal.mk_perm ind_Ts)
   18.42              (map Bound (length atomTs downto 1))) ts)))) concls));
   18.43  
   18.44      val concl' = HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
   18.45 @@ -268,7 +268,7 @@
   18.46               else map_term (split_conj (K o I) names) prem prem) prems, q))))
   18.47          (mk_distinct bvars @
   18.48           maps (fn (t, T) => map (fn (u, U) => HOLogic.mk_Trueprop
   18.49 -           (NominalPackage.fresh_const U T $ u $ t)) bvars)
   18.50 +           (Nominal.fresh_const U T $ u $ t)) bvars)
   18.51               (ts ~~ binder_types (fastype_of p)))) prems;
   18.52  
   18.53      val perm_pi_simp = PureThy.get_thms thy "perm_pi_simp";
   18.54 @@ -296,7 +296,7 @@
   18.55          val p = foldr1 HOLogic.mk_prod (map protect ts @ freshs1);
   18.56          val ex = Goal.prove ctxt [] [] (HOLogic.mk_Trueprop
   18.57              (HOLogic.exists_const T $ Abs ("x", T,
   18.58 -              NominalPackage.fresh_const T (fastype_of p) $
   18.59 +              Nominal.fresh_const T (fastype_of p) $
   18.60                  Bound 0 $ p)))
   18.61            (fn _ => EVERY
   18.62              [resolve_tac exists_fresh' 1,
   18.63 @@ -325,13 +325,13 @@
   18.64                     (fn (Bound i, T) => (nth params' (length params' - i), T)
   18.65                       | (t, T) => (t, T)) bvars;
   18.66                   val pi_bvars = map (fn (t, _) =>
   18.67 -                   fold_rev (NominalPackage.mk_perm []) pis t) bvars';
   18.68 +                   fold_rev (Nominal.mk_perm []) pis t) bvars';
   18.69                   val (P, ts) = strip_comb (HOLogic.dest_Trueprop (term_of concl));
   18.70                   val (freshs1, freshs2, ctxt'') = fold
   18.71                     (obtain_fresh_name (ts @ pi_bvars))
   18.72                     (map snd bvars') ([], [], ctxt');
   18.73 -                 val freshs2' = NominalPackage.mk_not_sym freshs2;
   18.74 -                 val pis' = map NominalPackage.perm_of_pair (pi_bvars ~~ freshs1);
   18.75 +                 val freshs2' = Nominal.mk_not_sym freshs2;
   18.76 +                 val pis' = map Nominal.perm_of_pair (pi_bvars ~~ freshs1);
   18.77                   fun concat_perm pi1 pi2 =
   18.78                     let val T = fastype_of pi1
   18.79                     in if T = fastype_of pi2 then
   18.80 @@ -343,11 +343,11 @@
   18.81                     (Vartab.empty, Vartab.empty);
   18.82                   val ihyp' = Thm.instantiate ([], map (pairself (cterm_of thy))
   18.83                     (map (Envir.subst_vars env) vs ~~
   18.84 -                    map (fold_rev (NominalPackage.mk_perm [])
   18.85 +                    map (fold_rev (Nominal.mk_perm [])
   18.86                        (rev pis' @ pis)) params' @ [z])) ihyp;
   18.87                   fun mk_pi th =
   18.88                     Simplifier.simplify (HOL_basic_ss addsimps [@{thm id_apply}]
   18.89 -                       addsimprocs [NominalPackage.perm_simproc])
   18.90 +                       addsimprocs [Nominal.perm_simproc])
   18.91                       (Simplifier.simplify eqvt_ss
   18.92                         (fold_rev (mk_perm_bool o cterm_of thy)
   18.93                           (rev pis' @ pis) th));
   18.94 @@ -369,13 +369,13 @@
   18.95                         | _ $ (_ $ (_ $ lhs $ rhs)) =>
   18.96                             (curry (HOLogic.mk_not o HOLogic.mk_eq), lhs, rhs));
   18.97                       val th'' = Goal.prove ctxt'' [] [] (HOLogic.mk_Trueprop
   18.98 -                         (bop (fold_rev (NominalPackage.mk_perm []) pis lhs)
   18.99 -                            (fold_rev (NominalPackage.mk_perm []) pis rhs)))
  18.100 +                         (bop (fold_rev (Nominal.mk_perm []) pis lhs)
  18.101 +                            (fold_rev (Nominal.mk_perm []) pis rhs)))
  18.102                         (fn _ => simp_tac (HOL_basic_ss addsimps
  18.103                            (fresh_bij @ perm_bij)) 1 THEN rtac th' 1)
  18.104                     in Simplifier.simplify (eqvt_ss addsimps fresh_atm) th'' end)
  18.105                       vc_compat_ths;
  18.106 -                 val vc_compat_ths'' = NominalPackage.mk_not_sym vc_compat_ths';
  18.107 +                 val vc_compat_ths'' = Nominal.mk_not_sym vc_compat_ths';
  18.108                   (** Since swap_simps simplifies (pi :: 'a prm) o (x :: 'b) to x **)
  18.109                   (** we have to pre-simplify the rewrite rules                   **)
  18.110                   val swap_simps_ss = HOL_ss addsimps swap_simps @
  18.111 @@ -383,14 +383,14 @@
  18.112                        (vc_compat_ths'' @ freshs2');
  18.113                   val th = Goal.prove ctxt'' [] []
  18.114                     (HOLogic.mk_Trueprop (list_comb (P $ hd ts,
  18.115 -                     map (fold (NominalPackage.mk_perm []) pis') (tl ts))))
  18.116 +                     map (fold (Nominal.mk_perm []) pis') (tl ts))))
  18.117                     (fn _ => EVERY ([simp_tac eqvt_ss 1, rtac ihyp' 1,
  18.118                       REPEAT_DETERM_N (nprems_of ihyp - length gprems)
  18.119                         (simp_tac swap_simps_ss 1),
  18.120                       REPEAT_DETERM_N (length gprems)
  18.121                         (simp_tac (HOL_basic_ss
  18.122                            addsimps [inductive_forall_def']
  18.123 -                          addsimprocs [NominalPackage.perm_simproc]) 1 THEN
  18.124 +                          addsimprocs [Nominal.perm_simproc]) 1 THEN
  18.125                          resolve_tac gprems2 1)]));
  18.126                   val final = Goal.prove ctxt'' [] [] (term_of concl)
  18.127                     (fn _ => cut_facts_tac [th] 1 THEN full_simp_tac (HOL_ss
  18.128 @@ -435,7 +435,7 @@
  18.129               ((ps, qs, is, map (curry subst_bounds (rev ts)) prems), ctxt')
  18.130             end) (prems ~~ avoids) ctxt')
  18.131        end)
  18.132 -        (InductivePackage.partition_rules' raw_induct (intrs ~~ avoids') ~~
  18.133 +        (Inductive.partition_rules' raw_induct (intrs ~~ avoids') ~~
  18.134           elims);
  18.135  
  18.136      val cases_prems' =
  18.137 @@ -448,7 +448,7 @@
  18.138                    (Logic.list_implies
  18.139                      (mk_distinct qs @
  18.140                       maps (fn (t, T) => map (fn u => HOLogic.mk_Trueprop
  18.141 -                      (NominalPackage.fresh_const T (fastype_of u) $ t $ u))
  18.142 +                      (Nominal.fresh_const T (fastype_of u) $ t $ u))
  18.143                          args) qs,
  18.144                       HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  18.145                         (map HOLogic.dest_Trueprop prems))),
  18.146 @@ -499,13 +499,13 @@
  18.147                      chop (length vc_compat_ths - length args * length qs)
  18.148                        (map (first_order_mrs hyps2) vc_compat_ths);
  18.149                    val vc_compat_ths' =
  18.150 -                    NominalPackage.mk_not_sym vc_compat_ths1 @
  18.151 +                    Nominal.mk_not_sym vc_compat_ths1 @
  18.152                      flat (fst (fold_map inst_fresh hyps1 vc_compat_ths2));
  18.153                    val (freshs1, freshs2, ctxt3) = fold
  18.154                      (obtain_fresh_name (args @ map fst qs @ params'))
  18.155                      (map snd qs) ([], [], ctxt2);
  18.156 -                  val freshs2' = NominalPackage.mk_not_sym freshs2;
  18.157 -                  val pis = map (NominalPackage.perm_of_pair)
  18.158 +                  val freshs2' = Nominal.mk_not_sym freshs2;
  18.159 +                  val pis = map (Nominal.perm_of_pair)
  18.160                      ((freshs1 ~~ map fst qs) @ (params' ~~ freshs1));
  18.161                    val mk_pis = fold_rev mk_perm_bool (map (cterm_of thy) pis);
  18.162                    val obj = cterm_of thy (foldr1 HOLogic.mk_conj (map (map_aterms
  18.163 @@ -513,7 +513,7 @@
  18.164                             if x mem args then x
  18.165                             else (case AList.lookup op = tab x of
  18.166                               SOME y => y
  18.167 -                           | NONE => fold_rev (NominalPackage.mk_perm []) pis x)
  18.168 +                           | NONE => fold_rev (Nominal.mk_perm []) pis x)
  18.169                         | x => x) o HOLogic.dest_Trueprop o prop_of) case_hyps));
  18.170                    val inst = Thm.first_order_match (Thm.dest_arg
  18.171                      (Drule.strip_imp_concl (hd (cprems_of case_hyp))), obj);
  18.172 @@ -522,7 +522,7 @@
  18.173                         rtac (Thm.instantiate inst case_hyp) 1 THEN
  18.174                         SUBPROOF (fn {prems = fresh_hyps, ...} =>
  18.175                           let
  18.176 -                           val fresh_hyps' = NominalPackage.mk_not_sym fresh_hyps;
  18.177 +                           val fresh_hyps' = Nominal.mk_not_sym fresh_hyps;
  18.178                             val case_ss = cases_eqvt_ss addsimps freshs2' @
  18.179                               simp_fresh_atm (vc_compat_ths' @ fresh_hyps');
  18.180                             val fresh_fresh_ss = case_ss addsimps perm_fresh_fresh;
  18.181 @@ -548,13 +548,13 @@
  18.182          val rec_name = space_implode "_" (map Long_Name.base_name names);
  18.183          val rec_qualified = Binding.qualify false rec_name;
  18.184          val ind_case_names = RuleCases.case_names induct_cases;
  18.185 -        val induct_cases' = InductivePackage.partition_rules' raw_induct
  18.186 +        val induct_cases' = Inductive.partition_rules' raw_induct
  18.187            (intrs ~~ induct_cases); 
  18.188          val thss' = map (map atomize_intr) thss;
  18.189 -        val thsss = InductivePackage.partition_rules' raw_induct (intrs ~~ thss');
  18.190 +        val thsss = Inductive.partition_rules' raw_induct (intrs ~~ thss');
  18.191          val strong_raw_induct =
  18.192 -          mk_ind_proof ctxt thss' |> InductivePackage.rulify;
  18.193 -        val strong_cases = map (mk_cases_proof ##> InductivePackage.rulify)
  18.194 +          mk_ind_proof ctxt thss' |> Inductive.rulify;
  18.195 +        val strong_cases = map (mk_cases_proof ##> Inductive.rulify)
  18.196            (thsss ~~ elims ~~ cases_prems ~~ cases_prems');
  18.197          val strong_induct =
  18.198            if length names > 1 then
  18.199 @@ -587,17 +587,17 @@
  18.200    let
  18.201      val thy = ProofContext.theory_of ctxt;
  18.202      val ({names, ...}, {raw_induct, intrs, elims, ...}) =
  18.203 -      InductivePackage.the_inductive ctxt (Sign.intern_const thy s);
  18.204 +      Inductive.the_inductive ctxt (Sign.intern_const thy s);
  18.205      val raw_induct = atomize_induct ctxt raw_induct;
  18.206      val elims = map (atomize_induct ctxt) elims;
  18.207      val intrs = map atomize_intr intrs;
  18.208 -    val monos = InductivePackage.get_monos ctxt;
  18.209 -    val intrs' = InductivePackage.unpartition_rules intrs
  18.210 +    val monos = Inductive.get_monos ctxt;
  18.211 +    val intrs' = Inductive.unpartition_rules intrs
  18.212        (map (fn (((s, ths), (_, k)), th) =>
  18.213 -           (s, ths ~~ InductivePackage.infer_intro_vars th k ths))
  18.214 -         (InductivePackage.partition_rules raw_induct intrs ~~
  18.215 -          InductivePackage.arities_of raw_induct ~~ elims));
  18.216 -    val k = length (InductivePackage.params_of raw_induct);
  18.217 +           (s, ths ~~ Inductive.infer_intro_vars th k ths))
  18.218 +         (Inductive.partition_rules raw_induct intrs ~~
  18.219 +          Inductive.arities_of raw_induct ~~ elims));
  18.220 +    val k = length (Inductive.params_of raw_induct);
  18.221      val atoms' = NominalAtoms.atoms_of thy;
  18.222      val atoms =
  18.223        if null xatoms then atoms' else
  18.224 @@ -635,7 +635,7 @@
  18.225              val prems'' = map (fn th => Simplifier.simplify eqvt_ss
  18.226                (mk_perm_bool (cterm_of thy pi) th)) prems';
  18.227              val intr' = Drule.cterm_instantiate (map (cterm_of thy) vs ~~
  18.228 -               map (cterm_of thy o NominalPackage.mk_perm [] pi o term_of) params)
  18.229 +               map (cterm_of thy o Nominal.mk_perm [] pi o term_of) params)
  18.230                 intr
  18.231            in (rtac intr' THEN_ALL_NEW (TRY o resolve_tac prems'')) 1
  18.232            end) ctxt' 1 st
  18.233 @@ -655,7 +655,7 @@
  18.234                val (ts1, ts2) = chop k ts
  18.235              in
  18.236                HOLogic.mk_imp (p, list_comb (h, ts1 @
  18.237 -                map (NominalPackage.mk_perm [] pi') ts2))
  18.238 +                map (Nominal.mk_perm [] pi') ts2))
  18.239              end) ps)))
  18.240            (fn {context, ...} => EVERY (rtac raw_induct 1 :: map (fn intr_vs =>
  18.241                full_simp_tac eqvt_ss 1 THEN
    19.1 --- a/src/HOL/Nominal/nominal_inductive2.ML	Thu Jun 18 18:31:14 2009 -0700
    19.2 +++ b/src/HOL/Nominal/nominal_inductive2.ML	Fri Jun 19 17:23:21 2009 +0200
    19.3 @@ -56,7 +56,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 @@ -154,11 +154,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 @@ -249,7 +249,7 @@
   19.28        | lift_prem t = t;
   19.29  
   19.30      fun mk_fresh (x, T) = HOLogic.mk_Trueprop
   19.31 -      (NominalPackage.fresh_star_const T fsT $ x $ Bound 0);
   19.32 +      (Nominal.fresh_star_const T fsT $ x $ Bound 0);
   19.33  
   19.34      val (prems', prems'') = split_list (map (fn (params, sets, prems, (p, ts)) =>
   19.35        let
   19.36 @@ -270,7 +270,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 @@ -283,7 +283,7 @@
   19.46               if null (preds_of ps prem) then SOME prem
   19.47               else map_term (split_conj (K o I) names) prem prem) prems, q))))
   19.48          (maps (fn (t, T) => map (fn (u, U) => HOLogic.mk_Trueprop
   19.49 -           (NominalPackage.fresh_star_const U T $ u $ t)) sets)
   19.50 +           (Nominal.fresh_star_const U T $ u $ t)) sets)
   19.51               (ts ~~ binder_types (fastype_of p)) @
   19.52           map (fn (u, U) => HOLogic.mk_Trueprop (Const (@{const_name finite},
   19.53             HOLogic.mk_setT U --> HOLogic.boolT) $ u)) sets) |>
   19.54 @@ -339,7 +339,7 @@
   19.55          val th2' =
   19.56            Goal.prove ctxt [] []
   19.57              (list_all (map (pair "pi") pTs, HOLogic.mk_Trueprop
   19.58 -               (f $ fold_rev (NominalPackage.mk_perm (rev pTs))
   19.59 +               (f $ fold_rev (Nominal.mk_perm (rev pTs))
   19.60                    (pis1 @ pi :: pis2) l $ r)))
   19.61              (fn _ => cut_facts_tac [th2] 1 THEN
   19.62                 full_simp_tac (HOL_basic_ss addsimps perm_set_forget) 1) |>
   19.63 @@ -364,7 +364,7 @@
   19.64                   val params' = map term_of cparams'
   19.65                   val sets' = map (apfst (curry subst_bounds (rev params'))) sets;
   19.66                   val pi_sets = map (fn (t, _) =>
   19.67 -                   fold_rev (NominalPackage.mk_perm []) pis t) sets';
   19.68 +                   fold_rev (Nominal.mk_perm []) pis t) sets';
   19.69                   val (P, ts) = strip_comb (HOLogic.dest_Trueprop (term_of concl));
   19.70                   val gprems1 = List.mapPartial (fn (th, t) =>
   19.71                     if null (preds_of ps t) then SOME th
   19.72 @@ -380,7 +380,7 @@
   19.73                     in
   19.74                       Goal.prove ctxt' [] []
   19.75                         (HOLogic.mk_Trueprop (list_comb (h,
   19.76 -                          map (fold_rev (NominalPackage.mk_perm []) pis) ts)))
   19.77 +                          map (fold_rev (Nominal.mk_perm []) pis) ts)))
   19.78                         (fn _ => simp_tac (HOL_basic_ss addsimps
   19.79                            (fresh_star_bij @ finite_ineq)) 1 THEN rtac th' 1)
   19.80                     end) vc_compat_ths vc_compat_vs;
   19.81 @@ -400,11 +400,11 @@
   19.82                     end;
   19.83                   val pis'' = fold_rev (concat_perm #> map) pis' pis;
   19.84                   val ihyp' = inst_params thy vs_ihypt ihyp
   19.85 -                   (map (fold_rev (NominalPackage.mk_perm [])
   19.86 +                   (map (fold_rev (Nominal.mk_perm [])
   19.87                        (pis' @ pis) #> cterm_of thy) params' @ [cterm_of thy z]);
   19.88                   fun mk_pi th =
   19.89                     Simplifier.simplify (HOL_basic_ss addsimps [@{thm id_apply}]
   19.90 -                       addsimprocs [NominalPackage.perm_simproc])
   19.91 +                       addsimprocs [Nominal.perm_simproc])
   19.92                       (Simplifier.simplify eqvt_ss
   19.93                         (fold_rev (mk_perm_bool o cterm_of thy)
   19.94                           (pis' @ pis) th));
   19.95 @@ -419,13 +419,13 @@
   19.96                       (fresh_ths2 ~~ sets);
   19.97                   val th = Goal.prove ctxt'' [] []
   19.98                     (HOLogic.mk_Trueprop (list_comb (P $ hd ts,
   19.99 -                     map (fold_rev (NominalPackage.mk_perm []) pis') (tl ts))))
  19.100 +                     map (fold_rev (Nominal.mk_perm []) pis') (tl ts))))
  19.101                     (fn _ => EVERY ([simp_tac eqvt_ss 1, rtac ihyp' 1] @
  19.102                       map (fn th => rtac th 1) fresh_ths3 @
  19.103                       [REPEAT_DETERM_N (length gprems)
  19.104                         (simp_tac (HOL_basic_ss
  19.105                            addsimps [inductive_forall_def']
  19.106 -                          addsimprocs [NominalPackage.perm_simproc]) 1 THEN
  19.107 +                          addsimprocs [Nominal.perm_simproc]) 1 THEN
  19.108                          resolve_tac gprems2 1)]));
  19.109                   val final = Goal.prove ctxt'' [] [] (term_of concl)
  19.110                     (fn _ => cut_facts_tac [th] 1 THEN full_simp_tac (HOL_ss
  19.111 @@ -450,12 +450,12 @@
  19.112          val rec_name = space_implode "_" (map Long_Name.base_name names);
  19.113          val rec_qualified = Binding.qualify false rec_name;
  19.114          val ind_case_names = RuleCases.case_names induct_cases;
  19.115 -        val induct_cases' = InductivePackage.partition_rules' raw_induct
  19.116 +        val induct_cases' = Inductive.partition_rules' raw_induct
  19.117            (intrs ~~ induct_cases); 
  19.118          val thss' = map (map atomize_intr) thss;
  19.119 -        val thsss = InductivePackage.partition_rules' raw_induct (intrs ~~ thss');
  19.120 +        val thsss = Inductive.partition_rules' raw_induct (intrs ~~ thss');
  19.121          val strong_raw_induct =
  19.122 -          mk_ind_proof ctxt thss' |> InductivePackage.rulify;
  19.123 +          mk_ind_proof ctxt thss' |> Inductive.rulify;
  19.124          val strong_induct =
  19.125            if length names > 1 then
  19.126              (strong_raw_induct, [ind_case_names, RuleCases.consumes 0])
    20.1 --- a/src/HOL/Nominal/nominal_package.ML	Thu Jun 18 18:31:14 2009 -0700
    20.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    20.3 @@ -1,2095 +0,0 @@
    20.4 -(*  Title:      HOL/Nominal/nominal_package.ML
    20.5 -    Author:     Stefan Berghofer and Christian Urban, TU Muenchen
    20.6 -
    20.7 -Nominal datatype package for Isabelle/HOL.
    20.8 -*)
    20.9 -
   20.10 -signature NOMINAL_PACKAGE =
   20.11 -sig
   20.12 -  val add_nominal_datatype : DatatypeAux.datatype_config -> string list ->
   20.13 -    (string list * bstring * mixfix *
   20.14 -      (bstring * string list * mixfix) list) list -> theory -> theory
   20.15 -  type descr
   20.16 -  type nominal_datatype_info
   20.17 -  val get_nominal_datatypes : theory -> nominal_datatype_info Symtab.table
   20.18 -  val get_nominal_datatype : theory -> string -> nominal_datatype_info option
   20.19 -  val mk_perm: typ list -> term -> term -> term
   20.20 -  val perm_of_pair: term * term -> term
   20.21 -  val mk_not_sym: thm list -> thm list
   20.22 -  val perm_simproc: simproc
   20.23 -  val fresh_const: typ -> typ -> term
   20.24 -  val fresh_star_const: typ -> typ -> term
   20.25 -end
   20.26 -
   20.27 -structure NominalPackage : NOMINAL_PACKAGE =
   20.28 -struct
   20.29 -
   20.30 -val finite_emptyI = thm "finite.emptyI";
   20.31 -val finite_Diff = thm "finite_Diff";
   20.32 -val finite_Un = thm "finite_Un";
   20.33 -val Un_iff = thm "Un_iff";
   20.34 -val In0_eq = thm "In0_eq";
   20.35 -val In1_eq = thm "In1_eq";
   20.36 -val In0_not_In1 = thm "In0_not_In1";
   20.37 -val In1_not_In0 = thm "In1_not_In0";
   20.38 -val Un_assoc = thm "Un_assoc";
   20.39 -val Collect_disj_eq = thm "Collect_disj_eq";
   20.40 -val empty_def = thm "empty_def";
   20.41 -val empty_iff = thm "empty_iff";
   20.42 -
   20.43 -open DatatypeAux;
   20.44 -open NominalAtoms;
   20.45 -
   20.46 -(** FIXME: DatatypePackage should export this function **)
   20.47 -
   20.48 -local
   20.49 -
   20.50 -fun dt_recs (DtTFree _) = []
   20.51 -  | dt_recs (DtType (_, dts)) = List.concat (map dt_recs dts)
   20.52 -  | dt_recs (DtRec i) = [i];
   20.53 -
   20.54 -fun dt_cases (descr: descr) (_, args, constrs) =
   20.55 -  let
   20.56 -    fun the_bname i = Long_Name.base_name (#1 (valOf (AList.lookup (op =) descr i)));
   20.57 -    val bnames = map the_bname (distinct op = (List.concat (map dt_recs args)));
   20.58 -  in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
   20.59 -
   20.60 -
   20.61 -fun induct_cases descr =
   20.62 -  DatatypeProp.indexify_names (List.concat (map (dt_cases descr) (map #2 descr)));
   20.63 -
   20.64 -fun exhaust_cases descr i = dt_cases descr (valOf (AList.lookup (op =) descr i));
   20.65 -
   20.66 -in
   20.67 -
   20.68 -fun mk_case_names_induct descr = RuleCases.case_names (induct_cases descr);
   20.69 -
   20.70 -fun mk_case_names_exhausts descr new =
   20.71 -  map (RuleCases.case_names o exhaust_cases descr o #1)
   20.72 -    (List.filter (fn ((_, (name, _, _))) => name mem_string new) descr);
   20.73 -
   20.74 -end;
   20.75 -
   20.76 -(* theory data *)
   20.77 -
   20.78 -type descr = (int * (string * dtyp list * (string * (dtyp list * dtyp) list) list)) list;
   20.79 -
   20.80 -type nominal_datatype_info =
   20.81 -  {index : int,
   20.82 -   descr : descr,
   20.83 -   sorts : (string * sort) list,
   20.84 -   rec_names : string list,
   20.85 -   rec_rewrites : thm list,
   20.86 -   induction : thm,
   20.87 -   distinct : thm list,
   20.88 -   inject : thm list};
   20.89 -
   20.90 -structure NominalDatatypesData = TheoryDataFun
   20.91 -(
   20.92 -  type T = nominal_datatype_info Symtab.table;
   20.93 -  val empty = Symtab.empty;
   20.94 -  val copy = I;
   20.95 -  val extend = I;
   20.96 -  fun merge _ tabs : T = Symtab.merge (K true) tabs;
   20.97 -);
   20.98 -
   20.99 -val get_nominal_datatypes = NominalDatatypesData.get;
  20.100 -val put_nominal_datatypes = NominalDatatypesData.put;
  20.101 -val map_nominal_datatypes = NominalDatatypesData.map;
  20.102 -val get_nominal_datatype = Symtab.lookup o get_nominal_datatypes;
  20.103 -
  20.104 -
  20.105 -(**** make datatype info ****)
  20.106 -
  20.107 -fun make_dt_info descr sorts induct reccomb_names rec_thms
  20.108 -    (((i, (_, (tname, _, _))), distinct), inject) =
  20.109 -  (tname,
  20.110 -   {index = i,
  20.111 -    descr = descr,
  20.112 -    sorts = sorts,
  20.113 -    rec_names = reccomb_names,
  20.114 -    rec_rewrites = rec_thms,
  20.115 -    induction = induct,
  20.116 -    distinct = distinct,
  20.117 -    inject = inject});
  20.118 -
  20.119 -(*******************************)
  20.120 -
  20.121 -val (_ $ (_ $ (_ $ (distinct_f $ _) $ _))) = hd (prems_of distinct_lemma);
  20.122 -
  20.123 -
  20.124 -(** simplification procedure for sorting permutations **)
  20.125 -
  20.126 -val dj_cp = thm "dj_cp";
  20.127 -
  20.128 -fun dest_permT (Type ("fun", [Type ("List.list", [Type ("*", [T, _])]),
  20.129 -      Type ("fun", [_, U])])) = (T, U);
  20.130 -
  20.131 -fun permTs_of (Const ("Nominal.perm", T) $ t $ u) = fst (dest_permT T) :: permTs_of u
  20.132 -  | permTs_of _ = [];
  20.133 -
  20.134 -fun perm_simproc' thy ss (Const ("Nominal.perm", T) $ t $ (u as Const ("Nominal.perm", U) $ r $ s)) =
  20.135 -      let
  20.136 -        val (aT as Type (a, []), S) = dest_permT T;
  20.137 -        val (bT as Type (b, []), _) = dest_permT U
  20.138 -      in if aT mem permTs_of u andalso aT <> bT then
  20.139 -          let
  20.140 -            val cp = cp_inst_of thy a b;
  20.141 -            val dj = dj_thm_of thy b a;
  20.142 -            val dj_cp' = [cp, dj] MRS dj_cp;
  20.143 -            val cert = SOME o cterm_of thy
  20.144 -          in
  20.145 -            SOME (mk_meta_eq (Drule.instantiate' [SOME (ctyp_of thy S)]
  20.146 -              [cert t, cert r, cert s] dj_cp'))
  20.147 -          end
  20.148 -        else NONE
  20.149 -      end
  20.150 -  | perm_simproc' thy ss _ = NONE;
  20.151 -
  20.152 -val perm_simproc =
  20.153 -  Simplifier.simproc (the_context ()) "perm_simp" ["pi1 \<bullet> (pi2 \<bullet> x)"] perm_simproc';
  20.154 -
  20.155 -val meta_spec = thm "meta_spec";
  20.156 -
  20.157 -fun projections rule =
  20.158 -  ProjectRule.projections (ProofContext.init (Thm.theory_of_thm rule)) rule
  20.159 -  |> map (standard #> RuleCases.save rule);
  20.160 -
  20.161 -val supp_prod = thm "supp_prod";
  20.162 -val fresh_prod = thm "fresh_prod";
  20.163 -val supports_fresh = thm "supports_fresh";
  20.164 -val supports_def = thm "Nominal.supports_def";
  20.165 -val fresh_def = thm "fresh_def";
  20.166 -val supp_def = thm "supp_def";
  20.167 -val rev_simps = thms "rev.simps";
  20.168 -val app_simps = thms "append.simps";
  20.169 -val at_fin_set_supp = thm "at_fin_set_supp";
  20.170 -val at_fin_set_fresh = thm "at_fin_set_fresh";
  20.171 -val abs_fun_eq1 = thm "abs_fun_eq1";
  20.172 -
  20.173 -val collect_simp = rewrite_rule [mk_meta_eq mem_Collect_eq];
  20.174 -
  20.175 -fun mk_perm Ts t u =
  20.176 -  let
  20.177 -    val T = fastype_of1 (Ts, t);
  20.178 -    val U = fastype_of1 (Ts, u)
  20.179 -  in Const ("Nominal.perm", T --> U --> U) $ t $ u end;
  20.180 -
  20.181 -fun perm_of_pair (x, y) =
  20.182 -  let
  20.183 -    val T = fastype_of x;
  20.184 -    val pT = mk_permT T
  20.185 -  in Const ("List.list.Cons", HOLogic.mk_prodT (T, T) --> pT --> pT) $
  20.186 -    HOLogic.mk_prod (x, y) $ Const ("List.list.Nil", pT)
  20.187 -  end;
  20.188 -
  20.189 -fun mk_not_sym ths = maps (fn th => case prop_of th of
  20.190 -    _ $ (Const ("Not", _) $ (Const ("op =", _) $ _ $ _)) => [th, th RS not_sym]
  20.191 -  | _ => [th]) ths;
  20.192 -
  20.193 -fun fresh_const T U = Const ("Nominal.fresh", T --> U --> HOLogic.boolT);
  20.194 -fun fresh_star_const T U =
  20.195 -  Const ("Nominal.fresh_star", HOLogic.mk_setT T --> U --> HOLogic.boolT);
  20.196 -
  20.197 -fun gen_add_nominal_datatype prep_typ config new_type_names dts thy =
  20.198 -  let
  20.199 -    (* this theory is used just for parsing *)
  20.200 -
  20.201 -    val tmp_thy = thy |>
  20.202 -      Theory.copy |>
  20.203 -      Sign.add_types (map (fn (tvs, tname, mx, _) =>
  20.204 -        (Binding.name tname, length tvs, mx)) dts);
  20.205 -
  20.206 -    val atoms = atoms_of thy;
  20.207 -
  20.208 -    fun prep_constr ((constrs, sorts), (cname, cargs, mx)) =
  20.209 -      let val (cargs', sorts') = Library.foldl (prep_typ tmp_thy) (([], sorts), cargs)
  20.210 -      in (constrs @ [(cname, cargs', mx)], sorts') end
  20.211 -
  20.212 -    fun prep_dt_spec ((dts, sorts), (tvs, tname, mx, constrs)) =
  20.213 -      let val (constrs', sorts') = Library.foldl prep_constr (([], sorts), constrs)
  20.214 -      in (dts @ [(tvs, tname, mx, constrs')], sorts') end
  20.215 -
  20.216 -    val (dts', sorts) = Library.foldl prep_dt_spec (([], []), dts);
  20.217 -    val tyvars = map (map (fn s =>
  20.218 -      (s, the (AList.lookup (op =) sorts s))) o #1) dts';
  20.219 -
  20.220 -    fun inter_sort thy S S' = Type.inter_sort (Sign.tsig_of thy) (S, S');
  20.221 -    fun augment_sort_typ thy S =
  20.222 -      let val S = Sign.certify_sort thy S
  20.223 -      in map_type_tfree (fn (s, S') => TFree (s,
  20.224 -        if member (op = o apsnd fst) sorts s then inter_sort thy S S' else S'))
  20.225 -      end;
  20.226 -    fun augment_sort thy S = map_types (augment_sort_typ thy S);
  20.227 -
  20.228 -    val types_syntax = map (fn (tvs, tname, mx, constrs) => (tname, mx)) dts';
  20.229 -    val constr_syntax = map (fn (tvs, tname, mx, constrs) =>
  20.230 -      map (fn (cname, cargs, mx) => (cname, mx)) constrs) dts';
  20.231 -
  20.232 -    val ps = map (fn (_, n, _, _) =>
  20.233 -      (Sign.full_bname tmp_thy n, Sign.full_bname tmp_thy (n ^ "_Rep"))) dts;
  20.234 -    val rps = map Library.swap ps;
  20.235 -
  20.236 -    fun replace_types (Type ("Nominal.ABS", [T, U])) =
  20.237 -          Type ("fun", [T, Type ("Nominal.noption", [replace_types U])])
  20.238 -      | replace_types (Type (s, Ts)) =
  20.239 -          Type (getOpt (AList.lookup op = ps s, s), map replace_types Ts)
  20.240 -      | replace_types T = T;
  20.241 -
  20.242 -    val dts'' = map (fn (tvs, tname, mx, constrs) => (tvs, Binding.name (tname ^ "_Rep"), NoSyn,
  20.243 -      map (fn (cname, cargs, mx) => (Binding.name (cname ^ "_Rep"),
  20.244 -        map replace_types cargs, NoSyn)) constrs)) dts';
  20.245 -
  20.246 -    val new_type_names' = map (fn n => n ^ "_Rep") new_type_names;
  20.247 -    val full_new_type_names' = map (Sign.full_bname thy) new_type_names';
  20.248 -
  20.249 -    val ({induction, ...},thy1) =
  20.250 -      DatatypePackage.add_datatype config new_type_names' dts'' thy;
  20.251 -
  20.252 -    val SOME {descr, ...} = Symtab.lookup
  20.253 -      (DatatypePackage.get_datatypes thy1) (hd full_new_type_names');
  20.254 -    fun nth_dtyp i = typ_of_dtyp descr sorts (DtRec i);
  20.255 -
  20.256 -    val big_name = space_implode "_" new_type_names;
  20.257 -
  20.258 -
  20.259 -    (**** define permutation functions ****)
  20.260 -
  20.261 -    val permT = mk_permT (TFree ("'x", HOLogic.typeS));
  20.262 -    val pi = Free ("pi", permT);
  20.263 -    val perm_types = map (fn (i, _) =>
  20.264 -      let val T = nth_dtyp i
  20.265 -      in permT --> T --> T end) descr;
  20.266 -    val perm_names' = DatatypeProp.indexify_names (map (fn (i, _) =>
  20.267 -      "perm_" ^ name_of_typ (nth_dtyp i)) descr);
  20.268 -    val perm_names = replicate (length new_type_names) "Nominal.perm" @
  20.269 -      map (Sign.full_bname thy1) (List.drop (perm_names', length new_type_names));
  20.270 -    val perm_names_types = perm_names ~~ perm_types;
  20.271 -    val perm_names_types' = perm_names' ~~ perm_types;
  20.272 -
  20.273 -    val perm_eqs = maps (fn (i, (_, _, constrs)) =>
  20.274 -      let val T = nth_dtyp i
  20.275 -      in map (fn (cname, dts) =>
  20.276 -        let
  20.277 -          val Ts = map (typ_of_dtyp descr sorts) dts;
  20.278 -          val names = Name.variant_list ["pi"] (DatatypeProp.make_tnames Ts);
  20.279 -          val args = map Free (names ~~ Ts);
  20.280 -          val c = Const (cname, Ts ---> T);
  20.281 -          fun perm_arg (dt, x) =
  20.282 -            let val T = type_of x
  20.283 -            in if is_rec_type dt then
  20.284 -                let val (Us, _) = strip_type T
  20.285 -                in list_abs (map (pair "x") Us,
  20.286 -                  Free (nth perm_names_types' (body_index dt)) $ pi $
  20.287 -                    list_comb (x, map (fn (i, U) =>
  20.288 -                      Const ("Nominal.perm", permT --> U --> U) $
  20.289 -                        (Const ("List.rev", permT --> permT) $ pi) $
  20.290 -                        Bound i) ((length Us - 1 downto 0) ~~ Us)))
  20.291 -                end
  20.292 -              else Const ("Nominal.perm", permT --> T --> T) $ pi $ x
  20.293 -            end;
  20.294 -        in
  20.295 -          (Attrib.empty_binding, HOLogic.mk_Trueprop (HOLogic.mk_eq
  20.296 -            (Free (nth perm_names_types' i) $
  20.297 -               Free ("pi", mk_permT (TFree ("'x", HOLogic.typeS))) $
  20.298 -               list_comb (c, args),
  20.299 -             list_comb (c, map perm_arg (dts ~~ args)))))
  20.300 -        end) constrs
  20.301 -      end) descr;
  20.302 -
  20.303 -    val (perm_simps, thy2) =
  20.304 -      PrimrecPackage.add_primrec_overloaded
  20.305 -        (map (fn (s, sT) => (s, sT, false))
  20.306 -           (List.take (perm_names' ~~ perm_names_types, length new_type_names)))
  20.307 -        (map (fn s => (Binding.name s, NONE, NoSyn)) perm_names') perm_eqs thy1;
  20.308 -
  20.309 -    (**** prove that permutation functions introduced by unfolding are ****)
  20.310 -    (**** equivalent to already existing permutation functions         ****)
  20.311 -
  20.312 -    val _ = warning ("length descr: " ^ string_of_int (length descr));
  20.313 -    val _ = warning ("length new_type_names: " ^ string_of_int (length new_type_names));
  20.314 -
  20.315 -    val perm_indnames = DatatypeProp.make_tnames (map body_type perm_types);
  20.316 -    val perm_fun_def = PureThy.get_thm thy2 "perm_fun_def";
  20.317 -
  20.318 -    val unfolded_perm_eq_thms =
  20.319 -      if length descr = length new_type_names then []
  20.320 -      else map standard (List.drop (split_conj_thm
  20.321 -        (Goal.prove_global thy2 [] []
  20.322 -          (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  20.323 -            (map (fn (c as (s, T), x) =>
  20.324 -               let val [T1, T2] = binder_types T
  20.325 -               in HOLogic.mk_eq (Const c $ pi $ Free (x, T2),
  20.326 -                 Const ("Nominal.perm", T) $ pi $ Free (x, T2))
  20.327 -               end)
  20.328 -             (perm_names_types ~~ perm_indnames))))
  20.329 -          (fn _ => EVERY [indtac induction perm_indnames 1,
  20.330 -            ALLGOALS (asm_full_simp_tac
  20.331 -              (simpset_of thy2 addsimps [perm_fun_def]))])),
  20.332 -        length new_type_names));
  20.333 -
  20.334 -    (**** prove [] \<bullet> t = t ****)
  20.335 -
  20.336 -    val _ = warning "perm_empty_thms";
  20.337 -
  20.338 -    val perm_empty_thms = List.concat (map (fn a =>
  20.339 -      let val permT = mk_permT (Type (a, []))
  20.340 -      in map standard (List.take (split_conj_thm
  20.341 -        (Goal.prove_global thy2 [] []
  20.342 -          (augment_sort thy2 [pt_class_of thy2 a]
  20.343 -            (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  20.344 -              (map (fn ((s, T), x) => HOLogic.mk_eq
  20.345 -                  (Const (s, permT --> T --> T) $
  20.346 -                     Const ("List.list.Nil", permT) $ Free (x, T),
  20.347 -                   Free (x, T)))
  20.348 -               (perm_names ~~
  20.349 -                map body_type perm_types ~~ perm_indnames)))))
  20.350 -          (fn _ => EVERY [indtac induction perm_indnames 1,
  20.351 -            ALLGOALS (asm_full_simp_tac (simpset_of thy2))])),
  20.352 -        length new_type_names))
  20.353 -      end)
  20.354 -      atoms);
  20.355 -
  20.356 -    (**** prove (pi1 @ pi2) \<bullet> t = pi1 \<bullet> (pi2 \<bullet> t) ****)
  20.357 -
  20.358 -    val _ = warning "perm_append_thms";
  20.359 -
  20.360 -    (*FIXME: these should be looked up statically*)
  20.361 -    val at_pt_inst = PureThy.get_thm thy2 "at_pt_inst";
  20.362 -    val pt2 = PureThy.get_thm thy2 "pt2";
  20.363 -
  20.364 -    val perm_append_thms = List.concat (map (fn a =>
  20.365 -      let
  20.366 -        val permT = mk_permT (Type (a, []));
  20.367 -        val pi1 = Free ("pi1", permT);
  20.368 -        val pi2 = Free ("pi2", permT);
  20.369 -        val pt_inst = pt_inst_of thy2 a;
  20.370 -        val pt2' = pt_inst RS pt2;
  20.371 -        val pt2_ax = PureThy.get_thm thy2 (Long_Name.map_base_name (fn s => "pt_" ^ s ^ "2") a);
  20.372 -      in List.take (map standard (split_conj_thm
  20.373 -        (Goal.prove_global thy2 [] []
  20.374 -           (augment_sort thy2 [pt_class_of thy2 a]
  20.375 -             (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  20.376 -                (map (fn ((s, T), x) =>
  20.377 -                    let val perm = Const (s, permT --> T --> T)
  20.378 -                    in HOLogic.mk_eq
  20.379 -                      (perm $ (Const ("List.append", permT --> permT --> permT) $
  20.380 -                         pi1 $ pi2) $ Free (x, T),
  20.381 -                       perm $ pi1 $ (perm $ pi2 $ Free (x, T)))
  20.382 -                    end)
  20.383 -                  (perm_names ~~
  20.384 -                   map body_type perm_types ~~ perm_indnames)))))
  20.385 -           (fn _ => EVERY [indtac induction perm_indnames 1,
  20.386 -              ALLGOALS (asm_full_simp_tac (simpset_of thy2 addsimps [pt2', pt2_ax]))]))),
  20.387 -         length new_type_names)
  20.388 -      end) atoms);
  20.389 -
  20.390 -    (**** prove pi1 ~ pi2 ==> pi1 \<bullet> t = pi2 \<bullet> t ****)
  20.391 -
  20.392 -    val _ = warning "perm_eq_thms";
  20.393 -
  20.394 -    val pt3 = PureThy.get_thm thy2 "pt3";
  20.395 -    val pt3_rev = PureThy.get_thm thy2 "pt3_rev";
  20.396 -
  20.397 -    val perm_eq_thms = List.concat (map (fn a =>
  20.398 -      let
  20.399 -        val permT = mk_permT (Type (a, []));
  20.400 -        val pi1 = Free ("pi1", permT);
  20.401 -        val pi2 = Free ("pi2", permT);
  20.402 -        val at_inst = at_inst_of thy2 a;
  20.403 -        val pt_inst = pt_inst_of thy2 a;
  20.404 -        val pt3' = pt_inst RS pt3;
  20.405 -        val pt3_rev' = at_inst RS (pt_inst RS pt3_rev);
  20.406 -        val pt3_ax = PureThy.get_thm thy2 (Long_Name.map_base_name (fn s => "pt_" ^ s ^ "3") a);
  20.407 -      in List.take (map standard (split_conj_thm
  20.408 -        (Goal.prove_global thy2 [] []
  20.409 -          (augment_sort thy2 [pt_class_of thy2 a] (Logic.mk_implies
  20.410 -             (HOLogic.mk_Trueprop (Const ("Nominal.prm_eq",
  20.411 -                permT --> permT --> HOLogic.boolT) $ pi1 $ pi2),
  20.412 -              HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  20.413 -                (map (fn ((s, T), x) =>
  20.414 -                    let val perm = Const (s, permT --> T --> T)
  20.415 -                    in HOLogic.mk_eq
  20.416 -                      (perm $ pi1 $ Free (x, T),
  20.417 -                       perm $ pi2 $ Free (x, T))
  20.418 -                    end)
  20.419 -                  (perm_names ~~
  20.420 -                   map body_type perm_types ~~ perm_indnames))))))
  20.421 -           (fn _ => EVERY [indtac induction perm_indnames 1,
  20.422 -              ALLGOALS (asm_full_simp_tac (simpset_of thy2 addsimps [pt3', pt3_rev', pt3_ax]))]))),
  20.423 -         length new_type_names)
  20.424 -      end) atoms);
  20.425 -
  20.426 -    (**** prove pi1 \<bullet> (pi2 \<bullet> t) = (pi1 \<bullet> pi2) \<bullet> (pi1 \<bullet> t) ****)
  20.427 -
  20.428 -    val cp1 = PureThy.get_thm thy2 "cp1";
  20.429 -    val dj_cp = PureThy.get_thm thy2 "dj_cp";
  20.430 -    val pt_perm_compose = PureThy.get_thm thy2 "pt_perm_compose";
  20.431 -    val pt_perm_compose_rev = PureThy.get_thm thy2 "pt_perm_compose_rev";
  20.432 -    val dj_perm_perm_forget = PureThy.get_thm thy2 "dj_perm_perm_forget";
  20.433 -
  20.434 -    fun composition_instance name1 name2 thy =
  20.435 -      let
  20.436 -        val cp_class = cp_class_of thy name1 name2;
  20.437 -        val pt_class =
  20.438 -          if name1 = name2 then [pt_class_of thy name1]
  20.439 -          else [];
  20.440 -        val permT1 = mk_permT (Type (name1, []));
  20.441 -        val permT2 = mk_permT (Type (name2, []));
  20.442 -        val Ts = map body_type perm_types;
  20.443 -        val cp_inst = cp_inst_of thy name1 name2;
  20.444 -        val simps = simpset_of thy addsimps (perm_fun_def ::
  20.445 -          (if name1 <> name2 then
  20.446 -             let val dj = dj_thm_of thy name2 name1
  20.447 -             in [dj RS (cp_inst RS dj_cp), dj RS dj_perm_perm_forget] end
  20.448 -           else
  20.449 -             let
  20.450 -               val at_inst = at_inst_of thy name1;
  20.451 -               val pt_inst = pt_inst_of thy name1;
  20.452 -             in
  20.453 -               [cp_inst RS cp1 RS sym,
  20.454 -                at_inst RS (pt_inst RS pt_perm_compose) RS sym,
  20.455 -                at_inst RS (pt_inst RS pt_perm_compose_rev) RS sym]
  20.456 -            end))
  20.457 -        val sort = Sign.certify_sort thy (cp_class :: pt_class);
  20.458 -        val thms = split_conj_thm (Goal.prove_global thy [] []
  20.459 -          (augment_sort thy sort
  20.460 -            (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
  20.461 -              (map (fn ((s, T), x) =>
  20.462 -                  let
  20.463 -                    val pi1 = Free ("pi1", permT1);
  20.464 -                    val pi2 = Free ("pi2", permT2);
  20.465 -                    val perm1 = Const (s, permT1 --> T --> T);
  20.466 -                    val perm2 = Const (s, permT2 --> T --> T);
  20.467 -                    val perm3 = Const ("Nominal.perm", permT1 --> permT2 --> permT2)
  20.468 -                  in HOLogic.mk_eq
  20.469 -                    (perm1 $ pi1 $ (perm2 $ pi2 $ Free (x, T)),
  20.470 -                     perm2 $ (perm3 $ pi1 $ pi2) $ (perm1 $ pi1 $ Free (x, T)))
  20.471 -                  end)
  20.472 -                (perm_names ~~ Ts ~~ perm_indnames)))))
  20.473 -          (fn _ => EVERY [indtac induction perm_indnames 1,
  20.474 -             ALLGOALS (asm_full_simp_tac simps)]))
  20.475 -      in
  20.476 -        fold (fn (s, tvs) => fn thy => AxClass.prove_arity
  20.477 -            (s, map (inter_sort thy sort o snd) tvs, [cp_class])
  20.478 -            (Class.intro_classes_tac [] THEN ALLGOALS (resolve_tac thms)) thy)
  20.479 -          (full_new_type_names' ~~ tyvars) thy
  20.480 -      end;
  20.481 -
  20.482 -    val (perm_thmss,thy3) = thy2 |>
  20.483 -      fold (fn name1 => fold (composition_instance name1) atoms) atoms |>
  20.484 -      fold (fn atom => fn thy =>
  20.485 -        let val pt_name = pt_class_of thy atom
  20.486 -        in
  20.487 -          fold (fn (s, tvs) => fn thy => AxClass.prove_arity
  20.488 -              (s, map (inter_sort thy [pt_name] o snd) tvs, [pt_name])
  20.489 -              (EVERY
  20.490 -                [Class.intro_classes_tac [],
  20.491 -                 resolve_tac perm_empty_thms 1,
  20.492 -                 resolve_tac perm_append_thms 1,
  20.493 -                 resolve_tac perm_eq_thms 1, assume_tac 1]) thy)
  20.494 -            (full_new_type_names' ~~ tyvars) thy
  20.495 -        end) atoms |>
  20.496 -      PureThy.add_thmss
  20.497 -        [((Binding.name (space_implode "_" new_type_names ^ "_unfolded_perm_eq"),
  20.498 -          unfolded_perm_eq_thms), [Simplifier.simp_add]),
  20.499 -         ((Binding.name (space_implode "_" new_type_names ^ "_perm_empty"),
  20.500 -          perm_empty_thms), [Simplifier.simp_add]),
  20.501 -         ((Binding.name (space_implode "_" new_type_names ^ "_perm_append"),
  20.502 -          perm_append_thms), [Simplifier.simp_add]),
  20.503 -         ((Binding.name (space_implode "_" new_type_names ^ "_perm_eq"),
  20.504 -          perm_eq_thms), [Simplifier.simp_add])];
  20.505 -
  20.506 -    (**** Define representing sets ****)
  20.507 -
  20.508 -    val _ = warning "representing sets";
  20.509 -
  20.510 -    val rep_set_names = DatatypeProp.indexify_names
  20.511 -      (map (fn (i, _) => name_of_typ (nth_dtyp i) ^ "_set") descr);
  20.512 -    val big_rep_name =
  20.513 -      space_implode "_" (DatatypeProp.indexify_names (List.mapPartial
  20.514 -        (fn (i, ("Nominal.noption", _, _)) => NONE
  20.515 -          | (i, _) => SOME (name_of_typ (nth_dtyp i))) descr)) ^ "_set";
  20.516 -    val _ = warning ("big_rep_name: " ^ big_rep_name);
  20.517 -
  20.518 -    fun strip_option (dtf as DtType ("fun", [dt, DtRec i])) =
  20.519 -          (case AList.lookup op = descr i of
  20.520 -             SOME ("Nominal.noption", _, [(_, [dt']), _]) =>
  20.521 -               apfst (cons dt) (strip_option dt')
  20.522 -           | _ => ([], dtf))
  20.523 -      | strip_option (DtType ("fun", [dt, DtType ("Nominal.noption", [dt'])])) =
  20.524 -          apfst (cons dt) (strip_option dt')
  20.525 -      | strip_option dt = ([], dt);
  20.526 -
  20.527 -    val dt_atomTs = distinct op = (map (typ_of_dtyp descr sorts)
  20.528 -      (List.concat (map (fn (_, (_, _, cs)) => List.concat
  20.529 -        (map (List.concat o map (fst o strip_option) o snd) cs)) descr)));
  20.530 -    val dt_atoms = map (fst o dest_Type) dt_atomTs;
  20.531 -
  20.532 -    fun make_intr s T (cname, cargs) =
  20.533 -      let
  20.534 -        fun mk_prem (dt, (j, j', prems, ts)) =
  20.535 -          let
  20.536 -            val (dts, dt') = strip_option dt;
  20.537 -            val (dts', dt'') = strip_dtyp dt';
  20.538 -            val Ts = map (typ_of_dtyp descr sorts) dts;
  20.539 -            val Us = map (typ_of_dtyp descr sorts) dts';
  20.540 -            val T = typ_of_dtyp descr sorts dt'';
  20.541 -            val free = mk_Free "x" (Us ---> T) j;
  20.542 -            val free' = app_bnds free (length Us);
  20.543 -            fun mk_abs_fun (T, (i, t)) =
  20.544 -              let val U = fastype_of t
  20.545 -              in (i + 1, Const ("Nominal.abs_fun", [T, U, T] --->
  20.546 -                Type ("Nominal.noption", [U])) $ mk_Free "y" T i $ t)
  20.547 -              end
  20.548 -          in (j + 1, j' + length Ts,
  20.549 -            case dt'' of
  20.550 -                DtRec k => list_all (map (pair "x") Us,
  20.551 -                  HOLogic.mk_Trueprop (Free (List.nth (rep_set_names, k),
  20.552 -                    T --> HOLogic.boolT) $ free')) :: prems
  20.553 -              | _ => prems,
  20.554 -            snd (List.foldr mk_abs_fun (j', free) Ts) :: ts)
  20.555 -          end;
  20.556 -
  20.557 -        val (_, _, prems, ts) = List.foldr mk_prem (1, 1, [], []) cargs;
  20.558 -        val concl = HOLogic.mk_Trueprop (Free (s, T --> HOLogic.boolT) $
  20.559 -          list_comb (Const (cname, map fastype_of ts ---> T), ts))
  20.560 -      in Logic.list_implies (prems, concl)
  20.561 -      end;
  20.562 -
  20.563 -    val (intr_ts, (rep_set_names', recTs')) =
  20.564 -      apfst List.concat (apsnd ListPair.unzip (ListPair.unzip (List.mapPartial
  20.565 -        (fn ((_, ("Nominal.noption", _, _)), _) => NONE
  20.566 -          | ((i, (_, _, constrs)), rep_set_name) =>
  20.567 -              let val T = nth_dtyp i
  20.568 -              in SOME (map (make_intr rep_set_name T) constrs,
  20.569 -                (rep_set_name, T))
  20.570 -              end)
  20.571 -                (descr ~~ rep_set_names))));
  20.572 -    val rep_set_names'' = map (Sign.full_bname thy3) rep_set_names';
  20.573 -
  20.574 -    val ({raw_induct = rep_induct, intrs = rep_intrs, ...}, thy4) =
  20.575 -        InductivePackage.add_inductive_global (serial_string ())
  20.576 -          {quiet_mode = false, verbose = false, kind = Thm.internalK,
  20.577 -           alt_name = Binding.name big_rep_name, coind = false, no_elim = true, no_ind = false,
  20.578 -           skip_mono = true, fork_mono = false}
  20.579 -          (map (fn (s, T) => ((Binding.name s, T --> HOLogic.boolT), NoSyn))
  20.580 -             (rep_set_names' ~~ recTs'))
  20.581 -          [] (map (fn x => (Attrib.empty_binding, x)) intr_ts) [] thy3;
  20.582 -
  20.583 -    (**** Prove that representing set is closed under permutation ****)
  20.584 -
  20.585 -    val _ = warning "proving closure under permutation...";
  20.586 -
  20.587 -    val abs_perm = PureThy.get_thms thy4 "abs_perm";
  20.588 -
  20.589 -    val perm_indnames' = List.mapPartial
  20.590 -      (fn (x, (_, ("Nominal.noption", _, _))) => NONE | (x, _) => SOME x)
  20.591 -      (perm_indnames ~~ descr);
  20.592 -
  20.593 -    fun mk_perm_closed name = map (fn th => standard (th RS mp))
  20.594 -      (List.take (split_conj_thm (Goal.prove_global thy4 [] []
  20.595 -        (augment_sort thy4
  20.596 -          (pt_class_of thy4 name :: map (cp_class_of thy4 name) (dt_atoms \ name))
  20.597 -          (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map
  20.598 -            (fn ((s, T), x) =>
  20.599 -               let
  20.600 -                 val S = Const (s, T --> HOLogic.boolT);
  20.601 -                 val permT = mk_permT (Type (name, []))
  20.602 -               in HOLogic.mk_imp (S $ Free (x, T),
  20.603 -                 S $ (Const ("Nominal.perm", permT --> T --> T) $
  20.604 -                   Free ("pi", permT) $ Free (x, T)))
  20.605 -               end) (rep_set_names'' ~~ recTs' ~~ perm_indnames')))))
  20.606 -        (fn _ => EVERY
  20.607 -           [indtac rep_induct [] 1,
  20.608 -            ALLGOALS (simp_tac (simpset_of thy4 addsimps
  20.609 -              (symmetric perm_fun_def :: abs_perm))),
  20.610 -            ALLGOALS (resolve_tac rep_intrs THEN_ALL_NEW assume_tac)])),
  20.611 -        length new_type_names));
  20.612 -
  20.613 -    val perm_closed_thmss = map mk_perm_closed atoms;
  20.614 -
  20.615 -    (**** typedef ****)
  20.616 -
  20.617 -    val _ = warning "defining type...";
  20.618 -
  20.619 -    val (typedefs, thy6) =
  20.620 -      thy4
  20.621 -      |> fold_map (fn ((((name, mx), tvs), (cname, U)), name') => fn thy =>
  20.622 -          TypedefPackage.add_typedef false (SOME (Binding.name name'))
  20.623 -            (Binding.name name, map fst tvs, mx)
  20.624 -            (Const ("Collect", (U --> HOLogic.boolT) --> HOLogic.mk_setT U) $
  20.625 -               Const (cname, U --> HOLogic.boolT)) NONE
  20.626 -            (rtac exI 1 THEN rtac CollectI 1 THEN
  20.627 -              QUIET_BREADTH_FIRST (has_fewer_prems 1)
  20.628 -              (resolve_tac rep_intrs 1)) thy |> (fn ((_, r), thy) =>
  20.629 -        let
  20.630 -          val permT = mk_permT
  20.631 -            (TFree (Name.variant (map fst tvs) "'a", HOLogic.typeS));
  20.632 -          val pi = Free ("pi", permT);
  20.633 -          val T = Type (Sign.intern_type thy name, map TFree tvs);
  20.634 -        in apfst (pair r o hd)
  20.635 -          (PureThy.add_defs_unchecked true [((Binding.name ("prm_" ^ name ^ "_def"), Logic.mk_equals
  20.636 -            (Const ("Nominal.perm", permT --> T --> T) $ pi $ Free ("x", T),
  20.637 -             Const (Sign.intern_const thy ("Abs_" ^ name), U --> T) $
  20.638 -               (Const ("Nominal.perm", permT --> U --> U) $ pi $
  20.639 -                 (Const (Sign.intern_const thy ("Rep_" ^ name), T --> U) $
  20.640 -                   Free ("x", T))))), [])] thy)
  20.641 -        end))
  20.642 -          (types_syntax ~~ tyvars ~~
  20.643 -            List.take (rep_set_names'' ~~ recTs', length new_type_names) ~~
  20.644 -            new_type_names);
  20.645 -
  20.646 -    val perm_defs = map snd typedefs;
  20.647 -    val Abs_inverse_thms = map (collect_simp o #Abs_inverse o fst) typedefs;
  20.648 -    val Rep_inverse_thms = map (#Rep_inverse o fst) typedefs;
  20.649 -    val Rep_thms = map (collect_simp o #Rep o fst) typedefs;
  20.650 -
  20.651 -
  20.652 -    (** prove that new types are in class pt_<name> **)
  20.653 -
  20.654 -    val _ = warning "prove that new types are in class pt_<name> ...";
  20.655 -
  20.656 -    fun pt_instance (atom, perm_closed_thms) =
  20.657 -      fold (fn ((((((Abs_inverse, Rep_inverse), Rep),
  20.658 -        perm_def), name), tvs), perm_closed) => fn thy =>
  20.659 -          let
  20.660 -            val pt_class = pt_class_of thy atom;
  20.661 -            val sort = Sign.certify_sort thy
  20.662 -              (pt_class :: map (cp_class_of thy atom) (dt_atoms \ atom))
  20.663 -          in AxClass.prove_arity
  20.664 -            (Sign.intern_type thy name,
  20.665 -              map (inter_sort thy sort o snd) tvs, [pt_class])
  20.666 -            (EVERY [Class.intro_classes_tac [],
  20.667 -              rewrite_goals_tac [perm_def],
  20.668 -              asm_full_simp_tac (simpset_of thy addsimps [Rep_inverse]) 1,
  20.669 -              asm_full_simp_tac (simpset_of thy addsimps
  20.670 -                [Rep RS perm_closed RS Abs_inverse]) 1,
  20.671 -              asm_full_simp_tac (HOL_basic_ss addsimps [PureThy.get_thm thy
  20.672 -                ("pt_" ^ Long_Name.base_name atom ^ "3")]) 1]) thy
  20.673 -          end)
  20.674 -        (Abs_inverse_thms ~~ Rep_inverse_thms ~~ Rep_thms ~~ perm_defs ~~
  20.675 -           new_type_names ~~ tyvars ~~ perm_closed_thms);
  20.676 -
  20.677 -
  20.678 -    (** prove that new types are in class cp_<name1>_<name2> **)
  20.679 -
  20.680 -    val _ = warning "prove that new types are in class cp_<name1>_<name2> ...";
  20.681 -
  20.682 -    fun cp_instance (atom1, perm_closed_thms1) (atom2, perm_closed_thms2) thy =
  20.683 -      let
  20.684 -        val cp_class = cp_class_of thy atom1 atom2;
  20.685 -        val sort = Sign.certify_sort thy
  20.686 -          (pt_class_of thy atom1 :: map (cp_class_of thy atom1) (dt_atoms \ atom1) @
  20.687 -           (if atom1 = atom2 then [cp_class_of thy atom1 atom1] else
  20.688 -            pt_class_of thy atom2 :: map (cp_class_of thy atom2) (dt_atoms \ atom2)));
  20.689 -        val cp1' = cp_inst_of thy atom1 atom2 RS cp1
  20.690 -      in fold (fn ((((((Abs_inverse, Rep),
  20.691 -        perm_def), name), tvs), perm_closed1), perm_closed2) => fn thy =>
  20.692 -          AxClass.prove_arity
  20.693 -            (Sign.intern_type thy name,
  20.694 -              map (inter_sort thy sort o snd) tvs, [cp_class])
  20.695 -            (EVERY [Class.intro_classes_tac [],
  20.696 -              rewrite_goals_tac [perm_def],
  20.697 -              asm_full_simp_tac (simpset_of thy addsimps
  20.698 -                ((Rep RS perm_closed1 RS Abs_inverse) ::
  20.699 -                 (if atom1 = atom2 then []
  20.700 -                  else [Rep RS perm_closed2 RS Abs_inverse]))) 1,
  20.701 -              cong_tac 1,
  20.702 -              rtac refl 1,
  20.703 -              rtac cp1' 1]) thy)
  20.704 -        (Abs_inverse_thms ~~ Rep_thms ~~ perm_defs ~~ new_type_names ~~
  20.705 -           tyvars ~~ perm_closed_thms1 ~~ perm_closed_thms2) thy
  20.706 -      end;
  20.707 -
  20.708 -    val thy7 = fold (fn x => fn thy => thy |>
  20.709 -      pt_instance x |>
  20.710 -      fold (cp_instance x) (atoms ~~ perm_closed_thmss))
  20.711 -        (atoms ~~ perm_closed_thmss) thy6;
  20.712 -
  20.713 -    (**** constructors ****)
  20.714 -
  20.715 -    fun mk_abs_fun (x, t) =
  20.716 -      let
  20.717 -        val T = fastype_of x;
  20.718 -        val U = fastype_of t
  20.719 -      in
  20.720 -        Const ("Nominal.abs_fun", T --> U --> T -->
  20.721 -          Type ("Nominal.noption", [U])) $ x $ t
  20.722 -      end;
  20.723 -
  20.724 -    val (ty_idxs, _) = List.foldl
  20.725 -      (fn ((i, ("Nominal.noption", _, _)), p) => p
  20.726 -        | ((i, _), (ty_idxs, j)) => (ty_idxs @ [(i, j)], j + 1)) ([], 0) descr;
  20.727 -
  20.728 -    fun reindex (DtType (s, dts)) = DtType (s, map reindex dts)
  20.729 -      | reindex (DtRec i) = DtRec (the (AList.lookup op = ty_idxs i))
  20.730 -      | reindex dt = dt;
  20.731 -
  20.732 -    fun strip_suffix i s = implode (List.take (explode s, size s - i));
  20.733 -
  20.734 -    (** strips the "_Rep" in type names *)
  20.735 -    fun strip_nth_name i s =
  20.736 -      let val xs = Long_Name.explode s;
  20.737 -      in Long_Name.implode (Library.nth_map (length xs - i) (strip_suffix 4) xs) end;
  20.738 -
  20.739 -    val (descr'', ndescr) = ListPair.unzip (map_filter
  20.740 -      (fn (i, ("Nominal.noption", _, _)) => NONE
  20.741 -        | (i, (s, dts, constrs)) =>
  20.742 -             let
  20.743 -               val SOME index = AList.lookup op = ty_idxs i;
  20.744 -               val (constrs2, constrs1) =
  20.745 -                 map_split (fn (cname, cargs) =>
  20.746 -                   apsnd (pair (strip_nth_name 2 (strip_nth_name 1 cname)))
  20.747 -                   (fold_map (fn dt => fn dts =>
  20.748 -                     let val (dts', dt') = strip_option dt
  20.749 -                     in ((length dts, length dts'), dts @ dts' @ [reindex dt']) end)
  20.750 -                       cargs [])) constrs
  20.751 -             in SOME ((index, (strip_nth_name 1 s,  map reindex dts, constrs1)),
  20.752 -               (index, constrs2))
  20.753 -             end) descr);
  20.754 -
  20.755 -    val (descr1, descr2) = chop (length new_type_names) descr'';
  20.756 -    val descr' = [descr1, descr2];
  20.757 -
  20.758 -    fun partition_cargs idxs xs = map (fn (i, j) =>
  20.759 -      (List.take (List.drop (xs, i), j), List.nth (xs, i + j))) idxs;
  20.760 -
  20.761 -    val pdescr = map (fn ((i, (s, dts, constrs)), (_, idxss)) => (i, (s, dts,
  20.762 -      map (fn ((cname, cargs), idxs) => (cname, partition_cargs idxs cargs))
  20.763 -        (constrs ~~ idxss)))) (descr'' ~~ ndescr);
  20.764 -
  20.765 -    fun nth_dtyp' i = typ_of_dtyp descr'' sorts (DtRec i);
  20.766 -
  20.767 -    val rep_names = map (fn s =>
  20.768 -      Sign.intern_const thy7 ("Rep_" ^ s)) new_type_names;
  20.769 -    val abs_names = map (fn s =>
  20.770 -      Sign.intern_const thy7 ("Abs_" ^ s)) new_type_names;
  20.771 -
  20.772 -    val recTs = get_rec_types descr'' sorts;
  20.773 -    val newTs' = Library.take (length new_type_names, recTs');
  20.774 -    val newTs = Library.take (length new_type_names, recTs);
  20.775 -
  20.776 -    val full_new_type_names = map (Sign.full_bname thy) new_type_names;
  20.777 -
  20.778 -    fun make_constr_def tname T T' ((thy, defs, eqns),
  20.779 -        (((cname_rep, _), (cname, cargs)), (cname', mx))) =
  20.780 -      let
  20.781 -        fun constr_arg ((dts, dt), (j, l_args, r_args)) =
  20.782 -          let
  20.783 -            val xs = map (fn (dt, i) => mk_Free "x" (typ_of_dtyp descr'' sorts dt) i)
  20.784 -              (dts ~~ (j upto j + length dts - 1))
  20.785 -            val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts)
  20.786 -          in
  20.787 -            (j + length dts + 1,
  20.788 -             xs @ x :: l_args,
  20.789 -             List.foldr mk_abs_fun
  20.790 -               (case dt of
  20.791 -                  DtRec k => if k < length new_type_names then
  20.792 -                      Const (List.nth (rep_names, k), typ_of_dtyp descr'' sorts dt -->
  20.793 -                        typ_of_dtyp descr sorts dt) $ x
  20.794 -                    else error "nested recursion not (yet) supported"
  20.795 -                | _ => x) xs :: r_args)
  20.796 -          end
  20.797 -
  20.798 -        val (_, l_args, r_args) = List.foldr constr_arg (1, [], []) cargs;
  20.799 -        val abs_name = Sign.intern_const thy ("Abs_" ^ tname);
  20.800 -        val rep_name = Sign.intern_const thy ("Rep_" ^ tname);
  20.801 -        val constrT = map fastype_of l_args ---> T;
  20.802 -        val lhs = list_comb (Const (cname, constrT), l_args);
  20.803 -        val rhs = list_comb (Const (cname_rep, map fastype_of r_args ---> T'), r_args);
  20.804 -        val def = Logic.mk_equals (lhs, Const (abs_name, T' --> T) $ rhs);
  20.805 -        val eqn = HOLogic.mk_Trueprop (HOLogic.mk_eq
  20.806 -          (Const (rep_name, T --> T') $ lhs, rhs));
  20.807 -        val def_name = (Long_Name.base_name cname) ^ "_def";
  20.808 -        val ([def_thm], thy') = thy |>
  20.809 -          Sign.add_consts_i [(Binding.name cname', constrT, mx)] |>
  20.810 -          (PureThy.add_defs false o map Thm.no_attributes) [(Binding.name def_name, def)]
  20.811 -      in (thy', defs @ [def_thm], eqns @ [eqn]) end;
  20.812 -
  20.813 -    fun dt_constr_defs ((thy, defs, eqns, dist_lemmas), ((((((_, (_, _, constrs)),
  20.814 -        (_, (_, _, constrs'))), tname), T), T'), constr_syntax)) =
  20.815 -      let
  20.816 -        val rep_const = cterm_of thy
  20.817 -          (Const (Sign.intern_const thy ("Rep_" ^ tname), T --> T'));
  20.818 -        val dist = standard (cterm_instantiate [(cterm_of thy distinct_f, rep_const)] distinct_lemma);
  20.819 -        val (thy', defs', eqns') = Library.foldl (make_constr_def tname T T')
  20.820 -          ((Sign.add_path tname thy, defs, []), constrs ~~ constrs' ~~ constr_syntax)
  20.821 -      in
  20.822 -        (parent_path (#flat_names config) thy', defs', eqns @ [eqns'], dist_lemmas @ [dist])
  20.823 -      end;
  20.824 -
  20.825 -    val (thy8, constr_defs, constr_rep_eqns, dist_lemmas) = Library.foldl dt_constr_defs
  20.826 -      ((thy7, [], [], []), List.take (descr, length new_type_names) ~~
  20.827 -        List.take (pdescr, length new_type_names) ~~
  20.828 -        new_type_names ~~ newTs ~~ newTs' ~~ constr_syntax);
  20.829 -
  20.830 -    val abs_inject_thms = map (collect_simp o #Abs_inject o fst) typedefs
  20.831 -    val rep_inject_thms = map (#Rep_inject o fst) typedefs
  20.832 -
  20.833 -    (* prove theorem  Rep_i (Constr_j ...) = Constr'_j ...  *)
  20.834 -
  20.835 -    fun prove_constr_rep_thm eqn =
  20.836 -      let
  20.837 -        val inj_thms = map (fn r => r RS iffD1) abs_inject_thms;
  20.838 -        val rewrites = constr_defs @ map mk_meta_eq Rep_inverse_thms
  20.839 -      in Goal.prove_global thy8 [] [] eqn (fn _ => EVERY
  20.840 -        [resolve_tac inj_thms 1,
  20.841 -         rewrite_goals_tac rewrites,
  20.842 -         rtac refl 3,
  20.843 -         resolve_tac rep_intrs 2,
  20.844 -         REPEAT (resolve_tac Rep_thms 1)])
  20.845 -      end;
  20.846 -
  20.847 -    val constr_rep_thmss = map (map prove_constr_rep_thm) constr_rep_eqns;
  20.848 -
  20.849 -    (* prove theorem  pi \<bullet> Rep_i x = Rep_i (pi \<bullet> x) *)
  20.850 -
  20.851 -    fun prove_perm_rep_perm (atom, perm_closed_thms) = map (fn th =>
  20.852 -      let
  20.853 -        val _ $ (_ $ (Rep $ x)) = Logic.unvarify (prop_of th);
  20.854 -        val Type ("fun", [T, U]) = fastype_of Rep;
  20.855 -        val permT = mk_permT (Type (atom, []));
  20.856 -        val pi = Free ("pi", permT);
  20.857 -      in
  20.858 -        Goal.prove_global thy8 [] []
  20.859 -          (augment_sort thy8
  20.860 -            (pt_class_of thy8 atom :: map (cp_class_of thy8 atom) (dt_atoms \ atom))
  20.861 -            (HOLogic.mk_Trueprop (HOLogic.mk_eq
  20.862 -              (Const ("Nominal.perm", permT --> U --> U) $ pi $ (Rep $ x),
  20.863 -               Rep $ (Const ("Nominal.perm", permT --> T --> T) $ pi $ x)))))
  20.864 -          (fn _ => simp_tac (HOL_basic_ss addsimps (perm_defs @ Abs_inverse_thms @
  20.865 -            perm_closed_thms @ Rep_thms)) 1)
  20.866 -      end) Rep_thms;
  20.867 -
  20.868 -    val perm_rep_perm_thms = List.concat (map prove_perm_rep_perm
  20.869 -      (atoms ~~ perm_closed_thmss));
  20.870 -
  20.871 -    (* prove distinctness theorems *)
  20.872 -
  20.873 -    val distinct_props = DatatypeProp.make_distincts descr' sorts;
  20.874 -    val dist_rewrites = map2 (fn rep_thms => fn dist_lemma =>
  20.875 -      dist_lemma :: rep_thms @ [In0_eq, In1_eq, In0_not_In1, In1_not_In0])
  20.876 -        constr_rep_thmss dist_lemmas;
  20.877 -
  20.878 -    fun prove_distinct_thms _ (_, []) = []
  20.879 -      | prove_distinct_thms (p as (rep_thms, dist_lemma)) (k, t :: ts) =
  20.880 -          let
  20.881 -            val dist_thm = Goal.prove_global thy8 [] [] t (fn _ =>
  20.882 -              simp_tac (simpset_of thy8 addsimps (dist_lemma :: rep_thms)) 1)
  20.883 -          in dist_thm :: standard (dist_thm RS not_sym) ::
  20.884 -            prove_distinct_thms p (k, ts)
  20.885 -          end;
  20.886 -
  20.887 -    val distinct_thms = map2 prove_distinct_thms
  20.888 -      (constr_rep_thmss ~~ dist_lemmas) distinct_props;
  20.889 -
  20.890 -    (** prove equations for permutation functions **)
  20.891 -
  20.892 -    val perm_simps' = map (fn (((i, (_, _, constrs)), tname), constr_rep_thms) =>
  20.893 -      let val T = nth_dtyp' i
  20.894 -      in List.concat (map (fn (atom, perm_closed_thms) =>
  20.895 -          map (fn ((cname, dts), constr_rep_thm) =>
  20.896 -        let
  20.897 -          val cname = Sign.intern_const thy8
  20.898 -            (Long_Name.append tname (Long_Name.base_name cname));
  20.899 -          val permT = mk_permT (Type (atom, []));
  20.900 -          val pi = Free ("pi", permT);
  20.901 -
  20.902 -          fun perm t =
  20.903 -            let val T = fastype_of t
  20.904 -            in Const ("Nominal.perm", permT --> T --> T) $ pi $ t end;
  20.905 -
  20.906 -          fun constr_arg ((dts, dt), (j, l_args, r_args)) =
  20.907 -            let
  20.908 -              val Ts = map (typ_of_dtyp descr'' sorts) dts;
  20.909 -              val xs = map (fn (T, i) => mk_Free "x" T i)
  20.910 -                (Ts ~~ (j upto j + length dts - 1))
  20.911 -              val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts)
  20.912 -            in
  20.913 -              (j + length dts + 1,
  20.914 -               xs @ x :: l_args,
  20.915 -               map perm (xs @ [x]) @ r_args)
  20.916 -            end
  20.917 -
  20.918 -          val (_, l_args, r_args) = List.foldr constr_arg (1, [], []) dts;
  20.919 -          val c = Const (cname, map fastype_of l_args ---> T)
  20.920 -        in
  20.921 -          Goal.prove_global thy8 [] []
  20.922 -            (augment_sort thy8
  20.923 -              (pt_class_of thy8 atom :: map (cp_class_of thy8 atom) (dt_atoms \ atom))
  20.924 -              (HOLogic.mk_Trueprop (HOLogic.mk_eq
  20.925 -                (perm (list_comb (c, l_args)), list_comb (c, r_args)))))
  20.926 -            (fn _ => EVERY
  20.927 -              [simp_tac (simpset_of thy8 addsimps (constr_rep_thm :: perm_defs)) 1,
  20.928 -               simp_tac (HOL_basic_ss addsimps (Rep_thms @ Abs_inverse_thms @
  20.929 -                 constr_defs @ perm_closed_thms)) 1,
  20.930 -               TRY (simp_tac (HOL_basic_ss addsimps
  20.931 -                 (symmetric perm_fun_def :: abs_perm)) 1),
  20.932 -               TRY (simp_tac (HOL_basic_ss addsimps
  20.933 -                 (perm_fun_def :: perm_defs @ Rep_thms @ Abs_inverse_thms @
  20.934 -                    perm_closed_thms)) 1)])
  20.935 -        end) (constrs ~~ constr_rep_thms)) (atoms ~~ perm_closed_thmss))
  20.936 -      end) (List.take (pdescr, length new_type_names) ~~ new_type_names ~~ constr_rep_thmss);
  20.937 -
  20.938 -    (** prove injectivity of constructors **)
  20.939 -
  20.940 -    val rep_inject_thms' = map (fn th => th RS sym) rep_inject_thms;
  20.941 -    val alpha = PureThy.get_thms thy8 "alpha";
  20.942 -    val abs_fresh = PureThy.get_thms thy8 "abs_fresh";
  20.943 -
  20.944 -    val pt_cp_sort =
  20.945 -      map (pt_class_of thy8) dt_atoms @
  20.946 -      maps (fn s => map (cp_class_of thy8 s) (dt_atoms \ s)) dt_atoms;
  20.947 -
  20.948 -    val inject_thms = map (fn (((i, (_, _, constrs)), tname), constr_rep_thms) =>
  20.949 -      let val T = nth_dtyp' i
  20.950 -      in List.mapPartial (fn ((cname, dts), constr_rep_thm) =>
  20.951 -        if null dts then NONE else SOME
  20.952 -        let
  20.953 -          val cname = Sign.intern_const thy8
  20.954 -            (Long_Name.append tname (Long_Name.base_name cname));
  20.955 -
  20.956 -          fun make_inj ((dts, dt), (j, args1, args2, eqs)) =
  20.957 -            let
  20.958 -              val Ts_idx = map (typ_of_dtyp descr'' sorts) dts ~~ (j upto j + length dts - 1);
  20.959 -              val xs = map (fn (T, i) => mk_Free "x" T i) Ts_idx;
  20.960 -              val ys = map (fn (T, i) => mk_Free "y" T i) Ts_idx;
  20.961 -              val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts);
  20.962 -              val y = mk_Free "y" (typ_of_dtyp descr'' sorts dt) (j + length dts)
  20.963 -            in
  20.964 -              (j + length dts + 1,
  20.965 -               xs @ (x :: args1), ys @ (y :: args2),
  20.966 -               HOLogic.mk_eq
  20.967 -                 (List.foldr mk_abs_fun x xs, List.foldr mk_abs_fun y ys) :: eqs)
  20.968 -            end;
  20.969 -
  20.970 -          val (_, args1, args2, eqs) = List.foldr make_inj (1, [], [], []) dts;
  20.971 -          val Ts = map fastype_of args1;
  20.972 -          val c = Const (cname, Ts ---> T)
  20.973 -        in
  20.974 -          Goal.prove_global thy8 [] []
  20.975 -            (augment_sort thy8 pt_cp_sort
  20.976 -              (HOLogic.mk_Trueprop (HOLogic.mk_eq
  20.977 -                (HOLogic.mk_eq (list_comb (c, args1), list_comb (c, args2)),
  20.978 -                 foldr1 HOLogic.mk_conj eqs))))
  20.979 -            (fn _ => EVERY
  20.980 -               [asm_full_simp_tac (simpset_of thy8 addsimps (constr_rep_thm ::
  20.981 -                  rep_inject_thms')) 1,
  20.982 -                TRY (asm_full_simp_tac (HOL_basic_ss addsimps (fresh_def :: supp_def ::
  20.983 -                  alpha @ abs_perm @ abs_fresh @ rep_inject_thms @
  20.984 -                  perm_rep_perm_thms)) 1)])
  20.985 -        end) (constrs ~~ constr_rep_thms)
  20.986 -      end) (List.take (pdescr, length new_type_names) ~~ new_type_names ~~ constr_rep_thmss);
  20.987 -
  20.988 -    (** equations for support and freshness **)
  20.989 -
  20.990 -    val (supp_thms, fresh_thms) = ListPair.unzip (map ListPair.unzip
  20.991 -      (map (fn ((((i, (_, _, constrs)), tname), inject_thms'), perm_thms') =>
  20.992 -      let val T = nth_dtyp' i
  20.993 -      in List.concat (map (fn (cname, dts) => map (fn atom =>
  20.994 -        let
  20.995 -          val cname = Sign.intern_const thy8
  20.996 -            (Long_Name.append tname (Long_Name.base_name cname));
  20.997 -          val atomT = Type (atom, []);
  20.998 -
  20.999 -          fun process_constr ((dts, dt), (j, args1, args2)) =
 20.1000 -            let
 20.1001 -              val Ts_idx = map (typ_of_dtyp descr'' sorts) dts ~~ (j upto j + length dts - 1);
 20.1002 -              val xs = map (fn (T, i) => mk_Free "x" T i) Ts_idx;
 20.1003 -              val x = mk_Free "x" (typ_of_dtyp descr'' sorts dt) (j + length dts)
 20.1004 -            in
 20.1005 -              (j + length dts + 1,
 20.1006 -               xs @ (x :: args1), List.foldr mk_abs_fun x xs :: args2)
 20.1007 -            end;
 20.1008 -
 20.1009 -          val (_, args1, args2) = List.foldr process_constr (1, [], []) dts;
 20.1010 -          val Ts = map fastype_of args1;
 20.1011 -          val c = list_comb (Const (cname, Ts ---> T), args1);
 20.1012 -          fun supp t =
 20.1013 -            Const ("Nominal.supp", fastype_of t --> HOLogic.mk_setT atomT) $ t;
 20.1014 -          fun fresh t = fresh_const atomT (fastype_of t) $ Free ("a", atomT) $ t;
 20.1015 -          val supp_thm = Goal.prove_global thy8 [] []
 20.1016 -            (augment_sort thy8 pt_cp_sort
 20.1017 -              (HOLogic.mk_Trueprop (HOLogic.mk_eq
 20.1018 -                (supp c,
 20.1019 -                 if null dts then HOLogic.mk_set atomT []
 20.1020 -                 else foldr1 (HOLogic.mk_binop @{const_name Un}) (map supp args2)))))
 20.1021 -            (fn _ =>
 20.1022 -              simp_tac (HOL_basic_ss addsimps (supp_def ::
 20.1023 -                 Un_assoc :: de_Morgan_conj :: Collect_disj_eq :: finite_Un ::
 20.1024 -                 symmetric empty_def :: finite_emptyI :: simp_thms @
 20.1025 -                 abs_perm @ abs_fresh @ inject_thms' @ perm_thms')) 1)
 20.1026 -        in
 20.1027 -          (supp_thm,
 20.1028 -           Goal.prove_global thy8 [] [] (augment_sort thy8 pt_cp_sort
 20.1029 -             (HOLogic.mk_Trueprop (HOLogic.mk_eq
 20.1030 -               (fresh c,
 20.1031 -                if null dts then HOLogic.true_const
 20.1032 -                else foldr1 HOLogic.mk_conj (map fresh args2)))))
 20.1033 -             (fn _ =>
 20.1034 -               simp_tac (HOL_ss addsimps [Un_iff, empty_iff, fresh_def, supp_thm]) 1))
 20.1035 -        end) atoms) constrs)
 20.1036 -      end) (List.take (pdescr, length new_type_names) ~~ new_type_names ~~ inject_thms ~~ perm_simps')));
 20.1037 -
 20.1038 -    (**** weak induction theorem ****)
 20.1039 -
 20.1040 -    fun mk_indrule_lemma ((prems, concls), (((i, _), T), U)) =
 20.1041 -      let
 20.1042 -        val Rep_t = Const (List.nth (rep_names, i), T --> U) $
 20.1043 -          mk_Free "x" T i;
 20.1044 -
 20.1045 -        val Abs_t =  Const (List.nth (abs_names, i), U --> T)
 20.1046 -
 20.1047 -      in (prems @ [HOLogic.imp $
 20.1048 -            (Const (List.nth (rep_set_names'', i), U --> HOLogic.boolT) $ Rep_t) $
 20.1049 -              (mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ (Abs_t $ Rep_t))],
 20.1050 -          concls @ [mk_Free "P" (T --> HOLogic.boolT) (i + 1) $ mk_Free "x" T i])
 20.1051 -      end;
 20.1052 -
 20.1053 -    val (indrule_lemma_prems, indrule_lemma_concls) =
 20.1054 -      Library.foldl mk_indrule_lemma (([], []), (descr'' ~~ recTs ~~ recTs'));
 20.1055 -
 20.1056 -    val indrule_lemma = Goal.prove_global thy8 [] []
 20.1057 -      (Logic.mk_implies
 20.1058 -        (HOLogic.mk_Trueprop (mk_conj indrule_lemma_prems),
 20.1059 -         HOLogic.mk_Trueprop (mk_conj indrule_lemma_concls))) (fn _ => EVERY
 20.1060 -           [REPEAT (etac conjE 1),
 20.1061 -            REPEAT (EVERY
 20.1062 -              [TRY (rtac conjI 1), full_simp_tac (HOL_basic_ss addsimps Rep_inverse_thms) 1,
 20.1063 -               etac mp 1, resolve_tac Rep_thms 1])]);
 20.1064 -
 20.1065 -    val Ps = map head_of (HOLogic.dest_conj (HOLogic.dest_Trueprop (concl_of indrule_lemma)));
 20.1066 -    val frees = if length Ps = 1 then [Free ("P", snd (dest_Var (hd Ps)))] else
 20.1067 -      map (Free o apfst fst o dest_Var) Ps;
 20.1068 -    val indrule_lemma' = cterm_instantiate
 20.1069 -      (map (cterm_of thy8) Ps ~~ map (cterm_of thy8) frees) indrule_lemma;
 20.1070 -
 20.1071 -    val Abs_inverse_thms' = map (fn r => r RS subst) Abs_inverse_thms;
 20.1072 -
 20.1073 -    val dt_induct_prop = DatatypeProp.make_ind descr' sorts;
 20.1074 -    val dt_induct = Goal.prove_global thy8 []
 20.1075 -      (Logic.strip_imp_prems dt_induct_prop) (Logic.strip_imp_concl dt_induct_prop)
 20.1076 -      (fn {prems, ...} => EVERY
 20.1077 -        [rtac indrule_lemma' 1,
 20.1078 -         (indtac rep_induct [] THEN_ALL_NEW ObjectLogic.atomize_prems_tac) 1,
 20.1079 -         EVERY (map (fn (prem, r) => (EVERY
 20.1080 -           [REPEAT (eresolve_tac Abs_inverse_thms' 1),
 20.1081 -            simp_tac (HOL_basic_ss addsimps [symmetric r]) 1,
 20.1082 -            DEPTH_SOLVE_1 (ares_tac [prem] 1 ORELSE etac allE 1)]))
 20.1083 -                (prems ~~ constr_defs))]);
 20.1084 -
 20.1085 -    val case_names_induct = mk_case_names_induct descr'';
 20.1086 -
 20.1087 -    (**** prove that new datatypes have finite support ****)
 20.1088 -
 20.1089 -    val _ = warning "proving finite support for the new datatype";
 20.1090 -
 20.1091 -    val indnames = DatatypeProp.make_tnames recTs;
 20.1092 -
 20.1093 -    val abs_supp = PureThy.get_thms thy8 "abs_supp";
 20.1094 -    val supp_atm = PureThy.get_thms thy8 "supp_atm";
 20.1095 -
 20.1096 -    val finite_supp_thms = map (fn atom =>
 20.1097 -      let val atomT = Type (atom, [])
 20.1098 -      in map standard (List.take
 20.1099 -        (split_conj_thm (Goal.prove_global thy8 [] []
 20.1100 -           (augment_sort thy8 (fs_class_of thy8 atom :: pt_cp_sort)
 20.1101 -             (HOLogic.mk_Trueprop
 20.1102 -               (foldr1 HOLogic.mk_conj (map (fn (s, T) =>
 20.1103 -                 Const ("Finite_Set.finite", HOLogic.mk_setT atomT --> HOLogic.boolT) $
 20.1104 -                   (Const ("Nominal.supp", T --> HOLogic.mk_setT atomT) $ Free (s, T)))
 20.1105 -                   (indnames ~~ recTs)))))
 20.1106 -           (fn _ => indtac dt_induct indnames 1 THEN
 20.1107 -            ALLGOALS (asm_full_simp_tac (simpset_of thy8 addsimps
 20.1108 -              (abs_supp @ supp_atm @
 20.1109 -               PureThy.get_thms thy8 ("fs_" ^ Long_Name.base_name atom ^ "1") @
 20.1110 -               List.concat supp_thms))))),
 20.1111 -         length new_type_names))
 20.1112 -      end) atoms;
 20.1113 -
 20.1114 -    val simp_atts = replicate (length new_type_names) [Simplifier.simp_add];
 20.1115 -
 20.1116 -	(* Function to add both the simp and eqvt attributes *)
 20.1117 -        (* These two attributes are duplicated on all the types in the mutual nominal datatypes *)
 20.1118 -
 20.1119 -    val simp_eqvt_atts = replicate (length new_type_names) [Simplifier.simp_add, NominalThmDecls.eqvt_add];
 20.1120 - 
 20.1121 -    val (_, thy9) = thy8 |>
 20.1122 -      Sign.add_path big_name |>
 20.1123 -      PureThy.add_thms [((Binding.name "induct", dt_induct), [case_names_induct])] ||>>
 20.1124 -      PureThy.add_thmss [((Binding.name "inducts", projections dt_induct), [case_names_induct])] ||>
 20.1125 -      Sign.parent_path ||>>
 20.1126 -      DatatypeAux.store_thmss_atts "distinct" new_type_names simp_atts distinct_thms ||>>
 20.1127 -      DatatypeAux.store_thmss "constr_rep" new_type_names constr_rep_thmss ||>>
 20.1128 -      DatatypeAux.store_thmss_atts "perm" new_type_names simp_eqvt_atts perm_simps' ||>>
 20.1129 -      DatatypeAux.store_thmss "inject" new_type_names inject_thms ||>>
 20.1130 -      DatatypeAux.store_thmss "supp" new_type_names supp_thms ||>>
 20.1131 -      DatatypeAux.store_thmss_atts "fresh" new_type_names simp_atts fresh_thms ||>
 20.1132 -      fold (fn (atom, ths) => fn thy =>
 20.1133 -        let
 20.1134 -          val class = fs_class_of thy atom;
 20.1135 -          val sort = Sign.certify_sort thy (class :: pt_cp_sort)
 20.1136 -        in fold (fn Type (s, Ts) => AxClass.prove_arity
 20.1137 -          (s, map (inter_sort thy sort o snd o dest_TFree) Ts, [class])
 20.1138 -          (Class.intro_classes_tac [] THEN resolve_tac ths 1)) newTs thy
 20.1139 -        end) (atoms ~~ finite_supp_thms);
 20.1140 -
 20.1141 -    (**** strong induction theorem ****)
 20.1142 -
 20.1143 -    val pnames = if length descr'' = 1 then ["P"]
 20.1144 -      else map (fn i => "P" ^ string_of_int i) (1 upto length descr'');
 20.1145 -    val ind_sort = if null dt_atomTs then HOLogic.typeS
 20.1146 -      else Sign.certify_sort thy9 (map (fs_class_of thy9) dt_atoms);
 20.1147 -    val fsT = TFree ("'n", ind_sort);
 20.1148 -    val fsT' = TFree ("'n", HOLogic.typeS);
 20.1149 -
 20.1150 -    val fresh_fs = map (fn (s, T) => (T, Free (s, fsT' --> HOLogic.mk_setT T)))
 20.1151 -      (DatatypeProp.indexify_names (replicate (length dt_atomTs) "f") ~~ dt_atomTs);
 20.1152 -
 20.1153 -    fun make_pred fsT i T =
 20.1154 -      Free (List.nth (pnames, i), fsT --> T --> HOLogic.boolT);
 20.1155 -
 20.1156 -    fun mk_fresh1 xs [] = []
 20.1157 -      | mk_fresh1 xs ((y as (_, T)) :: ys) = map (fn x => HOLogic.mk_Trueprop
 20.1158 -            (HOLogic.mk_not (HOLogic.mk_eq (Free y, Free x))))
 20.1159 -              (filter (fn (_, U) => T = U) (rev xs)) @
 20.1160 -          mk_fresh1 (y :: xs) ys;
 20.1161 -
 20.1162 -    fun mk_fresh2 xss [] = []
 20.1163 -      | mk_fresh2 xss ((p as (ys, _)) :: yss) = List.concat (map (fn y as (_, T) =>
 20.1164 -            map (fn (_, x as (_, U)) => HOLogic.mk_Trueprop
 20.1165 -              (fresh_const T U $ Free y $ Free x)) (rev xss @ yss)) ys) @
 20.1166 -          mk_fresh2 (p :: xss) yss;
 20.1167 -
 20.1168 -    fun make_ind_prem fsT f k T ((cname, cargs), idxs) =
 20.1169 -      let
 20.1170 -        val recs = List.filter is_rec_type cargs;
 20.1171 -        val Ts = map (typ_of_dtyp descr'' sorts) cargs;
 20.1172 -        val recTs' = map (typ_of_dtyp descr'' sorts) recs;
 20.1173 -        val tnames = Name.variant_list pnames (DatatypeProp.make_tnames Ts);
 20.1174 -        val rec_tnames = map fst (List.filter (is_rec_type o snd) (tnames ~~ cargs));
 20.1175 -        val frees = tnames ~~ Ts;
 20.1176 -        val frees' = partition_cargs idxs frees;
 20.1177 -        val z = (Name.variant tnames "z", fsT);
 20.1178 -
 20.1179 -        fun mk_prem ((dt, s), T) =
 20.1180 -          let
 20.1181 -            val (Us, U) = strip_type T;
 20.1182 -            val l = length Us
 20.1183 -          in list_all (z :: map (pair "x") Us, HOLogic.mk_Trueprop
 20.1184 -            (make_pred fsT (body_index dt) U $ Bound l $ app_bnds (Free (s, T)) l))
 20.1185 -          end;
 20.1186 -
 20.1187 -        val prems = map mk_prem (recs ~~ rec_tnames ~~ recTs');
 20.1188 -        val prems' = map (fn p as (_, T) => HOLogic.mk_Trueprop
 20.1189 -            (f T (Free p) (Free z))) (List.concat (map fst frees')) @
 20.1190 -          mk_fresh1 [] (List.concat (map fst frees')) @
 20.1191 -          mk_fresh2 [] frees'
 20.1192 -
 20.1193 -      in list_all_free (frees @ [z], Logic.list_implies (prems' @ prems,
 20.1194 -        HOLogic.mk_Trueprop (make_pred fsT k T $ Free z $
 20.1195 -          list_comb (Const (cname, Ts ---> T), map Free frees))))
 20.1196 -      end;
 20.1197 -
 20.1198 -    val ind_prems = List.concat (map (fn (((i, (_, _, constrs)), (_, idxss)), T) =>
 20.1199 -      map (make_ind_prem fsT (fn T => fn t => fn u =>
 20.1200 -        fresh_const T fsT $ t $ u) i T)
 20.1201 -          (constrs ~~ idxss)) (descr'' ~~ ndescr ~~ recTs));
 20.1202 -    val tnames = DatatypeProp.make_tnames recTs;
 20.1203 -    val zs = Name.variant_list tnames (replicate (length descr'') "z");
 20.1204 -    val ind_concl = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop "op &")
 20.1205 -      (map (fn ((((i, _), T), tname), z) =>
 20.1206 -        make_pred fsT i T $ Free (z, fsT) $ Free (tname, T))
 20.1207 -        (descr'' ~~ recTs ~~ tnames ~~ zs)));
 20.1208 -    val induct = Logic.list_implies (ind_prems, ind_concl);
 20.1209 -
 20.1210 -    val ind_prems' =
 20.1211 -      map (fn (_, f as Free (_, T)) => list_all_free ([("x", fsT')],
 20.1212 -        HOLogic.mk_Trueprop (Const ("Finite_Set.finite",
 20.1213 -          (snd (split_last (binder_types T)) --> HOLogic.boolT) -->
 20.1214 -            HOLogic.boolT) $ (f $ Free ("x", fsT'))))) fresh_fs @
 20.1215 -      List.concat (map (fn (((i, (_, _, constrs)), (_, idxss)), T) =>
 20.1216 -        map (make_ind_prem fsT' (fn T => fn t => fn u => HOLogic.Not $
 20.1217 -          HOLogic.mk_mem (t, the (AList.lookup op = fresh_fs T) $ u)) i T)
 20.1218 -            (constrs ~~ idxss)) (descr'' ~~ ndescr ~~ recTs));
 20.1219 -    val ind_concl' = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop "op &")
 20.1220 -      (map (fn ((((i, _), T), tname), z) =>
 20.1221 -        make_pred fsT' i T $ Free (z, fsT') $ Free (tname, T))
 20.1222 -        (descr'' ~~ recTs ~~ tnames ~~ zs)));
 20.1223 -    val induct' = Logic.list_implies (ind_prems', ind_concl');
 20.1224 -
 20.1225 -    val aux_ind_vars =
 20.1226 -      (DatatypeProp.indexify_names (replicate (length dt_atomTs) "pi") ~~
 20.1227 -       map mk_permT dt_atomTs) @ [("z", fsT')];
 20.1228 -    val aux_ind_Ts = rev (map snd aux_ind_vars);
 20.1229 -    val aux_ind_concl = HOLogic.mk_Trueprop (foldr1 (HOLogic.mk_binop "op &")
 20.1230 -      (map (fn (((i, _), T), tname) =>
 20.1231 -        HOLogic.list_all (aux_ind_vars, make_pred fsT' i T $ Bound 0 $
 20.1232 -          fold_rev (mk_perm aux_ind_Ts) (map Bound (length dt_atomTs downto 1))
 20.1233 -            (Free (tname, T))))
 20.1234 -        (descr'' ~~ recTs ~~ tnames)));
 20.1235 -
 20.1236 -    val fin_set_supp = map (fn s =>
 20.1237 -      at_inst_of thy9 s RS at_fin_set_supp) dt_atoms;
 20.1238 -    val fin_set_fresh = map (fn s =>
 20.1239 -      at_inst_of thy9 s RS at_fin_set_fresh) dt_atoms;
 20.1240 -    val pt1_atoms = map (fn Type (s, _) =>
 20.1241 -      PureThy.get_thm thy9 ("pt_" ^ Long_Name.base_name s ^ "1")) dt_atomTs;
 20.1242 -    val pt2_atoms = map (fn Type (s, _) =>
 20.1243 -      PureThy.get_thm thy9 ("pt_" ^ Long_Name.base_name s ^ "2") RS sym) dt_atomTs;
 20.1244 -    val exists_fresh' = PureThy.get_thms thy9 "exists_fresh'";
 20.1245 -    val fs_atoms = PureThy.get_thms thy9 "fin_supp";
 20.1246 -    val abs_supp = PureThy.get_thms thy9 "abs_supp";
 20.1247 -    val perm_fresh_fresh = PureThy.get_thms thy9 "perm_fresh_fresh";
 20.1248 -    val calc_atm = PureThy.get_thms thy9 "calc_atm";
 20.1249 -    val fresh_atm = PureThy.get_thms thy9 "fresh_atm";
 20.1250 -    val fresh_left = PureThy.get_thms thy9 "fresh_left";
 20.1251 -    val perm_swap = PureThy.get_thms thy9 "perm_swap";
 20.1252 -
 20.1253 -    fun obtain_fresh_name' ths ts T (freshs1, freshs2, ctxt) =
 20.1254 -      let
 20.1255 -        val p = foldr1 HOLogic.mk_prod (ts @ freshs1);
 20.1256 -        val ex = Goal.prove ctxt [] [] (HOLogic.mk_Trueprop
 20.1257 -            (HOLogic.exists_const T $ Abs ("x", T,
 20.1258 -              fresh_const T (fastype_of p) $
 20.1259 -                Bound 0 $ p)))
 20.1260 -          (fn _ => EVERY
 20.1261 -            [resolve_tac exists_fresh' 1,
 20.1262 -             simp_tac (HOL_ss addsimps (supp_prod :: finite_Un :: fs_atoms @
 20.1263 -               fin_set_supp @ ths)) 1]);
 20.1264 -        val (([cx], ths), ctxt') = Obtain.result
 20.1265 -          (fn _ => EVERY
 20.1266 -            [etac exE 1,
 20.1267 -             full_simp_tac (HOL_ss addsimps (fresh_prod :: fresh_atm)) 1,
 20.1268 -             REPEAT (etac conjE 1)])
 20.1269 -          [ex] ctxt
 20.1270 -      in (freshs1 @ [term_of cx], freshs2 @ ths, ctxt') end;
 20.1271 -
 20.1272 -    fun fresh_fresh_inst thy a b =
 20.1273 -      let
 20.1274 -        val T = fastype_of a;
 20.1275 -        val SOME th = find_first (fn th => case prop_of th of
 20.1276 -            _ $ (_ $ (Const (_, Type (_, [U, _])) $ _ $ _)) $ _ => U = T
 20.1277 -          | _ => false) perm_fresh_fresh
 20.1278 -      in
 20.1279 -        Drule.instantiate' []
 20.1280 -          [SOME (cterm_of thy a), NONE, SOME (cterm_of thy b)] th
 20.1281 -      end;
 20.1282 -
 20.1283 -    val fs_cp_sort =
 20.1284 -      map (fs_class_of thy9) dt_atoms @
 20.1285 -      maps (fn s => map (cp_class_of thy9 s) (dt_atoms \ s)) dt_atoms;
 20.1286 -
 20.1287 -    (**********************************************************************
 20.1288 -      The subgoals occurring in the proof of induct_aux have the
 20.1289 -      following parameters:
 20.1290 -
 20.1291 -        x_1 ... x_k p_1 ... p_m z
 20.1292 -
 20.1293 -      where
 20.1294 -
 20.1295 -        x_i : constructor arguments (introduced by weak induction rule)
 20.1296 -        p_i : permutations (one for each atom type in the data type)
 20.1297 -        z   : freshness context
 20.1298 -    ***********************************************************************)
 20.1299 -
 20.1300 -    val _ = warning "proving strong induction theorem ...";
 20.1301 -
 20.1302 -    val induct_aux = Goal.prove_global thy9 []
 20.1303 -        (map (augment_sort thy9 fs_cp_sort) ind_prems')
 20.1304 -        (augment_sort thy9 fs_cp_sort ind_concl') (fn {prems, context} =>
 20.1305 -      let
 20.1306 -        val (prems1, prems2) = chop (length dt_atomTs) prems;
 20.1307 -        val ind_ss2 = HOL_ss addsimps
 20.1308 -          finite_Diff :: abs_fresh @ abs_supp @ fs_atoms;
 20.1309 -        val ind_ss1 = ind_ss2 addsimps fresh_left @ calc_atm @
 20.1310 -          fresh_atm @ rev_simps @ app_simps;
 20.1311 -        val ind_ss3 = HOL_ss addsimps abs_fun_eq1 ::
 20.1312 -          abs_perm @ calc_atm @ perm_swap;
 20.1313 -        val ind_ss4 = HOL_basic_ss addsimps fresh_left @ prems1 @
 20.1314 -          fin_set_fresh @ calc_atm;
 20.1315 -        val ind_ss5 = HOL_basic_ss addsimps pt1_atoms;
 20.1316 -        val ind_ss6 = HOL_basic_ss addsimps flat perm_simps';
 20.1317 -        val th = Goal.prove context [] []
 20.1318 -          (augment_sort thy9 fs_cp_sort aux_ind_concl)
 20.1319 -          (fn {context = context1, ...} =>
 20.1320 -             EVERY (indtac dt_induct tnames 1 ::
 20.1321 -               maps (fn ((_, (_, _, constrs)), (_, constrs')) =>
 20.1322 -                 map (fn ((cname, cargs), is) =>
 20.1323 -                   REPEAT (rtac allI 1) THEN
 20.1324 -                   SUBPROOF (fn {prems = iprems, params, concl,
 20.1325 -                       context = context2, ...} =>
 20.1326 -                     let
 20.1327 -                       val concl' = term_of concl;
 20.1328 -                       val _ $ (_ $ _ $ u) = concl';
 20.1329 -                       val U = fastype_of u;
 20.1330 -                       val (xs, params') =
 20.1331 -                         chop (length cargs) (map term_of params);
 20.1332 -                       val Ts = map fastype_of xs;
 20.1333 -                       val cnstr = Const (cname, Ts ---> U);
 20.1334 -                       val (pis, z) = split_last params';
 20.1335 -                       val mk_pi = fold_rev (mk_perm []) pis;
 20.1336 -                       val xs' = partition_cargs is xs;
 20.1337 -                       val xs'' = map (fn (ts, u) => (map mk_pi ts, mk_pi u)) xs';
 20.1338 -                       val ts = maps (fn (ts, u) => ts @ [u]) xs'';
 20.1339 -                       val (freshs1, freshs2, context3) = fold (fn t =>
 20.1340 -                         let val T = fastype_of t
 20.1341 -                         in obtain_fresh_name' prems1
 20.1342 -                           (the (AList.lookup op = fresh_fs T) $ z :: ts) T
 20.1343 -                         end) (maps fst xs') ([], [], context2);
 20.1344 -                       val freshs1' = unflat (map fst xs') freshs1;
 20.1345 -                       val freshs2' = map (Simplifier.simplify ind_ss4)
 20.1346 -                         (mk_not_sym freshs2);
 20.1347 -                       val ind_ss1' = ind_ss1 addsimps freshs2';
 20.1348 -                       val ind_ss3' = ind_ss3 addsimps freshs2';
 20.1349 -                       val rename_eq =
 20.1350 -                         if forall (null o fst) xs' then []
 20.1351 -                         else [Goal.prove context3 [] []
 20.1352 -                           (HOLogic.mk_Trueprop (HOLogic.mk_eq
 20.1353 -                             (list_comb (cnstr, ts),
 20.1354 -                              list_comb (cnstr, maps (fn ((bs, t), cs) =>
 20.1355 -                                cs @ [fold_rev (mk_perm []) (map perm_of_pair
 20.1356 -                                  (bs ~~ cs)) t]) (xs'' ~~ freshs1')))))
 20.1357 -                           (fn _ => EVERY
 20.1358 -                              (simp_tac (HOL_ss addsimps flat inject_thms) 1 ::
 20.1359 -                               REPEAT (FIRSTGOAL (rtac conjI)) ::
 20.1360 -                               maps (fn ((bs, t), cs) =>
 20.1361 -                                 if null bs then []
 20.1362 -                                 else rtac sym 1 :: maps (fn (b, c) =>
 20.1363 -                                   [rtac trans 1, rtac sym 1,
 20.1364 -                                    rtac (fresh_fresh_inst thy9 b c) 1,
 20.1365 -                                    simp_tac ind_ss1' 1,
 20.1366 -                                    simp_tac ind_ss2 1,
 20.1367 -                                    simp_tac ind_ss3' 1]) (bs ~~ cs))
 20.1368 -                                 (xs'' ~~ freshs1')))];
 20.1369 -                       val th = Goal.prove context3 [] [] concl' (fn _ => EVERY
 20.1370 -                         [simp_tac (ind_ss6 addsimps rename_eq) 1,
 20.1371 -                          cut_facts_tac iprems 1,
 20.1372 -                          (resolve_tac prems THEN_ALL_NEW
 20.1373 -                            SUBGOAL (fn (t, i) => case Logic.strip_assums_concl t of
 20.1374 -                                _ $ (Const ("Nominal.fresh", _) $ _ $ _) =>
 20.1375 -                                  simp_tac ind_ss1' i
 20.1376 -                              | _ $ (Const ("Not", _) $ _) =>
 20.1377 -                                  resolve_tac freshs2' i
 20.1378 -                              | _ => asm_simp_tac (HOL_basic_ss addsimps
 20.1379 -                                  pt2_atoms addsimprocs [perm_simproc]) i)) 1])
 20.1380 -                       val final = ProofContext.export context3 context2 [th]
 20.1381 -                     in
 20.1382 -                       resolve_tac final 1
 20.1383 -                     end) context1 1) (constrs ~~ constrs')) (descr'' ~~ ndescr)))
 20.1384 -      in
 20.1385 -        EVERY
 20.1386 -          [cut_facts_tac [th] 1,
 20.1387 -           REPEAT (eresolve_tac [conjE, @{thm allE_Nil}] 1),
 20.1388 -           REPEAT (etac allE 1),
 20.1389 -           REPEAT (TRY (rtac conjI 1) THEN asm_full_simp_tac ind_ss5 1)]
 20.1390 -      end);
 20.1391 -
 20.1392 -    val induct_aux' = Thm.instantiate ([],
 20.1393 -      map (fn (s, v as Var (_, T)) =>
 20.1394 -        (cterm_of thy9 v, cterm_of thy9 (Free (s, T))))
 20.1395 -          (pnames ~~ map head_of (HOLogic.dest_conj
 20.1396 -             (HOLogic.dest_Trueprop (concl_of induct_aux)))) @
 20.1397 -      map (fn (_, f) =>
 20.1398 -        let val f' = Logic.varify f
 20.1399 -        in (cterm_of thy9 f',
 20.1400 -          cterm_of thy9 (Const ("Nominal.supp", fastype_of f')))
 20.1401 -        end) fresh_fs) induct_aux;
 20.1402 -
 20.1403 -    val induct = Goal.prove_global thy9 []
 20.1404 -      (map (augment_sort thy9 fs_cp_sort) ind_prems)
 20.1405 -      (augment_sort thy9 fs_cp_sort ind_concl)
 20.1406 -      (fn {prems, ...} => EVERY
 20.1407 -         [rtac induct_aux' 1,
 20.1408 -          REPEAT (resolve_tac fs_atoms 1),
 20.1409 -          REPEAT ((resolve_tac prems THEN_ALL_NEW
 20.1410 -            (etac meta_spec ORELSE' full_simp_tac (HOL_basic_ss addsimps [fresh_def]))) 1)])
 20.1411 -
 20.1412 -    val (_, thy10) = thy9 |>
 20.1413 -      Sign.add_path big_name |>
 20.1414 -      PureThy.add_thms [((Binding.name "strong_induct'", induct_aux), [])] ||>>
 20.1415 -      PureThy.add_thms [((Binding.name "strong_induct", induct), [case_names_induct])] ||>>
 20.1416 -      PureThy.add_thmss [((Binding.name "strong_inducts", projections induct), [case_names_induct])];
 20.1417 -
 20.1418 -    (**** recursion combinator ****)
 20.1419 -
 20.1420 -    val _ = warning "defining recursion combinator ...";
 20.1421 -
 20.1422 -    val used = List.foldr OldTerm.add_typ_tfree_names [] recTs;
 20.1423 -
 20.1424 -    val (rec_result_Ts', rec_fn_Ts') = DatatypeProp.make_primrec_Ts descr' sorts used;
 20.1425 -
 20.1426 -    val rec_sort = if null dt_atomTs then HOLogic.typeS else
 20.1427 -      Sign.certify_sort thy10 pt_cp_sort;
 20.1428 -
 20.1429 -    val rec_result_Ts = map (fn TFree (s, _) => TFree (s, rec_sort)) rec_result_Ts';
 20.1430 -    val rec_fn_Ts = map (typ_subst_atomic (rec_result_Ts' ~~ rec_result_Ts)) rec_fn_Ts';
 20.1431 -
 20.1432 -    val rec_set_Ts = map (fn (T1, T2) =>
 20.1433 -      rec_fn_Ts @ [T1, T2] ---> HOLogic.boolT) (recTs ~~ rec_result_Ts);
 20.1434 -
 20.1435 -    val big_rec_name = big_name ^ "_rec_set";
 20.1436 -    val rec_set_names' =
 20.1437 -      if length descr'' = 1 then [big_rec_name] else
 20.1438 -        map ((curry (op ^) (big_rec_name ^ "_")) o string_of_int)
 20.1439 -          (1 upto (length descr''));
 20.1440 -    val rec_set_names =  map (Sign.full_bname thy10) rec_set_names';
 20.1441 -
 20.1442 -    val rec_fns = map (uncurry (mk_Free "f"))
 20.1443 -      (rec_fn_Ts ~~ (1 upto (length rec_fn_Ts)));
 20.1444 -    val rec_sets' = map (fn c => list_comb (Free c, rec_fns))
 20.1445 -      (rec_set_names' ~~ rec_set_Ts);
 20.1446 -    val rec_sets = map (fn c => list_comb (Const c, rec_fns))
 20.1447 -      (rec_set_names ~~ rec_set_Ts);
 20.1448 -
 20.1449 -    (* introduction rules for graph of recursion function *)
 20.1450 -
 20.1451 -    val rec_preds = map (fn (a, T) =>
 20.1452 -      Free (a, T --> HOLogic.boolT)) (pnames ~~ rec_result_Ts);
 20.1453 -
 20.1454 -    fun mk_fresh3 rs [] = []
 20.1455 -      | mk_fresh3 rs ((p as (ys, z)) :: yss) = List.concat (map (fn y as (_, T) =>
 20.1456 -            List.mapPartial (fn ((_, (_, x)), r as (_, U)) => if z = x then NONE
 20.1457 -              else SOME (HOLogic.mk_Trueprop
 20.1458 -                (fresh_const T U $ Free y $ Free r))) rs) ys) @
 20.1459 -          mk_fresh3 rs yss;
 20.1460 -
 20.1461 -    (* FIXME: avoid collisions with other variable names? *)
 20.1462 -    val rec_ctxt = Free ("z", fsT');
 20.1463 -
 20.1464 -    fun make_rec_intr T p rec_set ((rec_intr_ts, rec_prems, rec_prems',
 20.1465 -          rec_eq_prems, l), ((cname, cargs), idxs)) =
 20.1466 -      let
 20.1467 -        val Ts = map (typ_of_dtyp descr'' sorts) cargs;
 20.1468 -        val frees = map (fn i => "x" ^ string_of_int i) (1 upto length Ts) ~~ Ts;
 20.1469 -        val frees' = partition_cargs idxs frees;
 20.1470 -        val binders = List.concat (map fst frees');
 20.1471 -        val atomTs = distinct op = (maps (map snd o fst) frees');
 20.1472 -        val recs = List.mapPartial
 20.1473 -          (fn ((_, DtRec i), p) => SOME (i, p) | _ => NONE)
 20.1474 -          (partition_cargs idxs cargs ~~ frees');
 20.1475 -        val frees'' = map (fn i => "y" ^ string_of_int i) (1 upto length recs) ~~
 20.1476 -          map (fn (i, _) => List.nth (rec_result_Ts, i)) recs;
 20.1477 -        val prems1 = map (fn ((i, (_, x)), y) => HOLogic.mk_Trueprop
 20.1478 -          (List.nth (rec_sets', i) $ Free x $ Free y)) (recs ~~ frees'');
 20.1479 -        val prems2 =
 20.1480 -          map (fn f => map (fn p as (_, T) => HOLogic.mk_Trueprop
 20.1481 -            (fresh_const T (fastype_of f) $ Free p $ f)) binders) rec_fns;
 20.1482 -        val prems3 = mk_fresh1 [] binders @ mk_fresh2 [] frees';
 20.1483 -        val prems4 = map (fn ((i, _), y) =>
 20.1484 -          HOLogic.mk_Trueprop (List.nth (rec_preds, i) $ Free y)) (recs ~~ frees'');
 20.1485 -        val prems5 = mk_fresh3 (recs ~~ frees'') frees';
 20.1486 -        val prems6 = maps (fn aT => map (fn y as (_, T) => HOLogic.mk_Trueprop
 20.1487 -          (Const ("Finite_Set.finite", HOLogic.mk_setT aT --> HOLogic.boolT) $
 20.1488 -             (Const ("Nominal.supp", T --> HOLogic.mk_setT aT) $ Free y)))
 20.1489 -               frees'') atomTs;
 20.1490 -        val prems7 = map (fn x as (_, T) => HOLogic.mk_Trueprop
 20.1491 -          (fresh_const T fsT' $ Free x $ rec_ctxt)) binders;
 20.1492 -        val result = list_comb (List.nth (rec_fns, l), map Free (frees @ frees''));
 20.1493 -        val result_freshs = map (fn p as (_, T) =>
 20.1494 -          fresh_const T (fastype_of result) $ Free p $ result) binders;
 20.1495 -        val P = HOLogic.mk_Trueprop (p $ result)
 20.1496 -      in
 20.1497 -        (rec_intr_ts @ [Logic.list_implies (List.concat prems2 @ prems3 @ prems1,
 20.1498 -           HOLogic.mk_Trueprop (rec_set $
 20.1499 -             list_comb (Const (cname, Ts ---> T), map Free frees) $ result))],
 20.1500 -         rec_prems @ [list_all_free (frees @ frees'', Logic.list_implies (prems4, P))],
 20.1501 -         rec_prems' @ map (fn fr => list_all_free (frees @ frees'',
 20.1502 -           Logic.list_implies (List.nth (prems2, l) @ prems3 @ prems5 @ prems7 @ prems6 @ [P],
 20.1503 -             HOLogic.mk_Trueprop fr))) result_freshs,
 20.1504 -         rec_eq_prems @ [List.concat prems2 @ prems3],
 20.1505 -         l + 1)
 20.1506 -      end;
 20.1507 -
 20.1508 -    val (rec_intr_ts, rec_prems, rec_prems', rec_eq_prems, _) =
 20.1509 -      Library.foldl (fn (x, ((((d, d'), T), p), rec_set)) =>
 20.1510 -        Library.foldl (make_rec_intr T p rec_set) (x, #3 (snd d) ~~ snd d'))
 20.1511 -          (([], [], [], [], 0), descr'' ~~ ndescr ~~ recTs ~~ rec_preds ~~ rec_sets');
 20.1512 -
 20.1513 -    val ({intrs = rec_intrs, elims = rec_elims, raw_induct = rec_induct, ...}, thy11) =
 20.1514 -      thy10 |>
 20.1515 -        InductivePackage.add_inductive_global (serial_string ())
 20.1516 -          {quiet_mode = #quiet config, verbose = false, kind = Thm.internalK,
 20.1517 -           alt_name = Binding.name big_rec_name, coind = false, no_elim = false, no_ind = false,
 20.1518 -           skip_mono = true, fork_mono = false}
 20.1519 -          (map (fn (s, T) => ((Binding.name s, T), NoSyn)) (rec_set_names' ~~ rec_set_Ts))
 20.1520 -          (map dest_Free rec_fns)
 20.1521 -          (map (fn x => (Attrib.empty_binding, x)) rec_intr_ts) [] ||>
 20.1522 -      PureThy.hide_fact true (Long_Name.append (Sign.full_bname thy10 big_rec_name) "induct");
 20.1523 -
 20.1524 -    (** equivariance **)
 20.1525 -
 20.1526 -    val fresh_bij = PureThy.get_thms thy11 "fresh_bij";
 20.1527 -    val perm_bij = PureThy.get_thms thy11 "perm_bij";
 20.1528 -
 20.1529 -    val (rec_equiv_thms, rec_equiv_thms') = ListPair.unzip (map (fn aT =>
 20.1530 -      let
 20.1531 -        val permT = mk_permT aT;
 20.1532 -        val pi = Free ("pi", permT);
 20.1533 -        val rec_fns_pi = map (mk_perm [] pi o uncurry (mk_Free "f"))
 20.1534 -          (rec_fn_Ts ~~ (1 upto (length rec_fn_Ts)));
 20.1535 -        val rec_sets_pi = map (fn c => list_comb (Const c, rec_fns_pi))
 20.1536 -          (rec_set_names ~~ rec_set_Ts);
 20.1537 -        val ps = map (fn ((((T, U), R), R'), i) =>
 20.1538 -          let
 20.1539 -            val x = Free ("x" ^ string_of_int i, T);
 20.1540 -            val y = Free ("y" ^ string_of_int i, U)
 20.1541 -          in
 20.1542 -            (R $ x $ y, R' $ mk_perm [] pi x $ mk_perm [] pi y)
 20.1543 -          end) (recTs ~~ rec_result_Ts ~~ rec_sets ~~ rec_sets_pi ~~ (1 upto length recTs));
 20.1544 -        val ths = map (fn th => standard (th RS mp)) (split_conj_thm
 20.1545 -          (Goal.prove_global thy11 [] []
 20.1546 -            (augment_sort thy1 pt_cp_sort
 20.1547 -              (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map HOLogic.mk_imp ps))))
 20.1548 -            (fn _ => rtac rec_induct 1 THEN REPEAT
 20.1549 -               (simp_tac (Simplifier.theory_context thy11 HOL_basic_ss
 20.1550 -                  addsimps flat perm_simps'
 20.1551 -                  addsimprocs [NominalPermeq.perm_simproc_app]) 1 THEN
 20.1552 -                (resolve_tac rec_intrs THEN_ALL_NEW
 20.1553 -                 asm_simp_tac (HOL_ss addsimps (fresh_bij @ perm_bij))) 1))))
 20.1554 -        val ths' = map (fn ((P, Q), th) =>
 20.1555 -          Goal.prove_global thy11 [] []
 20.1556 -            (augment_sort thy1 pt_cp_sort
 20.1557 -              (Logic.mk_implies (HOLogic.mk_Trueprop Q, HOLogic.mk_Trueprop P)))
 20.1558 -            (fn _ => dtac (Thm.instantiate ([],
 20.1559 -                 [(cterm_of thy11 (Var (("pi", 0), permT)),
 20.1560 -                   cterm_of thy11 (Const ("List.rev", permT --> permT) $ pi))]) th) 1 THEN
 20.1561 -               NominalPermeq.perm_simp_tac HOL_ss 1)) (ps ~~ ths)
 20.1562 -      in (ths, ths') end) dt_atomTs);
 20.1563 -
 20.1564 -    (** finite support **)
 20.1565 -
 20.1566 -    val rec_fin_supp_thms = map (fn aT =>
 20.1567 -      let
 20.1568 -        val name = Long_Name.base_name (fst (dest_Type aT));
 20.1569 -        val fs_name = PureThy.get_thm thy11 ("fs_" ^ name ^ "1");
 20.1570 -        val aset = HOLogic.mk_setT aT;
 20.1571 -        val finite = Const ("Finite_Set.finite", aset --> HOLogic.boolT);
 20.1572 -        val fins = map (fn (f, T) => HOLogic.mk_Trueprop
 20.1573 -          (finite $ (Const ("Nominal.supp", T --> aset) $ f)))
 20.1574 -            (rec_fns ~~ rec_fn_Ts)
 20.1575 -      in
 20.1576 -        map (fn th => standard (th RS mp)) (split_conj_thm
 20.1577 -          (Goal.prove_global thy11 []
 20.1578 -            (map (augment_sort thy11 fs_cp_sort) fins)
 20.1579 -            (augment_sort thy11 fs_cp_sort
 20.1580 -              (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
 20.1581 -                (map (fn (((T, U), R), i) =>
 20.1582 -                   let
 20.1583 -                     val x = Free ("x" ^ string_of_int i, T);
 20.1584 -                     val y = Free ("y" ^ string_of_int i, U)
 20.1585 -                   in
 20.1586 -                     HOLogic.mk_imp (R $ x $ y,
 20.1587 -                       finite $ (Const ("Nominal.supp", U --> aset) $ y))
 20.1588 -                   end) (recTs ~~ rec_result_Ts ~~ rec_sets ~~
 20.1589 -                     (1 upto length recTs))))))
 20.1590 -            (fn {prems = fins, ...} =>
 20.1591 -              (rtac rec_induct THEN_ALL_NEW cut_facts_tac fins) 1 THEN REPEAT
 20.1592 -               (NominalPermeq.finite_guess_tac (HOL_ss addsimps [fs_name]) 1))))
 20.1593 -      end) dt_atomTs;
 20.1594 -
 20.1595 -    (** freshness **)
 20.1596 -
 20.1597 -    val finite_premss = map (fn aT =>
 20.1598 -      map (fn (f, T) => HOLogic.mk_Trueprop
 20.1599 -        (Const ("Finite_Set.finite", HOLogic.mk_setT aT --> HOLogic.boolT) $
 20.1600 -           (Const ("Nominal.supp", T --> HOLogic.mk_setT aT) $ f)))
 20.1601 -           (rec_fns ~~ rec_fn_Ts)) dt_atomTs;
 20.1602 -
 20.1603 -    val rec_fns' = map (augment_sort thy11 fs_cp_sort) rec_fns;
 20.1604 -
 20.1605 -    val rec_fresh_thms = map (fn ((aT, eqvt_ths), finite_prems) =>
 20.1606 -      let
 20.1607 -        val name = Long_Name.base_name (fst (dest_Type aT));
 20.1608 -        val fs_name = PureThy.get_thm thy11 ("fs_" ^ name ^ "1");
 20.1609 -        val a = Free ("a", aT);
 20.1610 -        val freshs = map (fn (f, fT) => HOLogic.mk_Trueprop
 20.1611 -          (fresh_const aT fT $ a $ f)) (rec_fns ~~ rec_fn_Ts)
 20.1612 -      in
 20.1613 -        map (fn (((T, U), R), eqvt_th) =>
 20.1614 -          let
 20.1615 -            val x = Free ("x", augment_sort_typ thy11 fs_cp_sort T);
 20.1616 -            val y = Free ("y", U);
 20.1617 -            val y' = Free ("y'", U)
 20.1618 -          in
 20.1619 -            standard (Goal.prove (ProofContext.init thy11) []
 20.1620 -              (map (augment_sort thy11 fs_cp_sort)
 20.1621 -                (finite_prems @
 20.1622 -                   [HOLogic.mk_Trueprop (R $ x $ y),
 20.1623 -                    HOLogic.mk_Trueprop (HOLogic.mk_all ("y'", U,
 20.1624 -                      HOLogic.mk_imp (R $ x $ y', HOLogic.mk_eq (y', y)))),
 20.1625 -                    HOLogic.mk_Trueprop (fresh_const aT T $ a $ x)] @
 20.1626 -                 freshs))
 20.1627 -              (HOLogic.mk_Trueprop (fresh_const aT U $ a $ y))
 20.1628 -              (fn {prems, context} =>
 20.1629 -                 let
 20.1630 -                   val (finite_prems, rec_prem :: unique_prem ::
 20.1631 -                     fresh_prems) = chop (length finite_prems) prems;
 20.1632 -                   val unique_prem' = unique_prem RS spec RS mp;
 20.1633 -                   val unique = [unique_prem', unique_prem' RS sym] MRS trans;
 20.1634 -                   val _ $ (_ $ (_ $ S $ _)) $ _ = prop_of supports_fresh;
 20.1635 -                   val tuple = foldr1 HOLogic.mk_prod (x :: rec_fns')
 20.1636 -                 in EVERY
 20.1637 -                   [rtac (Drule.cterm_instantiate
 20.1638 -                      [(cterm_of thy11 S,
 20.1639 -                        cterm_of thy11 (Const ("Nominal.supp",
 20.1640 -                          fastype_of tuple --> HOLogic.mk_setT aT) $ tuple))]
 20.1641 -                      supports_fresh) 1,
 20.1642 -                    simp_tac (HOL_basic_ss addsimps
 20.1643 -                      [supports_def, symmetric fresh_def, fresh_prod]) 1,
 20.1644 -                    REPEAT_DETERM (resolve_tac [allI, impI] 1),
 20.1645 -                    REPEAT_DETERM (etac conjE 1),
 20.1646 -                    rtac unique 1,
 20.1647 -                    SUBPROOF (fn {prems = prems', params = [a, b], ...} => EVERY
 20.1648 -                      [cut_facts_tac [rec_prem] 1,
 20.1649 -                       rtac (Thm.instantiate ([],
 20.1650 -                         [(cterm_of thy11 (Var (("pi", 0), mk_permT aT)),
 20.1651 -                           cterm_of thy11 (perm_of_pair (term_of a, term_of b)))]) eqvt_th) 1,
 20.1652 -                       asm_simp_tac (HOL_ss addsimps
 20.1653 -                         (prems' @ perm_swap @ perm_fresh_fresh)) 1]) context 1,
 20.1654 -                    rtac rec_prem 1,
 20.1655 -                    simp_tac (HOL_ss addsimps (fs_name ::
 20.1656 -                      supp_prod :: finite_Un :: finite_prems)) 1,
 20.1657 -                    simp_tac (HOL_ss addsimps (symmetric fresh_def ::
 20.1658 -                      fresh_prod :: fresh_prems)) 1]
 20.1659 -                 end))
 20.1660 -          end) (recTs ~~ rec_result_Ts ~~ rec_sets ~~ eqvt_ths)
 20.1661 -      end) (dt_atomTs ~~ rec_equiv_thms' ~~ finite_premss);
 20.1662 -
 20.1663 -    (** uniqueness **)
 20.1664 -
 20.1665 -    val fun_tuple = foldr1 HOLogic.mk_prod (rec_ctxt :: rec_fns);
 20.1666 -    val fun_tupleT = fastype_of fun_tuple;
 20.1667 -    val rec_unique_frees =
 20.1668 -      DatatypeProp.indexify_names (replicate (length recTs) "x") ~~ recTs;
 20.1669 -    val rec_unique_frees'' = map (fn (s, T) => (s ^ "'", T)) rec_unique_frees;
 20.1670 -    val rec_unique_frees' =
 20.1671 -      DatatypeProp.indexify_names (replicate (length recTs) "y") ~~ rec_result_Ts;
 20.1672 -    val rec_unique_concls = map (fn ((x, U), R) =>
 20.1673 -        Const ("Ex1", (U --> HOLogic.boolT) --> HOLogic.boolT) $
 20.1674 -          Abs ("y", U, R $ Free x $ Bound 0))
 20.1675 -      (rec_unique_frees ~~ rec_result_Ts ~~ rec_sets);
 20.1676 -
 20.1677 -    val induct_aux_rec = Drule.cterm_instantiate
 20.1678 -      (map (pairself (cterm_of thy11) o apsnd (augment_sort thy11 fs_cp_sort))
 20.1679 -         (map (fn (aT, f) => (Logic.varify f, Abs ("z", HOLogic.unitT,
 20.1680 -            Const ("Nominal.supp", fun_tupleT --> HOLogic.mk_setT aT) $ fun_tuple)))
 20.1681 -              fresh_fs @
 20.1682 -          map (fn (((P, T), (x, U)), Q) =>
 20.1683 -           (Var ((P, 0), Logic.varifyT (fsT' --> T --> HOLogic.boolT)),
 20.1684 -            Abs ("z", HOLogic.unitT, absfree (x, U, Q))))
 20.1685 -              (pnames ~~ recTs ~~ rec_unique_frees ~~ rec_unique_concls) @
 20.1686 -          map (fn (s, T) => (Var ((s, 0), Logic.varifyT T), Free (s, T)))
 20.1687 -            rec_unique_frees)) induct_aux;
 20.1688 -
 20.1689 -    fun obtain_fresh_name vs ths rec_fin_supp T (freshs1, freshs2, ctxt) =
 20.1690 -      let
 20.1691 -        val p = foldr1 HOLogic.mk_prod (vs @ freshs1);
 20.1692 -        val ex = Goal.prove ctxt [] [] (HOLogic.mk_Trueprop
 20.1693 -            (HOLogic.exists_const T $ Abs ("x", T,
 20.1694 -              fresh_const T (fastype_of p) $ Bound 0 $ p)))
 20.1695 -          (fn _ => EVERY
 20.1696 -            [cut_facts_tac ths 1,
 20.1697 -             REPEAT_DETERM (dresolve_tac (the (AList.lookup op = rec_fin_supp T)) 1),
 20.1698 -             resolve_tac exists_fresh' 1,
 20.1699 -             asm_simp_tac (HOL_ss addsimps (supp_prod :: finite_Un :: fs_atoms)) 1]);
 20.1700 -        val (([cx], ths), ctxt') = Obtain.result
 20.1701 -          (fn _ => EVERY
 20.1702 -            [etac exE 1,
 20.1703 -             full_simp_tac (HOL_ss addsimps (fresh_prod :: fresh_atm)) 1,
 20.1704 -             REPEAT (etac conjE 1)])
 20.1705 -          [ex] ctxt
 20.1706 -      in (freshs1 @ [term_of cx], freshs2 @ ths, ctxt') end;
 20.1707 -
 20.1708 -    val finite_ctxt_prems = map (fn aT =>
 20.1709 -      HOLogic.mk_Trueprop
 20.1710 -        (Const ("Finite_Set.finite", HOLogic.mk_setT aT --> HOLogic.boolT) $
 20.1711 -           (Const ("Nominal.supp", fsT' --> HOLogic.mk_setT aT) $ rec_ctxt))) dt_atomTs;
 20.1712 -
 20.1713 -    val rec_unique_thms = split_conj_thm (Goal.prove
 20.1714 -      (ProofContext.init thy11) (map fst rec_unique_frees)
 20.1715 -      (map (augment_sort thy11 fs_cp_sort)
 20.1716 -        (List.concat finite_premss @ finite_ctxt_prems @ rec_prems @ rec_prems'))
 20.1717 -      (augment_sort thy11 fs_cp_sort
 20.1718 -        (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj rec_unique_concls)))
 20.1719 -      (fn {prems, context} =>
 20.1720 -         let
 20.1721 -           val k = length rec_fns;
 20.1722 -           val (finite_thss, ths1) = fold_map (fn T => fn xs =>
 20.1723 -             apfst (pair T) (chop k xs)) dt_atomTs prems;
 20.1724 -           val (finite_ctxt_ths, ths2) = chop (length dt_atomTs) ths1;
 20.1725 -           val (P_ind_ths, fcbs) = chop k ths2;
 20.1726 -           val P_ths = map (fn th => th RS mp) (split_conj_thm
 20.1727 -             (Goal.prove context
 20.1728 -               (map fst (rec_unique_frees'' @ rec_unique_frees')) []
 20.1729 -               (augment_sort thy11 fs_cp_sort
 20.1730 -                 (HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj
 20.1731 -                    (map (fn (((x, y), S), P) => HOLogic.mk_imp
 20.1732 -                      (S $ Free x $ Free y, P $ (Free y)))
 20.1733 -                        (rec_unique_frees'' ~~ rec_unique_frees' ~~
 20.1734 -                           rec_sets ~~ rec_preds)))))
 20.1735 -               (fn _ =>
 20.1736 -                  rtac rec_induct 1 THEN
 20.1737 -                  REPEAT ((resolve_tac P_ind_ths THEN_ALL_NEW assume_tac) 1))));
 20.1738 -           val rec_fin_supp_thms' = map
 20.1739 -             (fn (ths, (T, fin_ths)) => (T, map (curry op MRS fin_ths) ths))
 20.1740 -             (rec_fin_supp_thms ~~ finite_thss);
 20.1741 -         in EVERY
 20.1742 -           ([rtac induct_aux_rec 1] @
 20.1743 -            maps (fn ((_, finite_ths), finite_th) =>
 20.1744 -              [cut_facts_tac (finite_th :: finite_ths) 1,
 20.1745 -               asm_simp_tac (HOL_ss addsimps [supp_prod, finite_Un]) 1])
 20.1746 -                (finite_thss ~~ finite_ctxt_ths) @
 20.1747 -            maps (fn ((_, idxss), elim) => maps (fn idxs =>
 20.1748 -              [full_simp_tac (HOL_ss addsimps [symmetric fresh_def, supp_prod, Un_iff]) 1,
 20.1749 -               REPEAT_DETERM (eresolve_tac [conjE, ex1E] 1),
 20.1750 -               rtac ex1I 1,
 20.1751 -               (resolve_tac rec_intrs THEN_ALL_NEW atac) 1,
 20.1752 -               rotate_tac ~1 1,
 20.1753 -               ((DETERM o etac elim) THEN_ALL_NEW full_simp_tac
 20.1754 -                  (HOL_ss addsimps List.concat distinct_thms)) 1] @
 20.1755 -               (if null idxs then [] else [hyp_subst_tac 1,
 20.1756 -                SUBPROOF (fn {asms, concl, prems = prems', params, context = context', ...} =>
 20.1757 -                  let
 20.1758 -                    val SOME prem = find_first (can (HOLogic.dest_eq o
 20.1759 -                      HOLogic.dest_Trueprop o prop_of)) prems';
 20.1760 -                    val _ $ (_ $ lhs $ rhs) = prop_of prem;
 20.1761 -                    val _ $ (_ $ lhs' $ rhs') = term_of concl;
 20.1762 -                    val rT = fastype_of lhs';
 20.1763 -                    val (c, cargsl) = strip_comb lhs;
 20.1764 -                    val cargsl' = partition_cargs idxs cargsl;
 20.1765 -                    val boundsl = List.concat (map fst cargsl');
 20.1766 -                    val (_, cargsr) = strip_comb rhs;
 20.1767 -                    val cargsr' = partition_cargs idxs cargsr;
 20.1768 -                    val boundsr = List.concat (map fst cargsr');
 20.1769 -                    val (params1, _ :: params2) =
 20.1770 -                      chop (length params div 2) (map term_of params);
 20.1771 -                    val params' = params1 @ params2;
 20.1772 -                    val rec_prems = filter (fn th => case prop_of th of
 20.1773 -                        _ $ p => (case head_of p of
 20.1774 -                          Const (s, _) => s mem rec_set_names
 20.1775 -                        | _ => false)
 20.1776 -                      | _ => false) prems';
 20.1777 -                    val fresh_prems = filter (fn th => case prop_of th of
 20.1778 -                        _ $ (Const ("Nominal.fresh", _) $ _ $ _) => true
 20.1779 -                      | _ $ (Const ("Not", _) $ _) => true
 20.1780 -                      | _ => false) prems';
 20.1781 -                    val Ts = map fastype_of boundsl;
 20.1782 -
 20.1783 -                    val _ = warning "step 1: obtaining fresh names";
 20.1784 -                    val (freshs1, freshs2, context'') = fold
 20.1785 -                      (obtain_fresh_name (rec_ctxt :: rec_fns' @ params')
 20.1786 -                         (List.concat (map snd finite_thss) @
 20.1787 -                            finite_ctxt_ths @ rec_prems)
 20.1788 -                         rec_fin_supp_thms')
 20.1789 -                      Ts ([], [], context');
 20.1790 -                    val pi1 = map perm_of_pair (boundsl ~~ freshs1);
 20.1791 -                    val rpi1 = rev pi1;
 20.1792 -                    val pi2 = map perm_of_pair (boundsr ~~ freshs1);
 20.1793 -                    val rpi2 = rev pi2;
 20.1794 -
 20.1795 -                    val fresh_prems' = mk_not_sym fresh_prems;
 20.1796 -                    val freshs2' = mk_not_sym freshs2;
 20.1797 -
 20.1798 -                    (** as, bs, cs # K as ts, K bs us **)
 20.1799 -                    val _ = warning "step 2: as, bs, cs # K as ts, K bs us";
 20.1800 -                    val prove_fresh_ss = HOL_ss addsimps
 20.1801 -                      (finite_Diff :: List.concat fresh_thms @
 20.1802 -                       fs_atoms @ abs_fresh @ abs_supp @ fresh_atm);
 20.1803 -                    (* FIXME: avoid asm_full_simp_tac ? *)
 20.1804 -                    fun prove_fresh ths y x = Goal.prove context'' [] []
 20.1805 -                      (HOLogic.mk_Trueprop (fresh_const
 20.1806 -                         (fastype_of x) (fastype_of y) $ x $ y))
 20.1807 -                      (fn _ => cut_facts_tac ths 1 THEN asm_full_simp_tac prove_fresh_ss 1);
 20.1808 -                    val constr_fresh_thms =
 20.1809 -                      map (prove_fresh fresh_prems lhs) boundsl @
 20.1810 -                      map (prove_fresh fresh_prems rhs) boundsr @
 20.1811 -                      map (prove_fresh freshs2 lhs) freshs1 @
 20.1812 -                      map (prove_fresh freshs2 rhs) freshs1;
 20.1813 -
 20.1814 -                    (** pi1 o (K as ts) = pi2 o (K bs us) **)
 20.1815 -                    val _ = warning "step 3: pi1 o (K as ts) = pi2 o (K bs us)";
 20.1816 -                    val pi1_pi2_eq = Goal.prove context'' [] []
 20.1817 -                      (HOLogic.mk_Trueprop (HOLogic.mk_eq
 20.1818 -                        (fold_rev (mk_perm []) pi1 lhs, fold_rev (mk_perm []) pi2 rhs)))
 20.1819 -                      (fn _ => EVERY
 20.1820 -                         [cut_facts_tac constr_fresh_thms 1,
 20.1821 -                          asm_simp_tac (HOL_basic_ss addsimps perm_fresh_fresh) 1,
 20.1822 -                          rtac prem 1]);
 20.1823 -
 20.1824 -                    (** pi1 o ts = pi2 o us **)
 20.1825 -                    val _ = warning "step 4: pi1 o ts = pi2 o us";
 20.1826 -                    val pi1_pi2_eqs = map (fn (t, u) =>
 20.1827 -                      Goal.prove context'' [] []
 20.1828 -                        (HOLogic.mk_Trueprop (HOLogic.mk_eq
 20.1829 -                          (fold_rev (mk_perm []) pi1 t, fold_rev (mk_perm []) pi2 u)))
 20.1830 -                        (fn _ => EVERY
 20.1831 -                           [cut_facts_tac [pi1_pi2_eq] 1,
 20.1832 -                            asm_full_simp_tac (HOL_ss addsimps
 20.1833 -                              (calc_atm @ List.concat perm_simps' @
 20.1834 -                               fresh_prems' @ freshs2' @ abs_perm @
 20.1835 -                               alpha @ List.concat inject_thms)) 1]))
 20.1836 -                        (map snd cargsl' ~~ map snd cargsr');
 20.1837 -
 20.1838 -                    (** pi1^-1 o pi2 o us = ts **)
 20.1839 -                    val _ = warning "step 5: pi1^-1 o pi2 o us = ts";
 20.1840 -                    val rpi1_pi2_eqs = map (fn ((t, u), eq) =>
 20.1841 -                      Goal.prove context'' [] []
 20.1842 -                        (HOLogic.mk_Trueprop (HOLogic.mk_eq
 20.1843 -                          (fold_rev (mk_perm []) (rpi1 @ pi2) u, t)))
 20.1844 -                        (fn _ => simp_tac (HOL_ss addsimps
 20.1845 -                           ((eq RS sym) :: perm_swap)) 1))
 20.1846 -                        (map snd cargsl' ~~ map snd cargsr' ~~ pi1_pi2_eqs);
 20.1847 -
 20.1848 -                    val (rec_prems1, rec_prems2) =
 20.1849 -                      chop (length rec_prems div 2) rec_prems;
 20.1850 -
 20.1851 -                    (** (ts, pi1^-1 o pi2 o vs) in rec_set **)
 20.1852 -                    val _ = warning "step 6: (ts, pi1^-1 o pi2 o vs) in rec_set";
 20.1853 -                    val rec_prems' = map (fn th =>
 20.1854 -                      let
 20.1855 -                        val _ $ (S $ x $ y) = prop_of th;
 20.1856 -                        val Const (s, _) = head_of S;
 20.1857 -                        val k = find_index (equal s) rec_set_names;
 20.1858 -                        val pi = rpi1 @ pi2;
 20.1859 -                        fun mk_pi z = fold_rev (mk_perm []) pi z;
 20.1860 -                        fun eqvt_tac p =
 20.1861 -                          let
 20.1862 -                            val U as Type (_, [Type (_, [T, _])]) = fastype_of p;
 20.1863 -                            val l = find_index (equal T) dt_atomTs;
 20.1864 -                            val th = List.nth (List.nth (rec_equiv_thms', l), k);
 20.1865 -                            val th' = Thm.instantiate ([],
 20.1866 -                              [(cterm_of thy11 (Var (("pi", 0), U)),
 20.1867 -                                cterm_of thy11 p)]) th;
 20.1868 -                          in rtac th' 1 end;
 20.1869 -                        val th' = Goal.prove context'' [] []
 20.1870 -                          (HOLogic.mk_Trueprop (S $ mk_pi x $ mk_pi y))
 20.1871 -                          (fn _ => EVERY
 20.1872 -                             (map eqvt_tac pi @
 20.1873 -                              [simp_tac (HOL_ss addsimps (fresh_prems' @ freshs2' @
 20.1874 -                                 perm_swap @ perm_fresh_fresh)) 1,
 20.1875 -                               rtac th 1]))
 20.1876 -                      in
 20.1877 -                        Simplifier.simplify
 20.1878 -                          (HOL_basic_ss addsimps rpi1_pi2_eqs) th'
 20.1879 -                      end) rec_prems2;
 20.1880 -
 20.1881 -                    val ihs = filter (fn th => case prop_of th of
 20.1882 -                      _ $ (Const ("All", _) $ _) => true | _ => false) prems';
 20.1883 -
 20.1884 -                    (** pi1 o rs = pi2 o vs , rs = pi1^-1 o pi2 o vs **)
 20.1885 -                    val _ = warning "step 7: pi1 o rs = pi2 o vs , rs = pi1^-1 o pi2 o vs";
 20.1886 -                    val rec_eqns = map (fn (th, ih) =>
 20.1887 -                      let
 20.1888 -                        val th' = th RS (ih RS spec RS mp) RS sym;
 20.1889 -                        val _ $ (_ $ lhs $ rhs) = prop_of th';
 20.1890 -                        fun strip_perm (_ $ _ $ t) = strip_perm t
 20.1891 -                          | strip_perm t = t;
 20.1892 -                      in
 20.1893 -                        Goal.prove context'' [] []
 20.1894 -                           (HOLogic.mk_Trueprop (HOLogic.mk_eq
 20.1895 -                              (fold_rev (mk_perm []) pi1 lhs,
 20.1896 -                               fold_rev (mk_perm []) pi2 (strip_perm rhs))))
 20.1897 -                           (fn _ => simp_tac (HOL_basic_ss addsimps
 20.1898 -                              (th' :: perm_swap)) 1)
 20.1899 -                      end) (rec_prems' ~~ ihs);
 20.1900 -
 20.1901 -                    (** as # rs **)
 20.1902 -                    val _ = warning "step 8: as # rs";
 20.1903 -                    val rec_freshs = List.concat
 20.1904 -                      (map (fn (rec_prem, ih) =>
 20.1905 -                        let
 20.1906 -                          val _ $ (S $ x $ (y as Free (_, T))) =
 20.1907 -                            prop_of rec_prem;
 20.1908 -                          val k = find_index (equal S) rec_sets;
 20.1909 -                          val atoms = List.concat (List.mapPartial (fn (bs, z) =>
 20.1910 -                            if z = x then NONE else SOME bs) cargsl')
 20.1911 -                        in
 20.1912 -                          map (fn a as Free (_, aT) =>
 20.1913 -                            let val l = find_index (equal aT) dt_atomTs;
 20.1914 -                            in
 20.1915 -                              Goal.prove context'' [] []
 20.1916 -                                (HOLogic.mk_Trueprop (fresh_const aT T $ a $ y))
 20.1917 -                                (fn _ => EVERY
 20.1918 -                                   (rtac (List.nth (List.nth (rec_fresh_thms, l), k)) 1 ::
 20.1919 -                                    map (fn th => rtac th 1)
 20.1920 -                                      (snd (List.nth (finite_thss, l))) @
 20.1921 -                                    [rtac rec_prem 1, rtac ih 1,
 20.1922 -                                     REPEAT_DETERM (resolve_tac fresh_prems 1)]))
 20.1923 -                            end) atoms
 20.1924 -                        end) (rec_prems1 ~~ ihs));
 20.1925 -
 20.1926 -                    (** as # fK as ts rs , bs # fK bs us vs **)
 20.1927 -                    val _ = warning "step 9: as # fK as ts rs , bs # fK bs us vs";
 20.1928 -                    fun prove_fresh_result (a as Free (_, aT)) =
 20.1929 -                      Goal.prove context'' [] []
 20.1930 -                        (HOLogic.mk_Trueprop (fresh_const aT rT $ a $ rhs'))
 20.1931 -                        (fn _ => EVERY
 20.1932 -                           [resolve_tac fcbs 1,
 20.1933 -                            REPEAT_DETERM (resolve_tac
 20.1934 -                              (fresh_prems @ rec_freshs) 1),
 20.1935 -                            REPEAT_DETERM (resolve_tac (maps snd rec_fin_supp_thms') 1
 20.1936 -                              THEN resolve_tac rec_prems 1),
 20.1937 -                            resolve_tac P_ind_ths 1,
 20.1938 -                            REPEAT_DETERM (resolve_tac (P_ths @ rec_prems) 1)]);
 20.1939 -
 20.1940 -                    val fresh_results'' = map prove_fresh_result boundsl;
 20.1941 -
 20.1942 -                    fun prove_fresh_result'' ((a as Free (_, aT), b), th) =
 20.1943 -                      let val th' = Goal.prove context'' [] []
 20.1944 -                        (HOLogic.mk_Trueprop (fresh_const aT rT $
 20.1945 -                            fold_rev (mk_perm []) (rpi2 @ pi1) a $
 20.1946 -                            fold_rev (mk_perm []) (rpi2 @ pi1) rhs'))
 20.1947 -                        (fn _ => simp_tac (HOL_ss addsimps fresh_bij) 1 THEN
 20.1948 -                           rtac th 1)
 20.1949 -                      in
 20.1950 -                        Goal.prove context'' [] []
 20.1951 -                          (HOLogic.mk_Trueprop (fresh_const aT rT $ b $ lhs'))
 20.1952 -                          (fn _ => EVERY
 20.1953 -                             [cut_facts_tac [th'] 1,
 20.1954 -                              full_simp_tac (Simplifier.theory_context thy11 HOL_ss
 20.1955 -                                addsimps rec_eqns @ pi1_pi2_eqs @ perm_swap
 20.1956 -                                addsimprocs [NominalPermeq.perm_simproc_app]) 1,
 20.1957 -                              full_simp_tac (HOL_ss addsimps (calc_atm @
 20.1958 -                                fresh_prems' @ freshs2' @ perm_fresh_fresh)) 1])
 20.1959 -                      end;
 20.1960 -
 20.1961 -                    val fresh_results = fresh_results'' @ map prove_fresh_result''
 20.1962 -                      (boundsl ~~ boundsr ~~ fresh_results'');
 20.1963 -
 20.1964 -                    (** cs # fK as ts rs , cs # fK bs us vs **)
 20.1965 -                    val _ = warning "step 10: cs # fK as ts rs , cs # fK bs us vs";
 20.1966 -                    fun prove_fresh_result' recs t (a as Free (_, aT)) =
 20.1967 -                      Goal.prove context'' [] []
 20.1968 -                        (HOLogic.mk_Trueprop (fresh_const aT rT $ a $ t))
 20.1969 -                        (fn _ => EVERY
 20.1970 -                          [cut_facts_tac recs 1,
 20.1971 -                           REPEAT_DETERM (dresolve_tac
 20.1972 -                             (the (AList.lookup op = rec_fin_supp_thms' aT)) 1),
 20.1973 -                           NominalPermeq.fresh_guess_tac
 20.1974 -                             (HOL_ss addsimps (freshs2 @
 20.1975 -                                fs_atoms @ fresh_atm @
 20.1976 -                                List.concat (map snd finite_thss))) 1]);
 20.1977 -
 20.1978 -                    val fresh_results' =
 20.1979 -                      map (prove_fresh_result' rec_prems1 rhs') freshs1 @
 20.1980 -                      map (prove_fresh_result' rec_prems2 lhs') freshs1;
 20.1981 -
 20.1982 -                    (** pi1 o (fK as ts rs) = pi2 o (fK bs us vs) **)
 20.1983 -                    val _ = warning "step 11: pi1 o (fK as ts rs) = pi2 o (fK bs us vs)";
 20.1984 -                    val pi1_pi2_result = Goal.prove context'' [] []
 20.1985 -                      (HOLogic.mk_Trueprop (HOLogic.mk_eq
 20.1986 -                        (fold_rev (mk_perm []) pi1 rhs', fold_rev (mk_perm []) pi2 lhs')))
 20.1987 -                      (fn _ => simp_tac (Simplifier.context context'' HOL_ss
 20.1988 -                           addsimps pi1_pi2_eqs @ rec_eqns
 20.1989 -                           addsimprocs [NominalPermeq.perm_simproc_app]) 1 THEN
 20.1990 -                         TRY (simp_tac (HOL_ss addsimps
 20.1991 -                           (fresh_prems' @ freshs2' @ calc_atm @ perm_fresh_fresh)) 1));
 20.1992 -
 20.1993 -                    val _ = warning "final result";
 20.1994 -                    val final = Goal.prove context'' [] [] (term_of concl)
 20.1995 -                      (fn _ => cut_facts_tac [pi1_pi2_result RS sym] 1 THEN
 20.1996 -                        full_simp_tac (HOL_basic_ss addsimps perm_fresh_fresh @
 20.1997 -                          fresh_results @ fresh_results') 1);
 20.1998 -                    val final' = ProofContext.export context'' context' [final];
 20.1999 -                    val _ = warning "finished!"
 20.2000 -                  in
 20.2001 -                    resolve_tac final' 1
 20.2002 -                  end) context 1])) idxss) (ndescr ~~ rec_elims))
 20.2003 -         end));
 20.2004 -
 20.2005 -    val rec_total_thms = map (fn r => r RS theI') rec_unique_thms;
 20.2006 -
 20.2007 -    (* define primrec combinators *)
 20.2008 -
 20.2009 -    val big_reccomb_name = (space_implode "_" new_type_names) ^ "_rec";
 20.2010 -    val reccomb_names = map (Sign.full_bname thy11)
 20.2011 -      (if length descr'' = 1 then [big_reccomb_name] else
 20.2012 -        (map ((curry (op ^) (big_reccomb_name ^ "_")) o string_of_int)
 20.2013 -          (1 upto (length descr''))));
 20.2014 -    val reccombs = map (fn ((name, T), T') => list_comb
 20.2015 -      (Const (name, rec_fn_Ts @ [T] ---> T'), rec_fns))
 20.2016 -        (reccomb_names ~~ recTs ~~ rec_result_Ts);
 20.2017 -
 20.2018 -    val (reccomb_defs, thy12) =
 20.2019 -      thy11
 20.2020 -      |> Sign.add_consts_i (map (fn ((name, T), T') =>
 20.2021 -          (Binding.name (Long_Name.base_name name), rec_fn_Ts @ [T] ---> T', NoSyn))
 20.2022 -          (reccomb_names ~~ recTs ~~ rec_result_Ts))
 20.2023 -      |> (PureThy.add_defs false o map Thm.no_attributes) (map (fn ((((name, comb), set), T), T') =>
 20.2024 -          (Binding.name (Long_Name.base_name name ^ "_def"), Logic.mk_equals (comb, absfree ("x", T,
 20.2025 -           Const ("The", (T' --> HOLogic.boolT) --> T') $ absfree ("y", T',
 20.2026 -             set $ Free ("x", T) $ Free ("y", T'))))))
 20.2027 -               (reccomb_names ~~ reccombs ~~ rec_sets ~~ recTs ~~ rec_result_Ts));
 20.2028 -
 20.2029 -    (* prove characteristic equations for primrec combinators *)
 20.2030 -
 20.2031 -    val rec_thms = map (fn (prems, concl) =>
 20.2032 -      let
 20.2033 -        val _ $ (_ $ (_ $ x) $ _) = concl;
 20.2034 -        val (_, cargs) = strip_comb x;
 20.2035 -        val ps = map (fn (x as Free (_, T), i) =>
 20.2036 -          (Free ("x" ^ string_of_int i, T), x)) (cargs ~~ (1 upto length cargs));
 20.2037 -        val concl' = subst_atomic_types (rec_result_Ts' ~~ rec_result_Ts) concl;
 20.2038 -        val prems' = List.concat finite_premss @ finite_ctxt_prems @
 20.2039 -          rec_prems @ rec_prems' @ map (subst_atomic ps) prems;
 20.2040 -        fun solve rules prems = resolve_tac rules THEN_ALL_NEW
 20.2041 -          (resolve_tac prems THEN_ALL_NEW atac)
 20.2042 -      in
 20.2043 -        Goal.prove_global thy12 []
 20.2044 -          (map (augment_sort thy12 fs_cp_sort) prems')
 20.2045 -          (augment_sort thy12 fs_cp_sort concl')
 20.2046 -          (fn {prems, ...} => EVERY
 20.2047 -            [rewrite_goals_tac reccomb_defs,
 20.2048 -             rtac the1_equality 1,
 20.2049 -             solve rec_unique_thms prems 1,
 20.2050 -             resolve_tac rec_intrs 1,
 20.2051 -             REPEAT (solve (prems @ rec_total_thms) prems 1)])
 20.2052 -      end) (rec_eq_prems ~~
 20.2053 -        DatatypeProp.make_primrecs new_type_names descr' sorts thy12);
 20.2054 -
 20.2055 -    val dt_infos = map (make_dt_info pdescr sorts induct reccomb_names rec_thms)
 20.2056 -      ((0 upto length descr1 - 1) ~~ descr1 ~~ distinct_thms ~~ inject_thms);
 20.2057 -
 20.2058 -    (* FIXME: theorems are stored in database for testing only *)
 20.2059 -    val (_, thy13) = thy12 |>
 20.2060 -      PureThy.add_thmss
 20.2061 -        [((Binding.name "rec_equiv", List.concat rec_equiv_thms), []),
 20.2062 -         ((Binding.name "rec_equiv'", List.concat rec_equiv_thms'), []),
 20.2063 -         ((Binding.name "rec_fin_supp", List.concat rec_fin_supp_thms), []),
 20.2064 -         ((Binding.name "rec_fresh", List.concat rec_fresh_thms), []),
 20.2065 -         ((Binding.name "rec_unique", map standard rec_unique_thms), []),
 20.2066 -         ((Binding.name "recs", rec_thms), [])] ||>
 20.2067 -      Sign.parent_path ||>
 20.2068 -      map_nominal_datatypes (fold Symtab.update dt_infos);
 20.2069 -
 20.2070 -  in
 20.2071 -    thy13
 20.2072 -  end;
 20.2073 -
 20.2074 -val add_nominal_datatype = gen_add_nominal_datatype DatatypePackage.read_typ;
 20.2075 -
 20.2076 -
 20.2077 -(* FIXME: The following stuff should be exported by DatatypePackage *)
 20.2078 -
 20.2079 -local structure P = OuterParse and K = OuterKeyword in
 20.2080 -
 20.2081 -val datatype_decl =
 20.2082 -  Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.type_args -- P.name -- P.opt_infix --
 20.2083 -    (P.$$$ "=" |-- P.enum1 "|" (P.name -- Scan.repeat P.typ -- P.opt_mixfix));
 20.2084 -
 20.2085 -fun mk_datatype args =
 20.2086 -  let
 20.2087 -    val names = map (fn ((((NONE, _), t), _), _) => t | ((((SOME t, _), _), _), _) => t) args;
 20.2088 -    val specs = map (fn ((((_, vs), t), mx), cons) =>
 20.2089 -      (vs, t, mx, map (fn ((x, y), z) => (x, y, z)) cons)) args;
 20.2090 -  in add_nominal_datatype DatatypeAux.default_datatype_config names specs end;
 20.2091 -
 20.2092 -val _ =
 20.2093 -  OuterSyntax.command "nominal_datatype" "define inductive datatypes" K.thy_decl
 20.2094 -    (P.and_list1 datatype_decl >> (Toplevel.theory o mk_datatype));
 20.2095 -
 20.2096 -end;
 20.2097 -
 20.2098 -end
    21.1 --- a/src/HOL/Nominal/nominal_primrec.ML	Thu Jun 18 18:31:14 2009 -0700
    21.2 +++ b/src/HOL/Nominal/nominal_primrec.ML	Fri Jun 19 17:23:21 2009 +0200
    21.3 @@ -3,7 +3,7 @@
    21.4      Author:     Stefan Berghofer, TU Muenchen
    21.5  
    21.6  Package for defining functions on nominal datatypes by primitive recursion.
    21.7 -Taken from HOL/Tools/primrec_package.ML
    21.8 +Taken from HOL/Tools/primrec.ML
    21.9  *)
   21.10  
   21.11  signature NOMINAL_PRIMREC =
   21.12 @@ -223,7 +223,7 @@
   21.13  
   21.14  (* find datatypes which contain all datatypes in tnames' *)
   21.15  
   21.16 -fun find_dts (dt_info : NominalPackage.nominal_datatype_info Symtab.table) _ [] = []
   21.17 +fun find_dts (dt_info : Nominal.nominal_datatype_info Symtab.table) _ [] = []
   21.18    | find_dts dt_info tnames' (tname::tnames) =
   21.19        (case Symtab.lookup dt_info tname of
   21.20            NONE => primrec_err (quote tname ^ " is not a nominal datatype")
   21.21 @@ -247,7 +247,7 @@
   21.22      val eqns' = map unquantify spec'
   21.23      val eqns = fold_rev (process_eqn lthy (fn v => Variable.is_fixed lthy v
   21.24        orelse exists (fn ((w, _), _) => v = Binding.name_of w) fixes)) spec' [];
   21.25 -    val dt_info = NominalPackage.get_nominal_datatypes (ProofContext.theory_of lthy);
   21.26 +    val dt_info = Nominal.get_nominal_datatypes (ProofContext.theory_of lthy);
   21.27      val lsrs :: lsrss = maps (fn (_, (_, _, eqns)) =>
   21.28        map (fn (_, (ls, _, rs, _, _)) => ls @ rs) eqns) eqns
   21.29      val _ =
    22.1 --- a/src/HOL/Product_Type.thy	Thu Jun 18 18:31:14 2009 -0700
    22.2 +++ b/src/HOL/Product_Type.thy	Fri Jun 19 17:23:21 2009 +0200
    22.3 @@ -9,7 +9,7 @@
    22.4  imports Inductive
    22.5  uses
    22.6    ("Tools/split_rule.ML")
    22.7 -  ("Tools/inductive_set_package.ML")
    22.8 +  ("Tools/inductive_set.ML")
    22.9    ("Tools/inductive_realizer.ML")
   22.10    ("Tools/datatype_package/datatype_realizer.ML")
   22.11  begin
   22.12 @@ -1151,8 +1151,8 @@
   22.13  use "Tools/inductive_realizer.ML"
   22.14  setup InductiveRealizer.setup
   22.15  
   22.16 -use "Tools/inductive_set_package.ML"
   22.17 -setup InductiveSetPackage.setup
   22.18 +use "Tools/inductive_set.ML"
   22.19 +setup Inductive_Set.setup
   22.20  
   22.21  use "Tools/datatype_package/datatype_realizer.ML"
   22.22  setup DatatypeRealizer.setup
    23.1 --- a/src/HOL/Recdef.thy	Thu Jun 18 18:31:14 2009 -0700
    23.2 +++ b/src/HOL/Recdef.thy	Fri Jun 19 17:23:21 2009 +0200
    23.3 @@ -16,7 +16,7 @@
    23.4    ("Tools/TFL/thry.ML")
    23.5    ("Tools/TFL/tfl.ML")
    23.6    ("Tools/TFL/post.ML")
    23.7 -  ("Tools/recdef_package.ML")
    23.8 +  ("Tools/recdef.ML")
    23.9  begin
   23.10  
   23.11  text{** This form avoids giant explosions in proofs.  NOTE USE OF ==*}
   23.12 @@ -76,8 +76,8 @@
   23.13  use "Tools/TFL/thry.ML"
   23.14  use "Tools/TFL/tfl.ML"
   23.15  use "Tools/TFL/post.ML"
   23.16 -use "Tools/recdef_package.ML"
   23.17 -setup RecdefPackage.setup
   23.18 +use "Tools/recdef.ML"
   23.19 +setup Recdef.setup
   23.20  
   23.21  lemmas [recdef_simp] =
   23.22    inv_image_def
    24.1 --- a/src/HOL/Record.thy	Thu Jun 18 18:31:14 2009 -0700
    24.2 +++ b/src/HOL/Record.thy	Fri Jun 19 17:23:21 2009 +0200
    24.3 @@ -1,5 +1,4 @@
    24.4  (*  Title:      HOL/Record.thy
    24.5 -    ID:         $Id$
    24.6      Author:     Wolfgang Naraschewski, Norbert Schirmer and Markus Wenzel, TU Muenchen
    24.7  *)
    24.8  
    24.9 @@ -7,7 +6,7 @@
   24.10  
   24.11  theory Record
   24.12  imports Product_Type
   24.13 -uses ("Tools/record_package.ML")
   24.14 +uses ("Tools/record.ML")
   24.15  begin
   24.16  
   24.17  lemma prop_subst: "s = t \<Longrightarrow> PROP P t \<Longrightarrow> PROP P s"
   24.18 @@ -56,7 +55,7 @@
   24.19    "_record_scheme"      :: "[fields, 'a] => 'a"                 ("(3\<lparr>_,/ (2\<dots> =/ _)\<rparr>)")
   24.20    "_record_update"      :: "['a, updates] => 'b"                ("_/(3\<lparr>_\<rparr>)" [900,0] 900)
   24.21  
   24.22 -use "Tools/record_package.ML"
   24.23 -setup RecordPackage.setup
   24.24 +use "Tools/record.ML"
   24.25 +setup Record.setup
   24.26  
   24.27  end
    25.1 --- a/src/HOL/Statespace/state_fun.ML	Thu Jun 18 18:31:14 2009 -0700
    25.2 +++ b/src/HOL/Statespace/state_fun.ML	Fri Jun 19 17:23:21 2009 +0200
    25.3 @@ -74,7 +74,7 @@
    25.4  val string_eq_simp_tac =
    25.5       simp_tac (HOL_basic_ss 
    25.6                   addsimps (thms "list.inject"@thms "char.inject"@simp_thms)
    25.7 -                 addsimprocs [DatatypePackage.distinct_simproc,lazy_conj_simproc]
    25.8 +                 addsimprocs [Datatype.distinct_simproc,lazy_conj_simproc]
    25.9                   addcongs [thm "block_conj_cong"])
   25.10  end;
   25.11  
   25.12 @@ -89,7 +89,7 @@
   25.13  in
   25.14  val lookup_ss = (HOL_basic_ss 
   25.15                   addsimps (thms "list.inject"@thms "char.inject"@simp_thms@rules)
   25.16 -                 addsimprocs [DatatypePackage.distinct_simproc,lazy_conj_simproc]
   25.17 +                 addsimprocs [Datatype.distinct_simproc,lazy_conj_simproc]
   25.18                   addcongs [thm "block_conj_cong"]
   25.19                   addSolver StateSpace.distinctNameSolver) 
   25.20  end;
   25.21 @@ -167,7 +167,7 @@
   25.22  val meta_ext = thm "StateFun.meta_ext";
   25.23  val o_apply = thm "Fun.o_apply";
   25.24  val ss' = (HOL_ss addsimps (update_apply::o_apply::thms "list.inject"@thms "char.inject")
   25.25 -                 addsimprocs [DatatypePackage.distinct_simproc,lazy_conj_simproc,StateSpace.distinct_simproc]
   25.26 +                 addsimprocs [Datatype.distinct_simproc,lazy_conj_simproc,StateSpace.distinct_simproc]
   25.27                   addcongs [thm "block_conj_cong"]);
   25.28  in
   25.29  val update_simproc =
   25.30 @@ -267,7 +267,7 @@
   25.31  val swap_ex_eq = thm "StateFun.swap_ex_eq";
   25.32  fun is_selector thy T sel =
   25.33       let 
   25.34 -       val (flds,more) = RecordPackage.get_recT_fields thy T 
   25.35 +       val (flds,more) = Record.get_recT_fields thy T 
   25.36       in member (fn (s,(n,_)) => n=s) (more::flds) sel
   25.37       end;
   25.38  in
   25.39 @@ -340,7 +340,7 @@
   25.40    | mkName (TFree (x,_)) = mkUpper (Long_Name.base_name x)
   25.41    | mkName (TVar ((x,_),_)) = mkUpper (Long_Name.base_name x);
   25.42  
   25.43 -fun is_datatype thy n = is_some (Symtab.lookup (DatatypePackage.get_datatypes thy) n);
   25.44 +fun is_datatype thy n = is_some (Symtab.lookup (Datatype.get_datatypes thy) n);
   25.45  
   25.46  fun mk_map "List.list" = Syntax.const "List.map"
   25.47    | mk_map n = Syntax.const ("StateFun.map_" ^ Long_Name.base_name n);
    26.1 --- a/src/HOL/Statespace/state_space.ML	Thu Jun 18 18:31:14 2009 -0700
    26.2 +++ b/src/HOL/Statespace/state_space.ML	Fri Jun 19 17:23:21 2009 +0200
    26.3 @@ -585,8 +585,8 @@
    26.4    end
    26.5    handle ERROR msg => cat_error msg ("Failed to define statespace " ^ quote name);
    26.6  
    26.7 -val define_statespace = gen_define_statespace RecordPackage.read_typ NONE;
    26.8 -val define_statespace_i = gen_define_statespace RecordPackage.cert_typ;
    26.9 +val define_statespace = gen_define_statespace Record.read_typ NONE;
   26.10 +val define_statespace_i = gen_define_statespace Record.cert_typ;
   26.11  
   26.12  
   26.13  (*** parse/print - translations ***)
    27.1 --- a/src/HOL/Tools/TFL/casesplit.ML	Thu Jun 18 18:31:14 2009 -0700
    27.2 +++ b/src/HOL/Tools/TFL/casesplit.ML	Fri Jun 19 17:23:21 2009 +0200
    27.3 @@ -90,7 +90,7 @@
    27.4  (* get the case_thm (my version) from a type *)
    27.5  fun case_thm_of_ty sgn ty  =
    27.6      let
    27.7 -      val dtypestab = DatatypePackage.get_datatypes sgn;
    27.8 +      val dtypestab = Datatype.get_datatypes sgn;
    27.9        val ty_str = case ty of
   27.10                       Type(ty_str, _) => ty_str
   27.11                     | TFree(s,_)  => error ("Free type: " ^ s)
    28.1 --- a/src/HOL/Tools/TFL/tfl.ML	Thu Jun 18 18:31:14 2009 -0700
    28.2 +++ b/src/HOL/Tools/TFL/tfl.ML	Fri Jun 19 17:23:21 2009 +0200
    28.3 @@ -446,7 +446,7 @@
    28.4         slow.*)
    28.5       val case_ss = Simplifier.theory_context theory
    28.6         (HOL_basic_ss addcongs
    28.7 -         (map (#weak_case_cong o snd) o Symtab.dest o DatatypePackage.get_datatypes) theory addsimps case_rewrites)
    28.8 +         (map (#weak_case_cong o snd) o Symtab.dest o Datatype.get_datatypes) theory addsimps case_rewrites)
    28.9       val corollaries' = map (Simplifier.simplify case_ss) corollaries
   28.10       val extract = R.CONTEXT_REWRITE_RULE
   28.11                       (f, [R], @{thm cut_apply}, meta_tflCongs@context_congs)
    29.1 --- a/src/HOL/Tools/TFL/thry.ML	Thu Jun 18 18:31:14 2009 -0700
    29.2 +++ b/src/HOL/Tools/TFL/thry.ML	Fri Jun 19 17:23:21 2009 +0200
    29.3 @@ -60,20 +60,20 @@
    29.4   *---------------------------------------------------------------------------*)
    29.5  
    29.6  fun match_info thy dtco =
    29.7 -  case (DatatypePackage.get_datatype thy dtco,
    29.8 -         DatatypePackage.get_datatype_constrs thy dtco) of
    29.9 +  case (Datatype.get_datatype thy dtco,
   29.10 +         Datatype.get_datatype_constrs thy dtco) of
   29.11        (SOME { case_name, ... }, SOME constructors) =>
   29.12          SOME {case_const = Const (case_name, Sign.the_const_type thy case_name), constructors = map Const constructors}
   29.13      | _ => NONE;
   29.14  
   29.15 -fun induct_info thy dtco = case DatatypePackage.get_datatype thy dtco of
   29.16 +fun induct_info thy dtco = case Datatype.get_datatype thy dtco of
   29.17          NONE => NONE
   29.18        | SOME {nchotomy, ...} =>
   29.19            SOME {nchotomy = nchotomy,
   29.20 -                constructors = (map Const o the o DatatypePackage.get_datatype_constrs thy) dtco};
   29.21 +                constructors = (map Const o the o Datatype.get_datatype_constrs thy) dtco};
   29.22  
   29.23  fun extract_info thy =
   29.24 - let val infos = (map snd o Symtab.dest o DatatypePackage.get_datatypes) thy
   29.25 + let val infos = (map snd o Symtab.dest o Datatype.get_datatypes) thy
   29.26   in {case_congs = map (mk_meta_eq o #case_cong) infos,
   29.27       case_rewrites = List.concat (map (map mk_meta_eq o #case_rewrites) infos)}
   29.28   end;
    30.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    30.2 +++ b/src/HOL/Tools/choice_specification.ML	Fri Jun 19 17:23:21 2009 +0200
    30.3 @@ -0,0 +1,257 @@
    30.4 +(*  Title:      HOL/Tools/choice_specification.ML
    30.5 +    Author:     Sebastian Skalberg, TU Muenchen
    30.6 +
    30.7 +Package for defining constants by specification.
    30.8 +*)
    30.9 +
   30.10 +signature CHOICE_SPECIFICATION =
   30.11 +sig
   30.12 +  val add_specification: string option -> (bstring * xstring * bool) list ->
   30.13 +    theory * thm -> theory * thm
   30.14 +end
   30.15 +
   30.16 +structure Choice_Specification: CHOICE_SPECIFICATION =
   30.17 +struct
   30.18 +
   30.19 +(* actual code *)
   30.20 +
   30.21 +local
   30.22 +    fun mk_definitional [] arg = arg
   30.23 +      | mk_definitional ((thname,cname,covld)::cos) (thy,thm) =
   30.24 +        case HOLogic.dest_Trueprop (concl_of thm) of
   30.25 +            Const("Ex",_) $ P =>
   30.26 +            let
   30.27 +                val ctype = domain_type (type_of P)
   30.28 +                val cname_full = Sign.intern_const thy cname
   30.29 +                val cdefname = if thname = ""
   30.30 +                               then Thm.def_name (Long_Name.base_name cname)
   30.31 +                               else thname
   30.32 +                val def_eq = Logic.mk_equals (Const(cname_full,ctype),
   30.33 +                                              HOLogic.choice_const ctype $  P)
   30.34 +                val (thms, thy') = PureThy.add_defs covld [((Binding.name cdefname, def_eq),[])] thy
   30.35 +                val thm' = [thm,hd thms] MRS @{thm exE_some}
   30.36 +            in
   30.37 +                mk_definitional cos (thy',thm')
   30.38 +            end
   30.39 +          | _ => raise THM ("Internal error: Bad specification theorem",0,[thm])
   30.40 +
   30.41 +    fun mk_axiomatic axname cos arg =
   30.42 +        let
   30.43 +            fun process [] (thy,tm) =
   30.44 +                let
   30.45 +                    val (thms, thy') = PureThy.add_axioms [((Binding.name axname, HOLogic.mk_Trueprop tm),[])] thy
   30.46 +                in
   30.47 +                    (thy',hd thms)
   30.48 +                end
   30.49 +              | process ((thname,cname,covld)::cos) (thy,tm) =
   30.50 +                case tm of
   30.51 +                    Const("Ex",_) $ P =>
   30.52 +                    let
   30.53 +                        val ctype = domain_type (type_of P)
   30.54 +                        val cname_full = Sign.intern_const thy cname
   30.55 +                        val cdefname = if thname = ""
   30.56 +                                       then Thm.def_name (Long_Name.base_name cname)
   30.57 +                                       else thname
   30.58 +                        val co = Const(cname_full,ctype)
   30.59 +                        val thy' = Theory.add_finals_i covld [co] thy
   30.60 +                        val tm' = case P of
   30.61 +                                      Abs(_, _, bodt) => subst_bound (co, bodt)
   30.62 +                                    | _ => P $ co
   30.63 +                    in
   30.64 +                        process cos (thy',tm')
   30.65 +                    end
   30.66 +                  | _ => raise TERM ("Internal error: Bad specification theorem",[tm])
   30.67 +        in
   30.68 +            process cos arg
   30.69 +        end
   30.70 +
   30.71 +in
   30.72 +fun proc_exprop axiomatic cos arg =
   30.73 +    case axiomatic of
   30.74 +        SOME axname => mk_axiomatic axname cos (apsnd (HOLogic.dest_Trueprop o concl_of) arg)
   30.75 +      | NONE => mk_definitional cos arg
   30.76 +end
   30.77 +
   30.78 +fun add_specification axiomatic cos arg =
   30.79 +    arg |> apsnd Thm.freezeT
   30.80 +        |> proc_exprop axiomatic cos
   30.81 +        |> apsnd standard
   30.82 +
   30.83 +
   30.84 +(* Collect all intances of constants in term *)
   30.85 +
   30.86 +fun collect_consts (        t $ u,tms) = collect_consts (u,collect_consts (t,tms))
   30.87 +  | collect_consts (   Abs(_,_,t),tms) = collect_consts (t,tms)
   30.88 +  | collect_consts (tm as Const _,tms) = insert (op aconv) tm tms
   30.89 +  | collect_consts (            _,tms) = tms
   30.90 +
   30.91 +(* Complementing Type.varify... *)
   30.92 +
   30.93 +fun unvarify t fmap =
   30.94 +    let
   30.95 +        val fmap' = map Library.swap fmap
   30.96 +        fun unthaw (f as (a, S)) =
   30.97 +            (case AList.lookup (op =) fmap' a of
   30.98 +                 NONE => TVar f
   30.99 +               | SOME (b, _) => TFree (b, S))
  30.100 +    in
  30.101 +        map_types (map_type_tvar unthaw) t
  30.102 +    end
  30.103 +
  30.104 +(* The syntactic meddling needed to setup add_specification for work *)
  30.105 +
  30.106 +fun process_spec axiomatic cos alt_props thy =
  30.107 +    let
  30.108 +        fun zip3 [] [] [] = []
  30.109 +          | zip3 (x::xs) (y::ys) (z::zs) = (x,y,z)::zip3 xs ys zs
  30.110 +          | zip3 _ _ _ = error "Choice_Specification.process_spec internal error"
  30.111 +
  30.112 +        fun myfoldr f [x] = x
  30.113 +          | myfoldr f (x::xs) = f (x,myfoldr f xs)
  30.114 +          | myfoldr f [] = error "Choice_Specification.process_spec internal error"
  30.115 +
  30.116 +        val rew_imps = alt_props |>
  30.117 +          map (ObjectLogic.atomize o Thm.cterm_of thy o Syntax.read_prop_global thy o snd)
  30.118 +        val props' = rew_imps |>
  30.119 +          map (HOLogic.dest_Trueprop o term_of o snd o Thm.dest_equals o cprop_of)
  30.120 +
  30.121 +        fun proc_single prop =
  30.122 +            let
  30.123 +                val frees = OldTerm.term_frees prop
  30.124 +                val _ = forall (fn v => Sign.of_sort thy (type_of v,HOLogic.typeS)) frees
  30.125 +                  orelse error "Specificaton: Only free variables of sort 'type' allowed"
  30.126 +                val prop_closed = List.foldr (fn ((vname,T),prop) => HOLogic.mk_all (vname,T,prop)) prop (map dest_Free frees)
  30.127 +            in
  30.128 +                (prop_closed,frees)
  30.129 +            end
  30.130 +
  30.131 +        val props'' = map proc_single props'
  30.132 +        val frees = map snd props''
  30.133 +        val prop  = myfoldr HOLogic.mk_conj (map fst props'')
  30.134 +        val cprop = cterm_of thy (HOLogic.mk_Trueprop prop)
  30.135 +
  30.136 +        val (vmap, prop_thawed) = Type.varify [] prop
  30.137 +        val thawed_prop_consts = collect_consts (prop_thawed,[])
  30.138 +        val (altcos,overloaded) = Library.split_list cos
  30.139 +        val (names,sconsts) = Library.split_list altcos
  30.140 +        val consts = map (Syntax.read_term_global thy) sconsts
  30.141 +        val _ = not (Library.exists (not o Term.is_Const) consts)
  30.142 +          orelse error "Specification: Non-constant found as parameter"
  30.143 +
  30.144 +        fun proc_const c =
  30.145 +            let
  30.146 +                val (_, c') = Type.varify [] c
  30.147 +                val (cname,ctyp) = dest_Const c'
  30.148 +            in
  30.149 +                case List.filter (fn t => let val (name,typ) = dest_Const t
  30.150 +                                     in name = cname andalso Sign.typ_equiv thy (typ, ctyp)
  30.151 +                                     end) thawed_prop_consts of
  30.152 +                    [] => error ("Specification: No suitable instances of constant \"" ^ Syntax.string_of_term_global thy c ^ "\" found")
  30.153 +                  | [cf] => unvarify cf vmap
  30.154 +                  | _ => error ("Specification: Several variations of \"" ^ Syntax.string_of_term_global thy c ^ "\" found (try applying explicit type constraints)")
  30.155 +            end
  30.156 +        val proc_consts = map proc_const consts
  30.157 +        fun mk_exist (c,prop) =
  30.158 +            let
  30.159 +                val T = type_of c
  30.160 +                val cname = Long_Name.base_name (fst (dest_Const c))
  30.161 +                val vname = if Syntax.is_identifier cname
  30.162 +                            then cname
  30.163 +                            else "x"
  30.164 +            in
  30.165 +                HOLogic.exists_const T $ Abs(vname,T,Term.abstract_over (c,prop))
  30.166 +            end
  30.167 +        val ex_prop = List.foldr mk_exist prop proc_consts
  30.168 +        val cnames = map (fst o dest_Const) proc_consts
  30.169 +        fun post_process (arg as (thy,thm)) =
  30.170 +            let
  30.171 +                fun inst_all thy (thm,v) =
  30.172 +                    let
  30.173 +                        val cv = cterm_of thy v
  30.174 +                        val cT = ctyp_of_term cv
  30.175 +                        val spec' = instantiate' [SOME cT] [NONE,SOME cv] spec
  30.176 +                    in
  30.177 +                        thm RS spec'
  30.178 +                    end
  30.179 +                fun remove_alls frees thm =
  30.180 +                    Library.foldl (inst_all (Thm.theory_of_thm thm)) (thm,frees)
  30.181 +                fun process_single ((name,atts),rew_imp,frees) args =
  30.182 +                    let
  30.183 +                        fun undo_imps thm =
  30.184 +                            equal_elim (symmetric rew_imp) thm
  30.185 +
  30.186 +                        fun add_final (arg as (thy, thm)) =
  30.187 +                            if name = ""
  30.188 +                            then arg |> Library.swap
  30.189 +                            else (writeln ("  " ^ name ^ ": " ^ (Display.string_of_thm thm));
  30.190 +                                  PureThy.store_thm (Binding.name name, thm) thy)
  30.191 +                    in
  30.192 +                        args |> apsnd (remove_alls frees)
  30.193 +                             |> apsnd undo_imps
  30.194 +                             |> apsnd standard
  30.195 +                             |> Thm.theory_attributes (map (Attrib.attribute thy) atts)
  30.196 +                             |> add_final
  30.197 +                             |> Library.swap
  30.198 +                    end
  30.199 +
  30.200 +                fun process_all [proc_arg] args =
  30.201 +                    process_single proc_arg args
  30.202 +                  | process_all (proc_arg::rest) (thy,thm) =
  30.203 +                    let
  30.204 +                        val single_th = thm RS conjunct1
  30.205 +                        val rest_th   = thm RS conjunct2
  30.206 +                        val (thy',_)  = process_single proc_arg (thy,single_th)
  30.207 +                    in
  30.208 +                        process_all rest (thy',rest_th)
  30.209 +                    end
  30.210 +                  | process_all [] _ = error "Choice_Specification.process_spec internal error"
  30.211 +                val alt_names = map fst alt_props
  30.212 +                val _ = if exists (fn(name,_) => not (name = "")) alt_names
  30.213 +                        then writeln "specification"
  30.214 +                        else ()
  30.215 +            in
  30.216 +                arg |> apsnd Thm.freezeT
  30.217 +                    |> process_all (zip3 alt_names rew_imps frees)
  30.218 +            end
  30.219 +
  30.220 +      fun after_qed [[thm]] = ProofContext.theory (fn thy =>
  30.221 +        #1 (post_process (add_specification axiomatic (zip3 names cnames overloaded) (thy, thm))));
  30.222 +    in
  30.223 +      thy
  30.224 +      |> ProofContext.init
  30.225 +      |> Proof.theorem_i NONE after_qed [[(HOLogic.mk_Trueprop ex_prop, [])]]
  30.226 +    end;
  30.227 +
  30.228 +
  30.229 +(* outer syntax *)
  30.230 +
  30.231 +local structure P = OuterParse and K = OuterKeyword in
  30.232 +
  30.233 +val opt_name = Scan.optional (P.name --| P.$$$ ":") ""
  30.234 +val opt_overloaded = P.opt_keyword "overloaded";
  30.235 +
  30.236 +val specification_decl =
  30.237 +  P.$$$ "(" |-- Scan.repeat1 (opt_name -- P.term -- opt_overloaded) --| P.$$$ ")" --
  30.238 +          Scan.repeat1 ((SpecParse.opt_thm_name ":" >> apfst Binding.name_of) -- P.prop)
  30.239 +
  30.240 +val _ =
  30.241 +  OuterSyntax.command "specification" "define constants by specification" K.thy_goal
  30.242 +    (specification_decl >> (fn (cos,alt_props) =>
  30.243 +                               Toplevel.print o (Toplevel.theory_to_proof
  30.244 +                                                     (process_spec NONE cos alt_props))))
  30.245 +
  30.246 +val ax_specification_decl =
  30.247 +    P.name --
  30.248 +    (P.$$$ "(" |-- Scan.repeat1 (opt_name -- P.term -- opt_overloaded) --| P.$$$ ")" --
  30.249 +           Scan.repeat1 ((SpecParse.opt_thm_name ":" >> apfst Binding.name_of) -- P.prop))
  30.250 +
  30.251 +val _ =
  30.252 +  OuterSyntax.command "ax_specification" "define constants by specification" K.thy_goal
  30.253 +    (ax_specification_decl >> (fn (axname,(cos,alt_props)) =>
  30.254 +                               Toplevel.print o (Toplevel.theory_to_proof
  30.255 +                                                     (process_spec (SOME axname) cos alt_props))))
  30.256 +
  30.257 +end
  30.258 +
  30.259 +
  30.260 +end
    31.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    31.2 +++ b/src/HOL/Tools/datatype_package/datatype.ML	Fri Jun 19 17:23:21 2009 +0200
    31.3 @@ -0,0 +1,705 @@
    31.4 +(*  Title:      HOL/Tools/datatype.ML
    31.5 +    Author:     Stefan Berghofer, TU Muenchen
    31.6 +
    31.7 +Datatype package for Isabelle/HOL.
    31.8 +*)
    31.9 +
   31.10 +signature DATATYPE =
   31.11 +sig
   31.12 +  type datatype_config = DatatypeAux.datatype_config
   31.13 +  type datatype_info = DatatypeAux.datatype_info
   31.14 +  type descr = DatatypeAux.descr
   31.15 +  val get_datatypes : theory -> datatype_info Symtab.table
   31.16 +  val get_datatype : theory -> string -> datatype_info option
   31.17 +  val the_datatype : theory -> string -> datatype_info
   31.18 +  val datatype_of_constr : theory -> string -> datatype_info option
   31.19 +  val datatype_of_case : theory -> string -> datatype_info option
   31.20 +  val the_datatype_spec : theory -> string -> (string * sort) list * (string * typ list) list
   31.21 +  val the_datatype_descr : theory -> string list
   31.22 +    -> descr * (string * sort) list * string list
   31.23 +      * (string list * string list) * (typ list * typ list)
   31.24 +  val get_datatype_constrs : theory -> string -> (string * typ) list option
   31.25 +  val distinct_simproc : simproc
   31.26 +  val make_case :  Proof.context -> bool -> string list -> term ->
   31.27 +    (term * term) list -> term * (term * (int * bool)) list
   31.28 +  val strip_case : Proof.context -> bool -> term -> (term * (term * term) list) option
   31.29 +  val read_typ: theory ->
   31.30 +    (typ list * (string * sort) list) * string -> typ list * (string * sort) list
   31.31 +  val interpretation : (datatype_config -> string list -> theory -> theory) -> theory -> theory
   31.32 +  type rules = {distinct : thm list list,
   31.33 +    inject : thm list list,
   31.34 +    exhaustion : thm list,
   31.35 +    rec_thms : thm list,
   31.36 +    case_thms : thm list list,
   31.37 +    split_thms : (thm * thm) list,
   31.38 +    induction : thm,
   31.39 +    simps : thm list}
   31.40 +  val rep_datatype : datatype_config -> (rules -> Proof.context -> Proof.context)
   31.41 +    -> string list option -> term list -> theory -> Proof.state;
   31.42 +  val rep_datatype_cmd : string list option -> string list -> theory -> Proof.state
   31.43 +  val add_datatype : datatype_config -> string list -> (string list * binding * mixfix *
   31.44 +    (binding * typ list * mixfix) list) list -> theory -> rules * theory
   31.45 +  val add_datatype_cmd : string list -> (string list * binding * mixfix *
   31.46 +    (binding * string list * mixfix) list) list -> theory -> rules * theory
   31.47 +  val setup: theory -> theory
   31.48 +  val print_datatypes : theory -> unit
   31.49 +end;
   31.50 +
   31.51 +structure Datatype : DATATYPE =
   31.52 +struct
   31.53 +
   31.54 +open DatatypeAux;
   31.55 +
   31.56 +
   31.57 +(* theory data *)
   31.58 +
   31.59 +structure DatatypesData = TheoryDataFun
   31.60 +(
   31.61 +  type T =
   31.62 +    {types: datatype_info Symtab.table,
   31.63 +     constrs: datatype_info Symtab.table,
   31.64 +     cases: datatype_info Symtab.table};
   31.65 +
   31.66 +  val empty =
   31.67 +    {types = Symtab.empty, constrs = Symtab.empty, cases = Symtab.empty};
   31.68 +  val copy = I;
   31.69 +  val extend = I;
   31.70 +  fun merge _
   31.71 +    ({types = types1, constrs = constrs1, cases = cases1},
   31.72 +     {types = types2, constrs = constrs2, cases = cases2}) =
   31.73 +    {types = Symtab.merge (K true) (types1, types2),
   31.74 +     constrs = Symtab.merge (K true) (constrs1, constrs2),
   31.75 +     cases = Symtab.merge (K true) (cases1, cases2)};
   31.76 +);
   31.77 +
   31.78 +val get_datatypes = #types o DatatypesData.get;
   31.79 +val map_datatypes = DatatypesData.map;
   31.80 +
   31.81 +fun print_datatypes thy =
   31.82 +  Pretty.writeln (Pretty.strs ("datatypes:" ::
   31.83 +    map #1 (NameSpace.extern_table (Sign.type_space thy, get_datatypes thy))));
   31.84 +
   31.85 +
   31.86 +(** theory information about datatypes **)
   31.87 +
   31.88 +fun put_dt_infos (dt_infos : (string * datatype_info) list) =
   31.89 +  map_datatypes (fn {types, constrs, cases} =>
   31.90 +    {types = fold Symtab.update dt_infos types,
   31.91 +     constrs = fold Symtab.default (*conservative wrt. overloaded constructors*)
   31.92 +       (maps (fn (_, info as {descr, index, ...}) => map (rpair info o fst)
   31.93 +          (#3 (the (AList.lookup op = descr index)))) dt_infos) constrs,
   31.94 +     cases = fold Symtab.update
   31.95 +       (map (fn (_, info as {case_name, ...}) => (case_name, info)) dt_infos)
   31.96 +       cases});
   31.97 +
   31.98 +val get_datatype = Symtab.lookup o get_datatypes;
   31.99 +
  31.100 +fun the_datatype thy name = (case get_datatype thy name of
  31.101 +      SOME info => info
  31.102 +    | NONE => error ("Unknown datatype " ^ quote name));
  31.103 +
  31.104 +val datatype_of_constr = Symtab.lookup o #constrs o DatatypesData.get;
  31.105 +val datatype_of_case = Symtab.lookup o #cases o DatatypesData.get;
  31.106 +
  31.107 +fun get_datatype_descr thy dtco =
  31.108 +  get_datatype thy dtco
  31.109 +  |> Option.map (fn info as { descr, index, ... } =>
  31.110 +       (info, (((fn SOME (_, dtys, cos) => (dtys, cos)) o AList.lookup (op =) descr) index)));
  31.111 +
  31.112 +fun the_datatype_spec thy dtco =
  31.113 +  let
  31.114 +    val info as { descr, index, sorts = raw_sorts, ... } = the_datatype thy dtco;
  31.115 +    val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr index;
  31.116 +    val sorts = map ((fn v => (v, (the o AList.lookup (op =) raw_sorts) v))
  31.117 +      o DatatypeAux.dest_DtTFree) dtys;
  31.118 +    val cos = map
  31.119 +      (fn (co, tys) => (co, map (DatatypeAux.typ_of_dtyp descr sorts) tys)) raw_cos;
  31.120 +  in (sorts, cos) end;
  31.121 +
  31.122 +fun the_datatype_descr thy (raw_tycos as raw_tyco :: _) =
  31.123 +  let
  31.124 +    val info = the_datatype thy raw_tyco;
  31.125 +    val descr = #descr info;
  31.126 +
  31.127 +    val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr (#index info);
  31.128 +    val vs = map ((fn v => (v, (the o AList.lookup (op =) (#sorts info)) v))
  31.129 +      o dest_DtTFree) dtys;
  31.130 +
  31.131 +    fun is_DtTFree (DtTFree _) = true
  31.132 +      | is_DtTFree _ = false
  31.133 +    val k = find_index (fn (_, (_, dTs, _)) => not (forall is_DtTFree dTs)) descr;
  31.134 +    val protoTs as (dataTs, _) = chop k descr
  31.135 +      |> (pairself o map) (fn (_, (tyco, dTs, _)) => (tyco, map (typ_of_dtyp descr vs) dTs));
  31.136 +    
  31.137 +    val tycos = map fst dataTs;
  31.138 +    val _ = if gen_eq_set (op =) (tycos, raw_tycos) then ()
  31.139 +      else error ("Type constructors " ^ commas (map quote raw_tycos)
  31.140 +        ^ "do not belong exhaustively to one mutual recursive datatype");
  31.141 +
  31.142 +    val (Ts, Us) = (pairself o map) Type protoTs;
  31.143 +
  31.144 +    val names = map Long_Name.base_name (the_default tycos (#alt_names info));
  31.145 +    val (auxnames, _) = Name.make_context names
  31.146 +      |> fold_map (yield_singleton Name.variants o name_of_typ) Us
  31.147 +
  31.148 +  in (descr, vs, tycos, (names, auxnames), (Ts, Us)) end;
  31.149 +
  31.150 +fun get_datatype_constrs thy dtco =
  31.151 +  case try (the_datatype_spec thy) dtco
  31.152 +   of SOME (sorts, cos) =>
  31.153 +        let
  31.154 +          fun subst (v, sort) = TVar ((v, 0), sort);
  31.155 +          fun subst_ty (TFree v) = subst v
  31.156 +            | subst_ty ty = ty;
  31.157 +          val dty = Type (dtco, map subst sorts);
  31.158 +          fun mk_co (co, tys) = (co, map (Term.map_atyps subst_ty) tys ---> dty);
  31.159 +        in SOME (map mk_co cos) end
  31.160 +    | NONE => NONE;
  31.161 +
  31.162 +
  31.163 +(** induct method setup **)
  31.164 +
  31.165 +(* case names *)
  31.166 +
  31.167 +local
  31.168 +
  31.169 +fun dt_recs (DtTFree _) = []
  31.170 +  | dt_recs (DtType (_, dts)) = maps dt_recs dts
  31.171 +  | dt_recs (DtRec i) = [i];
  31.172 +
  31.173 +fun dt_cases (descr: descr) (_, args, constrs) =
  31.174 +  let
  31.175 +    fun the_bname i = Long_Name.base_name (#1 (the (AList.lookup (op =) descr i)));
  31.176 +    val bnames = map the_bname (distinct (op =) (maps dt_recs args));
  31.177 +  in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
  31.178 +
  31.179 +
  31.180 +fun induct_cases descr =
  31.181 +  DatatypeProp.indexify_names (maps (dt_cases descr) (map #2 descr));
  31.182 +
  31.183 +fun exhaust_cases descr i = dt_cases descr (the (AList.lookup (op =) descr i));
  31.184 +
  31.185 +in
  31.186 +
  31.187 +fun mk_case_names_induct descr = RuleCases.case_names (induct_cases descr);
  31.188 +
  31.189 +fun mk_case_names_exhausts descr new =
  31.190 +  map (RuleCases.case_names o exhaust_cases descr o #1)
  31.191 +    (filter (fn ((_, (name, _, _))) => member (op =) new name) descr);
  31.192 +
  31.193 +end;
  31.194 +
  31.195 +fun add_rules simps case_thms rec_thms inject distinct
  31.196 +                  weak_case_congs cong_att =
  31.197 +  PureThy.add_thmss [((Binding.name "simps", simps), []),
  31.198 +    ((Binding.empty, flat case_thms @
  31.199 +          flat distinct @ rec_thms), [Simplifier.simp_add]),
  31.200 +    ((Binding.empty, rec_thms), [Code.add_default_eqn_attribute]),
  31.201 +    ((Binding.empty, flat inject), [iff_add]),
  31.202 +    ((Binding.empty, map (fn th => th RS notE) (flat distinct)), [Classical.safe_elim NONE]),
  31.203 +    ((Binding.empty, weak_case_congs), [cong_att])]
  31.204 +  #> snd;
  31.205 +
  31.206 +
  31.207 +(* add_cases_induct *)
  31.208 +
  31.209 +fun add_cases_induct infos induction thy =
  31.210 +  let
  31.211 +    val inducts = ProjectRule.projections (ProofContext.init thy) induction;
  31.212 +
  31.213 +    fun named_rules (name, {index, exhaustion, ...}: datatype_info) =
  31.214 +      [((Binding.empty, nth inducts index), [Induct.induct_type name]),
  31.215 +       ((Binding.empty, exhaustion), [Induct.cases_type name])];
  31.216 +    fun unnamed_rule i =
  31.217 +      ((Binding.empty, nth inducts i), [Thm.kind_internal, Induct.induct_type ""]);
  31.218 +  in
  31.219 +    thy |> PureThy.add_thms
  31.220 +      (maps named_rules infos @
  31.221 +        map unnamed_rule (length infos upto length inducts - 1)) |> snd
  31.222 +    |> PureThy.add_thmss [((Binding.name "inducts", inducts), [])] |> snd
  31.223 +  end;
  31.224 +
  31.225 +
  31.226 +
  31.227 +(**** simplification procedure for showing distinctness of constructors ****)
  31.228 +
  31.229 +fun stripT (i, Type ("fun", [_, T])) = stripT (i + 1, T)
  31.230 +  | stripT p = p;
  31.231 +
  31.232 +fun stripC (i, f $ x) = stripC (i + 1, f)
  31.233 +  | stripC p = p;
  31.234 +
  31.235 +val distinctN = "constr_distinct";
  31.236 +
  31.237 +fun distinct_rule thy ss tname eq_t = case #distinct (the_datatype thy tname) of
  31.238 +    FewConstrs thms => Goal.prove (Simplifier.the_context ss) [] [] eq_t (K
  31.239 +      (EVERY [rtac eq_reflection 1, rtac iffI 1, rtac notE 1,
  31.240 +        atac 2, resolve_tac thms 1, etac FalseE 1]))
  31.241 +  | ManyConstrs (thm, simpset) =>
  31.242 +      let
  31.243 +        val [In0_inject, In1_inject, In0_not_In1, In1_not_In0] =
  31.244 +          map (PureThy.get_thm (ThyInfo.the_theory "Datatype" thy))
  31.245 +            ["In0_inject", "In1_inject", "In0_not_In1", "In1_not_In0"];
  31.246 +      in
  31.247 +        Goal.prove (Simplifier.the_context ss) [] [] eq_t (K
  31.248 +        (EVERY [rtac eq_reflection 1, rtac iffI 1, dtac thm 1,
  31.249 +          full_simp_tac (Simplifier.inherit_context ss simpset) 1,
  31.250 +          REPEAT (dresolve_tac [In0_inject, In1_inject] 1),
  31.251 +          eresolve_tac [In0_not_In1 RS notE, In1_not_In0 RS notE] 1,
  31.252 +          etac FalseE 1]))
  31.253 +      end;
  31.254 +
  31.255 +fun distinct_proc thy ss (t as Const ("op =", _) $ t1 $ t2) =
  31.256 +  (case (stripC (0, t1), stripC (0, t2)) of
  31.257 +     ((i, Const (cname1, T1)), (j, Const (cname2, T2))) =>
  31.258 +         (case (stripT (0, T1), stripT (0, T2)) of
  31.259 +            ((i', Type (tname1, _)), (j', Type (tname2, _))) =>
  31.260 +                if tname1 = tname2 andalso not (cname1 = cname2) andalso i = i' andalso j = j' then
  31.261 +                   (case (get_datatype_descr thy) tname1 of
  31.262 +                      SOME (_, (_, constrs)) => let val cnames = map fst constrs
  31.263 +                        in if cname1 mem cnames andalso cname2 mem cnames then
  31.264 +                             SOME (distinct_rule thy ss tname1
  31.265 +                               (Logic.mk_equals (t, Const ("False", HOLogic.boolT))))
  31.266 +                           else NONE
  31.267 +                        end
  31.268 +                    | NONE => NONE)
  31.269 +                else NONE
  31.270 +          | _ => NONE)
  31.271 +   | _ => NONE)
  31.272 +  | distinct_proc _ _ _ = NONE;
  31.273 +
  31.274 +val distinct_simproc =
  31.275 +  Simplifier.simproc @{theory HOL} distinctN ["s = t"] distinct_proc;
  31.276 +
  31.277 +val dist_ss = HOL_ss addsimprocs [distinct_simproc];
  31.278 +
  31.279 +val simproc_setup =
  31.280 +  Simplifier.map_simpset (fn ss => ss addsimprocs [distinct_simproc]);
  31.281 +
  31.282 +
  31.283 +(**** translation rules for case ****)
  31.284 +
  31.285 +fun make_case ctxt = DatatypeCase.make_case
  31.286 +  (datatype_of_constr (ProofContext.theory_of ctxt)) ctxt;
  31.287 +
  31.288 +fun strip_case ctxt = DatatypeCase.strip_case
  31.289 +  (datatype_of_case (ProofContext.theory_of ctxt));
  31.290 +
  31.291 +fun add_case_tr' case_names thy =
  31.292 +  Sign.add_advanced_trfuns ([], [],
  31.293 +    map (fn case_name =>
  31.294 +      let val case_name' = Sign.const_syntax_name thy case_name
  31.295 +      in (case_name', DatatypeCase.case_tr' datatype_of_case case_name')
  31.296 +      end) case_names, []) thy;
  31.297 +
  31.298 +val trfun_setup =
  31.299 +  Sign.add_advanced_trfuns ([],
  31.300 +    [("_case_syntax", DatatypeCase.case_tr true datatype_of_constr)],
  31.301 +    [], []);
  31.302 +
  31.303 +
  31.304 +(* prepare types *)
  31.305 +
  31.306 +fun read_typ thy ((Ts, sorts), str) =
  31.307 +  let
  31.308 +    val ctxt = ProofContext.init thy
  31.309 +      |> fold (Variable.declare_typ o TFree) sorts;
  31.310 +    val T = Syntax.read_typ ctxt str;
  31.311 +  in (Ts @ [T], Term.add_tfreesT T sorts) end;
  31.312 +
  31.313 +fun cert_typ sign ((Ts, sorts), raw_T) =
  31.314 +  let
  31.315 +    val T = Type.no_tvars (Sign.certify_typ sign raw_T) handle
  31.316 +      TYPE (msg, _, _) => error msg;
  31.317 +    val sorts' = Term.add_tfreesT T sorts;
  31.318 +  in (Ts @ [T],
  31.319 +      case duplicates (op =) (map fst sorts') of
  31.320 +         [] => sorts'
  31.321 +       | dups => error ("Inconsistent sort constraints for " ^ commas dups))
  31.322 +  end;
  31.323 +
  31.324 +
  31.325 +(**** make datatype info ****)
  31.326 +
  31.327 +fun make_dt_info alt_names descr sorts induct reccomb_names rec_thms
  31.328 +    (((((((((i, (_, (tname, _, _))), case_name), case_thms),
  31.329 +      exhaustion_thm), distinct_thm), inject), nchotomy), case_cong), weak_case_cong) =
  31.330 +  (tname,
  31.331 +   {index = i,
  31.332 +    alt_names = alt_names,
  31.333 +    descr = descr,
  31.334 +    sorts = sorts,
  31.335 +    rec_names = reccomb_names,
  31.336 +    rec_rewrites = rec_thms,
  31.337 +    case_name = case_name,
  31.338 +    case_rewrites = case_thms,
  31.339 +    induction = induct,
  31.340 +    exhaustion = exhaustion_thm,
  31.341 +    distinct = distinct_thm,
  31.342 +    inject = inject,
  31.343 +    nchotomy = nchotomy,
  31.344 +    case_cong = case_cong,
  31.345 +    weak_case_cong = weak_case_cong});
  31.346 +
  31.347 +type rules = {distinct : thm list list,
  31.348 +  inject : thm list list,
  31.349 +  exhaustion : thm list,
  31.350 +  rec_thms : thm list,
  31.351 +  case_thms : thm list list,
  31.352 +  split_thms : (thm * thm) list,
  31.353 +  induction : thm,
  31.354 +  simps : thm list}
  31.355 +
  31.356 +structure DatatypeInterpretation = InterpretationFun
  31.357 +  (type T = datatype_config * string list val eq: T * T -> bool = eq_snd op =);
  31.358 +fun interpretation f = DatatypeInterpretation.interpretation (uncurry f);
  31.359 +
  31.360 +
  31.361 +(******************* definitional introduction of datatypes *******************)
  31.362 +
  31.363 +fun add_datatype_def (config : datatype_config) new_type_names descr sorts types_syntax constr_syntax dt_info
  31.364 +    case_names_induct case_names_exhausts thy =
  31.365 +  let
  31.366 +    val _ = message config ("Proofs for datatype(s) " ^ commas_quote new_type_names);
  31.367 +
  31.368 +    val ((inject, distinct, dist_rewrites, simproc_dists, induct), thy2) = thy |>
  31.369 +      DatatypeRepProofs.representation_proofs config dt_info new_type_names descr sorts
  31.370 +        types_syntax constr_syntax case_names_induct;
  31.371 +
  31.372 +    val (casedist_thms, thy3) = DatatypeAbsProofs.prove_casedist_thms config new_type_names descr
  31.373 +      sorts induct case_names_exhausts thy2;
  31.374 +    val ((reccomb_names, rec_thms), thy4) = DatatypeAbsProofs.prove_primrec_thms
  31.375 +      config new_type_names descr sorts dt_info inject dist_rewrites
  31.376 +      (Simplifier.theory_context thy3 dist_ss) induct thy3;
  31.377 +    val ((case_thms, case_names), thy6) = DatatypeAbsProofs.prove_case_thms
  31.378 +      config new_type_names descr sorts reccomb_names rec_thms thy4;
  31.379 +    val (split_thms, thy7) = DatatypeAbsProofs.prove_split_thms config new_type_names
  31.380 +      descr sorts inject dist_rewrites casedist_thms case_thms thy6;
  31.381 +    val (nchotomys, thy8) = DatatypeAbsProofs.prove_nchotomys config new_type_names
  31.382 +      descr sorts casedist_thms thy7;
  31.383 +    val (case_congs, thy9) = DatatypeAbsProofs.prove_case_congs new_type_names
  31.384 +      descr sorts nchotomys case_thms thy8;
  31.385 +    val (weak_case_congs, thy10) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
  31.386 +      descr sorts thy9;
  31.387 +
  31.388 +    val dt_infos = map
  31.389 +      (make_dt_info (SOME new_type_names) (flat descr) sorts induct reccomb_names rec_thms)
  31.390 +      ((0 upto length (hd descr) - 1) ~~ (hd descr) ~~ case_names ~~ case_thms ~~
  31.391 +        casedist_thms ~~ simproc_dists ~~ inject ~~ nchotomys ~~ case_congs ~~ weak_case_congs);
  31.392 +
  31.393 +    val simps = flat (distinct @ inject @ case_thms) @ rec_thms;
  31.394 +
  31.395 +    val thy12 =
  31.396 +      thy10
  31.397 +      |> add_case_tr' case_names
  31.398 +      |> Sign.add_path (space_implode "_" new_type_names)
  31.399 +      |> add_rules simps case_thms rec_thms inject distinct
  31.400 +          weak_case_congs (Simplifier.attrib (op addcongs))
  31.401 +      |> put_dt_infos dt_infos
  31.402 +      |> add_cases_induct dt_infos induct
  31.403 +      |> Sign.parent_path
  31.404 +      |> store_thmss "splits" new_type_names (map (fn (x, y) => [x, y]) split_thms) |> snd
  31.405 +      |> DatatypeInterpretation.data (config, map fst dt_infos);
  31.406 +  in
  31.407 +    ({distinct = distinct,
  31.408 +      inject = inject,
  31.409 +      exhaustion = casedist_thms,
  31.410 +      rec_thms = rec_thms,
  31.411 +      case_thms = case_thms,
  31.412 +      split_thms = split_thms,
  31.413 +      induction = induct,
  31.414 +      simps = simps}, thy12)
  31.415 +  end;
  31.416 +
  31.417 +
  31.418 +(*********************** declare existing type as datatype *********************)
  31.419 +
  31.420 +fun prove_rep_datatype (config : datatype_config) alt_names new_type_names descr sorts induct inject half_distinct thy =
  31.421 +  let
  31.422 +    val ((_, [induct']), _) =
  31.423 +      Variable.importT_thms [induct] (Variable.thm_context induct);
  31.424 +
  31.425 +    fun err t = error ("Ill-formed predicate in induction rule: " ^
  31.426 +      Syntax.string_of_term_global thy t);
  31.427 +
  31.428 +    fun get_typ (t as _ $ Var (_, Type (tname, Ts))) =
  31.429 +          ((tname, map (fst o dest_TFree) Ts) handle TERM _ => err t)
  31.430 +      | get_typ t = err t;
  31.431 +    val dtnames = map get_typ (HOLogic.dest_conj (HOLogic.dest_Trueprop (Thm.concl_of induct')));
  31.432 +
  31.433 +    val dt_info = get_datatypes thy;
  31.434 +
  31.435 +    val distinct = (map o maps) (fn thm => [thm, thm RS not_sym]) half_distinct;
  31.436 +    val (case_names_induct, case_names_exhausts) =
  31.437 +      (mk_case_names_induct descr, mk_case_names_exhausts descr (map #1 dtnames));
  31.438 +
  31.439 +    val _ = message config ("Proofs for datatype(s) " ^ commas_quote new_type_names);
  31.440 +
  31.441 +    val (casedist_thms, thy2) = thy |>
  31.442 +      DatatypeAbsProofs.prove_casedist_thms config new_type_names [descr] sorts induct
  31.443 +        case_names_exhausts;
  31.444 +    val ((reccomb_names, rec_thms), thy3) = DatatypeAbsProofs.prove_primrec_thms
  31.445 +      config new_type_names [descr] sorts dt_info inject distinct
  31.446 +      (Simplifier.theory_context thy2 dist_ss) induct thy2;
  31.447 +    val ((case_thms, case_names), thy4) = DatatypeAbsProofs.prove_case_thms
  31.448 +      config new_type_names [descr] sorts reccomb_names rec_thms thy3;
  31.449 +    val (split_thms, thy5) = DatatypeAbsProofs.prove_split_thms
  31.450 +      config new_type_names [descr] sorts inject distinct casedist_thms case_thms thy4;
  31.451 +    val (nchotomys, thy6) = DatatypeAbsProofs.prove_nchotomys config new_type_names
  31.452 +      [descr] sorts casedist_thms thy5;
  31.453 +    val (case_congs, thy7) = DatatypeAbsProofs.prove_case_congs new_type_names
  31.454 +      [descr] sorts nchotomys case_thms thy6;
  31.455 +    val (weak_case_congs, thy8) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
  31.456 +      [descr] sorts thy7;
  31.457 +
  31.458 +    val ((_, [induct']), thy10) =
  31.459 +      thy8
  31.460 +      |> store_thmss "inject" new_type_names inject
  31.461 +      ||>> store_thmss "distinct" new_type_names distinct
  31.462 +      ||> Sign.add_path (space_implode "_" new_type_names)
  31.463 +      ||>> PureThy.add_thms [((Binding.name "induct", induct), [case_names_induct])];
  31.464 +
  31.465 +    val dt_infos = map (make_dt_info alt_names descr sorts induct' reccomb_names rec_thms)
  31.466 +      ((0 upto length descr - 1) ~~ descr ~~ case_names ~~ case_thms ~~ casedist_thms ~~
  31.467 +        map FewConstrs distinct ~~ inject ~~ nchotomys ~~ case_congs ~~ weak_case_congs);
  31.468 +
  31.469 +    val simps = flat (distinct @ inject @ case_thms) @ rec_thms;
  31.470 +
  31.471 +    val thy11 =
  31.472 +      thy10
  31.473 +      |> add_case_tr' case_names
  31.474 +      |> add_rules simps case_thms rec_thms inject distinct
  31.475 +           weak_case_congs (Simplifier.attrib (op addcongs))
  31.476 +      |> put_dt_infos dt_infos
  31.477 +      |> add_cases_induct dt_infos induct'
  31.478 +      |> Sign.parent_path
  31.479 +      |> store_thmss "splits" new_type_names (map (fn (x, y) => [x, y]) split_thms)
  31.480 +      |> snd
  31.481 +      |> DatatypeInterpretation.data (config, map fst dt_infos);
  31.482 +  in
  31.483 +    ({distinct = distinct,
  31.484 +      inject = inject,
  31.485 +      exhaustion = casedist_thms,
  31.486 +      rec_thms = rec_thms,
  31.487 +      case_thms = case_thms,
  31.488 +      split_thms = split_thms,
  31.489 +      induction = induct',
  31.490 +      simps = simps}, thy11)
  31.491 +  end;
  31.492 +
  31.493 +fun gen_rep_datatype prep_term (config : datatype_config) after_qed alt_names raw_ts thy =
  31.494 +  let
  31.495 +    fun constr_of_term (Const (c, T)) = (c, T)
  31.496 +      | constr_of_term t =
  31.497 +          error ("Not a constant: " ^ Syntax.string_of_term_global thy t);
  31.498 +    fun no_constr (c, T) = error ("Bad constructor: "
  31.499 +      ^ Sign.extern_const thy c ^ "::"
  31.500 +      ^ Syntax.string_of_typ_global thy T);
  31.501 +    fun type_of_constr (cT as (_, T)) =
  31.502 +      let
  31.503 +        val frees = OldTerm.typ_tfrees T;
  31.504 +        val (tyco, vs) = ((apsnd o map) (dest_TFree) o dest_Type o snd o strip_type) T
  31.505 +          handle TYPE _ => no_constr cT
  31.506 +        val _ = if has_duplicates (eq_fst (op =)) vs then no_constr cT else ();
  31.507 +        val _ = if length frees <> length vs then no_constr cT else ();
  31.508 +      in (tyco, (vs, cT)) end;
  31.509 +
  31.510 +    val raw_cs = AList.group (op =) (map (type_of_constr o constr_of_term o prep_term thy) raw_ts);
  31.511 +    val _ = case map_filter (fn (tyco, _) =>
  31.512 +        if Symtab.defined (get_datatypes thy) tyco then SOME tyco else NONE) raw_cs
  31.513 +     of [] => ()
  31.514 +      | tycos => error ("Type(s) " ^ commas (map quote tycos)
  31.515 +          ^ " already represented inductivly");
  31.516 +    val raw_vss = maps (map (map snd o fst) o snd) raw_cs;
  31.517 +    val ms = case distinct (op =) (map length raw_vss)
  31.518 +     of [n] => 0 upto n - 1
  31.519 +      | _ => error ("Different types in given constructors");
  31.520 +    fun inter_sort m = map (fn xs => nth xs m) raw_vss
  31.521 +      |> Library.foldr1 (Sorts.inter_sort (Sign.classes_of thy))
  31.522 +    val sorts = map inter_sort ms;
  31.523 +    val vs = Name.names Name.context Name.aT sorts;
  31.524 +
  31.525 +    fun norm_constr (raw_vs, (c, T)) = (c, map_atyps
  31.526 +      (TFree o (the o AList.lookup (op =) (map fst raw_vs ~~ vs)) o fst o dest_TFree) T);
  31.527 +
  31.528 +    val cs = map (apsnd (map norm_constr)) raw_cs;
  31.529 +    val dtyps_of_typ = map (dtyp_of_typ (map (rpair (map fst vs) o fst) cs))
  31.530 +      o fst o strip_type;
  31.531 +    val new_type_names = map Long_Name.base_name (the_default (map fst cs) alt_names);
  31.532 +
  31.533 +    fun mk_spec (i, (tyco, constr)) = (i, (tyco,
  31.534 +      map (DtTFree o fst) vs,
  31.535 +      (map o apsnd) dtyps_of_typ constr))
  31.536 +    val descr = map_index mk_spec cs;
  31.537 +    val injs = DatatypeProp.make_injs [descr] vs;
  31.538 +    val half_distincts = map snd (DatatypeProp.make_distincts [descr] vs);
  31.539 +    val ind = DatatypeProp.make_ind [descr] vs;
  31.540 +    val rules = (map o map o map) Logic.close_form [[[ind]], injs, half_distincts];
  31.541 +
  31.542 +    fun after_qed' raw_thms =
  31.543 +      let
  31.544 +        val [[[induct]], injs, half_distincts] =
  31.545 +          unflat rules (map Drule.zero_var_indexes_list raw_thms);
  31.546 +            (*FIXME somehow dubious*)
  31.547 +      in
  31.548 +        ProofContext.theory_result
  31.549 +          (prove_rep_datatype config alt_names new_type_names descr vs induct injs half_distincts)
  31.550 +        #-> after_qed
  31.551 +      end;
  31.552 +  in
  31.553 +    thy
  31.554 +    |> ProofContext.init
  31.555 +    |> Proof.theorem_i NONE after_qed' ((map o map) (rpair []) (flat rules))
  31.556 +  end;
  31.557 +
  31.558 +val rep_datatype = gen_rep_datatype Sign.cert_term;
  31.559 +val rep_datatype_cmd = gen_rep_datatype Syntax.read_term_global default_datatype_config (K I);
  31.560 +
  31.561 +
  31.562 +
  31.563 +(******************************** add datatype ********************************)
  31.564 +
  31.565 +fun gen_add_datatype prep_typ (config : datatype_config) new_type_names dts thy =
  31.566 +  let
  31.567 +    val _ = Theory.requires thy "Datatype" "datatype definitions";
  31.568 +
  31.569 +    (* this theory is used just for parsing *)
  31.570 +
  31.571 +    val tmp_thy = thy |>
  31.572 +      Theory.copy |>
  31.573 +      Sign.add_types (map (fn (tvs, tname, mx, _) =>
  31.574 +        (tname, length tvs, mx)) dts);
  31.575 +
  31.576 +    val (tyvars, _, _, _)::_ = dts;
  31.577 +    val (new_dts, types_syntax) = ListPair.unzip (map (fn (tvs, tname, mx, _) =>
  31.578 +      let val full_tname = Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname)
  31.579 +      in (case duplicates (op =) tvs of
  31.580 +            [] => if eq_set (tyvars, tvs) then ((full_tname, tvs), (tname, mx))
  31.581 +                  else error ("Mutually recursive datatypes must have same type parameters")
  31.582 +          | dups => error ("Duplicate parameter(s) for datatype " ^ quote (Binding.str_of tname) ^
  31.583 +              " : " ^ commas dups))
  31.584 +      end) dts);
  31.585 +
  31.586 +    val _ = (case duplicates (op =) (map fst new_dts) @ duplicates (op =) new_type_names of
  31.587 +      [] => () | dups => error ("Duplicate datatypes: " ^ commas dups));
  31.588 +
  31.589 +    fun prep_dt_spec ((tvs, tname, mx, constrs), tname') (dts', constr_syntax, sorts, i) =
  31.590 +      let
  31.591 +        fun prep_constr (cname, cargs, mx') (constrs, constr_syntax', sorts') =
  31.592 +          let
  31.593 +            val (cargs', sorts'') = Library.foldl (prep_typ tmp_thy) (([], sorts'), cargs);
  31.594 +            val _ = (case fold (curry OldTerm.add_typ_tfree_names) cargs' [] \\ tvs of
  31.595 +                [] => ()
  31.596 +              | vs => error ("Extra type variables on rhs: " ^ commas vs))
  31.597 +          in (constrs @ [((if #flat_names config then Sign.full_name tmp_thy else
  31.598 +                Sign.full_name_path tmp_thy tname')
  31.599 +                  (Binding.map_name (Syntax.const_name mx') cname),
  31.600 +                   map (dtyp_of_typ new_dts) cargs')],
  31.601 +              constr_syntax' @ [(cname, mx')], sorts'')
  31.602 +          end handle ERROR msg => cat_error msg
  31.603 +           ("The error above occured in constructor " ^ quote (Binding.str_of cname) ^
  31.604 +            " of datatype " ^ quote (Binding.str_of tname));
  31.605 +
  31.606 +        val (constrs', constr_syntax', sorts') =
  31.607 +          fold prep_constr constrs ([], [], sorts)
  31.608 +
  31.609 +      in
  31.610 +        case duplicates (op =) (map fst constrs') of
  31.611 +           [] =>
  31.612 +             (dts' @ [(i, (Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname),
  31.613 +                map DtTFree tvs, constrs'))],
  31.614 +              constr_syntax @ [constr_syntax'], sorts', i + 1)
  31.615 +         | dups => error ("Duplicate constructors " ^ commas dups ^
  31.616 +             " in datatype " ^ quote (Binding.str_of tname))
  31.617 +      end;
  31.618 +
  31.619 +    val (dts', constr_syntax, sorts', i) =
  31.620 +      fold prep_dt_spec (dts ~~ new_type_names) ([], [], [], 0);
  31.621 +    val sorts = sorts' @ (map (rpair (Sign.defaultS tmp_thy)) (tyvars \\ map fst sorts'));
  31.622 +    val dt_info = get_datatypes thy;
  31.623 +    val (descr, _) = unfold_datatypes tmp_thy dts' sorts dt_info dts' i;
  31.624 +    val _ = check_nonempty descr handle (exn as Datatype_Empty s) =>
  31.625 +      if #strict config then error ("Nonemptiness check failed for datatype " ^ s)
  31.626 +      else raise exn;
  31.627 +
  31.628 +    val descr' = flat descr;
  31.629 +    val case_names_induct = mk_case_names_induct descr';
  31.630 +    val case_names_exhausts = mk_case_names_exhausts descr' (map #1 new_dts);
  31.631 +  in
  31.632 +    add_datatype_def
  31.633 +      (config : datatype_config) new_type_names descr sorts types_syntax constr_syntax dt_info
  31.634 +      case_names_induct case_names_exhausts thy
  31.635 +  end;
  31.636 +
  31.637 +val add_datatype = gen_add_datatype cert_typ;
  31.638 +val add_datatype_cmd = gen_add_datatype read_typ default_datatype_config;
  31.639 +
  31.640 +
  31.641 +
  31.642 +(** package setup **)
  31.643 +
  31.644 +(* setup theory *)
  31.645 +
  31.646 +val setup =
  31.647 +  DatatypeRepProofs.distinctness_limit_setup #>
  31.648 +  simproc_setup #>
  31.649 +  trfun_setup #>
  31.650 +  DatatypeInterpretation.init;
  31.651 +
  31.652 +
  31.653 +(* outer syntax *)
  31.654 +
  31.655 +local structure P = OuterParse and K = OuterKeyword in
  31.656 +
  31.657 +val datatype_decl =
  31.658 +  Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.type_args -- P.binding -- P.opt_infix --
  31.659 +    (P.$$$ "=" |-- P.enum1 "|" (P.binding -- Scan.repeat P.typ -- P.opt_mixfix));
  31.660 +
  31.661 +fun mk_datatype args =
  31.662 +  let
  31.663 +    val names = map
  31.664 +      (fn ((((NONE, _), t), _), _) => Binding.name_of t | ((((SOME t, _), _), _), _) => t) args;
  31.665 +    val specs = map (fn ((((_, vs), t), mx), cons) =>
  31.666 +      (vs, t, mx, map (fn ((x, y), z) => (x, y, z)) cons)) args;
  31.667 +  in snd o add_datatype_cmd names specs end;
  31.668 +
  31.669 +val _ =
  31.670 +  OuterSyntax.command "datatype" "define inductive datatypes" K.thy_decl
  31.671 +    (P.and_list1 datatype_decl >> (Toplevel.theory o mk_datatype));
  31.672 +
  31.673 +val _ =
  31.674 +  OuterSyntax.command "rep_datatype" "represent existing types inductively" K.thy_goal
  31.675 +    (Scan.option (P.$$$ "(" |-- Scan.repeat1 P.name --| P.$$$ ")") -- Scan.repeat1 P.term
  31.676 +      >> (fn (alt_names, ts) => Toplevel.print
  31.677 +           o Toplevel.theory_to_proof (rep_datatype_cmd alt_names ts)));
  31.678 +
  31.679 +end;
  31.680 +
  31.681 +
  31.682 +(* document antiquotation *)
  31.683 +
  31.684 +val _ = ThyOutput.antiquotation "datatype" Args.tyname
  31.685 +  (fn {source = src, context = ctxt, ...} => fn dtco =>
  31.686 +    let
  31.687 +      val thy = ProofContext.theory_of ctxt;
  31.688 +      val (vs, cos) = the_datatype_spec thy dtco;
  31.689 +      val ty = Type (dtco, map TFree vs);
  31.690 +      fun pretty_typ_bracket (ty as Type (_, _ :: _)) =
  31.691 +            Pretty.enclose "(" ")" [Syntax.pretty_typ ctxt ty]
  31.692 +        | pretty_typ_bracket ty =
  31.693 +            Syntax.pretty_typ ctxt ty;
  31.694 +      fun pretty_constr (co, tys) =
  31.695 +        (Pretty.block o Pretty.breaks)
  31.696 +          (Syntax.pretty_term ctxt (Const (co, tys ---> ty)) ::
  31.697 +            map pretty_typ_bracket tys);
  31.698 +      val pretty_datatype =
  31.699 +        Pretty.block
  31.700 +          (Pretty.command "datatype" :: Pretty.brk 1 ::
  31.701 +           Syntax.pretty_typ ctxt ty ::
  31.702 +           Pretty.str " =" :: Pretty.brk 1 ::
  31.703 +           flat (separate [Pretty.brk 1, Pretty.str "| "]
  31.704 +             (map (single o pretty_constr) cos)));
  31.705 +    in ThyOutput.output (ThyOutput.maybe_pretty_source (K pretty_datatype) src [()]) end);
  31.706 +
  31.707 +end;
  31.708 +
    32.1 --- a/src/HOL/Tools/datatype_package/datatype_abs_proofs.ML	Thu Jun 18 18:31:14 2009 -0700
    32.2 +++ b/src/HOL/Tools/datatype_package/datatype_abs_proofs.ML	Fri Jun 19 17:23:21 2009 +0200
    32.3 @@ -155,7 +155,7 @@
    32.4          (([], 0), descr' ~~ recTs ~~ rec_sets');
    32.5  
    32.6      val ({intrs = rec_intrs, elims = rec_elims, ...}, thy1) =
    32.7 -        InductivePackage.add_inductive_global (serial_string ())
    32.8 +        Inductive.add_inductive_global (serial_string ())
    32.9            {quiet_mode = #quiet config, verbose = false, kind = Thm.internalK,
   32.10              alt_name = Binding.name big_rec_name', coind = false, no_elim = false, no_ind = true,
   32.11              skip_mono = true, fork_mono = false}
    33.1 --- a/src/HOL/Tools/datatype_package/datatype_codegen.ML	Thu Jun 18 18:31:14 2009 -0700
    33.2 +++ b/src/HOL/Tools/datatype_package/datatype_codegen.ML	Fri Jun 19 17:23:21 2009 +0200
    33.3 @@ -276,12 +276,12 @@
    33.4  
    33.5  fun datatype_codegen thy defs dep module brack t gr = (case strip_comb t of
    33.6     (c as Const (s, T), ts) =>
    33.7 -     (case DatatypePackage.datatype_of_case thy s of
    33.8 +     (case Datatype.datatype_of_case thy s of
    33.9          SOME {index, descr, ...} =>
   33.10            if is_some (get_assoc_code thy (s, T)) then NONE else
   33.11            SOME (pretty_case thy defs dep module brack
   33.12              (#3 (the (AList.lookup op = descr index))) c ts gr )
   33.13 -      | NONE => case (DatatypePackage.datatype_of_constr thy s, strip_type T) of
   33.14 +      | NONE => case (Datatype.datatype_of_constr thy s, strip_type T) of
   33.15          (SOME {index, descr, ...}, (_, U as Type (tyname, _))) =>
   33.16            if is_some (get_assoc_code thy (s, T)) then NONE else
   33.17            let
   33.18 @@ -296,7 +296,7 @@
   33.19   | _ => NONE);
   33.20  
   33.21  fun datatype_tycodegen thy defs dep module brack (Type (s, Ts)) gr =
   33.22 -      (case DatatypePackage.get_datatype thy s of
   33.23 +      (case Datatype.get_datatype thy s of
   33.24           NONE => NONE
   33.25         | SOME {descr, sorts, ...} =>
   33.26             if is_some (get_assoc_type thy s) then NONE else
   33.27 @@ -331,7 +331,7 @@
   33.28  fun mk_case_cert thy tyco =
   33.29    let
   33.30      val raw_thms =
   33.31 -      (#case_rewrites o DatatypePackage.the_datatype thy) tyco;
   33.32 +      (#case_rewrites o Datatype.the_datatype thy) tyco;
   33.33      val thms as hd_thm :: _ = raw_thms
   33.34        |> Conjunction.intr_balanced
   33.35        |> Thm.unvarify
   33.36 @@ -364,8 +364,8 @@
   33.37  
   33.38  fun mk_eq_eqns thy dtco =
   33.39    let
   33.40 -    val (vs, cos) = DatatypePackage.the_datatype_spec thy dtco;
   33.41 -    val { descr, index, inject = inject_thms, ... } = DatatypePackage.the_datatype thy dtco;
   33.42 +    val (vs, cos) = Datatype.the_datatype_spec thy dtco;
   33.43 +    val { descr, index, inject = inject_thms, ... } = Datatype.the_datatype thy dtco;
   33.44      val ty = Type (dtco, map TFree vs);
   33.45      fun mk_eq (t1, t2) = Const (@{const_name eq_class.eq}, ty --> ty --> HOLogic.boolT)
   33.46        $ t1 $ t2;
   33.47 @@ -383,7 +383,7 @@
   33.48      val refl = HOLogic.mk_Trueprop (true_eq (Free ("x", ty), Free ("x", ty)));
   33.49      val simpset = Simplifier.context (ProofContext.init thy) (HOL_basic_ss
   33.50        addsimps (map Simpdata.mk_eq (@{thm eq} :: @{thm eq_True} :: inject_thms))
   33.51 -      addsimprocs [DatatypePackage.distinct_simproc]);
   33.52 +      addsimprocs [Datatype.distinct_simproc]);
   33.53      fun prove prop = SkipProof.prove_global thy [] [] prop (K (ALLGOALS (simp_tac simpset)))
   33.54        |> Simpdata.mk_eq;
   33.55    in map (rpair true o prove) (triv_injects @ injects @ distincts) @ [(prove refl, false)] end;
   33.56 @@ -428,11 +428,11 @@
   33.57  
   33.58  fun add_all_code config dtcos thy =
   33.59    let
   33.60 -    val (vs :: _, coss) = (split_list o map (DatatypePackage.the_datatype_spec thy)) dtcos;
   33.61 +    val (vs :: _, coss) = (split_list o map (Datatype.the_datatype_spec thy)) dtcos;
   33.62      val any_css = map2 (mk_constr_consts thy vs) dtcos coss;
   33.63      val css = if exists is_none any_css then []
   33.64        else map_filter I any_css;
   33.65 -    val case_rewrites = maps (#case_rewrites o DatatypePackage.the_datatype thy) dtcos;
   33.66 +    val case_rewrites = maps (#case_rewrites o Datatype.the_datatype thy) dtcos;
   33.67      val certs = map (mk_case_cert thy) dtcos;
   33.68    in
   33.69      if null css then thy
   33.70 @@ -450,6 +450,6 @@
   33.71  val setup = 
   33.72    add_codegen "datatype" datatype_codegen
   33.73    #> add_tycodegen "datatype" datatype_tycodegen
   33.74 -  #> DatatypePackage.interpretation add_all_code
   33.75 +  #> Datatype.interpretation add_all_code
   33.76  
   33.77  end;
    34.1 --- a/src/HOL/Tools/datatype_package/datatype_package.ML	Thu Jun 18 18:31:14 2009 -0700
    34.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    34.3 @@ -1,705 +0,0 @@
    34.4 -(*  Title:      HOL/Tools/datatype_package.ML
    34.5 -    Author:     Stefan Berghofer, TU Muenchen
    34.6 -
    34.7 -Datatype package for Isabelle/HOL.
    34.8 -*)
    34.9 -
   34.10 -signature DATATYPE_PACKAGE =
   34.11 -sig
   34.12 -  type datatype_config = DatatypeAux.datatype_config
   34.13 -  type datatype_info = DatatypeAux.datatype_info
   34.14 -  type descr = DatatypeAux.descr
   34.15 -  val get_datatypes : theory -> datatype_info Symtab.table
   34.16 -  val get_datatype : theory -> string -> datatype_info option
   34.17 -  val the_datatype : theory -> string -> datatype_info
   34.18 -  val datatype_of_constr : theory -> string -> datatype_info option
   34.19 -  val datatype_of_case : theory -> string -> datatype_info option
   34.20 -  val the_datatype_spec : theory -> string -> (string * sort) list * (string * typ list) list
   34.21 -  val the_datatype_descr : theory -> string list
   34.22 -    -> descr * (string * sort) list * string list
   34.23 -      * (string list * string list) * (typ list * typ list)
   34.24 -  val get_datatype_constrs : theory -> string -> (string * typ) list option
   34.25 -  val distinct_simproc : simproc
   34.26 -  val make_case :  Proof.context -> bool -> string list -> term ->
   34.27 -    (term * term) list -> term * (term * (int * bool)) list
   34.28 -  val strip_case : Proof.context -> bool -> term -> (term * (term * term) list) option
   34.29 -  val read_typ: theory ->
   34.30 -    (typ list * (string * sort) list) * string -> typ list * (string * sort) list
   34.31 -  val interpretation : (datatype_config -> string list -> theory -> theory) -> theory -> theory
   34.32 -  type rules = {distinct : thm list list,
   34.33 -    inject : thm list list,
   34.34 -    exhaustion : thm list,
   34.35 -    rec_thms : thm list,
   34.36 -    case_thms : thm list list,
   34.37 -    split_thms : (thm * thm) list,
   34.38 -    induction : thm,
   34.39 -    simps : thm list}
   34.40 -  val rep_datatype : datatype_config -> (rules -> Proof.context -> Proof.context)
   34.41 -    -> string list option -> term list -> theory -> Proof.state;
   34.42 -  val rep_datatype_cmd : string list option -> string list -> theory -> Proof.state
   34.43 -  val add_datatype : datatype_config -> string list -> (string list * binding * mixfix *
   34.44 -    (binding * typ list * mixfix) list) list -> theory -> rules * theory
   34.45 -  val add_datatype_cmd : string list -> (string list * binding * mixfix *
   34.46 -    (binding * string list * mixfix) list) list -> theory -> rules * theory
   34.47 -  val setup: theory -> theory
   34.48 -  val print_datatypes : theory -> unit
   34.49 -end;
   34.50 -
   34.51 -structure DatatypePackage : DATATYPE_PACKAGE =
   34.52 -struct
   34.53 -
   34.54 -open DatatypeAux;
   34.55 -
   34.56 -
   34.57 -(* theory data *)
   34.58 -
   34.59 -structure DatatypesData = TheoryDataFun
   34.60 -(
   34.61 -  type T =
   34.62 -    {types: datatype_info Symtab.table,
   34.63 -     constrs: datatype_info Symtab.table,
   34.64 -     cases: datatype_info Symtab.table};
   34.65 -
   34.66 -  val empty =
   34.67 -    {types = Symtab.empty, constrs = Symtab.empty, cases = Symtab.empty};
   34.68 -  val copy = I;
   34.69 -  val extend = I;
   34.70 -  fun merge _
   34.71 -    ({types = types1, constrs = constrs1, cases = cases1},
   34.72 -     {types = types2, constrs = constrs2, cases = cases2}) =
   34.73 -    {types = Symtab.merge (K true) (types1, types2),
   34.74 -     constrs = Symtab.merge (K true) (constrs1, constrs2),
   34.75 -     cases = Symtab.merge (K true) (cases1, cases2)};
   34.76 -);
   34.77 -
   34.78 -val get_datatypes = #types o DatatypesData.get;
   34.79 -val map_datatypes = DatatypesData.map;
   34.80 -
   34.81 -fun print_datatypes thy =
   34.82 -  Pretty.writeln (Pretty.strs ("datatypes:" ::
   34.83 -    map #1 (NameSpace.extern_table (Sign.type_space thy, get_datatypes thy))));
   34.84 -
   34.85 -
   34.86 -(** theory information about datatypes **)
   34.87 -
   34.88 -fun put_dt_infos (dt_infos : (string * datatype_info) list) =
   34.89 -  map_datatypes (fn {types, constrs, cases} =>
   34.90 -    {types = fold Symtab.update dt_infos types,
   34.91 -     constrs = fold Symtab.default (*conservative wrt. overloaded constructors*)
   34.92 -       (maps (fn (_, info as {descr, index, ...}) => map (rpair info o fst)
   34.93 -          (#3 (the (AList.lookup op = descr index)))) dt_infos) constrs,
   34.94 -     cases = fold Symtab.update
   34.95 -       (map (fn (_, info as {case_name, ...}) => (case_name, info)) dt_infos)
   34.96 -       cases});
   34.97 -
   34.98 -val get_datatype = Symtab.lookup o get_datatypes;
   34.99 -
  34.100 -fun the_datatype thy name = (case get_datatype thy name of
  34.101 -      SOME info => info
  34.102 -    | NONE => error ("Unknown datatype " ^ quote name));
  34.103 -
  34.104 -val datatype_of_constr = Symtab.lookup o #constrs o DatatypesData.get;
  34.105 -val datatype_of_case = Symtab.lookup o #cases o DatatypesData.get;
  34.106 -
  34.107 -fun get_datatype_descr thy dtco =
  34.108 -  get_datatype thy dtco
  34.109 -  |> Option.map (fn info as { descr, index, ... } =>
  34.110 -       (info, (((fn SOME (_, dtys, cos) => (dtys, cos)) o AList.lookup (op =) descr) index)));
  34.111 -
  34.112 -fun the_datatype_spec thy dtco =
  34.113 -  let
  34.114 -    val info as { descr, index, sorts = raw_sorts, ... } = the_datatype thy dtco;
  34.115 -    val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr index;
  34.116 -    val sorts = map ((fn v => (v, (the o AList.lookup (op =) raw_sorts) v))
  34.117 -      o DatatypeAux.dest_DtTFree) dtys;
  34.118 -    val cos = map
  34.119 -      (fn (co, tys) => (co, map (DatatypeAux.typ_of_dtyp descr sorts) tys)) raw_cos;
  34.120 -  in (sorts, cos) end;
  34.121 -
  34.122 -fun the_datatype_descr thy (raw_tycos as raw_tyco :: _) =
  34.123 -  let
  34.124 -    val info = the_datatype thy raw_tyco;
  34.125 -    val descr = #descr info;
  34.126 -
  34.127 -    val SOME (_, dtys, raw_cos) = AList.lookup (op =) descr (#index info);
  34.128 -    val vs = map ((fn v => (v, (the o AList.lookup (op =) (#sorts info)) v))
  34.129 -      o dest_DtTFree) dtys;
  34.130 -
  34.131 -    fun is_DtTFree (DtTFree _) = true
  34.132 -      | is_DtTFree _ = false
  34.133 -    val k = find_index (fn (_, (_, dTs, _)) => not (forall is_DtTFree dTs)) descr;
  34.134 -    val protoTs as (dataTs, _) = chop k descr
  34.135 -      |> (pairself o map) (fn (_, (tyco, dTs, _)) => (tyco, map (typ_of_dtyp descr vs) dTs));
  34.136 -    
  34.137 -    val tycos = map fst dataTs;
  34.138 -    val _ = if gen_eq_set (op =) (tycos, raw_tycos) then ()
  34.139 -      else error ("Type constructors " ^ commas (map quote raw_tycos)
  34.140 -        ^ "do not belong exhaustively to one mutual recursive datatype");
  34.141 -
  34.142 -    val (Ts, Us) = (pairself o map) Type protoTs;
  34.143 -
  34.144 -    val names = map Long_Name.base_name (the_default tycos (#alt_names info));
  34.145 -    val (auxnames, _) = Name.make_context names
  34.146 -      |> fold_map (yield_singleton Name.variants o name_of_typ) Us
  34.147 -
  34.148 -  in (descr, vs, tycos, (names, auxnames), (Ts, Us)) end;
  34.149 -
  34.150 -fun get_datatype_constrs thy dtco =
  34.151 -  case try (the_datatype_spec thy) dtco
  34.152 -   of SOME (sorts, cos) =>
  34.153 -        let
  34.154 -          fun subst (v, sort) = TVar ((v, 0), sort);
  34.155 -          fun subst_ty (TFree v) = subst v
  34.156 -            | subst_ty ty = ty;
  34.157 -          val dty = Type (dtco, map subst sorts);
  34.158 -          fun mk_co (co, tys) = (co, map (Term.map_atyps subst_ty) tys ---> dty);
  34.159 -        in SOME (map mk_co cos) end
  34.160 -    | NONE => NONE;
  34.161 -
  34.162 -
  34.163 -(** induct method setup **)
  34.164 -
  34.165 -(* case names *)
  34.166 -
  34.167 -local
  34.168 -
  34.169 -fun dt_recs (DtTFree _) = []
  34.170 -  | dt_recs (DtType (_, dts)) = maps dt_recs dts
  34.171 -  | dt_recs (DtRec i) = [i];
  34.172 -
  34.173 -fun dt_cases (descr: descr) (_, args, constrs) =
  34.174 -  let
  34.175 -    fun the_bname i = Long_Name.base_name (#1 (the (AList.lookup (op =) descr i)));
  34.176 -    val bnames = map the_bname (distinct (op =) (maps dt_recs args));
  34.177 -  in map (fn (c, _) => space_implode "_" (Long_Name.base_name c :: bnames)) constrs end;
  34.178 -
  34.179 -
  34.180 -fun induct_cases descr =
  34.181 -  DatatypeProp.indexify_names (maps (dt_cases descr) (map #2 descr));
  34.182 -
  34.183 -fun exhaust_cases descr i = dt_cases descr (the (AList.lookup (op =) descr i));
  34.184 -
  34.185 -in
  34.186 -
  34.187 -fun mk_case_names_induct descr = RuleCases.case_names (induct_cases descr);
  34.188 -
  34.189 -fun mk_case_names_exhausts descr new =
  34.190 -  map (RuleCases.case_names o exhaust_cases descr o #1)
  34.191 -    (filter (fn ((_, (name, _, _))) => member (op =) new name) descr);
  34.192 -
  34.193 -end;
  34.194 -
  34.195 -fun add_rules simps case_thms rec_thms inject distinct
  34.196 -                  weak_case_congs cong_att =
  34.197 -  PureThy.add_thmss [((Binding.name "simps", simps), []),
  34.198 -    ((Binding.empty, flat case_thms @
  34.199 -          flat distinct @ rec_thms), [Simplifier.simp_add]),
  34.200 -    ((Binding.empty, rec_thms), [Code.add_default_eqn_attribute]),
  34.201 -    ((Binding.empty, flat inject), [iff_add]),
  34.202 -    ((Binding.empty, map (fn th => th RS notE) (flat distinct)), [Classical.safe_elim NONE]),
  34.203 -    ((Binding.empty, weak_case_congs), [cong_att])]
  34.204 -  #> snd;
  34.205 -
  34.206 -
  34.207 -(* add_cases_induct *)
  34.208 -
  34.209 -fun add_cases_induct infos induction thy =
  34.210 -  let
  34.211 -    val inducts = ProjectRule.projections (ProofContext.init thy) induction;
  34.212 -
  34.213 -    fun named_rules (name, {index, exhaustion, ...}: datatype_info) =
  34.214 -      [((Binding.empty, nth inducts index), [Induct.induct_type name]),
  34.215 -       ((Binding.empty, exhaustion), [Induct.cases_type name])];
  34.216 -    fun unnamed_rule i =
  34.217 -      ((Binding.empty, nth inducts i), [Thm.kind_internal, Induct.induct_type ""]);
  34.218 -  in
  34.219 -    thy |> PureThy.add_thms
  34.220 -      (maps named_rules infos @
  34.221 -        map unnamed_rule (length infos upto length inducts - 1)) |> snd
  34.222 -    |> PureThy.add_thmss [((Binding.name "inducts", inducts), [])] |> snd
  34.223 -  end;
  34.224 -
  34.225 -
  34.226 -
  34.227 -(**** simplification procedure for showing distinctness of constructors ****)
  34.228 -
  34.229 -fun stripT (i, Type ("fun", [_, T])) = stripT (i + 1, T)
  34.230 -  | stripT p = p;
  34.231 -
  34.232 -fun stripC (i, f $ x) = stripC (i + 1, f)
  34.233 -  | stripC p = p;
  34.234 -
  34.235 -val distinctN = "constr_distinct";
  34.236 -
  34.237 -fun distinct_rule thy ss tname eq_t = case #distinct (the_datatype thy tname) of
  34.238 -    FewConstrs thms => Goal.prove (Simplifier.the_context ss) [] [] eq_t (K
  34.239 -      (EVERY [rtac eq_reflection 1, rtac iffI 1, rtac notE 1,
  34.240 -        atac 2, resolve_tac thms 1, etac FalseE 1]))
  34.241 -  | ManyConstrs (thm, simpset) =>
  34.242 -      let
  34.243 -        val [In0_inject, In1_inject, In0_not_In1, In1_not_In0] =
  34.244 -          map (PureThy.get_thm (ThyInfo.the_theory "Datatype" thy))
  34.245 -            ["In0_inject", "In1_inject", "In0_not_In1", "In1_not_In0"];
  34.246 -      in
  34.247 -        Goal.prove (Simplifier.the_context ss) [] [] eq_t (K
  34.248 -        (EVERY [rtac eq_reflection 1, rtac iffI 1, dtac thm 1,
  34.249 -          full_simp_tac (Simplifier.inherit_context ss simpset) 1,
  34.250 -          REPEAT (dresolve_tac [In0_inject, In1_inject] 1),
  34.251 -          eresolve_tac [In0_not_In1 RS notE, In1_not_In0 RS notE] 1,
  34.252 -          etac FalseE 1]))
  34.253 -      end;
  34.254 -
  34.255 -fun distinct_proc thy ss (t as Const ("op =", _) $ t1 $ t2) =
  34.256 -  (case (stripC (0, t1), stripC (0, t2)) of
  34.257 -     ((i, Const (cname1, T1)), (j, Const (cname2, T2))) =>
  34.258 -         (case (stripT (0, T1), stripT (0, T2)) of
  34.259 -            ((i', Type (tname1, _)), (j', Type (tname2, _))) =>
  34.260 -                if tname1 = tname2 andalso not (cname1 = cname2) andalso i = i' andalso j = j' then
  34.261 -                   (case (get_datatype_descr thy) tname1 of
  34.262 -                      SOME (_, (_, constrs)) => let val cnames = map fst constrs
  34.263 -                        in if cname1 mem cnames andalso cname2 mem cnames then
  34.264 -                             SOME (distinct_rule thy ss tname1
  34.265 -                               (Logic.mk_equals (t, Const ("False", HOLogic.boolT))))
  34.266 -                           else NONE
  34.267 -                        end
  34.268 -                    | NONE => NONE)
  34.269 -                else NONE
  34.270 -          | _ => NONE)
  34.271 -   | _ => NONE)
  34.272 -  | distinct_proc _ _ _ = NONE;
  34.273 -
  34.274 -val distinct_simproc =
  34.275 -  Simplifier.simproc @{theory HOL} distinctN ["s = t"] distinct_proc;
  34.276 -
  34.277 -val dist_ss = HOL_ss addsimprocs [distinct_simproc];
  34.278 -
  34.279 -val simproc_setup =
  34.280 -  Simplifier.map_simpset (fn ss => ss addsimprocs [distinct_simproc]);
  34.281 -
  34.282 -
  34.283 -(**** translation rules for case ****)
  34.284 -
  34.285 -fun make_case ctxt = DatatypeCase.make_case
  34.286 -  (datatype_of_constr (ProofContext.theory_of ctxt)) ctxt;
  34.287 -
  34.288 -fun strip_case ctxt = DatatypeCase.strip_case
  34.289 -  (datatype_of_case (ProofContext.theory_of ctxt));
  34.290 -
  34.291 -fun add_case_tr' case_names thy =
  34.292 -  Sign.add_advanced_trfuns ([], [],
  34.293 -    map (fn case_name =>
  34.294 -      let val case_name' = Sign.const_syntax_name thy case_name
  34.295 -      in (case_name', DatatypeCase.case_tr' datatype_of_case case_name')
  34.296 -      end) case_names, []) thy;
  34.297 -
  34.298 -val trfun_setup =
  34.299 -  Sign.add_advanced_trfuns ([],
  34.300 -    [("_case_syntax", DatatypeCase.case_tr true datatype_of_constr)],
  34.301 -    [], []);
  34.302 -
  34.303 -
  34.304 -(* prepare types *)
  34.305 -
  34.306 -fun read_typ thy ((Ts, sorts), str) =
  34.307 -  let
  34.308 -    val ctxt = ProofContext.init thy
  34.309 -      |> fold (Variable.declare_typ o TFree) sorts;
  34.310 -    val T = Syntax.read_typ ctxt str;
  34.311 -  in (Ts @ [T], Term.add_tfreesT T sorts) end;
  34.312 -
  34.313 -fun cert_typ sign ((Ts, sorts), raw_T) =
  34.314 -  let
  34.315 -    val T = Type.no_tvars (Sign.certify_typ sign raw_T) handle
  34.316 -      TYPE (msg, _, _) => error msg;
  34.317 -    val sorts' = Term.add_tfreesT T sorts;
  34.318 -  in (Ts @ [T],
  34.319 -      case duplicates (op =) (map fst sorts') of
  34.320 -         [] => sorts'
  34.321 -       | dups => error ("Inconsistent sort constraints for " ^ commas dups))
  34.322 -  end;
  34.323 -
  34.324 -
  34.325 -(**** make datatype info ****)
  34.326 -
  34.327 -fun make_dt_info alt_names descr sorts induct reccomb_names rec_thms
  34.328 -    (((((((((i, (_, (tname, _, _))), case_name), case_thms),
  34.329 -      exhaustion_thm), distinct_thm), inject), nchotomy), case_cong), weak_case_cong) =
  34.330 -  (tname,
  34.331 -   {index = i,
  34.332 -    alt_names = alt_names,
  34.333 -    descr = descr,
  34.334 -    sorts = sorts,
  34.335 -    rec_names = reccomb_names,
  34.336 -    rec_rewrites = rec_thms,
  34.337 -    case_name = case_name,
  34.338 -    case_rewrites = case_thms,
  34.339 -    induction = induct,
  34.340 -    exhaustion = exhaustion_thm,
  34.341 -    distinct = distinct_thm,
  34.342 -    inject = inject,
  34.343 -    nchotomy = nchotomy,
  34.344 -    case_cong = case_cong,
  34.345 -    weak_case_cong = weak_case_cong});
  34.346 -
  34.347 -type rules = {distinct : thm list list,
  34.348 -  inject : thm list list,
  34.349 -  exhaustion : thm list,
  34.350 -  rec_thms : thm list,
  34.351 -  case_thms : thm list list,
  34.352 -  split_thms : (thm * thm) list,
  34.353 -  induction : thm,
  34.354 -  simps : thm list}
  34.355 -
  34.356 -structure DatatypeInterpretation = InterpretationFun
  34.357 -  (type T = datatype_config * string list val eq: T * T -> bool = eq_snd op =);
  34.358 -fun interpretation f = DatatypeInterpretation.interpretation (uncurry f);
  34.359 -
  34.360 -
  34.361 -(******************* definitional introduction of datatypes *******************)
  34.362 -
  34.363 -fun add_datatype_def (config : datatype_config) new_type_names descr sorts types_syntax constr_syntax dt_info
  34.364 -    case_names_induct case_names_exhausts thy =
  34.365 -  let
  34.366 -    val _ = message config ("Proofs for datatype(s) " ^ commas_quote new_type_names);
  34.367 -
  34.368 -    val ((inject, distinct, dist_rewrites, simproc_dists, induct), thy2) = thy |>
  34.369 -      DatatypeRepProofs.representation_proofs config dt_info new_type_names descr sorts
  34.370 -        types_syntax constr_syntax case_names_induct;
  34.371 -
  34.372 -    val (casedist_thms, thy3) = DatatypeAbsProofs.prove_casedist_thms config new_type_names descr
  34.373 -      sorts induct case_names_exhausts thy2;
  34.374 -    val ((reccomb_names, rec_thms), thy4) = DatatypeAbsProofs.prove_primrec_thms
  34.375 -      config new_type_names descr sorts dt_info inject dist_rewrites
  34.376 -      (Simplifier.theory_context thy3 dist_ss) induct thy3;
  34.377 -    val ((case_thms, case_names), thy6) = DatatypeAbsProofs.prove_case_thms
  34.378 -      config new_type_names descr sorts reccomb_names rec_thms thy4;
  34.379 -    val (split_thms, thy7) = DatatypeAbsProofs.prove_split_thms config new_type_names
  34.380 -      descr sorts inject dist_rewrites casedist_thms case_thms thy6;
  34.381 -    val (nchotomys, thy8) = DatatypeAbsProofs.prove_nchotomys config new_type_names
  34.382 -      descr sorts casedist_thms thy7;
  34.383 -    val (case_congs, thy9) = DatatypeAbsProofs.prove_case_congs new_type_names
  34.384 -      descr sorts nchotomys case_thms thy8;
  34.385 -    val (weak_case_congs, thy10) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
  34.386 -      descr sorts thy9;
  34.387 -
  34.388 -    val dt_infos = map
  34.389 -      (make_dt_info (SOME new_type_names) (flat descr) sorts induct reccomb_names rec_thms)
  34.390 -      ((0 upto length (hd descr) - 1) ~~ (hd descr) ~~ case_names ~~ case_thms ~~
  34.391 -        casedist_thms ~~ simproc_dists ~~ inject ~~ nchotomys ~~ case_congs ~~ weak_case_congs);
  34.392 -
  34.393 -    val simps = flat (distinct @ inject @ case_thms) @ rec_thms;
  34.394 -
  34.395 -    val thy12 =
  34.396 -      thy10
  34.397 -      |> add_case_tr' case_names
  34.398 -      |> Sign.add_path (space_implode "_" new_type_names)
  34.399 -      |> add_rules simps case_thms rec_thms inject distinct
  34.400 -          weak_case_congs (Simplifier.attrib (op addcongs))
  34.401 -      |> put_dt_infos dt_infos
  34.402 -      |> add_cases_induct dt_infos induct
  34.403 -      |> Sign.parent_path
  34.404 -      |> store_thmss "splits" new_type_names (map (fn (x, y) => [x, y]) split_thms) |> snd
  34.405 -      |> DatatypeInterpretation.data (config, map fst dt_infos);
  34.406 -  in
  34.407 -    ({distinct = distinct,
  34.408 -      inject = inject,
  34.409 -      exhaustion = casedist_thms,
  34.410 -      rec_thms = rec_thms,
  34.411 -      case_thms = case_thms,
  34.412 -      split_thms = split_thms,
  34.413 -      induction = induct,
  34.414 -      simps = simps}, thy12)
  34.415 -  end;
  34.416 -
  34.417 -
  34.418 -(*********************** declare existing type as datatype *********************)
  34.419 -
  34.420 -fun prove_rep_datatype (config : datatype_config) alt_names new_type_names descr sorts induct inject half_distinct thy =
  34.421 -  let
  34.422 -    val ((_, [induct']), _) =
  34.423 -      Variable.importT_thms [induct] (Variable.thm_context induct);
  34.424 -
  34.425 -    fun err t = error ("Ill-formed predicate in induction rule: " ^
  34.426 -      Syntax.string_of_term_global thy t);
  34.427 -
  34.428 -    fun get_typ (t as _ $ Var (_, Type (tname, Ts))) =
  34.429 -          ((tname, map (fst o dest_TFree) Ts) handle TERM _ => err t)
  34.430 -      | get_typ t = err t;
  34.431 -    val dtnames = map get_typ (HOLogic.dest_conj (HOLogic.dest_Trueprop (Thm.concl_of induct')));
  34.432 -
  34.433 -    val dt_info = get_datatypes thy;
  34.434 -
  34.435 -    val distinct = (map o maps) (fn thm => [thm, thm RS not_sym]) half_distinct;
  34.436 -    val (case_names_induct, case_names_exhausts) =
  34.437 -      (mk_case_names_induct descr, mk_case_names_exhausts descr (map #1 dtnames));
  34.438 -
  34.439 -    val _ = message config ("Proofs for datatype(s) " ^ commas_quote new_type_names);
  34.440 -
  34.441 -    val (casedist_thms, thy2) = thy |>
  34.442 -      DatatypeAbsProofs.prove_casedist_thms config new_type_names [descr] sorts induct
  34.443 -        case_names_exhausts;
  34.444 -    val ((reccomb_names, rec_thms), thy3) = DatatypeAbsProofs.prove_primrec_thms
  34.445 -      config new_type_names [descr] sorts dt_info inject distinct
  34.446 -      (Simplifier.theory_context thy2 dist_ss) induct thy2;
  34.447 -    val ((case_thms, case_names), thy4) = DatatypeAbsProofs.prove_case_thms
  34.448 -      config new_type_names [descr] sorts reccomb_names rec_thms thy3;
  34.449 -    val (split_thms, thy5) = DatatypeAbsProofs.prove_split_thms
  34.450 -      config new_type_names [descr] sorts inject distinct casedist_thms case_thms thy4;
  34.451 -    val (nchotomys, thy6) = DatatypeAbsProofs.prove_nchotomys config new_type_names
  34.452 -      [descr] sorts casedist_thms thy5;
  34.453 -    val (case_congs, thy7) = DatatypeAbsProofs.prove_case_congs new_type_names
  34.454 -      [descr] sorts nchotomys case_thms thy6;
  34.455 -    val (weak_case_congs, thy8) = DatatypeAbsProofs.prove_weak_case_congs new_type_names
  34.456 -      [descr] sorts thy7;
  34.457 -
  34.458 -    val ((_, [induct']), thy10) =
  34.459 -      thy8
  34.460 -      |> store_thmss "inject" new_type_names inject
  34.461 -      ||>> store_thmss "distinct" new_type_names distinct
  34.462 -      ||> Sign.add_path (space_implode "_" new_type_names)
  34.463 -      ||>> PureThy.add_thms [((Binding.name "induct", induct), [case_names_induct])];
  34.464 -
  34.465 -    val dt_infos = map (make_dt_info alt_names descr sorts induct' reccomb_names rec_thms)
  34.466 -      ((0 upto length descr - 1) ~~ descr ~~ case_names ~~ case_thms ~~ casedist_thms ~~
  34.467 -        map FewConstrs distinct ~~ inject ~~ nchotomys ~~ case_congs ~~ weak_case_congs);
  34.468 -
  34.469 -    val simps = flat (distinct @ inject @ case_thms) @ rec_thms;
  34.470 -
  34.471 -    val thy11 =
  34.472 -      thy10
  34.473 -      |> add_case_tr' case_names
  34.474 -      |> add_rules simps case_thms rec_thms inject distinct
  34.475 -           weak_case_congs (Simplifier.attrib (op addcongs))
  34.476 -      |> put_dt_infos dt_infos
  34.477 -      |> add_cases_induct dt_infos induct'
  34.478 -      |> Sign.parent_path
  34.479 -      |> store_thmss "splits" new_type_names (map (fn (x, y) => [x, y]) split_thms)
  34.480 -      |> snd
  34.481 -      |> DatatypeInterpretation.data (config, map fst dt_infos);
  34.482 -  in
  34.483 -    ({distinct = distinct,
  34.484 -      inject = inject,
  34.485 -      exhaustion = casedist_thms,
  34.486 -      rec_thms = rec_thms,
  34.487 -      case_thms = case_thms,
  34.488 -      split_thms = split_thms,
  34.489 -      induction = induct',
  34.490 -      simps = simps}, thy11)
  34.491 -  end;
  34.492 -
  34.493 -fun gen_rep_datatype prep_term (config : datatype_config) after_qed alt_names raw_ts thy =
  34.494 -  let
  34.495 -    fun constr_of_term (Const (c, T)) = (c, T)
  34.496 -      | constr_of_term t =
  34.497 -          error ("Not a constant: " ^ Syntax.string_of_term_global thy t);
  34.498 -    fun no_constr (c, T) = error ("Bad constructor: "
  34.499 -      ^ Sign.extern_const thy c ^ "::"
  34.500 -      ^ Syntax.string_of_typ_global thy T);
  34.501 -    fun type_of_constr (cT as (_, T)) =
  34.502 -      let
  34.503 -        val frees = OldTerm.typ_tfrees T;
  34.504 -        val (tyco, vs) = ((apsnd o map) (dest_TFree) o dest_Type o snd o strip_type) T
  34.505 -          handle TYPE _ => no_constr cT
  34.506 -        val _ = if has_duplicates (eq_fst (op =)) vs then no_constr cT else ();
  34.507 -        val _ = if length frees <> length vs then no_constr cT else ();
  34.508 -      in (tyco, (vs, cT)) end;
  34.509 -
  34.510 -    val raw_cs = AList.group (op =) (map (type_of_constr o constr_of_term o prep_term thy) raw_ts);
  34.511 -    val _ = case map_filter (fn (tyco, _) =>
  34.512 -        if Symtab.defined (get_datatypes thy) tyco then SOME tyco else NONE) raw_cs
  34.513 -     of [] => ()
  34.514 -      | tycos => error ("Type(s) " ^ commas (map quote tycos)
  34.515 -          ^ " already represented inductivly");
  34.516 -    val raw_vss = maps (map (map snd o fst) o snd) raw_cs;
  34.517 -    val ms = case distinct (op =) (map length raw_vss)
  34.518 -     of [n] => 0 upto n - 1
  34.519 -      | _ => error ("Different types in given constructors");
  34.520 -    fun inter_sort m = map (fn xs => nth xs m) raw_vss
  34.521 -      |> Library.foldr1 (Sorts.inter_sort (Sign.classes_of thy))
  34.522 -    val sorts = map inter_sort ms;
  34.523 -    val vs = Name.names Name.context Name.aT sorts;
  34.524 -
  34.525 -    fun norm_constr (raw_vs, (c, T)) = (c, map_atyps
  34.526 -      (TFree o (the o AList.lookup (op =) (map fst raw_vs ~~ vs)) o fst o dest_TFree) T);
  34.527 -
  34.528 -    val cs = map (apsnd (map norm_constr)) raw_cs;
  34.529 -    val dtyps_of_typ = map (dtyp_of_typ (map (rpair (map fst vs) o fst) cs))
  34.530 -      o fst o strip_type;
  34.531 -    val new_type_names = map Long_Name.base_name (the_default (map fst cs) alt_names);
  34.532 -
  34.533 -    fun mk_spec (i, (tyco, constr)) = (i, (tyco,
  34.534 -      map (DtTFree o fst) vs,
  34.535 -      (map o apsnd) dtyps_of_typ constr))
  34.536 -    val descr = map_index mk_spec cs;
  34.537 -    val injs = DatatypeProp.make_injs [descr] vs;
  34.538 -    val half_distincts = map snd (DatatypeProp.make_distincts [descr] vs);
  34.539 -    val ind = DatatypeProp.make_ind [descr] vs;
  34.540 -    val rules = (map o map o map) Logic.close_form [[[ind]], injs, half_distincts];
  34.541 -
  34.542 -    fun after_qed' raw_thms =
  34.543 -      let
  34.544 -        val [[[induct]], injs, half_distincts] =
  34.545 -          unflat rules (map Drule.zero_var_indexes_list raw_thms);
  34.546 -            (*FIXME somehow dubious*)
  34.547 -      in
  34.548 -        ProofContext.theory_result
  34.549 -          (prove_rep_datatype config alt_names new_type_names descr vs induct injs half_distincts)
  34.550 -        #-> after_qed
  34.551 -      end;
  34.552 -  in
  34.553 -    thy
  34.554 -    |> ProofContext.init
  34.555 -    |> Proof.theorem_i NONE after_qed' ((map o map) (rpair []) (flat rules))
  34.556 -  end;
  34.557 -
  34.558 -val rep_datatype = gen_rep_datatype Sign.cert_term;
  34.559 -val rep_datatype_cmd = gen_rep_datatype Syntax.read_term_global default_datatype_config (K I);
  34.560 -
  34.561 -
  34.562 -
  34.563 -(******************************** add datatype ********************************)
  34.564 -
  34.565 -fun gen_add_datatype prep_typ (config : datatype_config) new_type_names dts thy =
  34.566 -  let
  34.567 -    val _ = Theory.requires thy "Datatype" "datatype definitions";
  34.568 -
  34.569 -    (* this theory is used just for parsing *)
  34.570 -
  34.571 -    val tmp_thy = thy |>
  34.572 -      Theory.copy |>
  34.573 -      Sign.add_types (map (fn (tvs, tname, mx, _) =>
  34.574 -        (tname, length tvs, mx)) dts);
  34.575 -
  34.576 -    val (tyvars, _, _, _)::_ = dts;
  34.577 -    val (new_dts, types_syntax) = ListPair.unzip (map (fn (tvs, tname, mx, _) =>
  34.578 -      let val full_tname = Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname)
  34.579 -      in (case duplicates (op =) tvs of
  34.580 -            [] => if eq_set (tyvars, tvs) then ((full_tname, tvs), (tname, mx))
  34.581 -                  else error ("Mutually recursive datatypes must have same type parameters")
  34.582 -          | dups => error ("Duplicate parameter(s) for datatype " ^ quote (Binding.str_of tname) ^
  34.583 -              " : " ^ commas dups))
  34.584 -      end) dts);
  34.585 -
  34.586 -    val _ = (case duplicates (op =) (map fst new_dts) @ duplicates (op =) new_type_names of
  34.587 -      [] => () | dups => error ("Duplicate datatypes: " ^ commas dups));
  34.588 -
  34.589 -    fun prep_dt_spec ((tvs, tname, mx, constrs), tname') (dts', constr_syntax, sorts, i) =
  34.590 -      let
  34.591 -        fun prep_constr (cname, cargs, mx') (constrs, constr_syntax', sorts') =
  34.592 -          let
  34.593 -            val (cargs', sorts'') = Library.foldl (prep_typ tmp_thy) (([], sorts'), cargs);
  34.594 -            val _ = (case fold (curry OldTerm.add_typ_tfree_names) cargs' [] \\ tvs of
  34.595 -                [] => ()
  34.596 -              | vs => error ("Extra type variables on rhs: " ^ commas vs))
  34.597 -          in (constrs @ [((if #flat_names config then Sign.full_name tmp_thy else
  34.598 -                Sign.full_name_path tmp_thy tname')
  34.599 -                  (Binding.map_name (Syntax.const_name mx') cname),
  34.600 -                   map (dtyp_of_typ new_dts) cargs')],
  34.601 -              constr_syntax' @ [(cname, mx')], sorts'')
  34.602 -          end handle ERROR msg => cat_error msg
  34.603 -           ("The error above occured in constructor " ^ quote (Binding.str_of cname) ^
  34.604 -            " of datatype " ^ quote (Binding.str_of tname));
  34.605 -
  34.606 -        val (constrs', constr_syntax', sorts') =
  34.607 -          fold prep_constr constrs ([], [], sorts)
  34.608 -
  34.609 -      in
  34.610 -        case duplicates (op =) (map fst constrs') of
  34.611 -           [] =>
  34.612 -             (dts' @ [(i, (Sign.full_name tmp_thy (Binding.map_name (Syntax.type_name mx) tname),
  34.613 -                map DtTFree tvs, constrs'))],
  34.614 -              constr_syntax @ [constr_syntax'], sorts', i + 1)
  34.615 -         | dups => error ("Duplicate constructors " ^ commas dups ^
  34.616 -             " in datatype " ^ quote (Binding.str_of tname))
  34.617 -      end;
  34.618 -
  34.619 -    val (dts', constr_syntax, sorts', i) =
  34.620 -      fold prep_dt_spec (dts ~~ new_type_names) ([], [], [], 0);
  34.621 -    val sorts = sorts' @ (map (rpair (Sign.defaultS tmp_thy)) (tyvars \\ map fst sorts'));
  34.622 -    val dt_info = get_datatypes thy;
  34.623 -    val (descr, _) = unfold_datatypes tmp_thy dts' sorts dt_info dts' i;
  34.624 -    val _ = check_nonempty descr handle (exn as Datatype_Empty s) =>
  34.625 -      if #strict config then error ("Nonemptiness check failed for datatype " ^ s)
  34.626 -      else raise exn;
  34.627 -
  34.628 -    val descr' = flat descr;
  34.629 -    val case_names_induct = mk_case_names_induct descr';
  34.630 -    val case_names_exhausts = mk_case_names_exhausts descr' (map #1 new_dts);
  34.631 -  in
  34.632 -    add_datatype_def
  34.633 -      (config : datatype_config) new_type_names descr sorts types_syntax constr_syntax dt_info
  34.634 -      case_names_induct case_names_exhausts thy
  34.635 -  end;
  34.636 -
  34.637 -val add_datatype = gen_add_datatype cert_typ;
  34.638 -val add_datatype_cmd = gen_add_datatype read_typ default_datatype_config;
  34.639 -
  34.640 -
  34.641 -
  34.642 -(** package setup **)
  34.643 -
  34.644 -(* setup theory *)
  34.645 -
  34.646 -val setup =
  34.647 -  DatatypeRepProofs.distinctness_limit_setup #>
  34.648 -  simproc_setup #>
  34.649 -  trfun_setup #>
  34.650 -  DatatypeInterpretation.init;
  34.651 -
  34.652 -
  34.653 -(* outer syntax *)
  34.654 -
  34.655 -local structure P = OuterParse and K = OuterKeyword in
  34.656 -
  34.657 -val datatype_decl =
  34.658 -  Scan.option (P.$$$ "(" |-- P.name --| P.$$$ ")") -- P.type_args -- P.binding -- P.opt_infix --
  34.659 -    (P.$$$ "=" |-- P.enum1 "|" (P.binding -- Scan.repeat P.typ -- P.opt_mixfix));
  34.660 -
  34.661 -fun mk_datatype args =
  34.662 -  let
  34.663 -    val names = map
  34.664 -      (fn ((((NONE, _), t), _), _) => Binding.name_of t | ((((SOME t, _), _), _), _) => t) args;
  34.665 -    val specs = map (fn ((((_, vs), t), mx), cons) =>
  34.666 -      (vs, t, mx, map (fn ((x, y), z) => (x, y, z)) cons)) args;
  34.667 -  in snd o add_datatype_cmd names specs end;
  34.668 -
  34.669 -val _ =
  34.670 -  OuterSyntax.command "datatype" "define inductive datatypes" K.thy_decl
  34.671 -    (P.and_list1 datatype_decl >> (Toplevel.theory o mk_datatype));
  34.672 -
  34.673 -val _ =
  34.674 -  OuterSyntax.command "rep_datatype" "represent existing types inductively" K.thy_goal
  34.675 -    (Scan.option (P.$$$ "(" |-- Scan.repeat1 P.name --| P.$$$ ")") -- Scan.repeat1 P.term
  34.676 -      >> (fn (alt_names, ts) => Toplevel.print
  34.677 -           o Toplevel.theory_to_proof (rep_datatype_cmd alt_names ts)));
  34.678 -
  34.679 -end;
  34.680 -
  34.681 -
  34.682 -(* document antiquotation *)
  34.683 -
  34.684 -val _ = ThyOutput.antiquotation "datatype" Args.tyname
  34.685 -  (fn {source = src, context = ctxt, ...} => fn dtco =>
  34.686 -    let
  34.687 -      val thy = ProofContext.theory_of ctxt;
  34.688 -      val (vs, cos) = the_datatype_spec thy dtco;
  34.689 -      val ty = Type (dtco, map TFree vs);
  34.690 -      fun pretty_typ_bracket (ty as Type (_, _ :: _)) =
  34.691 -            Pretty.enclose "(" ")" [Syntax.pretty_typ ctxt ty]
  34.692 -        | pretty_typ_bracket ty =
  34.693 -            Syntax.pretty_typ ctxt ty;
  34.694 -      fun pretty_constr (co, tys) =
  34.695 -        (Pretty.block o Pretty.breaks)
  34.696 -          (Syntax.pretty_term ctxt (Const (co, tys ---> ty)) ::
  34.697 -            map pretty_typ_bracket tys);
  34.698 -      val pretty_datatype =
  34.699 -        Pretty.block
  34.700 -          (Pretty.command "datatype" :: Pretty.brk 1 ::
  34.701 -           Syntax.pretty_typ ctxt ty ::
  34.702 -           Pretty.str " =" :: Pretty.brk 1 ::
  34.703 -           flat (separate [Pretty.brk 1, Pretty.str "| "]
  34.704 -             (map (single o pretty_constr) cos)));
  34.705 -    in ThyOutput.output (ThyOutput.maybe_pretty_source (K pretty_datatype) src [()]) end);
  34.706 -
  34.707 -end;
  34.708 -
    35.1 --- a/src/HOL/Tools/datatype_package/datatype_realizer.ML	Thu Jun 18 18:31:14 2009 -0700
    35.2 +++ b/src/HOL/Tools/datatype_package/datatype_realizer.ML	Fri Jun 19 17:23:21 2009 +0200
    35.3 @@ -217,7 +217,7 @@
    35.4    if ! Proofterm.proofs < 2 then thy
    35.5    else let
    35.6      val _ = message config "Adding realizers for induction and case analysis ..."
    35.7 -    val infos = map (DatatypePackage.the_datatype thy) names;
    35.8 +    val infos = map (Datatype.the_datatype thy) names;
    35.9      val info :: _ = infos;
   35.10    in
   35.11      thy
   35.12 @@ -225,6 +225,6 @@
   35.13      |> fold_rev (make_casedists (#sorts info)) infos
   35.14    end;
   35.15  
   35.16 -val setup = DatatypePackage.interpretation add_dt_realizers;
   35.17 +val setup = Datatype.interpretation add_dt_realizers;
   35.18  
   35.19  end;
    36.1 --- a/src/HOL/Tools/datatype_package/datatype_rep_proofs.ML	Thu Jun 18 18:31:14 2009 -0700
    36.2 +++ b/src/HOL/Tools/datatype_package/datatype_rep_proofs.ML	Fri Jun 19 17:23:21 2009 +0200
    36.3 @@ -183,7 +183,7 @@
    36.4          ((1 upto (length constrs)) ~~ constrs)) (descr' ~~ rep_set_names');
    36.5  
    36.6      val ({raw_induct = rep_induct, intrs = rep_intrs, ...}, thy2) =
    36.7 -        InductivePackage.add_inductive_global (serial_string ())
    36.8 +        Inductive.add_inductive_global (serial_string ())
    36.9            {quiet_mode = #quiet config, verbose = false, kind = Thm.internalK,
   36.10             alt_name = Binding.name big_rec_name, coind = false, no_elim = true, no_ind = false,
   36.11             skip_mono = true, fork_mono = false}
   36.12 @@ -195,7 +195,7 @@
   36.13      val (typedefs, thy3) = thy2 |>
   36.14        parent_path (#flat_names config) |>
   36.15        fold_map (fn ((((name, mx), tvs), c), name') =>
   36.16 -          TypedefPackage.add_typedef false (SOME (Binding.name name')) (name, tvs, mx)
   36.17 +          Typedef.add_typedef false (SOME (Binding.name name')) (name, tvs, mx)
   36.18              (Collect $ Const (c, UnivT')) NONE
   36.19              (rtac exI 1 THEN rtac CollectI 1 THEN
   36.20                QUIET_BREADTH_FIRST (has_fewer_prems 1)
    37.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    37.2 +++ b/src/HOL/Tools/function_package/fundef.ML	Fri Jun 19 17:23:21 2009 +0200
    37.3 @@ -0,0 +1,226 @@
    37.4 +(*  Title:      HOL/Tools/function_package/fundef.ML
    37.5 +    Author:     Alexander Krauss, TU Muenchen
    37.6 +
    37.7 +A package for general recursive function definitions.
    37.8 +Isar commands.
    37.9 +*)
   37.10 +
   37.11 +signature FUNDEF =
   37.12 +sig
   37.13 +    val add_fundef :  (binding * typ option * mixfix) list
   37.14 +                       -> (Attrib.binding * term) list
   37.15 +                       -> FundefCommon.fundef_config
   37.16 +                       -> local_theory
   37.17 +                       -> Proof.state
   37.18 +    val add_fundef_cmd :  (binding * string option * mixfix) list
   37.19 +                      -> (Attrib.binding * string) list
   37.20 +                      -> FundefCommon.fundef_config
   37.21 +                      -> local_theory
   37.22 +                      -> Proof.state
   37.23 +
   37.24 +    val termination_proof : term option -> local_theory -> Proof.state
   37.25 +    val termination_proof_cmd : string option -> local_theory -> Proof.state
   37.26 +    val termination : term option -> local_theory -> Proof.state
   37.27 +    val termination_cmd : string option -> local_theory -> Proof.state
   37.28 +
   37.29 +    val setup : theory -> theory
   37.30 +    val get_congs : Proof.context -> thm list
   37.31 +end
   37.32 +
   37.33 +
   37.34 +structure Fundef : FUNDEF =
   37.35 +struct
   37.36 +
   37.37 +open FundefLib
   37.38 +open FundefCommon
   37.39 +
   37.40 +val simp_attribs = map (Attrib.internal o K)
   37.41 +    [Simplifier.simp_add,
   37.42 +     Code.add_default_eqn_attribute,
   37.43 +     Nitpick_Const_Simp_Thms.add,
   37.44 +     Quickcheck_RecFun_Simp_Thms.add]
   37.45 +
   37.46 +val psimp_attribs = map (Attrib.internal o K)
   37.47 +    [Simplifier.simp_add,
   37.48 +     Nitpick_Const_Psimp_Thms.add]
   37.49 +
   37.50 +fun note_theorem ((name, atts), ths) =
   37.51 +  LocalTheory.note Thm.generatedK ((Binding.qualified_name name, atts), ths)
   37.52 +
   37.53 +fun mk_defname fixes = fixes |> map (fst o fst) |> space_implode "_"
   37.54 +