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 14(macsyma-module array) 15 16;;; Macsyma User array utilities originally due to CFFK. 17 18;;; Note that on the lisp level we regard as an array either 19;;; (1) a symbol whose ARRAY property is a common lisp array 20;;; [i.e., (symbol-array 'symbol) 21;;; == (get 'symbol 'array) => some array] or 22;;; (2) a common lisp array. 23;;; On the maxima level a declared array not of type HASH or FUNCTIONAL 24;;; is either 25;;; (1m) a symbol whose ARRAY mproperty is of type (1) 26;;; [i.e., (symbol-array (mget 'symbol 'array)) => some array] or 27;;; (2m) it is of type (2) (and then called a `fast' array). 28;;; Such an array is of type (1m) iff it was created with ARRAY 29;;; with USE_FAST_ARRAYS being set to FALSE. 30;;; 31;;; Curiously enough, ARRAY(...,TYPE,...) (which currently can only be 32;;; used for USE_FAST_ARRAYS:FALSE) results in an array which is 33;;; simultaneously of type (1) and (1m). 34 35(defmfun $listarray (ary) 36 (cons '(mlist) 37 (cond ((mget ary 'hashar) 38 (mapcar #'(lambda (subs) ($arrayapply ary subs)) 39 (cdddr (meval (list '($arrayinfo) ary))))) 40 ((mget ary 'array) (listarray (mget ary 'array))) 41 ((arrayp ary) 42 (if (eql (array-rank ary) 1) 43 (coerce ary 'list) 44 (coerce (make-array (apply '* (array-dimensions ary)) 45 :displaced-to ary 46 :element-type (array-element-type ary)) 47 'list))) 48 ((hash-table-p ary) 49 (let (vals (tab ary)) 50 (maphash #'(lambda (x &rest l) l 51 (unless (eq x 'dim1) (push (gethash x tab) vals))) 52 ary) 53 (reverse vals))) 54 ((eq (marray-type ary) '$functional) 55 (cdr ($listarray (mgenarray-content ary)))) 56 (t 57 (merror (intl:gettext "listarray: argument must be an array; found: ~M") 58 ary))))) 59 60(defmfun $fillarray (ary1 ary2) 61 (let ((ary 62 (or (mget ary1 'array) 63 (and (arrayp ary1) ary1) 64 (merror (intl:gettext "fillarray: first argument must be a declared array; found: ~M") ary1)))) 65 (fillarray ary 66 (cond (($listp ary2) (cdr ary2)) 67 ((get (mget ary2 'array) 'array)) 68 ((arrayp ary2) ary2) 69 (t 70 (merror (intl:gettext "fillarray: second argument must be an array or list; found: ~M") ary2)))) 71 ary1)) 72 73(defun getvalue (sym) 74 (and (symbolp sym) (boundp sym) (symbol-value sym))) 75 76(defmspec $rearray (l) 77 (setq l (cdr l)) 78 (let ((ar (car l)) 79 (dims (mapcar #'meval (cdr l)))) 80 (cond ($use_fast_arrays 81 (setf (symbol-value ar) (rearray-aux ar (getvalue ar) dims))) 82 (t 83 (rearray-aux ar (getvalue ar) dims))))) 84 85(defun rearray-aux (ar val dims &aux marray-sym) 86 (cond ((arrayp val) 87 (apply 'lispm-rearray val dims)) 88 ((arrayp (get ar 'array)) 89 (setf (get ar 'array) (apply 'lispm-rearray (get ar 'array) dims))) 90 ((setq marray-sym (mget ar 'array)) 91 (rearray-aux marray-sym nil dims) 92 ar) 93 (t (merror (intl:gettext "rearray: argument is not an array: ~A") ar)))) 94 95(defun lispm-rearray (ar &rest dims) 96 (cond ((eql (array-rank ar) (length dims)) 97 (adjust-array ar (mapcar #'1+ (copy-list dims)) :element-type (array-element-type ar) )) 98 (t (merror (intl:gettext "rearray: arrays must have the same number of subscripts."))))) 99