author | wenzelm |
Thu, 11 Jan 2024 12:37:10 +0100 | |
changeset 79474 | c39aed404ffc |
parent 79473 | e1b2595d678a |
child 79475 | 9eb9882f1845 |
permissions | -rw-r--r-- |
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
1 |
(* Title: Pure/zterm.ML |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
2 |
Author: Makarius |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
3 |
|
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
4 |
Tight representation of types / terms / proof terms, notably for proof recording. |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
5 |
*) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
6 |
|
79124 | 7 |
(*** global ***) |
8 |
||
9 |
(* types and terms *) |
|
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
10 |
|
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
11 |
datatype ztyp = |
79119 | 12 |
ZTVar of indexname * sort (*free: index ~1*) |
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
13 |
| ZFun of ztyp * ztyp |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
14 |
| ZProp |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
15 |
| ZType0 of string (*type constant*) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
16 |
| ZType1 of string * ztyp (*type constructor: 1 argument*) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
17 |
| ZType of string * ztyp list (*type constructor: >= 2 arguments*) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
18 |
|
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
19 |
datatype zterm = |
79119 | 20 |
ZVar of indexname * ztyp (*free: index ~1*) |
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
21 |
| ZBound of int |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
22 |
| ZConst0 of string (*monomorphic constant*) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
23 |
| ZConst1 of string * ztyp (*polymorphic constant: 1 type argument*) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
24 |
| ZConst of string * ztyp list (*polymorphic constant: >= 2 type arguments*) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
25 |
| ZAbs of string * ztyp * zterm |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
26 |
| ZApp of zterm * zterm |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
27 |
| ZClass of ztyp * class (*OFCLASS proposition*) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
28 |
|
79124 | 29 |
structure ZTerm = |
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
30 |
struct |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
31 |
|
79119 | 32 |
(* fold *) |
33 |
||
34 |
fun fold_tvars f (ZTVar v) = f v |
|
35 |
| fold_tvars f (ZFun (T, U)) = fold_tvars f T #> fold_tvars f U |
|
36 |
| fold_tvars f (ZType1 (_, T)) = fold_tvars f T |
|
37 |
| fold_tvars f (ZType (_, Ts)) = fold (fold_tvars f) Ts |
|
38 |
| fold_tvars _ _ = I; |
|
39 |
||
40 |
fun fold_aterms f (ZApp (t, u)) = fold_aterms f t #> fold_aterms f u |
|
41 |
| fold_aterms f (ZAbs (_, _, t)) = fold_aterms f t |
|
42 |
| fold_aterms f a = f a; |
|
43 |
||
44 |
fun fold_types f (ZVar (_, T)) = f T |
|
45 |
| fold_types f (ZConst1 (_, T)) = f T |
|
46 |
| fold_types f (ZConst (_, As)) = fold f As |
|
47 |
| fold_types f (ZAbs (_, T, b)) = f T #> fold_types f b |
|
48 |
| fold_types f (ZApp (t, u)) = fold_types f t #> fold_types f u |
|
49 |
| fold_types f (ZClass (T, _)) = f T |
|
50 |
| fold_types _ _ = I; |
|
51 |
||
52 |
||
79264
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
53 |
(* type ordering *) |
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
54 |
|
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
55 |
local |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
56 |
|
79119 | 57 |
fun cons_nr (ZTVar _) = 0 |
58 |
| cons_nr (ZFun _) = 1 |
|
59 |
| cons_nr ZProp = 2 |
|
79420
4c3346b4b100
clarified datatype ztyp: omit special case that rarely occurs (thanks to ZClass and ZClassp);
wenzelm
parents:
79419
diff
changeset
|
60 |
| cons_nr (ZType0 _) = 3 |
4c3346b4b100
clarified datatype ztyp: omit special case that rarely occurs (thanks to ZClass and ZClassp);
wenzelm
parents:
79419
diff
changeset
|
61 |
| cons_nr (ZType1 _) = 4 |
4c3346b4b100
clarified datatype ztyp: omit special case that rarely occurs (thanks to ZClass and ZClassp);
wenzelm
parents:
79419
diff
changeset
|
62 |
| cons_nr (ZType _) = 5; |
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
63 |
|
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
64 |
val fast_indexname_ord = Term_Ord.fast_indexname_ord; |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
65 |
val sort_ord = Term_Ord.sort_ord; |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
66 |
|
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
67 |
in |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
68 |
|
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
69 |
fun ztyp_ord TU = |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
70 |
if pointer_eq TU then EQUAL |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
71 |
else |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
72 |
(case TU of |
79119 | 73 |
(ZTVar (a, A), ZTVar (b, B)) => |
74 |
(case fast_indexname_ord (a, b) of EQUAL => sort_ord (A, B) | ord => ord) |
|
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
75 |
| (ZFun (T, T'), ZFun (U, U')) => |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
76 |
(case ztyp_ord (T, U) of EQUAL => ztyp_ord (T', U') | ord => ord) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
77 |
| (ZProp, ZProp) => EQUAL |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
78 |
| (ZType0 a, ZType0 b) => fast_string_ord (a, b) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
79 |
| (ZType1 (a, T), ZType1 (b, U)) => |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
80 |
(case fast_string_ord (a, b) of EQUAL => ztyp_ord (T, U) | ord => ord) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
81 |
| (ZType (a, Ts), ZType (b, Us)) => |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
82 |
(case fast_string_ord (a, b) of EQUAL => dict_ord ztyp_ord (Ts, Us) | ord => ord) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
83 |
| (T, U) => int_ord (cons_nr T, cons_nr U)); |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
84 |
|
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
85 |
end; |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
86 |
|
79264
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
87 |
|
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
88 |
(* term ordering and alpha-conversion *) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
89 |
|
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
90 |
local |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
91 |
|
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
92 |
fun cons_nr (ZVar _) = 0 |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
93 |
| cons_nr (ZBound _) = 1 |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
94 |
| cons_nr (ZConst0 _) = 2 |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
95 |
| cons_nr (ZConst1 _) = 3 |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
96 |
| cons_nr (ZConst _) = 4 |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
97 |
| cons_nr (ZAbs _) = 5 |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
98 |
| cons_nr (ZApp _) = 6 |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
99 |
| cons_nr (ZClass _) = 7; |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
100 |
|
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
101 |
fun struct_ord tu = |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
102 |
if pointer_eq tu then EQUAL |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
103 |
else |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
104 |
(case tu of |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
105 |
(ZAbs (_, _, t), ZAbs (_, _, u)) => struct_ord (t, u) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
106 |
| (ZApp (t1, t2), ZApp (u1, u2)) => |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
107 |
(case struct_ord (t1, u1) of EQUAL => struct_ord (t2, u2) | ord => ord) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
108 |
| (t, u) => int_ord (cons_nr t, cons_nr u)); |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
109 |
|
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
110 |
fun atoms_ord tu = |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
111 |
if pointer_eq tu then EQUAL |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
112 |
else |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
113 |
(case tu of |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
114 |
(ZAbs (_, _, t), ZAbs (_, _, u)) => atoms_ord (t, u) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
115 |
| (ZApp (t1, t2), ZApp (u1, u2)) => |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
116 |
(case atoms_ord (t1, u1) of EQUAL => atoms_ord (t2, u2) | ord => ord) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
117 |
| (ZConst0 a, ZConst0 b) => fast_string_ord (a, b) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
118 |
| (ZConst1 (a, _), ZConst1 (b, _)) => fast_string_ord (a, b) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
119 |
| (ZConst (a, _), ZConst (b, _)) => fast_string_ord (a, b) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
120 |
| (ZVar (xi, _), ZVar (yj, _)) => Term_Ord.fast_indexname_ord (xi, yj) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
121 |
| (ZBound i, ZBound j) => int_ord (i, j) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
122 |
| (ZClass (_, a), ZClass (_, b)) => fast_string_ord (a, b) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
123 |
| _ => EQUAL); |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
124 |
|
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
125 |
fun types_ord tu = |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
126 |
if pointer_eq tu then EQUAL |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
127 |
else |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
128 |
(case tu of |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
129 |
(ZAbs (_, T, t), ZAbs (_, U, u)) => |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
130 |
(case ztyp_ord (T, U) of EQUAL => types_ord (t, u) | ord => ord) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
131 |
| (ZApp (t1, t2), ZApp (u1, u2)) => |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
132 |
(case types_ord (t1, u1) of EQUAL => types_ord (t2, u2) | ord => ord) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
133 |
| (ZConst1 (_, T), ZConst1 (_, U)) => ztyp_ord (T, U) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
134 |
| (ZConst (_, Ts), ZConst (_, Us)) => dict_ord ztyp_ord (Ts, Us) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
135 |
| (ZVar (_, T), ZVar (_, U)) => ztyp_ord (T, U) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
136 |
| (ZClass (T, _), ZClass (U, _)) => ztyp_ord (T, U) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
137 |
| _ => EQUAL); |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
138 |
|
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
139 |
in |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
140 |
|
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
141 |
val fast_zterm_ord = struct_ord ||| atoms_ord ||| types_ord; |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
142 |
|
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
143 |
end; |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
144 |
|
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
145 |
fun aconv_zterm (tm1, tm2) = |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
146 |
pointer_eq (tm1, tm2) orelse |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
147 |
(case (tm1, tm2) of |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
148 |
(ZApp (t1, u1), ZApp (t2, u2)) => aconv_zterm (t1, t2) andalso aconv_zterm (u1, u2) |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
149 |
| (ZAbs (_, T1, t1), ZAbs (_, T2, t2)) => aconv_zterm (t1, t2) andalso T1 = T2 |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
150 |
| (a1, a2) => a1 = a2); |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
151 |
|
79124 | 152 |
end; |
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
153 |
|
79124 | 154 |
|
79264
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
155 |
(* tables and term items *) |
79124 | 156 |
|
79163 | 157 |
structure ZTypes = Table(type key = ztyp val ord = ZTerm.ztyp_ord); |
79264
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
158 |
structure ZTerms = Table(type key = zterm val ord = ZTerm.fast_zterm_ord); |
79163 | 159 |
|
79124 | 160 |
structure ZTVars: |
161 |
sig |
|
162 |
include TERM_ITEMS |
|
163 |
val add_tvarsT: ztyp -> set -> set |
|
164 |
val add_tvars: zterm -> set -> set |
|
165 |
end = |
|
166 |
struct |
|
167 |
open TVars; |
|
168 |
val add_tvarsT = ZTerm.fold_tvars add_set; |
|
169 |
val add_tvars = ZTerm.fold_types add_tvarsT; |
|
170 |
end; |
|
171 |
||
172 |
structure ZVars: |
|
173 |
sig |
|
174 |
include TERM_ITEMS |
|
175 |
val add_vars: zterm -> set -> set |
|
176 |
end = |
|
177 |
struct |
|
178 |
||
179 |
structure Term_Items = Term_Items |
|
180 |
( |
|
181 |
type key = indexname * ztyp; |
|
182 |
val ord = pointer_eq_ord (prod_ord Term_Ord.fast_indexname_ord ZTerm.ztyp_ord); |
|
183 |
); |
|
184 |
open Term_Items; |
|
185 |
||
186 |
val add_vars = ZTerm.fold_aterms (fn ZVar v => add_set v | _ => I); |
|
187 |
||
188 |
end; |
|
189 |
||
190 |
||
191 |
(* proofs *) |
|
192 |
||
79126 | 193 |
datatype zproof_name = |
194 |
ZAxiom of string |
|
195 |
| ZOracle of string |
|
79313
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79312
diff
changeset
|
196 |
| ZBox of serial |
79361 | 197 |
| ZThm of {theory_name: string, thm_name: Thm_Name.T * Position.T, serial: int}; |
79126 | 198 |
|
79124 | 199 |
datatype zproof = |
200 |
ZDummy (*dummy proof*) |
|
79212 | 201 |
| ZConstp of zproof_name * zterm * ztyp ZTVars.table * zterm ZVars.table |
202 |
| ZBoundp of int |
|
79124 | 203 |
| ZHyp of zterm |
204 |
| ZAbst of string * ztyp * zproof |
|
79212 | 205 |
| ZAbsp of string * zterm * zproof |
79124 | 206 |
| ZAppt of zproof * zterm |
79212 | 207 |
| ZAppp of zproof * zproof |
208 |
| ZClassp of ztyp * class; (*OFCLASS proof from sorts algebra*) |
|
79124 | 209 |
|
210 |
||
211 |
||
212 |
(*** local ***) |
|
213 |
||
214 |
signature ZTERM = |
|
215 |
sig |
|
216 |
datatype ztyp = datatype ztyp |
|
217 |
datatype zterm = datatype zterm |
|
218 |
datatype zproof = datatype zproof |
|
79265 | 219 |
exception ZTERM of string * ztyp list * zterm list * zproof list |
79263 | 220 |
type zproof_const = zproof_name * zterm * ztyp ZTVars.table * zterm ZVars.table |
79124 | 221 |
val fold_tvars: (indexname * sort -> 'a -> 'a) -> ztyp -> 'a -> 'a |
222 |
val fold_aterms: (zterm -> 'a -> 'a) -> zterm -> 'a -> 'a |
|
223 |
val fold_types: (ztyp -> 'a -> 'a) -> zterm -> 'a -> 'a |
|
79264
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
224 |
val ztyp_ord: ztyp ord |
07b93dee105f
more operations: zterm ordering that follows fast_term_ord;
wenzelm
parents:
79263
diff
changeset
|
225 |
val fast_zterm_ord: zterm ord |
79124 | 226 |
val aconv_zterm: zterm * zterm -> bool |
79212 | 227 |
val ZAbsts: (string * ztyp) list -> zproof -> zproof |
228 |
val ZAbsps: zterm list -> zproof -> zproof |
|
229 |
val ZAppts: zproof * zterm list -> zproof |
|
230 |
val ZAppps: zproof * zproof list -> zproof |
|
79200 | 231 |
val incr_bv_same: int -> int -> zterm Same.operation |
79283 | 232 |
val incr_proof_bv_same: int -> int -> int -> int -> zproof Same.operation |
79200 | 233 |
val incr_bv: int -> int -> zterm -> zterm |
234 |
val incr_boundvars: int -> zterm -> zterm |
|
79283 | 235 |
val incr_proof_bv: int -> int -> int -> int -> zproof -> zproof |
236 |
val incr_proof_boundvars: int -> int -> zproof -> zproof |
|
237 |
val subst_term_bound_same: zterm -> int -> zterm Same.operation |
|
238 |
val subst_proof_bound_same: zterm -> int -> zproof Same.operation |
|
239 |
val subst_proof_boundp_same: zproof -> int -> int -> zproof Same.operation |
|
240 |
val subst_term_bound: zterm -> zterm -> zterm |
|
241 |
val subst_proof_bound: zterm -> zproof -> zproof |
|
242 |
val subst_proof_boundp: zproof -> zproof -> zproof |
|
79388 | 243 |
val subst_type_same: (indexname * sort, ztyp) Same.function -> ztyp Same.operation |
244 |
val subst_term_same: |
|
245 |
ztyp Same.operation -> (indexname * ztyp, zterm) Same.function -> zterm Same.operation |
|
79318 | 246 |
exception BAD_INST of ((indexname * ztyp) * zterm) list |
79418 | 247 |
val map_proof: {hyps: bool} -> ztyp Same.operation -> zterm Same.operation -> zproof -> zproof |
248 |
val map_proof_types: {hyps: bool} -> ztyp Same.operation -> zproof -> zproof |
|
79414 | 249 |
val map_class_proof: (ztyp * class, zproof) Same.function -> zproof -> zproof |
79124 | 250 |
val ztyp_of: typ -> ztyp |
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
251 |
val zterm_cache: theory -> {zterm: term -> zterm, ztyp: typ -> ztyp} |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
252 |
val zterm_of: theory -> term -> zterm |
79124 | 253 |
val typ_of: ztyp -> typ |
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
254 |
val term_of: theory -> zterm -> term |
79298 | 255 |
val beta_norm_term_same: zterm Same.operation |
256 |
val beta_norm_proof_same: zproof Same.operation |
|
79302
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
257 |
val beta_norm_prooft_same: zproof -> zproof |
79298 | 258 |
val beta_norm_term: zterm -> zterm |
259 |
val beta_norm_proof: zproof -> zproof |
|
79302
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
260 |
val beta_norm_prooft: zproof -> zproof |
79200 | 261 |
val norm_type: Type.tyenv -> ztyp -> ztyp |
262 |
val norm_term: theory -> Envir.env -> zterm -> zterm |
|
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
263 |
val norm_proof: theory -> Envir.env -> term list -> zproof -> zproof |
79311
e4a9a861856b
omit pointless future: proof terms are built sequentially;
wenzelm
parents:
79303
diff
changeset
|
264 |
type zbox = serial * (zterm * zproof) |
79279 | 265 |
val zbox_ord: zbox ord |
266 |
type zboxes = zbox Ord_List.T |
|
79265 | 267 |
val union_zboxes: zboxes -> zboxes -> zboxes |
79279 | 268 |
val unions_zboxes: zboxes list -> zboxes |
79425 | 269 |
val add_box_proof: {unconstrain: bool} -> theory -> |
270 |
term list -> term -> zproof -> zboxes -> zproof * zboxes |
|
79329 | 271 |
val thm_proof: theory -> Thm_Name.T * Position.T -> term list -> term -> zproof -> zbox * zproof |
79126 | 272 |
val axiom_proof: theory -> string -> term -> zproof |
273 |
val oracle_proof: theory -> string -> term -> zproof |
|
79124 | 274 |
val assume_proof: theory -> term -> zproof |
275 |
val trivial_proof: theory -> term -> zproof |
|
79414 | 276 |
val implies_intr_proof': zterm -> zproof -> zproof |
79124 | 277 |
val implies_intr_proof: theory -> term -> zproof -> zproof |
278 |
val forall_intr_proof: theory -> typ -> string * term -> zproof -> zproof |
|
279 |
val forall_elim_proof: theory -> term -> zproof -> zproof |
|
79128 | 280 |
val of_class_proof: typ * class -> zproof |
79124 | 281 |
val reflexive_proof: theory -> typ -> term -> zproof |
282 |
val symmetric_proof: theory -> typ -> term -> term -> zproof -> zproof |
|
283 |
val transitive_proof: theory -> typ -> term -> term -> term -> zproof -> zproof -> zproof |
|
284 |
val equal_intr_proof: theory -> term -> term -> zproof -> zproof -> zproof |
|
285 |
val equal_elim_proof: theory -> term -> term -> zproof -> zproof -> zproof |
|
286 |
val abstract_rule_proof: theory -> typ -> typ -> string * term -> term -> term -> zproof -> zproof |
|
287 |
val combination_proof: theory -> typ -> typ -> term -> term -> term -> term -> |
|
288 |
zproof -> zproof -> zproof |
|
79133 | 289 |
val generalize_proof: Names.set * Names.set -> int -> zproof -> zproof |
79149 | 290 |
val instantiate_proof: theory -> |
291 |
((indexname * sort) * typ) list * ((indexname * typ) * term) list -> zproof -> zproof |
|
79135 | 292 |
val varifyT_proof: ((string * sort) * (indexname * sort)) list -> zproof -> zproof |
79152 | 293 |
val legacy_freezeT_proof: term -> zproof -> zproof |
79155 | 294 |
val rotate_proof: theory -> term list -> term -> (string * typ) list -> |
295 |
term list -> int -> zproof -> zproof |
|
296 |
val permute_prems_proof: theory -> term list -> int -> int -> zproof -> zproof |
|
79234 | 297 |
val incr_indexes_proof: int -> zproof -> zproof |
79237 | 298 |
val lift_proof: theory -> term -> int -> term list -> zproof -> zproof |
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
299 |
val assumption_proof: theory -> Envir.env -> term list -> term -> int -> term list -> |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
300 |
zproof -> zproof |
79261 | 301 |
val bicompose_proof: theory -> Envir.env -> int -> bool -> term list -> term list -> |
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
302 |
term option -> term list -> int -> int -> term list -> zproof -> zproof -> zproof |
79425 | 303 |
type sorts_proof = (class * class -> zproof) * (string * class list list * class -> zproof) |
304 |
val of_sort_proof: Sorts.algebra -> sorts_proof -> (typ * class -> zproof) -> |
|
79405 | 305 |
typ * sort -> zproof list |
79425 | 306 |
val unconstrainT_proof: theory -> sorts_proof -> Logic.unconstrain_context -> zproof -> zproof |
79124 | 307 |
end; |
308 |
||
309 |
structure ZTerm: ZTERM = |
|
310 |
struct |
|
311 |
||
312 |
datatype ztyp = datatype ztyp; |
|
313 |
datatype zterm = datatype zterm; |
|
314 |
datatype zproof = datatype zproof; |
|
315 |
||
79265 | 316 |
exception ZTERM of string * ztyp list * zterm list * zproof list; |
317 |
||
79124 | 318 |
open ZTerm; |
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
319 |
|
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
320 |
|
79155 | 321 |
(* derived operations *) |
322 |
||
79234 | 323 |
val ZFuns = Library.foldr ZFun; |
324 |
||
79212 | 325 |
val ZAbsts = fold_rev (fn (x, T) => fn prf => ZAbst (x, T, prf)); |
326 |
val ZAbsps = fold_rev (fn t => fn prf => ZAbsp ("H", t, prf)); |
|
79155 | 327 |
|
79212 | 328 |
val ZAppts = Library.foldl ZAppt; |
329 |
val ZAppps = Library.foldl ZAppp; |
|
79155 | 330 |
|
79234 | 331 |
fun combound (t, n, k) = |
332 |
if k > 0 then ZApp (combound (t, n + 1, k - 1), ZBound n) else t; |
|
333 |
||
79155 | 334 |
|
79283 | 335 |
(* increment bound variables *) |
79200 | 336 |
|
337 |
fun incr_bv_same inc = |
|
338 |
if inc = 0 then fn _ => Same.same |
|
339 |
else |
|
340 |
let |
|
79285 | 341 |
fun term lev (ZBound i) = |
342 |
if i >= lev then ZBound (i + inc) else raise Same.SAME |
|
79200 | 343 |
| term lev (ZAbs (a, T, t)) = ZAbs (a, T, term (lev + 1) t) |
344 |
| term lev (ZApp (t, u)) = |
|
79285 | 345 |
(ZApp (term lev t, Same.commit (term lev) u) |
346 |
handle Same.SAME => ZApp (t, term lev u)) |
|
79200 | 347 |
| term _ _ = raise Same.SAME; |
348 |
in term end; |
|
349 |
||
79283 | 350 |
fun incr_proof_bv_same incp inct = |
351 |
if incp = 0 andalso inct = 0 then fn _ => fn _ => Same.same |
|
352 |
else |
|
353 |
let |
|
354 |
val term = incr_bv_same inct; |
|
79200 | 355 |
|
79283 | 356 |
fun proof plev _ (ZBoundp i) = |
357 |
if i >= plev then ZBoundp (i + incp) else raise Same.SAME |
|
358 |
| proof plev tlev (ZAbsp (a, t, p)) = |
|
359 |
(ZAbsp (a, term tlev t, Same.commit (proof (plev + 1) tlev) p) |
|
360 |
handle Same.SAME => ZAbsp (a, t, proof (plev + 1) tlev p)) |
|
361 |
| proof plev tlev (ZAbst (a, T, p)) = ZAbst (a, T, proof plev (tlev + 1) p) |
|
362 |
| proof plev tlev (ZAppp (p, q)) = |
|
363 |
(ZAppp (proof plev tlev p, Same.commit (proof plev tlev) q) |
|
364 |
handle Same.SAME => ZAppp (p, proof plev tlev q)) |
|
365 |
| proof plev tlev (ZAppt (p, t)) = |
|
366 |
(ZAppt (proof plev tlev p, Same.commit (term tlev) t) |
|
367 |
handle Same.SAME => ZAppt (p, term tlev t)) |
|
368 |
| proof _ _ _ = raise Same.SAME; |
|
369 |
in proof end; |
|
370 |
||
371 |
fun incr_bv inc lev = Same.commit (incr_bv_same inc lev); |
|
79200 | 372 |
fun incr_boundvars inc = incr_bv inc 0; |
373 |
||
79283 | 374 |
fun incr_proof_bv incp inct plev tlev = Same.commit (incr_proof_bv_same incp inct plev tlev); |
375 |
fun incr_proof_boundvars incp inct = incr_proof_bv incp inct 0 0; |
|
376 |
||
377 |
||
378 |
(* substitution of bound variables *) |
|
379 |
||
79281
28342f38da5c
clarified signature, following Term.subst_bounds_same;
wenzelm
parents:
79279
diff
changeset
|
380 |
fun subst_term_bound_same arg = |
79200 | 381 |
let |
382 |
fun term lev (ZBound i) = |
|
383 |
if i < lev then raise Same.SAME (*var is locally bound*) |
|
384 |
else if i = lev then incr_boundvars lev arg |
|
385 |
else ZBound (i - 1) (*loose: change it*) |
|
386 |
| term lev (ZAbs (a, T, t)) = ZAbs (a, T, term (lev + 1) t) |
|
387 |
| term lev (ZApp (t, u)) = |
|
388 |
(ZApp (term lev t, Same.commit (term lev) u) |
|
389 |
handle Same.SAME => ZApp (t, term lev u)) |
|
390 |
| term _ _ = raise Same.SAME; |
|
79281
28342f38da5c
clarified signature, following Term.subst_bounds_same;
wenzelm
parents:
79279
diff
changeset
|
391 |
in term end; |
28342f38da5c
clarified signature, following Term.subst_bounds_same;
wenzelm
parents:
79279
diff
changeset
|
392 |
|
79283 | 393 |
fun subst_proof_bound_same arg = |
394 |
let |
|
395 |
val term = subst_term_bound_same arg; |
|
396 |
||
397 |
fun proof lev (ZAbsp (a, t, p)) = |
|
398 |
(ZAbsp (a, term lev t, Same.commit (proof lev) p) |
|
399 |
handle Same.SAME => ZAbsp (a, t, proof lev p)) |
|
400 |
| proof lev (ZAbst (a, T, p)) = ZAbst (a, T, proof (lev + 1) p) |
|
401 |
| proof lev (ZAppp (p, q)) = |
|
402 |
(ZAppp (proof lev p, Same.commit (proof lev) q) |
|
403 |
handle Same.SAME => ZAppp (p, proof lev q)) |
|
404 |
| proof lev (ZAppt (p, t)) = |
|
405 |
(ZAppt (proof lev p, Same.commit (term lev) t) |
|
406 |
handle Same.SAME => ZAppt (p, term lev t)) |
|
407 |
| proof _ _ = raise Same.SAME; |
|
408 |
in proof end; |
|
409 |
||
410 |
fun subst_proof_boundp_same arg = |
|
411 |
let |
|
412 |
fun proof plev tlev (ZBoundp i) = |
|
413 |
if i < plev then raise Same.SAME (*var is locally bound*) |
|
414 |
else if i = plev then incr_proof_boundvars plev tlev arg |
|
415 |
else ZBoundp (i - 1) (*loose: change it*) |
|
416 |
| proof plev tlev (ZAbsp (a, t, p)) = ZAbsp (a, t, proof (plev + 1) tlev p) |
|
417 |
| proof plev tlev (ZAbst (a, T, p)) = ZAbst (a, T, proof plev (tlev + 1) p) |
|
418 |
| proof plev tlev (ZAppp (p, q)) = |
|
419 |
(ZAppp (proof plev tlev p, Same.commit (proof plev tlev) q) |
|
420 |
handle Same.SAME => ZAppp (p, proof plev tlev q)) |
|
421 |
| proof plev tlev (ZAppt (p, t)) = ZAppt (proof plev tlev p, t) |
|
422 |
| proof _ _ _ = raise Same.SAME; |
|
423 |
in proof end; |
|
424 |
||
425 |
fun subst_term_bound arg body = Same.commit (subst_term_bound_same arg 0) body; |
|
426 |
fun subst_proof_bound arg body = Same.commit (subst_proof_bound_same arg 0) body; |
|
427 |
fun subst_proof_boundp arg body = Same.commit (subst_proof_boundp_same arg 0 0) body; |
|
79200 | 428 |
|
429 |
||
79268 | 430 |
(* substitution of free or schematic variables *) |
79132 | 431 |
|
432 |
fun subst_type_same tvar = |
|
433 |
let |
|
434 |
fun typ (ZTVar x) = tvar x |
|
79326 | 435 |
| typ (ZFun (T, U)) = |
436 |
(ZFun (typ T, Same.commit typ U) |
|
437 |
handle Same.SAME => ZFun (T, typ U)) |
|
79132 | 438 |
| typ ZProp = raise Same.SAME |
439 |
| typ (ZType0 _) = raise Same.SAME |
|
440 |
| typ (ZType1 (a, T)) = ZType1 (a, typ T) |
|
441 |
| typ (ZType (a, Ts)) = ZType (a, Same.map typ Ts); |
|
442 |
in typ end; |
|
443 |
||
444 |
fun subst_term_same typ var = |
|
445 |
let |
|
446 |
fun term (ZVar (x, T)) = |
|
447 |
let val (T', same) = Same.commit_id typ T in |
|
448 |
(case Same.catch var (x, T') of |
|
449 |
NONE => if same then raise Same.SAME else ZVar (x, T') |
|
450 |
| SOME t' => t') |
|
451 |
end |
|
452 |
| term (ZBound _) = raise Same.SAME |
|
453 |
| term (ZConst0 _) = raise Same.SAME |
|
454 |
| term (ZConst1 (a, T)) = ZConst1 (a, typ T) |
|
455 |
| term (ZConst (a, Ts)) = ZConst (a, Same.map typ Ts) |
|
456 |
| term (ZAbs (a, T, t)) = |
|
79326 | 457 |
(ZAbs (a, typ T, Same.commit term t) |
458 |
handle Same.SAME => ZAbs (a, T, term t)) |
|
79132 | 459 |
| term (ZApp (t, u)) = |
79326 | 460 |
(ZApp (term t, Same.commit term u) |
461 |
handle Same.SAME => ZApp (t, term u)) |
|
79132 | 462 |
| term (ZClass (T, c)) = ZClass (typ T, c); |
463 |
in term end; |
|
464 |
||
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
465 |
fun instantiate_type_same instT = |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
466 |
if ZTVars.is_empty instT then Same.same |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
467 |
else ZTypes.unsynchronized_cache (subst_type_same (Same.function (ZTVars.lookup instT))); |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
468 |
|
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
469 |
fun instantiate_term_same typ inst = |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
470 |
subst_term_same typ (Same.function (ZVars.lookup inst)); |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
471 |
|
79268 | 472 |
|
473 |
(* map types/terms within proof *) |
|
474 |
||
79318 | 475 |
exception BAD_INST of ((indexname * ztyp) * zterm) list |
476 |
||
477 |
fun make_inst inst = |
|
79320
bbac3e8a5070
more permissive: allow collapse of term variables for equal results, e.g. relevant for metis (line 1882 of "~~/src/HOL/List.thy");
wenzelm
parents:
79318
diff
changeset
|
478 |
ZVars.build (inst |> fold (ZVars.insert (op aconv_zterm))) |
bbac3e8a5070
more permissive: allow collapse of term variables for equal results, e.g. relevant for metis (line 1882 of "~~/src/HOL/List.thy");
wenzelm
parents:
79318
diff
changeset
|
479 |
handle ZVars.DUP _ => raise BAD_INST inst; |
79318 | 480 |
|
79145 | 481 |
fun map_insts_same typ term (instT, inst) = |
482 |
let |
|
483 |
val changed = Unsynchronized.ref false; |
|
79146
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
484 |
fun apply f x = |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
485 |
(case Same.catch f x of |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
486 |
NONE => NONE |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
487 |
| some => (changed := true; some)); |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
488 |
|
79145 | 489 |
val instT' = |
490 |
(instT, instT) |-> ZTVars.fold (fn (v, T) => |
|
79146
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
491 |
(case apply typ T of |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
492 |
NONE => I |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
493 |
| SOME T' => ZTVars.update (v, T'))); |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
494 |
|
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
495 |
val vars' = |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
496 |
(inst, ZVars.empty) |-> ZVars.fold (fn ((v, T), _) => |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
497 |
(case apply typ T of |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
498 |
NONE => I |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
499 |
| SOME T' => ZVars.add ((v, T), (v, T')))); |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
500 |
|
79145 | 501 |
val inst' = |
79146
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
502 |
if ZVars.is_empty vars' then |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
503 |
(inst, inst) |-> ZVars.fold (fn (v, t) => |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
504 |
(case apply term t of |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
505 |
NONE => I |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
506 |
| SOME t' => ZVars.update (v, t'))) |
feb94ac5df41
more accurate treatment of term variables after instantiation of type variables;
wenzelm
parents:
79145
diff
changeset
|
507 |
else |
79325 | 508 |
build (inst |> ZVars.fold_rev (fn (v, t) => |
509 |
cons (the_default v (ZVars.lookup vars' v), the_default t (apply term t)))) |
|
79318 | 510 |
|> make_inst; |
79145 | 511 |
in if ! changed then (instT', inst') else raise Same.SAME end; |
512 |
||
79418 | 513 |
fun map_proof_same {hyps} typ term = |
79132 | 514 |
let |
515 |
fun proof ZDummy = raise Same.SAME |
|
79212 | 516 |
| proof (ZConstp (a, A, instT, inst)) = |
79148
99201e7b1d94
proper treatment of ZConstP: term represents body of closure;
wenzelm
parents:
79147
diff
changeset
|
517 |
let val (instT', inst') = map_insts_same typ term (instT, inst) |
79212 | 518 |
in ZConstp (a, A, instT', inst') end |
519 |
| proof (ZBoundp _) = raise Same.SAME |
|
79418 | 520 |
| proof (ZHyp h) = if hyps then ZHyp (term h) else raise Same.SAME |
79132 | 521 |
| proof (ZAbst (a, T, p)) = |
79326 | 522 |
(ZAbst (a, typ T, Same.commit proof p) |
523 |
handle Same.SAME => ZAbst (a, T, proof p)) |
|
79212 | 524 |
| proof (ZAbsp (a, t, p)) = |
79326 | 525 |
(ZAbsp (a, term t, Same.commit proof p) |
526 |
handle Same.SAME => ZAbsp (a, t, proof p)) |
|
79132 | 527 |
| proof (ZAppt (p, t)) = |
79326 | 528 |
(ZAppt (proof p, Same.commit term t) |
529 |
handle Same.SAME => ZAppt (p, term t)) |
|
79212 | 530 |
| proof (ZAppp (p, q)) = |
79326 | 531 |
(ZAppp (proof p, Same.commit proof q) |
532 |
handle Same.SAME => ZAppp (p, proof q)) |
|
79474 | 533 |
| proof (ZClassp (T, c)) = if hyps then ZClassp (typ T, c) else raise Same.SAME; |
79132 | 534 |
in proof end; |
535 |
||
79418 | 536 |
fun map_proof hyps typ term = Same.commit (map_proof_same hyps typ term); |
537 |
fun map_proof_types hyps typ = map_proof hyps typ (subst_term_same typ Same.same); |
|
79144 | 538 |
|
79124 | 539 |
|
79414 | 540 |
(* map class proofs *) |
541 |
||
542 |
fun map_class_proof class = |
|
543 |
let |
|
79415 | 544 |
fun proof (ZClassp C) = class C |
79414 | 545 |
| proof (ZAbst (a, T, p)) = ZAbst (a, T, proof p) |
546 |
| proof (ZAbsp (a, t, p)) = ZAbsp (a, t, proof p) |
|
547 |
| proof (ZAppt (p, t)) = ZAppt (proof p, t) |
|
548 |
| proof (ZAppp (p, q)) = |
|
549 |
(ZAppp (proof p, Same.commit proof q) |
|
550 |
handle Same.SAME => ZAppp (p, proof q)) |
|
551 |
| proof _ = raise Same.SAME; |
|
552 |
in Same.commit proof end; |
|
553 |
||
554 |
||
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
555 |
(* convert ztyp / zterm vs. regular typ / term *) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
556 |
|
79119 | 557 |
fun ztyp_of (TFree (a, S)) = ZTVar ((a, ~1), S) |
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
558 |
| ztyp_of (TVar v) = ZTVar v |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
559 |
| ztyp_of (Type ("fun", [T, U])) = ZFun (ztyp_of T, ztyp_of U) |
79421 | 560 |
| ztyp_of (Type ("prop", [])) = ZProp |
561 |
| ztyp_of (Type (c, [])) = ZType0 c |
|
79420
4c3346b4b100
clarified datatype ztyp: omit special case that rarely occurs (thanks to ZClass and ZClassp);
wenzelm
parents:
79419
diff
changeset
|
562 |
| ztyp_of (Type (c, [T])) = ZType1 (c, ztyp_of T) |
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
563 |
| ztyp_of (Type (c, ts)) = ZType (c, map ztyp_of ts); |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
564 |
|
79163 | 565 |
fun ztyp_cache () = Typtab.unsynchronized_cache ztyp_of; |
566 |
||
79226 | 567 |
fun zterm_cache thy = |
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
568 |
let |
79226 | 569 |
val typargs = Consts.typargs (Sign.consts_of thy); |
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
570 |
|
79163 | 571 |
val ztyp = ztyp_cache (); |
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
572 |
|
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
573 |
fun zterm (Free (x, T)) = ZVar ((x, ~1), ztyp T) |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
574 |
| zterm (Var (xi, T)) = ZVar (xi, ztyp T) |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
575 |
| zterm (Bound i) = ZBound i |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
576 |
| zterm (Const (c, T)) = |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
577 |
(case typargs (c, T) of |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
578 |
[] => ZConst0 c |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
579 |
| [T] => ZConst1 (c, ztyp T) |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
580 |
| Ts => ZConst (c, map ztyp Ts)) |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
581 |
| zterm (Abs (a, T, b)) = ZAbs (a, ztyp T, zterm b) |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
582 |
| zterm ((t as Const (c, _)) $ (u as Const ("Pure.type", _))) = |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
583 |
if String.isSuffix Logic.class_suffix c then |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
584 |
ZClass (ztyp (Logic.dest_type u), Logic.class_of_const c) |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
585 |
else ZApp (zterm t, zterm u) |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
586 |
| zterm (t $ u) = ZApp (zterm t, zterm u); |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
587 |
in {ztyp = ztyp, zterm = zterm} end; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
588 |
|
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
589 |
val zterm_of = #zterm o zterm_cache; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
590 |
|
79119 | 591 |
fun typ_of (ZTVar ((a, ~1), S)) = TFree (a, S) |
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
592 |
| typ_of (ZTVar v) = TVar v |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
593 |
| typ_of (ZFun (T, U)) = typ_of T --> typ_of U |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
594 |
| typ_of ZProp = propT |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
595 |
| typ_of (ZType0 c) = Type (c, []) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
596 |
| typ_of (ZType1 (c, T)) = Type (c, [typ_of T]) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
597 |
| typ_of (ZType (c, Ts)) = Type (c, map typ_of Ts); |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
598 |
|
79201 | 599 |
fun typ_cache () = ZTypes.unsynchronized_cache typ_of; |
600 |
||
79226 | 601 |
fun term_of thy = |
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
602 |
let |
79226 | 603 |
val instance = Consts.instance (Sign.consts_of thy); |
604 |
||
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
605 |
fun const (c, Ts) = Const (c, instance (c, Ts)); |
79226 | 606 |
|
79119 | 607 |
fun term (ZVar ((x, ~1), T)) = Free (x, typ_of T) |
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
608 |
| term (ZVar (xi, T)) = Var (xi, typ_of T) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
609 |
| term (ZBound i) = Bound i |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
610 |
| term (ZConst0 c) = const (c, []) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
611 |
| term (ZConst1 (c, T)) = const (c, [typ_of T]) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
612 |
| term (ZConst (c, Ts)) = const (c, map typ_of Ts) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
613 |
| term (ZAbs (a, T, b)) = Abs (a, typ_of T, term b) |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
614 |
| term (ZApp (t, u)) = term t $ term u |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
615 |
| term (ZClass (T, c)) = Logic.mk_of_class (typ_of T, c); |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
616 |
in term end; |
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
617 |
|
79119 | 618 |
|
79298 | 619 |
(* beta contraction *) |
79200 | 620 |
|
79286 | 621 |
val beta_norm_term_same = |
79271 | 622 |
let |
79299 | 623 |
fun norm (ZAbs (a, T, t)) = ZAbs (a, T, Same.commit norm t) |
624 |
| norm (ZApp (ZAbs (_, _, body), t)) = Same.commit norm (subst_term_bound t body) |
|
79271 | 625 |
| norm (ZApp (f, t)) = |
626 |
((case norm f of |
|
79286 | 627 |
ZAbs (_, _, body) => Same.commit norm (subst_term_bound t body) |
79271 | 628 |
| nf => ZApp (nf, Same.commit norm t)) |
629 |
handle Same.SAME => ZApp (f, norm t)) |
|
630 |
| norm _ = raise Same.SAME; |
|
631 |
in norm end; |
|
632 |
||
79302
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
633 |
val beta_norm_prooft_same = |
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
634 |
let |
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
635 |
val term = beta_norm_term_same; |
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
636 |
|
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
637 |
fun norm (ZAbst (a, T, p)) = ZAbst (a, T, norm p) |
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
638 |
| norm (ZAppt (ZAbst (_, _, body), t)) = Same.commit norm (subst_proof_bound t body) |
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
639 |
| norm (ZAppt (f, t)) = |
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
640 |
((case norm f of |
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
641 |
ZAbst (_, _, body) => Same.commit norm (subst_proof_bound t body) |
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
642 |
| nf => ZAppt (nf, Same.commit term t)) |
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
643 |
handle Same.SAME => ZAppt (f, term t)) |
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
644 |
| norm _ = raise Same.SAME; |
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
645 |
in norm end; |
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
646 |
|
79286 | 647 |
val beta_norm_proof_same = |
648 |
let |
|
649 |
val term = beta_norm_term_same; |
|
650 |
||
79300
236fa4b32afb
more thorough beta contraction, following Envir.norm_term;
wenzelm
parents:
79299
diff
changeset
|
651 |
fun norm (ZAbst (a, T, p)) = ZAbst (a, T, norm p) |
236fa4b32afb
more thorough beta contraction, following Envir.norm_term;
wenzelm
parents:
79299
diff
changeset
|
652 |
| norm (ZAbsp (a, t, p)) = |
236fa4b32afb
more thorough beta contraction, following Envir.norm_term;
wenzelm
parents:
79299
diff
changeset
|
653 |
(ZAbsp (a, term t, Same.commit norm p) |
236fa4b32afb
more thorough beta contraction, following Envir.norm_term;
wenzelm
parents:
79299
diff
changeset
|
654 |
handle Same.SAME => ZAbsp (a, t, norm p)) |
236fa4b32afb
more thorough beta contraction, following Envir.norm_term;
wenzelm
parents:
79299
diff
changeset
|
655 |
| norm (ZAppt (ZAbst (_, _, body), t)) = Same.commit norm (subst_proof_bound t body) |
79301 | 656 |
| norm (ZAppp (ZAbsp (_, _, body), p)) = Same.commit norm (subst_proof_boundp p body) |
79286 | 657 |
| norm (ZAppt (f, t)) = |
658 |
((case norm f of |
|
659 |
ZAbst (_, _, body) => Same.commit norm (subst_proof_bound t body) |
|
660 |
| nf => ZAppt (nf, Same.commit term t)) |
|
661 |
handle Same.SAME => ZAppt (f, term t)) |
|
662 |
| norm (ZAppp (f, p)) = |
|
663 |
((case norm f of |
|
664 |
ZAbsp (_, _, body) => Same.commit norm (subst_proof_boundp p body) |
|
665 |
| nf => ZAppp (nf, Same.commit norm p)) |
|
666 |
handle Same.SAME => ZAppp (f, norm p)) |
|
667 |
| norm _ = raise Same.SAME; |
|
668 |
in norm end; |
|
669 |
||
79298 | 670 |
val beta_norm_term = Same.commit beta_norm_term_same; |
671 |
val beta_norm_proof = Same.commit beta_norm_proof_same; |
|
79302
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
672 |
val beta_norm_prooft = Same.commit beta_norm_prooft_same; |
79298 | 673 |
|
674 |
||
675 |
(* normalization wrt. environment and beta contraction *) |
|
676 |
||
79200 | 677 |
fun norm_type_same ztyp tyenv = |
678 |
if Vartab.is_empty tyenv then Same.same |
|
679 |
else |
|
680 |
let |
|
681 |
fun norm (ZTVar v) = |
|
682 |
(case Type.lookup tyenv v of |
|
683 |
SOME U => Same.commit norm (ztyp U) |
|
684 |
| NONE => raise Same.SAME) |
|
685 |
| norm (ZFun (T, U)) = |
|
686 |
(ZFun (norm T, Same.commit norm U) |
|
687 |
handle Same.SAME => ZFun (T, norm U)) |
|
688 |
| norm ZProp = raise Same.SAME |
|
689 |
| norm (ZType0 _) = raise Same.SAME |
|
690 |
| norm (ZType1 (a, T)) = ZType1 (a, norm T) |
|
691 |
| norm (ZType (a, Ts)) = ZType (a, Same.map norm Ts); |
|
692 |
in norm end; |
|
693 |
||
79269 | 694 |
fun norm_term_same {ztyp, zterm, typ} (envir as Envir.Envir {tyenv, tenv, ...}) = |
695 |
let |
|
696 |
val lookup = |
|
697 |
if Vartab.is_empty tenv then K NONE |
|
698 |
else ZVars.unsynchronized_cache (apsnd typ #> Envir.lookup envir #> Option.map zterm); |
|
79200 | 699 |
|
79269 | 700 |
val normT = norm_type_same ztyp tyenv; |
79200 | 701 |
|
79269 | 702 |
fun norm (ZVar (xi, T)) = |
703 |
(case lookup (xi, T) of |
|
704 |
SOME u => Same.commit norm u |
|
705 |
| NONE => ZVar (xi, normT T)) |
|
706 |
| norm (ZBound _) = raise Same.SAME |
|
707 |
| norm (ZConst0 _) = raise Same.SAME |
|
708 |
| norm (ZConst1 (a, T)) = ZConst1 (a, normT T) |
|
709 |
| norm (ZConst (a, Ts)) = ZConst (a, Same.map normT Ts) |
|
710 |
| norm (ZAbs (a, T, t)) = |
|
711 |
(ZAbs (a, normT T, Same.commit norm t) |
|
712 |
handle Same.SAME => ZAbs (a, T, norm t)) |
|
79281
28342f38da5c
clarified signature, following Term.subst_bounds_same;
wenzelm
parents:
79279
diff
changeset
|
713 |
| norm (ZApp (ZAbs (_, _, body), t)) = Same.commit norm (subst_term_bound t body) |
79269 | 714 |
| norm (ZApp (f, t)) = |
715 |
((case norm f of |
|
79281
28342f38da5c
clarified signature, following Term.subst_bounds_same;
wenzelm
parents:
79279
diff
changeset
|
716 |
ZAbs (_, _, body) => Same.commit norm (subst_term_bound t body) |
79269 | 717 |
| nf => ZApp (nf, Same.commit norm t)) |
718 |
handle Same.SAME => ZApp (f, norm t)) |
|
719 |
| norm _ = raise Same.SAME; |
|
79286 | 720 |
in fn t => if Envir.is_empty envir then beta_norm_term_same t else norm t end; |
79200 | 721 |
|
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
722 |
fun norm_proof_cache (cache as {ztyp, ...}) (envir as Envir.Envir {tyenv, ...}) = |
79269 | 723 |
let |
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
724 |
val norm_tvar = ZTVar #> Same.commit (norm_type_same ztyp tyenv); |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
725 |
val norm_var = ZVar #> Same.commit (norm_term_same cache envir); |
79269 | 726 |
in |
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
727 |
fn visible => fn prf => |
79302
fed9791928bf
less ambitious normalization: term abstractions over terms and proofs, but not proofs over proofs (which may be large);
wenzelm
parents:
79301
diff
changeset
|
728 |
if Envir.is_empty envir orelse null visible then beta_norm_prooft prf |
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
729 |
else |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
730 |
let |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
731 |
fun add_tvar v tab = |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
732 |
if ZTVars.defined tab v then tab else ZTVars.update (v, norm_tvar v) tab; |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
733 |
|
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
734 |
val inst_typ = |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
735 |
if Vartab.is_empty tyenv then Same.same |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
736 |
else |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
737 |
ZTVars.build (visible |> (fold o Term.fold_types o Term.fold_atyps) |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
738 |
(fn TVar v => add_tvar v | _ => I)) |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
739 |
|> instantiate_type_same; |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
740 |
|
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
741 |
fun add_var (a, T) tab = |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
742 |
let val v = (a, Same.commit inst_typ (ztyp T)) |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
743 |
in if ZVars.defined tab v then tab else ZVars.update (v, norm_var v) tab end; |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
744 |
|
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
745 |
val inst_term = |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
746 |
ZVars.build (visible |> (fold o Term.fold_aterms) (fn Var v => add_var v | _ => I)) |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
747 |
|> instantiate_term_same inst_typ; |
79272
899f37f6d218
proper beta_norm after instantiation (amending 90c5aadcc4b2);
wenzelm
parents:
79271
diff
changeset
|
748 |
|
79286 | 749 |
val norm_term = Same.compose beta_norm_term_same inst_term; |
79418 | 750 |
in beta_norm_prooft (map_proof {hyps = false} inst_typ norm_term prf) end |
79269 | 751 |
end; |
79210 | 752 |
|
753 |
fun norm_cache thy = |
|
79205 | 754 |
let |
79226 | 755 |
val {ztyp, zterm} = zterm_cache thy; |
79205 | 756 |
val typ = typ_cache (); |
757 |
in {ztyp = ztyp, zterm = zterm, typ = typ} end; |
|
758 |
||
79214 | 759 |
fun norm_type tyenv = Same.commit (norm_type_same (ztyp_cache ()) tyenv); |
760 |
fun norm_term thy envir = Same.commit (norm_term_same (norm_cache thy) envir); |
|
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
761 |
fun norm_proof thy envir = norm_proof_cache (norm_cache thy) envir; |
79200 | 762 |
|
763 |
||
79119 | 764 |
|
765 |
(** proof construction **) |
|
79113
5109e4b2a292
pro-forma support for optional zproof: no proper content yet;
wenzelm
parents:
79098
diff
changeset
|
766 |
|
79161 | 767 |
(* constants *) |
79124 | 768 |
|
79263 | 769 |
type zproof_const = zproof_name * zterm * ztyp ZTVars.table * zterm ZVars.table; |
770 |
||
771 |
fun zproof_const a A : zproof_const = |
|
79119 | 772 |
let |
79154 | 773 |
val instT = |
79263 | 774 |
ZTVars.build (A |> (fold_types o fold_tvars) (fn v => fn tab => |
79154 | 775 |
if ZTVars.defined tab v then tab else ZTVars.update (v, ZTVar v) tab)); |
776 |
val inst = |
|
79263 | 777 |
ZVars.build (A |> fold_aterms (fn t => fn tab => |
778 |
(case t of |
|
779 |
ZVar v => if ZVars.defined tab v then tab else ZVars.update (v, t) tab |
|
79154 | 780 |
| _ => tab))); |
79263 | 781 |
in (a, A, instT, inst) end; |
79126 | 782 |
|
79315 | 783 |
fun make_const_proof (f, g) (a, A, instT, inst) = |
79263 | 784 |
let |
79417
a4eae462f224
proper support for complex types, not just type variables (amending 623789141e39);
wenzelm
parents:
79416
diff
changeset
|
785 |
val typ = subst_type_same (Same.function (fn ((x, _), _) => try f x)); |
79416
623789141e39
proper instantiation for make_const_proof, notably change of types for term variables;
wenzelm
parents:
79415
diff
changeset
|
786 |
val term = Same.function (fn ZVar ((x, _), _) => try g x | _ => NONE); |
623789141e39
proper instantiation for make_const_proof, notably change of types for term variables;
wenzelm
parents:
79415
diff
changeset
|
787 |
val (instT', inst') = Same.commit (map_insts_same typ term) (instT, inst); |
79263 | 788 |
in ZConstp (a, A, instT', inst') end; |
79161 | 789 |
|
790 |
||
79265 | 791 |
(* closed proof boxes *) |
792 |
||
79311
e4a9a861856b
omit pointless future: proof terms are built sequentially;
wenzelm
parents:
79303
diff
changeset
|
793 |
type zbox = serial * (zterm * zproof); |
79279 | 794 |
val zbox_ord: zbox ord = fn ((i, _), (j, _)) => int_ord (j, i); |
79265 | 795 |
|
79279 | 796 |
type zboxes = zbox Ord_List.T; |
797 |
val union_zboxes = Ord_List.union zbox_ord; |
|
798 |
val unions_zboxes = Ord_List.unions zbox_ord; |
|
799 |
val add_zboxes = Ord_List.insert zbox_ord; |
|
79265 | 800 |
|
801 |
local |
|
802 |
||
79419
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
803 |
fun close_prop prems prop = |
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
804 |
fold_rev (fn A => fn B => ZApp (ZApp (ZConst0 "Pure.imp", A), B)) prems prop; |
79265 | 805 |
|
79428
4cd892d1a676
omit syntactic of_class check, which is in conflict with sort constraints within the logic;
wenzelm
parents:
79427
diff
changeset
|
806 |
fun close_proof prems prf = |
79265 | 807 |
let |
79419
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
808 |
val m = length prems - 1; |
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
809 |
val bounds = ZTerms.build (prems |> fold_index (fn (i, h) => ZTerms.update (h, m - i))); |
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
810 |
fun get_bound lev t = ZTerms.lookup bounds t |> Option.map (fn i => ZBoundp (lev + i)); |
79265 | 811 |
|
812 |
fun proof lev (ZHyp t) = |
|
79419
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
813 |
(case get_bound lev t of |
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
814 |
SOME p => p |
79428
4cd892d1a676
omit syntactic of_class check, which is in conflict with sort constraints within the logic;
wenzelm
parents:
79427
diff
changeset
|
815 |
| NONE => raise ZTERM ("Loose bound in proof term", [], [t], [prf])) |
79419
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
816 |
| proof lev (ZClassp C) = |
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
817 |
(case get_bound lev (ZClass C) of |
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
818 |
SOME p => p |
79428
4cd892d1a676
omit syntactic of_class check, which is in conflict with sort constraints within the logic;
wenzelm
parents:
79427
diff
changeset
|
819 |
| NONE => raise Same.SAME) |
79265 | 820 |
| proof lev (ZAbst (x, T, p)) = ZAbst (x, T, proof lev p) |
821 |
| proof lev (ZAbsp (x, t, p)) = ZAbsp (x, t, proof (lev + 1) p) |
|
822 |
| proof lev (ZAppt (p, t)) = ZAppt (proof lev p, t) |
|
823 |
| proof lev (ZAppp (p, q)) = |
|
79326 | 824 |
(ZAppp (proof lev p, Same.commit (proof lev) q) |
825 |
handle Same.SAME => ZAppp (p, proof lev q)) |
|
79265 | 826 |
| proof _ _ = raise Same.SAME; |
79419
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
827 |
in ZAbsps prems (Same.commit (proof 0) prf) end; |
79265 | 828 |
|
79429
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
829 |
fun box_proof {unconstrain} zproof_name thy hyps concl prf = |
79265 | 830 |
let |
79428
4cd892d1a676
omit syntactic of_class check, which is in conflict with sort constraints within the logic;
wenzelm
parents:
79427
diff
changeset
|
831 |
val {zterm, ...} = zterm_cache thy; |
79419
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
832 |
|
79473 | 833 |
val present_set = Types.build (Types.add_atyps concl #> fold Types.add_atyps hyps); |
79429
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
834 |
val ucontext as {constraints, outer_constraints, ...} = |
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
835 |
Logic.unconstrain_context [] present_set; |
79419
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
836 |
|
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
837 |
val typ_operation = #typ_operation ucontext {strip_sorts = true}; |
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
838 |
val unconstrain_typ = Same.commit typ_operation; |
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
839 |
val unconstrain_ztyp = |
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
840 |
ZTypes.unsynchronized_cache (Same.function_eq (op =) (typ_of #> unconstrain_typ #> ztyp_of)); |
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
841 |
val unconstrain_zterm = zterm o Term.map_types typ_operation; |
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
842 |
val unconstrain_proof = Same.commit (map_proof_types {hyps = true} unconstrain_ztyp); |
79265 | 843 |
|
79419
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
844 |
val constrain_instT = |
79429
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
845 |
if unconstrain then ZTVars.empty |
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
846 |
else |
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
847 |
ZTVars.build (present_set |> Types.fold (fn (T, _) => |
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
848 |
let |
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
849 |
val ZTVar v = ztyp_of (unconstrain_typ T) and U = ztyp_of T; |
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
850 |
val equal = (case U of ZTVar u => u = v | _ => false); |
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
851 |
in not equal ? ZTVars.add (v, U) end)); |
79419
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
852 |
val constrain_proof = |
79426 | 853 |
if ZTVars.is_empty constrain_instT then I |
854 |
else |
|
855 |
map_proof_types {hyps = true} |
|
856 |
(subst_type_same (Same.function (ZTVars.lookup constrain_instT))); |
|
79419
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
857 |
|
79429
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
858 |
val hyps' = map unconstrain_zterm hyps; |
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
859 |
val prems = map (zterm o #2) constraints @ hyps'; |
79419
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
860 |
val prop' = beta_norm_term (close_prop prems (unconstrain_zterm concl)); |
79428
4cd892d1a676
omit syntactic of_class check, which is in conflict with sort constraints within the logic;
wenzelm
parents:
79427
diff
changeset
|
861 |
val prf' = beta_norm_prooft (close_proof prems (unconstrain_proof prf)); |
79265 | 862 |
|
863 |
val i = serial (); |
|
79312 | 864 |
val zbox: zbox = (i, (prop', prf')); |
79429
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
865 |
|
79419
93f26d333fb5
clarified box_proof: use sort constraints within the logic;
wenzelm
parents:
79418
diff
changeset
|
866 |
val const = constrain_proof (ZConstp (zproof_const (zproof_name i) prop')); |
79429
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
867 |
val args1 = |
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
868 |
outer_constraints |> map (fn (T, c) => |
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
869 |
ZClassp (ztyp_of (if unconstrain then unconstrain_typ T else T), c)); |
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
870 |
val args2 = if unconstrain then map ZHyp hyps' else map (ZHyp o zterm) hyps; |
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
871 |
in (zbox, ZAppps (ZAppps (const, args1), args2)) end; |
79312 | 872 |
|
79313
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79312
diff
changeset
|
873 |
in |
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79312
diff
changeset
|
874 |
|
79361 | 875 |
fun thm_proof thy thm_name = |
79329 | 876 |
let |
877 |
val thy_name = Context.theory_long_name thy; |
|
79361 | 878 |
fun zproof_name i = ZThm {theory_name = thy_name, thm_name = thm_name, serial = i}; |
79429
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
879 |
in box_proof {unconstrain = false} zproof_name thy end; |
79313
3b03af5125de
use strict Global_Theory.register_proofs as checkpoint for stored zproof, and thus reduce current zboxes;
wenzelm
parents:
79312
diff
changeset
|
880 |
|
79429
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
881 |
fun add_box_proof unconstrain thy hyps concl prf zboxes = |
79422 | 882 |
let |
79429
637d7d896929
more zproofs, underlying Proofterm.unconstrain_thm_proof / Thm.unconstrainT;
wenzelm
parents:
79428
diff
changeset
|
883 |
val (zbox, prf') = box_proof unconstrain ZBox thy hyps concl prf; |
79422 | 884 |
val zboxes' = add_zboxes zbox zboxes; |
885 |
in (prf', zboxes') end; |
|
79265 | 886 |
|
887 |
end; |
|
888 |
||
889 |
||
79161 | 890 |
(* basic logic *) |
891 |
||
79263 | 892 |
fun axiom_proof thy name A = |
893 |
ZConstp (zproof_const (ZAxiom name) (zterm_of thy A)); |
|
79161 | 894 |
|
79263 | 895 |
fun oracle_proof thy name A = |
896 |
ZConstp (zproof_const (ZOracle name) (zterm_of thy A)); |
|
79119 | 897 |
|
898 |
fun assume_proof thy A = |
|
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
899 |
ZHyp (zterm_of thy A); |
79119 | 900 |
|
901 |
fun trivial_proof thy A = |
|
79212 | 902 |
ZAbsp ("H", zterm_of thy A, ZBoundp 0); |
79119 | 903 |
|
79414 | 904 |
fun implies_intr_proof' h prf = |
79119 | 905 |
let |
79277 | 906 |
fun proof lev (ZHyp t) = if aconv_zterm (h, t) then ZBoundp lev else raise Same.SAME |
907 |
| proof lev (ZAbst (x, T, p)) = ZAbst (x, T, proof lev p) |
|
908 |
| proof lev (ZAbsp (x, t, p)) = ZAbsp (x, t, proof (lev + 1) p) |
|
909 |
| proof lev (ZAppt (p, t)) = ZAppt (proof lev p, t) |
|
910 |
| proof lev (ZAppp (p, q)) = |
|
79326 | 911 |
(ZAppp (proof lev p, Same.commit (proof lev) q) |
912 |
handle Same.SAME => ZAppp (p, proof lev q)) |
|
79157 | 913 |
| proof _ _ = raise Same.SAME; |
79212 | 914 |
in ZAbsp ("H", h, Same.commit (proof 0) prf) end; |
79119 | 915 |
|
79414 | 916 |
fun implies_intr_proof thy = implies_intr_proof' o zterm_of thy; |
917 |
||
79124 | 918 |
fun forall_intr_proof thy T (a, x) prf = |
79119 | 919 |
let |
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
920 |
val {ztyp, zterm} = zterm_cache thy; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
921 |
val Z = ztyp T; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
922 |
val z = zterm x; |
79119 | 923 |
|
79157 | 924 |
fun term i b = |
79119 | 925 |
if aconv_zterm (b, z) then ZBound i |
926 |
else |
|
927 |
(case b of |
|
79157 | 928 |
ZAbs (x, T, t) => ZAbs (x, T, term (i + 1) t) |
79156 | 929 |
| ZApp (t, u) => |
79326 | 930 |
(ZApp (term i t, Same.commit (term i) u) |
931 |
handle Same.SAME => ZApp (t, term i u)) |
|
79156 | 932 |
| _ => raise Same.SAME); |
79119 | 933 |
|
79157 | 934 |
fun proof i (ZAbst (x, T, prf)) = ZAbst (x, T, proof (i + 1) prf) |
79212 | 935 |
| proof i (ZAbsp (x, t, prf)) = |
79326 | 936 |
(ZAbsp (x, term i t, Same.commit (proof i) prf) |
937 |
handle Same.SAME => ZAbsp (x, t, proof i prf)) |
|
79157 | 938 |
| proof i (ZAppt (p, t)) = |
79326 | 939 |
(ZAppt (proof i p, Same.commit (term i) t) |
940 |
handle Same.SAME => ZAppt (p, term i t)) |
|
79212 | 941 |
| proof i (ZAppp (p, q)) = |
79326 | 942 |
(ZAppp (proof i p, Same.commit (proof i) q) |
943 |
handle Same.SAME => ZAppp (p, proof i q)) |
|
79157 | 944 |
| proof _ _ = raise Same.SAME; |
79119 | 945 |
|
79157 | 946 |
in ZAbst (a, Z, Same.commit (proof 0) prf) end; |
79119 | 947 |
|
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
948 |
fun forall_elim_proof thy t p = ZAppt (p, zterm_of thy t); |
79119 | 949 |
|
79212 | 950 |
fun of_class_proof (T, c) = ZClassp (ztyp_of T, c); |
79128 | 951 |
|
79124 | 952 |
|
953 |
(* equality *) |
|
954 |
||
955 |
local |
|
956 |
||
957 |
val thy0 = |
|
958 |
Context.the_global_context () |
|
959 |
|> Sign.add_types_global [(Binding.name "fun", 2, NoSyn), (Binding.name "prop", 0, NoSyn)] |
|
960 |
|> Sign.local_path |
|
961 |
|> Sign.add_consts |
|
962 |
[(Binding.name "all", (Term.aT [] --> propT) --> propT, NoSyn), |
|
963 |
(Binding.name "imp", propT --> propT --> propT, NoSyn), |
|
964 |
(Binding.name "eq", Term.aT [] --> Term.aT [] --> propT, NoSyn)]; |
|
965 |
||
966 |
val [reflexive_axiom, symmetric_axiom, transitive_axiom, equal_intr_axiom, equal_elim_axiom, |
|
967 |
abstract_rule_axiom, combination_axiom] = |
|
79263 | 968 |
Theory.equality_axioms |> map (fn (b, t) => |
969 |
let val ZConstp c = axiom_proof thy0 (Sign.full_name thy0 b) t in c end); |
|
79124 | 970 |
|
971 |
in |
|
972 |
||
973 |
val is_reflexive_proof = |
|
79212 | 974 |
fn ZConstp (ZAxiom "Pure.reflexive", _, _, _) => true | _ => false; |
79124 | 975 |
|
976 |
fun reflexive_proof thy T t = |
|
977 |
let |
|
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
978 |
val {ztyp, zterm} = zterm_cache thy; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
979 |
val A = ztyp T; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
980 |
val x = zterm t; |
79263 | 981 |
in make_const_proof (fn "'a" => A, fn "x" => x) reflexive_axiom end; |
79124 | 982 |
|
983 |
fun symmetric_proof thy T t u prf = |
|
984 |
if is_reflexive_proof prf then prf |
|
985 |
else |
|
986 |
let |
|
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
987 |
val {ztyp, zterm} = zterm_cache thy; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
988 |
val A = ztyp T; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
989 |
val x = zterm t; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
990 |
val y = zterm u; |
79263 | 991 |
val ax = make_const_proof (fn "'a" => A, fn "x" => x | "y" => y) symmetric_axiom; |
79212 | 992 |
in ZAppp (ax, prf) end; |
79124 | 993 |
|
994 |
fun transitive_proof thy T t u v prf1 prf2 = |
|
995 |
if is_reflexive_proof prf1 then prf2 |
|
996 |
else if is_reflexive_proof prf2 then prf1 |
|
997 |
else |
|
998 |
let |
|
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
999 |
val {ztyp, zterm} = zterm_cache thy; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1000 |
val A = ztyp T; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1001 |
val x = zterm t; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1002 |
val y = zterm u; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1003 |
val z = zterm v; |
79263 | 1004 |
val ax = make_const_proof (fn "'a" => A, fn "x" => x | "y" => y | "z" => z) transitive_axiom; |
79212 | 1005 |
in ZAppp (ZAppp (ax, prf1), prf2) end; |
79124 | 1006 |
|
1007 |
fun equal_intr_proof thy t u prf1 prf2 = |
|
1008 |
let |
|
79160 | 1009 |
val {zterm, ...} = zterm_cache thy; |
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1010 |
val A = zterm t; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1011 |
val B = zterm u; |
79263 | 1012 |
val ax = make_const_proof (undefined, fn "A" => A | "B" => B) equal_intr_axiom; |
79212 | 1013 |
in ZAppp (ZAppp (ax, prf1), prf2) end; |
79124 | 1014 |
|
1015 |
fun equal_elim_proof thy t u prf1 prf2 = |
|
1016 |
let |
|
79160 | 1017 |
val {zterm, ...} = zterm_cache thy; |
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1018 |
val A = zterm t; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1019 |
val B = zterm u; |
79263 | 1020 |
val ax = make_const_proof (undefined, fn "A" => A | "B" => B) equal_elim_axiom; |
79212 | 1021 |
in ZAppp (ZAppp (ax, prf1), prf2) end; |
79124 | 1022 |
|
1023 |
fun abstract_rule_proof thy T U x t u prf = |
|
1024 |
let |
|
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1025 |
val {ztyp, zterm} = zterm_cache thy; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1026 |
val A = ztyp T; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1027 |
val B = ztyp U; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1028 |
val f = zterm t; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1029 |
val g = zterm u; |
79126 | 1030 |
val ax = |
79263 | 1031 |
make_const_proof (fn "'a" => A | "'b" => B, fn "f" => f | "g" => g) |
79126 | 1032 |
abstract_rule_axiom; |
79212 | 1033 |
in ZAppp (ax, forall_intr_proof thy T x prf) end; |
79124 | 1034 |
|
1035 |
fun combination_proof thy T U f g t u prf1 prf2 = |
|
1036 |
let |
|
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1037 |
val {ztyp, zterm} = zterm_cache thy; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1038 |
val A = ztyp T; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1039 |
val B = ztyp U; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1040 |
val f' = zterm f; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1041 |
val g' = zterm g; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1042 |
val x = zterm t; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1043 |
val y = zterm u; |
79124 | 1044 |
val ax = |
79263 | 1045 |
make_const_proof (fn "'a" => A | "'b" => B, fn "f" => f' | "g" => g' | "x" => x | "y" => y) |
79124 | 1046 |
combination_axiom; |
79212 | 1047 |
in ZAppp (ZAppp (ax, prf1), prf2) end; |
79124 | 1048 |
|
79098
d8940e5bbb25
tight representation of types / terms / proof terms (presently unused);
wenzelm
parents:
diff
changeset
|
1049 |
end; |
79124 | 1050 |
|
79133 | 1051 |
|
1052 |
(* substitution *) |
|
1053 |
||
1054 |
fun generalize_proof (tfrees, frees) idx prf = |
|
1055 |
let |
|
1056 |
val typ = |
|
79326 | 1057 |
if Names.is_empty tfrees then Same.same |
1058 |
else |
|
79163 | 1059 |
ZTypes.unsynchronized_cache |
1060 |
(subst_type_same (fn ((a, i), S) => |
|
1061 |
if i = ~1 andalso Names.defined tfrees a then ZTVar ((a, idx), S) |
|
1062 |
else raise Same.SAME)); |
|
79136 | 1063 |
val term = |
79147 | 1064 |
subst_term_same typ (fn ((x, i), T) => |
1065 |
if i = ~1 andalso Names.defined frees x then ZVar ((x, idx), T) |
|
1066 |
else raise Same.SAME); |
|
79418 | 1067 |
in map_proof {hyps = false} typ term prf end; |
79133 | 1068 |
|
79149 | 1069 |
fun instantiate_proof thy (Ts, ts) prf = |
1070 |
let |
|
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1071 |
val {ztyp, zterm} = zterm_cache thy; |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1072 |
val instT = ZTVars.build (Ts |> fold (fn (v, T) => ZTVars.add (v, ztyp T))); |
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1073 |
val inst = ZVars.build (ts |> fold (fn ((v, T), t) => ZVars.add ((v, ztyp T), zterm t))); |
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
1074 |
val typ = instantiate_type_same instT; |
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
1075 |
val term = instantiate_term_same typ inst; |
79418 | 1076 |
in map_proof {hyps = false} typ term prf end; |
79149 | 1077 |
|
79135 | 1078 |
fun varifyT_proof names prf = |
1079 |
if null names then prf |
|
1080 |
else |
|
1081 |
let |
|
1082 |
val tab = ZTVars.build (names |> fold (fn ((a, S), b) => ZTVars.add (((a, ~1), S), b))); |
|
79136 | 1083 |
val typ = |
79163 | 1084 |
ZTypes.unsynchronized_cache (subst_type_same (fn v => |
79136 | 1085 |
(case ZTVars.lookup tab v of |
1086 |
NONE => raise Same.SAME |
|
79163 | 1087 |
| SOME w => ZTVar w))); |
79418 | 1088 |
in map_proof_types {hyps = false} typ prf end; |
79135 | 1089 |
|
79152 | 1090 |
fun legacy_freezeT_proof t prf = |
1091 |
(case Type.legacy_freezeT t of |
|
1092 |
NONE => prf |
|
1093 |
| SOME f => |
|
1094 |
let |
|
1095 |
val tvar = ztyp_of o Same.function f; |
|
79163 | 1096 |
val typ = ZTypes.unsynchronized_cache (subst_type_same tvar); |
79418 | 1097 |
in map_proof_types {hyps = false} typ prf end); |
79152 | 1098 |
|
79155 | 1099 |
|
1100 |
(* permutations *) |
|
1101 |
||
1102 |
fun rotate_proof thy Bs Bi' params asms m prf = |
|
1103 |
let |
|
79158
3c7ab17380a8
performance tuning: cache for ztyp_of within zterm_of;
wenzelm
parents:
79157
diff
changeset
|
1104 |
val {ztyp, zterm} = zterm_cache thy; |
79155 | 1105 |
val i = length asms; |
1106 |
val j = length Bs; |
|
1107 |
in |
|
79212 | 1108 |
ZAbsps (map zterm Bs @ [zterm Bi']) (ZAppps (prf, map ZBoundp |
1109 |
(j downto 1) @ [ZAbsts (map (apsnd ztyp) params) (ZAbsps (map zterm asms) |
|
1110 |
(ZAppps (ZAppts (ZBoundp i, map ZBound ((length params - 1) downto 0)), |
|
79326 | 1111 |
map ZBoundp (((i - m - 1) downto 0) @ ((i - 1) downto (i - m))))))])) |
79155 | 1112 |
end; |
1113 |
||
1114 |
fun permute_prems_proof thy prems' j k prf = |
|
1115 |
let |
|
79160 | 1116 |
val {zterm, ...} = zterm_cache thy; |
79155 | 1117 |
val n = length prems'; |
1118 |
in |
|
79212 | 1119 |
ZAbsps (map zterm prems') |
79326 | 1120 |
(ZAppps (prf, map ZBoundp ((n - 1 downto n - j) @ (k - 1 downto 0) @ (n - j - 1 downto k)))) |
79155 | 1121 |
end; |
1122 |
||
79211 | 1123 |
|
79234 | 1124 |
(* lifting *) |
1125 |
||
1126 |
fun incr_tvar_same inc = |
|
1127 |
if inc = 0 then Same.same |
|
1128 |
else |
|
1129 |
let fun tvar ((a, i), S) = if i >= 0 then ZTVar ((a, i + inc), S) else raise Same.SAME |
|
1130 |
in ZTypes.unsynchronized_cache (subst_type_same tvar) end; |
|
1131 |
||
1132 |
fun incr_indexes_proof inc prf = |
|
1133 |
let |
|
1134 |
val typ = incr_tvar_same inc; |
|
1135 |
fun var ((x, i), T) = if i >= 0 then ZVar ((x, i + inc), T) else raise Same.SAME; |
|
1136 |
val term = subst_term_same typ var; |
|
79418 | 1137 |
in map_proof {hyps = false} typ term prf end; |
79234 | 1138 |
|
1139 |
fun lift_proof thy gprop inc prems prf = |
|
1140 |
let |
|
1141 |
val {ztyp, zterm} = zterm_cache thy; |
|
1142 |
||
1143 |
val typ = incr_tvar_same inc; |
|
1144 |
||
1145 |
fun term Ts lev = |
|
1146 |
if null Ts andalso inc = 0 then Same.same |
|
1147 |
else |
|
1148 |
let |
|
1149 |
val n = length Ts; |
|
1150 |
fun incr lev (ZVar ((x, i), T)) = |
|
1151 |
if i >= 0 then combound (ZVar ((x, i + inc), ZFuns (Ts, Same.commit typ T)), lev, n) |
|
1152 |
else raise Same.SAME |
|
1153 |
| incr _ (ZBound _) = raise Same.SAME |
|
1154 |
| incr _ (ZConst0 _) = raise Same.SAME |
|
1155 |
| incr _ (ZConst1 (c, T)) = ZConst1 (c, typ T) |
|
1156 |
| incr _ (ZConst (c, Ts)) = ZConst (c, Same.map typ Ts) |
|
1157 |
| incr lev (ZAbs (x, T, t)) = |
|
1158 |
(ZAbs (x, typ T, Same.commit (incr (lev + 1)) t) |
|
1159 |
handle Same.SAME => ZAbs (x, T, incr (lev + 1) t)) |
|
1160 |
| incr lev (ZApp (t, u)) = |
|
1161 |
(ZApp (incr lev t, Same.commit (incr lev) u) |
|
1162 |
handle Same.SAME => ZApp (t, incr lev u)) |
|
1163 |
| incr _ (ZClass (T, c)) = ZClass (typ T, c); |
|
1164 |
in incr lev end; |
|
1165 |
||
1166 |
fun proof Ts lev (ZAbst (a, T, p)) = |
|
1167 |
(ZAbst (a, typ T, Same.commit (proof Ts (lev + 1)) p) |
|
1168 |
handle Same.SAME => ZAbst (a, T, proof Ts (lev + 1) p)) |
|
1169 |
| proof Ts lev (ZAbsp (a, t, p)) = |
|
1170 |
(ZAbsp (a, term Ts lev t, Same.commit (proof Ts lev) p) |
|
1171 |
handle Same.SAME => ZAbsp (a, t, proof Ts lev p)) |
|
1172 |
| proof Ts lev (ZAppt (p, t)) = |
|
1173 |
(ZAppt (proof Ts lev p, Same.commit (term Ts lev) t) |
|
1174 |
handle Same.SAME => ZAppt (p, term Ts lev t)) |
|
1175 |
| proof Ts lev (ZAppp (p, q)) = |
|
1176 |
(ZAppp (proof Ts lev p, Same.commit (proof Ts lev) q) |
|
1177 |
handle Same.SAME => ZAppp (p, proof Ts lev q)) |
|
1178 |
| proof Ts lev (ZConstp (a, A, instT, inst)) = |
|
1179 |
let val (instT', insts') = map_insts_same typ (term Ts lev) (instT, inst) |
|
1180 |
in ZConstp (a, A, instT', insts') end |
|
1181 |
| proof _ _ (ZClassp (T, c)) = ZClassp (typ T, c) |
|
1182 |
| proof _ _ _ = raise Same.SAME; |
|
1183 |
||
1184 |
val k = length prems; |
|
1185 |
||
1186 |
fun mk_app b (i, j, p) = |
|
1187 |
if b then (i - 1, j, ZAppp (p, ZBoundp i)) else (i, j - 1, ZAppt (p, ZBound j)); |
|
1188 |
||
1189 |
fun lift Ts bs i j (Const ("Pure.imp", _) $ A $ B) = |
|
1190 |
ZAbsp ("H", Same.commit (term Ts 0) (zterm A), lift Ts (true :: bs) (i + 1) j B) |
|
1191 |
| lift Ts bs i j (Const ("Pure.all", _) $ Abs (a, T, t)) = |
|
1192 |
let val T' = ztyp T |
|
1193 |
in ZAbst (a, T', lift (T' :: Ts) (false :: bs) i (j + 1) t) end |
|
1194 |
| lift Ts bs i j _ = |
|
1195 |
ZAppps (Same.commit (proof (rev Ts) 0) prf, |
|
1196 |
map (fn k => (#3 (fold_rev mk_app bs (i - 1, j - 1, ZBoundp k)))) (i + k - 1 downto i)); |
|
79237 | 1197 |
in ZAbsps (map zterm prems) (lift [] [] 0 0 gprop) end; |
79234 | 1198 |
|
1199 |
||
79211 | 1200 |
(* higher-order resolution *) |
1201 |
||
1202 |
fun mk_asm_prf C i m = |
|
1203 |
let |
|
79212 | 1204 |
fun imp _ i 0 = ZBoundp i |
1205 |
| imp (ZApp (ZApp (ZConst0 "Pure.imp", A), B)) i m = ZAbsp ("H", A, imp B (i + 1) (m - 1)) |
|
1206 |
| imp _ i _ = ZBoundp i; |
|
79211 | 1207 |
fun all (ZApp (ZConst1 ("Pure.all", _), ZAbs (a, T, t))) = ZAbst (a, T, all t) |
1208 |
| all t = imp t (~ i) m |
|
1209 |
in all C end; |
|
1210 |
||
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
1211 |
fun assumption_proof thy envir Bs Bi n visible prf = |
79211 | 1212 |
let |
1213 |
val cache as {zterm, ...} = norm_cache thy; |
|
1214 |
val normt = zterm #> Same.commit (norm_term_same cache envir); |
|
1215 |
in |
|
79212 | 1216 |
ZAbsps (map normt Bs) |
1217 |
(ZAppps (prf, map ZBoundp (length Bs - 1 downto 0) @ [mk_asm_prf (normt Bi) n ~1])) |
|
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
1218 |
|> norm_proof_cache cache envir visible |
79211 | 1219 |
end; |
1220 |
||
79261 | 1221 |
fun flatten_params_proof i j n (ZApp (ZApp (ZConst0 "Pure.imp", A), B), k) = |
1222 |
ZAbsp ("H", A, flatten_params_proof (i + 1) j n (B, k)) |
|
1223 |
| flatten_params_proof i j n (ZApp (ZConst1 ("Pure.all", _), ZAbs (a, T, t)), k) = |
|
1224 |
ZAbst (a, T, flatten_params_proof i (j + 1) n (t, k)) |
|
1225 |
| flatten_params_proof i j n (_, k) = |
|
1226 |
ZAppps (ZAppts (ZBoundp (k + i), |
|
1227 |
map ZBound (j - 1 downto 0)), map ZBoundp (remove (op =) (i - n) (i - 1 downto 0))); |
|
1228 |
||
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
1229 |
fun bicompose_proof thy env smax flatten Bs As A oldAs n m visible rprf sprf = |
79261 | 1230 |
let |
1231 |
val cache as {zterm, ...} = norm_cache thy; |
|
1232 |
val normt = zterm #> Same.commit (norm_term_same cache env); |
|
79270
90c5aadcc4b2
more robust norm_proof: turn env into instantiation, based on visible statement;
wenzelm
parents:
79269
diff
changeset
|
1233 |
val normp = norm_proof_cache cache env visible; |
79261 | 1234 |
|
1235 |
val lb = length Bs; |
|
1236 |
val la = length As; |
|
1237 |
||
1238 |
fun proof p q = |
|
1239 |
ZAbsps (map normt (Bs @ As)) |
|
1240 |
(ZAppp (ZAppps (q, map ZBoundp (lb + la - 1 downto la)), |
|
1241 |
ZAppps (p, (if n > 0 then [mk_asm_prf (normt (the A)) n m] else []) @ |
|
1242 |
map (if flatten then flatten_params_proof 0 0 n else ZBoundp o snd) |
|
1243 |
(map normt oldAs ~~ (la - 1 downto 0))))); |
|
1244 |
in |
|
1245 |
if Envir.is_empty env then proof rprf sprf |
|
1246 |
else proof (normp rprf) (if Envir.above env smax then sprf else normp sprf) |
|
1247 |
end; |
|
1248 |
||
79405 | 1249 |
|
1250 |
(* sort constraints within the logic *) |
|
1251 |
||
79425 | 1252 |
type sorts_proof = (class * class -> zproof) * (string * class list list * class -> zproof); |
79405 | 1253 |
|
1254 |
fun of_sort_proof algebra (classrel_proof, arity_proof) hyps = |
|
1255 |
Sorts.of_sort_derivation algebra |
|
1256 |
{class_relation = fn _ => fn _ => fn (prf, c1) => fn c2 => |
|
1257 |
if c1 = c2 then prf else ZAppp (classrel_proof (c1, c2), prf), |
|
1258 |
type_constructor = fn (a, _) => fn dom => fn c => |
|
1259 |
let val Ss = map (map snd) dom and prfs = maps (map fst) dom |
|
1260 |
in ZAppps (arity_proof (a, Ss, c), prfs) end, |
|
1261 |
type_variable = fn typ => map (fn c => (hyps (typ, c), c)) (Type.sort_of_atyp typ)}; |
|
1262 |
||
79414 | 1263 |
fun unconstrainT_proof thy sorts_proof (ucontext: Logic.unconstrain_context) = |
1264 |
let |
|
1265 |
val cache = norm_cache thy; |
|
1266 |
val algebra = Sign.classes_of thy; |
|
1267 |
||
1268 |
val typ = |
|
1269 |
ZTypes.unsynchronized_cache |
|
1270 |
(typ_of #> #typ_operation ucontext {strip_sorts = true} #> ztyp_of); |
|
1271 |
||
1272 |
val typ_sort = #typ_operation ucontext {strip_sorts = false}; |
|
1273 |
||
1274 |
fun hyps T = |
|
1275 |
(case AList.lookup (op =) (#constraints ucontext) T of |
|
1276 |
SOME t => ZHyp (#zterm cache t) |
|
1277 |
| NONE => raise Fail "unconstrainT_proof: missing constraint"); |
|
1278 |
||
1279 |
fun class (T, c) = |
|
1280 |
let val T' = Same.commit typ_sort (#typ cache T) |
|
1281 |
in the_single (of_sort_proof algebra sorts_proof hyps (T', [c])) end; |
|
1282 |
in |
|
79418 | 1283 |
map_proof_types {hyps = false} typ #> map_class_proof class #> beta_norm_prooft |
79414 | 1284 |
#> fold_rev (implies_intr_proof' o #zterm cache o #2) (#constraints ucontext) |
1285 |
end; |
|
1286 |
||
79124 | 1287 |
end; |