File: elim.lsp

package info (click to toggle)
maxima 5.6-17
  • links: PTS
  • area: main
  • in suites: woody
  • size: 30,572 kB
  • ctags: 47,715
  • sloc: ansic: 154,079; lisp: 147,553; asm: 45,843; tcl: 16,744; sh: 11,057; makefile: 7,198; perl: 1,842; sed: 334; fortran: 24; awk: 5
file content (115 lines) | stat: -rw-r--r-- 3,296 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
;;; -*- Mode: Lisp; Package: Macsyma -*-
;;; Translated code for LMIVAX::MAX$DISK:[SHARE1]ELIM.MC;4
;;; Written on 9/10/1984 00:48:31, from MACSYMA 302
;;; Translated for LPH

;;; TRANSL-AUTOLOAD version NIL
;;; TRANSS version 87 TRANSL version 1157 TRUTIL version 27
;;; TRANS1 version 108 TRANS2 version 39 TRANS3 version 50
;;; TRANS4 version 29 TRANS5 version 26 TRANSF version NIL
;;; TROPER version 15 TRPRED version 6 MTAGS version NIL
;;; MDEFUN version 58 TRANSQ version 88 FCALL version 40
;;; ACALL version 70 TRDATA version 68 MCOMPI version 146
;;; TRMODE version 73 TRHOOK version NIL
(eval-when (compile eval)
      (setq *infile-name-key*
	          (namestring (truename '#.standard-input))))

(eval-when (compile)
   (setq $tr_semicompile 'NIL)
   (setq forms-to-compile-queue ()))

(comment "MAX$DISK:[SHARE1]ELIM.MC;4")

;;; General declarations required for translated MACSYMA code.

(DECLARE (SPECIAL $DISPFLAG))

(DEFMTRFUN-EXTERNAL ($ELIMINATE $ANY MDEFINE NIL NIL))


(DEFPROP $ELIMINATE T TRANSLATED)

(ADD2LNC '$ELIMINATE $PROPS)

(DEFMTRFUN
 ($ELIMINATE $ANY MDEFINE NIL NIL) ($EQNS $VARS) NIL
 ((LAMBDA ($TEQNS $SV $SE $L $FLAG $DISPFLAG)
    (DECLARE (FIXNUM $L))
    NIL
    (SETQ $FLAG (SETQ $DISPFLAG NIL))
    (COND
      ((NOT
	 (AND (MFUNCTION-CALL $LISTP $EQNS) (MFUNCTION-CALL $LISTP $VARS)))
	 (SIMPLIFY
	   (MFUNCTION-CALL $ERROR '|&THE ARGUMENTS MUST BOTH BE LISTS|))))
    (COND
      ((> (MFUNCTION-CALL $LENGTH $VARS)
	  (SETQ $L (MFUNCTION-CALL $LENGTH $EQNS)))
	 (SIMPLIFY
	   (MFUNCTION-CALL $ERROR '|&MORE VARIABLES THEN EQUATIONS|))))
    (COND
      ((= $L 1)
	 (SIMPLIFY (MFUNCTION-CALL
		     $ERROR '|&CAN'T ELIMINATE FROM ONLY ONE EQUATION|))))
    (COND
      ((= (MFUNCTION-CALL $LENGTH $VARS) $L)
	 (SETQ $VARS (SIMPLIFY (MFUNCTION-CALL $REVERSE $VARS)))
	 (SETQ $SV (MARRAYREF $VARS 1))
	 (SETQ
	   $VARS
	   (SIMPLIFY (MFUNCTION-CALL
		       $REVERSE (SIMPLIFY (MFUNCTION-CALL $REST $VARS)))))
	 (SETQ $FLAG T)))
    (SETQ $EQNS (SIMPLIFY (MAP1 (GETOPR 'MEQHK) $EQNS)))
    (DO (($V) (MDO (CDR $VARS) (CDR MDO))) ((NULL MDO) '$DONE)
      (SETQ $V (CAR MDO))
      (SETQ $TEQNS '((MLIST)))
      (DO (($J 1 (+ 1 $J)))
	  ((OR (> $J $L)
	       (NOT (MFUNCTION-CALL $FREEOF $V (SIMPLIFY ($FIRST $EQNS)))))
	     '$DONE)
	(SETQ $TEQNS
	      (SIMPLIFY
		(MFUNCTION-CALL $CONS (SIMPLIFY ($FIRST $EQNS)) $TEQNS)))
	(SETQ $EQNS (SIMPLIFY (MFUNCTION-CALL $REST $EQNS))))
      (COND
	((LIKE $EQNS '((MLIST))) (SETQ $EQNS $TEQNS))
	(T (SETQ
	     $TEQNS
	     (SIMPLIFY
	       (MFUNCTION-CALL
		 $APPEND $TEQNS (SIMPLIFY (MFUNCTION-CALL $REST $EQNS)))))
	   (SETQ $EQNS (SIMPLIFY ($FIRST $EQNS)))
	   (SETQ $L (+ $L -1)) (SETQ $SE '((MLIST)))
	   (DO (($J 1 (+ 1 $J))) ((> $J $L) '$DONE)
	     (SETQ
	       $SE
	       (SIMPLIFY
		 (MFUNCTION-CALL
		   $CONS
		   (SIMPLIFY (MFUNCTION-CALL
			       $RESULTANT $EQNS (MARRAYREF $TEQNS $J) $V))
		   $SE))))
	   (SETQ $EQNS $SE))))
    (COND
      ($FLAG
	(LIST
	  '(MLIST)
	  (SIMPLIFY
	    (MFUNCTION-CALL
	      $RHS
	      (SIMPLIFY
		(MFUNCALL
		  '$EV
		  (SIMPLIFY
		    (MFUNCTION-CALL
		      $LAST
		      (SIMPLIFY
			(MFUNCTION-CALL $SOLVE (MARRAYREF $EQNS 1) $SV))))
		  '$EVAL))))))
      (T $EQNS)))
  '$TEQNS '$SV '$SE 0 '$FLAG '$DISPFLAG))

(compile-forms-to-compile-queue)