path: root/hyperquirks.lisp

;;;; hyperquirks.lisp

(in-package #:hyperquirks)

;;; MACROS

(defmacro defvarf (var &optional val doc)
  `(if (boundp ',var)
       (setf ,var ,val)
       (defvar ,var ,val ,doc)))

(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 >> (ob &rest accessors)
  "Chain access to OB."
  (let* ((tmpvar
           (gensym))
         (block-name
           (gensym))
         (body
           (loop for a in accessors
                 when (symbolp a)
                   collect `(setf ,tmpvar (funcall ',a ,tmpvar))
                 else
                   collect `(setf ,tmpvar (funcall ,a ,tmpvar)))))
    `(block ,block-name
         (let ((,tmpvar ,ob))
           ,@body))))


(defmacro ?> ((&key default (test 'null)) ob &rest accessors)
  "Chain access to OB, returning DEFAULT the first time TEST returns null.
E.g. 


> (let ((num-tree '(1 (2 3 (4 5) 6))))
    (?> num-tree second third fourth))
NIL

> (let ((num-tree '(1 (2 3 (4 5) 6))))
    (?> num-tree second third first))
4
"
  (let* ((tmpvar
           (gensym "TEMP"))
         (block-name
           (gensym "BLOCK"))
         (body
           (loop for a in accessors
                 collect `(when (funcall ',test ,tmpvar)
                            (return-from ,block-name ,default))
                 when (symbolp a)
                   collect `(setf ,tmpvar (funcall ',a ,tmpvar))
                 else
                   collect `(setf ,tmpvar (funcall ,a ,tmpvar)))))
    `(block ,block-name
         (let ((,tmpvar ,ob))
           ,@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 (keys plist &body body)
  "KEYS is a list, each member of which is either a symbol or a pair of symbols.

If a member is just a symbol, say KEY, then it is treated as the name
of a symbol-macro (defined using symbol-macrolet) that expands to the
expression (getf PLIST KEY).  In this case, KEY is not allowed to be a
keyword symbol.

If a member is a pair of symbols, it is of the form (VAR KEY). Here,
key is a valid key into the PLIST and VAR is the name of the symbol
macrolet that will be bound to (getf PLIST KEY).

EXAMPLE:

(let ((pl 
        (list 'name \"colin\" :age 40 :|currentJob| :crumb-bum)))
  (hq:with-plist (name (age :age) (job :|currentJob|)) pl 
    (setf age (1+ age)) 
    (format t \"~a the ~a had a birthday, and is now ~a years old~%\" 
            name job age) 
    pl))

The above would print out:
colin the CRUMB-BUM had a birthday, and is now 41 years old

And would return 
(NAME \"colin\" :AGE 41 :|currentJob| :CRUMB-BUM)"  

  (let* ((plist-var
           (gensym))
         (macrolet-bindings
           (loop for term in keys
                 when (consp term )
                   collect (destructuring-bind (var key) term
                               `(,var (getf ,plist-var ',key)))
                 else
                   collect `(,term (getf ,plist-var ',term)))))
    `(let ((,plist-var ,plist)) (symbol-macrolet ,macrolet-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)))))



(defmacro defun-case (name &rest clauses)
  "Clauses look like (VARLIST . BODY) 

E.g. 

(defun-case foobar 
  (() 10) 
  ((x y) (+ x y))
  ((foo) (* foo 2))
  ((a b c d) (list a b c d)))"
  (let* ((rest-args
           (gensym "variable-pattern-"))
         (clauses
           (loop for (arglist . body) in clauses
                 collect `(,(length arglist)
                           (destructuring-bind ,arglist ,rest-args
                             ,@body)))))
    `(defun ,name (&rest ,rest-args)
       (case (length ,rest-args)
         ,@clauses))))

;;; 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
    with len = (length xs)
    for start from 0 to len by n
    for end = (+ start n)
    when (<= end len)
      collect (subseq xs start end)
    when (< start len end)
      collect (nconc (subseq xs start)
                     (loop repeat (- end len) 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))))