Trailing-Edge
-
PDP-10 Archives
-
decus_20tap2_198111
-
decus/20-0039/ilt2.l
There are 2 other files named ilt2.l in the archive. Click here to see a list.
(DEFPROP VARLIST T SPECIAL)
(DEFPROP SIMP T SPECIAL)
(DEFPROP ROOTFACTOR T SPECIAL)
(DEFPROP PARDENOM T SPECIAL)
(DEFPROP PARNUMER T SPECIAL)
(DEFPROP LOGPTDX T SPECIAL)
(DEFPROP SWITCH1 T SPECIAL)
(DEFPROP SIGNMEMORY T SPECIAL)
(DEFPROP WHOLEPART T SPECIAL)
(DEFPROP KLTH T SPECIAL)
(DEFPROP THEBPG T SPECIAL)
(DEFPROP AROOTF T SPECIAL)
(DEFPROP KX T SPECIAL)
(DEFPROP RNK T SPECIAL)
(DEFPROP TIME T SPECIAL)
(DEFPROP POW T SPECIAL)
(DEFPROP FLIST T SPECIAL)
(DEFPROP REPSWITCH T SPECIAL)
(QUOTE (FILE ILTX))
(DEFPROP ILTXD
(LAMBDA (RATARG)
(PROG (KLTH RNK)
(COND ((NULL RATARG) (RETURN NIL)))
(COND
((NOT (LESSP (LENGTH (NUMERATORF RATARG))
(LENGTH (DENOMINATORF RATARG))))
(PRINLIST(QUOTE(ILTX OF IMPROPER FRACTION)))
(CHARYBDIS (SIMPSIMP (LQUOTIENT (TRANS (NUMERATORF RATARG))
(TRANS (DENOMINATORF RATARG))))1 (LINELENGTH NIL))
(ERR) ))
(SETQ RNK (RANK RATARG))
(APROG (DENOMINATORF RATARG))
(CPROG (NUMERATORF RATARG) (DENOMINATORF RATARG))
(SETQ ROOTFACTOR (REVERSE ROOTFACTOR))
(SETQ PARNUMER (REVERSE PARNUMER))
(SETQ KLTH (LENGTH ROOTFACTOR))
(RETURN (ILTXD1))))
EXPR)
(DEFPROP ILTXD1
(LAMBDA NIL
(PROG ( AROOTF DERIV THEBPG)
(COND ((ONEP KLTH)
(RETURN (PROG2 (SETQ LOGPTDX
(CONS (QUOTIENTF (CAR PARNUMER)
(CAR ROOTFACTOR))
LOGPTDX))
NIL))))
(SETQ AROOTF (CAR ROOTFACTOR))
(COND ((NULL (CDR AROOTF)) (RETURN (RESET))))
(SETQ DERIV (POLDERIVATIVE AROOTF))
(SETQ THEBPG (BPROG AROOTF DERIV))
(ILTXD2 (CAR PARNUMER)(SUB1 KLTH))
(RETURN (RESET)) ))
EXPR)
(DEFPROP ILTXD2
(LAMBDA (X KX)
(PROG (PROD1 PROD2 THEBOT THETOP THETOPT)
(COND ((NULL (PUREPART X)) (RETURN NIL)))
(SETQ PROD1 (TIMESF (PUREPART X) (CAR THEBPG)))
(SETQ PROD2 (TIMESF (PUREPART X) (CDR THEBPG)))
(SETQ THEBOT (POLEXPT AROOTF KX))
(SETQ THETOP (PLUSF PROD1 (QUOTIENTF (PFDERIVATIVE PROD2)
(FORMCONST KX RNK))))
(SETQ THETOPT (QUOTIENTF PROD2 (FORMCONST KX RNK)))
(SETQ THETOP (PFREMAINDER THETOP THEBOT))
(SETQ THETOPT (PFREMAINDER THETOPT THEBOT))
(COND ((ONEP KX) (GO LOGSET)))
(SETQ KX (SUB1 KX))
(ILTXD2 (COND ((PUREP X) THETOP) (T (CONS (CAR X) THETOP)))KX)
(RETURN (ILTXD2 (ADD1TPOW (COND ((PUREP X) THETOPT)
(T (CONS (CAR X) THETOPT))))KX))
LOGSET
(SETQ LOGPTDX
(CONS (COND ((PUREP X) (QUOTIENTF THETOP THEBOT))
(T (CONS (CAR X) (QUOTIENTF THETOP THEBOT))))
(CONS (ADD1TPOW (COND ((PUREP X)
(QUOTIENTF THETOPT THEBOT))
(T (CONS (CAR X)
(QUOTIENTF THETOPT
THEBOT)))))
LOGPTDX)))
))
EXPR)
(DEFPROP RESET
(LAMBDA NIL (PROG NIL
(SETQ ROOTFACTOR (CDR ROOTFACTOR))
(SETQ PARNUMER (CDR PARNUMER))
(SETQ KLTH (SUB1 KLTH))
(RETURN (ILTXD1))))
EXPR)
(DEFPROP PUREP
(LAMBDA (X)
(OR (ATOM X) (ATOM (CAR X)) (NOT (EQ (CAAR X) (QUOTE TPOW)))))
EXPR)
(DEFPROP PUREPART (LAMBDA (X) (COND ((PUREP X) X) (T (CDR X)))) EXPR)
(DEFPROP ADD1TPOW
(LAMBDA (X) (COND ((PUREP X) (CONS (CONS (QUOTE TPOW) 1) X))
(T(CONS(CONS(CAAR X)(ADD1(CDAR X)))(CDR X)))
))
EXPR)
(DEFPROP ILTXE
(LAMBDA (P)
(PROG (RNK NUM DENOM LISTFACTOR ANSLIST POW DESCRIM SQRTDES SIGN SUPSWITCH)
(COND ((NOT (PUREP P)) (PROG2 (SETQ POW (CDAR P)) (SETQ P (CDR P)))))
(COND ((OR (NULL P) (NULL (CAR P))) (RETURN 0)))
(SETQ RNK (SUB1 (RANK P)))
(SETQ NUM (NUMERATORF P))
(SETQ DENOM (DENOMINATORF P))
(COND (SWITCH1 (GO POSTFACTOR)))
(SETQ LISTFACTOR (INTFACTOR DENOM))
(COND ((NOT (NULL (CDR LISTFACTOR))) (GO MANYFACTOR)))
POSTFACTOR
(COND ((EQUAL (LENGTH DENOM) 2) (GO LINEAR))
((EQUAL (LENGTH DENOM) 3) (GO QUADRATIC)))
(RETURN (FIXPOW (LIST (QUOTE ILTX)
(LQUOTIENT(SIMPSIMP (TRANS NUM))
(SIMPSIMP (TRANS DENOM)))
(CAR(LAST VARLIST)) TIME)))
LINEAR
(RETURN (FIXPOW (LTIMES (TRANS (QUOTIENTF (CAR NUM) (CAR DENOM)))
(SEXPTE (TRANS (QUOTIENTF (CADR DENOM)
(CAR DENOM)))))))
QUADRATIC
(COND
((NOT (ZEROPF (CADR DENOM)))
(RETURN
(FIXPOW
(LTIMES
(SEXPTE (TRANS (QUOTIENTF (CADR DENOM)
(TIMESF (FORMCONST 2 RNK) (CAR DENOM)))))
(ILTXE
(QUOTIENTF
(COND
((NULL (CDR NUM)) NUM)
(T (UNMONIC (LIST (CAR NUM)
(DIFFERENCEF
(CADR NUM)
(QUOTIENTF (TIMESF (CAR NUM)
(CADR DENOM))
(TIMESF (FORMCONST 2 RNK)
(CAR DENOM))))))))
(UNMONIC
(LIST (CAR DENOM)
(FORMCONST 0 RNK)
(DIFFERENCEF (CADDR DENOM)
(QUOTIENTF (EXPTF (CADR DENOM) 2)
(TIMESF (FORMCONST 4 RNK)
(CAR DENOM)))))))))))))
(COND ((NULL (CDR NUM)) (GO BY)))
(COND((NOT(ZEROPF(CADR NUM))) (RETURN (FIXPOW (LPLUS (ILTXE (QUOTIENTF (LIST (CAR NUM)
(FORMCONST 0 RNK))
DENOM))
(ILTXE (QUOTIENTF (CDR NUM) DENOM)))))
))
(SETQ SUPSWITCH T)
BY (SETQ NUM (QUOTIENTF (CAR NUM) (CAR DENOM)))
(SETQ DESCRIM (QUOTIENTF (CADDR DENOM) (CAR DENOM)))
(COND ((REMEMBERSIGN DESCRIM SIGNMEMORY) (GO SKIP1))
((REMEMBERSIGN (MINUSF DESCRIM) SIGNMEMORY) (GO SKIP2)))
(SETQ SIGNMEMORY
(CONS (CONS DESCRIM (SETQ SIGN (ASKSIGN DESCRIM))) SIGNMEMORY))
(GO AHEAD)
SKIP1(SETQ SIGN (REMEMBERSIGN DESCRIM SIGNMEMORY))
(GO AHEAD)
SKIP2(SETQ SIGN ((LAMBDA (J) (COND ((EQ J (QUOTE POSITIVE)) (QUOTE NEGATIVE))
((EQ J (QUOTE NEGATIVE)) (QUOTE POSITIVE))
(T (QUOTE ZERO))))
(REMEMBERSIGN (MINUSF DESCRIM) SIGNMEMORY)))
AHEAD(COND ((EQ SIGN (QUOTE ZERO))
(RETURN (FIXPOW (COND (SUPSWITCH (TRANS NUM))
(T (LTIMES (TRANS NUM) TIME))))))
((EQ SIGN (QUOTE POSITIVE)) (SETQ SQRTDES (SQRTF DESCRIM)))
(T (SETQ SQRTDES (SQRTF (MINUSF DESCRIM)))))
(RETURN
(FIXPOW
(LTIMES
(COND (SUPSWITCH (TRANS NUM))
(T (TRANS (QUOTIENTF NUM (CAR SQRTDES)))))
(COND
(SUPSWITCH (APPLY (COND ((EQ SIGN (QUOTE POSITIVE)) (FUNCTION SCOS))
(T (FUNCTION SCOSH)))
(LIST (LTIMES (TRANS (CAR SQRTDES))
(SSQRT (TRANS (CDR SQRTDES)))))
))
(T (LQUOTIENT (APPLY (COND ((EQ SIGN (QUOTE POSITIVE))
(FUNCTION SSIN))
(T (FUNCTION SSINH)))
(LIST (LTIMES (TRANS (CAR SQRTDES))
(SSQRT (TRANS (CDR SQRTDES)))))
)
(SSQRT (TRANS (CDR SQRTDES)))))))))
MANYFACTOR
(SETQ PARNUMER NIL)
(SETQ PARDENOM LISTFACTOR)
(SETQ SWITCH1 T)
(CPROG NUM DENOM)
(SETQ ANSLIST
(MAPCAR
(FUNCTION(LAMBDA(Y)(ILTXE(QUOTIENTF
(CAR Y)(CDR Y)))))
(PAIR PARNUMER PARDENOM) ))
(SETQ SWITCH1 NIL)
(RETURN (FIXPOW (CONS (QUOTE PLUS) ANSLIST)))))
EXPR)
(DEFPROP REMEMBERSIGN
(LAMBDA (EXPR LIST) (COND ((NULL LIST) NIL)
((EQUAL EXPR (CAAR LIST)) (CDAR LIST))
(T (REMEMBERSIGN EXPR (CDR LIST)))))
EXPR)
(DEFPROP LPLUS (LAMBDA (X Y) (LIST (QUOTE PLUS) X Y)) EXPR)
(DEFPROP LTIMES (LAMBDA (X Y) (LIST (QUOTE TIMES) X Y)) EXPR)
(DEFPROP LQUOTIENT (LAMBDA (X Y) (LIST (QUOTE QUOTIENT) X Y)) EXPR)
(DEFPROP LEXPTE (LAMBDA (X) (LIST (QUOTE EXPT) (QUOTE E) X)) EXPR)
(DEFPROP LSQRT (LAMBDA (X)(LEXPT X(QUOTE(QUOTIENT 1 2))))EXPR)
(DEFPROP LMINUS (LAMBDA (X) (LIST (QUOTE MINUS) X)) EXPR)
(DEFPROP LEXPT (LAMBDA (X Y) (LIST (QUOTE EXPT) X Y)) EXPR)
(DEFPROP SEXPTE
(LAMBDA (A) (COND ((AND (NUMBERP A) (ZEROP A)) 1)
(T (LEXPTE (LTIMES (LMINUS A) TIME)))))
EXPR)
(DEFPROP SSQRT
(LAMBDA (A) (COND ((AND (NUMBERP A) (ONEP A)) 1) (T (LSQRT A))))
EXPR)
(DEFPROP SSIN (LAMBDA (A) (LIST (QUOTE SIN) (LTIMES A TIME))) EXPR)
(DEFPROP SSINH (LAMBDA (A) (LIST (QUOTE SINH) (LTIMES A TIME))) EXPR)
(DEFPROP SCOS (LAMBDA (A) (LIST (QUOTE COS) (LTIMES A TIME))) EXPR)
(DEFPROP SCOSH (LAMBDA (A) (LIST (QUOTE COSH) (LTIMES A TIME))) EXPR)
(DEFPROP FIXPOW
(LAMBDA (X) (COND ((NULL POW) X)
((ONEP POW) (LTIMES X TIME ))
(T (LTIMES X (LEXPT TIME POW) ))))
EXPR)
(DEFPROP ILTXF
(LAMBDA (RAT) (PROG (ROOTFACTOR PARDENOM
PARNUMER
LOGPTDX
SWITCH1
DONE
SIGNMEMORY
WHOLEPART) (COND((ZEROPF RAT)(RETURN 0)))
(ILTXD RAT)
(SETQ LOGPTDX(MATCHLIST LOGPTDX))
WEE (COND ((NULL LOGPTDX) (RETURN DONE)))
(COND ((NULL (PUREPART (CAR LOGPTDX))) (GO SKIP)))
(SETQ DONE
(COND ((NULL DONE) (ILTXE (CAR LOGPTDX)))
(T (LIST (QUOTE PLUS)
DONE
(ILTXE (CAR LOGPTDX))))))
SKIP (SETQ LOGPTDX (CDR LOGPTDX))
(GO WEE)))
EXPR)
(DEFPROP ILTX
(LAMBDA (X Y)
(PROG
NIL
(COND
((NOT(EQ(LENGTH X)3))
(ERLIST
(QUOTE (ILTX 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 ILTX MUST BE ATOMS))))
((OR (EQ (CAAR X) (QUOTE EQUAL))
(EQ (CAAR X) (QUOTE LAMBDA)))
(ERLIST (QUOTE (CANNOT APPLY ILTX TO
EQUATIONS
OR
FUNCTIONS))))
((NOT (RFP (CAR X) (CADR X)))
(ERLIST (QUOTE (CAN ONLY
APPLY ILTX TO
RATIONAL
FUNCTIONS)))))
(SETQ X (MAPCAR (FUNCTION BIN) X))
(SETQ X (ILTX1 X))
(RETURN (COND (SIMP X) (T (CLEANR X))))))
FEXPR)
(DEFPROP ILTX1
(LAMBDA (X)
(PROG
(FLIST TIME REPSWITCH)
(SETQ VARLIST (NCONS(CADR X)))
(SETQ TIME(CADDR X))
(NEWVAR (CAR X))
(COND ((MEMBER TIME VARLIST)
(ERLIST (APPEND (QUOTE (ILTX CONFUSED BY))
(CONS TIME
(QUOTE (IN THE PROBLEM)))))))
(SETQ REPSWITCH T)
(SETQ X (SIMPSIMP (ILTXF (REP (CAR X)))))
(SETQ REPSWITCH NIL)
(RETURN X)))
EXPR)
(DEFPROP ILTX T INTCOM)
(DEFPROP ILTX T SACRED)
(DEFPROP MATCHLIST(LAMBDA(X)(PROG()
(SETQ X(REMCRAP X))
(COND((NULL X)(RETURN NIL)))
(SETQ X(MATCHLIST1 X))
(RETURN(CONS(CAR X)(MATCHLIST1(CDR X))))
))EXPR)
(DEFPROP REMCRAP(LAMBDA(X)(COND
((NULL X)NIL)
((AND(NOT(ATOM(CAR X)))(NOT(ATOM(CAAR X)))(EQ(CAAAR X)(Q TPOW))(NULL(CDAR X)))
(REMCRAP(CDR X)))
((CONS(CAR X)(REMCRAP(CDR X))))
))EXPR)
(DEFPROP MATCHLIST1(LAMBDA(X)(PROG(IT OUT)
(COND((NULL X)(RETURN NIL)))
(SETQ IT(CAR X))
(SETQ X(CDR X))
LOOP(COND((NULL X)(RETURN(CONS IT(REVERSE OUT)))))
(COND((MATCHP IT(CAR X))(GO MATCH)))
(SETQ OUT(CONS(CAR X)OUT))
(SETQ X(CDR X))
(GO LOOP)
MATCH (SETQ IT(COND((PUREP IT)(PLUSF IT(CAR X)))
((CONS(CAAR X)(PLUSF(CDR IT)(CDAR X))))
))
(SETQ X(CDR X))
(GO LOOP)
))EXPR)
(DEFPROP MATCHP(LAMBDA(X Y)(COND
((OR(NULL X)(NULL Y))NIL)
((PUREP X)(AND(PUREP Y)(CONSTP(QUOTIENTF X Y))))
((AND(EQUAL(CDAR X)(CDAR Y))(CONSTP(QUOTIENTF(CDR X)(CDR Y)))))
))EXPR)
(DEFPROP CONSTP(LAMBDA(X)(COND
((NUMBERP X)T)
((AND(NUMBERP(CAR X))(NUMBERP(CDR X)))T)
((POLP X)(NULL(CDR X)))
((AND(NULL(CDAR X))(NULL(CDDR X))))
))EXPR)