src/sublis.lisp

   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 ;;; SUBLIS: A Macsyma flavor of Lisp's SUBLIS...
   9 ;;;
  10 ;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **
  11
  12 (in-package :maxima)
  13
  14 (macsyma-module sublis)
  15
  16 (defmvar $sublis_apply_lambda t
  17   "a flag which controls whether LAMBDA's substituted are applied in
  18    simplification after the SUBLIS or whether you have to do an
  19    EV to get things to apply. A value of TRUE means perform the application.")
  20
  21 (declare-top (special *msublis-marker*))
  22
  23 ;;; SUBLIS([sym1=form1,sym2=form2,...],expression)$
  24 ;;;
  25 ;;;  This should change all occurrences of sym1 in expression to form1,
  26 ;;;  all occurrences of sym2 to form2, etc. The replacement is done in
  27 ;;;  parallel, so having occurrences of sym1 in form2, etc. will have
  28 ;;;  the `desired' (non-interfering) effect.
  29
  30 (defmfun $sublis (substitutions form)
  31   (cond (($listp substitutions)
  32          (do ((l (cdr substitutions) (cdr l))
  33               (nl ())
  34               (temp))
  35              ((null l) (setq substitutions nl))
  36            (setq temp (car l))
  37            (cond ((and (not (atom temp))
  38                        (not (atom (car temp)))
  39                        (eq (caar temp) 'mequal)
  40                        (symbolp (car (pop temp))))
  41                   (push (cons (pop temp) (pop temp)) nl))
  42                  (t (merror (intl:gettext "sublis: expected an equation with left-hand side a symbol; found: ~M") temp)))))
  43         (t
  44          (merror (intl:gettext "sublis: first argument must a list; found: ~M") substitutions)))
  45   (msublis substitutions form))
  46
  47 (defun msublis (s y)
  48   (declare (special s))
  49   (let ((*msublis-marker* (copy-symbol '*msublis-marker* nil)))
  50     (msublis-setup)
  51     (unwind-protect (msublis-subst y t) (msublis-unsetup))))
  52
  53 (defun msublis-setup ()
  54   (declare (special s))
  55   (do ((x s (cdr x)) (temp) (temp1)) ((null x))
  56     (cond ((not (symbolp (setq temp (caar x))))
  57            (merror (intl:gettext "sublis: left-hand side of equation must be a symbol; found: ~M") temp)))
  58     (setf (symbol-plist temp) (list* *msublis-marker* (cdar x) (symbol-plist temp)))
  59     (cond ((not (eq temp (setq temp1 (getopr temp))))
  60            (setf (symbol-plist temp1) (list* *msublis-marker* (cdar x) (symbol-plist temp1)))
  61            (push (ncons temp1) s)))))   ; Remember extra cleanup
  62
  63 (defun msublis-unsetup ()
  64   (declare (special s))
  65   (do ((x s (cdr x))) ((null x)) (remprop (caar x) *msublis-marker*)))
  66
  67 (defun msublis-subst (form flag)
  68   (cond ((atom form)
  69          (cond ((and (null form) (not flag)) nil) ;preserve trailing NILs
  70                ((symbolp form)
  71                 (cond ((eq (car (symbol-plist form)) *msublis-marker*)
  72                        (cadr (symbol-plist form)))
  73                       (t form)))
  74                (t form)))
  75         (flag
  76          (cond (($ratp form)
  77                 (let* ((disrep ($ratdisrep form))
  78                        (sub    (msublis-subst disrep t)))
  79                   (cond ((eq disrep sub) form)
  80                         (t ($rat sub)))))
  81                ((atom (car form))
  82                 ;; NOTE TO TRANSLATORS: "CAR" = FIRST ELEMENT OF LISP CONS
  83                 (merror (intl:gettext "sublis: malformed expression (atomic car).")))
  84                (t
  85                 (let ((cdr-value (msublis-subst (cdr form) nil))
  86                       (caar-value (msublis-subst (caar form) t)))
  87                   (cond ((and (eq cdr-value (cdr form))
  88                               (eq (caar form) caar-value))
  89                          form)
  90                         ((and $sublis_apply_lambda
  91                               (eq (caar form) 'mqapply)
  92                               (eq caar-value 'mqapply)
  93                               (atom (cadr form))
  94                               (not (atom (car cdr-value)))
  95                               (eq (caar (car cdr-value)) 'lambda))
  96                          (cons (cons (car cdr-value)
  97                                      (cond ((member 'array (car form) :test #'eq)
  98                                             '(array))
  99                                            (t nil)))
 100                                (cdr cdr-value)))
 101                         ((and (not (atom caar-value))
 102                               (or (not (or (eq (car caar-value) 'lambda)
 103                                            (eq (caar caar-value) 'lambda)))
 104                                   (not $sublis_apply_lambda)))
 105                          (list* (cons 'mqapply
 106                                       (cond ((member 'array (car form) :test #'eq)
 107                                              '(array))
 108                                             (t nil)))
 109                                 caar-value
 110                                 cdr-value))
 111                         (t (cons (cons caar-value
 112                                        (cond ((member 'array (car form) :test #'eq)
 113                                               '(array))
 114                                              (t nil)))
 115                                  cdr-value)))))))
 116         (t
 117          (let ((car-value (msublis-subst (car form) t))
 118                (cdr-value (msublis-subst (cdr form) nil)))
 119            (cond ((and (eq (car form) car-value)
 120                        (eq (cdr form) cdr-value))
 121                   form)
 122                  (t
 123                   (cons car-value cdr-value)))))))