(
(globals . (
(mac . [define mac
(litmac litfn () ((m . params) . body)
`(define ,m
(litmac litfn () ,params ,@body)))])
(def . [mac (def (name . params) . body)
`(define ,name (fn ,params ,@body))])
(do . [mac (do . body)
`((fn () ,@body))])
(let . [(mac (let var val . body)
`((fn (,var) ,@body) ,val))])
(when . [mac (when cond . body)
`(if ,cond (do ,@body) ())])
(iflet . [mac (iflet var expr then else)
`(let ,var ,expr
(if ,var ,then ,else))])
(aif . [mac (aif expr then else)
`(iflet it ,expr ,then ,else)])
(list . [def (list . args)
# we should probably make a copy here
args])
(ret . [mac (ret var val . body)
`(let ,var ,val ,@body ,var)])
(len . [def (len l)
if (no l)
0
(1 + (len (cdr l)))])
(nth . [def (nth n xs)
if (n < 1)
(car xs)
(nth n-1 (cdr xs))])
(map1 . [def (map1 f xs)
if (no xs)
()
(cons (f (car xs))
(map1 f (cdr xs)))])
(compose . [def (compose f g)
(fn args
(f (apply g args)))])
(caar . [define caar (compose car car)])
(cadr . [define cadr (compose car cdr)])
(cddr . [define cddr (compose cdr cdr)])
(cdar . [define cdar (compose cdr car)])
(some . [def (some f xs)
if (no xs)
()
if (f (car xs))
xs
(some f (cdr xs))])
(any . [define any some])
(all . [def (all f xs)
if (no xs)
1
if (f (car xs))
(all f (cdr xs))
()])
(find . [def (find x xs)
if (no xs)
()
if (x = (car xs))
1
(find x (cdr xs))])
(pair . [def (pair xs)
if (no xs)
()
if (no (cdr xs))
(list (list (car xs)))
(cons (list (car xs) (cadr xs))
(pair (cddr xs)))])
(with . [mac (with bindings . body)
`((fn ,(map1 car (pair bindings))
,@body)
,@(map1 cadr (pair bindings)))])
(afn . [mac (afn params . body)
`(let self ()
(set self (fn ,params ,@body)))])
(seq . [def (seq n)
((afn (i)
(if (i > n)
()
(cons i (self i+1))))
1)])
(each . [mac (each x xs . body)
`(walk ,xs (fn (,x) ,@body))])
(walk . [def (walk xs f)
when xs
(f (car xs))
(walk (cdr xs) f)])
(rem . [def (rem f xs)
if (no xs)
()
let rest (rem f (cdr xs))
if (f (car xs))
rest
(cons (car xs) rest)])
(keep . [def (keep f xs)
if (no xs)
()
let rest (keep f (cdr xs))
if (f (car xs))
(cons (car xs) rest)
rest])
(++ . [mac (++ var) `(set ,var (,var + 1))])
(+= . [mac (var += inc)
`(set ,var (,var + ,inc))])
(for . [mac (for var init test update . body)
`(let ,var ,init
(while ,test
,@body
,update))])
(hline1 . [def (hline1 screen y x xmax color)
while (x < xmax)
(pixel screen x y color)
(++ x)])
(vline1 . [def (vline1 screen x y ymax color)
while (y < ymax)
(pixel screen x y color)
++ y])
(hline . [def (hline scr y color)
(hline1 scr y 0 (width scr) color)])
(vline . [def (vline scr x color)
(vline1 scr x 0 (height scr) color)])
(line . [def (line screen x0 y0 x1 y1 color)
with (x x0
y y0
dx (abs x1-x0)
dy (0 - (abs y1-y0))
sx (sgn x1-x0)
sy (sgn y1-y0))
let err dx+dy
while (not (and (x = x1)
(y = y1)))
(pixel screen x y color)
let e2 err*2
when (e2 >= dy)
x += sx
when (e2 <= dx)
y += sy
err +=
(+ (if (e2 >= dy)
dy
0)
(if (e2 <= dx)
dx
0))])
(read_line . [def (read_line keyboard)
ret str (stream)
let c (key keyboard)
while (not (or (c = 0) (c = 10)))
(write str c)
(set c (key keyboard))])
(wait . [def (wait keyboard)
while (= 0 (key keyboard))
()])
(sq . [def (sq n) (n * n)])
(cube . [def (cube n) (n * n * n)])
(fill_rect . [def (fill_rect screen x1 y1 x2 y2 color)
for y y1 (y < y2) (++ y)
(hline1 screen y x1 x2 color)])
(circle . [def (circle scr cx cy r clr)
with (x (0 - r)
y 0
err (2 - (* 2 r))
continue 1)
while continue
(pixel scr cx-x cy+y clr)
(pixel scr cx-y cy-x clr)
(pixel scr cx+x cy-y clr)
(pixel scr cx+y cy+x clr)
(set r err)
when (r <= y)
++ y
err += (1 + (2 * y))
when (or (r > x) (err > y))
++ x
err += (+ 1 (* 2 x))
set continue (x < 0)])
(ring . [def (ring screen cx cy r0 w clr)
for r r0 (r < (r0 + w)) (++ r)
(circle screen cx cy r clr)])
(Greys . [define Greys
(map1 (fn(n) (n + 15))
(seq 16))])
(Pinks . [define Pinks '(84 85 59 60 61
13 36 37 5 108)])
(palette . [def (palette p i)
(nth (i % (len p)) p)])
(pat . [def (pat screen)
with (w (width screen)
h (height screen))
for y 0 (y < h) (++ y)
for x 0 (x < w) (++ x)
(pixel screen x y x*y)])
(main . [def (main screen keyboard)
(pat screen)])
))
(sandbox . [circle screen 35 35 14 3])
)