author | krauss |
Wed, 13 Sep 2006 12:05:50 +0200 | |
changeset 20523 | 36a59e5d0039 |
child 21025 | 10b0821a4d11 |
permissions | -rw-r--r-- |
20523
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
1 |
(* Title: HOL/Tools/function_package/inductive_wrap.ML |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
2 |
ID: $Id$ |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
3 |
Author: Alexander Krauss, TU Muenchen |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
4 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
5 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
6 |
This is a wrapper around the inductive package which corrects some of its |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
7 |
slightly annoying behaviours and makes the whole business more controllable. |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
8 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
9 |
Specifically: |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
10 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
11 |
- Following newer Isar conventions, declaration and definition are done in one step |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
12 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
13 |
- The specification is expected in fully quantified form. This allows the client to |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
14 |
control the variable order. The variables will appear in the result in the same order. |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
15 |
This is especially relevant for the elimination rule, where the order usually *does* matter. |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
16 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
17 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
18 |
All this will probably become obsolete in the near future, when the new "predicate" package |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
19 |
is in place. |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
20 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
21 |
*) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
22 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
23 |
signature FUNDEF_INDUCTIVE_WRAP = |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
24 |
sig |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
25 |
val inductive_def : term list |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
26 |
-> ((bstring * typ) * mixfix) * local_theory |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
27 |
-> thm list * (term * thm * local_theory) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
28 |
end |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
29 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
30 |
structure FundefInductiveWrap = |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
31 |
struct |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
32 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
33 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
34 |
fun inst_forall (Free (n,_)) (_ $ Abs (_, T, b)) = subst_bound (Free (n, T), b) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
35 |
| inst_forall t1 t2 = sys_error ((Sign.string_of_term (the_context ()) t1)) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
36 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
37 |
fun permute_bounds_in_premises thy [] impl = impl |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
38 |
| permute_bounds_in_premises thy ((oldvs, newvs) :: perms) impl = |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
39 |
let |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
40 |
val (prem, concl) = dest_implies (cprop_of impl) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
41 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
42 |
val newprem = term_of prem |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
43 |
|> fold inst_forall oldvs |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
44 |
|> fold_rev mk_forall newvs |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
45 |
|> cterm_of thy |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
46 |
in |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
47 |
assume newprem |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
48 |
|> fold (forall_elim o cterm_of thy) newvs |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
49 |
|> fold_rev (forall_intr o cterm_of thy) oldvs |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
50 |
|> implies_elim impl |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
51 |
|> permute_bounds_in_premises thy perms |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
52 |
|> implies_intr newprem |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
53 |
end |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
54 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
55 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
56 |
fun inductive_def defs (((R, T), mixfix), lthy) = |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
57 |
let |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
58 |
fun wrap1 thy = |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
59 |
let |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
60 |
val thy = Sign.add_consts_i [(R, T, mixfix)] thy |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
61 |
val RC = Const (Sign.full_name thy R, T) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
62 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
63 |
val cdefs = map (Pattern.rewrite_term thy [(Free (R, T), RC)] []) defs |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
64 |
val qdefs = map dest_all_all cdefs |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
65 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
66 |
val (thy, {intrs = intrs_gen, elims = [elim_gen], ...}) = |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
67 |
InductivePackage.add_inductive_i true (*verbose*) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
68 |
false (* dont add_consts *) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
69 |
"" (* no altname *) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
70 |
false (* no coind *) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
71 |
false (* elims, please *) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
72 |
false (* induction thm please *) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
73 |
[RC] (* the constant *) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
74 |
(map (fn (_,t) => (("", t),[])) qdefs) (* the intros *) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
75 |
[] (* no special monos *) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
76 |
thy |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
77 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
78 |
val perms = map (fn (qs, t) => ((term_frees t) inter qs, qs)) qdefs |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
79 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
80 |
fun inst (qs, _) intr_gen = |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
81 |
intr_gen |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
82 |
|> Thm.freezeT |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
83 |
|> fold_rev (forall_intr o (fn Free (n, T) => cterm_of thy (Var ((n,0), T)))) qs |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
84 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
85 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
86 |
val a = cterm_of thy (Free ("a0123", HOLogic.dest_setT T)) (* Let's just hope there are no clashes :-} *) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
87 |
val P = cterm_of thy (Free ("P0123", HOLogic.boolT)) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
88 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
89 |
val intrs = map2 inst qdefs intrs_gen |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
90 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
91 |
val elim = elim_gen |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
92 |
|> Thm.freezeT |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
93 |
|> forall_intr_vars (* FIXME... *) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
94 |
|> forall_elim a |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
95 |
|> forall_elim P |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
96 |
|> permute_bounds_in_premises thy (([],[]) :: perms) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
97 |
|> forall_intr P |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
98 |
|> forall_intr a |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
99 |
in |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
100 |
((RC, (intrs, elim)), thy) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
101 |
end |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
102 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
103 |
val ((RC, (intrs, elim)), lthy) = LocalTheory.theory_result wrap1 lthy |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
104 |
in |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
105 |
(intrs, (RC, elim, lthy)) |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
106 |
end |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
107 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
108 |
|
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
109 |
end |
36a59e5d0039
Major update to function package, including new syntax and the (only theoretical)
krauss
parents:
diff
changeset
|
110 |