archive/share/lisp/elim.lisp

   1 ;;; -*- Mode: Lisp; Package: Macsyma -*-
   2 ;;; Translated code for LMIVAX::MAX$DISK:[SHARE1]ELIM.MC;4
   3 ;;; Written on 9/10/1984 00:48:31, from MACSYMA 302
   4 ;;; Translated for LPH
   5
   6 ;;; TRANSL-AUTOLOAD version NIL
   7 ;;; TRANSS version 87 TRANSL version 1157 TRUTIL version 27
   8 ;;; TRANS1 version 108 TRANS2 version 39 TRANS3 version 50
   9 ;;; TRANS4 version 29 TRANS5 version 26 TRANSF version NIL
  10 ;;; TROPER version 15 TRPRED version 6 MTAGS version NIL
  11 ;;; MDEFUN version 58 TRANSQ version 88 FCALL version 40
  12 ;;; ACALL version 70 TRDATA version 68 MCOMPI version 146
  13 ;;; TRMODE version 73 TRHOOK version NIL
  14 (eval-when (compile eval)
  15       (setq *infile-name-key*
  16                   (namestring (truename '#.standard-input))))
  17
  18 (eval-when (compile)
  19    (setq $tr_semicompile 'NIL)
  20    (setq forms-to-compile-queue ()))
  21
  22 (comment "MAX$DISK:[SHARE1]ELIM.MC;4")
  23
  24 ;;; General declarations required for translated MACSYMA code.
  25
  26 (DECLARE (SPECIAL $DISPFLAG))
  27
  28 (DEFMTRFUN-EXTERNAL ($ELIMINATE $ANY MDEFINE NIL NIL))
  29
  30
  31 (DEFPROP $ELIMINATE T TRANSLATED)
  32
  33 (ADD2LNC '$ELIMINATE $PROPS)
  34
  35 (DEFMTRFUN
  36  ($ELIMINATE $ANY MDEFINE NIL NIL) ($EQNS $VARS) NIL
  37  ((LAMBDA ($TEQNS $SV $SE $L $FLAG $DISPFLAG)
  38     (DECLARE (FIXNUM $L))
  39     NIL
  40     (SETQ $FLAG (SETQ $DISPFLAG NIL))
  41     (COND
  42       ((NOT
  43          (AND (MFUNCTION-CALL $LISTP $EQNS) (MFUNCTION-CALL $LISTP $VARS)))
  44          (SIMPLIFY
  45            (MFUNCTION-CALL $ERROR '|&THE ARGUMENTS MUST BOTH BE LISTS|))))
  46     (COND
  47       ((> (MFUNCTION-CALL $LENGTH $VARS)
  48           (SETQ $L (MFUNCTION-CALL $LENGTH $EQNS)))
  49          (SIMPLIFY
  50            (MFUNCTION-CALL $ERROR '|&MORE VARIABLES THEN EQUATIONS|))))
  51     (COND
  52       ((= $L 1)
  53          (SIMPLIFY (MFUNCTION-CALL
  54                      $ERROR '|&CAN'T ELIMINATE FROM ONLY ONE EQUATION|))))
  55     (COND
  56       ((= (MFUNCTION-CALL $LENGTH $VARS) $L)
  57          (SETQ $VARS (SIMPLIFY (MFUNCTION-CALL $REVERSE $VARS)))
  58          (SETQ $SV (MARRAYREF $VARS 1))
  59          (SETQ
  60            $VARS
  61            (SIMPLIFY (MFUNCTION-CALL
  62                        $REVERSE (SIMPLIFY (MFUNCTION-CALL $REST $VARS)))))
  63          (SETQ $FLAG T)))
  64     (SETQ $EQNS (SIMPLIFY (MAP1 (GETOPR 'MEQHK) $EQNS)))
  65     (DO (($V) (MDO (CDR $VARS) (CDR MDO))) ((NULL MDO) '$DONE)
  66       (SETQ $V (CAR MDO))
  67       (SETQ $TEQNS '((MLIST)))
  68       (DO (($J 1 (+ 1 $J)))
  69           ((OR (> $J $L)
  70                (NOT (MFUNCTION-CALL $FREEOF $V (SIMPLIFY ($FIRST $EQNS)))))
  71              '$DONE)
  72         (SETQ $TEQNS
  73               (SIMPLIFY
  74                 (MFUNCTION-CALL $CONS (SIMPLIFY ($FIRST $EQNS)) $TEQNS)))
  75         (SETQ $EQNS (SIMPLIFY (MFUNCTION-CALL $REST $EQNS))))
  76       (COND
  77         ((LIKE $EQNS '((MLIST))) (SETQ $EQNS $TEQNS))
  78         (T (SETQ
  79              $TEQNS
  80              (SIMPLIFY
  81                (MFUNCTION-CALL
  82                  $APPEND $TEQNS (SIMPLIFY (MFUNCTION-CALL $REST $EQNS)))))
  83            (SETQ $EQNS (SIMPLIFY ($FIRST $EQNS)))
  84            (SETQ $L (+ $L -1)) (SETQ $SE '((MLIST)))
  85            (DO (($J 1 (+ 1 $J))) ((> $J $L) '$DONE)
  86              (SETQ
  87                $SE
  88                (SIMPLIFY
  89                  (MFUNCTION-CALL
  90                    $CONS
  91                    (SIMPLIFY (MFUNCTION-CALL
  92                                $RESULTANT $EQNS (MARRAYREF $TEQNS $J) $V))
  93                    $SE))))
  94            (SETQ $EQNS $SE))))
  95     (COND
  96       ($FLAG
  97         (LIST
  98           '(MLIST)
  99           (SIMPLIFY
 100             (MFUNCTION-CALL
 101               $RHS
 102               (SIMPLIFY
 103                 (MFUNCALL
 104                   '$EV
 105                   (SIMPLIFY
 106                     (MFUNCTION-CALL
 107                       $LAST
 108                       (SIMPLIFY
 109                         (MFUNCTION-CALL $SOLVE (MARRAYREF $EQNS 1) $SV))))
 110                   '$EVAL))))))
 111       (T $EQNS)))
 112   '$TEQNS '$SV '$SE 0 '$FLAG '$DISPFLAG))
 113
 114 (compile-forms-to-compile-queue)
 115