Trailing-Edge
-
PDP-10 Archives
-
decus_20tap2_198111
-
decus/20-0039/top9.l
There are 2 other files named top9.l in the archive. Click here to see a list.
(DEFPROP SIMP T SPECIAL)
(DEFPROP VARLIST T SPECIAL)
(DEFPROP REPSWITCH T SPECIAL)
(DEFPROP X* T SPECIAL)
(DEFPROP FLIST T SPECIAL)
(DEFPROP VARNUM T SPECIAL)
(DEFPROP PARNUMER T SPECIAL)
(DEFPROP PARDENOM T SPECIAL)
(DEFPROP ROOTFACTOR T SPECIAL)
(DEFPROP WHOLEPART T SPECIAL)
(DEFPROP POW T SPECIAL)
(QUOTE (FILE TOP))
(DEFPROP PF
(LAMBDA (X Y) (SWINGFACTOR X T))
FEXPR)
(DEFPROP PPF
(LAMBDA (X Y) (SWINGFACTOR X NIL))
FEXPR)
(DEFPROP SWINGFACTOR
(LAMBDA (X IND)
(PROG
(ANS)
(DISTEXP)
(SETQ X (MAPCAR (FUNCTION UNQUOTE) X))
(COND
((OR
(NULL X)
(EVAL
(CONS
(QUOTE OR)
(MAPCAR
(FUNCTION
(LAMBDA (J)
(OR (EQ (CAR J)
(QUOTE EQUAL))
(EQ (CAR J)
(QUOTE LAMBDA)))))
(CDR X)))))
(ERLIST
(APPEND
(QUOTE (WRONG FORM FOR))
(LIST (COND (IND (QUOTE PF))
(T (QUOTE PPF))))))))
(SETQ X (MAPCAR (FUNCTION BIN) X))
(COND ((ATOM (CAR X)) (GO EXPR))
((EQ (CAAR X) (QUOTE EQUAL))
(GO EQN))
((EQ (CAAR X) (QUOTE LAMBDA))
(GO FN)))
EXPR
(SETQ ANS (DOFACT1 (CONS IND X)))
(GO OUT)
EQN
(SETQ ANS
(LIST (QUOTE EQUAL)
(DOFACT1 (CONS IND
(CONS (CADAR X) (CDR X))))
(DOFACT1 (CONS IND
(CONS (CADDAR X) (CDR X))))))
(GO OUT)
FN
(SETQ ANS
(LIST (QUOTE LAMBDA)
(CADAR X)
(DOFACT1
(CONS IND
(CONS (CADDAR X) (CDR X))))))
OUT
(RETURN (COND (SIMP ANS)
(T (CLEANR (BIN ANS)))))))
EXPR)
(DEFPROP RATSIMP
(LAMBDA (X Y)
(PROG
(ANS)
(DISTEXP)
(SETQ X (MAPCAR (FUNCTION UNQUOTE) X))
(COND
((OR
(NULL X)
(EVAL
(CONS
(QUOTE OR)
(MAPCAR
(FUNCTION
(LAMBDA (J)
(OR (EQ (CAR J) (QUOTE EQUAL))
(EQ (CAR J)
(QUOTE LAMBDA)))))
(CDR X)))))
(ERLIST (QUOTE (WRONG FORM
FOR
RATSIMP)))))
(SETQ X (MAPCAR (FUNCTION BIN) X))
(COND ((ATOM (CAR X)) (GO EXPR))
((EQ (CAAR X) (QUOTE EQUAL))
(GO EQN))
((EQ (CAAR X) (QUOTE LAMBDA))
(GO FN)))
EXPR
(SETQ ANS (RSIMP1 X))
(GO OUT)
EQN
(SETQ ANS
(LIST (QUOTE EQUAL)
(RSIMP1 (CONS (CADAR X) (CDR X)))
(RSIMP1 (CONS (CADDAR X) (CDR X)))))
(GO OUT)
FN
(SETQ ANS
(LIST (QUOTE LAMBDA)
(CADAR X)
(RSIMP1 (CONS (CADDAR X) (CDR X)))))
OUTETURN (COND (SIMP ANS)
(T (CLEANR ANS))))))
FEXPR)
(DEFPROP RATSIMP T INTCOM)
(DEFPROP RATSIMP T SACRED)
(DEFPROP PF T INTCOM)
(DEFPROP PF T SACRED)
(DEFPROP PPF T INTCOM)
(DEFPROP PPF T SACRED)
(DEFPROP INTEGRATE
(LAMBDA (X Y)
(PROG
NIL
(COND
((OR (NULL X) (NULL (CDR X)) (CDDR X))
(ERLIST
(QUOTE (INTEGRATE TAKES
TWO
ARGUMENTS)))))
(SETQ X (LIST (UNQUOTE (CAR X))
(UNQUOTE (CADR X))))
(COND
((NOT (LATOM (CADR X)))
(ERLIST (QUOTE (CAN ONLY
INTEGRATE
WITH
RESPECT
TO
ATOMS))))
((OR (EQ (CAAR X) (QUOTE EQUAL))
(EQ (CAAR X) (QUOTE LAMBDA)))
(ERLIST (QUOTE (CANNOT INTEGRATE
EQUATIONS
OR
FUNCTIONS))))
((NOT (RFP (CAR X) (CADR X)))
(ERLIST (QUOTE (CAN ONLY
INTEGRATE
RATIONAL
FUNCTIONS)))))
(SETQ X (MAPCAR (FUNCTION BIN) X))
(SETQ X (INGRATE1 X))
(RETURN (COND (SIMP X) (T (CLEANR X))))))
FEXPR)
(DEFPROP RFP
(LAMBDA (EXPR X*)
(COND
((ATOM EXPR) T)
((EQUAL EXPR X*) T)
((NOT (GINN X* EXPR)) T)
((EQ (CAR EXPR) (QUOTE EXPT))
(AND (RFP (CADR EXPR) X*)
(NUMBERP (CADDR EXPR))))
((OPP (CAR EXPR))
(EVAL
(CONS
(QUOTE AND)
(MAPCAR (FUNCTION (LAMBDA (J)
(RFP J X*)))
(CDR EXPR)))))
(T NIL)))
EXPR)
(DEFPROP INTEGRATE T INTCOM)
(DEFPROP INTEGRATE T SACRED)
(DEFPROP DOFACT1
(LAMBDA (X)
(PROG
(IND EXPR REPSWITCH)
(SETQ IND (CAR X))
(SETQ EXPR (CADR X))
(SETQ VARLIST (REVERSE (CDDR X)))
(NEWVAR EXPR)
(SETQ EXPR (REP EXPR))
(RETURN
(COND
((RATFUNP EXPR)
(LIST (QUOTE QUOTIENT)
(PARTFACTOR (NUMERATORF EXPR)
IND)
(PARTFACTOR (DENOMINATORF EXPR)
IND)))
(T (PARTFACTOR EXPR IND))))))
EXPR)
(DEFPROP PARTFACTOR
(LAMBDA (X IND)
((LAMBDA (J)
(COND ((NULL (CDR J)) (CAR J))
(T (CONS (QUOTE TIMES)
J))))
(MAPCAR
(FUNCTION (LAMBDA (K)
(SIMPSIMP (TRANS K))))
((COND (IND (FUNCTION FACTOR))
(T (FUNCTION FACTOR1)))
X))))
EXPR)
(DEFPROP RSIMP1
(LAMBDA (X)
(PROG
(REPSWITCH)
(SETQ VARLIST (REVERSE (CDR X)))
(NEWVAR (CAR X))
(RETURN
(SIMPSIMP (TRANS (REP (CAR X)))))))
EXPR)
(DEFPROP BIN
(LAMBDA (X)
(COND ((ATOM X) X)
((EQ(CAR X)(QUOTE EXPT))(COND
((NUMBERP(CADDR X))(LIST(CAR X)(BIN(CADR X))(CADDR X)))
((LIST(CAR X)(SPT(CADR X))(SPT(CADDR X))))
))
((AND (OR (EQ (CAR X) (QUOTE PLUS))
(EQ (CAR X)
(QUOTE TIMES)))
(CDDDR X))
(BIN (LIST (CAR X)
(CADR X)
(CONS (CAR X)
(CDDR X)))))
((EQ(CAR X)(QUOTE MINUS))(LIST(CAR X)(BIN(CADR X))))
((OPP(CAR X))(LIST(CAR X)(BIN(CADR X))(BIN(CADDR X))))
((MAPCAR (FUNCTION SPT)X))
)) EXPR)
(DEFPROP INGRATE1
(LAMBDA (X)
(PROG
(FLIST REPSWITCH)
(SETQ VARLIST (CDR X))
(NEWVAR (CAR X))
(SETQ REPSWITCH T)
(SETQ
X
(SIMPSIMP (FPROG (REP (CAR X)))))
(SETQ REPSWITCH NIL)
(RETURN X)))
EXPR)
(DEFPROP ASKSIGN
(LAMBDA (X)
(PROG
NIL
(SETQ X (STRIPPAREN X))
(COND
((NUMBERPRL X)
(RETURN (COND ((MINUSPF X)
(QUOTE NEGATIVE))
(T (QUOTE POSITIVE))))))
(RETURN (ASIGN (SIMPSIMP (TRANS X))))))
EXPR)
(DEFPROP ASIGN
(LAMBDA (X)
(PROG
(ANS)
(PRINLIST (QUOTE (IS THE EXPRESSION)))
(TERPRI)
(CHARYBDIS (SPT (REMDIF (CLEANR X)))
1
(LINELENGTH NIL))
(PRINLIST (QUOTE (TO BE
CONSIDERED
POSITIVE
NEGATIVE
OR
ZERO?)))
WELL
(PRINC (QUOTE #))
(SETQ ANS (ERRSET (PRE)NIL))
(COND((NOT ANS)(GO ECH)))
(SETQ ANS (CAR ANS))
(COND ((MEMBER ANS
(QUOTE (POSITIVE NEGATIVE
ZERO)))
(GO OUT)))
ECH (PRINLIST (QUOTE (ANSWER POSITIVE
NEGATIVE
OR
ZERO)))
(GO WELL)
OUT (TERPRI)
(RETURN ANS)))
EXPR)
(DEFPROP CLEANR
(LAMBDA (X)
(COND
((AND (NUMBERP X) (MINUSP X))
(LIST(QUOTE MINUS)(MINUS X)))
((ATOM X) X)
((EQ (CAR X) (QUOTE TIMES))
((LAMBDA(J)(COND
((AND(NOT(ATOM(CAR J)))(EQ(CAAR J)(QUOTE MINUS)))
(LIST(QUOTE MINUS)(CONS(QUOTE TIMES)(CONS(CADAR J)(CDR J)))))
((CONS(QUOTE TIMES)J)) ))
(MAPCAR(FUNCTION CLEANR)(CDR X)) ))
((CONS (CLEANR (CAR X))
(CLEANR (CDR X))))))
EXPR)
(DEFPROP GINN
(LAMBDA (X Y)
(COND ((EQUAL X Y) T)
((ATOM Y) NIL)
((OR (GINN X (CAR Y))
(GINN X (CDR Y))))))
EXPR)
(DEFPROP PFE2(LAMBDA(R)(PROG(PARNUMER PARDENOM ROOTFACTOR ANS WHOLEPART)
(COND((PFP R)(RETURN(TRANS R))))
(APROG(DENOMINATORF R))
(CPROG(NUMERATORF R)(DENOMINATORF R))
(SETQ ROOTFACTOR(REVERSE ROOTFACTOR))
(SETQ PARNUMER(REVERSE PARNUMER))
(SETQ ANS(APPEND (COND(WHOLEPART(LIST(TRANS WHOLEPART))))
(APPLY(QUOTE APPEND)(MAPLIST2
(FUNCTION(LAMBDA(J K)(PFEROOT(CAR J)(CAR K)(LENGTH K))))
PARNUMER ROOTFACTOR))))
(RETURN(COND
((CDR ANS)(CONS(QUOTE PLUS)ANS))
((CAR ANS))))
))EXPR)
(DEFPROP PFEROOT(LAMBDA(TOP ROOT POW)(PROG
(PARDENOM PARNUMER)
(SETQ PARDENOM(MAPCAR
(FUNCTION(LAMBDA(J)(EXPTF J POW)))
(INTFACTOR ROOT)))
(CPROG TOP(EXPTF ROOT POW))
(RETURN(MAPCAR2
(FUNCTION(LAMBDA(J K)(TRANS(QUOTIENTF J K))))
PARNUMER PARDENOM))
))EXPR)
(DEFPROP MAPCAR2(LAMBDA(FN L1 L2)(PROG (ANS)
LOOP (COND((OR(NULL L1)(NULL L2))(RETURN (REV ANS))))
(SETQ ANS(CONS (APPLY FN(LIST(CAR L1)(CAR L2)))ANS))
(SETQ L1(CDR L1))
(SETQ L2(CDR L2))
(GO LOOP)
))EXPR)
(DEFPROP MAPLIST2(LAMBDA(FN L1 L2)(PROG(ANS)
LOOP(COND((OR(NULL L1)(NULL L2))(RETURN(REV ANS))))
(SETQ ANS(CONS(APPLY FN(LIST L1 L2))ANS))
(SETQ L1(CDR L1))
(SETQ L2(CDR L2))
(GO LOOP)
))EXPR)
(DEFPROP PFE
(LAMBDA (X Y)
(PROG
(ANS)
(SETQ X (MAPCAR (FUNCTION UNQUOTE) X))
(COND
((OR
(NULL X)
(EVAL
(CONS
(QUOTE OR)
(MAPCAR
(FUNCTION
(LAMBDA (J)
(OR (EQ (CAR J) (QUOTE EQUAL))
(EQ (CAR J)
(QUOTE LAMBDA)))))
(CDR X)))))
(ERLIST (QUOTE (WRONG FORM
FOR
PFE)))))
(SETQ X (MAPCAR (FUNCTION BIN) X))
(COND ((ATOM (CAR X)) (GO EXPR))
((EQ (CAAR X) (QUOTE EQUAL))
(GO EQN))
((EQ (CAAR X) (QUOTE LAMBDA))
(GO FN)))
EXPR
(SETQ ANS (PFE1 X))
(GO OUT)
EQN
(SETQ ANS
(LIST (QUOTE EQUAL)
(PFE1 (CONS (CADAR X) (CDR X)))
(PFE1 (CONS (CADDAR X) (CDR X)))))
(GO OUT)
FN
(SETQ ANS
(LIST (QUOTE LAMBDA)
(CADAR X)
(PFE1 (CONS (CADDAR X) (CDR X)))))
OUTETURN (COND (SIMP ANS)
(T (CLEANR ANS))))))
FEXPR)
(DEFPROP PFE1
(LAMBDA (X)
(PROG
(REPSWITCH FLIST VARLIST)
(SETQ VARLIST (REVERSE (CDR X)))
(NEWVAR (CAR X))
(SETQ REPSWITCH T)
(RETURN
(SIMPSIMP (PFE2(REP(CAR X)))))
))EXPR)
(DEFPROP PFE T INTCOM)
(DEFPROP PFE T SACRED)