Trailing-Edge
-
PDP-10 Archives
-
decuslib20-02
-
decus/20-0039/celt6.l
There are 2 other files named celt6.l in the archive. Click here to see a list.
(DEFPROP VARLIST T SPECIAL)
(DEFPROP VARNUM T SPECIAL)
(DEFPROP GOODGUYS T SPECIAL)
(DEFPROP BADGUYS T SPECIAL)
(DEFPROP RS T SPECIAL)
(DEFPROP RS1 T SPECIAL)
(DEFPROP RS2 T SPECIAL)
(DEFPROP *TIME T SPECIAL)
(DEFPROP *S T SPECIAL)
(DEFPROP TCOEF T SPECIAL)
(DEFPROP CONSTCOEF T SPECIAL)
(DEFPROP SIMP T SPECIAL)
(DEFPROP CIRCFLAG T SPECIAL)
(DEFPROP EXPOP T SPECIAL)
(QUOTE (FILE LTX))
(DEFPROP LAPTR5
(LAMBDA (EXPR *TIME *S DEFLAG)
(PROG
(GOODGUYS BADGUYS
PARTSUM
WHOLESUM
HOLDPOP
CIRCFLAG
RS1
RS2
RS EXPOP)
(COND((INN *S EXPR)(ERLIST(APPEND(Q(LTX CONFUSED BY))(CONS *S(Q(IN THE PROBLEM))))))) (COND(DEFLAG(GO DE)))
(SETQ EXPR (HYPERSUB EXPR *TIME))
(SETQ HOLDPOP EXPOP)
(SETQ EXPOP 1000)
(SETQ EXPR(CLEANTALK(SIMPLIFYA EXPR NIL)))
(SETQ EXPR ( SUMSPLIT EXPR *TIME))
(COND (CIRCFLAG (SETQ EXPR(CLEANTALK
(SIMPLIFYA EXPR
NIL)))))
(SETQ VARLIST (NCONS *S))
(VARWHOMP EXPR *TIME)
DE (SETQ RS1 (REP (LIST (Q QUOTIENT) 1 *S)))
(SETQ RS2
(REP (LIST (Q QUOTIENT)
1
(LIST (Q EXPT) *S 2))))
(SETQ RS (REP *S))
(COND
((EQ (LEAD EXPR) (QUOTE PLUS))
(MAPC (FUNCTION (LAMBDA (J)
(MOLECULE J
*TIME
*S)))
(CDR EXPR)))
((MOLECULE EXPR *TIME *S)))
LOOP
(COND ((NULL GOODGUYS) (GO OUT)))
(SETQ PARTSUM
(PLUSF (CAR GOODGUYS) PARTSUM))
(SETQ GOODGUYS (CDR GOODGUYS))
(GO LOOP)
OUT (COND((AND DEFLAG BADGUYS)
(ERLIST(QUOTE(CANNOT HANDLE THE PROBLEM))))
(DEFLAG(RETURN PARTSUM)))
(COND
(PARTSUM
(SETQ PARTSUM
(SIMPSIMP (TRANS PARTSUM)))))
(SETQ
BADGUYS
(MAPCAR (FUNCTION (LAMBDA (J)
(LIST (Q LTX)
(SPT(REMDIF(SIMPSIMP(BIN(CLEAN J)))))
*TIME
*S)))
BADGUYS))
(SETQ WHOLESUM
(COND ((AND (NULL PARTSUM)
(NULL BADGUYS))
0)
((NULL BADGUYS) PARTSUM)
((NULL PARTSUM)
(CONS (Q PLUS) BADGUYS))
((CONS (Q PLUS)
(CONS PARTSUM
BADGUYS)))))
(SETQ EXPOP HOLDPOP)
(RETURN WHOLESUM)))
EXPR)
(DEFPROP VARWHOMP(LAMBDA(X TIME)(PROG2
(VARWHOMP1 X TIME)
(SETQ VARNUM(LENGTH VARLIST))
))EXPR)
(DEFPROP VLCUT(LAMBDA(X TIME)(COND
((NULL X)NIL)
((INN TIME(CAR X))
(VLCUT(CDR X)TIME))
((CONS(CAR X)(VLCUT(CDR X)TIME)))
))EXPR)
(DEFPROP VARWHOMP1(LAMBDA(X *TIME)(COND
((NULL X)NIL)
((NUMBERP X)NIL)
((EQ X *TIME)NIL)
((ATOM X)(SETQ VARLIST(PASTE X VARLIST)))
((EQ(CAR X)(QUOTE EXPT))(COND
((NUMBERP(CADDR X))(VARWHOMP1(CADR X)*TIME))
((INN *TIME(CADDR X))(VARWHOMP1(CADDR X)*TIME))
((SETQ VARLIST(PASTE X VARLIST)))
) )
((OPP(CAR X))(MAPC(FUNCTION(LAMBDA(J)(VARWHOMP1 J *TIME)))(CDR X)))
((OR(EQ(CAR X)(Q COS))(EQ(CAR X)(Q SIN)))(COND
((NOT(INN *TIME(CADR X)))(SETQ VARLIST(PASTE X VARLIST)))
((VARWHOMP1(CADR X)*TIME))
) )
((NOT(INN *TIME X))(SETQ VARLIST(PASTE X VARLIST)))
))EXPR)
(DEFPROP MOLECULE
(LAMBDA (X TIME S)
(COND ((NOT (LTXLEGAL X TIME))
(SETQ BADGUYS
(CONS X BADGUYS)))
((EQ X TIME)
(SETQ GOODGUYS
(CONS RS2 GOODGUYS)))
((OR (ATOM X)
(EQ (CAR X) (Q QUOTIENT))
(NOT (INN TIME X)))
(SETQ GOODGUYS
(CONS (TIMESF (REP(BIN X))
RS1)GOODGUYS)))
((OR (EQ (CAR X) (Q SIN))
(EQ (CAR X) (Q COS)))
(SETQ GOODGUYS
(CONS (MOLECULE2 1
X
TIME
S)
GOODGUYS)))
((EQ (CAR X) (QUOTE EXPT))
(MOLECULE1 (LIST 1 X)
TIME
S))
((MOLECULE1 (CDR X) TIME S))))
EXPR)
(DEFPROP MOLECULE2
(LAMBDA (RAT SIN TIME S)
(COND ((NULL SIN) (TIMESF (REP RAT) RS1))
((NOT (INN TIME SIN))
(TIMESF (REP RAT) (REP(BIN SIN))))
((MOLECULE3 RAT (CAR SIN)
(CAR (REPCOEF (CADR SIN)
TIME))))))
EXPR)
(DEFPROP CLEANTALK
(LAMBDA (X)
(COND ((ATOM X) X)
((TALKP X)(COND
((ONEP(CDR X))(CAR X))( (LIST (Q QUOTIENT)
(CAR X)
(CDR X)))))
((CONS (CLEANTALK (CAR X))
(CLEANTALK (CDR X))))))
EXPR)
(DEFPROP COEF
(LAMBDA (X TIME)
(PROG
(TCOEF CONSTCOEF)
(COEF1 X TIME)
(SETQ TCOEF(COND(TCOEF(BIN (DTP(CONS(Q PLUS)TCOEF))))))
(SETQ CONSTCOEF(COND(CONSTCOEF(BIN (DTP(CONS(Q PLUS)CONSTCOEF))))))
(RETURN (CONS TCOEF CONSTCOEF))))
EXPR)
(DEFPROP COEF1
(LAMBDA (X *TIME)
(COND
((NULL X) NIL)
((EQ X *TIME)
(SETQ TCOEF (COND (TCOEF TCOEF) ((QUOTE(1))))))
((ATOM X)(SETQ CONSTCOEF(CONS X CONSTCOEF)))
((EQ (CAR X) (QUOTE PLUS))
(MAPC (FUNCTION (LAMBDA (J)
(COEF1 J *TIME)))
(CDR X)))
((EQ (CAR X) (Q TIMES))
(COND ((MEMBER *TIME X)
(SETQ TCOEF
(CONS (WIPE *TIME X) TCOEF)))
((SETQ CONSTCOEF
(CONS X CONSTCOEF)))))
((SETQ CONSTCOEF(CONS X CONSTCOEF)))))
EXPR)
(DEFPROP REPCOEF(LAMBDA(X TIME)((LAMBDA(J)
(CONS(COND((CAR J)(REP(CAR J))))
(COND((CDR J)(REP(CDR J))))
) )(COEF X TIME)
))EXPR)
(DEFPROP DTP
(LAMBDA (X) (COND ((ATOM X) X)
((AND (OR (EQ (CAR X)
(Q PLUS))
(EQ (CAR X)
(Q TIMES)))
(NULL (CDDR X)))
(DTP(CADR X)))
((CONS (DTP (CAR X))
(DTP (CDR X))))))
EXPR)
(DEFPROP MOLECULE3
(LAMBDA (RAT SIN A )
(COND ((EQ SIN (Q SIN))
(TIMESF(REP RAT)(QUOTIENTF A(PLUSF(EXPTF RS 2)(EXPTF A 2)))))
((TIMESF(REP RAT)(QUOTIENTF RS(PLUSF(EXPTF RS 2)(EXPTF A 2))))))) EXPR)
(DEFPROP MOLECULE1
(LAMBDA (X TIME S)
(PROG
(REST ANS RAT)
(SETQ RAT (CAR X))
LOOP1
(SETQ X (CDR X))
(COND ((NULL X) (GO ON))
((AND (OR (EQ (CAAR X) (Q SIN))
(EQ (CAAR X) (Q COS)))
(INN TIME (CDAR X)))
(GO SIN)))
(SETQ REST (CONS (CAR X) REST))
(GO LOOP1)
SIN(SETQ ANS (MOLECULE2 RAT (CAR X) TIME S))
(SETQ REST (NCONC REST (CDR X)))
(GO FURTHER)
ON (SETQ ANS (MOLECULE2 RAT NIL TIME S))
FURTHER
(COND
((NULL REST)
(RETURN(SETQ GOODGUYS(CONS ANS GOODGUYS))))
((EQ (CAR REST) TIME)
(SETQ ANS (MINUSF (RATDIFF ANS))))
((ATOM (CAR REST))
(SETQ ANS
(TIMESF (REP (CAR REST)) ANS)))
((NOT (INN TIME (CAR REST)))
(SETQ ANS
(TIMESF (REP(BIN(CAR REST))) ANS)))
((EQ (CADAR REST) TIME)
(SETQ ANS (RATDIFFN ANS (CADDAR REST))))
((SETQ ANS
(TRANSF ANS
(CAR (REPCOEF (CADDAR REST)
TIME))))))
(SETQ REST (CDR REST))
(GO FURTHER)))
EXPR)
(DEFPROP RATDIFFN
(LAMBDA (X N)
(COND
((ONEP N) (MINUSF (RATDIFF X)))
((MINUSF (RATDIFF (RATDIFFN X
(SUB1 N)))))))
EXPR)
(DEFPROP TRANSF
(LAMBDA (X A)
(COND ((POLP X) (TRANSF1 X A))
((QUOTIENTF (TRANSF1 (CAR X)
A)
(TRANSF1 (CDR X)
A)))))
EXPR)
(DEFPROP TRANSF1
(LAMBDA (X A)
(COND
((NULL X)NIL)
((PLUSF (TIMESF
(UPVAR(CAR X))
(EXPTF (DIFFERENCEF RS A)
(SUB1 (LENGTH X))))
(TRANSF1 (CDR X) A)))))
EXPR)
(DEFPROP UPVAR(LAMBDA(X)(COND
((ZEROPF X)NIL)
(T(NCONS X))
))EXPR)
(DEFPROP RATDIFF
(LAMBDA (X)
(QUOTIENTF (POLDIFFERENCE (POLTIMES (DENOMINATORF X)
(POLDERIVATIVE (NUMERATORF X)))
(POLTIMES (NUMERATORF X)
(POLDERIVATIVE (DENOMINATORF X))))
(POLTIMES (DENOMINATORF X) (DENOMINATORF X))))
EXPR)
(DEFPROP LTX
(LAMBDA (X Y)
(PROG
NIL
(COND
((NOT(EQ(LENGTH X)3))
(ERLIST
(QUOTE (LTX TAKES
THREE
ARGUMENTS)))))
(SETQ X (LIST (UNQUOTE (CAR X))
(UNQUOTE (CADR X))
(UNQUOTE(CADDR X))))
(COND
((OR(NOT (LATOM (CADR X)))
(NOT(LATOM(CADDR X))))
(ERLIST (QUOTE (SECOND AND THIRD
ARGUMENTS OF LTX MUST BE ATOMS))))
((OR (EQ (LEAD(CAR X)) (QUOTE EQUAL))
(EQ (LEAD(CAR X)) (QUOTE LAMBDA)))
(ERLIST (QUOTE (CANNOT APPLY LTX TO
EQUATIONS
OR
FUNCTIONS)))))
(SETQ X (MAPCAR (FUNCTION BIN) X))
(SETQ X (LAPTR5 (CAR X)(CADR X)(CADDR X)NIL))
(RETURN (COND (SIMP X) (T (CLEANR X))))))
FEXPR)
(DEFPROP LTX LTX INTCOM)
(DEFPROP LTX T SACRED)
(DEFPROP HYPERSUB(LAMBDA(X TIME)(COND
((ATOM X)X)
((NOT(OR(INN(Q SINH)X)(INN(Q COSH)X)))X)
((NOT(INN TIME X))X)
((EQ(CAR X)(Q SINH))(LIST(Q TIMES)(Q(QUOTIENT 1 2))
(LIST(Q DIFFERENCE)
(LIST(Q EXPT)(Q E)(CADR X))
(LIST(Q EXPT)(Q E)(LIST(Q MINUS)(CADR X))))))
((EQ(CAR X)(Q COSH))(LIST(Q TIMES)(Q(QUOTIENT 1 2))
(LIST(Q PLUS)
(LIST(Q EXPT)(Q E)(CADR X))
(LIST(Q EXPT)(Q E)(LIST(Q MINUS)(CADR X))))))
((CONS(HYPERSUB(CAR X)TIME)(HYPERSUB(CDR X)TIME)))
))EXPR)
(DEFPROP LINEARP(LAMBDA(EXPR *TIME)(COND
((ATOM EXPR)T)
((NOT(INN *TIME EXPR))T)
((OR(EQ(CAR EXPR)(Q PLUS))(EQ(CAR EXPR)(Q TIMES)))
(EVAL(CONS(Q AND)(MAPCAR
(FUNCTION(LAMBDA(J)(LINEARP J *TIME)))
(CDR EXPR)))))
))EXPR)
(DEFPROP SUMSPLIT(LAMBDA(X *TIME)(COND
((ATOM X)X)
((OR(EQ(CAR X)(Q PLUS))(EQ(CAR X)(Q TIMES)))
(CONS(CAR X)(MAPCAR
(FUNCTION(LAMBDA(J)(SUMSPLIT J *TIME)))
(CDR X))))
((AND(EQ(CAR X)(QUOTE SIN))(LINEARP(CADR X)*TIME))
(SINSPLIT(CADR X)*TIME))
((AND(EQ(CAR X)(QUOTE COS))(LINEARP(CADR X)*TIME))
(COSSPLIT(CADR X)*TIME))
(X)
))EXPR)
(DEFPROP SINSPLIT(LAMBDA(X TIME)((LAMBDA(J)((LAMBDA(A B)(COND
((NULL A)(LIST(Q SIN)X))
((NULL B)(LIST(Q SIN)X))
((SETQ CIRCFLAG T)
(LIST(Q PLUS)
(LIST(Q TIMES)(LIST(Q COS)B)
(LIST(Q SIN)(LIST(Q TIMES)A TIME)))
(LIST(Q TIMES)(LIST(Q SIN)B)
(LIST(Q COS)(LIST(Q TIMES)A TIME)))))))
(CAR J)(CDR J)))(COEF X TIME)))EXPR)
(DEFPROP COSSPLIT(LAMBDA(X TIME)((LAMBDA(J)((LAMBDA(A B)(COND
((NULL A)(LIST(Q COS)X))
((NULL B)(LIST(Q COS)X))
((SETQ CIRCFLAG T)
(LIST(Q DIFFERENCE)
(LIST(Q TIMES)(LIST(Q COS)B)
(LIST(Q COS)(LIST(Q TIMES)A TIME)))
(LIST(Q TIMES)(LIST(Q SIN)B)
(LIST(Q SIN)(LIST(Q TIMES)A TIME)))))))
(CAR J)(CDR J)))(COEF X TIME)))EXPR)
(DEFPROP LTXLEGAL(LAMBDA(X TIME)(COND
((ATOM X)T)
((NOT(INN TIME X))T)
((EQ(CAR X)(QUOTE EXPT))(COND
((EQ(CADR X)TIME)
(AND(NUMBERP(CADDR X))(NOT(MINUSP(CADDR X)))))
((EQ(CADR X)(QUOTE E))
(AND(LINEARP(CADDR X)TIME)
(NULL(CDR(COEF(CADDR X)TIME)))))
))
((OR(EQ(CAR X)(Q SIN))(EQ(CAR X)(Q COS)))
(LINEARP(CADR X)TIME))
((EQ(CAR X)(Q TIMES))(LTXTIMESLEGAL(CDR X)TIME NIL))
))EXPR)
(DEFPROP LTXTIMESLEGAL(LAMBDA(X TIME SINFLAG)(COND
((NULL X)T)
((OR(EQ(LEAD(CAR X))(Q SIN))(EQ(LEAD(CAR X))(Q COS)))
(COND((NOT(INN TIME(CAR X)))
(LTXTIMESLEGAL(CDR X)TIME SINFLAG))
((AND(LTXLEGAL(CAR X)TIME)
(NOT SINFLAG))
(LTXTIMESLEGAL(CDR X)TIME T))))
((LTXLEGAL(CAR X)TIME)
(LTXTIMESLEGAL(CDR X)TIME SINFLAG))
))EXPR)