discontinued ancient tradition to suffix certain ML module names with "_package"
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 +