wenzelm@9536
|
1 |
(* Title: Pure/term.ML
|
wenzelm@9536
|
2 |
Author: Lawrence C Paulson, Cambridge University Computer Laboratory
|
wenzelm@29280
|
3 |
Author: Makarius
|
clasohm@1364
|
4 |
|
wenzelm@4444
|
5 |
Simply typed lambda-calculus: types, terms, and basic operations.
|
clasohm@0
|
6 |
*)
|
clasohm@0
|
7 |
|
wenzelm@29257
|
8 |
infix 9 $;
|
clasohm@1364
|
9 |
infixr 5 -->;
|
wenzelm@4444
|
10 |
infixr --->;
|
wenzelm@4444
|
11 |
infix aconv;
|
clasohm@0
|
12 |
|
wenzelm@4444
|
13 |
signature BASIC_TERM =
|
wenzelm@4444
|
14 |
sig
|
wenzelm@22572
|
15 |
eqtype indexname
|
wenzelm@22572
|
16 |
eqtype class
|
wenzelm@22572
|
17 |
eqtype sort
|
wenzelm@22572
|
18 |
eqtype arity
|
wenzelm@4444
|
19 |
datatype typ =
|
wenzelm@4444
|
20 |
Type of string * typ list |
|
wenzelm@4444
|
21 |
TFree of string * sort |
|
wenzelm@4444
|
22 |
TVar of indexname * sort
|
wenzelm@16537
|
23 |
datatype term =
|
wenzelm@16537
|
24 |
Const of string * typ |
|
wenzelm@16537
|
25 |
Free of string * typ |
|
wenzelm@16537
|
26 |
Var of indexname * typ |
|
wenzelm@16537
|
27 |
Bound of int |
|
wenzelm@16537
|
28 |
Abs of string * typ * term |
|
wenzelm@17756
|
29 |
$ of term * term
|
wenzelm@16537
|
30 |
exception TYPE of string * typ list * term list
|
wenzelm@16537
|
31 |
exception TERM of string * term list
|
wenzelm@21353
|
32 |
val dummyS: sort
|
wenzelm@16710
|
33 |
val dummyT: typ
|
wenzelm@16710
|
34 |
val no_dummyT: typ -> typ
|
wenzelm@4444
|
35 |
val --> : typ * typ -> typ
|
wenzelm@4444
|
36 |
val ---> : typ list * typ -> typ
|
wenzelm@16710
|
37 |
val dest_Type: typ -> string * typ list
|
wenzelm@16710
|
38 |
val dest_TVar: typ -> indexname * sort
|
wenzelm@16710
|
39 |
val dest_TFree: typ -> string * sort
|
wenzelm@16710
|
40 |
val is_Bound: term -> bool
|
wenzelm@16710
|
41 |
val is_Const: term -> bool
|
wenzelm@16710
|
42 |
val is_Free: term -> bool
|
wenzelm@16710
|
43 |
val is_Var: term -> bool
|
wenzelm@4444
|
44 |
val is_TVar: typ -> bool
|
wenzelm@16710
|
45 |
val dest_Const: term -> string * typ
|
wenzelm@16710
|
46 |
val dest_Free: term -> string * typ
|
wenzelm@16710
|
47 |
val dest_Var: term -> indexname * typ
|
wenzelm@4444
|
48 |
val domain_type: typ -> typ
|
wenzelm@4480
|
49 |
val range_type: typ -> typ
|
wenzelm@4444
|
50 |
val binder_types: typ -> typ list
|
wenzelm@4444
|
51 |
val body_type: typ -> typ
|
wenzelm@4444
|
52 |
val strip_type: typ -> typ list * typ
|
wenzelm@16710
|
53 |
val type_of1: typ list * term -> typ
|
wenzelm@4444
|
54 |
val type_of: term -> typ
|
wenzelm@16710
|
55 |
val fastype_of1: typ list * term -> typ
|
wenzelm@4444
|
56 |
val fastype_of: term -> typ
|
wenzelm@10806
|
57 |
val list_abs: (string * typ) list * term -> term
|
haftmann@18927
|
58 |
val strip_abs: term -> (string * typ) list * term
|
wenzelm@4444
|
59 |
val strip_abs_body: term -> term
|
wenzelm@4444
|
60 |
val strip_abs_vars: term -> (string * typ) list
|
wenzelm@4444
|
61 |
val strip_qnt_body: string -> term -> term
|
wenzelm@4444
|
62 |
val strip_qnt_vars: string -> term -> (string * typ) list
|
wenzelm@4444
|
63 |
val list_comb: term * term list -> term
|
wenzelm@4444
|
64 |
val strip_comb: term -> term * term list
|
wenzelm@4444
|
65 |
val head_of: term -> term
|
wenzelm@4444
|
66 |
val size_of_term: term -> int
|
kleing@29819
|
67 |
val size_of_typ: typ -> int
|
haftmann@18847
|
68 |
val map_atyps: (typ -> typ) -> typ -> typ
|
haftmann@18847
|
69 |
val map_aterms: (term -> term) -> term -> term
|
wenzelm@4444
|
70 |
val map_type_tvar: (indexname * sort -> typ) -> typ -> typ
|
wenzelm@4444
|
71 |
val map_type_tfree: (string * sort -> typ) -> typ -> typ
|
wenzelm@20548
|
72 |
val map_types: (typ -> typ) -> term -> term
|
wenzelm@16943
|
73 |
val fold_atyps: (typ -> 'a -> 'a) -> typ -> 'a -> 'a
|
wenzelm@16943
|
74 |
val fold_aterms: (term -> 'a -> 'a) -> term -> 'a -> 'a
|
wenzelm@16943
|
75 |
val fold_term_types: (term -> typ -> 'a -> 'a) -> term -> 'a -> 'a
|
wenzelm@16943
|
76 |
val fold_types: (typ -> 'a -> 'a) -> term -> 'a -> 'a
|
wenzelm@24483
|
77 |
val burrow_types: (typ list -> typ list) -> term list -> term list
|
wenzelm@16710
|
78 |
val aconv: term * term -> bool
|
wenzelm@4444
|
79 |
val propT: typ
|
wenzelm@4444
|
80 |
val strip_all_body: term -> term
|
wenzelm@4444
|
81 |
val strip_all_vars: term -> (string * typ) list
|
wenzelm@4444
|
82 |
val incr_bv: int * int * term -> term
|
wenzelm@4444
|
83 |
val incr_boundvars: int -> term -> term
|
wenzelm@4444
|
84 |
val add_loose_bnos: term * int * int list -> int list
|
wenzelm@4444
|
85 |
val loose_bnos: term -> int list
|
wenzelm@4444
|
86 |
val loose_bvar: term * int -> bool
|
wenzelm@4444
|
87 |
val loose_bvar1: term * int -> bool
|
wenzelm@4444
|
88 |
val subst_bounds: term list * term -> term
|
wenzelm@4444
|
89 |
val subst_bound: term * term -> term
|
wenzelm@4444
|
90 |
val betapply: term * term -> term
|
wenzelm@18183
|
91 |
val betapplys: term * term list -> term
|
wenzelm@4444
|
92 |
val subst_free: (term * term) list -> term -> term
|
wenzelm@4444
|
93 |
val abstract_over: term * term -> term
|
wenzelm@11922
|
94 |
val lambda: term -> term -> term
|
wenzelm@4444
|
95 |
val absfree: string * typ * term -> term
|
wenzelm@17786
|
96 |
val absdummy: typ * term -> term
|
wenzelm@4444
|
97 |
val list_abs_free: (string * typ) list * term -> term
|
wenzelm@4444
|
98 |
val list_all_free: (string * typ) list * term -> term
|
wenzelm@4444
|
99 |
val list_all: (string * typ) list * term -> term
|
wenzelm@16710
|
100 |
val subst_atomic: (term * term) list -> term -> term
|
wenzelm@16710
|
101 |
val typ_subst_atomic: (typ * typ) list -> typ -> typ
|
wenzelm@16710
|
102 |
val subst_atomic_types: (typ * typ) list -> term -> term
|
wenzelm@16710
|
103 |
val typ_subst_TVars: (indexname * typ) list -> typ -> typ
|
wenzelm@16710
|
104 |
val subst_TVars: (indexname * typ) list -> term -> term
|
wenzelm@16710
|
105 |
val subst_Vars: (indexname * term) list -> term -> term
|
wenzelm@16710
|
106 |
val subst_vars: (indexname * typ) list * (indexname * term) list -> term -> term
|
wenzelm@16710
|
107 |
val is_first_order: string list -> term -> bool
|
wenzelm@4444
|
108 |
val maxidx_of_typ: typ -> int
|
wenzelm@4444
|
109 |
val maxidx_of_typs: typ list -> int
|
wenzelm@4444
|
110 |
val maxidx_of_term: term -> int
|
wenzelm@19909
|
111 |
val exists_subtype: (typ -> bool) -> typ -> bool
|
wenzelm@20531
|
112 |
val exists_type: (typ -> bool) -> term -> bool
|
wenzelm@16943
|
113 |
val exists_subterm: (term -> bool) -> term -> bool
|
wenzelm@16710
|
114 |
val exists_Const: (string * typ -> bool) -> term -> bool
|
wenzelm@15986
|
115 |
val show_question_marks: bool ref
|
wenzelm@4444
|
116 |
end;
|
clasohm@0
|
117 |
|
wenzelm@4444
|
118 |
signature TERM =
|
wenzelm@4444
|
119 |
sig
|
wenzelm@4444
|
120 |
include BASIC_TERM
|
wenzelm@19394
|
121 |
val aT: sort -> typ
|
wenzelm@19394
|
122 |
val itselfT: typ -> typ
|
wenzelm@19394
|
123 |
val a_itselfT: typ
|
wenzelm@27335
|
124 |
val all: typ -> term
|
wenzelm@22908
|
125 |
val argument_type_of: term -> int -> typ
|
wenzelm@29257
|
126 |
val add_tvar_namesT: typ -> indexname list -> indexname list
|
wenzelm@29257
|
127 |
val add_tvar_names: term -> indexname list -> indexname list
|
wenzelm@16943
|
128 |
val add_tvarsT: typ -> (indexname * sort) list -> (indexname * sort) list
|
wenzelm@16943
|
129 |
val add_tvars: term -> (indexname * sort) list -> (indexname * sort) list
|
wenzelm@29257
|
130 |
val add_var_names: term -> indexname list -> indexname list
|
wenzelm@16943
|
131 |
val add_vars: term -> (indexname * typ) list -> (indexname * typ) list
|
wenzelm@29257
|
132 |
val add_tfree_namesT: typ -> string list -> string list
|
wenzelm@29257
|
133 |
val add_tfree_names: term -> string list -> string list
|
wenzelm@16943
|
134 |
val add_tfreesT: typ -> (string * sort) list -> (string * sort) list
|
wenzelm@16943
|
135 |
val add_tfrees: term -> (string * sort) list -> (string * sort) list
|
wenzelm@29257
|
136 |
val add_free_names: term -> string list -> string list
|
wenzelm@16943
|
137 |
val add_frees: term -> (string * typ) list -> (string * typ) list
|
wenzelm@29286
|
138 |
val add_const_names: term -> string list -> string list
|
wenzelm@29286
|
139 |
val add_consts: term -> (string * typ) list -> (string * typ) list
|
wenzelm@25050
|
140 |
val hidden_polymorphism: term -> (indexname * sort) list
|
wenzelm@29278
|
141 |
val declare_typ_names: typ -> Name.context -> Name.context
|
wenzelm@29278
|
142 |
val declare_term_names: term -> Name.context -> Name.context
|
wenzelm@29278
|
143 |
val declare_term_frees: term -> Name.context -> Name.context
|
wenzelm@29278
|
144 |
val variant_frees: term -> (string * 'a) list -> (string * 'a) list
|
wenzelm@29278
|
145 |
val rename_wrt_term: term -> (string * 'a) list -> (string * 'a) list
|
wenzelm@29269
|
146 |
val eq_ix: indexname * indexname -> bool
|
wenzelm@29269
|
147 |
val eq_tvar: (indexname * sort) * (indexname * sort) -> bool
|
wenzelm@29269
|
148 |
val eq_var: (indexname * typ) * (indexname * typ) -> bool
|
wenzelm@29269
|
149 |
val could_unify: term * term -> bool
|
haftmann@20109
|
150 |
val strip_abs_eta: int -> term -> (string * typ) list * term
|
wenzelm@12981
|
151 |
val match_bvars: (term * term) * (string * string) list -> (string * string) list
|
haftmann@22031
|
152 |
val map_abs_vars: (string -> string) -> term -> term
|
wenzelm@12981
|
153 |
val rename_abs: term -> term -> term -> term option
|
wenzelm@25050
|
154 |
val close_schematic_term: term -> term
|
wenzelm@16710
|
155 |
val maxidx_typ: typ -> int -> int
|
wenzelm@16710
|
156 |
val maxidx_typs: typ list -> int -> int
|
wenzelm@16710
|
157 |
val maxidx_term: term -> int -> int
|
wenzelm@24671
|
158 |
val has_abs: term -> bool
|
wenzelm@20239
|
159 |
val dest_abs: string * typ * term -> string * term
|
wenzelm@9536
|
160 |
val dummy_patternN: string
|
wenzelm@18253
|
161 |
val dummy_pattern: typ -> term
|
wenzelm@22723
|
162 |
val is_dummy_pattern: term -> bool
|
wenzelm@24733
|
163 |
val free_dummy_patterns: term -> Name.context -> term * Name.context
|
wenzelm@9536
|
164 |
val no_dummy_patterns: term -> term
|
wenzelm@24762
|
165 |
val replace_dummy_patterns: term -> int -> term * int
|
wenzelm@10552
|
166 |
val is_replaced_dummy_pattern: indexname -> bool
|
wenzelm@16035
|
167 |
val show_dummy_patterns: term -> term
|
wenzelm@14786
|
168 |
val string_of_vname: indexname -> string
|
wenzelm@14786
|
169 |
val string_of_vname': indexname -> string
|
wenzelm@4444
|
170 |
end;
|
wenzelm@4444
|
171 |
|
wenzelm@4444
|
172 |
structure Term: TERM =
|
clasohm@1364
|
173 |
struct
|
clasohm@0
|
174 |
|
clasohm@0
|
175 |
(*Indexnames can be quickly renamed by adding an offset to the integer part,
|
clasohm@0
|
176 |
for resolution.*)
|
wenzelm@16537
|
177 |
type indexname = string * int;
|
clasohm@0
|
178 |
|
wenzelm@4626
|
179 |
(* Types are classified by sorts. *)
|
clasohm@0
|
180 |
type class = string;
|
clasohm@0
|
181 |
type sort = class list;
|
wenzelm@14829
|
182 |
type arity = string * sort list * sort;
|
clasohm@0
|
183 |
|
clasohm@0
|
184 |
(* The sorts attached to TFrees and TVars specify the sort of that variable *)
|
clasohm@0
|
185 |
datatype typ = Type of string * typ list
|
clasohm@0
|
186 |
| TFree of string * sort
|
wenzelm@9536
|
187 |
| TVar of indexname * sort;
|
clasohm@0
|
188 |
|
paulson@6033
|
189 |
(*Terms. Bound variables are indicated by depth number.
|
clasohm@0
|
190 |
Free variables, (scheme) variables and constants have names.
|
wenzelm@4626
|
191 |
An term is "closed" if every bound variable of level "lev"
|
wenzelm@13000
|
192 |
is enclosed by at least "lev" abstractions.
|
clasohm@0
|
193 |
|
clasohm@0
|
194 |
It is possible to create meaningless terms containing loose bound vars
|
clasohm@0
|
195 |
or type mismatches. But such terms are not allowed in rules. *)
|
clasohm@0
|
196 |
|
wenzelm@13000
|
197 |
datatype term =
|
clasohm@0
|
198 |
Const of string * typ
|
wenzelm@13000
|
199 |
| Free of string * typ
|
clasohm@0
|
200 |
| Var of indexname * typ
|
clasohm@0
|
201 |
| Bound of int
|
clasohm@0
|
202 |
| Abs of string*typ*term
|
wenzelm@3965
|
203 |
| op $ of term*term;
|
clasohm@0
|
204 |
|
wenzelm@16537
|
205 |
(*Errors involving type mismatches*)
|
clasohm@0
|
206 |
exception TYPE of string * typ list * term list;
|
clasohm@0
|
207 |
|
wenzelm@16537
|
208 |
(*Errors errors involving terms*)
|
clasohm@0
|
209 |
exception TERM of string * term list;
|
clasohm@0
|
210 |
|
clasohm@0
|
211 |
(*Note variable naming conventions!
|
clasohm@0
|
212 |
a,b,c: string
|
clasohm@0
|
213 |
f,g,h: functions (including terms of function type)
|
clasohm@0
|
214 |
i,j,m,n: int
|
clasohm@0
|
215 |
t,u: term
|
clasohm@0
|
216 |
v,w: indexnames
|
clasohm@0
|
217 |
x,y: any
|
clasohm@0
|
218 |
A,B,C: term (denoting formulae)
|
clasohm@0
|
219 |
T,U: typ
|
clasohm@0
|
220 |
*)
|
clasohm@0
|
221 |
|
clasohm@0
|
222 |
|
paulson@6033
|
223 |
(** Types **)
|
paulson@6033
|
224 |
|
wenzelm@21353
|
225 |
(*dummies for type-inference etc.*)
|
wenzelm@21353
|
226 |
val dummyS = [""];
|
wenzelm@16537
|
227 |
val dummyT = Type ("dummy", []);
|
wenzelm@16537
|
228 |
|
wenzelm@16537
|
229 |
fun no_dummyT typ =
|
wenzelm@16537
|
230 |
let
|
wenzelm@16537
|
231 |
fun check (T as Type ("dummy", _)) =
|
wenzelm@16537
|
232 |
raise TYPE ("Illegal occurrence of '_' dummy type", [T], [])
|
wenzelm@16537
|
233 |
| check (Type (_, Ts)) = List.app check Ts
|
wenzelm@16537
|
234 |
| check _ = ();
|
wenzelm@16537
|
235 |
in check typ; typ end;
|
wenzelm@16537
|
236 |
|
paulson@6033
|
237 |
fun S --> T = Type("fun",[S,T]);
|
paulson@6033
|
238 |
|
paulson@6033
|
239 |
(*handy for multiple args: [T1,...,Tn]--->T gives T1-->(T2--> ... -->T)*)
|
skalberg@15570
|
240 |
val op ---> = Library.foldr (op -->);
|
paulson@6033
|
241 |
|
paulson@6033
|
242 |
fun dest_Type (Type x) = x
|
paulson@6033
|
243 |
| dest_Type T = raise TYPE ("dest_Type", [T], []);
|
dixon@15914
|
244 |
fun dest_TVar (TVar x) = x
|
dixon@15914
|
245 |
| dest_TVar T = raise TYPE ("dest_TVar", [T], []);
|
dixon@15914
|
246 |
fun dest_TFree (TFree x) = x
|
dixon@15914
|
247 |
| dest_TFree T = raise TYPE ("dest_TFree", [T], []);
|
paulson@6033
|
248 |
|
wenzelm@16537
|
249 |
|
clasohm@0
|
250 |
(** Discriminators **)
|
clasohm@0
|
251 |
|
nipkow@7318
|
252 |
fun is_Bound (Bound _) = true
|
nipkow@7318
|
253 |
| is_Bound _ = false;
|
nipkow@7318
|
254 |
|
clasohm@0
|
255 |
fun is_Const (Const _) = true
|
clasohm@0
|
256 |
| is_Const _ = false;
|
clasohm@0
|
257 |
|
clasohm@0
|
258 |
fun is_Free (Free _) = true
|
clasohm@0
|
259 |
| is_Free _ = false;
|
clasohm@0
|
260 |
|
clasohm@0
|
261 |
fun is_Var (Var _) = true
|
clasohm@0
|
262 |
| is_Var _ = false;
|
clasohm@0
|
263 |
|
clasohm@0
|
264 |
fun is_TVar (TVar _) = true
|
clasohm@0
|
265 |
| is_TVar _ = false;
|
clasohm@0
|
266 |
|
wenzelm@16537
|
267 |
|
clasohm@0
|
268 |
(** Destructors **)
|
clasohm@0
|
269 |
|
clasohm@0
|
270 |
fun dest_Const (Const x) = x
|
clasohm@0
|
271 |
| dest_Const t = raise TERM("dest_Const", [t]);
|
clasohm@0
|
272 |
|
clasohm@0
|
273 |
fun dest_Free (Free x) = x
|
clasohm@0
|
274 |
| dest_Free t = raise TERM("dest_Free", [t]);
|
clasohm@0
|
275 |
|
clasohm@0
|
276 |
fun dest_Var (Var x) = x
|
clasohm@0
|
277 |
| dest_Var t = raise TERM("dest_Var", [t]);
|
clasohm@0
|
278 |
|
clasohm@0
|
279 |
|
paulson@4464
|
280 |
fun domain_type (Type("fun", [T,_])) = T
|
paulson@4464
|
281 |
and range_type (Type("fun", [_,T])) = T;
|
paulson@4064
|
282 |
|
clasohm@0
|
283 |
(* maps [T1,...,Tn]--->T to the list [T1,T2,...,Tn]*)
|
clasohm@0
|
284 |
fun binder_types (Type("fun",[S,T])) = S :: binder_types T
|
clasohm@0
|
285 |
| binder_types _ = [];
|
clasohm@0
|
286 |
|
clasohm@0
|
287 |
(* maps [T1,...,Tn]--->T to T*)
|
clasohm@0
|
288 |
fun body_type (Type("fun",[S,T])) = body_type T
|
clasohm@0
|
289 |
| body_type T = T;
|
clasohm@0
|
290 |
|
clasohm@0
|
291 |
(* maps [T1,...,Tn]--->T to ([T1,T2,...,Tn], T) *)
|
clasohm@0
|
292 |
fun strip_type T : typ list * typ =
|
clasohm@0
|
293 |
(binder_types T, body_type T);
|
clasohm@0
|
294 |
|
clasohm@0
|
295 |
|
clasohm@0
|
296 |
(*Compute the type of the term, checking that combinations are well-typed
|
clasohm@0
|
297 |
Ts = [T0,T1,...] holds types of bound variables 0, 1, ...*)
|
clasohm@0
|
298 |
fun type_of1 (Ts, Const (_,T)) = T
|
clasohm@0
|
299 |
| type_of1 (Ts, Free (_,T)) = T
|
skalberg@15570
|
300 |
| type_of1 (Ts, Bound i) = (List.nth (Ts,i)
|
skalberg@15570
|
301 |
handle Subscript => raise TYPE("type_of: bound variable", [], [Bound i]))
|
clasohm@0
|
302 |
| type_of1 (Ts, Var (_,T)) = T
|
clasohm@0
|
303 |
| type_of1 (Ts, Abs (_,T,body)) = T --> type_of1(T::Ts, body)
|
wenzelm@13000
|
304 |
| type_of1 (Ts, f$u) =
|
clasohm@0
|
305 |
let val U = type_of1(Ts,u)
|
clasohm@0
|
306 |
and T = type_of1(Ts,f)
|
clasohm@0
|
307 |
in case T of
|
wenzelm@9536
|
308 |
Type("fun",[T1,T2]) =>
|
wenzelm@9536
|
309 |
if T1=U then T2 else raise TYPE
|
wenzelm@9536
|
310 |
("type_of: type mismatch in application", [T1,U], [f$u])
|
wenzelm@13000
|
311 |
| _ => raise TYPE
|
wenzelm@9536
|
312 |
("type_of: function type is expected in application",
|
wenzelm@9536
|
313 |
[T,U], [f$u])
|
clasohm@0
|
314 |
end;
|
clasohm@0
|
315 |
|
clasohm@0
|
316 |
fun type_of t : typ = type_of1 ([],t);
|
clasohm@0
|
317 |
|
clasohm@0
|
318 |
(*Determines the type of a term, with minimal checking*)
|
wenzelm@13000
|
319 |
fun fastype_of1 (Ts, f$u) =
|
lcp@61
|
320 |
(case fastype_of1 (Ts,f) of
|
wenzelm@9536
|
321 |
Type("fun",[_,T]) => T
|
wenzelm@9536
|
322 |
| _ => raise TERM("fastype_of: expected function type", [f$u]))
|
lcp@61
|
323 |
| fastype_of1 (_, Const (_,T)) = T
|
lcp@61
|
324 |
| fastype_of1 (_, Free (_,T)) = T
|
skalberg@15570
|
325 |
| fastype_of1 (Ts, Bound i) = (List.nth(Ts,i)
|
skalberg@15570
|
326 |
handle Subscript => raise TERM("fastype_of: Bound", [Bound i]))
|
wenzelm@13000
|
327 |
| fastype_of1 (_, Var (_,T)) = T
|
lcp@61
|
328 |
| fastype_of1 (Ts, Abs (_,T,u)) = T --> fastype_of1 (T::Ts, u);
|
lcp@61
|
329 |
|
lcp@61
|
330 |
fun fastype_of t : typ = fastype_of1 ([],t);
|
clasohm@0
|
331 |
|
wenzelm@16678
|
332 |
(*Determine the argument type of a function*)
|
wenzelm@22908
|
333 |
fun argument_type_of tm k =
|
wenzelm@16678
|
334 |
let
|
wenzelm@16678
|
335 |
fun argT i (Type ("fun", [T, U])) = if i = 0 then T else argT (i - 1) U
|
wenzelm@16678
|
336 |
| argT _ T = raise TYPE ("argument_type_of", [T], []);
|
wenzelm@16678
|
337 |
|
wenzelm@16678
|
338 |
fun arg 0 _ (Abs (_, T, _)) = T
|
wenzelm@16678
|
339 |
| arg i Ts (Abs (_, T, t)) = arg (i - 1) (T :: Ts) t
|
wenzelm@16678
|
340 |
| arg i Ts (t $ _) = arg (i + 1) Ts t
|
wenzelm@16678
|
341 |
| arg i Ts a = argT i (fastype_of1 (Ts, a));
|
wenzelm@22908
|
342 |
in arg k [] tm end;
|
wenzelm@16678
|
343 |
|
clasohm@0
|
344 |
|
wenzelm@19473
|
345 |
val list_abs = uncurry (fold_rev (fn (x, T) => fn t => Abs (x, T, t)));
|
wenzelm@10806
|
346 |
|
haftmann@18927
|
347 |
fun strip_abs (Abs (a, T, t)) =
|
haftmann@18927
|
348 |
let val (a', t') = strip_abs t
|
haftmann@18927
|
349 |
in ((a, T) :: a', t') end
|
haftmann@18927
|
350 |
| strip_abs t = ([], t);
|
haftmann@18927
|
351 |
|
clasohm@0
|
352 |
(* maps (x1,...,xn)t to t *)
|
wenzelm@13000
|
353 |
fun strip_abs_body (Abs(_,_,t)) = strip_abs_body t
|
clasohm@0
|
354 |
| strip_abs_body u = u;
|
clasohm@0
|
355 |
|
clasohm@0
|
356 |
(* maps (x1,...,xn)t to [x1, ..., xn] *)
|
wenzelm@13000
|
357 |
fun strip_abs_vars (Abs(a,T,t)) = (a,T) :: strip_abs_vars t
|
clasohm@0
|
358 |
| strip_abs_vars u = [] : (string*typ) list;
|
clasohm@0
|
359 |
|
clasohm@0
|
360 |
|
clasohm@0
|
361 |
fun strip_qnt_body qnt =
|
clasohm@0
|
362 |
let fun strip(tm as Const(c,_)$Abs(_,_,t)) = if c=qnt then strip t else tm
|
clasohm@0
|
363 |
| strip t = t
|
clasohm@0
|
364 |
in strip end;
|
clasohm@0
|
365 |
|
clasohm@0
|
366 |
fun strip_qnt_vars qnt =
|
clasohm@0
|
367 |
let fun strip(Const(c,_)$Abs(a,T,t)) = if c=qnt then (a,T)::strip t else []
|
clasohm@0
|
368 |
| strip t = [] : (string*typ) list
|
clasohm@0
|
369 |
in strip end;
|
clasohm@0
|
370 |
|
clasohm@0
|
371 |
|
clasohm@0
|
372 |
(* maps (f, [t1,...,tn]) to f(t1,...,tn) *)
|
skalberg@15570
|
373 |
val list_comb : term * term list -> term = Library.foldl (op $);
|
clasohm@0
|
374 |
|
clasohm@0
|
375 |
|
clasohm@0
|
376 |
(* maps f(t1,...,tn) to (f, [t1,...,tn]) ; naturally tail-recursive*)
|
wenzelm@13000
|
377 |
fun strip_comb u : term * term list =
|
clasohm@0
|
378 |
let fun stripc (f$t, ts) = stripc (f, t::ts)
|
wenzelm@13000
|
379 |
| stripc x = x
|
clasohm@0
|
380 |
in stripc(u,[]) end;
|
clasohm@0
|
381 |
|
clasohm@0
|
382 |
|
clasohm@0
|
383 |
(* maps f(t1,...,tn) to f , which is never a combination *)
|
clasohm@0
|
384 |
fun head_of (f$t) = head_of f
|
clasohm@0
|
385 |
| head_of u = u;
|
clasohm@0
|
386 |
|
wenzelm@16599
|
387 |
(*number of atoms and abstractions in a term*)
|
wenzelm@16599
|
388 |
fun size_of_term tm =
|
wenzelm@16599
|
389 |
let
|
wenzelm@16678
|
390 |
fun add_size (t $ u, n) = add_size (t, add_size (u, n))
|
wenzelm@16678
|
391 |
| add_size (Abs (_ ,_, t), n) = add_size (t, n + 1)
|
wenzelm@16678
|
392 |
| add_size (_, n) = n + 1;
|
wenzelm@16678
|
393 |
in add_size (tm, 0) end;
|
clasohm@0
|
394 |
|
kleing@29819
|
395 |
(*number of tfrees, tvars, and constructors in a type*)
|
kleing@29819
|
396 |
fun size_of_typ ty =
|
kleing@29819
|
397 |
let
|
kleing@29819
|
398 |
fun add_size (Type (_, ars), n) = foldl add_size (n + 1) ars
|
kleing@29819
|
399 |
| add_size (_, n) = n + 1;
|
kleing@29819
|
400 |
in add_size (ty, 0) end;
|
kleing@29819
|
401 |
|
haftmann@18847
|
402 |
fun map_atyps f (Type (a, Ts)) = Type (a, map (map_atyps f) Ts)
|
haftmann@18976
|
403 |
| map_atyps f T = f T;
|
haftmann@18847
|
404 |
|
haftmann@18847
|
405 |
fun map_aterms f (t $ u) = map_aterms f t $ map_aterms f u
|
haftmann@18847
|
406 |
| map_aterms f (Abs (a, T, t)) = Abs (a, T, map_aterms f t)
|
haftmann@18847
|
407 |
| map_aterms f t = f t;
|
haftmann@18847
|
408 |
|
wenzelm@18981
|
409 |
fun map_type_tvar f = map_atyps (fn TVar x => f x | T => T);
|
wenzelm@18981
|
410 |
fun map_type_tfree f = map_atyps (fn TFree x => f x | T => T);
|
nipkow@949
|
411 |
|
wenzelm@20548
|
412 |
fun map_types f =
|
wenzelm@16678
|
413 |
let
|
wenzelm@16678
|
414 |
fun map_aux (Const (a, T)) = Const (a, f T)
|
wenzelm@16678
|
415 |
| map_aux (Free (a, T)) = Free (a, f T)
|
wenzelm@16678
|
416 |
| map_aux (Var (v, T)) = Var (v, f T)
|
wenzelm@16678
|
417 |
| map_aux (t as Bound _) = t
|
wenzelm@16678
|
418 |
| map_aux (Abs (a, T, t)) = Abs (a, f T, map_aux t)
|
wenzelm@16678
|
419 |
| map_aux (t $ u) = map_aux t $ map_aux u;
|
wenzelm@16678
|
420 |
in map_aux end;
|
clasohm@0
|
421 |
|
clasohm@0
|
422 |
|
wenzelm@16943
|
423 |
(* fold types and terms *)
|
wenzelm@16943
|
424 |
|
wenzelm@16943
|
425 |
fun fold_atyps f (Type (_, Ts)) = fold (fold_atyps f) Ts
|
wenzelm@16943
|
426 |
| fold_atyps f T = f T;
|
wenzelm@16943
|
427 |
|
wenzelm@16943
|
428 |
fun fold_aterms f (t $ u) = fold_aterms f t #> fold_aterms f u
|
wenzelm@16943
|
429 |
| fold_aterms f (Abs (_, _, t)) = fold_aterms f t
|
wenzelm@16943
|
430 |
| fold_aterms f a = f a;
|
wenzelm@16943
|
431 |
|
wenzelm@16943
|
432 |
fun fold_term_types f (t as Const (_, T)) = f t T
|
wenzelm@16943
|
433 |
| fold_term_types f (t as Free (_, T)) = f t T
|
wenzelm@16943
|
434 |
| fold_term_types f (t as Var (_, T)) = f t T
|
wenzelm@16943
|
435 |
| fold_term_types f (Bound _) = I
|
wenzelm@16943
|
436 |
| fold_term_types f (t as Abs (_, T, b)) = f t T #> fold_term_types f b
|
wenzelm@16943
|
437 |
| fold_term_types f (t $ u) = fold_term_types f t #> fold_term_types f u;
|
wenzelm@16943
|
438 |
|
wenzelm@16943
|
439 |
fun fold_types f = fold_term_types (K f);
|
wenzelm@16943
|
440 |
|
wenzelm@24483
|
441 |
fun replace_types (Const (c, _)) (T :: Ts) = (Const (c, T), Ts)
|
wenzelm@24483
|
442 |
| replace_types (Free (x, _)) (T :: Ts) = (Free (x, T), Ts)
|
wenzelm@24483
|
443 |
| replace_types (Var (xi, _)) (T :: Ts) = (Var (xi, T), Ts)
|
wenzelm@24483
|
444 |
| replace_types (Bound i) Ts = (Bound i, Ts)
|
wenzelm@24483
|
445 |
| replace_types (Abs (x, _, b)) (T :: Ts) =
|
wenzelm@24483
|
446 |
let val (b', Ts') = replace_types b Ts
|
wenzelm@24483
|
447 |
in (Abs (x, T, b'), Ts') end
|
wenzelm@24483
|
448 |
| replace_types (t $ u) Ts =
|
wenzelm@24483
|
449 |
let
|
wenzelm@24483
|
450 |
val (t', Ts') = replace_types t Ts;
|
wenzelm@24483
|
451 |
val (u', Ts'') = replace_types u Ts';
|
wenzelm@24483
|
452 |
in (t' $ u', Ts'') end;
|
wenzelm@24483
|
453 |
|
wenzelm@24483
|
454 |
fun burrow_types f ts =
|
wenzelm@24483
|
455 |
let
|
wenzelm@24483
|
456 |
val Ts = rev (fold (fold_types cons) ts []);
|
wenzelm@24483
|
457 |
val Ts' = f Ts;
|
wenzelm@24483
|
458 |
val (ts', []) = fold_map replace_types ts Ts';
|
wenzelm@24483
|
459 |
in ts' end;
|
wenzelm@24483
|
460 |
|
wenzelm@16943
|
461 |
(*collect variables*)
|
wenzelm@29257
|
462 |
val add_tvar_namesT = fold_atyps (fn TVar (xi, _) => insert (op =) xi | _ => I);
|
wenzelm@29257
|
463 |
val add_tvar_names = fold_types add_tvar_namesT;
|
wenzelm@16943
|
464 |
val add_tvarsT = fold_atyps (fn TVar v => insert (op =) v | _ => I);
|
wenzelm@16943
|
465 |
val add_tvars = fold_types add_tvarsT;
|
wenzelm@29257
|
466 |
val add_var_names = fold_aterms (fn Var (xi, _) => insert (op =) xi | _ => I);
|
wenzelm@16943
|
467 |
val add_vars = fold_aterms (fn Var v => insert (op =) v | _ => I);
|
wenzelm@29257
|
468 |
val add_tfree_namesT = fold_atyps (fn TFree (xi, _) => insert (op =) xi | _ => I);
|
wenzelm@29257
|
469 |
val add_tfree_names = fold_types add_tfree_namesT;
|
wenzelm@16943
|
470 |
val add_tfreesT = fold_atyps (fn TFree v => insert (op =) v | _ => I);
|
wenzelm@16943
|
471 |
val add_tfrees = fold_types add_tfreesT;
|
wenzelm@29257
|
472 |
val add_free_names = fold_aterms (fn Free (x, _) => insert (op =) x | _ => I);
|
wenzelm@16943
|
473 |
val add_frees = fold_aterms (fn Free v => insert (op =) v | _ => I);
|
wenzelm@29286
|
474 |
val add_const_names = fold_aterms (fn Const (c, _) => insert (op =) c | _ => I);
|
wenzelm@29286
|
475 |
val add_consts = fold_aterms (fn Const c => insert (op =) c | _ => I);
|
wenzelm@16943
|
476 |
|
wenzelm@25050
|
477 |
(*extra type variables in a term, not covered by its type*)
|
wenzelm@25050
|
478 |
fun hidden_polymorphism t =
|
wenzelm@21682
|
479 |
let
|
wenzelm@25050
|
480 |
val T = fastype_of t;
|
wenzelm@21682
|
481 |
val tvarsT = add_tvarsT T [];
|
wenzelm@21682
|
482 |
val extra_tvars = fold_types (fold_atyps
|
wenzelm@21682
|
483 |
(fn TVar v => if member (op =) tvarsT v then I else insert (op =) v | _ => I)) t [];
|
wenzelm@21682
|
484 |
in extra_tvars end;
|
wenzelm@21682
|
485 |
|
wenzelm@16943
|
486 |
|
wenzelm@29278
|
487 |
(* renaming variables *)
|
wenzelm@29278
|
488 |
|
wenzelm@29278
|
489 |
val declare_typ_names = fold_atyps (fn TFree (a, _) => Name.declare a | _ => I);
|
wenzelm@29278
|
490 |
|
wenzelm@29278
|
491 |
fun declare_term_names tm =
|
wenzelm@29278
|
492 |
fold_aterms
|
wenzelm@29278
|
493 |
(fn Const (a, _) => Name.declare (NameSpace.base a)
|
wenzelm@29278
|
494 |
| Free (a, _) => Name.declare a
|
wenzelm@29278
|
495 |
| _ => I) tm #>
|
wenzelm@29278
|
496 |
fold_types declare_typ_names tm;
|
wenzelm@29278
|
497 |
|
wenzelm@29278
|
498 |
val declare_term_frees = fold_aterms (fn Free (x, _) => Name.declare x | _ => I);
|
wenzelm@29278
|
499 |
|
wenzelm@29278
|
500 |
fun variant_frees t frees =
|
wenzelm@29278
|
501 |
fst (Name.variants (map fst frees) (declare_term_names t Name.context)) ~~ map snd frees;
|
wenzelm@29278
|
502 |
|
wenzelm@29278
|
503 |
fun rename_wrt_term t frees = rev (variant_frees t frees); (*reversed result!*)
|
wenzelm@29278
|
504 |
|
wenzelm@29278
|
505 |
|
wenzelm@25050
|
506 |
|
wenzelm@29269
|
507 |
(** Comparing terms **)
|
wenzelm@16537
|
508 |
|
wenzelm@29269
|
509 |
(* variables *)
|
wenzelm@29269
|
510 |
|
wenzelm@29269
|
511 |
fun eq_ix ((x, i): indexname, (y, j)) = i = j andalso x = y;
|
wenzelm@29269
|
512 |
|
wenzelm@29269
|
513 |
fun eq_tvar ((xi, S: sort), (xi', S')) = eq_ix (xi, xi') andalso S = S';
|
wenzelm@29269
|
514 |
fun eq_var ((xi, T: typ), (xi', T')) = eq_ix (xi, xi') andalso T = T';
|
wenzelm@29269
|
515 |
|
wenzelm@29269
|
516 |
|
wenzelm@29269
|
517 |
(* alpha equivalence *)
|
wenzelm@20511
|
518 |
|
wenzelm@20511
|
519 |
fun tm1 aconv tm2 =
|
wenzelm@20511
|
520 |
pointer_eq (tm1, tm2) orelse
|
wenzelm@20511
|
521 |
(case (tm1, tm2) of
|
wenzelm@20511
|
522 |
(t1 $ u1, t2 $ u2) => t1 aconv t2 andalso u1 aconv u2
|
wenzelm@20511
|
523 |
| (Abs (_, T1, t1), Abs (_, T2, t2)) => t1 aconv t2 andalso T1 = T2
|
wenzelm@20511
|
524 |
| (a1, a2) => a1 = a2);
|
wenzelm@20511
|
525 |
|
wenzelm@20511
|
526 |
|
wenzelm@29269
|
527 |
(*A fast unification filter: true unless the two terms cannot be unified.
|
wenzelm@29269
|
528 |
Terms must be NORMAL. Treats all Vars as distinct. *)
|
wenzelm@29269
|
529 |
fun could_unify (t, u) =
|
wenzelm@29269
|
530 |
let
|
wenzelm@29269
|
531 |
fun matchrands (f $ t) (g $ u) = could_unify (t, u) andalso matchrands f g
|
wenzelm@29269
|
532 |
| matchrands _ _ = true;
|
wenzelm@29269
|
533 |
in
|
wenzelm@29269
|
534 |
case (head_of t, head_of u) of
|
wenzelm@29269
|
535 |
(_, Var _) => true
|
wenzelm@29269
|
536 |
| (Var _, _) => true
|
wenzelm@29269
|
537 |
| (Const (a, _), Const (b, _)) => a = b andalso matchrands t u
|
wenzelm@29269
|
538 |
| (Free (a, _), Free (b, _)) => a = b andalso matchrands t u
|
wenzelm@29269
|
539 |
| (Bound i, Bound j) => i = j andalso matchrands t u
|
wenzelm@29269
|
540 |
| (Abs _, _) => true (*because of possible eta equality*)
|
wenzelm@29269
|
541 |
| (_, Abs _) => true
|
wenzelm@29269
|
542 |
| _ => false
|
wenzelm@29269
|
543 |
end;
|
wenzelm@16678
|
544 |
|
nipkow@16570
|
545 |
|
wenzelm@16537
|
546 |
|
clasohm@0
|
547 |
(** Connectives of higher order logic **)
|
clasohm@0
|
548 |
|
wenzelm@24850
|
549 |
fun aT S = TFree (Name.aT, S);
|
wenzelm@19394
|
550 |
|
wenzelm@375
|
551 |
fun itselfT ty = Type ("itself", [ty]);
|
wenzelm@24850
|
552 |
val a_itselfT = itselfT (TFree (Name.aT, []));
|
wenzelm@375
|
553 |
|
clasohm@0
|
554 |
val propT : typ = Type("prop",[]);
|
clasohm@0
|
555 |
|
clasohm@0
|
556 |
fun all T = Const("all", (T-->propT)-->propT);
|
clasohm@0
|
557 |
|
clasohm@0
|
558 |
(* maps !!x1...xn. t to t *)
|
wenzelm@13000
|
559 |
fun strip_all_body (Const("all",_)$Abs(_,_,t)) = strip_all_body t
|
clasohm@0
|
560 |
| strip_all_body t = t;
|
clasohm@0
|
561 |
|
clasohm@0
|
562 |
(* maps !!x1...xn. t to [x1, ..., xn] *)
|
clasohm@0
|
563 |
fun strip_all_vars (Const("all",_)$Abs(a,T,t)) =
|
wenzelm@13000
|
564 |
(a,T) :: strip_all_vars t
|
clasohm@0
|
565 |
| strip_all_vars t = [] : (string*typ) list;
|
clasohm@0
|
566 |
|
clasohm@0
|
567 |
(*increments a term's non-local bound variables
|
clasohm@0
|
568 |
required when moving a term within abstractions
|
clasohm@0
|
569 |
inc is increment for bound variables
|
clasohm@0
|
570 |
lev is level at which a bound variable is considered 'loose'*)
|
wenzelm@13000
|
571 |
fun incr_bv (inc, lev, u as Bound i) = if i>=lev then Bound(i+inc) else u
|
clasohm@0
|
572 |
| incr_bv (inc, lev, Abs(a,T,body)) =
|
wenzelm@9536
|
573 |
Abs(a, T, incr_bv(inc,lev+1,body))
|
wenzelm@13000
|
574 |
| incr_bv (inc, lev, f$t) =
|
clasohm@0
|
575 |
incr_bv(inc,lev,f) $ incr_bv(inc,lev,t)
|
clasohm@0
|
576 |
| incr_bv (inc, lev, u) = u;
|
clasohm@0
|
577 |
|
clasohm@0
|
578 |
fun incr_boundvars 0 t = t
|
clasohm@0
|
579 |
| incr_boundvars inc t = incr_bv(inc,0,t);
|
clasohm@0
|
580 |
|
wenzelm@12981
|
581 |
(*Scan a pair of terms; while they are similar,
|
wenzelm@12981
|
582 |
accumulate corresponding bound vars in "al"*)
|
wenzelm@12981
|
583 |
fun match_bvs(Abs(x,_,s),Abs(y,_,t), al) =
|
wenzelm@12981
|
584 |
match_bvs(s, t, if x="" orelse y="" then al
|
wenzelm@12981
|
585 |
else (x,y)::al)
|
wenzelm@12981
|
586 |
| match_bvs(f$s, g$t, al) = match_bvs(f,g,match_bvs(s,t,al))
|
wenzelm@12981
|
587 |
| match_bvs(_,_,al) = al;
|
wenzelm@12981
|
588 |
|
wenzelm@12981
|
589 |
(* strip abstractions created by parameters *)
|
wenzelm@12981
|
590 |
fun match_bvars((s,t),al) = match_bvs(strip_abs_body s, strip_abs_body t, al);
|
wenzelm@12981
|
591 |
|
haftmann@22031
|
592 |
fun map_abs_vars f (t $ u) = map_abs_vars f t $ map_abs_vars f u
|
haftmann@22031
|
593 |
| map_abs_vars f (Abs (a, T, t)) = Abs (f a, T, map_abs_vars f t)
|
haftmann@22031
|
594 |
| map_abs_vars f t = t;
|
haftmann@22031
|
595 |
|
wenzelm@12981
|
596 |
fun rename_abs pat obj t =
|
wenzelm@12981
|
597 |
let
|
wenzelm@12981
|
598 |
val ren = match_bvs (pat, obj, []);
|
wenzelm@12981
|
599 |
fun ren_abs (Abs (x, T, b)) =
|
wenzelm@18942
|
600 |
Abs (the_default x (AList.lookup (op =) ren x), T, ren_abs b)
|
wenzelm@12981
|
601 |
| ren_abs (f $ t) = ren_abs f $ ren_abs t
|
wenzelm@12981
|
602 |
| ren_abs t = t
|
skalberg@15531
|
603 |
in if null ren then NONE else SOME (ren_abs t) end;
|
clasohm@0
|
604 |
|
clasohm@0
|
605 |
(*Accumulate all 'loose' bound vars referring to level 'lev' or beyond.
|
clasohm@0
|
606 |
(Bound 0) is loose at level 0 *)
|
wenzelm@13000
|
607 |
fun add_loose_bnos (Bound i, lev, js) =
|
haftmann@20854
|
608 |
if i<lev then js else insert (op =) (i - lev) js
|
clasohm@0
|
609 |
| add_loose_bnos (Abs (_,_,t), lev, js) = add_loose_bnos (t, lev+1, js)
|
clasohm@0
|
610 |
| add_loose_bnos (f$t, lev, js) =
|
wenzelm@13000
|
611 |
add_loose_bnos (f, lev, add_loose_bnos (t, lev, js))
|
clasohm@0
|
612 |
| add_loose_bnos (_, _, js) = js;
|
clasohm@0
|
613 |
|
clasohm@0
|
614 |
fun loose_bnos t = add_loose_bnos (t, 0, []);
|
clasohm@0
|
615 |
|
clasohm@0
|
616 |
(* loose_bvar(t,k) iff t contains a 'loose' bound variable referring to
|
clasohm@0
|
617 |
level k or beyond. *)
|
clasohm@0
|
618 |
fun loose_bvar(Bound i,k) = i >= k
|
clasohm@0
|
619 |
| loose_bvar(f$t, k) = loose_bvar(f,k) orelse loose_bvar(t,k)
|
clasohm@0
|
620 |
| loose_bvar(Abs(_,_,t),k) = loose_bvar(t,k+1)
|
clasohm@0
|
621 |
| loose_bvar _ = false;
|
clasohm@0
|
622 |
|
nipkow@2792
|
623 |
fun loose_bvar1(Bound i,k) = i = k
|
nipkow@2792
|
624 |
| loose_bvar1(f$t, k) = loose_bvar1(f,k) orelse loose_bvar1(t,k)
|
nipkow@2792
|
625 |
| loose_bvar1(Abs(_,_,t),k) = loose_bvar1(t,k+1)
|
nipkow@2792
|
626 |
| loose_bvar1 _ = false;
|
clasohm@0
|
627 |
|
clasohm@0
|
628 |
(*Substitute arguments for loose bound variables.
|
clasohm@0
|
629 |
Beta-reduction of arg(n-1)...arg0 into t replacing (Bound i) with (argi).
|
wenzelm@4626
|
630 |
Note that for ((%x y. c) a b), the bound vars in c are x=1 and y=0
|
wenzelm@9536
|
631 |
and the appropriate call is subst_bounds([b,a], c) .
|
clasohm@0
|
632 |
Loose bound variables >=n are reduced by "n" to
|
clasohm@0
|
633 |
compensate for the disappearance of lambdas.
|
clasohm@0
|
634 |
*)
|
wenzelm@13000
|
635 |
fun subst_bounds (args: term list, t) : term =
|
wenzelm@19065
|
636 |
let
|
wenzelm@19065
|
637 |
exception SAME;
|
wenzelm@19065
|
638 |
val n = length args;
|
wenzelm@19065
|
639 |
fun subst (t as Bound i, lev) =
|
wenzelm@19065
|
640 |
(if i < lev then raise SAME (*var is locally bound*)
|
wenzelm@19065
|
641 |
else incr_boundvars lev (List.nth (args, i - lev))
|
wenzelm@19065
|
642 |
handle Subscript => Bound (i - n)) (*loose: change it*)
|
wenzelm@19065
|
643 |
| subst (Abs (a, T, body), lev) = Abs (a, T, subst (body, lev + 1))
|
wenzelm@19065
|
644 |
| subst (f $ t, lev) =
|
wenzelm@19065
|
645 |
(subst (f, lev) $ (subst (t, lev) handle SAME => t) handle SAME => f $ subst (t, lev))
|
wenzelm@19065
|
646 |
| subst _ = raise SAME;
|
wenzelm@19065
|
647 |
in case args of [] => t | _ => (subst (t, 0) handle SAME => t) end;
|
clasohm@0
|
648 |
|
paulson@2192
|
649 |
(*Special case: one argument*)
|
wenzelm@13000
|
650 |
fun subst_bound (arg, t) : term =
|
wenzelm@19065
|
651 |
let
|
wenzelm@19065
|
652 |
exception SAME;
|
wenzelm@19065
|
653 |
fun subst (Bound i, lev) =
|
wenzelm@19065
|
654 |
if i < lev then raise SAME (*var is locally bound*)
|
wenzelm@19065
|
655 |
else if i = lev then incr_boundvars lev arg
|
wenzelm@19065
|
656 |
else Bound (i - 1) (*loose: change it*)
|
wenzelm@19065
|
657 |
| subst (Abs (a, T, body), lev) = Abs (a, T, subst (body, lev + 1))
|
wenzelm@19065
|
658 |
| subst (f $ t, lev) =
|
wenzelm@19065
|
659 |
(subst (f, lev) $ (subst (t, lev) handle SAME => t) handle SAME => f $ subst (t, lev))
|
wenzelm@19065
|
660 |
| subst _ = raise SAME;
|
wenzelm@19065
|
661 |
in subst (t, 0) handle SAME => t end;
|
paulson@2192
|
662 |
|
clasohm@0
|
663 |
(*beta-reduce if possible, else form application*)
|
paulson@2192
|
664 |
fun betapply (Abs(_,_,t), u) = subst_bound (u,t)
|
clasohm@0
|
665 |
| betapply (f,u) = f$u;
|
clasohm@0
|
666 |
|
wenzelm@18183
|
667 |
val betapplys = Library.foldl betapply;
|
wenzelm@18183
|
668 |
|
wenzelm@14786
|
669 |
|
haftmann@20109
|
670 |
(*unfolding abstractions with substitution
|
haftmann@20109
|
671 |
of bound variables and implicit eta-expansion*)
|
haftmann@20109
|
672 |
fun strip_abs_eta k t =
|
haftmann@20109
|
673 |
let
|
wenzelm@29278
|
674 |
val used = fold_aterms declare_term_frees t Name.context;
|
haftmann@20109
|
675 |
fun strip_abs t (0, used) = (([], t), (0, used))
|
haftmann@20109
|
676 |
| strip_abs (Abs (v, T, t)) (k, used) =
|
haftmann@20109
|
677 |
let
|
wenzelm@20122
|
678 |
val ([v'], used') = Name.variants [v] used;
|
haftmann@21013
|
679 |
val t' = subst_bound (Free (v', T), t);
|
wenzelm@20122
|
680 |
val ((vs, t''), (k', used'')) = strip_abs t' (k - 1, used');
|
wenzelm@20122
|
681 |
in (((v', T) :: vs, t''), (k', used'')) end
|
haftmann@20109
|
682 |
| strip_abs t (k, used) = (([], t), (k, used));
|
haftmann@20109
|
683 |
fun expand_eta [] t _ = ([], t)
|
haftmann@20109
|
684 |
| expand_eta (T::Ts) t used =
|
haftmann@20109
|
685 |
let
|
wenzelm@20122
|
686 |
val ([v], used') = Name.variants [""] used;
|
wenzelm@20122
|
687 |
val (vs, t') = expand_eta Ts (t $ Free (v, T)) used';
|
haftmann@20109
|
688 |
in ((v, T) :: vs, t') end;
|
haftmann@20109
|
689 |
val ((vs1, t'), (k', used')) = strip_abs t (k, used);
|
haftmann@20109
|
690 |
val Ts = (fst o chop k' o fst o strip_type o fastype_of) t';
|
haftmann@20109
|
691 |
val (vs2, t'') = expand_eta Ts t' used';
|
haftmann@20109
|
692 |
in (vs1 @ vs2, t'') end;
|
haftmann@20109
|
693 |
|
haftmann@20109
|
694 |
|
clasohm@0
|
695 |
(*Substitute new for free occurrences of old in a term*)
|
wenzelm@29256
|
696 |
fun subst_free [] = I
|
clasohm@0
|
697 |
| subst_free pairs =
|
wenzelm@13000
|
698 |
let fun substf u =
|
haftmann@17314
|
699 |
case AList.lookup (op aconv) pairs u of
|
skalberg@15531
|
700 |
SOME u' => u'
|
skalberg@15531
|
701 |
| NONE => (case u of Abs(a,T,t) => Abs(a, T, substf t)
|
wenzelm@9536
|
702 |
| t$u' => substf t $ substf u'
|
wenzelm@9536
|
703 |
| _ => u)
|
clasohm@0
|
704 |
in substf end;
|
clasohm@0
|
705 |
|
wenzelm@13000
|
706 |
(*Abstraction of the term "body" over its occurrences of v,
|
clasohm@0
|
707 |
which must contain no loose bound variables.
|
clasohm@0
|
708 |
The resulting term is ready to become the body of an Abs.*)
|
wenzelm@16882
|
709 |
fun abstract_over (v, body) =
|
wenzelm@16882
|
710 |
let
|
wenzelm@16990
|
711 |
exception SAME;
|
wenzelm@16990
|
712 |
fun abs lev tm =
|
wenzelm@16990
|
713 |
if v aconv tm then Bound lev
|
wenzelm@16882
|
714 |
else
|
wenzelm@16990
|
715 |
(case tm of
|
wenzelm@16990
|
716 |
Abs (a, T, t) => Abs (a, T, abs (lev + 1) t)
|
wenzelm@16990
|
717 |
| t $ u => (abs lev t $ (abs lev u handle SAME => u) handle SAME => t $ abs lev u)
|
wenzelm@16990
|
718 |
| _ => raise SAME);
|
wenzelm@16990
|
719 |
in abs 0 body handle SAME => body end;
|
clasohm@0
|
720 |
|
wenzelm@21975
|
721 |
fun lambda v t =
|
wenzelm@21975
|
722 |
let val x =
|
wenzelm@21975
|
723 |
(case v of
|
wenzelm@21975
|
724 |
Const (x, _) => NameSpace.base x
|
wenzelm@21975
|
725 |
| Free (x, _) => x
|
wenzelm@21975
|
726 |
| Var ((x, _), _) => x
|
wenzelm@24850
|
727 |
| _ => Name.uu)
|
wenzelm@21975
|
728 |
in Abs (x, fastype_of v, abstract_over (v, t)) end;
|
clasohm@0
|
729 |
|
clasohm@0
|
730 |
(*Form an abstraction over a free variable.*)
|
wenzelm@21975
|
731 |
fun absfree (a,T,body) = Abs (a, T, abstract_over (Free (a, T), body));
|
wenzelm@24850
|
732 |
fun absdummy (T, body) = Abs (Name.internal Name.uu, T, body);
|
clasohm@0
|
733 |
|
clasohm@0
|
734 |
(*Abstraction over a list of free variables*)
|
clasohm@0
|
735 |
fun list_abs_free ([ ] , t) = t
|
wenzelm@13000
|
736 |
| list_abs_free ((a,T)::vars, t) =
|
clasohm@0
|
737 |
absfree(a, T, list_abs_free(vars,t));
|
clasohm@0
|
738 |
|
clasohm@0
|
739 |
(*Quantification over a list of free variables*)
|
clasohm@0
|
740 |
fun list_all_free ([], t: term) = t
|
wenzelm@13000
|
741 |
| list_all_free ((a,T)::vars, t) =
|
clasohm@0
|
742 |
(all T) $ (absfree(a, T, list_all_free(vars,t)));
|
clasohm@0
|
743 |
|
clasohm@0
|
744 |
(*Quantification over a list of variables (already bound in body) *)
|
clasohm@0
|
745 |
fun list_all ([], t) = t
|
wenzelm@13000
|
746 |
| list_all ((a,T)::vars, t) =
|
clasohm@0
|
747 |
(all T) $ (Abs(a, T, list_all(vars,t)));
|
clasohm@0
|
748 |
|
wenzelm@16678
|
749 |
(*Replace the ATOMIC term ti by ui; inst = [(t1,u1), ..., (tn,un)].
|
clasohm@0
|
750 |
A simultaneous substitution: [ (a,b), (b,a) ] swaps a and b. *)
|
wenzelm@16678
|
751 |
fun subst_atomic [] tm = tm
|
wenzelm@16678
|
752 |
| subst_atomic inst tm =
|
wenzelm@16678
|
753 |
let
|
wenzelm@16678
|
754 |
fun subst (Abs (a, T, body)) = Abs (a, T, subst body)
|
wenzelm@16678
|
755 |
| subst (t $ u) = subst t $ subst u
|
wenzelm@18942
|
756 |
| subst t = the_default t (AList.lookup (op aconv) inst t);
|
wenzelm@16678
|
757 |
in subst tm end;
|
clasohm@0
|
758 |
|
wenzelm@16678
|
759 |
(*Replace the ATOMIC type Ti by Ui; inst = [(T1,U1), ..., (Tn,Un)].*)
|
wenzelm@16678
|
760 |
fun typ_subst_atomic [] ty = ty
|
wenzelm@16678
|
761 |
| typ_subst_atomic inst ty =
|
wenzelm@16678
|
762 |
let
|
wenzelm@16678
|
763 |
fun subst (Type (a, Ts)) = Type (a, map subst Ts)
|
wenzelm@18942
|
764 |
| subst T = the_default T (AList.lookup (op = : typ * typ -> bool) inst T);
|
wenzelm@16678
|
765 |
in subst ty end;
|
berghofe@15797
|
766 |
|
wenzelm@16678
|
767 |
fun subst_atomic_types [] tm = tm
|
wenzelm@20548
|
768 |
| subst_atomic_types inst tm = map_types (typ_subst_atomic inst) tm;
|
clasohm@0
|
769 |
|
wenzelm@16678
|
770 |
fun typ_subst_TVars [] ty = ty
|
wenzelm@16678
|
771 |
| typ_subst_TVars inst ty =
|
wenzelm@16678
|
772 |
let
|
wenzelm@16678
|
773 |
fun subst (Type (a, Ts)) = Type (a, map subst Ts)
|
wenzelm@18942
|
774 |
| subst (T as TVar (xi, _)) = the_default T (AList.lookup (op =) inst xi)
|
wenzelm@16678
|
775 |
| subst T = T;
|
wenzelm@16678
|
776 |
in subst ty end;
|
clasohm@0
|
777 |
|
wenzelm@16678
|
778 |
fun subst_TVars [] tm = tm
|
wenzelm@20548
|
779 |
| subst_TVars inst tm = map_types (typ_subst_TVars inst) tm;
|
clasohm@0
|
780 |
|
wenzelm@16678
|
781 |
fun subst_Vars [] tm = tm
|
wenzelm@16678
|
782 |
| subst_Vars inst tm =
|
wenzelm@16678
|
783 |
let
|
wenzelm@18942
|
784 |
fun subst (t as Var (xi, _)) = the_default t (AList.lookup (op =) inst xi)
|
wenzelm@16678
|
785 |
| subst (Abs (a, T, t)) = Abs (a, T, subst t)
|
wenzelm@16678
|
786 |
| subst (t $ u) = subst t $ subst u
|
wenzelm@16678
|
787 |
| subst t = t;
|
wenzelm@16678
|
788 |
in subst tm end;
|
wenzelm@16678
|
789 |
|
wenzelm@16678
|
790 |
fun subst_vars ([], []) tm = tm
|
wenzelm@16678
|
791 |
| subst_vars ([], inst) tm = subst_Vars inst tm
|
wenzelm@16678
|
792 |
| subst_vars (instT, inst) tm =
|
wenzelm@16678
|
793 |
let
|
wenzelm@16678
|
794 |
fun subst (Const (a, T)) = Const (a, typ_subst_TVars instT T)
|
wenzelm@16678
|
795 |
| subst (Free (a, T)) = Free (a, typ_subst_TVars instT T)
|
wenzelm@16678
|
796 |
| subst (t as Var (xi, T)) =
|
haftmann@17271
|
797 |
(case AList.lookup (op =) inst xi of
|
wenzelm@16678
|
798 |
NONE => Var (xi, typ_subst_TVars instT T)
|
wenzelm@16678
|
799 |
| SOME t => t)
|
wenzelm@16678
|
800 |
| subst (t as Bound _) = t
|
wenzelm@16678
|
801 |
| subst (Abs (a, T, t)) = Abs (a, typ_subst_TVars instT T, subst t)
|
wenzelm@16678
|
802 |
| subst (t $ u) = subst t $ subst u;
|
wenzelm@16678
|
803 |
in subst tm end;
|
clasohm@0
|
804 |
|
wenzelm@25050
|
805 |
fun close_schematic_term t =
|
wenzelm@25050
|
806 |
let
|
wenzelm@25050
|
807 |
val extra_types = map (fn v => Const ("TYPE", itselfT (TVar v))) (hidden_polymorphism t);
|
wenzelm@25050
|
808 |
val extra_terms = map Var (rev (add_vars t []));
|
wenzelm@25050
|
809 |
in fold_rev lambda (extra_types @ extra_terms) t end;
|
wenzelm@25050
|
810 |
|
wenzelm@25050
|
811 |
|
clasohm@0
|
812 |
|
paulson@15573
|
813 |
(** Identifying first-order terms **)
|
paulson@15573
|
814 |
|
wenzelm@20199
|
815 |
(*Differs from proofterm/is_fun in its treatment of TVar*)
|
wenzelm@29256
|
816 |
fun is_funtype (Type ("fun", [_, _])) = true
|
wenzelm@20199
|
817 |
| is_funtype _ = false;
|
wenzelm@20199
|
818 |
|
paulson@15573
|
819 |
(*Argument Ts is a reverse list of binder types, needed if term t contains Bound vars*)
|
wenzelm@29256
|
820 |
fun has_not_funtype Ts t = not (is_funtype (fastype_of1 (Ts, t)));
|
paulson@15573
|
821 |
|
wenzelm@16537
|
822 |
(*First order means in all terms of the form f(t1,...,tn) no argument has a
|
paulson@16589
|
823 |
function type. The supplied quantifiers are excluded: their argument always
|
paulson@16589
|
824 |
has a function type through a recursive call into its body.*)
|
wenzelm@16667
|
825 |
fun is_first_order quants =
|
paulson@16589
|
826 |
let fun first_order1 Ts (Abs (_,T,body)) = first_order1 (T::Ts) body
|
wenzelm@16667
|
827 |
| first_order1 Ts (Const(q,_) $ Abs(a,T,body)) =
|
wenzelm@20664
|
828 |
member (op =) quants q andalso (*it is a known quantifier*)
|
paulson@16589
|
829 |
not (is_funtype T) andalso first_order1 (T::Ts) body
|
wenzelm@16667
|
830 |
| first_order1 Ts t =
|
wenzelm@16667
|
831 |
case strip_comb t of
|
wenzelm@16667
|
832 |
(Var _, ts) => forall (first_order1 Ts andf has_not_funtype Ts) ts
|
wenzelm@16667
|
833 |
| (Free _, ts) => forall (first_order1 Ts andf has_not_funtype Ts) ts
|
wenzelm@16667
|
834 |
| (Const _, ts) => forall (first_order1 Ts andf has_not_funtype Ts) ts
|
wenzelm@16667
|
835 |
| (Bound _, ts) => forall (first_order1 Ts andf has_not_funtype Ts) ts
|
wenzelm@16667
|
836 |
| (Abs _, ts) => false (*not in beta-normal form*)
|
wenzelm@16667
|
837 |
| _ => error "first_order: unexpected case"
|
paulson@16589
|
838 |
in first_order1 [] end;
|
paulson@15573
|
839 |
|
clasohm@0
|
840 |
|
wenzelm@16990
|
841 |
(* maximum index of typs and terms *)
|
clasohm@0
|
842 |
|
wenzelm@16710
|
843 |
fun maxidx_typ (TVar ((_, j), _)) i = Int.max (i, j)
|
wenzelm@16710
|
844 |
| maxidx_typ (Type (_, Ts)) i = maxidx_typs Ts i
|
wenzelm@16710
|
845 |
| maxidx_typ (TFree _) i = i
|
wenzelm@16710
|
846 |
and maxidx_typs [] i = i
|
wenzelm@16710
|
847 |
| maxidx_typs (T :: Ts) i = maxidx_typs Ts (maxidx_typ T i);
|
clasohm@0
|
848 |
|
wenzelm@16710
|
849 |
fun maxidx_term (Var ((_, j), T)) i = maxidx_typ T (Int.max (i, j))
|
wenzelm@16710
|
850 |
| maxidx_term (Const (_, T)) i = maxidx_typ T i
|
wenzelm@16710
|
851 |
| maxidx_term (Free (_, T)) i = maxidx_typ T i
|
wenzelm@16710
|
852 |
| maxidx_term (Bound _) i = i
|
wenzelm@16710
|
853 |
| maxidx_term (Abs (_, T, t)) i = maxidx_term t (maxidx_typ T i)
|
wenzelm@16710
|
854 |
| maxidx_term (t $ u) i = maxidx_term u (maxidx_term t i);
|
wenzelm@16710
|
855 |
|
wenzelm@16710
|
856 |
fun maxidx_of_typ T = maxidx_typ T ~1;
|
wenzelm@16710
|
857 |
fun maxidx_of_typs Ts = maxidx_typs Ts ~1;
|
wenzelm@16710
|
858 |
fun maxidx_of_term t = maxidx_term t ~1;
|
berghofe@13665
|
859 |
|
clasohm@0
|
860 |
|
clasohm@0
|
861 |
|
wenzelm@29270
|
862 |
(** misc syntax operations **)
|
clasohm@0
|
863 |
|
wenzelm@19909
|
864 |
(* substructure *)
|
wenzelm@4017
|
865 |
|
wenzelm@19909
|
866 |
fun exists_subtype P =
|
wenzelm@19909
|
867 |
let
|
wenzelm@19909
|
868 |
fun ex ty = P ty orelse
|
wenzelm@19909
|
869 |
(case ty of Type (_, Ts) => exists ex Ts | _ => false);
|
wenzelm@19909
|
870 |
in ex end;
|
nipkow@13646
|
871 |
|
wenzelm@20531
|
872 |
fun exists_type P =
|
wenzelm@20531
|
873 |
let
|
wenzelm@20531
|
874 |
fun ex (Const (_, T)) = P T
|
wenzelm@20531
|
875 |
| ex (Free (_, T)) = P T
|
wenzelm@20531
|
876 |
| ex (Var (_, T)) = P T
|
wenzelm@20531
|
877 |
| ex (Bound _) = false
|
wenzelm@20531
|
878 |
| ex (Abs (_, T, t)) = P T orelse ex t
|
wenzelm@20531
|
879 |
| ex (t $ u) = ex t orelse ex u;
|
wenzelm@20531
|
880 |
in ex end;
|
wenzelm@20531
|
881 |
|
wenzelm@16943
|
882 |
fun exists_subterm P =
|
wenzelm@16943
|
883 |
let
|
wenzelm@16943
|
884 |
fun ex tm = P tm orelse
|
wenzelm@16943
|
885 |
(case tm of
|
wenzelm@16943
|
886 |
t $ u => ex t orelse ex u
|
wenzelm@16943
|
887 |
| Abs (_, _, t) => ex t
|
wenzelm@16943
|
888 |
| _ => false);
|
wenzelm@16943
|
889 |
in ex end;
|
obua@16108
|
890 |
|
wenzelm@29270
|
891 |
fun exists_Const P = exists_subterm (fn Const c => P c | _ => false);
|
wenzelm@29270
|
892 |
|
wenzelm@24671
|
893 |
fun has_abs (Abs _) = true
|
wenzelm@24671
|
894 |
| has_abs (t $ u) = has_abs t orelse has_abs u
|
wenzelm@24671
|
895 |
| has_abs _ = false;
|
wenzelm@24671
|
896 |
|
wenzelm@24671
|
897 |
|
wenzelm@20199
|
898 |
(* dest abstraction *)
|
clasohm@0
|
899 |
|
wenzelm@16678
|
900 |
fun dest_abs (x, T, body) =
|
wenzelm@16678
|
901 |
let
|
wenzelm@16678
|
902 |
fun name_clash (Free (y, _)) = (x = y)
|
wenzelm@16678
|
903 |
| name_clash (t $ u) = name_clash t orelse name_clash u
|
wenzelm@16678
|
904 |
| name_clash (Abs (_, _, t)) = name_clash t
|
wenzelm@16678
|
905 |
| name_clash _ = false;
|
wenzelm@16678
|
906 |
in
|
wenzelm@27335
|
907 |
if name_clash body then dest_abs (Name.variant [x] x, T, body) (*potentially slow*)
|
wenzelm@16678
|
908 |
else (x, subst_bound (Free (x, T), body))
|
wenzelm@16678
|
909 |
end;
|
wenzelm@16678
|
910 |
|
clasohm@0
|
911 |
|
wenzelm@9536
|
912 |
(* dummy patterns *)
|
wenzelm@9536
|
913 |
|
wenzelm@9536
|
914 |
val dummy_patternN = "dummy_pattern";
|
wenzelm@9536
|
915 |
|
wenzelm@18253
|
916 |
fun dummy_pattern T = Const (dummy_patternN, T);
|
wenzelm@18253
|
917 |
|
wenzelm@9536
|
918 |
fun is_dummy_pattern (Const ("dummy_pattern", _)) = true
|
wenzelm@9536
|
919 |
| is_dummy_pattern _ = false;
|
wenzelm@9536
|
920 |
|
wenzelm@9536
|
921 |
fun no_dummy_patterns tm =
|
haftmann@16787
|
922 |
if not (fold_aterms (fn t => fn b => b orelse is_dummy_pattern t) tm false) then tm
|
wenzelm@9536
|
923 |
else raise TERM ("Illegal occurrence of '_' dummy pattern", [tm]);
|
wenzelm@9536
|
924 |
|
wenzelm@24733
|
925 |
fun free_dummy_patterns (Const ("dummy_pattern", T)) used =
|
wenzelm@24850
|
926 |
let val [x] = Name.invents used Name.uu 1
|
wenzelm@24733
|
927 |
in (Free (Name.internal x, T), Name.declare x used) end
|
wenzelm@24733
|
928 |
| free_dummy_patterns (Abs (x, T, b)) used =
|
wenzelm@24733
|
929 |
let val (b', used') = free_dummy_patterns b used
|
wenzelm@24733
|
930 |
in (Abs (x, T, b'), used') end
|
wenzelm@24733
|
931 |
| free_dummy_patterns (t $ u) used =
|
wenzelm@24733
|
932 |
let
|
wenzelm@24733
|
933 |
val (t', used') = free_dummy_patterns t used;
|
wenzelm@24733
|
934 |
val (u', used'') = free_dummy_patterns u used';
|
wenzelm@24733
|
935 |
in (t' $ u', used'') end
|
wenzelm@24733
|
936 |
| free_dummy_patterns a used = (a, used);
|
wenzelm@24733
|
937 |
|
wenzelm@24762
|
938 |
fun replace_dummy Ts (Const ("dummy_pattern", T)) i =
|
wenzelm@24762
|
939 |
(list_comb (Var (("_dummy_", i), Ts ---> T), map Bound (0 upto length Ts - 1)), i + 1)
|
wenzelm@24762
|
940 |
| replace_dummy Ts (Abs (x, T, t)) i =
|
wenzelm@24762
|
941 |
let val (t', i') = replace_dummy (T :: Ts) t i
|
wenzelm@24762
|
942 |
in (Abs (x, T, t'), i') end
|
wenzelm@24762
|
943 |
| replace_dummy Ts (t $ u) i =
|
wenzelm@24762
|
944 |
let
|
wenzelm@24762
|
945 |
val (t', i') = replace_dummy Ts t i;
|
wenzelm@24762
|
946 |
val (u', i'') = replace_dummy Ts u i';
|
wenzelm@24762
|
947 |
in (t' $ u', i'') end
|
wenzelm@24762
|
948 |
| replace_dummy _ a i = (a, i);
|
wenzelm@11903
|
949 |
|
wenzelm@11903
|
950 |
val replace_dummy_patterns = replace_dummy [];
|
wenzelm@9536
|
951 |
|
wenzelm@10552
|
952 |
fun is_replaced_dummy_pattern ("_dummy_", _) = true
|
wenzelm@10552
|
953 |
| is_replaced_dummy_pattern _ = false;
|
wenzelm@9536
|
954 |
|
wenzelm@16035
|
955 |
fun show_dummy_patterns (Var (("_dummy_", _), T)) = Const ("dummy_pattern", T)
|
wenzelm@16035
|
956 |
| show_dummy_patterns (t $ u) = show_dummy_patterns t $ show_dummy_patterns u
|
wenzelm@16035
|
957 |
| show_dummy_patterns (Abs (x, T, t)) = Abs (x, T, show_dummy_patterns t)
|
wenzelm@16035
|
958 |
| show_dummy_patterns a = a;
|
wenzelm@16035
|
959 |
|
wenzelm@13484
|
960 |
|
wenzelm@20100
|
961 |
(* display variables *)
|
wenzelm@20100
|
962 |
|
wenzelm@15986
|
963 |
val show_question_marks = ref true;
|
berghofe@15472
|
964 |
|
wenzelm@14786
|
965 |
fun string_of_vname (x, i) =
|
wenzelm@14786
|
966 |
let
|
wenzelm@15986
|
967 |
val question_mark = if ! show_question_marks then "?" else "";
|
wenzelm@15986
|
968 |
val idx = string_of_int i;
|
wenzelm@15986
|
969 |
val dot =
|
wenzelm@15986
|
970 |
(case rev (Symbol.explode x) of
|
wenzelm@15986
|
971 |
_ :: "\\<^isub>" :: _ => false
|
wenzelm@15986
|
972 |
| _ :: "\\<^isup>" :: _ => false
|
wenzelm@15986
|
973 |
| c :: _ => Symbol.is_digit c
|
wenzelm@15986
|
974 |
| _ => true);
|
wenzelm@14786
|
975 |
in
|
wenzelm@15986
|
976 |
if dot then question_mark ^ x ^ "." ^ idx
|
wenzelm@15986
|
977 |
else if i <> 0 then question_mark ^ x ^ idx
|
wenzelm@15986
|
978 |
else question_mark ^ x
|
wenzelm@14786
|
979 |
end;
|
wenzelm@14786
|
980 |
|
wenzelm@14786
|
981 |
fun string_of_vname' (x, ~1) = x
|
wenzelm@14786
|
982 |
| string_of_vname' xi = string_of_vname xi;
|
wenzelm@14786
|
983 |
|
clasohm@1364
|
984 |
end;
|
clasohm@1364
|
985 |
|
wenzelm@4444
|
986 |
structure BasicTerm: BASIC_TERM = Term;
|
wenzelm@4444
|
987 |
open BasicTerm;
|