spreadsheet tinkering

png.lisp

@@ -8,19 +8,41 @@
 (defmacro hexbytes (&rest bytes)
   (map '(vector flex:octet) (λ (x) (reread "#x" x)) bytes))
 
-(defparameter signature
-  (hexbytes 89 50 4E 47 0D 0A 1A 0A))
-
 (defgeneric bmatch (obj stream)
   (:documentation "attempt to match OBJ with the binary input stream STREAM.
 returns (VALUES BOOLEAN T)"))
 
+(defmacro bor (&body opts)
+  (with-gensyms (ok? val)
+    (match opts
+      ((list a b)
+       `(mvbind (,ok? ,val) ,a
+          (if ,ok? ,val ,b)))
+      ((cons a b*)
+       `(bor ,a (bor ,@b*)))
+      (nil '(values nil nil)))))
+
+(defmacro band (&body opts)
+  (with-gensyms (a-ok? a-val b-ok? b-val)
+    (match opts
+      ((cons a b*)
+       `(mvbind (,a-ok? ,a-val) ,a
+                (if ,a-ok?
+                    (mvbind (,b-ok? ,b-val) (band ,@b*)
+                       (if ,b-ok?
+                           (values t (cons ,a-val ,b-val))
+                           (bor)))
+                    (bor))))
+      (nil '(values t nil)))))
+
+(defparameter signature
+  (hexbytes 89 50 4E 47 0D 0A 1A 0A))
+
 (defmethod bmatch ((obj vector) stream)
-  (values
+  (values 
-   (block nil
+   (loop for exp across signature
-     (loop for exp across signature
+         for got = (read-byte stream nil nil)
-           for got = (read-byte stream nil nil)
+         do (unless (and got (= exp got))
-           do (unless (and got (= exp got))
+              (return))
-                (return)))
+         finally (return t)) 
-     t)
    nil))

spreadsheet.lisp

@@ -0,0 +1,36 @@
+(load "utils.lisp")
+
+;; n-dimensional, why not
+(defclass sheet ()
+  ((cells :initarg :cells :type (simple-array function))))
+
+;; todo: identify dependencies and lazily recompute
+;; (i would use promises, but)
+;; having everything be a thunk is advantageous
+(defmacro sheet (&body rows)
+  (begin
+    (= width (length (car rows)))
+    (assert (apply #'= (mapcar #'length rows)))
+    (= cells-name (gensym "CELLS"))
+    (= current-index (gensym "CURRENT-INDEX"))
+    (= cells
+       `(list
+         ,@(loop for row in rows
+               for y from 0
+               collecting
+               `(list
+                 ,@(loop for cell in row
+                         for x from 0
+                         collecting `(lambda () (let1 ,current-index '(,x ,y) ,cell)))))))
+    (= cells
+       `(progn
+          (defvar ,current-index nil)
+          (labels ((,cells-name ()
+                     (make-array '(,(length rows) ,width)
+                                 :element-type 'function
+                                 :initial-contents ,cells))
+                   (cell (x y)
+                     (assert (not (equal (list x y) ,current-index)))
+                     (funcall (aref (,cells-name) y x))))
+            (,cells-name))))
+    cells))

utils.lisp

@@ -686,6 +686,12 @@
       `(loop for ,(first (car binds)) in ,(second (car binds))
              do (doprod ,(cdr binds) ,@body))))
 
+(defmacro mapprod ((&rest binds) &body body)
+  (if (null binds)
+      `(progn ,@body)
+      `(loop for ,(first (car binds)) in ,(second (car binds))
+             collect (mapprod ,(cdr binds) ,@body))))
+
 (defpattern structure (expr)
   (match expr
     ((list 'quote x) `',x)
@@ -720,3 +726,21 @@
 
        (_ `(locally ,stmt (begin ,@rest)))))
     (_ nil)))
+
+(defmacro l$ (&body body)
+  (begin
+    (=f $? (sym) (and (symbolp sym) (starts-with #\$ (symbol-name sym))))
+    (=f $-value (sym) (or (parse-integer (string-trim "$" (symbol-name sym))
+                                         :junk-allowed t)
+                          -1))
+
+    (= money (remove-duplicates (remove-if-not #'$? (flatten body))))
+    (= highest (apply #'max (cons 0 (mapcar #'$-value money))))
+
+    `(lambda (,@(loop for i from 1 to highest
+                      collecting (symb '$ i))
+              ,@(when (member '$@ money)
+                  '(&rest $@)))
+       ,@body)))
+
+(begin (=f x2 (n) (+ n n)) (fpromote x2) (mapcar x2 '(1 2 3)))