src/marray.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancements.                   ;;;;;
   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.")))))