--- a/Makefile Sat Aug 20 21:40:14 2016 +0000
+++ b/Makefile Sat Aug 20 21:44:25 2016 +0000
@@ -21,8 +21,8 @@
# Quickutils ------------------------------------------------------------------
-src/quickutils.lisp: src/make-quickutils.lisp
- cd src && sbcl-rlwrap --noinform --load make-quickutils.lisp --eval '(quit)'
+vendor/quickutils.lisp: vendor/make-quickutils.lisp
+ cd vendor && ros run -L sbcl --load make-quickutils.lisp
# Documentation ---------------------------------------------------------------
--- a/bones.asd Sat Aug 20 21:40:14 2016 +0000
+++ b/bones.asd Sat Aug 20 21:44:25 2016 +0000
@@ -15,7 +15,9 @@
:in-order-to ((asdf:test-op (asdf:test-op #:bones-test)))
:serial t
- :components ((:file "src/quickutils") ; quickutils package ordering crap
+ :components ((:module "vendor"
+ :serial t
+ :components ((:file "quickutils")))
(:file "package")
(:module "src"
:serial t
--- a/src/make-quickutils.lisp Sat Aug 20 21:40:14 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,23 +0,0 @@
-(ql:quickload 'quickutil)
-
-(qtlc:save-utils-as
- "quickutils.lisp"
- :utilities '(:define-constant
- :set-equal
- :curry
- :rcurry
- :switch
- :ensure-boolean
- :while
- :until
- :tree-member-p
- :with-gensyms
- :once-only
- :zip
- :alist-to-hash-table
- :map-tree
- :weave
- :alist-plist
- :equivalence-classes
- :map-product)
- :package "BONES.QUICKUTILS")
--- a/src/quickutils.lisp Sat Aug 20 21:40:14 2016 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,413 +0,0 @@
-;;;; This file was automatically generated by Quickutil.
-;;;; See http://quickutil.org for details.
-
-;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :RCURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :WITH-GENSYMS :ONCE-ONLY :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE :WEAVE :ALIST-PLIST :EQUIVALENCE-CLASSES :MAP-PRODUCT) :ensure-package T :package "BONES.QUICKUTILS")
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (unless (find-package "BONES.QUICKUTILS")
- (defpackage "BONES.QUICKUTILS"
- (:documentation "Package that contains Quickutil utility functions.")
- (:use #:cl))))
-
-(in-package "BONES.QUICKUTILS")
-
-(when (boundp '*utilities*)
- (setf *utilities* (union *utilities* '(:DEFINE-CONSTANT :SET-EQUAL
- :MAKE-GENSYM-LIST :ENSURE-FUNCTION
- :CURRY :RCURRY :STRING-DESIGNATOR
- :WITH-GENSYMS :EXTRACT-FUNCTION-NAME
- :SWITCH :ENSURE-BOOLEAN :UNTIL :WHILE
- :TREE-MEMBER-P :ONCE-ONLY :TRANSPOSE
- :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE
- :WEAVE :SAFE-ENDP :ALIST-PLIST
- :EQUIVALENCE-CLASSES :MAPPEND
- :MAP-PRODUCT))))
-
- (defun %reevaluate-constant (name value test)
- (if (not (boundp name))
- value
- (let ((old (symbol-value name))
- (new value))
- (if (not (constantp name))
- (prog1 new
- (cerror "Try to redefine the variable as a constant."
- "~@<~S is an already bound non-constant variable ~
- whose value is ~S.~:@>" name old))
- (if (funcall test old new)
- old
- (restart-case
- (error "~@<~S is an already defined constant whose value ~
- ~S is not equal to the provided initial value ~S ~
- under ~S.~:@>" name old new test)
- (ignore ()
- :report "Retain the current value."
- old)
- (continue ()
- :report "Try to redefine the constant."
- new)))))))
-
- (defmacro define-constant (name initial-value &key (test ''eql) documentation)
- "Ensures that the global variable named by `name` is a constant with a value
-that is equal under `test` to the result of evaluating `initial-value`. `test` is a
-function designator that defaults to `eql`. If `documentation` is given, it
-becomes the documentation string of the constant.
-
-Signals an error if `name` is already a bound non-constant variable.
-
-Signals an error if `name` is already a constant variable whose value is not
-equal under `test` to result of evaluating `initial-value`."
- `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
- ,@(when documentation `(,documentation))))
-
-
- (defun set-equal (list1 list2 &key (test #'eql) (key nil keyp))
- "Returns true if every element of `list1` matches some element of `list2` and
-every element of `list2` matches some element of `list1`. Otherwise returns false."
- (let ((keylist1 (if keyp (mapcar key list1) list1))
- (keylist2 (if keyp (mapcar key list2) list2)))
- (and (dolist (elt keylist1 t)
- (or (member elt keylist2 :test test)
- (return nil)))
- (dolist (elt keylist2 t)
- (or (member elt keylist1 :test test)
- (return nil))))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun make-gensym-list (length &optional (x "G"))
- "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
-using the second (optional, defaulting to `\"G\"`) argument."
- (let ((g (if (typep x '(integer 0)) x (string x))))
- (loop repeat length
- collect (gensym g))))
- ) ; eval-when
-(eval-when (:compile-toplevel :load-toplevel :execute)
- ;;; To propagate return type and allow the compiler to eliminate the IF when
- ;;; it is known if the argument is function or not.
- (declaim (inline ensure-function))
-
- (declaim (ftype (function (t) (values function &optional))
- ensure-function))
- (defun ensure-function (function-designator)
- "Returns the function designated by `function-designator`:
-if `function-designator` is a function, it is returned, otherwise
-it must be a function name and its `fdefinition` is returned."
- (if (functionp function-designator)
- function-designator
- (fdefinition function-designator)))
- ) ; eval-when
-
- (defun curry (function &rest arguments)
- "Returns a function that applies `arguments` and the arguments
-it is called with to `function`."
- (declare (optimize (speed 3) (safety 1) (debug 1)))
- (let ((fn (ensure-function function)))
- (lambda (&rest more)
- (declare (dynamic-extent more))
- ;; Using M-V-C we don't need to append the arguments.
- (multiple-value-call fn (values-list arguments) (values-list more)))))
-
- (define-compiler-macro curry (function &rest arguments)
- (let ((curries (make-gensym-list (length arguments) "CURRY"))
- (fun (gensym "FUN")))
- `(let ((,fun (ensure-function ,function))
- ,@(mapcar #'list curries arguments))
- (declare (optimize (speed 3) (safety 1) (debug 1)))
- (lambda (&rest more)
- (apply ,fun ,@curries more)))))
-
-
- (defun rcurry (function &rest arguments)
- "Returns a function that applies the arguments it is called
-with and `arguments` to `function`."
- (declare (optimize (speed 3) (safety 1) (debug 1)))
- (let ((fn (ensure-function function)))
- (lambda (&rest more)
- (declare (dynamic-extent more))
- (multiple-value-call fn (values-list more) (values-list arguments)))))
-
-
- (deftype string-designator ()
- "A string designator type. A string designator is either a string, a symbol,
-or a character."
- `(or symbol string character))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defmacro with-gensyms (names &body forms)
- "Binds each variable named by a symbol in `names` to a unique symbol around
-`forms`. Each of `names` must either be either a symbol, or of the form:
-
- (symbol string-designator)
-
-Bare symbols appearing in `names` are equivalent to:
-
- (symbol symbol)
-
-The string-designator is used as the argument to `gensym` when constructing the
-unique symbol the named variable will be bound to."
- `(let ,(mapcar (lambda (name)
- (multiple-value-bind (symbol string)
- (etypecase name
- (symbol
- (values name (symbol-name name)))
- ((cons symbol (cons string-designator null))
- (values (first name) (string (second name)))))
- `(,symbol (gensym ,string))))
- names)
- ,@forms))
-
- (defmacro with-unique-names (names &body forms)
- "Binds each variable named by a symbol in `names` to a unique symbol around
-`forms`. Each of `names` must either be either a symbol, or of the form:
-
- (symbol string-designator)
-
-Bare symbols appearing in `names` are equivalent to:
-
- (symbol symbol)
-
-The string-designator is used as the argument to `gensym` when constructing the
-unique symbol the named variable will be bound to."
- `(with-gensyms ,names ,@forms))
- ) ; eval-when
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun extract-function-name (spec)
- "Useful for macros that want to mimic the functional interface for functions
-like `#'eq` and `'eq`."
- (if (and (consp spec)
- (member (first spec) '(quote function)))
- (second spec)
- spec))
- ) ; eval-when
-
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (defun generate-switch-body (whole object clauses test key &optional default)
- (with-gensyms (value)
- (setf test (extract-function-name test))
- (setf key (extract-function-name key))
- (when (and (consp default)
- (member (first default) '(error cerror)))
- (setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S."
- ,value ',test)))
- `(let ((,value (,key ,object)))
- (cond ,@(mapcar (lambda (clause)
- (if (member (first clause) '(t otherwise))
- (progn
- (when default
- (error "Multiple default clauses or illegal use of a default clause in ~S."
- whole))
- (setf default `(progn ,@(rest clause)))
- '(()))
- (destructuring-bind (key-form &body forms) clause
- `((,test ,value ,key-form)
- ,@forms))))
- clauses)
- (t ,default))))))
-
- (defmacro switch (&whole whole (object &key (test 'eql) (key 'identity))
- &body clauses)
- "Evaluates first matching clause, returning its values, or evaluates and
-returns the values of `default` if no keys match."
- (generate-switch-body whole object clauses test key))
-
- (defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity))
- &body clauses)
- "Like `switch`, but signals an error if no key matches."
- (generate-switch-body whole object clauses test key '(error)))
-
- (defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity))
- &body clauses)
- "Like `switch`, but signals a continuable error if no key matches."
- (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
-
-
- (defun ensure-boolean (x)
- "Convert `x` into a Boolean value."
- (and x t))
-
-
- (defmacro until (expression &body body)
- "Executes `body` until `expression` is true."
- `(do ()
- (,expression)
- ,@body))
-
-
- (defmacro while (expression &body body)
- "Executes `body` while `expression` is true."
- `(until (not ,expression)
- ,@body))
-
-
- (defun tree-member-p (item tree &key (test #'eql))
- "Returns `t` if `item` is in `tree`, `nil` otherwise."
- (labels ((rec (tree)
- (cond ((null tree) nil)
- ((atom tree) (funcall test item tree))
- (t (or (rec (car tree))
- (rec (cdr tree)))))))
- (rec tree)))
-
-
- (defmacro once-only (specs &body forms)
- "Evaluates `forms` with symbols specified in `specs` rebound to temporary
-variables, ensuring that each initform is evaluated only once.
-
-Each of `specs` must either be a symbol naming the variable to be rebound, or of
-the form:
-
- (symbol initform)
-
-Bare symbols in `specs` are equivalent to
-
- (symbol symbol)
-
-Example:
-
- (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
- (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
- (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
- (names-and-forms (mapcar (lambda (spec)
- (etypecase spec
- (list
- (destructuring-bind (name form) spec
- (cons name form)))
- (symbol
- (cons spec spec))))
- specs)))
- ;; bind in user-macro
- `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
- gensyms names-and-forms)
- ;; bind in final expansion
- `(let (,,@(mapcar (lambda (g n)
- ``(,,g ,,(cdr n)))
- gensyms names-and-forms))
- ;; bind in user-macro
- ,(let ,(mapcar (lambda (n g) (list (car n) g))
- names-and-forms gensyms)
- ,@forms)))))
-
-
- (defun transpose (lists)
- "Analog to matrix transpose for a list of lists given by `lists`."
- (apply #'mapcar #'list lists))
-
-
- (defun zip (&rest lists)
- "Take a tuple of lists and turn them into a list of
-tuples. Equivalent to `unzip`."
- (transpose lists))
-
-
- (defun alist-to-hash-table (kv-pairs)
- "Create a hash table populated with `kv-pairs`."
- (let ((hashtab (make-hash-table :test #'equal)))
- (loop
- :for (i j) :in kv-pairs
- :do (setf (gethash i hashtab) j)
- :finally (return hashtab))))
-
-
- (defun map-tree (function tree)
- "Map `function` to each of the leave of `tree`."
- (check-type tree cons)
- (labels ((rec (tree)
- (cond
- ((null tree) nil)
- ((atom tree) (funcall function tree))
- ((consp tree)
- (cons (rec (car tree))
- (rec (cdr tree)))))))
- (rec tree)))
-
-
- (defun weave (&rest lists)
- "Return a list whose elements alternate between each of the lists
-`lists`. Weaving stops when any of the lists has been exhausted."
- (apply #'mapcan #'list lists))
-
-
- (declaim (inline safe-endp))
- (defun safe-endp (x)
- (declare (optimize safety))
- (endp x))
-
-
- (defun alist-plist (alist)
- "Returns a property list containing the same keys and values as the
-association list ALIST in the same order."
- (let (plist)
- (dolist (pair alist)
- (push (car pair) plist)
- (push (cdr pair) plist))
- (nreverse plist)))
-
- (defun plist-alist (plist)
- "Returns an association list containing the same keys and values as the
-property list PLIST in the same order."
- (let (alist)
- (do ((tail plist (cddr tail)))
- ((safe-endp tail) (nreverse alist))
- (push (cons (car tail) (cadr tail)) alist))))
-
-
- (defun equivalence-classes (equiv seq)
- "Partition the sequence `seq` into a list of equivalence classes
-defined by the equivalence relation `equiv`."
- (let ((classes nil))
- (labels ((find-equivalence-class (x)
- (member-if (lambda (class)
- (funcall equiv x (car class)))
- classes))
-
- (add-to-class (x)
- (let ((class (find-equivalence-class x)))
- (if class
- (push x (car class))
- (push (list x) classes)))))
- (declare (dynamic-extent (function find-equivalence-class)
- (function add-to-class))
- (inline find-equivalence-class
- add-to-class))
-
- ;; Partition into equivalence classes.
- (map nil #'add-to-class seq)
-
- ;; Return the classes.
- classes)))
-
-
- (defun mappend (function &rest lists)
- "Applies `function` to respective element(s) of each `list`, appending all the
-all the result list to a single list. `function` must return a list."
- (loop for results in (apply #'mapcar function lists)
- append results))
-
-
- (defun map-product (function list &rest more-lists)
- "Returns a list containing the results of calling `function` with one argument
-from `list`, and one from each of `more-lists` for each combination of arguments.
-In other words, returns the product of `list` and `more-lists` using `function`.
-
-Example:
-
- (map-product 'list '(1 2) '(3 4) '(5 6))
- => ((1 3 5) (1 3 6) (1 4 5) (1 4 6)
- (2 3 5) (2 3 6) (2 4 5) (2 4 6))"
- (labels ((%map-product (f lists)
- (let ((more (cdr lists))
- (one (car lists)))
- (if (not more)
- (mapcar f one)
- (mappend (lambda (x)
- (%map-product (curry f x) more))
- one)))))
- (%map-product (ensure-function function) (cons list more-lists))))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(define-constant set-equal curry rcurry switch eswitch cswitch
- ensure-boolean while until tree-member-p with-gensyms
- with-unique-names once-only zip alist-to-hash-table map-tree weave
- alist-plist plist-alist equivalence-classes map-product)))
-
-;;;; END OF quickutils.lisp ;;;;
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/make-quickutils.lisp Sat Aug 20 21:44:25 2016 +0000
@@ -0,0 +1,25 @@
+(ql:quickload 'quickutil)
+
+(qtlc:save-utils-as
+ "quickutils.lisp"
+ :utilities '(:define-constant
+ :set-equal
+ :curry
+ :rcurry
+ :switch
+ :ensure-boolean
+ :while
+ :until
+ :tree-member-p
+ :with-gensyms
+ :once-only
+ :zip
+ :alist-to-hash-table
+ :map-tree
+ :weave
+ :alist-plist
+ :equivalence-classes
+ :map-product)
+ :package "BONES.QUICKUTILS")
+
+(quit)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/quickutils.lisp Sat Aug 20 21:44:25 2016 +0000
@@ -0,0 +1,413 @@
+;;;; This file was automatically generated by Quickutil.
+;;;; See http://quickutil.org for details.
+
+;;;; To regenerate:
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:DEFINE-CONSTANT :SET-EQUAL :CURRY :RCURRY :SWITCH :ENSURE-BOOLEAN :WHILE :UNTIL :TREE-MEMBER-P :WITH-GENSYMS :ONCE-ONLY :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE :WEAVE :ALIST-PLIST :EQUIVALENCE-CLASSES :MAP-PRODUCT) :ensure-package T :package "BONES.QUICKUTILS")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (find-package "BONES.QUICKUTILS")
+ (defpackage "BONES.QUICKUTILS"
+ (:documentation "Package that contains Quickutil utility functions.")
+ (:use #:cl))))
+
+(in-package "BONES.QUICKUTILS")
+
+(when (boundp '*utilities*)
+ (setf *utilities* (union *utilities* '(:DEFINE-CONSTANT :SET-EQUAL
+ :MAKE-GENSYM-LIST :ENSURE-FUNCTION
+ :CURRY :RCURRY :STRING-DESIGNATOR
+ :WITH-GENSYMS :EXTRACT-FUNCTION-NAME
+ :SWITCH :ENSURE-BOOLEAN :UNTIL :WHILE
+ :TREE-MEMBER-P :ONCE-ONLY :TRANSPOSE
+ :ZIP :ALIST-TO-HASH-TABLE :MAP-TREE
+ :WEAVE :SAFE-ENDP :ALIST-PLIST
+ :EQUIVALENCE-CLASSES :MAPPEND
+ :MAP-PRODUCT))))
+
+ (defun %reevaluate-constant (name value test)
+ (if (not (boundp name))
+ value
+ (let ((old (symbol-value name))
+ (new value))
+ (if (not (constantp name))
+ (prog1 new
+ (cerror "Try to redefine the variable as a constant."
+ "~@<~S is an already bound non-constant variable ~
+ whose value is ~S.~:@>" name old))
+ (if (funcall test old new)
+ old
+ (restart-case
+ (error "~@<~S is an already defined constant whose value ~
+ ~S is not equal to the provided initial value ~S ~
+ under ~S.~:@>" name old new test)
+ (ignore ()
+ :report "Retain the current value."
+ old)
+ (continue ()
+ :report "Try to redefine the constant."
+ new)))))))
+
+ (defmacro define-constant (name initial-value &key (test ''eql) documentation)
+ "Ensures that the global variable named by `name` is a constant with a value
+that is equal under `test` to the result of evaluating `initial-value`. `test` is a
+function designator that defaults to `eql`. If `documentation` is given, it
+becomes the documentation string of the constant.
+
+Signals an error if `name` is already a bound non-constant variable.
+
+Signals an error if `name` is already a constant variable whose value is not
+equal under `test` to result of evaluating `initial-value`."
+ `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
+ ,@(when documentation `(,documentation))))
+
+
+ (defun set-equal (list1 list2 &key (test #'eql) (key nil keyp))
+ "Returns true if every element of `list1` matches some element of `list2` and
+every element of `list2` matches some element of `list1`. Otherwise returns false."
+ (let ((keylist1 (if keyp (mapcar key list1) list1))
+ (keylist2 (if keyp (mapcar key list2) list2)))
+ (and (dolist (elt keylist1 t)
+ (or (member elt keylist2 :test test)
+ (return nil)))
+ (dolist (elt keylist2 t)
+ (or (member elt keylist1 :test test)
+ (return nil))))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun make-gensym-list (length &optional (x "G"))
+ "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
+using the second (optional, defaulting to `\"G\"`) argument."
+ (let ((g (if (typep x '(integer 0)) x (string x))))
+ (loop repeat length
+ collect (gensym g))))
+ ) ; eval-when
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;;; To propagate return type and allow the compiler to eliminate the IF when
+ ;;; it is known if the argument is function or not.
+ (declaim (inline ensure-function))
+
+ (declaim (ftype (function (t) (values function &optional))
+ ensure-function))
+ (defun ensure-function (function-designator)
+ "Returns the function designated by `function-designator`:
+if `function-designator` is a function, it is returned, otherwise
+it must be a function name and its `fdefinition` is returned."
+ (if (functionp function-designator)
+ function-designator
+ (fdefinition function-designator)))
+ ) ; eval-when
+
+ (defun curry (function &rest arguments)
+ "Returns a function that applies `arguments` and the arguments
+it is called with to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ ;; Using M-V-C we don't need to append the arguments.
+ (multiple-value-call fn (values-list arguments) (values-list more)))))
+
+ (define-compiler-macro curry (function &rest arguments)
+ (let ((curries (make-gensym-list (length arguments) "CURRY"))
+ (fun (gensym "FUN")))
+ `(let ((,fun (ensure-function ,function))
+ ,@(mapcar #'list curries arguments))
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (lambda (&rest more)
+ (apply ,fun ,@curries more)))))
+
+
+ (defun rcurry (function &rest arguments)
+ "Returns a function that applies the arguments it is called
+with and `arguments` to `function`."
+ (declare (optimize (speed 3) (safety 1) (debug 1)))
+ (let ((fn (ensure-function function)))
+ (lambda (&rest more)
+ (declare (dynamic-extent more))
+ (multiple-value-call fn (values-list more) (values-list arguments)))))
+
+
+ (deftype string-designator ()
+ "A string designator type. A string designator is either a string, a symbol,
+or a character."
+ `(or symbol string character))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmacro with-gensyms (names &body forms)
+ "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+ `(let ,(mapcar (lambda (name)
+ (multiple-value-bind (symbol string)
+ (etypecase name
+ (symbol
+ (values name (symbol-name name)))
+ ((cons symbol (cons string-designator null))
+ (values (first name) (string (second name)))))
+ `(,symbol (gensym ,string))))
+ names)
+ ,@forms))
+
+ (defmacro with-unique-names (names &body forms)
+ "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+ (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+ (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+ `(with-gensyms ,names ,@forms))
+ ) ; eval-when
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun extract-function-name (spec)
+ "Useful for macros that want to mimic the functional interface for functions
+like `#'eq` and `'eq`."
+ (if (and (consp spec)
+ (member (first spec) '(quote function)))
+ (second spec)
+ spec))
+ ) ; eval-when
+
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun generate-switch-body (whole object clauses test key &optional default)
+ (with-gensyms (value)
+ (setf test (extract-function-name test))
+ (setf key (extract-function-name key))
+ (when (and (consp default)
+ (member (first default) '(error cerror)))
+ (setf default `(,@default "No keys match in SWITCH. Testing against ~S with ~S."
+ ,value ',test)))
+ `(let ((,value (,key ,object)))
+ (cond ,@(mapcar (lambda (clause)
+ (if (member (first clause) '(t otherwise))
+ (progn
+ (when default
+ (error "Multiple default clauses or illegal use of a default clause in ~S."
+ whole))
+ (setf default `(progn ,@(rest clause)))
+ '(()))
+ (destructuring-bind (key-form &body forms) clause
+ `((,test ,value ,key-form)
+ ,@forms))))
+ clauses)
+ (t ,default))))))
+
+ (defmacro switch (&whole whole (object &key (test 'eql) (key 'identity))
+ &body clauses)
+ "Evaluates first matching clause, returning its values, or evaluates and
+returns the values of `default` if no keys match."
+ (generate-switch-body whole object clauses test key))
+
+ (defmacro eswitch (&whole whole (object &key (test 'eql) (key 'identity))
+ &body clauses)
+ "Like `switch`, but signals an error if no key matches."
+ (generate-switch-body whole object clauses test key '(error)))
+
+ (defmacro cswitch (&whole whole (object &key (test 'eql) (key 'identity))
+ &body clauses)
+ "Like `switch`, but signals a continuable error if no key matches."
+ (generate-switch-body whole object clauses test key '(cerror "Return NIL from CSWITCH.")))
+
+
+ (defun ensure-boolean (x)
+ "Convert `x` into a Boolean value."
+ (and x t))
+
+
+ (defmacro until (expression &body body)
+ "Executes `body` until `expression` is true."
+ `(do ()
+ (,expression)
+ ,@body))
+
+
+ (defmacro while (expression &body body)
+ "Executes `body` while `expression` is true."
+ `(until (not ,expression)
+ ,@body))
+
+
+ (defun tree-member-p (item tree &key (test #'eql))
+ "Returns `t` if `item` is in `tree`, `nil` otherwise."
+ (labels ((rec (tree)
+ (cond ((null tree) nil)
+ ((atom tree) (funcall test item tree))
+ (t (or (rec (car tree))
+ (rec (cdr tree)))))))
+ (rec tree)))
+
+
+ (defmacro once-only (specs &body forms)
+ "Evaluates `forms` with symbols specified in `specs` rebound to temporary
+variables, ensuring that each initform is evaluated only once.
+
+Each of `specs` must either be a symbol naming the variable to be rebound, or of
+the form:
+
+ (symbol initform)
+
+Bare symbols in `specs` are equivalent to
+
+ (symbol symbol)
+
+Example:
+
+ (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
+ (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
+ (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
+ (names-and-forms (mapcar (lambda (spec)
+ (etypecase spec
+ (list
+ (destructuring-bind (name form) spec
+ (cons name form)))
+ (symbol
+ (cons spec spec))))
+ specs)))
+ ;; bind in user-macro
+ `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+ gensyms names-and-forms)
+ ;; bind in final expansion
+ `(let (,,@(mapcar (lambda (g n)
+ ``(,,g ,,(cdr n)))
+ gensyms names-and-forms))
+ ;; bind in user-macro
+ ,(let ,(mapcar (lambda (n g) (list (car n) g))
+ names-and-forms gensyms)
+ ,@forms)))))
+
+
+ (defun transpose (lists)
+ "Analog to matrix transpose for a list of lists given by `lists`."
+ (apply #'mapcar #'list lists))
+
+
+ (defun zip (&rest lists)
+ "Take a tuple of lists and turn them into a list of
+tuples. Equivalent to `unzip`."
+ (transpose lists))
+
+
+ (defun alist-to-hash-table (kv-pairs)
+ "Create a hash table populated with `kv-pairs`."
+ (let ((hashtab (make-hash-table :test #'equal)))
+ (loop
+ :for (i j) :in kv-pairs
+ :do (setf (gethash i hashtab) j)
+ :finally (return hashtab))))
+
+
+ (defun map-tree (function tree)
+ "Map `function` to each of the leave of `tree`."
+ (check-type tree cons)
+ (labels ((rec (tree)
+ (cond
+ ((null tree) nil)
+ ((atom tree) (funcall function tree))
+ ((consp tree)
+ (cons (rec (car tree))
+ (rec (cdr tree)))))))
+ (rec tree)))
+
+
+ (defun weave (&rest lists)
+ "Return a list whose elements alternate between each of the lists
+`lists`. Weaving stops when any of the lists has been exhausted."
+ (apply #'mapcan #'list lists))
+
+
+ (declaim (inline safe-endp))
+ (defun safe-endp (x)
+ (declare (optimize safety))
+ (endp x))
+
+
+ (defun alist-plist (alist)
+ "Returns a property list containing the same keys and values as the
+association list ALIST in the same order."
+ (let (plist)
+ (dolist (pair alist)
+ (push (car pair) plist)
+ (push (cdr pair) plist))
+ (nreverse plist)))
+
+ (defun plist-alist (plist)
+ "Returns an association list containing the same keys and values as the
+property list PLIST in the same order."
+ (let (alist)
+ (do ((tail plist (cddr tail)))
+ ((safe-endp tail) (nreverse alist))
+ (push (cons (car tail) (cadr tail)) alist))))
+
+
+ (defun equivalence-classes (equiv seq)
+ "Partition the sequence `seq` into a list of equivalence classes
+defined by the equivalence relation `equiv`."
+ (let ((classes nil))
+ (labels ((find-equivalence-class (x)
+ (member-if (lambda (class)
+ (funcall equiv x (car class)))
+ classes))
+
+ (add-to-class (x)
+ (let ((class (find-equivalence-class x)))
+ (if class
+ (push x (car class))
+ (push (list x) classes)))))
+ (declare (dynamic-extent (function find-equivalence-class)
+ (function add-to-class))
+ (inline find-equivalence-class
+ add-to-class))
+
+ ;; Partition into equivalence classes.
+ (map nil #'add-to-class seq)
+
+ ;; Return the classes.
+ classes)))
+
+
+ (defun mappend (function &rest lists)
+ "Applies `function` to respective element(s) of each `list`, appending all the
+all the result list to a single list. `function` must return a list."
+ (loop for results in (apply #'mapcar function lists)
+ append results))
+
+
+ (defun map-product (function list &rest more-lists)
+ "Returns a list containing the results of calling `function` with one argument
+from `list`, and one from each of `more-lists` for each combination of arguments.
+In other words, returns the product of `list` and `more-lists` using `function`.
+
+Example:
+
+ (map-product 'list '(1 2) '(3 4) '(5 6))
+ => ((1 3 5) (1 3 6) (1 4 5) (1 4 6)
+ (2 3 5) (2 3 6) (2 4 5) (2 4 6))"
+ (labels ((%map-product (f lists)
+ (let ((more (cdr lists))
+ (one (car lists)))
+ (if (not more)
+ (mapcar f one)
+ (mappend (lambda (x)
+ (%map-product (curry f x) more))
+ one)))))
+ (%map-product (ensure-function function) (cons list more-lists))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(define-constant set-equal curry rcurry switch eswitch cswitch
+ ensure-boolean while until tree-member-p with-gensyms
+ with-unique-names once-only zip alist-to-hash-table map-tree weave
+ alist-plist plist-alist equivalence-classes map-product)))
+
+;;;; END OF quickutils.lisp ;;;;