/lib/util.arc

  1; lib/util.arc: A collection of useful miscellanea
  2
  3; Contributors:
  4; - Michael Arntzenius <daekharel@gmail.com>
  5
  6; Persons we've shamelessly ripped off:
  7; - Conan Dalton <conan@conandalton.net>
  8; - absz (http://arclanguage.org/user?id=absz)
  9; - fallintothis (http://arclanguage.org/user?id=fallintothis)
 10
 11; License: Do what you want, but it's not my fault!
 12; This license applies to all code in this file UNLESS OTHERWISE NOTED.
 13
 14; Feel free to make additions to this file and push them to anarki. Keep it to
 15; stuff that is widely applicable. Don't remove or change the semantics of stuff
 16; other people added. Add yourself to the contributors list above if you want.
 17
 18; If you wish to use a different license, make a comment around the code you've
 19; contributed noting the license. No licenses that don't permit modification
 20; (duh) and redistribution (double duh).
 21
 22; Try and keep track of what is whose in sections with unknown licenses
 23; ("ripoffs").
 24
 25
 26; miscellaneous
 27
 28(def fst (a . _) " Returns its first argument. See also [[snd]] " a)
 29(def snd (a b . _) " Returns its second argument. See also [[fst]] " b)
 30
 31(def bool (x)
 32  " Returns `t' if x is not nil, and `nil' otherwise. "
 33  (if x t))
 34
 35(def uniqs (lst)
 36  " Returns a list of gensyms, one for each element of `lst'. Elements
 37    of `lst' that are symbols are used as the base names for their
 38    corresponding gensyms.
 39    See also [[uniq]] "
 40  (map1 (iff asym uniq [uniq]) lst))
 41
 42(def gc () ($.collect-garbage))
 43
 44; type checkers
 45(def asym (x) " `t' iff `x' is a symbol. " (isa x 'sym))
 46(def astring (x) " `t' iff `x' is a string. " (isa x 'string))
 47(def atable (x) " `t' iff `x' is a table. " (isa x 'table))
 48(def aint (x) " `t' iff `x' is an int. " (isa x 'int))
 49(def anum (x) " `t' iff `x' is a num. Note that ints are not nums. "
 50  (isa x 'num))
 51
 52
 53; list manipulation
 54
 55; 'reduce and 'rreduce have somewhat quirky behavior, well-suited to arithmetic
 56; functions, but otherwise hard to reason about. I usually prefer 'foldl and
 57; 'foldr.
 58(def foldl (f v l)
 59  (if l (foldl f (f v car.l) cdr.l) v))
 60
 61(def foldr (f v l)
 62  (foldl flip.f v rev.l))
 63
 64(def foot (l)
 65  " Gets the last cons in a proper list. (Fails on dotted lists.) "
 66  (aif cdr.l foot.it l))
 67
 68(def join/d ls
 69  " Destructive join.
 70    See also [[join]]"
 71  (foldr (afn (a b) (if b (aif foot.a (do (scdr it b) a) b) a)) nil ls))
 72
 73(def classify (classifier seq)
 74  " Groups the elements of `seq' by `classifier', returning back a table,
 75    whose keys are the results of `classifier' and whose values are lists
 76    of the corresponding elements of `seq'. For example:
 77
 78      arc> (classify type '(1 \"foo\" a 2 (b)))
 79      #hash((cons . ((b))) (int . (2 1)) (string . (\"foo\")) (sym . (a)))
 80
 81    See also [[partition]] [[keep]] [[rem]] "
 82  (w/table h
 83    (each e seq
 84      (push e (h classifier.e)))))
 85
 86(def partition (test seq)
 87  " Equivalent to but more efficient than
 88   `(list (keep test seq) (rem test seq))'. See also [[keep]] [[rem]] "
 89  (let (passed failed) nil
 90    (each e seq
 91      (if test.e
 92        (push e passed)
 93        (push e failed)))
 94    (list rev.passed rev.failed)))
 95
 96(def unzip (xs)
 97  " Precisely as `zip', except that zip's `ls' is unzip's `xs'; so it takes one
 98    list of lists rather than any number of lists as arguments. Can be thought
 99    of as performing the inverse operation.
100    See also [[zip]] "
101  (apply map list xs))
102
103(def zip ls
104  " Returns a list of lists; the n-th element of the result is a list of the
105    n-th elements of the lists in `ls'. The length of the result is the length
106    of the shortest list in `ls'; extra elements in other lists are discarded.
107    See also [[unzip]] "
108  (unzip ls))
109
110(def mklist (x)
111  " Wraps atoms in a list; does nothing if `x' is already a list.
112    See also [[atom]] [[alist]] [[list]] "
113  (check x alist list.x))
114
115; 'many was precisely the same function as 'acons, hence has been removed (any
116; cons has a length > 0, since nil is not a cons). Also, 'popfind has been
117; renamed 'pull1, to fit with the newly-added 'rem1.
118
119(def rem1 (test seq)
120  " Returns a copy of `seq' with the first element that passes `test' removed.
121    See also [[rem]] [[keep]] [[pull1]] [[pull]] "
122  (zap testify test)
123  (if alist.seq ((afn (s)
124                   (if no.s nil
125                       (f car.s) cdr.s
126                       (cons car.s (self cdr.s))))
127                 seq)
128      (coerce (rem1 test (coerce seq 'cons)) 'string)))
129
130(mac pull1 (test place)
131  " Removes the first element that passes `test' from `place'.
132    See also [[pull]] [[rem1]] [[rem]] [[keep]] "
133  `(= ,place (rem1 ,test ,place)))
134
135(= len= [is len._a _b])
136(= len- [- len._a _b])
137(= car< [< car._a car._b])
138
139(def keepkey (key lst) (keep [_ key] lst))
140(def mapkey (key lst) (map [_ key] lst))
141
142(def rand-pos (lst) (if lst (rand:len lst)))
143
144(mac pushend (elem lst)
145  `(= ,lst (join ,lst (list ,elem))))
146
147(mac popnth (lst n)
148  (w/uniq g1
149    `(let ,g1 (,lst ,n)
150       (= ,lst (+ (cut ,lst 0 ,n) (cut ,lst (+ 1 ,n))))
151       ,g1)))
152
153(mac poprand (lst)
154  (w/uniq g1
155    `(if ,lst
156	 (let ,g1 (rand-pos ,lst)
157	   (popnth ,lst ,g1)))))
158
159
160; combinators
161
162(def applied (f)
163  " Returns a fn that calls `f' on the list of its arguments.
164    For example, 'max is equivalent to `(applied [best > _])'. "
165  (fn a (f a)))
166
167(def flip (f)
168  " Flips the order of the first two arguments of `f'.
169    For example: ((flip cons) 1 2) => (2 . 1) "
170  (fn (x y . zs) (apply f y x zs)))
171
172(def curry (f . xs)
173  " Partially applies (\"curries\") `f' to `xs'. "
174  (fn ys (apply f (join xs ys))))
175
176(def const (x) 
177  " Creates a fn that takes any number of arguments and returns `x'. "
178  (fn _ x))
179
180(def tfn _ " Ignores its arguments and returns t. " t)
181(def nilfn _ " Ignores its arguments and returns nil. " nil)
182
183(def norf fns
184  " Creates a function which returns `t' iff none of `fns' return `t'
185    on its arguments.
186    See also [[orf]] [[andf]] [[nor]] "
187  (complement (apply orf fns)))
188
189(def iff funs
190  " Put simply: iff is to if as andf is to and. Specifically: 
191
192    (iff) => idfn
193    (iff fun) => fun
194    (iff test fun rest ...) => a fn that applies `fun' to its arguments if they
195    pass `test', otherwise applies `(iff rest...)' to them.
196
197    Examples:
198
199      arc> ((iff alist car) '(x))
200      x
201      arc> ((iff alist car) 2)
202      2
203      arc> ((iff < (fn (x y) x) (fn (x y) y)) 1 2)
204      1
205
206    See also [[andf]] [[orf]] [[check]] [[idfn]] "
207  (case len.funs
208    0 idfn
209    1 funs.0
210      (withs ((test fun . rest) funs
211              restfun (apply iff rest))
212        (fn a (if (apply test a) (apply fun a) 
213                  (apply restfun a))))))
214
215
216; macros
217
218(mac mappendeach (var lst . body)
219  " As 'mapeach, but using 'mappend instead of 'map.
220    See also [[mapeach]] [[mappend]] [[each]] "
221  `(mappend (fn (,var) ,@body) ,lst))
222
223(mac ado body
224  " Anaphoric do. 
225    See also [[aif]] [[awhen]] [[aand]] "
226  (aif cdr.body `(let it ,car.body (ado ,@it))
227       car.body))
228
229; now that pg has renamed 'assert to 'set, we're free to use it in its more
230; conventional sense
231(mac assert (exp (o msg (+ "Assertion failed: " 
232                           (tostring:ppr exp (len "Assertion failed: ") t))))
233  " Errors with `msg' if `exp' evaluates to nil. "
234  `(unless ,exp (err ,msg)))
235
236(mac asserts args
237  " Asserts each expr in `args', with the default error message. "
238  `(do ,@(map [list 'assert _] args)))
239
240(mac switchlet (var expr . cases)
241  " Like 'caselet, except it (lazily) evals the expressions compared against.
242    See also [[switch]] [[caselet]] [[case]]"
243  `(let ,var ,expr
244     ,((afn (args)
245         (if (no cdr.args) car.args
246           `(if (is ,var ,car.args) ,cadr.args
247              ,(self cddr.args)))) cases)))
248
249(mac switch (expr . cases)
250  " 'switch is to 'switchlet as 'case is to 'caselet.
251    See also [[switchlet]] [[case]] [[caselet]]"
252  `(switchlet ,(uniq) ,exp ,@cases))
253
254(mac dol (parms (test result) . body)
255  " Like the standard lisp/scheme do loop, but with redundant inner parens 
256    removed."
257  (w/uniq loop-name
258    (let parms (tuples parms 3)
259      `((rfn ,loop-name ,(map1 [_ 0] parms)
260          (if ,test ,result
261            (do ,@body (,loop-name ,@(map1 [_ 2] parms)))))
262         ,@(map1 [_ 1] parms)))))
263
264
265; binding forms
266
267(mac with/p (vars-vals . body)
268  " Scheme/Common Lisp's `let' - ie: 'with with the parens added back.
269    Easier to use in macro expansions than 'with.
270    See also [[with]] [[withs/p]] "
271  `(with ,(apply join vars-vals) ,@body))
272
273(mac withs/p (vars-vals . body)
274  " Like Scheme/Common Lisp's `let*' - ie: 'withs with the parens added back.
275    Easier to use in macro expansions than 'withs.
276    See also [[withs]] [[with/p]] "
277  `(withs ,(apply join vars-vals) ,@body))
278
279; a 'with that works for defining recursive fns
280(mac withr/p (bindings . body)
281  " Scheme's 'letrec. 
282    See also [[withr]] [[where]] "
283  `(let ,(map1 car bindings) nil
284     ,@(map [cons 'assign _] bindings)
285     ,@body))
286
287(mac withr (bindings . body)
288  " Scheme's 'letrec, with the redundant inner parens removed. 
289    See also [[withf]] [[letf]] [[where]] [[withr/p]] "
290  `(withr/p ,pair.bindings ,@body))
291
292; mutually recursive local fns
293(mac withf/p (fns . body)
294  " Like 'withf, only with extra parens, as in 'with/p compared to 'with.
295    See also [[withf]] [[with/p]] [[withr]] [[withr/p]] "
296  `(withr/p ,(mapeach (name . rest) fns `(,name (fn ,@rest)))
297     ,@body))
298
299(mac withf (fns . body)
300  " Defines a set `fns' of mutually recursive local fns within `body'. Each 
301    three elements of `fn' correspond to a fn name, argument list, and body,
302    so you'll need to use 'do if you want a multi-expression fn body.
303    Example:
304
305      arc> (withf (is-even (x) (case x 0 t (is-odd (- x 1)))
306                   is-odd (x) (case x 0 nil (is-even (- x 1))))
307             (keep is-odd (range 0 5)))
308      (1 3 5)
309
310    See also [[letf]] [[withr]] "
311  `(withf/p ,(tuples fns 3) ,@body))
312
313(mac letf (name args expr . body)
314  " Defines a (possibly recursive) local fn `(fn ,args ,expr)' named `name'
315    within `body'. Example:
316
317      arc> (letf last (x) (aif cdr.x last.it car.x)
318             (last '(x y z)))
319      z
320
321    See also [[withf]] [[withr]] "
322  `(withf (,name ,args ,expr) ,@body))
323
324; inspired by Haskell
325(mac where (expr . parms)
326  " Binds `parms' and evaluates `expr'. Examples:
327
328      arc> (where (square x)
329              square [* _ _]
330              x 2)
331      4
332
333    Note that binding is recursive, but that actual assignment of values is done
334    in the reverse of the order given, so any variables which are both bound and
335    used in `parms' must be used in reverse dependency order:
336
337      arc> (where x x (+ y y) y 0)    ; this works as expected
338      y
339      arc> (where x y 0 x (+ y y))    ; this doesn't
340      nil
341
342    Essentially, this is a reversed form of Scheme's 'letrec,
343    with many fewer parentheses. Inspired by Haskell's \"where\".
344    See also [[withr]] [[withr/p]] [[withf]] "
345  `(withr/p ,(rev:pair parms) ,expr))
346
347
348; ripoffs - licenses unknown
349
350; once-only by fallintothis
351; http://arclanguage.org/item?id=9939
352; CHANGED 2009-08-20:
353;   + take advantage of 'uniqs, 'with/p, 'zip
354;   + wrap 'names in a list if it's an atom
355;   + alter indentation slightly
356;  - Michael Arntzenius
357
358(mac once-only (names . body)
359  (withs (names (check names alist list.names)
360          gensyms (uniqs names))
361    `(w/uniq ,gensyms
362       `(with ,(list ,@(mappend list gensyms names))
363          ,(with/p ,(zip names gensyms)
364             ,@body)))))
365
366; afnwith by Conan Dalton
367; http://arclanguage.org/item?id=10055
368; CHANGED 2009-08-15: added docstrings - Michael Arntzenius
369(mac rfnwith (name withses . body)
370  " Convenient wrapper for applying an rfn using with-like syntax.
371    `withses' is a list of argument names and their initial values.
372    Best explained by example:
373
374      arc> (rfnwith sum (x (range 1 3))
375             (iflet (a . r) x (+ a (sum r)) 0))
376      6
377
378    The above example macroexpands to:
379
380      ((rfn sum (x) (iflet (a . r) x (+ a (sum r)) 0))
381       (range 1 3))
382
383    See also [[afnwith]] [[w/rfn]] [[rfn]] "
384  (let w (pair withses)
385    `((rfn ,name ,(map car w) ,@body) ,@(map cadr w))))
386
387(mac afnwith (withses . body)
388  " Convenient wrapper for applying an afn using with-like syntax.
389    `withses' is a list of argument names and their initial values.
390    Best explained by example:
391
392      arc> (afnwith (x (range 1 3))
393             (iflet (a . r) x (+ a (self r)) 0))
394      6
395
396    See also [[rfnwith]] [[w/afn]] [[afn]] "
397  `(rfnwith self ,withses ,@body))
398
399; ripoff: w/afn, by absz
400; http://arclanguage.org/item?id=10125
401; CHANGED 2009-08-15: added docstrings - Michael Arntzenius
402
403(mac w/rfn (name withses . body)
404  " Convenient wrapper for applying an rfn using preexisting variables
405    in `withses' as arguments. Best explained by example:
406
407      arc> (let x (range 1 3) 
408             (w/rfn sum (x)
409               (iflet (a . r) x (+ a (sum r)) 0)))
410      6
411
412    The above example (w/rfn sum ...) macroexpands to:
413
414      ((rfn sum (x) (iflet (a . r) x (+ a (sum r)) 0))
415       x)
416
417    See also [[w/afn]] [[rfnwith]] [[rfn]] "
418  `(rfnwith ,name ,(mappend [list _ _] mklist.withses) ,@body))
419
420(mac w/afn (withses . body)
421  " Convenient wrapper for applying an afn using the preexisting variables
422    in `withses' as arguments. Best explained by example:
423
424      arc> (let x (range 1 3)
425             (w/afn (x)
426               (iflet (a . r) x (+ a (self r)) 0)))
427      6
428
429    The above example (w/afn (x) ...) macroexpands to:
430
431      ((afn (x) (iflet (a . r) x (+ a (sum r)) 0))
432       x)
433
434    See also [[w/rfn]] [[afnwith]] [[afn]] "
435  `(w/rfn self ,withses ,@body))
436
437; start Andrew Wilcox (aw) code
438
439; http://awwx.ws/span0.arc
440(def span (tst lst)
441  ((afn (a lst)
442     (if (and lst (tst (car lst)))
443          (self (cons (car lst) a) (cdr lst))
444          (list (rev a) lst)))
445   nil lst))
446
447; http://awwx.ws/xloop0.arc
448(mac xloop (withses . body)
449  (let w (pair withses)
450      `((rfn next ,(map car w) ,@body) ,@(map cadr w))))
451
452; http://awwx.ws/implicit2.arc
453(mac implicit (name (o val))
454  `(do (defvar ,name ($.make-parameter ,val))
455       (mac ,(sym (string "w/" name)) (v . body)
456         (w/uniq (param gv gf)
457           `(with (,param (defvar-impl ,',name)
458                   ,gv ,v
459                   ,gf (fn () ,@body))
460              ($ (parameterize ((,param ,gv)) (,gf))))))))
461
462; http://awwx.ws/extend-readtable0.arc
463(def extend-readtable (c parser)
464  ($
465   (current-readtable
466    (make-readtable (current-readtable)
467                    c
468                    'non-terminating-macro
469                    (lambda (ch port src line col pos)
470                      (parser port))))))
471
472; end aw code
473
474; while with break and continue. by fallintothis
475; http://arclanguage.org/item?id=12229
476(mac whilesc (test . body)
477  `(point break (while ,test (point continue ,@body))))
478
479; END RIPOFFS