home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / marray.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  6.2 KB  |  188 lines
  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  9. ;;;     (c) Copyright 1981 Massachusetts Institute of Technology         ;;;
  10. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11.  
  12. (in-package "MAXIMA")
  13. (macsyma-module array)
  14.  
  15. ;;; Macsyma User array utilities originally due to CFFK.
  16.  
  17. ;;; Note that on the lisp level we regard as an array either
  18. ;;;   (1) a symbol whose ARRAY property is a common lisp array
  19. ;;;       [i.e., (symbol-array 'symbol)
  20. ;;;               == (get 'symbol 'array) => some array] or
  21. ;;;   (2) a common lisp array.
  22. ;;; On the maxima level a declared array not of type HASH or FUNCTIONAL 
  23. ;;; is either
  24. ;;;   (1m) a symbol whose ARRAY mproperty is of type (1)
  25. ;;;        [i.e., (symbol-array (mget 'symbol 'array)) => some array] or
  26. ;;;   (2m) it is of type (2) (and then called a `fast' array).
  27. ;;; Such an array is of type (1m) iff it was created with ARRAY 
  28. ;;; with USE_FAST_ARRAYS being set to FALSE.
  29. ;;;
  30. ;;; Curiously enough, ARRAY(...,TYPE,...) (which currently can only be
  31. ;;; used for USE_FAST_ARRAYS:FALSE) results in an array which is
  32. ;;; simultaneously of type (1) and (1m).
  33.  
  34. (defun $listarray (ary)
  35.        (Cons '(mlist)
  36.          (cond ((mget ary 'hashar)
  37.             (mapcar #'(lambda (subs) ($arrayapply ary subs))
  38.                 (cdddr (meval (list '($arrayinfo) ary)))))
  39.            ((mget ary 'array) (listarray (mget ary 'array)))
  40.            #+cl
  41.            ((arrayp ary) (coerce ary 'list))
  42.            #+cl
  43.              ( 
  44.             (hash-table-p ary)
  45.             (let (vals (tab ary))
  46.               (declare (special vals tab))
  47.                (maphash #'(lambda (x &rest l)l (push (gethash x tab) vals)) ary )
  48.                vals))
  49.            (t 
  50.             (merror "Argument to LISTARRAY must be an array:~%~M" ary)))))
  51.  
  52. (defmfun $fillarray (ary1 ary2)
  53.       (let ((ary
  54.           (or
  55.            (mget ary1 'array)
  56.            #+cl
  57.            (and (arrayp ary1) ary1)
  58.            (merror "First argument to FILLARRAY must be a declared array:~%~M" ary1))))
  59.         (fillarray
  60.          ary
  61.          (cond (($listp ary2) (cdr ary2))
  62.            ((get (mget ary2 'array) 'array))
  63.            #+cl
  64.            ((arrayp ary2) ary2)
  65.            (t
  66.             (merror
  67.              "Second argument to FILLARRAY must be an array or list:~%~M" ary2))))
  68.         ary1))
  69. ;#+cl
  70. ;(defmacro $rearray (ar &rest dims)
  71. ;  `(cond ($use_fast_arrays (setq ,ar (rearray-aux ',ar ,(safe-value ar) ,@ dims)))
  72. ;     (t (rearray-aux ',ar (safe-value ,ar) ,@ dims))))
  73.  
  74. (defun getvalue (sym)
  75.   (and (symbolp sym) (boundp sym) (symbol-value sym)))
  76. (defmspec $rearray (l) (setq l (cdr l))
  77.   (let ((ar (car l)) (dims (cdr l)))
  78.     (cond ($use_fast_arrays (set ar (rearray-aux ar (getvalue ar) dims )))
  79.       (t (rearray-aux ar (getvalue ar) dims)))))
  80.  
  81. #+cl
  82. (defun rearray-aux (ar val dims &aux marray-sym)
  83.   (cond ((arrayp val)
  84.      (apply 'lispm-rearray val dims))
  85.     ((arrayp (symbol-array ar))
  86.      (setf (symbol-array ar)
  87.            (apply 'lispm-rearray (symbol-array ar ) dims)))
  88.     ((setq marray-sym (mget ar 'array))
  89.      (apply 'rearray-aux  marray-sym nil dims ) ar)
  90.     (t (error "unknown array ~A " ar))))
  91.  
  92. #-cl
  93. (defmspec $rearray (l) (setq l (cdr l))
  94.       (cond ((> (length l) 6)
  95.          (merror "Too many arguments to REARRAY:~%~M" l))
  96.         ((< (length l) 2)
  97.          (merror "Too few arguments to REARRAY:~%~M" l)))
  98.       (let ((name (car l))
  99.         (ary (cond ($use_fast_arrays
  100.                (symbol-value (car l)))
  101.              (t
  102.                (cond ((mget (car l) 'array))
  103.                  (t 
  104.                   (merror "First argument to REARRAY must be a declared array:~%~M"
  105.                       (car l))))))))
  106.         (setq l (cdr l)
  107.           l (mapcar #'(lambda (x)
  108.                 (setq x (meval x))
  109.                 (cond ((not (eq (ml-typep x) 'fixnum))
  110.                        (merror
  111.                      "Non-integer dimension to REARRAY:~%~M"
  112.                      x)))
  113.                 #-cl
  114.                 (f1+ x)
  115.                 #+cl x
  116.                 )
  117.                 l))
  118.         (show l)
  119.         #-lispm
  120.         (let ((new-array 
  121.             (apply '*rearray (cons ary 
  122.                        (cons (car (arraydims ary)) l)))))
  123.           #+Franz(mputprop name new-array 'array)
  124.           )
  125.         #+lispm
  126.         (progn
  127.           (cond ($use_fast_arrays
  128.              (setq ary (apply 'lispm-rearray (cons ary l))))
  129.             (t (setf (symbol-function ary) (apply 'lispm-rearray (cons (symbol-function ary) l)))))
  130.           (cond ($use_fast_arrays (setq name ary))
  131.             (t (mputprop name ary 'array))))
  132.         name))
  133.  
  134.  
  135. ;(defmspec $rearray (l) (setq l (cdr l))
  136. ;      (cond ((> (length l) 6)
  137. ;         (merror "Too many arguments to REARRAY:~%~M" l))
  138. ;        ((< (length l) 2)
  139. ;         (merror "Too few arguments to REARRAY:~%~M" l)))
  140. ;      (let ((name (car l))
  141. ;        (ary (cond ($use_fast_arrays
  142. ;               (symbol-value (car l)))
  143. ;             (t
  144. ;               (cond ((mget (car l) 'array))
  145. ;                 (t 
  146. ;                  (merror "First argument to REARRAY must be a declared array:~%~M"
  147. ;                      (car l))))))))
  148. ;        (setq l (cdr l)
  149. ;          l (mapcar #'(lambda (x)
  150. ;                (setq x (meval x))
  151. ;                (cond ((not (eq (ml-typep x) 'fixnum))
  152. ;                       (merror
  153. ;                     "Non-integer dimension to REARRAY:~%~M"
  154. ;                     x)))
  155. ;                #-lispm
  156. ;                (f1+ x)
  157. ;                #+Lispm x
  158. ;                )
  159. ;                l))
  160. ;        (show l)
  161. ;        #-lispm
  162. ;        (let ((new-array 
  163. ;            (apply '*rearray (cons ary 
  164. ;                       (cons (car (arraydims ary)) l)))))
  165. ;          #+Franz(mputprop name new-array 'array)
  166. ;          )
  167. ;        #+lispm
  168. ;        (progn
  169. ;          (cond ($use_fast_arrays
  170. ;             (setq ary (apply 'lispm-rearray (cons ary l))))
  171. ;            (t (setf (symbol-function ary) (apply 'lispm-rearray (cons (symbol-function ary) l)))))
  172. ;          (cond ($use_fast_arrays (setq name ary))
  173. ;            (t (mputprop name ary 'array))))
  174. ;        name))
  175.  
  176. #+cl
  177. ;(defun lispm-rearray (ar &rest dims)
  178. ; ( make-array (mapcar '1+ (copy-list dims)) :element-type (array-element-type ar) :displaced-to ar ))
  179.  
  180.  
  181. (defun lispm-rearray (ar &rest dims)
  182.   (cond ((eql (array-rank ar) (length dims))
  183.      (adjust-array ar (mapcar '1+ (copy-list dims)) :element-type (array-element-type ar)  ))
  184.     (t (merror "Rearray only works for arrays with same rank ie number of subscripts"))))
  185.  
  186.  
  187.  
  188.