-
Notifications
You must be signed in to change notification settings - Fork 6
/
util.scm
605 lines (523 loc) · 17.4 KB
/
util.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
#lang scheme/base
(require scheme/list
(only-in (lib "1.ss" "srfi")
reverse! zip unzip1 unzip2 (remove removef)
delete-duplicates! concatenate any iota
alist-cons break cons* delete-duplicates every fold-right reduce find
lset-difference lset-union pair-fold-right unfold span take take-while
delete drop fold pair-fold delete! list-index
)
(lib "26.ss" "srfi")
(lib "2.ss" "srfi")
(only-in (lib "13.ss" "srfi")
string-join string-trim string-trim-right string-trim-both
string-reverse string-reverse!)
(lib "pregexp.ss")
mzlib/defmacro
(for-syntax scheme/base)
scheme/match
(lib "pretty.ss")
(lib "unit.ss")
(only-in file/md5 md5)
)
(provide first
second
rest
empty?
sort
vector-for-each
vector-list-map
map-i
for-each-i
replace-i
transform-i
iota
zip
unzip1
unzip2
concatenate
take
take-while
take-up-to
drop
drop-up-to
partition
span
break
safe-list-ref
last
last-pair
length=
length>
assoc-val
alist-key-filter
repeat-thunk-in-list
cut
cute
cross
filter
filter-map
append-map
removef
delete
delete!
delete-duplicates
delete-duplicates!
find
any
every
hash
map-hash
sub-hash-set!
hash-exists?
hash-keys
hash-singleton-value
hash-filter-map
hash-hash-map
hash-find
alist->hash
bucketed-hash-add!
fold ;(iterative-style)
fold-right ;(recursive-style)
reduce
reduce-right-result
pair-fold
pair-fold-right
file-line-fold
unfold
cons*
cons-to-end
listify
alist-cons
alist-merge
receive
list-join
list-index
aif
awhen
aand
and-let*
pregexp-split
pregexp-match
pregexp-match-positions
pregexp-replace
pregexp-replace*
pregexp-replace-many
regexp-replace-in-list*
string-join
string-ellide
capitalize-word
string-trim
string-trim-right
string-trim-both
string-reverse
string-reverse!
->string
pretty-print
pretty-string
lset-difference
lset-union
random-choice
random-choice-and-remove
random-sub-list
random-key-string
e
round-k
show
prn
(all-from-out scheme/match)
splice-if
asplice-if
call-with-keyword-override
make-recursive-keyword-version-of-fn
max-f
max-f-elt
sync-on-lock
make-lock
md5-string
)
(define (random-choice lst)
(list-ref lst (random (length lst))))
(define (random-sub-list lst)
(cond ((empty? lst) '())
((= (random 2) 0) (cons (first lst) (random-sub-list (rest lst))))
(else (random-sub-list (rest lst)))))
(define (repeat-thunk-in-list thunk n)
(let ((result '()))
(let lp ((n n))
(if (zero? n) result (begin (set! result (cons (thunk) result)) (lp (- n 1)))))))
(define random-key-string
(let* ((choices '("b" "c" "d" "f" "g" "h" "j" "k" "m" "n" "p" "q" "r" "s" "t" "u" "v"
"x" "y" "z" "2" "3" "4" "5" "6" "7" "8" "9"))
(len (length choices)))
(lambda (key-len) (apply string-append (repeat-thunk-in-list
(lambda () (list-ref choices (random len)))
key-len)))))
(define (length= lst n)
(= (length lst) n))
(define (length> lst n)
(> (length lst) n))
(define-syntax show
(syntax-rules ()
((_ expr)
(let ((val expr))
(display (format "Expr ~A => ~A\n" 'expr val))
val))))
;; like show, but return "" instead of the value computed; also takes any number of
;; expressions; useful in web debugging because the return value ("") won't affect the
;; page if used.
(define-syntax prn
(syntax-rules ()
((_ expr ...)
(begin (show expr) ...
"You are trying to use the return value from the prn function. Bad you."))))
;; returns VAL X LST
(define (random-choice-and-remove lst)
(let ((to-go (random (length lst)))
(result '()))
(let lp ((i 0) (lst lst))
(if (= i to-go)
(values (first lst) (append (reverse! result) (rest lst)))
(begin (set! result (cons (first lst) result))
(lp (+ i 1) (rest lst)))))))
(define-syntax receive
(syntax-rules ()
((_ (var ...) values-expr body ...)
(let-values (((var ...) values-expr)) body ...))))
(define (map-i f . lsts)
(let lp ((i 0) (lst-ptrs lsts))
(if (null? (first lst-ptrs))
'()
(cons (apply f i (map first lst-ptrs))
(lp (+ i 1) (map rest lst-ptrs))))))
(define (replace-i lst i new-elt)
(transform-i lst i (lambda (x) new-elt)))
(define (transform-i lst i f)
(map-i (lambda (j elt) (if (= j i) (f elt) elt)) lst))
(define-syntax hash
(syntax-rules (=)
((_ (key = val) ...)
(let ((ht (make-hash)))
(hash-set! ht `key val) ...
ht))))
(define (alist->hash alist)
(let ((ht (make-hash)))
(for-each (match-lambda ((list-rest k v) (hash-set! ht k v))) alist)
ht))
(define (vector-for-each fn . vs)
(let ((len (vector-length (first vs))))
(let lp ((i 0))
(if (>= i len)
'done
(begin (apply fn (map (lambda (v) (vector-ref v i)) vs))
(lp (+ 1 i)))))))
(define (vector-for-each-i fn . vs)
(let ((len (vector-length (first vs))))
(let lp ((i 0))
(if (>= i len)
'done
(begin (apply fn i (map (lambda (v) (vector-ref v i)) vs))
(lp (+ 1 i)))))))
(define (vector-list-map fn . vs)
(let ((len (vector-length (first vs))))
(let lp ((i 0))
(if (>= i len)
'()
(cons (apply fn (map (lambda (v) (vector-ref v i)) vs))
(lp (+ 1 i)))))))
;; mutates starting-vector
(define (make-counter! starting-vector ending-vector)
(let ((len (vector-length starting-vector)))
;; returns #f when done
(lambda ()
(let lp ((i (- len 1)))
(and (>= i 0)
(let ((cur (+ 1 (vector-ref starting-vector i))))
(vector-set! starting-vector i cur)
(if (<= cur (vector-ref ending-vector i))
starting-vector
(begin (vector-set! starting-vector i 0)
(lp (- i 1))))))))))
(define (for-each-i fn . lists)
(let lp ((i 0) (lists lists))
(if (null? (first lists))
'done
(begin (apply fn i (map first lists))
(lp (+ i 1) (map rest lists))))))
;; can't this be shorter?
(define (cross . lsts)
(if (= (length lsts) 1)
(zip (first lsts))
(let ((rst (apply cross (rest lsts))))
(append-map (lambda (next)
(map (lambda (cons-result)
(cons next cons-result))
rst))
(first lsts)))))
;; fn : elt -> (VALUES k v)
(define (map-hash fn lst)
(let ((ht (make-hash)))
(for-each (lambda (elt) (receive (k v) (fn elt) (hash-set! ht k v)))
lst)
ht))
(define (hash-exists? ht k)
(let* ((does-exist #t)
(failure-thunk (lambda () (set! does-exist #f))))
(hash-ref ht k failure-thunk)
does-exist))
(define (hash-keys ht)
(hash-map ht (lambda (k v) k)))
(define (hash-singleton-value ht)
(if (= (hash-count ht) 1)
(hash-iterate-value ht (hash-iterate-first ht))
(error (format "Exactly one value expected in hash table ~A." ht))))
;; for creating hash-tables within hash-tables, when the outer-key might not exist
;; (in this case, we create a fresh sub-hash-table)
(define (sub-hash-set! outer-ht outer-key inner-key val)
(let ((has-outer-key (hash-exists? outer-ht outer-key)))
(unless has-outer-key
(hash-set! outer-ht outer-key (make-hash)))
(let ((inner-ht (hash-ref outer-ht outer-key)))
(hash-set! inner-ht inner-key val))))
(define (hash-filter-map ht fn)
(removef not (hash-map ht fn)))
;; returns a new hash-table:
(define (hash-hash-map ht fn)
(let ((fresh-ht (make-hash)))
(hash-for-each ht (lambda (k v) (hash-set! fresh-ht k (fn k v))))
fresh-ht))
;; fn : key X val -> #f | alpha
(define (hash-find ht fn)
(aand (find (lambda (k) (fn k (hash-ref ht k))) (hash-keys ht))
(hash-ref ht it)))
(define (bucketed-hash-add! bht key val)
(hash-set! bht key (cons val (hash-ref bht key '()))))
;; f : line-str X acc -> acc'
(define (file-line-fold f initial file-name)
(with-input-from-file file-name
(lambda ()
(let lp ((putative-line (read-line)) (acc initial))
(if (eof-object? putative-line)
acc
(lp (read-line) (f putative-line acc)))))))
(define-macro (aif a b c)
`(let ((it ,a))
(if it ,b ,c)))
(define-macro (awhen test . body)
`(let ((it ,test))
(if it (begin ,@body) 'done)))
(define-macro (aand . args)
(if (null? args)
#t
(if (null? (cdr args))
(car args)
`(let ((it ,(car args)))
(if it (aand ,@(cdr args)) #f)))))
(define (pretty-string v)
(let ((p (open-output-string)))
(pretty-print v p)
(get-output-string p)))
;;
;; pregexp-replace-many
;;
;; E.g.,
;; (pregexp-replace-many some-str
;; ("\n" => " ")
;; ("foo" => "bar"))
;;
(define-syntax pregexp-replace-many
(syntax-rules (=>)
((_ str (pattern => replacement) ...)
(let ((result str))
(set! result (pregexp-replace* pattern result replacement))
...
result))))
;;
;; regexp-replace-in-list*
;;
;; like pregexp-replace* but the return result is a list of strings and alphas,
;; where alpha is the return type of your function match->xexpr.
;; Unlike pregexp-replace*, the third argument must be a function, and it must
;; take one argument (thus the regexp must only match one thing).
;;
;; You can optionally provide a 4th arg function which will be applied to segments
;; of the given str that don't match. This can be useful when you have more than
;; one potential transform to apply to a string.
;;
;; Example: (regexp-replace-in-list* "ab" "abbracadabra" (lambda (match) "!"))
;; ==> ("!" "bracad" "!" "ra")
;;
;; Note: this is regexp, not pregexp (Perl regexp), so it's missing some features.
;; Pregexp "uses { and } bounded repetition and uses \ for meta-characters both
;; inside and outside of ranges."
;;
(define (regexp-replace-in-list* regexp str match->xexpr
(non-match->xexpr (lambda (x) x)))
(let lp ((matches (regexp-match-positions* regexp str))
(idx 0))
(if (empty? matches)
(let ((len (string-length str)))
(if (= idx len)
(list)
(list (non-match->xexpr (substring str idx (string-length str))))))
(let* ((from-idx (caar matches))
(to-idx (cdar matches))
(left-str (substring str idx from-idx))
(matched-str (substring str from-idx to-idx))
(result (match->xexpr matched-str)))
(append (if (string=? "" left-str)
(list result)
(list (non-match->xexpr left-str) (match->xexpr matched-str)))
(lp (rest matches) to-idx))))))
(define (assoc-val key alist (missing-val #f))
(let ((lookup (assoc key alist)))
(if lookup (cdr lookup) missing-val)))
;; returns an alist where keys are eq are "merged". alists further to the right
;; overshadow those to the left. duplicate keys are removed.
(define (alist-merge . alists)
(delete-duplicates! (concatenate (reverse alists))
(lambda (pair1 pair2) (eq? (car pair1) (car pair2)))))
;;
;; list-join
;;
;; (-> (listof any?) any? (listof any?))
;;
;; Analagous to string-join.
;; E.g., (list-join '(a b c) '(x x)) => (a (x x) b (x x) c)
;;
(define (list-join lst joiner)
(concatenate (pair-fold-right (lambda (pair acc)
(let ((elt (car pair)))
(cons (if (empty? (cdr pair))
(list elt)
(list elt joiner))
acc)))
'() lst)))
(define (alist-key-filter fn alist)
(filter (match-lambda ((list-rest k v) (fn k))) alist))
(define (cons-to-end elt lst)
(append lst (list elt)))
(define (e format-str . args)
(error (apply format format-str args)))
(define (take-up-to lst n)
(if (or (zero? n) (empty? lst))
'()
(cons (first lst) (take-up-to (rest lst) (- n 1)))))
(define (drop-up-to lst n)
(if (or (zero? n) (empty? lst))
lst
(drop-up-to (rest lst) (- n 1))))
;; usage: inside a backquote, ,@(splice-if TEST VAL) or ,@(splice-if TEST-AND-VAL)
(define-syntax splice-if
(syntax-rules ()
((_ test val)
(if test (list val) '()))
((_ test)
(let ((t test))
(if t (list t) '())))))
(define-macro (asplice-if test val)
`(let ((it ,test))
(splice-if it val)))
;; returns a string of at most n chars. Uses ellipsis if it has to chop.
(define (string-ellide str n)
(let ((len (string-length str)))
(if (<= len (- n 3))
str
(string-append (substring str 0 (- n 4)) "..."))))
;; if idx < 0 then returns 0th elt
;; if idx > len-1, then returns (len-1)th elt
;; it's still an error to use on an empty list.
(define (safe-list-ref lst idx)
(if (< idx 0)
(first lst)
(let ((len (length lst)))
(if (>= idx len)
(list-ref lst (- len 1))
(list-ref lst idx)))))
;; XXX should use srfi 13 version of string-upcase, but can't figure out how to get the
;; conflicts working with the mzscheme version.
(define (capitalize-word str)
(let ((chars (string->list str)))
(list->string (cons (char-upcase (first chars)) (rest chars)))))
(define (make-recursive-keyword-version-of-fn fn recur-kw-str)
(make-keyword-procedure
(lambda (kws kw-vals . reg-args)
(define recur
(make-keyword-procedure
(lambda (override-kws override-kw-vals . override-reg-args)
(call-with-keyword-override fn
kws kw-vals
(cons (string->keyword recur-kw-str)
override-kws)
(cons recur override-kw-vals)
(if (empty? override-reg-args)
reg-args
override-reg-args)))))
(recur))))
;; call fn with original kws/kw-vals except override with new kws/kw-vals:
(define (call-with-keyword-override fn
original-kws original-kw-vals
new-kws new-kw-vals
reg-args)
(receive (kws kw-vals)
(unzip2 (sort (lset-union (lambda (k1.v1 k2.v2) (eq? (car k1.v1) (car k2.v2)))
(zip new-kws new-kw-vals)
(zip original-kws original-kw-vals))
(lambda (k1.v1 k2.v2) (keyword<? (car k1.v1) (car k2.v2)))))
(keyword-apply fn kws kw-vals reg-args)))
;; round n to k places to the right of the decimal
(define (round-k n k)
(let ((dec-mover (expt 10 k)))
(/ (round (* dec-mover n)) dec-mover)))
(define (->string thing)
(cond ((string? thing) thing)
((symbol? thing) (symbol->string thing))
(else (e "Don't know how to convert '~A' into a string."))))
;; the first invocation of f looks like (f init (first lst))
;; cannot
(define (reduce-right-result kons init lst)
(if (null? lst)
init
(let lp ((lst (rest lst)) (acc (kons (first lst) init)))
(if (null? lst)
acc
(lp (rest lst) (kons (first lst) acc))))))
;;
;; max-f
;;
;; find the elt in lst which has the highest value of (f elt) which is greater than
;; init-max, and return that max value.
;;
;;
(define (max-f init-max f lst)
(let ((m init-max))
(for-each (lambda (elt) (let ((v (f elt))) (when (> v m) (set! m v))))
lst)
m))
;;
;; max-f-elt
;;
;; like max-f, but returns the element instead of the max value.
;;
(define (max-f-elt init-max f lst)
(let ((m init-max)
(m-elt 'dummy))
(for-each (lambda (elt) (let ((v (f elt))) (when (> v m) (set! m v) (set! m-elt elt))))
lst)
m-elt))
(define (listify x)
(if (list? x) x (list x)))
(define-syntax sync-on-lock
(syntax-rules ()
((_ lock body ...)
(begin (semaphore-wait lock)
(let ((val (begin body ...)))
(semaphore-post lock)
val)))))
(define (make-lock)
(make-semaphore 1))
(define (md5-string str)
(bytes->string/utf-8 (md5 (string->bytes/utf-8 str))))
;; pretty printing:
(print-hash-table #t)
(print-struct #t)