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 / schatc.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  16.9 KB  |  573 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. ;;;     (c) Copyright 1980 Massachusetts Institute of Technology         ;;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (in-package "MAXIMA")
  12. (macsyma-module schatc)
  13.  
  14. #-NIL
  15. (EVAL-WHEN (EVAL COMPILE)
  16.        (SETQ OLD-IBASE *read-base* *read-base* 10.))
  17.  
  18. (DECLARE-TOP(SPECIAL
  19.          ;;VAR
  20.          SPLIST DICT ANS *SCHATFACTOR BINDLIST SPECLIST)
  21.      (*LEXPR $DIVIDE $FACTOR)
  22.      (GENPREFIX SCHAT))
  23.  
  24. (DEFMACRO PUSH-CONTEXT () '(SETQ ANS (CONS NIL ANS)))
  25.  
  26. (DEFMACRO PUSH-LOOP-CONTEXT () '(RPLACD ANS (CONS '*LOOP (CDR ANS))))
  27.  
  28. (DEFMACRO PRESERVE (Z)
  29.       `(RPLACD ANS (CONS (CONS ,Z (CDR ,Z)) (CDR ANS))))
  30.  
  31. (DEFMACRO ADD-TO (VAR VAL)
  32.       `(RPLACD ANS (CONS (CONS ,VAR ,VAL) (CDR ANS))))
  33.  
  34. (DEFMACRO VAR-PAT (X) `(ATOM (CAR ,X)))
  35.  
  36. (SETQ *SCHATFACTOR NIL)        ;DETERMINES WHETHER FACTORING SHOULD BE USED.
  37.  
  38.  
  39. ;;;
  40. ;;;    VARIOUS MACROS WHICH PERMIT STAND-ALONE SCHATCHEN'S
  41. ;;;    Stand-alone Schatchen's are only needed on ITS, so define them
  42. ;;;    there only.
  43.  
  44. #+ITS (PROGN 'COMPILE
  45.  
  46. (DEFUN COMPILING MACRO (L)
  47.        (AND (BOUNDP 'COMPILER-STATE)
  48.         (NOT (EQ COMPILER-STATE 'TOPLEVEL))))
  49.  
  50. ;; If compiling or the function already defined, punt.
  51.  
  52. (DEFMACRO DEFINE (&rest L)
  53.        (COND ((OR (COMPILING) (FBOUNDP (CADR L)))
  54.           NIL)
  55.          (T (CONS 'DEFUN L))))
  56.  
  57. (DEFINE MPLUSP (X)
  58.     (AND (NULL (ATOM X))
  59.          (EQ (CAAR X) 'MPLUS)))
  60.  
  61. (DEFINE MTIMESP (X)
  62.     (AND (NULL (ATOM X))
  63.          (EQ (CAAR X) 'MTIMES)))
  64.  
  65. (DEFINE MEXPTP (X)
  66.     (AND (NULL (ATOM X))
  67.          (EQ (CAAR X) 'MEXPT)))
  68.  
  69. (DEFINE FREE (E X)
  70.     (COND ((EQUAL E X) NIL)
  71.           ((ATOM E))
  72.           ((DO ((L (CDR E) (CDR L)))
  73.            ((NULL L) T)
  74.            (OR (FREE (CAR L) X)
  75.                (RETURN NIL))))))
  76.  
  77. (DEFINE ALIKE (X Y)
  78.     (COND ((ATOM X) (EQUAL X Y))
  79.           ((ATOM Y) NIL)
  80.           (T (AND (ALIKE1 (CAR X) (CAR Y))
  81.               (ALIKE (CDR X) (CDR Y))))))
  82.  
  83. (DEFINE ALIKE1 (X Y)
  84.     (COND ((EQ X Y))
  85.           ((ATOM X) (EQUAL X Y))
  86.           ((ATOM Y) NIL)
  87.           (T (AND (EQ (CAAR X) (CAAR Y))
  88.               (ALIKE (CDR X) (CDR Y))))))
  89.  
  90. ) ;; End of ITS conditionalization
  91.  
  92.  
  93. ;
  94. ;VARIOUS SIMPLE PATTERNS
  95. ;
  96.  
  97. (DEFUN FREE1 (A)
  98.   (declare (special var))
  99.     (AND (NULL (pzerop A)) (FREE A VAR)))
  100.  
  101. (DEFUN NOT-ZERO-FREE (A VAR) (declare (special var)) (FREE1 A))
  102.  
  103. (DEFUN LINEAR* (E VAR)
  104.   (declare(special var))
  105.     (PROG (A N)
  106.         (SETQ N ($RATCOEF E VAR))
  107.         (COND ((NULL (FREE N VAR))
  108.                (RETURN NIL)))
  109.         (SETQ A (SIMPLUS (LIST '(MPLUS) E (LIST '(MTIMES) -1 N VAR)) 1 NIL))
  110.         (RETURN
  111.            (COND ((FREE A VAR) (CONS A N))))))
  112.  
  113. (DEFUN DVCOE (E PAT ARGS)
  114.     (M1 ($RATSIMP (LIST '(MTIMES) E ARGS)) PAT))
  115.  
  116. (DEFMFUN SCHATCHEN (E P)
  117.     (M2 E P NIL))
  118.  
  119. ;THE RESTORE FUNCTIONS RESTORE THE SPEC-VAR ANS
  120. ;AND RETURN TRUE OR FALSE AS FOLLOWS
  121. ;RESTORE - FLASE
  122. ;RESTORE1 - TRUE AND CLEARS UP ANS
  123. ;RESTORE2 - TRUE AND CLEARS OFF *LOOP INDICATORS
  124. ;        DOES NOT FIX UP THE EXPRESSION AND
  125. ;        IS THUS TO BE USED ONLY INTERNALLY
  126. ;
  127. ;TO INSURE THAT THERE IS NO CONFLICT IN SPECIAL VARIABLES,
  128. ;ESPECIALLY WITH THE VAR* (SET) MODE ALL SCHATCHEN VARIABLES
  129. ;ARE TO BE PRECEEDED BY A "%"
  130.  
  131. (DEFMFUN M2 (E P SPLIST)
  132.    ((LAMBDA (ANS)
  133.     (COND ((NULL (M1 (COPY E) P)) NIL)
  134.           ((NULL (CDR ANS)))
  135.           ((CDR ANS))))
  136.     (LIST NIL)))
  137.  
  138. (DEFUN SAV&DEL (X)
  139.     (PRESERVE X)
  140.     (RPLACD X (CDDR X)))
  141.  
  142. (DEFMFUN M1 (E P)
  143.     (COND ((EQ E P) T)
  144.           ((ATOM P) NIL)
  145.           ((VAR-PAT P)
  146.            (PUSH-CONTEXT)
  147.            (COND ((TESTA P E NIL)
  148.               (RESTORE1))
  149.              ((RESTORE))))
  150.           ((ATOM (CAAR P))
  151.            (COND ((MEMQ 'SIMP (CDAR P)) (ALIKE1 E P))
  152.              ((MEMQ (CAAR P) '(MPLUS MTIMES))
  153.               (LOOPP E P))
  154.              ((MEMQ (CAAR P) '(MEXPT ZEPOW)) (ZEPOW E P T))
  155.              ((AND (NOT (ATOM E)) (EQ (CAAR E) (CAAR P))) (EACHP E P)) 
  156.              ((EQ (CAAR P) 'COEFFT) (COEFFT E P T))
  157.              ((EQ (CAAR P) 'COEFFPT) (COEFFPT E P T))
  158.              ((EQ (CAAR P) 'COEFFP) (COEFFP E P T))
  159.              ((EQ (CAAR P) 'COEFFTT)
  160.               (COEFFTT E (CADR P) T 'MTIMES))
  161.              ((EQ (CAAR P) 'COEFFPP)
  162.               (COEFFTT E (CADR P) T 'MPLUS))))
  163.           ((VAR-PAT (CAAR P))                    ;HAIRY OPERATOR MATCHING SCHEME
  164.            (COND ((ATOM E) NIL)                ;NO OPERATOR TO MATCH
  165.              ((PROG2 (PUSH-CONTEXT)            ;BIND THE CONTEXT
  166.                  (TESTA (CAAR P) (CAR E) NIL))    ;TRY IT
  167.               (COND ((MEMQ (CAAR E) '(MPLUS MTIMES))    ;CHECK FOR COMMUTIVITY
  168.                  (COND ((LOOPP E (CONS (CAR E) (CDR P)))
  169.                     (RESTORE1))
  170.                    ((RESTORE))))
  171.                 ((EACHP E P)
  172.                  (RESTORE1))
  173.                 ((RESTORE))))
  174.              ((RESTORE))))))
  175.  
  176. (DEFUN LOOPP (E P)
  177.   (PROG (X Z)
  178.     (SETQ E (COND  ((ATOM E) (LIST (CAR P) E))
  179.                ((NULL (EQ (CAAR P) (CAAR E)))
  180.             (COND ((AND *SCHATFACTOR (EQ (CAAR E) 'MPLUS)
  181.                     (MTIMESP (SETQ X ($FACTOR E))))
  182.                    X)
  183.                   ((LIST (CAR P) E))))
  184.                (E)))
  185.     (PUSH-CONTEXT)
  186.     (SETQ Z P)
  187.   LOOP    (SETQ Z (CDR Z))
  188.     (COND ((NULL Z)
  189.            (RETURN
  190.         (COND ((NULL (CDR E)) (RESTORE1))
  191.               ((RESTORE))))))
  192.     (SETQ X E)
  193.   L5    (COND ((NULL (CDR X)) 
  194.            ((LAMBDA (IDENT)
  195.            (COND ((AND IDENT (M1 IDENT (CAR Z)))
  196.               (GO LOOP))
  197.              ((RETURN (RESTORE)))))
  198.         (OPIDENT (CAAR P))))
  199.           ((OR (ATOM (CAR Z)) (VAR-PAT (CAR Z)))
  200.            (COND ((M1 (CADR X) (CAR Z))
  201.               (SAV&DEL X) (GO LOOP))))
  202.           ((EQ (CAAAR Z) 'COEFFT)
  203.            (COND ((COEFFT E (CAR Z) NIL)
  204.               (GO LOOP))
  205.              ((RETURN (RESTORE)))))
  206.           ((EQ (CAAAR Z) 'COEFFP)
  207.            (COND ((COEFFP E (CAR Z) NIL)
  208.               (GO LOOP))
  209.              ((RETURN (RESTORE)))))
  210.           ((EQ (CAAAR Z) 'COEFFPT)
  211.            (COND ((COEFFPT E (CAR Z) NIL) (GO LOOP))
  212.              ((RETURN (RESTORE)))))
  213.           ((EQ (CAAAR Z) 'COEFFTT)
  214.            (COND ((COEFFTT E (CADAR Z) NIL 'MTIMES) (GO LOOP))
  215.              ((RETURN (RESTORE)))))
  216.           ((EQ (CAAAR Z) 'COEFFPP)
  217.            (COND ((COEFFTT E (CADAR Z) NIL 'MPLUS) (GO LOOP))
  218.              ((RETURN (RESTORE)))))
  219.           ((MEMQ (CAAAR Z) '(MEXPT ZEPOW)) 
  220.            (COND ((ZEPOW (CADR X) (CAR Z) T) 
  221.               (SAV&DEL X) (GO LOOP))))
  222.           ((EQ (CAAAR Z) 'LOOP)
  223.            (COND ((SCH-LOOP E (CDAR Z)) (GO LOOP))
  224.              ((RETURN (RESTORE)))))
  225.           ((M1 (CADR X) (CAR Z)) 
  226.            (SAV&DEL X) (GO LOOP)))
  227.     (SETQ X (CDR X))
  228.     (GO L5)))
  229.  
  230. ;;; IND = T MEANS AN INTERNAL CALL (USUALLY FROM LOOPP)
  231.  
  232. (DEFUN COEFFP (E P IND)
  233.     (PUSH-CONTEXT)
  234.     (COND ((OR (AND (NULL (MPLUSP E))    ;;;WITH IND SET, OR E = (PLUS <EXPR>)
  235.             (SETQ E (LIST '(MPLUS) E)))
  236.            IND (NULL (CDDR E)))
  237.        (COEFFPORT E P 0 IND))    ;;; USE COEFFPORT
  238.       ((AND (NULL (CDDR P))        ;;; P = ((COEFFP) (<VAR> <PRED> . . .))
  239.         (VAR-PAT (CADR P)))    ;;; SO CALL TESTA
  240.        (COND ((TESTA (CADR P) E NIL)
  241.           (COND ((MPLUSP E)
  242.              (PRESERVE E)
  243.              (RPLACD E NIL)
  244.              T)
  245.             ((merror "(BAD ARGS TO COEFFP -- REPORT BUG TO RZ)"))))))
  246.       ((DO ((X E (CDR X)))
  247.            ((NULL (CDR X))
  248.         (COND ((M1 0 P) (RESTORE2))
  249.               ((RESTORE))))
  250.            (COND ((COEFFP (CADR X) P T)
  251.               (SAV&DEL X)
  252.               (RETURN (RESTORE2))))))))
  253.  
  254. (DEFUN COEFFT (E P IND)
  255.     (PUSH-CONTEXT)
  256.     (COND ((AND (NULL IND) (NULL (ATOM E)) (MEMQ (CAAR E) '(MPLUS MTIMES)))
  257.        (DO ((X E (CDR X)))
  258.            ((NULL (CDR X))
  259.         (COND ((M1 1 P) (RESTORE2))
  260.               ((RESTORE))))
  261.            (COND ((COEFFT (CADR X) P T)
  262.               (SAV&DEL X)
  263.               (RETURN (RESTORE2))))))
  264.       ((AND (MPLUSP E) (CDDR E))
  265.        (COND ((AND *SCHATFACTOR (MTIMESP (SETQ E ($FACTOR E))))
  266.           (COEFFPORT E P 1 IND))
  267.          ((RESTORE))))
  268.       (T (COEFFPORT (COND ((MTIMESP E) E) ((LIST '(MTIMES) E)))
  269.             P 1 IND))))
  270.  
  271. (DEFUN COEFFPORT (E P IDENT IND)
  272.     (DO ((Z (CDDR P) (CDR Z))
  273.      (X E E))
  274.     ((NULL Z)
  275.      (COEFFRET E (CADR P) IDENT IND))
  276.      L    ;;; EACH TIME HERE WE HAVR CDR'D DOWN THE EXP.
  277.         (COND ((NULL (CDR X))
  278.            (AND (NULL (M1 IDENT (CAR Z)))
  279.             (RETURN (RESTORE))))
  280.           ((OR (ATOM (CAR Z))
  281.            (VAR-PAT (CAR Z))))
  282.           ((EQ (CAAAR Z) 'COEFFTT)
  283.            (AND (NULL (COEFFTT E (CADAR Z) NIL 'MTIMES))
  284.             (RETURN (COEFFRET E P IDENT IND))))
  285.           ((EQ (CAAAR Z) 'COEFFPP)
  286.            (AND (NULL (COEFFTT E (CADAR Z) NIL 'MPLUS))
  287.             (RETURN (COEFFRET E P IDENT IND)))))
  288.     (COND ((NULL (CDR X)))
  289.           ((M1 (CADR X) (CAR Z))
  290.            (SAV&DEL X))
  291.           (T (SETQ X (CDR X))
  292.            (GO L)))))
  293.  
  294. (DEFUN COEFFRET (E P IDENT IND)
  295.     (COND ((NULL (CDR E))
  296.        (COND ((TESTA P IDENT NIL)
  297.           (COND (IND (RESTORE1))
  298.             ((RESTORE2))))
  299.          ((RESTORE))))
  300.       ((TESTA P (COND ((CDDR E) (copy-top-level E ))
  301.               ((CADR E)))
  302.          NIL)
  303.        (COND (IND (RESTORE1))
  304.          (T (PRESERVE E)
  305.             (RPLACD E NIL)
  306.             (RESTORE2))))
  307.       ((RESTORE))))
  308.  
  309. (DEFUN COEFFPT (E P IND)    ;THE PATTERN LIST (P) MUST BE OF VAR-PATTERNS
  310.     (PUSH-CONTEXT)
  311.     (DO ((Z (COND ((MPLUSP E) E) ((LIST '(MPLUS) E))))
  312.          (ZZ (CONS '(COEFFT) (CDR P))))            ;THIS ROUTINE IS THE ONE WHICH PUTS
  313.                                 ;MOST OF THE THE GARBAGE ON ANS IT
  314.         ((NULL (CDR Z))                    ;IT CANNOT USE THE SPLIST HACK 
  315.          (SETQ Z (FINDIT (COND ((EQ (CAADR P) 'VAR*)    ;BECAUSE IT COULD BE USING
  316.                     (CAR (CDDADR P)))        ;MANY DIFFERENT VARIABLES ALTHOUGH 
  317.                    ((CAADR P)))))        ;THOUGHT THE FIRST IS THE ONLY ONE
  318.          ((LAMBDA (Q FL)                    ;WHICH BECOMES A SUM AND MIGHT BE RESET
  319.         (COND ((NULL (TESTA (CADR P) Q FL))
  320.                (RESTORE))
  321.               (IND (RESTORE1))
  322.               (T (RESTORE2) Q)))
  323.           (COND ((NULL Z) 0)
  324.             ((NULL (CDR Z)) (CAR Z))
  325.             ((SIMPLUS (CONS '(MPLUS) Z) 1 NIL)))
  326.           (COND ((AND Z (CDR Z)) 'COEFFPT))))
  327.         (COND ((NULL (M1 (CADR Z) ZZ))    ;THIS IS THE DO BODY
  328.            (SETQ Z (CDR Z)))
  329.           ((SAV&DEL Z)))))
  330. (DEFUN ZEPOW (E P FL)                ;FL=NIL INDICATES A RECURSIVE CALL
  331.     (AND FL (PUSH-CONTEXT))    ;SO ANS SHOULD NOT BE MARKED
  332.     (COND ((ATOM E)
  333.            (COND ((EQUAL E 1)
  334.               (COND ((NOT (OR (M1 0 (CADDR P)) (M1 1 (CADR P))))
  335.                  (RESTORE))
  336.                 ((RESTORE1))))
  337.              ((EQUAL E 0)
  338.               (COND ((NULL (M1 0 (CADR P))) (RESTORE))
  339.                 ((RESTORE1))))
  340.              ((AND (M1 E (CADR P)) (M1 1 (CADDR P)))
  341.               (RESTORE1))
  342.              ((RESTORE))))
  343.           ((AND *SCHATFACTOR (MPLUSP E) (SETQ E ($FACTOR E)) NIL))
  344.           ((AND (EQ (CAAR E) 'MTIMES)
  345.             (MEXPTP (CADR E)))
  346.            (DO ((E (CDDR E) (CDR E))
  347.             (B (CADADR E))
  348.             (X (CADDR (CADR E)))
  349.             (Z))
  350.            ((NULL E)            ;OK NOW LETS TRY AGAIN
  351.             (ZEPOW (LIST '(MEXPT) (SIMPLIFYA B T)
  352.                       (SIMPLIFYA X T)) P NIL))
  353.            (COND ((MEXPTP (CAR E))
  354.               (COND ((ALIKE1 (CADAR E) B)
  355.                  (SETQ X (SIMPLUS (LIST '(MPLUS) X (CADDAR E)) 1 NIL)))
  356.                 ((ALIKE1 (CADDAR E) X)
  357.                  (SETQ B (SIMPTIMES (LIST '(MTIMES) B (CADAR E)) 1 NIL)))
  358.                 ((SIGNP E (CADDR (SETQ Z ($DIVIDE X (CADDAR E)))))
  359.                  (SETQ B (SIMPTIMES (LIST '(MTIMES) B
  360.                               (LIST '(MEXPT) (CADAR E)
  361.                                 (LIST '(MTIMES) (CADDAR E) (CADR Z)))) 1 NIL)))
  362.                 ((RETURN (RESTORE)))))
  363.              ((ALIKE1 B (CAR E))
  364.               (SETQ X (SIMPLUS (LIST '(MPLUS) 1 X) 1 T)))
  365.              ((RETURN (RESTORE))))))
  366.           ((OR (AND (EQ (CAAR E) 'MEXPT)
  367.             (M1 (CADR E) (CADR P))
  368.             (M1 (CADDR E) (CADDR P)))
  369.            (AND (M1 E (CADR P))
  370.             (M1 1 (CADDR P))))
  371.            (RESTORE1))
  372.           ((RESTORE))))
  373.  
  374. (DEFUN EACHP (E P)
  375.     (COND ((= (LENGTH E) (LENGTH P))
  376.            (PUSH-CONTEXT)
  377.            (DO ((E (CDR E) (CDR E)))
  378.            ((NULL E) (RESTORE1))
  379.            (AND (NULL (M1 (CAR E) (CADR P))) (RETURN (RESTORE)))
  380.            (SETQ P (CDR P))))))
  381.  
  382. (DEFUN SCH-LOOP (E LP)
  383.     (PUSH-CONTEXT) (PUSH-LOOP-CONTEXT)
  384.     (DO ((X LP) (Z E) (Y))            ;Y A PSEUDO SAVE
  385.     (NIL)
  386.     (COND ((NULL (M1 (CADR Z) (CAR X)))    ;DIDN'T MATCH
  387.            (SETQ Z (CDR Z))            ;NEXT ARG FOR LOOP
  388.            (COND ((CDR Z))
  389.              ((EQ X LP) (RETURN (RESTORE)))
  390.              (T (SETQ X (CAAR Y) Z (CDAR Y))
  391.             (SETQ Y (CDR Y) ANS (CDR ANS))
  392.             (POP-LOOP-CONTEXT))))
  393.           (T (SETQ Y (CONS (CONS X Z) Y))
  394.          (SAV&DEL Z)
  395.          (SETQ X (CDR X))
  396.           (COND ((NULL X) (RETURN (RESTORE2)))
  397.                (T (PUSH-LOOP-CONTEXT)
  398.               (SETQ Z E)))))))
  399.  
  400. (DEFUN COEFFTT (EXP PAT IND OPIND)    ;OPIND IS MPLUS OR MTIMES
  401.     (PUSH-CONTEXT)
  402.     (COND ((OR (ATOM EXP) (AND IND (NOT (EQ (CAAR EXP) OPIND))))
  403.        (SETQ EXP (LIST (LIST OPIND) EXP))))
  404.     (SETQ SPLIST (CONS (CAR PAT) SPLIST))    ;SAVE VAR NAME HERE
  405.     (DO ((Z EXP) (RES))
  406.     ((NULL (CDR Z))
  407.      (SETQ SPLIST (CDR SPLIST))    ;KILL NAME SAVED
  408.      (COND (RES (SETQ RES (COND ((CDR RES) (CONS (LIST OPIND) RES))
  409.                     ((CAR RES))))
  410.             (COND ((AND (EQ (CAR PAT) 'VAR*)
  411.                 (MEMQ 'SET (CADR PAT)))
  412.                (ADD-TO (CADDR PAT) (SET (CADDR PAT) (SIMPLIFYA RES NIL))))
  413.                ((ADD-TO (CAR PAT) (SIMPLIFYA RES NIL))))
  414.             (COND (IND (RESTORE1))
  415.               ((RESTORE2))))
  416.           ((NULL (TESTA PAT (OPIDENT OPIND) NIL))
  417.            (RESTORE))
  418.               (IND (RESTORE1))
  419.               ((RESTORE2))))
  420.     (COND ((TESTA PAT (CADR Z) NIL)
  421.            (SETQ RES (CONS (CADR Z) RES))
  422.            (SAV&DEL Z))
  423.            (T (SETQ Z (CDR Z))))))
  424. (DEFUN RESTORE NIL
  425.     (DO ((Y (CDR ANS) (CDR Y)))
  426.         ((NULL Y) NIL)
  427.         (COND ((EQ (CAR Y) '*LOOP)
  428.                (RPLACA Y (CADR Y))
  429.                (RPLACD Y (CDDR Y)))
  430.               ((NULL (CAR Y))
  431.                (SETQ ANS Y)
  432.                (RETURN NIL))
  433.               ((NULL (ATOM (CAAR Y)))
  434.                (RPLACD (CAAR Y) (CDAR Y))))))
  435.  
  436. (DEFUN RESTORE1 NIL
  437.     (DO ((Y ANS) (L))                ;L IS A LIST OF VAR'S NOTED
  438.     ((NULL (CDR Y)) T)
  439.     (COND ((NULL (CADR Y))            ;END OF CONTEXT
  440.                (RPLACD Y (CDDR Y))        ;SPLICE OUT THE CONTEXT MARKER
  441.            (RETURN T))
  442.           ((NOT (ATOM (CAADR Y)))        ;FIXUP NECESSARY
  443.            (RPLACD (CAADR Y) (CDADR Y))    
  444.            (RPLACD Y (CDDR Y)))
  445.           ((MEMQ (CAR Y) L)            ;THIS VAR HAS ALREADY BEEN SEEN
  446.            (RPLACD Y (CDDR Y)))        ;SO SPLICE IT OUT TO KEEP ANS CLEAN
  447.           ((SETQ Y (CDR Y)
  448.              L (CONS (CAAR Y) L))))))
  449.  
  450. (DEFUN RESTORE2 NIL
  451.      (DO ((Y (CDR ANS) (CDR Y)))
  452.      ((NULL (CDR Y)) T)
  453.      (COND ((EQ (CADR Y) '*LOOP)
  454.         (RPLACD Y (CDDR Y)))
  455.            ((NULL (CADR Y))
  456.         (RPLACD Y (CDDR Y))
  457.         (RETURN T)))))
  458.  
  459. (DEFUN POP-LOOP-CONTEXT NIL
  460.     (DO ((Y ANS))
  461.         ((EQ (CADR Y) '*LOOP) NIL)
  462.         (OR (ATOM (CAADR Y))
  463.         (RPLACD (CAADR Y) (CDADR Y)))
  464.         (RPLACD Y (CDDR Y))))
  465. ;WHEN THE CAR OF ALA IS VAR* THE CADR IS A LIST OF
  466. ;THE VARIOUS SWITCHES WHICH MAY BE SET.  
  467. ;UVAR- INDICATES THIS SHOULD MATCH SOMETHING WHICH IS ALREADY ON ANS.
  468. ;SET - ACTUALLY SET THIS VARIABLE TO ITS VALUE IF IT MATCHES.
  469. ;COEFFPT - SPECIAL ARGUMENT IF IN COEFFPT.
  470.  
  471. (DEFUN TESTA (ALA EXP B)
  472.     (COND ((EQ (CAR ALA) 'MVAR*)
  473.            (TESTA* ALA EXP T))
  474.           ((EQ (CAR ALA) 'VAR*)
  475.            (DO ((Z (CADR ALA) (CDR Z))
  476.             (ALA (CDDR ALA))
  477.             (Y) (SET) (UVAR))
  478.            ((NULL Z)
  479.             (SETQ Y (COND (UVAR (M1 EXP Y))
  480.                   ((TESTA* ALA EXP NIL))))
  481.             (COND ((NULL Y) NIL)
  482.               (SET (SET (CAR ALA) EXP))
  483.               (Y)))
  484.            (COND ((EQ (CAR Z) 'SET) (SETQ SET T))
  485.              ((EQ (CAR Z) 'UVAR)
  486.               (COND ((SETQ Y (CDR (zl-ASSOC (CAR ALA) ANS)))
  487.                  (SETQ UVAR T))))
  488.              ((EQ (CAR Z) 'COEFFPT)
  489.               (AND (EQ B 'COEFFPT)
  490.                    (SETQ ALA (CADR Z)))
  491.               (SETQ Z (CDR Z)))
  492.              ((MERROR "(INVALID SWITCH IN PATTERN TO SCHATCHEN)")))))
  493.           ((TESTA* ALA EXP NIL))))
  494.  
  495. ; ALA IS THE PREDICATE LIST (VAR PREDFN ARG2 ARG3 ARG4 . . .)
  496.  
  497. (DEFUN TESTA* (ALA EXP LOC)
  498.       (declare (special var))
  499.     (COND ((COND ((EQ (CADR ALA) 'FREEVAR)
  500.               (COND ((EQ VAR '*NOVAR) (EQUAL EXP 1))
  501.                 ((FREE EXP VAR))))
  502.              ((EQ (CADR ALA) 'NUMBERP) (MNUMP EXP))
  503.              ((EQ (CADR ALA) 'TRUE) T)
  504.              ((EQ (CADR ALA) 'LINEAR*)
  505.               (SETQ EXP (LINEAR* EXP (CADDR ALA))))
  506.              ((NULL LOC)
  507.               (COND ((ATOM (CADR ALA))
  508.                  (COND ((FBOUNDP (CADR ALA))
  509.                     (APPLY (CADR ALA)
  510.                        (FINDTHEM EXP (CDDR ALA))))
  511.                    ((MGET (CADR ALA) 'MEXPR)
  512.                     (MAPPLY (CADR ALA)
  513.                         (FINDTHEM EXP (CDDR ALA))
  514.                         (CADR ALA)))))
  515.                 ((MEMQ (CAADR ALA) '(LAMBDA FUNCTION *FUNCTION QUOTE))
  516.                  ;;;THE LAMBDA IS HERE ONLY BECAUSE OF SIN!!!
  517.                  (APPLY (CADR ALA) (FINDTHEM EXP (CDDR ALA))))
  518.                 ((EVAL-PRED (CADR ALA) (CAR ALA) EXP)))))
  519.            (COND ((MEMQ (CAR ALA) SPLIST))
  520.              ((ADD-TO (CAR ALA) EXP))))
  521.           ((COND ((AND LOC (ATOM (CADR ALA))
  522.                (FBOUNDP (CADR ALA)))
  523.            (MAPC #'(LAMBDA (Q V) (AND (NULL (MEMQ Q SPLIST))
  524.                      (ADD-TO Q V)))
  525.              (CAR ALA)
  526.              (APPLY (CADR ALA) (FINDTHEM EXP (CDDR ALA)))))))))
  527.  
  528. (DEFUN EVAL-PRED (EXP %VAR VALUE)
  529.        (PROGV (LIST %VAR) (LIST VALUE)
  530.           (EVAL EXP)))
  531.  
  532. (DEFUN FINDTHEM (EXP ARGS)  
  533.     (CONS EXP
  534.       (MAPCAR #'(LAMBDA (Q)
  535.               (COND ((ATOM Q)
  536.                  (OR (CDR (ASSQ Q ANS))
  537.                      (EVAL Q)))
  538.                 ( Q )))
  539.          ARGS)))
  540.  
  541. (DEFUN FINDIT (A)
  542.     (DO ((Y ANS) (Z))
  543.         ((OR (NULL (CDR Y)) (NULL (CADR Y))) Z)
  544.         (COND ((EQ (CAADR Y) A)
  545.            (SETQ Z (NCONC Z (LIST (CDADR Y))))
  546.            (RPLACD Y (CDDR Y)))
  547.           ((SETQ Y (CDR Y))))))
  548.  
  549. (DEFUN SCH-REPLACE (DICT EXP1) (REPLAC EXP1))
  550.  
  551. (DEFUN REPLAC (EXP1)
  552.    ((LAMBDA (W1)
  553.     (COND ((NULL EXP1) NIL)
  554.           ((NOT (ATOM EXP1))
  555.            (COND ((EQ (CAR EXP1) 'EVAL)
  556.               (SIMPLIFYA (EVAL (REPLAC (CADR EXP1))) NIL))
  557.              ((EQ (CAR EXP1) 'QUOTE) (CADR EXP1))
  558.              (T (SETQ W1 (MAPCAR 'REPLAC (CDR EXP1)))
  559.             (COND ((EQUAL W1 (CDR EXP1))
  560.                    EXP1)
  561.                   ((SIMPLIFYA (CONS (LIST (CAAR EXP1)) W1) T))))))
  562.           ((NUMBERP EXP1) EXP1)
  563.           ((SETQ W1 (ASSQ EXP1 DICT))
  564.            (CDR W1))
  565.           (EXP1)))
  566.      NIL))
  567. #-NIL
  568. (DECLARE-TOP (UNSPECIAL VAR SPLIST DICT ANS BINDLIST SPECLIST))
  569.  
  570. #-NIL
  571. (EVAL-WHEN (EVAL COMPILE) (SETQ *read-base* OLD-IBASE))
  572.  
  573.