Commit 88a54e6c authored by Nikodemus Siivola's avatar Nikodemus Siivola

initial version

parents
Alexandria is public domain software:
Authors dedicate this work to public domain, for the benefit of the
public at large and to the detriment of the authors' heirs and
successors. Authors intends this dedication to be an overt act of
relinquishment in perpetuity of all present and future rights under
copyright law, whether vested or contingent, in the work. Authors
understands that such relinquishment of all rights includes the
relinquishment of all rights to enforce (by lawsuit or otherwise)
those copyrights in the work.
Authors recognize that, once placed in the public domain, the work
may be freely reproduced, distributed, transmitted, used, modified,
built upon, or otherwise exploited by anyone for any purpose,
commercial or non-commercial, and in any way, including by methods
that have not yet been invented or conceived.
In those legislations where public domain dedications are not
recognized or possible, Alexandria is distributed under the following
terms and conditions:
Permission is hereby granted, free of charge, to any person
obtaining a copy of this software and associated documentation files
(the "Software"), to deal in the Software without restriction,
including without limitation the rights to use, copy, modify, merge,
publish, distribute, sublicense, and/or sell copies of the Software,
and to permit persons to whom the Software is furnished to do so,
subject to the following conditions:
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
(defsystem :alexandria
:version "0.0.0"
:licence "Public Domain / 0-clause MIT"
:components
((:static-file "LICENCE")
(:static-file "tests.lisp")
(:file "package")
(:file "hash-tables" :depends-on ("package"))
(:file "functions" :depends-on ("package"))
(:file "lists" :depends-on ("package"))
(:file "sequences" :depends-on ("package"))
(:file "macros" :depends-on ("package"))
(:file "symbols" :depends-on ("package"))
(:file "arrays" :depends-on ("package"))
(:file "numbers" :depends-on ("package" "sequences"))))
(in-package :alexandria)
(deftype array-index (&optional (length array-dimension-limit))
"Type designator for an array of LENGTH: an integer between 0 (inclusive) and
LENGTH (exclusive). LENGTH defaults to ARRAY-DIMENSION-LIMIT."
`(integer 0 (,length)))
(defun copy-array (array &key
(element-type (array-element-type array))
(fill-pointer (and (array-has-fill-pointer-p array)
(fill-pointer array)))
(adjustable (adjustable-array-p array)))
"Returns an undisplaced copy of ARRAY, with same fill-pointer
and adjustability (if any) as the original, unless overridden by
the keyword arguments."
(let ((dims (array-dimensions array)))
;; Dictionary entry for ADJUST-ARRAY requires adjusting a
;; displaced array to a non-displaced one to make a copy.
(adjust-array
(make-array dims
:element-type element-type :fill-pointer fill-pointer
:adjustable adjustable :displaced-to array)
dims)))
(in-package :alexandria)
(defun disjoin (predicate &rest more-predicates)
"Returns a function that applies each of PREDICATE and MORE-PREDICATE
functions in turn to its arguments, returning the primary value of the first
predicate that returns true, without calling the remaining predicates.
If none of the predicates returns true, NIL is returned."
(declare (optimize (speed 3) (safety 1) (debug 1)))
(lambda (&rest arguments)
(or (apply predicate arguments)
(some (lambda (p)
(apply p arguments))
more-predicates))))
(defun conjoin (predicate &rest more-predicates)
"Returns a function that applies each of PREDICATE and MORE-PREDICATE
functions in turn to its arguments, returning NIL if any of the predicates
returns false, without calling the remaining predicated. If none of the
predicates returns false, returns the primary value of the last predicate."
(lambda (&rest arguments)
(and (apply predicate arguments)
(do ((tail (cdr more-predicates) (cdr tail))
(head (car more-predicates) (car tail)))
((not tail)
(apply head arguments))
(unless (apply head arguments)
(return nil))))))
(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)
(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 ,(mapcar #'list funs args)
(declare (optimize (speed 3) (safety 1) (debug 1)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
,(compose-1 funs))))))
(defun multiple-value-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 all the return values of
the last."
(declare (optimize (speed 3) (safety 1) (debug 1)))
(reduce (lambda (f g)
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
(multiple-value-call f (apply g arguments))))
more-functions
:initial-value function))
(define-compiler-macro multiple-value-compose (function &rest more-functions)
(labels ((compose-1 (funs)
(if (cdr funs)
`(multiple-value-call ,(car funs) ,(compose-1 (cdr funs)))
`(apply ,(car funs) arguments))))
(let* ((args (cons function more-functions))
(funs (make-gensym-list (length args) "MV-COMPOSE")))
`(let ,(mapcar #'list funs args)
(declare (optimize (speed 3) (safety 1) (debug 1)))
(lambda (&rest arguments)
(declare (dynamic-extent arguments))
,(compose-1 funs))))))
(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)))
(lambda (&rest more)
(declare (dynamic-extent more))
(multiple-value-call function (values-list arguments) (values-list more))))
(define-compiler-macro curry (function &rest arguments)
(let ((curries (make-gensym-list (length arguments) "CURRY")))
`(let ,(mapcar #'list curries arguments)
(declare (optimize (speed 3) (safety 1) (debug 1)))
(lambda (&rest more)
(declare (dynamic-extent more))
(apply ,function ,@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)))
(lambda (&rest more)
(declare (dynamic-extent more))
(multiple-value-call function (values-list more) (values-list arguments))))
(in-package :alexandria)
(defun copy-hash-table (table &key
(test (hash-table-test table))
(size (hash-table-size table))
(rehash-size (hash-table-size table))
(rehash-threshold (hash-table-rehash-threshold table)))
"Returns a shallow 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."
(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) v))
table)
copy))
(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))
(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-keys (table)
"Returns a list containing the keys of hash table TABLE."
(let ((keys nil))
(maphash-keys (lambda (k)
(push k keys))
table)
keys))
(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 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))
(defun hash-table-plist (table)
"Returns a property list containing the keys and values of hash table
TABLE."
(let ((plist nil))
(maphash (lambda (k v)
(setf plist (list* k v plist)))
table)
plist))
(defun alist-hash-table (alist &rest hash-table-initargs)
"Returns a hash table containing the keys and values of the association list
ALIST. Hash table is initialized using the HASH-TABLE-INITARGS."
(let ((table (apply #'make-hash-table hash-table-initargs)))
(dolist (cons alist)
(setf (gethash (car cons) table) (cdr cons)))
table))
(defun plist-hash-table (plist &rest hash-table-initargs)
"Returns a hash table containing the keys and values of the property list
PLIST. Hash table is initialized using the HASH-TABLE-INITARGS."
(let ((table (apply #'make-hash-table hash-table-initargs)))
(do ((tail plist (cddr tail)))
((not tail))
(setf (gethash (car tail) table) (cadr tail)))
table))
(in-package :alexandria)
(define-modify-macro appendf (&rest lists) append
"Modify-macro for APPEND. Appends LISTS to the place designated by the first
argument.")
(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 circular-tree-p (object)
"Returns true if OBJECT is a circular tree, NIL otherwise."
(labels ((circularp (object seen)
(and (consp object)
(do ((fast (cons (car object) (cdr object)) (cddr fast))
(slow object (cdr slow)))
((or (not (consp fast)) (not (consp (cdr slow))))
(do ((tail object (cdr tail)))
((not (consp tail))
nil)
(let ((elt (car tail)))
(circularp elt (cons object seen)))))
(when (or (eq fast slow) (member slow seen))
(return-from circular-tree-p t))))))
(circularp object nil)))
(defun proper-list-p (object)
"Returns true if OBJECT is a proper list."
(cond ((not object)
t)
((consp object)
(do ((fast object (cddr fast))
(slow (cons (car object) (cdr object)) (cdr slow)))
(nil)
(unless (and (listp fast) (consp (cdr fast)))
(return (and (listp fast) (not (cdr fast)))))
(when (eq fast slow)
(return nil))))
(t
nil)))
(deftype proper-list ()
`(satisfies proper-list-p))
(defun lastcar (list)
"Returns the last element of LIST. Signals a type-error if LIST is not a
proper list."
(do ((last list fast)
(fast list (cddr fast))
(slow (cons (car list) (cdr list)) (cdr slow)))
(nil)
(when (endp fast)
(return (cadr last)))
(when (endp (cdr fast))
(return (car fast)))
(when (eq fast slow)
(error 'type-error
:datum list
:expected-type '(and list (not circular-list))))))
(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 ()
"A circular list."
`(satisfies circular-list-p))
(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 remove-keys (keys plist)
"Returns a fresh propery-list with same keys and values as PLIST, except
that keys in the list designated by KEYS and values corresponding to them are
removed."
(do ((new nil)
(tail plist (cddr tail)))
((endp tail)
(nreverse new))
(let ((key (car tail)))
(unless (member key keys)
(push key new)
(push (cadr tail) new)))))
(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 set-equal (list1 list2 &key (test #'eql) (key #'identity))
"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* ((table1 (make-hash-table :test test))
(table2 (make-hash-table :test test))
(keylist1 (mapcar (lambda (elt)
(let ((elt-key (funcall key elt)))
(setf (gethash elt-key table1) t)
elt-key))
list1)))
(dolist (elt list2)
(let ((elt-key (funcall key elt)))
(unless (gethash elt-key table1)
(return-from set-equal nil))
(setf (gethash elt-key table2) t)))
(dolist (elt-key keylist1)
(unless (gethash elt-key table2)
(return-from set-equal nil))))
t)
(in-package :alexandria)
(defmacro with-unique-names (names &body forms)
"Binds each variable named by NAMES to a unique symbol."
`(let ,(mapcar (lambda (name)
`(,name (gensym ,(symbol-name name))))
names)
,@forms))
(defmacro once-only (names &body forms)
"Evaluates FORMS with NAMES rebound to temporary variables,
ensuring that each is evaluated only once.
Example:
(defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
(let ((y 0)) (cons1 (incf y))) => (1 . 1)"
(let ((gensyms (make-gensym-list (length names) "ONCE-ONLY")))
;; bind in user-macro
`(let ,(mapcar (lambda (g n) (list g `(gensym ,(string n))))
gensyms names)
;; bind in final expansion
`(let (,,@(mapcar (lambda (g n) ``(,,g ,,n)) gensyms names))
;; bind in user-macro
,(let ,(mapcar #'list names gensyms)
,@forms)))))
(defun parse-body (body &key documentation)
"Parses BODY into documentation string, declarations, and remaining forms.
Documentation strings are recognized only if DOCUMENTATION is true. Returns
three values: list of remaining forms, list of declarations, and documentation
string if any."
(let ((doc nil)
(decls nil)
(current nil))
(tagbody
:declarations
(setf current (car body))
(when (and documentation (stringp current) (not doc) (cdr body))
(setf doc (pop body))
(go :declarations))
(when (starts-with 'declare current)
(push (pop body) decls)
(go :declarations)))
(values body (nreverse decls) doc)))
(in-package :alexandria)
(declaim (inline clamp))
(defun clamp (number min max)
"Clamps the NUMBER into [MIN, MAX] range. Returns MIN if NUMBER lesser then
MIN and MAX if NUMBER is greater then MAX, otherwise returns NUMBER."
(if (< number min)
min
(if (> number max)
max
number)))
(defun gaussian-random (&optional min max)
"Returns two gaussian random double floats as the primary and secondary value,
optionally constrained by MIN and MAX. Gaussian random numbers form a standard
normal distribution around 0.0d0."
(labels ((gauss ()
(loop
for x1 = (- (random 2.0d0) 1.0d0)
for x2 = (- (random 2.0d0) 1.0d0)
for w = (+ (expt x1 2) (expt x2 2))
when (< w 1.0d0)
do (let ((v (sqrt (/ (* -2.0d0 (log w)) w))))
(return (values (* x1 v) (* x2 v))))))
(guard (x min max)
(unless (<= min x max)
(tagbody
:retry
(multiple-value-bind (x1 x2) (gauss)
(when (<= min x1 max)
(setf x x1)
(go :done))
(when (<= min x2 max)
(setf x x2)
(go :done))
(go :retry))
:done))
x))
(multiple-value-bind (g1 g2) (gauss)
(values (guard g1 (or min g1) (or max g1))
(guard g2 (or min g2) (or max g2))))))
(declaim (inline iota))
(defun iota (n &key (start 0) (step 1))
"Return a list of n numbers, starting from START (with numeric contagion
from STEP applied), each consequtive number being the sum of the previous one
and STEP. START defaults to 0 and STEP to 0.
Examples:
(iota 4) => (0 1 2 3 4)
(iota 3 :start 1 :step 1.0) => (1.0 2.0 3.0)
(iota 3 :start -1 :step -1/2) => (-1 -3/2 -2)
"
(declare (type (integer 0) n) (number start step))
(loop repeat n
;; KLUDGE: get numeric contagion right for the first element too
for i = (+ start (- step step)) then (+ i step)
collect i))
(declaim (inline lerp))
(defun lerp (v a b)
"Returns the result of linear interpolation between A and B, using the
interpolation coefficient V."
(+ a (* v (- b a))))
(declaim (inline mean))
(defun mean (sample)
"Returns the mean of SAMPLE. SAMPLE must be a sequence of numbers."
(/ (reduce #'+ sample) (length sample)))
(declaim (inline median))
(defun median (sample)
"Returns median of SAMPLE. SAMPLE must be a sequence of real numbers."
(let* ((vector (sort (copy-sequence 'vector sample) #'<))
(length (length vector))
(middle (truncate length 2)))
(if (oddp length)
(aref vector middle)
(/ (+ (aref vector middle) (aref vector (1+ middle))) 2))))
(declaim (inline variance))
(defun variance (sample &key biased)
"Returns the variance of SAMPLE, unbiased if BIASED is false (the
default.) SAMPLE must be a sequence of numbers."
(declare (inline mean))
(let ((mean (mean sample)))
(/ (reduce (lambda (a b)
(+ a (expt (- b mean) 2)))
sample
:initial-value 0)
(- (length sample) (if biased 0 1)))))
(declaim (inline standard-deviation))
(defun standard-deviation (sample &key biased)
"Standard deviation of SAMPLE, unbiased if BIASED is false (the default.)
SAMPLE must be a sequence of numbers."
(declare (inline variance))
(sqrt (variance sample :biased biased)))
(define-modify-macro maxf (&rest numbers) max
"Modify-macro for MAX. Sets place designated by the first argument to the
maximum of its original value and NUMBERS.")
(define-modify-macro minf (&rest numbers) min
"Modify-macro for MIN. Sets place designated by the first argument to the
minimum of its original value and NUMBERS.")
(defpackage :alexandria.0.dev
(:nicknames :alexandria)
(:use :cl)
(:export
;; Hash tables
#:copy-hash-table
#:hash-table-keys
#:hash-table-values
#:hash-table-plist
#:hash-table-alist
#:alist-hash-table
#:plist-hash-table
#:maphash-keys
#:maphash-values
;; Functions
#:conjoin
#:disjoin
#:curry
#:rcurry
#:compose
#:multiple-value-compose
;; Lists
#:appendf
#:circular-list
#:circular-list-p
#:circular-tree-p
#:ensure-list
#:lastcar
#:make-circular-list
#:proper-list-p
#:proper-list
#:mappend
#:remove-keys
#:set-equal
;; Numbers
#:clamp
#:gaussian-random
#:iota
#:lerp
#:maxf
#:mean
#:median
#:minf
#:variance
#:standard-deviation
;; Arrays
#:array-index
#:copy-array
;; Sequences
#:emptyp
#:copy-sequence
#:first-elt
#:last-elt
#:starts-with
#:ends-with
#:removef
#:deletef
#:proper-sequence
#:random-elt
#:rotate-left
#:rotate-right
#:sequence-of-length-p
#:suffle
;; Macros
#:with-unique-names
#:once-only
#:parse-body
;; Symbols
#:ensure-symbol
#:format-symbol
#:make-keyword
#:make-gensym-list
;; Types
#:of-type
#:type=
))
(in-package :alexandria)
(defun rotate-left (sequence &optional (n 1))
"Rotates the SEQUENCE to left by N, by moving N elements from the end of the
sequence to the front. Resulting sequence may share structure with the
original one. N defaults to 1. Sequence must be a proper sequence. N can be
creater then the length of sequence."
(if (listp sequence)
(let ((m (mod n (list-length sequence))))
(if (null (cdr sequence))
sequence
(let* ((tail (last sequence (+ m 1)))
(last (cdr tail)))
(setf (cdr tail) nil)
(nconc last sequence))))
(let* ((len (length sequence))
(m (mod n len))
(tail (subseq sequence (- len m))))
(replace sequence sequence :start1 m :start2 0)
(replace sequence tail)
sequence)))