Artifact 3d16ce7f6e04f443749cfc660511ca8e6d32559aa3a223d7d4ef00c7fc628b43:
- Executable file
reduce2/reduce2.os_source.s.2
— part of check-in
[1b32ca91d4]
at
2017-03-19 16:31:19
on branch master
— Reduce2 and associated material retrieved from softwarepreservation.org
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@3962 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 459675) [annotate] [blame] [check-ins using] [more...]
00000010 OPEN (COMPILE SYSFILE INPUT) RESTORE (COMPILE) CLOSE (COMPILE) 00000020 00000030 00000040 DEFLIST (((COMMENT (LAMBDA (U A) NIL))) FEXPR) 00000050 00000051 COMMENT (***** DATE OF LAST SYSTEM UPDATE *****) 00000052 00000053 DEFLIST (((DATE* ( 00000054 00000055 $$$15-SEP-72$ 00000056 00000057 ))) SPECIAL) 00000058 00000059 COMMENT (THE FOLLOWING COMMANDS ARE USED BY THE COMPILER) 00000060 00000061 OPTIMIZE (T) BPSUSED (T) 00000062 00000063 COMMENT((R E D U C E P R E P R O C E S S O R F O R L I S P /360))00000090 00000100 OVOFF NIL 00000110 00000120 COMMENT ((REDUCE CONVERTOR)) 00000130 00000140 REMPROP (DEFINE SUBR) 00000150 00000160 SPECIAL ((NOCMP*)) 00000170 00000180 (LAMBDA (U) (COMPILE (DEFLIST U (QUOTE EXPR)))) (( 00000190 00000200 (DEFINE (LAMBDA (U) 00000210 (DEF1 U (QUOTE EXPR)))) 00000220 00000230 (DEF1 (LAMBDA (U V) 00000240 (PROG (X Y) 00000250 A (COND ((NULL U) (RETURN Y)) 00000260 ((FLAGP (SETQ X (CAAR U)) (QUOTE LOSE)) (GO B)) 00000270 ((GETD (SETQ X (TRANS X NIL))) 00000280 (PRINT (LIST (QUOTE *****) X (QUOTE REDEFINED))))) 00000290 (SETQ Y (NCONC Y (LIST X))) 00000300 (COND (NOCMP* (DEFLIST (LIST (TRANS (CAR U) T)) V)) 00000310 ((EQ V (QUOTE EXPR)) 00000320 (COM1 X (TRANS (CADAR U) NIL) NIL)) 00000330 (T (COM1 X NIL (TRANS (CADAR U) NIL)))) 00000340 B (SETQ U (CDR U)) (GO A)))) 00000350 00000360 (TRANS (LAMBDA (U V) 00000370 (COND ((NULL U) NIL) 00000380 ((ATOM U) (COND ((NUMBERP U) U) 00000390 (T 00000400 ((LAMBDA(X) 00000410 (COND (X 00000420 (LIST 00000430 (QUOTE QUOTE) 00000440 X)) 00000450 (T ((LAMBDA (Y) 00000460 (COND (Y Y) 00000470 ((AND NOCMP* (GET U (QUOTE SPECIAL))) 00000480 (LIST (QUOTE GTS) (LIST (QUOTE QUOTE) U))) 00000490 (T U))) 00000500 (GET U (QUOTE NEWNAM)))))) 00000510 (GET U (QUOTE CONSTANT)))))) 00000520 ((ATOM (CAR U)) 00000530 (COND ((EQ (CAR U) (QUOTE QUOTE)) U) 00000540 ((NUMBERP (CAR U)) 00000550 (CONS (CAR U) (MAPTR (CDR U)))) 00000560 ((AND NOCMP* (EQ (CAR U) (QUOTE SETQ)) 00000570 (GET (CADR U) (QUOTE SPECIAL))) 00000580 (LIST (QUOTE PTS) (LIST (QUOTE QUOTE) (CADR U)) (TRANS 00000590 (CADDR U) V))) 00000600 (T 00000610 ((LAMBDA(X) 00000620 (COND (X 00000630 (SUBLIS 00000640 (PAIR (CADR X) (MAPTR (CDR U) V)) 00000650 (CADDR X))) 00000660 (T (CONS ((LAMBDA (Y) 00000670 (COND (Y Y) 00000680 (T ((LAMBDA (Z) 00000690 (COND (Z(LIST (QUOTE QUOTE)00000700 Z)) 00000710 (T (TRANS (CAR U) V)))) 00000720 (GET(CAR U) (QUOTE CONSTANT))))))00000730 (GET (CAR U) (QUOTE NEWNAM))) 00000740 (MAPTR (CDR U) V))))) 00000750 (GET (CAR U) (QUOTE NEWFORM)))))) 00000760 (T (MAPTR U V))))) 00000770 00000780 (MAPTR (LAMBDA (U V) 00000790 (COND ((ATOM U) (TRANS U V)) 00000800 (T (CONS (TRANS (CAR U) V) (MAPTR (CDR U) V)))))) 00000810 00000820 (GETD(LAMBDA(U) 00000830 (OR (GET U (QUOTE EXPR)) 00000840 (GET U (QUOTE FEXPR)) 00000850 (GET U (QUOTE SUBR)) 00000860 (GET U (QUOTE FSUBR)) 00000870 (GET U (QUOTE MACRO))))) 00000880 00000890 )) 00000900 00000910 (LAMBDA NIL (PROG NIL (DEFLIST (LIST (LIST (QUOTE CONVRT) 00000912 (GET (QUOTE TRANS) (QUOTE SUBR)))) (QUOTE SUBR)))) NIL 00000914 00000916 (LAMBDA (U) (DEFLIST U (QUOTE EXPR))) (( 00000920 00000930 (CONSTANT (LAMBDA (U) 00000940 (DEFLIST U (QUOTE CONSTANT)))) 00000950 00000960 (LOSE (LAMBDA (U) 00000970 (FLAG U (QUOTE LOSE)))) 00000980 00000990 (NEWFORM (LAMBDA (U) 00001000 (DEFLIST U (QUOTE NEWFORM)))) 00001010 00001020 (NEWNAM (LAMBDA (U) 00001030 (DEFLIST U (QUOTE NEWNAM)))) 00001040 00001050 )) 00001060 00001070 00001080 (LAMBDA (U) (COMPILE (DEFLIST U (QUOTE EXPR)))) (( 00001090 00001100 (SUBLIS (LAMBDA (U V) (COND 00001110 ((NULL U) V) 00001120 (T ((LAMBDA (X) (COND 00001130 (X (CDR X)) 00001140 ((ATOM V) V) 00001150 (T (CONS (SUBLIS U (CAR V)) (SUBLIS U (CDR V)))))) 00001160 (SASSOC V U (FUNCTION (LAMBDA NIL NIL)))))))) 00001170 )) 00001180 00001190 CONSTANT (( 00001200 (**BLANK $$$ $) 00001210 (**COMMA $$$,$) 00001220 (**DOLLAR $$/$/) 00001230 (**ESC ESC) 00001240 (**LPAR $$$($) 00001250 (**MILLION 1000000) 00001260 (**DASH $$$-$) 00001270 (**DOT $$$.$) 00001280 (**RPAR $$$)$) 00001290 (**SEMICOL $$$;$) 00001300 (**STAR $$$*$) 00001310 (**EMARK $$/$/) 00001320 (**FMARK $$$&$) 00001330 (**QMARK $$$'$) 00001340 (**SMARK $$$"$) 00001350 (**XMARK $$$!$) 00001360 (**EOF EOF) 00001370 (**PLUSS $$$+$) 00001380 (**ENDMSG $$$LEAVING REDUCE ...$) 00001390 )) 00001400 00001410 NEWNAM (( 00001420 (DIGIT DIGP) 00001430 (EVENP *EVENP) 00001440 (EXPLODE *EXPLODE) 00001450 (LITER LETP) 00001460 (OPEN *OPEN) 00001470 (PAIR PAIRX) 00001471 (PAUSE TERPRI) 00001472 (PRINC PRIN1) 00001480 (RDS *RDS) 00001500 (SPACES XTAB) 00001510 (WRS *WRS) 00001520 )) 00001530 00001540 00001550 NEWFORM (( 00001560 (*APPLY (LAMBDA (U V) (APPLY U V ALIST))) 00001570 (CAAAAR (LAMBDA (U) (CAAR (CAAR U)))) 00001580 (CAAADR (LAMBDA (U) (CAAR (CADR U)))) 00001590 (CAADAR (LAMBDA (U) (CAAR (CDAR U)))) 00001600 (CAADDR (LAMBDA (U) (CAAR (CDDR U)))) 00001610 (CADAAR (LAMBDA (U) (CADR (CAAR U)))) 00001620 (CADADR (LAMBDA (U) (CADR (CADR U)))) 00001630 (CADDAR (LAMBDA (U) (CADR (CDAR U)))) 00001640 (CADDDR (LAMBDA (U) (CADR (CDDR U)))) 00001650 (CDAAAR (LAMBDA (U) (CDAR (CAAR U)))) 00001660 (CDAADR (LAMBDA (U) (CDAR (CADR U)))) 00001670 (CDADAR (LAMBDA (U) (CDAR (CDAR U)))) 00001680 (CDDAAR (LAMBDA (U) (CDDR (CAAR U)))) 00001690 (CDDADR (LAMBDA (U) (CDDR (CADR U)))) 00001700 (CDDDAR (LAMBDA (U) (CDDR (CDAR U)))) 00001710 (CDDDDR (LAMBDA (U) (CDDR (CDDR U)))) 00001720 (DIVIDE (LAMBDA (U V) (CONS (QUOTIENT U V) (REMAINDER U V)))) 00001730 (ERRORSET (LAMBDA (U V) (LIST (*EVAL U)))) 00001740 (GENSYM (LAMBDA NIL (GENSYM1 (QUOTE $$$ G$)))) 00001750 (ONEP (LAMBDA (N) (EQUAL N 1))) 00001760 (READCH (LAMBDA NIL (READCH NIL))) 00001770 )) 00001780 00001790 00001800 00001810 COMMENT ((DECLARATION OF SPECIAL AND GLOBAL VARIABLES)) 00001820 00001830 COMMENT ((THE FOLLOWING ARE EXTENDED SPECIAL VARIABLES)) 00001840 00001850 SPECIAL ((*S* *S1*)) 00001860 00001870 COMMENT ((THE FOLLOWING VARIABLES ARE GLOBAL TO ALL FUNCTIONS)) 00001880 00001890 SPECIAL(( 00001900 IFL* OFL* IPL* OPL* PRI* CRCHAR* SV* MCOND* 00001910 *FORT *ECHO *INT PRECLIS* ORIG* POSN* *NAT YCOORD* 00001920 YMIN* YMAX* *LIST COUNT* *CARDNO ECHO* FORTVAR* 00001930 LLENGTH* PLINE* CURSYM* *MODE MATP* DEFN* 00001940 SEMIC* SYMFG* VARS* TMODE* *SQVAR* PROGRAM* PROGRAML* 00001950 *GCD *EXP *MCD *FLOAT MATCH* *DIV *RAT *SUPER *MSG 00001960 *ALLFAC *NCMP SUBFG* FRLIS1* FRLIS* GAMIDEN* SUB2* 00001970 RPLIS* SUBL* DSUBL* FACTORS* FRASC* VREP* INDICES* 00001980 WTP* SNO* *RAT *OUTP DIAG* 00001990 MCHFG* SYMFG* *ANS *RESUBS *NERO EXLIST* ORDN* 00002000 NAT** 00002001 )) 00002010 00002020 COMMENT ((THE FOLLOWING VARIABLE IS USED AS A FUNCTIONAL ARGUMENT)) 00002030 00002040 COMMON ((*PI*)) 00002050 00002060 REMPROP (F APVAL) 00002070 00002080 00002090 COMMENT ((REDUCE FUNCTIONS WITH SYSTEM DEPENDENT PROPERTIES)) 00002100 00002110 DEFLIST (( 00002120 00002130 (INIT (LAMBDA NIL (PROG NIL 00002140 (PTS (QUOTE NOCMP*) T) 00002150 (RECLAIM) 00002160 (OPEN (QUOTE REDUCE) (QUOTE SYSFILE) (QUOTE OUTPUT)) 00002170 (REMPROP (QUOTE INIT) (QUOTE EXPR)) 00002200 (RETURN (QUOTE ***))))) 00002210 00002220 ) EXPR) 00002230 00002240 (LAMBDA (U) (COMPILE (DEFLIST U (QUOTE EXPR)))) (( 00002250 00002260 (MKSTRING (LAMBDA (U) 00002270 (LIST (QUOTE QUOTE)(COMPRESS (DELETE (QUOTE $$$"$) (CDR U)))))) 00002280 00002281 (PRINTTY (LAMBDA (U) 00002282 (AND *NAT (PRINT U)))) 00002283 00002290 (READCH* (LAMBDA NIL 00002300 (SETQ CRCHAR* (READCH NIL)))) 00002310 00002320 )) 00002330 00002340 (LAMBDA (U) (COMPILE (DEFLIST U (QUOTE EXPR)))) (( 00002390 00002400 (BEGIN (LAMBDA NIL (PROG NIL 00002410 (OVOFF) 00002420 (SETQ NOCMP* T) 00002430 (SETQ *INT NIL) 00002440 (SETQ *ECHO T) 00002450 (SETQ ORIG* 0) 00002460 (SETP) 00002470 (SETQ *MODE (QUOTE ALGEBRAIC)) 00002480 (COND ((NULL DATE*) (GO A0))) 00002490 (VERBOS NIL) 00002500 (EXCISE T) 00002510 (EXITERR T) 00002520 (EJECT) 00002521 (PRIN1 (QUOTE $$$REDUCE2($)) 00002522 (PRIN1 DATE*) 00002523 (PRIN1 (QUOTE $$$) ...$)) 00002524 (TERPRI) (SETQ DATE* NIL) 00002525 A0 (SETQ IFL* NIL) 00002540 (SETQ OFL* NIL) 00002550 (RETURN (BEGIN1))))) 00002570 00002580 )) 00002590 00002600 00002610 COMMENT ((REDUCE FUNCTIONS DEFINED IN TERMS OF SYSTEM FUNCTIONS 00002620 OF THE SAME NAME)) 00002630 00002640 COMMENT ((THE FOLLOWING LIST IS USED BY EXPLODN1 DEFINED BELOW)) 00002650 00002660 DEFLIST (((NASL* (((0 . $$$0$) (1 . $$$1$) (2 . $$$2$) (3 . $$$3$) 00002670 (4 . $$$4$) (5 . $$$5$) (6 . $$$6$) (7 . $$$7$) 00002680 (8 . $$$8$) (9 . $$$9$))))) SPECIAL) 00002690 00002700 DEFLIST (((BLKSIZE* (80))) SPECIAL) 00002701 00002702 (LAMBDA (U) (COMPILE (DEFLIST U (QUOTE EXPR)))) (( 00002710 00002720 (*EXPLODE (LAMBDA (U) (COND 00002730 ((NUMBERP U) (EXPLODN U)) 00002740 (T (EXPLODE U))))) 00002750 00002760 (EXPLODN (LAMBDA (U) (COND 00002770 ((ZEROP U) (LIST (QUOTE $$$0$))) 00002780 ((MINUSP U) (CONS (QUOTE $$$-$) (EXPLODN (MINUS U)))) 00002790 ((NOT (FIXP U)) (LIST 1 2 3 4 5 6 7 8 9 0 1 2)) 00002800 (T (EXPLODN1 U))))) 00002810 00002820 (EXPLODN1 (LAMBDA (U) (PROG (Z) 00002830 A (COND ((ZEROP U) (RETURN Z))) 00002840 (SETQ Z (CONS (CDR (ASSOC* (REMAINDER U 10) NASL*)) Z)) 00002850 (SETQ U (QUOTIENT U 10)) 00002860 (GO A)))) 00002870 00002880 (ASSOC* (LAMBDA (U V) 00002890 (COND ((NULL V) NIL) 00002900 ((EQUAL U (CAAR V)) (CAR V)) 00002910 (T (ASSOC* U (CDR V)))))) 00002920 00002930 (*OPEN (LAMBDA (U V) (PROG2 00002935 (OPEN U (LIST (QUOTE (LRECL . 80)) (CONS (QUOTE BLKSIZE) 00002940 BLKSIZE*)) V) 00002945 U))) 00002950 00002960 (*RDS (LAMBDA (U) (COND 00002970 ((NULL U) (RDS (QUOTE LISPIN))) 00002980 (T (RDS U))))) 00002990 00003000 (*WRS (LAMBDA (U) (COND 00003010 ((NULL U) (WRS (QUOTE LISPOUT))) 00003020 (T (PROG NIL (OTLL 72) (ASA NIL) (WRS U)))))) 00003030 )) 00003040 00003050 LOSE ((ASSOC* REMK* TERMS CKRN* UP DOWN SYMMETRIC ANTISYMMETRIC)) 00003060 00003070 COMMENT ((STANDARD LISP FUNCTIONS NOT DEFINED IN LISP/360)) 00003080 00003090 00003100 DEFINE (( 00003110 00003120 (COMPRESS (LAMBDA (U) 00003130 (PROG2 (COND ((DIGIT (CAR U)) 00003140 (MAP U (FUNCTION (LAMBDA (J) (RNUMB (CAR J)))))) 00003150 (T (MAP U (FUNCTION (LAMBDA (J) (RLIT (CAR J))))))) 00003160 (MKATOM)))) 00003170 00003180 (GTS (LAMBDA (U) ((LAMBDA (X) (COND 00003190 ((NULL X) (ERROR (LIST (QUOTE GTS) U))) 00003200 (T (CAR X)))) (GET U (QUOTE SPECIAL))))) 00003210 00003220 (PTS (LAMBDA (U V) (CAR ((LAMBDA (X) (COND 00003230 ((NULL X) (PUT U (QUOTE SPECIAL) (LIST V))) 00003240 (T (RPLACA X V)))) (GET U (QUOTE SPECIAL)))))) 00003250 00003260 (PUT (LAMBDA (U V W) 00003270 (PROG2 (DEFLIST (LIST (LIST U W)) V) W))) 00003280 00003290 (*EVAL (LAMBDA (U) ((LAMBDA (X) (COND 00003300 (X (CAR X)) 00003310 (T (EVAL U ALIST)))) 00003320 (GET* U (QUOTE SPECIAL))))) 00003330 00003340 (PAIRX (LAMBDA (U V) 00003341 (COND ((AND (NULL U) (NULL V)) NIL) 00003342 ((OR (NULL U) (NULL V)) (ERROR (QUOTE (PAIR MISMATCH)))) 00003343 (T (CONS (CONS (CAR U) (CAR V)) (PAIRX (CDR U) (CDR V))))))) 00003344 00003345 )) 00003350 00003360 COMMENT ((REDEFINING SOME FUNCTIONS EXCISED FROM THE COMPILER)) 00003370 00003380 DEFINE (( 00003390 00003400 (MAP (LAMBDA (U *PI*) 00003410 (PROG NIL 00003420 A (COND ((NULL U) (RETURN NIL))) 00003430 (*PI* U) 00003440 (SETQ U (CDR U)) 00003450 (GO A)))) 00003460 00003470 (MAPCON (LAMBDA (U *PI*) 00003480 (COND ((NULL U) NIL) 00003490 (T (NCONC (*PI* U) (MAPCON (CDR U) *PI*)))))) 00003500 00003510 (REVERSE (LAMBDA (U) 00003520 (PROG (V) 00003530 A (COND ((NULL U) (RETURN V))) 00003540 (SETQ V (CONS (CAR U) V)) 00003550 (SETQ U (CDR U)) 00003560 (GO A)))) 00003570 00003580 (SUBST (LAMBDA (U V W) 00003590 (COND ((NULL W) NIL) 00003600 ((EQUAL V W) U) 00003610 ((ATOM W) W) 00003620 (T (CONS (SUBST U V (CAR W)) (SUBST U V (CDR W))))))) 00003630 00003640 )) 00003650 00003660 COMMENT (ARRAY HANDLING ROUTINES) 00003670 00003680 DEFINE (( 00003690 00003700 (*ARRAY (LAMBDA (U) 00003710 (MAP U (FUNCTION (LAMBDA (J) 00003720 (PUT (CAAR J) (QUOTE ARRAY) (MKARRAY (CDAR J)))))))) 00003730 00003740 (MKARRAY (LAMBDA (U) 00003750 (COND ((NULL U) NIL) 00003760 (T (ARLIST (CDR U) (CAR U)))))) 00003770 00003772 (ARLIST (LAMBDA (U N) 00003774 (COND ((ZEROP N) NIL) (T (CONS (MKARRAY U) (ARLIST U (SUB1 N))))))) 00003776 00003780 (GETEL (LAMBDA (U) 00003790 (GETEL1 (GET (CAR U) (QUOTE ARRAY)) (CDR U)))) 00003800 00003810 (GETEL1 (LAMBDA (U V) 00003820 (COND ((NULL V) U) 00003830 (T (GETEL1 (NTH U (ADD1 (CAR V))) (CDR V)))))) 00003840 00003850 (SETEL (LAMBDA (U V) 00003860 (PROG (X N) 00003870 (SETQ X (REVERSE (CDR U))) 00003880 (SETQ N (CAR X)) 00003890 (SETQ X (GETEL1 (GET (CAR U) (QUOTE ARRAY)) 00003900 (REVERSE (CDR X)))) 00003910 A (COND ((EQUAL N 0) (RETURN (RPLACA X V)))) 00003920 (SETQ N (SUB1 N)) 00003930 (SETQ X (CDR X)) 00003940 (GO A)))) 00003950 00003960 )) 00003970 00003980 COMMENT ((I O HANDLING ROUTINES)) 00003990 00004000 DEFINE (( 00004010 00004020 (IN (LAMBDA (U) 00004030 (INOUT U (QUOTE INPUT)))) 00004040 00004050 (OUT (LAMBDA (U) 00004060 (INOUT U (QUOTE OUTPUT)))) 00004070 00004080 (INOUT (LAMBDA (U V) 00004090 (PROG (ECHO INT) 00004100 (SETQ ECHO *ECHO) 00004110 (SETQ INT *INT) 00004120 A (COND ((NULL U) (GO E)) 00004130 ((EQ V (QUOTE OUTPUT)) (GO C)) 00004140 ((EQ (CAR U) (QUOTE T)) (GO L))) 00004150 (SETQ IFL* (CAR U)) 00004160 (COND ((MEMBER IFL* IPL*) (GO B))) 00004170 (OPEN IFL* V) 00004180 (SETQ IPL* (CONS IFL* IPL*)) 00004190 B (RDS IFL*) 00004200 (SETQ *ECHO T) 00004210 (SETQ *INT NIL) 00004220 (BEGIN1) 00004230 (SETQ U (CDR U)) 00004240 (GO A) 00004250 C (COND ((EQ (CAR U) (QUOTE T)) (GO M))) 00004260 (SETQ OFL* (CAR U)) 00004270 (COND ((MEMBER OFL* OPL*) (GO D))) 00004280 (OPEN OFL* V) 00004290 (SETQ OPL* (CONS OFL* OPL*)) 00004300 D (WRS OFL*) 00004310 E (SETQ *ECHO ECHO) 00004320 (SETQ *INT INT) 00004330 (RETURN NIL) 00004340 L (SETQ IFL* NIL) 00004350 (RDS NIL) 00004360 (GO E) 00004370 M (SETQ OFL* NIL) 00004380 (WRS NIL) 00004390 (GO E) 00004400 ))) 00004410 00004420 (SHUT (LAMBDA (U) 00004430 (PROG (X) 00004440 A (COND ((NULL U) (RETURN NIL))) 00004450 (SETQ X (CAR U)) 00004460 (COND ((MEMBER X OPL*) (GO B)) 00004470 ((NOT (MEMBER X IPL*)) 00004480 (REDERR (CONS X (QUOTE (NOT OPEN)))))) 00004490 (CLOSE X) 00004500 (SETQ IPL* (DELETE X IPL*)) 00004510 (COND ((NOT (EQUAL X IFL*)) (GO C))) 00004520 (RDS (SETQ IFL* (COND (IPL* (CAR IPL*)) (T NIL)))) 00004530 (GO C) 00004540 B (SETQ OPL* (DELETE X OPL*)) 00004550 (CLOSE X) 00004560 (COND ((NOT (EQ X OFL*)) (GO C))) 00004570 (SETQ OFL* NIL) 00004580 (WRS NIL) 00004590 C (SETQ U (CDR U)) 00004600 (GO A)))) 00004610 00004620 )) 00004630 00004640 DEFLIST (((SHUT RLIS) (IN RLIS) (OUT RLIS)) STAT) 00004650 00004660 00004670 COMMENT ((INITIALIZATION OF INPUT AND OUTPUT CHARACTER STRINGS)) 00004680 00004690 CSET (SWITCH* ( 00004700 ($$*$* NIL *SEMICOL* NIL) 00004710 ($$$;$ NIL *SEMICOL* NIL) 00004720 ($$$+$ NIL PLUS NIL $$$ + $) 00004730 ($$$-$ NIL MINUS NIL $$$ - $) 00004740 ($$$*$ $$$*$ TIMES EXPT) 00004750 ($$$/$ NIL QUOTIENT NIL) 00004760 ($$$=$ NIL EQUAL NIL) 00004770 ($$$,$ NIL *COMMA* NIL) 00004780 ($$$($ NIL *LPAR* NIL) 00004790 ($$$)$ NIL *RPAR* NIL) 00004800 ($$$.$ NIL CONS NIL) 00004810 ($$$:$ $$$=$ *COLON* SETQ) 00004820 ($$$<$ $$$=$ LESSP LESSEQ) 00004830 ($$$>$ $$$=$ GREATERP GREATEQ) 00004840 )) 00004850 00004860 00004870 COMMENT ((E N D O F R E D U C E P R E P R O C E S S O R)) 00004880 00004890 00004900 00004910 00010000 00010010 00010020 COMMENT ((R E D U C E M A I N P R O G R A M)) 00010030 00010040 (LAMBDA (U) (MAP U (FUNCTION (LAMBDA (J) (PTS (CAR J) NIL))))) ((*FORT 00010050 *ECHO *INT PRECLIS* ORIG* POSN* *NAT YCOORD* YMIN* YMAX* *LIST COUNT* 00010060 *CARDNO ECHO* FORTVAR* LLENGTH* PLINE* CURSYM* *MODE MATP* DEFN* 00010070 SEMIC* SYMFG* *MSG TMODE* *SQVAR* PROGRAM* PROGRAML* DIAG* VARS* 00010080 CRCHAR* IFL* OFL* IPL* OPL* PRI* ERFG*)) 00010090 00010100 (LAMBDA (U) (MAP U (FUNCTION (LAMBDA (J) (PTS (CAAR J) (CADAR J)))))) 00010110 (((*NAT T) (COUNT* 1) (*CARDNO 20) (ORIG* 0) (LLENGTH* 67) (*SQVAR* (T 00010120 )))) 00010130 00010140 DEFINE (( 00010150 00010160 (FLAGP** (LAMBDA (U V) 00010170 (AND (ATOM U) (NOT (NUMBERP U)) (FLAGP U V)))) 00010180 00010190 (GET* (LAMBDA (U V) 00010200 (COND ((NUMBERP U) NIL) (T (GET U V))))) 00010210 00010220 (EQCAR (LAMBDA (U V) 00010230 (AND (NOT (ATOM U)) (EQ (CAR U) V)))) 00010240 00010250 (MKPREC (LAMBDA NIL 00010260 (PROG (X Y) 00010270 (SETQ X (CONS (QUOTE SETQ) PRECLIS*)) 00010280 (SETQ Y 2) 00010290 A (COND ((NULL X) (RETURN NIL))) 00010300 (PUT (CAR X) (QUOTE INFIX) Y) 00010310 (SETQ X (CDR X)) 00010320 (SETQ Y (ADD1 Y)) 00010330 (GO A)))) 00010340 00010350 )) 00010360 00010370 PTS (PRECLIS* (AND OR MEMBER EQUAL UNEQ EQ GREATEQ GREATERP LESSEQ 00010380 LESSP PLUS MINUS TIMES QUOTIENT EXPT CONS)) 00010390 00010400 (LAMBDA NIL (PROG (W X Y Z) (MKPREC) (SETQ X SWITCH*) (MAP X (FUNCTION 00010410 (LAMBDA (J) (PUT (CAAR J) (QUOTE SWITCH*) (CDAR J))))) A (COND ((NULL 00010420 X) (RETURN NIL))) (SETQ W (CDAR X)) (PUT (CADR W) (QUOTE PRTCH) (LIST 00010430 (CAAR X) (CAAR X))) (COND ((CAR (SETQ Y (CDDR W))) (PROG2 (SETQ Z 00010440 (COMPRESS (LIST (CAAR X)(CAR W))))(PUT (CAR Y)(QUOTE PRTCH) (LIST Z Z) 00010450 )))) (COND ((NULL (CDR Y)) (GO B)) ((CADR Y) (RPLACA (GET (CADR W) 00010460 (QUOTE PRTCH))(CADR Y))))(COND ((CDDR Y)(RPLACA (GET (CAR Y) (QUOTE 00010470 PRTCH)) (CADDR Y)))) B (SETQ X (CDR X)) (GO A))) NIL 00010480 00010490 DEFLIST (((MINUS (PLUS . MINUS))) ALT) 00010500 00010510 DEFINE (( 00010520 00010530 (RVLIS (LAMBDA NIL 00010540 (PROG (X) 00010550 A (SETQ X (CONS (SCAN) X)) 00010560 (COND 00010570 ((OR (FLAGP** (SCAN) (QUOTE DELIM)) 00010580 (MEMBER CURSYM* (QUOTE (CLEAR LET MATCH SAVEAS)))) 00010590 (RETURN X)) 00010600 ((NOT (EQ CURSYM* (QUOTE *COMMA*))) (CURERR NIL T))) 00010610 (GO A)))) 00010620 00010630 (INFIXFN (LAMBDA NIL 00010640 (PROG (X) 00010650 (SETQ X (RVLIS)) 00010660 (COND 00010670 ((EQ *MODE (QUOTE ALGEBRAIC)) 00010680 (*APPLY (QUOTE OPERATOR) (LIST X)))) 00010690 (SETQ PRECLIS* (APPEND X PRECLIS*)) 00010700 (MKPREC)))) 00010710 00010720 (PRECEDFN (LAMBDA NIL 00010730 (PROG (W X Y Z) 00010740 (SETQ X (RVLIS)) 00010750 (SETQ Y (CAR X)) 00010760 (SETQ X (CADR X)) 00010770 (SETQ PRECLIS* (DELETE X PRECLIS*)) 00010780 (SETQ W PRECLIS*) 00010790 A (COND ((NULL W) (REDERR (CONS Y (QUOTE (NOT FOUND))))) 00010800 ((EQ Y (CAR W)) (GO B))) 00010810 (SETQ Z (CONS (CAR W) Z)) 00010820 (SETQ W (CDR W)) 00010830 (GO A) 00010840 B (SETQ PRECLIS* 00010850 (NCONC (REVERSE Z) (CONS (CAR W) (CONS X (CDR W))))) 00010860 (MKPREC)))) 00010870 00010880 )) 00010890 00010900 DEFINE (( 00010910 00010920 (MATHPRINT (LAMBDA (L) 00010930 (PROG NIL (MAPRIN L) (TERPRI*)))) 00010940 00010950 (MAPRIN (LAMBDA (U) 00010960 (MAPRINT U 0))) 00010970 00010980 (MAPRINT (LAMBDA (L P) 00010990 (PROG (X Y) 00011000 (COND ((NULL L) (RETURN NIL)) 00011010 ((ATOM L) (GO B)) 00011020 ((NOT (ATOM (CAR L))) (MAPRINT (CAR L) P)) 00011030 ((SETQ X (GET* (CAR L) (QUOTE INFIX))) (GO A)) 00011040 ((SETQ X (GET* (CAR L) (QUOTE SPECPRN))) 00011050 (RETURN (*APPLY X (LIST (CDR L))))) 00011060 (T (PRINC* (CAR L)))) 00011070 (PRINC* **LPAR) 00011080 (INPRINT (QUOTE *COMMA*) 0 (CDR L)) 00011090 E (RETURN (PRINC* **RPAR)) 00011100 B (COND ((NUMBERP L) (GO D)) 00011110 ((SETQ X (GET L (QUOTE OLDNAME))) 00011120 (RETURN (PRINC* X)))) 00011130 C (RETURN (PRINC* L)) 00011140 D (COND ((NOT (MINUSP L)) (GO C))) 00011150 (PRINC* **LPAR) 00011160 (PRINC* L) 00011170 (GO E) 00011180 A (SETQ P (NOT (GREATERP X P))) 00011190 (COND ((NOT P) (GO G))) 00011200 (SETQ Y ORIG*) 00011210 (PRINC* **LPAR) 00011220 (COND ((LESSP POSN* 15) (SETQ ORIG* POSN*))) 00011230 G (INPRINT (CAR L) X (CDR L)) 00011240 (COND ((NOT P) (RETURN NIL))) 00011250 (PRINC* **RPAR) 00011260 (SETQ ORIG* Y)))) 00011270 00011280 (INPRINT (LAMBDA (OP P L) 00011290 (PROG NIL 00011300 (COND ((FLAGP OP (QUOTE UNIP)) (GO A))) 00011310 (MAPRINT (CAR L) P) 00011320 (GO C) 00011330 A (COND ((NULL L) (RETURN NIL)) 00011340 ((AND (NOT (ATOM (CAR L))) 00011350 (GET* (CAAR L) (QUOTE ALT)) 00011360 (EQ OP (CAR (GET* (CAAR L) (QUOTE ALT))))) 00011370 (GO B))) 00011380 (OPRIN OP) 00011390 B (MAPRINT (CAR L) P) 00011400 (COND ((OR (NOT *NAT) (NOT (EQ OP (QUOTE EXPT)))) (GO C))) 00011410 (SETQ YCOORD* (SUB1 YCOORD*)) 00011420 (SETQ YMIN* (*EVAL (LIST (QUOTE MIN) YMIN* YCOORD*))) 00011430 C (SETQ L (CDR L)) 00011440 (GO A)))) 00011450 00011460 )) 00011470 00011480 DEFINE (( 00011490 00011500 (OPRIN (LAMBDA (OP) 00011510 ((LAMBDA(X) 00011520 (COND ((NULL X) (PRINC* OP)) 00011530 (*FORT (PRINC* (CADR X))) 00011540 (*NAT 00011550 (COND ((EQ OP (QUOTE EXPT)) 00011560 (PROG NIL 00011570 (SETQ YCOORD* (ADD1 YCOORD*)) 00011580 (SETQ YMAX* 00011590 (*EVAL 00011600 (LIST (QUOTE MAX) YMAX* YCOORD*))))) 00011610 ((AND *LIST 00011620 (MEMBER OP (QUOTE (PLUS MINUS QUOTIENT)))) 00011630 (PROG NIL (CLOSELINE) (TERPRI) (PPRINT (CAR X)))) 00011640 (T (PPRINT (CAR X))))) 00011650 (T (PRINC (CAR X))))) 00011660 (GET OP (QUOTE PRTCH))))) 00011670 00011680 (PRINC* (LAMBDA (U) 00011690 (COND (*NAT (PPRINT U)) 00011700 ((NULL *FORT) (PRINC U)) 00011710 (T 00011720 (PROG NIL 00011730 (COND 00011740 ((AND (EQUAL COUNT* *CARDNO) 00011750 (OR (EQ U **PLUSS) (EQ U **DASH))) 00011760 (GO B)) 00011770 ((NOT 00011780 (GREATERP (SETQ POSN* 00011790 (PLUS POSN* (LENGTH (EXPLODE U)))) 00011800 69)) 00011810 (GO A))) 00011820 (TERPRI) 00011830 (SPACES 5) 00011840 (PRINC (QUOTE X)) 00011850 (SETQ POSN* (PLUS 6 (LENGTH (EXPLODE U)))) 00011860 (SETQ COUNT* (ADD1 COUNT*)) 00011870 A (RETURN (COND (ECHO* (PRINC U)) (T NIL))) 00011880 B (TERPRI) 00011890 (SPACES 6) 00011900 (PRINC FORTVAR*) 00011910 (OPRIN (QUOTE EQUAL)) 00011920 (PRINC FORTVAR*) 00011930 (SETQ COUNT* 1) 00011940 (SETQ POSN* 20) 00011941 (GO A)))))) 00011950 00011960 (TERPRI* (LAMBDA NIL 00011970 (COND (*NAT (PROG NIL (CLOSELINE) (COND (ECHO* (TERPRI))))) 00011980 (*FORT (COND ((ZEROP POSN*) NIL) 00011990 (T (PROG NIL (TERPRI) (SETQ COUNT* 1) 00011992 (SETQ POSN* 0))))) 00011994 (T (TERPRI))))) 00012000 00012010 (PPRINT (LAMBDA (U) 00012020 (PROG (M N) 00012030 (SETQ N (LENGTH (EXPLODE U))) 00012040 (COND ((GREATERP N LLENGTH*) (GO A1))) 00012050 C (SETQ M (PLUS POSN* N)) 00012060 (COND ((AND (GREATERP M LLENGTH*) (NOT (TERPRI*))) (GO C))) 00012070 (SETQ PLINE* 00012080 (CONS (CONS (CONS (CONS POSN* M) YCOORD*) U) PLINE*)) 00012090 A (RETURN (SETQ POSN* M)) 00012100 A1 (TERPRI*) 00012110 (PRINC U) 00012120 (RETURN (SETQ POSN* (REMAINDER N LLENGTH*)))))) 00012130 00012140 (CLOSELINE (LAMBDA NIL 00012150 (PROG (N) 00012160 (COND ((OR (NULL PLINE*) (NULL ECHO*)) (GO C))) 00012170 (SETQ N YMAX*) 00012180 (SETQ PLINE* (REVERSE PLINE*)) 00012190 A (SCPRINT PLINE* N) 00012200 (COND ((EQUAL N YMIN*) (GO B))) 00012210 (TERPRI) 00012220 (SETQ N (SUB1 N)) 00012230 (GO A) 00012240 B (COND ((EQ ECHO* (QUOTE RESULT)) (TERPRI))) 00012250 C (SETP)))) 00012260 00012270 (SCPRINT (LAMBDA (U N) 00012280 (PROG (M) 00012290 (SETQ POSN* 0) 00012300 A (COND ((NULL U) (RETURN NIL)) 00012310 ((NOT (EQUAL (CDAAR U) N)) (GO B)) 00012320 ((NOT (MINUSP (SETQ M (DIFFERENCE (CAAAAR U) POSN*)))) 00012330 (SPACES M))) 00012340 (PRINC (CDAR U)) 00012350 (SETQ POSN* (CDAAAR U)) 00012360 B (SETQ U (CDR U)) 00012370 (GO A)))) 00012380 00012390 (SPACES* (LAMBDA (N) 00012400 (COND (*NAT (SETQ POSN* (PLUS N POSN*))) (T (SPACES N))))) 00012410 00012420 )) 00012430 00012440 DEFINE (( 00012450 00012460 (SETP (LAMBDA NIL 00012470 (PROG NIL 00012480 (SETQ PLINE* NIL) 00012490 (SETQ POSN* ORIG*) 00012500 (SETQ YMAX* 0) 00012510 (SETQ YMIN* 0) 00012520 (SETQ YCOORD* 0)))) 00012530 00012540 )) 00012550 00012560 FLAG ((MINUS NOT) UNIP) 00012570 00012580 DEFINE (( 00012590 00012600 (MREAD* (LAMBDA (J) 00012610 (PROG2 (SCAN) (MREAD J)))) 00012620 00012630 (MREAD (LAMBDA (J) 00012640 (PROG (U V W W1 X Y Z) 00012650 (SETQ Z -1) 00012660 A (SETQ V CURSYM*) 00012670 (COND ((OR (NOT (ATOM V)) (NUMBERP V)) (GO B)) 00012680 ((FLAGP V (QUOTE DELIM)) (GO ERR1)) 00012682 ((EQ V (QUOTE *LPAR*)) (GO E)) 00012690 ((AND (EQ V (QUOTE *RPAR*)) (NULL U)) (RETURN NIL))) 00012700 (SETQ X (GET V (QUOTE INFIX))) 00012710 B0 (COND ((SETQ W (GET* V (QUOTE ISTAT))) (GO L))) 00012720 B (SETQ W (SCAN)) 00012750 BX (SETQ Y NIL) 00012760 (COND ((OR (NOT (ATOM W)) (NUMBERP W)) (GO B2)) 00012762 ((FLAGP W (QUOTE DELIM)) (GO ENDD)) 00012764 ((EQ W (QUOTE *LPAR*)) (GO E2)) 00012770 ((EQ W (QUOTE *RPAR*)) (GO END0)) 00012780 (U (GO B1))) 00012790 BY (COND 00012800 ((AND J 00012870 (EQ W (QUOTE *COMMA*)) 00012880 (NOT (MEMBER J (QUOTE (MAT PAREN FUNC))))) 00012890 (RETURN V))) 00012900 B1 (SETQ Y (GET W (QUOTE INFIX))) 00012910 B2 (COND ((NULL X) (GO SYM)) 00012920 ((NOT (FLAGP V (QUOTE UNARY))) (GO ERR3))) 00012930 C (SETQ Z X) 00012940 (SETQ U (CONS (LIST V) U)) 00012950 (SETQ V W) 00012960 (SETQ X Y) 00012970 (COND ((OR (NOT (ATOM V)) (NUMBERP V)) (GO B)) (T (GO B0))) 00012980 SYM (COND ((NULL Y) (GO M)) 00012990 ((AND (NULL W1) 00013000 (SETQ W1 (GET W (QUOTE ALT))) 00013010 (SETQ W (CAR W1))) 00013020 (GO B1))) 00013030 SYM1 (COND ((OR (NULL Z) (LESSP Y Z)) (GO H)) 00013040 ((OR (GREATERP Y Z) (FLAGP W (QUOTE BINARY))) (GO G))) 00013050 (SETQ U (CONS (ACONC (CAR U) V) (CDR U))) 00013060 (GO G1) 00013070 E (SETQ V 00013080 (MREAD* 00013090 (COND ((EQ J (QUOTE MAT)) (QUOTE FUNC)) 00013100 (T (QUOTE PAREN))))) 00013110 (GO B) 00013130 E2 (COND ((EQ V (QUOTE MAT)) 00013140 (SETQ V (CONS V (REMCOMMA (MREAD* (SETQ MATP* V)))))) 00013150 ((AND (ATOM V) (GET V (QUOTE UNARY)) 00013152 (SETQ W (CAR (MREAD* (QUOTE FUNC))))) (GO C)) 00013154 ((OR (ATOM V) (EQ *MODE (QUOTE SYMBOLIC))) 00013160 (SETQ V (CONS V (MREAD* (QUOTE FUNC))))) 00013170 (T (GO ERR4))) 00013180 (SETQ X NIL) 00013185 (GO B) 00013190 G (SETQ U (CONS (LIST W V) U)) 00013200 (SETQ Z Y) 00013210 G1 (COND (W1 (GO G2))) 00013220 (SCAN) 00013230 G3 (SETQ X NIL) 00013232 (GO A) 00013240 G2 (SETQ CURSYM* (CDR W1)) 00013250 (SETQ W1 NIL) 00013260 (GO G3) 00013270 H (SETQ V (ACONC (CAR U) V)) 00013280 (SETQ U (CDR U)) 00013290 (COND ((AND (NULL U) (SETQ Z 0)) (GO BY))) 00013300 (SETQ Z (GET (CAAR U) (QUOTE INFIX))) 00013310 (GO SYM1) 00013320 L (SETQ V (*APPLY W NIL)) 00013330 (SETQ W CURSYM*) 00013340 (GO BX) 00013350 M (COND ((NUMBERP V) (GO ERR4)) 00013360 ((PROGVR V) 00013370 (LPRIM* 00013380 (APPEND (QUOTE (PROGRAM VARIABLE)) 00013390 (CONS V 00013400 (QUOTE (USED AS OPERATOR))))))) 00013410 (GO C) 00013420 END0 (COND ((NULL J) (GO ERR21)) (T (GO END2))) 00013430 ENDD (COND ((MEMBER J (QUOTE (MAT PAREN FUNC))) (GO ERR22))) 00013440 END2 (COND (X (GO ERR1))) 00013450 END1 (COND 00013460 ((NULL U) 00013470 (RETURN (COND ((EQ J (QUOTE FUNC)) (REMCOMMA V)) (T V))))) 00013480 (SETQ V (ACONC (CAR U) V)) 00013490 (SETQ U (CDR U)) 00013500 (GO END1) 00013510 ERR1 (CURERR (QUOTE (SYNTAX ERROR)) NIL) 00013520 ERR21 00013530 (CURERR (QUOTE (TOO MANY RIGHT PARENTHESES)) NIL) 00013540 ERR22 00013550 (CURERR (QUOTE (TOO FEW RIGHT PARENTHESES)) NIL) 00013560 ERR3 (CURERR (QUOTE (REDUNDANT OPERATOR)) 1) 00013570 ERR4 (CURERR (QUOTE (MISSING OPERATOR)) NIL)))) 00013580 00013590 (ACONC (LAMBDA (U V) 00013600 (NCONC U (LIST V)))) 00013610 00013620 (REMCOMMA (LAMBDA (U) 00013630 (COND ((EQCAR U (QUOTE *COMMA*)) (CDR U)) (T (LIST U))))) 00013640 00013650 (SCAN (LAMBDA NIL 00013660 (PROG (X Y) 00013670 (COND ((EQ CURSYM* (QUOTE *SEMICOL*)) (TERPRI*))) 00013680 A (COND ((EQ CRCHAR* **BLANK) (GO L)) 00013690 ((DIGIT CRCHAR*) (GO G)) 00013700 ((LITER CRCHAR*) (GO E)) 00013710 ((EQ CRCHAR* **XMARK) (GO E0)) 00013720 ((EQ CRCHAR* **QMARK) (GO P)) 00013730 ((EQ CRCHAR* **SMARK) (RETURN (COMM1 NIL))) 00013740 ((NULL (SETQ X (GET* CRCHAR* (QUOTE SWITCH*)))) 00013750 (GO B)) 00013760 ((EQ (SETQ Y (CADR X)) (QUOTE *SEMICOL*)) (GO J)) 00013770 ((EQ (READCH*) (CAR X)) (GO K))) 00013780 C (SETQ CURSYM* (CADR X)) 00013790 D (COND ((AND *ECHO *NAT) (SYMPRI CURSYM*))) 00013800 (COND 00013810 ((SETQ X (GET* CURSYM* (QUOTE NEWNAME))) (SETQ CURSYM* X))) 00013820 D1 (RETURN CURSYM*) 00013830 E0 (READCH*) 00013840 E (SETQ Y (CONS CRCHAR* Y)) 00013850 (COND 00013860 ((OR (DIGIT (READCH*)) (LITER CRCHAR*)) (GO E)) 00013870 ((EQ CRCHAR* **XMARK) (GO E0))) 00013880 (GO H) 00013890 G (SETQ Y (CONS CRCHAR* Y)) 00013900 (SETQ X CRCHAR*) 00013910 (COND 00013920 ((OR (DIGIT (READCH*)) 00013930 (EQ CRCHAR* **DOT) 00013940 (EQ CRCHAR* (QUOTE E)) 00013950 (EQ X (QUOTE E))) 00013960 (GO G))) 00013970 H (SETQ CURSYM* (COMPRESS (REVERSE Y))) 00013980 (GO D) 00013990 J (SETQ SEMIC* CRCHAR*) 00014000 (SETQ CRCHAR* **BLANK) 00014010 (GO C) 00014020 K (READCH*) 00014030 (SETQ CURSYM* (CADDR X)) 00014040 (GO D) 00014050 B (COND ((EQ CRCHAR* **ESC) (ERROR **ESC)) 00014060 (Y 00014070 (CURERR (CONS CRCHAR* (QUOTE (INVALID CHARACTER))) 00014080 NIL))) 00014090 (SETQ CURSYM* CRCHAR*) 00014100 (READCH*) 00014110 (GO D) 00014120 L (READCH*) 00014130 (GO A) 00014140 P (SETQ CURSYM* (LIST (QUOTE QUOTE) (READ))) 00014150 (READCH*) 00014160 (COND ((OR *ECHO *NAT) (MAPRIN CURSYM*))) 00014170 (GO D1)))) 00014180 00014190 )) 00014200 00014210 DEFINE (( 00014220 00014230 (LPRI (LAMBDA (U) 00014240 (PROG NIL 00014250 A (COND ((NULL U) (RETURN NIL))) 00014260 (PRINC* (CAR U)) 00014270 (SPACES* 1) 00014280 (SETQ U (CDR U)) 00014290 (GO A)))) 00014300 00014310 (LPRIE (LAMBDA (U X) 00014320 (PROG NIL (SETQ ERFG* T) (LPRIW U X (QUOTE *****))))) 00014330 00014340 (REDERR (LAMBDA (U) 00014350 (PROG2 (LPRIE U T) (ERROR*)))) 00014360 00014370 (LPRIW (LAMBDA (U X Y) 00014380 (PROG (V W) 00014390 (COND ((AND OFL* (OR *FORT (NOT *NAT))) (GO D))) 00014392 (TERPRI*) 00014400 A (SETQ V U) 00014410 (PRINC Y) 00014420 (PRINC **BLANK) 00014430 B (COND ((NULL V) (GO C))) 00014440 (PRINC (CAR V)) 00014450 (PRINC **BLANK) 00014460 (SETQ V (CDR V)) 00014470 (GO B) 00014480 C (COND (X (TERPRI))) 00014490 (COND ((NULL OFL*) (RETURN NIL)) (W (RETURN (WRS OFL*)))) 00014500 D (WRS NIL) 00014510 (SETQ W T) 00014520 (GO A)))) 00014530 00014540 )) 00014550 00014560 DEFLIST (((*COMMA* 1)) INFIX) 00014570 00014580 FLAG ((CONS EXPT QUOTIENT) BINARY) 00014590 00014600 FLAG ((PLUS MINUS TIMES NOT *COMMA*) UNARY) 00014610 00014620 FLAG ((*COLON* *SEMICOL*) DELIM) 00014630 00014640 DEFINE (( 00014670 00014680 (COMMAND (LAMBDA NIL 00014690 (PROG2 (SCAN) (COMMAND1 (QUOTE TOP))))) 00014700 00014710 (COMMAND1 (LAMBDA (U) 00014720 (PROG (V X Y) 00014730 A0 (COND ((NOT (ATOM U)) (SETQ V (CAR U))) 00014740 ((AND (EQ CURSYM* (QUOTE *SEMICOL*)) 00014750 (LIST (SCAN))) (GO A0)) 00014760 ((NOT (SETQ Y (GET* (SETQ V CURSYM*) (QUOTE STAT)))) 00014770 (SETQ V (MREAD 00014780 (AND (NOT (EQ U (QUOTE TOP))) 00014790 (OR (EQ U (QUOTE IF)) 00014800 (EQ *MODE (QUOTE SYMBOLIC)))))))) 00014810 (SETQ U 00014820 (AND (NOT (EQ *MODE (QUOTE SYMBOLIC))) 00014830 (OR PRI* (EQ U (QUOTE TOP))))) 00014840 (COND (Y (GO B)) 00014850 ((EQ CURSYM* (QUOTE *COLON*)) (RETURN V)) 00014860 ((EQCAR V (QUOTE SETQ)) (GO C)) 00014870 ((OR (EQUAL *MODE (QUOTE SYMBOLIC)) 00014880 (EQCAR V (QUOTE QUOTE)) 00014890 (AND (NUMBERP V) (FIXP V))) 00014900 (SETQ Y V)) 00014910 ((EQCAR V (QUOTE EQUAL)) (GO C)) 00014920 (T (SETQ Y (LIST (QUOTE AEVAL) (MKARG V))))) 00014930 A (COND ((AND U (EQ SEMIC* **SEMICOL)) 00014940 (SETQ Y (LIST (QUOTE VARPRI) X Y PRI*))) 00014950 ((AND PRI* (EQ *MODE (QUOTE SYMBOLIC))) 00014960 (SETQ Y (LIST (QUOTE PRINC) Y)))) 00014970 (RETURN Y) 00014980 B (SETQ Y (*APPLY Y NIL)) 00014990 (SETQ U (AND U (MEMBER V (QUOTE (BEGIN FOR IF))))) 00015000 (GO A) 00015010 C (SETQ V (CDR V)) 00015020 (COND ((NULL (CDDR V)) (GO D))) 00015030 (SETQ X PRI*) 00015040 (SETQ PRI* NIL) 00015050 (SETQ Y (COMMAND1 (LIST (CONS (QUOTE SETQ) (CDR V))))) 00015060 (SETQ PRI* X) 00015070 (SETQ X NIL) 00015080 D (COND ((EQ *MODE (QUOTE SYMBOLIC)) (GO E)) 00015090 (U 00015100 (SETQ X 00015110 (CONS (QUOTE LIST) 00015120 (MAPCAR 00015130 (REVERSE (CDR (REVERSE V))) 00015140 (FUNCTION MKARG*)))))) 00015150 (COND ((NULL (CDDR V)) 00015160 (SETQ Y (LIST (QUOTE AEVAL) (MKARG (CADR V)))))) 00015170 (SETQ Y 00015180 (COND 00015190 ((AND (ATOM (CAR V)) (PROGVR (CAR V))) 00015200 (LIST (QUOTE SETQ) (CAR V) Y)) 00015210 (T (LIST (QUOTE SETK) (MKARG (CAR V)) Y)))) 00015220 (GO A) 00015230 E (COND ((NULL (CDDR V)) (SETQ Y (CADR V)))) 00015240 (SETQ Y 00015250 (COND 00015260 ((ATOM (CAR V)) (LIST (QUOTE SETQ) (CAR V) Y)) 00015270 ((GET* (CAAR V) (QUOTE **ARRAY)) 00015280 (LIST (QUOTE SETEL) (CAR V) Y)) 00015282 (T (PROCDEF1 (CAR V) Y)))) 00015284 (GO A)))) 00015286 00015290 (MKARG (LAMBDA (U) 00015300 (COND ((NULL U) NIL) 00015310 ((ATOM U) (COND ((PROGVR U) U) (T (LIST (QUOTE QUOTE) U)))) 00015320 ((MEMBER (CAR U) (QUOTE (COND PROG QUOTE))) U) 00015330 (T (CONS (QUOTE LIST) (MAPCAR U (FUNCTION MKARG))))))) 00015340 00015350 (MKARG* (LAMBDA (U) 00015360 (COND ((NULL U) NIL) 00015370 ((ATOM U) (LIST (QUOTE QUOTE) U)) 00015420 (T (CONS (QUOTE LIST) (MAPCAR U (FUNCTION MKARG))))))) 00015430 00015440 (MKPROG (LAMBDA (U V) 00015480 (CONS (QUOTE PROG) (CONS U V)))) 00015490 00015510 (PROGVR (LAMBDA (VAR) 00015520 (COND ((NOT (ATOM VAR)) NIL) 00015530 ((NUMBERP VAR) T) 00015540 (T 00015550 ((LAMBDA (X) (COND (X (CAR X)) (T NIL))) 00015560 (GET VAR (QUOTE DATATYPE))))))) 00015570 00015580 )) 00015590 00015600 DEFINE (( 00015610 00015620 (LPRIM* (LAMBDA (U) 00015630 (PROG (X Y) 00015640 (COND ((AND OFL* (OR *FORT (NOT *NAT))) (GO C))) 00015650 A (SETQ X *NAT) 00015660 (SETQ *NAT NIL) 00015670 (LPRI (CONS (QUOTE ***) U)) 00015680 (TERPRI) 00015690 (SETQ *NAT X) 00015700 (COND ((NULL Y) (GO B))) 00015701 (WRS Y) 00015702 (RETURN NIL) 00015703 B (COND ((NULL OFL*) (RETURN NIL))) 00015704 C (SETQ Y OFL*) 00015705 (WRS NIL) 00015706 (GO A)))) 00015707 00015710 (SYMPRI (LAMBDA (U) 00015720 (PROG (X) 00015730 (COND 00015740 ((EQ U (QUOTE *SEMICOL*)) (PRINC* SEMIC*)) 00015750 ((SETQ X (GET* U (QUOTE PRTCH))) (PRINC* (CAR X))) 00015760 (T (GO B))) 00015770 (RETURN (SETQ SYMFG* NIL)) 00015780 B (COND (SYMFG* (SPACES* 1))) 00015790 (PRINC* U) 00015800 (SETQ SYMFG* T)))) 00015810 00015820 (CURERR (LAMBDA (U V) 00015830 (PROG (X) 00015840 (SETQ ECHO* T) 00015850 (TERPRI) 00015860 (SETQ X CURSYM*) 00015870 (COND ((NULL PLINE*) (GO B)) 00015880 ((EQUAL V 1) 00015890 (SETQ PLINE* 00015900 (CONS (CAR PLINE*) 00015910 (CONS 00015920 (CONS (CONS (CAAADR PLINE*) -1) **EMARK) 00015930 (CDR PLINE*))))) 00015940 (T 00015950 (SETQ PLINE* 00015960 (CONS (CONS (CONS (CAAAR PLINE*) -1) **EMARK) 00015970 PLINE*)))) 00015980 (SETQ YMIN* -1) 00015990 B (COMM1*) 00016000 (COND ((NUMBERP V) (SETQ V NIL))) 00016010 (COND ((AND (NULL U) (NULL V)) (GO A)) 00016020 ((NULL V) (LPRIE U T)) 00016030 (T (LPRIE 00016040 (CONS X 00016050 (CONS (QUOTE INVALID) 00016060 (COND 00016070 (U 00016080 (LIST (QUOTE IN) 00016090 U 00016100 (QUOTE STATEMENT))) 00016110 (T NIL)))) 00016120 T))) 00016130 A (ERROR*)))) 00016140 00016150 (ERROR* (LAMBDA NIL 00016160 (PROG2 (TERPRI*) (ERROR NIL)))) 00016170 00016180 )) 00016190 00016200 DEFINE (( 00016210 00016220 (GREATEQ (LAMBDA (U V) 00016230 (OR (EQUAL U V) (GREATERP U V)))) 00016240 00016250 (LESSEQ (LAMBDA (U V) 00016260 (OR (EQUAL U V) (LESSP U V)))) 00016270 00016280 (UNEQ (LAMBDA (U V) 00016290 (NOT (EQUAL U V)))) 00016300 00016310 (REDMSG (LAMBDA (U V W) 00016320 (COND ((NULL *MSG) T) 00016330 ((AND *INT W) (REDMSG1 U V)) 00016340 (T (NULL (LPRIM* (LIST U (QUOTE DECLARED) V))))))) 00016350 00016360 (DELETE (LAMBDA (U V) 00016370 (COND ((NULL V) NIL) 00016380 ((EQUAL U (CAR V)) (CDR V)) 00016390 (T (CONS (CAR V) (DELETE U (CDR V))))))) 00016400 00016410 (SETDIFF (LAMBDA (U V) 00016420 (COND ((NULL V) U) (T (SETDIFF (DELETE (CAR V) U) (CDR V)))))) 00016430 00016440 (XN (LAMBDA (U V) 00016450 (COND ((NULL U) NIL) 00016460 ((MEMBER (CAR U) V) 00016470 (CONS (CAR U) (XN (CDR U) (DELETE (CAR U) V)))) 00016480 (T (XN (CDR U) V))))) 00016490 00016500 )) 00016510 00016520 DEFINE (( 00016530 00016540 (PROCDEF (LAMBDA NIL 00016550 (PROG (X Y) 00016560 (COND ((ATOM (SETQ X (MREAD* NIL))) (SETQ X (LIST X)))) 00016570 (SCAN) 00016580 (SETQ Y (FLAGTYPE (CDR X) (QUOTE SCALAR))) 00016581 (SETQ X (PROCDEF1 X (COMMAND1 NIL))) 00016582 (REMTYPE Y) 00016583 (RETURN X)))) 00016584 00016600 (PROCDEF1 (LAMBDA (U BODY) 00016602 (PROG (NAME VARLIS) 00016604 (SETQ NAME (CAR U)) 00016610 (COND 00016620 ((OR (NULL NAME) (NOT (ATOM NAME)) (NUMBERP NAME)) 00016630 (CURERR NAME NIL)) 00016640 ((NOT (GETD NAME)) (FLAG (LIST NAME) (QUOTE FNC)))) 00016650 (COND ((EQCAR BODY (QUOTE PROG)) (SETQ VARLIS (CADR BODY)))) 00016660 (COND (VARLIS (RPLACA (CDR BODY) (SETDIFF VARLIS (CDR U))))) 00016680 (SETQ VARLIS (CDR U)) 00016690 (AND (NOT (FLAGP NAME (QUOTE FNC))) 00016710 (LPRIM* (LIST NAME (QUOTE REDEFINED)))) 00016720 (DEF* NAME VARLIS BODY DEFN*) 00016730 (REMPROP NAME (QUOTE FNC)) 00016740 (RETURN (LIST (QUOTE QUOTE) NAME))))) 00016760 00016780 (FLAGTYPE (LAMBDA (U V) 00016790 (PROG (X Y Z) 00016800 A (COND ((NULL U) (RETURN (REVERSE Z)))) 00016810 (SETQ X (CAR U)) 00016820 (COND ((GET X (QUOTE SIMPFN)) 00016830 (REDERR (APPEND (QUOTE (TYPE CONFLICT FOR)) (LIST X))))) 00016830 (SETQ Y (GET X (QUOTE DATATYPE))) 00016840 (PUT X (QUOTE DATATYPE) (CONS V Y)) 00016910 (SETQ Z (CONS X Z)) 00016920 C (SETQ U (CDR U)) 00016930 (GO A)))) 00016940 00016970 (REMTYPE (LAMBDA (VARLIS) 00016980 (PROG (X Y) 00016990 A (COND ((NULL VARLIS) (RETURN NIL))) 00017000 (SETQ X (CAR VARLIS)) 00017010 (SETQ Y (CDR (GET X (QUOTE DATATYPE)))) 00017020 (COND (Y (PUT X (QUOTE DATATYPE) Y)) 00017060 (T (REMPROP X (QUOTE DATATYPE)))) 00017070 (SETQ VARLIS (CDR VARLIS)) 00017080 (GO A)))) 00017090 00017100 (NEWVAR (LAMBDA (U) 00017110 (COMPRESS (CONS **FMARK (EXPLODE U))))) 00017120 00017130 (DEF* (LAMBDA (NAME VARLIS BODY FN) 00017140 (*APPLY FN 00017150 (LIST 00017160 (LIST (LIST NAME (LIST (QUOTE LAMBDA) VARLIS BODY))))))) 00017170 00017180 )) 00017190 00017200 DEFINE (( 00017210 00017220 (PROCBLOCK (LAMBDA NIL 00017230 (PROG (X HOLD VARLIS) 00017240 (SCAN) 00017250 (COND ((MEMBER CURSYM* (QUOTE (NIL *RPAR*))) (ERROR **ESC))) 00017260 (SETQ VARLIS (DECL T)) 00017270 A (COND ((EQ CURSYM* (QUOTE END)) (GO B))) 00017280 (SETQ X (COMMAND1 NIL)) 00017290 (COND ((EQCAR X (QUOTE END)) (GO C))) 00017300 (AND (NOT (EQ CURSYM* (QUOTE END))) (SCAN)) 00017310 (COND (X (SETQ HOLD (ACONC HOLD X)))) 00017320 (GO A) 00017330 B (COMM1 (QUOTE END)) 00017340 C (REMTYPE VARLIS) 00017350 (COND ((NOT (EQ *MODE (QUOTE SYMBOLIC))) 00017351 (SETQ HOLD (ACONC HOLD (QUOTE (RETURN 0)))))) 00017352 (RETURN (MKPROG VARLIS HOLD))))) 00017360 00017380 (DECL* (LAMBDA NIL 00017390 (MAP (DECL NIL) (FUNCTION (LAMBDA (J) 00017400 (PUT (CAR J) (QUOTE SPECIAL) (LIST NIL))))))) 00017400 00017410 (DECL (LAMBDA (U) 00017420 (PROG (V W VARLIS) 00017430 A (COND 00017440 ((NOT (MEMBER CURSYM* (QUOTE (REAL INTEGER SCALAR)))) 00017450 (RETURN VARLIS))) 00017460 (SETQ W CURSYM*) 00017470 (COND ((EQ (SCAN) (QUOTE PROCEDURE)) (RETURN (ALGFN)))) 00017480 (SETQ V (FLAGTYPE (REMCOMMA (MREAD NIL)) W)) 00017490 (SETQ VARLIS (APPEND V VARLIS)) 00017500 (AND (NOT (EQ CURSYM* (QUOTE *SEMICOL*))) (CURERR NIL T)) 00017510 (AND U (SCAN)) 00017520 (GO A)))) 00017530 00017540 (GOFN (LAMBDA NIL 00017550 (PROG (VAR) 00017560 (SETQ VAR 00017570 (COND ((EQ (SCAN) (QUOTE TO)) (SCAN)) (T CURSYM*))) 00017580 (SCAN) 00017590 (RETURN (LIST (QUOTE GO) VAR))))) 00017600 00017610 (RETFN (LAMBDA NIL 00017620 (LIST (QUOTE RETURN) 00017630 (COND ((FLAGP** (SCAN) (QUOTE DELIM)) NIL) 00017635 (T (COMMAND1 NIL)))))) 00017640 00017650 (ENDFN (LAMBDA NIL 00017660 (PROG2 (COMM1 (QUOTE END)) (QUOTE (END))))) 00017670 00017680 )) 00017690 00017700 DEFINE (( 00017710 00017720 (FORSTAT (LAMBDA NIL 00017730 (COND ((EQ (SCAN) (QUOTE ALL)) (FORALLFN*)) (T (FORLOOP))))) 00017740 00017750 (FORLOOP (LAMBDA NIL 00017760 (PROG (CURS EXP INCR INDX CONDLIST BODY FLG FNC LAB1 LAB2) 00017770 (SETQ FNC (GENSYM)) 00017780 (SETQ EXP (MREAD T)) 00017790 (COND 00017800 ((AND (EQ (CAR EXP) (QUOTE *COMMA*)) 00017810 (EQCAR (CADR EXP) (QUOTE SETQ))) 00017820 (SETQ EXP 00017830 (LIST NIL 00017840 (CADADR EXP) 00017850 (CONS (QUOTE *COMMA*) 00017860 (NCONC (CDDADR EXP) (CDDR EXP)))))) 00017870 ((NOT (MEMBER (CAR EXP) (QUOTE (SETQ EQUAL)))) (GO ERR))) 00017880 (SETQ EXP (CDR EXP)) 00017890 (COND 00017900 ((OR (NOT (ATOM (SETQ INDX (CAR EXP)))) (NUMBERP INDX)) 00017910 (GO ERR))) 00017920 (SETQ INDX (CAR (FLAGTYPE (LIST INDX) (QUOTE INTEGER)))) 00017920 A (SETQ EXP (REMCOMMA (CADR EXP))) 00017930 A1 (COND ((NULL EXP) (GO B2)) 00017940 ((CDR EXP) (SETQ FLG T)) 00017950 ((EQ CURSYM* (QUOTE STEP)) (GO B1)) 00017960 ((EQ CURSYM* (QUOTE *COLON*)) (GO BB))) 00017970 (SETQ CONDLIST 00017980 (NCONC CONDLIST 00017990 (LIST (LIST (QUOTE SETQ) INDX (MKEX (CAR EXP))) 00018000 (LIST FNC)))) 00018010 B0 (SETQ EXP (CDR EXP)) 00018020 (GO A1) 00018030 B1 (SETQ INCR (MKEX (MREAD* NIL))) 00018040 (COND 00018050 ((NOT (MEMBER (SETQ CURS CURSYM*) (QUOTE (UNTIL WHILE)))) 00018060 (GO ERR))) 00018070 AA (SETQ LAB1 (GENSYM)) 00018080 (SETQ LAB2 (GENSYM)) 00018090 (SETQ CONDLIST 00018100 (ACONC CONDLIST(LIST (QUOTE SETQ) INDX (MKEX (CAR EXP))))) 00018110 (SETQ EXP (REMCOMMA (MREAD* NIL))) 00018120 (SETQ BODY (MKEX (CAR EXP))) 00018130 (SETQ CONDLIST 00018140 (NCONC CONDLIST 00018150 (LIST LAB1 00018160 (LIST (QUOTE COND) 00018170 (LIST 00018180 (COND 00018190 ((EQ CURS (QUOTE UNTIL)) 00018200 (COND 00018210 ((NUMBERP INCR) 00018220 (LIST 00018230 (COND 00018240 ((MINUSP INCR) 00018250 (QUOTE LESSP)) 00018260 (T (QUOTE GREATERP))) 00018270 INDX 00018280 BODY)) 00018290 (T 00018300 (LIST 00018310 (QUOTE MINUSP) 00018320 (LIST 00018330 (QUOTE TIMES) 00018340 (LIST 00018350 (QUOTE DIFFERENCE) 00018360 BODY 00018370 INDX) 00018380 INCR))))) 00018390 (T (LIST (QUOTE NOT) BODY))) 00018400 (LIST (QUOTE GO) LAB2))) 00018410 (LIST FNC) 00018420 (LIST (QUOTE SETQ) 00018430 INDX 00018440 (LIST (QUOTE PLUS) INDX INCR)) 00018450 (LIST (QUOTE GO) LAB1) 00018460 LAB2))) 00018470 (AND (CDR EXP) (SETQ FLG T)) 00018480 (GO B0) 00018490 BB (SETQ INCR 1) 00018500 (SETQ CURS (QUOTE UNTIL)) 00018510 (GO AA) 00018520 B2 (COND ((NULL CONDLIST) (GO ERR)) 00018530 ((MEMBER CURSYM* (QUOTE (SUM PRODUCT))) (GO C)) 00018540 ((NOT (EQ CURSYM* (QUOTE DO))) (GO ERR))) 00018550 (SCAN) 00018560 (SETQ BODY (COMMAND1 NIL)) 00018570 B (COND (FLG (DEF* FNC NIL BODY (QUOTE DEFINE))) 00018590 (T (SETQ CONDLIST (ADFORM BODY (LIST FNC) CONDLIST)))) 00018600 (REMTYPE (LIST INDX)) 00018602 (RETURN (MKPROG (CONS INDX EXP) (ACONC CONDLIST 00018610 (QUOTE (RETURN NIL))))) 00018612 C (SETQ CURS CURSYM*) 00018620 (SETQ EXP (GENSYM)) 00018630 (SETQ BODY 00018640 (LIST (QUOTE SETQ) 00018650 EXP 00018660 (LIST 00018670 (COND 00018680 ((EQ CURS (QUOTE SUM)) (QUOTE ADDSQ)) 00018690 (T (QUOTE MULTSQ))) 00018700 (LIST (QUOTE AEVAL1) (MKARG (MREAD* T))) 00018710 EXP))) 00018720 (SETQ CONDLIST 00018730 (CONS (LIST (QUOTE SETQ) 00018740 EXP 00018750 (LIST (QUOTE CONS) 00018760 (COND 00018770 ((EQ CURS (QUOTE SUM)) NIL) 00018780 (T 1)) 00018790 1)) 00018800 (ACONC CONDLIST 00018810 (LIST (QUOTE RETURN) 00018820 (LIST (QUOTE MK*SQ) 00018830 (LIST (QUOTE SUBS2) EXP)))))) 00018840 (SETQ EXP (LIST EXP)) 00018840 (GO B) 00018850 ERR (CURERR (QUOTE FOR) T)))) 00018900 00018910 (ADFORM (LAMBDA (U V W) 00018920 (COND ((NULL W) NIL) 00018930 ((EQUAL V (CAR W)) 00018940 ((LAMBDA(X) 00018950 (COND (X (APPEND X (CDR W))) (T (CONS U (CDR W))))) 00018960 (PROGCHK U))) 00018970 (T (CONS (CAR W) (ADFORM U V (CDR W))))))) 00018980 00018990 (PROGCHK (LAMBDA (U) 00019000 (PROG (X) 00019010 (COND 00019020 ((OR (NOT (EQCAR U (QUOTE PROG))) (CADR U)) (RETURN NIL))) 00019030 (SETQ U (CDR U)) 00019040 A (SETQ U (CDR U)) 00019050 (COND ((NULL U) (RETURN (REVERSE X))) 00019060 ((ATOM (CAR U)) (GO B)) 00019070 ((EQCAR (CAR U) (QUOTE RETURN)) (GO RET)) 00019080 ((EQCAR (CAR U) (QUOTE PROG)) (GO B)) 00019090 ((MEMBER (QUOTE RETURN) (FLATTEN (CAR U))) 00019100 (RETURN NIL))) 00019110 B (SETQ X (CONS (CAR U) X)) 00019120 (GO A) 00019130 RET (COND ((CDR U) (RETURN NIL)) 00019135 ((NOT (ATOM (CADAR U))) (SETQ X (CONS (CADAR U) X)))) 00019140 (GO A)))) 00019145 00019150 (FLATTEN (LAMBDA (U) 00019160 (COND ((NULL U) NIL) 00019170 ((ATOM U) (LIST U)) 00019180 ((ATOM (CAR U)) (CONS (CAR U) (FLATTEN (CDR U)))) 00019190 (T (NCONC (FLATTEN (CAR U)) (FLATTEN (CDR U))))))) 00019200 00019210 )) 00019220 00019230 DEFINE (( 00019240 00019250 (IFSTAT (LAMBDA NIL 00019260 (PROG (CONDX CONDIT) 00019270 (FLAG (QUOTE (CLEAR LET MATCH)) (QUOTE DELIM)) 00019280 A (SETQ CONDX (MREAD* T)) 00019290 (REMFLAG (QUOTE (CLEAR LET MATCH)) (QUOTE DELIM)) 00019300 (COND ((NOT (EQ CURSYM* (QUOTE THEN))) (GO C))) 00019330 (SCAN) 00019340 (SETQ CONDIT(ACONC CONDIT (LIST (MKEX CONDX) (COMMAND1 NIL)))) 00019350 (COND ((NOT (EQ CURSYM* (QUOTE ELSE))) (GO B)) 00019360 ((EQ (SCAN) (QUOTE IF)) (GO A)) 00019370 (T 00019380 (SETQ CONDIT 00019390 (ACONC CONDIT 00019400 (LIST T (COMMAND1 (QUOTE IF))))))) 00019410 B (RETURN (CONS (QUOTE COND) CONDIT)) 00019420 C (COND 00019430 ((NOT (MEMBER CURSYM* (QUOTE (CLEAR LET MATCH)))) 00019440 (CURERR (QUOTE IF) T))) 00019450 (SETQ MCOND* (MKEX CONDX)) 00019460 (RETURN (FORALLFN (GVARB CONDX)))))) 00019470 00019480 (MKEX (LAMBDA (U) 00019490 (COND ((EQ *MODE (QUOTE SYMBOLIC)) U) (T (APROC U))))) 00019500 00019510 (APROC (LAMBDA (U) 00019520 (COND ((NULL U) NIL) 00019530 ((ATOM U) 00019540 (COND ((AND (NUMBERP U) (FIXP U)) U) 00019550 (T (LIST (QUOTE REVAL) (MKARG U))))) 00019560 ((MEMBER (CAR U) (QUOTE (COND PROG))) U) 00019570 ((MEMBER (CAR U) (QUOTE (EQUAL UNEQ))) 00019580 (LIST (CAR U) 00019590 (LIST (QUOTE REVAL) 00019600 (MKARG 00019610 (LIST (QUOTE PLUS) 00019620 (CADR U) 00019630 (LIST (QUOTE MINUS) (CARX (CDDR U)))))) 00019640 0)) 00019650 (T (CONS (CAR U) (MAPCAR (CDR U) (FUNCTION APROC))))))) 00019660 00019670 (ARB (LAMBDA (U) 00019680 T)) 00019690 00019700 (GVARB (LAMBDA (U) 00019710 (COND ((ATOM U) (COND ((NUMBERP U) NIL) (T (LIST U)))) 00019720 ((EQ (CAR U) (QUOTE QUOTE)) NIL) 00019730 (T 00019740 (MAPCON (CDR U) (FUNCTION (LAMBDA (J) (GVARB (CAR J))))))))) 00019750 00019760 )) 00019770 00019780 FLAG ((THEN ELSE END STEP DO SUM PRODUCT UNTIL WHILE) DELIM) 00019790 00019800 DEFINE (( 00019810 00019820 (ALGFN (LAMBDA NIL 00019830 (ALGFN* (QUOTE ALGEBRAIC)))) 00019840 00019850 (LSPFN (LAMBDA NIL 00019860 (ALGFN* (QUOTE SYMBOLIC)))) 00019870 00019880 (ALGFN* (LAMBDA (U) 00019890 (PROG (X) 00019900 (COND ((EQ CURSYM* (QUOTE PROCEDURE)) (GO A)) 00019910 ((EQ CURSYM* (QUOTE MACRO)) (SETQ DEFN* CURSYM*)) 00019920 ((EQ CURSYM* (QUOTE FEXPR)) 00019930 (SETQ DEFN* (QUOTE DEFEXPR)))) 00019940 (COND 00019950 ((FLAGP** (SCAN) (QUOTE DELIM)) (GO B))) 00019960 A (SETQ TMODE* *MODE) 00019970 (SETQ *MODE U) 00019980 (COND 00019990 ((NOT (EQ CURSYM* (QUOTE PROCEDURE))) 00020000 (RETURN (COMMAND1 NIL)))) 00020010 (SETQ X (PROCDEF)) 00020020 (COND 00020030 ((NOT (EQ U (QUOTE SYMBOLIC)))(FLAG (CDR X)(QUOTE OPFN)))) 00020035 (RETURN (CONS (QUOTE QUOTE) (CDR X))) 00020040 B (SETQ *MODE U)))) 00020050 00020060 (RLIS (LAMBDA NIL 00020070 (RLIS* T))) 00020080 00020090 (NORLIS (LAMBDA NIL 00020100 (RLIS* NIL))) 00020110 00020120 (RLIS* (LAMBDA (U) 00020130 (PROG (X Y) 00020140 (SETQ X CURSYM*) 00020150 (COND ((FLAGP** (SCAN) (QUOTE DELIM)) (GO A))) 00020160 (SETQ Y (REMCOMMA (MREAD NIL))) 00020170 (COND (U (SETQ Y (LIST Y)))) 00020180 A (RETURN (CONS X (MAPCAR Y (FUNCTION MKARG))))))) 00020190 00020200 )) 00020210 00020220 DEFINE (( 00020230 00020240 (COMM1* (LAMBDA NIL 00020250 (COMM1 T))) 00020260 00020270 (COMM1 (LAMBDA (U) 00020280 (PROG (X Y) 00020290 (SETQ X (AND (OR *ECHO ECHO*) *NAT)) 00020300 (COND 00020310 ((AND (EQ U (QUOTE END)) 00020320 (MEMBER (SCAN) (QUOTE (ELSE END UNTIL *RPAR*)))) 00020330 (GO RET1))) 00020340 (COND (U (GO LOOP)) (X (PRINC* CRCHAR*))) 00020350 (SETQ Y (LIST CRCHAR*)) 00020360 (GO A) 00020370 LOOP (COND ((NULL U) (GO L1)) 00020380 ((EQ CURSYM* (QUOTE *SEMICOL*)) (GO RET1)) 00020390 ((OR (EQ CRCHAR* **SEMICOL) 00020400 (EQ CRCHAR* **DOLLAR) 00020410 (EQ CRCHAR* **ESC)) 00020420 (GO RET))) 00020430 L1 (COND (X (PRINC* CRCHAR*))) 00020440 (COND 00020450 ((OR (NULL U) (EQ U (QUOTE END))) 00020460 (SETQ Y (CONS CRCHAR* Y)))) 00020470 (COND 00020480 ((AND (EQ U (QUOTE END)) 00020490 (EQ CRCHAR* (QUOTE D)) 00020500 (EQCAR (CDR Y) (QUOTE N)) 00020510 (EQCAR (CDDR Y) (QUOTE E)) 00020520 (SETQ CRCHAR* **BLANK) 00020530 (SETQ CURSYM* (QUOTE END))) 00020540 (GO RET1)) 00020550 ((AND (NULL U) (EQ CRCHAR* **SMARK)) (GO RETS))) 00020560 A (SETQ CRCHAR* (READCH*)) 00020570 (GO LOOP) 00020580 RET (SCAN) 00020590 RET1 (RETURN (COND (X (TERPRI*)) (T NIL))) 00020600 RETS (SETQ CURSYM* (MKSTRING (REVERSE Y))) 00020610 (READCH*) 00020620 (RETURN CURSYM*)))) 00020630 00020640 (QOTPRI (LAMBDA (U) 00020650 (PROG2 (PRINC* **QMARK) (PRIN0* (CAR U))))) 00020660 00020670 (PRIN0* (LAMBDA (U) 00020680 (PROG NIL 00020690 (COND ((ATOM U) (RETURN (PRINC* U)))) 00020700 (PRINC* **LPAR) 00020710 A (COND ((NULL U) (GO B)) ((ATOM U) (GO C))) 00020720 (PRIN0* (CAR U)) 00020730 (COND ((CDR U) (PRINC* **BLANK))) 00020740 (SETQ U (CDR U)) 00020750 (GO A) 00020760 B (RETURN (PRINC* **RPAR)) 00020770 C (PRINC* **DOT) 00020780 (PRINC* **BLANK) 00020790 (PRINC* U) 00020800 (GO B)))) 00020810 00020820 )) 00020830 00020840 DEFLIST (((QUOTE QOTPRI)) SPECPRN) 00020850 00020860 DEFINE (( 00020870 00020880 (LMDEF (LAMBDA NIL 00020890 (PROG (X) 00020900 (COND 00020910 ((NOT (EQ *MODE (QUOTE SYMBOLIC))) 00020920 (CURERR (QUOTE ALGEBRAIC) T))) 00020930 (SETQ CURSYM* (QUOTE *COMMA*)) 00020940 (SETQ X (MREAD NIL)) 00020950 (RETURN (LIST (QUOTE LAMBDA) (CDR X) (COMMAND1 NIL)))))) 00020960 00020970 (WRITEFN (LAMBDA NIL 00020980 (PROG (X Y Z) 00020990 (SETQ X (MREAD* NIL)) 00021000 (SETQ PRI* T) 00021010 (SETQ X 00021020 (COND 00021030 ((EQCAR X (QUOTE *COMMA*)) (CDR X)) 00021040 (T (LIST X)))) 00021050 A (COND ((NULL X) (GO B))) 00021060 (SETQ Z (COMMAND1 (LIST (CAR X)))) 00021065 (COND ((NULL (CDR X)) (SETQ Z (LIST (QUOTE RETURN) Z)))) 00021070 (SETQ Y (ACONC Y Z)) 00021075 (SETQ X (CDR X)) 00021080 (GO A) 00021090 B (SETQ PRI* NIL) 00021100 (RETURN (MKPROG NIL (CONS (QUOTE (TERPRI*)) Y)))))) 00021110 00021120 )) 00021130 00021140 DEFINE (( 00021150 00021160 (ON1 (LAMBDA (U V) 00021170 (PROG (X) 00021180 A (COND ((NULL U) (RETURN NIL))) 00021190 (PTS (COMPRESS (APPEND (EXPLODE **STAR) (EXPLODE (CAR U)))) 00021200 V) 00021210 (COND 00021220 ((SETQ X (ASSOC V (GET* (CAR U) (QUOTE SIMPFG)))) 00021230 (*APPLY (CONVRT (CDR X) NIL) NIL))) 00021240 (SETQ U (CDR U)) 00021250 (GO A)))) 00021260 00021270 (ON (LAMBDA (U) 00021280 (ON1 U T))) 00021290 00021300 (OFF (LAMBDA (U) 00021310 (ON1 U NIL))) 00021320 00021330 )) 00021340 00021350 DEFINE (( 00021360 00021370 (AARRAY (LAMBDA (U) 00021380 (PROG (X Y) 00021390 A (COND ((NULL U) (RETURN NIL))) 00021400 (SETQ X (CAR U)) 00021410 (COND 00021420 ((OR (NUMBERP (CAR X)) 00021430 (NOT (ATOM (CAR X))) 00021440 (GET (CAR X) (QUOTE SIMPFN)) 00021460 (GET (CAR X) (QUOTE APROP))) 00021465 (REDERR (APPEND (QUOTE (TYPE CONFLICT FOR)) 00021470 (LIST (CAR X))))) 00021475 ((NOT (NUMLIS (SETQ Y (MAPCAR (CDR X) 00021480 (FUNCTION REVAL))))) (ERRPRI2 X))) 00021485 (PUT (CAR X) (QUOTE **ARRAY) Y) 00021490 (*ARRAY 00021495 (LIST (CONS (CAR X) (MAPCAR Y (FUNCTION ADD1))))) 00021500 B (SETQ U (CDR U)) 00021520 (GO A)))) 00021530 00021560 (NUMLIS (LAMBDA (U) 00021570 (OR (NULL U) (AND (NUMBERP (CAR U)) (NUMLIS (CDR U)))))) 00021580 00021590 )) 00021600 00021610 DEFLIST (((AARRAY RLIS)) STAT) 00021620 00021630 (LAMBDA NIL (PUT (QUOTE ARRAY) (QUOTE NEWNAME) (QUOTE AARRAY))) NIL 00021640 00021650 DEFINE (( 00021660 00021670 (BEGIN1 (LAMBDA NIL 00021680 (PROG (RESULT) 00021690 (SETQ CURSYM* NIL) 00021700 A (TERPRI) 00021710 (COND ((AND TMODE* (SETQ *MODE TMODE*)) (SETQ TMODE* NIL))) 00021720 (SETQ ECHO* *ECHO) 00021730 (SETQ ERFG* NIL) 00021740 (COND ((EQ CURSYM* (QUOTE END)) (GO ND0))) 00021750 (SETQ CRCHAR* **BLANK) 00021760 (SETQ DEFN* (QUOTE DEFINE)) 00021770 (OVOFF) 00021771 (SETQ PROGRAM* (ERRORSET (QUOTE (COMMAND)) T)) 00021780 (COND ((OR (ATOM PROGRAM*) (CDR PROGRAM*)) (GO ERR1))) 00021790 (SETQ PROGRAM* (CAR PROGRAM*)) 00021800 (COND 00021810 ((EQ (CAR PROGRAM*) (QUOTE RETRY)) 00021820 (SETQ PROGRAM* PROGRAML*)) 00021830 ((EQCAR PROGRAM* (QUOTE *COMMA*)) (GO ER)) 00021835 ((EQ (CAR PROGRAM*) (QUOTE END)) (GO ND1)) 00021840 (DIAG* (GO D))) 00021850 B (COND (PLINE* (TERPRI*))) 00021852 (SETQ ECHO* (QUOTE RESULT)) 00021860 (SETP) 00021870 (OVON) 00021871 (SETQ RESULT 00021880 (ERRORSET (CONVRT (GTS (QUOTE PROGRAM*)) NOCMP*) T)) 00021890 (COND ((OR (ATOM RESULT) (CDR RESULT)) (GO ERR2)) 00021900 ((EQ *MODE (QUOTE SYMBOLIC)) (AND (EQ SEMIC* **SEMICOL) 00021910 (PROG2 (PRINT (CAR RESULT)) (TERPRI)))) 00021920 ((CAR RESULT) (SETQ *ANS (CAR RESULT)))) 00021930 (SETQ ORIG* 0) 00021940 (CLOSELINE) 00021950 (COND ((NULL *INT) (PRINTTY **STAR))) 00021960 (GO A) 00021970 D (COND ((OR (ATOM PROGRAM*)(EQ (CAR PROGRAM*) (QUOTE QUOTE))) 00021972 (GO A)) 00021974 ((FLAGP (CAR PROGRAM*) (QUOTE IGNORE)) (GO B))) 00021975 (PRINT (CONVRT PROGRAM* NIL)) 00021978 (GO A) 00021979 ND0 (COMM1 (QUOTE END)) 00021980 ND1 00022000 (RETURN (FINF)) 00022010 ERR1 (COND ((OR (EQ PROGRAM* **ESC) (EQ PROGRAM* **EOF)) (GO A))) 00022020 (GO ERR3) 00022030 ER (LPRIE (COND ((NOT (ATOM (CADR PROGRAM*))) 00022032 (LIST (CAADR PROGRAM*) (QUOTE UNDEFINED))) 00022034 (T (QUOTE (SYNTAX ERROR)))) T) 00022036 (GO ERR3) 00022038 ERR2 (SETQ PROGRAML* PROGRAM*) 00022040 ERR3 (COND 00022050 ((NULL ERFG*) 00022060 (LPRIE (QUOTE (ERROR TERMINATION *****)) NIL))) 00022070 (SETQ ORIG* 0) 00022080 (TERPRI*) 00022090 (COND (IFL* (PAUSE)) (OFL* (PRINTTY **STAR))) 00022100 (GO A)))) 00022110 00022120 (FINF (LAMBDA NIL 00022130 (PROG NIL 00022140 (COND (IFL* (GO A))) 00022150 (MAPCAR (APPEND IPL* OPL*) (FUNCTION CLOSE)) 00022160 (SETQ IPL* NIL) 00022170 (SETQ OPL* NIL) 00022180 (SETQ OFL* NIL) 00022190 (LPRIW NIL T **ENDMSG) 00022200 (RETURN (QUOTE ***)) 00022210 A (CLOSE IFL*) 00022220 (SETQ IPL* (DELETE IFL* IPL*)) 00022221 (RDS (SETQ IFL* (COND (IPL* (CAR IPL*)) (T NIL)))) 00022222 (LPRIM* NIL)))) 00022260 00022270 )) 00022280 00022290 DEFLIST (((FOR FORSTAT) (FORALL FORALLFN*) (IF IFSTAT) (BEGIN PROCBLOCK 00022300 ) (IN RLIS) (OUT RLIS) (SHUT RLIS) (GO GOFN) (GOTO GOFN) (RETURN RETFN 00022310 ) (INTEGER DECL*) (SCALAR DECL*) (WRITE WRITEFN) ( 00022320 REAL DECL*) (LISP LSPFN) (ALGEBRAIC ALGFN) (RETRY NORLIS) (PROCEDURE 00022330 ALGFN)(MACRO LSPFN)(FEXPR LSPFN) (SYMBOLIC LSPFN) (ON RLIS) (OFF RLIS 00022340 ) (END ENDFN) (COMMENT COMM1*) (INFIX INFIXFN) (PRECEDENCE PRECEDFN)) 00022350 STAT) 00022360 00022370 DEFLIST (((BEGIN PROCBLOCK) (FOR FORSTAT) (IF IFSTAT) (LAMBDA LMDEF)) 00022380 ISTAT) 00022390 00022400 (LAMBDA (U) (MAP U (FUNCTION (LAMBDA (J) (PTS (CAR J) NIL))))) ((*GCD 00022410 *EXP *MCD *FLOAT MATCH* *DIV *RAT *SUPER MCOND* *ALLFAC *NCMP SUBFG* 00022420 FRLIS1* FRLIS* GAMIDEN* SUB2* RPLIS* SUBL* DSUBL* FACTORS* FRASC* VREP* 00022430 INDICES* WTP* SNO* PNO* *RAT *OUTP MCHFG* *ANS *RESUBS *NERO EXLIST* 00022440 ORDN* *XDN SV* DNL* UPL* EXPTL*)) 00022450 00022460 (LAMBDA (U) (MAP U (FUNCTION (LAMBDA (J) (PTS (CAAR J) (CADAR J)))))) 00022470 (((*EXP T) (*MSG T) (*ALLFAC T) (*MCD T) (SUBFG* T) (EXLIST* ((*))) 00022480 (*RESUBS T) (ORDN* 0) (*ANS 0) (SNO* 500) (*XDN T))) 00022490 00022500 DEFLIST (((EXP ((NIL . RMSUBS1) (T . RMSUBS))) (MCD ((NIL . RMSUBS1) ( 00022510 T . RMSUBS))) (FORT ((NIL LAMBDA NIL (SETQ *NAT NAT**)) (T LAMBDA NIL 00022520 (PROG2 (SETQ NAT** *NAT) (SETQ *NAT NIL))))) (GCD ((T . RMSUBS))) 00022530 (FLOAT ((T . RMSUBS)))) SIMPFG) 00022540 00022550 DEFLIST (((ANTISYMMETRIC RLIS)(CLEAR RLIS)(DENOM NORLIS) (FACTOR RLIS) 00022560 (LET RLIS) (MATCH RLIS) (MKCOEFF NORLIS) (ND NORLIS) (NUMER NORLIS) 00022570 (OPERATOR RLIS) (ORDER RLIS) (REMFAC RLIS) (SAVEAS NORLIS) (SYMMETRIC 00022580 RLIS) (TERMS NORLIS) (WEIGHT RLIS)) STAT) 00022590 00022600 DEFLIST (((PLUS SIMPPLUS) (MINUS SIMPMINUS) (EXPT SIMPEXPT) (SUB 00022610 SIMPSUBS)(DF SIMPDF)(RECIP SIMPRECIP)(QUOTIENT SIMPQUOT) (*SQ SIMP*SQ) 00022620 (TIMES SIMPTIMES)) SIMPFN) 00022630 00022640 DEFLIST (((*ANS (SCALAR)) (*MODE (SCALAR))) DATATYPE) 00022650 00022660 DEFLIST (((I (I NIL (REP (MINUS 1) 2 NIL)))) APROP) 00022670 00022680 DEFINE (( 00022690 00022700 (ABS (LAMBDA (N) 00022710 (COND ((MINUSP N) (MINUS N)) (T N)))) 00022720 00022730 (ASSOC (LAMBDA (U V) 00022740 (SASSOC U V (FUNCTION (LAMBDA NIL NIL))))) 00022750 00022760 (ASSOC* (LAMBDA (U V) 00022770 (COND ((NULL V) NIL) 00022780 ((EQUAL U (CAAR V)) (CAR V)) 00022790 (T (ASSOC* U (CDR V)))))) 00022800 00022810 (ATOMLIS (LAMBDA (U) 00022820 (OR (NULL U) (AND (ATOM (CAR U)) (ATOMLIS (CDR U)))))) 00022830 00022840 (CARX (LAMBDA (U) 00022850 (COND ((NULL (CDR U)) (CAR U)) (T (ERRACH (LIST (QUOTE CARX) U))))) 00022860 ) 00022870 00022880 (DELASC (LAMBDA (U V) 00022890 (COND ((NULL V) NIL) 00022900 ((OR (ATOM (CAR V)) (NOT (EQUAL U (CAAR V)))) 00022910 (CONS (CAR V) (DELASC U (CDR V)))) 00022920 (T (CDR V))))) 00022930 00022940 (MAPCONS (LAMBDA (U *S*) 00022980 (MAPCAR U (FUNCTION (LAMBDA (J) (CONS *S* J)))))) 00022990 00023000 (MAPC2 (LAMBDA (U *PI*) 00023010 (MAPCAR U 00023020 (FUNCTION 00023030 (LAMBDA(J) 00023040 (MAPCAR J (FUNCTION (LAMBDA (K) (*PI* K))))))))) 00023050 00023060 (MEXPR (LAMBDA (U V) 00023070 (COND ((NULL V) NIL) 00023080 ((ATOM V) (EQ U V)) 00023090 (T (OR (MEXPR U (CAR V)) (MEXPR U (CDR V))))))) 00023100 00023110 (NCONS (LAMBDA (U V) 00023120 (COND ((NULL U) V) (T (CONS U V))))) 00023130 00023140 (NLIST (LAMBDA (U N) 00023150 (COND ((ZEROP N) NIL) (T (CONS U (NLIST U (SUB1 N))))))) 00023160 00023170 (NTH (LAMBDA (U N) 00023180 (COND ((ONEP N) (CAR U)) (T (NTH (CDR U) (SUB1 N)))))) 00023190 00023200 (POSN (LAMBDA (U V) 00023210 (COND ((EQ U (CAR V)) 1) (T (ADD1 (POSN U (CDR V))))))) 00023220 00023230 (REMOVE (LAMBDA (X N) 00023240 (COND ((MINUSP N) (ERRACH (LIST (QUOTE REMOVE) X N))) 00023250 ((NULL X) NIL) 00023260 ((ZEROP N) (CDR X)) 00023270 (T (CONS (CAR X) (REMOVE (CDR X) (SUB1 N))))))) 00023280 00023290 (REVPR (LAMBDA (U) 00023300 (CONS (CDR U) (CAR U)))) 00023310 00023320 (RPLACW (LAMBDA (U V) 00023330 (COND 00023340 ((OR (ATOM U) (ATOM V)) (ERRACH (LIST (QUOTE RPLACW) U V))) 00023350 (T (RPLACD (RPLACA U (CAR V)) (CDR V)))))) 00023360 00023370 (REPEATS (LAMBDA (X) 00023380 (COND ((NULL X) NIL) 00023390 ((MEMBER (CAR X) (CDR X)) (CONS (CAR X) (REPEATS (CDR X)))) 00023400 (T (REPEATS (CDR X)))))) 00023410 00023420 (UNION (LAMBDA (X Y) 00023430 (COND ((NULL X) Y) 00023440 (T 00023450 (UNION (CDR X) 00023460 (COND ((MEMBER (CAR X) Y) Y) 00023470 (T (CONS (CAR X) Y)))))))) 00023480 00023490 )) 00023500 00023510 DEFINE (( 00023520 00023530 (REPPRI (LAMBDA (U V) 00023540 (MESPRI NIL U (QUOTE (REPRESENTED BY)) V NIL))) 00023550 00023560 (REDEFPRI (LAMBDA (U) 00023570 (COND ((NULL U) NIL) 00023580 (T 00023590 (MESPRI (QUOTE (ASSIGNMENT FOR)) 00023600 U 00023610 (QUOTE (REDEFINED)) 00023620 NIL 00023630 NIL))))) 00023640 00023650 (MESPRI (LAMBDA (U V W X Y) 00023660 (PROG (Z) 00023670 (COND 00023680 ((AND (NULL Y) (NULL *MSG)) (RETURN NIL)) 00023690 ((AND OFL* (OR *FORT (NOT *NAT))) (GO B))) 00023700 A (LPRIM U) 00023710 (MAPRIN V) 00023720 (PRINC* **BLANK) 00023730 (LPRI W) 00023740 (MATHPRINT X) 00023750 (COND ((NULL OFL*) (RETURN NIL)) (Z (RETURN (WRS OFL*)))) 00023760 B (WRS NIL) 00023770 (SETQ Z T) 00023780 (GO A)))) 00023790 00023800 (LPRIM (LAMBDA (U) 00023810 (PROG2 (TERPRI*) (LPRI (CONS (QUOTE ***) U))))) 00023820 00023830 (ERRACH (LAMBDA (U) 00023840 (PROG NIL 00023850 (LPRIE (QUOTE (CATASTROPHIC ERROR *****)) T) 00023860 (PRINTTY U) 00023870 (PRINTTY **BLANK) 00023880 (LPRIE (QUOTE 00023890 (PLEASE SEND 00023900 OUTPUT 00023910 AND 00023920 INPUT 00023930 LISTING 00023940 TO 00023950 A 00023960 C 00023970 HEARN 00023980 *****)) 00023990 T) 00024000 (ERROR*)))) 00024010 00024020 (ERRPRI1 (LAMBDA (U) 00024030 (MESPRI (QUOTE (ASSIGNMENT)) U (QUOTE (NOT ALLOWED)) NIL T))) 00024040 00024050 (ERRPRI2 (LAMBDA (U) 00024060 (MESPRI (QUOTE (FORMAT)) U (QUOTE (INCORRECT)) NIL T))) 00024070 00024080 )) 00024090 00024100 DEFINE (( 00024110 00024120 (ORDAD (LAMBDA (A U) 00024130 (COND ((NULL U) (LIST A)) 00024140 ((ORDP A (CAR U)) (CONS A U)) 00024150 (T (CONS (CAR U) (ORDAD A (CDR U))))))) 00024160 00024170 (ORDN (LAMBDA (U) 00024180 (COND ((NULL U) NIL) 00024190 ((NULL (CDR U)) U) 00024200 ((NULL (CDDR U)) (ORD2 (CAR U) (CADR U))) 00024210 (T (ORDAD (CAR U) (ORDN (CDR U))))))) 00024220 00024230 (ORD2 (LAMBDA (U V) 00024240 (COND ((ORDP U V) (LIST U V)) (T (LIST V U))))) 00024250 00024260 (ORDP (LAMBDA (U V) 00024270 (COND ((NULL U) (NULL V)) 00024280 ((NULL V) T) 00024290 ((ATOM U) 00024300 (COND 00024310 ((ATOM V) 00024320 (COND ((NUMBERP U) (AND (NUMBERP V) (NOT (LESSP U V)))) 00024330 ((NUMBERP V) T) 00024340 (T (ORDERP U V)))) 00024350 (T T))) 00024360 ((ATOM V) NIL) 00024370 ((EQUAL (CAR U) (CAR V)) (ORDP (CDR U) (CDR V))) 00024380 (T (ORDP (CAR U) (CAR V)))))) 00024390 00024400 )) 00024410 00024420 DEFINE (( 00024430 00024440 (ADDSQ (LAMBDA (U V) 00024450 (COND ((EQUAL (CDR U) (CDR V)) 00024460 (CONS (ADDF (CAR U) (CAR V)) (CDR U))) 00024470 ((NULL (CAR U)) V) 00024480 ((NULL (CAR V)) U) 00024490 ((NULL *MCD) (CONS (ADDF (MKSQP U) (MKSQP V)) 1)) 00024500 (T 00024510 ((LAMBDA(Z) 00024520 ((LAMBDA(X Y) 00024530 (COND ((OR (NULL X) (NULL Y)) (ERRACH (QUOTE ADDSQ))) (T 00024531 (CONS (ADDF (MULTF Y (CAR U)) (MULTF X (CAR V))) 00024540 (MULTF Y (CDR U)))) 00024550 )) 00024551 (QUOTF (CDR U) Z) 00024560 (QUOTF (CDR V) Z))) 00024570 (GCD1 (CDR U) (CDR V))))))) 00024580 00024590 (ADDF (LAMBDA (U V) 00024600 (COND ((NULL U) V) 00024610 ((NULL V) U) 00024620 ((ATOM U) (ADDN U V)) 00024630 ((ATOM V) (ADDN V U)) 00024640 ((EQUAL (CAAR U) (CAAR V)) 00024650 ((LAMBDA(X) 00024660 (COND ((NULL X) (ADDF (CDR U) (CDR V))) 00024670 (T 00024680 (CONS (CONS (CAAR U) X) (ADDF (CDR U) (CDR V)))))) 00024690 (ADDF (CDAR U) (CDAR V)))) 00024700 ((ORDP (CAAR U) (CAAR V)) (CONS (CAR U) (ADDF (CDR U) V))) 00024710 (T (CONS (CAR V) (ADDF U (CDR V))))))) 00024720 00024730 (ADDN (LAMBDA (N V) 00024740 (COND ((NULL V) N) 00024750 ((ATOM V) 00024760 ((LAMBDA (M) (COND ((ZEROP M) NIL) (T M))) (PLUS N V))) 00024770 (T (CONS (CAR V) (ADDN N (CDR V))))))) 00024780 00024790 (MULTSQ (LAMBDA (U V) 00024800 (COND 00024810 ((OR (NULL (CAR U)) (NULL (CAR V))) (CONS NIL 1)) 00024820 (T 00024830 ((LAMBDA(X Y) 00024840 (COND ((AND X Y) (CONS (MULTF X Y) 1)) 00024850 (X (CONS (MULTF X (CAR V)) (CDR U))) 00024860 (Y (CONS (MULTF (CAR U) Y) (CDR V))) 00024870 (T 00024880 (CONS (MULTF (CAR U) (CAR V)) 00024890 (MULTF (CDR U) (CDR V)))))) 00024900 (QUOTF (CAR U) (CDR V)) 00024910 (QUOTF (CAR V) (CDR U))))))) 00024920 00024930 (MULTF (LAMBDA (U V) 00024940 (PROG (X Y Z) 00024950 (COND ((OR (NULL U) (NULL V)) (RETURN NIL)) 00024960 ((ATOM U) (RETURN (MULTN U V))) 00024970 ((ATOM V) (RETURN (MULTN V U))) 00024980 ((OR *EXP *NCMP) (GO A))) 00024990 (SETQ U (MKSFP U 1)) 00025000 (SETQ V (MKSFP V 1)) 00025010 (COND ((ATOM U) (RETURN (MULTN U V))) 00025020 ((ATOM V) (RETURN (MULTN V U)))) 00025030 A (SETQ X (CAAAR U)) 00025040 (SETQ Y (CAAAR V)) 00025050 (COND 00025060 ((OR (ATOM X) 00025070 (ATOM Y) 00025080 (NOT (ATOM (CAR X))) 00025090 (NOT (ATOM (CAR Y)))) 00025100 (GO B)) 00025110 ((AND (EQ (CAR X) (CAR Y)) 00025120 (SETQ Z (GET (CAR X) (QUOTE MRULE))) 00025130 (NOT 00025140 (EQ (SETQ Z (*APPLY Z (LIST (CAAR U) (CAAR V)))) 00025150 (QUOTE FAILED)))) 00025160 (RETURN 00025170 (ADDF (MULTF Z (MULTF (CDAR U) (CDAR V))) 00025180 (ADDF (MULTF (LIST (CAR U)) (CDR V)) 00025190 (MULTF (CDR U) V))))) 00025200 ((AND (FLAGP (CAR X) (QUOTE NONCOM)) 00025210 (FLAGP (CAR Y) (QUOTE NONCOM))) 00025220 (GO B1))) 00025230 B (COND ((EQ X Y) (GO C)) 00025240 ((ORDP (CAAR U) (CAAR V)) (GO B1))) 00025250 (SETQ X (MULTF U (CDAR V))) 00025260 (SETQ Y (MULTF U (CDR V))) 00025270 (RETURN (COND ((NULL X) Y) (T (CONS (CONS (CAAR V) X) Y)))) 00025280 B1 (SETQ X (MULTF (CDAR U) V)) 00025290 (SETQ Y (MULTF (CDR U) V)) 00025300 (RETURN (COND ((NULL X) Y) (T (CONS (CONS (CAAR U) X) Y)))) 00025310 C (SETQ X (MKSP X (PLUS (CDAAR U) (CDAAR V)))) 00025320 (SETQ Y 00025330 (ADDF (MULTF (LIST (CAR U)) (CDR V)) 00025340 (MULTF (CDR U) V))) 00025350 (RETURN 00025360 (COND 00025370 ((NULL (CDR X)) 00025380 (COND ((NULL (CAAR X)) Y) 00025390 (T 00025400 (ADDF (MULTF (CAAR X) 00025410 (MULTF (CDAR U) 00025420 (COND 00025430 ((EQUAL (CDAR X) 1) (CDAR V)) 00025440 (T 00025450 (MULTF 00025460 (MKSQP (CONS 1 (CDAR X))) 00025470 (CDAR V)))))) 00025480 Y)))) 00025490 ((NULL (SETQ U (MULTF (CDAR U) (CDAR V)))) Y) 00025495 (T (CONS (CONS X U) Y))))))) 00025500 00025510 (MULTF2 (LAMBDA (U V) 00025520 (MULTF (LIST (CONS U 1)) V))) 00025530 00025540 (MULTN (LAMBDA (N V) 00025550 (COND ((NULL V) NIL) 00025560 ((ZEROP N) NIL) 00025570 ((ONEP N) V) 00025580 ((NUMBERP V) (TIMES N V)) 00025590 ((EQ (CAR V) (QUOTE QUOTIENT)) 00025591 (MKFR (TIMES N (CADR V)) (CADDR V))) 00025592 (T 00025600 (CONS (CONS (CAAR V) (MULTN N (CDAR V))) 00025610 (MULTN N (CDR V))))))) 00025620 00025630 )) 00025640 00025650 DEFINE (( 00025660 00025670 (REVAL (LAMBDA (U) 00025680 (COND ((AND (NUMBERP U) (FIXP U)) U) 00025690 ((VECTORP U) U) 00025700 (T ((LAMBDA (X) 00025710 (COND ((AND (EQCAR X (QUOTE MINUS)) (NUMBERP (CADR X))) 00025712 (MINUS (CADR X))) 00025714 (T X))) 00025716 (PREPSQ (AEVAL1 U))))))) 00025718 00025720 (AEVAL (LAMBDA (U) 00025730 (COND 00025740 ((EQCAR U (QUOTE *COMMA*)) (REDERR (QUOTE (SYNTAX ERROR)))) 00025750 (T (MK*SQ (AEVAL1 U)))))) 00025760 00025770 (AEVAL1 (LAMBDA (U) 00025780 (PROG2 (RSET2) 00025790 (COND ((MATEXPR U) (MATSM U)) (T (SUBS2 (SIMP* U))))))) 00025800 00025810 (MATEXPR (LAMBDA (U) 00025820 NIL)) 00025830 00025840 (MK*SQ (LAMBDA (U) 00025880 (COND ((NULL (CAR U)) 0) 00025890 ((AND (ATOM (CAR U)) (EQUAL (CDR U) 1)) (CAR U)) 00025900 ((EQCAR U (QUOTE MAT)) U) 00025910 (T (CONS (QUOTE *SQ) (CONS U *SQVAR*)))))) 00025920 00025930 (RSET2 (LAMBDA NIL 00025940 (PROG2 (MAP RPLIS* 00025950 (FUNCTION (LAMBDA (J) (RPLACW (CDAR J) (CAAR J))))) 00025960 (SETQ RPLIS* NIL)))) 00025970 00025980 )) 00025990 00026000 DEFINE (( 00026010 00026020 (MKSP (LAMBDA (U P) 00026030 (PROG (V X Y) 00026040 (SETQ U (FKERN U)) 00026050 A0 (SETQ V (CDDR U)) 00026060 A (COND ((OR (NULL V) (NULL SUBFG*)) (GO B)) 00026070 ((SETQ X (ASSOC (QUOTE ASYMP) V)) (GO L1)) 00026080 ((SETQ X (ASSOC (QUOTE REP) V)) (GO L2)) 00026090 ((AND (NOT (ATOM (CAR U))) 00026110 (ATOM (CAAR U)) 00026120 (FLAGP (CAAR U) (QUOTE VOP)) 00026130 (VCREP U)) 00026140 (GO A0))) 00026150 B (RETURN (GETPOWER U P)) 00026170 L1 (COND 00026180 ((NOT (LESSP P (CDR X))) (RETURN (LIST (CONS NIL 1))))) 00026190 (SETQ V (DELASC (CAR X) V)) 00026200 (GO A) 00026210 L2 (SETQ V (CDDDR X)) 00026220 (COND ((LESSP P (CADDR X)) (GO B)) 00026230 ((AND (CAR V) 00026231 (NOT (FLAGP** (CAR U) (QUOTE WEIGHT)))) (GO L3))) 00026232 (SETQ SUBL* (CONS V SUBL*)) 00026240 (SETQ Y (SIMPCAR (CDR X))) 00026250 (COND 00026260 ((NOT (ASSOC (QUOTE HOLD) (CDDR U))) (GO L21)) 00026270 ((EQUAL (CDR Y) 1) (SETQ Y (CONS (MKSFP (CAR Y) 1) 1))) 00026280 (T (SETQ Y (MKSQP Y)))) 00026290 L21 (RPLACA V (MK*SQ Y)) 00026295 (GO L31) 00026300 L3 (SETQ Y (SIMPCAR V)) 00026305 (COND((AND(EQCAR (CAR V)(QUOTE *SQ))(NULL(CADDAR V)))(GO L21)))00026310 L31 (SETQ V Y) 00026315 (SETQ X (CADDR X)) 00026320 (COND ((ONEP X) (RETURN (LIST (NMULTSQ V P))))) 00026330 (SETQ Y (DIVIDE P X)) 00026340 C (SETQ V (NMULTSQ V (CAR Y))) 00026370 (COND 00026380 ((NOT (ZEROP (CDR Y))) 00026390 (SETQ V 00026400 (CONS (MULTF2 (GETPOWER U (CDR Y)) (CAR V)) 00026410 (CDR V))))) 00026420 (RETURN (LIST V))))) 00026470 00026500 (FKERN (LAMBDA (U) 00026510 (PROG (V) 00026520 (COND ((NOT (ATOM U)) (GO A0)) 00026530 ((SETQ V (GET U (QUOTE APROP))) (RETURN V))) 00026540 (SETQ V (LIST U NIL)) 00026550 (PUT U (QUOTE APROP) V) 00026560 (RETURN V) 00026570 A0 (COND ((NOT (ATOM (CAR U))) (SETQ V EXLIST*)) 00026580 ((NOT (SETQ V (GET (CAR U) (QUOTE KLIST)))) (GO B))) 00026590 A (COND ((EQUAL U (CAAR V)) (RETURN (CAR V))) 00026600 ((ORDP U (CAAR V)) 00026610 (RETURN 00026620 (CAR 00026630 (RPLACW V 00026640 (CONS (LIST U NIL) 00026650 (CONS (CAR V) (CDR V))))))) 00026660 ((NULL (CDR V)) 00026670 (RETURN (CADR (RPLACD V (LIST (LIST U NIL))))))) 00026680 (SETQ V (CDR V)) 00026690 (GO A) 00026700 B (SETQ V (LIST (LIST U NIL))) 00026710 (PUT (CAR U) (QUOTE KLIST) V) 00026720 (GO A)))) 00026730 00026740 (GETPOWER (LAMBDA (U N) 00026750 (PROG (V) 00026760 (COND ((AND SUBFG* (NOT (ASSOC (QUOTE USED*) (CDR U)))) 00026761 (ACONC U (LIST (QUOTE USED*))))) 00026762 (SETQ V (CADR U)) 00026770 (COND 00026780 ((NULL V) 00026790 (RETURN (CAAR (RPLACA (CDR U) (LIST (CONS (CAR U) N))))))) 00026800 A (COND ((EQUAL N (CDAR V)) (RETURN (CAR V))) 00026810 ((LESSP N (CDAR V)) 00026820 (RETURN 00026830 (CAR 00026840 (RPLACW V 00026850 (CONS (CONS (CAAR V) N) 00026860 (CONS (CAR V) (CDR V))))))) 00026870 ((NULL (CDR V)) 00026880 (RETURN (CADR (RPLACD V (LIST (CONS (CAAR V) N))))))) 00026890 (SETQ V (CDR V)) 00026900 (GO A)))) 00026910 00026920 (NMULTSQ (LAMBDA (U N) 00026930 (PROG (X) 00026940 (COND 00026950 ((NULL (CAR U)) (RETURN U)) 00026955 ((NULL *EXP) 00026960 (RETURN (CONS (MKSFP (CAR U) N) (MKSFP (CDR U) N))))) 00026970 (SETQ X U) 00026980 A (COND ((ONEP N) (RETURN X))) 00026990 (SETQ X (MULTSQ U X)) 00027000 (SETQ N (SUB1 N)) 00027010 (GO A)))) 00027020 00027030 )) 00027040 00027050 DEFINE (( 00027060 00027070 (MKSF (LAMBDA (U N) 00027080 ((LAMBDA(X) 00027090 (COND 00027100 ((NULL (CDR X)) 00027110 (COND ((EQUAL (CDAR X) 1) (CAAR X)) 00027120 (T (MULTF (MKSQP (CONS 1 (CDAR X))) (CAAR X))))) 00027130 (T (LIST (CONS X 1))))) 00027140 (MKSP U N)))) 00027150 00027160 (MKSFP (LAMBDA (U N) 00027170 (COND ((KERNLP U) (NMULTF U N)) 00027180 (T 00027190 (PROG2 (SETQ SUB2* T) 00027200 (COND ((MINUSF U) (MULTN -1 (MKSF (MULTN -1 U) N))) 00027210 (T (MKSF U N)))))))) 00027220 00027230 (MKSQP (LAMBDA (U) 00027240 (COND ((NULL (CAR U)) NIL) 00027250 ((OR (EQUAL (CDR U) 1) (EQUAL (CDR (SETQ U (CANCEL U))) 1)) 00027260 (COND (*EXP (CAR U)) (T (MKSFP (CAR U) 1)))) 00027270 (T 00027280 (PROG NIL 00027290 (SETQ SUB2* T) 00027300 (RETURN 00027310 (COND (*EXP 00027320 (MULTF (CAR U) 00027330 (MKSF (MK*SQ 00027340 (CONS 1 (MKSFP (CDR U) 1))) 00027350 1))) 00027360 ((MINUSF (CAR U)) 00027370 (MULTN -1 00027380 (MKSF 00027390 (MK*SQ 00027400 (CONS (MULTN -1 (CAR U)) 00027410 (MKSFP (CDR U) 1))) 00027420 1))) 00027430 (T 00027440 (MKSF (MK*SQ 00027450 (CONS (CAR U) (MKSFP (CDR U) 1))) 00027460 1))))))))) 00027470 00027480 (MKSQ (LAMBDA (U N) 00027570 ((LAMBDA(X) 00027580 (COND ((NULL (CDR X)) (CAR X)) (T (CONS (LIST (CONS X 1)) 1)))) 00027590 (MKSP U N)))) 00027600 00027610 )) 00027620 00027630 DEFINE (( 00027640 00027650 (SIMP* (LAMBDA (U) 00027660 (COND ((LESSP (SCNT U) SNO*) (ISIMPQ (SIMP U))) 00027670 ((EQ (CAR U) (QUOTE PLUS)) (SIMPADD (CDR U))) 00027680 ((EQ (CAR U) (QUOTE MINUS)) (NEGSQ (SIMP* (CARX (CDR U))))) 00027690 ((EQ (CAR U) (QUOTE TIMES)) (ISIMPQ* (TSCAN (CDR U)))) 00027700 (T (ISIMPQ (SIMP U)))))) 00027710 00027720 (SIMPADD (LAMBDA (U) 00027730 (PROG (Z) 00027740 (SETQ Z (CONS NIL 1)) 00027750 A (COND ((NULL U) (RETURN Z))) 00027760 (SETQ Z (ADDSQ (SIMP* (CAR U)) Z)) 00027770 (SETQ U (CDR U)) 00027780 (GO A)))) 00027790 00027800 (ISIMPQ* (LAMBDA (U) 00027810 (PROG (X) 00027820 (SETQ U (REVERSE (MAPCAR U (FUNCTION SIMP)))) 00027830 (SETQ SV* (CONS NIL 1)) 00027840 (ISIMPQ*1 (CDR U) (CAR U)) 00027850 (SETQ X SV*) 00027860 (SETQ SV* NIL) 00027870 (RETURN X)))) 00027880 00027890 (ISIMPQ*1 (LAMBDA (U V) 00027900 (PROG (X Y) 00027910 (COND ((NULL U) (RETURN (SETQ SV* (ADDSQ (ISIMPQ V) SV*))))) 00027920 (SETQ X (CAAR U)) 00027930 (SETQ Y (MULTF (CDAR U) (CDR V))) 00027940 (SETQ V (CAR V)) 00027950 A (COND ((NULL X) (RETURN NIL)) 00027960 ((ATOM X) 00027970 (RETURN (ISIMPQ*1 (CDR U) (CONS (MULTN X V) Y))))) 00027980 (ISIMPQ*1 (CDR U) (CONS (MULTF (LIST (CAR X)) V) Y)) 00027990 (SETQ X (CDR X)) 00028000 (GO A)))) 00028010 00028020 (ISIMPQ (LAMBDA (U) 00028020 U)) 00028020 00028020 (TSCAN (LAMBDA (U) 00028030 (COND ((NULL U) NIL) 00028040 ((ATOM U) (ERRACH (LIST (QUOTE TSCAN) U))) 00028050 ((EQ (CAR U) (QUOTE TIMES)) (TSCAN (CDR U))) 00028060 ((AND (NOT (ATOM (CAR U))) (EQ (CAAR U) (QUOTE TIMES))) 00028070 (APPEND (TSCAN (CDAR U)) (TSCAN (CDR U)))) 00028080 (T (CONS (CAR U) (TSCAN (CDR U))))))) 00028090 00028100 (SCNT (LAMBDA (U) 00028110 (COND ((OR (NULL U) (EQUAL U 0)) 0) 00028120 ((ATOM U) 1) 00028130 ((EQ (CAR U) (QUOTE PLUS)) 00028140 (*EVAL 00028150 (CONS (QUOTE PLUS) (MAPCAR (CDR U) (FUNCTION SCNT))))) 00028160 ((MEMBER (CAR U) (QUOTE (TIMES G CONS EPS))) 00028170 (*EVAL 00028180 (CONS (QUOTE TIMES) (MAPCAR (CDR U) (FUNCTION SCNT))))) 00028190 ((FLAGP (CAR U) (QUOTE UNIP)) (SCNT (CADR U))) 00028200 ((EQ (CAR U) (QUOTE EXPT)) 00028210 (COND 00028220 ((OR (ATOM (CADR U)) (NOT (NUMBERP (CADDR U)))) 1) 00028230 (T 00028240 ((LAMBDA(X) 00028250 (COND ((LESSP X 2) 1) 00028260 (T (TIMES 2 X (ABS (*EVAL (CADDR U))))))) 00028270 (SCNT (CADR U)))))) 00028280 ((AND (EQ (CAR U) (QUOTE *SQ)) GAMIDEN*) (TERMS1 (CAADR U))) 00028290 (T 1)))) 00028300 00028310 )) 00028320 00028330 DEFINE (( 00028340 00028350 (SIMP (LAMBDA (U) 00028360 (PROG (X) 00028370 A (COND ((ATOM U) (RETURN (SIMPATOM U))) 00028380 ((OR (NOT (ATOM (CAR U))) (NUMBERP (CAR U))) (GO E)) 00028390 ((AND (SETQ X (OPMTCH U)) (SETQ U X)) (GO A)) 00028400 ((SETQ X (GET (CAR U) (QUOTE SIMPFN))) 00028410 (RETURN 00028420 (COND 00028430 ((EQ X (QUOTE IDEN)) (SIMPIDEN U)) 00028440 (T (*APPLY X (LIST (CDR U))))))) 00028450 ((GET (CAR U) (QUOTE **ARRAY)) (GO D)) 00028460 ((FLAGP (CAR U) (QUOTE OPFN)) 00028470 (SETQ U (*APPLY (CAR U) (CDR U)))) 00028480 ((GET (CAR U) (QUOTE INFIX)) (GO E)) 00028490 ((MEMBER (CAR U) (QUOTE (COND PROG))) 00028500 (RETURN (SIMP (*EVAL U)))) 00028510 ((NOT (REDMSG (CAR U) (QUOTE OPERATOR) T)) (ERROR*)) 00028520 (T (MKOP (CAR U)))) 00028530 (GO A) 00028540 D (SETQ U (CONS (CAR U) (MAPCAR (CDR U) (FUNCTION REVAL)))) 00028550 (COND 00028560 ((NOT (NUMLIS (CDR U))) 00028570 (REDERR 00028580 (APPEND (QUOTE (INCORRECT ARRAY ARGUMENTS FOR)) 00028590 (LIST (CAR U))))) 00028600 ((AND (SETQ X (GETEL U)) (SETQ U X)) (GO A)) 00028610 (T (RETURN (MKSQ U 1)))) 00028620 E (CURERR (QUOTE (SYNTAX ERROR)) NIL)))) 00028630 00028640 (SIMPATOM (LAMBDA (U) 00028650 (COND((NULL U)(REDERR(QUOTE(NIL USED IN ALGEBRAIC EXPRESSION)))) 00028660 ((NUMBERP U) 00028670 (COND ((ZEROP U) (CONS NIL 1)) 00028680 ((FIXP U) (CONS U 1)) 00028690 (*FLOAT (CONS (PLUS 0.0 U) 1)) 00028700 (T 00028710 ((LAMBDA(Z) 00028720 (PROG2 (REPPRI U 00028730 (LIST 00028740 (QUOTE QUOTIENT) 00028750 (CAR Z) 00028760 (CDR Z))) 00028770 Z)) 00028780 (MAKFRC U))))) 00028790 ((VECTORP U) 00028800 (REDERR 00028810 (CONS (QUOTE VECTOR) (CONS U (QUOTE (USED AS SCALAR)))))) 00028820 (T (MKSQ U 1))))) 00028830 00028840 (MAKFRC (LAMBDA (U) 00028850 (PROG (X Y) 00028860 (SETQ X (FIX (TIMES **MILLION U))) 00028870 (SETQ Y (GCDN **MILLION X)) 00028880 (RETURN (CONS (QUOTIENT X Y) (QUOTIENT **MILLION Y)))))) 00028890 00028900 (MKOP (LAMBDA (U) 00028910 (COND ((MEMBER U FRLIS*) (REDERR (CONS (QUOTE OPERATOR) 00028920 (CONS U (QUOTE (CANNOT BE ARBITRARY)))))) 00028922 (T (PUT U (QUOTE SIMPFN) (QUOTE IDEN)))))) 00028924 00028930 (SIMPCAR (LAMBDA (U) 00028940 (SIMP (CAR U)))) 00028950 00028960 (VECTORP (LAMBDA (U) 00028970 NIL)) 00028980 00028990 (SIMPEXPT (LAMBDA (U) 00029000 (PROG (N X) 00029010 (COND 00029020 ((AND (NUMBERP (SETQ N (CARX (CDR U)))) (FIXP N)) (GO A))) 00029030 (SETQ X *FLOAT) 00029040 (SETQ *FLOAT NIL) 00029050 (SETQ N (CANCEL (SIMP N))) 00029060 (SETQ *FLOAT X) 00029070 (COND ((AND (ATOM (CAR N)) (EQUAL (CDR N) 1)) (GO A0))) 00029080 (SETQ X (PREPSQ (SIMPCAR U))) 00029090 (SETQ N (PREPSQ N)) 00029100 (COND ((EQCAR X (QUOTE TIMES)) (GO B)) 00029101 ((AND (EQCAR X (QUOTE MINUS)) 00029102 (NOT (NUMBERP (CADR X)))) 00029103 (RETURN 00029104 (MULTSQ (SIMPEXPT (LIST -1 N)) 00029105 (SIMPEXPT (LIST (CADR X) N))))) 00029106 ((EQCAR X (QUOTE QUOTIENT)) 00029107 (RETURN 00029108 (MULTSQ (SIMPEXPT (LIST (CADR X) N)) 00029109 (SIMPEXPT 00029110 (LIST (CADDR X) (LIST (QUOTE MINUS) N)))))) 00029111 ((EQCAR X (QUOTE EXPT)) 00029112 (AND (SETQ N 00029113 (REVAL (LIST (QUOTE TIMES) (CADDR X) N))) 00029114 (SETQ X (CADR X))))) 00029115 (RETURN 00029116 (COND ((EQUAL X 0) (CONS NIL 1)) 00029117 ((EQUAL X 1) (CONS 1 1)) 00029118 ((AND (ATOM X) (MEMBER N FRLIS*)) 00029119 (CONS (LIST (CONS (CONS X N) 1)) 1)) 00029120 (T 00029121 (PROG2 (AND (NOT (MEMBER X EXPTL*)) 00029122 (NOT (NUMBERP X)) 00029123 (SETQ EXPTL* (CONS X EXPTL*))) 00029124 (MKSQ (LIST (QUOTE EXPT) X N) 1))))) 00029125 A0 (SETQ N (CAR N)) 00029170 (COND ((NULL N) (SETQ N 0))) 00029172 A (RETURN 00029180 (COND ((EQUAL N 0) (CONS 1 1)) 00029190 ((ATOM (CAR U)) 00029200 (COND ((NULL N) (CONS 1 1)) 00029210 ((NUMBERP (CAR U)) 00029220 (COND 00029230 ((ZEROP (CAR U)) (CONS NIL 1)) 00029240 ((MINUSP N) 00029250 (CONS 1 (EXPT (CAR U) (MINUS N)))) 00029260 (T (CONS (EXPT (CAR U) N) 1)))) 00029270 ((MINUSP N) 00029280 (LIST 1 (CONS (MKSP (CAR U) (MINUS N)) 1))) 00029290 (T (MKSQ (CAR U) N)))) 00029300 ((MINUSP N) (REVPR (NMULTSQ (SIMPCAR U) (MINUS N)))) 00029310 (T (NMULTSQ (SIMPCAR U) N)))) 00029311 B (SETQ U (CDDR X)) 00029312 (SETQ X (SIMPEXPT (LIST (CADR X) N))) 00029313 C (COND ((NULL U) (RETURN X))) 00029314 (SETQ X (MULTSQ (SIMPEXPT (LIST (CAR U) N)) X)) 00029315 (SETQ U (CDR U)) 00029316 (GO C)))) 00029317 00029318 (MEXPT (LAMBDA (U V) 00029340 (COND 00029350 ((NOT (EQUAL (CADAR U) (CADAR V))) (QUOTE FAILED)) 00029360 (T 00029370 ((LAMBDA(X) 00029380 (COND ((EQUAL X 0) 1) 00029390 ((AND (NUMBERP X) (EQUAL (CADAR U) (QUOTE (MINUS 1)))) 00029400 (COND ((ZEROP (REMAINDER X 2)) 1) (T -1))) 00029410 (T (MKSQP (MKSQ (LIST (QUOTE EXPT) (CADAR U) X) 1))))) 00029450 (REVAL 00029460 (LIST (QUOTE PLUS) 00029470 (LIST (QUOTE TIMES) (CDR U) (CADDAR U)) 00029480 (LIST (QUOTE TIMES) (CDR V) (CADDAR V))))))))) 00029490 00029500 )) 00029510 00029520 DEFLIST (((EXPT MEXPT)) MRULE) 00029530 00029540 DEFINE (( 00029550 00029560 (SIMPIDEN (LAMBDA (*S*) 00029570 (PROG (Y Z) 00029580 (COND ((FLAGP (CAR *S*) (QUOTE VOP)) (GO E))) 00029590 (SETQ *S* 00029600 (CONS (CAR *S*) (MAPCAR (CDR *S*) (FUNCTION REVAL)))) 00029610 B (COND ((SETQ Z (OPMTCH *S*)) (RETURN (SIMP Z))) 00029620 ((FLAGP (CAR *S*) (QUOTE SYMMETRIC)) 00029630 (SETQ *S* (CONS (CAR *S*) (ORDN (CDR *S*))))) 00029640 ((FLAGP (CAR *S*) (QUOTE ANTISYMMETRIC)) (GO D))) 00029650 C (SETQ *S* (MKSQ *S* 1)) 00029660 (RETURN (COND (Y (NEGSQ *S*)) (T *S*))) 00029670 D (COND ((REPEATS (CDR *S*)) (RETURN (CONS NIL 1))) 00029680 ((NOT (PERMP (SETQ Z (ORDN (CDR *S*))) (CDR *S*))) 00029690 (SETQ Y T))) 00029700 (SETQ *S* (CONS (CAR *S*) Z)) 00029710 (GO C) 00029720 E (COND ((ATOMLIS (CDR *S*)) (GO B))) 00029730 (RETURN 00029740 (MKVARG (CDR *S*) 00029750 (FUNCTION 00029760 (LAMBDA (J) (SIMPIDEN (CONS (CAR *S*) J))))))))) 00029770 00029780 (NEGSQ (LAMBDA (U) 00029790 (CONS (MULTN -1 (CAR U)) (CDR U)))) 00029800 00029810 (SIMPMINUS (LAMBDA (U) 00029820 (NEGSQ (SIMP (CARX U))))) 00029830 00029840 (SIMPPLUS (LAMBDA (U) 00029850 (PROG (Z) 00029860 (SETQ Z (CONS NIL 1)) 00029870 A (COND ((NULL U) (RETURN Z))) 00029880 (SETQ Z (ADDSQ (SIMPCAR U) Z)) 00029890 (SETQ U (CDR U)) 00029900 (GO A)))) 00029910 00029920 (SIMPQUOT (LAMBDA (U) 00029930 ((LAMBDA(X) 00029940 (COND 00029950 ((NULL (CDR X)) (REDERR (QUOTE (ZERO DENOMINATOR)))) 00029960 (T (MULTSQ (SIMPCAR U) X)))) 00029970 (SIMPRECIP (CDR U))))) 00029980 00029990 (SIMPRECIP (LAMBDA (U) 00030000 ((LAMBDA(X) 00030010 (COND 00030020 ((NULL (CAR X)) (REDERR (QUOTE (ZERO DENOMINATOR)))) 00030030 ((AND *FLOAT (ATOM (CAR X))) 00030040 (CONS (MULTN (RECIP (PLUS 0.0 (CAR X))) (CDR X)) 1)) 00030050 (T (REVPR X)))) 00030060 (SIMP (CARX U))))) 00030070 00030080 (SIMPTIMES (LAMBDA (U) 00030090 (PROG (X) 00030100 (SETQ X (SIMPCAR U)) 00030110 A (SETQ U (CDR U)) 00030120 (COND ((NULL (CAR X)) (RETURN (CONS NIL 1))) 00030130 ((NULL U) (RETURN X))) 00030140 (SETQ X (MULTSQ X (SIMPCAR U))) 00030150 (GO A)))) 00030160 00030170 (SIMPSUBS (LAMBDA (U) 00030180 (PROG (X Y Z) 00030190 (SETQ U (REVERSE U)) 00030200 (SETQ Y (SUBS2 (SIMPCAR U))) 00030210 (SETQ U (CDR U)) 00030220 A (COND ((NULL U) (GO B)) 00030230 ((NOT (MEMBER (CAAR U) (QUOTE (EQUAL SETQ)))) 00030240 (GO ERR)) 00030250 ((VECTORP (SETQ X (CADAR U))) (GO C)) 00030260 ((OR (NOT (KERNP (SETQ X (SIMP X)))) 00030270 (NOT (EQUAL (CDR X) 1)) 00030280 (NOT (EQUAL (CDAAR X) 1)) 00030290 (NOT (EQUAL (CDAAAR X) 1))) 00030300 (GO ERR))) 00030310 (SETQ X (CAAAAR X)) 00030320 C (SETQ Z (CONS (CONS X (CADDAR U)) Z)) 00030330 (SETQ U (CDR U)) 00030340 (GO A) 00030350 B (RETURN (SIMP (SUBLIS Z (PREPSQ Y)))) 00030360 ERR (ERRPRI1 (CAR U)) 00030370 (ERROR*)))) 00030380 00030390 (SIMP*SQ (LAMBDA (U) 00030400 (COND ((NULL (CADR U)) (SIMP (PREPSQ (CAR U)))) (T (CAR U))))) 00030410 00030420 )) 00030430 00030440 DEFINE (( 00030450 00030460 (SUBS2 (LAMBDA (U) 00030470 (PROG (X) 00030480 (RSET2) 00030490 (SETQ U (EXPSQ U)) 00030500 (COND ((AND (NULL EXPTL*) 00030505 (OR (NULL MATCH*) (NULL SUBFG*))) (GO A))) 00030510 (COND (EXPTL* (SETQ U (EXPTCHK U)))) 00030515 (SETQ X MCHFG*) 00030520 (SETQ U (MULTSQ (SUBS31 (CAR U)) (REVPR (SUBS31 (CDR U))))) 00030530 (SETQ MCHFG* X) 00030540 A (RETURN (CANCEL U))))) 00030550 00030560 (CANCEL (LAMBDA (U) 00030570 (PROG (X) 00030580 (COND ((NULL (CAR U)) (RETURN (CONS NIL 1))) 00030590 ((OR *FLOAT (EQUAL (CDR U) 1)) (GO C))) 00030600 (SETQ X (GCD1 (CDR U) (CAR U))) 00030610 (SETQ U (CONS (QUOTF (CAR U) X) (QUOTF (CDR U) X))) 00030620 C (RETURN (MKCANON U))))) 00030630 00030640 (MKCANON (LAMBDA (U) 00030650 (COND ((MINUSF (CDR U)) 00030660 (CONS (MULTN -1 (CAR U)) (MULTN -1 (CDR U)))) 00030670 (T U)))) 00030680 00030690 (MINUSF (LAMBDA (U) 00030700 (COND ((NULL U) NIL) 00030701 ((ATOM U) (MINUSP U)) 00030702 ((EQ (CAR U) (QUOTE QUOTIENT)) (MINUSP (CADR U))) 00030703 (T (MINUSF (CDAR U)))))) 00030704 00030720 )) 00030730 00030740 DEFINE (( 00030750 00030760 (EXPSQ (LAMBDA (U) 00030770 (COND ((OR (NULL SUB2*) (NULL *EXP)) U) 00030780 (T 00030790 ((LAMBDA(X Y) 00030800 (CONS (MULTF (CAR X) (CDR Y)) (MULTF (CDR X) (CAR Y)))) 00030810 (EXPAND (CAR U)) 00030820 (COND (*XDN (EXPAND (CDR U))) (T (CONS (CDR U) 1)))))))) 00030830 00030840 (EXPAND (LAMBDA (U) 00030850 (PROG (W X Y Z) 00030860 (COND ((ATOM U) (RETURN (CONS U 1)))) 00030870 (SETQ X U) 00030880 (SETQ Z (CONS NIL 1)) 00030890 A (COND 00030900 ((NULL X) 00030910 (RETURN 00030920 (COND ((EQUAL (CAR Z) U) (CONS U (CDR Z))) (T Z)))) 00030930 ((ATOM X) (GO E))) 00030940 (SETQ Y (EXPAND (CDAR X))) 00030950 (COND 00030960 ((AND (NOT (ATOM (SETQ W (CAAAR X)))) 00030970 (OR (EQ (CAR W) (QUOTE *SQ)) (NOT (ATOM (CAR W))))) 00030980 (GO C))) 00030990 (SETQ Z (ADDSQ (CONS (MULTF2 (CAAR X) (CAR Y)) (CDR Y)) Z)) 00031000 B (SETQ X (CDR X)) 00031010 (GO A) 00031020 C (SETQ Z 00031030 (ADDSQ 00031040 (MULTSQ 00031050 (COND 00031060 ((EQ (CAR W) (QUOTE *SQ)) 00031070 (NMULTSQ (EXPSQ (CADR W)) (CDAAR X))) 00031080 ((NULL (CDAAR X)) (EXPSQ W)) 00031090 (T (NMULTSQ (EXPAND W) (CDAAR X)))) 00031100 Y) 00031110 Z)) 00031120 (GO B) 00031130 E (SETQ Z (ADDSQ (CONS X 1) Z)) 00031140 (SETQ X NIL) 00031150 (GO A)))) 00031160 00031170 )) 00031180 00031181 DEFINE (( 00031182 00031183 (EXSCAN (LAMBDA (U) 00031184 (COND ((ATOM U) U) 00031185 (T 00031186 (ADDF 00031187 (MULTF2 00031188 (COND 00031189 ((MEMBER (CAAAR U) EXPTL*) 00031190 (MKSP (LIST (QUOTE EXPT) (CAAAR U) 1) (CDAAR U))) 00031191 (T (CAAR U))) 00031192 (EXSCAN (CDAR U))) 00031193 (EXSCAN (CDR U))))))) 00031194 00031195 (EXPTCHK (LAMBDA (U) 00031196 (PROG (V W X Y Y1 Z) 00031197 (SETQ V (EXSCAN (CAR U))) 00031198 (SETQ W (CDR U)) 00031199 (SETQ X (CONS FACTORS* ORDN*)) 00031200 (SETQ FACTORS* NIL) 00031201 (SETQ ORDN* 0) 00031202 (SETQ Y (CKRN W)) 00031203 A (COND ((ATOM Y) (GO C))) 00031204 (SETQ Y1 (CAAAR Y)) 00031205 (COND 00031206 ((AND (NOT (MEMBER Y1 EXPTL*)) (NOT (EQCAR Y1 (QUOTE EXPT)))) 00031207 (GO B))) 00031208 (SETQ V 00031209 (MULTF2 00031210 (MKSP 00031211 (COND 00031212 ((MEMBER Y1 EXPTL*) (LIST (QUOTE EXPT) Y1 -1)) 00031213 (T 00031214 (LIST (QUOTE EXPT) 00031215 (CADR Y1) 00031216 (PREPSQ (SIMPMINUS (CDDR Y1)))))) 00031217 (CDAAR Y)) 00031218 V)) 00031219 (SETQ Z (CONS (CAAR Y) Z)) 00031220 B (SETQ Y (CDAR Y)) 00031221 (GO A) 00031222 C (SETQ FACTORS* (CAR X)) 00031223 (SETQ ORDN* (CDR X)) 00031224 (SETQ X 1) 00031225 D (COND ((NULL Z) (GO E))) 00031226 (SETQ X (LIST (CONS (CAR Z) X))) 00031227 (SETQ Z (CDR Z)) 00031228 (GO D) 00031229 (COND ((EQUAL V (CAR U)) (SETQ V (CAR U)))) 00031230 E (RETURN (CONS V (QUOTF W X)))))) 00031231 00031232 )) 00031233 00031234 DEFINE (( 00031235 00031236 (SUBS31 (LAMBDA (U) 00031237 (COND ((ATOM U) (CONS U 1)) 00031238 (T 00031239 (ADDSQ 00031250 ((LAMBDA(X) 00031260 (COND ((NULL MCHFG*) (CONS (LIST (CAR U)) 1)) 00031270 ((AND MCHFG* (NOT (SETQ MCHFG* NIL)) *RESUBS) 00031280 (SUBS2 X)) 00031290 (T X))) 00031300 (SUBS3T (CAR U) MATCH*)) 00031310 (SUBS31 (CDR U))))))) 00031320 00031330 (SUBS3T (LAMBDA (U V) 00031340 (SUBS3T0 (SUBS3T1 U V)))) 00031350 00031360 (SUBS3T0 (LAMBDA (X) 00031370 (PROG (Y) 00031380 (COND ((OR (CAR X) (ATOM (CDR X))) (RETURN X))) 00031390 (SETQ Y (MULTSQ (SIMP (CAADR X)) (CADDR X))) 00031400 (COND 00031410 ((CDADR X) 00031420 (SETQ Y 00031430 (MULTSQ 00031440 (REVPR (SIMPTIMES (EXCHK (CDADR X) NIL))) 00031450 Y)))) 00031460 (RETURN (CANCEL Y))))) 00031470 00031480 (SUBS3T1 (LAMBDA (U V) 00031490 (PROG (X Y Z) 00031500 (SETQ X (MTCHK (CAR U) V)) 00031510 (COND 00031520 ((NULL X) 00031530 (RETURN (COND ((NULL MCHFG*) U) (T (CONS (LIST U) 1))))) 00031540 ((AND (NULL (CAAR X)) 00031550 (SETQ MCHFG* T) 00031560 (SETQ Y 00031570 (LIST NIL 00031580 (CONS (CADDAR X) (CADR (CDDAR X))) 00031590 (SUBS32 (CDR U) MATCH*)))) 00031600 (GO B)) 00031610 ((AND (NOT (ATOM (CDR U))) (NULL (CDDR U))) (GO A))) 00031620 (SETQ Y (SUBS32 (CDR U) X)) 00031630 (COND ((NULL MCHFG*) (RETURN (CONS (CAR U) Y)))) 00031640 A0 (SETQ X (LIST (CONS (CAR U) 1))) 00031650 (SETQ Z (GCD1 X (CDR Y))) 00031660 (RETURN 00031670 (COND ((NULL Z) (MULTS2 (CAR U) Y)) 00031680 ((EQUAL X Z) (CONS (CAR Y) (QUOTF (CDR Y) X))) 00031690 (T 00031700 (CONS (MULTF (QUOTF X Z) (CAR Y)) 00031710 (QUOTF (CDR Y) Z))))) 00031720 A (SETQ Y (SUBS3T1 (CADR U) X)) 00031730 (COND ((AND (NULL (CAR Y)) (NOT (ATOM (CDR Y)))) (GO B)) 00031740 ((NULL MCHFG*) (RETURN (LIST (CAR U) Y))) 00031750 (T (GO A0))) 00031760 B (COND 00031770 ((AND (CDADR Y) (EQUAL (CADADR Y) (CAR U))) 00031780 (RETURN (LIST NIL (CONS (CAADR Y) (CDDADR Y)) (CADDR Y)))) 00031790 ((AND (NOT (ATOM (CAAR U))) 00031800 (FLAGP** (CAAAR U) (QUOTE NONCOM)) 00031810 (SETQ Y (SUBS3T0 Y))) 00031820 (GO A0)) 00031830 (T 00031840 (RETURN (LIST NIL (CADR Y) (MULTS2 (CAR U) (CADDR Y)))))))) 00031850 ) 00031860 00031870 (MULTS2 (LAMBDA (U V) 00031880 (CONS (MULTF2 U (CAR V)) (CDR V)))) 00031890 00031900 (SUBS32 (LAMBDA (U V) 00031910 (PROG (B X Y) 00031920 A (COND 00031930 ((ATOM U) 00031940 (RETURN 00031950 (COND (MCHFG* 00031960 (COND ((NULL X) (CONS U 1)) 00031970 (T (ADDSQ (CONS U 1) X)))) 00031980 (T (APPEND X U)))))) 00031990 (SETQ Y (SUBS3T (CAR U) V)) 00032000 (COND ((NULL MCHFG*) (SETQ X (APPEND X (LIST Y)))) 00032010 (B (SETQ X (ADDSQ Y X))) 00032020 ((SETQ B T) (SETQ X (ADDSQ (CONS X 1) Y)))) 00032030 (SETQ U (CDR U)) 00032040 (GO A)))) 00032050 00032060 (MKKL (LAMBDA (U V) 00032070 (COND ((NULL U) V) (T (MKKL (CDR U) (LIST (CONS (CAR U) V))))))) 00032080 00032090 )) 00032100 00032110 DEFINE (( 00032120 00032130 (MTCHK (LAMBDA (U V1) 00032140 (PROG (V W X Y Z) 00032150 A0 (COND ((NULL V1) (RETURN Z))) 00032160 (SETQ V (CAR V1)) 00032170 (SETQ W (CAR V)) 00032180 A (COND ((NULL W) (GO D)) 00032190 ((AND (EQUAL U (CAR W)) (SETQ Y (LIST NIL))) (GO B)) 00032200 ((NOT (ATOM (CAR U))) (GO A1)) 00032210 ((NOT (ATOM (CAAR W))) (GO D)) 00032220 ((OR FRLIS* (ORDP (CAR U) (CAAR W))) (GO A2)) 00032230 (T (GO E))) 00032231 A1 (COND ((EQ (CAAR U) (CAAAR W)) (GO A2)) 00032232 ((FLAGP** (CAAR U) (QUOTE NONCOM)) (GO C1)) 00032234 ((NULL (ORDP (CAAR U) (CAAAR W))) (GO E)) 00032240 (T (GO D))) 00032250 A2 (COND 00032260 ((OR (AND (NOT (MEMBER (CDAR W) FRLIS*)) 00032270 (OR (AND (CAADR V) 00032280 (NOT (EQUAL (CDR U) (CDAR W)))) 00032290 (LESSP (CDR U) (CDAR W)))) 00032300 (NOT (SETQ Y (MCHK (CAR U) (CAAR W))))) 00032310 (GO C)) 00032320 ((MEMBER (CDAR W) FRLIS*) 00032321 (SETQ Y 00032322 (MAPCONS U (CONS (CDAR W) (CDR U)))))) 00032324 B (COND ((NULL Y) (GO C)) 00032330 ((AND (NULL 00032340 (CAR 00032350 (SETQ X 00032360 (CONS (SUBLIS (CAR Y) 00032370 (DELETE (CAR W) (CAR V))) 00032380 (LIST (CADR V) 00032390 (SUBLIS (CAR Y) (CADDR V)) 00032400 (CONS 00032410 (SUBLIS (CAR Y) (CAR W)) 00032420 (CADDDR V))))))) 00032430 (*EVAL (SUBLIS (CAR Y) (CDADR V)))) 00032440 (RETURN (LIST X)))) 00032450 (SETQ Z (CONS X Z)) 00032460 (SETQ Y (CDR Y)) 00032470 (GO B) 00032480 C (COND 00032490 ((AND (NOT (ATOM (CAR U))) 00032500 (FLAGP** (CAAR U) (QUOTE NONCOM))) 00032510 (GO C1))) 00032520 (SETQ W (CDR W)) 00032530 (GO A) 00032540 C1 (COND ((AND (CADDDR V) (NOT (NOCP (CADDDR V)))) (GO E))) 00032550 D (SETQ Z (APPEND Z (LIST V))) 00032580 E (SETQ V1 (CDR V1)) 00032590 (GO A0)))) 00032600 00032710 (NOCP (LAMBDA (U) 00032720 (OR (NULL U) 00032730 (AND (OR (ATOM (CAAR U)) 00032740 (NOT (FLAGP** (CAAAR U) (QUOTE NONCOM)))) 00032750 (NOCP (CDR U)))))) 00032760 00032770 (MCHK (LAMBDA (U V) 00032780 (COND ((EQUAL U V) (LIST NIL)) 00032790 ((OR (NULL U) (NULL V)) NIL) 00032800 ((MEMBER V FRLIS*) (LIST (LIST (CONS V (EMTCH U))))) 00032810 ((OR (ATOM U) (ATOM V)) NIL) 00032820 ((EQ (CAR U) (CAR V)) (MCHARG (CDR U) (CDR V) (CAR U))) 00032830 (T NIL)))) 00032840 00032850 (MCHARG (LAMBDA (*S* V W) 00032860 ((LAMBDA(X) 00032870 (COND 00032880 ((MTP V) 00032890 (COND 00032900 (X 00032910 (COND 00032920 ((FLAGP W (QUOTE SYMMETRIC)) 00032930 (MAPLIST (PERMUTATIONS V) 00032940 (FUNCTION 00032950 (LAMBDA(J) 00032960 (PAIR (CAR J) 00032970 (MAPCAR *S* (FUNCTION EMTCH))))))) 00032980 ((FLAGP W (QUOTE ANTISYMMETRIC)) 00032990 (ERRACH (QUOTE (NOT YET)))) 00033000 (T (LIST (PAIR V (MAPCAR *S* (FUNCTION EMTCH))))))) 00033010 ((AND (EQUAL (LENGTH V) 2) (FLAGP W (QUOTE NARY))) 00033020 (MCHARG (CDR (MKBIN (CONS W *S*))) V W)) 00033030 (T NIL))) 00033040 (X (MCHARG1 *S* V (FLAGP W (QUOTE SYMMETRIC)) (LIST NIL))) 00033050 (T NIL))) 00033060 (EQUAL (LENGTH *S*) (LENGTH V))))) 00033070 00033080 (MCHARG1 (LAMBDA (U V FLG W) 00033090 (PROG (X Z) 00033100 (COND ((NULL U) (RETURN W)) 00033110 ((NULL FLG) 00033120 (RETURN 00033130 (MCHARG3 U (CDR V) (MCHK (CAR U) (CAR V)) FLG W)))) 00033140 (SETQ X (MCHARG2 (CAR U) V)) 00033150 A (COND ((NULL X) (RETURN Z))) 00033160 (SETQ Z (APPEND (MCHARG3 U (CDAR X) (CAAR X) FLG W) Z)) 00033170 (SETQ X (CDR X)) 00033180 (GO A)))) 00033190 00033200 (MCHARG2 (LAMBDA (U V) 00033210 (PROG (X Y Z) 00033220 A (COND ((NULL V) (RETURN (REVERSE Z))) 00033230 ((SETQ Y (MCHK U (CAR V))) 00033240 (SETQ Z 00033250 (CONS (CONS Y (APPEND (REVERSE X) (CDR V))) 00033260 Z)))) 00033270 (SETQ X (CONS (CAR V) X)) 00033280 (SETQ V (CDR V)) 00033290 (GO A)))) 00033300 00033310 (MCHARG3 (LAMBDA (U V *S* FLG W) 00033320 (PROG (Z) 00033330 A (COND ((NULL *S*) (RETURN Z))) 00033340 (SETQ Z 00033350 (APPEND (MCHARG1 (CDR U) 00033360 (SUBLIS (CAR *S*) V) 00033370 FLG 00033380 (MAPLIST W 00033390 (FUNCTION 00033400 (LAMBDA(J) 00033410 (APPEND 00033420 (CAR *S*) 00033430 (CAR J)))))) 00033440 Z)) 00033450 (SETQ *S* (CDR *S*)) 00033460 (GO A)))) 00033470 00033480 (MKBIN (LAMBDA (U) 00033490 (COND ((OR (NULL (CDDR U)) (NULL (CDDDR U))) U) 00033500 (T (MKBIN1 (CAR U) (CDR U)))))) 00033510 00033520 (MKBIN1 (LAMBDA (U V) 00033530 (COND ((NULL (CDDR V)) (CONS U V)) 00033540 (T (LIST U (CAR V) (MKBIN1 U (CDR V))))))) 00033550 00033560 (MTP (LAMBDA (V) 00033570 (OR (NULL V) 00033580 (AND (MEMBER (CAR V) FRLIS*) 00033590 (NOT (MEMBER (CAR V) (CDR V))) 00033600 (MTP (CDR V)))))) 00033610 00033620 (PERMUTATIONS (LAMBDA (*S*) 00033630 (COND ((NULL *S*) (LIST NIL)) 00033640 ((NULL (CDR *S*)) (LIST *S*)) 00033650 (T 00033660 (MAPCON *S* 00033670 (FUNCTION 00033680 (LAMBDA(J) 00033690 (MAPCONS 00033700 (PERMUTATIONS (DELETE (CAR J) *S*)) 00033710 (CAR J))))))))) 00033720 00033730 )) 00033740 00033750 DEFINE (( 00033760 00033770 (EMTCH (LAMBDA (U) 00033780 (COND ((ATOM U) U) 00033790 (T ((LAMBDA (X) (COND (X X) (T U))) (OPMTCH U)))))) 00033800 00033810 (OPMTCH (LAMBDA (U) 00033820 (PROG (X Y) 00033830 (COND ((NULL SUBFG*) (RETURN NIL))) 00033840 (SETQ X (GET (CAR U) (QUOTE OPMTCH*))) 00033850 A (COND ((NULL X) (RETURN NIL)) 00033860 ((AND (NULL (CAADAR X)) 00033870 (SETQ Y (MCHARG (CDR U) (CAAR X) (CAR U))) 00033880 (*EVAL (SUBLIS (CAR Y) (CDADAR X)))) 00033890 (GO B))) 00033900 (SETQ X (CDR X)) 00033910 (GO A) 00033920 B (RETURN (SUBLIS (CAR Y) (CADDAR X)))))) 00033930 00033940 )) 00033950 00033960 DEFINE (( 00033970 00033980 (ORDER (LAMBDA (U) 00033990 (PROG NIL 00034000 A (COND ((NULL U) (RETURN NIL)) 00034010 ((OR (NOT (ATOM (CAR U))) (NUMBERP (CAR U))) (GO B))) 00034020 (PUT (CAR U) (QUOTE ORDER) ORDN*) 00034030 (SETQ ORDN* (ADD1 ORDN*)) 00034040 B (SETQ U (CDR U)) 00034050 (GO A)))) 00034060 00034070 (FORMOP (LAMBDA (U) 00034080 (COND ((ATOM U) U) 00034090 (T 00034100 (ADDOF (MULTOP (CAAR U) (FORMOP (CDAR U))) 00034110 (FORMOP (CDR U))))))) 00034120 00034130 (ADDOF (LAMBDA (U V) 00034140 (COND ((NULL U) V) 00034150 ((NULL V) U) 00034160 ((ATOM U) (CONS (CAR V) (ADDOF U (CDR V)))) 00034170 ((ATOM V) (ADDOF V U)) 00034180 ((EQUAL (CAAR U) (CAAR V)) 00034190 (CONS (CONS (CAAR U) (ADDOF (CDAR U) (CDAR V))) 00034200 (ADDOF (CDR U) (CDR V)))) 00034210 ((ORDOP (CAAR U) (CAAR V)) (CONS (CAR U) (ADDOF (CDR U) V))) 00034220 (T (CONS (CAR V) (ADDOF U (CDR V))))))) 00034230 00034240 (MULTOP (LAMBDA (U V) 00034250 (COND ((EQ (CAR U) (QUOTE K*)) V) (T (MULTOP1 U V))))) 00034260 00034270 (MULTOP1 (LAMBDA (U V) 00034280 (COND ((NULL V) NIL) 00034290 ((OR (ATOM V) (ORDOP U (CAAR V))) (LIST (CONS U V))) 00034300 (T 00034310 (CONS (CONS (CAAR V) (MULTOP1 U (CDAR V))) 00034320 (MULTOP1 U (CDR V))))))) 00034330 00034340 (ORDOP (LAMBDA (U V) 00034350 (COND ((NULL U) (NULL V)) 00034360 ((NULL V) NIL) 00034370 ((AND (MEMBER U FACTORS*) (NOT (MEMBER V FACTORS*))) T) 00034380 ((AND (MEMBER V FACTORS*) (NOT (MEMBER U FACTORS*))) NIL) 00034390 ((ATOM U) 00034400 (COND 00034410 ((ATOM V) 00034420 (COND ((NUMBERP U) (AND (NUMBERP V) (NOT (LESSP U V)))) 00034430 ((NUMBERP V) T) 00034440 ((ZEROP ORDN*) (ORDERP U V)) 00034445 (T 00034450 ((LAMBDA(X Y) 00034460 (COND ((AND X Y) (LESSP X Y)) 00034470 (X T) 00034480 (Y NIL) 00034490 (T (ORDERP U V)))) 00034500 (GET U (QUOTE ORDER)) 00034510 (GET V (QUOTE ORDER)))))) 00034520 ((MEMBER U FACTORS*) T) 00034530 (T (NOT (MEMBER (CAR V) FACTORS*))))) 00034540 ((ATOM V) (MEMBER (CAR U) FACTORS*)) 00034550 ((EQUAL (CAR U) (CAR V)) (ORDOP (CDR U) (CDR V))) 00034560 (T (ORDOP (CAR U) (CAR V)))))) 00034570 00034580 (QUOTOF (LAMBDA (P Q) 00034590 (COND ((NULL P) NIL) 00034600 ((EQUAL P Q) 1) 00034610 ((EQUAL Q 1) P) 00034620 ((NUMB Q) 00034630 (COND 00034640 ((NUMB P) 00034650 (COND ((AND (ATOM P) (ATOM Q)) (MKFR P Q)) 00034660 (T (ERRACH (LIST (QUOTE QUOTOF) P Q))))) 00034670 (T 00034680 (CONS (CONS (CAAR P) (QUOTOF (CDAR P) Q)) 00034690 (QUOTOF (CDR P) Q))))) 00034700 ((NUMB P) 00034710 (LIST 00034720 (CONS (CONS (CAAAR Q) (MINUS (CDAAR Q))) 00034730 (QUOTOF P (CDARX Q))))) 00034740 (T 00034750 ((LAMBDA(X Y) 00034760 (COND 00034770 ((EQ (CAR X) (CAR Y)) 00034780 ((LAMBDA(N W Z) 00034790 (COND ((ZEROP N) (ADDOF W Z)) 00034800 (T (CONS (CONS (CONS (CAR Y) N) W) Z)))) 00034810 (DIFFERENCE (CDR X) (CDR Y)) 00034820 (QUOTOF (CDAR P) (CDARX Q)) 00034830 (QUOTOF (CDR P) Q))) 00034840 ((ORDOP X Y) 00034850 (CONS (CONS X (QUOTOF (CDAR P) Q)) (QUOTOF (CDR P) Q))) 00034860 (T 00034870 (LIST 00034880 (CONS (CONS (CAR Y) (MINUS (CDR Y))) 00034890 (QUOTOF P (CDARX Q))))))) 00034900 (CAAR P) 00034910 (CAAR Q)))))) 00034920 00034930 )) 00034940 00034950 DEFINE (( 00034960 00034970 (CKRN (LAMBDA (U) 00034980 (PROG (X) 00034990 (COND ((KERNLOP U) (RETURN U))) 00035000 A (SETQ X (CONS (CKRN (CDAR U)) X)) 00035010 (COND 00035020 ((NULL (CDR U)) (RETURN (LIST (CONS (CAAR U) (GCK X))))) 00035030 ((OR (ATOM (CDR U)) (NOT (EQ (CAAAR U) (CAAADR U)))) 00035040 (RETURN (GCK (CONS (CKRN (CDR U)) X))))) 00035050 (SETQ U (CDR U)) 00035060 (GO A)))) 00035070 00035080 (GCK (LAMBDA (U) 00035090 (COND ((NULL U) 1) 00035100 ((NULL (CDR U)) (CAR U)) 00035110 (T (GCK (CONS (GCK1 (CAR U) (CADR U)) (CDDR U))))))) 00035120 00035130 (GCK1 (LAMBDA (U V) 00035140 (COND ((OR (NULL U) (NULL V)) (ERRACH (QUOTE GCK1))) 00035150 ((EQUAL U V) U) 00035160 ((NUMB U) 00035170 (COND 00035180 ((NUMB V) 00035190 (COND ((AND (ATOM U) (ATOM V)) (GCDN U V)) (T 1))) 00035200 (T (GCK1 U (CDARX V))))) 00035210 ((NUMB V) (GCK1 (CDARX U) V)) 00035220 (T 00035230 ((LAMBDA(X Y) 00035240 (COND 00035250 ((EQ (CAR X) (CAR Y)) 00035260 (LIST 00035270 (CONS 00035280 (COND ((GREATERP (CDR X) (CDR Y)) Y) (T X)) 00035290 (GCK1 (CDARX U) (CDARX V))))) 00035300 ((ORDOP X Y) (GCK1 (CDARX U) V)) 00035310 (T (GCK1 U (CDARX V))))) 00035320 (CAAR U) 00035330 (CAAR V)))))) 00035340 00035350 )) 00035360 00035370 DEFINE (( 00035380 00035390 (PREPSQ (LAMBDA (U) 00035400 (COND ((NULL (CAR U)) 0) 00035410 (T 00035420 ((LAMBDA(X) 00035430 (COND 00035440 ((OR *RAT (AND (NOT *FLOAT) *DIV) UPL* DNL*) 00035450 (REPLUS (PREPSQ1 (CAR X) NIL (CDR X)))) 00035460 (T 00035470 (SQFORM X 00035480 (FUNCTION 00035490 (LAMBDA (J) (REPLUS (PREPSQ1 J NIL 1)))))))) 00035500 (CONS (FORMOP (CAR U)) (FORMOP (CDR U)))))))) 00035510 00035520 (SQFORM (LAMBDA (U *PI*) 00035530 ((LAMBDA(X Y) 00035540 (COND ((EQUAL Y 1) X) (T (LIST (QUOTE QUOTIENT) X Y)))) 00035550 (*PI* (CAR U)) 00035560 (*PI* (CDR U))))) 00035570 00035580 (PREPSQ1 (LAMBDA (U V W) 00035590 (PROG (X Y Z) 00035600 (COND ((NULL U) (RETURN NIL)) 00035610 ((AND (NOT (ATOM U)) 00035620 (OR (MEMBER (CAAAR U) FACTORS*) 00035630 (AND (NOT (ATOM (CAAAR U))) 00035640 (MEMBER (CAAAAR U) FACTORS*)))) 00035650 (RETURN 00035660 (NCONC (PREPSQ1 (CDAR U) (CONS (CAAR U) V) W) 00035670 (PREPSQ1 (CDR U) V W)))) 00035680 ((NULL (KERNLP U)) (GO A))) 00035690 (SETQ U (MKKL V U)) 00035700 (SETQ V NIL) 00035710 A (SETQ X (CKRN U)) 00035720 (COND ((NULL DNL*) (GO A1))) 00035730 (SETQ Z (CKRN* X DNL*)) 00035740 (SETQ X (QUOTOF X Z)) 00035750 (SETQ U (QUOTF U Z)) 00035760 (SETQ W (QUOTOF W Z)) 00035770 A1 (SETQ Y (CKRN W)) 00035780 (COND ((NULL UPL*) (GO A2))) 00035790 (SETQ Z (CKRN* Y UPL*)) 00035800 (SETQ Y (QUOTOF Y Z)) 00035810 (SETQ U (QUOTOF U Z)) 00035820 (SETQ W (QUOTOF W Z)) 00035830 A2 (COND ((AND (NULL *DIV) (NULL *FLOAT)) (SETQ Y (GCK1 X Y)))) 00035840 (SETQ U (MKCANON (CONS (QUOTOF U Y) (QUOTOF W Y)))) 00035850 (COND ((AND *GCD (ZEROP ORDN*)) (SETQ U (CANCEL U)))) 00035852 (SETQ X (QUOTOF X Y)) 00035860 (COND 00035870 ((AND *ALLFAC (NULL *DIV) (NOT (EQUAL X (CAR U)))) (GO B)) 00035880 ((NULL V) (GO D))) 00035890 (SETQ V (EXCHK V NIL)) 00035900 (GO C) 00035910 D (SETQ U (PREPSQ2 U)) 00035920 (RETURN 00035930 (COND ((EQCAR U (QUOTE PLUS)) (CDR U)) (T (LIST U)))) 00035940 B (COND ((AND (EQUAL X 1) (NULL V)) (GO D))) 00035950 (SETQ U (CONS (QUOTOF (CAR U) X) (CDR U))) 00035960 (SETQ V (PREPF (MKKL V X))) 00035970 (COND ((EQUAL U (CONS 1 1)) (RETURN V)) 00035980 ((EQCAR V (QUOTE TIMES)) (SETQ V (CDR V))) 00035990 (T (SETQ V (LIST V)))) 00036000 C (RETURN (LIST (RETIMES (ACONC V (PREPSQ2 U)))))))) 00036010 00036020 (CKRN* (LAMBDA (U V) 00036030 (COND ((NULL U) (ERRACH (QUOTE CKRN*))) 00036040 ((ATOM U) 1) 00036050 ((MEMBER (CAAAR U) V) 00036060 (LIST (CONS (CAAR U) (CKRN* (CDARX U) V)))) 00036070 (T (CKRN* (CDARX U) V))))) 00036080 00036090 (UP (LAMBDA (U) 00036100 (FACTOR1 U T (QUOTE UPL*)))) 00036110 00036120 (DOWN (LAMBDA (U) 00036130 (FACTOR1 U T (QUOTE DNL*)))) 00036140 00036150 )) 00036160 00036170 DEFLIST (((UP RLIS) (DOWN RLIS)) STAT) 00036180 00036190 DEFINE (( 00036200 00036210 (REPLUS (LAMBDA (U) 00036220 (COND ((ATOM U) U) 00036230 ((NULL (CDR U)) (CAR U)) 00036240 (T (CONS (QUOTE PLUS) U))))) 00036250 00036260 (RETIMES (LAMBDA (U) 00036270 (PROG (X Y) 00036275 A (COND ((NULL U) (GO D)) 00036280 ((NOT (EQCAR (CAR U) (QUOTE MINUS))) (GO B))) 00036285 (SETQ X (NOT X)) 00036290 (COND ((EQUAL (CADAR U) 1) (GO C)) 00036295 (T (SETQ U (CONS (CADAR U) (CDR U))))) 00036300 B (SETQ Y (CONS (CAR U) Y)) 00036305 C (SETQ U (CDR U)) 00036310 (GO A) 00036315 D (SETQ Y (COND ((NULL Y) 1) 00036320 ((CDR Y) (CONS (QUOTE TIMES) (REVERSE Y))) 00036325 (T (CAR Y)))) 00036330 (RETURN (COND (X (LIST (QUOTE MINUS) Y)) (T Y)))))) 00036335 00036350 (PREPSQ2 (LAMBDA (U) 00036360 (SQFORM U (FUNCTION PREPF)))) 00036370 00036380 (PREPF (LAMBDA (U) 00036390 (PROG (X) 00036395 (COND ((AND (MINUSF U) (SETQ X T)) (SETQ U (MULTN -1 U)))) 00036400 (SETQ U (REPLUS (PREPF1 U NIL))) 00036405 (RETURN (COND (X (LIST (QUOTE MINUS) U)) (T U)))))) 00036410 00036415 (PREPF1 (LAMBDA (U V) 00036420 (COND ((NULL U) NIL) 00036430 ((NUMB U) 00036440 (LIST (RETIMES (NUMCONS (MINUSCHK U) (EXCHK V NIL))))) 00036450 (T 00036460 (NCONC (PREPF1 (CDAR U) (CONS (CAAR U) V)) 00036470 (PREPF1 (CDR U) V)))))) 00036480 00036490 (NUMB (LAMBDA (U) 00036500 (OR (NUMBERP U) (EQCAR U (QUOTE QUOTIENT))))) 00036510 00036520 (NUMCONS (LAMBDA (N V) 00036530 (COND ((NULL V) (LIST N)) ((EQUAL N 1) V) (T (CONS N V))))) 00036540 00036550 (KERNLOP (LAMBDA (U) 00036560 (OR (NUMB U) (AND (NULL (CDR U)) (KERNLOP (CDAR U)))))) 00036570 00036580 (EXCHK (LAMBDA (U V) 00036590 (COND ((NULL U) V) 00036600 ((ONEP (CDAR U)) (EXCHK (CDR U) (CONS (SQCHK (CAAR U)) V))) 00036610 (T 00036620 (EXCHK (CDR U) 00036630 (CONS (LIST (QUOTE EXPT) (SQCHK (CAAR U)) (CDAR U)) 00036640 V)))))) 00036650 00036660 (SQCHK (LAMBDA (U) 00036670 (COND ((ATOM U) ((LAMBDA (X) 00036675 (COND (X X) (T U))) (GET U (QUOTE NEWNAME)))) 00036680 ((EQ (CAR U) (QUOTE *SQ)) (PREPSQ (CADR U))) 00036685 ((AND (EQ (CAR U) (QUOTE EXPT)) (EQUAL (CADDR U) 1)) 00036690 (CADR U)) 00036695 ((ATOM (CAR U)) U) 00036700 (T (PREPF U))))) 00036710 00036720 (MINUSCHK (LAMBDA (U) 00036730 (COND 00036740 ((ATOM U) 00036750 (COND ((MINUSP U) (LIST (QUOTE MINUS) (MINUS U))) (T U))) 00036760 ((MINUSP (CADR U)) 00036770 (LIST (QUOTE MINUS) 00036780 (LIST (QUOTE QUOTIENT) (MINUS (CADR U)) (CADDR U)))) 00036790 (T U)))) 00036800 00036810 (MKFR (LAMBDA (U V) 00036820 (COND (*FLOAT (QUOTIENT (PLUS 0.0 U) V)) 00036830 (T 00036840 ((LAMBDA(M) 00036850 ((LAMBDA(N1 N2) 00036860 (COND ((ONEP N2) N1) 00036870 (T (LIST (QUOTE QUOTIENT) N1 N2)))) 00036880 (QUOTIENT U M) 00036890 (QUOTIENT V M))) 00036900 (GCDN U V)))))) 00036910 00036920 )) 00036930 00036940 DEFLIST (((*SQ SQPRINT)) SPECPRN) 00036950 00036960 DEFINE (( 00036970 00036980 (SQPRINT (LAMBDA (U) 00036990 (PROG (Z) 00037000 (SETQ Z ORIG*) 00037010 (COND ((LESSP POSN* 20) (SETQ ORIG* POSN*))) 00037020 (MAPRIN 00037030 (SETQ *OUTP 00037040 (COND ((NULL (CAAR U)) 0) (T (PREPSQ (CAR U)))))) 00037050 (SETQ ORIG* Z)))) 00037060 00037070 (VARPRI (LAMBDA (U V W) 00037080 (PROG NIL 00037090 (COND ((NULL V) (RETURN NIL)) 00037100 (*FORT (GO D)) 00037110 ((AND (EQUAL V 0) U *NERO) (GO C))) 00037120 (COND ((NULL W) (TERPRI*))) 00037130 (COND ((EQCAR V (QUOTE MAT)) (GO M)) ((NULL U) (GO A))) 00037140 (INPRINT (QUOTE SETQ) (GET (QUOTE SETQ) (QUOTE INFIX)) U) 00037150 (OPRIN (QUOTE SETQ)) 00037160 A (MAPRIN V) 00037170 (COND (W (GO C)) 00037180 ((AND (NULL *NAT) (NULL *FORT)) (PRINC* **DOLLAR))) 00037190 C (RETURN V) 00037210 D (SETQ COUNT* 1) 00037220 (COND ((AND (ATOM V) (NOT (NUMBERP V))) (GO A))) 00037221 (SETQ FORTVAR* (QUOTE ANS)) 00037230 (COND ((OR (NULL U) (NOT (ATOM (CAR U)))) (GO E))) 00037240 (SETQ FORTVAR* (CAR U)) 00037250 E (COND ((GREATERP POSN* 5) (GO A))) 00037260 (SPACES 6) 00037265 (PRINC FORTVAR*) 00037270 (OPRIN (QUOTE EQUAL)) 00037280 (SETQ POSN* (PLUS 7 (LENGTH (EXPLODE FORTVAR*)))) 00037281 (GO A) 00037290 M (MATPRI (CDR V) (COND (U (CAR U)) (T NIL))) 00037300 (GO C)))) 00037310 00037320 )) 00037330 00037340 DEFINE (( 00037350 00037360 (SIMPDF (LAMBDA (U) 00037370 (PROG (V X Y N) 00037380 (COND ((NULL SUBFG*) (RETURN (MKSQ (CONS (QUOTE DF) U) 1)))) 00037390 (SETQ V (CDR U)) 00037400 (SETQ U (SIMPCAR U)) 00037410 A (COND ((OR (NULL V) (NULL (CAR U))) (RETURN U))) 00037420 (SETQ X (COND ((NULL Y) (SIMP (CAR V))) (T Y))) 00037430 (SETQ Y NIL) 00037440 (COND 00037450 ((OR (NULL (KERNP X)) (NOT (ONEP (CDAAAR X)))) (GO E)) 00037460 ((OR (NULL (CDR V)) 00037470 (NOT 00037480 (NUMBERP 00037490 (SETQ N (PREPSQ (SETQ Y (SIMP (CADR V)))))))) 00037500 (GO C1))) 00037510 (SETQ Y NIL) 00037520 (SETQ V (CDR V)) 00037530 (SETQ X (CAAAAR X)) 00037540 C (COND ((ZEROP N) (GO D))) 00037550 (SETQ U (DIFF1 U X)) 00037560 (SETQ N (SUB1 N)) 00037570 (GO C) 00037580 C1 (SETQ U (DIFF1 U (CAAAAR X))) 00037590 D (SETQ V (CDR V)) 00037600 (GO A) 00037610 E (MESPRI (QUOTE (DIFFERENTIATION WITH RESPECT TO)) 00037620 (CAR V) 00037630 (QUOTE (NOT ALLOWED)) 00037640 NIL 00037650 T) 00037660 (ERROR*)))) 00037670 00037680 (DIFF1 (LAMBDA (U V) 00037690 (PROG (W X Y Z Z1) 00037700 (COND 00037710 ((KERNP (CONS (CDR U) 1)) (SETQ W (CONS (CAAADR U) 1)))) 00037720 (SETQ X (DIFF2 (CAR U) V)) 00037730 (SETQ Y 00037740 (COND ((NULL W) (DIFF2 (CDR U) V)) 00037750 (T (DIFFK (LIST (CONS W 1)) V)))) 00037760 (SETQ Z 00037770 (COND ((NULL (CAR X)) (CONS NIL 1)) 00037780 (T (CONS (CAR X) (MULTF (CDR X) (CDR U)))))) 00037790 (COND ((NULL (CAR Y)) (RETURN Z))) 00037800 (SETQ Z1 00037810 (NEGSQ 00037820 (MULTSQ Y 00037830 (COND ((NULL W) 00037840 (CONS (CAR U) (NMULTF (CDR U) 2))) 00037850 (T 00037860 (CONS (MULTN (CDAADR U) (CAR U)) 00037870 (MULTF2 W (CDR U)))))))) 00037880 (RETURN 00037890 (COND 00037900 ((AND *EXP *MCD) 00037910 (CANCEL 00037920 (CONS (ADDF (MULTF (CAR X) 00037930 (COND 00037940 ((NULL W) (MULTF (CDR U) (CDR Y))) 00037950 (T (MULTF2 W (CDR Y))))) 00037960 (MULTF (CDR X) (CAR Z1))) 00037970 (MULTF (CDR X) (CDR Z1))))) 00037980 (T (ADDSQ Z Z1))))))) 00037990 00038000 (DIFF2 (LAMBDA (U V) 00038010 (COND ((ATOM U) (CONS NIL 1)) 00038020 (T 00038030 (ADDSQ (DIFF2 (CDR U) V) 00038040 (ADDSQ (MULTS2 (CAAR U) (DIFF2 (CDAR U) V)) 00038050 (DIFFK U V))))))) 00038060 00038070 (DIFFK (LAMBDA (U *S*) 00038080 (PROG (V W X Y Z) 00038090 (SETQ X (CAAR U)) 00038100 (COND 00038110 ((AND (EQ (CAR X) *S*) (SETQ X (CONS 1 1))) (GO D)) 00038120 ((OR (ATOM (CAR X)) 00038130 (AND (ATOM (CAAR X)) (GET (CAAR X) (QUOTE **ARRAY)))) 00038140 (RETURN (COND ((AND (SETQ Z (FKERN (CAR X))) 00038150 (ASSOC (QUOTE REP) (CDDR Z))) 00038151 (MKSQ (LIST (QUOTE DF) (CAR X) *S*) 1)) 00038152 (T (CONS NIL 1)))))) 00038153 (SETQ Y (FKERN (CAR X))) 00038160 (COND 00038170 ((AND (SETQ V (ASSOC (QUOTE DFN) (CDDR Y))) 00038180 (SETQ V (ASSOC *S* (CADR V))) 00038190 (SETQ X (CDR V))) 00038200 (GO D)) 00038210 ((OR (AND (NOT (ATOM (CAAR X))) 00038220 (SETQ X (NMULTSQ (DIFF2 (CAR X) *S*) (CDR X)))) 00038230 (AND (EQ (CAAR X) (QUOTE *SQ)) 00038240 (SETQ X (DIFF1 (CADAR X) *S*)))) 00038250 (GO B)) 00038260 ((OR (NOT (SETQ V (GET* (CAAR X) (QUOTE DFN)))) 00038270 (NOT 00038280 (DFP (SETQ W 00038290 (MAPCAR (CDAR X) 00038300 (FUNCTION 00038310 (LAMBDA(J) 00038320 (DIFF1 (SIMP J) *S*))))) 00038330 V))) 00038340 (GO H))) 00038350 (SETQ Z (CDAR X)) 00038360 (SETQ X (CONS NIL 1)) 00038370 (COND 00038380 ((NULL 00038390 (*EVAL 00038400 (CONS (QUOTE OR) 00038410 (MAPCAR W 00038420 (FUNCTION 00038430 (LAMBDA(J) 00038440 (LIST (QUOTE QUOTE) (CAR J)))))))) 00038450 (GO B))) 00038460 A (COND ((NULL W) (GO B)) 00038470 ((CAAR W) 00038480 (SETQ X 00038490 (ADDSQ (MULTSQ (CAR W) 00038500 (SIMP 00038510 (SUBLIS 00038520 (PAIR (CAAR V) Z) 00038530 (CDAR V)))) 00038540 X)))) 00038550 (SETQ W (CDR W)) 00038560 (SETQ V (CDR V)) 00038570 (GO A) 00038580 B (COND 00038590 ((SETQ V (ASSOC (QUOTE DFN) (CDDR Y))) (GO C)) 00038600 (T (ACONC Y (SETQ V (LIST (QUOTE DFN) NIL))))) 00038610 (SETQ DSUBL* (CONS (CDR V) DSUBL*)) 00038620 C (RPLACA (CDR V) (XADD (CONS *S* X) (CADR V) NIL T)) 00038630 (COND ((NULL (CAR X)) (RETURN X))) 00038640 D (SETQ U (CAR U)) 00038650 (SETQ W 00038660 (COND ((ONEP (CDAR U)) (CDR U)) 00038670 (T 00038680 (MULTF2 (GETPOWER (COND (Y Y) 00038690 (T (FKERN (CAAR U)))) 00038700 (SUB1 (CDAR U))) 00038710 (MULTN (CDAR U) (CDR U)))))) 00038720 (RETURN (CONS (MULTF (CAR X) W) (CDR X))) 00038730 H (SETQ V 00038740 (COND 00038750 ((EQ (CAAR X) (QUOTE DF)) 00038760 (CONS (CAAR X) (CONS (CADAR X) 00038765 (ORDAD *S* (CDDAR X))))) 00038770 (T (LIST (QUOTE DF) (CAR X) *S*)))) 00038780 (SETQ X 00038790 (COND ((SETQ W (OPMTCH V)) (SIMP W)) (T (MKSQ V 1)))) 00038800 (GO B)))) 00038810 00038820 (DFP (LAMBDA (U V) 00038830 (COND ((NULL U) (NULL V)) 00038840 ((NULL V) NIL) 00038850 ((CAAR U) (AND (CAR V) (DFP (CDR U) (CDR V)))) 00038860 (T (DFP (CDR U) (CDR V)))))) 00038870 00038880 )) 00038890 00038900 DEFINE (( 00038910 00038920 (GCDN (LAMBDA (P Q) 00038930 (GCDN0 (ABS P) (ABS Q)))) 00038940 00038950 (GCDN0 (LAMBDA (P Q) 00038960 (COND ((EQUAL P Q) P) 00038970 (*FLOAT (COND ((GREATERP P Q) Q) (T P))) 00038980 ((GREATERP Q P) (GCDN1 Q P)) 00038990 (T (GCDN1 P Q))))) 00039000 00039010 (GCDN1 (LAMBDA (P Q) 00039020 ((LAMBDA (X) (COND ((ZEROP X) Q) (T (GCDN1 Q X)))) 00039030 (REMAINDER P Q)))) 00039040 00039050 )) 00039060 00039070 DEFINE (( 00039080 00039090 (QUOTF (LAMBDA (P Q) 00039100 (COND ((NULL P) NIL) 00039110 ((EQUAL P Q) 1) 00039120 ((EQUAL Q 1) P) 00039130 ((ATOM Q) 00039140 (COND 00039150 ((ATOM P) 00039160 (COND (*FLOAT (TIMES P (RECIP (PLUS 0.0 Q)))) 00039165 (T ((LAMBDA (Z) 00039170 (COND ((ZEROP (CDR Z)) (CAR Z)) 00039180 (T NIL))) 00039200 (DIVIDE P Q))))) 00039210 (T (QUOTK (CAAR P) P Q)))) 00039220 ((ATOM P) NIL) 00039230 (T 00039240 ((LAMBDA(X Y) 00039250 (COND 00039260 ((EQ (CAR X) (CAR Y)) 00039270 ((LAMBDA(N) 00039280 (COND 00039290 ((NOT (MINUSP N)) 00039300 ((LAMBDA(W) 00039310 (COND 00039320 (W 00039330 ((LAMBDA(V Y) 00039340 (COND ((NULL Y) V) 00039350 (T 00039360 ((LAMBDA(Z) 00039370 (COND (Z (APPEND V Z)) (T NIL))) 00039380 (QUOTF Y Q))))) 00039390 (COND ((ZEROP N) W) 00039400 (T (LIST (CONS (MKSP (CAR X) N) W)))) 00039410 (ADDF P 00039420 (MULTF 00039430 (COND ((ZEROP N) Q) 00039440 (T (MULTF2 (MKSP (CAR X) N) Q))) 00039450 (MULTN -1 W))))) 00039460 (T NIL))) 00039470 (QUOTF (CDAR P) (CDAR Q)))) 00039480 (T NIL))) 00039490 (DIFFERENCE (CDR X) (CDR Y)))) 00039500 ((ORDP X Y) (QUOTK X P Q)) 00039510 (T NIL))) 00039520 (CAAR P) 00039530 (CAAR Q)))))) 00039540 00039550 (QUOTK (LAMBDA (X P Q) 00039560 ((LAMBDA(W) 00039570 (COND (W 00039580 (COND ((NULL (CDR P)) (LIST (CONS X W))) 00039590 (T 00039600 ((LAMBDA(Y) 00039610 (COND (Y (CONS (CONS X W) Y)) (T NIL))) 00039620 (QUOTF (CDR P) Q))))) 00039630 (T NIL))) 00039640 (QUOTF (CDAR P) Q)))) 00039650 00039660 )) 00039670 00039680 DEFINE (( 00039690 00039700 (ABSONE (LAMBDA (U) 00039710 (AND (NUMBERP U) (ONEP (ABS U))))) 00039720 00039730 (CDARX (LAMBDA (U) 00039740 (COND ((NULL (CDR U)) (CDAR U)) 00039750 (T (ERRACH (LIST (QUOTE CDARX) U)))))) 00039760 00039770 )) 00039780 00039790 DEFINE (( 00039800 00039810 (PRMCON (LAMBDA (P) 00039820 (PROG (X Y Q) 00039830 (SETQ Q P) 00039840 (COND ((ATOM P) (ERRACH (LIST (QUOTE PRMCON) P))) 00039850 ((AND (NULL (CDR P)) (SETQ X (CAR P))) (GO B))) 00039860 (SETQ Y (CAAAR P)) 00039870 A (COND 00039880 ((OR (AND (OR (ATOM Q) (NOT (EQ (CAAAR Q) Y))) 00039890 (SETQ X (CONS 1 (GCD (REVERSE (CONS Q X)))))) 00039900 (AND (NULL (CDR Q)) 00039910 (SETQ X 00039920 (CONS (CAAR Q) (GCD (CONS (CDAR Q) X)))))) 00039930 (GO B))) 00039940 (SETQ X (CONS (CDAR Q) X)) 00039950 (SETQ Q (CDR Q)) 00039960 (GO A) 00039970 B (RETURN 00039980 (CONS (QUOTF P 00039990 (COND ((ATOM (CAR X)) (CDR X)) (T (LIST X)))) 00040000 X))))) 00040010 00040020 (GCD (LAMBDA (L) 00040030 (COND ((NULL (CDR L)) (CAR L)) 00040040 ((MEMBER 1 L) 1) 00040050 (T (GCD (CONS (GCD1 (CAR L) (CADR L)) (CDDR L))))))) 00040060 00040070 (GCD1 (LAMBDA (U V) 00040080 (COND 00040090 ((OR (NULL U) (NULL V)) (ERRACH (LIST (QUOTE GCD1) U V))) 00040100 ((EQUAL U V) U) 00040110 ((ATOM U) 00040120 (COND ((ATOM V) (GCDN U V)) 00040130 (T (GCD (NCONS (CDR V) (LIST U (CDAR V))))))) 00040140 ((ATOM V) (GCD (NCONS (CDR U) (LIST V (CDAR U))))) 00040150 (T 00040160 ((LAMBDA(X Y) 00040170 (COND ((EQ X Y) 00040180 (PROG (N W X1 Y1 Z Z1 Z2 Z3) 00040190 (SETQ X1 (PRMCON U)) 00040200 (SETQ Y1 (PRMCON V)) 00040210 (SETQ W 1) 00040220 (SETQ Z1 (CAR X1)) 00040230 (SETQ Z2 (CAR Y1)) 00040240 (COND 00040250 ((OR (NULL *GCD) (ABSONE Z1) (ABSONE Z2)) 00040260 (GO A)) 00040270 ((OR (ATOM Z1) (ATOM Z2)) 00040280 (ERRACH (LIST (QUOTE GCDK) U V X1 Y1))) 00040290 ((EQ (CAAAR Z1) (CAAAR Z2)) (GO C))) 00040300 A (SETQ W (MULTF W (GCD1 (CDDR X1) (CDDR Y1)))) 00040310 (RETURN 00040320 (COND 00040330 ((OR (ATOM (CADR X1)) (ATOM (CADR Y1))) W) 00040340 ((ORDP (CADR X1) (CADR Y1)) 00040350 (MULTF2 (CADR Y1) W)) 00040360 (T (MULTF2 (CADR X1) W)))) 00040370 C (COND ((ORDP Z1 Z2) (GO D))) 00040380 (SETQ Z Z1) 00040390 D1 (SETQ Z1 Z2) 00040400 (SETQ Z2 Z) 00040410 D (SETQ Z (REMK Z1 Z2)) 00040420 (COND (Z (GO G))) 00040430 (SETQ W (CAR (PRMCON Z2))) 00040440 (GO A) 00040450 G (COND ((NULL N) (GO H))) 00040460 (SETQ Z (QUOTF Z (NMULTF Z3 N))) 00040470 (COND 00040480 ((NULL Z) 00040490 (REDERR 00040500 (LIST (QUOTE (INTEGER OVERFLOW)) Z3 N)))) 00040510 H (SETQ N 00040520 (ADD1 (DIFFERENCE (CDAAR Z1) (CDAAR Z2)))) 00040530 (SETQ Z3 (CDAR Z2)) 00040540 (COND 00040550 ((OR (ATOM Z) 00040560 (NULL (CDR Z)) 00040570 (NOT (EQ (CAAAR Z) (CAAAR Z1)))) 00040580 (GO A))) 00040590 (GO D1))) 00040600 ((ORDP X Y) (GCD (CONS V (COEFF U X)))) 00040610 (T (GCD (CONS U (COEFF V Y)))))) 00040620 (CAAAR U) 00040630 (CAAAR V)))))) 00040640 00040650 (COEFF (LAMBDA (U A) 00040660 (COND ((NULL U) NIL) 00040670 ((OR (ATOM U) (NOT (EQ (CAAAR U) A))) (LIST U)) 00040680 (T (CONS (CDAR U) (COEFF (CDR U) A)))))) 00040690 00040700 (REMK (LAMBDA (U V) 00040710 (REMK1 U V (CAAR V) NIL))) 00040720 00040730 (REMK1 (LAMBDA (U V W Z) 00040740 (COND 00040750 ((AND (NOT (ATOM U)) (ORDP (CAAR U) W)) 00040760 (REMK1 (ADDF (MULTF (CDAR V) U) 00040770 ((LAMBDA(M X) 00040780 (COND ((ZEROP M) (MULTN -1 X)) 00040790 (T 00040800 (MULTF 00040810 (LIST (CONS (MKSP (CAAAR U) M) -1)) 00040820 X)))) 00040830 (DIFFERENCE (CDAAR U) (CDR W)) 00040840 (MULTF (CDAR U) V))) 00040850 V 00040860 W 00040870 (MULTF Z (CDAR V)))) 00040880 ((NULL Z) U) 00040890 (T (CANCEL (CONS U Z)))))) 00040900 00040910 (REMK* (LAMBDA (U V) 00040920 (REMK1 U V (CAAR V) 1))) 00040930 00040940 (NMULTF (LAMBDA (U N) 00040950 (COND ((OR *EXP (KERNLP U)) (NMULTF1 U N)) (T (MKSFP U N))))) 00040960 00040970 (NMULTF1 (LAMBDA (U N) 00040980 (COND ((ONEP N) U) (T (MULTF U (NMULTF1 U (SUB1 N))))))) 00040990 00041000 )) 00041010 00041020 DEFINE (( 00041030 00041040 (OPERATOR (LAMBDA (U) 00041050 (PROG NIL 00041060 (COND 00041070 ((EQ *MODE (QUOTE SYMBOLIC)) 00041080 (RETURN (FLAG U (QUOTE OPFN))))) 00041090 A (COND ((NULL U) (RETURN NIL)) 00041100 ((OR (NUMBERP (CAR U)) (NOT (ATOM (CAR U)))) 00041110 (LPRIM* 00041120 (CONS (CAR U) (QUOTE (CANNOT BE AN OPERATOR))))) 00041130 ((GET (CAR U) (QUOTE SIMPFN)) 00041140 (LPRIM* (CONS (CAR U) (QUOTE (ALREADY DEFINED))))) 00041150 (T (MKOP (CAR U)))) 00041160 (SETQ U (CDR U)) 00041170 (GO A)))) 00041180 00041190 (FACTOR (LAMBDA (U) 00041200 (FACTOR1 U T (QUOTE FACTORS*)))) 00041210 00041220 (FACTOR1 (LAMBDA (U V W) 00041230 (PROG (X Y) 00041240 (SETQ Y (GTS W)) 00041250 A (COND ((NULL U) (GO B)) 00041260 ((OR (KERNP (SETQ X (SIMPCAR U))) 00041270 (AND *SUPER (KERNP (SETQ X (MKSFP X 1))))) 00041280 (GO C)) 00041290 (T (ERRPRI2 (CAR U)))) 00041300 (GO D) 00041310 C (SETQ X (CAAAAR X)) 00041320 (COND (V (SETQ Y (CONS X Y))) 00041330 ((NOT (MEMBER X Y)) 00041340 (MESPRI NIL (CAR U) (QUOTE (NOT FOUND)) NIL NIL)) 00041350 (T (SETQ Y (DELETE X Y)))) 00041360 D (SETQ U (CDR U)) 00041370 (GO A) 00041375 B (PTS W Y)))) 00041380 00041390 (REMFAC (LAMBDA (U) 00041400 (FACTOR1 U NIL (QUOTE FACTORS*)))) 00041410 00041420 )) 00041430 00041440 DEFINE (( 00041450 00041460 (FORALLFN* (LAMBDA NIL 00041470 (FORALLFN (RVLIS)))) 00041480 00041490 (FORALLFN (LAMBDA (U) 00041500 (PROG (X Y) 00041510 (SETQ X (MAPCAR U (FUNCTION NEWVAR))) 00041520 (SETQ Y (PAIR U X)) 00041530 (SETQ MCOND* (SUBLIS Y MCOND*)) 00041540 (SETQ FRLIS* (UNION X FRLIS*)) 00041550 (SETQ X (LIST (COMMAND1 NIL))) 00041560 (COND (MCOND* (SETQ X (CONS (LIST (QUOTE SETQ) 00041570 (QUOTE MCOND*) (LIST (QUOTE QUOTE) MCOND*)) X)))) 00041580 (COND (Y (SETQ X (CONS (LIST (QUOTE SETQ) (QUOTE FRASC*) 00041590 (LIST (QUOTE QUOTE) Y)) X)))) 00041592 (RETURN (MKPROG NIL X))))) 00041594 00041600 )) 00041610 00041620 DEFINE (( 00041630 00041640 (LET (LAMBDA (U) 00041650 (LET0 U NIL))) 00041660 00041670 (LET0 (LAMBDA (U V) 00041680 (PROG NIL 00041690 A (COND ((NULL U) (RETURN (SETQ MCOND* (SETQ FRASC* NIL)))) 00041700 ((OR (NOT (EQCAR (CAR U) (QUOTE EQUAL))) (CDDDAR U)) 00041710 (ERRPRI2 (CAR U)))) 00041720 (LET2 (CADAR U) (CAR (CDDAR U)) V T) 00041730 (SETQ U (CDR U)) 00041740 (GO A)))) 00041750 00041760 (LET1 (LAMBDA (U V) 00041770 (LET2 U V NIL T))) 00041780 00041790 (LET2 (LAMBDA (U V W B) 00041800 (PROG (X Y Z) 00041810 (SETQ U (SUBLIS FRASC* U)) 00041812 (SETQ V (SUBLIS FRASC* V)) 00041814 (COND ((AND FRASC* (EQCAR V (QUOTE *SQ))) 00041816 (SETQ V (PREPSQ (CADR V))))) 00041818 A (SETQ X U) 00041820 (COND ((NUMBERP X) (GO LER1)) 00041840 ((NOT (ATOM X)) (GO D)) 00041850 ((AND (SETQ Y (GET X (QUOTE OLDNAME))) 00041860 (NOT (MEMBER Y (FLATTEN V)))) (LET2 Y V W B))) 00041870 (COND (B (GO A2))) 00041880 (REMPROP X (QUOTE NEWNAME)) 00041890 (REMPROP X (QUOTE OLDNAME)) 00041900 A2 (COND 00041950 ((AND (VECTORP X) (VLET X V B)) (RETURN NIL)) 00041960 ((AND (NULL B) (GET X (QUOTE **ARRAY))) (GO J2)) 00041970 (W (GO H)) 00041980 ((MATEXPR V) (GO J))) 00041990 B1 (SETQ X (SIMP0 X)) 00042000 C (SETQ X (CAAAR X)) 00042010 (SETQ Z (FKERN (CAR X))) 00042020 (COND ((NULL B) (RETURN (RPLACD (CDR Z) NIL))) 00042025 ((ASSOC (QUOTE USED*) (CDR Z)) (RMSUBS2))) 00042030 (XADD 00042040 (COND 00042050 ((AND (EQUAL V 0) (NOT (EQUAL (CDR X) 1))) 00042060 (CONS (QUOTE ASYMP) (CDR X))) 00042070 (T (LIST (QUOTE REP) V (CDR X) NIL))) 00042080 (CDR Z) 00042090 (SQCHK (CAR Z)) 00042100 T) 00042110 (RPLACW Z (DELASC (QUOTE DFN) Z)) 00042120 (RETURN NIL) 00042130 D (COND ((NOT (ATOM (CAR X))) (GO LER2)) 00042140 ((GET* (CAR X) (QUOTE **ARRAY)) (GO L)) 00042150 ((EQ (CAR X) (QUOTE DF)) (GO K)) 00042160 ((NOT (GET* (CAR X) (QUOTE SIMPFN))) (GO LER3)) 00042180 ((OR W 00042190 (EQ (CAR X) (QUOTE TIMES)) 00042200 (XN (FLATTEN (CDR X)) FRLIS*)) 00042210 (GO H))) 00042220 (SETQ X (SIMP0 X)) 00042230 (COND ((NOT (EQUAL (CDR X) 1)) (GO LER1))) 00042240 E (COND ((NOT (KERNP X)) (GO G)) 00042250 ((NOT (ONEP (CDAAR X))) 00042260 (SETQ V (LIST (QUOTE QUOTIENT) V (CDAAR X))))) 00042270 (GO C) 00042280 G (COND ((NOT (KERNLP (CAR X))) (GO M))) 00042290 (SETQ X U) 00042300 H (RMSUBS) 00042305 (COND 00042310 ((OR (NULL 00042320 (SETQ Y 00042330 (KERNLP 00042340 (CAR (SETQ X (SIMP0 X)))))) 00042350 (NOT (ATOM (CDR X)))) 00042360 (GO LER2)) 00042370 ((AND (ONEP Y) (ONEP (CDR X))) (GO H1))) 00042380 (SETQ V (LIST (QUOTE TIMES) (CDR X) V)) 00042390 (COND 00042400 ((NOT (ONEP Y)) 00042410 (SETQ V (ACONC V (LIST (QUOTE QUOTIENT) 1 Y))))) 00042420 H1 (SETQ X (KLISTT (CAR X))) 00042430 (SETQ Y 00042440 (LIST (CONS W (COND (MCOND* MCOND*) (T T))) 00042450 V 00042460 NIL)) 00042470 (COND 00042480 ((AND (NULL W) (NULL (CDR X)) (ONEP (CDAR X))) (GO H2))) 00042490 (RETURN (SETQ MATCH* (XADD (CONS X Y) MATCH* U B))) 00042500 H2 (SETQ X (CAAR X)) 00042510 (COND ((NOT (MATEXPR V)) (GO H3)) 00042511 ((NOT (REDMSG (CAR X) (QUOTE MATRIX) T)) (ERROR*))) 00042512 (FLAG (LIST (CAR X)) (QUOTE MATFN)) 00042513 H3 (RETURN (PUT (CAR X) 00042514 (QUOTE OPMTCH*) 00042530 (XADD (CONS (CDR X) Y) 00042540 (GET (CAR X) (QUOTE OPMTCH*)) 00042550 U B))) 00042560 J (SETQ MATP* T) 00042590 (COND ((GET X (QUOTE MATRIX)) (GO J1)) 00042600 ((NOT (REDMSG X (QUOTE MATRIX) T)) (ERROR*))) 00042610 (PUT X (QUOTE MATRIX) (QUOTE MATRIX)) 00042620 J1 (COND ((EQCAR V (QUOTE MAT)) (RETURN (SETM X V))) 00042630 (T (GO B1))) 00042640 J2 (REMPROP X (QUOTE MATRIX)) 00042650 (REMPROP X (QUOTE **ARRAY)) 00042660 (RETURN NIL) 00042670 K (COND 00042680 ((AND (NOT (ATOMLIS (CADR X))) (CDDDR X)) (GO LER1)) 00042690 ((AND (NOT (GET* (CAADR X) (QUOTE SIMPFN))) 00042700 (SETQ X (CADR X))) 00042710 (GO LER3)) 00042720 ((OR (NOT (FRLP (CDADR X))) 00042730 (NOT (FRLP (CDDR X))) 00042740 (NOT (MEMBER (CADDR X) (CDADR X)))) 00042750 (GO H))) 00042760 (SETQ Z (POSN (CADDR X) (CDADR X))) 00042770 (COND 00042780 ((NOT (GET (CAADR X) (QUOTE DFN))) 00042790 (PUT (CAADR X) 00042800 (QUOTE DFN) 00042810 (NLIST NIL (LENGTH (CDADR X)))))) 00042820 (COND 00042830 ((NULL (REPN (GET (CAADR X) (QUOTE DFN)) Z V X)) 00042840 (GO LER1))) 00042850 (RETURN NIL) 00042860 L (COND ((AND (SETQ Z (ASSOC* X (GET (CAR X) (QUOTE KLIST)))) 00042865 (ASSOC (QUOTE USED*) (CDR Z))) (RMSUBS2))) 00042870 (SETEL (CONS (CAR X) (MAPCAR (CDR X) (FUNCTION 00042875 REVAL))) V) 00042880 (RETURN NIL) 00042890 M (COND ((NULL *SUPER) (GO LER1))) 00042900 (SETQ X (CONS (MKSFP (CAR X) 1) 1)) 00042910 (GO E) 00042920 LER1 (ERRPRI2 U) 00042930 (ERROR*) 00042940 LER2 (ERRPRI1 U) 00042950 (ERROR*) 00042960 LER3 (COND ((NOT (REDMSG (CAR X) (QUOTE OPERATOR) T)) (ERROR*))) 00042970 (MKOP (CAR X)) 00042980 (GO A)))) 00042990 00043000 (FRLP (LAMBDA (U) 00043010 (OR (NULL U) (AND (MEMBER (CAR U) FRLIS*) (FRLP (CDR U)))))) 00043020 00043030 (SIMP0 (LAMBDA (U) 00043040 (PROG (X) 00043050 (SETQ SUBFG* NIL) 00043060 (SETQ X (SIMP U)) 00043070 (SETQ SUBFG* T) 00043080 (RETURN X)))) 00043090 00043100 (MATCH (LAMBDA (U) 00043220 (LET0 U T))) 00043230 00043240 (CLEAR (LAMBDA (U) 00043250 (PROG NIL 00043260 (RMSUBS) 00043270 A (COND ((NULL U) (RETURN (SETQ MCOND* (SETQ FRASC* NIL))))) 00043280 B (LET2 (CAR U) NIL NIL NIL) 00043330 (SETQ U (CDR U)) 00043340 (GO A)))) 00043350 00043360 (KLISTT (LAMBDA (U) 00043370 (COND ((ATOM U) NIL) (T (CONS (CAAR U) (KLISTT (CDARX U))))))) 00043380 00043390 )) 00043400 00043410 PTS (NOCMP* T) 00043411 00043412 DEFINE (( 00043420 00043430 (KERNP (LAMBDA (U) 00043440 (AND (ATOM (CDR U)) 00043450 (NOT (ATOM (CAR U))) 00043460 (NULL (CDAR U)) 00043470 (ATOM (CDAAR U))))) 00043480 00043490 (KERNLP (LAMBDA (U) 00043500 (COND ((ATOM U) U) ((NULL (CDR U)) (KERNLP (CDAR U))) (T NIL)))) 00043510 00043520 (RMSUBS (LAMBDA NIL 00043530 (PROG2 (RMSUBS1) (RMSUBS2)))) 00043531 00043532 (RMSUBS2 (LAMBDA NIL 00043533 (PROG2 (RPLACA *SQVAR* NIL) (SETQ *SQVAR* (LIST T))))) 00043534 00043550 (RMSUBS1 (LAMBDA NIL 00043560 (PROG NIL 00043570 (MAP (APPEND DSUBL* SUBL*) 00043580 (FUNCTION (LAMBDA (J) (RPLACA (CAR J) NIL)))) 00043590 (SETQ SUBL* NIL)))) 00043600 00043610 (XADD (LAMBDA (U V W B) 00043620 (PROG (X) 00043630 (SETQ X (ASSOC* (CAR U) V)) 00043640 (COND ((NULL X) (GO C)) ((NULL B) (GO B1))) 00043650 (RMSUBS1) 00043660 (RPLACD X (CDR U)) 00043670 A (RETURN V) 00043680 B1 (SETQ V (DELETE X V)) 00043690 (GO A) 00043700 C (COND ((NULL B) (MESPRI NIL W (QUOTE (NOT FOUND)) NIL NIL)) 00043710 (T (SETQ V (NCONC V (LIST U))))) 00043720 (GO A)))) 00043730 00043740 (REPN (LAMBDA (U N V W) 00043750 (PROG NIL 00043760 A (COND ((OR (NULL U) (ZEROP N)) (RETURN NIL)) 00043770 ((NOT (ONEP N)) (GO B)) 00043780 ((CAR U) (REDEFPRI W))) 00043790 (RETURN (RPLACA U (CONS (CDADR W) V))) 00043800 B (SETQ U (CDR U)) 00043810 (SETQ N (SUB1 N)) 00043820 (GO A)))) 00043830 00043840 (DENOM (LAMBDA (U) 00043850 (LET1 U (MK*SQ (CONS (CDR (SIMP *ANS)) 1))))) 00043860 00043870 (NUMER (LAMBDA (U) 00043880 (LET1 U (MK*SQ (CONS (CAR (SIMP *ANS)) 1))))) 00043890 00043900 (ND (LAMBDA (U V) 00043910 (PROG2 (NUMER U) (DENOM V)))) 00043920 00043930 (SAVEAS (LAMBDA (U) 00043940 (SETK U *ANS))) 00043950 00043960 (SETK (LAMBDA (U V) 00043970 (PROG2 (LET1 U 00043980 (COND 00043990 ((AND(NOT (ATOM U))(NOT (ATOM V))(XN (CDR U) FRLIS*)) 00044000 (PREPSQ (CADR V))) 00044010 (T V))) 00044020 V))) 00044030 00044040 (TERMS (LAMBDA NIL 00044050 (PRINTTY 00044060 (COND 00044070 ((EQCAR *ANS (QUOTE *SQ)) (TERMS1 (CAADR *ANS))) 00044080 (T (SCNT *ANS)))))) 00044090 00044100 (TERMS1 (LAMBDA (U) 00044110 (PROG (N) 00044120 (SETQ N 0) 00044130 A (COND ((NULL U) (RETURN N)) ((ATOM U) (RETURN (ADD1 N)))) 00044140 (SETQ N (PLUS N (TERMS1 (CDAR U)))) 00044150 (SETQ U (CDR U)) 00044160 (GO A)))) 00044170 00044180 )) 00044190 00044200 DEFINE (( 00044210 00044220 (ANTISYMMETRIC (LAMBDA (U) 00044230 (FLAG U (QUOTE ANTISYMMETRIC)))) 00044240 00044250 (SYMMETRIC (LAMBDA (U) 00044260 (FLAG U (QUOTE SYMMETRIC)))) 00044270 00044280 )) 00044290 00044300 FLAG ((PLUS TIMES CONS) SYMMETRIC) 00044310 00044320 FLAG ((PLUS TIMES) NARY) 00044321 00044322 DEFINE (( 00044330 00044340 (MKCOEFF (LAMBDA (U V) 00044350 (PROG (W X Y Z) 00044360 (COND ((NOT (ATOM U)) (SETQ U (REVAL U)))) 00044370 (SETQ X FACTORS*) 00044380 (SETQ FACTORS* (LIST U)) 00044390 (SETQ W 00044400 (COND 00044410 ((EQCAR *ANS (QUOTE *SQ)) (CADR *ANS)) 00044420 (T (SIMP *ANS)))) 00044430 (SETQ Y (CONS (FORMOP (CAR W)) (FORMOP (CDR W)))) 00044440 (COND 00044450 ((NULL (EQUAL (CDR Y) 1)) 00044460 (LPRIM* (QUOTE (MKCOEFF GIVEN RATIONAL FUNCTION))))) 00044470 (SETQ W (CDR Y)) 00044480 (SETQ Y (CAR Y)) 00044490 A (COND ((OR (ATOM Y) (NOT (EQUAL (CAAAR Y) U))) (GO B))) 00044500 (SETQ Z 00044510 (CONS (CONS (CDAAR Y) 00044520 (PREPSQ (CANCEL (CONS (CDAR Y) W)))) 00044530 Z)) 00044540 (SETQ Y (CDR Y)) 00044550 (GO A) 00044560 B (COND ((NULL Y) (GO B1))) 00044570 (SETQ Z (CONS (CONS 0 (PREPSQ (CANCEL (CONS Y W)))) Z)) 00044580 B1 (COND 00044590 ((OR (AND (NOT (ATOM V)) (ATOM (CAR V)) 00044595 (SETQ Y (GET* (CAR V) (QUOTE **ARRAY)))) 00044600 (AND (ATOM V) 00044605 (SETQ Y (GET* V (QUOTE **ARRAY))) 00044610 (NULL (CDR Y)))) 00044615 (GO G))) 00044630 (SETQ Y (EXPLODE V)) 00044640 (SETQ V NIL) 00044650 C (COND ((NULL Z) (GO D))) 00044660 (SETQ V 00044670 (CONS (LIST (QUOTE EQUAL) 00044680 (COMPRESS (APPEND Y (EXPLODE (CAAR Z)))) 00044690 (CDAR Z)) 00044700 V)) 00044710 (SETQ Z (CDR Z)) 00044720 (GO C) 00044730 D (*APPLY (QUOTE LET) (LIST V)) 00044740 (COND 00044760 (*MSG 00044770 (LPRI 00044780 (NCONC (MAPLIST V (FUNCTION CADAR)) 00044790 (QUOTE (ARE NON ZERO)))))) 00044800 E (SETQ FACTORS* X) 00044805 (RETURN NIL) 00044810 G (SETQ Z (REVERSE Z)) 00044815 (COND ((ATOM V) (SETQ V (LIST V (QUOTE *))))) 00044820 (COND 00044840 (*MSG 00044850 (LPRI 00044860 (APPEND (QUOTE (HIGHEST POWER IS)) (LIST (CAAR Z)))))) 00044870 (SETQ Y (PAIR (CDR V) Y)) 00044871 G0 (COND ((AND (MEMBER (QUOTE *) (FLATTEN (CAAR Y))) 00044872 (SETQ Y (PLUS (CDAR Y) (MINUS (REVAL 00044873 (SUBST 0 (QUOTE *) (CAAR Y))))))) (GO G1))) 00044874 (SETQ Y (CDR Y)) 00044875 (GO G0) 00044876 G1 (COND 00044877 ((GREATERP (CAAR Z) Y) (REDERR (QUOTE (ARRAY TOO SMALL))))) 00044890 H (COND 00044900 ((OR (NULL Z) (NOT (EQUAL Y (CAAR Z)))) 00044910 (SETEL (SUBST Y (QUOTE *) V) 0)) 00044915 (T (PROG2 (SETEL (SUBST Y (QUOTE *) V) (CDAR Z)) 00044920 (SETQ Z (CDR Z))))) 00044925 (COND ((ZEROP Y) (GO E))) 00044930 (SETQ Y (SUB1 Y)) 00044950 (GO H)))) 00044960 00044970 )) 00044980 00044990 00045000 DEFINE (( 00045010 00045020 (WEIGHT (LAMBDA (U) 00045030 (PROG (X Y) 00045040 (RMSUBS) 00045050 A (COND ((NULL U) (RETURN NIL)) 00045060 ((OR (NOT (EQ (CAAR U) (QUOTE EQUAL))) 00045070 (NOT (AND (ATOM (CADAR U)) 00045075 (NOT (NUMBERP (CADAR U))))) 00045080 (NOT 00045090 (AND (NUMBERP (CADDAR U)) 00045100 (FIXP (CADDAR U)) 00045110 (NOT (MINUSP (CADDAR U)))))) 00045115 (ERRPRI1 (CAR U)))) 00045120 (SETQ Y (CADAR U)) 00045125 (COND ((SETQ X (GET Y (QUOTE OLDNAME))) (GO C))) 00045130 (SETQ X (NEWVAR Y)) 00045135 (PUT Y (QUOTE NEWNAME) X) 00045140 (PUT X (QUOTE OLDNAME) Y) 00045145 (FLAG (LIST X) (QUOTE WEIGHT)) 00045150 B (LET2 X 00045155 (LIST (QUOTE TIMES) 00045160 Y 00045165 (LIST (QUOTE EXPT) (QUOTE K*) (CADDAR U))) 00045170 NIL 00045175 T) 00045180 (SETQ U (CDR U)) 00045185 (GO A) 00045190 C (COND ((NOT (FLAGP Y (QUOTE WEIGHT))) (ERRPRI1 (CAR U)))) 00045195 (SETQ Y X) 00045200 (SETQ X (CADAR U)) 00045205 (GO B)))) 00045210 00045215 (WTLEVEL (LAMBDA (N) 00045220 (PROG (X) 00045225 (SETQ N (REVAL N)) 00045230 (COND 00045235 ((NOT (AND (NUMBERP N) (FIXP N) (NOT (MINUSP N)))) 00045240 (ERRPRI1 N))) 00045245 (SETQ X (ASSOC (QUOTE ASYMP) (CDDR (FKERN (QUOTE K*))))) 00045250 (COND ((EQUAL N (CDR X)) (RETURN NIL)) 00045255 ((NOT (GREATERP N (CDR X))) (RMSUBS2))) 00045260 (RMSUBS1) 00045265 (RPLACD X N)))) 00045270 00045300 )) 00045310 00045320 PTS (NOCMP* NIL) 00045321 00045322 DEFLIST (((WEIGHT RLIS) (WTLEVEL NORLIS)) STAT) 00045330 00045340 LET1 ((EXPT K* 2) 0) 00045350 00045360 COMMENT ((ELEMENTARY FUNCTION PROPERTIES)) 00045370 00045380 DEFLIST (((LOG IDEN) (COS IDEN) (SIN IDEN)) SIMPFN) 00045390 00045400 DEFLIST (( 00045410 (LOG (((LOG E) (((LOG E) . 1)) (REP 1 1 NIL)) 00045420 ((LOG 1) (((LOG 1) . 1)) (REP 0 1 NIL)))) 00045430 (COS (((COS 0) (((COS 0) . 1)) (REP 1 1 NIL)))) 00045440 (SIN (((SIN 0) (((SIN 0) . 1)) (REP 0 1 NIL)))) 00045450 ) KLIST) 00045460 00045470 DEFLIST (( 00045480 (EXPT (((X Y) TIMES Y (EXPT X (PLUS Y (MINUS 1)))) 00045490 ((X Y) TIMES (LOG X) (EXPT X Y)))) 00045500 (LOG (((X) QUOTIENT 1 X))) 00045510 (COS (((X) MINUS (SIN X)))) 00045520 (SIN (((X) COS X))) 00045530 ) DFN) 00045540 00045550 DEFLIST (( 00045560 (COS ((((MINUS ***X)) (NIL . T) (COS ***X) NIL))) 00045570 (SIN ((((MINUS ***X)) (NIL . T) (MINUS (SIN ***X)) NIL))) 00045580 ) OPMTCH*) 00045590 00045600 PTS (FRLIS* (***X)) 00045610 00045620 DEFINE (( 00045630 00045640 (MSIMP (LAMBDA (U V) 00045650 (PROG (X Y Z) 00045660 (COND ((AND (NULL V) SUBFG*) (SETQ U (SUBLIS VREP* U)))) 00045670 (SETQ U (MSIMP1 U V)) 00045680 A1 (COND ((NULL U) (RETURN Z))) 00045690 A0 (SETQ X (CAR U)) 00045700 A (COND ((AND V (NULL X)) (GO D)) 00045710 ((NULL X) (GO NULLU)) 00045720 ((OR (AND (NULL V) (VECTORP (CAR X))) 00045730 (AND V (MATP (CAR X)))) 00045740 (GO B))) 00045750 BACK (SETQ X (CDR X)) 00045760 (GO A) 00045770 B (SETQ Y (LIST (CAR X))) 00045780 (SETQ X (CDR X)) 00045790 C (COND ((NULL X) (GO D)) 00045800 ((AND (NULL V) (VECTORP (CAR X))) 00045810 (REDERR 00045820 (APPEND (QUOTE (REDUNDANT VECTOR)) (LIST (CAR U))))) 00045830 ((AND V (MATP (CAR X))) (SETQ Y (ACONC Y (CAR X))))) 00045840 (SETQ X (CDR X)) 00045850 (GO C) 00045860 D (SETQ X (SETDIFF (CAR U) Y)) 00045870 (SETQ Z 00045880 (ADDM1 (CONS (COND ((NULL X) (CONS 1 1)) 00045890 (T (SIMPTIMES X))) 00045900 (REVERSE Y)) 00045910 Z)) 00045920 (SETQ U (CDR U)) 00045930 (GO A1) 00045940 E (VECTOR (LIST (CAAR U))) 00045950 (GO A0) 00045960 NULLU 00045970 (COND 00045980 ((AND (ATOM (CAAR U)) 00045990 (NOT (NUMBERP (CAAR U))) 00046000 (REDMSG (CAAR U) (QUOTE VECTOR) T)) 00046010 (GO E)) 00046020 (T 00046030 (REDERR 00046040 (APPEND (QUOTE (MISSING VECTOR)) (LIST (CAR U)))))) 00046050 (GO BACK)))) 00046060 00046070 (MSIMP1 (LAMBDA (U1 *S*) ((LAMBDA (U) 00046080 (COND ((NUMBERP U) (LIST (LIST U))) 00046090 ((ATOM U) 00046100 ((LAMBDA(X) 00046110 (COND ((AND X SUBFG* (EQUAL (CADDR X) 1)) 00046115 (MSIMP1 (CADR X) *S*)) 00046120 (T 00046130 (PROG2 00046140 (COND ((NULL *S*) (FLAG (LIST U) (QUOTE USED*))) 00046150 (T NIL)) 00046160 (LIST (LIST U)))))) 00046170 (ASSOC (QUOTE REP) (CDDR (FKERN U))))) 00046180 ((EQ (CAR U) (QUOTE PLUS)) 00046190 (MAPCON (CDR U) 00046200 (FUNCTION (LAMBDA (J) (MSIMP1 (CAR J) *S*))))) 00046210 ((EQ (CAR U) (QUOTE MINUS)) 00046220 (MSIMPTIMES (LIST -1 (CARX (CDR U))) *S*)) 00046230 ((EQ (CAR U) (QUOTE TIMES)) (MSIMPTIMES (CDR U) *S*)) 00046240 ((EQ (CAR U) (QUOTE QUOTIENT)) 00046241 (MSIMPTIMES (LIST (CADR U) 00046242 (LIST (QUOTE RECIP) (CARX (CDDR U)))) 00046243 *S*)) 00046244 ((OR (NULL *S*) (EQCAR U (QUOTE MAT)) (NOT (MATEXPR U))) 00046250 (LIST (LIST U))) 00046260 ((EQ (CAR U) (QUOTE RECIP)) (MSIMPRS (CARX (CDR U)) NIL)) 00046270 ((EQ (CAR U) (QUOTE SOLVE)) 00046280 (MSIMPRS (CADR U) (MATSIMP (MSIMP (CADDR U) T)))) 00046290 (T 00046340 ((LAMBDA(Z) 00046350 (COND 00046360 ((OR (NOT (EQ (CAR U) (QUOTE EXPT))) 00046370 (NOT (NUMBERP Z)) 00046380 (NOT (FIXP Z))) 00046390 (REDERR (QUOTE (MATRIX SYNTAX)))) 00046400 ((MINUSP Z) 00046410 (MSIMPRS 00046420 (CONS (QUOTE TIMES) (NLIST (CADR U) (MINUS Z))) NIL)) 00046430 (T (MSIMPTIMES (NLIST (CADR U) Z) T)))) 00046440 ((LAMBDA(Y) 00046450 (COND 00046460 ((AND (EQCAR Y (QUOTE MINUS)) (NUMBERP (CADR Y))) 00046470 (MINUS (CADR Y))) 00046480 (T Y))) 00046490 (REVAL (CADDR U))))))) (EMTCH U1)))) 00046500 00046510 (MSIMPTIMES (LAMBDA (U V) 00046520 (COND ((NULL U) (ERRACH (QUOTE MSIMPTIMES))) 00046530 ((NULL (CDR U)) (MSIMP1 (CAR U) V)) 00046540 (T 00046550 ((LAMBDA(*S*) 00046560 (MAPCON (MSIMPTIMES (CDR U) V) 00046570 (FUNCTION 00046580 (LAMBDA(*S1*) 00046590 (MAPCAR *S* 00046600 (FUNCTION 00046610 (LAMBDA(K) 00046620 (APPEND (CAR *S1*) K)))))))) 00046630 (MSIMP1 (CAR U) V)))))) 00046640 00046650 (ADDM1 (LAMBDA (U V) 00046660 (COND ((NULL V) (LIST U)) 00046670 ((EQUAL (CDR U) (CDAR V)) 00046680 ((LAMBDA(X) 00046690 (COND ((NULL (CAR X)) (CDR V)) 00046700 (T (CONS (CONS X (CDR U)) (CDR V))))) 00046710 (ADDSQ (CAR U) (CAAR V)))) 00046720 ((ORDP (CDR U) (CDAR V)) (CONS U V)) 00046730 (T (CONS (CAR V) (ADDM1 U (CDR V))))))) 00046740 00046750 )) 00046760 00046770 DEFINE (( 00046780 00046790 (MATP (LAMBDA (U) 00046800 (COND ((ATOM U) (FLAGP** U (QUOTE MATRIX))) 00046810 (T (EQCAR U (QUOTE MAT)))))) 00046820 00046830 (MATEXPR (LAMBDA (U) 00046840 (AND MATP* (MATEXPR1 U)))) 00046850 00046860 (MATEXPR1 (LAMBDA (U) 00046870 (COND ((NULL U) NIL) 00046880 ((ATOM U) (MATP U)) 00046890 ((MEMBER (CAR U) (QUOTE (*SQ DET TRACE))) NIL) 00046900 ((OR (FLAGP** (CAR U) (QUOTE MATFN)) (MATEXPR1 (CADR U))) T) 00046910 (T 00046920 (*EVAL 00046930 (CONS (QUOTE OR) (MAPCAR (CDR U) (FUNCTION MATEXPR1)))))))) 00046940 00046950 )) 00046960 00046970 FLAG ((MAT) MATFN) 00046971 00046972 DEFINE (( 00046980 00046990 (MATSM (LAMBDA (U) 00047000 ((LAMBDA(X) 00047010 (COND 00047020 ((AND (NULL (CDR X)) (NULL (CDAR X))) (SIMP (CAAR X))) 00047030 (T (CONS (QUOTE MAT) X)))) 00047040 (MAPC2 (MATSIMP (MSIMP U T)) 00047050 (FUNCTION (LAMBDA (J) (MK*SQ (SUBS2 J)))))))) 00047060 00047070 )) 00047080 00047090 DEFINE (( 00047100 00047110 (MATSIMP (LAMBDA (U) 00047120 (PROG (X) 00047130 (SETQ X (SMMULT (CAAR U) (MMULT (CDAR U)))) 00047140 A (SETQ U (CDR U)) 00047150 (COND ((NULL U) (RETURN X))) 00047160 (SETQ X (MADD X (SMMULT (CAAR U) (MMULT (CDAR U))))) 00047170 (GO A)))) 00047180 00047190 (MMULT (LAMBDA (U) 00047200 (PROG (Y Z) 00047210 (SETQ Y (GETM* (CAR U))) 00047220 A (SETQ U (CDR U)) 00047230 (COND ((NULL U) (RETURN Y))) 00047240 (SETQ Z (GETM* (CAR U))) 00047250 (COND 00047260 ((NOT (EQUAL (LENGTH (CAR Y)) (LENGTH Z))) 00047270 (REDERR (QUOTE (MATRIX MISMATCH))))) 00047280 (SETQ Y (MULTM Y Z)) 00047290 (GO A)))) 00047300 00047310 (SMMULT (LAMBDA (*S* V) 00047320 (COND ((EQUAL *S* (CONS 1 1)) V) 00047330 (T (MAPC2 V (FUNCTION (LAMBDA (J) (MULTSQ *S* J)))))))) 00047340 00047350 (GETM* (LAMBDA (U) 00047360 (COND ((EQCAR U (QUOTE MAT)) (SIMPDET* (CDR U))) 00047370 (T 00047380 ((LAMBDA(X) 00047390 (COND 00047400 ((OR (NULL X) (EQ X (QUOTE MATRIX))) 00047410 (REDERR 00047420 (CONS (QUOTE MATRIX) (CONS U (QUOTE (NOT SET)))))) 00047430 (T (MLIST U (CAR X) (CADR X))))) 00047440 (COND ((ATOM U) (GET U (QUOTE MATRIX))) (T NIL))))))) 00047450 00047460 (MLIST (LAMBDA (U M N) 00047470 (PROG (M1 N1 X Y Z) 00047480 (SETQ M1 M) 00047490 A (SETQ Y NIL) 00047500 (SETQ N1 N) 00047510 B (COND 00047520 ((NULL (SETQ X (GETEL (LIST U M1 N1)))) 00047530 (REDERR (CONS U (CONS (LIST M1 N1) (QUOTE (NOT SET))))))) 00047540 (SETQ Y (CONS (SIMP X) Y)) 00047550 (SETQ N1 (SUB1 N1)) 00047560 (COND ((NOT (ZEROP N1)) (GO B))) 00047570 (SETQ Z (CONS Y Z)) 00047580 (SETQ M1 (SUB1 M1)) 00047590 (COND ((ZEROP M1) (RETURN Z))) 00047600 (GO A)))) 00047610 00047620 )) 00047630 00047640 DEFINE (( 00047650 00047660 (MADD (LAMBDA (U V) 00047670 (MAPCAR (PAIR U V) 00047680 (FUNCTION (LAMBDA (J) (MADD1 (CAR J) (CDR J))))))) 00047690 00047700 (MADD1 (LAMBDA (U V) 00047710 (COND ((NULL U) NIL) 00047720 (T (CONS (ADDSQ (CAR U) (CAR V)) (MADD1 (CDR U) (CDR V))))))) 00047730 00047740 )) 00047750 00047760 DEFLIST (((MATRIX RLIS)) STAT) 00047770 00047780 DEFINE (( 00047790 00047800 (MATRIX (LAMBDA (U) 00047810 (PROG NIL 00047820 (SETQ MATP* T) 00047830 A (COND ((NULL U) (RETURN NIL)) 00047840 ((ATOM (CAR U)) 00047850 (PUT (CAR U) 00047860 (QUOTE MATRIX) 00047870 ((LAMBDA (X) (COND (X X) (T (QUOTE MATRIX)))) 00047880 (GET* (CAR U) (QUOTE **ARRAY))))) 00047890 (T 00047900 (PROG2 (*APPLY (QUOTE AARRAY) (LIST (LIST (CAR U)))) 00047910 (PUT (CAAR U) (QUOTE MATRIX) 00047915 (MAPCAR (CDAR U) (FUNCTION REVAL)))))) 00047920 (SETQ U (CDR U)) 00047930 (GO A)))) 00047940 00047950 )) 00047960 00047970 DEFINE (( 00047980 00047990 (MULTM (LAMBDA (U *S*) 00048000 (MAPCAR U 00048010 (FUNCTION 00048020 (LAMBDA (J) (MULTM1 J *S* (LENGTH (CAR *S*)) NIL)))))) 00048030 00048040 (MULTM1 (LAMBDA (U V N W) 00048050 (COND ((ZEROP N) W) 00048060 (T (MULTM1 U V (SUB1 N) (CONS (MELEM U V N) W)))))) 00048070 00048080 (MELEM (LAMBDA (U V N) 00048090 (COND ((NULL U) (CONS NIL 1)) 00048100 (T 00048110 ((LAMBDA (X) (COND ((NULL (CAR X)) (CONS NIL 1)) (T X))) 00048120 (ADDSQ (MULTSQ (CAR U) (NTH (CAR V) N)) 00048130 (MELEM (CDR U) (CDR V) N))))))) 00048140 00048150 )) 00048160 00048170 DEFINE (( 00048180 00048190 (MATPRI (LAMBDA (U X) 00048200 (PROG (V M N) 00048210 (SETQ M 1) 00048220 (COND ((NULL X) (SETQ X (QUOTE MAT)))) 00048230 A (COND ((NULL U) (RETURN NIL))) 00048240 (SETQ N 1) 00048250 (SETQ V (CAR U)) 00048260 B (COND ((NULL V) (GO C)) 00048270 ((AND (EQUAL (CAR V) 0) *NERO) (GO B1))) 00048280 (MAPRIN (LIST X M N)) 00048290 (OPRIN (QUOTE EQUAL)) 00048350 (SETQ ORIG* POSN*) 00048360 (MATHPRINT (CAR V)) 00048370 (SETQ ORIG* 0) 00048380 (TERPRI*) 00048390 B1 (SETQ V (CDR V)) 00048400 (SETQ N (ADD1 N)) 00048410 (GO B) 00048420 C (SETQ U (CDR U)) 00048430 (SETQ M (ADD1 M)) 00048440 (GO A)))) 00048450 00048460 )) 00048470 00048480 DEFINE (( 00048490 00048500 (SETM (LAMBDA (U V) 00048510 (PROG (N M X Y) 00048520 (SETQ V (CDR V)) 00048530 (SETQ Y (LIST (LENGTH V) (LENGTH (CAR V)))) 00048540 (COND 00048550 ((NOT (EQ (SETQ X (GET U (QUOTE MATRIX))) (QUOTE MATRIX))) 00048560 (GO A))) 00048570 (*APPLY (QUOTE AARRAY) (LIST (LIST (CONS U Y)))) 00048580 (PUT U (QUOTE MATRIX) Y) 00048590 (GO A1) 00048600 A (COND 00048610 ((NOT (EQUAL X Y)) (REDERR (QUOTE (MATRIX MISMATCH))))) 00048620 A1 (SETQ M 1) 00048630 B (SETQ Y (CAR V)) 00048640 (SETQ N 1) 00048650 C (COND ((NULL Y) (GO D))) 00048660 (SETEL (LIST U M N) (CAR Y)) 00048670 (SETQ N (ADD1 N)) 00048680 (SETQ Y (CDR Y)) 00048690 (GO C) 00048700 D (SETQ V (CDR V)) 00048710 (COND ((NULL V) (RETURN NIL))) 00048720 (SETQ M (ADD1 M)) 00048730 (GO B)))) 00048740 00048750 )) 00048760 00048770 DEFINE (( 00048780 00048790 (MSIMPRS (LAMBDA (U V) 00048800 ((LAMBDA(X) 00048810 (LIST 00048820 (LIST 00048830 (CONS (QUOTE MAT) 00048840 (MAPC2 00048850 (COND 00048860 ((AND (NULL (CDR X)) (NULL V)) 00048870 (SMMULT (REVPR (CAAR X)) 00048880 (*MATINV (MMULT (CDAR X)) NIL))) 00048890 (T (*MATINV (MATSIMP X) V))) 00048900 (FUNCTION MK*SQ)))))) 00048910 (MSIMP U T)))) 00048920 00048930 )) 00048940 00048950 DEFINE (( 00048960 00048970 (AUGMENT (LAMBDA (U V) 00048980 (COND ((NULL U) NIL) 00048990 (T 00049000 (CONS (APPEND (CAR U) (CAR V)) (AUGMENT (CDR U) (CDR V)))))) 00049010 ) 00049020 00049030 )) 00049040 00049050 DEFINE (( 00049060 00049070 (SETMATELEM (LAMBDA (U I J ELEM) 00049080 (PROG (A) 00049090 (SETQ A (NTH U I)) 00049100 LOOP (COND ((EQUAL J 1) (RETURN (RPLACA A ELEM)))) 00049110 (SETQ J (SUB1 J)) 00049120 (SETQ A (CDR A)) 00049130 (GO LOOP)))) 00049140 00049150 )) 00049160 00049170 DEFINE (( 00049180 00049190 (LIPSON (LAMBDA (U M N V) 00049200 (PROG (AA AA1 K K1 K2 I J TEMP BB C0 CI1 CI2 AAK) 00049210 (SETQ AA (CONS 1 1)) 00049220 (SETQ K 2) 00049230 BEG (SETQ K1 (SUB1 K)) 00049240 (SETQ K2 (SUB1 K1)) 00049250 (COND ((GREATERP K M) (GO FB)) ((EQUAL K 2) (GO PIVOT))) 00049260 (SETQ AA (REVPR (NTH (NTH U K2) K2))) 00049270 PIVOT 00049280 (SETQ AA1 (NTH (NTH U K1) K1)) 00049290 (COND ((NULL (EQUAL AA1 (CONS NIL 1))) (GO L2))) 00049300 (SETQ I K) 00049310 L (COND ((GREATERP I M) (GO SING)) 00049320 ((EQUAL (NTH (NTH U I) K1) (CONS NIL 1)) (GO L1))) 00049330 (SETQ J K1) 00049340 L0 (COND ((GREATERP J N) (GO PL2))) 00049350 (SETQ TEMP (NTH (NTH U I) J)) 00049360 (SETMATELEM U I J (NEGSQ (NTH (NTH U K1) J))) 00049370 (SETMATELEM U K1 J TEMP) 00049380 (SETQ J (ADD1 J)) 00049390 (GO L0) 00049400 L1 (SETQ I (ADD1 I)) 00049410 (GO L) 00049420 PL2 (SETQ AA1 (NTH (NTH U K1) K1)) 00049430 L2 (SETQ I K) 00049440 L2A (COND ((GREATERP I M) (GO SING))) 00049450 (SETQ BB 00049460 (ADDSQ (MULTSQ AA1 (NTH (NTH U I) K)) 00049470 (NEGSQ 00049480 (MULTSQ (NTH (NTH U K1) K) 00049490 (NTH (NTH U I) K1))))) 00049500 (COND ((EQUAL BB (CONS NIL 1)) (GO L2B))) 00049510 (GO L3) 00049520 L2B (SETQ I (ADD1 I)) 00049530 (GO L2A) 00049540 L3 (SETQ C0 (MULTSQ BB AA)) 00049550 (COND ((EQUAL K M) (GO EV)) ((EQUAL I K) (GO COMP))) 00049560 (SETQ J K1) 00049570 L3A (COND ((GREATERP J N) (GO COMP))) 00049580 (SETQ TEMP (NTH (NTH U I) J)) 00049590 (SETMATELEM U I J (NEGSQ (NTH (NTH U K) J))) 00049600 (SETMATELEM U K J TEMP) 00049610 (SETQ J (ADD1 J)) 00049620 (GO L3A) 00049630 COMP (SETQ I (ADD1 K)) 00049640 (SETQ AAK (NTH (NTH U K) K)) 00049650 COMP1 00049660 (COND ((GREATERP I M) (GO EV))) 00049670 (SETQ CI1 00049680 (MULTSQ (ADDSQ (MULTSQ (NTH (NTH U K1) K) 00049690 (NTH (NTH U I) K1)) 00049700 (NEGSQ (MULTSQ AA1 (NTH (NTH U I) K)))) 00049710 AA)) 00049720 (SETQ CI2 00049730 (MULTSQ (ADDSQ (MULTSQ (NTH (NTH U K) K1) 00049740 (NTH (NTH U I) K)) 00049750 (NEGSQ 00049760 (MULTSQ AAK (NTH (NTH U I) K1)))) 00049770 AA)) 00049780 (SETQ J (ADD1 K)) 00049790 COMP2 00049800 (COND ((GREATERP J N) (GO COMP3))) 00049810 (SETMATELEM U 00049820 I 00049830 J 00049840 (MULTSQ 00049850 (ADDSQ (MULTSQ (NTH (NTH U I) J) C0) 00049860 (ADDSQ 00049870 (MULTSQ (NTH (NTH U K) J) CI1) 00049880 (MULTSQ (NTH (NTH U K1) J) CI2))) 00049890 AA)) 00049900 (SETQ J (ADD1 J)) 00049910 (GO COMP2) 00049920 COMP3 00049930 (SETQ I (ADD1 I)) 00049940 (GO COMP1) 00049950 EV (SETMATELEM U K K C0) 00049960 (SETQ J (ADD1 K)) 00049970 EV1 (COND ((GREATERP J N) (GO BOT))) 00049980 (SETMATELEM U 00049990 K 00050000 J 00050010 (MULTSQ (ADDSQ (MULTSQ AA1 (NTH (NTH U K) J)) 00050020 (NEGSQ 00050030 (MULTSQ 00050040 (NTH (NTH U K) K1) 00050050 (NTH (NTH U K1) J)))) 00050060 AA)) 00050070 (SETQ J (ADD1 J)) 00050080 (GO EV1) 00050090 BOT (SETQ K (ADD1 (ADD1 K))) 00050100 (GO BEG) 00050110 FB (COND ((EQUAL (NTH (NTH U M) M) (CONS NIL 1)) (GO SING))) 00050120 (RETURN U) 00050130 SING (COND 00050140 ((NULL V) 00050150 (RETURN (PROG2 (SETMATELEM U N N (CONS NIL 1)) U)))) 00050160 (REDERR (QUOTE (SINGULAR MATRIX)))))) 00050170 00050180 )) 00050190 00050200 DEFINE (( 00050210 00050220 (BACKSUB (LAMBDA (U M N) 00050230 (PROG (DET IJ I J JJ SUM) 00050240 (SETQ DET (NTH (NTH U M) M)) 00050250 (SETQ J (ADD1 M)) 00050260 ROWM (COND ((GREATERP J N) (GO ROWS))) 00050270 (SETMATELEM U 00050280 M 00050290 J 00050300 (CANCEL (MULTSQ (NTH (NTH U M) J) (REVPR DET)))) 00050310 (SETQ J (ADD1 J)) 00050320 (GO ROWM) 00050330 ROWS (SETQ IJ 1) 00050340 ROWS1 00050350 (COND ((GREATERP IJ (SUB1 M)) (GO DONE))) 00050360 (SETQ I (DIFFERENCE M IJ)) 00050370 (SETQ JJ (ADD1 M)) 00050380 ROWS2 00050390 (COND ((GREATERP JJ N) (GO ROWS5))) 00050400 (SETQ J (ADD1 I)) 00050410 (SETQ DET (NTH (NTH U I) I)) 00050420 (SETQ SUM (CONS NIL 1)) 00050430 ROWS3 00050440 (COND ((GREATERP J M) (GO ROWS4))) 00050450 (SETQ SUM 00050460 (ADDSQ SUM 00050470 (CANCEL (MULTSQ (NTH (NTH U I) J) (NTH (NTH U J) JJ))))) 00050480 (SETQ J (ADD1 J)) 00050490 (GO ROWS3) 00050500 ROWS4 00050510 (SETMATELEM U 00050520 I 00050530 JJ 00050540 (CANCEL 00050550 (MULTSQ (ADDSQ (NTH (NTH U I) JJ) (NEGSQ SUM)) 00050560 (REVPR DET)))) 00050570 (SETQ JJ (ADD1 JJ)) 00050580 (GO ROWS2) 00050590 ROWS5 00050600 (SETQ IJ (ADD1 IJ)) 00050610 (GO ROWS1) 00050620 DONE (RETURN U)))) 00050630 00050640 )) 00050650 00050660 DEFINE (( 00050670 00050680 (RHSIDE (LAMBDA (U M) 00050690 (COND ((NULL U) NIL) 00050700 (T (CONS (RHSIDE1 (CAR U) M) (RHSIDE (CDR U) M)))))) 00050710 00050720 )) 00050730 00050740 DEFINE (( 00050750 00050760 (RHSIDE1 (LAMBDA (U M) 00050770 (PROG NIL 00050780 A (COND ((EQUAL M 0) (RETURN U))) 00050790 (SETQ U (CDR U)) 00050800 (SETQ M (SUB1 M)) 00050810 (GO A)))) 00050820 00050830 )) 00050840 00050850 DEFINE (( 00050860 00050870 (GENERATEIDENT (LAMBDA (N) 00050880 (PROG (I K U V) 00050890 (SETQ I 1) 00050900 (SETQ V NIL) 00050910 E (COND ((GREATERP I N) (GO A))) 00050920 (SETQ U NIL) 00050930 (SETQ K 1) 00050940 C (COND ((GREATERP K N) (GO D)) ((EQUAL K I) (GO B))) 00050950 (SETQ U (CONS (CONS NIL 1) U)) 00050960 (SETQ K (ADD1 K)) 00050970 (GO C) 00050980 B (SETQ U (CONS (CONS 1 1) U)) 00050990 (SETQ K (ADD1 K)) 00051000 (GO C) 00051010 D (SETQ I (ADD1 I)) 00051020 (SETQ V (CONS U V)) 00051030 (GO E) 00051040 A (RETURN V)))) 00051050 00051060 (*MATINV (LAMBDA (U V) 00051070 (PROG (A B M N X) 00051080 (SETQ A U) 00051090 (SETQ X SUBFG*) 00051092 (SETQ SUBFG* NIL) 00051094 (SETQ M (LENGTH A)) 00051100 (SETQ N (LENGTH (CAR A))) 00051110 (COND 00051120 ((NOT (EQUAL M N)) (REDERR (QUOTE (NON SQUARE MATRIX))))) 00051130 (SETQ B (COND (V V) (T (GENERATEIDENT M)))) 00051140 (COND 00051150 ((AND V (NOT (EQUAL M (LENGTH B)))) 00051160 (REDERR (QUOTE (EQUATION MISMATCH))))) 00051170 (SETQ A (AUGMENT A B)) 00051180 (SETQ N (LENGTH (CAR A))) 00051190 (SETQ A (LIPSON A M N T)) 00051200 (SETQ A (BACKSUB A M N)) 00051210 (SETQ SUBFG* X) 00051212 (RETURN (MAPC2 (RHSIDE A M) (FUNCTION 00051220 (LAMBDA (J) (SIMP (PREPSQ J))))))))) 00051221 00051230 )) 00051240 00051250 DEFINE (( 00051260 00051270 (SIMPDET (LAMBDA (U) 00051280 (SIMPDET1 U T))) 00051290 00051300 (SIMPTRACE (LAMBDA (U) 00051310 (SIMPDET1 U NIL))) 00051320 00051330 (SIMPDET1 (LAMBDA (U V) 00051340 (PROG (N) 00051350 (COND 00051360 ((AND (NOT (EQCAR (CAR U) (QUOTE *COMMA*))) 00051370 (NOT (MATEXPR (CAR U)))) 00051380 (REDERR (QUOTE (MATRIX EXPRESSION REQUIRED))))) 00051390 (SETQ U 00051400 (COND 00051410 ((EQCAR (CAR U) (QUOTE *COMMA*)) 00051420 (MAPCAR U 00051430 (FUNCTION 00051440 (LAMBDA(J) 00051450 (MAPCAR 00051460 (COND 00051470 ((EQCAR J (QUOTE *COMMA*)) (CDR J)) 00051480 (T J)) 00051490 (FUNCTION SIMP)))))) 00051500 (T (MATSIMP (MSIMP (CARX U) T))))) 00051510 (COND 00051520 ((NOT (EQUAL (LENGTH U) (LENGTH (CAR U)))) 00051530 (REDERR (QUOTE (NON SQUARE MATRIX))))) 00051540 (COND (V (RETURN (DETQ U)))) 00051550 (SETQ N 1) 00051560 (SETQ V (CONS NIL 1)) 00051570 A (COND ((NULL U) (RETURN V))) 00051580 (SETQ V (ADDSQ (NTH (CAR U) N) V)) 00051590 (SETQ U (CDR U)) 00051600 (SETQ N (ADD1 N)) 00051610 (GO A)))) 00051620 00051630 (SIMPDET* (LAMBDA (U) 00051640 (MAPC2 U (FUNCTION SIMP)))) 00051650 00051660 (SIMPMAT (LAMBDA (U) 00051670 (REDERR (QUOTE (MATRIX MISMATCH))))) 00051680 00051690 )) 00051700 00051710 DEFLIST (((DET SIMPDET) (TRACE SIMPTRACE) (MAT SIMPMAT)) SIMPFN) 00051720 00051730 DEFINE (( 00051740 00051750 (DETQ (LAMBDA (U) 00051760 (PROG (V X) 00051770 (SETQ X SUBFG*) 00051772 (SETQ SUBFG* NIL) 00051774 (SETQ V (LENGTH U)) 00051776 (SETQ V (NTH (NTH (LIPSON U V V NIL) V) V)) 00051777 (SETQ SUBFG* X) 00051778 (RETURN (SIMP (PREPSQ V)))))) 00051779 00051780 )) 00051790 00051800 DEFLIST (((CONS SIMPDOT)) SIMPFN) 00051810 00051820 FLAG ((CONS) VOP) 00051830 00051840 DEFINE (( 00051870 00051880 (VOP (LAMBDA (U) 00051890 (FLAG U (QUOTE VOP)))) 00051900 00051910 (VECTORP (LAMBDA (U) 00051920 (AND (ATOM U) 00051930 (NOT (NUMBERP U)) 00051940 (OR (FLAGP U (QUOTE MASS)) 00051950 (FLAGP U (QUOTE VECTOR)) 00051960 (MEMBER U INDICES*))))) 00051970 00051980 (ISIMPQ (LAMBDA (U) 00051990 (CONS (ISIMP (CAR U)) (CDR U)))) 00052000 00052010 (ISIMP (LAMBDA (U) 00052020 (COND 00052030 ((OR (NULL SUBFG*) 00052035 (AND (NULL INDICES*) 00052040 (NULL GAMIDEN*) 00052050 (NULL (GET (QUOTE EPS) (QUOTE KLIST))))) 00052060 U) 00052070 (T (ISIMP1 U INDICES* NIL NIL NIL))))) 00052080 00052090 (ISIMP1 (LAMBDA (U I V W X) 00052100 (COND 00052110 ((ATOM U) 00052120 (COND 00052130 ((OR V X) (REDERR (APPEND (QUOTE (UNMATCHED INDEX ERROR)) I))) 00052140 (W (MULTF (EMULT W) (ISIMP1 U I V NIL X))) 00052150 (T U))) 00052160 (T 00052170 (ADDF (ISIMP2 (CAR U) I V W X) 00052180 (COND ((NULL (CDR U)) NIL) 00052190 (T (ISIMP1 (CDR U) I V W X)))))))) 00052200 00052210 (ISIMP2 (LAMBDA (U I V W X) 00052220 (PROG (Z) 00052230 (COND ((ATOM (SETQ Z (CAAR U))) (GO A)) 00052240 ((AND (EQ (CAR Z) (QUOTE CONS)) (XN (CDR Z) I)) 00052250 (RETURN (DOTSUM U I V W X))) 00052260 ((EQ (CAR Z) (QUOTE G)) (RETURN (SPUR0 U I V W X))) 00052270 ((EQ (CAR Z) (QUOTE EPS)) (RETURN (ESUM U I V W X)))) 00052280 A (RETURN (MULTF2 (CAR U) (ISIMP1 (CDR U) I V W X)))))) 00052290 00052300 (DOTSUM (LAMBDA (U I V W X) 00052310 (PROG (I1 N U1 U2 V1 Y Z) 00052320 (SETQ N (CDAR U)) 00052330 (COND 00052340 ((NOT (MEMBER (CAR (SETQ U1 (CDAAR U))) I)) 00052350 (SETQ U1 (REVERSE U1)))) 00052360 (SETQ U2 (CADR U1)) 00052370 (SETQ U1 (CAR U1)) 00052380 (SETQ V1 (CDR U)) 00052390 (COND ((EQUAL N 2) (GO H)) ((NOT (ONEP N)) (REDERR U))) 00052400 A (COND 00052410 ((NOT (MEMBER U1 I)) 00052420 (RETURN (MULTF (MKDOT U1 U2) (ISIMP1 V1 I1 V W X))))) 00052430 A1 (SETQ I1 (DELETE U1 I)) 00052440 (COND ((EQ U1 U2) (RETURN (MULTN 4 (ISIMP1 V1 I1 V W X)))) 00052450 ((NOT (SETQ Z (ASSOC U1 V))) (GO C)) 00052460 ((MEMBER U2 I) (GO D))) 00052470 (SETQ U1 (CDR Z)) 00052480 (GO E) 00052490 C (COND 00052500 ((SETQ Z (MEMLIS U1 X)) 00052510 (RETURN 00052520 (SPUR0 (CONS (CONS (CONS (QUOTE G) (SUBST U2 U1 Z)) 1) 00052530 V1) 00052540 I1 00052550 V 00052560 W 00052570 (DELETE Z X)))) 00052580 ((SETQ Z (MEMLIS U1 W)) 00052590 (RETURN 00052600 (ESUM (CONS (CONS (CONS (QUOTE EPS) (SUBST U2 U1 Z)) 1) 00052610 V1) 00052620 I1 00052630 V 00052640 (DELETE Z W) 00052650 X))) 00052660 ((AND (MEMBER U2 I) (NULL Y)) (GO G))) 00052670 (RETURN (ISIMP1 V1 I (CONS (CONS U1 U2) V) W X)) 00052680 D (SETQ U1 U2) 00052690 (SETQ U2 (CDR Z)) 00052700 E (SETQ I I1) 00052710 (SETQ V (DELETE Z V)) 00052720 (GO A) 00052730 G (SETQ Y T) 00052740 (SETQ Z U1) 00052750 (SETQ U1 U2) 00052760 (SETQ U2 Z) 00052770 (GO A1) 00052780 H (COND ((EQ U1 U2) (REDERR U))) 00052790 (SETQ I (DELETE U1 I)) 00052800 (SETQ U1 U2) 00052810 (GO A)))) 00052820 00052830 )) 00052840 00052850 DEFINE (( 00052860 00052870 (VMULT (LAMBDA (U) 00052880 (PROG (Z) 00052890 (SETQ U 00052900 (REVERSE 00052910 (MAPCAR U (FUNCTION (LAMBDA (J) (MSIMP J NIL)))))) 00052920 A (COND ((NULL U) (RETURN Z)) 00052930 ((NULL Z) (SETQ Z (CAR U))) 00052940 (T (SETQ Z (VMULT1 (CAR U) Z)))) 00052950 (SETQ U (CDR U)) 00052960 (GO A)))) 00052970 00052980 (VMULT1 (LAMBDA (U *S1*) 00052990 (COND ((NULL *S1*) NIL) 00053000 (T 00053010 (MAPCON U 00053020 (FUNCTION 00053030 (LAMBDA(*S*) 00053040 (MAPCAR *S1* 00053050 (FUNCTION 00053060 (LAMBDA(J) 00053070 (CONS (MULTSQ (CAAR *S*) (CAR J)) 00053080 (APPEND (CDAR *S*) 00053090 (CDR J))))))))))))) 00053100 00053110 )) 00053120 00053130 DEFINE (( 00053140 00053150 (SIMPDOT (LAMBDA (U) 00053160 (COND ((CDDR U) (ERRACH (LIST (QUOTE SIMPDOT) U))) 00053170 (T 00053180 (MKVARG U 00053190 (FUNCTION 00053200 (LAMBDA(J) 00053210 (MKSQ (CONS (QUOTE CONS) (ORD2 (CAR J) (CADR J))) 00053220 1)))))))) 00053230 00053240 (MKVARG (LAMBDA (U *PI*) 00053250 (PROG (Z) 00053260 (SETQ U (VMULT U)) 00053270 (SETQ Z (CONS NIL 1)) 00053280 A (COND ((NULL U) (RETURN Z))) 00053290 (SETQ Z (ADDSQ (MULTSQ (*PI* (CDAR U)) (CAAR U)) Z)) 00053300 (SETQ U (CDR U)) 00053310 (GO A)))) 00053320 00053330 (MKDOT (LAMBDA (U V) 00053340 (MKSF (CONS (QUOTE CONS) (ORD2 U V)) 1))) 00053350 00053360 (VLET (LAMBDA (U V B) 00053370 (PROG2 00053375 (AND B (FLAGP U (QUOTE USED*)) (RMSUBS2)) 00053380 (SETQ VREP* (XADD (CONS U V) VREP* U B))))) 00053385 00053390 )) 00053400 00053410 DEFINE (( 00053420 00053430 (INDEX (LAMBDA (U) 00053440 (SETQ INDICES* (UNION INDICES* U)))) 00053450 00053460 (REMIND (LAMBDA (U) 00053470 (PROG2 (VECTOR U) (SETQ INDICES* (SETDIFF INDICES* U))))) 00053480 00053490 (MASS (LAMBDA (U) 00053500 (COND ((NULL U) NIL) 00053510 (T 00053520 (PROG2 (PUT (CADAR U) (QUOTE MASS) (CADDAR U)) 00053530 (MASS (CDR U))))))) 00053540 00053550 (MSHELL (LAMBDA (U) 00053560 (PROG (X Z) 00053570 A (COND ((NULL U) (RETURN (LET Z)))) 00053580 (SETQ X (GETMAS (CAR U))) 00053590 (SETQ Z 00053600 (CONS (LIST (QUOTE EQUAL) 00053610 (LIST (QUOTE CONS) (CAR U) (CAR U)) 00053620 (LIST (QUOTE TIMES) X X)) 00053630 Z)) 00053640 (SETQ U (CDR U)) 00053650 (GO A)))) 00053660 00053670 (GETMAS (LAMBDA (U) 00053680 ((LAMBDA(X) 00053690 (COND (X X) (T (REDERR (CONS U (QUOTE (HAS NO MASS))))))) 00053700 (GET* U (QUOTE MASS))))) 00053710 00053720 (VECTOR (LAMBDA (U) 00053730 (FLAG U (QUOTE VECTOR)))) 00053740 00053750 )) 00053760 00053770 DEFINE (( 00053780 00053790 (VCREP (LAMBDA (U) 00053800 ((LAMBDA(X) 00053810 (COND 00053820 ((AND SUBFG* (NOT (EQUAL X (CAR U)))) 00053830 (NCONC U (LIST (LIST (QUOTE REP) X 1 NIL NIL)))) 00053840 (T NIL))) 00053850 (SUBLIS VREP* (CAR U))))) 00053860 00053870 )) 00053880 00053890 DEFLIST (((MSHELL RLIS) (MASS RLIS) (INDEX RLIS) (REMIND RLIS) (VECTOR 00053900 RLIS) (VOP RLIS)) STAT) 00053910 00053920 FLAG ((EPS) VOP) 00053950 00053960 DEFLIST (((G SIMPGAMMA) (EPS SIMPEPS)) SIMPFN) 00053970 00053980 FLAG ((G) NONCOM) 00053990 00054000 DEFLIST (((G GMULT)) MRULE) 00054010 00054020 DEFINE (( 00054030 00054040 (GMULT (LAMBDA (U V) 00054050 (COND 00054060 ((OR (NOT (EQUAL (CDR U) 1)) (NOT (EQUAL (CDR V) 1))) 00054070 (ERRACH (LIST (QUOTE GMULT) U V))) 00054080 ((NOT (EQ (CADAR U) (CADAR V))) (QUOTE FAILED)) 00054090 (T (GCHECK (REVERSE (CDDAR U)) (CDDAR V) (CADAR U)))))) 00054100 00054110 (NONCOM (LAMBDA (U) 00054120 (FLAG U (QUOTE NONCOM)))) 00054130 00054140 )) 00054150 00054160 DEFINE (( 00054170 00054180 (SPUR (LAMBDA (U) 00054190 (PROG2 (RMSUBS) 00054200 (MAP U 00054210 (FUNCTION 00054220 (LAMBDA(J) 00054230 (PROG2 (REMFLAG (LIST (CAR J)) (QUOTE NOSPUR)) 00054240 (REMFLAG (LIST (CAR J)) (QUOTE REDUCE))))))))) 00054250 00054260 (NOSPUR (LAMBDA (U) 00054270 (FLAG U (QUOTE NOSPUR)))) 00054280 00054290 (REDUCE (LAMBDA (U) 00054300 (PROG2 (NOSPUR U) (FLAG U (QUOTE REDUCE))))) 00054310 00054320 (SIMPGAMMA (LAMBDA (*S*) 00054330 (COND 00054340 ((OR (NULL *S*) (NULL (CDR *S*))) 00054350 (REDERR (QUOTE (MISSING ARGUMENTS FOR G OPERATOR)))) 00054360 (T 00054370 (PROG NIL 00054380 (SETQ GAMIDEN* (UNION (LIST (CAR *S*)) GAMIDEN*)) 00054390 (SETQ *NCMP T) 00054400 (RETURN 00054410 (MKVARG (CDR *S*) 00054420 (FUNCTION 00054430 (LAMBDA(J) 00054440 (CONS (GCHECK (REVERSE J) NIL (CAR *S*)) 00054450 1)))))))))) 00054460 00054470 (GCHECK (LAMBDA (U V L) 00054480 (COND ((EQ (CAR V) (QUOTE A)) (GCHKA U (CDR V) T L)) 00054490 (T (GCHKV U V T L))))) 00054500 00054510 (GCHKA (LAMBDA (U V X W) 00054520 (COND ((NULL U) (MULTN (NB X) (MKG (CONS (QUOTE A) V) W))) 00054530 ((EQ (CAR U) (QUOTE A)) (GCHKV (CDR U) V X W)) 00054540 (T (GCHKA (CDR U) (CONS (CAR U) V) (NOT X) W))))) 00054550 00054560 (GCHKV (LAMBDA (U V X L) 00054570 (COND ((NULL U) 00054580 (COND ((NULL V) (NB X)) (T (MULTN (NB X) (MKG V L))))) 00054590 ((EQ (CAR U) (QUOTE A)) (GCHKA (CDR U) V X L)) 00054600 (T (GCHKV (CDR U) (CONS (CAR U) V) X L))))) 00054610 00054620 (MKG (LAMBDA (U L) 00054630 (LIST (CONS (CONS (CONS (QUOTE G) (CONS L U)) 1) 1)))) 00054640 00054650 (MKA (LAMBDA (L) 00054660 (MKG (LIST (QUOTE A)) L))) 00054670 00054680 (MKG1 (LAMBDA (U L) 00054690 (COND 00054700 ((OR (NOT (FLAGP L (QUOTE NOSPUR))) 00054710 (NULL (CDR U)) 00054720 (CDDR U) 00054730 (ORDOP (CAR U) (CADR U)) 00054740 (EQ (CAR U) (QUOTE A))) 00054750 (MKG U L)) 00054760 (T 00054770 (ADDF (MULTN 2 (MKDOT (CAR U) (CADR U))) 00054780 (MULTN -1 (MKG (REVERSE U) L))))))) 00054790 00054800 (NB (LAMBDA (U) 00054810 (COND (U 1) (T -1)))) 00054820 00054830 )) 00054840 00054850 DEFINE (( 00054860 00054870 (SPUR0 (LAMBDA (U I V1 V2 V3) 00054880 (PROG (L V W I1 Z KAHP) 00054890 (SETQ L (CADAAR U)) 00054900 (SETQ V (CDDAAR U)) 00054910 (COND ((NOT (ONEP (CDAR U))) (SETQ V (APPN V (CDAR U))))) 00054920 (SETQ U (CDR U)) 00054930 (COND 00054940 ((AND (NOT (GET L (QUOTE NOSPUR))) 00054950 (OR (AND (EQ (CAR V) (QUOTE A)) 00054960 (OR (LESSP (LENGTH V) 5) 00054970 (NOT (EVENP (CDR V))))) 00054980 (AND (NOT (EQ (CAR V) (QUOTE A))) 00054990 (NOT (EVENP V))))) 00055000 (RETURN NIL)) 00055010 ((NULL I) (GO END))) 00055020 A (COND ((NULL V) (GO END1)) ((MEMBER (CAR V) I) (GO B))) 00055030 A1 (SETQ W (CONS (CAR V) W)) 00055040 (SETQ V (CDR V)) 00055050 (GO A) 00055060 B (COND ((MEMBER (CAR V) (CDR V)) (GO KAH1)) 00055070 ((MEMBER (CAR V) I1) (GO A1)) 00055080 ((SETQ Z (BASSOC (CAR V) V1)) (GO E)) 00055090 ((SETQ Z (MEMLIS (CAR V) V2)) 00055100 (RETURN 00055110 ((LAMBDA(X) 00055120 (COND 00055130 ((AND (FLAGP L (QUOTE REDUCE)) 00055140 (NULL V1) 00055150 (NULL V3) 00055160 (NULL (CDR V2))) 00055170 (MULTF (MKG* X L) (MULTF (MKEPS1 Z) (ISIMP U)))) 00055180 (T 00055190 (ISIMP1 00055200 (SPUR0 (CONS (CAAR (MKG X L)) U) 00055210 NIL 00055220 V1 00055230 (DELETE Z V2) 00055240 V3) 00055250 I 00055260 NIL 00055270 (LIST Z) 00055280 NIL)))) 00055290 (APPEND (REVERSE W) V)))) 00055300 ((SETQ Z (MEMLIS (CAR V) V3)) (GO C)) 00055310 (T 00055320 (RETURN 00055330 (ISIMP1 U 00055340 I 00055350 V1 00055360 V2 00055370 (CONS (CONS L (APPEND (REVERSE W) V)) 00055380 V3))))) 00055390 C (SETQ V3 (DELETE Z V3)) 00055400 (SETQ KAHP NIL) 00055410 (COND 00055420 ((AND (FLAGP L (QUOTE NOSPUR)) 00055430 (FLAGP (CAR Z) (QUOTE NOSPUR))) 00055440 (ERROR (QUOTE HELP))) 00055450 ((FLAGP (CAR Z) (QUOTE NOSPUR)) (SETQ KAHP (CAR Z)))) 00055460 (SETQ Z (CDR Z)) 00055470 (SETQ I1 NIL) 00055480 C1 (COND ((EQ (CAR V) (CAR Z)) (GO D))) 00055490 (SETQ I1 (CONS (CAR Z) I1)) 00055500 (SETQ Z (CDR Z)) 00055510 (GO C1) 00055520 D (SETQ Z (CDR Z)) 00055530 (SETQ I (DELETE (CAR V) I)) 00055540 (SETQ V (CDR V)) 00055550 (COND ((NOT (FLAGP L (QUOTE NOSPUR))) (GO D0))) 00055560 (SETQ W (CONS W (CONS V (CONS I1 Z)))) 00055570 (SETQ I1 (CAR W)) 00055580 (SETQ Z (CADR W)) 00055590 (SETQ V (CADDR W)) 00055600 (SETQ W (CDDDR W)) 00055610 D0 (SETQ W (REVERSE W)) 00055620 (COND 00055630 ((AND (OR (NULL V) (NOT (EQ (CAR W) (QUOTE A)))) 00055640 (SETQ V (APPEND V W))) 00055650 (GO D1)) 00055660 ((NOT (EVENP V)) (SETQ U (MULTN -1 U)))) 00055670 (SETQ V (CONS (QUOTE A) (APPEND V (CDR W)))) 00055680 D1 (COND (KAHP (SETQ L KAHP))) 00055690 (SETQ VARS* NIL) 00055700 (SETQ Z (MULTF (MKG (REVERSE I1) L) 00055710 (MULTF (BRACE V L I) (MULTF (MKG1 Z L) U)))) 00055720 (SETQ Z (ISIMP1 Z (APPEND VARS* I) V1 V2 V3)) 00055730 (COND ((NULL Z) (RETURN Z)) 00055780 ((NULL (SETQ Z (QUOTF Z 2))) 00055790 (ERRACH (LIST (QUOTE SPUR0) U I V1 V2 V3)))) 00055800 (RETURN Z) 00055810 E (SETQ V1 (DELETE Z V1)) 00055820 (SETQ I (DELETE (CAR W) I)) 00055830 (SETQ V (CONS (OTHER (CAR V) Z) (CDR V))) 00055840 (GO A) 00055850 KAH1 (COND ((EQ (CAR V) (CADR V)) (GO K2))) 00055860 (SETQ KAHP T) 00055870 (SETQ I1 (CONS (CAR V) I1)) 00055880 (GO A1) 00055890 K2 (SETQ I (DELETE (CAR V) I)) 00055900 (SETQ V (CDDR V)) 00055910 (SETQ U (MULTN 4 U)) 00055920 (GO A) 00055930 END (SETQ W (REVERSE V)) 00055940 END1 (COND (KAHP (GO END2)) 00055950 ((NULL (SETQ Z (SPURR W L NIL 1))) (RETURN NIL)) 00055960 (T (RETURN (COND ((AND (GET (QUOTE EPS) (QUOTE KLIST)) 00055970 (NOT (FLAGP L (QUOTE NOSPUR)))) 00055971 (ISIMP1 (MULTF Z U) I V1 V2 V3)) 00055972 (T (MULTF Z (ISIMP1 U I V1 V2 V3))))))) 00055973 END2 (SETQ VARS* NIL) 00055980 (SETQ Z (MULTF (KAHANE (REVERSE W) I1 L) U)) 00055990 (RETURN (ISIMP1 Z (APPEND VARS* (SETDIFF I I1)) V1 V2 V3))))) 00056000 00056040 (APPN (LAMBDA (U N) 00056050 (COND ((ONEP N) U) (T (APPEND U (APPN U (SUB1 N))))))) 00056060 00056070 (OTHER (LAMBDA (U V) 00056080 (COND ((EQ U (CAR V)) (CDR V)) (T (CAR V))))) 00056090 00056100 )) 00056110 00056120 DEFINE (( 00056130 00056140 (KAHANE (LAMBDA (U I L) 00056150 (PROG (K2 LD LU M P V W X Y) 00056160 (SETQ K2 0) 00056170 (SETQ M 0) 00056180 (SETQ W (LIST T T NIL)) 00056190 (COND ((EQ (CAR U) (QUOTE A)) (GO B))) 00056200 A (COND 00056210 ((AND (NULL U) (SETQ W (CONS NIL (CONS NIL (CONS NIL W))))) 00056220 (GO KETJAK)) 00056230 ((MEMBER (CAR U) I) (GO D))) 00056240 (SETQ P (NOT P)) 00056250 B (SETQ W (CONS (CAR U) W)) 00056260 C (SETQ U (CDR U)) 00056270 (GO A) 00056280 D (SETQ W (CONS (CAR U) (CONS P (CONS NIL W)))) 00056290 (SETQ X NIL) 00056300 KETJAK 00056310 (SETQ W (REVERSE W)) 00056320 TJARUM 00056330 (COND ((CADR W) (SETQ LU (CONS W LU))) 00056340 (T (SETQ LD (CONS W LD)))) 00056350 (COND ((NULL U) (GO DJANGER)) (X (GO MAS))) 00056360 (SETQ W (REVERSE W)) 00056370 (SETQ X T) 00056380 (GO TJARUM) 00056390 MAS (SETQ W (LIST T (SETQ P (NOT P)) (CAR U))) 00056400 (SETQ K2 (ADD1 K2)) 00056410 (GO C) 00056420 DJANGER 00056430 (SETQ LU (REVERSE LU)) 00056440 BARUNA 00056450 (COND ((NULL LU) (GO JAVA))) 00056460 (SETQ V (CAR LU)) 00056470 (SETQ LU (CDR LU)) 00056480 WAJANG 00056490 (SETQ X (CONS (CAR V) (CADR V))) 00056495 (SETQ P (NULL (CADDR V))) 00056500 (SETQ M (ADD1 M)) 00056510 (SETQ W NIL) 00056520 RINDIK 00056530 (SETQ Y (REVERSE V)) 00056540 R1 (COND ((CADR Y) (SETQ LU (DELETE Y LU))) 00056545 (T (SETQ LD (DELETE Y LD)))) 00056550 (COND ((EQ Y V) (GO RINDIK)) 00056555 (P (AND (SETQ V Y) 00056560 (SETQ X (CONS (CAR V) (CADR V))) 00056565 (SETQ P NIL)))) 00056570 (SETQ V (CDDDR V)) 00056575 BANDJAR 00056580 (COND ((CDDDR V) (GO SUBAK)) 00056585 ((NULL (CADDR V)) (GO WADAH)) 00056590 ((AND (EQ (CADDR V) (CAR X)) 00056595 (EQ (CADR V) (CDR X))) (GO BARIS))) 00056596 (SETQ V 00056600 (SASSOC (CADDR V) 00056605 (COND ((CADR V) LU) (T LD)) 00056610 (FUNCTION 00056650 (LAMBDA NIL (ERRACH (QUOTE KAHANE)))))) 00056660 (SETQ Y V) 00056670 (GO R1) 00056680 SUBAK 00056700 (SETQ W (CONS (CAR V) W)) 00056710 (SETQ V (CDR V)) 00056720 (GO BANDJAR) 00056730 WADAH 00056740 (SETQ U (MKG (REVERSE W) L)) 00056750 (GO BARUNA) 00056760 BARIS 00056770 (COND ((AND W (CDR X)) (SETQ W (NCONC (CDR W) (LIST (CAR W)))))) 00056775 (SETQ U (MULTF (BRACE W L NIL) U)) 00056780 (GO BARUNA) 00056790 JAVA (COND ((NULL LD) (GO HOME))) 00056800 (SETQ V (CAR LD)) 00056810 (SETQ LD (CDR LD)) 00056820 (GO WAJANG) 00056830 HOME (SETQ K2 (QUOTIENT K2 2)) 00056840 (SETQ X (EXPT 2 K2)) 00056850 (COND 00056860 ((ZEROP (REMAINDER (DIFFERENCE K2 M) 2)) 00056870 (SETQ X (MINUS X)))) 00056880 (RETURN (MULTN X U))))) 00056890 00056900 (BRACE (LAMBDA (U L I) 00056910 (COND ((NULL U) 2) 00056920 ((OR (XN I U) (FLAGP L (QUOTE NOSPUR))) 00056930 (ADDF (MKG1 U L) (MKG1 (REVERSE U) L))) 00056935 ((EQ (CAR U) (QUOTE A)) 00056940 (COND ((EVENP U) (ADDF (MKG U L) 00056950 (MULTN -1 (MKG (CONS (QUOTE A) 00056952 (REVERSE (CDR U))) L)))) 00056954 (T (MULTF (MKA L) (SPR2 (CDR U) L 2 NIL))))) 00056960 ((EVENP U) (SPR2 U L 2 NIL)) 00056970 (T (SPR1 U L 2 NIL))))) 00056980 00056990 (SPR1 (LAMBDA (U L N B) 00057000 (COND ((NULL U) NIL) 00057010 ((NULL (CDR U)) (MULTN N (MKG1 U L))) 00057020 (T 00057030 (PROG (M X Z) 00057040 (SETQ X U) 00057050 (SETQ M 0) 00057060 A (COND ((NULL X) (RETURN Z))) 00057070 (SETQ Z 00057080 (ADDF (MULTF (MKG1 (LIST (CAR X)) L) 00057090 (COND 00057100 ((NULL B) 00057110 (SPURR (REMOVE U M) L NIL N)) 00057120 (T (SPR1 (REMOVE U M) L N NIL)))) 00057130 Z)) 00057140 (SETQ X (CDR X)) 00057150 (SETQ N (MINUS N)) 00057160 (SETQ M (ADD1 M)) 00057170 (GO A)))))) 00057180 00057190 (SPR2 (LAMBDA (U L N B) 00057200 (COND ((AND (NULL (CDDR U)) (NULL B)) 00057210 (MULTN N (MKDOT (CAR U) (CADR U)))) 00057220 (T 00057230 ((LAMBDA (X) (COND (B (ADDF (SPR1 U L N B) X)) (T X))) 00057240 (ADDF (SPURR U L NIL N) 00057250 (MULTF (MKA L) 00057255 (SPURR (APPEND U (LIST (QUOTE A))) L NIL N)))))))) 00057260 00057270 (EVENP (LAMBDA (U) 00057410 (OR (NULL U) (NOT (EVENP (CDR U)))))) 00057420 00057430 (BASSOC (LAMBDA (U V) 00057440 (COND ((NULL V) NIL) 00057450 ((OR (EQ U (CAAR V)) (EQ U (CDAR V))) (CAR V)) 00057460 (T (BASSOC U (CDR V)))))) 00057470 00057480 (MEMLIS (LAMBDA (U V) 00057490 (COND ((NULL V) NIL) 00057500 ((MEMBER U (CAR V)) (CAR V)) 00057510 (T (MEMLIS U (CDR V)))))) 00057520 00057530 )) 00057540 00057550 DEFINE (( 00057560 00057570 (SPURR (LAMBDA (U L V N) 00057580 (PROG (M W X Y Z) 00057590 A (COND ((NULL U) (GO B)) ((MEMBER (CAR U) (CDR U)) (GO G))) 00057600 (SETQ V (CONS (CAR U) V)) 00057610 (SETQ U (CDR U)) 00057620 (GO A) 00057630 B (COND ((NULL V) (RETURN N)) 00057640 ((FLAGP L (QUOTE NOSPUR)) 00057650 (RETURN (MULTN N (MKG* V L)))) 00057660 (T (RETURN (SPRGEN V N)))) 00057670 G (SETQ X (CAR U)) 00057680 (SETQ Y (CDR U)) 00057690 (SETQ W Y) 00057700 (SETQ M 0) 00057710 H (COND 00057720 ((EQ X (CAR W)) 00057730 (RETURN 00057740 (ADDF (MULTF (MKDOT X X) (SPURR (DELETE X Y) L V N)) 00057750 Z)))) 00057760 (SETQ Z 00057770 (ADDF (MULTF (MKDOT X (CAR W)) 00057780 (SPURR (REMOVE Y M) L V (TIMES 2 N))) 00057790 Z)) 00057800 (SETQ W (CDR W)) 00057810 (SETQ N (MINUS N)) 00057820 (SETQ M (ADD1 M)) 00057830 (GO H)))) 00057840 00057850 (SPRGEN (LAMBDA (V N) 00057860 (PROG (X Z) 00057870 (COND 00057880 ((NOT (EQ (CAR V) (QUOTE A))) (RETURN (SPRGEN1 V N))) 00057890 ((NULL (SETQ X (COMB1 (SETQ V (CDR V)) 4 NIL))) 00057900 (RETURN NIL)) 00057910 ((NULL (CDR X)) (GO E))) 00057920 C (COND ((NULL X) (RETURN (MULTF2 (MKSP (QUOTE I) 1) Z)))) 00057930 (SETQ Z 00057940 (ADDF (MULTN (ASIGN (CAR X) V N) 00057950 (MULTF (MKEPS1 (CAR X)) 00057960 (SPRGEN1 (SETDIFF V (CAR X)) 1))) 00057970 Z)) 00057980 D (SETQ X (CDR X)) 00057990 (GO C) 00058000 E (SETQ Z (MULTN N (MKEPS1 (CAR X)))) 00058010 (GO D)))) 00058020 00058030 (ASIGN (LAMBDA (U V N) 00058031 (COND ((NULL U) N) 00058032 (T (ASIGN (CDR U) V (TIMES (ASIGN1 (CAR U) V -1) N)))))) 00058033 00058034 (ASIGN1 (LAMBDA (U V N) 00058035 (COND ((NULL V) (ERROR (QUOTE ARG))) 00058036 ((EQ U (CAR V)) N) 00058037 (T (ASIGN1 U (CDR V) (MINUS N)))))) 00058038 00058039 (SPRGEN1 (LAMBDA (U N) 00058040 (COND ((NULL U) NIL) 00058050 ((NULL (CDDR U)) (MULTN N (MKDOT (CAR U) (CADR U)))) 00058060 (T 00058070 (PROG (W X Y Z) 00058080 (SETQ X (CAR U)) 00058090 (SETQ U (CDR U)) 00058100 (SETQ Y U) 00058110 A (COND ((NULL U) (RETURN Z)) 00058120 ((NULL (SETQ W (MKDOT X (CAR U)))) (GO B))) 00058130 (SETQ Z 00058140 (ADDF (MULTF W (SPRGEN1 (DELETE (CAR U) Y) N)) 00058150 Z)) 00058160 B (SETQ N (MINUS N)) 00058170 (SETQ U (CDR U)) 00058180 (GO A)))))) 00058190 00058200 (COMB1 (LAMBDA (U N V) 00058210 ((LAMBDA(M) 00058220 (COND ((ONEP N) 00058230 (APPEND V (MAPCAR U (FUNCTION (LAMBDA (J) (LIST J)))))) 00058240 ((MINUSP M) NIL) 00058250 ((ZEROP M) (CONS U V)) 00058260 (T 00058270 (COMB1 (CDR U) 00058280 N 00058290 (APPEND V 00058300 (MAPCONS (COMB1 (CDR U) (SUB1 N) NIL) 00058310 (CAR U))))))) 00058320 (DIFFERENCE (LENGTH U) N)))) 00058330 00058340 )) 00058350 00058360 DEFINE (( 00058370 00058380 (SIMPEPS (LAMBDA (U) 00058390 (MKVARG U 00058400 (FUNCTION 00058410 (LAMBDA(J) 00058420 (CONS (COND ((REPEATS J) NIL) (T (MKEPS1 J))) 1)))))) 00058430 00058440 (MKEPS1 (LAMBDA (U) 00058450 ((LAMBDA(X) 00058460 (MULTN (NB (PERMP X U)) (MKSF (CONS (QUOTE EPS) X) 1))) 00058470 (ORDN U)))) 00058480 00058490 (PERMP (LAMBDA (U V) 00058500 (COND ((NULL U) T) 00058510 ((EQ (CAR U) (CAR V)) (PERMP (CDR U) (CDR V))) 00058520 (T (NOT (PERMP (CDR U) (SUBST (CAR V) (CAR U) (CDR V)))))))) 00058530 00058540 )) 00058550 00058560 DEFINE (( 00058570 00058580 (ESUM (LAMBDA (U I V W XX) 00058590 (PROG (X Y Z) 00058600 (SETQ X (CAR U)) 00058610 (SETQ U (CDR U)) 00058620 (COND 00058630 ((NOT (ONEP (CDR X))) 00058640 (SETQ U 00058650 (MULTF (NMULTF (MKEPS1 (CDAR X)) (SUB1 (CDR X))) 00058660 U)))) 00058670 (SETQ X (CDAR X)) 00058680 A (COND ((REPEATS X) (RETURN NIL))) 00058690 B (COND ((NULL X) 00058700 (RETURN (ISIMP1 U I V (CONS (REVERSE Y) W) XX))) 00058710 ((NOT (MEMBER (CAR X) I)) (GO D)) 00058720 ((NOT (SETQ Z (BASSOC (CAR X) V))) (GO C))) 00058730 (SETQ V (DELETE Z V)) 00058740 (SETQ I (DELETE (CAR X) I)) 00058750 (SETQ X 00058760 (APPEND (REVERSE Y) (CONS (OTHER (CAR X) Z) (CDR X)))) 00058770 (SETQ Y NIL) 00058780 (GO A) 00058790 C (COND ((SETQ Z (MEMLIS (CAR X) W)) (GO C1)) 00058800 ((SETQ Z (MEMLIS (CAR X) XX)) 00058810 (RETURN 00058820 (SPUR0 (CONS (CONS (CONS (QUOTE G) Z) 1) U) 00058830 I 00058840 V 00058850 (CONS (APPEND (REVERSE Y) X) W) 00058860 (DELETE Z XX))))) 00058870 (RETURN (ISIMP1 U I V (CONS (APPEND (REVERSE Y) X) W) XX)) 00058880 C1 (SETQ X (APPEND (REVERSE Y) X)) 00058890 (SETQ Y (XN I (XN X Z))) 00058900 (RETURN 00058910 (ISIMP1 (MULTF (EMULT1 Z X Y) U) 00058920 (SETDIFF I Y) 00058930 V 00058940 (DELETE Z W) 00058950 XX)) 00058960 D (SETQ Y (CONS (CAR X) Y)) 00058970 (SETQ X (CDR X)) 00058980 (GO B)))) 00058990 00059000 (EMULT (LAMBDA (U) 00059010 (COND ((NULL (CDR U)) (MKEPS1 (CAR U) 1)) 00059020 ((NULL (CDDR U)) (EMULT1 (CAR U) (CADR U) NIL)) 00059030 (T (MULTF (EMULT1 (CAR U) (CADR U) NIL) (EMULT (CDDR U))))))) 00059040 00059050 (EMULT1 (LAMBDA (U V I) 00059060 ((LAMBDA(X *S*) 00059070 ((LAMBDA(M N) 00059080 (COND ((EQUAL M 4) (TIMES 6 (TIMES 4 N))) 00059090 ((EQUAL M 3) 00059100 (MULTN (TIMES 6 N) (MKDOT (CAR X) (CAR *S*)))) 00059110 (T 00059120 (MULTN (TIMES N (COND ((ZEROP M) 1) (T M))) 00059130 (CAR 00059140 (DETQ 00059150 (MAPLIST X 00059160 (FUNCTION 00059170 (LAMBDA(*S1*) 00059180 (MAPLIST *S* 00059190 (FUNCTION 00059200 (LAMBDA 00059210 (J) 00059220 (CONS 00059230 (MKDOT 00059240 (CAR *S1*) 00059250 (CAR J)) 00059260 1))))))))))))) 00059270 (LENGTH I) 00059280 ((LAMBDA (J) (NB(COND((PERMP U (APPEND I X)) (NOT J)) (T J)))) 00059290 (PERMP V (APPEND I *S*))))) 00059300 (SETDIFF U I) 00059310 (SETDIFF V I)))) 00059320 00059330 )) 00059340 00059350 DEFLIST (((NONCOM RLIS) (SPUR RLIS) (NOSPUR RLIS) (REDUCE RLIS)) STAT) 00059360 00059370 00059380 PTS (NOCMP* T) 00059381 DEFINE (( 00059390 00059400 (MKG* (LAMBDA (U L) 00059410 (COND ((NULL U) 1) 00059420 ((NOT (FLAGP L (QUOTE REDUCE))) (MKG1 U L)) 00059430 ((LESSP (LENGTH U) 3) (MKG1 U L)) 00059440 ((AND (EQCAR U (QUOTE A)) (EQUAL (LENGTH U) 3)) 00059450 ((LAMBDA(Y) 00059460 (PROG2 (SETQ INDICES* (APPEND Y INDICES*)) 00059470 (ADDF (MULTF (MKA L) (MKDOT (CADR U) (CADDR U))) 00059480 (MULTF2 (MKSP (QUOTE I) 1) 00059490 (MULTF (MKG1 Y L) 00059500 (MKEPS1 00059510 (APPEND (CDR U) Y))))))) 00059520 (LIST (GENSYM) (GENSYM)))) 00059530 (T (RED* U L))))) 00059540 00059550 (RED* (LAMBDA (U L) 00059560 (PROG (I X) 00059570 (SETQ X (ACONC (EXPLODE L) (QUOTE I))) 00059580 (SETQ I 00059590 (LIST (COMPRESS (APPEND X (QUOTE (1)))) 00059600 (COMPRESS (APPEND X (QUOTE (2)))))) 00059610 (SETQ X (LIST (QUOTE A) (CAR I))) 00059620 (RETURN 00059630 (ADDF (SPURR NIL (QUOTE ***) U 3) 00059640 (ADDF (MULTF (MKG (QUOTE (A)) L) 00059650 (ISIMP1 00059660 (GCHECK (QUOTE (A)) U (QUOTE ***)) 00059670 NIL 00059680 NIL 00059690 NIL 00059700 NIL)) 00059710 (ADDF 00059720 (ISIMP1* 00059730 (ISIMP1 (GCHECK (LIST (CAR I)) U (QUOTE ***)) 00059740 NIL 00059750 NIL 00059760 NIL 00059770 NIL) 00059780 (LIST (CAR I)) 00059790 (LIST (LIST L (CAR I)))) 00059800 (ADDF (MULTN -1 00059810 (ISIMP1* 00059820 (ISIMP1 00059830 (GCHECK 00059840 (REVERSE X) 00059850 U 00059860 (QUOTE ***)) 00059870 NIL 00059880 NIL 00059890 NIL 00059900 NIL) 00059910 (CDR X) 00059920 (LIST (CONS L X)))) 00059930 (MULTF (MKSQP (CONS -1 2)) 00059940 (ISIMP1* 00059950 (ISIMP1 00059960 (GCHECK 00059970 (REVERSE I) 00059980 U 00059990 (QUOTE ***)) 00060000 NIL 00060010 NIL 00060020 NIL 00060030 NIL) 00060040 I 00060050 (LIST (CONS L I)))))))))))) 00060060 00060070 (ISIMP1* (LAMBDA (U I V) 00060080 (COND ((NULL U) NIL) (T (ISIMP1 U I NIL NIL V))))) 00060090 00060100 )) 00060110 00060120 INIT NIL 00060130 00060140 CHKPOINT (REDUCE) 00060145 00060150 COMMENT ((E N D O F R E D U C E P R O G R A M)) 00060160 00060170 00060180