Trailing-Edge
-
PDP-10 Archives
-
decuslib10-02
-
43,50216/bsimp1.l
There are 2 other files named bsimp1.l in the archive. Click here to see a list.
(SETQ EXPOP 0)
(SETQ EXPON 0)
(SETQ ORDLB (QUOTE (NIL)))
(SETQ ONET (QUOTE (1 . 1)))
(SETQ ZEROT (QUOTE (0 . 1)))
(SETQ MONET (QUOTE (-1 . 1)))
(DEFPROP ORDL T SPECIAL)
(DEFPROP EXPOP T SPECIAL)
(DEFPROP EXPON T SPECIAL)
(DEFPROP ORDLA T SPECIAL)
(DEFPROP ORDLB T SPECIAL)
(DEFPROP ONET T SPECIAL)
(DEFPROP MONET T SPECIAL)
(DEFPROP ZEROT T SPECIAL)
(DEFPROP W T SPECIAL)
(DEFPROP Y T SPECIAL)
(DEFPROP Z T SPECIAL)
(DEFPROP Q (LAMBDA (L) (CONS (QUOTE QUOTE) (CDR L))) MACRO)
(DEFPROP MCONS
(LAMBDA (L)
(COND ((NULL (CDDR L)) (CADR L))
(T (LIST (Q CONS) (CADR L) (CONS (CAR L) (CDDR L))))))
MACRO)
(DEFPROP ONEP
(LAMBDA (X) (MCONS (Q EQ) 1 (CDR X)))
MACRO)
(DEFPROP COPY (LAMBDA (X) (SUBST 0 0 X)) EXPR)
(SETQ F NIL)
(QUOTE (SSPKOR LISP JUL19))
(DEFPROP PLUS PLUS COM)
(DEFPROP TIMES TIMES COM)
(DEFPROP PLUS SIMPLUS OPERATORS)
(DEFPROP TIMES SIMPTIMES OPERATORS)
(DEFPROP MINUS SIMPMIN OPERATORS)
(DEFPROP DIFFERENCE SIMPDIFF OPERATORS)
(DEFPROP RECIP SIMPRECIP OPERATORS)
(DEFPROP QUOTIENT SIMPQUOT OPERATORS)
(DEFPROP EXPT SIMPEXPT OPERATORS)
(DEFPROP LN SIMPLN OPERATORS)
(DEFPROP LOG SIMPLN OPERATORS)
(DEFPROP DIFF SIMPD OPERATORS)
(DEFPROP OP1 SIMPWAIT OPERATORS)
(DEFPROP OP2 SIMPWAIT OPERATORS)
(DEFPROP OP3 SIMPWAIT OPERATORS)
(DEFPROP ARGUMENTS NODO OPERATORS)
(DEFPROP OPERATOR NODO OPERATORS)
(DEFPROP POLY SIMPOLY OPERATORS)
(DEFPROP VALUE SIMPVAL OPERATORS)
(DEFPROP SIN SIMPSIN OPERATORS)
(DEFPROP COS SIMPCOS OPERATORS)
(DEFPROP TEREAD (LAMBDA NIL NIL) EXPR)
(DEFPROP *EQN
(LAMBDA (X Y)
(OR (EQ X Y)
(AND (NUMBERP X)
(EQUAL X Y))))
EXPR)
(DEFPROP TIMESKL
(LAMBDA (X Y)
((LAMBDA (U V)
(COND ((OR (EQ U ZEROT) (EQ V ZEROT))
ZEROT)
((AND (EQ U ONET) (EQ V ONET))
ONET)
((EQ V ONET) U)
((AND (EQ U MONET) (EQ V MONET))
ONET)
(T (CONS (*TIMES (CAR U) (CAR V))
(*TIMES (CDR U)
(CDR V))))))
(*RED (CAR X) (CDR Y))
(*RED (CAR Y) (CDR X))))
EXPR)
(DEFPROP ADDK
(LAMBDA (X Y)
(PROG (G)
(SETQ G (GCD (CDR X) (CDR Y)))
(SETQ X (CONS (CAR X)
(QUOTIENT (CDR X) G)))
(SETQ Y (CONS (CAR Y)
(QUOTIENT (CDR Y) G)))
(RETURN
(TIMESKL
(CONS 1 G)
(CONS (*PLUS (*TIMES (CAR X)
(CDR Y))
(*TIMES (CAR Y)
(CDR X)))
(*TIMES (CDR X)
(CDR Y)))))))
EXPR)
(DEFPROP *RED
(LAMBDA (N D)
(PROG (U V W)
(COND ((ZEROP N) (RETURN ZEROT)))
(COND
((EQ D 1)
(RETURN (COND ((EQ N 1) ONET)
((EQ N -1) MONET)
(T (CONS N 1))))))
(SETQ U (GCD N D))
(SETQ V (QUOTIENT N U))
(SETQ W (QUOTIENT D U))
(COND ((MINUSP W) (GO A)))
B (COND
((EQ W 1)
(RETURN (COND ((EQ V 1) ONET)
((EQ V -1) MONET)
(T (CONS V 1))))))
(RETURN (CONS V W))
A (SETQ W (MINUS W))
(SETQ V (MINUS V))
(GO B)))
EXPR)
(DEFPROP EVALQT
(LAMBDA (FN ARGS)
(COND ((OR (GET FN (QUOTE FEXPR))
(GET FN (QUOTE FSUBR)))
(EVAL (CONS FN ARGS)))
(T (APPLY FN ARGS))))
EXPR)
(QUOTE (SA1KOR LISP JUL19))
(DEFPROP GREAT
(LAMBDA (X Y)
(COND
((NULL X) F)
((NULL Y) T)
((TALKP X)
(COND ((TALKP Y)
(COND ((*EQN (CAR X) (CAR Y))
(GREATERP (CDR Y)
(CDR X)))
(T (GREATERP (CAR X)
(CAR Y)))))
(T F)))
((TALKP Y) T)
((NUMBERP X)
(COND ((NUMBERP Y) (GREATERP X Y))
(T F)))
((NUMBERP Y) T)
((ATOM X)
(COND ((ATOM Y)
(ORDER X Y (LIST ORDL ORDLB)))
(T F)))
((ATOM Y) T)
((EQUAL (CAR X) (CAR Y))
(GREAT (CDR X) (CDR Y)))
(T (GREAT (CAR X) (CAR Y)))))
EXPR)
(DEFPROP GREATP
(LAMBDA (X Y) (ORDER X
Y
(LIST ORDLA
ORDL
ORDLB)))
EXPR)
(DEFPROP ORDER
(LAMBDA (X Y Z)
(PROG (U)
O1 (SETQ U (CAR Z))
(SETQ Z (CDR Z))
O3 (COND ((NULL U) (GO O1))
((EQUAL X (CAR U))
(RETURN F))
((EQUAL Y (CAR U))
(RETURN T))
((NULL (CDR U))
(GO O2)))
(SETQ U (CDR U))
(GO O3)
O2 (COND (Z (GO O1)))
(RETURN (RPLACD U
(LIST Y)))))
EXPR)
(DEFPROP TIMESK
(LAMBDA (X Y)
(TIMESKL (*RED (CAR X)
(CDR Y))
(*RED (CAR Y)
(CDR X))))
EXPR)
(DEFPROP OVERFLOW
(LAMBDA NIL
(ERLIST (QUOTE OVERFLOW)))
EXPR)
(DEFPROP SIMPLIFYA
(LAMBDA (X Y)
(COND
((NUMBERP X) (CONS X 1))
((TALKP X) (*RED (CAR X)
(CDR X)))
((ATOM X) X)
(T
((LAMBDA (W)
(EVALQT (COND (W W)
(T (QUOTE SIMPARGS)))
(LIST X ONET Y)))
(GET (CAR X) (QUOTE OPERATORS))))))
EXPR)
(DEFPROP SIMPARGS
(LAMBDA (X Y Z)
(CONS
(CAR X)
(MAPLIST
(FUNCTION (LAMBDA (J) (SIMPLIFYA (CAR J)
Z)))
(CDR X))))
EXPR)
(DEFPROP SIMPVAL
(LAMBDA (X Y Z)
(SIMPLIFYA (*EVAL (CADR X))
Z))
EXPR)
(DEFPROP NODO (LAMBDA (X Y Z) X) EXPR)
(DEFPROP TALKP
(LAMBDA (X)
(COND ((ATOM X) F)
(T (AND (NUMBERP (CAR X))
(NUMBERP (CDR X))))))
EXPR)
(DEFPROP TALKZ
(LAMBDA (X)
(COND ((NOT (TALKP X)) F)
(T (ZEROP (CAR X)))))
EXPR)
(DEFPROP TALKO
(LAMBDA (X)
(COND ((ATOM X) F)
(T (EQUAL (CAR X)
(CDR X)))))
EXPR)
(DEFPROP TALKNO
(LAMBDA (X) (EQUAL X MONET))
EXPR)
(DEFPROP TALKN
(LAMBDA (X) (AND (TALKP X)
(MINUSP (CAR X))))
EXPR)
(DEFPROP UNT
(LAMBDA (X)
(COND ((NOT (TALKP X)) 0)
((ONEP (CDR X))
(CAR X))
(T 0)))
EXPR)
(DEFPROP TALKGCD
(LAMBDA (X Y)
(COND
((ZEROP (CAR Y))
(COND ((TALKO X) NIL) (T (LIST X))))
((ZEROP (CAR X))
(COND ((TALKO Y) NIL) (T (LIST Y))))
(T
((LAMBDA (W)
(COND ((TALKO W) NIL)
((MINUSP (CAR Y))
(LIST (CONS (MINUS (CAR W))
(CDR W))))
(T (LIST W))))
(*RED (GCD (CAR X)
(CAR Y))
(GCD (CDR X)
(CDR Y)))))))
EXPR)
(DEFPROP SIMPLN
(LAMBDA (X Z Y)
(COND
((OR (NULL (CDR X)) (CDDR X))
(ERLIST (QUOTE (LOG TAKES
ONE
ARGUMENT))))
(T
((LAMBDA (W)
(COND
((TALKO W) ZEROT)
((EQ W (QUOTE E)) ONET)
((EQ (CAR W) (QUOTE EXPT))
(SIMPTIMES
(LIST (QUOTE TIMES)
(CADDR W)
(SIMPLN (LIST (QUOTE LOG)
(CADR W))
Z
T))
ONET
T))
(T (LIST (QUOTE LOG) W))))
(COND (Y (CADR X))
(T (SIMPLIFYA (CADR X) NIL)))))))
EXPR)
(DEFPROP EXPTA
(LAMBDA (X Y)
(COND
((MINUSP (CAR Y))
(*RED (EXPT (CDR X)
(MINUS (CAR Y)))
(EXPT (CAR X)
(MINUS (CAR Y)))))
(T (*RED (EXPT (CAR X) (CAR Y))
(EXPT (CDR X)
(CAR Y))))))
EXPR)
(DEFPROP SIMPLUS
(LAMBDA (X Y Z)
(PROG (RES)
(COND
((NULL (CDR X))
(RETURN (LIST (QUOTE ARGUMENTS)
X))))
START(SETQ X (CDR X))
(COND ((NULL X) (GO FINISH)))
(SETQ
RES
(PLS (COND (Z (CAR X))
(T (SIMPLIFYA (CAR X)
F)))
Y
RES))
(GO START)
FINISH
(SETQ X (MULPLUS (TESTP RES)))
(RETURN X)))
EXPR)
(DEFPROP SIMPRECIP
(LAMBDA (X Z Y)
(COND ((OR (NULL (CDR X)) (CDDR X))
(LIST (QUOTE ARGUMENTS) X))
(T (SIMPTIMES X MONET Y))))
EXPR)
(DEFPROP SIMPMIN
(LAMBDA (X Z Y)
(COND
((OR (NULL (CDR X)) (CDDR X))
(LIST (QUOTE ARGUMENTS) X))
((NUMBERP (CADR X))
(CONS (MINUS (CADR X)) 1))
((ATOM (CADR X))
(LIST (QUOTE TIMES) MONET (CADR X)))
(T (SIMPTIMES (LIST (QUOTE TIMES)
MONET
(SIMPLIFYA (CADR X)
Y))
ONET
T))))
EXPR)
(DEFPROP SIMPDIFF
(LAMBDA (X Z Y)
(COND
((OR (NULL (CDR X))
(NULL (CDDR X))
(CDDDR X))
(LIST (QUOTE ARGUMENTS) X))
(T
(SIMPLUS
(LIST (QUOTE PLUS)
(SIMPLIFYA (CADR X) Y)
(SIMPTIMES (LIST (QUOTE TIMES)
MONET
(CADDR X))
ONET
Y))
ONET
T))))
EXPR)
(DEFPROP SIMPTIMES
(LAMBDA (X Y Z)
(PROG (RES)
(COND
((NULL (CDR X))
(RETURN (LIST (QUOTE ARGUMENTS)
X))))
START(SETQ X (CDR X))
(COND ((TALKZ RES) (RETURN RES))
((NULL X) (GO FINISH)))
(SETQ
RES
(TMS (COND (Z (CAR X))
(T (SIMPLIFYA (CAR X)
F)))
Y
RES))
(GO START)
FINISH
(SETQ RES (TESTT RES))
(COND ((OR (ATOM RES)
(NOT (EQ (CAR RES)
(QUOTE TIMES))))
(RETURN RES)))
(RETURN (MULB RES EXPOP EXPON))))
EXPR)
(DEFPROP SIMPWAIT
(LAMBDA (X Z Y)
((LAMBDA (W) X)
(RPLACD X
(SIMPLEDD (CDR X)
Y))))
EXPR)
(DEFPROP SIMPLEDD
(LAMBDA (X Y)
(COND
((NULL X) NIL)
(T (RPLACD (RPLACA X
(SIMPLIFYA (CAR X) Y))
(SIMPLEDD (CDR X) Y)))))
EXPR)
(QUOTE (SA2KOR LISP JUL19))
(DEFPROP SIMPQUOT
(LAMBDA (X Z Y)
(COND
((OR (NULL (CDR X))
(NULL (CDDR X))
(CDDDR X))
(LIST (QUOTE ARGUMENTS) X))
((AND Y
(NOT (ATOM (CADR X)))
(NOT (ATOM (CADDR X)))
(OR (TALKP (CADR X))
(EQ (CADR X) (QUOTE POLY)))
(OR (TALKP (CADDR X))
(EQ (CADDR X) (QUOTE POLY))))
(POLYDIVIDE (CADR X) (CADDR X)))
(T
(SIMPTIMES
(LIST (QUOTE TIMES)
(SIMPLIFYA (CADR X) Y)
(SIMPTIMES (CONS (QUOTE TIMES)
(CDDR X))
MONET
Y))
ONET
T))))
EXPR)
(QUOTE (SA3KOR LISP JUL19))
(DEFPROP OREM
(LAMBDA (X Y)
(COND ((NULL Y) X)
(T (OREM (CDR X)
(CDR Y)))))
EXPR)
(DEFPROP MULPLUS
(LAMBDA (X)
(PROG (FM HELP RES TEM)
(COND ((OR (ATOM X)
(NOT (EQ (CAR X)
(QUOTE PLUS)))
(ZEROP EXPOP))
(RETURN X)))
(SETQ FM X)
START(SETQ FM (CDR FM))
STARTA
(COND ((NULL (CDR FM))
(RETURN (TESTP (PLS RES
ONET
X))))
((OR (ATOM (CADR FM))
(NOT (EQ (CAADR FM)
(QUOTE TIMES))))
(GO START)))
(SETQ HELP (CADR FM))
UP (SETQ HELP (CDR HELP))
(COND ((NULL (CDR HELP)) (GO START))
((OR (ATOM (CADR HELP))
(NOT (EQ (CAADR HELP)
(QUOTE PLUS))))
(GO UP)))
(SETQ TEM (CADR HELP))
(RPLACD HELP (CDDR HELP))
(SETQ RES
(PLS (SYMT (CADR FM) TEM ONET)
ONET
RES))
(RPLACD FM (CDDR FM))
(GO STARTA)))
EXPR)
(DEFPROP SIMPEXPT
(LAMBDA (X Z Y)
(PROG (GR POT RES)
(COND
(Y (GO SIMP))
((OR (NULL (CDR X))
(NULL (CDDR X))
(CDDDR X))
(RETURN (LIST (QUOTE ARGUMENTS)
X))))
(SETQ POT (SIMPLIFYA (CADDR X) F))
(SETQ GR (SIMPLIFYA (CADR X) F))
CONT (COND
((AND(TALKP GR)(TALKP POT))(RETURN(EXPTRL GR POT)))
((ATOM POT) (GO ATP))
((ATOM GR) (GO ATGR))
((TALKZ POT) (GO TALKZP))
((OR (TALKO POT)
(TALKZ GR)
(TALKO GR))
(RETURN GR))
((EQ (CAR GR) (QUOTE EXPT))
(GO E1))
((TALKNO POT)
(RETURN (TESTT (TMS GR POT NIL))))
((NOT (ZEROP (UNT POT)))
(RETURN
(SIMPLIFYA
(COND
((AND
(EQ (CAR GR) (QUOTE PLUS))
(NOT
(OR
(GREATERP (CAR POT) EXPOP)
(GREATERP (MINUS (CAR POT))
EXPON))))
(MULB (LIST (QUOTE TIMES)
ONET
(LIST (QUOTE EXPT)
GR
POT))
EXPOP
EXPON))
(T (TMS GR POT NIL)))
T))))
OPP (COND ((EQ (CAR GR) (QUOTE EXPT))
(GO E1))
((NOT (EQ (CAR GR)
(QUOTE TIMES)))
(GO UP)))
(SETQ RES (LIST ONET))
START(COND ((AND (CDR RES)
(TALKO (CAR RES))
(TALKP (CADR RES)))
(SETQ RES (CDR RES))))
(SETQ GR (CDR GR))
(COND
((NULL GR)
(RETURN (TESTT (CONS (QUOTE TIMES)
RES))))
((AND (NOT (ATOM (CAR GR)))
(EQ (CAAR GR) (QUOTE EXPT)))
(RPLACA (CDDAR GR)
(MULT (CADDAR GR) POT)))
(T (RPLACA GR (LIST (QUOTE EXPT)
(CAR GR)
POT))))
(TIMESIN (SIMPLIFYA (CAR GR) T)
RES
ONET)
(GO START)
TALKZP
(COND
((TALKZ GR)
(RETURN (LIST (QUOTE ARGUMENTS)
(LIST (QUOTE EXPT)
0
0)))))
(RETURN ONET)
ATGR (COND ((TALKZ POT) (RETURN ONET))
((TALKO POT) (RETURN GR)))
(COND
((AND (EQ GR (QUOTE E))
(EQ (CAR POT) (QUOTE LOG)))
(RETURN (CADR POT)))
((AND (EQ GR (QUOTE E))
(EQ (CAR POT) (QUOTE TIMES))
(TALKP (CADR POT))
(EQ (CAADDR POT) (QUOTE LOG))
(NULL (CDDDR POT)))
(RETURN (LIST (QUOTE EXPT)
(CADR (CADDR POT))
(CADR POT)))))
UP
(COND((AND(TALKP GR)(TALKP POT))
(RETURN(EXPTRL GR POT))))
(RETURN (LIST (QUOTE EXPT) GR POT))
ATP (COND ((ATOM GR) (GO UP))
((TALKZ GR) (RETURN ZEROT))
((TALKO GR) (RETURN ONET)))
(GO OPP)
E1 (SETQ POT (MULT POT (CADDR GR)))
(SETQ GR (CADR GR))
(GO CONT)
SIMP (SETQ POT (CADDR X))
(SETQ GR (CADR X))
(GO CONT)))
EXPR)
(DEFPROP PLUSIN
(LAMBDA (X Y W)
(PROG (FM)
(SETQ FM Y)
(COND ((AND (NOT (ATOM X))
(EQ (CAR X)
(QUOTE TIMES)))
(GO TIMESX)))
(SETQ X (LIST X))
START(COND ((NULL (CDR FM)) (GO LESS))
((AND (NOT (ATOM (CADR FM)))
(EQ (CAADR FM)
(QUOTE TIMES)))
(GO TIMESL))
((EQUAL X (LIST (CADR FM)))
(GO EQU))
((GREAT X (LIST (CADR FM)))
(GO GR)))
LESS (RETURN
(CDR
(RPLACD
FM
(CONS (TESTT (CONS (QUOTE TIMES)
(CONS W X)))
(CDR FM)))))
GR (SETQ FM (CDR FM))
(GO START)
EQU (RPLACA (CDR FM)
(CONS (QUOTE TIMES)
(CONS (ADDK ONET W)
X)))
DEL (COND
((NOT (ZEROP (CAADAR (CDR FM))))
(RETURN (CDR FM))))
(RETURN (RPLACD FM (CDDR FM)))
TIMESL
(COND ((EQUAL X (CDDADR FM))
(GO EQUT))
((GREAT X (CDDADR FM))
(GO GR)))
(GO LESS)
EQUT (COND
((AND
(TALKO
(CADAR
(RPLACA
(CDR FM)
(CONS (QUOTE TIMES)
(CONS (ADDK (CADADR FM)
W)
X)))))
(NULL (CDR (CDDADR FM))))
(RPLACA (CDR FM)
(CAR (CDDADR FM))))
(T (GO DEL)))
(RETURN (CDR FM))
TIMESX
(SETQ W (TIMESK W (CADR X)))
(SETQ X (CDDR X))
(GO START)))
EXPR)
(QUOTE (EXPTR LISP))
( DEFPROP EXPTRL
(LAMBDA (R1 R2)
(COND
((TALKO R1) ONET)
((TALKO R2)R1)
((TALKZ R1)
(COND
((OR (TALKZ R2) (TALKN R2))
(ERLIST(QUOTE (ZERO TO A NONPOSITIVE POWER))))
(T ZEROT)))
((ONEP(CDR R2))(EXPTR1 R1(CAR R2))) ((AND (NOT (TALKN R1))
(NOT (TALKN R2)))
(DBLEPOSEXPT R1 R2))
((TALKN R2)
(EXPTRL (INVERTRL R1)
(MINUSRL R2)))
((AND (ODD (CAR R2))
(ODD (CDR R2)))
((LAMBDA (J)
(COND ((TALKP J) (MINUSRL J))
((EQ(CAR J)(QUOTE TIMES))(CONS
(QUOTE TIMES)(CONS(MINUSRL(CADR J)
)(CDDR J))))
((LIST(QUOTE TIMES)MONET J)) ))
(DBLEPOSEXPT (MINUSRL R1) R2)))
((EVEN (CAR R2))
(DBLEPOSEXPT (MINUSRL R1) R2))
((TALKNO R1 )
(LIST (QUOTE EXPT) MONET R2))
(T ((LAMBDA(J K)(COND
((TALKP J)(LIST(QUOTE TIMES)J K))
((EQ(CAR J)(QUOTE TIMES))(CONS(QUOTE TIMES)
(CONS(CADR J)(CONS K(CDDR J)))))
((LIST(QUOTE TIMES)ONET K J))
))
(DBLEPOSEXPT(MINUSRL R1)R2)
(LIST(QUOTE EXPT)MONET R2)
))
))EXPR)
( DEFPROP DBLEPOSEXPT
(LAMBDA (R1 R2)
(PROG
(NUMLIST DENOMLIST)
(SETQ NUMLIST
(NROOTLIST (CAR R1)
(CDR R2)))
(COND
((ONEP(CDR R1))
(COND
((EQUAL (CAR NUMLIST) (LIST 1))
(RETURN (LIST (QUOTE EXPT)
R1
R2)))
((ONEP (CDR NUMLIST))
(RETURN
(EXPTR1(CONS
(EVAL (CONS (QUOTE TIMES)
(CAR NUMLIST)))1)
(CAR R2))))
(T
(RETURN
(LIST
(QUOTE TIMES)
(EXPTR1(CONS
(EVAL (CONS (QUOTE TIMES)
(CAR NUMLIST)))1)
(CAR R2))
(LIST (QUOTE EXPT)
(CONS(CDR NUMLIST)1)
R2)))))))
(SETQ DENOMLIST
(NROOTLIST (CDR R1)
(CDR R2)))
(COND
((AND (EQUAL (CAR NUMLIST)
(QUOTE ( 1)))
(EQUAL (CAR DENOMLIST)
(QUOTE ( 1))))
(RETURN (LIST (QUOTE EXPT)
R1
R2)))
((AND (ONEP (CDR NUMLIST))
(ONEP (CDR DENOMLIST)))
(RETURN
(EXPTR1
(*RED
(EVAL (CONS(QUOTE TIMES)
(CAR NUMLIST)))
(EVAL (CONS(QUOTE TIMES)
(CAR DENOMLIST))))
(CAR R2)))))
(RETURN
(LIST
(QUOTE TIMES)
(EXPTR1
(*RED
(EVAL (CONS (QUOTE TIMES)
(CAR NUMLIST)))
(EVAL (CONS (QUOTE TIMES)
(CAR DENOMLIST))))
(CAR R2))
(LIST
(QUOTE EXPT)
(*RED (CDR NUMLIST)
(CDR DENOMLIST))
R2)))
)) EXPR)
(DEFPROP NROOTLIST (LAMBDA (K N)
(NFACTOR K
N
(LIST 1)
2))EXPR)
( DEFPROP NFACTOR
(LAMBDA (K N NROOTS CANDIDATE)
(PROG
(CANDPOW)
(SETQ CANDPOW (EXPT CANDIDATE N))
(COND
((GREATERP CANDPOW K)
(RETURN (CONS NROOTS K)))
((ZEROP(REMAINDER K CANDPOW))
(RETURN
(NFACTOR (QUOTIENT K CANDPOW)
N
(CONS CANDIDATE NROOTS)
CANDIDATE)))
(T
(RETURN
(NFACTOR
K
N
NROOTS
(COND ((EQ CANDIDATE 2) 3)
(T (PLUS CANDIDATE
2))))))))) EXPR)
(DEFPROP EXPTR1 (LAMBDA(R N)
(COND
((TALKO R)ONET)
((MINUSP N)(INVERTRL(EXPTR1 R(MINUS N))))
(T(CONS(EXPT(CAR R)N)(EXPT(CDR R)N)))
))EXPR)
(DEFPROP INVERTRL(LAMBDA(R)(CONS(CDR R)(CAR R)))EXPR)
(DEFPROP MINUSRL(LAMBDA(R)(COND
((TALKZ R)R)
((TALKO R)MONET)
((EQ R MONET)ONET)
((CONS(MINUS(CAR R))(CDR R)))
)) EXPR)
(QUOTE (B1KORS LISP JUL19))
(DEFPROP PLS
(LAMBDA (X Y OUT)
(PROG (FM)
(COND ((OR (NULL X) (ZEROP (CAR Y)))
(RETURN OUT))
((NULL OUT)
(SETQ OUT (LIST (QUOTE PLUS)
ZEROT))))
(COND
((TALKP X)
(RETURN
(CONS (QUOTE PLUS)
(CONS (ADDK (CADR OUT)
(TIMESK X Y))
(CDDR OUT)))))
((ATOM X) (GO NED))
((EQ (CAR X) (QUOTE PLUS))
(GO PLUSX)))
NED (PLUSIN X (CDR OUT) Y)
(RETURN OUT)
PLUSX(RPLACA (CDR OUT)
(ADDK (CADR OUT)
(TIMESK (CADR X) Y)))
(SETQ X (CDDR X))
(SETQ FM (CDR OUT))
START(COND ((NULL X) (RETURN OUT)))
(SETQ FM (PLUSIN (CAR X) FM Y))
(SETQ X (CDR X))
(GO START)))
EXPR)
(DEFPROP SYMT
(LAMBDA (X Y N)
(PROG (W OUT)
(COND ((NULL Y) (RETURN X)))
(SETQ OUT (LIST (QUOTE PLUS) ZEROT))
(COND
((TALKP X) (GO TALKX))
((ATOM X)
(SETQ X (LIST (QUOTE TIMES) N X)))
((EQ (CAR X) (QUOTE TIMES))
(SETQ X
(CONS (QUOTE TIMES)
(CONS (TIMESK (CADR X)
N)
(CDDR X)))))
(T (SETQ X (LIST (QUOTE TIMES)
N
X))))
START(SETQ Y (CDR Y))
(COND
((NULL Y)
(RETURN (MULPLUS (TESTP OUT)))))
(SETQ W (TESTT (TMS (CAR Y)
ONET
(COPY X))))
(COND ((TALKP W)
(RPLACA (CDR OUT)
(ADDK (CADR OUT) W)))
(T (PLUSIN W (CDR OUT) ONET)))
(GO START)
TALKX(SETQ X (TIMESK X N))
(COND ((TALKO X) (RETURN Y)))
(SETQ X (LIST (QUOTE TIMES) X))
(GO START)))
EXPR)
(DEFPROP TIMESIN
(LAMBDA (X Y W)
(PROG (FM)
(SETQ FM Y)
(COND ((AND (NOT (ATOM X))
(EQ (CAR X)
(QUOTE EXPT)))
(SETQ X (CDR X)))
(T (SETQ X (LIST X ONET))))
(SETQ W (MULT (CADR X) W))
START(COND ((NULL (CDR FM)) (GO LESS))
((AND (NOT (ATOM (CADR FM)))
(EQ (CAADR FM)
(QUOTE EXPT)))
(GO EXPTL))
((EQUAL (CAR X) (CADR FM))
(GO EQU))
((GREAT (CAR X) (CADR FM))
(GO GR)))
LESS (RETURN
(CDR
(COND
((TALKO W)
(RPLACD FM (CONS
(CAR X)
(CDR FM))))
(T
(RPLACD FM
(CONS(COND((AND(TALKP(CAR X))(TALKP W))(EXPTRL(CAR X)W))(
(LIST (QUOTE EXPT)
(CAR X)
W)))
(CDR FM)))))))
GR (SETQ FM (CDR FM))
(GO START)
EQU (SETQ W (PLSK ONET W))
(COND ((TALKZ W) (GO DEL)))
(RETURN (RPLACA (CDR FM)
(COND((AND(TALKP(CAR X))(TALKP W))(EXPTRL(CAR X)W))(
(LIST (QUOTE EXPT)
(CAR X)
W)))))
DEL (RETURN (RPLACD FM (CDDR FM)))
EXPTL(COND ((EQUAL (CAR X) (CADADR FM))
(GO EQUT))
((GREAT (CAR X) (CADADR FM))
(GO GR)))
(GO LESS)
EQUT (SETQ W (PLSK (CAR (CDDADR FM)) W))
(COND
((TALKZ W) (GO DEL))
((AND(TALKP W)(TALKP(CAR X)))(GO WEH))
((TALKO W)
(RETURN (RPLACA (CDR FM)
(CAR X))))
(T
(RETURN (RPLACA (CDR FM)
(LIST (QUOTE EXPT)
(CAR X)
W)))))
WEH (SETQ X(EXPTRL(CAR X)W))
(COND
((TALKP X)(RPLACA FM(TIMESK(CAR FM)X)))
((EQ(CAR X)(QUOTE TIMES))(PROG2
(RPLACA FM(TIMESK(CAR FM)(CADR X)))
(SETQ X(CADDR X))
)))
(RPLACD FM(CDDR FM))
(COND((TALKP X)(RETURN FM)))
(SETQ X(CDR X))
(GO START)
))
EXPR)
(DEFPROP TMS
(LAMBDA (X Y OUT)
(PROG (FM)
(COND ((NULL X) (RETURN OUT))
((NULL OUT)
(SETQ OUT (LIST (QUOTE TIMES)
ONET))))
(COND ((TALKP X) (GO TALKX))
((AND (NOT (ATOM X))
(EQ (CAR X)
(QUOTE TIMES)))
(GO TIMESX)))
(TIMESIN X (CDR OUT) Y)
(RETURN OUT)
TALKX(COND ((TALKZ X)
(COND((TALKN Y)(ERLIST(QUOTE (DIVIDING BY ZERO))))
(T (RETURN X)))
))
(RPLACA (CDR OUT)
(TIMESK (CADR OUT)
(EXPTA X Y)))
(RETURN OUT)
TIMESX
(RPLACA (CDR OUT)
(TIMESK (CADR OUT)
(EXPTA (CADR X) Y)))
(SETQ X (CDDR X))
(SETQ FM (CDR OUT))
START(COND ((NULL X) (RETURN OUT)))
(TIMESIN (CAR X) FM Y)
(SETQ X (CDR X))
(GO START)))
EXPR)
(DEFPROP PLSK
(LAMBDA (X Y)
(COND ((AND (TALKP X) (TALKP Y))
(ADDK X Y))
(T (SIMPLUS (LIST (QUOTE PLUS) X Y)
ONET
T))))
EXPR)
(DEFPROP MULT
(LAMBDA (X Y)
(COND ((AND (TALKP X) (TALKP Y))
(TIMESK X Y))
(T (SIMPTIMES (LIST (QUOTE TIMES)
X
Y)
ONET
T))))
EXPR)
(DEFPROP PLUSMULT
(LAMBDA (X Y Z)
(COND ((NULL (CDR X)) Z)
((TALKZ (CADR X))
(PLUSMULT (CDR X) Y Z))
(T (PLUSMULT (CDR X)
Y
(PLS (SYMT (CADR X)
Y
ONET)
ONET
Z)))))
EXPR)
(DEFPROP TESTT
(LAMBDA (X)
(COND ((TALKP X) X)
((NULL (CDDR X)) (CADR X))
((AND (TALKO (CADR X))
(NULL (CDDDR X)))
(CADDR X))
(T X)))
EXPR)
(DEFPROP TESTP
(LAMBDA (X)
(COND ((NULL (CDDR X)) (CADR X))
((AND (TALKZ (CADR X))
(NULL (CDDDR X)))
(CADDR X))
(T X)))
EXPR)
(QUOTE (B2KORS LISP JUL19))
(DEFPROP MULB
(LAMBDA (X P N)
(PROG (NUM M FM HELP RES W)
(SETQ NUM 1)
(COND ((OR (ZEROP P) (ONEP P))
(GO NEG)))
(SETQ M P)
STARTA
(SETQ FM X)
START(SETQ FM (CDR FM))
(COND
((NULL (CDR FM)) (GO NEG))
((OR (ATOM (CADR FM))
(NOT (EQ (CAADR FM)
(QUOTE EXPT)))
(ATOM (CADADR FM))
(NOT (EQ (CAR (CADADR FM))
(QUOTE PLUS))))
(GO START)))
(SETQ
HELP
(TIMES NUM
(UNT (CAR (CDDADR FM)))))
(COND ((OR (ZEROP HELP)
(MINUSP HELP)
(GREATERP HELP M))
(GO START))
((ONEP HELP) (GO RECIP)))
(SETQ RES (CADADR FM))
OPP (SETQ HELP (SUB1 HELP))
(SETQ RES (PLUSMULT (CADADR FM)
RES
NIL))
(COND ((NOT (ONEP HELP)) (GO OPP)))
(RPLACD FM (CDDR FM))
(SETQ X (TMS RES (CONS NUM 1) X))
(GO STARTA)
NEG (COND ((OR (MINUSP NUM)
(ONEP N)
(ZEROP N))
(GO ENER)))
(SETQ NUM -1)
(SETQ M N)
(GO STARTA)
CONTA(SETQ NUM 1)
(SETQ P 0)
CONTC(SETQ HELP NIL)
(SETQ FM X)
CONT (SETQ FM (CDR FM))
CONTB(COND ((NULL (CDR FM)) (GO CNUMT))
((OR (ATOM (CADR FM))
(NOT (EQ (CAADR FM)
(QUOTE PLUS))))
(GO CONT))
((NULL HELP) (GO SHELP)))
(SETQ RES (CADR FM))
(RPLACD FM (CDDR FM))
(SETQ X (TMS (PLUSMULT RES HELP NIL)
ONET
X))
(GO CONTC)
SHELP(SETQ P -1)
(SETQ HELP (CADR FM))
(RPLACD FM (CDDR FM))
(GO CONTB)
CNUMT(COND(HELP(SETQ X(PLUSMULT(LIST(QUOTE PLUS)X)HELP NIL))))
(SETQ HELP NIL)
NUMT (SETQ X (TMS HELP (CONS NUM 1) X))
NULLA(COND
((ZEROP N)
(COND
((OR (ATOM X)
(NOT (EQ (CAR X)
(QUOTE TIMES))))
(RETURN X))
(T (RETURN (TESTT X))))))
(SETQ NUM -1)
(SETQ N 0)
(SETQ M 1)
(SETQ W NIL)
(GO STARTA)
RECIP(COND ((NOT (ZEROP N)) (GO START))
((NULL W) (GO RHELP)))
(SETQ RES (CADADR FM))
(RPLACD FM (CDDR FM))
(SETQ X (TMS (PLUSMULT RES W NIL)
(CONS NUM 1)
X))
(GO STARTA)
RHELP(SETQ W (CADADR FM))
(RPLACD FM (CDDR FM))
(GO STARTA)
ENER (COND ((AND (MINUSP NUM) (ZEROP N))
(SETQ X (TMS W
(CONS NUM 1)
X)))
((GREATERP P 0) (GO CONTA)))
(GO NULLA)))
EXPR)
(DEFPROP SIMPSIN(LAMBDA(X Y Z)(COND
((OR(NULL X)(CDDR X))(ERLIST(Q(SIN TAKES ONE ARGUMENT))))
(((LAMBDA(J)(COND((TALKZ J)ZEROT)
((LIST(Q SIN)J))
) )
(COND(Z(CADR X))((SIMPLIFYA(CADR X)NIL)))
) )
))EXPR)
(DEFPROP SIMPCOS(LAMBDA(X Y Z)(COND
((OR(NULL X)(CDDR X))(ERLIST(Q(COS TAKES ONE ARGUMENT))))
( ((LAMBDA(J)(COND((TALKZ J)ONET)
((LIST(Q COS)J))
) )
(COND(Z(CADR X))((SIMPLIFYA(CADR X)NIL)))
) )
))EXPR)