203 lines
5.2 KiB
Plaintext
203 lines
5.2 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)])
|
|
(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 vars_vals . body)
|
|
`((fn ,(map1 car (pair vars_vals))
|
|
,@body)
|
|
,@(map1 cadr (pair vars_vals)))])
|
|
(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)
|
|
(let w (width screen)
|
|
(let 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 . [(pat screen)])
|
|
)
|