author  wenzelm 
Wed, 15 Oct 1997 15:13:43 +0200  
changeset 3874  552ce5ad6a2e 
parent 3832  17a20a2af8f5 
child 3973  1be726ef6813 
permissions  rwrr 
41
97aae241094b
added cons, rcons, last_elem, sort_strings, take_suffix;
wenzelm
parents:
24
diff
changeset

1 
(* Title: Pure/library.ML 
0  2 
ID: $Id$ 
233  3 
Author: Lawrence C Paulson, Cambridge University Computer Laboratory 
0  4 
Copyright 1992 University of Cambridge 
5 

233  6 
Basic library: functions, options, pairs, booleans, lists, integers, 
7 
strings, lists as sets, association lists, generic tables, balanced trees, 

2506  8 
orders, input / output, timing, filenames, misc functions. 
0  9 
*) 
10 

1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

11 
infix > ~~ \ \\ orelf ins ins_string ins_int orf andf prefix upto downto 
2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

12 
mem mem_int mem_string union union_int union_string 
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

13 
inter inter_int inter_string subset subset_int subset_string subdir_of; 
1364
8ea1a962ad72
files now define a structure to allow SML/NJ to optimize the code
clasohm
parents:
1290
diff
changeset

14 

8ea1a962ad72
files now define a structure to allow SML/NJ to optimize the code
clasohm
parents:
1290
diff
changeset

15 

8ea1a962ad72
files now define a structure to allow SML/NJ to optimize the code
clasohm
parents:
1290
diff
changeset

16 
structure Library = 
8ea1a962ad72
files now define a structure to allow SML/NJ to optimize the code
clasohm
parents:
1290
diff
changeset

17 
struct 
0  18 

233  19 
(** functions **) 
0  20 

233  21 
(*handy combinators*) 
22 
fun curry f x y = f (x, y); 

23 
fun uncurry f (x, y) = f x y; 

24 
fun I x = x; 

25 
fun K x y = x; 

0  26 

380  27 
(*reverse apply*) 
410  28 
fun (x > f) = f x; 
380  29 

233  30 
(*combine two functions forming the union of their domains*) 
2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

31 
fun (f orelf g) = fn x => f x handle Match => g x; 
0  32 

233  33 
(*application of (infix) operator to its left or right argument*) 
34 
fun apl (x, f) y = f (x, y); 

35 
fun apr (f, y) x = f (x, y); 

0  36 

233  37 
(*functional for pairs*) 
38 
fun pairself f (x, y) = (f x, f y); 

0  39 

233  40 
(*function exponentiation: f(...(f x)...) with n applications of f*) 
41 
fun funpow n f x = 

42 
let fun rep (0, x) = x 

43 
 rep (n, x) = rep (n  1, f x) 

44 
in rep (n, x) end; 

160  45 

46 

47 

2471  48 
(** stamps **) 
49 

50 
type stamp = unit ref; 

51 
val stamp: unit > stamp = ref; 

52 

53 

54 

233  55 
(** options **) 
0  56 

57 
datatype 'a option = None  Some of 'a; 

58 

59 
exception OPTION of string; 

60 

61 
fun the (Some x) = x 

62 
 the None = raise OPTION "the"; 

63 

255
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

64 
fun if_none None y = y 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

65 
 if_none (Some x) _ = x; 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

66 

0  67 
fun is_some (Some _) = true 
68 
 is_some None = false; 

69 

70 
fun is_none (Some _) = false 

71 
 is_none None = true; 

72 

233  73 
fun apsome f (Some x) = Some (f x) 
74 
 apsome _ None = None; 

0  75 

233  76 

77 

78 
(** pairs **) 

79 

80 
fun pair x y = (x, y); 

81 
fun rpair x y = (y, x); 

82 

83 
fun fst (x, y) = x; 

84 
fun snd (x, y) = y; 

85 

86 
fun eq_fst ((x1, _), (x2, _)) = x1 = x2; 

87 
fun eq_snd ((_, y1), (_, y2)) = y1 = y2; 

88 

89 
fun swap (x, y) = (y, x); 

90 

91 
(*apply the function to a component of a pair*) 

92 
fun apfst f (x, y) = (f x, y); 

93 
fun apsnd f (x, y) = (x, f y); 

94 

95 

96 

97 
(** booleans **) 

98 

99 
(* equality *) 

100 

101 
fun equal x y = x = y; 

102 
fun not_equal x y = x <> y; 

103 

104 

105 
(* operators for combining predicates *) 

106 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

107 
fun (p orf q) = fn x => p x orelse q x; 
233  108 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

109 
fun (p andf q) = fn x => p x andalso q x; 
233  110 

111 
fun notf p x = not (p x); 

0  112 

233  113 

114 
(* predicates on lists *) 

115 

116 
fun orl [] = false 

117 
 orl (x :: xs) = x orelse orl xs; 

118 

119 
fun andl [] = true 

120 
 andl (x :: xs) = x andalso andl xs; 

121 

3246  122 
(*Several objectlogics declare theories named List or Option, hiding the 
123 
eponymous basis library structures.*) 

124 
structure List_ = List 

125 
and Option_ = Option; 

2271  126 

233  127 
(*exists pred [x1, ..., xn] ===> pred x1 orelse ... orelse pred xn*) 
128 
fun exists (pred: 'a > bool) : 'a list > bool = 

129 
let fun boolf [] = false 

130 
 boolf (x :: xs) = pred x orelse boolf xs 

131 
in boolf end; 

132 

133 
(*forall pred [x1, ..., xn] ===> pred x1 andalso ... andalso pred xn*) 

134 
fun forall (pred: 'a > bool) : 'a list > bool = 

135 
let fun boolf [] = true 

136 
 boolf (x :: xs) = pred x andalso boolf xs 

137 
in boolf end; 

0  138 

233  139 

380  140 
(* flags *) 
141 

142 
fun set flag = (flag := true; true); 

143 
fun reset flag = (flag := false; false); 

144 
fun toggle flag = (flag := not (! flag); ! flag); 

145 

2978  146 
fun setmp flag value f x = 
2958  147 
let 
148 
val orig_value = ! flag; 

149 
fun return y = (flag := orig_value; y); 

150 
in 

151 
flag := value; 

152 
return (f x handle exn => (return (); raise exn)) 

153 
end; 

154 

380  155 

233  156 

157 
(** lists **) 

158 

159 
exception LIST of string; 

160 

161 
fun null [] = true 

162 
 null (_ :: _) = false; 

163 

164 
fun hd [] = raise LIST "hd" 

165 
 hd (x :: _) = x; 

166 

167 
fun tl [] = raise LIST "tl" 

168 
 tl (_ :: xs) = xs; 

169 

170 
fun cons x xs = x :: xs; 

171 

172 

173 
(* fold *) 

174 

175 
(*the following versions of fold are designed to fit nicely with infixes*) 

0  176 

233  177 
(* (op @) (e, [x1, ..., xn]) ===> ((e @ x1) @ x2) ... @ xn 
178 
for operators that associate to the left (TAIL RECURSIVE)*) 

179 
fun foldl (f: 'a * 'b > 'a) : 'a * 'b list > 'a = 

180 
let fun itl (e, []) = e 

181 
 itl (e, a::l) = itl (f(e, a), l) 

182 
in itl end; 

183 

184 
(* (op @) ([x1, ..., xn], e) ===> x1 @ (x2 ... @ (xn @ e)) 

185 
for operators that associate to the right (not tail recursive)*) 

186 
fun foldr f (l, e) = 

187 
let fun itr [] = e 

188 
 itr (a::l) = f(a, itr l) 

189 
in itr l end; 

190 

191 
(* (op @) [x1, ..., xn] ===> x1 @ (x2 ... @ (x[n1] @ xn)) 

192 
for n > 0, operators that associate to the right (not tail recursive)*) 

193 
fun foldr1 f l = 

194 
let fun itr [x] = x (* FIXME [] case: elim warn (?) *) 

195 
 itr (x::l) = f(x, itr l) 

196 
in itr l end; 

197 

198 

199 
(* basic list functions *) 

200 

201 
(*length of a list, should unquestionably be a standard function*) 

202 
local fun length1 (n, []) = n (*TAIL RECURSIVE*) 

203 
 length1 (n, x :: xs) = length1 (n + 1, xs) 

204 
in fun length l = length1 (0, l) end; 

205 

206 
(*take the first n elements from a list*) 

207 
fun take (n, []) = [] 

208 
 take (n, x :: xs) = 

209 
if n > 0 then x :: take (n  1, xs) else []; 

210 

211 
(*drop the first n elements from a list*) 

212 
fun drop (n, []) = [] 

213 
 drop (n, x :: xs) = 

214 
if n > 0 then drop (n  1, xs) else x :: xs; 

0  215 

233  216 
(*return nth element of a list, where 0 designates the first element; 
217 
raise EXCEPTION if list too short*) 

218 
fun nth_elem NL = 

219 
(case drop NL of 

220 
[] => raise LIST "nth_elem" 

221 
 x :: _ => x); 

222 

223 
(*last element of a list*) 

224 
fun last_elem [] = raise LIST "last_elem" 

225 
 last_elem [x] = x 

226 
 last_elem (_ :: xs) = last_elem xs; 

227 

3762  228 
(*rear decomposition*) 
229 
fun split_last [] = raise LIST "split_last" 

230 
 split_last [x] = ([], x) 

231 
 split_last (x :: xs) = apfst (cons x) (split_last xs); 

232 

233 

233  234 
(*find the position of an element in a list*) 
235 
fun find (x, ys) = 

236 
let fun f (y :: ys, i) = if x = y then i else f (ys, i + 1) 

237 
 f (_, _) = raise LIST "find" 

238 
in f (ys, 0) end; 

239 

240 
(*flatten a list of lists to a list*) 

241 
fun flat (ls: 'c list list) : 'c list = foldr (op @) (ls, []); 

242 

243 

244 
(*like Lisp's MAPC  seq proc [x1, ..., xn] evaluates 

245 
(proc x1; ...; proc xn) for side effects*) 

246 
fun seq (proc: 'a > unit) : 'a list > unit = 

247 
let fun seqf [] = () 

248 
 seqf (x :: xs) = (proc x; seqf xs) 

249 
in seqf end; 

250 

251 

252 
(*separate s [x1, x2, ..., xn] ===> [x1, s, x2, s, ..., s, xn]*) 

253 
fun separate s (x :: (xs as _ :: _)) = x :: s :: separate s xs 

254 
 separate _ xs = xs; 

255 

256 
(*make the list [x, x, ..., x] of length n*) 

257 
fun replicate n (x: 'a) : 'a list = 

258 
let fun rep (0, xs) = xs 

259 
 rep (n, xs) = rep (n  1, x :: xs) 

260 
in 

261 
if n < 0 then raise LIST "replicate" 

262 
else rep (n, []) 

263 
end; 

264 

265 

266 
(* filter *) 

267 

268 
(*copy the list preserving elements that satisfy the predicate*) 

269 
fun filter (pred: 'a>bool) : 'a list > 'a list = 

0  270 
let fun filt [] = [] 
233  271 
 filt (x :: xs) = if pred x then x :: filt xs else filt xs 
272 
in filt end; 

0  273 

274 
fun filter_out f = filter (not o f); 

275 

276 

233  277 
fun mapfilter (f: 'a > 'b option) ([]: 'a list) = [] : 'b list 
278 
 mapfilter f (x :: xs) = 

279 
(case f x of 

280 
None => mapfilter f xs 

281 
 Some y => y :: mapfilter f xs); 

282 

283 

380  284 
fun find_first _ [] = None 
285 
 find_first pred (x :: xs) = 

286 
if pred x then Some x else find_first pred xs; 

287 

288 

233  289 
(* lists of pairs *) 
290 

380  291 
fun map2 _ ([], []) = [] 
292 
 map2 f (x :: xs, y :: ys) = (f (x, y) :: map2 f (xs, ys)) 

293 
 map2 _ _ = raise LIST "map2"; 

294 

295 
fun exists2 _ ([], []) = false 

296 
 exists2 pred (x :: xs, y :: ys) = pred (x, y) orelse exists2 pred (xs, ys) 

297 
 exists2 _ _ = raise LIST "exists2"; 

298 

299 
fun forall2 _ ([], []) = true 

300 
 forall2 pred (x :: xs, y :: ys) = pred (x, y) andalso forall2 pred (xs, ys) 

301 
 forall2 _ _ = raise LIST "forall2"; 

302 

233  303 
(*combine two lists forming a list of pairs: 
304 
[x1, ..., xn] ~~ [y1, ..., yn] ===> [(x1, y1), ..., (xn, yn)]*) 

305 
fun [] ~~ [] = [] 

306 
 (x :: xs) ~~ (y :: ys) = (x, y) :: (xs ~~ ys) 

307 
 _ ~~ _ = raise LIST "~~"; 

308 

309 

310 
(*inverse of ~~; the old 'split': 

311 
[(x1, y1), ..., (xn, yn)] ===> ([x1, ..., xn], [y1, ..., yn])*) 

312 
fun split_list (l: ('a * 'b) list) = (map #1 l, map #2 l); 

313 

314 

315 
(* prefixes, suffixes *) 

316 

317 
fun [] prefix _ = true 

318 
 (x :: xs) prefix (y :: ys) = x = y andalso (xs prefix ys) 

319 
 _ prefix _ = false; 

320 

321 
(* [x1, ..., xi, ..., xn] > ([x1, ..., x(i1)], [xi, ..., xn]) 

322 
where xi is the first element that does not satisfy the predicate*) 

323 
fun take_prefix (pred : 'a > bool) (xs: 'a list) : 'a list * 'a list = 

324 
let fun take (rxs, []) = (rev rxs, []) 

255
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

325 
 take (rxs, x :: xs) = 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

326 
if pred x then take(x :: rxs, xs) else (rev rxs, x :: xs) 
233  327 
in take([], xs) end; 
328 

329 
(* [x1, ..., xi, ..., xn] > ([x1, ..., xi], [x(i+1), ..., xn]) 

330 
where xi is the last element that does not satisfy the predicate*) 

331 
fun take_suffix _ [] = ([], []) 

332 
 take_suffix pred (x :: xs) = 

333 
(case take_suffix pred xs of 

334 
([], sffx) => if pred x then ([], x :: sffx) else ([x], sffx) 

335 
 (prfx, sffx) => (x :: prfx, sffx)); 

336 

337 

338 

339 
(** integers **) 

340 

2958  341 
fun inc i = (i := ! i + 1; ! i); 
342 
fun dec i = (i := ! i  1; ! i); 

233  343 

344 

345 
(* lists of integers *) 

346 

347 
(*make the list [from, from + 1, ..., to]*) 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

348 
fun (from upto to) = 
233  349 
if from > to then [] else from :: ((from + 1) upto to); 
350 

351 
(*make the list [from, from  1, ..., to]*) 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

352 
fun (from downto to) = 
233  353 
if from < to then [] else from :: ((from  1) downto to); 
354 

355 
(*predicate: downto0 (is, n) <=> is = [n, n  1, ..., 0]*) 

356 
fun downto0 (i :: is, n) = i = n andalso downto0 (is, n  1) 

357 
 downto0 ([], n) = n = ~1; 

358 

359 

360 
(* convert integers to strings *) 

361 

362 
(*expand the number in the given base; 

363 
example: radixpand (2, 8) gives [1, 0, 0, 0]*) 

364 
fun radixpand (base, num) : int list = 

365 
let 

366 
fun radix (n, tail) = 

367 
if n < base then n :: tail 

368 
else radix (n div base, (n mod base) :: tail) 

369 
in radix (num, []) end; 

370 

371 
(*expands a number into a string of characters starting from "zerochar"; 

372 
example: radixstring (2, "0", 8) gives "1000"*) 

373 
fun radixstring (base, zerochar, num) = 

374 
let val offset = ord zerochar; 

375 
fun chrof n = chr (offset + n) 

376 
in implode (map chrof (radixpand (base, num))) end; 

377 

378 

3407
afd288caf573
Removal of radixstring from string_of_int; addition of string_of_indexname
paulson
parents:
3393
diff
changeset

379 
val string_of_int = Int.toString; 
233  380 

3407
afd288caf573
Removal of radixstring from string_of_int; addition of string_of_indexname
paulson
parents:
3393
diff
changeset

381 
fun string_of_indexname (a,0) = a 
afd288caf573
Removal of radixstring from string_of_int; addition of string_of_indexname
paulson
parents:
3393
diff
changeset

382 
 string_of_indexname (a,i) = a ^ "_" ^ Int.toString i; 
233  383 

384 

385 
(** strings **) 

386 

387 
fun is_letter ch = 

388 
ord "A" <= ord ch andalso ord ch <= ord "Z" orelse 

389 
ord "a" <= ord ch andalso ord ch <= ord "z"; 

390 

391 
fun is_digit ch = 

392 
ord "0" <= ord ch andalso ord ch <= ord "9"; 

393 

394 
(*letter or _ or prime (')*) 

395 
fun is_quasi_letter "_" = true 

396 
 is_quasi_letter "'" = true 

397 
 is_quasi_letter ch = is_letter ch; 

398 

512
55755ed9fab9
Pure/library/enclose, Pure/Syntax/pretty/enclose: renamed from parents
lcp
parents:
410
diff
changeset

399 
(*white space: blanks, tabs, newlines, formfeeds*) 
233  400 
val is_blank : string > bool = 
3393  401 
fn " " => true  "\t" => true  "\n" => true  "\^L" => true  "\160" => true 
3063  402 
 _ => false; 
233  403 

404 
val is_letdig = is_quasi_letter orf is_digit; 

405 

2196  406 
(*printable chars*) 
407 
fun is_printable c = ord c > ord " " andalso ord c <= ord "~"; 

408 

233  409 

410 
(*lower all chars of string*) 

411 
val to_lower = 

412 
let 

413 
fun lower ch = 

414 
if ch >= "A" andalso ch <= "Z" then 

415 
chr (ord ch  ord "A" + ord "a") 

416 
else ch; 

417 
in implode o (map lower) o explode end; 

418 

419 

512
55755ed9fab9
Pure/library/enclose, Pure/Syntax/pretty/enclose: renamed from parents
lcp
parents:
410
diff
changeset

420 
(*enclose in brackets*) 
55755ed9fab9
Pure/library/enclose, Pure/Syntax/pretty/enclose: renamed from parents
lcp
parents:
410
diff
changeset

421 
fun enclose lpar rpar str = lpar ^ str ^ rpar; 
255
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

422 

233  423 
(*simple quoting (does not escape special chars)*) 
512
55755ed9fab9
Pure/library/enclose, Pure/Syntax/pretty/enclose: renamed from parents
lcp
parents:
410
diff
changeset

424 
val quote = enclose "\"" "\""; 
233  425 

426 
(*space_implode "..." (explode "hello"); gives "h...e...l...l...o"*) 

427 
fun space_implode a bs = implode (separate a bs); 

428 

255
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

429 
val commas = space_implode ", "; 
380  430 
val commas_quote = commas o map quote; 
255
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

431 

233  432 
(*concatenate messages, one per line, into a string*) 
255
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

433 
val cat_lines = space_implode "\n"; 
233  434 

3832
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

435 
(*BAD_space_explode "." "h.e..l.lo"; gives ["h", "e", "l", "lo"]*) 
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

436 
fun BAD_space_explode sep s = 
1290  437 
let fun divide [] "" = [] 
438 
 divide [] part = [part] 

439 
 divide (c::s) part = 

440 
if c = sep then 

441 
(if part = "" then divide s "" else part :: divide s "") 

442 
else divide s (part ^ c) 

443 
in divide (explode s) "" end; 

233  444 

3832
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

445 
(*space_explode "." "h.e..l.lo"; gives ["h", "e", "", "l", "lo"]*) 
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

446 
fun space_explode _ "" = [] 
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

447 
 space_explode sep str = 
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

448 
let 
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

449 
fun expl chs = 
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

450 
(case take_prefix (not_equal sep) chs of 
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

451 
(cs, []) => [implode cs] 
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

452 
 (cs, _ :: cs') => implode cs :: expl cs'); 
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

453 
in expl (explode str) end; 
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

454 

17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

455 
val split_lines = space_explode "\n"; 
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

456 

17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

457 

233  458 

459 
(** lists as sets **) 

460 

461 
(*membership in a list*) 

462 
fun x mem [] = false 

463 
 x mem (y :: ys) = x = y orelse x mem ys; 

0  464 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

465 
(*membership in a list, optimized version for ints*) 
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

466 
fun (x:int) mem_int [] = false 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

467 
 x mem_int (y :: ys) = x = y orelse x mem_int ys; 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

468 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

469 
(*membership in a list, optimized version for strings*) 
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

470 
fun (x:string) mem_string [] = false 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

471 
 x mem_string (y :: ys) = x = y orelse x mem_string ys; 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

472 

0  473 
(*generalized membership test*) 
233  474 
fun gen_mem eq (x, []) = false 
475 
 gen_mem eq (x, y :: ys) = eq (x, y) orelse gen_mem eq (x, ys); 

476 

477 

478 
(*insertion into list if not already there*) 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

479 
fun (x ins xs) = if x mem xs then xs else x :: xs; 
0  480 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

481 
(*insertion into list, optimized version for ints*) 
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

482 
fun (x ins_int xs) = if x mem_int xs then xs else x :: xs; 
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

483 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

484 
(*insertion into list, optimized version for strings*) 
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

485 
fun (x ins_string xs) = if x mem_string xs then xs else x :: xs; 
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

486 

0  487 
(*generalized insertion*) 
233  488 
fun gen_ins eq (x, xs) = if gen_mem eq (x, xs) then xs else x :: xs; 
489 

490 

491 
(*union of sets represented as lists: no repetitions*) 

492 
fun xs union [] = xs 

493 
 [] union ys = ys 

494 
 (x :: xs) union ys = xs union (x ins ys); 

0  495 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

496 
(*union of sets, optimized version for ints*) 
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

497 
fun (xs:int list) union_int [] = xs 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

498 
 [] union_int ys = ys 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

499 
 (x :: xs) union_int ys = xs union_int (x ins_int ys); 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

500 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

501 
(*union of sets, optimized version for strings*) 
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

502 
fun (xs:string list) union_string [] = xs 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

503 
 [] union_string ys = ys 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

504 
 (x :: xs) union_string ys = xs union_string (x ins_string ys); 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

505 

0  506 
(*generalized union*) 
233  507 
fun gen_union eq (xs, []) = xs 
508 
 gen_union eq ([], ys) = ys 

509 
 gen_union eq (x :: xs, ys) = gen_union eq (xs, gen_ins eq (x, ys)); 

510 

511 

512 
(*intersection*) 

513 
fun [] inter ys = [] 

514 
 (x :: xs) inter ys = 

515 
if x mem ys then x :: (xs inter ys) else xs inter ys; 

516 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

517 
(*intersection, optimized version for ints*) 
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

518 
fun ([]:int list) inter_int ys = [] 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

519 
 (x :: xs) inter_int ys = 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

520 
if x mem_int ys then x :: (xs inter_int ys) else xs inter_int ys; 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

521 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

522 
(*intersection, optimized version for strings *) 
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

523 
fun ([]:string list) inter_string ys = [] 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

524 
 (x :: xs) inter_string ys = 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

525 
if x mem_string ys then x :: (xs inter_string ys) else xs inter_string ys; 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

526 

233  527 

528 
(*subset*) 

529 
fun [] subset ys = true 

530 
 (x :: xs) subset ys = x mem ys andalso xs subset ys; 

531 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

532 
(*subset, optimized version for ints*) 
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

533 
fun ([]:int list) subset_int ys = true 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

534 
 (x :: xs) subset_int ys = x mem_int ys andalso xs subset_int ys; 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

535 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

536 
(*subset, optimized version for strings*) 
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

537 
fun ([]:string list) subset_string ys = true 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

538 
 (x :: xs) subset_string ys = x mem_string ys andalso xs subset_string ys; 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

539 

2182
29e56f003599
Removal of polymorphic equality via mem, subset, eq_set, etc
paulson
parents:
2175
diff
changeset

540 
(*set equality for strings*) 
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

541 
fun eq_set_string ((xs:string list), ys) = 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

542 
xs = ys orelse (xs subset_string ys andalso ys subset_string xs); 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

543 

2182
29e56f003599
Removal of polymorphic equality via mem, subset, eq_set, etc
paulson
parents:
2175
diff
changeset

544 
fun gen_subset eq (xs, ys) = forall (fn x => gen_mem eq (x, ys)) xs; 
29e56f003599
Removal of polymorphic equality via mem, subset, eq_set, etc
paulson
parents:
2175
diff
changeset

545 

265  546 

233  547 
(*removing an element from a list WITHOUT duplicates*) 
548 
fun (y :: ys) \ x = if x = y then ys else y :: (ys \ x) 

549 
 [] \ x = []; 

550 

2243
3ebeaaacfbd1
Etaexpanded some declarations that are illegal under value polymorphism
paulson
parents:
2196
diff
changeset

551 
fun ys \\ xs = foldl (op \) (ys,xs); 
0  552 

233  553 
(*removing an element from a list  possibly WITH duplicates*) 
554 
fun gen_rem eq (xs, y) = filter_out (fn x => eq (x, y)) xs; 

555 

2243
3ebeaaacfbd1
Etaexpanded some declarations that are illegal under value polymorphism
paulson
parents:
2196
diff
changeset

556 
fun gen_rems eq = foldl (gen_rem eq); 
233  557 

558 

559 
(*makes a list of the distinct members of the input; preserves order, takes 

560 
first of equal elements*) 

561 
fun gen_distinct eq lst = 

562 
let 

563 
val memb = gen_mem eq; 

0  564 

233  565 
fun dist (rev_seen, []) = rev rev_seen 
566 
 dist (rev_seen, x :: xs) = 

567 
if memb (x, rev_seen) then dist (rev_seen, xs) 

568 
else dist (x :: rev_seen, xs); 

569 
in 

570 
dist ([], lst) 

571 
end; 

572 

2243
3ebeaaacfbd1
Etaexpanded some declarations that are illegal under value polymorphism
paulson
parents:
2196
diff
changeset

573 
fun distinct l = gen_distinct (op =) l; 
233  574 

575 

576 
(*returns the tail beginning with the first repeated element, or []*) 

577 
fun findrep [] = [] 

578 
 findrep (x :: xs) = if x mem xs then x :: xs else findrep xs; 

579 

580 

255
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

581 
(*returns a list containing all repeated elements exactly once; preserves 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

582 
order, takes first of equal elements*) 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

583 
fun gen_duplicates eq lst = 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

584 
let 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

585 
val memb = gen_mem eq; 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

586 

ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

587 
fun dups (rev_dups, []) = rev rev_dups 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

588 
 dups (rev_dups, x :: xs) = 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

589 
if memb (x, rev_dups) orelse not (memb (x, xs)) then 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

590 
dups (rev_dups, xs) 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

591 
else dups (x :: rev_dups, xs); 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

592 
in 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

593 
dups ([], lst) 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

594 
end; 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

595 

2243
3ebeaaacfbd1
Etaexpanded some declarations that are illegal under value polymorphism
paulson
parents:
2196
diff
changeset

596 
fun duplicates l = gen_duplicates (op =) l; 
255
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

597 

ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

598 

233  599 

600 
(** association lists **) 

0  601 

233  602 
(*association list lookup*) 
603 
fun assoc ([], key) = None 

604 
 assoc ((keyi, xi) :: pairs, key) = 

605 
if key = keyi then Some xi else assoc (pairs, key); 

606 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

607 
(*association list lookup, optimized version for ints*) 
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

608 
fun assoc_int ([], (key:int)) = None 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

609 
 assoc_int ((keyi, xi) :: pairs, key) = 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

610 
if key = keyi then Some xi else assoc_int (pairs, key); 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

611 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

612 
(*association list lookup, optimized version for strings*) 
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

613 
fun assoc_string ([], (key:string)) = None 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

614 
 assoc_string ((keyi, xi) :: pairs, key) = 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

615 
if key = keyi then Some xi else assoc_string (pairs, key); 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

616 

2175
21fde76bc742
Updated syntax; shortened comments; put in monomorphic versions of ins
paulson
parents:
2157
diff
changeset

617 
(*association list lookup, optimized version for string*ints*) 
1576
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

618 
fun assoc_string_int ([], (key:string*int)) = None 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

619 
 assoc_string_int ((keyi, xi) :: pairs, key) = 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

620 
if key = keyi then Some xi else assoc_string_int (pairs, key); 
af8f43f742a0
Added some optimized versions of functions dealing with sets
berghofe
parents:
1460
diff
changeset

621 

233  622 
fun assocs ps x = 
623 
(case assoc (ps, x) of 

624 
None => [] 

625 
 Some ys => ys); 

626 

255
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

627 
(*twofold association list lookup*) 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

628 
fun assoc2 (aal, (key1, key2)) = 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

629 
(case assoc (aal, key1) of 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

630 
Some al => assoc (al, key2) 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

631 
 None => None); 
ee132db91681
added if_none, parents, commas, gen_duplicates, duplicates, assoc2;
wenzelm
parents:
245
diff
changeset

632 

233  633 
(*generalized association list lookup*) 
634 
fun gen_assoc eq ([], key) = None 

635 
 gen_assoc eq ((keyi, xi) :: pairs, key) = 

636 
if eq (key, keyi) then Some xi else gen_assoc eq (pairs, key); 

637 

638 
(*association list update*) 

639 
fun overwrite (al, p as (key, _)) = 

640 
let fun over ((q as (keyi, _)) :: pairs) = 

641 
if keyi = key then p :: pairs else q :: (over pairs) 

642 
 over [] = [p] 

643 
in over al end; 

644 

2522  645 
fun gen_overwrite eq (al, p as (key, _)) = 
646 
let fun over ((q as (keyi, _)) :: pairs) = 

647 
if eq (keyi, key) then p :: pairs else q :: (over pairs) 

648 
 over [] = [p] 

649 
in over al end; 

650 

233  651 

652 

653 
(** generic tables **) 

0  654 

233  655 
(*Tables are supposed to be 'efficient' encodings of lists of elements distinct 
656 
wrt. an equality "eq". The extend and merge operations below are optimized 

657 
for longterm space efficiency.*) 

658 

659 
(*append (new) elements to a table*) 

660 
fun generic_extend _ _ _ tab [] = tab 

661 
 generic_extend eq dest_tab mk_tab tab1 lst2 = 

662 
let 

663 
val lst1 = dest_tab tab1; 

664 
val new_lst2 = gen_rems eq (lst2, lst1); 

665 
in 

666 
if null new_lst2 then tab1 

667 
else mk_tab (lst1 @ new_lst2) 

668 
end; 

0  669 

233  670 
(*append (new) elements of 2nd table to 1st table*) 
671 
fun generic_merge eq dest_tab mk_tab tab1 tab2 = 

672 
let 

673 
val lst1 = dest_tab tab1; 

674 
val lst2 = dest_tab tab2; 

675 
val new_lst2 = gen_rems eq (lst2, lst1); 

676 
in 

677 
if null new_lst2 then tab1 

678 
else if gen_subset eq (lst1, lst2) then tab2 

679 
else mk_tab (lst1 @ new_lst2) 

680 
end; 

0  681 

233  682 

683 
(*lists as tables*) 

2243
3ebeaaacfbd1
Etaexpanded some declarations that are illegal under value polymorphism
paulson
parents:
2196
diff
changeset

684 
fun extend_list tab = generic_extend (op =) I I tab; 
3ebeaaacfbd1
Etaexpanded some declarations that are illegal under value polymorphism
paulson
parents:
2196
diff
changeset

685 
fun merge_lists tab = generic_merge (op =) I I tab; 
233  686 

380  687 
fun merge_rev_lists xs [] = xs 
688 
 merge_rev_lists [] ys = ys 

689 
 merge_rev_lists xs (y :: ys) = 

690 
(if y mem xs then I else cons y) (merge_rev_lists xs ys); 

691 

0  692 

693 

233  694 
(** balanced trees **) 
695 

696 
exception Balance; (*indicates nonpositive argument to balancing fun*) 

697 

698 
(*balanced folding; avoids deep nesting*) 

699 
fun fold_bal f [x] = x 

700 
 fold_bal f [] = raise Balance 

701 
 fold_bal f xs = 

702 
let val k = length xs div 2 

703 
in f (fold_bal f (take(k, xs)), 

704 
fold_bal f (drop(k, xs))) 

705 
end; 

706 

707 
(*construct something of the form f(...g(...(x)...)) for balanced access*) 

708 
fun access_bal (f, g, x) n i = 

709 
let fun acc n i = (*1<=i<=n*) 

710 
if n=1 then x else 

711 
let val n2 = n div 2 

712 
in if i<=n2 then f (acc n2 i) 

713 
else g (acc (nn2) (in2)) 

714 
end 

715 
in if 1<=i andalso i<=n then acc n i else raise Balance end; 

716 

717 
(*construct ALL such accesses; could try harder to share recursive calls!*) 

718 
fun accesses_bal (f, g, x) n = 

719 
let fun acc n = 

720 
if n=1 then [x] else 

721 
let val n2 = n div 2 

722 
val acc2 = acc n2 

723 
in if nn2=n2 then map f acc2 @ map g acc2 

724 
else map f acc2 @ map g (acc (nn2)) end 

725 
in if 1<=n then acc n else raise Balance end; 

726 

727 

728 

2506  729 
(** orders **) 
730 

731 
datatype order = LESS  EQUAL  GREATER; 

732 

733 
fun intord (i, j: int) = 

734 
if i < j then LESS 

735 
else if i = j then EQUAL 

736 
else GREATER; 

737 

738 
fun stringord (a, b: string) = 

739 
if a < b then LESS 

740 
else if a = b then EQUAL 

741 
else GREATER; 

742 

743 

744 

3525  745 
(** input / output and diagnostics **) 
233  746 

2243
3ebeaaacfbd1
Etaexpanded some declarations that are illegal under value polymorphism
paulson
parents:
2196
diff
changeset

747 
val cd = OS.FileSys.chDir; 
2317  748 
val pwd = OS.FileSys.getDir; 
2243
3ebeaaacfbd1
Etaexpanded some declarations that are illegal under value polymorphism
paulson
parents:
2196
diff
changeset

749 

3525  750 

751 
local 

752 
fun out s = 

753 
(TextIO.output (TextIO.stdOut, s); TextIO.flushOut TextIO.stdOut); 

754 

755 
fun prefix_lines prfx txt = 

3832
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

756 
txt > split_lines > map (fn s => prfx ^ s ^ "\n") > implode; 
3525  757 
in 
758 

759 
(*hooks for output channels: normal, warning, error*) 

760 
val prs_fn = ref (fn s => out s); 

761 
val warning_fn = ref (fn s => out (prefix_lines "### " s)); 

762 
val error_fn = ref (fn s => out (prefix_lines "*** " s)); 

763 

764 
end; 

1580
e3fd931e6095
Added some functions which allow redirection of Isabelle's output
berghofe
parents:
1576
diff
changeset

765 

e3fd931e6095
Added some functions which allow redirection of Isabelle's output
berghofe
parents:
1576
diff
changeset

766 
fun prs s = !prs_fn s; 
233  767 
fun writeln s = prs (s ^ "\n"); 
768 

3525  769 
fun warning s = !warning_fn s; 
233  770 

771 
(*print error message and abort to top level*) 

772 
exception ERROR; 

3874  773 
fun error_msg s = !error_fn s; (*promise to raise ERROR later!*) 
3553  774 
fun error s = (error_msg s; raise ERROR); 
775 
fun sys_error msg = (error_msg " !! SYSTEM ERROR !!\n"; error msg); 

233  776 

777 
fun assert p msg = if p then () else error msg; 

778 
fun deny p msg = if p then error msg else (); 

779 

544
c53386a5bcf1
Pure/library/assert_all: new, moved from ZF/ind_syntax.ML
lcp
parents:
512
diff
changeset

780 
(*Assert pred for every member of l, generating a message if pred fails*) 
c53386a5bcf1
Pure/library/assert_all: new, moved from ZF/ind_syntax.ML
lcp
parents:
512
diff
changeset

781 
fun assert_all pred l msg_fn = 
c53386a5bcf1
Pure/library/assert_all: new, moved from ZF/ind_syntax.ML
lcp
parents:
512
diff
changeset

782 
let fun asl [] = () 
2243
3ebeaaacfbd1
Etaexpanded some declarations that are illegal under value polymorphism
paulson
parents:
2196
diff
changeset

783 
 asl (x::xs) = if pred x then asl xs 
3ebeaaacfbd1
Etaexpanded some declarations that are illegal under value polymorphism
paulson
parents:
2196
diff
changeset

784 
else error (msg_fn x) 
544
c53386a5bcf1
Pure/library/assert_all: new, moved from ZF/ind_syntax.ML
lcp
parents:
512
diff
changeset

785 
in asl l end; 
233  786 

3624  787 

3699  788 
(* handle errors (capturing messages) *) 
789 

790 
datatype 'a error = 

791 
Error of string  

792 
OK of 'a; 

793 

794 
fun handle_error f x = 

795 
let 

796 
val buffer = ref ""; 

797 
fun capture s = buffer := ! buffer ^ s ^ "\n"; 

798 
val result = Some (setmp error_fn capture f x) handle ERROR => None; 

799 
in 

800 
case result of 

801 
None => Error (! buffer) 

802 
 Some y => OK y 

803 
end; 

804 

805 

3624  806 
(* read / write files *) 
807 

808 
fun read_file name = 

809 
let 

810 
val instream = TextIO.openIn name; 

811 
val intext = TextIO.inputAll instream; 

812 
in 

813 
TextIO.closeIn instream; 

814 
intext 

815 
end; 

816 

817 
fun write_file name txt = 

3645  818 
let val outstream = TextIO.openOut name in 
819 
TextIO.output (outstream, txt); 

820 
TextIO.closeOut outstream 

821 
end; 

822 

823 
fun append_file name txt = 

824 
let val outstream = TextIO.openAppend name in 

3624  825 
TextIO.output (outstream, txt); 
826 
TextIO.closeOut outstream 

827 
end; 

828 

829 

830 
(*for the "test" target in IsaMakefiles  signifies successful termination*) 

233  831 
fun maketest msg = 
3624  832 
(writeln msg; write_file "test" "Test examples ran successfully\n"); 
233  833 

834 

835 
(*print a list surrounded by the brackets lpar and rpar, with comma separator 

836 
print nothing for empty list*) 

837 
fun print_list (lpar, rpar, pre: 'a > unit) (l : 'a list) = 

838 
let fun prec x = (prs ","; pre x) 

839 
in 

840 
(case l of 

841 
[] => () 

842 
 x::l => (prs lpar; pre x; seq prec l; prs rpar)) 

843 
end; 

844 

845 
(*print a list of items separated by newlines*) 

846 
fun print_list_ln (pre: 'a > unit) : 'a list > unit = 

847 
seq (fn x => (pre x; writeln "")); 

848 

849 

850 
val print_int = prs o string_of_int; 

851 

852 

3525  853 
(* output to LaTeX / xdvi *) 
854 
fun latex s = 

855 
execute ("( cd /tmp ; echo \"" ^ s ^ 

856 
"\"  isa2latex s > $$.tex ; latex $$.tex ; xdvi $$.dvi ; rm $$.* ) > /dev/null &"); 

857 

233  858 

859 
(** timing **) 

860 

861 
(*unconditional timing function*) 

2243
3ebeaaacfbd1
Etaexpanded some declarations that are illegal under value polymorphism
paulson
parents:
2196
diff
changeset

862 
fun timeit x = cond_timeit true x; 
233  863 

864 
(*timed application function*) 

865 
fun timeap f x = timeit (fn () => f x); 

866 

867 
(*timed "use" function, printing filenames*) 

868 
fun time_use fname = timeit (fn () => 

869 
(writeln ("\n**** Starting " ^ fname ^ " ****"); use fname; 

870 
writeln ("\n**** Finished " ^ fname ^ " ****"))); 

871 

3624  872 
(*use the file, but exit with error code if errors found.*) 
955
aa0c5f9daf5b
Declares the function exit_use to behave like use but fail if
lcp
parents:
544
diff
changeset

873 
fun exit_use fname = use fname handle _ => exit 1; 
233  874 

875 

1407  876 
(** filenames and paths **) 
233  877 

1290  878 
(*Convert UNIX filename of the form "path/file" to "path/" and "file"; 
233  879 
if filename contains no slash, then it returns "" and "file"*) 
880 
val split_filename = 

881 
(pairself implode) o take_suffix (not_equal "/") o explode; 

882 

883 
val base_name = #2 o split_filename; 

884 

1290  885 
(*Merge splitted filename (path and file); 
233  886 
if path does not end with one a slash is appended*) 
887 
fun tack_on "" name = name 

888 
 tack_on path name = 

889 
if last_elem (explode path) = "/" then path ^ name 

890 
else path ^ "/" ^ name; 

891 

1290  892 
(*Remove the extension of a filename, i.e. the part after the last '.'*) 
233  893 
val remove_ext = implode o #1 o take_suffix (not_equal ".") o explode; 
894 

1290  895 
(*Make relative path to reach an absolute location from a different one*) 
896 
fun relative_path cur_path dest_path = 

897 
let (*Remove common beginning of both paths and make relative path*) 

898 
fun mk_relative [] [] = [] 

899 
 mk_relative [] ds = ds 

900 
 mk_relative cs [] = map (fn _ => "..") cs 

901 
 mk_relative (c::cs) (d::ds) = 

902 
if c = d then mk_relative cs ds 

903 
else ".." :: map (fn _ => "..") cs @ (d::ds); 

904 
in if cur_path = "" orelse hd (explode cur_path) <> "/" orelse 

905 
dest_path = "" orelse hd (explode dest_path) <> "/" then 

906 
error "Relative or empty path passed to relative_path" 

907 
else (); 

3832
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

908 
space_implode "/" (mk_relative (BAD_space_explode "/" cur_path) 
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

909 
(BAD_space_explode "/" dest_path)) 
1290  910 
end; 
233  911 

1407  912 
(*Determine if absolute path1 is a subdirectory of absolute path2*) 
913 
fun path1 subdir_of path2 = 

914 
if hd (explode path1) <> "/" orelse hd (explode path2) <> "/" then 

915 
error "Relative or empty path passed to subdir_of" 

3832
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

916 
else (BAD_space_explode "/" path2) prefix (BAD_space_explode "/" path1); 
1407  917 

1456  918 
fun absolute_path cwd file = 
919 
let fun rm_points [] result = rev result 

920 
 rm_points (".."::ds) result = rm_points ds (tl result) 

921 
 rm_points ("."::ds) result = rm_points ds result 

922 
 rm_points (d::ds) result = rm_points ds (d::result); 

923 
in if file = "" then "" 

924 
else if hd (explode file) = "/" then file 

925 
else "/" ^ space_implode "/" 

3832
17a20a2af8f5
fixed space_explode, old one retained as BAD_space_explode;
wenzelm
parents:
3762
diff
changeset

926 
(rm_points (BAD_space_explode "/" (tack_on cwd file)) []) 
1456  927 
end; 
928 

3606  929 
fun file_exists file = (file_info file <> ""); 
930 

233  931 

932 
(** misc functions **) 

933 

934 
(*use the keyfun to make a list of (x, key) pairs*) 

0  935 
fun make_keylist (keyfun: 'a>'b) : 'a list > ('a * 'b) list = 
233  936 
let fun keypair x = (x, keyfun x) 
937 
in map keypair end; 

0  938 

233  939 
(*given a list of (x, key) pairs and a searchkey 
0  940 
return the list of xs from each pair whose key equals searchkey*) 
941 
fun keyfilter [] searchkey = [] 

233  942 
 keyfilter ((x, key) :: pairs) searchkey = 
943 
if key = searchkey then x :: keyfilter pairs searchkey 

944 
else keyfilter pairs searchkey; 

0  945 

946 

947 
(*Partition list into elements that satisfy predicate and those that don't. 

233  948 
Preserves order of elements in both lists.*) 
0  949 
fun partition (pred: 'a>bool) (ys: 'a list) : ('a list * 'a list) = 
950 
let fun part ([], answer) = answer 

233  951 
 part (x::xs, (ys, ns)) = if pred(x) 
952 
then part (xs, (x::ys, ns)) 

953 
else part (xs, (ys, x::ns)) 

954 
in part (rev ys, ([], [])) end; 

0  955 

956 

957 
fun partition_eq (eq:'a * 'a > bool) = 

958 
let fun part [] = [] 

233  959 
 part (x::ys) = let val (xs, xs') = partition (apl(x, eq)) ys 
960 
in (x::xs)::(part xs') end 

0  961 
in part end; 
962 

963 

233  964 
(*Partition a list into buckets [ bi, b(i+1), ..., bj ] 
0  965 
putting x in bk if p(k)(x) holds. Preserve order of elements if possible.*) 
966 
fun partition_list p i j = 

233  967 
let fun part k xs = 
968 
if k>j then 

0  969 
(case xs of [] => [] 
970 
 _ => raise LIST "partition_list") 

971 
else 

233  972 
let val (ns, rest) = partition (p k) xs; 
973 
in ns :: part(k+1)rest end 

0  974 
in part i end; 
975 

976 

233  977 
(* sorting *) 
978 

979 
(*insertion sort; stable (does not reorder equal elements) 

980 
'less' is lessthan test on type 'a*) 

981 
fun sort (less: 'a*'a > bool) = 

0  982 
let fun insert (x, []) = [x] 
233  983 
 insert (x, y::ys) = 
984 
if less(y, x) then y :: insert (x, ys) else x::y::ys; 

0  985 
fun sort1 [] = [] 
986 
 sort1 (x::xs) = insert (x, sort1 xs) 

987 
in sort1 end; 

988 

41
97aae241094b
added cons, rcons, last_elem, sort_strings, take_suffix;
wenzelm
parents:
24
diff
changeset

989 
(*sort strings*) 
97aae241094b
added cons, rcons, last_elem, sort_strings, take_suffix;
wenzelm
parents:
24
diff
changeset

990 
val sort_strings = sort (op <= : string * string > bool); 
97aae241094b
added cons, rcons, last_elem, sort_strings, take_suffix;
wenzelm
parents:
24
diff
changeset

991 

97aae241094b
added cons, rcons, last_elem, sort_strings, take_suffix;
wenzelm
parents:
24
diff
changeset

992 

233  993 
(* transitive closure (not Warshall's algorithm) *) 
0  994 

233  995 
fun transitive_closure [] = [] 
996 
 transitive_closure ((x, ys)::ps) = 

997 
let val qs = transitive_closure ps 

2182
29e56f003599
Removal of polymorphic equality via mem, subset, eq_set, etc
paulson
parents:
2175
diff
changeset

998 
val zs = foldl (fn (zs, y) => assocs qs y union_string zs) (ys, ys) 
29e56f003599
Removal of polymorphic equality via mem, subset, eq_set, etc
paulson
parents:
2175
diff
changeset

999 
fun step(u, us) = (u, if x mem_string us then zs union_string us 
2243
3ebeaaacfbd1
Etaexpanded some declarations that are illegal under value polymorphism
paulson
parents:
2196
diff
changeset

1000 
else us) 
233  1001 
in (x, zs) :: map step qs end; 
0  1002 

1003 

233  1004 
(* generating identifiers *) 
0  1005 

1006 
local 

233  1007 
val a = ord "a" and z = ord "z" and A = ord "A" and Z = ord "Z" 
1008 
and k0 = ord "0" and k9 = ord "9" 

2003  1009 

2806
772f6bba48a1
gensym no longer generates random identifiers, but just enumerates them
paulson
parents:
2522
diff
changeset

1010 
val seedr = ref 0; 
0  1011 
in 
1012 

2003  1013 
(*Maps 063 to AZ, az, 09 or _ or ' for generating random identifiers*) 
1014 
fun newid n = 

1015 
let fun char i = 

1016 
if i<26 then chr (A+i) 

1017 
else if i<52 then chr (a+i26) 

1018 
else if i<62 then chr (k0+i52) 

1019 
else if i=62 then "_" 

1020 
else (*i=63*) "'" 

1021 
in implode (map char (radixpand (64,n))) end; 

1022 

2806
772f6bba48a1
gensym no longer generates random identifiers, but just enumerates them
paulson
parents:
2522
diff
changeset

1023 
(*Freshly generated identifiers with given prefix; MUST start with a letter*) 
2003  1024 
fun gensym pre = pre ^ 
2806
772f6bba48a1
gensym no longer generates random identifiers, but just enumerates them
paulson
parents:
2522
diff
changeset

1025 
(#1(newid (!seedr), 
772f6bba48a1
gensym no longer generates random identifiers, but just enumerates them
paulson
parents:
2522
diff
changeset

1026 
seedr := 1+ !seedr)) 
2003  1027 

0  1028 
(*Increment a list of letters like a reversed base 26 number. 
233  1029 
If head is "z", bumps chars in tail. 
0  1030 
Digits are incremented as if they were integers. 
1031 
"_" and "'" are not changed. 

233  1032 
For making variants of identifiers.*) 
0  1033 

1034 
fun bump_int_list(c::cs) = if c="9" then "0" :: bump_int_list cs else 

233  1035 
if k0 <= ord(c) andalso ord(c) < k9 then chr(ord(c)+1) :: cs 
1036 
else "1" :: c :: cs 

0  1037 
 bump_int_list([]) = error("bump_int_list: not an identifier"); 
1038 

233  1039 
fun bump_list([], d) = [d] 
1040 
 bump_list(["'"], d) = [d, "'"] 

1041 
 bump_list("z"::cs, _) = "a" :: bump_list(cs, "a") 

1042 
 bump_list("Z"::cs, _) = "A" :: bump_list(cs, "A") 

1043 
 bump_list("9"::cs, _) = "0" :: bump_int_list cs 

1044 
 bump_list(c::cs, _) = let val k = ord(c) 

1045 
in if (a <= k andalso k < z) orelse (A <= k andalso k < Z) orelse 

1046 
(k0 <= k andalso k < k9) then chr(k+1) :: cs else 

1047 
if c="'" orelse c="_" then c :: bump_list(cs, "") else 

1048 
error("bump_list: not legal in identifier: " ^ 

1049 
implode(rev(c::cs))) 

1050 
end; 

0  1051 

1052 
end; 

1053 

233  1054 
fun bump_string s : string = implode (rev (bump_list(rev(explode s), ""))); 
41
97aae241094b
added cons, rcons, last_elem, sort_strings, take_suffix;
wenzelm
parents:
24
diff
changeset

1055 

97aae241094b
added cons, rcons, last_elem, sort_strings, take_suffix;
wenzelm
parents:
24
diff
changeset

1056 

233  1057 
(* lexical scanning *) 
0  1058 

233  1059 
(*scan a list of characters into "words" composed of "letters" (recognized by 
1060 
is_let) and separated by any number of non"letters"*) 

1061 
fun scanwords is_let cs = 

0  1062 
let fun scan1 [] = [] 
233  1063 
 scan1 cs = 
1064 
let val (lets, rest) = take_prefix is_let cs 

1065 
in implode lets :: scanwords is_let rest end; 

1066 
in scan1 (#2 (take_prefix (not o is_let) cs)) end; 

24
f3d4ff75d9f2
added functions that operate on filenames: split_filename (originally located
clasohm
parents:
0
diff
changeset

1067 

1364
8ea1a962ad72
files now define a structure to allow SML/NJ to optimize the code
clasohm
parents:
1290
diff
changeset

1068 
end; 
8ea1a962ad72
files now define a structure to allow SML/NJ to optimize the code
clasohm
parents:
1290
diff
changeset

1069 

1592  1070 
(*Variablebranching trees: for proof terms*) 
1071 
datatype 'a mtree = Join of 'a * 'a mtree list; 

1072 

1364
8ea1a962ad72
files now define a structure to allow SML/NJ to optimize the code
clasohm
parents:
1290
diff
changeset

1073 
open Library; 