mu/shell/data.limg

(
  (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 - r*2)
        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 += (y*2 + 1)
      when (or (r > x) (err > y))
        ++x
        err += (x*2 + 1)
      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])
)