summaryrefslogtreecommitdiff
path: root/Sacla/array.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'Sacla/array.lisp')
-rw-r--r--Sacla/array.lisp137
1 files changed, 137 insertions, 0 deletions
diff --git a/Sacla/array.lisp b/Sacla/array.lisp
new file mode 100644
index 0000000..4fd0147
--- /dev/null
+++ b/Sacla/array.lisp
@@ -0,0 +1,137 @@
+;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp>
+;; ALL RIGHTS RESERVED.
+;;
+;; $Id: array.lisp,v 1.4 2004/02/20 07:12:10 yuji Exp $
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; * Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;; * Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in
+;; the documentation and/or other materials provided with the
+;; distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+(defun aref (array &rest subscripts)
+ "Access an element of ARRAY specified by SUBSCRIPTS."
+ (row-major-aref array (apply #'array-row-major-index array subscripts)))
+
+(defsetf aref (array &rest subscripts) (value)
+ "Set VALUE onto the element of ARRAY specified by SUBSCRIPTS."
+ `(setf (row-major-aref ,array (array-row-major-index ,array ,@subscripts))
+ ,value))
+
+(defun array-dimension (array axis-number)
+ "Return AXIS-NUMBER dimension of ARRAY."
+ (nth axis-number (array-dimensions array)))
+
+(defun array-in-bounds-p (array &rest subscripts)
+ "Return true if SUBSCRIPTS are all in bounds for ARRAY, otherwise false."
+ (and (not (some #'minusp subscripts))
+ (every #'< subscripts (array-dimensions array))))
+
+(defun array-rank (array)
+ "Return the number of dimensions of ARRAY."
+ (length (array-dimensions array)))
+
+(defun array-row-major-index (array &rest subscripts)
+ "Compute the row-major index of the element of ARRAY specified by SUBSCRIPTS."
+ (assert (apply #'array-in-bounds-p array subscripts))
+ (apply #'+ (maplist #'(lambda (x y)
+ (* (car x) (apply #'* (cdr y))))
+ subscripts
+ (array-dimensions array))))
+
+(defun array-total-size (array)
+ "Return the total number of elements in ARRAY."
+ (apply #'* (array-dimensions array)))
+
+
+(defun vector (&rest objects)
+ "Create a fresh simple general vector whose elements are OBJECTS."
+ (make-array (length objects)
+ :element-type t
+ :initial-contents objects))
+
+(defun vector-pop (vector)
+ "Decrease the fill pointer of VECTOR by one and return the top element."
+ (check-type vector vector)
+ (assert (and (array-has-fill-pointer-p vector)
+ (plusp (fill-pointer vector))))
+ (aref vector (setf (fill-pointer vector) (1- (fill-pointer vector)))))
+
+(defun vector-push (new-element vector)
+ "Try to store NEW-ELEMENT in VECTOR's element designated by the fill pointer."
+ (let ((fill-pointer (fill-pointer vector)))
+ (when (< fill-pointer (array-dimension vector 0))
+ (setf (aref vector fill-pointer) new-element)
+ (setf (fill-pointer vector) (1+ fill-pointer))
+ fill-pointer)))
+
+(defun vector-push-extend (new-element vector &optional
+ (extension (1+ (length vector))))
+ "Do the same thing as vector-push but extend VECTOR when space is lacking."
+ (when (>= (fill-pointer vector) (array-dimension vector 0))
+ (assert (adjustable-array-p vector))
+ (adjust-array vector (+ (fill-pointer vector) extension)))
+ (vector-push new-element vector))
+
+(defun vectorp (object)
+ "Return true if OBJECT is of type vector; otherwise, return false."
+ (and (arrayp object)
+ (eql (array-rank object) 1)))
+
+
+(defun bit-andc1 (bit-array1 bit-array2 &optional opt-arg)
+ "And complement of BIT-ARRAY1 with BIT-ARRAY2."
+ (bit-and (bit-not bit-array1 opt-arg) bit-array2 opt-arg))
+
+(defun bit-andc2 (bit-array1 bit-array2 &optional opt-arg)
+ "And BIT-ARRAY1 with complement of BIT-ARRAY2."
+ (bit-and bit-array1 (bit-not bit-array2) opt-arg))
+
+(defun bit-eqv (bit-array1 bit-array2 &optional opt-arg)
+ "Exclusive nor (equivalence) between BIT-ARRAY1 and BIT-ARRAY2."
+ (bit-not (bit-xor bit-array1 bit-array2 opt-arg) opt-arg))
+
+(defun bit-nand (bit-array1 bit-array2 &optional opt-arg)
+ "Complement of BIT-ARRAY1 and BIT-ARRAY2."
+ (bit-not (bit-and bit-array1 bit-array2 opt-arg) opt-arg))
+
+(defun bit-nor (bit-array1 bit-array2 &optional opt-arg)
+ "Complement of BIT-ARRAY1 or BIT-ARRAY2."
+ (bit-not (bit-ior bit-array1 bit-array2 opt-arg) opt-arg))
+
+(defun bit-orc1 (bit-array1 bit-array2 &optional opt-arg)
+ "Or complement of BIT-ARRAY1 with BIT-ARRAY2."
+ (bit-ior (bit-not bit-array1 opt-arg) bit-array2 opt-arg))
+
+(defun bit-orc2 (bit-array1 bit-array2 &optional opt-arg)
+ "Or BIT-ARRAY1 with complement of BIT-ARRAY2."
+ (bit-ior bit-array1 (bit-not bit-array2) opt-arg))
+
+
+(defun bit-vector-p (object)
+ "Return true if OBJECT is of type bit-vector; otherwise, return false."
+ (and (vectorp object)
+ (eq (array-element-type object) 'bit)))
+
+(defun simple-bit-vector-p (object)
+ "Return true if OBJECT is of type simple-bit-vector; otherwise, return false."
+ (and (bit-vector-p object)
+ (typep object 'simple-array)))