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