mu/shell/data.limg

(
  (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])
    (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)))])
    (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))])
    (pair . [def (pair xs)
  if (no xs)
    ()
    if (no (cdr xs))
      (list (list (car xs)))
      (cons (list (car xs) (car (cdr xs)))
            (pair (cdr (cdr xs))))])
    (with . [mac (with vars_vals . body)
  `((fn ,(map1 car (pair vars_vals))
      ,@body)
    ,@(map1 (compose car cdr) (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 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)
  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 screen cx cy r clr)
  with (x (- 0 r)
        y 0
        err (- 2 (* 2 r))
        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)])
)