Trailing-Edge
-
PDP-10 Archives
-
decuslib20-02
-
decus/20-0039/mat11.l
There are 2 other files named mat11.l in the archive. Click here to see a list.
(DEFPROP COMMENT(LAMBDA(X)NIL)FEXPR)
(COMMENT THIS IS REALLY MAT12)
(COMMENT THIS IS THE MATRIX PACKAGE)
(SPECIAL VARNUM VARLIST *SP *COL *SH PRINVAR NUMPVAR *V EQSIGN *VARS *EQN *E)
(PROG () (SETQ HOLDBASE IBASE)
(SETQ IBASE (PLUS 4 4 )))
(MAPC (FUNCTION (LAMBDA (X)
(SET (CAR X)
(INTERN (LIST (CAR NIL)
(QUOTE PNAME)
(LIST (CDDR (LSH (CADR X) 35))))))))
(QUOTE ((*SP 40) (*TB 11) (*SH 43) (*COL 72)
(*CR 15)
(*LF 12)
(*VT 13)
(*FF 14)
(*CO 54)
(*PT 56)
(*LP 50)
(*RP 51)
(*SL 57)
(*AM 175)
(*RO 177))))
(SETQ IBASE HOLDBASE)
(DEFPROP MXADD (LAMBDA (X )
(PROG (MAT1 MAT2 Y VARLIST VARNUM L)
(COND((NULL X)(GO ZILCH)))
(SETQ X (MAPCAR (FUNCTION UNQUOTE )X))
SORT(COND
((NULL X)(GO SORTED))
((EQ(LEAD(CAR X))(Q MATRIX))(SETQ Y(CONS(CAR X)Y)))
((NOT(OR(NUMBERP(CAR X))(EQ(LEAD(CAR X))(Q EQUAL))(EQ(LEAD(CAR X))(Q LAMBDA))))
(SETQ L(CONS(CAR X)L)) )
(T(ERLIST(Q(ILLEGAL USE OF MXADD))))
)
(SETQ X(CDR X))
(GO SORT)
SORTED
(SETQ VARLIST L)
(SETQ Y(REVERSE Y))
ZILCH
(COND
((NULL Y)(ERLIST(Q(MXADD NEEDS AT LEAST ONE MATRIX ARGUMENT))))
((NULL(CDR Y))(RETURN(PROG()
(SETQ Y(CDAR Y))
(FIXVARL1 Y NIL)
(RETURN(CONS(Q MATRIX)(DISREPLIST1(REPLIST1 Y))))
))))
(SETQ MAT1 (CAR Y))
(SETQ MAT1 (CDR MAT1))
LOOP (SETQ Y (CDR Y))
(COND ((NULL Y ) (RETURN (CONS (Q MATRIX ) MAT1 ))))
(SETQ MAT2 (CAR Y))
(SETQ MAT1 (ADDMATRIX MAT1 (CDR MAT2)))
(GO LOOP)))
FEXPR)
(DEFPROP ADDMATRIX
(LAMBDA (X Y) (PROG (C D M)
(FIXVARL1 X Y)
(SETQ C (REPLIST1 X))
(SETQ D (REPLIST1 Y))
(SETQ M (ADDMATRIX1 C D))
(RETURN (DISREPLIST1 M))))
EXPR)
(DEFPROP ADDMATRIX1
(LAMBDA (X Y) (PROG (B C D E)
(COND ((NOT (AND (EQUAL (LENGTH X) (LENGTH Y))
(EQUAL (LENGTH (CAR X)) (LENGTH (CAR Y)))))
(ERLIST (Q (CANNOT ADD ))))) (SETQ B X)
(SETQ C Y)
LOOP (COND ((NULL B) (RETURN D)))
(SETQ E (ADDROWS (CAR B) (CAR C)))
(SETQ D (APPEND D (LIST E)))
(SETQ B (CDR B))
(SETQ C (CDR C))
(GO LOOP)))
EXPR)
(DEFPROP ADDROWS
(LAMBDA (X Y) (PROG (A B C G)
(SETQ A X)
(SETQ B Y)
LOOP (COND ((NULL A) (RETURN G)))
(SETQ C (PLUSF(COND((RATFUNP(CAR A))(REDUCEF(CAR A)))(T (CAR A))) (CAR B)))
(SETQ G (APPEND G (LIST C)))
(SETQ A (CDR A))
(SETQ B (CDR B))
(GO LOOP)))
EXPR)
(DEFPROP CHECK (LAMBDA ( X)
(COND ((OR (ATOM X) (NOT (EQ (CAR X) (Q MATRIX))))
(ERLIST (Q (NOT MATRIX))))
(T T)))
EXPR)
(DEFPROP MXCHARPOL (LAMBDA (X)
(PROG (MAT V VARLIST VARNUM)
(COND((NOT(EQ(LENGTH X)2))(ERLIST(Q(MXCHARPOL TAKES TWO ARGUMENTS)))))
(SETQ MAT (UNQUOTE(CAR X)))
(CHECK MAT)
(SETQ MAT (CDR MAT))
(COND ((NOT (SQUAREMATRIX MAT))
(ERLIST (Q (MATRIX MUST BE SQUARE )))))
(SETQ V(UNQUOTE(CADR X)))
(COND((NOT(LATOM V))(ERLIST(Q(SECOND ARGUMENT OF MXCHARPOL MUST BE A VARIABLE))))
((INN V MAT)(ERLIST(APPEND(Q(MXCHARPOL CONFUSED BY PRESENCE OF))
(CONS V(Q(IN MATRIX))))) ) )
(SETQ MAT (ADDMATRIX MAT
(DIAGMATRIX (LENGTH MAT) (LIST (Q MINUS) V) )))
(RETURN(EVAL(LIST(Q RATSIMP)(DETERMINANT1 MAT)V)))
))FEXPR)
(DEFPROP COEFS
(LAMBDA (EQN NUM) (PROG (ANS G)
(COND((RATFUNP EQN)(SETQ EQN(NUMERATORF EQN))))
LOOP (COND ((ZEROP NUM) (GO END)))
(COND ((NULL (CDR EQN)) (SETQ G NIL))
(T (SETQ G (MAKERANK VARNUM (CAR EQN)))))
(SETQ ANS (CONS G ANS))
(COND ((NULL (CDR EQN)) (SETQ EQN (CAR EQN)))
(T (SETQ EQN (CADR EQN))))
(SETQ NUM (SUB1 NUM))
(GO LOOP)
END (COND ((ZEROPF EQN) (SETQ EQN NIL))
(T (SETQ EQN (MAKERANK VARNUM EQN))))
(SETQ ANS (APPEND ANS (LIST EQN)))
(RETURN ANS)))
EXPR)
(DEFPROP MXCOL (LAMBDA (X)
(PROG ( ANS)
(SETQ X (MAPCAR (FUNCTION UNQUOTE) X))
(COND((NOT(AND(EQ(LENGTH X)2)(NUMBERP(CAR X))(GREATERP(CAR X)0)
(EQ(LEAD(CADR X))(Q MATRIX)) ))
(ERLIST(Q(ILLEGAL USE OF MXCOL))) ))
(SETQ ANS (NTHCOL (CDADR X) (CAR X)))
(COND((NULL ANS)(ERLIST(APPEND(Q(MATRIX HAS FEWER THAN))(LIST(CAR X)
(Q COLUMNS))))))
(RETURN (CONS (Q MATRIX) (TRANSPOSE (LIST ANS))))
))FEXPR)
(DEFPROP DELETE
(LAMBDA (A X) (COND ((NOT (MEMBER A X)) X)
((EQUAL A (CAR X)) (DELETE A (CDR X)))
(T (APPEND (LIST (CAR X)) (DELETE A (CDR X))))))
EXPR)
(DEFPROP DELETECOL
(LAMBDA (N X) (PROG (B C M G)
(SETQ M X)
LOOP (COND ((NULL M) (RETURN (REVERSE G))))
(SETQ B (CAR M))
(SETQ C (DELETEROW N B))
(SETQ G (CONS C G))
(SETQ M (CDR M))
(GO LOOP)))
EXPR)
(DEFPROP DELETEROW
(LAMBDA (I M) (COND ((EQUAL I 1) (CDR M))
(T (CONS (CAR M) (DELETEROW (SUB1 I) (CDR M))))))
EXPR)
(DEFPROP DET
(LAMBDA (M) (COND ((EQUAL (LENGTH M) 1) (CAAR M)) (T (DET1 M))))
EXPR)
(DEFPROP DET1
(LAMBDA (M) (PROG (B C D E N I K G)
(SETQ N 1)
(SETQ I (REP -1))
(SETQ C (CAR M))
LOOP (COND ((NULL C) (RETURN B)))
(SETQ D (CAR C))
(SETQ I (TIMESF (REP -1) I))
(SETQ E (MINOR 1 N M))
(SETQ K (DET E))
(SETQ G (TIMESF I (TIMESF K D)))
(COND ((NULL B) (SETQ B G)) (T (SETQ B (PLUSF B G))))
(SETQ N (ADD1 N))
(SETQ C (CDR C))
(GO LOOP)))
EXPR)
(DEFPROP MXDETERMINANT
(LAMBDA (L)
(PROG (MAT VARLIST VARNUM)
(COND((OR(NULL L)(CDR L))(ERLIST(Q(MXDTERMINANT TAKES ONE ARGUMENT)))))
(SETQ MAT (UNQUOTE (CAR L)))
(CHECK MAT)
(SETQ MAT(CDR MAT))
(COND((NOT(SQUAREMATRIX MAT))(ERLIST(Q (MATRIX NOT SQUARE)))))
(RETURN (DETERMINANT1 MAT))))
FEXPR)
(DEFPROP DETERMINANT1
(LAMBDA (X) (PROG (D M)
(FIXVARL X NIL)
(SETQ M (REPLIST1 X))
(SETQ D (DET M))
(RETURN (MIDFIX (SIMPSIMP (TRANS D))))))
EXPR)
(DEFPROP DIAGMATRIX (LAMBDA (N VAR)
(PROG (A B ANS ROW)
(SETQ A 0)
LOOP1 (SETQ A (ADD1 A))
(SETQ B 0)
(SETQ ROW NIL)
LOOP2 (SETQ B (ADD1 B))
(COND ((EQ A B) (SETQ ROW (APPEND ROW (LIST VAR))))
(T (SETQ ROW (APPEND ROW (LIST 0)))))
(COND ((NOT(EQ B N)) (GO LOOP2)))
(SETQ ANS (APPEND ANS (LIST ROW)))
(COND ((AND (EQ A N) (EQ B N) ) (RETURN ANS)))
(GO LOOP1)
))
EXPR)
(DEFPROP DISREPLIST
(LAMBDA (X) (PROG (A B C)
(SETQ A X)
LOOP (COND ((NULL A) (RETURN B)))
(SETQ C (CAR A))
(SETQ C (MIDFIX (SIMPSIMP (TRANS C))))
(SETQ B (APPEND B (LIST C)))
(SETQ A (CDR A))
(GO LOOP)))
EXPR)
(DEFPROP DISREPLIST1
(LAMBDA (X) (PROG (A B C)
(SETQ A X)
LOOP (COND ((NULL A) (RETURN B)))
(SETQ C (DISREPLIST (CAR A)))
(SETQ B (APPEND B (LIST C)))
(SETQ A (CDR A))
(GO LOOP)))
EXPR)
(DEFPROP DIVIDEROW
(LAMBDA (A R)
(PROG (ANS)
(COND ((AND (ATOM A) (NOT (NULL A))) (SETQ A (REP A))))
LOOP (COND ((NULL R) (RETURN ANS)))
(SETQ ANS (APPEND ANS (LIST (QUOTIENTF (CAR R) A))))
(SETQ R (CDR R))
(GO LOOP)))
EXPR)
(DEFPROP MXELEMENT (LAMBDA (X)
(PROG (MAT M N)
(COND((NOT(EQ(LENGTH X)3))(ERLIST(Q(MXELEMENT TAKES THREE ARGUMENTS))) ))
(SETQ X (MAPCAR (FUNCTION UNQUOTE ) X))
(CHECK (CAR X))
(SETQ MAT (CDAR X))
(SETQ M (CADR X))
(SETQ N (CADDR X))
(COND ((NOT (AND (NUMBERP M) (NUMBERP N)(GREATERP M 0)(GREATERP N 0)))
(ERLIST (Q (MXELEMENT NEEDS TWO POSITIVE INTEGERS))))
((OR (GREATERP M(LENGTH MAT)) (GREATERP N (LENGTH (CAR MAT))))
(ERLIST (Q (IMPOSSIBLE)))))
(RETURN (ELT N (ELT M MAT)))
))FEXPR)
(DEFPROP MXENTER
(LAMBDA (L)
(PROG (ELEMENT ROWS ROW COLLUMS COLUMN VECTOR MATRIX)
(COND ((OR (LESSP (LENGTH L) 2)
(GREATERP (LENGTH L) 2))
(ERLIST (QUOTE (MXENTER TAKES TWO ARGUMENTS)))))
(SETQ L(MAPCAR(FUNCTION UNQUOTE)L))
(SETQ ROWS (CAR L))
(SETQ COLLUMS (CADR L))
(COND((NOT(AND(NUMBERP ROWS)(GREATERP ROWS 0)(NUMBERP COLLUMS)(GREATERP COLLUMS 0)))
(ERLIST(Q(MXENTER NEEDS TWO POSITIVE INTEGERS))) ))
(SETQ MATRIX NIL)
(SETQ ROW 0)
(TERPRI)
OLOOP(SETQ ROW (ADD1 ROW))
(COND ((GREATERP ROW ROWS)
(TERPRI)
(RETURN (CONS (QUOTE MATRIX)
(REVERSE MATRIX)))))
(SETQ COLUMN 0)
(SETQ VECTOR NIL)
ILOOP(SETQ COLUMN (ADD1 COLUMN))
(COND ((GREATERP COLUMN COLLUMS)
(SETQ MATRIX (CONS (REVERSE VECTOR)
MATRIX))
(GO OLOOP)))
LOOP (PRINC (QUOTE ROW))
(PRINC *SP)
(PRINC ROW)
(PRINC *SP)
(PRINC (QUOTE COLUMN))
(PRINC *SP)
(PRINC COLUMN)
(PRINC *SP) (PRINC *COL)(PRINC *SP)(PRINC *SH)
(SETQ ELEMENT (ERRSET (SPT(UNQUOTE (PRE)))))
(COND ((OR(NULL ELEMENT)(NULL(CAR ELEMENT))) (GO LOOP)))
(SETQ ELEMENT (CAR ELEMENT))
(SETQ VECTOR (CONS ELEMENT VECTOR))
(TERPRI)
(GO ILOOP)))
FEXPR)
(DEFPROP FIXVAR
(LAMBDA (E V) (PROG (A B)
(SETQ VARLIST V)
(SETQ PRINVAR V)
(SETQ NUMPVAR (LENGTH V))
(SETQ A E)
LOOP (COND ((NULL A) (RETURN NIL)))
(SETQ B (CAR A))
(NEWVAR B)
(SETQ A (CDR A))
(GO LOOP)))
EXPR)
(DEFPROP FIXSIDES
(LAMBDA (E) (PROG (X RT LT B C)
(SETQ X E)
LOOP (COND ((NULL X) (RETURN B)))
(SETQ RT (CADDAR X)) (SETQ LT (CADAR X)) (SETQ C (ONESIDE RT LT))
(SETQ B (APPEND B (LIST C)))
(SETQ X (CDR X))
(GO LOOP)))
EXPR)
(DEFPROP FIXVARL
(LAMBDA (X Y)
(PROG2 (SETQ VARLIST NIL)(MAPC (FUNCTION NEWVAR)
(APPLY (FUNCTION APPEND) (APPEND X Y)))))
EXPR)
(DEFPROP FIXVARL1(LAMBDA(X Y)
(MAPC(FUNCTION NEWVAR)(APPLY(FUNCTION APPEND)(APPEND X Y)))
)EXPR)
(DEFPROP MXIDENT(LAMBDA(X)(PROG()
(COND((OR(NULL X)(CDR X))(ERLIST(Q(MXIDENT TAKES ONE ARGUMENT))) ))
(SETQ X(UNQUOTE(CAR X)))
(COND((NOT(AND(NUMBERP X)(GREATERP X 0)))
(ERLIST(Q(MXIDENT NEEDS A POSITIVE INTEGER))) ))
(RETURN(CONS(Q MATRIX)(DIAGMATRIX X 1)))
))FEXPR)
(DEFPROP MXINVERSE
(LAMBDA (X) (PROG (MAT VARLIST VARNUM)
(COND((NULL X)(ERLIST(Q(MXINVERSE TAKES AT LEAST ONE ARGUMENT))) ))
(SETQ MAT (UNQUOTE (CAR X)))
(CHECK MAT)
(COND((NOT(SQUAREMATRIX(CDR MAT)))(ERLIST(Q(MXINVERSE ACCEPTS ONLY SQUARE MATRICES)))))
(COND((NOT(EVAL(CONS(Q AND)(MAPCAR
(FUNCTION(LAMBDA(J)(NOT(MEMBER(LEAD J)(Q(EQUAL LAMBDA))))))
(SETQ X(MAPCAR(FUNCTION UNQUOTE)(CDR X)))
))))
(ERLIST(Q(ILLEGAL USE OF MXINVERSE)))
))
(SETQ VARLIST(REVERSE X))
(RETURN (CONS (QUOTE MATRIX ) (INVERSE (CDR MAT))))
)) FEXPR)
(DEFPROP INVERSE
(LAMBDA (X) (PROG (M L K)
(FIXVARL1 X NIL)
(SETQ K (REPLIST1 X))
(SETQ L (LENGTH X))
(COND ((NOT (EQ L (RANKMATRIX X))) (ERLIST (Q (SINGULAR)))))
(SETQ M (INVERT1 K))
(RETURN (DISREPLIST1 M))
)) EXPR)
(DEFPROP INVERT1
(LAMBDA (X) (PROG (M L R B G I J)
(SETQ M X)
(SETQ L (LENGTH X))
(SETQ I 1)
LOOP (COND ((NULL M) (GO L1)))
(SETQ R (CAR M))
(SETQ B (ONEN I L))
(SETQ B (APPEND R B))
(SETQ G (APPEND G (LIST B)))
(SETQ M (CDR M))
(SETQ I (ADD1 I))
(GO LOOP)
L1 (SETQ M (ROWRED G))
(SETQ J 1)
L2 (COND ((GREATERP J L) (RETURN M)))
(SETQ M (DELETECOL 1 M))
(SETQ J (ADD1 J))
(GO L2)))
EXPR)
(DEFPROP MAKEMATRIX
(LAMBDA (L) (COND ((NULL L) NIL) (T (APPEND (LIST (RCOEF (CAR L)))
(MAKEMATRIX (CDR L))))))
EXPR)
(DEFPROP MAKEZERO
(LAMBDA (I J X) (PROG (R K L M A B C D)
(SETQ R (NTH X I))
(SETQ K (ADD1 I))
(SETQ M X)
(SETQ L (LENGTH X))
L1 (COND ((GREATERP K L) (RETURN M)))
(SETQ A (NTH X K))
(SETQ B (NTH A J))
(SETQ C (TIMESROW B R))
(SETQ D (SUBROWS A C))
(SETQ M (REPLACEROW K D M))
(SETQ K (ADD1 K))
(GO L1)))
EXPR)
(DEFPROP MIDFIX (LAMBDA (L) (SPT(REMOVEDIFFERENCES L))) EXPR)
(DEFPROP MXMINOR (LAMBDA (X)
(PROG(ANS)
(COND((NOT(EQ(LENGTH X)3))(ERLIST(Q(MXMINOR TAKES THREE ARGUMENTS)))))
(SETQ X (MAPCAR (FUNCTION UNQUOTE) X))
(COND((NOT(AND(CHECK(CAR X))(NUMBERP(CADR X))(GREATERP(CADR X)0)
(NUMBERP(CADDR X))(GREATERP(CADDR X)0) ))
(ERLIST(Q(MXMINOR TAKES ONE MATRIX AND TWO POSITIVE INTEGERS))) ))
(COND((NOT(AND(SQUAREMATRIX(CDAR X))(GREATERP(LENGTH(CDAR X))1)))
(ERLIST(Q(MXMINOR ACCEPTS ONLY SQUARE MATRICES WITH MORE THAN ONE ROW AND COLUMN))) ))
(COND((GREATERP(CADR X)(LENGTH(CDAR X)))(ERLIST(LIST(Q ONLY)(LENGTH(CDAR X))(Q ROWS))))
((GREATERP(CADDR X)(LENGTH(CADAR X)))(ERLIST(LIST(Q ONLY)(LENGTH(CADAR X))(Q COLUMNS))))
)
(SETQ ANS (MINOR (CADR X) (CADDR X) (CDAR X)))
(RETURN (CONS (Q MATRIX) ANS))
))FEXPR)
(DEFPROP MINOR
(LAMBDA (I J M) (PROG (A B)
(SETQ A (DELETEROW I M))
(SETQ B (DELETECOL J A))
(RETURN B)))
EXPR)
(DEFPROP MOVELAST
(LAMBDA (X N)
(COND ((EQUAL N 1) (APPEND (CDR X) (LIST (CAR X))))
(T (APPEND (LIST (CAR X)) (MOVELAST (CDR X) (SUB1 N))))))
EXPR)
(DEFPROP NPART (LAMBDA (X N)
(COND ((ONEP N) X)
((LESSP N 1) NIL)
(T (NPART (CDR X ) (SUB1 N))))
)EXPR)
(DEFPROP MXMULT (LAMBDA (X )
(PROG (MAT1 MAT2 Y VARLIST VARNUM)
(COND((NULL X)(ERLIST(Q(MXMULT NEEDS AT LEAST ONE ARGUMENT)))))
(SETQ Y (MAPCAR (FUNCTION UNQUOTE )X))
(SETQ MAT1 (CAR Y))
LOOP (SETQ Y (CDR Y))
(COND ((NULL Y ) (RETURN MAT1 )))
(SETQ MAT2 (CAR Y))
(SETQ MAT1 (TIMEX0 MAT1 MAT2))
(GO LOOP)))
FEXPR)
(DEFPROP TIMEX0 (LAMBDA (X Y)
(PROG (U V )
(SETQ U (LEAD X))
(SETQ V (LEAD Y))
(COND
((OR(EQ U(Q EQUAL))(EQ U(QUOTE LAMBDA))(EQ V(Q EQUAL))(EQ V(Q LAMBDA)))
(ERLIST(Q(ARGUMENTS OF MXMULT CANNOT BE EQUATIONS OR FUNCTIONS))))
((AND(EQ U(Q MATRIX))(EQ V(Q MATRIX)))
(RETURN(CONS(Q MATRIX)(MULTIPLYMATRICES(CDR X)(CDR Y)))))
((EQ U(Q MATRIX))(RETURN(TIMEX1 Y X)))
((EQ V(Q MATRIX))(RETURN(TIMEX1 X Y)))
(T(RETURN(PROG()
(SETQ VARLIST NIL)
(NEWVAR X)
(NEWVAR Y)
(RETURN(MIDFIX(SIMPSIMP(TRANS(TIMESF(REP(BIN X))(REP(BIN Y))))))))))
)
)) EXPR)
(DEFPROP TIMEX1 (LAMBDA (X Y)
(PROG (A C)
L1 (FIXVARL (CDR Y)(LIST (LIST X)))
(SETQ X (REP(BIN X)))
(SETQ Y (REPLIST1 (CDR Y)))
LOOP (COND ((NULL Y) (RETURN (CONS (Q MATRIX ) (DISREPLIST1 C)))))
(SETQ A (CAR Y))
(SETQ C (APPEND C (LIST (TIMESROW X A))))
(SETQ Y (CDR Y))
(GO LOOP)
))EXPR)
(DEFPROP MULTIPLYMATRICES
(LAMBDA (X Y) (PROG ( M X1 Y1)
(COND ((NOT (EQUAL (LENGTH (CAR X)) (LENGTH Y )))
(ERLIST (Q (CANNOT MULTIPLY)))))
(FIXVARL X Y)
(SETQ X1 (REPLIST1 X))
(SETQ Y1 (REPLIST1 Y))
(SETQ M (MULTMAT X1 Y1))
(RETURN (DISREPLIST1 M))))
EXPR)
(DEFPROP MULTL
(LAMBDA (A B) (COND ((ZEROPF A) A)
(T (PLUSF (TIMESF (CAR A) (CAR B))
(MULTL (CDR A) (CDR B))))))
EXPR)
(DEFPROP MULTMAT
(LAMBDA (X Y)
(PROG (A ROW B C D E G M N)
(SETQ B (TRANSPOSE Y))
(SETQ D (LENGTH B))
(SETQ ROW (LENGTH X))
(SETQ N 1)
L1 (SETQ M 1)
(SETQ A (NTH X N))
(SETQ C NIL)
L2 (COND ((GREATERP M D) (GO L3)) ((GREATERP N ROW) (GO L3)))
(SETQ E (NTH B M))
(SETQ C (APPEND C (LIST (MULTL A E))))
(SETQ M (ADD1 M))
(GO L2)
L3 (COND ((GREATERP N ROW) (RETURN G)))
(SETQ N (ADD1 N))
(SETQ G (APPEND G (LIST C)))
(GO L1)))
EXPR)
(DEFPROP NTH
(LAMBDA (X N) (COND ((NULL X) NIL)
(T (CAR (NPART X N))))
)EXPR)
(DEFPROP NTHCOL
(LAMBDA (X N)
(COND((NULL X) NIL) ((GREATERP N (LENGTH (CAR X))) NIL) (T (NTHCOL1 X N))))
EXPR)
(DEFPROP NTHCOL1
(LAMBDA (X N) (COND ((NULL X) NIL)
((ZEROP N) NIL)
(T (CONS (NTH (CAR X) N) (NTHCOL1 (CDR X) N)))))
EXPR)
(DEFPROP ONEN
(LAMBDA (N L) (PROG (I G H)
(SETQ I 1)
LOOP (COND ((EQUAL I N) (GO L1))
((GREATERP I L) (RETURN (REVERSE G))))
(SETQ H (REP 0))
L2 (SETQ G (CONS H G))
(SETQ I (ADD1 I))
(GO LOOP)
L1 (SETQ H (REP 1))
(GO L2)))
EXPR)
(DEFPROP ONEROW (LAMBDA (X N) (DIVIDEROW (NTH X N) X)) EXPR)
(DEFPROP ONESIDE (LAMBDA (RT LT) (LIST (QUOTE DIFFERENCE) LT RT)) EXPR)
(DEFPROP MXPOWER (LAMBDA (X)
(PROG (N MAT Y VARLIST VARNUM)
(COND((NOT(EQ(LENGTH X)2))(ERLIST(Q(MXPOWER TAKES TWO ARGUMENTS)))))
(SETQ Y (MAPCAR (FUNCTION UNQUOTE ) X))
(CHECK (CAR Y))
(SETQ X (CADR Y))
(SETQ MAT (CDAR Y))
(COND ((AND (NUMBERP X) (GREATERP X 0))
(SETQ N 1))
(T (ERLIST (Q (SECOND ARGUMENT OF MXPOWER MUST BE A POSITIVE INTERGER)))))
(SETQ Y MAT)
LOOP (COND ((EQUAL N X) (RETURN (CONS (Q MATRIX) Y))))
(SETQ Y (MULTIPLYMATRICES Y MAT))
(SETQ N (ADD1 N ))
(GO LOOP)
))FEXPR)
(DEFPROP RANKM (LAMBDA (X)
(PROG (R)
(SETQ R (LENGTH X))
LOOP(COND ((NULL X) (RETURN R)))
(COND ((ZEROLIST (CAR X)) (SETQ R (SUB1 R)))) (SETQ X (CDR X)) (GO LOOP)
))EXPR)
(DEFPROP MXRANK (LAMBDA (X)(PROG(VARLIST VARNUM)
(COND((OR(NULL X)(CDR X))(ERLIST(Q(MXRANK TAKES ONE ARGUMENT)))))
(SETQ X(UNQUOTE(CAR X)))
(CHECK X)
(RETURN(RANKMATRIX (CDR X)))
))FEXPR)
(DEFPROP RANKMATRIX
(LAMBDA (X) (PROG (B)
(FIXVARL1 X NIL)
(SETQ B (REPLIST1 X))
(SETQ B (DISREPLIST1 (ROWRED B)))
(RETURN (RANKM B))))
EXPR)
(DEFPROP RCOEF (LAMBDA (EQN) (COEFS (REP EQN) NUMPVAR)) EXPR)
(DEFPROP REMOVEDIFFERENCES
(LAMBDA (EXP)
(COND ((ATOM EXP) EXP)
((EQUAL (CAR EXP) (QUOTE DIFFERENCE))
(LIST (QUOTE PLUS)
(REMOVEDIFFERENCES (CADR EXP))
(LIST (QUOTE MINUS)
(REMOVEDIFFERENCES (CADDR EXP)))))
(T (MAPCAR (FUNCTION REMOVEDIFFERENCES)
EXP))))
EXPR)
(DEFPROP REPLACEROW
(LAMBDA (I Y X) (COND ((EQUAL I 1) (APPEND (LIST Y) (CDR X)))
(T (APPEND (LIST (CAR X))
(REPLACEROW (SUB1 I) Y (CDR X))))))
EXPR)
(DEFPROP REPLIST
(LAMBDA (X) (PROG (A B C)
(SETQ A X)
LOOP (COND ((NULL A) (RETURN B)))
(SETQ C (CAR A))
(SETQ C (REP(BIN C)))
(SETQ B (APPEND B (LIST C)))
(SETQ A (CDR A))
(GO LOOP)))
EXPR)
(DEFPROP REPLIST1
(LAMBDA (X) (PROG (A B G)
(SETQ A X)
LOOP (COND ((NULL A) (RETURN G)))
(SETQ B (CAR A))
(SETQ G (APPEND G (LIST (REPLIST B))))
(SETQ A (CDR A))
(GO LOOP)))
EXPR)
(DEFPROP ROWRED
(LAMBDA (X)
(PROG (I J L M A Y)
(SETQ X (ECHELON1 X))
(SETQ L (LENGTH X))
(SETQ Y (LENGTH (CAR X)))
(SETQ I 2)
(SETQ J 2)
(SETQ M X)
L1 (COND ((OR (GREATERP I L) (GREATERP J Y)) (RETURN M)))
(SETQ A (NTH M I))
(COND ((ZEROPF (NTH A J)) (GO L7)) (T (GO L3)))
L3 (SETQ M (UPZERO I J M))
(SETQ I (ADD1 I))
(SETQ J (ADD1 J))
(GO L1)
L7 (SETQ J (ADD1 J))
(GO L1)))
EXPR)
(DEFPROP ROWREDUCE
(LAMBDA (X) (PROG (M)
(FIXVARL X NIL) (SETQ M (ROWRED (REPLIST1 X)))
(RETURN (DISREPLIST1 M))))
EXPR)
(DEFPROP MXROW (LAMBDA (X)
(PROG (ANS)
(SETQ X (MAPCAR (FUNCTION UNQUOTE) X))
(COND((NOT(AND(EQ(LENGTH X)2)(NUMBERP(CAR X))(GREATERP(CAR X)0)
(CHECK(CADR X))(NOT(LESSP(LENGTH(CDADR X))(CAR X)))))
(ERLIST(Q(ILLEGAL USE OF MXROW))) ))
(SETQ ANS (NTH (CDADR X) (CAR X)))
(RETURN (CONS (Q MATRIX ) (LIST ANS)))
))FEXPR)
(DEFPROP MXELSET (LAMBDA (X)(PROG()
(SETQ X(MAPCAR(FUNCTION UNQUOTE)X))
(COND((NOT(AND(EQ(LENGTH X)4)(NOT(MEMBER(LEAD(CAR X))(Q(LAMBDA EQUAL MATRIX))))
(NUMBERP(CADR X))(GREATERP(CADR X)0)(NUMBERP(CADDR X))(GREATERP(CADDR X)0)(CHECK(CADDDR X))
(NOT(LESSP(LENGTH(CDR(CADDDR X)))(CADR X))) ))
(ERLIST(Q(ILLEGAL USE OF MXELSET))) ))
(RETURN(CONS (Q MATRIX) (SETELM1 (CAR X) (CADR X)
(CADDR X) (CDR (CADDDR X)))))))FEXPR)
(DEFPROP SETELM1 (LAMBDA (E M N X)
(PROG (A B C D COUNT)
LOOP (SETQ C (CDR(NPART(REVERSE X) (DIFFERENCE (LENGTH X) (SUB1 M)))))
(SETQ D (NPART X M))
(COND((NULL D)(ERLIST(LIST(Q FEWER)(Q THAN) N (Q COLUMNS)))))
(COND ((ONEP COUNT) (GO OUT)))
(SETQ A (REVERSE C))
(SETQ B (CDR D))
(SETQ X (CAR D))
(SETQ COUNT 1)
(SETQ M N)
(GO LOOP)
OUT (RETURN (APPEND A (CONS (APPEND (REVERSE C) (CONS E (CDR D))) B )))
))EXPR)
(DEFPROP SIMSOLVE (LAMBDA (X)
(PROG( *V ANS E VARNUM VARLIST PRINVAR NUMPVAR)
(COND((OR(NULL X)(NULL(CDR X)))(ERLIST(Q(SIMSOLVE NEEDS AT LEAST TWO ARGUMENTS)))))
(SETQ X (MAPCAR (FUNCTION UNQUOTE) X))
LOOP (COND((NULL X)(GO L1)))
(COND ((LATOM (CAR X)) (SETQ *V (APPEND *V (LIST (CAR X)))))
((EQ(LEAD(CAR X))(Q EQUAL))
(SETQ E(CONS(CAR X)E)))
(T(ERLIST(Q(ARGUMENTS OF SIMSOLVE MUST BE VARIABLES OR EQUATIONS)))) )
(SETQ X (CDR X))
(GO LOOP)
L1 (COND((NULL E)(ERLIST(Q(SIMSOLVE NEEDS AT LEAST ONE EQUATION))))
((NULL *V)(ERLIST(Q(SIMSOLVE NEEDS AT LEAST ONE SOLVEE VARIABLE))))
((NOT(EVAL(CONS(QUOTE AND)(MAPCAR(FUNCTION(LAMBDA(J)
(INVOLVEP J *V)))E))))
(ERLIST(Q(EACH SIMSOLVE EQUATION MUST CONTAIN AT LEAST
ONE SOLVEE VARIABLE))))
((NOT(EVAL(CONS(Q AND)(MAPCAR(FUNCTION(LAMBDA(J)(LINEQP2 J *V)))E))))
(ERLIST(Q(NON-LINEAR EQUATION FOR SIMSOLVE))) ))
(SETQ ANS (SOLVEM (REVERSE E) *V))
L2 (COND ((AND (ATOM (CAR ANS)) (NULL (CADR ANS )) (CADDR ANS))
(PROG2 (MLABSET (CAR ANS) (CADDR ANS) NIL)
(REPEAT1 (LIST (Q SETQ) (CAR ANS) (MGET (CAR ANS)))))) (T (ERLIST (Q (ILLEGAL ANSWER OBTAINED)))))
(SETQ ANS (CDDDR ANS))
(COND ((NULL ANS)(RETURN(PROG2(PRINT(Q FINISHED))(TERPRI NIL))) ))
(GO L2)
))FEXPR)
(DEFPROP INVOLVEP(LAMBDA(*E V)(EVAL(CONS(Q OR)
(MAPCAR(FUNCTION(LAMBDA(J)(OR(INN J(CADR *E))(INN J(CADDR *E)))))V))))EXPR)
(DEFPROP LINEQP2(LAMBDA(E V)(AND(LINEQP(CADR E)V)(LINEQP(CADDR E)V)))EXPR)
(DEFPROP SOLVEM
(LAMBDA (E V)
(PROG (A M Z G Q S ANS V1)
(SETQ A (FIXSIDES E))
(FIXVAR A V)
(SETQ M (MAKEMATRIX A))
(SETQ M (ROWRED M))
(SETQ Z (DISREPLIST1 M))
(COND ((EQUAL (RANKM Z) (RANKM (DELETECOL (ADD1 NUMPVAR) Z))) (GO L1))
(T (ERLIST (QUOTE (INCONSISTENT EQUATIONS)))))
L1 (SETQ V1 (APPEND (REPLIST V) (LIST 1)))
L4 (COND ((OR (NULL M) (NULL (CAR M))) (RETURN ANS)))
(SETQ Q (CAR M))
(SETQ G (CAR Q))
L3 (COND ((ZEROPF G) (GO L2)))
(SETQ
ANS
(APPEND ANS
(LIST (MIDFIX (SIMPSIMP (TRANS (TIMESF G (CAR V1)))))
EQSIGN
(MIDFIX (SIMPSIMP (TRANS (MINUSF (MULTL (CDR Q)
(CDR V1)))))))))
(SETQ M (DELETECOL 1 (CDR M)))
(SETQ V1 (CDR V1))
(GO L4)
L2 (SETQ M (DELETECOL 1 M))
(SETQ Q (CDR Q))
(SETQ V1 (CDR V1))
(GO L4)))
EXPR)
(DEFPROP LINEQP(LAMBDA(EQN VARS)(LESSP(LINEQP1 EQN VARS)2))EXPR)
(DEFPROP LINEQP1(LAMBDA(*EQN *VARS)(COND
((NULL *EQN)0)
((ATOM *EQN)(COND((MEMBER *EQN *VARS)1)
(T 0)
) )
((EQ(CAR *EQN)(Q MINUS))(LINEQP1(CADR *EQN)*VARS))
((EQ(CAR *EQN)(Q DIFFERENCE))(MAX(LINEQP1(CADR *EQN)*VARS)(LINEQP1(CADDR *EQN)*VARS)))
((EQ(CAR *EQN)(Q PLUS))(EVAL(CONS(Q MAXL)(MAPCAR(FUNCTION(LAMBDA(J)(LINEQP1 J *VARS))) (CDR *EQN) ))))
((EQ(CAR *EQN)(Q TIMES))
(EVAL(CONS(Q PLUS)(MAPCAR(FUNCTION(LAMBDA(J)(LINEQP1 J *VARS)))
(CDR *EQN) ))))
((EQ(CAR *EQN)(Q QUOTIENT))
(COND((EVAL(CONS(Q OR)(MAPCAR(FUNCTION(LAMBDA(J)(INN J(CADDR *EQN))))
*VARS )))2)
(T(LINEQP1(CADR *EQN)*VARS))
))
(T(COND((EVAL(CONS(Q OR)(MAPCAR(FUNCTION(LAMBDA(J)(INN J(CDR *EQN))))*VARS)))
2)
(T 0)
) )
))EXPR)
(DEFPROP SQUAREMATRIX
(LAMBDA (X) (COND ((EQUAL (LENGTH X) (LENGTH (CAR X))) T) (T NIL)))
EXPR)
(DEFPROP SUBROWS (LAMBDA (A B) (ADDROWS A (TIMESROW -1 B))) EXPR)
(DEFPROP SWTH (LAMBDA (X N M)
(PROG(D)
(SETQ D (NTH X M))
(SETQ X(SETELM1 (NTH X N) 1 M (LIST X)))
(RETURN(CAR (SETELM1 D 1 N X)))))EXPR)
(DEFPROP TIMESROW
(LAMBDA (Y ROW)
(PROG (ANS)
(COND ((AND (ATOM Y) (NOT (NULL Y))) (SETQ Y (REP Y))))
LOOP (COND ((NULL ROW) (RETURN ANS)))
(SETQ ANS (APPEND ANS (LIST (TIMESF Y (CAR ROW)))))
(SETQ ROW (CDR ROW))
(GO LOOP)))
EXPR)
(DEFPROP MXTRANSPOSE (LAMBDA (X)
(PROG (MAT)
(COND((OR(NULL X)(CDR X))(ERLIST(Q(MXTRANSPOSE TAKES ONE ARGUMENT)))))
(SETQ MAT (UNQUOTE (CAR X)))
(CHECK MAT)
(RETURN (CONS (QUOTE MATRIX) (TRANSPOSE (CDR MAT))))))
FEXPR)
(DEFPROP TRANSPOSE
(LAMBDA (M) (PROG (A B N C)
(SETQ C (LENGTH (CAR M)))
(SETQ N 1)
LOOP (COND ((GREATERP N C) (RETURN B)))
(SETQ A (LIST (NTHCOL M N)))
(SETQ B (APPEND B A))
(SETQ N (ADD1 N))
(GO LOOP)))
EXPR)
(DEFPROP MXECHELON(LAMBDA (X)(PROG(MAT VARLIST VARNUM)
(COND((NULL X)(ERLIST(Q(MXECHELON TAKES AT LEAST ONE ARGUMENT)))))
(SETQ MAT(UNQUOTE(CAR X)))
(CHECK MAT)
(COND((NOT(EVAL(CONS(Q AND)(MAPCAR
(FUNCTION(LAMBDA(J)(NOT(MEMBER(LEAD J)(Q(EQUAL LAMBDA))))))
(SETQ X(MAPCAR(FUNCTION UNQUOTE)(CDR X)))
))))
(ERLIST(Q(ILLEGAL USE OF MXECHELON)))
))
(SETQ VARLIST(REVERSE X))
(RETURN(CONS (Q MATRIX) (DISREPLIST1 (ECHELON1 (PROG2(FIXVARL1 (SETQ MAT (CDR MAT))NIL) (REPLIST1 MAT))))))
))FEXPR)
(DEFPROP ECHELON1
(LAMBDA (X)
(PROG (L I J M K B C A Y)
(SETQ L (LENGTH X))
(SETQ Y (LENGTH (CAR X)))
(SETQ I 1)
(SETQ J 1)
(SETQ M X)
L1 (COND ((OR (GREATERP I L) (GREATERP J Y)) (RETURN M)))
(SETQ A (NTH M I))
(COND ((ZEROPF (NTH A J)) (GO L7)) (T (GO L3)))
L7 (SETQ B M)
(SETQ K 1)
L2 (COND ((GREATERP K I) (GO L4)))
(SETQ B (DELETEROW 1 B))
(SETQ K (ADD1 K))
(GO L2)
L4 (SETQ B (NTHCOL B J))
(SETQ B (DELETE (NTH A J) B))
(COND ((NULL B) (GO L5)) (T (GO L6)))
L5 (SETQ J (ADD1 J))
(GO L1)
L6 (SETQ M (MOVELAST M I))
(GO L1)
L3 (SETQ C (ONEROW A J))
(SETQ M (REPLACEROW I C M))
(SETQ M (MAKEZERO I J M))
(SETQ I (ADD1 I))
(SETQ J (ADD1 J))
(GO L1)))
EXPR)
(DEFPROP UPZERO
(LAMBDA (I J X) (PROG (R K A B C D M)
(SETQ R (NTH X I))
(SETQ K (SUB1 I))
(SETQ M X)
L1 (COND ((ZEROP K) (RETURN M)))
(SETQ A (NTH X K))
(SETQ B (NTH A J))
(SETQ C (TIMESROW B R))
(SETQ D (SUBROWS A C))
(SETQ M (REPLACEROW K D M))
(SETQ K (SUB1 K))
(GO L1)))
EXPR)
(DEFPROP ZEROLIST
(LAMBDA (X) (COND ((NULL (DELETE NIL (DELETE 0 X))) T) (T NIL)))
EXPR)
(DEFPROP MXTRACE(LAMBDA(X)(PROG(DIAG VAL VARLIST VARNUM)
(COND((OR(NULL X)(CDR X))(ERLIST(Q(MXTRACE TAKES ONE ARGUMENT)))))
(CHECK(SETQ X(UNQUOTE(CAR X))))
(COND((NOT(SQUAREMATRIX(SETQ X(CDR X))))(ERLIST(Q(MXTRACE REQUIRES SQUARE MATRICES)))))
LOOP (COND((NULL X)(GO OUT)))
(SETQ DIAG(CONS(CAAR X)DIAG))
(SETQ X(MAPCAR(FUNCTION CDR)(CDR X)))
(GO LOOP)
OUT (MAPC(FUNCTION NEWVAR)DIAG)
(SETQ DIAG(MAPCAR(FUNCTION(LAMBDA(J)(REP(BIN J))))DIAG))
(COND((NULL VARLIST)(SETQ VAL 0)))
PLUSLOOP (COND((NULL DIAG)(GO REALLYOUT)))
(SETQ VAL(PLUSF(CAR DIAG)VAL))
(SETQ DIAG(CDR DIAG))
(GO PLUSLOOP)
REALLYOUT (RETURN(MIDFIX(SIMPSIMP(TRANS VAL))))
))FEXPR)
(MAPC(FUNCTION (LAMBDA (X)
(PROG2 (PUTPROP X T (Q INTCOM)) (PUTPROP X T (Q SACRED)))))(Q(MXADD MXCHARPOL MXCOL MXDETERMINANT MXELEMENT MXENTER MXIDENT
MXINVERSE MXMINOR MXCMULT MXMULT MXPOWER MXRANK MXROW MXELSET
SIMSOLVE MXTRANSPOSE MXECHELON MXTRACE)))