NetNews Usenet Archive 1992 #20/NN_1992_20.iso/spool/comp/lang/lisp/2444

Text File | 1992-09-15 | 12.6 KB | 383 lines

Newsgroups: comp.lang.lisp
Path: sparky!uunet!statsci!almond
From: [e-mail] (Russell G. Almond)
Subject: Re: copy-array?
In-Reply-To: [e-mail]'s message of 14 Sep 92 23:01:51 GMT
Message-ID: <[e-mail]>
Sender: [e-mail] (Usenet News Account)
Organization: Statistical Sciences, Inc., Seattle, WA USA
References: <[e-mail]> <[e-mail]>
Date: Wed, 16 Sep 1992 03:02:05 GMT
Lines: 370

In article <[e-mail]> [e-mail] (Barry Margolin) writes:

   In article <[e-mail]> [e-mail] (Bryan S. So) writes:
   >This is almost the first time I seriously use arrays
   >in Common Lisp.  Now, how come there is no intrinsic
   >function to make a copy of an array?

   There was a proposal in X3J13 to extend some of the sequence functions to
   work on multidimensional arrays, but it was voted down.  That would have
   enabled COPY-SEQ to do what you want.

   It's kind of a shame that a multidimensional array can't be used as the
   :INITIAL-CONTENTS argument for MAKE-ARRAY, even when it matches the
   dimensionality of the array being built.  Then you could do:

   (make-array ... :initial-contents old-array)

   >The only algorithm I have is to make a new array then
   >assign the elements one by one.  Is there an easier/
   >more efficient method to do this?

   You can do it using displaced arrays and MAP-INTO:

   [ ... ]

The problem is a little bit more general than you think.  There are
actually many cases in which you would like to think of an array as a
vector and perform operations on all elements.  S (and S-PLUS) which
are primarily statistics languages do this, and I've found myself
wanting it so much in LISP that I created a specialized structure to
do it, I call a d-array.  It basically supports an array and a vector
displaced to the same location in storage. If you modify the one, it
modified the other.  I haven't had efficiency problems because its
displaced.

Code follows .sig.


            Russell Almond
Statistical Sciences, Inc.        U. Washington
1700 Westlake Ave., N Suite 500        Statistics, GN-22
Seattle, WA  98109            Seattle, WA  98195
[phone]
[e-mail]            [e-mail]




;;; -*- mode: fi:common-lisp; package: rga-utils -*-

;;; Copyright 1992 Russell G. Almond

;;; This code is in the Public Domain.  Anyone who can get some use
;;; from it is welcome.
;;; This code come with no warentee.

(in-package :rga)

;;;; d-arrays.lisp

;;; This code contains a series of utilities for manipulating arrays.
;;; In particular it sets up a structure called a d-array which is an
;;; array with a vector displaced to its contents.  These are much
;;; easier for certain operations.



;;; First some functions mandated by X3J13 which have not made it into
;;; all versions of Common Lisp



#+:cmu(defun map-into (result funct &rest sequences)
  "When this definition generates an error comment it out!"
  (declare (type Sequence result)
       (type Function funct))
  (let ((out-length (if (and (vectorp result)
                 (array-has-fill-pointer-p result))
            (array-total-size result)
              (length result))))
    (if (eql 0 out-length) (return 'map-into result))
    (let* ((in-length (apply #'min out-length
                (mapcar #'length sequences)))
       (dummy-variables (mapcar #'(lambda (x) (gensym)) sequences))
       (loop-as-clauses
        (mapcan #'(lambda (x x-seq)
            (list 'as x (if (listp x-seq) 'in
                      'across)
                  x-seq))
            dummy-variables sequences)))
      (eval `(loop
        for which-el from 0 to ,in-length
        ,@loop-as-clauses
         do (setf (elt ,result which-el)
              (funcall ,funct ,@dummy-variables))
            ))
      (if (array-has-fill-pointer-p result)
      (setf (fill-pointer result) in-length))
      result)))
;;; It is unclear what should happen when map-into is called with
;;; result and adjustable array whose total-length is less than the
;;; min length of the other sequences.  We will assume that if this is
;;; the case, iteration terminates when we reach the last function in
;;; the sequence.




#+:excl(excl:without-package-locks
(defun row-major-aref (array index)
  (declare (type Array array) (type Fixnum index))
  "Comment this code out if your implementation supports it!"
  (aref (make-array (array-total-size array)
            :displaced-to array
            :element-type (array-element-type array))
    index))

(defun (setf row-major-aref) (array index value)
  (declare (type Array array) (type Fixnum index) (type T value))
  "Comment this code out if your implementation supports it!"
  (setf (aref (make-array (array-total-size array)
            :displaced-to array
            :element-type (array-element-type array))
    index)
    value))
)

;;;----------------------------------------------------------------------
;;; Common-lisp syntax extension.

;;; These functions deal with setting elements of an array using a
;;; list of the indexies rather than an including the index of the
;;; lists directly.
(declaim (inline elt-array set-elt-array))
(defun elt-array (array indexlist)
  (declare (type Array array) (type List indexlist)
       (:returns (type T)))
  "Access element marked by <indexlist> in <array>.  Allows
<indexlist> to be treated as a single entity."
  (apply #'aref array indexlist))

(defun set-elt-array (array indexlist value)
  (declare (type Array array) (type List indexlist)
       (type T value)
       (:returns (type T value)))
  "Access element marked by <indexlist> in <array>.  Allows
<indexlist> to be treated as a single entity."
  (setf (apply #'aref array indexlist) value))


(defsetf elt-array set-elt-array
    "Access element marked by <indexlist> in <array>.  Allows
<indexlist> to be treated as a single entity."
    )
;(declaim (inline (setf elt-array)))


;
;;;----------------------------------------------------------------------
;;; Floating Point defaults.
;;;----------------------------------------------------------------------

(defvar user::*rga-precision* `Double-Float
  "Default precsions for operations.  Should usually be Long-Float or
Double-Float.  Could be set in you init file.")


(deftype Default-Precision ()
  "Default Floating Point Type."
  user::*rga-precision*)

(deftype Default-Array (&rest dims)
  "Default Floating Point Type Array."
  (list* 'array user::*rga-precision* dims))

(deftype Default-Vector (&rest dims)
  "Default Floating Point Type Vector."
  (list* 'array user::*rga-precision* dims))


(defconstant *0* (coerce 0.0 *rga-precision*))
(defconstant *1* (coerce 1.0 *rga-precision*))
(defconstant *-1* (coerce -1.0 *rga-precision*))

;;; Type casting functions to switch between arrays and vectors.

(defun as-vector (arr &optional (type (array-element-type arr)))
  (declare (type Array arr)
       (:returns (type vector vec)))
  "Unwraps array <arr> into a vector <vec> of the same element type."
  (make-array (array-total-size arr) :displaced-to arr
          :element-type type))

(defun as-array (dims vec &optional (type (array-element-type vec)))
  (declare (type Vector vec) (type List dims)
       (:returns (type Array arr)))
  "Wraps vector <vec> into an array <arr> of the same element type
with dimensions <dims>."
  (make-array dims :displaced-to vec :element-type type))


(defun copy-array (arr)
  "Copies array <arr> yielding a fresh array with same contents as <arr>."
  (declare (type Array arr)
       (:returns (type Array)))
  (as-array (array-dimensions arr)
        (copy-seq (as-vector arr))
        (array-element-type arr)))



;;; linear-comb -- forms the linear combination of serval arrays given
;;; a series of co-efficients.  As this thing use mapcar to do its
;;; basic operation, if the lists are of unequal length the shorter
;;; one is used.
(defun linear-comb (array-list weight-list
            &key (result
              (make-array (array-dimensions (car array-list))
                      :element-type
                      (array-element-type (car array-list))
                      )))
  (declare (type List array-list) (type List weight-list)
       (type Default-Array result)
       (:returns (type Array weighted-sum)))
  "Produces a linear cominbation of arrays in <array-list> using
numbers in <weight-list> to do its work."
  (let ((vec-list (mapcar #'as-vector array-list))
    (res-vec (as-vector result)))
    (map-into res-vec #'(lambda (&rest args)
              (weight-sum weight-list args))
          vec-list)
    result))

;; weight-sum -- takes a list of weights and then the rest of the
;; arguments are assumed to be things to be summed with the weights
(defun weight-sum (weight-list obj-list)
  (declare (type List weight-list obj-list)
       (:returns (type Number linear-comb)))
  "Produces a weighted sum of <obj-list> using weights in
<weight-list>."
  (reduce #'+ (mapcar #'* weight-list obj-list)))






;
;;;----------------------------------------------------------------------
;;; d-arrays
;;;----------------------------------------------------------------------

;;; D-arrays have both vector and array specifications.


(defstruct (d-array (:conc-name d-)
                (:constructor %make-d-array (arr vec))
                (:copier nil)
                (:predicate d-array?)
                (:print-function
                 (lambda (d-array s k)
               (if *print-readably*
               (format s "(as-d-array ~S)"
                   (d-arr d-array))
             (format s "#<D-array ~S>"
                 (d-arr d-array))))))
  "Provides a convenient-method for refering to an array as either an
array or a vector.  Accessors are #'d-arr and #'d-vec."
  (arr #() :type array :read-only t)
  (vec #() :type vector :read-only t))


#-cmu(defmethod make-load-form ((self D-Array))
       (make-load-form-saving-slots self))

;;; Construction Functions

(defun make-d-array (dims &key (element-type *rga-precision*)
                   (initial-element *0*)
                   (initial-contents nil)
                   (adjustable nil)
                   (displaced-to nil)
                   (displaced-index-offset 0))
  "Creates a D-array using a synatic similar to make-array.  First
array is made using make-array.  Next a vector is made displaced to
that array.  The two are stored in a d-array structure which is
returned. "
  (declare (type List dims)
       (type T element-type)
       (type T initial-element)
       (type Sequence initial-contents)
       (type T adjustable)
       (type (or Null Array) displaced-to)
       (type Integer displaced-index-offset)
       (:returns (type D-array)))
  (let* ((arr (apply #'make-array dims :element-type element-type
             :adjustable adjustable :fill-pointer nil
             (cond (displaced-to
                (list :displaced-to displaced-to
                  :displaced-index-offset
                  displaced-index-offset))
               (initial-contents
                (list :initial-contents initial-contents))
               (t (list :initial-element initial-element)))))
     (vec (make-array (array-total-size arr) :element-type element-type
              :displaced-to arr)))
    (%make-d-array arr vec)))


(defun force-d-array (array)
  "Turns an array into a d-array."
  (declare (type Array array)
       (:returns (type D-Array)))
  (%make-d-array array (make-array (array-total-size array)
                 :element-type (array-element-type array)
                 :displaced-to array)))

(defun coerce-d-array (dims vector)
  "Turns a vector into a d-array with dimensions <dims>."
  (declare (type List dims)
       (type Array array)
       (:returns (type D-Array)))
  (%make-d-array (make-array dims
                 :element-type (array-element-type vector)
                 :displaced-to vector)
         vector))


(defun copy-d-array (old-array &key result)
  "Copies <old-array> into a new location.  If <result> is given it
must be a d-array of the same total-size as <old-array> and of the
same element type."
  (if result
      (if (and (eql (array-element-type (d-arr old-array))
            (array-element-type (d-arr result)))
           (eql (array-total-size (d-arr old-array))
            (array-total-size (d-arr result))))
      (map-into (d-vec result) #'identity (d-vec old-array))
    (error "~S and ~S do not match on size or element-type.~%"
           old-array result))
    (setq result
      (coerce-d-array (array-dimensions (d-arr old-array))
              (copy-seq (d-vec old-array)))))
  result)



(defun d-linear-comb (d-array-list weight-list
              &key (result
                (make-d-array (array-dimensions
                       (d-arr (car d-array-list)))
                      :element-type
                      (array-element-type
                       (d-arr (car d-array-list)))
                      )))
  (declare (type List d-array-list) (type List weight-list)
       (type D-Array result)
       (:returns (type Array weighted-sum)))
  "Produces a linear cominbation of arrays in <array-list> using
numbers in <weight-list> to do its work."
  (let ((vec-list (mapcar #'d-vec d-array-list))
    (res-vec (d-vec result)))
    (apply #'map-into res-vec #'(lambda (&rest args)
                  (weight-sum weight-list args))
       vec-list)
    result))