--- a/.lispwords Fri Apr 09 19:48:53 2021 -0402
+++ b/.lispwords Fri Apr 09 22:54:39 2021 -0400
@@ -1,2 +1,3 @@
(1 spit)
(1 recursively)
+(1 do-file)
--- a/DOCUMENTATION.markdown Fri Apr 09 19:48:53 2021 -0402
+++ b/DOCUMENTATION.markdown Fri Apr 09 22:54:39 2021 -0400
@@ -345,6 +345,44 @@
Thread the given forms, with `_` as a placeholder.
+### `DO-FILE` (macro)
+
+ (DO-FILE (SYMBOL PATH &REST OPEN-OPTIONS &KEY (READER '#'READ-LINE) &ALLOW-OTHER-KEYS)
+ &BODY
+ BODY)
+
+Iterate over the contents of `file` using `reader`.
+
+ During iteration, `symbol` will be set to successive values read from the
+ file by `reader`.
+
+ `reader` can be any function that conforms to the usual reading interface,
+ i.e. anything that can handle `(read-foo stream eof-error-p eof-value)`.
+
+ Any keyword arguments other than `:reader` will be passed along to `open`.
+ If `nil` is used for one of the `:if-…` options to `open` and this results
+ in `open` returning `nil`, no iteration will take place.
+
+ An implicit block named `nil` surrounds the iteration, so `return` can be
+ used to terminate early.
+
+ Returns `nil` by default.
+
+ Examples:
+
+ (do-file (line "foo.txt")
+ (print line))
+
+ (do-file (form "foo.lisp" :reader #'read :external-format :EBCDIC-US)
+ (when (eq form :stop)
+ (return :stopped-early))
+ (print form))
+
+ (do-file (line "does-not-exist.txt" :if-does-not-exist nil)
+ (this-will-not-be-executed))
+
+
+
### `DO-IRANGE` (macro)
(DO-IRANGE RANGES
@@ -1464,17 +1502,57 @@
Return a fresh list of the range `[1, to]`.
-### `N..` (function)
-
- (N.. FROM BELOW)
-
-Return a fresh list of the range `[from, below)`.
-
-### `N...` (function)
-
- (N... FROM TO)
-
-Return a fresh list of the range `[from, to]`.
+### `ASSOCAR` (function)
+
+ (ASSOCAR ITEM ALIST &REST ARGS)
+
+Return the `car` of `(apply #'assoc item alist args)`.
+
+### `ASSOCDR` (function)
+
+ (ASSOCDR ITEM ALIST &REST ARGS)
+
+Return the `cdr` of `(apply #'assoc item alist args)`.
+
+### `IRANGE` (function)
+
+ (IRANGE START END &KEY (STEP 1))
+
+Return a fresh list of the range `[start, end]` by `step`.
+
+ `end` can be smaller than `start`, in which case the numbers will be stepped
+ down instead of up.
+
+ `step` must always be a positive value, regardless of the direction of the
+ range.
+
+
+
+### `RANGE` (function)
+
+ (RANGE START END &KEY (STEP 1))
+
+Return a fresh list of the range `[start, end)` by `step`.
+
+ `end` can be smaller than `start`, in which case the numbers will be stepped
+ down instead of up.
+
+ `step` must always be a positive value, regardless of the direction of the
+ range.
+
+
+
+### `RASSOCAR` (function)
+
+ (RASSOCAR ITEM ALIST &REST ARGS)
+
+Return the `car` of `(apply #'rassoc item alist args)`.
+
+### `RASSOCDR` (function)
+
+ (RASSOCDR ITEM ALIST &REST ARGS)
+
+Return the `cdr` of `(apply #'rassoc item alist args)`.
### `SOMELIST` (function)
@@ -1896,6 +1974,10 @@
Return a random boolean with `chance` probability of `t`.
+## Package `LOSH.RING-BUFFERS`
+
+Simple ring buffer implementation.
+
## Package `LOSH.SEQUENCES`
Utilities for operating on sequences.
@@ -2014,7 +2096,7 @@
(enumerate '(a b c) :start 1)
; => ((1 . A) (2 . B) (3 . C))
- (enumerate '(a b c) :key #'ensure-keyword)
+ (enumerate '(a b c) :key #'alexandria:make-keyword)
; => ((0 . :A) (1 . :B) (2 . :C))
@@ -2333,6 +2415,7 @@
* `stream`: output will be returned as a character stream.
* `string`: all output will be gathered up and returned as a single string.
* `list`: all output will be gathered up and returned as a list of lines.
+ * `vector`: all output will be gathered up and returned as a vector of octets.
If `wait` is `nil`, the only acceptable values for `result-type` are `null`
and `stream`.
--- a/Makefile Fri Apr 09 19:48:53 2021 -0402
+++ b/Makefile Fri Apr 09 22:54:39 2021 -0400
@@ -2,12 +2,6 @@
heading_printer = $(shell which heading || echo 'true')
sourcefiles = $(shell ffind --full-path --literal .lisp)
-# Vendor ----------------------------------------------------------------------
-vendor: vendor/quickutils.lisp
-vendor/quickutils.lisp: vendor/make-quickutils.lisp
- cd vendor && ros run -L sbcl --load make-quickutils.lisp --eval '(quit)'
-
-
# Documentation ---------------------------------------------------------------
DOCUMENTATION.markdown: $(sourcefiles)
sbcl --noinform --load make-docs.lisp --eval '(quit)'
--- a/losh.asd Fri Apr 09 19:48:53 2021 -0402
+++ b/losh.asd Fri Apr 09 22:54:39 2021 -0400
@@ -9,37 +9,39 @@
:in-order-to ((asdf:test-op (asdf:test-op :losh/test)))
- :depends-on (:iterate
+ :depends-on (:alexandria
+ :iterate
:cl-ppcre
:external-program
:flexi-streams
#+sbcl :sb-sprof)
- :serial t
:components
- ((:module "vendor"
- :serial t
- :components ((:file "quickutils")))
- (:file "package")
- (:module "src"
+ ((:module "src"
:components (
+ ;; -1 --------------------------------------------------------
+ (:file "package")
+ (:file "base" :depends-on ("package"))
;; 0 ---------------------------------------------------------
- (:file "chili-dogs")
- (:file "clos")
- (:file "eldritch-horrors")
- (:file "functions")
- (:file "hash-sets")
- (:file "io")
- (:file "lists")
- (:file "mutation")
- (:file "shell")
+ (:file "chili-dogs" :depends-on ("base"))
+ (:file "clos" :depends-on ("base"))
+ (:file "eldritch-horrors" :depends-on ("base"))
+ (:file "functions" :depends-on ("base"))
+ (:file "hash-sets" :depends-on ("base"))
+ (:file "io" :depends-on ("base"))
+ (:file "lists" :depends-on ("base"))
+ (:file "mutation" :depends-on ("base"))
+ (:file "shell" :depends-on ("base"))
;; 1 ---------------------------------------------------------
(:file "arrays" :depends-on ("chili-dogs"))
(:file "bits" :depends-on ("chili-dogs"))
(:file "queues" :depends-on ("chili-dogs"))
(:file "priority-queues" :depends-on ("mutation"))
+ (:file "ring-buffers" :depends-on ("chili-dogs"
+ "eldritch-horrors"
+ "mutation"))
;; 2 ---------------------------------------------------------
(:file "control-flow" :depends-on ("queues"))
@@ -69,6 +71,7 @@
(:file "gnuplot" :depends-on ("control-flow"
"iterate"
"debugging"
+ "lists"
"sequences"))
))))
@@ -89,7 +92,8 @@
(:file "arrays")
(:file "lists")
(:file "sequences")
- (:file "control-flow"))))
+ (:file "control-flow")
+ (:file "ring-buffers"))))
:perform (asdf:test-op (op system)
(funcall (read-from-string "losh.test:run-tests"))))
--- a/package.lisp Fri Apr 09 19:48:53 2021 -0402
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,468 +0,0 @@
-(defpackage :losh.internal
- (:use :cl))
-
-(in-package :losh.internal)
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun external-symbols (package)
- (let ((symbols nil))
- (do-external-symbols (s (find-package package) symbols)
- (push s symbols)))))
-
-(defmacro defpackage-inheriting (name parent-packages &rest args)
- `(defpackage ,name
- ,@args
- ,@(loop :for parent-package :in parent-packages
- :collect `(:use ,parent-package)
- :collect `(:export ,@(external-symbols parent-package)))))
-
-
-(defpackage :losh.chili-dogs
- (:use :cl :iterate :losh.quickutils)
- (:documentation "Gotta go FAST.")
- (:export
- :defun-inline
- :defun-inlineable))
-
-(defpackage :losh.clos
- (:use :cl :iterate :losh.quickutils)
- (:documentation "Utilities for working with CLOS.")
- (:export
- :defclass*
- :define-condition*))
-
-(defpackage :losh.eldritch-horrors
- (:use :cl :iterate :losh.quickutils)
- (:documentation "Abandon all hope, ye who enter here.")
- (:export
- :eval-dammit
- :define-with-macro))
-
-(defpackage :losh.functions
- (:use :cl :iterate :losh.quickutils)
- (:documentation "Utilities for working with higher-order functions.")
- (:export
- :juxt
- :nullary
- :fixed-point))
-
-(defpackage :losh.hash-sets
- (:use :cl :iterate :losh.quickutils)
- (:documentation "Simple hash set implementation.")
- (:export
- :hash-set
- :make-hash-set
- :copy-hash-set
-
- :hset-empty-p
- :hset-contains-p
- :hset-elements
- :hset-count
-
- :hset-insert!
- :hset-remove!
- :hset-pop!
- :hset-clear!
-
- :hset=
-
- :hset-union
- :hset-union!
- :hset-intersection
- :hset-intersection!
- :hset-difference
- :hset-difference!
- :hset-filter
- :hset-filter!
- :hset-map
- :hset-map!
- :hset-reduce))
-
-
-(defpackage :losh.io
- (:use :cl :iterate :losh.quickutils)
- (:documentation "Utilities for input/output/reading/etc.")
- (:export
- :read-all
- :read-all-from-file
- :read-all-from-string))
-
-(defpackage :losh.lists
- (:use :cl :iterate :losh.quickutils)
- (:documentation "Utilities for operating on lists.")
- (:export
- :0.. :1.. :n..
- :0... :1... :n...
- :somelist
- :assocar :assocdr
- :rassocar :rassocdr))
-
-(defpackage :losh.mutation
- (:use :cl :iterate :losh.quickutils)
- (:documentation "Utilities for mutating places in-place.")
- (:export
- :zapf
- :%
- :mulf
- :divf
- :modf
- :remainderf
- :truncatef
- :clampf
- :negatef
- :notf
- :callf))
-
-(defpackage :losh.shell
- (:use :cl :iterate :losh.quickutils)
- (:documentation "Utilities for interacting with external programs.")
- (:export
- :sh
- :pbcopy
- :pbpaste
- :*pbcopy-command*
- :*pbpaste-command*))
-
-
-(defpackage :losh.arrays
- (:use :cl :iterate :losh.quickutils
- :losh.chili-dogs)
- (:documentation "Utilities related to arrays.")
- (:export
- :do-array
- :bisect-left
- :bisect-right
- :fill-multidimensional-array
- :fill-multidimensional-array-t
- :fill-multidimensional-array-fixnum
- :fill-multidimensional-array-single-float
- :vector-last))
-
-(defpackage :losh.bits
- (:use :cl :iterate :losh.quickutils
- :losh.chili-dogs)
- (:documentation "Utilities for low-level bit stuff.")
- (:export
- :+/8
- :-/8
- :+/16
- :-/16
- :+/32
- :-/32
- :+/64
- :-/64))
-
-(defpackage :losh.queues
- (:use :cl :iterate :losh.quickutils
- :losh.chili-dogs)
- (:documentation "A simple queue implementation.")
- (:export
- :queue
- :make-queue
- :queue-contents
- :queue-size
- :queue-empty-p
- :enqueue
- :dequeue
- :queue-append))
-
-(defpackage :losh.priority-queues
- (:use :cl :iterate :losh.quickutils
- :losh.mutation)
- (:documentation "Jankass priority queue implementation.")
- (:export
- :priority-queue
- :make-priority-queue
-
- :pq-insert
- :pq-ensure
- :pq-dequeue))
-
-(defpackage :losh.ring-buffers
- (:use :cl :iterate :losh.quickutils
- :losh.chili-dogs
- :losh.eldritch-horrors
- :losh.mutation)
- (:documentation "Simple ring buffer implementation.")
- (:export
-
- :do-ring-buffer
- :make-ring-buffer
- :rb-contents
- :rb-count
- :rb-empty-p
- :rb-full-p
- :rb-pop
- :rb-push
- :rb-ref
- :rb-safe-push
- :rb-size
- :ring-buffer
-
- ))
-
-
-(defpackage :losh.control-flow
- (:use :cl :iterate :losh.quickutils
- :losh.queues)
- (:documentation "Utilities for managing control flow.")
- (:export
- :-<>
- :<>
- :_
- :nest
- :recursively
- :recur
- :when-found
- :if-found
- :gathering
- :gathering-vector
- :gather
- :if-let
- :if-let*
- :when-let
- :when-let*
- :multiple-value-bind*
- :do-repeat
- :do-range
- :do-irange
- :do-file))
-
-
-(defpackage :losh.math
- (:use :cl :iterate :losh.quickutils
- :losh.chili-dogs
- :losh.control-flow)
- (:documentation "Utilities related to math and numbers.")
- (:export
- :tau
- :tau/2
- :1/2tau
- :tau/4
- :1/4tau
- :2/4tau
- :3/4tau
- :tau/8
- :1/8tau
- :2/8tau
- :3/8tau
- :4/8tau
- :5/8tau
- :6/8tau
- :7/8tau
-
- :clamp
- :degrees
- :dividesp
- :in-range-p
- :lerp
- :map-range
- :norm
- :precise-lerp
- :radians
- :square
- :digit))
-
-(defpackage :losh.hash-tables
- (:use :cl :iterate :losh.quickutils
- :losh.control-flow)
- (:documentation "Utilities for operating on hash tables.")
- (:export
- :hash-table-contents
- :mutate-hash-values
- :remhash-if
- :remhash-if-not
- :remhash-if-key
- :remhash-if-not-key
- :remhash-if-value
- :remhash-if-not-value))
-
-(defpackage :losh.iterate
- (:use :cl :iterate :losh.quickutils
- :losh.hash-sets
- :losh.ring-buffers)
- (:documentation "Custom `iterate` drivers and clauses.")
- (:export
-
- :across-flat-array
- :against
- :anding
- :averaging
- :collect-frequencies
- :collect-hash
- :collect-set
- :cycling
- :end
- :every-nth
- :finding-all
- :finding-first
- :for-nested
- :in-array
- :in-hashset
- :in-lists
- :in-ring-buffer
- :in-sequences
- :in-whatever
- :index-of-flat-array
- :initially
- :into
- :macroexpand-iterate
- :matching
- :modulo
- :oring
- :overlap
- :pairs-of-list
- :per-iteration-into
- :real-time
- :returning
- :run-time
- :seed
- :since-start-into
- :skip-origin
- :start
- :test
- :then
- :timing
- :within-radius
-
- ))
-
-
-(defpackage :losh.random
- (:use :cl :iterate :losh.quickutils
- :losh.chili-dogs
- :losh.math)
- (:documentation "Utilities related to randomness.")
- (:export
- :randomp
- :random-elt
- :random-range
-
- :random-range-exclusive
- :random-range-inclusive
- :random-around
- :random-gaussian
- :random-gaussian-integer
- :d))
-
-(defpackage :losh.sequences
- (:use :cl :iterate :losh.quickutils
- :losh.chili-dogs
- :losh.functions
- :losh.hash-tables
- :losh.iterate
- :losh.mutation)
- (:documentation "Utilities for operating on sequences.")
- (:export
- :extrema
- :enumerate
- :prefix-sums
- :frequencies
- :proportions
- :group-by
- :take
- :take-while
- :drop
- :drop-while
- :summation
- :product
- :doseq
- :string-join
- :define-sorting-predicate
- :make-sorting-predicate))
-
-(defpackage :losh.debugging
- (:use :cl :iterate :losh.quickutils
- :losh.math
- :losh.control-flow
- :losh.hash-tables)
- (:documentation "Utilities for figuring out what the hell is going on.")
- (:export
-
- #+sbcl :profile
- #+sbcl :start-profiling
- #+sbcl :stop-profiling
- :aesthetic-string
- :bits
- :comment
- :dis
- :gimme
- :hex
- :phr
- :pr
- :pretty-print-hash-table
- :print-table
- :prl
- :shut-up
- :structural-string
-
- ))
-
-
-(defpackage :losh.gnuplot
- (:use :cl :iterate :losh.quickutils
- :losh.control-flow
- :losh.debugging
- :losh.sequences)
- (:documentation "Utilities for plotting data with gnuplot.")
- (:export
- :gnuplot
- :gnuplot-args
- :gnuplot-function
- :gnuplot-histogram))
-
-(defpackage :losh.weightlists
- (:use :cl :iterate :losh.quickutils
- :losh.sequences)
- (:documentation
- "A simple data structure for choosing random items with weighted probabilities.")
- (:export
- :weightlist
- :weightlist-weights
- :weightlist-items
- :make-weightlist
- :weightlist-random))
-
-
-(defpackage-inheriting :losh
- (
-
- :losh.arrays
- :losh.bits
- :losh.chili-dogs
- :losh.clos
- :losh.control-flow
- :losh.debugging
- :losh.eldritch-horrors
- :losh.functions
- :losh.gnuplot
- :losh.hash-sets
- :losh.hash-tables
- :losh.io
- :losh.iterate
- :losh.lists
- :losh.math
- :losh.mutation
- :losh.priority-queues
- :losh.queues
- :losh.random
- :losh.ring-buffers
- :losh.sequences
- :losh.shell
- :losh.weightlists
-
- )
- (:use
- :cl
- :iterate
- :losh.quickutils)
- (:documentation
- "This package exports all of the symbols in the other packages.
-
- If you just want to get everything you can `:use` this one and be done with
- it. Otherwise you can `:use` only the ones you need.
-
- "))
-
-
-;;;; Remember to add it to the docs!
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/base.lisp Fri Apr 09 22:54:39 2021 -0400
@@ -0,0 +1,11 @@
+(in-package :losh.base)
+
+(defun mkstr (&rest args)
+ ;;; From On Lisp, page 58.
+ (with-output-to-string (s)
+ (dolist (a args)
+ (princ a s))))
+
+(defun symb (&rest args)
+ ;;; From On Lisp, page 58.
+ (values (intern (apply #'mkstr args))))
--- a/src/clos.lisp Fri Apr 09 19:48:53 2021 -0402
+++ b/src/clos.lisp Fri Apr 09 22:54:39 2021 -0400
@@ -4,7 +4,7 @@
(destructuring-bind (name &rest slot-options) (ensure-list slot-spec)
`(,name
,@(unless (getf slot-options :initarg)
- `(:initarg ,(ensure-keyword name)))
+ `(:initarg ,(alexandria:make-keyword name)))
,@(unless (or (getf slot-options :reader)
(getf slot-options :writer)
(getf slot-options :accessor))
--- a/src/control-flow.lisp Fri Apr 09 19:48:53 2021 -0402
+++ b/src/control-flow.lisp Fri Apr 09 22:54:39 2021 -0400
@@ -345,7 +345,7 @@
"
(with-gensyms (outer inner)
- (multiple-value-bind (body declarations) (parse-body body)
+ (multiple-value-bind (body declarations) (alexandria:parse-body body)
(destructuring-bind (then else) body
`(block ,outer
(block ,inner
@@ -393,7 +393,7 @@
"
(with-gensyms (outer inner)
- (multiple-value-bind (body declarations) (parse-body body)
+ (multiple-value-bind (body declarations) (alexandria:parse-body body)
(destructuring-bind (then else) body
`(block ,outer
(block ,inner
--- a/src/debugging.lisp Fri Apr 09 19:48:53 2021 -0402
+++ b/src/debugging.lisp Fri Apr 09 22:54:39 2021 -0400
@@ -143,7 +143,7 @@
(mapcar (curry #'mapcar (compose #'length #'aesthetic-string))
rows))) ; lol
(for row :in rows)
- (format t "~{~vA~^ | ~}~%" (weave column-sizes row))))
+ (format t "~{~vA~^ | ~}~%" (mapcan #'list column-sizes row))))
(values))
--- a/src/gnuplot.lisp Fri Apr 09 19:48:53 2021 -0402
+++ b/src/gnuplot.lisp Fri Apr 09 22:54:39 2021 -0400
@@ -154,7 +154,7 @@
(* bin-width (round y bin-width)))
<>)
frequencies
- hash-table-alist
+ alexandria:hash-table-alist
(apply #'gnuplot <>
:style :boxes
:min-y 0
--- a/src/hash-sets.lisp Fri Apr 09 19:48:53 2021 -0402
+++ b/src/hash-sets.lisp Fri Apr 09 22:54:39 2021 -0400
@@ -226,6 +226,6 @@
(define-hset-op hset-elements (hset)
"Return a fresh list containing the elements of `hset`."
- (hash-table-keys storage))
+ (alexandria:hash-table-keys storage))
--- a/src/iterate.lisp Fri Apr 09 19:48:53 2021 -0402
+++ b/src/iterate.lisp Fri Apr 09 22:54:39 2021 -0400
@@ -237,7 +237,7 @@
`(progn
(with ,len = nil)
(with ,idx = nil)
- (generate ,seq :in-whatever (remove-if #'emptyp ,seqs))
+ (generate ,seq :in-whatever (remove-if #'alexandria:emptyp ,seqs))
(,kwd ,var next
(progn
(when (seq-done-p ,seq ,len ,idx)
@@ -678,7 +678,7 @@
(defun keywordize-clause (clause)
(iterate
(for (k v . nil) :on clause :by #'cddr)
- (collect (ensure-keyword k))
+ (collect (alexandria:make-keyword k))
(collect v)))
(defun keywordize-some-of-clause (clause)
--- a/src/lists.lisp Fri Apr 09 19:48:53 2021 -0402
+++ b/src/lists.lisp Fri Apr 09 22:54:39 2021 -0400
@@ -15,29 +15,52 @@
(thereis (funcall predicate l)))))
+(defun range (start end &key (step 1))
+ "Return a fresh list of the range `[start, end)` by `step`.
+
+ `end` can be smaller than `start`, in which case the numbers will be stepped
+ down instead of up.
+
+ `step` must always be a positive value, regardless of the direction of the
+ range.
+
+ "
+ (check-type step (real (0) *))
+ (if (<= start end)
+ (loop :for i :from start :below end :by step :collect i)
+ (loop :for i :downfrom start :above end :by step :collect i)))
+
+(defun irange (start end &key (step 1))
+ "Return a fresh list of the range `[start, end]` by `step`.
+
+ `end` can be smaller than `start`, in which case the numbers will be stepped
+ down instead of up.
+
+ `step` must always be a positive value, regardless of the direction of the
+ range.
+
+ "
+ (check-type step (real (0) *))
+ (if (<= start end)
+ (loop :for i :from start :to end :by step :collect i)
+ (loop :for i :downfrom start :to end :by step :collect i)))
+
+
(defun 0.. (below)
"Return a fresh list of the range `[0, below)`."
- (loop :for i :from 0 :below below :collect i))
+ (range 0 below))
(defun 1.. (below)
"Return a fresh list of the range `[1, below)`."
- (loop :for i :from 1 :below below :collect i))
-
-(defun n.. (from below)
- "Return a fresh list of the range `[from, below)`."
- (loop :for i :from from :below below :collect i))
+ (range 1 below))
(defun 0... (to)
"Return a fresh list of the range `[0, to]`."
- (loop :for i :from 0 :to to :collect i))
+ (irange 0 to))
(defun 1... (to)
"Return a fresh list of the range `[1, to]`."
- (loop :for i :from 1 :to to :collect i))
-
-(defun n... (from to)
- "Return a fresh list of the range `[from, to]`."
- (loop :for i :from from :to to :collect i))
+ (irange 1 to))
(declaim (inline assocar assocdr rassocar rassocdr
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/package.lisp Fri Apr 09 22:54:39 2021 -0400
@@ -0,0 +1,481 @@
+(defpackage :losh.internal
+ (:use :cl))
+
+(in-package :losh.internal)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun external-symbols (package)
+ (let ((symbols nil))
+ (do-external-symbols (s (find-package package) symbols)
+ (push s symbols)))))
+
+(defmacro defpackage-inheriting (name parent-packages &rest args)
+ `(defpackage ,name
+ ,@args
+ ,@(loop :for parent-package :in parent-packages
+ :collect `(:use ,parent-package)
+ :collect `(:export ,@(external-symbols parent-package)))))
+
+
+(defpackage :losh.base
+ (:use :cl)
+ (:import-from :alexandria
+ :compose :curry :rcurry
+ :with-gensyms :once-only
+ :ensure-list
+ )
+ (:export
+ :compose :curry :rcurry
+ :with-gensyms :once-only
+ :ensure-list
+
+ :symb :mkstr))
+
+
+(defpackage :losh.chili-dogs
+ (:use :cl :iterate :losh.base)
+ (:documentation "Gotta go FAST.")
+ (:export
+ :defun-inline
+ :defun-inlineable))
+
+(defpackage :losh.clos
+ (:use :cl :iterate :losh.base)
+ (:documentation "Utilities for working with CLOS.")
+ (:export
+ :defclass*
+ :define-condition*))
+
+(defpackage :losh.eldritch-horrors
+ (:use :cl :iterate :losh.base)
+ (:documentation "Abandon all hope, ye who enter here.")
+ (:export
+ :eval-dammit
+ :define-with-macro))
+
+(defpackage :losh.functions
+ (:use :cl :iterate :losh.base)
+ (:documentation "Utilities for working with higher-order functions.")
+ (:export
+ :juxt
+ :nullary
+ :fixed-point))
+
+(defpackage :losh.hash-sets
+ (:use :cl :iterate :losh.base)
+ (:documentation "Simple hash set implementation.")
+ (:export
+ :hash-set
+ :make-hash-set
+ :copy-hash-set
+
+ :hset-empty-p
+ :hset-contains-p
+ :hset-elements
+ :hset-count
+
+ :hset-insert!
+ :hset-remove!
+ :hset-pop!
+ :hset-clear!
+
+ :hset=
+
+ :hset-union
+ :hset-union!
+ :hset-intersection
+ :hset-intersection!
+ :hset-difference
+ :hset-difference!
+ :hset-filter
+ :hset-filter!
+ :hset-map
+ :hset-map!
+ :hset-reduce))
+
+
+(defpackage :losh.io
+ (:use :cl :iterate :losh.base)
+ (:documentation "Utilities for input/output/reading/etc.")
+ (:export
+ :read-all
+ :read-all-from-file
+ :read-all-from-string))
+
+(defpackage :losh.lists
+ (:use :cl :iterate :losh.base)
+ (:documentation "Utilities for operating on lists.")
+ (:export
+ :0.. :1.. :range
+ :0... :1... :irange
+ :somelist
+ :assocar :assocdr
+ :rassocar :rassocdr))
+
+(defpackage :losh.mutation
+ (:use :cl :iterate :losh.base)
+ (:documentation "Utilities for mutating places in-place.")
+ (:export
+ :zapf
+ :%
+ :mulf
+ :divf
+ :modf
+ :remainderf
+ :truncatef
+ :clampf
+ :negatef
+ :notf
+ :callf))
+
+(defpackage :losh.shell
+ (:use :cl :iterate :losh.base)
+ (:documentation "Utilities for interacting with external programs.")
+ (:export
+ :sh
+ :pbcopy
+ :pbpaste
+ :*pbcopy-command*
+ :*pbpaste-command*))
+
+
+(defpackage :losh.arrays
+ (:use :cl :iterate :losh.base
+ :losh.chili-dogs)
+ (:documentation "Utilities related to arrays.")
+ (:export
+ :do-array
+ :bisect-left
+ :bisect-right
+ :fill-multidimensional-array
+ :fill-multidimensional-array-t
+ :fill-multidimensional-array-fixnum
+ :fill-multidimensional-array-single-float
+ :vector-last))
+
+(defpackage :losh.bits
+ (:use :cl :iterate :losh.base
+ :losh.chili-dogs)
+ (:documentation "Utilities for low-level bit stuff.")
+ (:export
+ :+/8
+ :-/8
+ :+/16
+ :-/16
+ :+/32
+ :-/32
+ :+/64
+ :-/64))
+
+(defpackage :losh.queues
+ (:use :cl :iterate :losh.base
+ :losh.chili-dogs)
+ (:documentation "A simple queue implementation.")
+ (:export
+ :queue
+ :make-queue
+ :queue-contents
+ :queue-size
+ :queue-empty-p
+ :enqueue
+ :dequeue
+ :queue-append))
+
+(defpackage :losh.priority-queues
+ (:use :cl :iterate :losh.base
+ :losh.mutation)
+ (:documentation "Jankass priority queue implementation.")
+ (:export
+ :priority-queue
+ :make-priority-queue
+
+ :pq-insert
+ :pq-ensure
+ :pq-dequeue))
+
+(defpackage :losh.ring-buffers
+ (:use :cl :iterate :losh.base
+ :losh.chili-dogs
+ :losh.eldritch-horrors
+ :losh.mutation)
+ (:documentation "Simple ring buffer implementation.")
+ (:export
+
+ :do-ring-buffer
+ :make-ring-buffer
+ :rb-contents
+ :rb-count
+ :rb-empty-p
+ :rb-full-p
+ :rb-pop
+ :rb-push
+ :rb-ref
+ :rb-safe-push
+ :rb-size
+ :ring-buffer
+
+ ))
+
+
+(defpackage :losh.control-flow
+ (:use :cl :iterate :losh.base
+ :losh.queues)
+ (:documentation "Utilities for managing control flow.")
+ (:export
+ :-<>
+ :<>
+ :_
+ :nest
+ :recursively
+ :recur
+ :when-found
+ :if-found
+ :gathering
+ :gathering-vector
+ :gather
+ :if-let
+ :if-let*
+ :when-let
+ :when-let*
+ :multiple-value-bind*
+ :do-repeat
+ :do-range
+ :do-irange
+ :do-file))
+
+
+(defpackage :losh.math
+ (:use :cl :iterate :losh.base
+ :losh.chili-dogs
+ :losh.control-flow)
+ (:documentation "Utilities related to math and numbers.")
+ (:export
+ :tau
+ :tau/2
+ :1/2tau
+ :tau/4
+ :1/4tau
+ :2/4tau
+ :3/4tau
+ :tau/8
+ :1/8tau
+ :2/8tau
+ :3/8tau
+ :4/8tau
+ :5/8tau
+ :6/8tau
+ :7/8tau
+
+ :clamp
+ :degrees
+ :dividesp
+ :in-range-p
+ :lerp
+ :map-range
+ :norm
+ :precise-lerp
+ :radians
+ :square
+ :digit))
+
+(defpackage :losh.hash-tables
+ (:use :cl :iterate :losh.base
+ :losh.control-flow)
+ (:documentation "Utilities for operating on hash tables.")
+ (:export
+ :hash-table-contents
+ :mutate-hash-values
+ :remhash-if
+ :remhash-if-not
+ :remhash-if-key
+ :remhash-if-not-key
+ :remhash-if-value
+ :remhash-if-not-value))
+
+(defpackage :losh.iterate
+ (:use :cl :iterate :losh.base
+ :losh.hash-sets
+ :losh.ring-buffers)
+ (:documentation "Custom `iterate` drivers and clauses.")
+ (:export
+
+ :across-flat-array
+ :against
+ :anding
+ :averaging
+ :collect-frequencies
+ :collect-hash
+ :collect-set
+ :cycling
+ :end
+ :every-nth
+ :finding-all
+ :finding-first
+ :for-nested
+ :in-array
+ :in-hashset
+ :in-lists
+ :in-ring-buffer
+ :in-sequences
+ :in-whatever
+ :index-of-flat-array
+ :initially
+ :into
+ :macroexpand-iterate
+ :matching
+ :modulo
+ :oring
+ :overlap
+ :pairs-of-list
+ :per-iteration-into
+ :real-time
+ :returning
+ :run-time
+ :seed
+ :since-start-into
+ :skip-origin
+ :start
+ :test
+ :then
+ :timing
+ :within-radius
+
+ ))
+
+
+(defpackage :losh.random
+ (:use :cl :iterate :losh.base
+ :losh.chili-dogs
+ :losh.math)
+ (:documentation "Utilities related to randomness.")
+ (:export
+ :randomp
+ :random-elt
+ :random-range
+
+ :random-range-exclusive
+ :random-range-inclusive
+ :random-around
+ :random-gaussian
+ :random-gaussian-integer
+ :d))
+
+(defpackage :losh.sequences
+ (:use :cl :iterate :losh.base
+ :losh.chili-dogs
+ :losh.functions
+ :losh.hash-tables
+ :losh.iterate
+ :losh.mutation)
+ (:documentation "Utilities for operating on sequences.")
+ (:export
+ :extrema
+ :enumerate
+ :prefix-sums
+ :frequencies
+ :proportions
+ :group-by
+ :take
+ :take-while
+ :drop
+ :drop-while
+ :summation
+ :product
+ :doseq
+ :string-join
+ :define-sorting-predicate
+ :make-sorting-predicate))
+
+(defpackage :losh.debugging
+ (:use :cl :iterate :losh.base
+ :losh.math
+ :losh.control-flow
+ :losh.hash-tables)
+ (:documentation "Utilities for figuring out what the hell is going on.")
+ (:export
+
+ #+sbcl :profile
+ #+sbcl :start-profiling
+ #+sbcl :stop-profiling
+ :aesthetic-string
+ :bits
+ :comment
+ :dis
+ :gimme
+ :hex
+ :phr
+ :pr
+ :pretty-print-hash-table
+ :print-table
+ :prl
+ :shut-up
+ :structural-string
+
+ ))
+
+
+(defpackage :losh.gnuplot
+ (:use :cl :iterate :losh.base
+ :losh.control-flow
+ :losh.debugging
+ :losh.lists
+ :losh.sequences)
+ (:documentation "Utilities for plotting data with gnuplot.")
+ (:export
+ :gnuplot
+ :gnuplot-args
+ :gnuplot-function
+ :gnuplot-histogram))
+
+(defpackage :losh.weightlists
+ (:use :cl :iterate :losh.base
+ :losh.sequences)
+ (:documentation
+ "A simple data structure for choosing random items with weighted probabilities.")
+ (:export
+ :weightlist
+ :weightlist-weights
+ :weightlist-items
+ :make-weightlist
+ :weightlist-random))
+
+
+(defpackage-inheriting :losh
+ (
+
+ :losh.arrays
+ :losh.bits
+ :losh.chili-dogs
+ :losh.clos
+ :losh.control-flow
+ :losh.debugging
+ :losh.eldritch-horrors
+ :losh.functions
+ :losh.gnuplot
+ :losh.hash-sets
+ :losh.hash-tables
+ :losh.io
+ :losh.iterate
+ :losh.lists
+ :losh.math
+ :losh.mutation
+ :losh.priority-queues
+ :losh.queues
+ :losh.random
+ :losh.ring-buffers
+ :losh.sequences
+ :losh.shell
+ :losh.weightlists
+
+ )
+ (:use :cl :iterate :losh.base)
+ (:documentation
+ "This package exports all of the symbols in the other packages.
+
+ If you just want to get everything you can `:use` this one and be done with
+ it. Otherwise you can `:use` only the ones you need.
+
+ "))
+
+
+;;;; Remember to add it to the docs!
--- a/src/sequences.lisp Fri Apr 09 19:48:53 2021 -0402
+++ b/src/sequences.lisp Fri Apr 09 22:54:39 2021 -0400
@@ -72,7 +72,7 @@
"
(let* ((freqs (frequencies sequence :test test :key key))
- (total (reduce #'+ (hash-table-values freqs)
+ (total (reduce #'+ (alexandria:hash-table-values freqs)
:initial-value (if float 1.0 1))))
(mutate-hash-values (lambda (v) (/ v total))
freqs)))
@@ -272,7 +272,7 @@
(enumerate '(a b c) :start 1)
; => ((1 . A) (2 . B) (3 . C))
- (enumerate '(a b c) :key #'ensure-keyword)
+ (enumerate '(a b c) :key #'alexandria:make-keyword)
; => ((0 . :A) (1 . :B) (2 . :C))
"
--- a/test/control-flow.lisp Fri Apr 09 19:48:53 2021 -0402
+++ b/test/control-flow.lisp Fri Apr 09 22:54:39 2021 -0400
@@ -193,6 +193,12 @@
(do-repeat 0
(gather 1))))))
+(define-test do-file
+ (is (equal '("1" "2" "34")
+ (gathering (do-file (line "test/example.txt") (gather line)))))
+ (is (equal '(1 2 34)
+ (gathering (do-file (s "test/example.txt" :reader #'read) (gather s))))))
+
(define-test gathering
#+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note))
@@ -245,4 +251,3 @@
(d b)))
(list a b c d)))))
-
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/test/example.txt Fri Apr 09 22:54:39 2021 -0400
@@ -0,0 +1,3 @@
+1
+2
+34
--- a/test/lists.lisp Fri Apr 09 19:48:53 2021 -0402
+++ b/test/lists.lisp Fri Apr 09 22:54:39 2021 -0400
@@ -20,3 +20,4 @@
nil))
'(a b c d e)
'(e d c b a)))))
+
--- a/test/package.lisp Fri Apr 09 19:48:53 2021 -0402
+++ b/test/package.lisp Fri Apr 09 22:54:39 2021 -0400
@@ -1,4 +1,4 @@
(defpackage :losh.test
- (:use :cl :1am :losh)
+ (:use :cl :1am :losh :iterate)
(:shadowing-import-from :1am :test)
(:export :run-tests))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/test/ring-buffers.lisp Fri Apr 09 22:54:39 2021 -0400
@@ -0,0 +1,75 @@
+(in-package :losh.test)
+
+(defun check-ring-buffer (rb expected-contents)
+ ;; rb-contents
+ (is (equal expected-contents (rb-contents rb)))
+ ;; rb-count
+ (is (= (length expected-contents) (rb-count rb)))
+ ;; rb-empty
+ (if (null expected-contents)
+ (is (rb-empty-p rb))
+ (is (not (rb-empty-p rb))))
+ ;; rb-full
+ (if (= (length expected-contents) (1- (rb-size rb)))
+ (is (rb-full-p rb))
+ (is (not (rb-full-p rb))))
+ ;; do-ring-buffer
+ (let ((contents expected-contents))
+ (do-ring-buffer (val rb)
+ (is (equal (pop contents) val)))
+ (is (null contents)))
+ ;; iterate driver
+ (let ((contents expected-contents))
+ (iterate (for val :in-ring-buffer rb)
+ (is (equal (pop contents) val)))
+ (is (null contents)))
+ ;; rb-ref
+ (iterate (for val :in expected-contents)
+ (for i :from 0)
+ (is (equal val (rb-ref rb i))))
+ (iterate (for val :in (reverse expected-contents))
+ (for i :downfrom -1)
+ (is (equal val (rb-ref rb i)))))
+
+(define-test basic-ring-buffers
+ (let ((rb (make-ring-buffer :size 4)))
+ (check-ring-buffer rb '())
+ (is (= 4 (rb-size rb)))
+
+ (rb-push rb 'a) (check-ring-buffer rb '(a))
+ (rb-push rb 'b) (check-ring-buffer rb '(a b))
+ (rb-push rb 'c) (check-ring-buffer rb '(a b c))
+ (rb-push rb 'd) (check-ring-buffer rb '(b c d))
+ (rb-push rb 'e) (check-ring-buffer rb '(c d e))
+ (rb-push rb 'f) (check-ring-buffer rb '(d e f))
+ (rb-push rb 'g) (check-ring-buffer rb '(e f g))
+ (is (eql 'e (rb-pop rb))) (check-ring-buffer rb '(f g))
+ (is (eql 'f (rb-pop rb))) (check-ring-buffer rb '(g))
+ (is (eql 'g (rb-pop rb))) (check-ring-buffer rb '())
+
+ (signals error (rb-pop rb))
+ (check-ring-buffer rb '())
+
+ (rb-safe-push rb 'a)
+ (rb-safe-push rb 'b)
+ (rb-safe-push rb 'c)
+ (is (= 4 (rb-size rb)))
+ (check-ring-buffer rb '(a b c))
+ (signals error (rb-safe-push rb 'd))))
+
+(define-test fuzz-ring-buffers
+ (do-range ((n 2 30))
+ (iterate
+ (with rb = (make-ring-buffer :size n))
+ (with data = (coerce (0... 400) 'vector))
+ (with i = 0)
+ (repeat 400)
+
+ ;; Randomly push/pop (but never try to pop if empty).
+ (if (or (rb-empty-p rb) (randomp 0.7))
+ (progn (rb-push rb (aref data i))
+ (incf i))
+ (rb-pop rb))
+
+ (for expected = (coerce (subseq data (- i (rb-count rb)) i) 'list))
+ (check-ring-buffer rb expected))))
--- a/test/sequences.lisp Fri Apr 09 19:48:53 2021 -0402
+++ b/test/sequences.lisp Fri Apr 09 22:54:39 2021 -0400
@@ -1,5 +1,13 @@
(in-package :losh.test)
+(defparameter *words* nil)
+
+(defun words ()
+ (when (null *words*)
+ (setf *words* (gathering-vector ()
+ (do-file (line "/usr/share/dict/words")
+ (gather line)))))
+ *words*)
(define-test make-sorting-predicate
(flet ((check (original expected &rest preds)
@@ -54,7 +62,6 @@
(#'< :key #'length)
#'string<)
-
(define-test define-sorting-predicate
(flet ((check (original expected pred)
(let ((actual (sort (copy-seq original) pred)))
@@ -75,6 +82,51 @@
'("by" "aby" "zzy" "az")
#'sort-fancy<)))
+(defun sortedp (sequence predicate)
+ ;; TODO Should this be a util of its own?
+ (etypecase sequence
+ (list (loop :for x = (pop sequence)
+ :until (null sequence)
+ :never (funcall predicate (first sequence) x)))
+ (sequence (loop :with l = (length sequence)
+ :for x :from 0 :below l
+ :for y :from 1 :below l
+ :never (funcall predicate (elt sequence y) (elt sequence x))))))
+
+(defun vowelp (char)
+ (find (char-downcase char) "aeiou"))
+
+(defun vowels< (a b)
+ (< (count-if #'vowelp a) (count-if #'vowelp b)))
+
+(defun random-elts (n sequence &key (result-type 'list))
+ "Return `N` random elements from `sequence` (duplicates allowed).
+
+ This wil not be fast if `sequence` is a list.
+
+ "
+ (ecase result-type
+ (list (loop :repeat n :collect (random-elt sequence)))
+ (vector (loop :with result = (make-array n)
+ :for i :from 0 :below n
+ :do (setf (aref result i) (random-elt sequence))
+ :finally (return result)))))
+
+
+(define-test fuzz-sorting-predicates
+ (let ((specs (vector 'string<
+ (cons '< 'length)
+ (cons 'string< 'reverse)
+ 'vowels<
+ (cons '< 'sxhash)))
+ (words (words)))
+ (do-repeat 256
+ (let* ((specs (random-elts (random-range 1 (+ 3 (length specs))) specs))
+ (predicate (apply #'make-sorting-predicate specs))
+ (seq (random-elts (random-range 0 100) words :result-type 'vector)))
+ (setf seq (sort seq predicate))
+ (is (sortedp seq predicate))))))
+
(define-test string-join
(is (string= "" (string-join #\x '())))
@@ -84,3 +136,16 @@
(is (string= "A, B, C" (string-join ", " #(a b c))))
(is (string= "foo" (string-join #\space '("foo"))))
(is (string= "f o o" (string-join #\space "foo"))))
+
+(define-test fuzz-string-join
+ (let ((words (words)))
+ (do-repeat 500
+ (let* ((n (random-range 0 10))
+ (ws (random-elts n words))
+ (sep (random-elt #(#\, "" "," ", ")))
+ (result (string-join sep ws)))
+ (if (zerop n)
+ (is (string= "" result))
+ (is (= (+ (reduce #'+ ws :key #'length)
+ (* (1- n) (length (string sep))))
+ (length result))))))))
--- a/vendor/make-quickutils.lisp Fri Apr 09 19:48:53 2021 -0402
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,29 +0,0 @@
-(ql:quickload 'quickutil)
-
-(qtlc:save-utils-as
- "quickutils.lisp"
- :utilities '(
-
- :compose
- :copy-hash-table
- :curry
- :emptyp
- :ensure-keyword
- :ensure-list
- :flatten
- :hash-table-alist
- :hash-table-keys
- :hash-table-values
- :make-gensym
- :map-tree
- :mkstr
- :once-only
- :parse-body
- :range
- :rcurry
- :symb
- :weave
- :with-gensyms
-
- )
- :package "LOSH.QUICKUTILS")
--- a/vendor/quickutils.lisp Fri Apr 09 19:48:53 2021 -0402
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,377 +0,0 @@
-;;;; 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 :EMPTYP :ENSURE-KEYWORD :ENSURE-LIST :FLATTEN :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-VALUES :MAKE-GENSYM :MAP-TREE :MKSTR :ONCE-ONLY :PARSE-BODY :RANGE :RCURRY :SYMB :WEAVE :WITH-GENSYMS) :ensure-package T :package "LOSH.QUICKUTILS")
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (unless (find-package "LOSH.QUICKUTILS")
- (defpackage "LOSH.QUICKUTILS"
- (:documentation "Package that contains Quickutil utility functions.")
- (:use #:cl))))
-
-(in-package "LOSH.QUICKUTILS")
-
-(when (boundp '*utilities*)
- (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
- :COMPOSE :COPY-HASH-TABLE :CURRY
- :NON-ZERO-P :EMPTYP :ENSURE-KEYWORD
- :ENSURE-LIST :FLATTEN
- :HASH-TABLE-ALIST :MAPHASH-KEYS
- :HASH-TABLE-KEYS :MAPHASH-VALUES
- :HASH-TABLE-VALUES :MAKE-GENSYM
- :MAP-TREE :MKSTR :ONCE-ONLY
- :PARSE-BODY :RANGE :RCURRY :SYMB
- :WEAVE :STRING-DESIGNATOR
- :WITH-GENSYMS))))
-(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 non-zero-p (n)
- "Check if `n` is non-zero."
- (not (zerop n)))
-
-
- (defgeneric emptyp (object)
- (:documentation "Determine if `object` is empty.")
- (:method ((x null)) t)
- (:method ((x cons)) nil)
- (:method ((x vector)) (zerop (length x))) ; STRING :< VECTOR
- (:method ((x array)) (notany #'non-zero-p (array-dimensions x)))
- (:method ((x hash-table)) (zerop (hash-table-count x))))
-
-
- (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)))
-
-
- (defun flatten (&rest xs)
- "Flatten (and append) all lists `xs` completely."
- (labels ((rec (xs acc)
- (cond ((null xs) acc)
- ((consp xs) (rec (car xs) (rec (cdr xs) acc)))
- (t (cons xs acc)))))
- (rec xs nil)))
-
-
- (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 make-gensym (name)
- "If `name` is a non-negative integer, calls `gensym` using it. Otherwise `name`
-must be a string designator, in which case calls `gensym` using the designated
-string as the argument."
- (gensym (if (typep name '(integer 0))
- name
- (string name))))
-
-
- (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 parse-body (body &key documentation whole)
- "Parses `body` into `(values remaining-forms declarations doc-string)`.
-Documentation strings are recognized only if `documentation` is true.
-Syntax errors in body are signalled and `whole` is used in the signal
-arguments when given."
- (let ((doc nil)
- (decls nil)
- (current nil))
- (tagbody
- :declarations
- (setf current (car body))
- (when (and documentation (stringp current) (cdr body))
- (if doc
- (error "Too many documentation strings in ~S." (or whole body))
- (setf doc (pop body)))
- (go :declarations))
- (when (and (listp current) (eql (first current) 'declare))
- (push (pop body) decls)
- (go :declarations)))
- (values body (nreverse decls) doc)))
-
-
- (defun range (start end &key (step 1) (key 'identity))
- "Return the list of numbers `n` such that `start <= n < end` and
-`n = start + k*step` for suitable integers `k`. If a function `key` is
-provided, then apply it to each number."
- (assert (<= start end))
- (loop :for i :from start :below end :by step :collecting (funcall key i)))
-
-
- (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 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 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))
-
-
- (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))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (export '(compose copy-hash-table curry emptyp ensure-keyword ensure-list
- flatten hash-table-alist hash-table-keys hash-table-values
- make-gensym map-tree mkstr once-only parse-body range rcurry symb
- weave with-gensyms with-unique-names)))
-
-;;;; END OF quickutils.lisp ;;;;