PDP-10 Archive: 43,50216/top9.l from decuslib10-02

Trailing-Edge - PDP-10 Archives - decuslib10-02 - 43,50216/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)