lib.tsp (11093B)
1 (define (list . lst) lst) 2 3 (define defmacro 4 (macro (args . body) 5 (list 'define (car args) (list 'macro (cdr args) . body)))) 6 7 ;;; CXR 8 (define (caar x) (car (car x))) 9 (define (cadr x) (car (cdr x))) 10 (define (cdar x) (cdr (car x))) 11 (define (cddr x) (cdr (cdr x))) 12 (define (caaar x) (car (car (car x)))) 13 (define (caadr x) (car (car (cdr x)))) 14 (define (cadar x) (car (cdr (car x)))) 15 (define (caddr x) (car (cdr (cdr x)))) 16 (define (cdaar x) (cdr (car (car x)))) 17 (define (cdadr x) (cdr (car (cdr x)))) 18 (define (cddar x) (cdr (cdr (car x)))) 19 (define (cdddr x) (cdr (cdr (cdr x)))) 20 (define (caaaar x) (car (car (car (car x))))) 21 (define (caaadr x) (car (car (car (cdr x))))) 22 (define (caadar x) (car (car (cdr (car x))))) 23 (define (caaddr x) (car (car (cdr (cdr x))))) 24 (define (cadaar x) (car (cdr (car (car x))))) 25 (define (cadadr x) (car (cdr (car (cdr x))))) 26 (define (caddar x) (car (cdr (cdr (car x))))) 27 (define (cadddr x) (car (cdr (cdr (cdr x))))) 28 (define (cdaaar x) (cdr (car (car (car x))))) 29 (define (cdaadr x) (cdr (car (car (cdr x))))) 30 (define (cdadar x) (cdr (car (cdr (car x))))) 31 (define (cdaddr x) (cdr (car (cdr (cdr x))))) 32 (define (cddaar x) (cdr (cdr (car (car x))))) 33 (define (cddadr x) (cdr (cdr (car (cdr x))))) 34 (define (cdddar x) (cdr (cdr (cdr (car x))))) 35 (define (cddddr x) (cdr (cdr (cdr (cdr x))))) 36 37 ;;; Types 38 (define (any? x) t) 39 (define (void? x) (= (typeof x) "void")) 40 (define (nil? x) (= (typeof x) "nil")) 41 (define empty? nil?) 42 (define (integer? x) (= (typeof x) "integer")) 43 (define (decimal? x) (= (typeof x) "decimal")) 44 (define (ratio? x) (= (typeof x) "ratio")) 45 (define (string? x) (= (typeof x) "string")) 46 (define (symbol? x) (= (typeof x) "symbol")) 47 (define (primitive? x) (= (typeof x) "primitive")) 48 (define (function? x) (= (typeof x) "function")) 49 (define (macro? x) (= (typeof x) "macro")) 50 (define (pair? x) (= (typeof x) "pair")) 51 (define (atom? x) (not (pair? x))) 52 (define (cons? x) (and (pair? x) (not (pair? (cdr x))))) 53 (define (list? x) (if (pair? x) (list? (cdr x)) (not x))) 54 (define (boolean? x) (or (= x t) (nil? x))) 55 (define (true? x) (= x t)) 56 (define false? nil?) 57 (define (procedure? x) (or (primitive? x) (or (function? x) (macro? x)))) 58 (define (rational? x) (or (integer? x) (ratio? x))) 59 (define (number? x) (or (rational? x) (decimal? x))) 60 61 (define (bool x) (if x t nil)) 62 ; TODO handle string and sym 63 (define (pair x) 64 (cond 65 ((rational? x) 66 (cons (numerator x) 67 (denominator x))) 68 ((decimal? x) 69 (cons (integer (truncate x)) 70 (- x (truncate x)))) 71 ((or (void? x) (nil? x) (pair? x)) x) 72 (else (list x)))) 73 74 (defmacro (assert expr) 75 `(unless ,expr 76 (error 'assert "assertion " ',expr " failed"))) 77 78 ; TODO support any sized list n depending on size of optional val 79 (define (default n val) 80 (cond 81 ((nil? n) val) 82 ((and (pair? n) (nil? (cdr n))) 83 (car n)) 84 (else (error 'default "expected only 1 optional argument")))) 85 86 ;;; Control Flow 87 ; TODO if b = pair and car b = else use cdr b 88 (defmacro (if con a b) 89 (list 'cond (list con a) (list t b))) 90 (define else t) 91 (defmacro (when con . body) 92 (list 'cond (list con (cons 'do body)))) 93 (defmacro (unless con . body) 94 (list 'cond (list (list not con) (cons 'do body)))) 95 96 (defmacro (let vars . body) 97 (list (list* 'lambda () 98 (append 99 (map 100 (lambda (x) 101 (list* 'define (car x) (cdr x))) 102 vars) 103 body)))) 104 105 (defmacro (recur proc vars . body) 106 (list 'let 107 (list* 108 (list proc (list* 'lambda (map car vars) body)) 109 vars) 110 (list* proc (map car vars)))) 111 112 (defmacro (switch val . body) 113 (list* 'cond (map 114 (lambda (line) 115 `((= ,val ,(car line)) ,(cadr line))) 116 body))) 117 118 ; TODO allow for improper lists 119 (defmacro (quasiquote x) 120 (define (check x) 121 (unless (and (pair? (cdr x)) (nil? (cddr x))) 122 (error (car x) "invalid form " x))) 123 (define (quasicons a d) 124 (if (pair? d) 125 (if (= (car d) 'quote) 126 (if (and (pair? a) (= (car a) 'quote)) 127 (list 'quote (list* (cadr a) (cadr d))) 128 (if (nil? (cadr d)) 129 (list 'list a) 130 (list list* a d))) 131 (if (member (car d) '(list list*)) 132 (list* (car d) a (cdr d)) 133 (list list* a d))) 134 (list list* a d))) 135 (recur f ((x x)) 136 (cond 137 ((atom? x) (list 'quote x)) 138 ((= (car x) 'unquote) 139 (check x) 140 (cadr x)) 141 (else (quasicons (f (car x)) (f (cdr x))))))) 142 143 (defmacro (unquote x) (list error ''unquote "called outside of quasiquote")) 144 145 ;;; Logic 146 (define true t) 147 (define false ()) 148 (define (not x) 149 (if x nil t)) 150 ; TODO logic func many arguments 151 ; Use a macro so arguments aren't evaluated all at once 152 (defmacro (and a b) 153 (list 'if a b nil)) 154 (defmacro (nand a b) 155 (list 'not (list 'and a b))) 156 (defmacro (or a b) 157 (list 'if a a b)) 158 (defmacro (nor a b) 159 (list 'not (list 'or a b))) 160 161 ;;; Lists 162 (define (list* . lst) 163 (if (cdr lst) 164 (cons (car lst) (apply list* (cdr lst))) 165 (car lst))) 166 167 (define (do . body) (last body)) 168 (define (do0 . body) (car body)) 169 170 (define (length lst) 171 (recur f ((lst lst) (x 0)) 172 (if lst 173 (f (cdr lst) (+ x 1)) 174 x))) 175 176 (define (last lst) 177 ; recur loop ((lst lst) (n (if n (car n) 0))) 178 (if (cdr lst) 179 (last (cdr lst)) 180 (car lst))) 181 182 ; TODO make nth generic for list str vec, made up of list-ref vec-ref str-ref 183 (define (nth lst n) 184 (cond 185 ((atom? lst) 186 (error 'nth "index of list out of bounds")) 187 ((<= n 0) (car lst)) 188 (else (nth (cdr lst) (- n 1))))) 189 190 ; TODO diff name head/tail since conflicts w/ unix 191 ; TODO support negative numers like unix tail/head to count from end backwards 192 (define (head lst n) 193 (cond 194 ((<= n 0) nil) 195 ((atom? lst) 196 (error 'name "index of list out of bounds")) 197 (else (cons (car lst) (head (cdr lst) (- n 1)))))) 198 199 (define (tail lst n) 200 (cond 201 ((<= n 0) lst) 202 ((atom? lst) 203 (error 'tail "index of list out of bounds")) 204 (else (tail (cdr lst) (- n 1))))) 205 206 (define (count x lst) 207 (cond ((nil? lst) 0) 208 ((atom? lst) (error 'count "expected proper list")) 209 ((= x (car lst)) (+ 1 (count x (cdr lst)))) 210 (else (count x (cdr lst))))) 211 212 ; TODO many args 213 (define (apply proc args) 214 (eval (map (lambda (x) ; prevent args from being evaluated twice 215 (list 'quote x)) 216 (cons proc args)))) 217 218 ; TODO many lsts for proc w/ multi arguments 219 (define (map proc lst) 220 (if lst 221 (cons (proc (car lst)) 222 (map proc (cdr lst))) 223 nil)) 224 225 (define (filter proc lst) 226 (cond 227 ((not (pair? lst)) nil) 228 ((proc (car lst)) (cons (car lst) (filter proc (cdr lst)))) 229 (else (filter proc (cdr lst))))) 230 231 (define (compose . procs) 232 (cond 233 ((nil? procs) (lambda x x)) 234 ((nil? (cdr procs)) (car procs)) 235 (else 236 (lambda x 237 ((car procs) (apply (apply compose (cdr procs)) x)))))) 238 239 (define (reverse l) 240 (recur f ((in l) (out nil)) 241 (if (pair? in) 242 (f (cdr in) (cons (car in) out)) 243 out))) 244 245 ; TODO accept many lists to append 246 (define (append x y) 247 (cond 248 ((pair? x) (cons (car x) (append (cdr x) y))) 249 ((nil? x) y) 250 (else (error 'append "expected proper list")))) 251 252 (define (zip x y) 253 (cond ((and (nil? x) (nil? y)) nil) 254 ((or (nil? x) (nil? y)) (error 'zip "given lists of unequal length")) 255 ((and (pair? x) (pair? y)) 256 (cons (cons (car x) (car y)) 257 (zip (cdr x) (cdr y)))))) 258 259 ; TODO assoc optional equal? arg 260 (define (assoc key table) 261 (cond ((nil? table) nil) 262 ((= key (caar table)) (car table)) 263 (else (assoc key (cdr table))))) 264 265 (define (memp proc lst) 266 (cond ((nil? lst) nil) 267 ((proc (car lst)) lst) 268 (else (memp proc (cdr lst))))) 269 270 (define (member mem lst) 271 (memp (lambda (x) (= mem x)) lst)) 272 273 ; define English list element accessors 274 (define rest cdr) ; TODO first and rest are generics for list, vec, str types 275 (define first car) 276 (let (((def name count) 277 (list 'define (list name 'x) (list 'nth 'x count)))) 278 (recur f ((n 1) 279 (lst '(second third forth fifth sixth seventh eighth ninth tenth))) 280 (when lst 281 (eval (def (car lst) n)) 282 (f (+ n 1) (cdr lst))))) 283 284 ;;; Stacks 285 (define (push stack val) 286 (cons val stack)) 287 288 (defmacro (push! stack val) 289 `(set! ,stack (push ,stack ,val))) 290 291 (define pop cdr) 292 293 (defmacro (pop! stack) 294 `(do0 295 (peek ,stack) 296 (set! ,stack (pop ,stack)))) 297 298 (define peek car) 299 300 (define (swap stack) 301 (let ((x (peek stack)) 302 (y (peek (pop stack)))) 303 (push (push (pop (pop stack)) x) y))) 304 305 ; TODO swap! use gen sym instead of x and y ? 306 (defmacro (swap! stack) 307 `(let ((x (pop! ,stack)) 308 (y (pop! ,stack))) 309 (set! ,stack (push (push ,stack x) y)))) 310 311 ;;; Math 312 (define pi (* 4 (arctan 1.))) 313 (define tau (* 2 pi)) 314 (define e (exp 1.)) 315 316 (define (inc x) (+ x 1)) 317 (define (dec x) (- x 1)) 318 (define (truncate x) (* (floor (abs x)) (sgn x))) 319 (define (sqr x) (* x x)) 320 (define (cube x) (* x (* x x))) 321 (define (root b p) (^ b (/ p))) 322 (define (sqrt x) (root x 2)) 323 (define (cbrt x) (root x 3)) 324 (define (logb b x) (/ (log x) (log b))) 325 (define (log10 x) (logb 10. x)) 326 327 (defmacro (++ x . n) 328 `(set! ,x (+ ,x ,(default n 1)))) 329 (defmacro (-- x . n) 330 `(set! ,x (- ,x ,(default n 1)))) 331 332 ; inverse trig functions 333 (define (csc x) (/ (sin x))) 334 (define (arccsc x) (/ (arcsin x))) 335 (define (csch x) (/ (sinh x))) 336 (define (arccsch x) (/ (arcsinh x))) 337 (define (sec x) (/ (cos x))) 338 (define (arcsec x) (/ (arccos x))) 339 (define (sech x) (/ (cosh x))) 340 (define (arcsech x) (/ (arccosh x))) 341 (define (cot x) (/ (tan x))) 342 (define (arccot x) (/ (arctan x))) 343 (define (coth x) (/ (tanh x))) 344 (define (arccoth x) (/ (arctanh x))) 345 346 (define (abs x) (if (>= x 0) x (- x))) 347 (define (sgn x) (if (= x 0) x (/ (abs x) x))) 348 ; TODO many args 349 (define (max a b) (if (> a b) a b)) 350 (define (min a b) (if (< a b) a b)) 351 352 (define (positive? x) (> x 0)) 353 (define (negative? x) (< x 0)) 354 (define (zero? x) (= x 0)) 355 (define (even? x) (= (mod x 2) 0)) 356 (define (odd? x) (= (mod x 2) 1)) 357 358 (define (dot x y) 359 (if x 360 (+ (* (car x) (car y)) 361 (dot (cdr x) (cdr y))) 362 0)) 363 364 (define (! n) 365 (if (= n 1) 366 1 367 (* n (! (- n 1))))) 368 369 ;;; IO 370 (define (run file) (eval (parse (read file)))) 371 (define (print . str) (apply write (list* 'stdout nil str))) 372 (define (newline . file) 373 (if (or (nil? file) (nil? (cdr file))) 374 (write (car (or file '(stdout))) file "\n") 375 (error 'newline "only zero or one file can be given"))) 376 377 (define (display . str) 378 (map (lambda (s) 379 (cond 380 ((string? s) (print "\"" s "\"")) 381 ((true? s) (print s)) ; don't print 't since it's self evaluating 382 ((symbol? s) (print "'" s)) 383 ((pair? s) (print "'" s)) 384 (else (print s)))) 385 str)) 386 (define (displayln . str) (apply display str) (newline)) 387 (define (println . str) (apply print str) (newline))