( (globals . ( (mac . [define mac (litmac litfn () ((name . params) . body) `(define ,name (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]) (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 (g args)))]) (some . [def (some f xs) if (no xs) () if (f (car xs)) xs (some f (cdr xs))]) (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))]) (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 screen y color) (hline1 screen y 0 (width screen) color)]) (vline . [def (vline screen x color) (vline1 screen x 0 (height screen) color)]) (line . [def (line screen x0 y0 x1 y1 color) (let (x y) `(,x0 ,y0) (let dx (abs (- x1 x0)) (let dy (- 0 (abs (- y1 y0))) (let sx (sgn (- x1 x0)) (let 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) (let str (stream) (let c (key keyboard) (while (not (or (= c 0) (= c 10))) (write str c) (set c (key keyboard)))) str)]) (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 screen cx cy r clr) (let x (- 0 r) (let y 0 (let err (- 2 (* 2 r)) (let continue 1 (while continue (pixel screen (- cx x) (+ cy y) clr) (pixel screen (- cx y) (- cy x) clr) (pixel screen (+ cx x) (- cy y) clr) (pixel screen (+ 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)) )