initial

bel.lisp

@@ -0,0 +1,85 @@
+(load "utils.lisp")
+
+(defun string->chars (s)
+  (declare (type string s))
+  (map 'list #'identity s))
+
+(defun chars->string (cs)
+  (map 'string #'identity cs))
+
+(defparameter prims
+  `((id    . ,#'eq)
+    (ins   . ,*terminal-io*)
+    (outs  . ,*terminal-io*)
+    (join  . ,#'(lambda (&optional a b) (cons a b)))
+    (car   . ,#'car)
+    (cdr   . ,#'cdr)
+    (apply . ,#'(lambda (f &rest args) (apply #'call f args)))
+    (type  . ,#'(lambda (x)
+                (typecase x
+                  (symbol 'symbol)
+                  (cons 'pair)
+                  (character 'char)
+                  (stream 'stream))))
+    (sym  . ,(fn (intern chars->string)))
+    (nom  . ,(fn (string->chars symbol-name)))
+    (coin . ,#'(lambda () (zerop (random 2))))
+    ;; todo
+    (sys  . ,(fn (uiop:run-program chars->string)))))
+
+(defclass lit ()
+  ((tag :initarg :tag)
+   (stuff :initarg :stuff)))
+
+(defmethod print-object ((obj lit) stream)
+  (with-slots (tag stuff) obj
+    (format stream "#lit#~s#~s" tag stuff)))
+
+(defmacro lit (tag &rest stuff)
+  `(make-instance 'lit :tag ',tag :stuff ',stuff))
+
+(defun call (f &rest args)
+  (format t "~s ~s~%" f args)
+  (typecase f
+    (function (apply f args))
+    (lit
+     (with-slots (tag stuff) f
+       (case tag
+         (prim (apply (cdr (assoc (car stuff) prims))
+                      args)))))))
+
+(defmacro bel-if (&rest branches)
+  (if branches
+      `(cond
+         ,(loop for (a b . rest) on branches by #'cddr
+                collecting
+                (if (or b rest)
+                    `(,a ,b)
+                    `(t ,a))))
+      nil))
+
+;; remember: compile!
+(defun bel-compile (expr)
+  (match expr
+    ((or 't 'nil 'o
+         (type number)
+         (list 'quote _))
+     expr)
+
+    ((type string) `',(string->chars expr))
+
+    ((list 'xar place car) `(setf (car ,(bel-compile place)) ,(bel-compile car)))
+    ((list 'xdr place cdr) `(setf (cdr ,(bel-compile place)) ,(bel-compile cdr)))
+
+    ((list* 'lit tag stuff) (make-instance 'lit :tag tag :stuff stuff))
+
+    ((list* 'if branches)
+     (let1 branches (mapcar #'bel-compile branches)
+       `(bel-if ,@branches)))
+
+    ((list* f args) `(call ,(bel-compile f) ,@(mapcar #'bel-compile args)))
+
+    ((type symbol)
+     (aif (assoc expr prims)
+          `(lit prim ,(car it))
+          expr))))

classic.lisp

@@ -0,0 +1,25 @@
+(load "utils.lisp")
+
+(defparameter example
+  '(
+    (class (Monoid a)
+     (mzero a)
+     (mplus (-> a a a)))
+
+    (instance (Monoid String)
+     (mzero "")
+     (mplus (lambda (a b) (native (concatenate 'string a b)))))
+
+    (def + (-> Number Number Number)
+     (lambda (a b) (native (+ a b))))
+
+    (instance (Monoid Number)
+     (mzero 0)
+     (mplus +))
+
+    (def msum (=> (Monoid a) (-> (List a) a))
+     (lambda (xs)
+       (List.iter xs
+                  mzero
+                  mplus)))
+    ))

clos-adt.lisp

@@ -0,0 +1 @@
+;; self-explanatory?

clpfd.lisp

@@ -0,0 +1,34 @@
+(load "utils.lisp")
+
+(defclass ?v ()
+  ((constraints :initform nil)))
+
+(defclass constraint () ())
+(defclass c= (constraint)
+  ((n :initarg :n :type number)))
+
+;; constr should be generic and return bool
+(defvar failure (gensym))
+(defun failure? (sym) (eq sym failure))
+
+(defmacro definverse ((?fw ?bw) op)
+  (with-gensyms (a b a-op-b)
+   `(progn
+      (defgeneric ,?fw (,a ,b ,a-op-b))
+      (defgeneric ,?bw (,a ,b ,a-op-b))
+
+      (defmethod ,?bw (,a ,b ,a-op-b)
+        (,?fw ,b ,a-op-b ,a))
+
+      (defmethod ,?fw ((,a number) (,b number) (,a-op-b number))
+        (if (= (,op ,a ,b) ,a-op-b)
+            nil
+            failure))
+
+      (defmethod ,?fw ((,a number) (,b number) (,a-op-b symbol))
+        (list (list '= (,op ,a ,b) ,a-op-b)))
+
+      (defmethod ,?fw ((,a number) (,b symbol) (,a-op-b number))
+        (,?bw )))))
+
+(definverse (?+ ?-) +)

compile-lc.lisp

@@ -0,0 +1,16 @@
+(load "utils.lisp")
+
+(defun to-lisp (term)
+  (match term
+    ((list '& vars body)
+     (let1 vars (mklist vars)
+       `(lambda ,vars
+          (declare (type function ,@vars)
+                   (ignorable ,@vars)
+                   (optimize (speed 3)
+                             ;; we know the code is safe
+                             (safety 0)))
+          ,(to-lisp body))))
+    ((list f x) `(funcall ,(to-lisp f) ,(to-lisp x)))
+    ((list* f x1 xs) (to-lisp `((,f ,x1) ,@xs)))
+    (x x)))

convert.lisp

@@ -0,0 +1,68 @@
+(load "utils.lisp")
+(ql:quickload "fset")
+(named-readtables:in-readtable fset:fset-readtable)
+
+;; TODO: compound
+;; let's do the form :cm :cm :cm first
+
+(defparameter conv
+  '((:kg (1000 :g))
+    (:g  (1000 :mg))
+    (:m  (100 :cm))
+    (:km (1000 :m))
+    (:in (254/100 :cm))
+    (:ft (12 :in))
+    (:yd (3 :ft))
+    (:mi (1760 :yd))
+    (:ml (1 :cm :cm :cm))
+    (:hz (1 (:s -1)))
+    (:acre (4840 (:yd 2)))))
+
+(defparameter dims
+  '(((:time)   :fs :ps :ns :ms :cs :s :ks :gs :min :hr :day :yr :century :millennium)
+    ((:length) :fm :pm :nm :mm :cm :m :km :gm :in :ft :yd :mi)
+    ((:mass)   :fg :pg :ng :mg :cg :g :kg :gg :lb)
+    ((:length 2) :acre)
+    ((:time -1) :hz)))
+
+;; multiset is not sufficient!
+;; why did i not read this comment!
+
+(defun dim (&rest dims)
+  (let1 out (fset:with-default #{| |} 0)
+    (loop for (dim . rest) on dims
+          when (keywordp dim)
+            do (incf (fset:@ out dim)
+                     (if (aand (car rest)
+                               (numberp it))
+                         (car rest)
+                         1)))
+    out))
+
+;; maybe should memoize?
+;; hash-table would be ffffast
+;; eh dw
+(defun convs (from)
+  (loop for (a (n b)) in conv
+        when (eq a from)
+          collect `(,n ,b)
+        when (eq b from)
+          collect `(,(/ n) ,a)))
+
+(defun convert (n from to &optional past)
+  (cond1
+    (equal from to) n
+    (consp from) (cond1
+                   (atom to) :idk
+                   (longer from to) nil
+                   ;; OMG
+                   (apply #'*
+                          (mapcar (lambda (f to)
+                                    (convert n f to (cons from past)))
+                                  from to)))
+    (let1 convs (remove-if #'(lambda (x) (member (cadr x) past :test #'equal)) (convs from))
+      (if convs
+          (loop for (mul new-from) in convs
+                do (let1 got (convert (* n mul) new-from to (cons from past))
+                     (if got (return got)))) 
+          nil))))

count-nodes.lisp

@@ -0,0 +1,4 @@
+(load "utils.lisp")
+
+; https://www.paulgraham.com/arcchallenge.html
+

defadt.lisp

@@ -0,0 +1,33 @@
+(load "utils.lisp")
+
+(defmacro defadt (name &rest clauses)
+  `(prog1
+     (defclass ,name () ())
+     ,@(loop for clause in clauses
+             nconcing
+             (begin
+               (= (cons clause-name slots) (mklist clause))
+               (= keywords (mapcar (lambda (x) (intern (string x) :keyword)) slots))
+               `((defclass ,clause-name (,name)
+                   ,(loop for slot in slots
+                          for keyword in keywords
+                          collecting `(,name :initarg ,keyword)))
+                 ,(if slots
+                      `(defun ,clause-name ,slots
+                         (make-instance ',clause-name
+                                        ,@(loop for slot in slots
+                                                for keyword in keywords
+                                                nconcing
+                                                `(,keyword ,slot))))
+                      `(defparameter ,clause-name
+                         (make-instance ',clause-name))))))))
+
+;; aaaaand match just works :P
+
+(defadt NonEmpty (End x) (NCons hd tl))
+
+(defun nlength (x)
+  (declare (type NonEmpty x))
+  (match x
+    ((End (x _)) 1)
+    ((NCons (hd _) tl) (+ 1 (nlength tl)))))

flow.lisp

@@ -0,0 +1,39 @@
+(load "utils.lisp")
+
+(defclass node ()
+  ((next :initarg :next :initform nil :accessor node-next)))
+
+(defclass if-node (node)
+  ((expr :initarg :expr)
+   (else :initarg :else :initform nil)))
+
+(defclass output-node (node)
+  )
+
+(defgeneric run (node))
+
+(defmethod run ((node node))
+  (node-next node))
+
+(defmethod run ((node if-node))
+  (with-slots (expr next else) node
+    (if (eval expr)
+        next
+        else)))
+
+
+;; start
+;;   |
+;;   v
+;; x = 10
+;;   |
+;;   v
+;; if x = 0 -Y> end
+;;   | ^
+;;   N |<-------
+;;   v         ^
+;; output x    |
+;;   |         |
+;;   v         |
+;; x = x - 1 ->|
+

maxima-stochiometry.lisp

@@ -0,0 +1,2 @@
+(load "utils.lisp")
+

polish.lisp

@@ -0,0 +1,8 @@
+(load "utils.lisp")
+
+(defun unpole (xs)
+  (if (inq (car xs) + - * / ^)
+      (mvbind (lhs rest) (unpole (cdr xs))
+        (mvbind (rhs rest) (unpole rest)
+          (values (list (car xs) lhs rhs) rest)))
+      (values (car xs) (cdr xs))))

questions.lisp

@@ -0,0 +1,39 @@
+(load "utils.lisp")
+
+(defstruct node contents yes no)
+
+(defvar *nodes* (make-hash-table))
+
+#+(or)
+(defun defnode (name conts &optional yes no)
+  (setf (gethash name *nodes*)
+        (make-node :contents conts
+                   :yes yes
+                   :no no)))
+
+#+(or)
+(defun defnode (name conts &optional yes no)
+  (setf (gethash name *nodes*)
+        (if yes
+            #'(lambda ()
+                (funcall
+                 (gethash
+                  (if (eq 'yes (prompt "~a~%>> " conts)) yes no)
+                  *nodes*)))
+            #'(lambda () conts))))
+
+(defnode 'people "Is the person a man?" 'male 'female)
+(defnode 'male "Is he living?" 'liveman 'deadman)
+(defnode 'deadman "Was he American?" 'us 'them)
+(defnode 'us "Is he on a coin?" 'coin 'cidence)
+(defnode 'coin "Is the coin a penny?" 'penny 'coins)
+(defnode 'penny 'lincoln)
+
+(defun run-node (name)
+  (let1 n (gethash name *nodes*)
+    (cond1
+      (node-yes n) (run-node
+                    (if (eq 'yes (prompt "~a~%>> " (node-contents n)))
+                        (node-yes n)
+                        (node-no  n)))
+      (node-contents n))))

sat.lisp

@@ -0,0 +1,36 @@
+(load "utils.lisp")
+
+(defun first-n-bits (n int)
+  (loop for i below n
+        collecting (logbitp i int)))
+
+(defun sat (expr)
+  (let* ((vars (delete-duplicates
+                (remove-if (lambda (x) (inq x and or not xor t nil))
+                           (flatten expr))))
+         (varc (length vars))
+         (f (eval `(lambda ,vars
+                     (declare (type boolean ,@vars) (optimize (speed 3) (safety 0) (debug 0)))
+                     ,expr))))
+    (disassemble f)
+    (loop for n below (expt 2 varc)
+          do (let1 bits (first-n-bits varc n)
+               (when (apply f bits)
+                 (return-from sat
+                   (mapcar #'list vars bits)))))
+    :unsat))
+
+(defmacro time-s (expr)
+  (with-gensyms (start end diff)
+    `(begin
+       (= ,start (get-internal-real-time))
+       ,expr
+       (= ,end (get-internal-real-time))
+       (= ,diff (- ,end ,start))
+       (/ ,diff internal-time-units-per-second))))
+
+(defparameter timings
+  (loop for var-count below 30
+        collecting
+        (time-s (sat `(and ,@(loop for i below var-count
+                                   collecting (symb 'v i)))))))

to-desmos.lisp

@@ -0,0 +1,30 @@
+(load "utils.lisp")
+
+(defgeneric to-desmos (obj port)
+  (:documentation "write OBJ in desmos-flavored latex to PORT"))
+
+(defmethod to-desmos ((obj complex) port)
+  (to-desmos (realpart obj) port)
+  (write-char #\+ port)
+  (to-desmos (imagpart obj) port)
+  (write-char #\i port))
+
+(defmethod to-desmos ((obj real) port)
+  (format port "~f" obj))
+
+(defmethod to-desmos ((obj rational) port)
+  (format port "\\frac{")
+  (to-desmos (numerator obj) port)
+  (format port "}{")
+  (to-desmos (denominator obj) port)
+  (format port "}"))
+
+(defmethod to-desmos ((obj integer) port)
+  (format port "~d" obj))
+
+(defmethod to-desmos ((obj list) port)
+  (format port "\\left[")
+  (loop for (n . rest) on obj
+        do (to-desmos n port)
+        when rest do (format port ","))
+  (format port "\\right]"))

undesirable-macros.lisp

@@ -0,0 +1,29 @@
+(load "utils.lisp")
+
+(defmacro fstr (str)
+  (begin
+    (= cmd nil)
+    (= outstr (gensym "outstr"))
+    (=f emit (c) (push `(princ ,c ,outstr) cmd))
+    (with-input-from-string (s str)
+      (loop with escaping? = nil
+            for c = (read-char s nil nil)
+            while c
+            do (cond
+                 (escaping? (emit c)
+                            (setf escaping? nil))
+                 (t (match c
+                      (#\\ (setf escaping? t))
+                      (#\{
+                       (begin
+                         (= chars
+                            (loop for c = (read-char s nil nil)
+                                  while c
+                                  until (eql c #\})
+                                  collecting c))
+                         (= str (map 'string #'identity chars))
+                         (emit (read-from-string str))))
+                      (_   (emit c)))))))
+    `(with-output-to-string (,outstr)
+       ,@(nreverse cmd))))
+

utils.lisp

@@ -0,0 +1,698 @@
+;;; fun
+(proclaim '(inline last1 single append1 conc1))
+
+;; has a lot of goodies
+;; hey whaddayaknow, pg has a with-gensyms
+;; it's just such a useful pattern
+;; maybe i should go wild with the defmacro!?g stuff from LOL
+
+(defun last1 (lst)
+  (car (last lst)))
+
+(defun single (lst)
+  (and (consp lst) (not (cdr lst))))
+
+(defun append1 (lst obj)
+  (append lst (list obj)))
+
+(defun conc1 (lst obj)
+  (nconc lst (list obj)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (ql:quickload '("alexandria" "trivia") :silent t)
+  (use-package '(:alexandria :trivia))
+
+  (proclaim '(inline mklist))
+
+  (defun mklist (obj)
+    (if (listp obj) obj (list obj)))
+
+  (defmacro let1 (name val &body body)
+    `(let ((,name ,val))
+       ,@body))
+
+  ;; labels should rarely be needed
+  (defmacro fpromote ((&rest fs) &body body)
+    `(labels ,(loop for f in (mklist fs)
+                    collecting
+                    (let ((fname
+                            (if (listp f)
+                                (car f)
+                                f))
+                          (fval
+                            (if (listp f)
+                                (cadr f)
+                                f))
+                          (xs (gensym "args")))
+                      `(,fname (&rest ,xs) (apply ,fval ,xs))))
+       ,@body))
+
+  (defmacro nlet (name (&rest vars) &body body)
+    (let1 vars (mapcar #'mklist vars)
+      `(labels ((,name ,(mapcar #'car vars) ,@body))
+         (,name ,@(mapcar #'cadr vars)))))
+
+  (defun group (source n)
+    (if (zerop n) (error "zero length"))
+    (labels ((rec (source acc)
+               (let1 rest (nthcdr n source)
+                 (if (consp rest)
+                     (rec rest (cons (subseq source 0 n) acc))
+                     (nreverse (cons source acc))))))
+      (if source (rec source nil) nil)))
+
+  (defmacro cond1 (&body branches)
+    `(cond ,@(mapcar (lambda (x)
+                       (if (cdr x)
+                           x
+                           (cons t x)))
+                     (group branches 2))))
+  (defmacro when-bind ((var expr) &body body)
+    `(let ((,var ,expr))
+       (when ,var
+         ,@body)))
+
+  (defmacro when-bind* (binds &body body)
+    (if (null binds)
+        `(progn ,@body)
+        `(let (,(car binds))
+           (if ,(caar binds)
+               (when-bind* ,(cdr binds) ,@body)))))
+
+  (defun condlet-binds (vars cl)
+    (mapcar #'(lambda (bindform)
+                (if (consp bindform)
+                    (cons (cdr (assoc (car bindform) vars))
+                          (cdr bindform))))
+            (cdr cl)))
+
+  (defun condlet-clause (vars cl bodfn)
+    `(,(car cl) (let ,(mapcar #'cdr vars)
+                  (let ,(condlet-binds vars cl)
+                    (,bodfn ,@(mapcar #'cdr vars))))))
+
+  ;; straight up do not get this one
+  #+(or)
+  (defmacro condlet (clauses &body body)
+    (let ((bodfn (gensym))
+          (vars (mapcar #'(lambda (v) (cons v (gensym)))
+                        (remove-duplicates
+                         (mapcar #'car
+                                 (mappend #'cdr clauses))))))
+      `(labels ((,bodfn ,(mapcar #'car vars)
+                  ,@body))
+         (cond ,@ (mapcar #'(lambda (cl)
+                              (condlet-clause vars cl bodfn))
+                          clauses))))))
+
+(defun longer (x y)
+  (labels ((compare (x y)
+             (and (consp x)
+                  (or (null y)
+                      (compare (cdr x) (cdr y))))))
+    (if (and (listp x) (listp y))
+        (compare x y)
+        (> (length x) (length y)))))
+
+(defun filter (f lst)
+  (fpromote f
+    (let (acc)
+      (dolist (x lst)
+        (let1 val (f x)
+          (if val (push val acc))))
+      (nreverse acc))))
+
+(defun prune (test tree)
+  (fpromote test
+    (labels ((rec (tree acc)
+               (cond1
+                 (null tree) (nreverse acc)
+                 (consp (car tree)) (rec (cdr tree)
+                                         (cons (rec (car tree) nil) acc))
+                 (rec (cdr tree)
+                      (if (test (car tree))
+                          acc
+                          (cons (car tree) acc))))))
+      (rec tree nil))))
+
+(defun find2 (f lst)
+  (fpromote f
+    (if (null lst)
+        nil
+        (let1 val (f (car lst))
+          (if val
+              (values (car lst) val)
+              (find2 f (cdr lst)))))))
+
+(defun before (x y lst &key (test #'eql))
+  (fpromote test
+    (and lst
+         (let1 first (car lst)
+           (cond1
+             (test y first) nil
+             (test x first) lst
+             (before x y (cdr lst) :test test))))))
+
+(defun after (x y lst &key (test #'eql))
+  (let1 rest (before y x lst :test test)
+    (and rest (member x rest :test test))))
+
+(defun duplicate (obj lst &key (test #'eql))
+  (member obj (cdr (member obj lst :test test))
+          :test test))
+
+(defun split-if (f lst)
+  (fpromote f
+    (let (acc)
+      (do ((src lst (cdr src)))
+          ((or (null src) (f (car src)))
+           (values (nreverse acc) src))
+        (push (car src) acc)))))
+
+(defun most (f lst)
+  (fpromote f
+    (if (null lst)
+        (values nil nil)
+        (let* ((wins (car lst))
+               (max  (f wins)))
+          (dolist (obj (cdr lst))
+            (let1 score (f obj)
+              (when (> score max)
+                (setf wins obj
+                      max  score))))
+          (values wins max)))))
+
+(defun best (f lst)
+  (fpromote f
+    (if (null lst)
+        nil
+        (let1 wins (car lst)
+          (dolist (obj (cdr lst))
+            (if (f obj wins)
+                (setf wins obj)))
+          wins))))
+
+(defun mostn (f lst)
+  (fpromote f
+    (if (null lst)
+        (values nil nil)
+        (let ((result (list (car lst)))
+              (max (f (car lst))))
+          (dolist (obj (cdr lst))
+            (let1 score (f obj)
+              (cond1
+                (> score max) (setf max    score
+                                    result (list obj))
+                (= score max) (push obj result))))
+          (values (nreverse result) max)))))
+
+(defun mapa-b (f a b &optional (step 1))
+  (fpromote f
+    (do ((i a (+ i step))
+         (result nil))
+        ((> i b) (nreverse result))
+      (push (f i) result))))
+
+(defun map0-n (f n)
+  (mapa-b f 0 n))
+
+(defun map1-n (f n)
+  (mapa-b f 1 n))
+
+(defun map-> (f start test succ)
+  (fpromote (f test succ)
+    (do ((i start (succ i))
+         (result nil))
+        ((test i) (nreverse result))
+      (push (f i) result))))
+
+(defun mapcars (f &rest lsts)
+  (fpromote f
+    (let (result)
+      (dolist (lst lsts)
+        (dolist (obj lst)
+          (push (f obj) result)))
+      (nreverse result))))
+
+(defun rmapcar (f &rest args)
+  (if (some #'atom args)
+      (apply f args)
+      (apply #'mapcar
+             #'(lambda (&rest args)
+                 (apply #'rmapcar f args))
+             args)))
+
+(defun readlist (&rest args)
+  (values (read-from-string
+           (concatenate 'string
+                        "("
+                        (apply #'read-line args)
+                        ")"))))
+
+(defun prompt (&rest args)
+  (apply #'format *query-io* args)
+  (read *query-io*))
+
+(defun break-loop (f quit &rest args)
+  (format *query-io* "Entering break-loop ~%")
+  (loop
+    (let1 in (apply #'prompt args)
+      (if (funcall quit in)
+          (return)
+          (format *query-io* "~a~%" (funcall f in))))))
+
+(defun mkstr (&rest args)
+  (with-output-to-string (s)
+    (dolist (a args) (princ a s))))
+
+(defun symb (&rest args)
+  (values (intern (apply #'mkstr args))))
+
+(defun reread (&rest args)
+  (values (read-from-string (apply #'mkstr args))))
+
+;; likely undesirable
+(defun explode (sym)
+  (map 'list #'(lambda (c)
+                 (intern (make-string 1 :initial-element c)))
+       (symbol-name sym)))
+
+;; do we want this?
+;; (defvar *!equivs* (make-hash-table))
+;;
+;; (defun ! (fn)
+;;   (or (gethash fn *!equivs*) fn))
+;;
+;; (defun def! (fn fn!)
+;;   (setf (gethash fn *!equivs*) fn!))
+;;
+;; (def! #'remove-if #'delete-if)
+
+(defun memoize (f)
+  (let1 cache (make-hash-table :test #'equal)
+    #'(lambda (&rest args)
+        (multiple-value-bind (val win) (gethash args cache)
+          (if win
+              val
+              (setf (gethash args cache)
+                    (apply f args)))))))
+
+;; yes
+;; (defun compose (&rest fs)
+;;   (if fs
+;;       (let ((f1 (last1 fs))
+;;             (fs (butlast fs)))
+;;         #'(lambda (&rest args)
+;;             (reduce #'funcall fs
+;;                     :from-end t
+;;                     :initial-value (apply f1 args))))
+;;       #'identity))
+
+;; maybe should take &rest args?
+(defun fif (ifp then &optional else)
+  (fpromote (ifp then else)
+    #'(lambda (x)
+        (if (ifp x)
+            (then x)
+            (if else (else x))))))
+
+;; f-intersection
+(defun fint (f &rest fs)
+  (if (null fs)
+      f
+      (let1 chain (apply #'fint fs)
+        (fpromote (f chain)
+          #'(lambda (x)
+              (and (f x) (chain x)))))))
+
+;; f-union
+(defun fun (f &rest fs)
+  (if (null fs)
+      f
+      (let1 chain (apply #'fun fs)
+        (fpromote (f chain)
+          #'(lambda (x)
+              (or (f x) (chain x)))))))
+
+(defun lrec (rec &optional base)
+  (fpromote (rec base)
+    (labels ((self (lst)
+               (if (null lst)
+                   (if (functionp base)
+                       (base)
+                       base)
+                   (rec (car lst)
+                        #'(lambda ()
+                            (self (cdr lst)))))))
+      #'self)))
+
+(defun ttrav (rec &optional (base #'identity))
+  (fpromote (rec base)
+    (labels ((self (tree)
+               (if (atom tree)
+                   (if (functionp base)
+                       (base tree)
+                       base)
+                   (rec (self (car tree))
+                        (if (cdr tree)
+                            (self (cdr tree)))))))
+      #'self)))
+
+(defun trec (rec &optional (base #'identity))
+  (fpromote (rec base)
+    (labels
+        ((self (tree)
+           (if (atom tree)
+               (if (functionp base)
+                   (base tree)
+                   base)
+               (rec tree
+                    #'(lambda () (self (car tree)))
+                    #'(lambda ()
+                        (if (cdr tree)
+                            (self (cdr tree))))))))
+      #'self)))
+
+(defmacro nil! (&rest vars)
+  `(setf ,@(loop for var in vars
+                 nconcing (list var nil))))
+
+(defmacro nif (n &optional pos zer neg)
+  (once-only (n)
+    `(cond
+       ((plusp  ,n) ,pos)
+       ((minusp ,n) ,neg)
+       (t ,zer))))
+
+;; sly already pretty-prints soooo
+(defmacro mac (expr)
+  (let1 expanded (gensym "EXPANDED")
+    `(let ((,expanded (macroexpand-1 ',expr)))
+       ;; (pprint ,expanded)
+       ,expanded)))
+
+(defmacro in (obj &rest choices)
+  (once-only (obj)
+    `(or ,@(mapcar #'(lambda (c) `(eql ,obj ,c))
+                   choices))))
+
+(defmacro inq (obj &rest args)
+  `(in ,obj ,@(mapcar #'(lambda (a) `',a)
+                      args)))
+
+(defmacro in-if (fn &rest choices)
+  (once-only (fn)
+    `(or ,@ (mapcar #'(lambda (c) `(funcall ,fn ,c))
+                    choices))))
+
+(defun >casex (g cl)
+  (let ((key (car cl)) (rest (cdr cl)))
+    (cond ((consp key) `((in ,g ,@key) ,@rest))
+          ((inq key t otherwise) `(t ,@rest))
+          (t (error "bad >case clause")))))
+
+(defmacro >case (expr &rest clauses)
+  (once-only (expr)
+    `(cond ,@(mapcar #'(lambda (cl) (>casex expr cl))
+                     clauses))))
+
+;; we have loop for for while and till
+
+(defmacro allf (val &rest args)
+  (once-only (val)
+    `(setf ,@(mapcan #'(lambda (a) `(,a ,val))
+                     args))))
+
+(defmacro nilf (&rest args)
+  `(allf nil ,@args))
+
+(define-modify-macro toggle1 () not)
+(defmacro toggle (&rest args)
+  `(progn
+     ,@(mapcar #'(lambda (a) `(toggle1 ,a))
+               args)))
+
+;; more from alexandria
+;; concf (nconcf)
+;; concnew (roughly, unionf)
+
+;; very cool
+(defmacro _f (op place &rest args)
+  (multiple-value-bind (vars forms var set access)
+                       (get-setf-expansion place)
+    `(let* (,@(mapcar #'list vars forms)
+            (,(car var) (,op ,access ,@args)))
+       ,set)))
+
+;; ANAPHORS!
+(defmacro aif (test then &optional else)
+  `(let ((it ,test))
+     (if it ,then ,else)))
+
+(defmacro awhen (test &body body)
+  `(aif ,test
+        (progn ,@body)))
+
+(defmacro awhile (expr &body body)
+  `(do ((it ,expr ,expr))
+       ((not it))
+     ,@body))
+
+(defmacro aand (&rest args)
+  (cond ((null args) t)
+        ((null (cdr args)) (car args))
+        (t `(aif ,(car args) (aand ,@(cdr args))))))
+
+(defmacro acond (&rest clauses)
+  (if (null clauses)
+      nil
+      (once-only ((test (caar clauses)))
+        `(if ,test
+             (let ((it ,test)) ,@(cdar clauses))
+             (acond ,@(cdr clauses))))))
+
+(defmacro alambda (args &body body)
+  `(labels ((self ,args ,@body))
+     #'self))
+
+;; reminds me of clojure's -> (i'll add that why not)
+;; (i'll probably end up integrating another alexandria-like that has it anyway :P)
+;; (n)let me be fancy
+(defmacro ablock (tag &rest args)
+  `(block ,tag
+     ,(nlet self ((args args))
+        (case (length args)
+          (0 nil)
+          (1 (car args))
+          (t `(let1 ((it ,(car args)))
+                ,(self (cdr args))))))))
+
+;; clever!
+;; is the or necessary?
+(defmacro aif2 (test then &optional else)
+  (with-gensyms (ok)
+    `(multiple-value-bind (it ,ok) ,test
+       (if (or it ,ok)
+           ,then
+           ,else))))
+
+(defmacro awhen2 (test &body body)
+  `(aif2 ,test
+         (progn ,@body)))
+
+(defmacro awhile2 (test &body body)
+  (with-gensyms (flag)
+    `(let ((,flag t))
+       (loop while ,flag
+             (aif2 ,test
+                   (progn ,@body)
+                   (setf ,flag nil))))))
+
+;; doubt i'll use it but for completeness
+(defmacro acond2 (&rest clauses)
+  (if (null clauses)
+      nil
+      (let ((cl1 (car clauses)))
+        (with-gensyms (val win)
+          `(multiple-value-bind (,val ,win) ,(car cl1)
+             (if (or ,val ,win)
+                 (let ((it ,val)) ,@(cdr cl1))
+                 (acond2 ,@(cdr clauses))))))))
+
+;; i was being foolish
+;; pg's is awesome stuff
+#|
+(defvar *fn-builders* (make-hash-table))
+(defmacro defbuilder (name (&rest args) &body body)
+  `(setf (gethash ',name *fn-builders*) (alambda ,args ,@body)))
+
+(defbuilder lambda (args &rest body) `(lambda ,args ,@body))
+(defbuilder and (&rest fs)
+  (with-gensyms (args)
+    `(lambda (&rest ,args)
+       (and ,@(loop for f in fs
+                    collecting `(apply #',(rbuild f) ,args))))))
+(defbuilder or (&rest fs)
+  (with-gensyms (args)
+    `(lambda (&rest ,args)
+       (or ,@(loop for f in fs
+                   collecting `(apply #',(rbuild f) ,args))))))
+(defbuilder compose (&rest fs)
+  )
+|#
+
+(declaim (ftype (function (t) t) rbuild))
+
+(defun build-compose (fns)
+  (with-gensyms (g)
+    `(lambda (,g)
+       ,(nlet rec ((fns fns))
+          (if fns
+              `(,(rbuild (car fns))
+                ,(rec (cdr fns)))
+              g)))))
+
+(defun build-call (op fns)
+  (with-gensyms (g)
+    `(lambda (,g)
+       (,op ,@(mapcar #'(lambda (f)
+                          `(,(rbuild f) ,g))
+                      fns)))))
+
+(defun rbuild (expr)
+  (if (or (atom expr) (inq (car expr) lambda function))
+      expr
+      (if (eq (car expr) 'compose)
+          (build-compose (cdr expr))
+          (build-call (car expr) (cdr expr)))))
+
+(defmacro fn (expr)
+  "shorthand for writing functions of a single argument
+(fn f)                 => #'f
+(fn (f g))             => (lambda (x) (f (g x)))
+(fn (compose a b c d)) => (lambda (x) (a (b (c (d x)))))
+(fn (list f g h))      => (lambda (x) (list (f x) (g x) (h x)))
+"
+  `#',(rbuild expr))
+
+(defmacro alrec (rec &optional base)
+  (with-gensyms (fn)
+    `(lrec #'(lambda (it ,fn)
+               (symbol-macrolet ((rec (funcall ,fn)))
+                 ,rec))
+           ,base)))
+
+(defmacro on-cdrs (rec base &rest lsts)
+  `(funcall (alrec ,rec #'(lambda () ,base)) ,@lsts))
+
+(defmacro atrec (rec &optional (base 'it))
+  (with-gensyms (lfn rfn)
+    `(trec #'(lambda (it ,lfn ,rfn)
+               (declare (ignorable it))
+               (symbol-macrolet ((left (funcall ,lfn))
+                                 (right (funcall ,rfn)))
+                 ,rec))
+           #'(lambda (it) ,base))))
+
+(defmacro on-trees (rec base &rest trees)
+  `(funcall (atrec ,rec ,base) ,@trees))
+
+(defvar unforced (gensym))
+
+;; a struct instead of a lambda is more visible
+(defstruct promise forced closure)
+
+;; interesting approach
+(defmacro delay (&body body)
+  (with-gensyms (self)
+    `(let ((,self (make-promise :forced unforced)))
+       (setf (promise-closure ,self)
+             #'(lambda ()
+                 (setf (promise-forced ,self) (progn ,@body))))
+       ,self)))
+
+(defun force (x)
+  (if (promise-p x)
+      (if (eq (promise-forced x) unforced)
+          (funcall (promise-closure x))
+          (promise-forced x))
+      x))
+
+(defmacro abbrev (short long)
+  `(defmacro ,short (&rest args)
+     `(,',long ,@args)))
+
+(defmacro abbrevs (&rest names)
+  `(progn
+     ,@(loop for pair in (group names 2)
+             collecting `(abbrev ,@pair))))
+
+(abbrevs dbind  destructuring-bind
+         mvbind multiple-value-bind
+         mvsetq multiple-value-setq)
+
+;; not great
+(defmacro propmacro (propname)
+  `(defmacro ,propname (obj)
+     `(get ,obj ',',propname)))
+
+(defmacro propmacros (&rest props)
+  `(progn
+     ,@(loop for prop in props
+             collecting `(propmacro ,prop))))
+
+;; meh
+;; i bet this'll come up
+(defun fix (f x0 &key (test #'eql))
+  (fpromote (f test)
+    (nlet wow ((x (f x0)) (last x0))
+      (if (test x last)
+          x
+          (wow (f x) x)))))
+
+(defmacro as-> (val name &body body)
+  (cond1
+    (null body) val
+    (null (cdr body)) `(let ((,name ,val)) ,(car body))
+    `(let* ,(mapcar #'(lambda (b) `(,name ,b)) (cons val (butlast body)))
+       ,(lastcar body))))
+
+;; even more for fun
+(defmacro a-> (val &body body)
+  `(as-> ,val it ,@body))
+
+;; (defmacro <>-> (val &body body)
+;;   `(as-> ,val <> ,@body))
+
+(defmacro doprod ((&rest binds) &body body)
+  (if (null binds)
+      `(progn ,@body)
+      `(loop for ,(first (car binds)) in ,(second (car binds))
+             do (doprod ,(cdr binds) ,@body))))
+
+(defpattern structure (expr)
+  (match expr
+    ((list 'quote x) `',x)
+    ((cons a b) `(cons (structure ,a) (structure ,b)))
+    (x x)))
+
+(defmacro begin (&body body)
+  "PROGN that admits internal, sequential defines written = a la arc"
+  (match body
+    ((list stmt) stmt)
+    ((cons stmt rest)
+     (match stmt
+       ((structure ('= ('values . binds) . body))
+        `(multiple-value-match (progn ,@body)
+           (,binds (begin ,@rest))))
+
+       ((list* '= pattern body)
+        `(let-match1 ,pattern (progn ,@body)
+           (begin ,@rest)))
+
+       ((structure ('=f name args . body))
+        `(flet ((,name ,args (begin ,@body)))
+           (begin ,@rest)))
+
+       (_ `(progn ,stmt (begin ,@rest)))))
+    (_ nil)))

word-search.lisp

@@ -0,0 +1,25 @@
+;; TODO:
+
+;; an M*N word search has M horiz, N vert, M diag, N diag
+
+(load "utils.lisp")
+
+;; not good
+(defun eacharray (f arr)
+  (apply #'map-product
+         #'(lambda (&rest idxs) (apply f (apply #'aref arr idxs) idxs))
+         (mapcar #'iota (array-dimensions arr))))
+
+(defmacro docross ((x y &optional c) arr &body body)
+  (once-only (arr)
+    `(loop for ,y below (array-dimension ,arr 0)
+           do (loop for ,x below (array-dimension ,arr 1)
+                    do
+                    ,(if c
+                         `(symbol-macrolet ((,c (aref ,arr ,y ,x)))
+                            (progn ,@body))
+                         `(progn ,@body))))))
+
+
+(defun things (arr words)
+  (docross (x y)))