├── .gitignore ├── tests ├── timing.lisp └── tests.lisp ├── array-operations.asd ├── LICENSE.md ├── src ├── package.lisp ├── utilities.lisp ├── general.lisp ├── displacement.lisp ├── transformations.lisp └── stack.lisp └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | README.html 2 | auto/ 3 | -------------------------------------------------------------------------------- /tests/timing.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:array-operations-tests) 4 | 5 | (defparameter *a* (ao:generate* 'double-float (lambda () (random 1d0)) 6 | '(100 100 100))) 7 | 8 | (defun permute-loop (array permutation &optional (n 10)) 9 | (loop repeat n 10 | do (ao:permute array permutation))) 11 | 12 | (time (permute-loop *a* '(2 1 0))) 13 | -------------------------------------------------------------------------------- /array-operations.asd: -------------------------------------------------------------------------------- 1 | ;;;; array-operations.asd 2 | 3 | (asdf:defsystem #:array-operations 4 | :serial t 5 | :description "Simple array operations library for Common Lisp." 6 | :author "Tamas K. Papp " 7 | :license "MIT" 8 | :depends-on (#:alexandria 9 | #:anaphora 10 | #:let-plus 11 | #:optima) 12 | :pathname #P"src/" 13 | :components ((:file "package") 14 | (:file "utilities") 15 | (:file "general") 16 | (:file "displacement") 17 | (:file "transformations") 18 | (:file "stack"))) 19 | 20 | (asdf:defsystem #:array-operations-tests 21 | :serial t 22 | :description "Unit tests for the ARRAY-OPERATIONS library." 23 | :author "Tamas K. Papp " 24 | :license "MIT" 25 | :depends-on (#:array-operations ; loads everything else 26 | #:clunit) 27 | :pathname #P"tests/" 28 | :components ((:file "tests"))) 29 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The LargeColumns.jl package is licensed under the MIT "Expat" License: 2 | 3 | > Copyright (c) 2017: Tamas K. Papp. 4 | > 5 | > Permission is hereby granted, free of charge, to any person obtaining a copy 6 | > of this software and associated documentation files (the "Software"), to deal 7 | > in the Software without restriction, including without limitation the rights 8 | > to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | > copies of the Software, and to permit persons to whom the Software is 10 | > furnished to do so, subject to the following conditions: 11 | > 12 | > The above copyright notice and this permission notice shall be included in all 13 | > copies or substantial portions of the Software. 14 | > 15 | > THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | > IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | > FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | > AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | > LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | > OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | > SOFTWARE. 22 | > 23 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (defpackage #:array-operations 4 | (:use #:cl 5 | #:alexandria 6 | #:anaphora 7 | #:let-plus 8 | #:optima) 9 | (:nicknames #:aops) 10 | (:shadow #:flatten) 11 | (:export ; utilities 12 | #:walk-subscripts 13 | #:walk-subscripts-list) 14 | (:export ; general 15 | #:as-array 16 | #:element-type 17 | #:dims 18 | #:size 19 | #:rank 20 | #:dim 21 | #:&dims 22 | #:nrow 23 | #:ncol 24 | #:array-matrix 25 | #:matrix? 26 | #:square-matrix? 27 | #:make-array-like) 28 | (:export ; displacement 29 | #:displace 30 | #:flatten 31 | #:split 32 | #:copy-into 33 | #:sub 34 | #:partition 35 | #:combine 36 | #:subvec 37 | #:reshape 38 | #:reshape-col 39 | #:reshape-row) 40 | (:export ; transformations 41 | #:coercing 42 | #:generate* 43 | #:generate 44 | #:permutation-repeated-index 45 | #:permutation-invalid-index 46 | #:permutation-incompatible-rank 47 | #:valid-permutation? 48 | #:complement-permutation 49 | #:complete-permutation 50 | #:invert-permutation 51 | #:identity-permutation? 52 | #:permute 53 | #:each* 54 | #:each 55 | #:margin* 56 | #:margin 57 | #:recycle 58 | #:outer* 59 | #:outer) 60 | (:export ; stack 61 | #:copy-row-major-block 62 | #:stack-rows-copy 63 | #:stack-rows* 64 | #:stack-rows 65 | #:stack-cols-copy 66 | #:stack-cols* 67 | #:stack-cols 68 | #:stack* 69 | #:stack)) 70 | -------------------------------------------------------------------------------- /src/utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:array-operations) 4 | 5 | ;;; utilities used internally, not exported 6 | 7 | (defun product (dimensions) 8 | "Product of elements in the argument. NOT EXPORTED." 9 | (reduce #'* dimensions)) 10 | 11 | (define-modify-macro multf (&rest values) * "Multiply by the arguments") 12 | 13 | (defun same-dimensions? (array &rest arrays) 14 | "Test if arguments have the same dimensions. NOT EXPORTED." 15 | (let ((dimensions (array-dimensions array))) 16 | (every (lambda (array) 17 | (equal dimensions (array-dimensions array))) 18 | arrays))) 19 | 20 | (defun ensure-dimensions (object) 21 | "Return a list of dimensions corresponding to OBJECT. Positive integers are 22 | treated as dimensions of rank 1, lists are returned as they are, and arrays 23 | are queried for their dimensions. 24 | 25 | OBJECTS accepted by this function as valid dimensions are called `dimension 26 | specifications' in this library." 27 | (aetypecase object 28 | ((integer 0) (list it)) 29 | (list it) 30 | (array (array-dimensions it)))) 31 | 32 | (defmacro walk-subscripts ((dimensions subscripts 33 | &optional (position (gensym "POSITION"))) 34 | &body body) 35 | "Iterate over the subscripts of an array with given DIMENSIONS. SUBSCRIPTS 36 | contains the current subscripts as a vector of fixnums, POSITION has the 37 | row-major index. Consequences are undefined if either POSITION or SUBSCRIPTS 38 | is modified." 39 | (check-type position symbol) 40 | (check-type subscripts symbol) 41 | (with-unique-names (rank last increment dimensions-var) 42 | `(let+ ((,dimensions-var (ensure-dimensions ,dimensions)) 43 | (,rank (length ,dimensions-var)) 44 | (,dimensions-var (make-array ,rank 45 | :element-type 'fixnum 46 | :initial-contents ,dimensions-var)) 47 | (,last (1- ,rank)) 48 | (,subscripts (make-array ,rank 49 | :element-type 'fixnum 50 | :initial-element 0)) 51 | ((&labels ,increment (index) 52 | (unless (minusp index) 53 | (when (= (incf (aref ,subscripts index)) 54 | (aref ,dimensions-var index)) 55 | (setf (aref ,subscripts index) 0) 56 | (,increment (1- index))))))) 57 | (dotimes (,position (product ,dimensions-var)) 58 | ,@body 59 | (,increment ,last))))) 60 | 61 | (defmacro walk-subscripts-list ((dimensions subscripts 62 | &optional (position (gensym "POSITION"))) 63 | &body body) 64 | "Like WALK-SUBSCRIPTS, but SUBSCRIPTS is a newly created list for each 65 | position that does not share structure and can be freely used/modified/kept 66 | etc." 67 | (with-unique-names (subscripts-vector) 68 | `(walk-subscripts (,dimensions ,subscripts-vector ,position) 69 | (let ((,subscripts (coerce ,subscripts-vector 'list))) 70 | ,@body)))) 71 | -------------------------------------------------------------------------------- /src/general.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:array-operations) 4 | 5 | ;;; shorthand functions 6 | ;;; 7 | ;;; In order to have the library functions work on objects other than arrays, 8 | ;;; 9 | ;;; 1. AS-ARRAY _must_ be defined, 10 | ;;; 2. ELEMENT-TYPE and DIMS _should_ be defined when AS-ARRAY is costly (eg conses), 11 | ;;; 3. all the other methods are optional as they fall back to DIMS. 12 | 13 | (defgeneric as-array (object) 14 | (:documentation "Return the contents of OBJECT as an array. Exact semantics depends on OBJECT, but generally objects which contain elements in a rectilinear coordinate system should have a natural mapping to arrays. 15 | 16 | When the second value is T, the array itself does not share structure with OBJECT, but its elements may. Otherwise, it is indeterminate whether the two objects share structure, and consequences of modifying the result are not defined. Methods are encouraged but not required to return a second value.") 17 | (:method ((array array)) 18 | array) 19 | (:method (object) 20 | (make-array nil :initial-element object))) 21 | 22 | (defgeneric element-type (array) 23 | (:documentation "Return TYPE such that 24 | 25 | 1. all elements of ARRAY are guaranteed to be a subtype of TYPE, 26 | 27 | 2. if applicable, elements of ARRAY can be set to values which are of a type that is a subtype of TYPE.") 28 | (:method ((array array)) 29 | (array-element-type array)) 30 | (:method (array) 31 | (array-element-type (as-array array)))) 32 | 33 | (defgeneric dims (array) 34 | (:documentation "Return a list of dimensions. 35 | 36 | For non-array objects, SIZE, DIM, NROW and NCOL use this method by default, so it is enough to define it (unless efficiency is a concern). 37 | 38 | When DIMS is not defined for an object, it falls back to as-array, which may be very inefficient for objects which need to be consed. It is always advisable to define DIMS.") 39 | (:method ((array array)) 40 | (array-dimensions array)) 41 | (:method (array) 42 | (array-dimensions (as-array array)))) 43 | 44 | (define-let+-expansion (&dims dimensions :value-var value-var 45 | :body-var body-var) 46 | "Dimensions of array-like object." 47 | `(let+ ((,dimensions (dims ,value-var))) 48 | ,@body-var)) 49 | 50 | (defgeneric size (array) 51 | (:documentation "Return the total number of elements in array.") 52 | (:method ((array array)) 53 | (array-total-size array)) 54 | (:method (array) 55 | (reduce #'* (dims array)))) 56 | 57 | (defgeneric rank (array) 58 | (:documentation "Return the rank of ARRAY.") 59 | (:method ((array array)) 60 | (array-rank array)) 61 | (:method (array) 62 | (length (dims array)))) 63 | 64 | (defgeneric dim (array axis) 65 | (:documentation "Return specificed dimension of ARRAY.") 66 | (:method ((array array) axis) 67 | (array-dimension array axis)) 68 | (:method (array axis) 69 | ;; NOTE: ELT is preferred to NTH here because it signals an error for invalid axes 70 | (elt (dims array) axis))) 71 | 72 | (defgeneric nrow (array) 73 | (:documentation "Number of rows. Will signal an error if ARRAY is not a matrix.") 74 | (:method ((array array)) 75 | (assert (= (rank array) 2)) 76 | (array-dimension array 0)) 77 | (:method (array) 78 | (let+ (((nrow &ign) (dims array))) 79 | nrow))) 80 | 81 | (defgeneric ncol (array) 82 | (:documentation "Number of columns. Will signal an error if ARRAY is not a matrix.") 83 | (:method ((array array)) 84 | (assert (= (rank array) 2)) 85 | (array-dimension array 1)) 86 | (:method (array) 87 | (let+ (((&ign ncol) (dims array))) 88 | ncol))) 89 | 90 | (deftype array-matrix () 91 | "A rank-2 array." 92 | '(array * (* *))) 93 | 94 | (declaim (inline matrix? square-matrix?)) 95 | (defun matrix? (matrix) 96 | "Test if MATRIX has rank 2." 97 | (length= (dims matrix) 2)) 98 | 99 | (defun square-matrix? (matrix) 100 | "Test if MATRIX has two dimensions and that they are equal." 101 | (let+ (((&accessors-r/o dims) matrix)) 102 | (and (length= dims 2) 103 | (= (first dims) (second dims))))) 104 | 105 | (defun make-array-like (array &key (dimensions (dims array)) 106 | (element-type (element-type array)) 107 | (initial-element nil initial-element?)) 108 | "Create an array with the same dimensions and element-type as ARRAY (which can be an array-like object that has the appropriate methods defined). Each attribute can be overriden. When INITIAL-ELEMENT is given, it is coerced to ELEMENT-TYPE and used as the initial element. 109 | 110 | The array returned is always a simple-array and shares no structure with anything else." 111 | (if initial-element? 112 | (make-array dimensions 113 | :element-type element-type 114 | :initial-element (coerce initial-element element-type)) 115 | (make-array dimensions 116 | :element-type element-type))) 117 | -------------------------------------------------------------------------------- /src/displacement.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:array-operations) 4 | 5 | ;;; displacement and flattening 6 | 7 | (defun displace (array dimensions &optional (offset 0)) 8 | "Shorthand function for displacing an array." 9 | (make-array (ensure-dimensions dimensions) 10 | :displaced-to array 11 | :displaced-index-offset offset 12 | :element-type (array-element-type array))) 13 | 14 | (defun flatten (array) 15 | "Return ARRAY flattened to a vector. Will share structure." 16 | (displace array (array-total-size array))) 17 | 18 | ;;; subarrays 19 | 20 | (defun split (array rank) 21 | "Return an array of subarrays, split off at RANK. All subarrays are 22 | displaced and share structure." 23 | (let ((array-rank (array-rank array))) 24 | (cond 25 | ((or (zerop rank) (= rank array-rank)) 26 | array) 27 | ((< 0 rank array-rank) 28 | (let* ((dimensions (array-dimensions array)) 29 | (result (make-array (subseq dimensions 0 rank))) 30 | (sub-dimensions (subseq dimensions rank)) 31 | (sub-size (product sub-dimensions))) 32 | (dotimes (index (array-total-size result)) 33 | (setf (row-major-aref result index) 34 | (displace array sub-dimensions (* index sub-size)))) 35 | result)) 36 | (t (error "Rank ~A outside [0,~A]." rank array-rank))))) 37 | 38 | (defun sub-location% (dimensions subscripts) 39 | "Return (values OFFSET REMAINING-DIMENSIONS) that can be used to displace a 40 | row-major subarray starting at SUBSCRIPTS in an array with the given 41 | DIMENSIONS. NOT EXPORTED." 42 | (let+ (rev-dimensions 43 | rev-subscripts 44 | (tail (do ((dimensions dimensions (cdr dimensions)) 45 | (subscripts subscripts (cdr subscripts))) 46 | ((not subscripts) dimensions) 47 | (assert dimensions () 48 | "More subscripts than dimensions.") 49 | (let ((s (car subscripts)) 50 | (d (car dimensions))) 51 | (declare (type fixnum d)) 52 | (assert (and (integerp s) (< -1 s d)) () 53 | "Invalid subscript.") 54 | (push s rev-subscripts) 55 | (push d rev-dimensions)))) 56 | (product (product tail)) 57 | (sum 0)) 58 | (declare (type fixnum product sum)) 59 | (mapc (lambda (d s) 60 | (declare (type fixnum d s)) 61 | (incf sum (the fixnum (* product s))) 62 | (multf product d)) 63 | rev-dimensions rev-subscripts) 64 | (values sum tail))) 65 | 66 | (defun sub (array &rest subscripts) 67 | "Given a partial list of subscripts, return the subarray that starts there, 68 | with all the other subscripts set to 0, dimensions inferred from the original. 69 | If no subscripts are given, the original array is returned. Implemented by 70 | displacing, may share structure." 71 | (if subscripts 72 | (let+ (((&values offset dimensions) 73 | (sub-location% (array-dimensions array) subscripts))) 74 | (if dimensions 75 | (displace array dimensions offset) 76 | (apply #'aref array subscripts))) 77 | array)) 78 | 79 | (defun copy-into (target source) 80 | "Copy SOURCE into TARGET, for array arguments of compatible 81 | dimensions (checked). Return TARGET, making the implementation of the 82 | semantics of SETF easy." 83 | (assert (same-dimensions? target source)) 84 | (replace (flatten target) (flatten source)) 85 | target) 86 | 87 | (defun (setf sub) (value array &rest subscripts) 88 | (let+ (((&values subarray atom?) (apply #'sub array subscripts))) 89 | (if atom? 90 | (setf (apply #'aref array subscripts) value) 91 | (copy-into subarray value)))) 92 | 93 | (defun partition (array start &optional (end (array-dimension array 0))) 94 | "Return a subset of the array, on the first indexes between START and END." 95 | (let* ((d0 (array-dimension array 0)) 96 | (stride (/ (array-total-size array) d0))) 97 | (assert (and (<= 0 start) (< start end) (<= end d0))) 98 | (displace array (cons (- end start) (cdr (array-dimensions array))) 99 | (* start stride)))) 100 | 101 | (defun (setf partition) (value array start 102 | &optional (end (array-dimension array 0))) 103 | (copy-into (partition array start end) value)) 104 | 105 | (defun combine (array &optional element-type) 106 | "The opposite of SUBARRAYS. If ELEMENT-TYPE is not given, it is inferred 107 | from the first element of array, which also determines the dimensions. If 108 | that element is not an array, the original ARRAY is returned as it is." 109 | (unless (arrayp array) 110 | (return-from combine array)) 111 | (let ((first (row-major-aref array 0))) 112 | (if (arrayp first) 113 | (let* ((dimensions (array-dimensions array)) 114 | (sub-dimensions (array-dimensions first)) 115 | (element-type (aif element-type it (array-element-type first))) 116 | (result (make-array (append dimensions sub-dimensions) 117 | :element-type element-type)) 118 | (length (product dimensions)) 119 | (displaced (displace result (cons length sub-dimensions)))) 120 | (dotimes (index length) 121 | (setf (sub displaced index) (row-major-aref array index))) 122 | result) 123 | array))) 124 | 125 | ;;; subvector 126 | 127 | (defun subvec (vector start &optional (end (length vector))) 128 | "Displaced vector between START and END." 129 | (displace vector (- end start) start)) 130 | 131 | (declaim (inline (setf subvec))) 132 | (defun (setf subvec) (value vector start &optional (end (length vector))) 133 | ;; just a synonym for (setf subseq), except for checking the length 134 | (assert (length= value (- end start))) 135 | (setf (subseq vector start end) value)) 136 | 137 | ;;; reshaping 138 | 139 | (defun fill-in-dimensions (dimensions size) 140 | "If one of the dimensions is missing (indicated with T), replace it with a 141 | dimension so that the total product equals SIZE. If that's not possible, 142 | signal an error. If there are no missing dimensions, just check that the 143 | product equals size. Also accepts other dimension specifications (integer, 144 | array)." 145 | (aetypecase dimensions 146 | ((integer 0) (assert (= size it)) (list it)) 147 | (array (assert (= size (rank it))) (dims it)) 148 | (list (let+ (((&flet missing? (dimension) (eq dimension t))) 149 | missing 150 | (product 1)) 151 | (loop for dimension in dimensions 152 | do (if (missing? dimension) 153 | (progn 154 | (assert (not missing) () 155 | "More than one missing dimension.") 156 | (setf missing t)) 157 | (progn 158 | (check-type dimension (integer 1)) 159 | (multf product dimension)))) 160 | (if missing 161 | (let+ (((&values fraction remainder) (floor size product))) 162 | (assert (zerop remainder) () 163 | "Substitution does not result in an integer ~ 164 | dimension.") 165 | (mapcar (lambda (dimension) 166 | (if (missing? dimension) fraction dimension)) 167 | dimensions)) 168 | dimensions))))) 169 | 170 | (defun reshape (array dimensions &optional (offset 0)) 171 | "Reshape ARRAY using DIMENSIONS (which can also be dimension 172 | specifications). If DIMENSIONS is a list, it may contain a single element T 173 | which will be calculated to match the total size of the resulting array." 174 | (let* ((size (array-total-size array)) 175 | (dimensions (fill-in-dimensions dimensions (- size offset)))) 176 | (displace array dimensions offset))) 177 | 178 | (defun reshape-col (array) 179 | "Array reshaped as an Nx1 matrix." 180 | (reshape array '(t 1))) 181 | 182 | (defun reshape-row (array) 183 | "Array reshaped as an 1xN matrix." 184 | (reshape array '(1 t))) 185 | -------------------------------------------------------------------------------- /tests/tests.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (cl:defpackage #:array-operations-tests 4 | (:use #:cl #:alexandria #:anaphora #:clunit #:let-plus) 5 | (:export #:run)) 6 | 7 | (cl:in-package #:array-operations-tests) 8 | 9 | (defsuite tests ()) 10 | 11 | (defun run (&optional interactive?) 12 | "Run all the tests for LLA." 13 | (run-suite 'tests :use-debugger interactive?)) 14 | 15 | ;;; utilities 16 | 17 | (deftest walk-subscripts (tests) 18 | (let (result) 19 | (aops:walk-subscripts ('(2 3) subscripts position) 20 | (push (cons position (copy-seq subscripts)) result)) 21 | (assert-equalp '((0 . #(0 0)) 22 | (1 . #(0 1)) 23 | (2 . #(0 2)) 24 | (3 . #(1 0)) 25 | (4 . #(1 1)) 26 | (5 . #(1 2))) 27 | (reverse result)))) 28 | 29 | ;;; displacement 30 | 31 | (deftest displacement (tests) 32 | (let ((a #2A((0 1) (2 3) (4 5)))) 33 | ;; displace 34 | (assert-equalp #(0 1) (aops:displace a 2)) 35 | (assert-equalp #2A((2 3)) (aops:displace a '(1 2) 2)) 36 | ;; flatten 37 | (assert-equalp #(0 1 2 3 4 5) (aops:flatten a)) 38 | ;; split 39 | (assert-equalp a (aops:split a 0)) 40 | (assert-equalp #(#(0 1) #(2 3) #(4 5)) (aops:split a 1)) 41 | (assert-equalp a (aops:split a 2)) 42 | ;; sub 43 | (assert-equalp #(4 5) (aops:sub a 2)) 44 | (assert-equalp 4 (aops:sub a 2 0)) 45 | (let ((b (copy-array a))) 46 | (assert-equalp #(7 9) (setf (aops:sub b 1) #(7 9))) 47 | (assert-equalp #2A((0 1) (7 9) (4 5)) b) 48 | (assert-condition error (setf (aops:sub 0 2) #(1)))) 49 | ;; partition 50 | (assert-equalp #2A((2 3) (4 5)) (aops:partition a 1)) 51 | (assert-equalp #2A((2 3)) (aops:partition a 1 2)) 52 | (assert-condition error (aops:partition a 0 9)) 53 | (let ((b (copy-array a))) 54 | (setf (aops:partition b 1) #2A((11 13) (17 19))) 55 | (assert-equalp #2A((0 1) (11 13) (17 19)) b)) 56 | ;; combine 57 | (assert-equalp a (aops:combine (aops:split a 0))) 58 | (assert-equalp a (aops:combine (aops:split a 1))) 59 | (assert-equalp a (aops:combine (aops:split a 2))) 60 | (let ((b #(1 #(2 3) 4)) 61 | (c 9)) 62 | (assert-equalp b (aops:combine b)) 63 | (assert-equalp c (aops:combine c))) 64 | ;; subvec 65 | (let ((b (copy-array (aops:flatten a)))) 66 | (assert-equalp #(2 3 4 5) (aops:subvec b 2)) 67 | (assert-equalp #(3 4) (aops:subvec b 3 5)) 68 | (assert-condition error (aops:subvec b 0 9)) 69 | (assert-equalp #(7 9) (setf (aops:subvec b 3 5) #(7 9))) 70 | (assert-equalp #(0 1 2 7 9 5) b) 71 | (assert-condition error (setf (aops:subvec b 3 5) #(7)))) 72 | ;; reshape & variances 73 | (assert-equalp #2A((0 1 2) (3 4 5)) (aops:reshape a '(2 3))) 74 | (assert-equalp #2A((0 1 2 3 4 5)) (aops:reshape-row a)) 75 | (assert-equalp #2A((0) (1) (2) (3) (4) (5)) (aops:reshape-col a)))) 76 | 77 | ;;; transformations 78 | 79 | (deftest coercing (tests) 80 | (assert-equality (curry #'every #'eql) 81 | #(1d0 2d0 3d0) 82 | (map 'vector (aops:coercing 'double-float) #(1 2 3))) 83 | (assert-equality (curry #'every #'eql) 84 | #(1d0 4d0 9d0) 85 | (map 'vector (aops:coercing 'double-float (lambda (x) (* x x))) #(1 2 3)))) 86 | 87 | (deftest generate (tests) 88 | (let ((a (aops:generate #'identity '(3 2) :position)) 89 | (b (aops:generate #'identity '(2 3) :subscripts))) 90 | (assert-equalp #2A((0 1) 91 | (2 3) 92 | (4 5)) 93 | a) 94 | (assert-equalp #2A(((0 0) (0 1) (0 2)) 95 | ((1 0) (1 1) (1 2))) 96 | b) 97 | (assert-equalp #2A(((0 0 0) (1 0 1))) 98 | (aops:generate #'cons '(1 2) :position-and-subscripts)))) 99 | 100 | (defun permute% (subscripts-mapping array) 101 | "Helper function for testing permutation. Permutes ARRAY using SUBSCRIPTS-MAPPING, should return the permuted arguments as a list." 102 | (let+ ((dimensions (array-dimensions array)) 103 | ((&flet map% (subscripts) 104 | (apply subscripts-mapping subscripts)))) 105 | (aprog1 (make-array (map% dimensions) 106 | :element-type (array-element-type array)) 107 | (aops:walk-subscripts-list (dimensions subscripts) 108 | (setf (apply #'aref it (map% subscripts)) 109 | (apply #'aref array subscripts)))))) 110 | 111 | (deftest permutations (tests) 112 | (assert-equalp #*10110 (aops::permutation-flags '(0 3 2) 5)) 113 | (assert-condition error (aops::check-permutation '(0 1 1))) 114 | (assert-equalp '(0 1 4) (aops:complement-permutation '(3 2) 5)) 115 | (assert-equalp '(3 2 0 1 4) (aops:complete-permutation '(3 2) 5)) 116 | (assert-equalp '(0 1 2 3) (aops:invert-permutation '(0 1 2 3))) 117 | (assert-equalp '(1 3 2 0) (aops:invert-permutation '(3 0 2 1))) 118 | (let+ (((&flet assert-equalp-i2 (permutation) 119 | (assert-equalp permutation 120 | (aops:invert-permutation (aops:invert-permutation permutation)))))) 121 | (assert-equalp-i2 '(0 1 2 3)) 122 | (assert-equalp-i2 '(3 0 2 1)))) 123 | 124 | (deftest permute (tests) 125 | (let ((a (aops:generate #'identity '(3 2) :position))) 126 | (assert-equalp a (aops:permute '(0 1) a)) 127 | (assert-equalp #2A((0 2 4) 128 | (1 3 5)) 129 | (aops:permute '(1 0) a)) 130 | (assert-condition aops:permutation-repeated-index (aops:permute '(0 0) a)) 131 | (assert-condition aops:permutation-invalid-index (aops:permute '(2 0) a)) 132 | (assert-condition aops:permutation-incompatible-rank (aops:permute '(0) a))) 133 | (let ((p (alexandria:shuffle (list 0 1 2 3 4))) 134 | (a (aops:generate (lambda () (random 100)) '(2 3 4 5 6))) 135 | (*lift-equality-test* #'equalp)) 136 | (assert-equalp p (aops:invert-permutation (aops:invert-permutation p))) 137 | (assert-equalp a (aops:permute (aops:invert-permutation p) (aops:permute p a)))) 138 | (let ((a (aops:generate #'identity '(2 2 2) :position))) 139 | (assert-equalp (aops:permute '(2 0 1) a) 140 | (permute% (lambda (a b c) (list c a b)) a)))) 141 | 142 | (deftest each (tests) 143 | (let ((a (aops:generate #'identity '(2 5) :position))) 144 | (assert-equalp (aops:generate #'1+ '(2 5) :position) (aops:each #'1+ a))) 145 | (assert-equalp #(1 1 2 3) (aops:each #'- #(2 3 5 7) #(1 2 3 4)))) 146 | 147 | (deftest margin (tests) 148 | (let ((a (aops:generate #'identity '(3 5) :position))) 149 | (assert-equalp #(10 35 60) (aops:margin (curry #'reduce #'+) a 1)) 150 | (assert-equalp #(0 66 168 312 504) (aops:margin (curry #'reduce #'*) a 0)))) 151 | 152 | (deftest recycle (tests) 153 | (assert-equalp (make-array '(3 4 2 1) :initial-element 1) 154 | (aops:recycle 1 :inner '(2 1) :outer '(3 4))) 155 | (let ((a (aops:generate #'identity '(2 3) :position))) 156 | (assert-equalp a (aops:recycle a)) 157 | (assert-equalp (aops:generate (lambda (p) (floor p 2)) '(2 3 2) :position) 158 | (aops:recycle a :inner 2)) 159 | (assert-equalp (aops:generate (lambda (p) (rem p 6)) '(2 2 3 1) :position) 160 | (aops:recycle a :inner 1 :outer 2)))) 161 | 162 | (deftest outer (tests) 163 | (let ((a #(2 3 5)) 164 | (b #(7 11)) 165 | (c #2A((7 11) 166 | (13 17)))) 167 | (assert-equalp #2A((14 22) 168 | (21 33) 169 | (35 55)) 170 | (aops:outer #'* a b)) 171 | (assert-equalp #3A(((14 21 35) (22 33 55)) 172 | ((26 39 65) (34 51 85))) 173 | (aops:outer #'* c a)) 174 | (assert-equalp (aops:combine (aops:each (lambda (v) 175 | (aops:each (curry #'* v) c)) 176 | a)) 177 | (aops:outer #'* a c)))) 178 | 179 | ;;; stack 180 | 181 | (deftest stack-rows (tests) 182 | (let ((a 1) 183 | (b #(2 3)) 184 | (c #2A((4 5) 185 | (6 7)))) 186 | (assert-equalp #2A((1 1) 187 | (2 3) 188 | (4 5) 189 | (6 7)) 190 | (aops:stack-rows a b c)) 191 | (assert-equalp #2A((2 3) 192 | (1 1) 193 | (4 5) 194 | (6 7)) 195 | (aops:stack-rows b a c)) 196 | (assert-equalp #2A((4 5) 197 | (6 7) 198 | (1 1) 199 | (2 3)) 200 | (aops:stack-rows c a b)) 201 | (assert-equalp #2A((1) (2) (3)) (aops:stack-rows 1 2 3)) 202 | (assert-condition error (aops:stack-rows #2A((1)) c)))) 203 | 204 | (deftest stack-cols (tests) 205 | (let ((a 1) 206 | (b #(2 3)) 207 | (c #2A((4 5) 208 | (6 7)))) 209 | (assert-equalp #2A((1 2 4 5) 210 | (1 3 6 7)) 211 | (aops:stack-cols a b c)) 212 | (assert-equalp #2A((2 1 4 5) 213 | (3 1 6 7)) 214 | (aops:stack-cols b a c)) 215 | (assert-equalp #2A((4 5 1 2) 216 | (6 7 1 3)) 217 | (aops:stack-cols c a b)) 218 | (assert-equalp #2A((1 2 3)) (aops:stack-cols 1 2 3)) 219 | (assert-condition error (aops:stack-cols #2A((1)) c)))) 220 | 221 | (deftest stack0 (tests) 222 | (assert-equalp #(0 1 2 3 4 5 6) (aops:stack 0 #(0 1 2 3) #(4 5 6))) 223 | (assert-equalp #2A((0 1) 224 | (2 3) 225 | (5 7)) 226 | (aops:stack 0 227 | #2A((0 1) 228 | (2 3)) 229 | #2A((5 7)))) 230 | (assert-condition error (aops:stack 0 #(0 1) #2A((0 1 2 3)))) 231 | (assert-condition error (aops:stack 0 #2A((1)) #2A((0 1))))) 232 | 233 | (deftest stack (tests) 234 | (assert-equalp #2A((0 1 5) 235 | (2 3 9)) 236 | (aops:stack 1 237 | #2A((0 1) 238 | (2 3)) 239 | #2A((5) (9))))) 240 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![Project Status: Abandoned – Initial development has started, but there 2 | has not yet been a stable, usable release; the project has been 3 | abandoned and the author(s) do not intend on continuing 4 | development.](http://www.repostatus.org/badges/latest/abandoned.svg) 5 | 6 | This library is [**abandonned**](https://tpapp.github.io/post/orphaned-lisp-libraries/) by the original author. A fork is maintained at https://github.com/Lisp-Stat/array-operations. 7 | 8 | ## NOTE 2019-05-16 9 | 10 | @bendudson and others have continued maintaining a fork of this library at . 11 | 12 | !!! important 13 | This is an **alpha** release. All the code works and unit tests are expected to run perfectly, but the operations are not optimized and the API change. 14 | 15 | ## Introduction 16 | 17 | `array-operations` is a Common Lisp library that facilitates working 18 | with Common Lisp arrays using syntax and semantics that work well with 19 | the rest of the language. 20 | 21 | *The library previously available under this name is deprecated, but you 22 | can find it [here](https://github.com/tpapp/array-operations-old).* 23 | 24 | ## A quick tour of the library 25 | 26 | ### Shorthand for frequently used Common Lisp array functions 27 | --------------------------------------------------------- 28 | 29 | The library defines the following short function names that are synomyms 30 | for Common Lisp operations: 31 | 32 | | array-operations | Common Lisp | 33 | | ------------------ | ------------------------------- | 34 | | size | array-total-size | 35 | | rank | array-rank | 36 | | dim | array-dimension | 37 | | dims | array-dimensions | 38 | | nrow | *number of rows in matrix* | 39 | | ncol | *number of columns in matrix* | 40 | 41 | The `array-operations` package has the nickname `ao`, so you can use, 42 | for example, `(ao:size my-array)` without `use`'ing the package. 43 | 44 | ### Displaced arrays for fun and profit 45 | 46 | > displaced array n. an array which has no storage of its own, but which 47 | > is instead indirected to the storage of another array, called its 48 | > target, at a specified offset, in such a way that any attempt to 49 | > access the displaced array implicitly references the target array. 50 | > (CLHS Glossary) 51 | 52 | Displaced arrays are one of the niftiest features of Common Lisp. When 53 | an array is displaced to another array, it shares structure with (part 54 | of) that array. The two arrays do not need to have the same dimensions, 55 | in fact, the dimensions do not be related at all as long as the 56 | displaced array fits inside the original one. The row-major index of the 57 | former in the latter is called the *offset* of the displacement. 58 | 59 | Displaced arrays are usually constructed using `make-array`, but this 60 | library also provides `displace` for that purpose: 61 | 62 | ```lisp 63 | (defparameter *a* #2A((1 2 3) (4 5 6))) 64 | (ao:displace *a* 2 1) ; => #(2 3) 65 | ``` 66 | 67 | `flatten` displaces to a row-major array: 68 | 69 | ```lisp 70 | (ao:flatten *a*) ; => #(1 2 3 4 5 6) 71 | ``` 72 | 73 | The real fun starts with `split`, which splits off subarrays nested 74 | within a given axis: 75 | 76 | ```lisp 77 | (ao:split *a* 1) ; => #(#(1 2 3) #(4 5 6)) 78 | (defparameter *b* #3A(((0 1) (2 3)) 79 | ((4 5) (6 7)))) 80 | (ao:split *b* 0) ; => #3A(((0 1) (2 3)) ((4 5) (6 7))) 81 | (ao:split *b* 1) ; => #(#2A((0 1) (2 3)) #2A((4 5) (6 7))) 82 | (ao:split *b* 2) ; => #2A((#(0 1) #(2 3)) (#(4 5) #(6 7))) 83 | (ao:split *b* 3) ; => #3A(((0 1) (2 3)) ((4 5) (6 7))) 84 | ``` 85 | 86 | Note how splitting at `0` and the rank of the array returns the array 87 | itself. 88 | 89 | Now consider `sub`, which returns a specific array, composed of the 90 | elements that would start with given subscripts: 91 | 92 | ```lisp 93 | (ao:sub *b* 0) ; => #2A((0 1) (2 3)) 94 | (ao:sub *b* 0 1) ; => #(2 3) 95 | (ao:sub *b* 0 1 0) ; => 2 96 | ``` 97 | 98 | There is also a `(setf sub)` function. 99 | 100 | `partition` returns a consecutive chunk of an array separated along its 101 | first subscript: 102 | 103 | ```lisp 104 | (ao:partition #2A((0 1) 105 | (2 3) 106 | (4 5) 107 | (6 7) 108 | (8 9)) 109 | 1 3) ; => #2A((2 3) (4 5)) 110 | ``` 111 | 112 | and also has a `(setf partition)` pair. 113 | 114 | `combine` is the opposite of `split`: 115 | 116 | ```lisp 117 | (ao:combine #(#(0 1) #(2 3))) ; => #2A((0 1) (2 3)) 118 | ``` 119 | 120 | `subvec` returns a displaced subvector: 121 | 122 | ```lisp 123 | (ao:subvec #(0 1 2 3 4) 2 4) ; => #(2 3) 124 | ``` 125 | 126 | There is also a `(setf subvec)` function, which is like `(setf subseq)` 127 | except for demanding matching lengths. 128 | 129 | Finally, `reshape` can be used to displace arrays into a different 130 | shape: 131 | 132 | ```lisp 133 | (ao:reshape *a* '(3 2)) ; => #2A((1 2) (3 4) (5 6)) 134 | ``` 135 | 136 | You can use `t` for one of the dimensions, to be filled in 137 | automatically: 138 | 139 | ```lisp 140 | (ao:reshape *b* '(1 t)) ; => #2A((0 1 2 3 4 5 6 7)) 141 | ``` 142 | 143 | `reshape-col` and `reshape-row` reshape your array into a column or row 144 | matrix, respectively. 145 | 146 | Dimension specifications 147 | ------------------------ 148 | 149 | Functions in the library accept the following in place of dimensions: 150 | 151 | - a list of dimensions (as for `make-array`), 152 | - a positive integer, which is used as a single-element list, 153 | - another array, the dimensions of which are used. 154 | 155 | The last one allows you to specify dimensions with other arrays. For 156 | example, to reshape an array `a1` to look like `a2`, you can use 157 | 158 | ```lisp 159 | (ao:reshape a1 a2) 160 | ``` 161 | 162 | instead of the longer form 163 | 164 | ```lisp 165 | (ao:reshape a1 (ao:dims a2)) 166 | ``` 167 | 168 | Array creation and transformations 169 | ---------------------------------- 170 | 171 | When the resulting element type cannot be inferred, functions that 172 | create and transform arrays are provided in pairs: one of these will 173 | allow you to specify the array-element-type of the result, while the 174 | other assumes it is `t`. The former ends with a `*`, and the 175 | `element-type` is always its first argument. I give examples for the 176 | versions without `*`, use the other when you are optimizing your code 177 | and you are sure you can constrain to a given element-type. 178 | 179 | **Element traversal order of these functions is unspecified**. The 180 | reason for this is that the library may use parallel code in the future, 181 | so it is unsafe to rely on a particular element traversal order. 182 | 183 | `generate` (and `generate*`) allow you to generate arrays using 184 | functions. 185 | 186 | ```lisp 187 | (ao:generate (lambda () (random 10)) 3) ; => #(6 9 5) 188 | (ao:generate #'identity '(2 3) :position) ; => #2A((0 1 2) (3 4 5)) 189 | (ao:generate #'identity '(2 2) :subscripts) 190 | ;; => #2A(((0 0) (0 1)) ((1 0) (1 1))) 191 | (ao:generate #'cons '(2 2) :position-and-subscripts) 192 | ;; => #2A(((0 0 0) (1 0 1)) ((2 1 0) (3 1 1))) 193 | ``` 194 | 195 | Depending on the last argument, the function will be called with the 196 | (row-major) position, the subscripts, both, or no argument. 197 | 198 | `permute` can permutate subscripts (you can also invert, complement, and 199 | complete permutations, look at the docstring and the unit tests). 200 | Transposing is a special case of permute: 201 | 202 | ```lisp 203 | (ao:permute '(0 1) *a*) ; => #2A((1 2 3) (4 5 6)) 204 | ``` 205 | 206 | `each` applies a function to its (array) arguments elementwise: 207 | 208 | ```lisp 209 | (ao:each #'+ #(0 1 2) #(2 3 5)) ; => #(2 4 7) 210 | ``` 211 | 212 | The semantics of `margin` are more difficult to explain, so perhaps an 213 | example will be more useful. Suppose that you want to calculate column 214 | sums in a matrix. You could `permute` (transpose) the matrix, `split` 215 | its subarrays at rank one (so you get a vector for each row), and apply 216 | the function that calculates the sum. `margin` automates that for you: 217 | 218 | ```lisp 219 | (ao:margin (lambda (column) 220 | (reduce #'+ column)) 221 | #2A((0 1) 222 | (2 3) 223 | (5 7)) 0) ; => #(7 11) 224 | ``` 225 | 226 | But the function is much more general than this: the arguments `inner` 227 | and `outer` allow arbitrary permutations before splitting. 228 | 229 | Finally, `recycle` allows you to recycle arrays along inner and outer 230 | dimensions: 231 | 232 | ```lisp 233 | (ao:recycle #(2 3) :inner 2 :outer 4) 234 | ; => #3A(((2 2) (3 3)) ((2 2) (3 3)) ((2 2) (3 3)) ((2 2) (3 3))) 235 | ``` 236 | 237 | Scalars as 0-dimensional arrays 238 | ------------------------------- 239 | 240 | Library functions treat non-array objects as if they were equivalent to 241 | 0-dimensional arrays: for example, `(ao:split array (rank array))` 242 | returns an array that effectively equivalent (`eq`) to array. Another 243 | example is `recycle`: 244 | 245 | ```lisp 246 | (ao:recycle 4 :inner '(2 2)) ; => #2A((4 4) (4 4)) 247 | ``` 248 | 249 | Stacking 250 | -------- 251 | 252 | You can also stack compatible arrays along any axis: 253 | 254 | ```lisp 255 | (defparameter *a1* #(0 1 2)) 256 | (defparameter *a2* #(3 5 7)) 257 | (ao:stack 0 *a1* *a2*) ; => #(0 1 2 3 5 7) 258 | (ao:stack 1 259 | (ao:reshape-col *a1*) 260 | (ao:reshape-col *a2*)) ; => #2A((0 3) (1 5) (2 7)) 261 | 262 | ``` 263 | 264 | Shared structure 265 | ---------------- 266 | 267 | **Rules for that aren't finalized yet, see the source.** Suggestions are 268 | welcome. 269 | 270 | To-do list 271 | ========== 272 | 273 | benchmark and optimize walk-subscripts and walk-subscripts-list 274 | --------------------------------------------------------------- 275 | 276 | - instead of allocating a new list each time, could map into a 277 | preallocated one 278 | -------------------------------------------------------------------------------- /src/transformations.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:array-operations) 4 | 5 | ;;; coercing can be used with * forms 6 | 7 | (defun coercing (element-type &optional (function #'identity)) 8 | "Return a function composed of a univariate function that coerces to ELEMENT-TYPE and function. When FUNCTION is not given, return a closure that coerces to ELEMENT-TYPE." 9 | (compose (lambda (value) (coerce value element-type)) 10 | function)) 11 | 12 | ;;; creating arrays 13 | 14 | (defun generate* (element-type function dimensions &optional arguments) 15 | "Return an array with given DIMENSIONS and ELEMENT-TYPE, with elements 16 | generated by calling FUNCTION with 17 | 18 | - no arguments, when ARGUMENTS is nil 19 | - the position (= row major index), when ARGUMENTS is :POSITION 20 | - a list of subscripts, when ARGUMENTS is :SUBSCRIPTS 21 | - both when ARGUMENTS is :POSITION-AND-SUBSCRIPTS 22 | 23 | The traversal order is unspecified and may be nonlinear." 24 | (let ((dimensions (ensure-dimensions dimensions))) 25 | (aprog1 (make-array dimensions :element-type element-type) 26 | (ecase arguments 27 | ((nil) 28 | (dotimes (position (array-total-size it)) 29 | (setf (row-major-aref it position) 30 | (funcall function)))) 31 | (:position 32 | (walk-subscripts (dimensions subscripts position) 33 | (setf (row-major-aref it position) (funcall function position)))) 34 | (:subscripts 35 | (walk-subscripts-list (dimensions subscripts position) 36 | (setf (row-major-aref it position) 37 | (funcall function subscripts)))) 38 | (:position-and-subscripts 39 | (walk-subscripts-list (dimensions subscripts position) 40 | (setf (row-major-aref it position) 41 | (funcall function position subscripts)))))))) 42 | 43 | (defun generate (function dimensions &optional arguments) 44 | "Like GENERATE*, with ELEMENT-TYPE T." 45 | (generate* t function dimensions arguments)) 46 | 47 | 48 | 49 | ;;; permutations 50 | ;;; 51 | ;;; A permutation is a list of nonnegative, non-repeated integers, below some 52 | ;;; rank (of the array it is applied to). 53 | 54 | (define-condition permutation-repeated-index (error) 55 | ((index :initarg :index))) 56 | 57 | (define-condition permutation-invalid-index (error) 58 | ((index :initarg :index))) 59 | 60 | (define-condition permutation-incompatible-rank (error) 61 | ()) 62 | 63 | (defun permutation-flags (permutation &optional (rank (length permutation))) 64 | "Make a bit vector of flags with indexes from PERMUTATION, signalling errors 65 | for invalid and repeated indices. NOT EXPORTED." 66 | (aprog1 (make-array rank :element-type 'bit :initial-element 0) 67 | (map nil (lambda (p) 68 | (assert (and (integerp p) (< -1 p rank)) () 69 | 'permutation-invalid-index :index p) 70 | (assert (zerop (aref it p)) () 71 | 'permutation-repeated-index :index p) 72 | (setf (aref it p) 1)) 73 | permutation))) 74 | 75 | (defun check-permutation (permutation 76 | &optional (rank (length permutation) rank?)) 77 | "Check if PERMUTATION is a valid permutation (of the given RANK), and signal 78 | an error if necessary." 79 | (when rank? 80 | (assert (= rank (length permutation)) () 81 | 'permutation-incompatible-rank )) 82 | (assert (every #'plusp (permutation-flags permutation)) () 83 | 'permutation-incompatible-rank)) 84 | 85 | (defun complement-permutation (permutation rank) 86 | "Return a list of increasing indices that complement PERMUTATION, ie form a 87 | permutation when appended. Atoms are accepted and treated as lists of a 88 | single element." 89 | (loop for f across (permutation-flags (ensure-list permutation) rank) 90 | for index from 0 91 | when (zerop f) 92 | collect index)) 93 | 94 | (defun complete-permutation (permutation rank) 95 | "Return a completed version of permutation, appending it to its complement." 96 | (let ((permutation (ensure-list permutation))) 97 | (append permutation (complement-permutation permutation rank)))) 98 | 99 | (defun invert-permutation (permutation) 100 | "Invert a permutation." 101 | (check-permutation permutation) 102 | (coerce (aprog1 (make-array (length permutation) :element-type 'fixnum) 103 | (map nil (let ((index 0)) 104 | (lambda (p) 105 | (setf (aref it p) index) 106 | (incf index))) 107 | permutation)) 108 | 'list)) 109 | 110 | (defun identity-permutation? (permutation 111 | &optional (rank (length permutation))) 112 | "Test if PERMUTATION is the identity permutation, ie a sequence of 113 | consecutive integers starting at 0. Note that permutation is otherwise not 114 | checked, ie it may not be a permutation." 115 | (let ((index 0)) 116 | (and 117 | (every 118 | (lambda (p) 119 | (prog1 (= index p) 120 | (incf index))) 121 | permutation) 122 | (= index rank)))) 123 | 124 | (defun permute (permutation array) 125 | "Return ARRAY with the axes permuted by PERMUTATION, which is a sequence of 126 | indexes. Specifically, an array A is transformed to B, where 127 | 128 | B[b_1,...,b_n] = A[a_1,...,a_n] with b_i=a_{P[i]} 129 | 130 | P is the permutation. 131 | 132 | Array element type is preserved." 133 | (let ((rank (array-rank array))) 134 | (if (identity-permutation? permutation rank) 135 | array 136 | (let+ ((dimensions (array-dimensions array)) 137 | ((&flet map-subscripts (subscripts-vector) 138 | (map 'list (curry #'aref subscripts-vector) permutation)))) 139 | (check-permutation permutation rank) 140 | (aprog1 (make-array (map-subscripts (coerce dimensions 'vector)) 141 | :element-type (array-element-type array)) 142 | (walk-subscripts (dimensions subscripts position) 143 | (setf (apply #'aref it (map-subscripts subscripts)) 144 | (row-major-aref array position)))))))) 145 | 146 | 147 | ;;; margin 148 | 149 | (defun each* (element-type function array &rest other-arrays) 150 | "Apply function to the array arguments elementwise, and return the result as 151 | an array with the given ELEMENT-TYPE. Arguments are checked for dimension 152 | compatibility." 153 | (aprog1 (make-array (array-dimensions array) :element-type element-type) 154 | (assert (apply #'same-dimensions? array other-arrays)) 155 | (apply #'map-into (flatten it) function 156 | (flatten array) (mapcar #'flatten other-arrays)))) 157 | 158 | (defun each (function array &rest other-arrays) 159 | "Like EACH*, with ELEMENT-TYPE T." 160 | (apply #'each* t function array other-arrays)) 161 | 162 | (defun margin* (element-type function array inner 163 | &optional (outer (complement-permutation inner 164 | (array-rank array)))) 165 | "PERMUTE ARRAY with `(,@OUTER ,@INNER), split the inner subarrays, apply 166 | FUNCTION to each, return the results in an array of dimensions OUTER, with the 167 | given ELEMENT-TYPE." 168 | (let ((outer (ensure-list outer))) 169 | (each* element-type function 170 | (split (permute (append outer (ensure-list inner)) array) 171 | (length outer))))) 172 | 173 | (defun margin (function array inner 174 | &optional (outer (complement-permutation inner 175 | (array-rank array)))) 176 | "Like MARGIN*, with ELEMENT-TYPE T." 177 | (margin* t function array inner outer)) 178 | 179 | 180 | 181 | ;;; recycle 182 | 183 | (defun recycle (object &key inner outer 184 | (element-type (if (arrayp object) 185 | (array-element-type object) 186 | t))) 187 | "Recycle elements of object, extending the dimensions by outer (repeating 188 | OBJECT) and inner (repeating each element of OBJECT). When both INNER and 189 | OUTER are nil, the OBJECT is returned as is. Non-array objects are intepreted 190 | as rank 0 arrays, following the usual semantics." 191 | (if (or inner outer) 192 | (let ((inner (ensure-dimensions inner)) 193 | (outer (ensure-dimensions outer))) 194 | (if (arrayp object) 195 | (let ((dimensions (array-dimensions object))) 196 | (aprog1 (make-array (append outer dimensions inner) 197 | :element-type element-type) 198 | (let* ((outer-size (product outer)) 199 | (size (product dimensions)) 200 | (inner-size (product inner)) 201 | (reshaped (reshape it (list outer-size size inner-size)))) 202 | (loop for outer-index below outer-size 203 | do (loop for index below size 204 | do (fill (sub reshaped outer-index index) 205 | (row-major-aref object index))))))) 206 | (make-array (append outer inner) :initial-element object 207 | :element-type element-type))) 208 | object)) 209 | 210 | ;;; outer produce 211 | (defun outer* (element-type function &rest arrays) 212 | "Generalized outer product of ARRAYS with FUNCTION. The resulting array has the concatenated dimensions of ARRAYS, and the given ELEMENT-TYPE." 213 | (assert arrays) 214 | (let* ((result (make-array (mapcan #'dims arrays) :element-type element-type)) 215 | (vectors (mapcar #'flatten arrays)) 216 | (flat-dimensions (mapcar #'length vectors)) 217 | (flat-result (reshape result flat-dimensions))) 218 | (walk-subscripts (flat-dimensions subscripts position) 219 | (setf (row-major-aref flat-result position) 220 | (apply function (map 'list #'aref vectors subscripts)))) 221 | result)) 222 | 223 | (defun outer (function &rest arrays) 224 | "Like OUTER, with ELEMENT-TYPE t." 225 | (apply #'outer* t function arrays)) 226 | -------------------------------------------------------------------------------- /src/stack.lisp: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8 -*- 2 | 3 | (in-package #:array-operations) 4 | 5 | (defun copy-row-major-block (source-array destination-array element-type 6 | &key (source-start 0) 7 | (source-end (size source-array)) 8 | (destination-start 0)) 9 | "Copy elements with row major indexes between the given start and end from SOURCE to DESTINATION, respectively. Elements are coerced to ELEMENT-TYPE when necessary. Return no values. 10 | 11 | This function should be used to implement copying of contiguous row-major blocks of elements, most optimizations should happen here." 12 | (let ((count (- source-end source-start))) 13 | (let ((source (displace source-array count source-start)) 14 | (destination (displace destination-array count destination-start))) 15 | (if (subtypep (element-type source-array) element-type) 16 | (replace destination source) 17 | (map-into destination (lambda (element) (coerce element element-type)) 18 | source)))) 19 | (values)) 20 | 21 | (defgeneric stack-rows-copy (source destination element-type start-row) 22 | (:documentation "Method used to implement the copying of objects in STACK-ROW*, by copying the elements of SOURCE to DESTINATION, starting with the row index START-ROW in the latter. Elements are coerced to ELEMENT-TYPE. 23 | 24 | This method is only called when (DIMS SOURCE) was non-nil. It is assumed that it onlychanges elements in DESTINATION which are supposed to be copies of SOURCE. DESTINATION is always a matrix with element-type upgraded from ELEMENT-TYPE, and its NCOL should match the relevant dimension of SOURCE. 25 | 26 | All objects have a fallback method, defined using AS-ARRAY. The only reason for definining a method is efficiency.") 27 | (:method (source destination element-type start-row) 28 | (stack-rows-copy (as-array source) destination element-type start-row)) 29 | (:method ((source array) destination element-type start-row) 30 | (copy-row-major-block source destination element-type 31 | :destination-start (* start-row (ncol destination))))) 32 | 33 | (defun stack-rows* (element-type &rest objects) 34 | "Stack OBJECTS row-wise into an array of the given ELEMENT-TYPE, coercing if necessary. Always return a simple array of rank 2. 35 | 36 | How objects are used depends on their dimensions, queried by DIMS: 37 | 38 | - when the object has 0 dimensions, fill a row with the element. 39 | 40 | - when the object has 1 dimension, use it as a row. 41 | 42 | - when the object has 2 dimensions, use it as a matrix. 43 | 44 | When applicable, compatibility of dimensions is checked, and the result is used to determine the number of columns. When all objects have 0 dimensions, the result has one column." 45 | (let+ (ncol 46 | ((&flet check-ncol (dim) 47 | (if ncol 48 | (assert (= ncol dim)) 49 | (setf ncol dim)))) 50 | (nrow 0) 51 | (start-rows-and-dims (mapcar 52 | (lambda (object) 53 | (let* ((dims (dims object)) 54 | (increment (ematch dims 55 | (nil 1) 56 | ((list d0) (check-ncol d0) 57 | 1) 58 | ((list d0 d1) (check-ncol d1) 59 | d0)))) 60 | (prog1 (cons nrow dims) 61 | (incf nrow increment)))) 62 | objects)) 63 | (ncol (aif ncol it 1))) 64 | (aprog1 (make-array (list nrow ncol) :element-type element-type) 65 | (mapc (lambda+ ((start-row &rest dims) object) 66 | (if dims 67 | (stack-rows-copy object it element-type start-row) 68 | (fill (displace it ncol (* start-row ncol)) 69 | (coerce object element-type)))) 70 | start-rows-and-dims objects)))) 71 | 72 | (defun stack-rows (&rest objects) 73 | "Like STACK-ROWS*, with ELEMENT-TYPE T." 74 | (apply #'stack-rows* t objects)) 75 | 76 | (defgeneric stack-cols-copy (source destination element-type start-col) 77 | (:documentation "Method used to implement the copying of objects in STACK-COL*, by copying the elements of SOURCE to DESTINATION, starting with the column index START-COL in the latter. Elements are coerced to ELEMENT-TYPE. 78 | 79 | This method is only called when (DIMS SOURCE) was non-nil. It is assumed that it only changes elements in DESTINATION which are supposed to be copies of SOURCE. DESTINATION is always a matrix with element-type upgraded from ELEMENT-TYPE, and its NROW should match the relevant dimension of SOURCE. 80 | 81 | All objects have a fallback method, defined using AS-ARRAY. The only reason for definining a method is efficiency.") 82 | (:method (source destination element-type start-col) 83 | (stack-cols-copy (as-array source) destination element-type start-col)) 84 | (:method ((source array) destination element-type start-col) 85 | (ematch (dims source) 86 | ((list _) 87 | (loop for row below (nrow destination) 88 | do (setf (aref destination row start-col) 89 | (coerce (aref source row) element-type)))) 90 | ((list _ ncol) 91 | (loop for row below (nrow destination) 92 | for source-start by ncol 93 | do (copy-row-major-block source destination element-type 94 | :source-start source-start 95 | :source-end (+ source-start ncol) 96 | :destination-start (array-row-major-index 97 | destination 98 | row start-col))))))) 99 | 100 | (defun stack-cols* (element-type &rest objects) 101 | "Stack OBJECTS column-wise into an array of the given ELEMENT-TYPE, coercing if necessary. Always return a simple array of rank 2. 102 | 103 | How objects are used depends on their dimensions, queried by DIMS: 104 | 105 | - when the object has 0 dimensions, fill a column with the element. 106 | 107 | - when the object has 1 dimension, use it as a column. 108 | 109 | - when the object has 2 dimensions, use it as a matrix. 110 | 111 | When applicable, compatibility of dimensions is checked, and the result is used to determine the number of rows. When all objects have 0 dimensions, the result has one row." 112 | (let+ (nrow 113 | ((&flet check-nrow (dim) 114 | (if nrow 115 | (assert (= nrow dim)) 116 | (setf nrow dim)))) 117 | (ncol 0) 118 | (start-cols-and-dims (mapcar 119 | (lambda (object) 120 | (let* ((dims (dims object)) 121 | (increment (ematch dims 122 | (nil 1) 123 | ((list d0) (check-nrow d0) 124 | 1) 125 | ((list d0 d1) (check-nrow d0) 126 | d1)))) 127 | (prog1 (cons ncol dims) 128 | (incf ncol increment)))) 129 | objects)) 130 | (nrow (aif nrow it 1))) 131 | (aprog1 (make-array (list nrow ncol) :element-type element-type) 132 | (mapc (lambda+ ((start-col &rest dims) object) 133 | (if dims 134 | (stack-cols-copy object it element-type start-col) 135 | (loop for row below nrow 136 | with object = (coerce object element-type) 137 | do (setf (aref it row start-col) object)))) 138 | start-cols-and-dims objects)))) 139 | 140 | (defun stack-cols (&rest objects) 141 | "Like STACK-COLS*, with ELEMENT-TYPE T." 142 | (apply #'stack-cols* t objects)) 143 | 144 | (defun stack*0 (element-type arrays) 145 | "Stack arrays along the 0 axis, returning an array with given ELEMENT-TYPE." 146 | (let+ ((array-first (car arrays)) 147 | (dim-rest (cdr (array-dimensions array-first))) 148 | (sum-first 149 | (reduce #'+ arrays 150 | :key (lambda (array) 151 | (let+ ((dimensions (array-dimensions array))) 152 | (unless (eq array array-first) 153 | (assert (equal dim-rest (cdr dimensions)) () 154 | "Array ~A has incomplatible dimensions" 155 | array)) 156 | (first dimensions)))))) 157 | (aprog1 (make-array (cons sum-first dim-rest) :element-type element-type) 158 | (loop with cumulative-sum = 0 159 | for array in arrays 160 | do (let* ((dim-first (array-dimension array 0)) 161 | (end (+ cumulative-sum dim-first))) 162 | (setf (partition it cumulative-sum end) array 163 | cumulative-sum end)))))) 164 | 165 | (defun stack* (element-type axis array &rest arrays) 166 | "Stack array arguments along AXIS. ELEMENT-TYPE determines the element-type 167 | of the result." 168 | (if arrays 169 | (let ((all-arrays (cons array arrays))) 170 | (if (= axis 0) 171 | (stack*0 element-type all-arrays) 172 | (let ((permutation (complete-permutation axis (array-rank array)))) 173 | ;; serious contender for the Least Efficient Implementation Award 174 | (permute (invert-permutation permutation) 175 | (stack*0 element-type 176 | (mapcar (curry #'permute permutation) 177 | all-arrays)))))) 178 | array)) 179 | 180 | (defun stack (axis array &rest arrays) 181 | "Like STACK*, with element-type T." 182 | (apply #'stack* t axis array arrays)) 183 | --------------------------------------------------------------------------------