1;; Flatten
2;; Barton Willis
3;; University of Nebraska at Kearney (aka UNK)
4;;    1 Nov 2002
5
6;; License: GPL
7;; The user of this code assumes all risk for its use. It has no warranty.
8;; If you don't know the meaning of "no warranty," don't use this code. :)
9
10;; Installation and usage:  Put flatten.lisp in a directory that
11;; Maxima can find.  (Maxima can find files in directories described
12;; in the list file_search_lisp.) To use flatten, begin by loading it.
13
14;; (C1) load("flatten.lisp")$
15;; (C2) flatten([x=7,[y+x=0,z+1=0], [[x-y=2]]]);
16;; (D2)         [x = 7, y + x = 0, z + 1 = 0, x - y = 2]
17;; (C3) m : matrix([a,b],[c,d])$
18;; (C4) flatten(args(m));
19;; (D4)         [a, b, c, d]
20
21;; Flatten is somewhat difficult to define -- essentially it evaluates an
22;; expression as if its main operator had been declared nary; however, there
23;; is a difference.  We have
24
25;; (C1) load("flatten.lisp");
26;; (D1)         flatten.lisp
27;; (C2) flatten(f(g(f(f(x)))));
28;; (D2)         f(g(f(f(x))))
29;; (C3) declare(f,nary);
30;; (D3)         DONE
31;; (C4) ev(d2);
32;; (D4)         f(g(f(x)))
33;; (C5)
34
35;; Unlike declaring the main operator of an expression to be nary, flatten
36;; doesn't recurse into other function arguments.
37
38;; This is supposed to be a clone of Macsyma's flatten function.
39;; Unlike the Macyma version, this version
40;;    (a) handles CRE expressions,
41;;    (b) doesn't try to flatten expressions of the form a^(b^c) -- Macsyma's
42;;        flatten gives an error about a "wrong number of arguments to "^"."
43;;    (c) doesn't try to flatten expressions of the form a=(b=c).
44
45;; There are other functions other than ^ and = that we shouldn't try
46;; to flatten -- Bessel functions, etc.
47
48(in-package :maxima)
49($put '$charsets_flatten 1 '$version)
50
51;; Return the operator and argument of the expression e.
52
53(defun get-op-and-arg (e)
54  (let ((op) (arg))
55    (cond ((or ($atom e) ($subvarp e))
56	   (setq op nil)
57	   (setq arg nil))
58	  ((and (consp (nth 0 e)) ($subvarp (nth 1 e)))
59	   (setq op `(,(nth 0 e) ,(nth 1 e)))
60	   (setq arg (cddr e)))
61	  (t
62	   (setq op (nth 0 e))
63	   (setq arg (cdr e))))
64    (values op arg)))
65
66(defun $charsets_flatten (e)
67  (setq e (ratdisrep e))
68  (cond ((or ($atom e) ($subvarp e) (or (member ($inpart e 0) (list "^" "=") :test #'equal)))
69	 e)
70	(t
71	 (let ((op (multiple-value-list (get-op-and-arg e))))
72	   (setq e (cadr op))
73	   (setq op (car op))
74	   (setq e (mapcar #'(lambda (x) (flatten-op x op)) e))
75	   (setq e (reduce #'append e))
76	   (cond ((and (consp (car op)) (eq (caar op) 'mqapply))
77		  (append op e))
78		 (t
79		  `(,op ,@e)))))))
80
81(defun flatten-op (e op)
82  (let ((e-op) (e-arg))
83    (setq e-op (multiple-value-list (get-op-and-arg e)))
84    (setq e-arg (cadr e-op))
85    (setq e-op (car e-op))
86    (cond ((equal e-op op)
87	   (mapcan #'(lambda (x) (flatten-op x op)) e-arg))
88	  (t
89	   (list e)))))
90
91
92;;; Cut $every from src/mutils.lisp and paste it here,
93;;; renamed to $charsets_every.
94;;; Also rename $flatten to $charsets_flatten.
95;;; Robert Dodier 2005/02/22
96
97;;; This function works like the every function in lisp.
98;;; It can take a list, or a positive number of arguments returning
99;;; true if all its arguments are not false.
100;;; Author Dan Stanger 12/1/02
101(defmfun $charsets_every (&rest args)
102  (let ((n (length args)))
103    (cond ((= n 0) (merror "Every must have at least 1 argument"))
104	  ((= n 1)
105	   (let ((args (first args)))
106	     (if (and ($listp args) (> ($length args) 0))
107		 (notany #'not (margs args))
108		 (if (and ($listp args) (= ($length args) 0)) nil args))))
109	  (t (notany #'not args)))))
110