├── .hgignore ├── .lispwords ├── DOCUMENTATION.markdown ├── LICENSE.markdown ├── Makefile ├── README.markdown ├── losh.asd ├── make-docs.lisp ├── src ├── arrays.lisp ├── astar.lisp ├── base.lisp ├── bits.lisp ├── chili-dogs.lisp ├── clos.lisp ├── control-flow.lisp ├── debugging.lisp ├── eldritch-horrors.lisp ├── functions.lisp ├── gnuplot.lisp ├── hash-sets.lisp ├── hash-tables.lisp ├── io.lisp ├── iterate.lisp ├── lists.lisp ├── math.lisp ├── mutation.lisp ├── package.lisp ├── priority-queues.lisp ├── queues.lisp ├── random.lisp ├── readtable.lisp ├── ring-buffers.lisp ├── sequences.lisp ├── shell.lisp ├── streams.lisp └── weightlists.lisp └── test ├── arrays.lisp ├── base.lisp ├── control-flow.lisp ├── example.txt ├── iterate.lisp ├── lists.lisp ├── package.lisp ├── ring-buffers.lisp ├── run.lisp └── sequences.lisp /.hgignore: -------------------------------------------------------------------------------- 1 | scratch.lisp 2 | plot.png 3 | plot.pdf 4 | -------------------------------------------------------------------------------- /.lispwords: -------------------------------------------------------------------------------- 1 | (1 spit) 2 | (1 recursively) 3 | (1 do-file) 4 | -------------------------------------------------------------------------------- /LICENSE.markdown: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022 Steve Losh and contributors 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: docs test test-sbcl test-ccl test-ecl test-abcl 2 | heading_printer = $(shell which heading || echo 'true') 3 | sourcefiles = $(shell ffind --full-path --literal .lisp) 4 | 5 | # Documentation --------------------------------------------------------------- 6 | DOCUMENTATION.markdown: $(sourcefiles) 7 | sbcl --noinform --load make-docs.lisp --eval '(quit)' 8 | 9 | docs: DOCUMENTATION.markdown 10 | 11 | 12 | # Testing --------------------------------------------------------------------- 13 | test: test-sbcl test-ccl test-ecl test-abcl 14 | 15 | test-sbcl: 16 | $(heading_printer) computer 'SBCL' 17 | sbcl --load test/run.lisp 18 | 19 | test-ccl: 20 | $(heading_printer) slant 'CCL' 21 | ccl --load test/run.lisp 22 | 23 | test-ecl: 24 | $(heading_printer) roman 'ECL' 25 | # oh for fucks sake, use -- for longopts come on 26 | ecl -load test/run.lisp 27 | 28 | test-abcl: 29 | $(heading_printer) broadway 'ABCL' 30 | abcl --load test/run.lisp 31 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | Common Lisp utilities I use a lot. 2 | 3 | License: MIT. 4 | -------------------------------------------------------------------------------- /losh.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem :losh 2 | :name "losh" 3 | :description "My personal utility belt library." 4 | 5 | :author "Steve Losh " 6 | 7 | :license "MIT" 8 | :version "0.0.1" 9 | 10 | :in-order-to ((asdf:test-op (asdf:test-op :losh/test))) 11 | 12 | :depends-on ( 13 | 14 | #+sbcl :sb-sprof 15 | :alexandria 16 | :cl-ppcre 17 | :external-program 18 | :flexi-streams 19 | :iterate 20 | :pileup 21 | :named-readtables 22 | 23 | ) 24 | 25 | :components 26 | ((:module "src" 27 | :components ( 28 | ;; -1 -------------------------------------------------------- 29 | (:file "package") 30 | (:file "base" :depends-on ("package")) 31 | 32 | ;; 0 --------------------------------------------------------- 33 | (:file "chili-dogs" :depends-on ("base")) 34 | (:file "clos" :depends-on ("base")) 35 | (:file "eldritch-horrors" :depends-on ("base")) 36 | (:file "functions" :depends-on ("base")) 37 | (:file "hash-sets" :depends-on ("base")) 38 | (:file "io" :depends-on ("base")) 39 | (:file "lists" :depends-on ("base")) 40 | (:file "mutation" :depends-on ("base")) 41 | (:file "shell" :depends-on ("base")) 42 | (:file "streams" :depends-on ("base")) 43 | 44 | ;; 1 --------------------------------------------------------- 45 | (:file "arrays" :depends-on ("chili-dogs")) 46 | (:file "bits" :depends-on ("chili-dogs")) 47 | (:file "queues" :depends-on ("chili-dogs")) 48 | (:file "priority-queues" :depends-on ("mutation")) 49 | (:file "ring-buffers" :depends-on ("chili-dogs" 50 | "eldritch-horrors" 51 | "mutation")) 52 | 53 | ;; 2 --------------------------------------------------------- 54 | (:file "control-flow" :depends-on ("queues")) 55 | 56 | ;; 3 --------------------------------------------------------- 57 | (:file "astar" :depends-on ("control-flow" 58 | "chili-dogs")) 59 | (:file "iterate" :depends-on ("control-flow" 60 | "hash-sets")) 61 | (:file "math" :depends-on ("control-flow" 62 | "chili-dogs")) 63 | (:file "hash-tables" :depends-on ("control-flow")) 64 | 65 | 66 | ;; 4 --------------------------------------------------------- 67 | (:file "random" :depends-on ("math" 68 | "chili-dogs")) 69 | (:file "readtable" :depends-on ("hash-tables")) 70 | (:file "sequences" :depends-on ("chili-dogs" 71 | "hash-tables" 72 | "functions" 73 | "iterate" 74 | "mutation")) 75 | (:file "debugging" :depends-on ("control-flow" 76 | "math" 77 | "hash-tables")) 78 | 79 | ;; 5 --------------------------------------------------------- 80 | (:file "weightlists" :depends-on ("sequences")) 81 | (:file "gnuplot" :depends-on ("control-flow" 82 | "iterate" 83 | "debugging" 84 | "lists" 85 | "sequences")) 86 | 87 | )))) 88 | 89 | (asdf:defsystem :losh/test 90 | :description "Test suite for losh." 91 | 92 | :author "Steve Losh " 93 | :license "MIT" 94 | 95 | :depends-on (:losh :1am) 96 | 97 | :serial t 98 | :components ((:module "test" 99 | :serial t 100 | :components ((:file "package") 101 | (:file "base") 102 | (:file "arrays") 103 | (:file "lists") 104 | (:file "iterate") 105 | (:file "sequences") 106 | (:file "control-flow") 107 | (:file "ring-buffers")))) 108 | 109 | :perform (asdf:test-op (op system) 110 | (funcall (read-from-string "losh.test:run-tests")))) 111 | -------------------------------------------------------------------------------- /make-docs.lisp: -------------------------------------------------------------------------------- 1 | (ql:quickload "cl-d-api") 2 | 3 | (defparameter *document-packages* 4 | (list "LOSH" 5 | 6 | "LOSH.ASTAR" 7 | "LOSH.ARRAYS" 8 | "LOSH.BASE" 9 | "LOSH.BITS" 10 | "LOSH.CHILI-DOGS" 11 | "LOSH.CLOS" 12 | "LOSH.CONTROL-FLOW" 13 | "LOSH.DEBUGGING" 14 | "LOSH.ELDRITCH-HORRORS" 15 | "LOSH.FUNCTIONS" 16 | "LOSH.GNUPLOT" 17 | "LOSH.HASH-SETS" 18 | "LOSH.HASH-TABLES" 19 | "LOSH.IO" 20 | "LOSH.ITERATE" 21 | "LOSH.LISTS" 22 | "LOSH.MATH" 23 | "LOSH.MUTATION" 24 | "LOSH.PRIORITY-QUEUES" 25 | "LOSH.QUEUES" 26 | "LOSH.RANDOM" 27 | "LOSH.READTABLE" 28 | "LOSH.RING-BUFFERS" 29 | "LOSH.SEQUENCES" 30 | "LOSH.SHELL" 31 | "LOSH.STREAMS" 32 | "LOSH.WEIGHTLISTS" 33 | 34 | )) 35 | 36 | (defparameter *output-path* 37 | #p"DOCUMENTATION.markdown" ) 38 | 39 | (defparameter *header* 40 | "This library is my own personal utility belt. 41 | 42 | Everything I write in here is MIT licensed, so you're free to use it if 43 | you want. But I make no guarantees about backwards compatibility -- I might 44 | change and break things at any time. Use this at your own risk. 45 | 46 | 47 | ") 48 | 49 | (d-api:generate-documentation 50 | :losh 51 | *output-path* 52 | *document-packages* 53 | *header* 54 | :title "Documentation for `cl-losh`") 55 | -------------------------------------------------------------------------------- /src/arrays.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.arrays) 2 | 3 | (declaim 4 | (ftype (function ((array * *) t)) fill-multidimensional-array) 5 | (ftype (function ((array t *) t)) fill-multidimensional-array-t) 6 | (ftype (function ((array fixnum *) fixnum)) fill-multidimensional-array-fixnum) 7 | (ftype (function ((array single-float *) single-float)) fill-multidimensional-array-single-float)) 8 | 9 | 10 | (defmacro do-array ((value array) &body body) 11 | "Perform `body` once for each element in `array` using `value` for the place. 12 | 13 | `array` can be multidimensional. 14 | 15 | `value` will be `symbol-macrolet`ed to the appropriate `aref`, so you can use 16 | it as a place if you want. 17 | 18 | Returns the array. 19 | 20 | Example: 21 | 22 | (let ((arr (vector 1 2 3))) 23 | (do-array (x arr) 24 | (setf x (1+ x)))) 25 | => #(2 3 4) 26 | 27 | " 28 | (with-gensyms (i) 29 | (once-only (array) 30 | `(iterate (for ,i :index-of-flat-array ,array) 31 | (symbol-macrolet ((,value (row-major-aref ,array ,i))) 32 | ,@body) 33 | (finally (return ,array)))))) 34 | 35 | 36 | (defun-inline fill-mda (array item) 37 | ;; from #lisp: 38 | ;; 39 | ;; sjl: the problem with the displaced array version is that it 40 | ;; accumulates weak pointers to displaced arrays when the arrays are created 41 | ;; and only removes them when the arrays are gced. that list is traversed each 42 | ;; time a displaced array is created. so it can get much worse with more 43 | ;; repetitions and depends on gc behavior 44 | ;; 45 | ;; scymtym: ugh, that's an sbcl-specific thing then? 46 | ;; 47 | ;; sjl: probably. i don't know how other implementations handle the 48 | ;; problem. the reason for this weak pointer mechanism is that resizing the 49 | ;; displaced-to array can propagate to the displaced array which has to be 50 | ;; a pretty rare case 51 | #+sbcl 52 | (fill (sb-ext:array-storage-vector array) item) 53 | 54 | #-(or sbcl) 55 | (fill (make-array (array-total-size array) 56 | :adjustable nil 57 | :fill-pointer nil 58 | :displaced-to array 59 | :element-type (array-element-type array)) 60 | item) 61 | 62 | array) 63 | 64 | 65 | (defun fill-multidimensional-array (array item) 66 | "Fill `array` with `item`. 67 | 68 | Unlike `fill`, this works on multidimensional arrays. It won't cons on SBCL, 69 | but it may in other implementations. 70 | 71 | " 72 | (fill-mda array item)) 73 | 74 | 75 | (eval-when (:compile-toplevel :load-toplevel :execute) 76 | (defparameter *fmda-docstring* 77 | "Fill `array` (which must be of type `(array ~A *)`) with `item`. 78 | 79 | Unlike `fill`, this works on multidimensional arrays. It won't cons on SBCL, 80 | but it may in other implementations. 81 | 82 | ")) 83 | 84 | (defmacro defun-fmda (type) 85 | `(defun ,(symb 'fill-multidimensional-array- type) (array item) 86 | ,(format nil *fmda-docstring* type) 87 | (fill-mda array item))) 88 | 89 | (defun-fmda t) 90 | (defun-fmda fixnum) 91 | (defun-fmda single-float) 92 | 93 | 94 | (defun-inlineable bisect-left (predicate vector target &key 95 | (key #'identity) 96 | (start 0) 97 | (end (length vector))) 98 | "Bisect `vector` with `predicate` and return the LEFT element. 99 | 100 | Only the subsequence of `vector` bounded by `start` and `end` is considered. 101 | 102 | `vector` must be sorted (with `predicate`) before this function is called 103 | (this is not checked). 104 | 105 | You can think of this function as partitioning the elements into two halves: 106 | those that satisfy `(predicate (funcall key element) target)` and those that 107 | don't, and then selecting the element on the LEFT side of the split: 108 | 109 | satisfying not statisfying 110 | #(.......... ...............) 111 | ^ 112 | | 113 | result 114 | 115 | Two values will be returned: the element and its index. If no element 116 | satisfies the predicate `nil` will be returned for both values. 117 | 118 | Examples: 119 | 120 | ; index 121 | ; 0 1 2 3 4 5 val index 122 | (bisect-left '< #(1 3 5 7 7 9) 5) ; => 3, 1 123 | (bisect-left '<= #(1 3 5 7 7 9) 5) ; => 5, 2 124 | (bisect-left '<= #(1 3 5 7 7 9) 7) ; => 7, 4 125 | (bisect-left '< #(1 3 5 7 7 9) 1) ; => nil, nil 126 | (bisect-left '> #(9 8 8 8 1 0) 5) ; => 8, 3 127 | (bisect-left '< #((1) (2 2) (3 3 3)) 2 :key #'length) ; => (1), 0 128 | (bisect-left '<= #((1) (2 2) (3 3 3)) 2 :key #'length) ; => (2 2), 1 129 | 130 | " 131 | (if (>= start end) 132 | (values nil nil) 133 | (iterate 134 | (for index = (truncate (+ start end) 2)) 135 | (for value = (aref vector index)) 136 | (for result = (funcall predicate (funcall key value) target)) 137 | (if (= start index) 138 | (return (if result 139 | (values value index) 140 | (values nil nil))) 141 | (if result 142 | (setf start index) 143 | (setf end index)))))) 144 | 145 | (defun-inlineable bisect-right (predicate vector target &key 146 | (key #'identity) 147 | (start 0) 148 | (end (length vector))) 149 | "Bisect `vector` with `predicate` and return the RIGHT element. 150 | 151 | Only the subsequence of `vector` bounded by `start` and `end` is considered. 152 | 153 | `vector` must be sorted (with `predicate`) before this function is called 154 | (this is not checked). 155 | 156 | You can think of this function as partitioning the elements into two halves: 157 | those that satisfy `(predicate (funcall key element) target)` and those that 158 | don't, and then selecting the element on the RIGHT side of the split: 159 | 160 | satisfying not statisfying 161 | #(.......... ...............) 162 | ^ 163 | | 164 | result 165 | 166 | Two values will be returned: the element and its index. If every element 167 | satisfies the predicate `nil` will be returned for both values. 168 | 169 | Examples: 170 | 171 | ; index 172 | ; 0 1 2 3 4 5 val index 173 | (bisect-right '< #(1 3 5 7 7 9) 5) ; => 5, 2 174 | (bisect-right '<= #(1 3 5 7 7 9) 5) ; => 7, 3 175 | (bisect-right '<= #(1 3 5 7 7 9) 7) ; => 9, 5 176 | (bisect-right '< #(1 3 5 7 7 9) 10) ; => nil, nil 177 | (bisect-right '> #(9 8 8 8 1 0) 5) ; => 1, 4 178 | (bisect-right '< #((1) (2 2) (3 3 3)) 2 :key #'length) ; => (2 2), 1 179 | (bisect-right '<= #((1) (2 2) (3 3 3)) 2 :key #'length) ; => (3 3 3), 2 180 | 181 | " 182 | (if (>= start end) 183 | (values nil nil) 184 | (iterate 185 | (with bottom = (1- start)) 186 | (with top = (1- end)) 187 | (for index = (ceiling (+ bottom top) 2)) 188 | (for value = (aref vector index)) 189 | (for result = (funcall predicate (funcall key value) target)) 190 | (if (= top index) 191 | (return (if result 192 | (values nil nil) 193 | (values value index))) 194 | (if result 195 | (setf bottom index) 196 | (setf top index)))))) 197 | 198 | 199 | (defun vector-last (vector) 200 | "Return the last element of `vector`, or `nil` if it is empty. 201 | 202 | A second value is returned, which will be `t` if the vector was not empty and 203 | `nil` if it was. 204 | 205 | The vector's fill-pointer will be respected. 206 | 207 | " 208 | (let ((length (length vector))) 209 | (if (zerop length) 210 | (values nil nil) 211 | (values (aref vector (1- length)) t)))) 212 | 213 | -------------------------------------------------------------------------------- /src/astar.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.astar) 2 | 3 | (defstruct path 4 | state 5 | (estimate 0) 6 | (cost 0) 7 | (previous nil)) 8 | 9 | (defun path-to-list (path &aux result) 10 | (recursively ((path path)) 11 | (unless (null path) 12 | (push (path-state path) result) 13 | (recur (path-previous path)))) 14 | result) 15 | 16 | (defun-inlineable astar (&key start neighbors goalp cost heuristic test limit 17 | get-seen set-seen) 18 | "Search for a path from `start` to a goal using A★. 19 | 20 | The following parameters are all required: 21 | 22 | * `start`: the starting state. 23 | 24 | * `neighbors`: a function that takes a state and returns all states reachable 25 | from it. 26 | 27 | * `goalp`: a predicate that takes a state and returns whether it is a goal. 28 | 29 | * `cost`: a function that takes two states `a` and `b` and returns the cost 30 | to move from `a` to `b`. 31 | 32 | * `heuristic`: a function that takes a state and estimates the distance 33 | remaining to the goal. 34 | 35 | * `test`: an equality predicate for comparing nodes. It must be suitable for 36 | passing to `make-hash-table`. 37 | 38 | If the heuristic function is admissable (i.e. it never overestimates the 39 | remaining distance) the algorithm will find the shortest path. If you don't 40 | have a decent heuristic, just use `(constantly 0)` to degrade to Dijkstra. 41 | 42 | Note that `test` is required. The only sensible default would be `eql`, but 43 | if you were using states that need a different predicate and forgot to pass it 44 | the algorithm would end up blowing the heap, which is unpleasant. 45 | 46 | The following parameters are optional: 47 | 48 | * `limit`: a maximum cost. Any paths that exceed this cost will not be 49 | considered. 50 | 51 | * `set-seen`: a function that takes a state and a cost, and records it. 52 | If not provided a hash table will be used, but sometimes (depending on what 53 | your states are) it can be faster to store visited nodes more efficiently. 54 | 55 | * `get-seen`: a function that takes a state and retrieves the stored cost, or 56 | `nil` if the state has not been seen. 57 | 58 | " 59 | (let ((seen (unless get-seen (make-hash-table :test test))) 60 | (frontier (pileup:make-heap #'< :key #'path-estimate))) 61 | (labels ((set-seen% (path) 62 | (if set-seen 63 | (funcall set-seen (path-state path) (path-cost path)) 64 | (setf (gethash (path-state path) seen) (path-cost path)))) 65 | (get-seen% (state) 66 | (if get-seen 67 | (funcall get-seen state) 68 | (gethash state seen))) 69 | (push-path (path) 70 | (set-seen% path) 71 | (pileup:heap-insert path frontier))) 72 | (iterate 73 | (initially (push-path (make-path :state start))) 74 | 75 | (for (values current found) = (pileup:heap-pop frontier)) 76 | (unless found 77 | (return (values nil nil))) 78 | 79 | (for current-state = (path-state current)) 80 | 81 | (when (funcall goalp current-state) 82 | (return (values (path-to-list current) t))) 83 | 84 | (for current-cost = (path-cost current)) 85 | 86 | (iterate 87 | (for next-state :in (funcall neighbors current-state)) 88 | (for next-cost = (+ current-cost (funcall cost current-state next-state))) 89 | (for seen-cost = (get-seen% next-state)) 90 | (unless (and limit (> next-cost limit)) 91 | (when (or (null seen-cost) (< next-cost seen-cost)) 92 | (for next-estimate = (+ next-cost (funcall heuristic next-state))) 93 | (push-path (make-path :state next-state 94 | :cost next-cost 95 | :estimate next-estimate 96 | :previous current))))))))) 97 | -------------------------------------------------------------------------------- /src/base.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.base) 2 | 3 | (defun mkstr (&rest args) 4 | ;;; From On Lisp, page 58. 5 | (with-output-to-string (s) 6 | (dolist (a args) 7 | (princ a s)))) 8 | 9 | (defun symb (&rest args) 10 | ;;; From On Lisp, page 58. 11 | (values (intern (apply #'mkstr args)))) 12 | -------------------------------------------------------------------------------- /src/bits.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.bits) 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (defparameter *signed-add-docstring-template* 5 | "Perform ~D-bit signed addition of `x` and `y`. 6 | 7 | Returns two values: the result and a boolean specifying whether 8 | underflow/overflow occurred. 9 | 10 | ") 11 | 12 | (defparameter *signed-sub-docstring-template* 13 | "Perform ~D-bit signed subtraction of `x` and `y`. 14 | 15 | Returns two values: the result and a boolean specifying whether 16 | underflow/overflow occurred. 17 | 18 | ")) 19 | 20 | (macrolet 21 | ((define-ops (size) 22 | (let ((overflow (symb 'overflow- size))) 23 | `(progn 24 | (defun-inline ,overflow (value) 25 | (cond ((> value (1- (expt 2 ,(1- size)))) 26 | (values (- value (expt 2 ,size)) t)) 27 | ((< value (- (expt 2 ,(1- size)))) 28 | (values (+ value (expt 2 ,size)) t)) 29 | (t (values value nil)))) 30 | 31 | (defun-inlineable ,(symb '+/ size) (x y) 32 | ,(format nil *signed-add-docstring-template* size) 33 | (declare (optimize speed) 34 | (type (signed-byte ,size) x y)) 35 | (,overflow (+ x y))) 36 | 37 | (defun-inlineable ,(symb '-/ size) (x y) 38 | ,(format nil *signed-sub-docstring-template* size) 39 | (declare (optimize speed) 40 | (type (signed-byte ,size) x y)) 41 | (,overflow (- x y))))))) 42 | (define-ops 8) 43 | (define-ops 16) 44 | (define-ops 32) 45 | (define-ops 64)) 46 | 47 | -------------------------------------------------------------------------------- /src/chili-dogs.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.chili-dogs) 2 | 3 | (defmacro defun-inlineable (name &body body) 4 | "Like `defun-inline`, but declaims `name` to be `notinline` afterword. 5 | 6 | This is useful when you don't want to inline a function everywhere, but *do* 7 | want to have the ability to inline it on demand with (declare (inline ...)). 8 | 9 | " 10 | `(progn 11 | (declaim (inline ,name)) 12 | (defun ,name ,@body) 13 | (declaim (notinline ,name)) 14 | ',name)) 15 | 16 | (defmacro defun-inline (name args &body body) 17 | "Like `defun`, but declaims `name` to be `inline`." 18 | `(progn 19 | (declaim (inline ,name)) 20 | (defun ,name ,args ,@body) 21 | ',name)) 22 | 23 | -------------------------------------------------------------------------------- /src/clos.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.clos) 2 | 3 | (defun build-slot-definition (conc-name slot-spec) 4 | (destructuring-bind (name &rest slot-options) (ensure-list slot-spec) 5 | `(,name 6 | ,@(unless (getf slot-options :initarg) 7 | `(:initarg ,(alexandria:make-keyword name))) 8 | ,@(unless (or (getf slot-options :reader) 9 | (getf slot-options :writer) 10 | (getf slot-options :accessor)) 11 | `(:accessor ,(if conc-name 12 | (symb conc-name name) 13 | name))) 14 | ,@slot-options))) 15 | 16 | (defmacro defclass* (name-and-options direct-superclasses slots &rest options) 17 | "`defclass` without the tedium. 18 | 19 | This is like `defclass`, but the `:initarg` and `:accessor` slot options will 20 | automatically be filled in with sane values if they aren't given. 21 | 22 | `name-and-options` can be a symbol or a list, which will be destructured 23 | against `(name &key conc-name)`. 24 | 25 | " 26 | (destructuring-bind (name &key conc-name) 27 | (ensure-list name-and-options) 28 | `(defclass ,name ,direct-superclasses 29 | ,(mapcar (curry #'build-slot-definition conc-name) slots) 30 | ,@options))) 31 | 32 | (defmacro define-condition* (name-and-options direct-superclasses slots &rest options) 33 | "`define-condition` without the tedium. 34 | 35 | This is like `define-condition`, but the `:initarg` and `:accessor` slot 36 | options will automatically be filled in with sane values if they aren't given. 37 | 38 | `name-and-options` can be a symbol or a list, which will be destructured 39 | against `(name &key conc-name)`. 40 | 41 | " 42 | (destructuring-bind (name &key conc-name) 43 | (ensure-list name-and-options) 44 | `(define-condition ,name ,direct-superclasses 45 | ,(mapcar (curry #'build-slot-definition conc-name) slots) 46 | ,@options))) 47 | 48 | 49 | (defun slot-value-or (object slot &optional default) 50 | "Return the `slot-value` of `slot` in `object`, or `default` if unbound." 51 | (if (slot-boundp object slot) 52 | (slot-value object slot) 53 | default)) 54 | 55 | 56 | (defmacro ensure-slot-value (object slot &optional default) 57 | "Return the `slot-value` of `slot` in `object`, setting it to `default` if unbound." 58 | (alexandria:once-only (object slot) 59 | `(if (slot-boundp ,object ,slot) 60 | (slot-value ,object ,slot) 61 | (setf (slot-value ,object ,slot) ,default)))) 62 | -------------------------------------------------------------------------------- /src/control-flow.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.control-flow) 2 | 3 | (defmacro _ (expr &rest forms) 4 | "Thread the given forms, with `_` as a placeholder." 5 | ;; I am going to lose my fucking mind if I have to program lisp without 6 | ;; a threading macro, but I don't want to add another dep to this library, so 7 | ;; here we are. 8 | `(let* ((_ ,expr) 9 | ,@(mapcar (lambda (form) 10 | (if (symbolp form) 11 | `(_ (,form _)) 12 | `(_ ,form))) 13 | forms)) 14 | _)) 15 | 16 | (defmacro nest (&rest forms) 17 | "Thread the given forms, putting each as the body of the previous. 18 | 19 | Example: 20 | 21 | (nest (multiple-value-bind (a b c) (foo)) 22 | (when (and a b c)) 23 | (multiple-value-bind (d e f) (bar)) 24 | (when (and d e f)) 25 | (do-something)) 26 | 27 | macroexpands to: 28 | 29 | (multiple-value-bind (a b c) (foo) 30 | (when (and a b c) 31 | (multiple-value-bind (d e f) (bar) 32 | (when (and d e f) 33 | (do-something))))) 34 | 35 | " 36 | ;; thanks, Fare 37 | (reduce (lambda (prefix body) `(,@prefix ,body)) 38 | forms :from-end t)) 39 | 40 | 41 | (defmacro recursively (bindings &body body) 42 | "Execute `body` recursively, like Clojure's `loop`/`recur`. 43 | 44 | `bindings` should contain a list of symbols and (optional) starting values. 45 | 46 | In `body` the symbol `recur` will be bound to the function for recurring. 47 | 48 | This macro doesn't perform an explicit tail-recursion check like Clojure's 49 | `loop`. You know what you're doing, right? 50 | 51 | Example: 52 | 53 | (defun length (some-list) 54 | (recursively ((list some-list) 55 | (n 0)) 56 | (if (null list) 57 | n 58 | (recur (cdr list) (1+ n))))) 59 | 60 | " 61 | (flet ((extract-var (binding) 62 | (if (atom binding) binding (first binding))) 63 | (extract-val (binding) 64 | (if (atom binding) nil (second binding)))) 65 | `(labels ((recur ,(mapcar #'extract-var bindings) 66 | ,@body)) 67 | (recur ,@(mapcar #'extract-val bindings))))) 68 | 69 | 70 | (defmacro when-found ((var lookup-expr) &body body) 71 | "Perform `body` with `var` bound to the result of `lookup-expr`, when valid. 72 | 73 | `lookup-expr` should be an expression that returns two values, the first being 74 | the result (which will be bound to `var`) and the second indicating whether 75 | the lookup was successful. The standard `gethash` is an example of a function 76 | that behaves like this. 77 | 78 | If the lookup was successful, `body` will be executed and its value returned. 79 | 80 | Example: 81 | 82 | (multiple-value-bind (val found) (gethash :foo hash) 83 | (when found 84 | body)) 85 | 86 | ; becomes 87 | 88 | (when-found (val (gethash :foo hash)) 89 | body) 90 | 91 | " 92 | (with-gensyms (found) 93 | `(multiple-value-bind (,var ,found) ,lookup-expr 94 | ;; We could preserve and pass along the value of found as a secondary 95 | ;; return value from the form, but that would kill potential last-call 96 | ;; optimization (and the ability to return multiple values from `body`). 97 | (when ,found 98 | ,@body)))) 99 | 100 | (defmacro if-found ((var lookup-expr) then else) 101 | "Perform `then` or `else` depending on the results of `lookup-expr`. 102 | 103 | `lookup-expr` should be an expression that returns two values, the first being 104 | the result and the second indicating whether the lookup was successful. The 105 | standard `gethash` is an example of a function that behaves like this. 106 | 107 | If the lookup was successful, `then` will be executed with `var` bound to the 108 | result, and its value returned. 109 | 110 | Otherwise `else` will be executed and returned, without any extra bindings. 111 | 112 | Example: 113 | 114 | (multiple-value-bind (val found) (gethash :foo hash) 115 | (if found 116 | 'yes 117 | 'no)) 118 | 119 | ; becomes 120 | 121 | (if-found (val (gethash :foo hash)) 122 | 'yes 123 | 'no) 124 | 125 | " 126 | (with-gensyms (found result) 127 | `(multiple-value-bind (,result ,found) ,lookup-expr 128 | (if ,found 129 | (let ((,var ,result)) 130 | ,then) 131 | ,else)))) 132 | 133 | 134 | (defmacro gathering (&body body) 135 | "Run `body` to gather some things and return a fresh list of them. 136 | 137 | `body` will be executed with the symbol `gather` bound to a function of one 138 | argument. Once `body` has finished, a list of everything `gather` was called 139 | on will be returned. 140 | 141 | It's handy for pulling results out of code that executes procedurally and 142 | doesn't return anything, like `maphash` or Alexandria's `map-permutations`. 143 | 144 | The `gather` function can be passed to other functions, but should not be 145 | retained once the `gathering` form has returned (it would be useless to do so 146 | anyway). 147 | 148 | Examples: 149 | 150 | (gathering 151 | (dotimes (i 5) 152 | (gather i)) 153 | => 154 | (0 1 2 3 4) 155 | 156 | (gathering 157 | (mapc #'gather '(1 2 3)) 158 | (mapc #'gather '(a b))) 159 | => 160 | (1 2 3 a b) 161 | 162 | " 163 | (with-gensyms (result) 164 | `(let ((,result (make-queue))) 165 | (flet ((gather (item) 166 | (enqueue item ,result) 167 | item)) 168 | ,@body) 169 | (queue-contents ,result)))) 170 | 171 | (defmacro gathering-vector ((&key (size 16) (element-type t)) &body body) 172 | "Run `body` to gather some things and return a fresh vector of them. 173 | 174 | `body` will be executed with the symbol `gather` bound to a function of one 175 | argument. Once `body` has finished, a vector of everything `gather` was 176 | called on will be returned. This vector will be adjustable and have a fill 177 | pointer. 178 | 179 | It's handy for pulling results out of code that executes procedurally and 180 | doesn't return anything, like `maphash` or Alexandria's `map-permutations`. 181 | 182 | The `gather` function can be passed to other functions, but should not be 183 | retained once the `gathering` form has returned (it would be useless to do so 184 | anyway). 185 | 186 | Examples: 187 | 188 | (gathering-vector () 189 | (dotimes (i 5) 190 | (gather i)) 191 | => 192 | #(0 1 2 3 4) 193 | 194 | (gathering-vector () 195 | (mapc #'gather '(1 2 3)) 196 | (mapc #'gather '(a b))) 197 | => 198 | #(1 2 3 a b) 199 | 200 | " 201 | (with-gensyms (result) 202 | `(let ((,result (make-array ,size :adjustable t :fill-pointer 0 203 | :element-type ,element-type))) 204 | (flet ((gather (item) 205 | (vector-push-extend item ,result) 206 | item)) 207 | ,@body) 208 | ,result))) 209 | 210 | 211 | (defmacro when-let (bindings &body body) 212 | "Bind `bindings` in parallel and execute `body`, short-circuiting on `nil`. 213 | 214 | This macro combines `when` and `let`. It takes a list of bindings and binds 215 | them like `let` before executing `body`, but if any binding's value evaluates 216 | to `nil` the process stops there and `nil` is immediately returned. 217 | 218 | Examples: 219 | 220 | (when-let ((a (progn (print :a) 1)) 221 | (b (progn (print :b) 2)) 222 | (c (progn (print :c) 3))) 223 | (list a b c)) 224 | ; => 225 | :A 226 | :B 227 | :C 228 | (1 2 3) 229 | 230 | (when-let ((a (progn (print :a) 1)) 231 | (b (progn (print :b) nil)) 232 | (c (progn (print :c) 3))) 233 | (list a b c)) 234 | ; => 235 | :A 236 | :B 237 | NIL 238 | 239 | " 240 | ;; (when-let ((a 1) 241 | ;; (b 2)) 242 | ;; (+ a b)) 243 | ;; => 244 | ;; (BLOCK #:BLOCK632 245 | ;; (LET ((A (OR 1 (RETURN-FROM #:BLOCK632))) 246 | ;; (B (OR 2 (RETURN-FROM #:BLOCK632)))) 247 | ;; (+ A B))) 248 | (with-gensyms (block) 249 | `(block ,block 250 | (let (,@(loop :for (symbol value) :in bindings 251 | :collect `(,symbol (or ,value (return-from ,block))))) 252 | ,@body)))) 253 | 254 | (defmacro when-let* (bindings &body body) 255 | "Bind `bindings` sequentially and execute `body`, short-circuiting on `nil`. 256 | 257 | This macro combines `when` and `let*`. It takes a list of bindings and binds 258 | them like `let` before executing `body`, but if any binding's value evaluates 259 | to `nil` the process stops there and `nil` is immediately returned. 260 | 261 | Examples: 262 | 263 | (when-let* ((a (progn (print :a) 1)) 264 | (b (progn (print :b) 2)) 265 | (c (progn (print :c) 3))) 266 | (list a b c)) 267 | ; => 268 | :A 269 | :B 270 | :C 271 | (1 2 3) 272 | 273 | (when-let* ((a (progn (print :a) 1)) 274 | (b (progn (print :b) nil)) 275 | (c (progn (print :c) 3))) 276 | (list a b c)) 277 | ; => 278 | :A 279 | :B 280 | NIL 281 | 282 | " 283 | ;; (when-let* ((a 1) 284 | ;; (b 2)) 285 | ;; (+ a b)) 286 | ;; => 287 | ;; (BLOCK #:BLOCK647 288 | ;; (LET* ((A (OR 1 (RETURN-FROM #:BLOCK647))) 289 | ;; (B (OR 2 (RETURN-FROM #:BLOCK647)))) 290 | ;; (+ A B))) 291 | (with-gensyms (block) 292 | `(block ,block 293 | (let* (,@(loop :for (symbol value) :in bindings 294 | :collect `(,symbol (or ,value (return-from ,block))))) 295 | ,@body)))) 296 | 297 | (defmacro if-let (bindings &body body) 298 | "Bind `bindings` in parallel and execute `then` if all are true, or `else` otherwise. 299 | 300 | `body` must be of the form `(...optional-declarations... then else)`. 301 | 302 | This macro combines `if` and `let`. It takes a list of bindings and binds 303 | them like `let` before executing the `then` branch of `body`, but if any 304 | binding's value evaluates to `nil` the process stops there and the `else` 305 | branch is immediately executed (with no bindings in effect). 306 | 307 | If any `optional-declarations` are included they will only be in effect for 308 | the `then` branch. 309 | 310 | Examples: 311 | 312 | (if-let ((a (progn (print :a) 1)) 313 | (b (progn (print :b) 2)) 314 | (c (progn (print :c) 3))) 315 | (list a b c) 316 | 'nope) 317 | ; => 318 | :A 319 | :B 320 | :C 321 | (1 2 3) 322 | 323 | (if-let ((a (progn (print :a) 1)) 324 | (b (progn (print :b) nil)) 325 | (c (progn (print :c) 3))) 326 | (list a b c) 327 | 'nope) 328 | ; => 329 | :A 330 | :B 331 | NOPE 332 | 333 | " 334 | (with-gensyms (outer inner) 335 | (multiple-value-bind (body declarations) (alexandria:parse-body body) 336 | (destructuring-bind (then else) body 337 | `(block ,outer 338 | (block ,inner 339 | (let ,(loop :for (symbol value) :in bindings 340 | :collect `(,symbol (or ,value (return-from ,inner)))) 341 | ,@declarations 342 | (return-from ,outer ,then))) 343 | ,else))))) 344 | 345 | (defmacro if-let* (bindings &body body) 346 | "Bind `bindings` sequentially and execute `then` if all are true, or `else` otherwise. 347 | 348 | `body` must be of the form `(...optional-declarations... then else)`. 349 | 350 | This macro combines `if` and `let*`. It takes a list of bindings and binds 351 | them like `let*` before executing the `then` branch of `body`, but if any 352 | binding's value evaluate to `nil` the process stops there and the `else` 353 | branch is immediately executed (with no bindings in effect). 354 | 355 | If any `optional-declarations` are included they will only be in effect for 356 | the `then` branch. 357 | 358 | Examples: 359 | 360 | (if-let* ((a (progn (print :a) 1)) 361 | (b (progn (print :b) 2)) 362 | (c (progn (print :c) 3))) 363 | (list a b c) 364 | 'nope) 365 | ; => 366 | :A 367 | :B 368 | :C 369 | (1 2 3) 370 | 371 | (if-let* ((a (progn (print :a) 1)) 372 | (b (progn (print :b) nil)) 373 | (c (progn (print :c) 3))) 374 | (list a b c) 375 | 'nope) 376 | ; => 377 | :A 378 | :B 379 | NOPE 380 | 381 | " 382 | (with-gensyms (outer inner) 383 | (multiple-value-bind (body declarations) (alexandria:parse-body body) 384 | (destructuring-bind (then else) body 385 | `(block ,outer 386 | (block ,inner 387 | (let* ,(loop :for (symbol value) :in bindings 388 | :collect `(,symbol (or ,value (return-from ,inner)))) 389 | ,@declarations 390 | (return-from ,outer ,then))) 391 | ,else))))) 392 | 393 | 394 | (defmacro multiple-value-bind* (bindings &body body) 395 | "Bind each pair in `bindings` with `multiple-value-bind` sequentially. 396 | 397 | Example: 398 | 399 | (multiple-value-bind* 400 | (((a b) (values 0 1)) 401 | ((c) (values (1+ b))) 402 | (list a b c)) 403 | ; => 404 | ; (0 1 2) 405 | 406 | From https://github.com/phoe/m-m-v-b 407 | 408 | " 409 | (if (null bindings) 410 | `(progn ,@body) 411 | (destructuring-bind ((vars form) &rest bindings) bindings 412 | `(multiple-value-bind ,vars ,form 413 | (multiple-value-bind* ,bindings ,@body))))) 414 | 415 | 416 | (defmacro do-repeat (n &body body) 417 | "Perform `body` `n` times." 418 | `(dotimes (,(gensym) ,n) 419 | ,@body)) 420 | 421 | (defmacro do-vector 422 | ((var-or-vars vector &key (start nil start?) (end nil end?)) &body body) 423 | "Iterate over `vector`, performing `body` with `var-or-vars` bound. 424 | 425 | `var-or-vars` can be one of the following: 426 | 427 | * `value-symbol` 428 | * `(value-symbol)` 429 | * `(index-symbol value-symbol)` 430 | 431 | Successive elements of `vector` will be bound to `value-symbol` while `body` 432 | is executed. If `index-symbol` is given, the current index will be bound to 433 | it. 434 | 435 | Returns `nil`. 436 | 437 | " 438 | (setf var-or-vars (alexandria:ensure-list var-or-vars) 439 | start (if start? start 0)) 440 | (alexandria:once-only (vector start) 441 | (let ((i nil) 442 | (v nil) 443 | (end% (gensym "END"))) 444 | (ecase (length var-or-vars) 445 | (1 (setf i (gensym "I") 446 | v (first var-or-vars))) 447 | (2 (setf i (first var-or-vars) 448 | v (second var-or-vars)))) 449 | `(do ((,end% ,(if end? end `(length ,vector))) 450 | (,i ,start (1+ ,i))) 451 | ((>= ,i ,end%)) 452 | (let ((,v (aref ,vector ,i))) 453 | ,@body))))) 454 | 455 | (defmacro do-range (ranges &body body) 456 | "Perform `body` on the given `ranges`. 457 | 458 | Each range in `ranges` should be of the form `(variable from below)`. During 459 | iteration `body` will be executed with `variable` bound to successive values 460 | in the range [`from`, `below`). 461 | 462 | `from` can be larger than `below`, in which case the values will be stepped 463 | down instead of up. 464 | 465 | If multiple ranges are given they will be iterated in a nested fashion. 466 | 467 | Example: 468 | 469 | (do-range ((x 0 6 2) 470 | (y 12 10)) 471 | (pr x y)) 472 | ; => 473 | ; 0 12 474 | ; 0 11 475 | ; 2 12 476 | ; 2 11 477 | ; 4 12 478 | ; 4 11 479 | 480 | " 481 | (assert (not (null ranges)) () 482 | "Ranges to iterate in DO-RANGE must not be null.") 483 | (recursively ((ranges ranges)) 484 | (if (null ranges) 485 | `(progn ,@body) 486 | (destructuring-bind (var from to &optional by) (first ranges) 487 | (with-gensyms (cmp) 488 | (once-only (from to by) 489 | `(do ((,cmp (if ,by 490 | (if (minusp ,by) #'<= #'>=) 491 | (if (< ,from ,to) #'>= #'<=))) 492 | (,by (or ,by (if (< ,from ,to) 1 -1))) 493 | (,var ,from (+ ,var ,by))) 494 | ((funcall ,cmp ,var ,to)) 495 | ,(recur (rest ranges))))))))) 496 | 497 | (defmacro do-irange (ranges &body body) 498 | "Perform `body` on the given inclusive `ranges`. 499 | 500 | Each range in `ranges` should be of the form `(variable from to &optional by)`. 501 | During iteration `body` will be executed with `variable` bound to successive 502 | values according to `by` in the range [`from`, `to`]. 503 | 504 | `from` can be larger than `to`, in which case the values will be stepped down 505 | instead of up. 506 | 507 | If multiple ranges are given they will be iterated in a nested fashion. 508 | 509 | Example: 510 | 511 | (do-irange ((x 0 4 2) 512 | (y 11 10)) 513 | (pr x y)) 514 | ; => 515 | ; 0 11 516 | ; 0 10 517 | ; 2 11 518 | ; 2 10 519 | ; 4 11 520 | ; 4 10 521 | 522 | " 523 | (assert (not (null ranges)) () 524 | "Ranges to iterate in DO-RANGE must not be null.") 525 | (recursively ((ranges ranges)) 526 | (if (null ranges) 527 | `(progn ,@body) 528 | (destructuring-bind (var from to &optional by) (first ranges) 529 | (with-gensyms (cmp) 530 | (once-only (from to by) 531 | `(do ((,cmp (if ,by 532 | (if (minusp ,by) #'< #'>) 533 | (if (< ,from ,to) #'> #'<))) 534 | (,by (or ,by (if (< ,from ,to) 1 -1))) 535 | (,var ,from (+ ,var ,by))) 536 | ((funcall ,cmp ,var ,to)) 537 | ,(recur (rest ranges))))))))) 538 | 539 | 540 | (let ((eof (gensym "EOF"))) 541 | (defmacro do-file 542 | ((symbol path &rest open-options &key (reader '#'read-line) &allow-other-keys) 543 | &body body) 544 | "Iterate over the contents of `file` using `reader`. 545 | 546 | During iteration, `symbol` will be set to successive values read from the 547 | file by `reader`. 548 | 549 | `reader` can be any function that conforms to the usual reading interface, 550 | i.e. anything that can handle `(read-foo stream eof-error-p eof-value)`. 551 | 552 | Any keyword arguments other than `:reader` will be passed along to `open`. 553 | 554 | If `nil` is used for one of the `:if-…` options to `open` and this results 555 | in `open` returning `nil`, no iteration will take place. 556 | 557 | An implicit block named `nil` surrounds the iteration, so `return` can be 558 | used to terminate early. 559 | 560 | Returns `nil`. 561 | 562 | Examples: 563 | 564 | (do-file (line \"foo.txt\") 565 | (print line)) 566 | 567 | (do-file (form \"foo.lisp\" :reader #'read :external-format :EBCDIC-US) 568 | (when (eq form :stop) 569 | (return :stopped-early)) 570 | (print form)) 571 | 572 | (do-file (line \"does-not-exist.txt\" :if-does-not-exist nil) 573 | (this-will-not-be-executed)) 574 | 575 | " 576 | (let ((open-options (alexandria:remove-from-plist open-options :reader))) 577 | (with-gensyms (stream) 578 | (once-only (path reader) 579 | `(when-let ((,stream (open ,path :direction :input ,@open-options))) 580 | (unwind-protect 581 | (do ((,symbol 582 | (funcall ,reader ,stream nil ',eof) 583 | (funcall ,reader ,stream nil ',eof))) 584 | ((eq ,symbol ',eof)) 585 | ,@body) 586 | (close ,stream)))))))) 587 | -------------------------------------------------------------------------------- /src/debugging.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.debugging) 2 | 3 | (defun pr (&rest args) 4 | "Print `args` readably, separated by spaces and followed by a newline. 5 | 6 | Returns the first argument, so you can just wrap it around a form without 7 | interfering with the rest of the program. 8 | 9 | This is what `print` should have been. 10 | 11 | " 12 | (format t "~{~S~^ ~}~%" args) 13 | (finish-output) 14 | (first args)) 15 | 16 | (defmacro prl (&rest args) 17 | "Print `args` labeled and readably. 18 | 19 | Each argument form will be printed, then evaluated and the result printed. 20 | One final newline will be printed after everything. 21 | 22 | Returns the last result. 23 | 24 | Examples: 25 | 26 | (let ((i 1) 27 | (l (list 1 2 3))) 28 | (prl i (second l))) 29 | ; => 30 | i 1 31 | (second l) 2 32 | 33 | " 34 | `(prog1 35 | (progn ,@(mapcar (lambda (arg) 36 | (with-gensyms (a) 37 | `(let ((,a ,arg)) 38 | (pr ',arg ,a) 39 | ,a))) 40 | args)) 41 | (terpri) 42 | (finish-output))) 43 | 44 | (defun phr () 45 | "Print a horizontal rule to aid in visual debugging." 46 | (pr "-----------------------------------------------------------------------")) 47 | 48 | 49 | (defun bits (&optional (n *) (size 8) (stream t)) 50 | "Print the bits of the `size`-bit two's complement integer `n` to `stream`. 51 | 52 | Examples: 53 | 54 | (bits 5 10) 55 | => 0000000101 56 | 57 | (bits -5 10) 58 | => 1111111011 59 | 60 | " 61 | ;; http://blog.chaitanyagupta.com/2013/10/print-bit-representation-of-signed.html 62 | (format stream (format nil "~~~D,'0B" size) (ldb (byte size 0) n))) 63 | 64 | (defun hex (&optional (thing *) (stream t)) 65 | "Print the `thing` to `stream` with numbers in base 16. 66 | 67 | Examples: 68 | 69 | (hex 255) 70 | => FF 71 | 72 | (hex #(0 128)) 73 | => #(0 80) 74 | 75 | " 76 | (let ((*print-base* 16)) 77 | (case stream 78 | ((nil) (prin1-to-string thing)) 79 | ((t) (prin1 thing stream) (terpri stream) nil) 80 | (otherwise (prin1 thing stream) (terpri stream) nil)))) 81 | 82 | (defmacro shut-up (&body body) 83 | "Run `body` with stdout and stderr redirected to the void." 84 | `(let ((*standard-output* (make-broadcast-stream)) 85 | (*error-output* (make-broadcast-stream))) 86 | ,@body)) 87 | 88 | (defmacro dis (&body body) 89 | "Disassemble the code generated for a `lambda` with `arglist` and `body`. 90 | 91 | It will also spew compiler notes so you can see why the garbage box isn't 92 | doing what you think it should be doing. 93 | 94 | " 95 | (let ((%disassemble #+sbcl 'sb-disassem:disassemble-code-component 96 | #-sbcl 'disassemble)) 97 | (destructuring-bind (arglist &body body) 98 | (iterate (for b :first body :then (cdr b)) 99 | (while (not (listp (car b)))) 100 | (finally (return b))) 101 | `(,%disassemble (compile nil '(lambda ,arglist 102 | (declare (optimize speed)) 103 | ,@body)))))) 104 | 105 | (defmacro comment (&body body) 106 | "Do nothing with a bunch of forms. 107 | 108 | Handy for block-commenting multiple expressions. 109 | 110 | " 111 | (declare (ignore body)) 112 | nil) 113 | 114 | 115 | (defun aesthetic-string (thing) 116 | "Return the string used to represent `thing` when printing aesthetically." 117 | (format nil "~A" thing)) 118 | 119 | (defun structural-string (thing) 120 | "Return the string used to represent `thing` when printing structurally." 121 | (format nil "~S" thing)) 122 | 123 | (defun print-table (rows) 124 | "Print `rows` as a nicely-formatted table. 125 | 126 | Each row should have the same number of colums. 127 | 128 | Columns will be justified properly to fit the longest item in each one. 129 | 130 | Example: 131 | 132 | (print-table '((1 :red something) 133 | (2 :green more))) 134 | => 135 | 1 | RED | SOMETHING 136 | 2 | GREEN | MORE 137 | 138 | " 139 | (when rows 140 | (iterate 141 | (with column-sizes = 142 | (reduce (curry #'mapcar #'max) 143 | (mapcar (curry #'mapcar (compose #'length #'aesthetic-string)) 144 | rows))) ; lol 145 | (for row :in rows) 146 | (format t "~{~vA~^ | ~}~%" (mapcan #'list column-sizes row)))) 147 | (values)) 148 | 149 | 150 | (defun pretty-print-hash-table (*standard-output* ht) 151 | (pprint-logical-block 152 | (*standard-output* (hash-table-contents ht) :prefix "{" :suffix "}") 153 | (pprint-exit-if-list-exhausted) 154 | (loop (destructuring-bind (k v) (pprint-pop) 155 | (write k) 156 | (write-string ": ") 157 | (write v) 158 | (pprint-exit-if-list-exhausted) 159 | (write-string ", ") 160 | (pprint-newline :linear))))) 161 | 162 | 163 | (set-pprint-dispatch 'hash-table 'pretty-print-hash-table) 164 | 165 | 166 | #+sbcl 167 | (defun dump-profile (filename) 168 | (with-open-file (*standard-output* filename 169 | :direction :output 170 | :if-exists :supersede) 171 | (sb-sprof:report :type :graph 172 | :sort-by :cumulative-samples 173 | :sort-order :ascending) 174 | (sb-sprof:report :type :flat 175 | :min-percent 0.5))) 176 | 177 | #+sbcl 178 | (defun start-profiling (&key call-count-packages (mode :cpu)) 179 | "Start profiling performance. SBCL only. 180 | 181 | `call-count-packages` should be a list of package designators. Functions in 182 | these packages will have their call counts recorded via 183 | `sb-sprof::profile-call-counts`. 184 | 185 | " 186 | (sb-sprof::reset) 187 | (_ call-count-packages 188 | (mapcar #'mkstr _) 189 | (mapcar #'string-upcase _) 190 | (mapc #'sb-sprof::profile-call-counts _)) 191 | (sb-sprof::start-profiling :max-samples 50000 192 | :mode mode 193 | ; :mode :time 194 | :sample-interval 0.01 195 | :threads :all)) 196 | 197 | #+sbcl 198 | (defun stop-profiling (&optional (filename "lisp.prof")) 199 | "Stop profiling performance and dump a report to `filename`. SBCL only." 200 | (sb-sprof::stop-profiling) 201 | (dump-profile filename)) 202 | 203 | #+sbcl 204 | (defmacro profile (form &key (mode :cpu)) 205 | "Profile `form` and dump the report to `lisp.prof`." 206 | `(progn 207 | (start-profiling :mode ,mode) 208 | (unwind-protect 209 | (time ,form) 210 | (stop-profiling)))) 211 | 212 | (defmacro profile-when (condition &body body) 213 | "Evaluate and return `body`, profiling when `condition` is true." 214 | (with-gensyms (thunk) 215 | `(flet ((,thunk () ,@body)) 216 | (if ,condition 217 | (profile (,thunk)) 218 | (,thunk))))) 219 | 220 | 221 | (defmacro timing ((&key (time :run) (result-type 'integer)) &body body) 222 | "Execute `body`, discard its result, and return the time taken. 223 | 224 | `time` must be one of `:run` or `:real`. 225 | 226 | `result-type` must be `integer` (which will return internal time units) or 227 | `rational`/`single-float`/`double-float` (which will return seconds). 228 | 229 | " 230 | (with-gensyms (start end result) 231 | `(let ((,start ,(ecase time 232 | (:run '(get-internal-run-time)) 233 | (:real '(get-internal-real-time))))) 234 | (progn ,@body) 235 | (let* ((,end ,(ecase time 236 | (:run '(get-internal-run-time)) 237 | (:real '(get-internal-real-time)))) 238 | (,result (- ,end ,start))) 239 | ,(ecase result-type 240 | (integer `,result) 241 | (rational `(/ ,result internal-time-units-per-second)) 242 | (single-float `(coerce (/ ,result internal-time-units-per-second) 'single-float)) 243 | (double-float `(coerce (/ ,result internal-time-units-per-second) 'double-float))))))) 244 | 245 | 246 | (defmacro gimme (n &body body) 247 | `(iterate (repeat ,n) 248 | (collect (progn ,@body)))) 249 | 250 | 251 | -------------------------------------------------------------------------------- /src/eldritch-horrors.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.eldritch-horrors) 2 | 3 | (defmacro with-flexible-accessors (slot-entries instance-form &rest body) 4 | (with-gensyms (instance) 5 | `(let ((,instance ,instance-form)) 6 | (declare (ignorable ,instance)) 7 | (symbol-macrolet 8 | ,(iterate (for (symbol accessor) :in slot-entries) 9 | (collect `(,symbol (,accessor ,instance)))) 10 | ,@body)))) 11 | 12 | (defmacro define-with-macro (type-and-options &rest slots) 13 | "Define a with-`type` macro for the given `type` and `slots`. 14 | 15 | This new macro wraps `with-accessors` so you don't have to type `type-` 16 | a billion times. 17 | 18 | The given `type` must be a symbol naming a struct or class. It must have the 19 | appropriate accessors with names exactly of the form `type`-`slot`. 20 | 21 | The defined macro will look something like this: 22 | 23 | (define-with-macro foo a b) 24 | => 25 | (defmacro with-foo ((foo &optional (a-symbol 'a) (b-symbol 'b)) 26 | &body body) 27 | `(with-accessors ((,a-symbol foo-a) (,b-symbol foo-b)) 28 | ,foo 29 | ,@body)) 30 | 31 | There's a lot of magic here, but it cuts down on boilerplate for simple things 32 | quite a lot. 33 | 34 | Example: 35 | 36 | (defstruct foo x y) 37 | (define-with-macro foo x y) 38 | 39 | (defparameter *f* (make-foo :x 10 :y 20)) 40 | (defparameter *g* (make-foo :x 555 :y 999)) 41 | 42 | (with-foo (*f*) 43 | (with-foo (*g* gx gy) 44 | (print (list x y gx gy)))) 45 | => 46 | (10 20 555 999) 47 | 48 | " 49 | (destructuring-bind (type &key conc-name) 50 | (ensure-list type-and-options) 51 | (let* ((accessors (loop :for slot :in slots 52 | :collect (if conc-name (symb conc-name slot) slot))) 53 | (symbol-args (loop :for slot :in slots 54 | :collect (symb slot '-symbol))) 55 | (macro-name (symb 'with- type)) 56 | (macro-arglist `((,type &optional 57 | ,@(loop :for slot :in slots 58 | :for arg :in symbol-args 59 | :collect `(,arg ',slot))) 60 | &body body)) 61 | (accessor-binding-list (loop :for arg :in symbol-args 62 | :for accessor :in accessors 63 | :collect ``(,,arg ,',accessor)))) 64 | `(defmacro ,macro-name ,macro-arglist 65 | `(with-flexible-accessors ,,`(list ,@accessor-binding-list) 66 | ,,type 67 | ,@body))))) 68 | 69 | 70 | (defmacro eval-dammit (&body body) 71 | "Just evaluate `body` all the time, jesus christ lisp." 72 | `(eval-when (:compile-toplevel :load-toplevel :execute) ,@body)) 73 | 74 | 75 | (defmacro scratch% (&body forms) 76 | (assert (not (null forms)) () "Malformed scratch block, missing final expr.") 77 | (destructuring-bind (head . forms) forms 78 | (cond 79 | ((null forms) head) 80 | ((eql head :mv) (destructuring-bind (symbols expr . forms) forms 81 | `(multiple-value-bind ,symbols ,expr 82 | (scratch% ,@forms)))) 83 | ((eql head :db) (destructuring-bind (bindings expr . forms) forms 84 | `(destructuring-bind ,bindings ,expr 85 | (scratch% ,@forms)))) 86 | ((symbolp head) (destructuring-bind (expr . forms) forms 87 | `(let ((,head ,expr)) 88 | (scratch% ,@forms)))) 89 | (t `(progn ,head (scratch% ,@forms)))))) 90 | 91 | 92 | (defmacro scratch (&body forms) 93 | "Evaluate `forms` in an imperative fashion. 94 | 95 | Each expression in `forms` will be evaluated, with the following exceptions: 96 | 97 | * A bare symbol will be bound via (nested) `let` to the next expression. 98 | * `:mv` will bind the next expression (which must be a list of symbols) to the 99 | expression after it with `multiple-value-bind`. 100 | * `:db` will bind the next expression (which must be a valid binding) to the 101 | expression after it with `destructuring-bind`. 102 | 103 | Example: 104 | 105 | (scratch 106 | a 10 107 | b 20 108 | c (+ a b) 109 | :mv (d e) (truncate 100 23) 110 | :db (f (g)) (list 100 (list 22)) 111 | (+ a (- b c) d e (* f g))) 112 | 113 | " 114 | ;; Similar to `bb` described here: 115 | ;; https://blog.rongarret.info/2023/01/lisping-at-jpl-revisited.html 116 | `(block nil (scratch% ,@forms))) 117 | 118 | -------------------------------------------------------------------------------- /src/functions.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.functions) 2 | 3 | (defun juxt (&rest functions) 4 | "Return a function that will juxtapose the results of `functions`. 5 | 6 | This is like Clojure's `juxt`. Given functions `(f0 f1 ... fn)`, this will 7 | return a new function which, when called with some arguments, will return 8 | `(list (f0 ...args...) (f1 ...args...) ... (fn ...args...))`. 9 | 10 | Example: 11 | 12 | (funcall (juxt #'list #'+ #'- #'*) 1 2) 13 | => ((1 2) 3 -1 2) 14 | 15 | " 16 | (lambda (&rest args) 17 | (mapcar (rcurry #'apply args) functions))) 18 | 19 | (defun nullary (function &optional result) 20 | "Return a new function that acts as a nullary-patched version of `function`. 21 | 22 | The new function will return `result` when called with zero arguments, and 23 | delegate to `function` otherwise. 24 | 25 | Examples: 26 | 27 | (max 1 10 2) ; => 10 28 | (max) ; => invalid number of arguments 29 | 30 | (funcall (nullary #'max)) ; => nil 31 | (funcall (nullary #'max 0)) ; => 0 32 | (funcall (nullary #'max 0) 1 10 2) ; => 10 33 | 34 | (reduce #'max nil) ; => invalid number of arguments 35 | (reduce (nullary #'max) nil) ; => nil 36 | (reduce (nullary #'max :empty) nil) ; => :empty 37 | (reduce (nullary #'max) '(1 10 2)) ; => 10 38 | 39 | " 40 | (lambda (&rest args) 41 | (if (null args) result (apply function args)))) 42 | 43 | (defun fixed-point (function data &key (test 'eql) (limit nil)) 44 | "Find a fixed point of `function`, starting with `data`. 45 | 46 | Successive runs of `function` will be compared with `test`. Once `test` 47 | returns true the last result will be returned. 48 | 49 | `limit` can be an integer to limit the maximum number of iterations performed. 50 | 51 | A second value is also returned: `t` if a fixed point was found or `nil` if 52 | the iteration limit was reached. 53 | 54 | " 55 | (if (and limit (zerop limit)) 56 | (values data nil) 57 | (let ((next (funcall function data))) 58 | (if (funcall test data next) 59 | (values next t) 60 | (fixed-point function next :test test :limit (when limit (1- limit))))))) 61 | 62 | -------------------------------------------------------------------------------- /src/gnuplot.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.gnuplot) 2 | 3 | ;;; This very spartan gnuplot interface is inspired by the advice in Gnuplot in 4 | ;;; Action (second edition) specifically the section "Thought for the design of 5 | ;;; a gnuplot access layer" on page 253. 6 | 7 | 8 | ;;;; State -------------------------------------------------------------------- 9 | (defparameter *gnuplot-path* "gnuplot") 10 | (defparameter *gnuplot-process* nil) 11 | 12 | 13 | ;;;; Data Printers ------------------------------------------------------------ 14 | (defun gnuplot-data-sequence% (sequence s) 15 | (map nil (lambda (row) 16 | (map nil (lambda (val) 17 | (princ val s) 18 | (princ #\tab s)) 19 | row) 20 | (terpri s)) 21 | sequence)) 22 | 23 | (defun gnuplot-data-alist% (alist s) 24 | (loop :for (k . v) :in alist :do 25 | (princ k s) 26 | (princ #\tab s) 27 | (princ v s) 28 | (terpri s))) 29 | 30 | (defun gnuplot-data-matrix% (matrix s) 31 | (destructuring-bind (rows cols) (array-dimensions matrix) 32 | (dotimes (r rows) 33 | (dotimes (c cols) 34 | (princ (aref matrix r c) s) 35 | (princ #\tab s)) 36 | (terpri s)))) 37 | 38 | 39 | ;;;; Basic API ---------------------------------------------------------------- 40 | (defmacro with-gnuplot (options &body body) 41 | (assert (null options)) 42 | `(let ((*gnuplot-process* 43 | (external-program:start *gnuplot-path* '() :input :stream :output t))) 44 | (unwind-protect (progn ,@body *gnuplot-process*) 45 | (close (external-program:process-input-stream *gnuplot-process*))))) 46 | 47 | (defun gnuplot-data (identifier data &aux (s (external-program:process-input-stream *gnuplot-process*))) 48 | "Bind `identifier` to `data` inside the currently-running gnuplot process. 49 | 50 | `identifier` must be a string of the form `$foo`. 51 | 52 | `data` must be one of the following: a sequence of sequences of data points, 53 | an alist of data points, or a 2D array of data points. 54 | 55 | Must be called from inside `with-gnuplot`. 56 | 57 | " 58 | (assert (not (null *gnuplot-process*)) () "~A must be called inside ~S" 'gnuplot-data 'with-gnuplot) 59 | (check-type identifier string) 60 | (assert (char= #\$ (char identifier 0))) 61 | (format s "~A << EOD~%" identifier) 62 | (etypecase data 63 | ((array * (* *)) (gnuplot-data-matrix% data s)) 64 | ((cons (cons t (not cons))) (gnuplot-data-alist% data s)) 65 | (sequence (gnuplot-data-sequence% data s))) 66 | (format s "EOD~%")) 67 | 68 | (defun gnuplot-format (format-string &rest args &aux (s (external-program:process-input-stream *gnuplot-process*))) 69 | "Send a `cl:format`ed string to the currently-running gnuplot process. 70 | 71 | Must be called from inside `with-gnuplot`. 72 | 73 | " 74 | (assert (not (null *gnuplot-process*)) () "~A must be called inside ~S" 'gnuplot-format 'with-gnuplot) 75 | (apply #'format s format-string args) 76 | (terpri s)) 77 | 78 | (defun gnuplot-command (command &aux (s (external-program:process-input-stream *gnuplot-process*))) 79 | "Send the string `command` to the currently-running gnuplot process. 80 | 81 | Must be called from inside `with-gnuplot`. 82 | 83 | " 84 | (assert (not (null *gnuplot-process*)) () "~A must be called inside ~S" 'gnuplot-command 'with-gnuplot) 85 | (write-line command s)) 86 | 87 | (defun gnuplot (data commands) 88 | "Graph `data` with gnuplot using `commands`. 89 | 90 | `data` must be an alist of `(identifier . data)` pairs. 91 | 92 | Each `identifier` must be a string of the form `$foo`. Each `data` must be 93 | one of the following: a sequence of sequences of data points, an alist of data 94 | points, or a 2D array of data points. 95 | 96 | `commands` must be a string or a sequence of strings. 97 | 98 | Example: 99 | 100 | (gnuplot `((\"$data\" . ,foo-data)) \" 101 | @xrfc3339 102 | set terminal qt 103 | plot $data using 1:2 with linespoints 104 | pause mouse close 105 | \") 106 | 107 | " 108 | (with-gnuplot () 109 | (dolist (d data) 110 | (gnuplot-data (car d) (cdr d))) 111 | (etypecase commands 112 | (string (gnuplot-command commands)) 113 | (sequence (map nil #'gnuplot-command commands))))) 114 | 115 | 116 | ;;;; Convenience Wrappers ----------------------------------------------------- 117 | (defun plot (data &key (style :linespoints) (file "plot.pdf") (logscale nil)) 118 | "Plot `data` with gnuplot. 119 | 120 | Convenience wrapper around the gnuplot functions. This is only intended for 121 | REPL-driven experimentation — if you want any customization you should use the 122 | gnuplot interface instead. 123 | 124 | " 125 | (with-gnuplot () 126 | (gnuplot-data "$data" data) 127 | (gnuplot-format "set terminal pdfcairo size 10in, 8in 128 | set output '~A'" 129 | file) 130 | (when logscale 131 | (gnuplot-format "set logscale y")) 132 | (gnuplot-format "plot $data using 1:2 with ~A" (string-downcase (symbol-name style))))) 133 | -------------------------------------------------------------------------------- /src/hash-sets.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.hash-sets) 2 | 3 | (defstruct (hash-set (:constructor make-hash-set%) 4 | (:copier nil)) 5 | (storage (error "Required") :type hash-table)) 6 | 7 | (defmethod print-object ((hset hash-set) stream) 8 | (print-unreadable-object (hset stream :type t :identity t) 9 | (format stream "~:S" (hset-elements hset)))) 10 | 11 | 12 | (defun make-hash-set (&key (test 'eql) (size 16) (initial-contents '())) 13 | "Create a fresh hash set. 14 | 15 | `size` should be a hint as to how many elements this set is expected to 16 | contain. 17 | 18 | `initial-contents` should be a sequence of initial elements for the set 19 | (duplicates are fine). 20 | 21 | " 22 | (let* ((result (make-hash-set% :storage (make-hash-table :test test 23 | :size size)))) 24 | (map nil (curry #'hset-insert! result) initial-contents) 25 | result)) 26 | 27 | (defun copy-hash-set (hset) 28 | "Create a (shallow) copy of the given hash set. 29 | 30 | Only the storage for the hash set itself will be copied -- the elements 31 | themselves will not be copied. 32 | 33 | " 34 | (make-hash-set% :storage (alexandria:copy-hash-table (hash-set-storage hset)))) 35 | 36 | 37 | (defmacro define-hset-op (name arglist &body body) 38 | (let* ((has-docstring (stringp (first body))) 39 | (docstring (if has-docstring 40 | (first body) 41 | "")) 42 | (body (if has-docstring 43 | (rest body) 44 | body))) 45 | `(defun ,name ,arglist 46 | ,docstring 47 | (symbol-macrolet ((storage (hash-set-storage ,(first arglist)))) 48 | ,@body)))) 49 | 50 | 51 | (define-hset-op hset-empty-p (hset) 52 | "Return whether `hset` is empty." 53 | (zerop (hash-table-count storage))) 54 | 55 | (define-hset-op hset-contains-p (hset element) 56 | "Return whether `hset` contains `element`." 57 | (values (gethash element storage))) 58 | 59 | (define-hset-op hset-count (hset) 60 | "Return the number of elements in `hset`." 61 | (hash-table-count storage)) 62 | 63 | (define-hset-op hset-insert! (hset &rest elements) 64 | "Insert each element in `elements` into `hset`. 65 | 66 | Returns nothing. 67 | 68 | " 69 | (dolist (element elements) 70 | (setf (gethash element storage) t)) 71 | (values)) 72 | 73 | (define-hset-op hset-remove! (hset &rest elements) 74 | "Remove each element in `elements` from `hset`. 75 | 76 | If an element is not in `hset`, it will be ignored. 77 | 78 | Returns nothing. 79 | 80 | " 81 | (dolist (element elements) 82 | (remhash element storage)) 83 | (values)) 84 | 85 | (define-hset-op hset-pop! (hset) 86 | "Remove and return an arbitrarily-chosen element from `hset`. 87 | 88 | An error will be signaled if the hash set is empty. 89 | 90 | " 91 | (assert (not (hset-empty-p hset)) 92 | (hset) 93 | "Cannot pop from empty hash set ~S" 94 | hset) 95 | (iterate (for (k nil) :in-hashtable storage) 96 | (remhash k storage) 97 | (return k))) 98 | 99 | (define-hset-op hset-clear! (hset) 100 | "Remove all elements from `hset`. 101 | 102 | Returns nothing. 103 | 104 | " 105 | (clrhash storage) 106 | (values)) 107 | 108 | 109 | (define-hset-op hset=% (hset other) 110 | (iterate (for (k nil) :in-hashtable storage) 111 | (when (not (hset-contains-p other k)) 112 | (return nil)) 113 | (finally (return t)))) 114 | 115 | (define-hset-op hset= (hset &rest others) 116 | "Return whether all the given hash sets contain exactly the same elements. 117 | 118 | All the hash sets are assumed to use the same `test` -- the consequences are 119 | undefined if this is not the case. 120 | 121 | " 122 | (if (apply #'/= (hset-count hset) (mapcar #'hset-count others)) 123 | nil 124 | (iterate (for other :in others) 125 | (when (not (hset=% hset other)) 126 | (return nil)) 127 | (finally (return t))))) 128 | 129 | 130 | (define-hset-op hset-union!% (hset other) 131 | (iterate (for (k nil) :in-hashtable (hash-set-storage other)) 132 | (hset-insert! hset k)) 133 | hset) 134 | 135 | (define-hset-op hset-union! (hset &rest others) 136 | "Destructively update `hset` to contain the union of itself with `others`." 137 | (reduce #'hset-union!% others :initial-value hset)) 138 | 139 | (define-hset-op hset-union (hset &rest others) 140 | "Return a fresh hash set containing the union of the given hash sets." 141 | (apply #'hset-union! (copy-hash-set hset) others)) 142 | 143 | 144 | (define-hset-op hset-intersection!% (hset other) 145 | (iterate (for (k nil) :in-hashtable storage) 146 | (when (not (hset-contains-p other k)) 147 | (remhash k storage))) 148 | hset) 149 | 150 | (define-hset-op hset-intersection! (hset &rest others) 151 | "Destructively update `hset` to contain the intersection of itself with `others`." 152 | (reduce #'hset-intersection!% others :initial-value hset)) 153 | 154 | (define-hset-op hset-intersection (hset &rest others) 155 | "Return a fresh hash set containing the intersection of the given hash sets." 156 | (apply #'hset-intersection! (copy-hash-set hset) others)) 157 | 158 | 159 | (define-hset-op hset-difference!% (hset other) 160 | (iterate (for (k nil) :in-hashtable (hash-set-storage other)) 161 | (remhash k storage)) 162 | hset) 163 | 164 | (define-hset-op hset-difference! (hset &rest others) 165 | "Destructively update `hset` to contain the difference of itself with `others`." 166 | (reduce #'hset-difference!% others :initial-value hset)) 167 | 168 | (define-hset-op hset-difference (hset &rest others) 169 | "Return a fresh hash set containing the difference of the given hash sets." 170 | (apply #'hset-difference! (copy-hash-set hset) others)) 171 | 172 | 173 | (define-hset-op hset-filter! (hset predicate) 174 | "Destructively update `hset` to contain only elements satisfying `predicate`." 175 | (iterate (for (k nil) :in-hashtable storage) 176 | (when (funcall predicate k) 177 | (remhash k storage)))) 178 | 179 | (define-hset-op hset-filter (hset predicate) 180 | "Return a fresh hash set containing elements of `hset` satisfying `predicate`." 181 | (let ((new (copy-hash-set hset))) 182 | (hset-filter! new predicate) 183 | new)) 184 | 185 | 186 | (define-hset-op hset-map! (hset function &key new-test) 187 | "Destructively update `hset` by calling `function` on each element. 188 | 189 | If `new-test` is given the hash set's `test` will be updated. 190 | 191 | " 192 | (let ((results (iterate (for (k nil) :in-hashtable storage) 193 | (collect (funcall function k))))) 194 | (if new-test 195 | ;; Rebuild the underlying hash table if we have a new test. 196 | (setf storage (make-hash-table :test new-test 197 | :size (hash-table-count storage))) 198 | ;; Otherwise just clear and reuse the existing one. 199 | (clrhash storage)) 200 | (dolist (k results) 201 | (hset-insert! hset k)) 202 | nil)) 203 | 204 | (define-hset-op hset-map (hset function &key new-test) 205 | "Return a fresh hash set containing the results of calling `function` on elements of `hset`. 206 | 207 | If `new-test` is given, the new hash set will use this as its `test`. 208 | 209 | " 210 | (let ((new (copy-hash-set hset))) 211 | (hset-map! new function :new-test new-test) 212 | new)) 213 | 214 | 215 | (define-hset-op hset-reduce (hset function &key (initial-value nil ivp)) 216 | "Reduce `function` over the elements of `hset`. 217 | 218 | The order in which the elements are processed is undefined. 219 | 220 | " 221 | (if ivp 222 | (iterate (for (n nil) :in-hashtable storage) 223 | (reducing n by function :initial-value initial-value)) 224 | (iterate (for (n nil) :in-hashtable storage) 225 | (reducing n by function)))) 226 | 227 | (define-hset-op hset-elements (hset) 228 | "Return a fresh list containing the elements of `hset`." 229 | (alexandria:hash-table-keys storage)) 230 | 231 | 232 | (defmacro do-hash-set ((symbol hset) &body body) 233 | "Iterate over `hset` with `symbol` bound to successive elements." 234 | (with-gensyms (iter found) 235 | `(with-hash-table-iterator (,iter (hash-set-storage ,hset)) 236 | (loop (multiple-value-bind (,found ,symbol) (,iter) 237 | (unless ,found (return nil)) 238 | ,@body))))) 239 | -------------------------------------------------------------------------------- /src/hash-tables.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.hash-tables) 2 | 3 | (defun mutate-hash-values (function hash-table) 4 | "Replace each value in `hash-table` with the result of calling `function` on it. 5 | 6 | Returns the hash table. 7 | 8 | " 9 | (iterate (for (key value) :in-hashtable hash-table) 10 | (setf (gethash key hash-table) 11 | (funcall function value))) 12 | hash-table) 13 | 14 | (defun hash-table-contents (hash-table) 15 | "Return a fresh list of `(key value)` elements of `hash-table`." 16 | (gathering (maphash (compose #'gather #'list) hash-table))) 17 | 18 | (defun remhash-if (test hash-table) 19 | "Remove elements which satisfy `(test key value)` from `hash-table`. 20 | 21 | Returns the hash table." 22 | (maphash (lambda (k v) 23 | (when (funcall test k v) 24 | (remhash k hash-table))) 25 | hash-table) 26 | hash-table) 27 | 28 | (defun remhash-if-not (test hash-table) 29 | "Remove elements which don't satisfy `(test key value)` from `hash-table`. 30 | 31 | Returns the hash table." 32 | (maphash (lambda (k v) 33 | (unless (funcall test k v) 34 | (remhash k hash-table))) 35 | hash-table) 36 | hash-table) 37 | 38 | (defun remhash-if-key (test hash-table) 39 | "Remove elements which satisfy `(test key)` from `hash-table`. 40 | 41 | Returns the hash table." 42 | (maphash (lambda (k v) 43 | (declare (ignore v)) 44 | (when (funcall test k) 45 | (remhash k hash-table))) 46 | hash-table) 47 | hash-table) 48 | 49 | (defun remhash-if-not-key (test hash-table) 50 | "Remove elements which satisfy don't `(test key)` from `hash-table`. 51 | 52 | Returns the hash table." 53 | (maphash (lambda (k v) 54 | (declare (ignore v)) 55 | (unless (funcall test k) 56 | (remhash k hash-table))) 57 | hash-table) 58 | hash-table) 59 | 60 | (defun remhash-if-value (test hash-table) 61 | "Remove elements which satisfy `(test value)` from `hash-table`. 62 | 63 | Returns the hash table." 64 | (maphash (lambda (k v) 65 | (when (funcall test v) 66 | (remhash k hash-table))) 67 | hash-table) 68 | hash-table) 69 | 70 | (defun remhash-if-not-value (test hash-table) 71 | "Remove elements which satisfy don't `(test value)` from `hash-table`. 72 | 73 | Returns the hash table." 74 | (maphash (lambda (k v) 75 | (unless (funcall test v) 76 | (remhash k hash-table))) 77 | hash-table) 78 | hash-table) 79 | 80 | (defun ht/eql (&rest keys-and-values) 81 | (alexandria:plist-hash-table keys-and-values :test 'eql)) 82 | 83 | (defun ht/equal (&rest keys-and-values) 84 | (alexandria:plist-hash-table keys-and-values :test 'equal)) 85 | 86 | (named-readtables:defreadtable hash-table-constructor-syntax 87 | (:merge :standard) 88 | (:macro-char #\{ (lambda (stream char) 89 | (declare (ignore char)) 90 | `(ht/eql ,@(read-delimited-list #\} stream t)))) 91 | (:macro-char #\# :dispatch) 92 | (:dispatch-macro-char #\# #\{ (lambda (stream char n) 93 | (declare (ignore char n)) 94 | `(ht/equal ,@(read-delimited-list #\} stream t)))) 95 | (:macro-char #\} (get-macro-character #\) nil))) 96 | 97 | -------------------------------------------------------------------------------- /src/io.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.io) 2 | 3 | (defun read-all (stream) 4 | "Read all forms from `stream` and return them as a fresh list." 5 | (iterate 6 | (for v :in-stream stream) 7 | (collect v))) 8 | 9 | (defun read-all-from-string (string) 10 | "Read all forms from `string` and return them as a fresh list." 11 | (iterate 12 | (with done = (gensym)) 13 | (with start = 0) 14 | (for (values form pos) = (read-from-string string nil done 15 | :start start)) 16 | (while (not (eq form done))) 17 | (collect form) 18 | (setf start pos))) 19 | 20 | (defun read-all-from-file (path) 21 | "Read all forms from the file at `path` and return them as a fresh list." 22 | (with-open-file (file path :direction :input) 23 | (read-all file))) 24 | -------------------------------------------------------------------------------- /src/iterate.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.iterate) 2 | 3 | (defmacro expand-iterate-sequence-keywords () 4 | '(list 5 | :from iterate::from 6 | :upfrom iterate::upfrom 7 | :downfrom iterate::downfrom 8 | :to iterate::to 9 | :downto iterate::downto 10 | :above iterate::above 11 | :below iterate::below 12 | :by iterate::by 13 | :with-index iterate::with-index)) 14 | 15 | 16 | (defmacro-driver (FOR var IN-WHATEVER seq) 17 | "Iterate over items in the given sequence. 18 | 19 | Unlike iterate's own `in-sequence` this won't use the horrifyingly inefficient 20 | `elt`/`length` functions on a list. 21 | 22 | " 23 | (let ((kwd (if generate 'generate 'for))) 24 | (with-gensyms (is-list source i len) 25 | `(progn 26 | (with ,source = ,seq) 27 | (with ,is-list = (typep ,source 'list)) 28 | (with ,len = (if ,is-list -1 (length ,source))) 29 | (for ,i :from 0) 30 | (,kwd ,var next (if ,is-list 31 | (if ,source 32 | (pop ,source) 33 | (terminate)) 34 | (if (< ,i ,len) 35 | (elt ,source ,i) 36 | (terminate)))))))) 37 | 38 | 39 | (defmacro-driver (FOR var MODULO divisor &sequence) 40 | "Iterate numerically with `var` bound modulo `divisor`. 41 | 42 | This driver iterates just like the vanilla `for`, but each resulting value 43 | will be modulo'ed by `divisor` before being bound to `var`. 44 | 45 | Note that the modulo doesn't affect the *iteration*, it just affects the 46 | variable you *see*. It is as if you had written two clauses: 47 | 48 | (for temp :from foo :to bar) 49 | (for var = (mod temp divisor)) 50 | 51 | Example: 52 | 53 | (iterate (for i :from 0 :to 20 :by 3) (collect i)) 54 | (0 3 6 9 12 15 18) 55 | 56 | (iterate (for i :modulo 10 :from 0 :to 20 :by 3) (collect i)) 57 | (0 3 6 9 2 5 8) 58 | 59 | " 60 | (let ((kwd (if generate 'generate 'for))) 61 | (with-gensyms (i d) 62 | `(progn 63 | (with ,d = ,divisor) 64 | (generate ,i ,@(expand-iterate-sequence-keywords)) 65 | (,kwd ,var next (mod (next ,i) ,d)))))) 66 | 67 | 68 | (defmacro-driver (FOR var PAIRS-OF-LIST list) 69 | "Iterate over the all pairs of `list` (including `(last . first)`). 70 | 71 | Examples: 72 | 73 | (iterate (for p :pairs-of-list (list 1 2 3 4)) 74 | (collect p)) 75 | => 76 | ((1 . 2) (2 . 3) (3 . 4) (4 . 1)) 77 | 78 | " 79 | (let ((kwd (if generate 'generate 'for))) 80 | (with-gensyms (current l) 81 | `(progn 82 | (with ,l = ,list) 83 | (with ,current = ,l) 84 | (,kwd ,var next 85 | (cond 86 | ((null ,current) 87 | (terminate)) 88 | 89 | ((null (cdr ,current)) 90 | (prog1 91 | (cons (first ,current) (car ,l)) 92 | (setf ,current nil))) 93 | 94 | (t (prog1 95 | (cons (first ,current) (second ,current)) 96 | (setf ,current (cdr ,current)))))))))) 97 | 98 | 99 | (defmacro-clause (AVERAGING expr &optional INTO var) 100 | "Maintain a running average of `expr` in `var`. 101 | 102 | If `var` is omitted the final average will be returned instead. 103 | 104 | Examples: 105 | 106 | (iterate (for x :in '(0 10 0 10)) 107 | (averaging x)) 108 | => 109 | 5 110 | 111 | (iterate (for x :in '(1.0 1 2 3 4)) 112 | (averaging (/ x 10) :into avg) 113 | (collect avg)) 114 | => 115 | (0.1 0.1 0.13333334 0.17500001 0.22) 116 | 117 | " 118 | (with-gensyms (count total) 119 | (let ((average (or var iterate::*result-var*))) 120 | `(progn 121 | (for ,count :from 1) 122 | (sum ,expr :into ,total) 123 | (for ,average = (/ ,total ,count)))))) 124 | 125 | (defmacro-clause (TIMING time-type &optional 126 | SINCE-START-INTO since-var 127 | PER-ITERATION-INTO per-var 128 | SECONDS seconds?) 129 | "Time [real/run]-time into variables. 130 | 131 | `time-type` should be either the symbol `run-time` or `real-time`, depending 132 | on which kind of time you want to track. Times are reported in internal time 133 | units, unless `seconds?` is given, in which case they will be converted to 134 | a `single-float` by dividing by `internal-time-units-per-second`. 135 | 136 | If `since-var` is given, on each iteration it will be bound to the amount of 137 | time that has passed since the beginning of the loop. 138 | 139 | If `per-var` is given, on each iteration it will be bound to the amount of 140 | time that has passed since the last time it was set. On the first iteration 141 | it will be bound to the amount of time since the loop started. 142 | 143 | If neither var is given, it is as if `since-var` were given and returned as 144 | the value of the `iterate` statement. 145 | 146 | `seconds?` is checked at compile time, not runtime. 147 | 148 | Note that the position of this clause in the `iterate` statement matters. 149 | Also, the code movement of `iterate` can change things around. Overall the 150 | results should be pretty intuitive, but if you need absolute accuracy you 151 | should use something else. 152 | 153 | Examples: 154 | 155 | ; sleep BEFORE the timing clause 156 | (iterate (repeat 3) 157 | (sleep 1.0) 158 | (timing real-time :since-start-into s :per-iteration-into p) 159 | (collect (list (/ s internal-time-units-per-second 1.0) 160 | (/ p internal-time-units-per-second 1.0)))) 161 | => 162 | ((1.0003 1.0003) 163 | (2.0050 1.0047) 164 | (3.0081 1.0030)) 165 | 166 | ; sleep AFTER the timing clause 167 | (iterate (repeat 3) 168 | (timing real-time :since-start-into s :per-iteration-into p :seconds t) 169 | (sleep 1.0) 170 | (collect (list s p))) 171 | => 172 | ((0.0 0.0) 173 | (1.001 1.001) 174 | (2.005 1.004)) 175 | 176 | " 177 | (let ((timing-function (ccase time-type 178 | ((:real-time real-time) 'get-internal-real-time) 179 | ((:run-time run-time) 'get-internal-run-time))) 180 | (since-var (or since-var (when (null per-var) 181 | iterate::*result-var*)))) 182 | (flet ((convert (val) 183 | (if seconds? 184 | `(/ ,val internal-time-units-per-second 1.0f0) 185 | val))) 186 | (with-gensyms (start-time current-time previous-time) 187 | `(progn 188 | (with ,start-time = (,timing-function)) 189 | (for ,current-time = (,timing-function)) 190 | ,@(when since-var 191 | `((for ,since-var = ,(convert `(- ,current-time ,start-time))))) 192 | ,@(when per-var 193 | `((for ,previous-time :previous ,current-time :initially ,start-time) 194 | (for ,per-var = ,(convert `(- ,current-time ,previous-time)))))))))) 195 | 196 | 197 | (defmacro-driver (FOR var IN-LISTS lists) 198 | "Iterate each element of each list in `lists` in turn. 199 | 200 | Examples: 201 | 202 | (iterate (with things = (list (list 1 2 3) nil (list :a :b :c))) 203 | (for val :in-lists things) 204 | (collect val)) 205 | => 206 | (1 2 3 :a :b :c) 207 | 208 | " 209 | (let ((kwd (if generate 'generate 'for))) 210 | (with-gensyms (list) 211 | `(progn 212 | (generate ,list :in (remove nil ,lists)) 213 | (,kwd ,var next (progn (when (null ,list) 214 | (next ,list)) 215 | (pop ,list))))))) 216 | 217 | 218 | (defun seq-done-p (seq len idx) 219 | (if idx 220 | (= idx len) 221 | (null seq))) 222 | 223 | (defmacro-driver (FOR var IN-SEQUENCES seqs) 224 | "Iterate each element of each sequence in `seqs` in turn. 225 | 226 | Examples: 227 | 228 | (iterate (with things = (list (list 1 2 3) nil #(:a :b :c) #())) 229 | (for val :in-sequences things) 230 | (collect val)) 231 | => 232 | (1 2 3 :a :b :c) 233 | 234 | " 235 | (let ((kwd (if generate 'generate 'for))) 236 | (with-gensyms (seq len idx) 237 | `(progn 238 | (with ,len = nil) 239 | (with ,idx = nil) 240 | (generate ,seq :in-whatever (remove-if #'alexandria:emptyp ,seqs)) 241 | (,kwd ,var next 242 | (progn 243 | (when (seq-done-p ,seq ,len ,idx) 244 | (etypecase (next ,seq) 245 | (cons (setf ,len nil ,idx nil)) 246 | (sequence (setf ,len (length ,seq) 247 | ,idx 0)))) 248 | (if ,idx 249 | (prog1 (elt ,seq ,idx) 250 | (incf ,idx)) 251 | (pop ,seq)))))))) 252 | 253 | 254 | (defmacro-driver (FOR var AROUND seq) 255 | "Iterate cyclically around items in the given sequence. 256 | 257 | The results are undefined if the sequence is empty. 258 | 259 | " 260 | (let ((kwd (if generate 'generate 'for))) 261 | (with-gensyms (is-list original source i len) 262 | `(progn 263 | (with ,original = ,seq) 264 | (with ,source = ,original) 265 | (with ,is-list = (typep ,source 'list)) 266 | (with ,len = (if ,is-list -1 (length ,source))) 267 | (with ,i = -1) 268 | (,kwd ,var :next (if ,is-list 269 | (progn (unless ,source (setf ,source ,original)) 270 | (pop ,source)) 271 | (progn (incf ,i) 272 | (when (= ,i ,len) 273 | (setf ,i 0)) 274 | (elt ,source ,i)))))))) 275 | 276 | 277 | (defclause-sequence ACROSS-FLAT-ARRAY INDEX-OF-FLAT-ARRAY 278 | :access-fn 'row-major-aref 279 | :size-fn 'array-total-size 280 | :sequence-type 'array 281 | :element-type t) 282 | 283 | 284 | (defun calculate-array-floors (array) 285 | (iterate (for (nil . later) :on (array-dimensions array)) 286 | (collect (apply #'* later) :result-type vector))) 287 | 288 | (defmacro-driver (FOR binding-form IN-ARRAY array) 289 | "Iterate over `array`, binding the things in `binding-form` each time. 290 | 291 | This driver iterates over every element in `array`. Multidimensional arrays 292 | are supported -- the array will be stepped in row-major order. 293 | 294 | `binding-form` should be a list of `(value ...index-vars...)`. An index 295 | variable can be `nil` to ignore it. Missing index variables are ignored. If 296 | no index variables are needed, `binding-form` can simply be the value symbol. 297 | 298 | `generate` is supported. Call `next` on the value symbol to use it. 299 | 300 | Examples: 301 | 302 | (iterate (for (height x y) :in-array some-2d-heightmap-array) 303 | (draw-terrain x y height)) 304 | 305 | (iterate (for (val nil nil z) :in-array some-3d-array) 306 | (collect (cons z val))) 307 | 308 | (iterate (for val :in-array any-array) 309 | (print val)) 310 | 311 | " 312 | (destructuring-bind (var &rest index-vars 313 | &aux (kwd (if generate 'generate 'for))) 314 | (ensure-list binding-form) 315 | (with-gensyms (i arr dims floors) 316 | `(progn 317 | (with ,arr = ,array) 318 | ,@(when (some #'identity index-vars) 319 | `((with ,dims = (coerce (array-dimensions ,arr) 'vector)) 320 | (with ,floors = (calculate-array-floors ,arr)))) 321 | (generate ,i :from 0 :below (array-total-size ,arr)) 322 | ,@(iterate (for index :in index-vars) 323 | (for dim-number :from 0) 324 | (when index 325 | (collect `(generate ,index :next 326 | (mod (floor ,i (svref ,floors ,dim-number)) 327 | (svref ,dims ,dim-number)))))) 328 | (,kwd ,var :next 329 | (progn 330 | (next ,i) 331 | ,@(iterate (for index :in index-vars) 332 | (when index (collect `(next ,index)))) 333 | (row-major-aref ,arr ,i))))))) 334 | 335 | 336 | (defun parse-sequence-arguments 337 | (from upfrom downfrom to downto above below by) 338 | (let* ((start (or from upfrom downfrom)) 339 | (end (or to downto above below)) 340 | (increment (or by 1)) 341 | (down (or downfrom downto above)) 342 | (exclusive (or below above)) 343 | (done-p (if exclusive 344 | (if down '<= '>=) 345 | (if down '< '>))) 346 | (op (if down '- '+))) 347 | (values start end increment op done-p))) 348 | 349 | (defmacro-driver (FOR var CYCLING on-cycle &sequence) 350 | "Iterate numerically as with `for`, but cycle around once finished. 351 | 352 | `on-cycle` should be a form to execute every time the number cycles back to 353 | the beginning. The value of `var` during this form's execution is undefined. 354 | 355 | `generate` is supported. 356 | 357 | Results are undefined if the cycle doesn't contain at least one number. 358 | 359 | Examples: 360 | 361 | (iterate (repeat 10) 362 | (for x :cycling t :from 0 :to 3) 363 | (collect x)) 364 | => 365 | (0 1 2 3 0 1 2 3 0 1) 366 | 367 | (iterate (repeat 5) 368 | (for x :cycling (print 'beep) :from 1 :downto 0 :by 0.5) 369 | (print x)) 370 | => 371 | 1.0 372 | 0.5 373 | 0.0 374 | BEEP 375 | 1.0 376 | 0.5 377 | 378 | " 379 | (declare (ignore iterate::with-index)) 380 | (multiple-value-bind (start end increment op done-p) 381 | (parse-sequence-arguments iterate::from iterate::upfrom iterate::downfrom 382 | iterate::to iterate::downto 383 | iterate::above iterate::below 384 | iterate::by) 385 | (let ((kwd (if generate 'generate 'for))) 386 | (with-gensyms (%counter %start %end %increment) 387 | `(progn 388 | (with ,%end = ,end) 389 | (with ,%increment = ,increment) 390 | (with ,%counter) 391 | ;; ugly hack to get numeric contagion right for the first val 392 | ;; (borrowed from Alexandria) 393 | (with ,%start = (- (+ ,start ,%increment) ,%increment)) 394 | (,kwd ,var next 395 | (progn 396 | (setf ,%counter 397 | (if-first-time ,%start (,op ,%counter ,%increment))) 398 | (if (,done-p ,%counter ,%end) 399 | (prog1 400 | (setf ,%counter ,%start) 401 | ,on-cycle) 402 | ,%counter)))))))) 403 | 404 | 405 | (defmacro-clause (GENERATE-NESTED forms CONTROL-VAR control-var) 406 | (iterate 407 | (for (var . args) :in forms) 408 | (for prev :previous var :initially nil) 409 | 410 | ;; we basically turn 411 | ;; (for-nested ((x :from 0 :to n) 412 | ;; (y :from 0 :to m) 413 | ;; (z :from 0 :to q))) 414 | ;; into 415 | ;; (generate x :from 0 :to n) 416 | ;; (generate y :cycling (next x) :from 0 :to m) 417 | ;; (generate z :cycling (next y) :from 0 :to q) 418 | ;; (generate control-var 419 | ;; :next (if-first-time 420 | ;; (progn (next x) (next y) (next z)) 421 | ;; (next z))) 422 | (collect var :into vars) 423 | (collect `(generate ,var 424 | ,@(when prev `(:cycling (next ,prev))) 425 | ,@args) 426 | :into cycling-forms) 427 | 428 | (finally (return `(progn 429 | ,@cycling-forms 430 | (declare (ignorable ,control-var)) 431 | (generate ,control-var :next 432 | (if-first-time 433 | (progn ,@(iterate (for v :in vars) 434 | (collect `(next ,v)))) 435 | (next ,var)))))))) 436 | 437 | (defmacro-clause (FOR-NESTED forms) 438 | "Iterate the given `forms` in a nested fashion. 439 | 440 | `forms` should be a list of iteration forms. Each one should have the same 441 | format as a standard `(for var ...)` numeric iteration clause, but WITHOUT 442 | the `for`. 443 | 444 | The forms will iterate numerically as if in a series of nested loops, with 445 | later forms cycling around as many times as is necessary. 446 | 447 | Examples: 448 | 449 | (iterate (for-nested ((x :from 0 :to 3) 450 | (y :from 0 :below 1 :by 0.4))) 451 | (print (list x y))) 452 | => 453 | (0 0) 454 | (0 0.4) 455 | (0 0.8) 456 | (1 0) 457 | (1 0.4) 458 | (1 0.8) 459 | (2 0) 460 | (2 0.4) 461 | (2 0.8) 462 | (3 0) 463 | (3 0.4) 464 | (3 0.8) 465 | 466 | " 467 | (with-gensyms (control) 468 | `(progn 469 | (generate-nested ,forms :control-var ,control) 470 | (next ,control)))) 471 | 472 | 473 | (defmacro-clause (FOR delta-vars WITHIN-RADIUS radius &optional 474 | SKIP-ORIGIN should-skip-origin 475 | ORIGIN origin) 476 | "Iterate through a number of delta values within a given radius. 477 | 478 | Imagine you have a 2D array and you want to find all the neighbors of a given 479 | cell: 480 | 481 | ......... 482 | ...nnn... 483 | ...nXn... 484 | ...nnn... 485 | ......... 486 | 487 | You'll need to iterate over the cross product of the array indices from 488 | `(- target 1)` to `(+ target 1)`. 489 | 490 | You may want to have a larger radius, and you may or may not want to include 491 | the origin (delta `(0 0)`). 492 | 493 | This clause handles calculating the deltas for you, without needless consing. 494 | 495 | Examples: 496 | 497 | (iterate (for (x) :within-radius 2) 498 | (collect (list x))) 499 | => 500 | ((-2) (-1) (0) (1) (2)) 501 | 502 | (iterate (for (x y) :within-radius 1 :skip-origin t) 503 | (collect (list x y))) 504 | => 505 | ((-1 -1) 506 | (-1 0) 507 | (-1 1) 508 | ( 0 -1) 509 | ( 0 1) 510 | ( 1 -1) 511 | ( 1 0) 512 | ( 1 1)) 513 | 514 | (iterate (for (x y z) :within-radius 3) 515 | (collect (list x y z))) 516 | => 517 | ; ... a bigass list of deltas, 518 | ; the point it is works in arbitrary dimensions. 519 | 520 | " 521 | ;; TODO rewrite this as bare `for`s without all the generator cruft to avoid 522 | ;; the bullshit SBCL `deleting unreachable code` garbage we get every time 523 | ;; skip-origin is true. 524 | (let* ((delta-vars (ensure-list delta-vars)) 525 | (origin-vars (mapcar (lambda (dv) (gensym (mkstr 'origin- dv))) 526 | delta-vars)) 527 | (origin-vals (if (null origin) 528 | (mapcar (constantly 0) delta-vars) 529 | origin))) 530 | (with-gensyms (r control skip) 531 | `(progn 532 | (with ,r = ,radius) 533 | (with ,skip = ,should-skip-origin) 534 | ,@(mapcar (lambda (ovar oval) 535 | `(with ,ovar = ,oval)) 536 | origin-vars origin-vals) 537 | (generate-nested ,(iterate (for var :in delta-vars) 538 | (for orig :in origin-vars) 539 | (collect `(,var :from (- ,orig ,r) :to (+ ,orig ,r)))) 540 | :control-var ,control) 541 | (next ,control) 542 | (when (and ,skip 543 | ,@(iterate (for var :in (ensure-list delta-vars)) 544 | (for ovar :in origin-vars) 545 | (collect `(= ,ovar ,var)))) 546 | (next ,control)))))) 547 | 548 | 549 | (defmacro-driver (FOR var EVERY-NTH n DO form) 550 | "Iterate `var` numerically modulo `n` and run `form` every `n`th iteration. 551 | 552 | The driver can be used to perform an action every N times through the loop. 553 | 554 | `var` itself will be a counter that counts up from to to `n - 1`. 555 | 556 | `generate` is supported. 557 | 558 | Example: 559 | 560 | (iterate (for i :from 1 :to 7) 561 | (print `(iteration ,i)) 562 | (for tick :every-nth 3 :do (print 'beep)) 563 | (print `(tick ,tick)) (terpri)) 564 | ; => 565 | (ITERATION 1) 566 | (TICK 0) 567 | 568 | (ITERATION 2) 569 | (TICK 1) 570 | 571 | (ITERATION 3) 572 | BEEP 573 | (TICK 2) 574 | 575 | (ITERATION 4) 576 | (TICK 0) 577 | 578 | (ITERATION 5) 579 | (TICK 1) 580 | 581 | (ITERATION 6) 582 | BEEP 583 | (TICK 2) 584 | 585 | (ITERATION 7) 586 | (TICK 0) 587 | 588 | " 589 | (let ((kwd (if generate 'generate 'for))) 590 | (with-gensyms (counter limit) 591 | `(progn 592 | (with ,limit = ,n) 593 | (generate ,counter :modulo ,limit :from 0) 594 | (,kwd ,var :next (prog1 (next ,counter) 595 | (when (= ,counter (1- ,limit)) 596 | ,form))))))) 597 | 598 | 599 | (defmacro-clause (COLLECT-HASH key-and-value &optional 600 | INTO var 601 | TEST (test '#'eql)) 602 | "Collect keys and values into a hash table at `var`. 603 | 604 | If `var` is omitted the hash table will be returned instead. 605 | 606 | `key-and-value` should be a list of `(key-expr value-expr)`. 607 | 608 | `test` specifies the test used for the hash table. 609 | 610 | Example: 611 | 612 | (iterate (for x :from 0) 613 | (for y :in '(a b c)) 614 | (collect-hash ((1+ x) y))) 615 | ; => {1 a 616 | ; 2 b 617 | ; 3 c} 618 | 619 | " 620 | (destructuring-bind (key value) key-and-value 621 | (let ((hash-table (or var iterate::*result-var*))) 622 | `(progn 623 | (with ,hash-table = (make-hash-table :test ,test)) 624 | (setf (gethash ,key ,hash-table) ,value))))) 625 | 626 | (defmacro-clause (COLLECT-SET element &optional 627 | INTO var 628 | TEST (test '#'eql)) 629 | "Collect elements into a hash set at `var`. 630 | 631 | If `var` is omitted the hash set will be returned instead. 632 | 633 | `test` specifies the test used for the hash set. 634 | 635 | Example: 636 | 637 | (iterate (for y :in '(a b a)) 638 | (collect-set y)) 639 | ; => {a b} 640 | 641 | " 642 | (let ((hash-set (or var iterate::*result-var*))) 643 | `(progn 644 | (with ,hash-set = (make-hash-set :test ,test)) 645 | (hset-insert! ,hash-set ,element)))) 646 | 647 | (defmacro-clause (COLLECT-FREQUENCIES expr &optional 648 | INTO var 649 | TEST (test '#'eql)) 650 | "Collect frequencies of `expr` values into a hash table at `var`. 651 | 652 | If `var` is omitted the hash table will be returned instead. 653 | 654 | `test` specifies the test used for the hash table. 655 | 656 | Example: 657 | 658 | (iterate (for x :in '(b a n a n a s)) 659 | (collect-frequencies x)) 660 | ; => {b 1 661 | ; a 3 662 | ; n 2 663 | ; s 1} 664 | 665 | " 666 | (let ((hash-table (or var iterate::*result-var*))) 667 | `(progn 668 | (with ,hash-table = (make-hash-table :test ,test)) 669 | (incf (gethash ,expr ,hash-table 0))))) 670 | 671 | (defmacro-clause (CONCATENATING expr &optional INTO var SEPARATOR separator) 672 | "Concatenate the string `expr` into `var`. 673 | 674 | If `var` is not given, `expr` will be accumulated into a string output stream 675 | and the result returned. 676 | 677 | If `var` is given, `expr` will be concatenated onto it. Whether `var` is 678 | a fresh string each time or whether an adjustable string is mutated is 679 | implementation defined. 680 | 681 | If `separator` is not `nil` it must be a string designator, and it will be 682 | evaluated once at the beginning of the iterate form. 683 | 684 | Examples: 685 | 686 | (iterate (for s :in '(\"foo\" \"bar\" \"baz\")) 687 | (concatenating s)) 688 | ; => \"foobarbaz\" 689 | 690 | (iterate (for s :in '(\"foo\" \"bar\" \"baz\")) 691 | (concatenating s :separator #\,)) 692 | ; => \"foo,bar,baz\" 693 | 694 | (iterate (for s :in '(\"foo\" \"bar\" \"baz\")) 695 | (concatenating s :separator \", \")) 696 | ; => \"foo, bar, baz\" 697 | 698 | (iterate (for s :in '(\"foo\" \"bar\" \"baz\")) 699 | (concatenating s :separator #\, :into v) 700 | (format t \"> ~A~%\" v) 701 | (collect v)) 702 | ; => > foo 703 | ; => > foo,bar 704 | ; => > foo,bar,baz 705 | ; 706 | ; Implementation defined result, might be one of: 707 | ; => (\"foo\" \"foo,bar\" \"foo,bar,baz\") ; 3 fresh strings 708 | ; => (\"foo,bar,baz\" \"foo,bar,baz\" \"foo,bar,baz\") ; same string 709 | 710 | " 711 | (if var 712 | (let ((separator% (gensym "SEPARATOR")) 713 | (sep (gensym "SEP"))) 714 | `(progn 715 | (with ,separator% = ,separator) 716 | (with ,sep = (if ,separator% (string ,separator%) "")) 717 | (reducing ,expr 718 | :by (lambda (a b) 719 | (if (null a) 720 | (copy-seq b) 721 | (concatenate 'string a ,sep b))) 722 | :into ,var 723 | :initial-value nil))) 724 | (let ((separator% (gensym "SEPARATOR")) 725 | (sos (gensym "SOS")) 726 | (sep (gensym "SEP"))) 727 | `(progn 728 | (with ,separator% = ,separator) 729 | (with ,sos = nil) 730 | (with ,sep = (if (or (null ,separator%) (equal ,separator% "")) 731 | nil 732 | (string ,separator%))) 733 | (if (null ,sos) 734 | (setf ,sos (make-string-output-stream)) 735 | (when ,sep 736 | (write-string ,sep ,sos))) 737 | (write-string ,expr ,sos) 738 | (finally (return (get-output-stream-string ,sos))))))) 739 | 740 | 741 | (defmacro-clause (ORING expr &optional INTO var) 742 | (let ((result (or var iterate::*result-var*))) 743 | `(reducing ,expr :by #'or :into ,result :initial-value nil))) 744 | 745 | (defmacro-clause (ANDING expr &optional INTO var) 746 | (let ((result (or var iterate::*result-var*))) 747 | `(reducing ,expr :by #'and :into ,result :initial-value t))) 748 | 749 | 750 | (defun keywordize-clause (clause) 751 | (iterate 752 | (for (k v . nil) :on clause :by #'cddr) 753 | (collect (alexandria:make-keyword k)) 754 | (collect v))) 755 | 756 | (defun keywordize-some-of-clause (clause) 757 | ; please kill me 758 | (append (list (first clause) (second clause)) 759 | (keywordize-clause (nthcdr 2 clause)))) 760 | 761 | (defun macroexpand-iterate (clause) 762 | "Macroexpand the given iterate clause/driver. 763 | 764 | Example: 765 | 766 | (macroexpand-iterate '(averaging (+ x 10) :into avg)) 767 | => 768 | (PROGN 769 | (FOR #:COUNT630 :FROM 1) 770 | (SUM (+ X 10) :INTO #:TOTAL631) 771 | (FOR AVG = (/ #:TOTAL631 #:COUNT630))) 772 | 773 | " 774 | ;; Given a clause like (for foo in-whatever bar) we need to: 775 | ;; 776 | ;; 1. Look up the appropriate macro (confusingly named via gentemp). This 777 | ;; requires calling `iterate::get-clause-info` with an appropriately-formed 778 | ;; clause. 779 | ;; 780 | ;; The first item in the clause must be a normal (non-keyword) symbol, but 781 | ;; the rest of the clause keywords must be actual keyword symbols. 782 | ;; 783 | ;; 2. Build the appropriate list to `macroexpand-1`. This should be of the 784 | ;; form `(the-wierdly-named-macro ...)`. 785 | ;; 786 | ;; Note that the macro will be expecting the clause to come in as keyword 787 | ;; arguments, so unlike in step 1 ALL the clause keywords need to be actual 788 | ;; keywords, including the first. 789 | ;; 790 | ;; We'll also bind `iterate::*result-var*` so any macros that use it won't 791 | ;; immediately shit the bed. 792 | (let ((iterate::*result-var* 'iterate::*result-var*)) 793 | (values 794 | (macroexpand-1 (cons (iterate::clause-info-function 795 | (iterate::get-clause-info 796 | (keywordize-some-of-clause clause))) 797 | (keywordize-clause clause)))))) 798 | 799 | 800 | (defmacro-driver (FOR var IN-HASHSET hset) 801 | (let ((kwd (if generate 'generate 'for))) 802 | `(,kwd (,var) :in-hashtable (losh.hash-sets::hash-set-storage ,hset)))) 803 | 804 | 805 | (defmacro-driver (FOR var IN-RING-BUFFER ring-buffer) 806 | "Iterate over the elements of `ring-buffer`, oldest to newest. 807 | 808 | Does not modify the ring buffer. 809 | 810 | " 811 | (let ((kwd (if generate 'generate 'for))) 812 | (with-gensyms (rb r w d s) 813 | `(progn 814 | (with ,rb = ,ring-buffer) 815 | (with ,r = (losh.ring-buffers::r ,rb)) 816 | (with ,w = (losh.ring-buffers::w ,rb)) 817 | (with ,d = (losh.ring-buffers::data ,rb)) 818 | (with ,s = (losh.ring-buffers::size ,rb)) 819 | (,kwd ,var :next (if (= ,r ,w) 820 | (terminate) 821 | (prog1 (svref ,d ,r) 822 | (incf ,r) 823 | (when (= ,r ,s) 824 | (setf ,r 0))))))))) 825 | 826 | 827 | (defmacro-driver (FOR var SEED seed THEN then) 828 | "Bind `var` to `seed` initially, then to `then` on every iteration. 829 | 830 | This differs from `(FOR … FIRST … THEN …)` and `(FOR … INITIALLY … THEN …)` 831 | because `then` is evaluated on every iteration, *including* the first. 832 | 833 | Example: 834 | 835 | (iterate 836 | (repeat 3) 837 | (for x :first 0 :then (1+ x)) 838 | (for y :initially 0 :then (1+ y)) 839 | (for z :seed 0 :then (1+ z)) 840 | (collect (list x y z))) 841 | ; => 842 | ((0 0 1) 843 | (1 1 2) 844 | (2 2 3)) 845 | 846 | " 847 | (let ((kwd (if generate 'generate 'for))) 848 | `(progn 849 | (,kwd ,var :next ,then) 850 | (initially (setf ,var ,seed))))) 851 | 852 | 853 | (deftype sharp-quoted-function () 854 | '(cons (eql function) 855 | (cons t null))) 856 | 857 | (defmacro-clause (FINDING-ALL expr MINIMIZING m-expr &optional INTO var) 858 | "Collect all `expr`s minimizing `m-expr` into a list at `var`. 859 | 860 | The partial list at `var` is available for inspection at any point in the loop. 861 | 862 | If `m-expr` is a sharp-quoted function, then it is called on `expr` instead of 863 | being evaluated and compared itself. 864 | 865 | " 866 | ;; TODO: result-type 867 | (with-gensyms (min value m-value tail) 868 | (let ((result (or var iterate::*result-var*))) 869 | `(progn 870 | (with ,result = '()) 871 | (with ,tail = nil) 872 | (with ,min = nil) 873 | ,(typecase m-expr 874 | (sharp-quoted-function 875 | `(progn 876 | (for ,value = ,expr) 877 | (for ,m-value = (funcall ,m-expr ,value)) 878 | (cond 879 | ((or (null ,min) 880 | (< ,m-value ,min)) (setf ,result (list ,value) 881 | ,tail ,result 882 | ,min ,m-value)) 883 | ((= ,m-value ,min) (setf (cdr ,tail) (cons ,value nil) 884 | ,tail (cdr ,tail)))))) 885 | (t `(progn 886 | (for ,m-value = ,m-expr) 887 | (cond 888 | ((or (null ,min) 889 | (< ,m-value ,min)) (setf ,result (list ,expr) 890 | ,tail ,result 891 | ,min ,m-value)) 892 | ((= ,m-value ,min) (setf (cdr ,tail) (cons ,expr nil) 893 | ,tail (cdr ,tail))))))))))) 894 | 895 | (defmacro-clause (FINDING-ALL expr MAXIMIZING m-expr &optional INTO var) 896 | "Collect all `expr`s maximizing `m-expr` into a list at `var`. 897 | 898 | The partial list at `var` is available for inspection at any point in the loop. 899 | 900 | If `m-expr` is a sharp-quoted function, then it is called on `expr` instead of 901 | being evaluated and compared itself. 902 | 903 | " 904 | ;; TODO: result-type 905 | (with-gensyms (max value m-value tail) 906 | (let ((result (or var iterate::*result-var*))) 907 | `(progn 908 | (with ,result = '()) 909 | (with ,tail = nil) 910 | (with ,max = nil) 911 | ,(typecase m-expr 912 | (sharp-quoted-function 913 | `(progn 914 | (for ,value = ,expr) 915 | (for ,m-value = (funcall ,m-expr ,value)) 916 | (cond 917 | ((or (null ,max) 918 | (> ,m-value ,max)) (setf ,result (list ,value) 919 | ,tail ,result 920 | ,max ,m-value)) 921 | ((= ,m-value ,max) (setf (cdr ,tail) (cons ,value nil) 922 | ,tail (cdr ,tail)))))) 923 | (t `(progn 924 | (for ,m-value = ,m-expr) 925 | (cond 926 | ((or (null ,max) 927 | (> ,m-value ,max)) (setf ,result (list ,expr) 928 | ,tail ,result 929 | ,max ,m-value)) 930 | ((= ,m-value ,max) (setf (cdr ,tail) (cons ,expr nil) 931 | ,tail (cdr ,tail))))))))))) 932 | 933 | (defmacro-clause (FINDING-ALL expr SUCH-THAT test &optional INTO var RESULT-TYPE result-type) 934 | "Collect all `expr`s for which `test` is true. 935 | 936 | If `test` is a sharp-quoted function, then it is called on `expr` instead of 937 | being evaluated and compared itself. 938 | 939 | " 940 | (let ((result (or var iterate::*result-var*))) 941 | (typecase test 942 | (sharp-quoted-function 943 | (with-gensyms (value) 944 | `(progn 945 | (for ,value = ,expr) 946 | (when (funcall ,test ,value) 947 | (collect ,value :into ,result 948 | ,@(when result-type `(:result-type ,result-type))))))) 949 | (t `(when ,test 950 | (collect ,expr :into ,result 951 | ,@(when result-type `(:result-type ,result-type)))))))) 952 | 953 | (defmacro-clause (FINDING-FIRST expr SUCH-THAT test &optional INTO var) 954 | "Collect the first `expr` for which `test` is true. 955 | 956 | Unlike vanilla `finding`, it does not block further iteration. 957 | 958 | If `test` is a sharp-quoted function, then it is called on `expr` instead of 959 | being evaluated and compared itself. 960 | 961 | " 962 | (with-gensyms (value found) 963 | (let ((result (or var iterate::*result-var*))) 964 | `(progn 965 | (with ,found) 966 | ,@(when var (list `(with ,var))) 967 | ,(typecase test 968 | (sharp-quoted-function 969 | `(unless ,found 970 | (for ,value = ,expr) 971 | (when (funcall ,test ,value) 972 | (setf ,found t ,result ,value)))) 973 | (t `(unless ,found 974 | (when ,test 975 | (setf ,found t ,result ,expr))))))))) 976 | 977 | 978 | (defmacro returning (&rest values) 979 | "Return `values` from the iterate clause. 980 | 981 | Equivalent to `(finally (return (values ...)))`. 982 | 983 | " 984 | `(finally (return (values ,@values)))) 985 | 986 | (defmacro with-result (symbol = expr) 987 | "Bind `expr` to symbol using `with`, and return it at the end. 988 | 989 | Equivalent to `(progn (with symbol = expr) (returning expr))`. 990 | 991 | " 992 | (assert (eql = '=)) 993 | `(progn (with ,symbol = ,expr) 994 | (returning ,symbol))) 995 | 996 | (defmacro-driver (FOR var-or-vars MATCHING regex AGAINST string &optional OVERLAP overlap? START start END end) 997 | "Iterate over the matches of `regex` in `string`, binding `var-or-vars`. 998 | 999 | `regex` must be a suitable argument for passing to `ppcre:create-scanner`. 1000 | Note that `ppcre:create-scanner` accepts already-created scanners and returns 1001 | them unchanged, so you can provide an existing scanner if you wish. 1002 | 1003 | `var-or-vars` will be bound to the successive matches. If it is a symbol, it 1004 | will be bound to the entire match. If it is a list of variables, they will be 1005 | bound to the register groups as if by `ppcre:register-groups-bind`. 1006 | 1007 | If `overlap?` is true, after finding a match, the next match will be searched 1008 | for from the next character, instead of skipping past the entire previous 1009 | match. 1010 | 1011 | `generate` is supported. 1012 | 1013 | Examples: 1014 | 1015 | (iterate (for word :matching \"\\\\w+\" :against \"foo bar baz\") 1016 | (collect word)) 1017 | ; => 1018 | (\"foo\" \"bar\" \"baz\") 1019 | 1020 | (iterate (for x :matching \"\\\\w\\\\w\" :against \"abcde\") 1021 | (collect x)) 1022 | ; => 1023 | (\"ab\" \"cd\") 1024 | 1025 | (iterate (for x :matching \"\\\\w\\\\w\" :against \"abcde\" :overlap t) 1026 | (collect x)) 1027 | ; => 1028 | (\"ab\" \"bc\" \"cd\" \"de\") 1029 | 1030 | (iterate (for ((#'string-upcase name) (#'parse-integer year month day)) 1031 | :matching \"(\\\\w+)? (\\\\d+)-(\\\\d+)-(\\\\d+)\" 1032 | :against \"foo 2019-12-06 / 2010-11-14\") 1033 | (collect (list name year month day))) 1034 | ; => 1035 | ((\"FOO\" 2019 12 6) (NIL 2010 11 14)) 1036 | 1037 | (iterate (for x :matching (ppcre:create-scanner \"foo+\" :case-insensitive-mode t) 1038 | :against \"FOOOOD\") 1039 | (collect x)) 1040 | ; => 1041 | (\"FOOOO\") 1042 | 1043 | " 1044 | (let* ((kwd (if generate 'generate 'for)) 1045 | (single (symbolp var-or-vars)) 1046 | (var (if single var-or-vars nil)) 1047 | (vars (unless single 1048 | (iterate 1049 | (for spec :in var-or-vars) 1050 | (etypecase spec 1051 | (cons (destructuring-bind (function &rest vars) spec 1052 | (appending (mapcar (curry #'cons function) vars)))) 1053 | (symbol (appending (list `(nil . ,spec))))))))) 1054 | (with-gensyms (scanner% pos% start% end% string% reg-start% reg-end% limit%) 1055 | `(progn 1056 | (with ,pos% = ,(or start 0)) 1057 | (with ,string% = ,string) 1058 | (with ,limit% = ,(or end `(length ,string%))) 1059 | (with ,scanner% = (ppcre:create-scanner ,regex)) 1060 | (,kwd ,(if single 1061 | var 1062 | `(values ,@(mapcar #'cdr vars))) 1063 | :next 1064 | (multiple-value-bind (,start% ,end% ,@(unless single `(,reg-start% ,reg-end%))) 1065 | (ppcre:scan ,scanner% ,string% :start ,pos% :end ,limit%) 1066 | (declare (ignorable ,end%)) 1067 | (if (null ,start%) 1068 | (terminate) 1069 | (progn (setf ,pos% ,(if overlap? `(1+ ,start%) end%)) 1070 | ,(if single 1071 | `(subseq ,string% ,start% ,end%) 1072 | `(values 1073 | ,@(iterate 1074 | (for i :from 0) 1075 | (for (function . nil) :in vars) 1076 | (collect 1077 | `(when (aref ,reg-start% ,i) 1078 | (,@(if function `(funcall ,function) `(progn)) 1079 | (subseq ,string% 1080 | (aref ,reg-start% ,i) 1081 | (aref ,reg-end% ,i)))))))))))))))) 1082 | 1083 | 1084 | (defmacro WHEN-FIRST-TIME (expr) 1085 | "Sugar for `(if-first-time expr nil)`." 1086 | `(if-first-time ,expr nil)) 1087 | 1088 | (defmacro UNLESS-FIRST-TIME (expr) 1089 | "Sugar for `(if-first-time nil expr)`." 1090 | `(if-first-time nil ,expr)) 1091 | 1092 | 1093 | (defmacro IF-FIRST-ITERATION (then else) 1094 | "Evaluate `then` if this clause is executed on the first iteration, otherwise `else`. 1095 | 1096 | This is similar to from iterate's built-in `if-first-time`, but slightly different: 1097 | 1098 | * `if-first-time` evaluates `then` the first time the clause is evaluated, 1099 | even if that happens on a subsequent iteration. 1100 | * `if-first-iteration` evaluates `then` only if the clause is evaluated on 1101 | the first iteration. 1102 | 1103 | Example: 1104 | 1105 | (iterate 1106 | (for i :from 1 :to 4) 1107 | (collect (cons i (when (evenp i) 1108 | (list 1109 | (if-first-time :first-time :later-time) 1110 | (if-first-iteration :first-iter :later-iter)))))) 1111 | ; => 1112 | ; ((1) 1113 | ; (2 :FIRST-TIME :LATER-ITER) 1114 | ; (3) 1115 | ; (4 :LATER-TIME :LATER-ITER)) 1116 | 1117 | in that it will only evaluate `then` on the first iteration of the loop, " 1118 | (with-gensyms (first-iteration) 1119 | `(progn 1120 | (with ,first-iteration = t) 1121 | (after-each (setf ,first-iteration nil)) 1122 | (if ,first-iteration 1123 | ,then 1124 | ,else)))) 1125 | 1126 | (defmacro WHEN-FIRST-ITERATION (expr) 1127 | "Sugar for `(if-first-iteration expr nil)`." 1128 | `(if-first-iteration ,expr nil)) 1129 | 1130 | (defmacro UNLESS-FIRST-ITERATION (expr) 1131 | "Sugar for `(if-first-iteration nil expr)`." 1132 | `(if-first-iteration nil ,expr)) 1133 | 1134 | 1135 | (defmacro-clause (FOR vars WINDOW size ON sequence-or-length 1136 | &optional START start END end) 1137 | "Iterate a window over a sequence. 1138 | 1139 | The exact nature of the iteration depends on the form of `vars`: 1140 | 1141 | If `vars` is a symbol, or a list of a single symbol, it will be bound to 1142 | a `size`-element `subseq` of `sequence-or-length` on each iteration. In this 1143 | case, `sequence-or-length` must be a sequence. 1144 | 1145 | If `vars` is a list of two symbols `(start end)`, they will be bound to the 1146 | start and end bounding indices of a a `size`-element window of 1147 | `sequence-or-length` on each iteration. In this case, `sequence-or-length` 1148 | can be a sequence (in which case its `length` is used) or an integer. 1149 | 1150 | If `vars` is a list of three symbols `(subseq start end)`, both of the above 1151 | bindings will happen. In this case, `sequence-or-length` must be a sequence. 1152 | 1153 | If `start` or `end` are given, they are used to restrict the range of the 1154 | sequence being iterated over. 1155 | 1156 | `generate` is not supported at this time. 1157 | 1158 | Examples: 1159 | 1160 | (iterate (with string = \"abcdefg\") 1161 | (for x :window 2 :on string) 1162 | (collect x)) 1163 | ; => (\"ab\" \"bc\" \"cd\" \"de\" \"ef\" \"fg\") 1164 | 1165 | (iterate (with string = \"abcdefg\") 1166 | (for (start end) :window 2 :on 5) 1167 | (collect (subseq string start end))) 1168 | ; => (\"ab\" \"bc\" \"cd\" \"de\") 1169 | 1170 | (iterate (with string = \"abcdefg\") 1171 | (for (x start end) :window 2 :on string) 1172 | (collect (list x start end))) 1173 | ; => ((\"ab\" 0 2) (\"bc\" 1 3) (\"cd\" 2 4) (\"de\" 3 5) (\"ef\" 4 6) (\"fg\" 5 7)) 1174 | 1175 | (iterate (with string = \"abcdefg\") 1176 | (for (x start end) :window 2 :on string :start 1 :end 5) 1177 | (collect (list x start end))) 1178 | ; => ((\"bc\" 1 3) (\"cd\" 2 4) (\"de\" 3 5)) 1179 | 1180 | " 1181 | (setf vars (ensure-list vars)) 1182 | (alexandria:with-gensyms (n seq s) 1183 | (let (subseq% start% end%) 1184 | (ecase (length vars) 1185 | (1 (setf subseq% (first vars) 1186 | start% (gensym "START") 1187 | end% (gensym "END"))) 1188 | (2 (setf subseq% nil 1189 | start% (first vars) 1190 | end% (second vars))) 1191 | (3 (setf subseq% (first vars) 1192 | start% (second vars) 1193 | end% (third vars)))) 1194 | `(progn 1195 | (with ,s = ,(or start 0)) 1196 | (with ,n = ,size) 1197 | (with ,seq = ,sequence-or-length) 1198 | (for ,start% :from ,s) 1199 | (for ,end% :from (+ ,n ,s) :to 1200 | ,(cond 1201 | (end end) 1202 | (subseq% `(length ,seq)) 1203 | (t `(etypecase ,seq 1204 | (integer ,seq) 1205 | (sequence (length ,seq)))))) 1206 | ,@(when subseq% 1207 | `((for ,subseq% = (subseq ,seq ,start% ,end%)))))))) 1208 | -------------------------------------------------------------------------------- /src/lists.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.lists) 2 | 3 | (defun somelist (predicate list &rest more-lists) 4 | "Call `predicate` on successive sublists of `list`, returning the first true result. 5 | 6 | `somelist` is to `some` as `maplist` is to `mapcar`. 7 | 8 | " 9 | (if more-lists 10 | (iterate 11 | (for lists :first (cons list more-lists) :then (mapcar #'cdr lists)) 12 | (until (some #'null lists)) 13 | (thereis (apply predicate lists))) 14 | (iterate (for l :on list) 15 | (thereis (funcall predicate l))))) 16 | 17 | 18 | (defun range (start end &key (step 1)) 19 | "Return a fresh list of the range `[start, end)` by `step`. 20 | 21 | `end` can be smaller than `start`, in which case the numbers will be stepped 22 | down instead of up. 23 | 24 | `step` must always be a positive value, regardless of the direction of the 25 | range. 26 | 27 | " 28 | (check-type step (real (0) *)) 29 | (if (<= start end) 30 | (loop :for i :from start :below end :by step :collect i) 31 | (loop :for i :downfrom start :above end :by step :collect i))) 32 | 33 | (defun irange (start end &key (step 1)) 34 | "Return a fresh list of the range `[start, end]` by `step`. 35 | 36 | `end` can be smaller than `start`, in which case the numbers will be stepped 37 | down instead of up. 38 | 39 | `step` must always be a positive value, regardless of the direction of the 40 | range. 41 | 42 | " 43 | (check-type step (real (0) *)) 44 | (if (<= start end) 45 | (loop :for i :from start :to end :by step :collect i) 46 | (loop :for i :downfrom start :to end :by step :collect i))) 47 | 48 | 49 | (defun 0.. (below) 50 | "Return a fresh list of the range `[0, below)`." 51 | (range 0 below)) 52 | 53 | (defun 1.. (below) 54 | "Return a fresh list of the range `[1, below)`." 55 | (range 1 below)) 56 | 57 | (defun 0... (to) 58 | "Return a fresh list of the range `[0, to]`." 59 | (irange 0 to)) 60 | 61 | (defun 1... (to) 62 | "Return a fresh list of the range `[1, to]`." 63 | (irange 1 to)) 64 | 65 | 66 | (declaim (inline assocar assocdr rassocar rassocdr 67 | (setf assocar) (setf assocdr) (setf rassocar) (setf rassocdr))) 68 | 69 | 70 | (defun assocar (item alist &rest args) 71 | "Return the `car` of `(apply #'assoc item alist args)`." 72 | (car (apply #'assoc item alist args))) 73 | 74 | (defun assocdr (item alist &rest args) 75 | "Return the `cdr` of `(apply #'assoc item alist args)`." 76 | (cdr (apply #'assoc item alist args))) 77 | 78 | (defun rassocar (item alist &rest args) 79 | "Return the `car` of `(apply #'rassoc item alist args)`." 80 | (car (apply #'rassoc item alist args))) 81 | 82 | (defun rassocdr (item alist &rest args) 83 | "Return the `cdr` of `(apply #'rassoc item alist args)`." 84 | (cdr (apply #'rassoc item alist args))) 85 | 86 | 87 | (defun (setf assocar) (new-value item alist &rest args) 88 | "Set the `car` of `(apply #'assoc item alist args)` to `new-value`." 89 | (setf (car (apply #'assoc item alist args)) new-value)) 90 | 91 | (defun (setf assocdr) (new-value item alist &rest args) 92 | "Set the `cdr` of `(apply #'assoc item alist args)` to `new-value`." 93 | (setf (cdr (apply #'assoc item alist args)) new-value)) 94 | 95 | (defun (setf rassocar) (new-value item alist &rest args) 96 | "Set the `car` of `(apply #'rassoc item alist args)` to `new-value`." 97 | (setf (car (apply #'rassoc item alist args)) new-value)) 98 | 99 | (defun (setf rassocdr) (new-value item alist &rest args) 100 | "Set the `cdr` of `(apply #'rassoc item alist args)` to `new-value`." 101 | (setf (cdr (apply #'rassoc item alist args)) new-value)) 102 | -------------------------------------------------------------------------------- /src/math.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.math) 2 | 3 | 4 | ;;;; Math --------------------------------------------------------------------- 5 | (defconstant tau (* pi 2)) ; fuck a pi 6 | 7 | (defconstant tau/2 (* tau 1/2)) 8 | (defconstant 1/2tau (* tau 1/2)) 9 | 10 | (defconstant tau/4 (* tau 1/4)) 11 | (defconstant 1/4tau (* tau 1/4)) 12 | (defconstant 2/4tau (* tau 2/4)) 13 | (defconstant 3/4tau (* tau 3/4)) 14 | 15 | (defconstant tau/8 (* tau 1/8)) 16 | (defconstant 1/8tau (* tau 1/8)) 17 | (defconstant 2/8tau (* tau 2/8)) 18 | (defconstant 3/8tau (* tau 3/8)) 19 | (defconstant 4/8tau (* tau 4/8)) 20 | (defconstant 5/8tau (* tau 5/8)) 21 | (defconstant 6/8tau (* tau 6/8)) 22 | (defconstant 7/8tau (* tau 7/8)) 23 | 24 | 25 | (defun-inline degrees (radians) 26 | "Convert `radians` into degrees. 27 | 28 | The result will be the same type as `tau` and `pi`. 29 | 30 | " 31 | (* radians (/ 360 tau))) 32 | 33 | (defun-inline radians (degrees) 34 | "Convert `degrees` into radians. 35 | 36 | The result will be the same type as `tau` and `pi`. 37 | 38 | " 39 | (* degrees (/ tau 360))) 40 | 41 | 42 | (defun-inline square (x) 43 | (* x x)) 44 | 45 | (defun-inline dividesp (n divisor) 46 | "Return whether `n` is evenly divisible by `divisor`. 47 | 48 | The value returned will be the quotient when true, `nil` otherwise. 49 | 50 | " 51 | (multiple-value-bind (quotient remainder) (floor n divisor) 52 | (when (zerop remainder) 53 | quotient))) 54 | 55 | 56 | (declaim (ftype (function (real real real) 57 | (values real &optional)) 58 | norm lerp precise-lerp clamp)) 59 | 60 | (declaim (ftype (function (real real real real real) 61 | (values real &optional)) 62 | map-range)) 63 | 64 | 65 | (defun-inline norm (min max val) 66 | "Normalize `val` to a number between `0` and `1` (maybe). 67 | 68 | If `val` is between `max` and `min`, the result will be a number between `0` 69 | and `1`. 70 | 71 | If `val` lies outside of the range, it'll be still be scaled and will end up 72 | outside the 0/1 range. 73 | 74 | " 75 | (/ (- val min) 76 | (- max min))) 77 | 78 | (defun-inline lerp (from to n) 79 | "Lerp together `from` and `to` by factor `n`. 80 | 81 | You might want `precise-lerp` instead. 82 | 83 | " 84 | (+ from 85 | (* n (- to from)))) 86 | 87 | (defun-inline precise-lerp (from to n) 88 | "Lerp together `from` and `to` by factor `n`, precisely. 89 | 90 | Vanilla lerp does not guarantee `(lerp from to 0.0)` will return exactly 91 | `from` due to floating-point errors. This version will return exactly `from` 92 | when given a `n` of `0.0`, at the cost of an extra multiplication. 93 | 94 | " 95 | (+ (* (- 1 n) from) 96 | (* n to))) 97 | 98 | (defun-inline map-range (source-from source-to dest-from dest-to source-val) 99 | "Map `source-val` from the source range to the destination range. 100 | 101 | Example: 102 | 103 | ; source dest value 104 | (map-range 0.0 1.0 10.0 20.0 0.2) 105 | => 12.0 106 | 107 | " 108 | (lerp dest-from dest-to 109 | (norm source-from source-to source-val))) 110 | 111 | (defun-inline clamp (from to value) 112 | "Clamp `value` between `from` and `to`." 113 | (let ((max (max from to)) 114 | (min (min from to))) 115 | (cond 116 | ((> value max) max) 117 | ((< value min) min) 118 | (t value)))) 119 | 120 | (defun-inline in-range-p (low value high) 121 | "Return whether `low` <= `value` < `high`." 122 | (and (<= low value) 123 | (< value high))) 124 | 125 | 126 | (defun-inline digit (position integer &optional (base 10)) 127 | "Return the value of the digit at `position` in `integer`. 128 | 129 | Examples: 130 | 131 | (digit 0 135) ; => 5 132 | (digit 1 135) ; => 3 133 | (digit 2 135) ; => 1 134 | 135 | (digit 0 #xD4 16) ; => 4 136 | (digit 1 #xD4 16) ; => 13 137 | 138 | " 139 | (_ integer 140 | (floor _ (expt base position)) 141 | (mod _ base))) 142 | 143 | -------------------------------------------------------------------------------- /src/mutation.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.mutation) 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (defun build-zap (place expr env) 5 | (multiple-value-bind (temps exprs stores store-expr access-expr) 6 | (get-setf-expansion place env) 7 | `(let* (,@(mapcar #'list temps exprs) 8 | (,(car stores) (symbol-macrolet ((% ,access-expr)) 9 | ,expr))) 10 | ,store-expr)))) 11 | 12 | (defmacro zapf (&rest place-expr-pairs &environment env) 13 | "Update each `place` by evaluating `expr` with `%` bound to the current value. 14 | 15 | `zapf` works like `setf`, but when evaluating the value expressions the symbol 16 | `%` will be bound to the current value of the place. 17 | 18 | Examples: 19 | 20 | (zapf foo (1+ %) 21 | (car bar) (if (> % 10) :a :b)) 22 | 23 | " 24 | ;; original idea/name from http://malisper.me/2015/09/29/zap/ 25 | `(progn 26 | ,@(loop :for (place expr . nil) :on place-expr-pairs :by #'cddr 27 | :collect (build-zap place expr env)))) 28 | 29 | 30 | (define-modify-macro mulf (factor) * 31 | "Multiply `place` by `factor` in-place.") 32 | 33 | 34 | (defun %divf (value &optional divisor) 35 | (if divisor 36 | (/ value divisor) 37 | (/ value))) 38 | 39 | (define-modify-macro divf (&optional divisor) %divf 40 | "Divide `place` by `divisor` in-place. 41 | 42 | If `divisor` is not given, `place` will be set to `(/ 1 place)`. 43 | 44 | ") 45 | 46 | 47 | (define-modify-macro modf (divisor) mod 48 | "Modulo `place` by `divisor` in-place.") 49 | 50 | (define-modify-macro remainderf (divisor) rem 51 | "Remainder `place` by `divisor` in-place.") 52 | 53 | (define-modify-macro truncatef (divisor) truncate 54 | "Truncate `place` by `divisor` in-place.") 55 | 56 | (define-modify-macro clampf (from to) losh.math:clamp 57 | "Clamp `place` between `from` and `to` in-place.") 58 | 59 | (define-modify-macro negatef () - 60 | "Negate the value of `place`.") 61 | 62 | (define-modify-macro notf () not 63 | "Set `place` to `(not place)` in-place.") 64 | 65 | 66 | (defun %funcall (value function) 67 | (funcall function value)) 68 | 69 | (define-modify-macro %callf (function) %funcall 70 | "Set `place` to the result of calling `function` on its current value.") 71 | 72 | 73 | (defmacro callf (&rest place-function-pairs) 74 | "Set each `place` to the result of calling `function` on its current value. 75 | 76 | Examples: 77 | 78 | (let ((x 10) (y 20)) 79 | (callf x #'1- 80 | y #'1+) 81 | (list x y)) 82 | => 83 | (9 21) 84 | " 85 | `(progn 86 | ,@(loop :for (place function . nil) :on place-function-pairs :by #'cddr 87 | :collect `(%callf ,place ,function)))) 88 | 89 | (eval-when (:compile-toplevel :load-toplevel :execute) 90 | (defun build-ensure (place expr env) 91 | (multiple-value-bind (temps exprs stores store-expr access-expr) 92 | (get-setf-expansion place env) 93 | `(let* (,@(mapcar #'list temps exprs)) 94 | (or ,access-expr (let ((,(car stores) ,expr)) 95 | ,store-expr)))))) 96 | 97 | (defmacro ensuref (&rest place-expr-pairs &environment env) 98 | "Set each `place` that is currently `NIL` to its corresponding `expr`. 99 | 100 | Syntactic sugar where `(ensuref place expr)` expands to something like 101 | `(or place (setf place expr))` but doesn't multiply-evaluate the place. 102 | 103 | Examples: 104 | 105 | (defparameter *foo* nil) 106 | *foo* ; => NIL 107 | 108 | (ensuref *foo* (print 'hello)) ; prints HELLO 109 | *foo* ; => HELLO 110 | 111 | (ensuref *foo* (print 'world)) 112 | *foo* ; => HELLO 113 | 114 | " 115 | `(progn 116 | ,@(loop :for (place expr) :on place-expr-pairs :by #'cddr 117 | :collect (build-ensure place expr env)))) 118 | 119 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :losh.internal 2 | (:use :cl)) 3 | 4 | (in-package :losh.internal) 5 | 6 | (eval-when (:compile-toplevel :load-toplevel :execute) 7 | (defun external-symbols (package) 8 | (let ((symbols nil)) 9 | (do-external-symbols (s (find-package package) symbols) 10 | (push s symbols))))) 11 | 12 | (defmacro defpackage-inheriting (name parent-packages &rest args) 13 | `(defpackage ,name 14 | ,@args 15 | ,@(loop :for parent-package :in parent-packages 16 | :collect `(:use ,parent-package) 17 | :collect `(:export ,@(external-symbols parent-package))))) 18 | 19 | 20 | (defpackage :losh.base 21 | (:use :cl) 22 | (:documentation "A few utilities re-exported from Alexandria, plus some other basic stuff.") 23 | (:import-from :alexandria 24 | :compose :curry :rcurry 25 | :with-gensyms :once-only 26 | :ensure-list 27 | ) 28 | (:export 29 | :losh 30 | 31 | :compose :curry :rcurry 32 | :with-gensyms :once-only 33 | :ensure-list 34 | 35 | :timing ; both profiling and iterate use this symbol 36 | 37 | :symb :mkstr)) 38 | 39 | 40 | (defpackage :losh.chili-dogs 41 | (:use :cl :iterate :losh.base) 42 | (:documentation "Gotta go FAST.") 43 | (:export 44 | :defun-inline 45 | :defun-inlineable)) 46 | 47 | (defpackage :losh.clos 48 | (:use :cl :iterate :losh.base) 49 | (:documentation "Utilities for working with CLOS.") 50 | (:export 51 | :defclass* 52 | :define-condition* 53 | :slot-value-or 54 | :ensure-slot-value)) 55 | 56 | (defpackage :losh.eldritch-horrors 57 | (:use :cl :iterate :losh.base) 58 | (:documentation "Abandon all hope, ye who enter here.") 59 | (:export 60 | :eval-dammit 61 | :define-with-macro 62 | :scratch)) 63 | 64 | (defpackage :losh.functions 65 | (:use :cl :iterate :losh.base) 66 | (:documentation "Utilities for working with higher-order functions.") 67 | (:export 68 | :juxt 69 | :nullary 70 | :fixed-point)) 71 | 72 | (defpackage :losh.hash-sets 73 | (:use :cl :iterate :losh.base) 74 | (:documentation "Simple hash set implementation.") 75 | (:export 76 | :hash-set 77 | :make-hash-set 78 | :copy-hash-set 79 | 80 | :hset-empty-p 81 | :hset-contains-p 82 | :hset-elements 83 | :hset-count 84 | 85 | :hset-insert! 86 | :hset-remove! 87 | :hset-pop! 88 | :hset-clear! 89 | 90 | :hset= 91 | 92 | :hset-union 93 | :hset-union! 94 | :hset-intersection 95 | :hset-intersection! 96 | :hset-difference 97 | :hset-difference! 98 | :hset-filter 99 | :hset-filter! 100 | :hset-map 101 | :hset-map! 102 | :hset-reduce 103 | 104 | :do-hash-set)) 105 | 106 | (defpackage :losh.streams 107 | (:use :cl :iterate :losh.base) 108 | (:documentation "Utilities related to strings, reading, and/or printing.") 109 | (:export 110 | :with-eof-handled)) 111 | 112 | 113 | (defpackage :losh.io 114 | (:use :cl :iterate :losh.base) 115 | (:documentation "Utilities for input/output/reading/etc.") 116 | (:export 117 | :read-all 118 | :read-all-from-file 119 | :read-all-from-string)) 120 | 121 | (defpackage :losh.lists 122 | (:use :cl :iterate :losh.base) 123 | (:documentation "Utilities for operating on lists.") 124 | (:export 125 | :0.. :1.. :range 126 | :0... :1... :irange 127 | :somelist 128 | :assocar :assocdr 129 | :rassocar :rassocdr)) 130 | 131 | (defpackage :losh.mutation 132 | (:use :cl :iterate :losh.base) 133 | (:documentation "Utilities for mutating places in-place.") 134 | (:export 135 | :zapf 136 | :% 137 | :mulf 138 | :divf 139 | :modf 140 | :remainderf 141 | :truncatef 142 | :clampf 143 | :negatef 144 | :notf 145 | :callf 146 | :ensuref)) 147 | 148 | (defpackage :losh.shell 149 | (:use :cl :iterate :losh.base) 150 | (:documentation "Utilities for interacting with external programs.") 151 | (:export 152 | :sh 153 | :pbcopy 154 | :pbpaste 155 | :*pbcopy-command* 156 | :*pbpaste-command*)) 157 | 158 | 159 | (defpackage :losh.arrays 160 | (:use :cl :iterate :losh.base 161 | :losh.chili-dogs) 162 | (:documentation "Utilities related to arrays.") 163 | (:export 164 | :do-array 165 | :bisect-left 166 | :bisect-right 167 | :fill-multidimensional-array 168 | :fill-multidimensional-array-t 169 | :fill-multidimensional-array-fixnum 170 | :fill-multidimensional-array-single-float 171 | :vector-last)) 172 | 173 | (defpackage :losh.bits 174 | (:use :cl :iterate :losh.base 175 | :losh.chili-dogs) 176 | (:documentation "Utilities for low-level bit stuff.") 177 | (:export 178 | :+/8 179 | :-/8 180 | :+/16 181 | :-/16 182 | :+/32 183 | :-/32 184 | :+/64 185 | :-/64)) 186 | 187 | (defpackage :losh.queues 188 | (:use :cl :iterate :losh.base 189 | :losh.chili-dogs) 190 | (:documentation "A simple queue implementation.") 191 | (:export 192 | :queue 193 | :make-queue 194 | :queue-contents 195 | :queue-size 196 | :queue-empty-p 197 | :enqueue 198 | :dequeue 199 | :queue-append)) 200 | 201 | (defpackage :losh.priority-queues 202 | (:use :cl :iterate :losh.base 203 | :losh.mutation) 204 | (:documentation "Jankass priority queue implementation.") 205 | (:export 206 | :priority-queue 207 | :make-priority-queue 208 | 209 | :pq-insert 210 | :pq-ensure 211 | :pq-dequeue)) 212 | 213 | (defpackage :losh.ring-buffers 214 | (:use :cl :iterate :losh.base 215 | :losh.chili-dogs 216 | :losh.eldritch-horrors 217 | :losh.mutation) 218 | (:documentation "Simple ring buffer implementation.") 219 | (:export 220 | 221 | :do-ring-buffer 222 | :make-ring-buffer 223 | :rb-clear 224 | :rb-contents 225 | :rb-count 226 | :rb-empty-p 227 | :rb-full-p 228 | :rb-pop 229 | :rb-push 230 | :rb-ref 231 | :rb-safe-push 232 | :rb-size 233 | :ring-buffer 234 | 235 | )) 236 | 237 | 238 | (defpackage :losh.control-flow 239 | (:use :cl :iterate :losh.base 240 | :losh.queues) 241 | (:documentation "Utilities for managing control flow.") 242 | (:export 243 | :_ 244 | :nest 245 | :recursively 246 | :recur 247 | :when-found 248 | :if-found 249 | :gathering 250 | :gathering-vector 251 | :gather 252 | :if-let 253 | :if-let* 254 | :when-let 255 | :when-let* 256 | :multiple-value-bind* 257 | :do-repeat 258 | :do-range 259 | :do-irange 260 | :do-file 261 | :do-vector)) 262 | 263 | 264 | (defpackage :losh.astar 265 | (:use :cl :iterate :losh.base 266 | :losh.chili-dogs 267 | :losh.control-flow) 268 | (:documentation "A★ search in a handy package.") 269 | (:export 270 | :astar)) 271 | 272 | (defpackage :losh.math 273 | (:use :cl :iterate :losh.base 274 | :losh.chili-dogs 275 | :losh.control-flow) 276 | (:documentation "Utilities related to math and numbers.") 277 | (:export 278 | :tau 279 | :tau/2 280 | :1/2tau 281 | :tau/4 282 | :1/4tau 283 | :2/4tau 284 | :3/4tau 285 | :tau/8 286 | :1/8tau 287 | :2/8tau 288 | :3/8tau 289 | :4/8tau 290 | :5/8tau 291 | :6/8tau 292 | :7/8tau 293 | 294 | :clamp 295 | :degrees 296 | :dividesp 297 | :in-range-p 298 | :lerp 299 | :map-range 300 | :norm 301 | :precise-lerp 302 | :radians 303 | :square 304 | :digit)) 305 | 306 | (defpackage :losh.hash-tables 307 | (:use :cl :iterate :losh.base 308 | :losh.control-flow) 309 | (:documentation "Utilities for operating on hash tables.") 310 | (:export 311 | :hash-table-contents 312 | :mutate-hash-values 313 | :remhash-if 314 | :remhash-if-not 315 | :remhash-if-key 316 | :remhash-if-not-key 317 | :remhash-if-value 318 | :remhash-if-not-value)) 319 | 320 | (defpackage :losh.iterate 321 | (:use :cl :iterate :losh.base 322 | :losh.hash-sets 323 | :losh.ring-buffers) 324 | (:documentation "Custom `iterate` drivers and clauses.") 325 | (:export 326 | 327 | :across-flat-array 328 | :against 329 | :anding 330 | :averaging 331 | :collect-frequencies 332 | :collect-hash 333 | :collect-set 334 | :concatenating 335 | :cycling 336 | :end 337 | :every-nth 338 | :finding-all 339 | :finding-first 340 | :for-nested 341 | :if-first-iteration 342 | :in-array 343 | :in-hashset 344 | :in-lists 345 | :in-ring-buffer 346 | :in-sequences 347 | :in-whatever 348 | :index-of-flat-array 349 | :initially 350 | :into 351 | :macroexpand-iterate 352 | :matching 353 | :modulo 354 | :oring 355 | :overlap 356 | :pairs-of-list 357 | :per-iteration-into 358 | :real-time 359 | :returning 360 | :run-time 361 | :seed 362 | :since-start-into 363 | :skip-origin 364 | :start 365 | :test 366 | :then 367 | :timing 368 | :unless-first-iteration 369 | :unless-first-time 370 | :when-first-iteration 371 | :when-first-time 372 | :window 373 | :with-result 374 | :within-radius 375 | 376 | )) 377 | 378 | 379 | (defpackage :losh.readtable 380 | (:use :cl :losh.base) 381 | (:documentation "Custom readtable.") 382 | (:export :losh)) 383 | 384 | 385 | (defpackage :losh.random 386 | (:use :cl :iterate :losh.base 387 | :losh.chili-dogs 388 | :losh.math) 389 | (:documentation "Utilities related to randomness.") 390 | (:export 391 | :randomp 392 | :random-elt 393 | :random-range 394 | 395 | :random-range-exclusive 396 | :random-range-inclusive 397 | :random-around 398 | :random-gaussian 399 | :random-gaussian-integer 400 | :d)) 401 | 402 | (defpackage :losh.sequences 403 | (:use :cl :iterate :losh.base 404 | :losh.chili-dogs 405 | :losh.functions 406 | :losh.hash-tables 407 | :losh.iterate 408 | :losh.mutation) 409 | (:documentation "Utilities for operating on sequences.") 410 | (:export 411 | :extrema 412 | :enumerate 413 | :prefix-sums 414 | :frequencies 415 | :proportions 416 | :group-by 417 | :take 418 | :take-while 419 | :drop 420 | :drop-while 421 | :chunk 422 | :ngrams 423 | :summation 424 | :product 425 | :doseq 426 | :string-join 427 | :reductions 428 | :define-sorting-predicate 429 | :make-sorting-predicate)) 430 | 431 | (defpackage :losh.debugging 432 | (:use :cl :iterate :losh.base 433 | :losh.math 434 | :losh.control-flow 435 | :losh.hash-tables) 436 | (:documentation "Utilities for figuring out what the hell is going on.") 437 | (:export 438 | 439 | #+sbcl :profile 440 | #+sbcl :profile-when 441 | #+sbcl :start-profiling 442 | #+sbcl :stop-profiling 443 | :aesthetic-string 444 | :bits 445 | :comment 446 | :dis 447 | :gimme 448 | :hex 449 | :phr 450 | :pr 451 | :pretty-print-hash-table 452 | :print-table 453 | :prl 454 | :shut-up 455 | :structural-string 456 | :timing 457 | 458 | )) 459 | 460 | 461 | (defpackage :losh.gnuplot 462 | (:use :cl :iterate :losh.base 463 | :losh.control-flow 464 | :losh.debugging 465 | :losh.lists 466 | :losh.sequences) 467 | (:documentation "Utilities for plotting data with gnuplot.") 468 | (:export 469 | :gnuplot 470 | :with-gnuplot 471 | :gnuplot-data 472 | :gnuplot-command 473 | :gnuplot-format 474 | :plot)) 475 | 476 | (defpackage :losh.weightlists 477 | (:use :cl :iterate :losh.base 478 | :losh.sequences) 479 | (:documentation 480 | "A simple data structure for choosing random items with weighted probabilities.") 481 | (:export 482 | :weightlist 483 | :weightlist-weights 484 | :weightlist-items 485 | :make-weightlist 486 | :weightlist-random)) 487 | 488 | 489 | (defpackage-inheriting :losh 490 | ( 491 | 492 | :losh.base 493 | :losh.arrays 494 | :losh.astar 495 | :losh.bits 496 | :losh.chili-dogs 497 | :losh.clos 498 | :losh.control-flow 499 | :losh.debugging 500 | :losh.eldritch-horrors 501 | :losh.functions 502 | :losh.gnuplot 503 | :losh.hash-sets 504 | :losh.hash-tables 505 | :losh.io 506 | :losh.iterate 507 | :losh.lists 508 | :losh.math 509 | :losh.mutation 510 | :losh.priority-queues 511 | :losh.queues 512 | :losh.random 513 | :losh.readtable 514 | :losh.ring-buffers 515 | :losh.sequences 516 | :losh.shell 517 | :losh.streams 518 | :losh.weightlists 519 | 520 | ) 521 | (:use :cl :iterate :losh.base) 522 | (:documentation 523 | "This package exports all of the symbols in the other packages. 524 | 525 | If you just want to get everything you can `:use` this one and be done with 526 | it. Otherwise you can `:use` only the ones you need. 527 | 528 | ")) 529 | 530 | 531 | ;;;; Remember to add it to the docs! 532 | -------------------------------------------------------------------------------- /src/priority-queues.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.priority-queues) 2 | 3 | (defstruct (priority-queue (:conc-name pq-) 4 | (:constructor make-priority-queue%)) 5 | (contents nil) 6 | (predicate #'<) 7 | (test #'eql)) 8 | 9 | 10 | (defun make-priority-queue (&key (priority-predicate #'<) (element-test #'eql)) 11 | "Create and return a fresh priority queue. 12 | 13 | `priority-predicate` is the comparison function used to compare priorities, 14 | and should be a `<`-like predicate. 15 | 16 | `element-test` should be the equality predicate for elements. 17 | 18 | " 19 | (make-priority-queue% :predicate priority-predicate :test element-test)) 20 | 21 | 22 | (defmethod print-object ((object priority-queue) stream) 23 | (print-unreadable-object (object stream :type t :identity t) 24 | (prin1 (pq-contents object) stream))) 25 | 26 | 27 | (defun pqn-priority (node) 28 | (first node)) 29 | 30 | (defun pqn-element (node) 31 | (second node)) 32 | 33 | (defun pq-resort (pq) 34 | (zapf (pq-contents pq) 35 | (sort % (pq-predicate pq) :key #'pqn-priority)) 36 | pq) 37 | 38 | (defun pq-lookup (pq element) 39 | (find element (pq-contents pq) 40 | :key #'pqn-element 41 | :test (pq-test pq))) 42 | 43 | 44 | (defun pq-insert (pq element priority) 45 | "Insert `element` into `pq` with `priority`. 46 | 47 | Returns `pq` (which has been modified). 48 | 49 | " 50 | (zapf (pq-contents pq) 51 | (merge 'list `((,priority ,element)) % (pq-predicate pq) 52 | :key #'pqn-priority)) 53 | pq) 54 | 55 | (defun pq-ensure (pq element priority) 56 | "Ensure `element` is in `pq` with `priority`. 57 | 58 | If `element` is already in `pq` its priority will be set to `priority`. 59 | Otherwise it will be inserted as if by calling `pq-insert`. 60 | 61 | Returns `pq` (which may have been modified). 62 | 63 | " 64 | (let ((existing (pq-lookup pq element))) 65 | (if existing 66 | (progn (setf (car existing) priority) 67 | (pq-resort pq)) 68 | (pq-insert pq element priority))) 69 | pq) 70 | 71 | 72 | (defun pq-dequeue (pq) 73 | "Remove and return the element in `pq` with the lowest-numbered priority. 74 | 75 | If `pq` is empty `nil` will be returned. 76 | 77 | A second value is also returned, which will be `t` if an element was present 78 | or `nil` if the priority queue was empty. 79 | 80 | " 81 | (if (pq-contents pq) 82 | (values (pqn-element (pop (pq-contents pq))) t) 83 | (values nil nil))) 84 | 85 | 86 | -------------------------------------------------------------------------------- /src/queues.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.queues) 2 | 3 | ;;; Based on the PAIP queues (thanks, Norvig), but beefed up a little bit to add 4 | ;;; tracking of the queue size. 5 | 6 | (defstruct (queue (:constructor make-queue%)) 7 | (contents nil :type list) 8 | (last nil :type list) 9 | (size 0 :type fixnum)) 10 | 11 | 12 | (declaim 13 | (ftype (function (&key (:initial-contents list)) 14 | (values queue &optional)) 15 | make-queue) 16 | (ftype (function (queue) 17 | (values boolean &optional)) 18 | queue-empty-p) 19 | (ftype (function (t queue) 20 | (values fixnum &optional)) 21 | enqueue) 22 | (ftype (function (queue) 23 | (values t &optional)) 24 | dequeue) 25 | (ftype (function (queue list) 26 | (values fixnum &optional)) 27 | queue-append)) 28 | 29 | 30 | (defun-inlineable make-queue (&key initial-contents) 31 | "Allocate and return a fresh queue." 32 | (let ((queue (make-queue%))) 33 | (when initial-contents 34 | (queue-append queue initial-contents)) 35 | queue)) 36 | 37 | (defun-inlineable queue-empty-p (queue) 38 | "Return whether `queue` is empty." 39 | (zerop (queue-size queue))) 40 | 41 | (defun-inlineable enqueue (item queue) 42 | "Enqueue `item` in `queue`, returning the new size of the queue." 43 | (let ((cell (cons item nil))) 44 | (if (queue-empty-p queue) 45 | (setf (queue-contents queue) cell) 46 | (setf (cdr (queue-last queue)) cell)) 47 | (setf (queue-last queue) cell)) 48 | (incf (queue-size queue))) 49 | 50 | (defun-inlineable dequeue (queue) 51 | "Dequeue an item from `queue` and return it." 52 | (when (zerop (decf (queue-size queue))) 53 | (setf (queue-last queue) nil)) 54 | (pop (queue-contents queue))) 55 | 56 | (defun-inlineable queue-append (queue list) 57 | "Enqueue each element of `list` in `queue` and return the queue's final size." 58 | (loop :for item :in list 59 | :for size = (enqueue item queue) 60 | :finally (return size))) 61 | 62 | -------------------------------------------------------------------------------- /src/random.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.random) 2 | 3 | (defun-inline epsilon (val) 4 | (etypecase val 5 | (integer 1) 6 | (short-float short-float-epsilon) 7 | (long-float long-float-epsilon) 8 | (single-float single-float-epsilon) 9 | (double-float double-float-epsilon))) 10 | 11 | 12 | (defun-inlineable randomp (&optional (chance 0.5) (generator #'random)) 13 | "Return a random boolean with `chance` probability of `t`." 14 | (< (funcall generator 1.0) chance)) 15 | 16 | (defun random-elt (seq &optional (generator #'random)) 17 | "Return a random element of `seq`, and whether one was available. 18 | 19 | This will NOT be efficient for lists. 20 | 21 | Examples: 22 | 23 | (random-elt #(1 2 3)) 24 | => 1 25 | T 26 | 27 | (random-elt nil) 28 | => nil 29 | nil 30 | 31 | " 32 | (let ((length (length seq))) 33 | (if (zerop length) 34 | (values nil nil) 35 | (values (elt seq (funcall generator length)) t)))) 36 | 37 | (defun-inlineable random-range (min max &optional (generator #'random)) 38 | "Return a random number in [`min`, `max`)." 39 | (+ min (funcall generator (- max min)))) 40 | 41 | (defun-inlineable random-range-inclusive (min max &optional (generator #'random)) 42 | "Return a random number in [`min`, `max`]." 43 | (+ min (funcall generator (+ (- max min) (epsilon min))))) 44 | 45 | (defun-inlineable random-range-exclusive (min max &optional (generator #'random)) 46 | "Return a random number in (`min`, `max`)." 47 | (+ (epsilon min) min (funcall generator (- max min (epsilon min))))) 48 | 49 | (defun-inlineable random-around (value spread &optional (generator #'random)) 50 | "Return a random number within `spread` of `value` (inclusive)." 51 | (random-range-inclusive (- value spread) 52 | (+ value spread) 53 | generator)) 54 | 55 | 56 | (let (spare) 57 | (defun clear-gaussian-spare () 58 | (setf spare nil)) 59 | (defun random-gaussian (mean standard-deviation &optional (generator #'random)) 60 | "Return a random float from a gaussian distribution. NOT THREAD-SAFE (yet)!" 61 | ;; https://en.wikipedia.org/wiki/Marsaglia_polar_method 62 | (declare (optimize (speed 3)) 63 | (inline random-range)) 64 | (let ((mean (coerce mean 'single-float)) 65 | (standard-deviation (coerce standard-deviation 'single-float))) 66 | (flet ((scale (n) 67 | (+ mean (* n standard-deviation)))) 68 | (if spare 69 | (prog1 70 | (scale (the single-float spare)) 71 | (setf spare nil)) 72 | (loop 73 | :for u :of-type single-float = (+ -1.0 (the single-float (funcall generator 2.0))) 74 | :for v :of-type single-float = (+ -1.0 (the single-float (funcall generator 2.0))) 75 | :for s :of-type single-float = (+ (square u) (square v)) 76 | :while (or (>= s 1.0) (= s 0.0)) 77 | :finally 78 | (setf s (sqrt (/ (* -2.0 (the (single-float * (0.0)) (log s))) 79 | s)) 80 | spare (* v s)) 81 | (return (scale (* u s))))))))) 82 | 83 | (defun random-gaussian-integer (mean standard-deviation &optional (generator #'random)) 84 | "Return a random integer from a gaussian distribution. NOT THREAD-SAFE (yet)!" 85 | (values (round (random-gaussian mean standard-deviation generator)))) 86 | 87 | 88 | (defun d (n sides &optional (plus 0)) 89 | "Roll some dice. 90 | 91 | Examples: 92 | 93 | (d 1 4) ; rolls 1d4 94 | (d 2 8) ; rolls 2d8 95 | (d 1 10 -1) ; rolls 1d10-1 96 | 97 | " 98 | (+ (iterate (repeat n) 99 | (sum (1+ (random sides)))) 100 | plus)) 101 | 102 | -------------------------------------------------------------------------------- /src/readtable.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.readtable) 2 | 3 | 4 | (defun sharp-semicolon-reader (stream sub-char numarg) 5 | (declare (ignore sub-char numarg)) 6 | (loop :while (read-line stream nil nil)) 7 | (values)) 8 | 9 | (defun shebang-reader (stream sub-char numarg) 10 | (declare (ignore sub-char numarg)) 11 | (read-line stream) 12 | (values)) 13 | 14 | (named-readtables:defreadtable losh 15 | (:merge :standard losh.hash-tables::hash-table-constructor-syntax) 16 | (:macro-char #\# :dispatch) 17 | (:dispatch-macro-char #\# #\; #'sharp-semicolon-reader) 18 | (:dispatch-macro-char #\# #\! #'shebang-reader)) 19 | -------------------------------------------------------------------------------- /src/ring-buffers.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.ring-buffers) 2 | 3 | ;;;; Data Structure ----------------------------------------------------------- 4 | (defstruct (ring-buffer (:constructor make-ring-buffer%) 5 | (:conc-name nil)) 6 | (data (error "Data is required.") :type simple-vector) 7 | (r 0 :type fixnum) 8 | (w 0 :type fixnum)) 9 | 10 | (defun make-ring-buffer (&key (size 64)) 11 | "Create and return a fresh ring buffer able to hold `(1- size)` elements." 12 | (check-type size (and (integer 2) fixnum)) 13 | (make-ring-buffer% :data (make-array (list size) :initial-element nil))) 14 | 15 | 16 | ;;;; Operations --------------------------------------------------------------- 17 | (defun-inline size (ring-buffer) 18 | (length (data ring-buffer))) 19 | 20 | (defun rb-size (ring-buffer) 21 | "Return the size of `ring-buffer`. 22 | 23 | A ring buffer can hold at most `(1- (rb-size ring-buffer))` elements. 24 | 25 | " 26 | (size ring-buffer)) 27 | 28 | (defun rb-count (ring-buffer) 29 | "Return the number of elements currently stored in `ring-buffer`." 30 | (mod (- (w ring-buffer) (r ring-buffer)) 31 | (size ring-buffer))) 32 | 33 | 34 | (defun rb-clear (ring-buffer) 35 | "Clear the contents of `ring-buffer`." 36 | (fill (data ring-buffer) nil) 37 | (setf (r ring-buffer) 0 38 | (w ring-buffer) 0) 39 | nil) 40 | 41 | 42 | (defmacro 1+mod ((field ring-buffer)) 43 | (once-only (ring-buffer) 44 | (with-gensyms (result) 45 | `(let ((,result (1+ (,field ,ring-buffer)))) 46 | (if (= (size ,ring-buffer) ,result) 47 | 0 48 | ,result))))) 49 | 50 | (defmacro 1+modf ((field ring-buffer)) 51 | (once-only (ring-buffer) 52 | `(setf (,field ,ring-buffer) (1+mod (,field ,ring-buffer))))) 53 | 54 | 55 | (defun rb-full-p (ring-buffer) 56 | "Return whether `ring-buffer` is full." 57 | (= (1+mod (w ring-buffer)) 58 | (r ring-buffer))) 59 | 60 | (defun rb-empty-p (ring-buffer) 61 | "Return whether `ring-buffer` is empty." 62 | (= (w ring-buffer) (r ring-buffer))) 63 | 64 | 65 | (defun rb-push (ring-buffer object) 66 | "Push `object` into `ring-buffer` and return `object`. 67 | 68 | If `ring-buffer` is full, its oldest element will be silently dropped. If you 69 | want an error to be signaled instead, use `rb-safe-push`. 70 | 71 | " 72 | (setf (svref (data ring-buffer) (w ring-buffer)) object) 73 | (let ((w (1+mod (w ring-buffer)))) 74 | (setf (w ring-buffer) w) 75 | (when (= w (r ring-buffer)) 76 | (setf (svref (data ring-buffer) w) nil) 77 | (1+modf (r ring-buffer)))) 78 | object) 79 | 80 | (defun rb-safe-push (ring-buffer object) 81 | "Push `object` into `ring-buffer`, or signal an error if it is already full." 82 | (assert (not (rb-full-p ring-buffer)) () 83 | "Cannot safely push ~S to a full ring buffer ~S." object ring-buffer) 84 | (setf (svref (data ring-buffer) (w ring-buffer)) object) 85 | (1+modf (w ring-buffer)) 86 | object) 87 | 88 | 89 | (defun-inline pop% (vector index) 90 | (prog1 (svref vector index) 91 | (setf (svref vector index) nil))) 92 | 93 | (defun rb-pop (ring-buffer) 94 | "Remove and return the oldest element of `ring-buffer`, or signal an error if it is empty." 95 | (if (rb-empty-p ring-buffer) 96 | (error "Cannot pop from empty ring buffer ~S." ring-buffer) 97 | (prog1 (pop% (data ring-buffer) (r ring-buffer)) 98 | (1+modf (r ring-buffer))))) 99 | 100 | 101 | (defun-inline bad-index (ring-buffer index) 102 | (error "Invalid index ~D for ring buffer with ~D element~:P." 103 | index (rb-count ring-buffer))) 104 | 105 | (defun-inline compute-index (ring-buffer index) 106 | (if (minusp index) 107 | (if (< index (- (rb-count ring-buffer))) 108 | (bad-index ring-buffer index) 109 | (mod (+ index (w ring-buffer)) (size ring-buffer))) 110 | (if (>= index (rb-count ring-buffer)) 111 | (bad-index ring-buffer index) 112 | (mod (+ index (r ring-buffer)) (size ring-buffer))))) 113 | 114 | (defun rb-ref (ring-buffer index) 115 | "Return the element of `ring-buffer` at `index`. 116 | 117 | Elements are indexed oldest to newest: element 0 is the oldest element in the 118 | ring buffer, element 1 is the second oldest, and so on. 119 | 120 | Negative indices are supported: element -1 is the newest element, element -2 121 | the second newest, and so on. 122 | 123 | An error will be signaled if `index` is out of range. 124 | 125 | " 126 | (svref (data ring-buffer) (compute-index ring-buffer index))) 127 | 128 | 129 | ;;;; Iteration ---------------------------------------------------------------- 130 | (defmacro do-ring-buffer ((symbol ring-buffer) &body body) 131 | "Iterate over `ring-buffer`, executing `body` with `symbol` bound to each element. 132 | 133 | Elements are walked oldest to newest. 134 | 135 | " 136 | (with-gensyms (r w d s) 137 | (once-only (ring-buffer) 138 | `(do ((,r (r ,ring-buffer)) 139 | (,w (w ,ring-buffer)) 140 | (,d (data ,ring-buffer)) 141 | (,s (size ,ring-buffer))) 142 | ((= ,r ,w)) 143 | (let ((,symbol (svref ,d ,r))) 144 | ,@body) 145 | (incf ,r) 146 | (when (= ,r ,s) (setf ,r 0)))))) 147 | 148 | (defun rb-contents (ring-buffer &key (result-type 'list)) 149 | "Return a fresh sequence of the contents of `ring-buffer` (oldest to newest). 150 | 151 | `result-type` can be `list` or `vector`. 152 | 153 | " 154 | (ecase result-type 155 | (list (loop :with r = (r ring-buffer) 156 | :with w = (w ring-buffer) 157 | :with d = (data ring-buffer) 158 | :with s = (size ring-buffer) 159 | :until (= r w) 160 | :collect (svref d r) 161 | :do (incf r) 162 | :when (= r s) :do (setf r 0))) 163 | (vector 164 | (let* ((n (rb-count ring-buffer)) 165 | (result (make-array n)) 166 | (data (data ring-buffer)) 167 | (r (r ring-buffer)) 168 | (w (w ring-buffer))) 169 | (if (<= r w) 170 | (replace result data :start2 r :end2 w) 171 | (progn (replace result data :start2 r) 172 | (replace result data :start2 0 :end2 w :start1 (- (size ring-buffer) r)))) 173 | result)))) 174 | 175 | 176 | ;;;; Printing ----------------------------------------------------------------- 177 | (defvar *debug-ring-buffers* nil) 178 | 179 | (defmethod print-object ((o ring-buffer) s) 180 | (print-unreadable-object (o s :type t :identity t) 181 | (if *debug-ring-buffers* 182 | (format s "~D/~D contents ~:S array [~A]" 183 | (rb-count o) (size o) (rb-contents o) 184 | (with-output-to-string (s) 185 | (loop :with r = (r o) 186 | :with w = (w o) 187 | :for i :from 0 188 | :for el :across (data o) 189 | :unless (zerop i) :do (princ #\space s) 190 | :do (format s (cond 191 | ((= i r w) "{R+W ~A}") 192 | ((= i r) "{R ~A}") 193 | ((= i w) "{W ~A}") 194 | (t "~A")) 195 | el)))) 196 | (format s "~D/~D" (rb-count o) (size o))))) 197 | -------------------------------------------------------------------------------- /src/sequences.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.sequences) 2 | 3 | (deftype array-index (&optional (length (1- array-dimension-limit))) 4 | "An integer in the range `[0, length)`. 5 | 6 | From Alexandria. 7 | 8 | " 9 | `(integer 0 (,length))) 10 | 11 | 12 | (defun prefix-sums (sequence &key key (result-type 'list)) 13 | "Return the prefix sums of the elements of `sequence`. 14 | 15 | If `key` is given, it will be called on the elements before summing. 16 | `result-type` must be a type suitable for passing to `map`. 17 | 18 | Example: 19 | 20 | (prefix-sums '(10 10 10 0 1)) 21 | ; => (10 20 30 30 31) 22 | 23 | (prefix-sums \"ABCD\" :key #'char-code :result-type '(vector fixnum)) 24 | ; => #(65 131 198 266) 25 | 26 | " 27 | (let ((sum 0)) 28 | (map result-type (lambda (x) (incf sum (if key (funcall key x) x))) 29 | sequence))) 30 | 31 | (defun frequencies (sequence &key (test #'eql) key) 32 | "Return a hash table containing the frequencies of the elements of `sequence`. 33 | 34 | When `key` is given, it will be called on the elements first before they are 35 | counted. 36 | 37 | Uses `test` for the `:test` of the hash table. 38 | 39 | Example: 40 | 41 | (frequencies '(foo foo bar)) 42 | => {foo 2 43 | bar 1} 44 | 45 | " 46 | (if key 47 | (iterate (for i :in-whatever sequence) 48 | (collect-frequencies (funcall key i) :test test)) 49 | (iterate (for i :in-whatever sequence) 50 | (collect-frequencies i :test test)))) 51 | 52 | (defun proportions (sequence &key (test 'eql) (float t) key) 53 | "Return a hash table containing the proportions of the items in `sequence`. 54 | 55 | When `key` is given, it will be called on the elements first before they are 56 | counted. 57 | 58 | Uses `test` for the `:test` of the hash table. 59 | 60 | If `float` is `t` the hash table values will be coerced to floats, otherwise 61 | they will be left as rationals. 62 | 63 | Example: 64 | 65 | (proportions '(foo foo bar)) 66 | => {foo 0.66666 67 | bar 0.33333} 68 | 69 | (proportions '(foo foo bar) :float nil) 70 | => {foo 2/3 71 | bar 1/3} 72 | 73 | " 74 | (let* ((freqs (frequencies sequence :test test :key key)) 75 | (total (reduce #'+ (alexandria:hash-table-values freqs) 76 | :initial-value (if float 1.0 1)))) 77 | (mutate-hash-values (lambda (v) (/ v total)) 78 | freqs))) 79 | 80 | (defun group-by (function sequence &key (test #'eql) (key #'identity)) 81 | "Return a hash table of the elements of `sequence` grouped by `function`. 82 | 83 | This function groups the elements of `sequence` into buckets. The bucket for 84 | an element is determined by calling `function` on it. 85 | 86 | The result is a hash table (with test `test`) whose keys are the bucket 87 | identifiers and whose values are lists of the elements in each bucket. The 88 | order of these lists is unspecified. 89 | 90 | If `key` is given it will be called on each element before passing it to 91 | `function` to produce the bucket identifier. This does not effect what is 92 | stored in the lists. 93 | 94 | Examples: 95 | 96 | (defparameter *items* '((1 foo) (1 bar) (2 cats) (3 cats))) 97 | 98 | (group-by #'first *items*) 99 | ; => { 1 ((1 foo) (1 bar)) 100 | ; 2 ((2 cats)) 101 | ; 3 ((3 cats)) } 102 | 103 | (group-by #'second *items*) 104 | ; => { foo ((1 foo)) 105 | ; bar ((1 bar)) 106 | ; cats ((2 cats) (3 cats)) } 107 | 108 | (group-by #'evenp *items* :key #'first) 109 | ; => { t ((2 cats)) 110 | ; nil ((1 foo) (1 bar) (3 cats)) } 111 | 112 | " 113 | (iterate 114 | (with result = (make-hash-table :test test)) 115 | (for i :in-whatever sequence) 116 | (push i (gethash (funcall function (funcall key i)) result)) 117 | (finally (return result)))) 118 | 119 | 120 | (defun-inline take-list (n list) 121 | (iterate (declare (iterate:declare-variables)) 122 | (repeat n) 123 | (for item :in list) 124 | (collect item))) 125 | 126 | (defun-inline take-seq (n seq) 127 | (subseq seq 0 (min n (length seq)))) 128 | 129 | (defun take (n seq) 130 | "Return a fresh sequence of the first `n` elements of `seq`. 131 | 132 | The result will be of the same type as `seq`. 133 | 134 | If `seq` is shorter than `n` a shorter result will be returned. 135 | 136 | Example: 137 | 138 | (take 2 '(a b c)) 139 | => (a b) 140 | 141 | (take 4 #(1)) 142 | => #(1) 143 | 144 | From Serapeum. 145 | 146 | " 147 | (check-type n array-index) 148 | (ctypecase seq 149 | (list (take-list n seq)) 150 | (sequence (take-seq n seq)))) 151 | 152 | 153 | (defun-inline take-while-list (predicate list) 154 | (iterate (for item :in list) 155 | (while (funcall predicate item)) 156 | (collect item))) 157 | 158 | (defun-inline take-while-seq (predicate seq) 159 | (subseq seq 0 (position-if-not predicate seq))) 160 | 161 | (defun take-while (predicate seq) 162 | "Take elements from `seq` as long as `predicate` remains true. 163 | 164 | The result will be a fresh sequence of the same type as `seq`. 165 | 166 | Example: 167 | 168 | (take-while #'evenp '(2 4 5 6 7 8)) 169 | ; => (2 4) 170 | 171 | (take-while #'evenp #(1)) 172 | ; => #() 173 | 174 | " 175 | (ctypecase seq 176 | (list (take-while-list predicate seq)) 177 | (sequence (take-while-seq predicate seq)))) 178 | 179 | 180 | (defun-inline drop-list (n list) 181 | (copy-list (nthcdr n list))) 182 | 183 | (defun-inline drop-seq (n seq) 184 | (subseq seq (min n (length seq)))) 185 | 186 | (defun drop (n seq) 187 | "Return a fresh copy of the `seq` without the first `n` elements. 188 | 189 | The result will be of the same type as `seq`. 190 | 191 | If `seq` is shorter than `n` an empty sequence will be returned. 192 | 193 | Example: 194 | 195 | (drop 2 '(a b c)) 196 | => (c) 197 | 198 | (drop 4 #(1)) 199 | => #() 200 | 201 | From Serapeum. 202 | 203 | " 204 | (check-type n array-index) 205 | (ctypecase seq 206 | (list (drop-list n seq)) 207 | (sequence (drop-seq n seq)))) 208 | 209 | 210 | (defun-inline drop-while-list (predicate list) 211 | (iterate (for tail :on list) 212 | (while (funcall predicate (first tail))) 213 | (finally (return (copy-list tail))))) 214 | 215 | (defun-inline drop-while-seq (predicate seq) 216 | (let ((start (position-if-not predicate seq))) 217 | (if start 218 | (subseq seq start) 219 | (subseq seq 0 0)))) 220 | 221 | (defun drop-while (predicate seq) 222 | "Drop elements from `seq` as long as `predicate` remains true. 223 | 224 | The result will be a fresh sequence of the same type as `seq`. 225 | 226 | Example: 227 | 228 | (drop-while #'evenp '(2 4 5 6 7 8)) 229 | ; => (5 6 7 8) 230 | 231 | (drop-while #'evenp #(2)) 232 | ; => #(2) 233 | 234 | " 235 | (ctypecase seq 236 | (list (drop-while-list predicate seq)) 237 | (sequence (drop-while-seq predicate seq)))) 238 | 239 | 240 | (defun-inline chunk-list (list chunk-size) 241 | ;; Since lists have O(N) access time, we iterate through manually, 242 | ;; collecting each chunk as we pass through it. Using SUBSEQ would 243 | ;; be O(N^2). 244 | (loop :while list 245 | :collect (loop :repeat chunk-size :while list :collect (pop list)))) 246 | 247 | (defun-inline chunk-sequence (sequence chunk-size) 248 | ;; For other sequences like strings or arrays, we can simply chunk 249 | ;; by repeated SUBSEQs. 250 | (loop :with len := (length sequence) 251 | :for i :below len :by chunk-size 252 | :collect (subseq sequence i (min len (+ chunk-size i))))) 253 | 254 | (defun chunk (sequence chunk-size) 255 | "Split `sequence` into a list of subsequences of size `chunk-size`. 256 | 257 | The final chunk may be smaller than `chunk-size` if the length of `sequence` 258 | is not evenly divisible by `chunk-size`. 259 | 260 | " 261 | ;; Based on `subdivide` from http://quickutil.org/ 262 | (check-type sequence sequence) 263 | (check-type chunk-size (integer 1)) 264 | (etypecase sequence 265 | (list (chunk-list sequence chunk-size)) 266 | (sequence (chunk-sequence sequence chunk-size)))) 267 | 268 | 269 | (defun-inline ngrams-list (n list) 270 | (loop :repeat (1+ (- (length list) n)) 271 | :for l :on list 272 | :collect (take-list n l))) 273 | 274 | (defun-inline ngrams-sequence (n sequence) 275 | (loop :for i :to (- (length sequence) n) 276 | :collect (subseq sequence i (+ i n)))) 277 | 278 | (defun ngrams (n sequence) 279 | "Return a list of the `n`grams of `sequence`. 280 | 281 | The length of `sequence` must be at least `n`. 282 | 283 | " 284 | ;; Based on `n-grams` from http://quickutil.org/ 285 | (check-type sequence sequence) 286 | (check-type n (integer 1)) 287 | (assert (<= n (length sequence))) 288 | (etypecase sequence 289 | (list (ngrams-list n sequence)) 290 | (sequence (ngrams-sequence n sequence)))) 291 | 292 | 293 | (defun extrema (predicate sequence &key (key #'identity)) 294 | "Return the smallest and largest elements of `sequence` according to `predicate`. 295 | 296 | `predicate` should be a strict ordering predicate (e.g. `<`). 297 | 298 | Returns the smallest and largest elements in the sequence as two values, 299 | respectively. 300 | 301 | " 302 | (iterate 303 | (with min = (elt sequence 0)) 304 | (with min-val = (funcall key min)) 305 | (with max = (elt sequence 0)) 306 | (with max-val = (funcall key max)) 307 | (for el :in-whatever sequence) 308 | (for val = (funcall key el)) 309 | (when (funcall predicate val min-val) (setf min el min-val val)) 310 | (when (funcall predicate max-val val) (setf max el max-val val)) 311 | (finally (return (values min max))))) 312 | 313 | 314 | (defun enumerate (sequence &key (start 0) (step 1) key) 315 | "Return an alist of `(n . element)` for each element of `sequence`. 316 | 317 | `start` and `step` control the values generated for `n`, NOT which elements of 318 | the sequence are enumerated. 319 | 320 | Examples: 321 | 322 | (enumerate '(a b c)) 323 | ; => ((0 . A) (1 . B) (2 . C)) 324 | 325 | (enumerate '(a b c) :start 1) 326 | ; => ((1 . A) (2 . B) (3 . C)) 327 | 328 | (enumerate '(a b c) :key #'alexandria:make-keyword) 329 | ; => ((0 . :A) (1 . :B) (2 . :C)) 330 | 331 | " 332 | (iterate (for el :in-whatever sequence) 333 | (for n :from start :by step) 334 | (collect (cons n (if key 335 | (funcall key el) 336 | el))))) 337 | 338 | 339 | (defun reductions/list% (function sequence key from-end start end initial-value iv?) 340 | (let ((result (list))) 341 | (labels ((f (&optional (a nil a?) b) 342 | ;; The only time the reducing function is called with zero 343 | ;; arguments is if we have an empty (sub)seq. If that's the case 344 | ;; we can just bail immediately. 345 | (when (not a?) 346 | (return-from reductions/list% (list))) 347 | ;; Otherwise push the current value (we'll handle the final one at 348 | ;; the end) and return the next. 349 | (push (if from-end b a) result) 350 | (funcall function a b))) 351 | (let ((final (if iv? 352 | (reduce #'f sequence 353 | :key key 354 | :from-end from-end 355 | :start (or start 0) 356 | :end end 357 | :initial-value initial-value) 358 | ;; We have to specifically NOT pass :initial-value if it's 359 | ;; omitted. We could apply (when …), but that's ugly. 360 | (reduce #'f sequence 361 | :key key 362 | :from-end from-end 363 | :start (or start 0) 364 | :end end)))) 365 | (push final result) 366 | (nreverse result))))) 367 | 368 | (defun reductions/vector% (function sequence key from-end start end initial-value iv? result-type) 369 | (let* ((end (or end (length sequence))) 370 | (start (or start 0)) 371 | (result (make-sequence result-type (+ (- end start) (if iv? 1 0)))) 372 | (i -1)) 373 | (labels ((collect (value) 374 | (setf (aref result (incf i)) value)) 375 | (f (&optional (a nil a?) b) 376 | (when (not a?) 377 | (return-from reductions/vector% result)) 378 | (collect (if from-end b a)) 379 | (funcall function a b))) 380 | (let ((final (if iv? 381 | (reduce #'f sequence 382 | :key key 383 | :from-end from-end 384 | :start start 385 | :end end 386 | :initial-value initial-value) 387 | (reduce #'f sequence 388 | :key key 389 | :from-end from-end 390 | :start start 391 | :end end)))) 392 | (collect final) 393 | result)))) 394 | 395 | (defun reductions (function sequence &key 396 | key from-end start end 397 | (initial-value nil iv?) 398 | (result-type 'list)) 399 | "Return a list of intermediate values of `reduce`ing `function` over `sequence`. 400 | 401 | If `initial-value` is provided it will be included as the first element in the 402 | results. 403 | 404 | If `from-end` is true the sequence will be walked in reverse order, but the 405 | order of the *results* will still be in the order they were produced (with the 406 | `initial-value` first, if one is provided). 407 | 408 | Like `reduce`, `key` is only called on the elements of `sequence`, *not* on 409 | `initial-value` if one is provided. 410 | 411 | *Unlike* `reduce`, if the (sub)sequence is empty (and no `initial-value` is 412 | provided) an empty list will be returned, instead of calling `function` with 413 | no arguments. 414 | 415 | `result-type` must be a subtype of `list` or `vector`. 416 | 417 | Examples: 418 | 419 | (reductions #'+ '(0 1 2 3)) 420 | ; => (0 1 3 6) 421 | 422 | (reductions #'+ '(0 1 2 3) :from-end t) 423 | ; => (3 5 6 6) 424 | 425 | (reductions #'+ '(10 20 30) :initial-value 100) 426 | ; => (100 110 120 130) 427 | 428 | (reductions #'+ '((10) (20) (30)) :initial-value 100 :key #'car) 429 | ; => (100 110 120 130) 430 | 431 | (reductions #'+ '(10 20 30) :start 1 :end 1) 432 | ; => () 433 | 434 | (reductions #'+ '(10 20 30) :start 1 :end 1 :initial-value 111) 435 | ; => (111) 436 | 437 | " 438 | (cond ((subtypep result-type 'vector) 439 | (reductions/vector% function sequence key from-end start end initial-value iv? result-type)) 440 | ((subtypep result-type 'list) 441 | (reductions/list% function sequence key from-end start end initial-value iv?)) 442 | (t (error "Bad result-type ~S: must be a subtype of list or vector." result-type)))) 443 | 444 | (defmacro doseq ((var sequence) &body body) 445 | "Perform `body` with `var` bound to each element in `sequence` in turn. 446 | 447 | It's like `cl:dolist`, but for all sequences. 448 | 449 | " 450 | `(map nil (lambda (,var) ,@body) ,sequence)) 451 | 452 | 453 | (defun-inlineable summation (sequence &key key (initial-value 0) modulo) 454 | "Return the sum of all elements of `sequence`. 455 | 456 | If `key` is given, it will be called on each element to compute the addend. 457 | 458 | If `initial-value` is given, it will be used instead of 0 to seed the addition. 459 | 460 | If `modulo` is given the successive sums will be modulo'ed by it along the 461 | way, which can prevent the need for bignums if you don't need the full result. 462 | 463 | This function's ugly name was chosen so it wouldn't clash with iterate's `sum` 464 | symbol. Sorry. 465 | 466 | Examples: 467 | 468 | (summation #(1 2 3)) 469 | ; => 6 470 | 471 | (summation '(\"1\" \"2\" \"3\") :key #'parse-integer) 472 | ; => 6 473 | 474 | (summation '(\"1\" \"2\" \"3\") :key #'length) 475 | ; => 3 476 | 477 | " 478 | (let ((result initial-value)) 479 | (when modulo (modf result modulo)) 480 | (if modulo 481 | (if key 482 | (doseq (n sequence) (setf result (mod (+ result (funcall key n)) modulo))) 483 | (doseq (n sequence) (setf result (mod (+ result n) modulo)))) 484 | (if key 485 | (doseq (n sequence) (setf result (+ result (funcall key n)))) 486 | (doseq (n sequence) (setf result (+ result n))))) 487 | result)) 488 | 489 | (defun-inlineable product (sequence &key key (initial-value 1) modulo) 490 | "Return the product of all elements of `sequence`. 491 | 492 | If `key` is given, it will be called on each element to compute the 493 | multiplicand. 494 | 495 | If `initial-value` is given, it will be used instead of 1 to seed the 496 | multiplication. 497 | 498 | If `modulo` is given the successive products will be modulo'ed by it along the 499 | way, which can prevent the need for bignums if you don't need the full result. 500 | 501 | Examples: 502 | 503 | (product #(1 2 3)) 504 | ; => 6 505 | 506 | (product #(1 2 3) :modulo 5) 507 | ; => 1 508 | 509 | (product #(1 2 3) :modulo 5 :initial-value 2) 510 | ; => 2 511 | 512 | (product '(\"1\" \"2\" \"3\") :key #'parse-integer) 513 | ; => 6 514 | 515 | (product '(\"1\" \"2\" \"3\") :key #'length) 516 | ; => 1 517 | 518 | " 519 | (let ((result initial-value)) 520 | (when modulo (modf result modulo)) 521 | (if modulo 522 | (if key 523 | (doseq (n sequence) (setf result (mod (* result (funcall key n)) modulo))) 524 | (doseq (n sequence) (setf result (mod (* result n) modulo)))) 525 | (if key 526 | (doseq (n sequence) (setf result (* result (funcall key n)))) 527 | (doseq (n sequence) (setf result (* result n))))) 528 | result)) 529 | 530 | 531 | (defun string-join (separator sequence) 532 | "Join a `sequence` of objects into a string, separated by `separator`. 533 | 534 | All objects in `sequence` (and `separator`) will be `princ`ed before joining. 535 | 536 | " 537 | (unless (stringp separator) 538 | (callf separator #'princ-to-string)) 539 | (with-output-to-string (s) 540 | (let ((first t)) 541 | (map nil (lambda (el) 542 | (if first 543 | (setf first nil) 544 | (write-string separator s)) 545 | (princ el s)) 546 | sequence)))) 547 | 548 | 549 | (defun make-sorting-predicate (predicate-spec &rest more-predicate-specs) 550 | "Compose the given predicates into a single predicate and return it. 551 | 552 | This function takes one or more predicates and composes them into a single 553 | predicate suitable for passing to `sort`. Earlier predicates will take 554 | precedence over later ones — later predicates will only be called to break 555 | ties for earlier predicates. This is useful if you want to do something like 556 | \"sort customers by last name, then by first name, then by ID number\". 557 | 558 | `predicate-spec` can be either a function or a cons of `(predicate . key)`, 559 | in which case the key will be called on arguments before passing them to 560 | `predicate`. Note that the `key` only affects the predicate it's consed to, 561 | not later predicates. 562 | 563 | See `define-sorting-predicate` for a convenient way to define named sorting 564 | predicates. 565 | 566 | Examples: 567 | 568 | ;; Trivial example: 569 | (sort (list \"zz\" \"abc\") 570 | (make-sorting-predicate #'string<)) 571 | ; => (\"abc\" \"zz\") 572 | 573 | ;; Sort shorter strings first, breaking ties lexicographically: 574 | (sort (list \"zz\" \"abc\" \"yy\") 575 | (make-sorting-predicate (cons #'< #'length) #'string<)) 576 | ; => (\"yy\" \"zz\" \"abc\") 577 | 578 | ;; Sort customers by last name, then first name, then ID number: 579 | (sort (find-customers) 580 | (make-sorting-predicate 581 | (cons #'string< #'last-name) 582 | (cons #'string< #'first-name) 583 | (cons #'< #'id))) 584 | 585 | " 586 | (let (predicate key) 587 | (if (consp predicate-spec) 588 | (setf predicate (car predicate-spec) 589 | key (cdr predicate-spec)) 590 | (setf predicate predicate-spec 591 | key nil)) 592 | (if (null more-predicate-specs) 593 | (if key 594 | (lambda (x y) 595 | (funcall predicate (funcall key x) (funcall key y))) 596 | predicate) 597 | (let ((next (apply #'make-sorting-predicate more-predicate-specs))) 598 | (if key 599 | (lambda (x y) 600 | (let ((kx (funcall key x)) 601 | (ky (funcall key y))) 602 | (cond 603 | ((funcall predicate kx ky) t) 604 | ((funcall predicate ky kx) nil) 605 | (t (funcall next x y))))) 606 | (lambda (x y) 607 | (cond 608 | ((funcall predicate x y) t) 609 | ((funcall predicate y x) nil) 610 | (t (funcall next x y))))))))) 611 | 612 | (defmacro define-sorting-predicate (name predicate-spec &rest more-predicate-specs) 613 | "Define `name` as a predicate that composes the given predicates. 614 | 615 | This function takes one or more predicates and composes them into a single 616 | predicate suitable for passing to `sort`. Earlier predicates will take 617 | precedence over later ones — later predicates will only be called to break 618 | ties for earlier predicates. This is useful if you want to do something like 619 | \"sort customers by last name, then by first name, then by ID number\". 620 | 621 | `predicate-spec` can be one of: 622 | 623 | * A quoted symbol. 624 | * `(function ...)` 625 | * `(lambda ...)` 626 | * A list of `(predicate &key key)`, where `predicate` is any of the above. 627 | 628 | If a `key` is specified, it will be called on arguments before passing them to 629 | `predicate`. Note that the `key` only affects the predicate it's consed to, 630 | not later predicates. 631 | 632 | See `make-sorting-predicate` for a functional version. 633 | 634 | Examples: 635 | 636 | ;; Sort shorter strings first, breaking ties lexicographically: 637 | (define-sorting-predicate fancy< 638 | (#'< :key #'length) 639 | #'string<) 640 | 641 | (sort (list \"zz\" \"abc\" \"yy\") #'fancy<) 642 | ; => (\"yy\" \"zz\" \"abc\") 643 | 644 | ;; Sort customers by last name, then first name, then ID number: 645 | (define-sorting-predicate customer< 646 | (#'string< :key #'last-name) 647 | (#'string< :key #'first-name) 648 | (#'< :key #'id)) 649 | 650 | (sort (find-customers) #'customer<) 651 | 652 | " 653 | (with-gensyms (x y) 654 | (labels ((parse-spec (spec) 655 | "Parse `spec` and return the predicate and key as values." 656 | (if (consp spec) 657 | (if (member (first spec) '(function lambda quote)) 658 | (values spec '#'identity) 659 | (destructuring-bind (predicate &key (key '#'identity)) spec 660 | (values predicate key))) 661 | (values spec '#'identity))) 662 | (expand (specs) 663 | "Expand `specs` into the body code of the new predicate." 664 | (destructuring-bind (spec . remaining) specs 665 | (multiple-value-bind (predicate key) (parse-spec spec) 666 | (once-only (predicate key) 667 | (with-gensyms (kx ky) 668 | `(let ((,kx (funcall ,key ,x)) 669 | (,ky (funcall ,key ,y))) 670 | ,(if (null remaining) 671 | `(if (funcall ,predicate ,kx ,ky) 672 | t 673 | nil) 674 | `(cond 675 | ((funcall ,predicate ,kx ,ky) t) 676 | ((funcall ,predicate ,ky ,kx) nil) 677 | (t ,(expand remaining))))))))))) 678 | `(defun ,name (,x ,y) 679 | ,(expand (cons predicate-spec more-predicate-specs)))))) 680 | 681 | 682 | -------------------------------------------------------------------------------- /src/shell.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.shell) 2 | 3 | (defun sh (command &key input (wait t) (result-type 'null)) 4 | "Run `command`, piping `input` to it, optionally returning its output. 5 | 6 | `command` must be either a string (the program), or a list of the program and 7 | its arguments. 8 | 9 | `wait` must be a boolean. If true, this function will block until the command 10 | completes. If false, it will return immediately and allow the program to run 11 | asynchronously. 12 | 13 | `input` must be a character input stream, a string, a list of strings, or 14 | `nil`. If non-`nil` its contents will be sent to the program as its standard 15 | input. A list of strings will be sent separated by newlines. 16 | 17 | `result-type` must be one of: 18 | 19 | * `null`: output will be sent to `/dev/null` and `nil` returned. 20 | * `stream`: output will be returned as a character stream. 21 | * `string`: all output will be gathered up and returned as a single string. 22 | * `list`: all output will be gathered up and returned as a list of lines. 23 | * `vector`: all output will be gathered up and returned as a vector of octets. 24 | 25 | If `wait` is `nil`, the only acceptable values for `result-type` are `null` 26 | and `stream`. 27 | 28 | " 29 | (ctypecase command 30 | (string (setf command (list command))) 31 | ((cons string list))) 32 | (ctypecase input 33 | (string (setf input (make-string-input-stream input))) 34 | (vector (setf input (flexi-streams:make-in-memory-input-stream input))) 35 | (cons (setf input (make-string-input-stream (format nil "~{~A~^~%~}" input)))) ; todo make this not cons as much 36 | (stream) 37 | (null)) 38 | (when (not wait) 39 | (assert (member result-type '(null stream)) () 40 | "`result-type` must be `stream` or `null` when not `wait`ing.")) 41 | (let* ((out (if wait ; why is every external programming running facility a goddamn mess? 42 | (ecase result-type 43 | ((string stream list) (make-string-output-stream)) 44 | (vector (flexi-streams:make-in-memory-output-stream)) 45 | (null nil)) 46 | (ecase result-type 47 | ((string list) (make-string-output-stream)) 48 | (vector (flexi-streams:make-in-memory-output-stream)) 49 | (stream :stream) 50 | (null nil)))) 51 | (result (multiple-value-list 52 | (funcall (if wait #'external-program:run #'external-program:start) 53 | (first command) (rest command) 54 | :output out 55 | :input input)))) 56 | (flet ((output-stream () ; jesus christ 57 | (if wait 58 | (make-string-input-stream (get-output-stream-string out)) 59 | (external-program:process-output-stream (first result))))) 60 | (values-list 61 | (cons (ecase result-type 62 | (null nil) 63 | (stream (output-stream)) 64 | (string (get-output-stream-string out)) 65 | (vector (flexi-streams:get-output-stream-sequence out)) 66 | (list (iterate (for line :in-stream (output-stream) :using #'read-line) 67 | (collect line)))) 68 | result))))) 69 | 70 | 71 | (defparameter *pbcopy-command* "pbcopy" 72 | "The shell command to use for `pbcopy`. When run, this command should set the clipboard contents to its standard input.") 73 | 74 | (defparameter *pbpaste-command* "pbpaste" 75 | "The shell command to use for `pbpaste`. When run, this command should print the clipboard contents on standard output.") 76 | 77 | (defun pbcopy (&optional (object *)) 78 | "`pbcopy` the `aesthetic-string` of `object`." 79 | (sh *pbcopy-command* :input (format nil "~A" object) :wait nil) 80 | (values)) 81 | 82 | (defun pbpaste () 83 | "`pbpaste` the current clipboard as a string." 84 | (values (sh *pbpaste-command* :result-type 'string))) 85 | -------------------------------------------------------------------------------- /src/streams.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.streams) 2 | 3 | (defmacro with-eof-handled ((stream eof-error-p eof-value) &body body) 4 | (alexandria:once-only (stream eof-error-p eof-value) 5 | `(if (null (peek-char nil ,stream nil)) 6 | (if ,eof-error-p 7 | (error 'end-of-file) 8 | ,eof-value) 9 | (progn ,@body)))) 10 | -------------------------------------------------------------------------------- /src/weightlists.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.weightlists) 2 | 3 | (defstruct (weightlist (:constructor %make-weightlist)) 4 | weights sums items total) 5 | 6 | (defun make-weightlist (weights-and-items) 7 | "Make a weightlist of the given items and weights. 8 | 9 | `weights-and-items` should be an alist of `(weight . item)` pairs. 10 | 11 | Weights can be any `real` numbers. Weights of zero are fine, as long as at 12 | least one of the weights is nonzero (otherwise there's nothing to choose). 13 | 14 | " 15 | (let ((weights (mapcar #'car weights-and-items)) 16 | (items (mapcar #'cdr weights-and-items))) 17 | (%make-weightlist 18 | :items items 19 | :weights weights 20 | :sums (prefix-sums weights) 21 | :total (apply #'+ weights)))) 22 | 23 | (defun weightlist-random (weightlist) 24 | "Return a random item from the weightlist, taking the weights into account." 25 | (iterate 26 | (with n = (random (weightlist-total weightlist))) 27 | (for item :in (weightlist-items weightlist)) 28 | (for weight :in (weightlist-sums weightlist)) 29 | (finding item :such-that (< n weight)))) 30 | 31 | 32 | -------------------------------------------------------------------------------- /test/arrays.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.test) 2 | 3 | 4 | (define-test do-array 5 | (let ((a (make-array 4 :initial-contents '(1 2 3 4))) 6 | (mda (make-array (list 2 2) :initial-contents '((1 2) (3 4))))) 7 | (is (equal '(1 2 3 4) 8 | (gathering 9 | (do-array (x a) 10 | (gather x))))) 11 | (do-array (x mda) 12 | (incf x)) 13 | (is (equal '(2 3 4 5) 14 | (gathering 15 | (do-array (x mda) 16 | (gather x))))))) 17 | 18 | (define-test fill-multidimensional-array 19 | (let ((mda (make-array (list 2 2) :initial-contents '((1 2) (3 4))))) 20 | (is (equalp #2A((1 2) (3 4)) mda)) 21 | (fill-multidimensional-array mda 9) 22 | (is (equalp #2A((9 9) (9 9)) mda))) 23 | 24 | (let ((mda (make-array (list 2 2) 25 | :initial-contents '((1 2) (3 4)) 26 | :element-type t))) 27 | (is (equalp #2A((1 2) (3 4)) mda)) 28 | (fill-multidimensional-array-t mda 9) 29 | (is (equalp #2A((9 9) (9 9)) mda))) 30 | 31 | (let ((mda (make-array (list 2 2) 32 | :initial-contents '((1 2) (3 4)) 33 | :element-type 'fixnum))) 34 | (is (equalp #2A((1 2) (3 4)) mda)) 35 | (fill-multidimensional-array-fixnum mda 9) 36 | (is (equalp #2A((9 9) (9 9)) mda))) 37 | 38 | (let ((mda (make-array (list 2 2) 39 | :initial-contents '((1.0 2.0) (3.0 4.0)) 40 | :element-type 'single-float))) 41 | (is (equalp #2A((1.0 2.0) (3.0 4.0)) mda)) 42 | (fill-multidimensional-array-single-float mda 9.0) 43 | (is (equalp #2A((9.0 9.0) (9.0 9.0)) mda)))) 44 | 45 | (define-test vector-last 46 | (is (equal '(nil nil) 47 | (multiple-value-list (vector-last #())))) 48 | (is (equal '(nil t) 49 | (multiple-value-list (vector-last #(nil))))) 50 | (let ((v (make-array 4 51 | :initial-contents '(1 2 3 4) 52 | :fill-pointer t))) 53 | (is (equal '(4 t) 54 | (multiple-value-list (vector-last v)))) 55 | (setf (fill-pointer v) 2) 56 | (is (equal '(2 t) 57 | (multiple-value-list (vector-last v)))) 58 | (setf (fill-pointer v) 0) 59 | (is (equal '(nil nil) 60 | (multiple-value-list (vector-last v)))))) 61 | 62 | 63 | (define-test bisect-left 64 | (let ((v #(10 12 14 16 18 20))) 65 | (is (equal '(14 2) (multiple-value-list (bisect-left #'<= v 15)))) 66 | (is (equal '(14 2) (multiple-value-list (bisect-left #'<= v 14)))) 67 | (is (equal '(20 5) (multiple-value-list (bisect-left #'<= v 999)))) 68 | (is (equal '(10 0) (multiple-value-list (bisect-left #'<= v 11)))) 69 | (is (equal '(nil nil) (multiple-value-list (bisect-left #'<= v 0)))))) 70 | 71 | (define-test bisect-right 72 | (let ((v #(10 12 14 16 18 20))) 73 | (is (equal '(16 3) (multiple-value-list (bisect-right #'<= v 15)))) 74 | (is (equal '(16 3) (multiple-value-list (bisect-right #'<= v 14)))) 75 | (is (equal '(nil nil) (multiple-value-list (bisect-right #'<= v 999)))) 76 | (is (equal '(12 1) (multiple-value-list (bisect-right #'<= v 11)))) 77 | (is (equal '(10 0) (multiple-value-list (bisect-right #'<= v 0)))))) 78 | -------------------------------------------------------------------------------- /test/base.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.test) 2 | 3 | 4 | (defmacro define-test (name &body body) 5 | `(test ,(intern (concatenate 'string (symbol-name 'test/) (symbol-name name))) 6 | (let ((*package* ,*package*)) 7 | ,@body))) 8 | 9 | (defun run-tests () 10 | (1am:run)) 11 | 12 | -------------------------------------------------------------------------------- /test/control-flow.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.test) 2 | 3 | 4 | (define-test when-let 5 | #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note)) 6 | (is (eql :foo (when-let () 7 | :foo))) 8 | (is (eql 1 (when-let ((a 1)) 9 | a))) 10 | (is (eql 3 (when-let ((a 1) 11 | (b 2)) 12 | (+ a b)))) 13 | (is (eql nil (when-let ((a nil) 14 | (b 2)) 15 | (+ a b)))) 16 | (is (eql nil (when-let ((a 1) 17 | (b nil)) 18 | (+ a b)))) 19 | (is (eql nil (when-let ((a 1) 20 | (b nil) 21 | (c 3)) 22 | (+ a b c)))) 23 | (let (x) 24 | (is (eql nil (when-let ((a (progn (push 1 x) 1)) 25 | (b (progn (push 2 x) nil)) 26 | (c (progn (push 3 x) 3))) 27 | (declare (type fixnum a b c)) 28 | (push :body x) 29 | (+ a b c)))) 30 | (is (equal '(2 1) x))) 31 | (let (x) 32 | (is (eql 6 (when-let ((a (progn (push 1 x) 1)) 33 | (b (progn (push 2 x) 2)) 34 | (c (progn (push 3 x) 3))) 35 | (declare (type fixnum a b c)) 36 | (push :body x) 37 | (+ a b c)))) 38 | (is (equal '(:body 3 2 1) x)))) 39 | 40 | (define-test when-let* 41 | #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note)) 42 | (is (eql :foo (when-let* () 43 | :foo))) 44 | (is (eql 1 (when-let* ((a 1)) 45 | a))) 46 | (is (eql 2 (when-let* ((a 1) 47 | (b (1+ a))) 48 | b))) 49 | (is (eql nil (when-let* ((a nil) 50 | (b 2)) 51 | (+ a b)))) 52 | (is (eql nil (when-let* ((a 1) 53 | (b nil)) 54 | (+ a b)))) 55 | (is (eql nil (when-let* ((a 1) 56 | (b nil) 57 | (c (+ 2 a))) 58 | (+ a b c)))) 59 | (let (x) 60 | (is (eql nil (when-let* ((a (progn (push 1 x) 1)) 61 | (b (progn (push 2 x) nil)) 62 | (c (progn (push 3 x) 3))) 63 | (push :body x) 64 | (+ a b c)))) 65 | (is (equal '(2 1) x))) 66 | (let (x) 67 | (is (eql 6 (when-let* ((a (progn (push 1 x) 1)) 68 | (b (progn (push 2 x) 2)) 69 | (c (progn (push 3 x) 3))) 70 | (push :body x) 71 | (+ a b c)))) 72 | (is (equal '(:body 3 2 1) x)))) 73 | 74 | 75 | (define-test if-let 76 | #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note)) 77 | (is (eql :foo (if-let () 78 | :foo 79 | :bar))) 80 | 81 | (is (eql 1 (if-let ((a 1)) 82 | a 83 | :bar))) 84 | (is (eql :bar (if-let ((a nil)) 85 | a 86 | :bar))) 87 | (is (eql 3 (if-let ((a 1) 88 | (b 2)) 89 | (+ a b) 90 | :bar))) 91 | (is (eql :bar (if-let ((a nil) 92 | (b 2)) 93 | (+ a b) 94 | :bar))) 95 | (is (eql :bar (if-let ((a 1) 96 | (b nil)) 97 | (+ a b) 98 | :bar))) 99 | (is (eql :bar (if-let ((a 1) 100 | (b nil) 101 | (c 3)) 102 | (+ a b c) 103 | :bar))) 104 | (let (x) 105 | (is (eql :bar (if-let ((a (progn (push 1 x) 1)) 106 | (b (progn (push 2 x) nil)) 107 | (c (progn (push 3 x) 3))) 108 | (declare (type fixnum a b c)) 109 | (+ a b c) 110 | :bar))) 111 | (is (equal '(2 1) x))) 112 | (let (x) 113 | (is (eql 6 (if-let ((a (progn (push 1 x) 1)) 114 | (b (progn (push 2 x) 2)) 115 | (c (progn (push 3 x) 3))) 116 | (declare (type fixnum a b c)) 117 | (+ a b c) 118 | :bar))) 119 | (is (equal '(3 2 1) x)))) 120 | 121 | (define-test if-let* 122 | #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note)) 123 | (is (eql :foo (if-let* () 124 | :foo 125 | :bar))) 126 | 127 | (is (eql 1 (if-let* ((a 1)) 128 | a 129 | :bar))) 130 | (is (eql :bar (if-let* ((a nil)) 131 | a 132 | :bar))) 133 | (is (eql 3 (if-let* ((a 1) 134 | (b (1+ a))) 135 | (+ a b) 136 | :bar))) 137 | (is (eql :bar (if-let* ((a nil) 138 | (b 2)) 139 | (+ a b) 140 | :bar))) 141 | (is (eql :bar (if-let* ((a 1) 142 | (b nil)) 143 | (+ a b) 144 | :bar))) 145 | (is (eql :bar (if-let* ((a 1) 146 | (b nil) 147 | (c 3)) 148 | (+ a b c) 149 | :bar))) 150 | (let (x) 151 | (is (eql :bar (if-let* ((a (progn (push 1 x) 1)) 152 | (b (progn (push 2 x) nil)) 153 | (c (progn (push 3 x) 3))) 154 | (declare (type fixnum a b c)) 155 | (+ a b c) 156 | :bar))) 157 | (is (equal '(2 1) x))) 158 | (let (x) 159 | (is (eql 6 (if-let* ((a (progn (push 1 x) 1)) 160 | (b (progn (push 2 x) 2)) 161 | (c (progn (push 3 x) 3))) 162 | (declare (type fixnum a b c)) 163 | (+ a b c) 164 | :bar))) 165 | (is (equal '(3 2 1) x)))) 166 | 167 | 168 | (define-test do-range 169 | #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note)) 170 | (is (equal '(1 2 3) 171 | (gathering 172 | (do-range ((x 1 4)) 173 | (gather x))))) 174 | (is (equal '() 175 | (gathering 176 | (do-range ((x 1 1)) 177 | (gather x))))) 178 | (is (equal '((1 . 1) (1 . 2) (1 . 3) 179 | (2 . 1) (2 . 2) (2 . 3)) 180 | (gathering 181 | (do-range ((x 1 3) 182 | (y 1 4)) 183 | (gather (cons x y))))))) 184 | 185 | (define-test do-repeat 186 | #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note)) 187 | (is (equal '(1 1 1) 188 | (gathering 189 | (do-repeat 3 190 | (gather 1))))) 191 | (is (equal '() 192 | (gathering 193 | (do-repeat 0 194 | (gather 1)))))) 195 | 196 | (define-test do-file 197 | (is (equal '("1" "2" "34") 198 | (gathering (do-file (line "test/example.txt") (gather line))))) 199 | (is (equal '(1 2 34) 200 | (gathering (do-file (s "test/example.txt" :reader #'read) (gather s)))))) 201 | 202 | 203 | (define-test gathering 204 | #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note)) 205 | (is (equal '(1 2 3) 206 | (gathering 207 | (gather 1) 208 | (gather 2) 209 | (gather 3)))) 210 | (is (equal '() 211 | (gathering 212 | 1)))) 213 | 214 | (define-test gathering-vector 215 | #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note)) 216 | (is (equalp #(1 2 3) 217 | (gathering-vector () 218 | (gather 1) 219 | (gather 2) 220 | (gather 3)))) 221 | (is (equalp #() 222 | (gathering-vector () 223 | 1)))) 224 | 225 | 226 | (define-test when-found 227 | (let ((h (make-hash-table))) 228 | (setf (gethash 'foo h) 1) 229 | (is (equal 2 (when-found (x (gethash 'foo h)) 230 | (1+ x)))) 231 | (is (equal nil (when-found (x (gethash 'bar h)) 232 | (1+ x)))))) 233 | 234 | (define-test if-found 235 | (let ((h (make-hash-table))) 236 | (setf (gethash 'foo h) 1) 237 | (is (equal 2 (if-found (x (gethash 'foo h)) 238 | (1+ x) 239 | :no))) 240 | (is (equal :no (if-found (x (gethash 'bar h)) 241 | (1+ x) 242 | :no))))) 243 | 244 | 245 | (define-test nest 246 | (is (equal '(1 2 1 2) 247 | (nest 248 | (let ((a 1) 249 | (b 2))) 250 | (let ((c a) 251 | (d b))) 252 | (list a b c d))))) 253 | 254 | -------------------------------------------------------------------------------- /test/example.txt: -------------------------------------------------------------------------------- 1 | 1 2 | 2 3 | 34 4 | -------------------------------------------------------------------------------- /test/iterate.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.test) 2 | 3 | 4 | (define-test within-radius 5 | (is (equal '(-1 0 1) (iterate (for (x) :within-radius 1) (collect x)))) 6 | (is (equal '(-1 1) (iterate (for (x) :within-radius 1 :skip-origin t) (collect x)))) 7 | (is (equal '(9 10 11) (iterate (for (x) :within-radius 1 :origin (10)) (collect x)))) 8 | (is (equal '(9 11) (iterate (for (x) :within-radius 1 :skip-origin t :origin (10)) (collect x)))) 9 | 10 | (is (equal '((-1 -1) (-1 0) (-1 1) (0 -1) (0 0) (0 1) (1 -1) (1 0) (1 1)) 11 | (iterate (for (x y) :within-radius 1) (collect (list x y))))) 12 | 13 | (is (equal '((-1 -1) (-1 0) (-1 1) (0 -1) (0 1) (1 -1) (1 0) (1 1)) 14 | (iterate (for (x y) :within-radius 1 :skip-origin t) 15 | (collect (list x y))))) 16 | 17 | (is (equal '((9 99) (9 100) (9 101) (10 99) (10 101) (11 99) (11 100) (11 101)) 18 | (iterate (for (x y) :within-radius 1 :skip-origin t :origin (10 100)) 19 | (collect (list x y))))) 20 | 21 | (is (equal '((8 98) (8 99) (8 100) (8 101) (8 102) 22 | (9 98) (9 99) (9 100) (9 101) (9 102) 23 | (10 98) (10 99) (10 101) (10 102) 24 | (11 98) (11 99) (11 100) (11 101) (11 102) 25 | (12 98) (12 99) (12 100) (12 101) (12 102)) 26 | (iterate (for (x y) :within-radius 2 :skip-origin t :origin (10 100)) 27 | (collect (list x y))))) 28 | 29 | (is (equal '((9 99 999) (9 99 1000) (9 99 1001) 30 | (9 100 999) (9 100 1000) (9 100 1001) 31 | (9 101 999) (9 101 1000) (9 101 1001) 32 | (10 99 999) (10 99 1000) (10 99 1001) 33 | (10 100 999) (10 100 1001) 34 | (10 101 999) (10 101 1000) (10 101 1001) 35 | (11 99 999) (11 99 1000) (11 99 1001) 36 | (11 100 999) (11 100 1000) (11 100 1001) 37 | (11 101 999) (11 101 1000) (11 101 1001)) 38 | (iterate (for (x y z) :within-radius 1 :skip-origin t :origin (10 100 1000)) 39 | (collect (list x y z)))))) 40 | -------------------------------------------------------------------------------- /test/lists.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.test) 2 | 3 | (define-test somelist 4 | (is (equal '(a b c d) 5 | (somelist (lambda (l) 6 | (if (eq (car l) 'a) 7 | l 8 | nil)) 9 | '(a b c d)))) 10 | (is (equal '(c d) 11 | (somelist (lambda (l) 12 | (if (eq (car l) 'c) 13 | l 14 | nil)) 15 | '(a b c d)))) 16 | (is (equal 6 17 | (somelist (lambda (l1 l2) 18 | (if (eq (car l1) (car l2)) 19 | (+ (length l1) (length l2)) 20 | nil)) 21 | '(a b c d e) 22 | '(e d c b a))))) 23 | 24 | -------------------------------------------------------------------------------- /test/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :losh.test 2 | (:use :cl :1am :losh :iterate) 3 | (:shadowing-import-from :1am :test) 4 | (:export :run-tests)) 5 | -------------------------------------------------------------------------------- /test/ring-buffers.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.test) 2 | 3 | (defun check-ring-buffer (rb expected-contents) 4 | ;; rb-contents (list) 5 | (is (equal (coerce expected-contents 'list) 6 | (rb-contents rb :result-type 'list))) 7 | ;; rb-contents (vector) 8 | (is (equalp (coerce expected-contents 'vector) 9 | (rb-contents rb :result-type 'vector))) 10 | ;; rb-count 11 | (is (= (length expected-contents) (rb-count rb))) 12 | ;; rb-empty 13 | (if (null expected-contents) 14 | (is (rb-empty-p rb)) 15 | (is (not (rb-empty-p rb)))) 16 | ;; rb-full 17 | (if (= (length expected-contents) (1- (rb-size rb))) 18 | (is (rb-full-p rb)) 19 | (is (not (rb-full-p rb)))) 20 | ;; do-ring-buffer 21 | (let ((contents expected-contents)) 22 | (do-ring-buffer (val rb) 23 | (is (equal (pop contents) val))) 24 | (is (null contents))) 25 | ;; iterate driver 26 | (let ((contents expected-contents)) 27 | (iterate (for val :in-ring-buffer rb) 28 | (is (equal (pop contents) val))) 29 | (is (null contents))) 30 | ;; rb-ref 31 | (iterate (for val :in expected-contents) 32 | (for i :from 0) 33 | (is (equal val (rb-ref rb i)))) 34 | (iterate (for val :in (reverse expected-contents)) 35 | (for i :downfrom -1) 36 | (is (equal val (rb-ref rb i))))) 37 | 38 | (define-test basic-ring-buffers 39 | (let ((rb (make-ring-buffer :size 4))) 40 | (check-ring-buffer rb '()) 41 | (is (= 4 (rb-size rb))) 42 | 43 | (rb-push rb 'a) (check-ring-buffer rb '(a)) 44 | (rb-push rb 'b) (check-ring-buffer rb '(a b)) 45 | (rb-push rb 'c) (check-ring-buffer rb '(a b c)) 46 | (rb-push rb 'd) (check-ring-buffer rb '(b c d)) 47 | (rb-push rb 'e) (check-ring-buffer rb '(c d e)) 48 | (rb-push rb 'f) (check-ring-buffer rb '(d e f)) 49 | (rb-push rb 'g) (check-ring-buffer rb '(e f g)) 50 | (is (eql 'e (rb-pop rb))) (check-ring-buffer rb '(f g)) 51 | (is (eql 'f (rb-pop rb))) (check-ring-buffer rb '(g)) 52 | (is (eql 'g (rb-pop rb))) (check-ring-buffer rb '()) 53 | 54 | (signals error (rb-pop rb)) 55 | (check-ring-buffer rb '()) 56 | 57 | (rb-safe-push rb 'a) 58 | (rb-safe-push rb 'b) 59 | (rb-safe-push rb 'c) 60 | (is (= 4 (rb-size rb))) 61 | (check-ring-buffer rb '(a b c)) 62 | (signals error (rb-safe-push rb 'd)) 63 | 64 | (rb-clear rb) 65 | (check-ring-buffer rb '()) 66 | 67 | (rb-clear rb) 68 | (check-ring-buffer rb '()))) 69 | 70 | (define-test fuzz-ring-buffers 71 | (do-range ((n 2 30)) 72 | (iterate 73 | (with rb = (make-ring-buffer :size n)) 74 | (with data = (coerce (0... 400) 'vector)) 75 | (with i = 0) 76 | (repeat 400) 77 | 78 | ;; Randomly push/pop (but never try to pop if empty). 79 | (if (or (rb-empty-p rb) (randomp 0.7)) 80 | (progn (rb-push rb (aref data i)) 81 | (incf i)) 82 | (rb-pop rb)) 83 | 84 | (for expected = (coerce (subseq data (- i (rb-count rb)) i) 'list)) 85 | (check-ring-buffer rb expected)))) 86 | -------------------------------------------------------------------------------- /test/run.lisp: -------------------------------------------------------------------------------- 1 | #+ecl (setf compiler:*user-cc-flags* "-Wno-shift-negative-value") 2 | 3 | (ql:quickload :losh) 4 | (time (asdf:test-system :losh)) 5 | (quit) 6 | -------------------------------------------------------------------------------- /test/sequences.lisp: -------------------------------------------------------------------------------- 1 | (in-package :losh.test) 2 | 3 | (defparameter *words* nil) 4 | 5 | (defun words () 6 | (when (null *words*) 7 | (setf *words* (gathering-vector () 8 | (do-file (line "/usr/share/dict/words") 9 | (gather line))))) 10 | *words*) 11 | 12 | (define-test make-sorting-predicate 13 | (flet ((check (original expected &rest preds) 14 | (let ((actual (sort (copy-seq original) 15 | (apply #'make-sorting-predicate preds)))) 16 | (is (equalp expected actual))))) 17 | (check '("zz" "yy" "abc") 18 | '("abc" "yy" "zz") 19 | #'string<) 20 | (check '("zz" "yy" "abc") 21 | '("yy" "zz" "abc") 22 | (cons #'< #'length) 23 | #'string<) 24 | (check '("yy" "zz" "abc") 25 | '("zz" "yy" "abc") 26 | (cons #'< #'length) 27 | #'string>) 28 | (check '("az" "by" "aby" "zzy") 29 | '("by" "aby" "zzy" "az") 30 | (lambda (x y) 31 | (char< (char x (1- (length x))) 32 | (char y (1- (length y))))) 33 | (cons #'< #'length) 34 | #'string<) 35 | (check '("az" "by" "aby" "zzy") 36 | '("by" "aby" "zzy" "az") 37 | (cons #'char< (lambda (s) (char s (1- (length s))))) 38 | (cons #'< #'length) 39 | #'string<))) 40 | 41 | 42 | (define-sorting-predicate sort-trivial< 43 | #'string<) 44 | 45 | (define-sorting-predicate sort-short< 46 | (#'< :key #'length) 47 | #'string<) 48 | 49 | (define-sorting-predicate sort-short> 50 | (#'< :key #'length) 51 | #'string>) 52 | 53 | (define-sorting-predicate sort-last-char< 54 | (lambda (x y) 55 | (char< (char x (1- (length x))) 56 | (char y (1- (length y))))) 57 | (#'< :key #'length) 58 | #'string<) 59 | 60 | (define-sorting-predicate sort-fancy< 61 | (#'char< :key (lambda (s) (char s (1- (length s))))) 62 | (#'< :key #'length) 63 | #'string<) 64 | 65 | (define-sorting-predicate sort-fancy-quoted< 66 | ('char< :key (lambda (s) (char s (1- (length s))))) 67 | ('< :key #'length) 68 | 'string<) 69 | 70 | (define-test define-sorting-predicate 71 | (flet ((check (original expected pred) 72 | (let ((actual (sort (copy-seq original) pred))) 73 | (is (equalp expected actual))))) 74 | (check '("zz" "yy" "abc") 75 | '("abc" "yy" "zz") 76 | #'sort-trivial<) 77 | (check '("zz" "yy" "abc") 78 | '("yy" "zz" "abc") 79 | #'sort-short<) 80 | (check '("yy" "zz" "abc") 81 | '("zz" "yy" "abc") 82 | #'sort-short>) 83 | (check '("az" "by" "aby" "zzy") 84 | '("by" "aby" "zzy" "az") 85 | #'sort-last-char<) 86 | (check '("az" "by" "aby" "zzy") 87 | '("by" "aby" "zzy" "az") 88 | #'sort-fancy<) 89 | (check '("az" "by" "aby" "zzy") 90 | '("by" "aby" "zzy" "az") 91 | #'sort-fancy-quoted<))) 92 | 93 | (defun sortedp (sequence predicate) 94 | ;; TODO Should this be a util of its own? 95 | (etypecase sequence 96 | (list (loop :for x = (pop sequence) 97 | :until (null sequence) 98 | :never (funcall predicate (first sequence) x))) 99 | (sequence (loop :with l = (length sequence) 100 | :for x :from 0 :below l 101 | :for y :from 1 :below l 102 | :never (funcall predicate (elt sequence y) (elt sequence x)))))) 103 | 104 | (defun vowelp (char) 105 | (find (char-downcase char) "aeiou")) 106 | 107 | (defun vowels< (a b) 108 | (< (count-if #'vowelp a) (count-if #'vowelp b))) 109 | 110 | (defun random-elts (n sequence &key (result-type 'list)) 111 | "Return `N` random elements from `sequence` (duplicates allowed). 112 | 113 | This wil not be fast if `sequence` is a list. 114 | 115 | " 116 | (ecase result-type 117 | (list (loop :repeat n :collect (random-elt sequence))) 118 | (vector (loop :with result = (make-array n) 119 | :for i :from 0 :below n 120 | :do (setf (aref result i) (random-elt sequence)) 121 | :finally (return result))))) 122 | 123 | 124 | (define-test fuzz-sorting-predicates 125 | (let ((specs (vector 'string< 126 | (cons '< 'length) 127 | (cons 'string< 'reverse) 128 | 'vowels< 129 | (cons '< 'sxhash))) 130 | (words (words))) 131 | (do-repeat 256 132 | (let* ((specs (random-elts (random-range 1 (+ 3 (length specs))) specs)) 133 | (predicate (apply #'make-sorting-predicate specs)) 134 | (seq (random-elts (random-range 0 100) words :result-type 'vector))) 135 | (setf seq (sort seq predicate)) 136 | (is (sortedp seq predicate)))))) 137 | 138 | 139 | (define-test string-join 140 | (is (string= "" (string-join #\x '()))) 141 | (is (string= "A" (string-join #\x '(a)))) 142 | (is (string= "AxB" (string-join #\x '(a b)))) 143 | (is (string= "AxBxC" (string-join #\x '(a b c)))) 144 | (is (string= "A, B, C" (string-join ", " #(a b c)))) 145 | (is (string= "foo" (string-join #\space '("foo")))) 146 | (is (string= "f o o" (string-join #\space "foo")))) 147 | 148 | (define-test fuzz-string-join 149 | (let ((words (words))) 150 | (do-repeat 500 151 | (let* ((n (random-range 0 10)) 152 | (ws (random-elts n words)) 153 | (sep (random-elt #(#\, "" "," ", "))) 154 | (result (string-join sep ws))) 155 | (if (zerop n) 156 | (is (string= "" result)) 157 | (is (= (+ (reduce #'+ ws :key #'length) 158 | (* (1- n) (length (string sep)))) 159 | (length result)))))))) 160 | 161 | (defun check-reductions (function expected input &rest args) 162 | (is (equalp expected 163 | (apply #'reductions function input :result-type 'list args))) 164 | (is (equalp (coerce expected 'vector) 165 | (apply #'reductions function input :result-type 'vector args))) 166 | (is (equalp expected 167 | (apply #'reductions function (coerce input 'vector) :result-type 'list args))) 168 | (is (equalp (coerce expected 'vector) 169 | (apply #'reductions function (coerce input 'vector) :result-type 'vector args)))) 170 | 171 | (define-test reductions/basic 172 | (check-reductions #'+ '() '()) 173 | (check-reductions #'+ '(1) '(1)) 174 | (check-reductions #'+ '(1 3) '(1 2)) 175 | (check-reductions #'+ '(1 3 6) '(1 2 3)) 176 | (check-reductions #'+ '(100 101 103 106) '(1 2 3) 177 | :initial-value 100) 178 | (check-reductions #'cons 179 | '(nil (-3) (-2 -3) (-1 -2 -3)) 180 | '(1 2 3) 181 | :initial-value nil 182 | :key #'- 183 | :from-end t)) 184 | 185 | (define-test reductions/initial-value 186 | (check-reductions #'+ '(23) '() :initial-value 23) 187 | (check-reductions #'+ '(23 123) '(100) :initial-value 23) 188 | (check-reductions #'+ '(23 123 1123) '(100 1000) :initial-value 23)) 189 | 190 | (define-test reductions/key 191 | ;; Key should be called on the contents. 192 | (check-reductions #'+ 193 | '(-1 -3 -6) 194 | '(1 2 3) 195 | :key #'-) 196 | ;; Key should NOT be called on the initial value, if given. 197 | (check-reductions #'+ 198 | '(100 101 103 106) 199 | '((1) (2) (3)) 200 | :initial-value 100 201 | :key #'car)) 202 | 203 | (define-test reductions/start-end 204 | (check-reductions #'+ '(0 1 3 6 10 15) '(0 1 2 3 4 5) :start 0 :end nil) 205 | (check-reductions #'+ '( 1 3 6 10 15) '(0 1 2 3 4 5) :start 1 :end nil) 206 | (check-reductions #'+ '(0 1 3 6 10 ) '(0 1 2 3 4 5) :start 0 :end 5) 207 | (check-reductions #'+ '( 2 5 9 ) '(0 1 2 3 4 5) :start 2 :end 5) 208 | (check-reductions #'+ '( 2 ) '(0 1 2 3 4 5) :start 2 :end 3) 209 | (check-reductions #'+ '( ) '(0 1 2 3 4 5) :start 2 :end 2) 210 | (check-reductions #'+ '( ) '(0 1 2 3 4 5) :start 6 :end nil) 211 | (check-reductions #'+ '( 2 5 9 ) (mapcar #'list '(0 1 2 3 4 5)) :start 2 :end 5 :key #'car)) 212 | 213 | (define-test reductions/from-end 214 | (flet ((cat (a b) (concatenate 'string a b))) 215 | (check-reductions #'cat 216 | '("E" "DE" "CDE" "BCDE" "ABCDE") 217 | '(a b c d e) 218 | :from-end t 219 | :key #'string) 220 | (check-reductions #'cat 221 | '("" "E" "DE" "CDE" "BCDE" "ABCDE") 222 | '(a b c d e) 223 | :from-end t 224 | :key #'string :initial-value "") 225 | (check-reductions #'cat 226 | '("" "C" "BC") 227 | '(a b c d e) 228 | :from-end t 229 | :key #'string :initial-value "" 230 | :start 1 :end 3) 231 | (check-reductions #'cat 232 | '("C" "BC") 233 | '(a b c d e) 234 | :from-end t 235 | :key #'string 236 | :start 1 :end 3) 237 | (check-reductions #'cat 238 | '() 239 | '(a b c d e) 240 | :from-end t 241 | :key #'string 242 | :start 1 :end 1) 243 | (check-reductions #'cat 244 | '("") 245 | '(a b c d e) 246 | :from-end t 247 | :key #'string :initial-value "" 248 | :start 1 :end 1))) 249 | 250 | (define-test reductions/non-list 251 | (check-reductions #'+ '(1 3 6) (vector 1 2 3)) 252 | (check-reductions #'+ '(99 100) (vector 1 2 3) :start 0 :end 1 :initial-value 99) 253 | (check-reductions #'+ '(99) (vector 1 2 3) :start 0 :end 0 :initial-value 99)) 254 | --------------------------------------------------------------------------------