share/algebra/charsets/charsets_flatten.lisp

   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)))))