SiteMap Search ElispArea HowTo Glossary RecentChanges News Problems Suggestions

cl-array.el

Download

;;; :NOTE cl-array.el is as of 2010-11-30 available at web.archive.org
;;; :SEE (URL `http://web.archive.org/web/20010617092325/http://mit.edu/cadet/www/cl-array.el')
;;; ==============================

;;; cl-array.el	-- Common Lisp style implementation of multi-dimensional arrays --
;;  Thursday Jun 2 1999

;; Copyright (C) 1999 Free Software Foundation, Inc.

;; Author: David Bakhash <cadet@alum.edu>
;; Maintainer: David Bakhash <cadet@alum.edu>
;; Version: 0.4
;; Created: Wed Jun 2 08:49:22 EST 1999
;; Keywords: extensions, lisp

;; This file is not part of emacs or XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.

;; XEmacs program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF.

;;; Commentary:

;; This package is designed as an API for multi-dimensional arrays.  It
;; strives to conform to the Common Lisp specification for
;; multi-dimensional arrays.  The limitations of this package are a
;; direct result of the limitations of Emacs Lisp.

;; Some things to note.  If you're going to use this package, to port
;; real CL code to (X)Emacs, then you must replace the following function
;; calls:

;; aref          ==>     aref*
;; arrayp        ==>     arrayp*

;; This last one is the most crucial since, if you don't, the code
;; will not err when it should, since I'm using elisp `vectors' to
;; store the array structures.  This being done, the code should work
;; (with respect to arrays), provided that they're not using
;; fill-pointers, displacement, etc.

;;  Here are some examples of how it's used...

;; (setq 3D-array (make-array '(5 8 10) :initial-element 0))
;; (arrayp* 3D-array)
;; ==> t
;; (vectorp* 3D-array)
;; ==> nil
;; (array-in-bounds-p 3D-array 1 1 1)
;; ==> t
;; (array-in-bounds-p 3D-array 20 20 20)
;; ==> nil
;; (aref* 3D-array 2 4 6)
;; ==> 0
;; (aref* 3D-array 2 4 6)
;; ==> 10
;; (setf (aref* 3D-array 10 20 30) 5)
;; ==> ERROR
;; (setf (aref* 3D-array 2 4 6) 5)
;; ==> 5
;; (loop for i below (array-total-size 3D-array)
;;   do
;;   (setf (row-major-aref 3D-array i) (* i i)))
;; (row-major-aref 3D-array 12)
;; ==> 144
;; (array-rank 3D-array)
;; ==> 3
;; (array-dimension 3D-array 2)
;; ==> 8
;; (array-total-size 3D-array)
;; ==> 400

(require 'cl)

;;(defvar cl-array-do-bounds-checking-p t
;;  "*Non-nil causes bounds checking to occur for cl-arrays.
;;Default is t.")

(defstruct
  (cl-array
   (:type list) :named
   (:copier nil))		; disable copier (use copy-sequence instead???)
  (dimensions :read-only t)
  elements)

;; I was thinking of adding advice (defadvice) to the function
;; `arrayp'.  But on second thought, I figured that since I just stick
;; with the cl.el convention of appending a `*' to functions whose
;; names already exist in elisp, but which should be upgraded for CL,
;; I will, in this package, not use defadvice.

;;(defun length* (object)
;;  (cond ((cl-array-p object)
;;	 (if (= (array-rank object) 1)
;;	     (if (array-has-fill-pointer-p object)
;;		 (fill-pointer object)
;;	       (length (cl-array-elements object)))
;;	   (error "Function `length' does not work for multi-dimensional arrays")))
;;	(t				; else
;;	 (length object))))

;; I think I really have to think about this one...

;; (defalias 'arrayp* 'arrayp)

(defun arrayp* (object)
  "Returns t iff OBJECT is any type of array, either CL-style, or elisp-style."
  (or (cl-array-p object)
      (arrayp object)))

(defun* make-array (dimensions &key
			       (initial-element nil ie-p)
			       (initial-contents nil ic-p)
;;			       (element-type t et-p)
;;			       (fill-pointer nil fp-p)
			       &allow-other-keys)
  "Return a newly created multi-dimensional array with dimesions DIMENSIONS.
Optional keys that can be specified are:

:initial-element   INITIAL-ELEMENT sets each element of the array to
                   INITIAL-ELEMENT

:initial-contents  INITIAL-CONTENTS also sets the initial contents of
                   the array.  This should be a sequence of nested
                   sequences which describes the structure of the array.

Example: \(setq my-matrix \(make-array '\(2 4\)
                                     :initial-contents '\(\(1 2 3 4\)
                                                         \(5 6 7 8\)\)\)\)

Example: \(setq 3D-array \(make-array '\(5 8 10\) :initial-element 0\)\)
will make a rank-3 array with all elements initialized to 0.
Note: INITIAL-CONTENTS and INITIAL-ELEMENT cannot both be specified."
  (when (atom dimensions)
    (setq dimensions (list dimensions)))
  (let ((cl-array (cond ((rest dimensions)
			 ;; rank > 1
			 (make-cl-array
			  :dimensions dimensions
			  :elements (make-vector (apply '* dimensions)
			  initial-element)))
			(t ; rank <= 1
			 (make-vector (first dimensions) initial-element)))))
    (cond ((and ie-p ic-p)
	   (error "Function `make-array': cannot specifiy both :initial-element and :initial-contents"))
	  (ic-p
	   ;; initial-contents is composed of a nested structure of
	   ;; sequences.  The numbers of levels in the structure must
	   ;; equal the rank of array.  Each leaf of the nested
	   ;; structure must be of the type given by element-type.  If
	   ;; array is zero-dimensional, then initial-contents
	   ;; specifies the single element.  Otherwise,
	   ;; initial-contents must be a sequence whose length is
	   ;; equal to the first dimension; each element must be a
	   ;; nested structure for an array whose dimensions are the
	   ;; remaining dimensions, and so on.  Initial-contents
	   ;; cannot be supplied if either initial-element is supplied
	   ;; or displaced-to is non-nil.  If initial-contents is not
	   ;; supplied, the consequences of later reading an
	   ;; uninitialized element of new-array are undefined unless
	   ;; either initial-element is supplied or displaced-to is
	   ;; non-nil.
	   (let ((rank (length dimensions)))
	     (labels ((setr! (subscripts level subseqs)
			(cond ((= level rank)
			       (cl-aset cl-array subscripts subseqs))
			      (t ; else
			       (incf level)
			       ;; check dimensions...
			       (unless (= (nth (1- level) dimensions)
					  (length subseqs))
				 (error ":initial-contents sequence argument in `make-array' must have proper dimensions"))
			       (loop
				 for i below (nth (1- level) dimensions)
				 for subseq = (elt subseqs i)
				 do
				 (setr! (append subscripts (list i)) level subseq))))))
	       (setr! '() 0 initial-contents)))))
    cl-array))

(defun adjustable-array-p (cl-array)
  "Returns nil since adjustable arrays have not been implemented yet."
  nil)

(defun adjust-array (&rest args)
  "Not implemented yet, but will (eventually) look like CL's
`adjust-array'."
  (error "Function `adjust-array' not implemented yet."))

(defun array-has-fill-pointer-p (cl-array)
  "Will always return nil since fill-pointers have not been
implemented yet."
  nil)

(defun fill-pointer (cl-array)
  "Not implemented yet, but may eventually be a like CL's `fill-pointer'."
  (error "Function `fill-pointer' not implemented yet."))

(defun array-element-type (cl-array)
  "Since elisp doesn't have types, this function assumes that the
type of an array is `t'.
An alternative definition could be to return the type of the first
element of the array."
;;  (type-of (row-major-aref cl-array 0)))
  t)

(defun array-in-bounds-p (cl-array &rest subscripts)
  "Returns t iff SUBSCRIPTS are all legal subscripts for CL-ARRAY."
  (let ((dims (array-dimensions cl-array))
	(rank (array-rank cl-array)))
    (and (= rank (length subscripts))
;;	 (every #'identity (mapcar* #'< subscripts dims)))))
	 (loop
	   for s in subscripts
	   and d in dims
	   always (< s d)))))

(defun array-dimension (cl-array axis-number)
  "Returns the length of AXIS-NUMBER for CL-ARRAY."
  (nth axis-number (array-dimensions cl-array)))

(defun array-dimensions (cl-array)
  "Return the dimensions CL-ARRAY in a list."
  (cond ((cl-array-p cl-array)
	 (cl-array-dimensions cl-array))
	 ;; #### shoud I type-check this, or just assume it's an elisp array?
	(t ; (arrayp cl-array)
	 (list (length cl-array)))))

(defun aref* (cl-array &rest subscripts)
  "Return the element of CL-ARRAY at position specified by SUBSCRIPTS.
This function is settable.
Example: \(setq x \(aref* 3D-array 2 4 6\)\)
This function also accepts regular elisp arrays."
  (cond ((cl-array-p cl-array)
	 ;; #### start by doing bounds checking...
	 ;; #### If I decide to re-instantiate the bounds checking, then
	 ;; #### I'll un-comment the `when' clause below.  It's a speed hit.
;;	 (when cl-array-do-bounds-checking-p
;;	   (unless (apply 'array-in-bounds-p cl-array subscripts)
;;	     (error "aref*: out-of-bounds array reference")))
	 (let* ((linear-ref (apply #'array-row-major-index cl-array subscripts)))
	   (aref (cl-array-elements cl-array) linear-ref)))
	;; #### Should I do type checking ??? ####
	(t ; (arrayp cl-array)
	 ;; #### Note: I don't check to make sure that `subscripts' is 
	 ;; #### length = 1 !!! ####
	 (aref cl-array (first subscripts)))))

(defun cl-aset (cl-array subscripts newval)
  ;; #### start by doing bounds checking...
  ;; #### If I decide to re-instantiate the bounds checking, then
  ;; #### I'll un-comment the `when' clause below.  It's a speed hit.
  ;;	 (when cl-array-do-bounds-checking-p
  ;;	   (unless (apply 'cl-array-in-bounds-p cl-array subscripts)
  ;;	     (error "cl-aset: out-of-bounds array reference")))
  (cond ((cl-array-p cl-array)
	 (let* ((linear-ref (apply #'array-row-major-index cl-array subscripts)))
	   (aset (cl-array-elements cl-array) linear-ref newval)))
	;; #### shoud I type-check this, or just assume it's an elisp array?
	(t ; (arrayp cl-array)
	 (aset cl-array (first subscripts) newval))))

(defsetf aref* (cl-array &rest subscripts) (newval)
  `(cl-aset ,cl-array (list ,@subscripts) ,newval))

(defun simple-vector-p (cl-array)
  "Until fill-pointers are implemented, this will always return t if
CL-ARRAY is a rank one array."
  (= (array-rank cl-array) 1))

(defun svref (cl-vector i)
  "Returns the ith element of (simple) CL-VECTOR. Settable."
  (cond ((= (array-rank cl-vector) 1)
	 (aref cl-vector i))
	(t ; else
	 (error "First argument to `svref' must be a simple vector."))))

(defsetf svref (cl-vector i) (newval)
  `(cl-aset ,cl-vector (list ,i) ,newval))

(defun array-row-major-index (cl-array &rest subscripts)
  "Return the index that `row-major-aref' would take which is
equivalent to SUBSCRIPTS."
  (let ((dims (array-dimensions cl-array)))
    (loop for i in subscripts
      for j on dims
      sum (* i (apply '* (cdr j))))))

(defun row-major-aref (cl-array index)
  "Treat the CL-ARRAY as a single array, indexed by a single number.
Indexed starting at 0.
This function is settable."
  (aref (if (cl-array-p cl-array)
	    (cl-array-elements cl-array)
	  cl-array)
	index))

(defun cl-row-major-aset (cl-array index newval)
  (setf (aref (if (cl-array-p cl-array)
		  (cl-array-elements cl-array)
		cl-array)
	      index)
    newval))

(defsetf row-major-aref (cl-array index) (newval)
  `(cl-row-major-aset ,cl-array ,index ,newval))

(defun array-rank (cl-array)
  "Returns the rank, or number of dimensions \(axes\) of CL-ARRAY."
  (cond ((cl-array-p cl-array)
	 (length (cl-array-dimensions cl-array)))
	;; #### shoud I type-check this, or just assume it's an elisp array?
	(t ; (arrayp cl-array)
	 1)))

(defun array-total-size (cl-array)
  "Returns the total number of elements in CL-ARRAY.
This is the same as the product of all the dimensions."
  (cond ((cl-array-p cl-array)
	 ;; (apply '* (cl-array-dimensions cl-array)))
	 (length (cl-array-elements cl-array)))
	 ;; #### Should I do type checking ??? ####
	(t ; (arrayp cl-array)
	 (length cl-array))))

(provide 'cl-array)