From: almond@statsci.com (Russell G. Almond)
Subject: Re: copy-array?
Organization: Statistical Sciences, Inc., Seattle, WA USA
Date: Wed, 16 Sep 1992 03:02:05 GMT

In article <1935kvINNi3f@early-bird.think.com> barmar@think.com (Barry Margolin) writes:

   In article <9209142212.AA24213@brownie.cs.wisc.edu> so@CS.WISC.EDU (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
(206) 283-8802				
almond@statsci.com			almond@stat.washington.edu




;;; -*- 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))




Newsgroups: comp.lang.lisp