Trailing-Edge
-
PDP-10 Archives
-
decuslib20-02
-
decus/20-0039/dif8.l
There are 2 other files named dif8.l in the archive. Click here to see a list.
(SETQ SETUPLIST (QUOTE
((LOG ((X) ((QUOTIENT 1 X))))
(SIN ((X) ((COS X))))
(ARCSIN
((X)
((QUOTIENT 1
(EXPT (DIFFERENCE 1
(EXPT X
2))
(QUOTIENT 1 2))))))
(ARCCOS
((X)
((QUOTIENT -1
(EXPT (DIFFERENCE 1
(EXPT X
2))
(QUOTIENT 1 2))))))
(ARCTAN ((X)
((QUOTIENT 1
(PLUS 1
(EXPT X
2))))))
(COS ((X) ((MINUS (SIN X)))))
)))
(SETQ
GRADLIST
(MAPCAR
(FUNCTION (LAMBDA (Z)
(PROG2 (PUTPROP (CAR Z)
(LIST(CAADR Z)(NCONS(SIMPLIFYA
(CAR(CADADR Z))NIL)))
(QUOTE GRAD))
(CAR Z))))
SETUPLIST))
(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 GRADLIST T SPECIAL)
(DEFPROP SVGRADLIST T SPECIAL)
(DEFPROP ERTALK T SPECIAL)
(DEFPROP FIRSTVAR T SPECIAL)
(DEFPROP ONET T SPECIAL)
(DEFPROP ZEROT T SPECIAL)
(DEFPROP MONET T SPECIAL)
(DEFPROP GRADLIST T SPECIAL)
(DEFPROP FN T SPECIAL)
(DEFPROP E T SPECIAL)
(DEFPROP *X T SPECIAL)
(DEFPROP SUBLIS
(LAMBDA (A Y)
(COND ((ATOM Y) (SUB2 A Y))
((CONS (SUBLIS A (CAR Y))
(SUBLIS A (CDR Y))))))
EXPR)
(DEFPROP SUB2
(LAMBDA (A Z)
(COND ((NULL A) Z)
((EQ (CAAR A) Z) (CDAR A))
((SUB2 (CDR A) Z))))
EXPR)
(DEFPROP PAIR
(LAMBDA (X Y)
(COND ((NULL X) NIL)
((CONS (CONS (CAR X) (CAR Y))
(PAIR (CDR X) (CDR Y))))))
EXPR)
(DEFPROP PROP
(LAMBDA (X Y U)
(COND ((NULL X) (U))
((EQ (CAR X) Y) (CDR X))
((PROP (CDR X) Y U))))
EXPR)
(DEFPROP DEPENDS
(LAMBDA (E X)
(COND ((EQ E X) T)
((TALKP E) NIL)
((ATOM E)
(MEMBER X
(GET E (QUOTE DEPENDS))))
((OR (DEPENDS (CAR E) X)
(DEPENDS (CDR E) X)))))
EXPR)
(DEFPROP SDIFF
(LAMBDA (E *X)
(COND
((EQ E *X) ONET)
((ATOM E)
(COND ((DEPENDS E *X)
(LIST (QUOTE DERIV) E *X ONET))
(T ZEROT)))
((TALKP E) ZEROT)
((NOT (DEPENDS E *X)) ZEROT)
((GET (CAR E) (QUOTE DIFFFN))
(APPLY (GET (CAR E) (QUOTE DIFFFN))
(LIST E *X)))
(T
(SIMPLUS
(CONS
(QUOTE PLUS)
(MAPCAR
(FUNCTION
(LAMBDA (K)
(SIMPTIMES (LIST (QUOTE TIMES)
(SIMPLIFYA(CAR K)NIL)
(CDR K))
ONET
T)))
(PAIR
((LAMBDA (GRAD)
(COND
((NOT
(EQUAL (LENGTH (CDR E))
(LENGTH (CAR GRAD))))
(ERLIST
(APPEND (QUOTE (WRONG NUMBER
OF
ARGS
FOR))
(LIST (CAR E)))))
(T (SUBLIS (PAIR (CAR GRAD)
(CDR E))
(CADR GRAD)))))
((LAMBDA (L)
(COND
(L L)
(T
(DIFFERROR
(CONS (CAR E)
(LENGTH (CDR E)))))))
(GET (CAR E) (QUOTE GRAD))))
(MAPCAR
(FUNCTION (LAMBDA (J)
(SDIFF J
*X)))
(CDR E)))))
ONET
T))))
EXPR)
(DEFPROP PUMP
(LAMBDA NIL
(MAPCAR
(FUNCTION
(LAMBDA (J)
((LAMBDA (K)
(RPLACA
(CDAR K)
(MAPCAR
(FUNCTION
(LAMBDA (L) (SIMPLIFYA L F)))
(CADAR K))))
(PROP
J
(QUOTE GRAD)
(FUNCTION
(LAMBDA NIL
(ERLIST (QUOTE(SVGRADLIST ERROR)))))))))
SVGRADLIST))
EXPR)
(SETQ SVGRADLIST NIL)
(DEFPROP DIFFPLUS
(LAMBDA (E *X)
(SIMPLUS
(CONS
(QUOTE PLUS)
(MAPCAR (FUNCTION (LAMBDA (J)
(SDIFF J *X)))
(CDDR E)))
ONET
T))
EXPR)
(DEFPROP DIFFTIMES
(LAMBDA (E X) (SIMPLUS (CONS (QUOTE PLUS)
(SDT (CDDR E)
(CADR E)
X))
ONET
T))
EXPR)
(DEFPROP SDT
(LAMBDA (L C X)
(PROG (SP LEFT RITE OUT)
(SETQ SP (CAR L))
(SETQ RITE (CDR L))
LOOP (SETQ
OUT
(NCONC
OUT
(LIST
(SIMPTIMES
(CONS
(QUOTE TIMES)
(CONS C (CONS (SDIFF SP X)
(APPEND LEFT
RITE))))
ONET
T))))
(COND ((NULL RITE) (RETURN OUT)))
(SETQ LEFT (NCONC LEFT (LIST SP)))
(SETQ SP (CAR RITE))
(SETQ RITE (CDR RITE))
(GO LOOP)))
EXPR)
(DEFPROP DIFFEXPT
(LAMBDA (E X)
(COND
((TALKP (CADDR E))
(SIMPTIMES
(LIST (QUOTE TIMES)
(CADDR E)
(SIMPEXPT (LIST (QUOTE EXPT)
(CADR E)
(ADDK (CADDR E)
MONET))
ONET
T)
(SDIFF (CADR E) X))
ONET
T))
(T
(SIMPLUS
(LIST
(QUOTE PLUS)
(SIMPTIMES
(LIST
(QUOTE TIMES)
(SIMPEXPT
(LIST (QUOTE EXPT)
(CADR E)
(SIMPLUS (LIST (QUOTE PLUS)
(CADDR E)
MONET)
ONET
T))
ONET
T)
(CADDR E)
(SDIFF (CADR E) X))
ONET
T)
(SIMPTIMES
(LIST (QUOTE TIMES)
(SIMPEXPT (LIST (QUOTE EXPT)
(CADR E)
(CADDR E))
ONET
T)
(SIMPLN (LIST (QUOTE LOG)
(CADR E))
ONET
T)
(SDIFF (CADDR E) X))
ONET
T))
ONET
T))))
EXPR)
(DEFPROP DIFFEQUAL
(LAMBDA (E X)
(LIST (CAR E)
(SDIFF (CADR E) X)
(SDIFF (CADDR E) X)))
EXPR)
(DEFPROP PLUS DIFFPLUS DIFFFN)
(DEFPROP TIMES DIFFTIMES DIFFFN)
(DEFPROP EXPT DIFFEXPT DIFFFN)
(DEFPROP EQUAL DIFFEQUAL DIFFFN)
(QUOTE (FILE DIFR))
(DEFPROP A T SPECIAL)
(DEFPROP B T SPECIAL)
(DEFPROP D T SPECIAL)
(DEFPROP SP T SPECIAL)
(DEFPROP LP T SPECIAL)
(DEFPROP RP T SPECIAL)
(DEFPROP CO T SPECIAL)
(DEFPROP DIFFERROR
(LAMBDA (G)
(PROG
(A N B RES GR DR C D)
(SETQ A (CAR G))
(SETQ N (CDR G))
(SETQ B (MAKEVAR1 N))
(SETQ C B)
ASKA
(PRINLIST (APPEND (QUOTE (NEED GRADIENT
OF))
(LIST A)))
(PRINC (QUOTE #))
(SETQ RES (ERRSET(PRE)NIL))
(COND((NOT RES)(GO ASKA)))
(SETQ RES(CAR RES))
(COND
((EQUAL RES (QUOTE ASK)) (GO ASK))
((EQUAL RES (QUOTE ALLFORMAL))
(GO ALLFORM))
((EQUAL RES (QUOTE USEDEF)) (GO USEDF))
(T
(PRINLIST
(QUOTE (
RESPONSES
ARE
ASK
USEDEF
AND
ALLFORMAL)))))
(GO ASKA)
END(SETQ
GR
(MAPCAR
(FUNCTION (LAMBDA (X)
(SIMPLIFYA X NIL)))
GR))
(NCONC(COND
((EVAL(CONS(QUOTE AND)(MAPCAR(FUNCTION ONEVAR)GR)))GRADLIST)
(T SVGRADLIST) )(LIST A))
(SETQ GR (CONS B (LIST GR)))
(PUTPROP A GR (QUOTE GRAD))
(TERPRI)
(RETURN GR)
ALLFORM
(SETQ
GR
(APPEND
GR
(MAPCAR
(FUNCTION
(LAMBDA (X)
(CONS
(READLIST
(APPEND (QUOTE (D))
(CDR (EXPLODE X))
(EXPLODE A)))
B)))
C)))
(GO END)
ASK(TERPRI)
(PRINC (QUOTE CONSIDER))
(PRINC SP)
(PRINFUN A B)
ASK1
(COND ((NULL C) (GO END)))
(CHARYBDIS (LIST (QUOTE EQUAL)
(LIST (QUOTE DERIV)
(CONS A B)
(CAR C)
1)
SP)
1
(LINELENGTH NIL))
(PRINC (QUOTE #))
(SETQ RES
(ERRSET (UNQUOTE (PRE)) ERTALK))
(TERPRI)
(COND ((NULL RES) (GO ASK1)))
(SETQ RES (CAR RES))
(COND ((EQUAL RES (QUOTE FORMAL))
(GO FORM))
((EQUAL RES (QUOTE ALLFORMAL))
(GO ALLFORM))
(T (GO LOOP1)))
LOOP2
(SETQ C (CDR C))
(GO ASK1)
FORM
(COND ((NULL C) (GO END)))
(SETQ
DR
(CONS
(READLIST
(APPEND (QUOTE (D))
(CDR (EXPLODE (CAR C)))
(EXPLODE A)))
B))
(SETQ GR (APPEND GR (LIST DR)))
(GO LOOP2)
LOOP1
(SETQ GR (APPEND GR (LIST RES)))
(GO LOOP2)
USEDF
(SETQ D (MGET A))
(COND
((NOT (EQUAL (CAR D) (QUOTE LAMBDA)))
(ERLIST (CONS A (QUOTE (IS NOT
DEFINED)))))
((NOT (EQUAL N (LENGTH (CADR D))))
(ERLIST (QUOTE (WRONG NUMBER
OF
ARGUMENTS)))))
L1 (SETQ B (CADR D))
(SETQ D (CADDR D))
(SETQ
GR
(MAPCAR
(FUNCTION
(LAMBDA (X)
(EVAL (CONS (QUOTE DERIV)
(CONS D (LIST X))))))
B))
(GO END)))
EXPR)
(DEFPROP PRINFUN
(LAMBDA (FUN ARGS)
(PROG NIL
(PRINC FUN)
(PRINC LP)
LOOP (COND ((NULL (CDR ARGS))
(GO END)))
(PRINC (CAR ARGS))
(PRINC CO)
(SETQ ARGS (CDR ARGS))
(GO LOOP)
END (PRINC (CAR ARGS))
(PRINC RP)
(RETURN (TERPRI))))
EXPR)
(DEFPROP MAKEVAR
(LAMBDA (N) (READLIST (CONS (QUOTE X)
(EXPLODE N))))
EXPR)
(DEFPROP MAKEVAR1
(LAMBDA (N)
(PROG (J ARG)
(SETQ J 1)
LOOP (SETQ ARG
(APPEND ARG
(LIST (MAKEVAR J))))
(SETQ J (ADD1 J))
(COND ((GREATERP J N) (RETURN ARG)))
(GO LOOP)))
EXPR)
(DEFPROP ONEVAR(LAMBDA(X)(PROG
(FIRSTVAR)(RETURN(COND((ONEVAR1 X)T)(T NIL)))))EXPR)
(DEFPROP ONEVAR1(LAMBDA(X)(COND
((ATOM X)(COND
((NULL FIRSTVAR)(SETQ FIRSTVAR X))
((EQ X FIRSTVAR))
) )
((TALKP X)T)
((ONEVAR2(CDR X)))
))EXPR)
(DEFPROP ONEVAR2(LAMBDA(X)(COND
((NULL X)T)
((ONEVAR1(CAR X))(ONEVAR2(CDR X)))
(NIL)
))EXPR)