1 files changed, 169 insertions, 0 deletions
diff --git a/hyperquirks.lisp b/hyperquirks.lisp
new file mode 100644
index 0000000..e90ff35
--- /dev/null
+++ b/hyperquirks.lisp
@@ -0,0 +1,169 @@
+;;;; hyperquirks.lisp
+
+(in-package #:hyperquirks)
+
+;;; MACROS
+
+(defmacro imperative (&body body)
+   "Evaluate expressins in BODY in sequence. Expressions that look
+ like (:= VAR1 EXPR1 ...) will expand into a LET* form whose bindings
+ are valid for the rest of the BODY
+
+ E.g.
+
+ (imperative 
+   (format t \"Welcome to IMPERATIVE\") 
+   (terpri)
+   (:= x 10 z (+ x 20))
+   (format t \"X = ~a, Z = ~a~%\" x z)
+   (:= y (+ z 20))
+   (format t \"Y = ~a~%\" y)
+   (list x y z))
+
+ would evaluate to:
+
+ Welcome to IMPERATIVE    ;; <-- printed to stdout
+ X = 10, Z = 30
+ Y = 50
+ 
+(10 50 30)     ;; <-- return value
+
+IMPERATIVE introduces an implicit, anonymous BLOCK, and hence can be
+returned from.
+ "
+   (labels ((binding-form-p (form)
+              (and (consp form)
+                   (keywordp (first form))
+                   (eql := (first form))))
+            (collect-bindings (bindings)
+              (loop for (var expr . more) on bindings by #'cddr
+                    collect (list var expr)))
+            (expander (body)
+              (cond
+                ((null body) body)
+                ((binding-form-p (first body))
+                 (list (list* 'let* (collect-bindings (rest (first body)))
+                              (expander (rest body)))))
+                (t
+                 (cons (first body)
+                       (expander (rest body)))))))
+     `(block () ,@(expander body))))
+
+
+(defmacro imperative-cond (&body clauses)
+  "Like cond except the first form of every clause is a binding form
+alá IMPERATIVE. 
+
+E.g. 
+
+(imperative-cond 
+   ((:= x (and (zerop (random 2)) 10)
+        y 11)
+    (list :x x :y y))
+   (t
+     12))
+
+
+That would bind x and y in the first clause, check both both are non
+nil, and if they are, return the evaluated body, in this case (list :x x :y y)
+
+Otherwise 12 would be returned."
+
+  (let ((imperative-body 
+          (loop for (bindings . body) in clauses
+                for vars = (unless (eq t bindings)
+                             (loop for (var _ . more) on (rest bindings) by #'cddr
+                                   collect var))
+                collect bindings
+                collect `(when (and ,@vars) (return (progn ,@body))))))
+    `(imperative ,@imperative-body)))
+
+
+
+(defmacro with-plist (vars plist &body body)
+  "Extract some properties from a property list, bind them to a variable
+with the same name as the property, and execute the body.
+
+PLIST is any expression that evaluates to a propety list. 
+
+E.g. 
+
+(let ((me (list :name \"colin\" 'age 40 :occupation :slacker)))
+   (with-plist (name age occupation) me
+      (format t \"My name is ~a, and I am a ~a year old ~a~%\" 
+        name age occupation)))
+
+Will print out:
+My name is colin, and I am a 40 year old SLACKER
+
+Notice that the keys in the PLIST can be eitehr keywords or symbols in
+some other package.
+"
+  (let* ((plist-var
+           (gensym))
+         (bindings
+           (loop for var in vars
+                 for keyword-var = (intern (symbol-name var) 'keyword)
+                 collect `(,var (or (getf ,plist-var ,keyword-var)
+                                    (getf ,plist-var ',var))))))
+    `(let ((,plist-var ,plist))
+       (let ,bindings
+         ,@body))))
+
+
+(defmacro with-leaves (leaf-var tree &body body)
+  "Binds each atom in TREE to LEAF-VAR and then executes BODY."
+  (let ((tree-var (gensym))
+        (ignore-var (gensym)))
+    `(let ((,tree-var ,tree))
+       (tree-equal ,tree-var ,tree-var
+                   :test (lambda (,leaf-var ,ignore-var)
+                           (declare (ignore ,ignore-var))
+                           ,@body
+                           t)))))
+
+
+
+;;; LIST FUNCTIONS
+
+(defun group (n xs &optional default)
+  "Group a list XS into consequtive sublists of size N, using the
+DEFAULT to fill in any remainder in the case the length of XS is not
+neatly divisible by N."
+  (loop for l on xs by (lambda (l) (nthcdr n l))
+        when (<= n (length l))
+          collect (subseq l 0 n)
+        else
+          collect (append l (loop repeat (- n (length l)) collect default))))
+
+
+;;; STRING FUNCTIONS
+
+(defun tabulate
+    (objects line-width col-count
+     &key
+       (default-fill #\space)
+       (stream t)
+       (object-formatter "~a"))
+"Print a table of OBJECTS to STREAM. The table will be LINE-WIDTH
+chracters wide and each line will have COL-COUNT columns. 
+
+The objects are formatted with the format string OBJECT-FORMATTER,
+which defaults to ~a. DEFAULT-FILL is used to fill in blanks in the
+table."
+  (let ((row-format
+          (apply 'concatenate 'string
+                 "~" (prin1-to-string line-width) "<"
+                 (loop for i from 1 to col-count
+                       collect object-formatter
+                       when (< i col-count)
+                         collect "~;"
+                       else
+                         collect "~>~%"))))
+    (dolist (g (group col-count objects default-fill))
+      (apply #'format stream row-format g))))
+
+
+
+
+