| author |
Steve Losh <steve@stevelosh.com> |
| date |
Sat, 20 May 2017 11:24:54 +0000 |
| parents |
fd5861c11c5f |
| children |
(none) |
;;;; This file was automatically generated by Quickutil.
;;;; See http://quickutil.org for details.
;;;; To regenerate:
;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-HASH-TABLE :CURRY :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-LIST :EXTREMUM :FLATTEN-ONCE :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAP-PRODUCT :MAP-TREE :MKSTR :ONCE-ONLY :PARTITION-IF :RCURRY :SET-EQUAL :SHUFFLE :SUBDIVIDE :SYMB :WITH-GENSYMS :WITH-OUTPUT-TO-FILE :WRITE-STRING-INTO-FILE :YES-NO) :ensure-package T :package "SCULLY.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "SCULLY.QUICKUTILS")
(defpackage "SCULLY.QUICKUTILS"
(:documentation "Package that contains Quickutil utility functions.")
(:use #:cl))))
(in-package "SCULLY.QUICKUTILS")
(when (boundp '*utilities*)
(setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
:COMPOSE :COPY-HASH-TABLE :CURRY
:ENSURE-BOOLEAN :ENSURE-GETHASH
:ENSURE-LIST :EXTREMUM :FLATTEN-ONCE
:HASH-TABLE-ALIST :MAPHASH-KEYS
:HASH-TABLE-KEYS :MAPHASH-VALUES
:HASH-TABLE-VALUES :MAPPEND
:MAP-PRODUCT :MAP-TREE :MKSTR
:ONCE-ONLY :PARTITION-IF :RCURRY
:SET-EQUAL :SAFE-ENDP :CIRCULAR-LIST
:PROPER-LIST-LENGTH/LAST-CAR :SHUFFLE
:SUBDIVIDE :SYMB :STRING-DESIGNATOR
:WITH-GENSYMS :WITH-OPEN-FILE*
:WITH-OUTPUT-TO-FILE
:WRITE-STRING-INTO-FILE :YES-NO))))
(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 compose (function &rest more-functions)
"Returns a function composed of `function` and `more-functions` that applies its ;
arguments to to each in turn, starting from the rightmost of `more-functions`,
and then calling the next one with the primary value of the last."
(declare (optimize (speed 3) (safety 1) (debug 1)))
(reduce (lambda (f g)
(let ((f (ensure-function f))
(g (ensure-function g)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
(funcall f (apply g arguments)))))
more-functions
:initial-value function))
(define-compiler-macro compose (function &rest more-functions)
(labels ((compose-1 (funs)
(if (cdr funs)
`(funcall ,(car funs) ,(compose-1 (cdr funs)))
`(apply ,(car funs) arguments))))
(let* ((args (cons function more-functions))
(funs (make-gensym-list (length args) "COMPOSE")))
`(let ,(loop for f in funs for arg in args
collect `(,f (ensure-function ,arg)))
(declare (optimize (speed 3) (safety 1) (debug 1)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
,(compose-1 funs))))))
(defun copy-hash-table (table &key key test size
rehash-size rehash-threshold)
"Returns a copy of hash table `table`, with the same keys and values
as the `table`. The copy has the same properties as the original, unless
overridden by the keyword arguments.
Before each of the original values is set into the new hash-table, `key`
is invoked on the value. As `key` defaults to `cl:identity`, a shallow
copy is returned by default."
(setf key (or key 'identity))
(setf test (or test (hash-table-test table)))
(setf size (or size (hash-table-size table)))
(setf rehash-size (or rehash-size (hash-table-rehash-size table)))
(setf rehash-threshold (or rehash-threshold (hash-table-rehash-threshold table)))
(let ((copy (make-hash-table :test test :size size
:rehash-size rehash-size
:rehash-threshold rehash-threshold)))
(maphash (lambda (k v)
(setf (gethash k copy) (funcall key v)))
table)
copy))
(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 ensure-boolean (x)
"Convert `x` into a Boolean value."
(and x t))
(defmacro ensure-gethash (key hash-table &optional default)
"Like `gethash`, but if `key` is not found in the `hash-table` saves the `default`
under key before returning it. Secondary return value is true if key was
already in the table."
`(multiple-value-bind (value ok) (gethash ,key ,hash-table)
(if ok
(values value ok)
(values (setf (gethash ,key ,hash-table) ,default) nil))))
(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)))
(defun extremum (sequence predicate &key key (start 0) end)
"Returns the element of `sequence` that would appear first if the subsequence
bounded by `start` and `end` was sorted using `predicate` and `key`.
`extremum` determines the relationship between two elements of `sequence` by using
the `predicate` function. `predicate` should return true if and only if the first
argument is strictly less than the second one (in some appropriate sense). Two
arguments `x` and `y` are considered to be equal if `(funcall predicate x y)`
and `(funcall predicate y x)` are both false.
The arguments to the `predicate` function are computed from elements of `sequence`
using the `key` function, if supplied. If `key` is not supplied or is `nil`, the
sequence element itself is used.
If `sequence` is empty, `nil` is returned."
(let* ((pred-fun (ensure-function predicate))
(key-fun (unless (or (not key) (eq key 'identity) (eq key #'identity))
(ensure-function key)))
(real-end (or end (length sequence))))
(cond ((> real-end start)
(if key-fun
(flet ((reduce-keys (a b)
(if (funcall pred-fun
(funcall key-fun a)
(funcall key-fun b))
a
b)))
(declare (dynamic-extent #'reduce-keys))
(reduce #'reduce-keys sequence :start start :end real-end))
(flet ((reduce-elts (a b)
(if (funcall pred-fun a b)
a
b)))
(declare (dynamic-extent #'reduce-elts))
(reduce #'reduce-elts sequence :start start :end real-end))))
((= real-end start)
nil)
(t
(error "Invalid bounding indexes for sequence of length ~S: ~S ~S, ~S ~S"
(length sequence)
:start start
:end end)))))
(defun flatten-once (list)
"Flatten `list` once."
(loop :for x :in list
:if (listp x)
:append x
:else
:collect x))
(defun hash-table-alist (table)
"Returns an association list containing the keys and values of hash table
`table`."
(let ((alist nil))
(maphash (lambda (k v)
(push (cons k v) alist))
table)
alist))
(declaim (inline maphash-keys))
(defun maphash-keys (function table)
"Like `maphash`, but calls `function` with each key in the hash table `table`."
(maphash (lambda (k v)
(declare (ignore v))
(funcall function k))
table))
(defun hash-table-keys (table)
"Returns a list containing the keys of hash table `table`."
(let ((keys nil))
(maphash-keys (lambda (k)
(push k keys))
table)
keys))
(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))
(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 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 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))))
(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 partition-if (f seq)
"Given a predicate F, partition SEQ into two sublists, the first
of which has elements that satisfy F, the second which do not."
(let ((yes nil)
(no nil))
(map nil
#'(lambda (x)
(if (funcall f x)
(push x yes)
(push x no)))
seq)
(values yes no)))
(defun partition-if-not (f seq)
"Partition SEQ into two sublists, the first whose elements do not
satisfy the predicate F, and the second whose elements do."
(multiple-value-bind (yes no)
(partition-if f seq)
(values no yes)))
(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)))))
(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))))))
(declaim (inline safe-endp))
(defun safe-endp (x)
(declare (optimize safety))
(endp x))
(defun circular-list (&rest elements)
"Creates a circular list of ELEMENTS."
(let ((cycle (copy-list elements)))
(nconc cycle cycle)))
(defun circular-list-p (object)
"Returns true if OBJECT is a circular list, NIL otherwise."
(and (listp object)
(do ((fast object (cddr fast))
(slow (cons (car object) (cdr object)) (cdr slow)))
(nil)
(unless (and (consp fast) (listp (cdr fast)))
(return nil))
(when (eq fast slow)
(return t)))))
(defun make-circular-list (length &key initial-element)
"Creates a circular list of LENGTH with the given INITIAL-ELEMENT."
(let ((cycle (make-list length :initial-element initial-element)))
(nconc cycle cycle)))
(deftype circular-list ()
"Type designator for circular lists. Implemented as a SATISFIES type, so not
recommended for performance intensive use. Main usefullness as the
expected-type designator of a TYPE-ERROR."
`(satisfies circular-list-p))
(defun circular-list-error (list)
(error 'type-error
:datum list
:expected-type '(and list (not circular-list))))
(macrolet ((def (name lambda-list doc step declare ret1 ret2)
(assert (member 'list lambda-list))
`(defun ,name ,lambda-list
,doc
(do ((last list fast)
(fast list (cddr fast))
(slow (cons (car list) (cdr list)) (cdr slow))
,@(when step (list step)))
(nil)
(declare (dynamic-extent slow) ,@(when declare (list declare))
(ignorable last))
(when (safe-endp fast)
(return ,ret1))
(when (safe-endp (cdr fast))
(return ,ret2))
(when (eq fast slow)
(circular-list-error list))))))
(def proper-list-length (list)
"Returns length of LIST, signalling an error if it is not a proper list."
(n 1 (+ n 2))
;; KLUDGE: Most implementations don't actually support lists with bignum
;; elements -- and this is WAY faster on most implementations then declaring
;; N to be an UNSIGNED-BYTE.
(fixnum n)
(1- n)
n)
(def lastcar (list)
"Returns the last element of LIST. Signals a type-error if LIST is not a
proper list."
nil
nil
(cadr last)
(car fast))
(def (setf lastcar) (object list)
"Sets the last element of LIST. Signals a type-error if LIST is not a proper
list."
nil
nil
(setf (cadr last) object)
(setf (car fast) object)))
(defun shuffle (sequence &key (start 0) end)
"Returns a random permutation of `sequence` bounded by `start` and `end`.
Original sequece may be destructively modified, and share storage with
the original one. Signals an error if `sequence` is not a proper
sequence."
(declare (type fixnum start)
(type (or fixnum null) end))
(etypecase sequence
(list
(let* ((end (or end (proper-list-length sequence)))
(n (- end start)))
(do ((tail (nthcdr start sequence) (cdr tail)))
((zerop n))
(rotatef (car tail) (car (nthcdr (random n) tail)))
(decf n))))
(vector
(let ((end (or end (length sequence))))
(loop for i from start below end
do (rotatef (aref sequence i)
(aref sequence (+ i (random (- end i))))))))
(sequence
(let ((end (or end (length sequence))))
(loop for i from (- end 1) downto start
do (rotatef (elt sequence i)
(elt sequence (+ i (random (- end i)))))))))
sequence)
(defun subdivide (sequence chunk-size)
"Split `sequence` into subsequences of size `chunk-size`."
(check-type sequence sequence)
(check-type chunk-size (integer 1))
(etypecase sequence
;; Since lists have O(N) access time, we iterate through manually,
;; collecting each chunk as we pass through it. Using SUBSEQ would
;; be O(N^2).
(list (loop :while sequence
:collect
(loop :repeat chunk-size
:while sequence
:collect (pop sequence))))
;; For other sequences like strings or arrays, we can simply chunk
;; by repeated SUBSEQs.
(sequence (loop :with len := (length sequence)
:for i :below len :by chunk-size
:collect (subseq sequence i (min len (+ chunk-size i)))))))
(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))))
(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))
(defmacro with-open-file* ((stream filespec &key direction element-type
if-exists if-does-not-exist external-format)
&body body)
"Just like `with-open-file`, but `nil` values in the keyword arguments mean to use
the default value specified for `open`."
(once-only (direction element-type if-exists if-does-not-exist external-format)
`(with-open-stream
(,stream (apply #'open ,filespec
(append
(when ,direction
(list :direction ,direction))
(when ,element-type
(list :element-type ,element-type))
(when ,if-exists
(list :if-exists ,if-exists))
(when ,if-does-not-exist
(list :if-does-not-exist ,if-does-not-exist))
(when ,external-format
(list :external-format ,external-format)))))
,@body)))
(defmacro with-output-to-file ((stream-name file-name &rest args
&key (direction nil direction-p)
&allow-other-keys)
&body body)
"Evaluate `body` with `stream-name` to an output stream on the file
`file-name`. `args` is sent as is to the call to `open` except `external-format`,
which is only sent to `with-open-file` when it's not `nil`."
(declare (ignore direction))
(when direction-p
(error "Can't specifiy :DIRECTION for WITH-OUTPUT-TO-FILE."))
`(with-open-file* (,stream-name ,file-name :direction :output ,@args)
,@body))
(defun write-string-into-file (string pathname &key (if-exists :error)
if-does-not-exist
external-format)
"Write `string` to `pathname`.
The `external-format` parameter will be passed directly to `with-open-file`
unless it's `nil`, which means the system default."
(with-output-to-file (file-stream pathname :if-exists if-exists
:if-does-not-exist if-does-not-exist
:external-format external-format)
(write-sequence string file-stream)))
(defun yes (&rest ignored)
(declare (ignore ignored))
t)
(defun no (&rest ignored)
(declare (ignore ignored))
nil)
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(compose copy-hash-table curry ensure-boolean ensure-gethash
ensure-list extremum flatten-once hash-table-alist hash-table-keys
hash-table-values map-product map-tree mkstr once-only partition-if
partition-if-not rcurry set-equal shuffle subdivide symb
with-gensyms with-unique-names with-output-to-file
write-string-into-file yes no)))
;;;; END OF quickutils.lisp ;;;;