shell/data.limg

   1 (
   2   (globals . (
   3     (mac . [define mac
   4   (litmac litfn () ((m . params) . body)
   5     `(define ,m
   6        (litmac litfn () ,params ,@body)))])
   7     (def . [mac (def (name . params) . body)
   8   `(define ,name (fn ,params ,@body))])
   9     (do . [mac (do . body)
  10   `((fn () ,@body))])
  11     (let . [mac (let var val . body)
  12   `((fn (,var) ,@body) ,val)])
  13     (when . [mac (when cond . body)
  14   `(if ,cond (do ,@body) ())])
  15     (iflet . [mac (iflet var expr then else)
  16   `(let ,var ,expr
  17      (if ,var ,then ,else))])
  18     (aif . [mac (aif expr then else)
  19   `(iflet it ,expr ,then ,else)])
  20     (forever . [mac (forever . body)
  21   `(while 1 ,@body)])
  22     (list . [def (list . args)
  23   # we should probably make a copy here
  24   args])
  25     (ret . [mac (ret var val . body)
  26   `(let ,var ,val ,@body ,var)])
  27     (nth . [def (nth n xs)
  28   if (n < 1)
  29     (car xs)
  30     (nth n-1 (cdr xs))])
  31     (map1 . [def (map1 f xs)
  32   if (no xs)
  33     ()
  34     (cons (f (car xs))
  35           (map1 f (cdr xs)))])
  36     (compose . [def (compose f g)
  37   (fn args
  38     (f (apply g args)))])
  39     (caar . [define caar (compose car car)])
  40     (cadr . [define cadr (compose car cdr)])
  41     (cddr . [define cddr (compose cdr cdr)])
  42     (cdar . [define cdar (compose cdr car)])
  43     (val . [define val cadr])
  44     (some . [def (some f xs)
  45   if (no xs)
  46     ()
  47     if (f (car xs))
  48       xs
  49       (some f (cdr xs))])
  50     (any . [define any some])
  51     (all . [def (all f xs)
  52   if (no xs)
  53     1
  54     if (f (car xs))
  55       (all f (cdr xs))
  56       ()])
  57     (find . [def (find x xs)
  58   if (no xs)
  59     ()
  60     if (x = (car xs))
  61       1
  62       (find x (cdr xs))])
  63     (pair . [def (pair xs)
  64   if (no xs)
  65     ()
  66     if (no (cdr xs))
  67       (list (list (car xs)))
  68       (cons (list (car xs) (cadr xs))
  69             (pair (cddr xs)))])
  70     (with . [mac (with bindings . body)
  71   `((fn ,(map1 car (pair bindings))
  72       ,@body)
  73     ,@(map1 cadr (pair bindings)))])
  74     (afn . [mac (afn params . body)
  75   `(let self ()
  76      (set self (fn ,params ,@body)))])
  77     (seq . [def (seq n)
  78   ((afn (i)
  79      (if (i > n)
  80        ()
  81        (cons i (self i+1))))
  82    1)])
  83     (each . [mac (each x xs . body)
  84   `(walk ,xs (fn (,x) ,@body))])
  85     (walk . [def (walk xs f)
  86   when xs
  87     (f (car xs))
  88     (walk (cdr xs) f)])
  89     (rem . [def (rem f xs)
  90   if (no xs)
  91     ()
  92     let rest (rem f (cdr xs))
  93       if (f (car xs))
  94         rest
  95         (cons (car xs) rest)])
  96     (keep . [def (keep f xs)
  97   if (no xs)
  98     ()
  99     let rest (keep f (cdr xs))
 100       if (f (car xs))
 101         (cons (car xs) rest)
 102         rest])
 103     (alist? . [def (alist? x)
 104   (and (cons? x)
 105        (cons? (car x)))])
 106     (assoc . [def (assoc alist key)
 107   if (no alist)
 108     ()
 109     if (key = (caar alist))
 110       (car alist)
 111       (assoc (cdr alist) key)])
 112     (get . [def (get alist key)
 113   aif (assoc alist key)
 114     (cdr it)
 115     ()])
 116     (+= . [mac (var += inc)
 117   `(set ,var (,var + ,inc))])
 118     (++ . [mac (++ var)
 119   `(+= ,var 1)])
 120     (for . [mac (for var init test update . body)
 121   `(let ,var ,init
 122      (while ,test
 123        ,@body
 124        ,update))])
 125     (repeat . [# Ideally we shouldn't have to provide
 126 # var.
 127 # But then nested repeats won't work
 128 # until we use gensyms.
 129 # And shell doesn't currently support
 130 # gensyms.
 131 # By exposing var to caller, it becomes
 132 # caller's responsibility to use unique
 133 # vars for each invocation of repeat.
 134 mac (repeat var n . body)
 135   `(for ,var 0 (,var < ,n) (++ ,var)
 136      ,@body)])
 137     (grid . [def (grid m n val)
 138   ret g (populate n ())
 139     for i 0 (< i n) ++i
 140       iset g i (populate m val)])
 141     (indexgrid . [def (indexgrid g x y)
 142   (index (index g y) x)])
 143     (isetgrid . [def (isetgrid g x y val)
 144   iset (index g y) x val])
 145     (hborder . [def (hborder scr y color)
 146   (hline scr y 0 (width scr) color)])
 147     (vborder . [def (vborder scr x color)
 148   (vline scr x 0 (height scr) color)])
 149     (read_line . [def (read_line keyboard)
 150   ret str (stream)
 151     let c (key keyboard)
 152       while (not (or (c = 0) (c = 10)))
 153         (write str c)
 154         (set c (key keyboard))])
 155     (wait . [def (wait keyboard)
 156   while (= 0 (key keyboard))
 157     ()])
 158     (sq . [def (sq n) (n * n)])
 159     (cube . [def (cube n) (n * n * n)])
 160     (fill_rect . [def (fill_rect screen x1 y1 x2 y2 color)
 161   for y y1 (y < y2) ++y
 162     (hline screen y x1 x2 color)])
 163     (ring . [def (ring screen cx cy r0 w clr)
 164   for r r0 (r < r0+w) ++r
 165     (circle screen cx cy r clr)])
 166     (Greys . [define Greys
 167   ret p (populate 16 ())
 168     for i 0 (< i 16) ++i
 169       iset p i i+16])
 170     (Pinks . [define Pinks (array
 171                 84 85 59 60 61
 172                 13 36 37 5 108)])
 173     (palette . [def (palette p i)
 174   (index p (i % (len p)))])
 175     (pat . [def (pat screen)
 176   with (w (width screen)
 177         h (height screen))
 178     for y 0 (y < h) ++y
 179       for x 0 (x < w) ++x
 180         (pixel screen x y (palette Greys x*y))])
 181     (main . [def (main screen keyboard)
 182   (life screen)])
 183     (liferes . [define liferes 8])
 184     (life . [def (life screen)
 185   with (w (/ (width screen) liferes)
 186         h (/ (height screen) liferes))
 187     with (g1 (grid w h 0)
 188           g2 (grid w h 0))
 189       isetgrid g1 w/2 h/2-1 1
 190       isetgrid g1 w/2+1 h/2-1 1
 191       isetgrid g1 w/2-1 h/2 1
 192       isetgrid g1 w/2 h/2 1
 193       isetgrid g1 w/2 h/2+1 1
 194       renderlife screen g1
 195       while 1
 196         steplife g1 g2 screen
 197         renderlife screen g2
 198         steplife g2 g1 screen
 199         renderlife screen g1])
 200     (steplife . [def (steplife old new screen)
 201   ++lifetime
 202   with (h (len old)
 203         w (len (index old 0)))
 204     for x 0 (< x w) ++x
 205       for y 0 (< y h) ++y
 206         fill_rect screen x*liferes y*liferes x+1*liferes y+1*liferes 0
 207         with (curr (indexgrid old x y)
 208               n (neighbors old x y w h)
 209              )
 210           isetgrid new x y (if (= n 2)
 211                              curr
 212                              (if (= n 3)
 213                                1
 214                                0))])
 215     (renderlife . [def (renderlife screen g)
 216   with (w (width screen)
 217         h (height screen))
 218     for y 0 (< y h) y+=liferes
 219       for x 0 (< x w) x+=liferes
 220         (fill_rect screen x y x+liferes y+liferes
 221           (if (0 = (indexgrid g x/liferes y/liferes))
 222             3
 223 #            (1 + lifetime%15)
 224             0))])
 225     (neighbors . [def (neighbors g x y w h)
 226   ret result 0
 227     when (y > 0)
 228       when (x > 0)
 229         result += (indexgrid g x-1 y-1)
 230       result += (indexgrid g x y-1)
 231       when (x < w-1)
 232         result += (indexgrid g x+1 y-1)
 233     when (x > 0)
 234       result += (indexgrid g x-1 y)
 235     when (x < w-1)
 236       result += (indexgrid g x+1 y)
 237     when (y < h-1)
 238       when (x > 0)
 239         result += (indexgrid g x-1 y+1)
 240       result += (indexgrid g x y+1)
 241       when (x < w-1)
 242         result += (indexgrid g x+1 y+1)])
 243     (lifetime . [define lifetime 0])
 244   ))
 245   (sandbox . [life screen])
 246 )