00000010
OPEN (COMPILE SYSFILE INPUT) RESTORE (COMPILE)
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 (UM 1-JUNE-73)$
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
(DEFEXPR (LAMBDA (U)
(DEF1 U (QUOTE FEXPR))))
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 V (GET U (QUOTE SPECIAL)))
(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 V (EQ (CAR U) (QUOTE SETQ))
(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 (TRANS (CAR U) V)
(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 $$$?$)
(**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
(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
(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
(REMPROP (QUOTE INIT) (QUOTE EXPR)) 00002200
(RETURN (QUOTE ***))))) 00002210
00002220
) EXPR) 00002230
00002240
(LAMBDA (U) (COMPILE (DEFLIST U (QUOTE EXPR)))) (( 00002250
00002260
(PRINTTY (LAMBDA (U) 00002282
(AND *NAT (PRINT U)))) 00002283
00002290
(READCH* (LAMBDA NIL 00002300
(SETQ CRCHAR* (READCH NIL)))) 00002310
00002320
)) 00002330
DEFINE ((
(MKSTRING (LAMBDA (U)
(LIST (QUOTE QUOTE) (COMPRESS (DELETE **SMARK (CDR U))))))
))
COMMENT ((FUNCTIONS FOR MTS IMPLEMENTATION ONLY))
DEFLIST (((PAUSE NORLIS) (CONT NORLIS)) STAT)
DEFINE ((
(PAUSE (LAMBDA NIL
(PROG (Y Z)
(COND ((BATCH) (RETURN NIL)))
(PRINM (QUOTE ($$$CONT?$)))
(COND ((YORN) (RETURN NIL)))
(COND ((AND IFL* (NOT (EQ IFL* (CAR IPL*))))
(SETQ IPL* (CONS IFL* IPL*))))
(SETQ IFL* NIL)
(SETQ Y *INT)
(SETQ *INT T)
(SETQ Z *ECHO)
(SETQ *ECHO NIL)
(RDS (OPEN (QUOTE GUSER) (QUOTE INPUT)))
(BEGIN1 T)
(SETQ *INT Y)
(SETQ *ECHO Z)
)))
(REDMSG1 (LAMBDA (U V)
(PROG NIL
(PRINM (LIST (QUOTE SHOULD) U (QUOTE BE)
(QUOTE DECLARED) V (QUOTE $$$?$)))
(RETURN (YORN)) )))
(PRINM (LAMBDA (U)
(PROG (V)
(WRS (OPEN (QUOTE SERCOM) (QUOTE OUTPUT)))
(SETQ V U)
A (PRINC (CAR V))
(PRINC **BLANK)
(COND ((SETQ V (CDR V)) (GO A)))
(TERPRI)
(WRS OFL*) )))
(READM (LAMBDA NIL
(PROG (U)
(CLOSE (QUOTE GUSER))
(RDS (OPEN (QUOTE GUSER) (QUOTE INPUT)))
(SETQ U (READ))
(RDS IFL*)
(RETURN U) )))
(YORN (LAMBDA NIL
(PROG (U)
A (SETQ U (READM))
(COND ((EQ U (QUOTE Y)) (RETURN T))
((EQ U (QUOTE N)) (RETURN NIL)))
(PRINM (QUOTE (ILLEGAL $$$RESPONSE.$ ENTER Y OR N)))
(GO A) )))
))
00002340
(LAMBDA (U) (COMPILE (DEFLIST U (QUOTE EXPR)))) (( 00002390
00002400
(BEGIN (LAMBDA NIL (PROG NIL 00002410
(OVOFF) 00002420
(SETQ NOCMP* T) 00002430
(SETQ *INT (NULL (BATCH)))
(SETQ *ECHO (BATCH))
(*WRS NIL)
(SETQ ORIG* 0) 00002460
(SETP) 00002470
(SETQ *MODE (QUOTE ALGEBRAIC)) 00002480
(COND ((NULL DATE*) (GO A0))) 00002490
(VERBOS NIL) 00002500
(EXCISE T) 00002510
(EXITERR (BATCH))
(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 NIL)))))
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
(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 (OPEN U NIL V) U)))
00002960
(*RDS (LAMBDA (U) (COND 00002970
((NULL U) (RDS (QUOTE LISPIN))) 00002980
(T (RDS U))))) 00002990
00003000
(*WRS (LAMBDA (U)
(PROG NIL
(WRS (QUOTE LISPOUT))
(COND (U (PROG2 (ASA NIL) (WRS U))))
(OTLL (OTLLNG))
(PTS (QUOTE LLENGTH*) (DIFFERENCE (OTLLNG) 7)))))
)) 00003040
00003050
LOSE ((ASSOC* REMK*))
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
(COND ((NOT (ATOMLIS U)) (REDERR (QUOTE (ILLEGAL FILE NAME)))))
(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
F (BEGIN1 T)
(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
(SETQ *INT (NOT (BATCH)))
(SETQ *ECHO (BATCH))
(GO F)
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
($$$&$ NIL AND NIL)
($$$|$ NIL OR NIL)
($$$~$ $$$=$ NOT UNEQ)
)) 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
(SETQ POSN* 0)
(COND ((NULL FORTVAR*) (GO A)))
(SPACES 6) 00011900
(SETQ POSN* 6)
(PRINC* FORTVAR*)
(OPRIN (QUOTE EQUAL)) 00011920
(PRINC* FORTVAR*)
(SETQ COUNT* 1) 00011940
(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
((EQ CRCHAR* **EOF) (GO EOF))
((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 ((OR ECHO* *NAT) (SYMPRI CURSYM*)))
(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*)))
(GO D1)
EOF (SETQ CURSYM* (QUOTE END))
(SETQ CRCHAR* **SEMICOL)
(GO D) )))
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 (AND (NOT (EQ *MODE (QUOTE SYMBOLIC)))
(OR PRI* (EQ U (QUOTE TOP)) (EQ U (QUOTE PRI)))))
(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 (OR PRI* (EQ SEMIC* **SEMICOL)))
(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
(REMFLAG (LIST NAME) (QUOTE FNC))
(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 (QUOTE PRI)))))
(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 Z)
(SETQ X ECHO*)
(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 ((EQ CRCHAR* **EOF) (GO RET))
((NULL U) (GO L1))
((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 ((NULL X) (GO L3)))
(COND ((NULL U) (PRINC* CRCHAR*))
((BREAKP CRCHAR*) (GO L2))
(T (PROG2 (RLIT CRCHAR*) (SETQ Z T))))
L3
(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
L2 (COND (Z (PRINC* (MKATOM))))
(SETQ Z NIL)
(PRINC* CRCHAR*)
(COND ((NOT (EQ CRCHAR* **BLANK)) (GO L3))
((EQ U (QUOTE END)) (SETQ Y NIL)))
L4 (COND ((EQ (READCH*) **BLANK) (GO L4)))
(GO LOOP)
RET (COND ((AND X Z) (PROG2 (PRINC* (MKATOM)) (SETQ Z NIL))))
(SCAN)
RET1 (COND ((AND X Z) (PRINC* (MKATOM))))
(RETURN (COND (X (TERPRI*)) (T NIL)))
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) T) NIL)))
(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))))) (PROG2 (ERRPRI2 X) (ERROR*))))
(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 (U)
(PROG (RESULT) 00021690
(SETQ CURSYM* NIL) 00021700
A (TERPRI) 00021710
(COND ((AND TMODE* (SETQ *MODE TMODE*)) (SETQ TMODE* NIL))) 00021720
(SETQ ECHO* (AND *ECHO (NOT (AND OFL* (OR *FORT (NULL *NAT))))))
(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
((EQ (CAR PROGRAM*) (QUOTE CONT)) (GO C))
(DIAG* (GO D))) 00021850
B (TERPRI*)
(SETQ ECHO* (QUOTE RESULT)) 00021860
(SETP) 00021870
(OVON) 00021871
(SETQ RESULT 00021880
(ERRORSET (CONVRT (GTS (QUOTE PROGRAM*)) T) T))
(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 (OR *INT OFL* *FORT)) (PRINTTY **STAR)))
(GO A) 00021970
C (COND ((NOT U) (GO A)))
(COND (IFL* (GO ND1)))
(SETQ IFL* (COND (IPL* (CAR IPL*)) (T NIL)))
(RDS IFL*)
(TERPRI*)
(RETURN NIL)
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 U))
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
(SETP)
ERR3 (COND 00022050
((NULL ERFG*) 00022060
(LPRIE (QUOTE (COMMAND TERMINATED *****)) T)))
(SETQ ORIG* 0) 00022080
(TERPRI*) 00022090
(COND (IFL* (PAUSE)))
(GO A)))) 00022110
00022120
(FINF (LAMBDA (U)
(PROG NIL 00022140
(COND (U (GO A)))
(MAPCAR (APPEND IPL* OPL*) (FUNCTION CLOSE)) 00022160
(SETQ IFL* NIL)
(SETQ IPL* NIL) 00022170
(SETQ OPL* NIL) 00022180
(SETQ OFL* NIL) 00022190
(LPRIW NIL T **ENDMSG) 00022200
(RETURN (QUOTE ***)) 00022210
A (COND ((NOT IFL*) (RETURN NIL)))
(SHUT (LIST IFL*))
(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
(MTS NORLIS)
(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
THE COMPUTING CENTER
*****)) 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
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 Q)
A0 (COND ((NULL V1) (RETURN Z))) 00032160
(SETQ V (CAR V1)) 00032170
(SETQ W (CAR V)) 00032180
A (SETQ Q (CAR W))
(COND ((NULL W) (GO D))
((AND (EQUAL U (CAR W)) (SETQ Y (LIST NIL))) (GO B)) 00032200
((NOT (ATOM (CAR U))) (GO A3))
((NOT (ATOM (CAAR W))) (GO D)) 00032220
((OR FRLIS* (ORDP (CAR U) (CAAR W))) (GO A2)) 00032230
(T (GO E))) 00032231
A3 (COND ((NOT (ATOM (CAAR W))) (GO A1))
((AND (MEMBER (CDAR W) FRLIS*)
(EQ (CAAR U) (QUOTE EXPT))
(SETQ W (CONS (CONS (LIST (QUOTE EXPT) (CAAR W)
(CDAR W)) 1) (CDR W))))
(GO A1))
((MEMBER (CAAR W) FRLIS*) (GO A2))
(T (GO D)))
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 Q (CAR V)))
(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
(RMSUBS)
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
((ATOM P) (MKFR (TIMES P (CADDR Q)) (CADR Q)))
((ATOM Q) (MKFR (CADR P) (TIMES Q (CADDR P))))
(T (MKFR (TIMES (CADR P) (CADDR Q))
(TIMES (CADR Q) (CADDR P)))) ))
(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 (NOT (EQUAL X (CAR U)))) (GO B))
((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 (COND ((NULL (OR W (EQ POSN* 0))) (PROG2 (SETQ POSN* 0)
(TERPRI))))
(COND ((EQ POSN* 0) (SETQ COUNT* 1)))
(SETQ FORTVAR* NIL)
(COND ((OR W (ATOM V) (NOT (EQ POSN* 0))) (GO A)))
(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
(SETQ POSN* 6)
(PRINC* FORTVAR*)
(OPRIN (QUOTE EQUAL)) 00037280
(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
(SETQ ERFG* T)
(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
(REMPROP X (QUOTE ARRAY))
(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
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
(PROG2 (LET1 U (MK*SQ (CONS (CDR (SIMP *ANS)) 1)))
(SETQ MCOND* (SETQ FRASC* NIL)))))
00043870
(NUMER* (LAMBDA (U)
(LET1 U (MK*SQ (CONS (CAR (SIMP *ANS)) 1))))) 00043890
00043900
(ND (LAMBDA (U V) 00043910
(PROG2 (NUMER* U) (DENOM V))))
(NUMER (LAMBDA (U)
(PROG2 (NUMER* U) (SETQ MCOND* (SETQ FRASC* NIL)))))
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
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 (FLAGP L (QUOTE NOSPUR)))
(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
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
00060150
COMMENT ((E N D O F R E D U C E P R O G R A M)) 00060160
00060170
00060180