247 lines
6.6 KiB
Plaintext
247 lines
6.6 KiB
Plaintext
(
|
|
(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)])
|
|
(forever . [mac (forever . body)
|
|
`(while 1 ,@body)])
|
|
(list . [def (list . args)
|
|
# we should probably make a copy here
|
|
args])
|
|
(ret . [mac (ret var val . body)
|
|
`(let ,var ,val ,@body ,var)])
|
|
(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)])
|
|
(val . [define val cadr])
|
|
(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])
|
|
(alist? . [def (alist? x)
|
|
(and (cons? x)
|
|
(cons? (car x)))])
|
|
(assoc . [def (assoc alist key)
|
|
if (no alist)
|
|
()
|
|
if (key = (caar alist))
|
|
(car alist)
|
|
(assoc (cdr alist) key)])
|
|
(get . [def (get alist key)
|
|
aif (assoc alist key)
|
|
(cdr it)
|
|
()])
|
|
(+= . [mac (var += inc)
|
|
`(set ,var (,var + ,inc))])
|
|
(++ . [mac (++ var)
|
|
`(+= ,var 1)])
|
|
(for . [mac (for var init test update . body)
|
|
`(let ,var ,init
|
|
(while ,test
|
|
,@body
|
|
,update))])
|
|
(repeat . [# Ideally we shouldn't have to provide
|
|
# var.
|
|
# But then nested repeats won't work
|
|
# until we use gensyms.
|
|
# And shell doesn't currently support
|
|
# gensyms.
|
|
# By exposing var to caller, it becomes
|
|
# caller's responsibility to use unique
|
|
# vars for each invocation of repeat.
|
|
mac (repeat var n . body)
|
|
`(for ,var 0 (,var < ,n) (++ ,var)
|
|
,@body)])
|
|
(grid . [def (grid m n val)
|
|
ret g (populate n ())
|
|
for i 0 (< i n) ++i
|
|
iset g i (populate m val)])
|
|
(indexgrid . [def (indexgrid g x y)
|
|
(index (index g y) x)])
|
|
(isetgrid . [def (isetgrid g x y val)
|
|
iset (index g y) x val])
|
|
(hborder . [def (hborder scr y color)
|
|
(hline scr y 0 (width scr) color)])
|
|
(vborder . [def (vborder scr x color)
|
|
(vline scr x 0 (height scr) color)])
|
|
(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
|
|
(hline screen y x1 x2 color)])
|
|
(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
|
|
ret p (populate 16 ())
|
|
for i 0 (< i 16) ++i
|
|
iset p i i+16])
|
|
(Pinks . [define Pinks (array
|
|
84 85 59 60 61
|
|
13 36 37 5 108)])
|
|
(palette . [def (palette p i)
|
|
(index p (i % (len 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 (palette Greys x*y))])
|
|
(main . [def (main screen keyboard)
|
|
(life screen)])
|
|
(liferes . [define liferes 8])
|
|
(life . [def (life screen)
|
|
with (w (/ (width screen) liferes)
|
|
h (/ (height screen) liferes))
|
|
with (g1 (grid w h 0)
|
|
g2 (grid w h 0))
|
|
isetgrid g1 w/2 h/2-1 1
|
|
isetgrid g1 w/2+1 h/2-1 1
|
|
isetgrid g1 w/2-1 h/2 1
|
|
isetgrid g1 w/2 h/2 1
|
|
isetgrid g1 w/2 h/2+1 1
|
|
renderlife screen g1
|
|
while 1
|
|
steplife g1 g2 screen
|
|
renderlife screen g2
|
|
steplife g2 g1 screen
|
|
renderlife screen g1])
|
|
(steplife . [def (steplife old new screen)
|
|
++lifetime
|
|
with (h (len old)
|
|
w (len (index old 0)))
|
|
for x 0 (< x w) ++x
|
|
for y 0 (< y h) ++y
|
|
fill_rect screen x*liferes y*liferes x+1*liferes y+1*liferes 0
|
|
with (curr (indexgrid old x y)
|
|
n (neighbors old x y w h)
|
|
)
|
|
isetgrid new x y (if (= n 2)
|
|
curr
|
|
(if (= n 3)
|
|
1
|
|
0))])
|
|
(renderlife . [def (renderlife screen g)
|
|
with (w (width screen)
|
|
h (height screen))
|
|
for y 0 (< y h) y+=liferes
|
|
for x 0 (< x w) x+=liferes
|
|
(fill_rect screen x y x+liferes y+liferes
|
|
(if (0 = (indexgrid g x/liferes y/liferes))
|
|
3
|
|
# (1 + lifetime%15)
|
|
0))])
|
|
(neighbors . [def (neighbors g x y w h)
|
|
ret result 0
|
|
when (y > 0)
|
|
when (x > 0)
|
|
result += (indexgrid g x-1 y-1)
|
|
result += (indexgrid g x y-1)
|
|
when (x < w-1)
|
|
result += (indexgrid g x+1 y-1)
|
|
when (x > 0)
|
|
result += (indexgrid g x-1 y)
|
|
when (x < w-1)
|
|
result += (indexgrid g x+1 y)
|
|
when (y < h-1)
|
|
when (x > 0)
|
|
result += (indexgrid g x-1 y+1)
|
|
result += (indexgrid g x y+1)
|
|
when (x < w-1)
|
|
result += (indexgrid g x+1 y+1)])
|
|
(lifetime . [define lifetime 0])
|
|
))
|
|
(sandbox . [life screen])
|
|
)
|