More links in the docs
author |
Steve Losh <steve@stevelosh.com> |
date |
Fri, 12 Aug 2016 19:57:26 +0000 |
parents |
939570d22350 |
children |
(none) |
;;;; This file was automatically generated by Quickutil.
;;;; See http://quickutil.org for details.
;;;; To regenerate:
;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:MAP-PRODUCT :HASH-TABLE-KEY-EXISTS-P :HASH-TABLE-VALUES :WITH-GENSYMS :SYMB :ENSURE-KEYWORD :ENSURE-LIST) :ensure-package T :package "BEAST.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "BEAST.QUICKUTILS")
(defpackage "BEAST.QUICKUTILS"
(:documentation "Package that contains Quickutil utility functions.")
(:use #:cl))))
(in-package "BEAST.QUICKUTILS")
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
:CURRY :MAPPEND :MAP-PRODUCT
:HASH-TABLE-KEY-EXISTS-P
:MAPHASH-VALUES :HASH-TABLE-VALUES
:STRING-DESIGNATOR :WITH-GENSYMS
:MKSTR :SYMB :ENSURE-KEYWORD
:ENSURE-LIST))))
(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 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))))
(defun hash-table-key-exists-p (hash-table key)
"Does `key` exist in `hash-table`?"
(nth-value 1 (gethash key hash-table)))
(declaim (inline maphash-values))
(defun maphash-values (function table)
"Like `maphash`, but calls `function` with each value in the hash table `table`."
(maphash (lambda (k v)
(declare (ignore k))
(funcall function v))
table))
(defun hash-table-values (table)
"Returns a list containing the values of hash table `table`."
(let ((values nil))
(maphash-values (lambda (v)
(push v values))
table)
values))
(deftype string-designator ()
"A string designator type. A string designator is either a string, a symbol,
or a character."
`(or symbol string character))
(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))
(defun mkstr (&rest args)
"Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string.
Extracted from _On Lisp_, chapter 4."
(with-output-to-string (s)
(dolist (a args) (princ a s))))
(defun symb (&rest args)
"Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol.
Extracted from _On Lisp_, chapter 4.
See also: `symbolicate`"
(values (intern (apply #'mkstr args))))
(defun ensure-keyword (x)
"Ensure that a keyword is returned for the string designator `x`."
(values (intern (string x) :keyword)))
(defun ensure-list (list)
"If `list` is a list, it is returned. Otherwise returns the list designated by `list`."
(if (listp list)
list
(list list)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(map-product hash-table-key-exists-p hash-table-values with-gensyms
with-unique-names symb ensure-keyword ensure-list)))
;;;; END OF quickutils.lisp ;;;;