#### /lib/util.arc

Unknown | 479 lines | 379 code | 100 blank | 0 comment | 0 complexity | cdd2584a05eeab882d079fe9e84e5331 MD5 | raw file

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