home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / sublis.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  4.5 KB  |  127 lines
  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. (macsyma-module sublis)
  14.  
  15. (DEFMVAR $SUBLIS_APPLY_LAMBDA T 
  16.   "a flag which controls whether LAMBDA's substituted are applied in
  17.    simplification after the SUBLIS or whether you have to do an
  18.    EV to get things to apply. A value of TRUE means perform the application.")
  19.  
  20.     ; The EXPR stuff here should eventually be flushed.
  21. (declare-top #-cl (*EXPR $LISTP $RAT $RATP $RATDISREP GETOPR) 
  22.      (SPECIAL *MSUBLIS-MARKER*))
  23.  
  24. ;;; SUBLIS([sym1=form1,sym2=form2,...],expression)$
  25. ;;;
  26. ;;;  This should change all occurrences of sym1 in expression to form1,
  27. ;;;  all occurrences of sym2 to form2, etc. The replacement is done in
  28. ;;;  parallel, so having occurrences of sym1 in form2, etc. will have
  29. ;;;  the `desired' (non-interfering) effect.
  30.  
  31. (DEFMFUN $SUBLIS (SUBSTITUTIONS FORM)
  32.   (COND
  33.    (($LISTP SUBSTITUTIONS)
  34.     (DO ((L  (CDR SUBSTITUTIONS) (CDR L))
  35.      (NL ())
  36.      (TEMP))
  37.     ((NULL L) (SETQ SUBSTITUTIONS NL))
  38.       (SETQ TEMP (CAR L))
  39.       (COND ((AND (NOT (ATOM TEMP))
  40.           (NOT (ATOM (CAR TEMP)))
  41.           (EQ (CAAR TEMP) 'MEQUAL)
  42.           (SYMBOLP (CAR (POP TEMP))))
  43.          (PUSH (CONS (POP TEMP) (POP TEMP)) NL))
  44.         (T (MERROR "Usage is SUBLIS([sym1=form1,...],expression)")))))
  45.    (T
  46.     (MERROR "Usage is SUBLIS([sym1=form1,...],expression)")))
  47.   (MSUBLIS SUBSTITUTIONS FORM))
  48.  
  49. (DEFUN MSUBLIS (S Y)
  50.   (DECLARE (SPECIAL S))
  51.   (LET ((*MSUBLIS-MARKER* (COPY-SYMBOL '*MSUBLIS-MARKER* NIL)))
  52.     (MSUBLIS-SETUP)
  53.     (UNWIND-PROTECT (MSUBLIS-SUBST Y T) (MSUBLIS-UNSETUP))))
  54.  
  55. (DEFUN MSUBLIS-SETUP ()
  56.   (DECLARE (SPECIAL S))
  57.        (DO ((X S (CDR X)) (TEMP) (TEMP1)) ((NULL X))
  58.     (COND ((NOT (SYMBOLP (SETQ TEMP (CAAR X))))
  59.            (MERROR "SUBLIS: Bad 1st arg")))
  60.     (SETPLIST TEMP (LIST* *MSUBLIS-MARKER* (CDAR X) (SYMBOL-PLIST TEMP)))
  61.     (COND ((NOT (EQ TEMP (SETQ TEMP1 (GETOPR TEMP))))
  62.            (SETPLIST TEMP1 (LIST* *MSUBLIS-MARKER* (CDAR X) (SYMBOL-PLIST TEMP1)))
  63.            (PUSH (NCONS TEMP1) S))))) ; Remember extra cleanup
  64.  
  65. (DEFUN MSUBLIS-UNSETUP ()
  66.   (DECLARE (SPECIAL S))
  67.        (DO ((X S (CDR X))) ((NULL X)) (REMPROP (CAAR X) *MSUBLIS-MARKER*)))
  68.  
  69. (DEFUN MSUBLIS-SUBST (FORM FLAG)
  70.        (COND ((ATOM FORM)
  71.           (COND ((AND (NULL FORM) (NOT FLAG)) NIL) ;preserve trailing NILs
  72.             ((SYMBOLP FORM)
  73.              (COND ((EQ (CAR (SYMBOL-PLIST FORM)) *MSUBLIS-MARKER*)
  74.                 (CADR (SYMBOL-PLIST FORM)))
  75.                (T FORM)))
  76.             (T FORM)))
  77.          (FLAG
  78.           (COND (($RATP FORM)
  79.              (LET* ((DISREP ($RATDISREP FORM))
  80.                 (SUB    (MSUBLIS-SUBST DISREP T)))
  81.                (COND ((EQ DISREP SUB) FORM)
  82.                  (T ($RAT SUB)))))
  83.             ((ATOM (CAR FORM))
  84.              (MERROR
  85.                "SUBLIS: Illegal object in expression being substituted for."))
  86.             (T
  87.              (LET ((CDR-VALUE (MSUBLIS-SUBST (CDR FORM) NIL))
  88.                (CAAR-VALUE (MSUBLIS-SUBST (CAAR FORM) T)))
  89.               (COND ((AND (EQ CDR-VALUE (CDR FORM))
  90.                       (EQ (CAAR FORM) CAAR-VALUE))
  91.                  FORM)
  92.                 ((AND $SUBLIS_APPLY_LAMBDA
  93.                       (EQ (CAAR FORM) 'MQAPPLY)
  94.                       (EQ CAAR-VALUE 'MQAPPLY)
  95.                       (ATOM (CADR FORM))
  96.                       (NOT (ATOM (CAR CDR-VALUE)))
  97.                       (EQ (CAAR (CAR CDR-VALUE)) 'LAMBDA))
  98.                  (CONS (CONS (CAR CDR-VALUE)
  99.                          (COND ((MEMQ 'array (CAR FORM))
  100.                             '(ARRAY))
  101.                            (T NIL)))
  102.                        (CDR CDR-VALUE)))
  103.                 ((AND (NOT (ATOM CAAR-VALUE))
  104.                       (OR (NOT (OR (EQ (CAR CAAR-VALUE) 'LAMBDA)
  105.                            (EQ (CAAR CAAR-VALUE) 'LAMBDA)))
  106.                       (NOT $SUBLIS_APPLY_LAMBDA)))
  107.                  (LIST* (CONS 'MQAPPLY
  108.                           (COND ((MEMQ 'array (CAR FORM))
  109.                              '(ARRAY))
  110.                             (T NIL)))
  111.                     CAAR-VALUE
  112.                     CDR-VALUE))
  113.                 (T (CONS (CONS CAAR-VALUE
  114.                            (COND ((MEMQ 'array (CAR FORM))
  115.                               '(ARRAY))
  116.                              (T NIL)))
  117.                      CDR-VALUE)))))))
  118.          (T
  119.           (LET ((CAR-VALUE (MSUBLIS-SUBST (CAR FORM) T))
  120.             (CDR-VALUE (MSUBLIS-SUBST (CDR FORM) NIL)))
  121.            (COND ((AND (EQ (CAR FORM) CAR-VALUE)
  122.                    (EQ (CDR FORM) CDR-VALUE))
  123.               FORM)
  124.              (T
  125.               (CONS CAR-VALUE CDR-VALUE)))))))
  126.  
  127.