912 lines
26 KiB
Common Lisp
912 lines
26 KiB
Common Lisp
; File: COMMON.LSP 12/29/85 Soft Warehouse, Inc.
|
||
|
||
|
||
; COMMON LISP Library: This file defines the library functions
|
||
; referred to in Chapter 5 of the muLISP-86 Reference Manual.
|
||
|
||
|
||
; Section 5.1: Selector Functions
|
||
|
||
(MOVD 'LENGTH 'LIST-LENGTH)
|
||
|
||
|
||
; Section 5.2: Constructor Functions
|
||
|
||
(MOVD 'REVERSE 'REVAPPEND)
|
||
|
||
(SETQ *GENSYM-PREFIX* "G")
|
||
(SETQ *GENSYM-COUNT* 0)
|
||
|
||
(DEFUN GENSYM (ATM)
|
||
; (GENSYM) returns the symbol whose print name consists of *GENSYM-PREFIX*
|
||
; concatenated to *GENSYM-COUNT* and increments *GENSYM-COUNT*.
|
||
; (GENSYM symbol) sets *GENSYM-PREFIX* to <symbol>.
|
||
; (GENSYM integer) sets *GENSYM-COUNT* to <integer>.
|
||
( ((NULL ATM))
|
||
((SYMBOLP ATM)
|
||
(SETQ *GENSYM-PREFIX* ATM) )
|
||
((AND (INTEGERP ATM) (>= ATM 0))
|
||
(SETQ *GENSYM-COUNT* ATM) ) )
|
||
(PROG1 (PACK* *GENSYM-PREFIX* *GENSYM-COUNT*)
|
||
(INCQ *GENSYM-COUNT*)) )
|
||
|
||
|
||
; Section 5.3: Modifier Functions
|
||
|
||
(MOVD 'NREVERSE 'NRECONC)
|
||
(MOVD 'SORT 'STABLE-SORT)
|
||
|
||
|
||
; Section 5.4: Recognizer Functions
|
||
|
||
(MOVD 'SYMBOLP 'STRINGP)
|
||
(MOVD 'NUMBERP 'RATIONALP)
|
||
|
||
|
||
; Section 5.5: Comparator Functions
|
||
|
||
(MOVD 'EQUAL 'TREE-EQUAL)
|
||
|
||
|
||
; Section 5.7: Assignment Functions
|
||
|
||
(DEFMACRO SETF LST
|
||
((NULL LST) NIL)
|
||
((NULL (CDDR LST))
|
||
((ATOM (CAR LST))
|
||
(CONS 'SETQ LST) )
|
||
(MAKE-SET-FORM (CAR LST) (CADR LST)) )
|
||
(CONS 'PROGN (SETF-AUX LST)) )
|
||
|
||
(DEFUN SETF-AUX (LST)
|
||
((NULL LST) NIL)
|
||
((ATOM (CAR LST))
|
||
(CONS (LIST 'SETQ (CAR LST) (CADR LST)) (SETF-AUX (CDDR LST))) )
|
||
(CONS (MAKE-SET-FORM (CAR LST) (CADR LST)) (SETF-AUX (CDDR LST))) )
|
||
|
||
(DEFUN MAKE-SET-FORM (PLACE VALUE)
|
||
((EQ (CAR PLACE) 'CAR)
|
||
(LIST 'CAR (LIST 'RPLACA (CADR PLACE) VALUE)) )
|
||
((OR (EQ (CAR PLACE) 'CDR) (EQ (CAR PLACE) 'REST))
|
||
(LIST 'CDR (LIST 'RPLACD (CADR PLACE) VALUE)) )
|
||
((EQ (CAR PLACE) 'NTH)
|
||
(LIST 'CAR (LIST 'RPLACA (CONS 'NTHCDR (CDR PLACE)) VALUE)) )
|
||
((EQ (CAR PLACE) 'GET)
|
||
(LIST 'PUT (CADR PLACE) (CADDR PLACE) VALUE) )
|
||
((EQ (CAR PLACE) 'SYMBOL-FUNCTION)
|
||
(LIST 'PUTD (CADR PLACE) VALUE) )
|
||
((GET (CAR PLACE) 'CAR) (LIST 'CAR
|
||
(LIST 'RPLACA (LIST (GET (CAR PLACE) 'CAR) (CADR PLACE)) VALUE)) )
|
||
((GET (CAR PLACE) 'CDR) (LIST 'CDR
|
||
(LIST 'RPLACD (LIST (GET (CAR PLACE) 'CDR) (CADR PLACE)) VALUE)) )
|
||
((GET (CAR PLACE) 'NTH)
|
||
(LIST 'CAR (LIST 'RPLACA
|
||
(LIST 'NTHCDR (GET (CAR PLACE) 'NTH) (CADR PLACE))
|
||
VALUE)) )
|
||
((MACRO-FUNCTION-P (CAR PLACE))
|
||
(MAKE-SET-FORM (MACROEXPAND PLACE) VALUE) )
|
||
(BREAK (LIST 'SETF PLACE VALUE) "Invalid Place Form") )
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'CAR (CDR PAIR)))
|
||
'((CAAR . CAR) (CADR . CDR)
|
||
(CAAAR . CAAR) (CAADR . CADR) (CADAR . CDAR) (CADDR . CDDR)
|
||
(CAAAAR . CAAAR) (CAAADR . CAADR) (CAADAR . CADAR) (CAADDR . CADDR)
|
||
(CADAAR . CDAAR) (CADADR . CDADR) (CADDAR . CDDAR) (CADDDR . CDDDR)) )
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'CDR (CDR PAIR)))
|
||
'((CDAR . CAR) (CDDR . CDR)
|
||
(CDAAR . CAAR) (CDADR . CADR) (CDDAR . CDAR) (CDDDR . CDDR)
|
||
(CDAAAR . CAAAR) (CDAADR . CAADR) (CDADAR . CADAR) (CDADDR . CADDR)
|
||
(CDDAAR . CDAAR) (CDDADR . CDADR) (CDDDAR . CDDAR) (CDDDDR . CDDDR)) )
|
||
|
||
(MAPC '(LAMBDA (PAIR) (PUT (CAR PAIR) 'NTH (CDR PAIR)))
|
||
'((FIRST . 0) (SECOND . 1) (THIRD . 2) (FOURTH . 3) (FIFTH . 4)
|
||
(SIXTH . 5) (SEVENTH . 6) (EIGHTH . 7) (NINTH . 8) (TENTH . 9)) )
|
||
|
||
(DEFMACRO PUSHNEW (OBJ SYM TEST)
|
||
(LIST 'SETQ SYM (LIST 'ADJOIN OBJ SYM TEST)) )
|
||
|
||
|
||
; Section 5.10: Definition Primitives
|
||
|
||
(MOVD 'REMD 'FMAKUNBOUND)
|
||
|
||
|
||
; Section 5.11.1: Character Functions
|
||
|
||
(DEFUN DIGIT-CHAR-P (SYM N)
|
||
((SYMBOLP SYM)
|
||
( ((AND (INTEGERP N) (<= 2 N 36)))
|
||
(SETQ N 10) )
|
||
((NUMERIC-CHAR-P SYM)
|
||
(SETQ SYM (- (ASCII SYM) 48))
|
||
((< SYM N) SYM) )
|
||
((UPPER-CASE-P SYM)
|
||
(SETQ SYM (- (ASCII SYM) 55))
|
||
((< SYM N) SYM) ) ) )
|
||
|
||
(DEFUN CHAR-CODE (SYM)
|
||
((SYMBOLP SYM)
|
||
(ASCII SYM) ) )
|
||
|
||
(DEFUN CODE-CHAR (N)
|
||
((AND (INTEGERP N) (<= 0 N 255))
|
||
(ASCII N) ) )
|
||
|
||
|
||
; Section 5.11.2: String Functions
|
||
|
||
(DEFMACRO STRING-EQUAL (ATM1 ATM2)
|
||
(LIST 'STRING= ATM1 ATM2 T) )
|
||
|
||
(DEFMACRO STRING-LESSP (ATM1 ATM2)
|
||
(LIST 'STRING< ATM1 ATM2 T) )
|
||
|
||
(DEFMACRO STRING-GREATERP (ATM1 ATM2)
|
||
(LIST 'STRING> ATM1 ATM2 T) )
|
||
|
||
(DEFMACRO STRING-NOT-GREATERP (ATM1 ATM2)
|
||
(LIST 'STRING<= ATM1 ATM2 T) )
|
||
|
||
(DEFMACRO STRING-NOT-LESSP (ATM1 ATM2)
|
||
(LIST 'STRING>= ATM1 ATM2 T) )
|
||
|
||
(DEFMACRO STRING-NOT-EQUAL (ATM1 ATM2)
|
||
(LIST 'STRING/= ATM1 ATM2 T) )
|
||
|
||
|
||
; Section 5.12: Arithmetic Functions
|
||
|
||
(DEFMACRO INCF (PLACE N)
|
||
((NULL N)
|
||
((ATOM PLACE)
|
||
(LIST 'INCQ PLACE) )
|
||
(MAKE-SET-FORM PLACE (LIST 'ADD1 PLACE)) )
|
||
((ATOM PLACE)
|
||
(LIST 'INCQ PLACE N) )
|
||
(MAKE-SET-FORM PLACE (LIST '+ PLACE N)) )
|
||
|
||
(DEFMACRO DECF (PLACE N)
|
||
((NULL N)
|
||
((ATOM PLACE)
|
||
(LIST 'DECQ PLACE) )
|
||
(MAKE-SET-FORM PLACE (LIST 'SUB1 PLACE)) )
|
||
((ATOM PLACE)
|
||
(LIST 'DECQ PLACE N) )
|
||
(MAKE-SET-FORM PLACE (LIST '- PLACE N)) )
|
||
|
||
|
||
; Section 5.12.5: Irrational and Transcendental Functions
|
||
|
||
(DEFUN GET-CONSTANT (CONSTANT FORM)
|
||
;GET-CONSTANT returns the value of numerical constant, accurate to the
|
||
;current precision.
|
||
((EQL (PRECISION) (GET CONSTANT 'PRECISION))
|
||
(EVAL CONSTANT) )
|
||
(SET CONSTANT
|
||
(IF (AND (GET CONSTANT 'PRECISION)
|
||
(< (PRECISION) (GET CONSTANT 'PRECISION)) )
|
||
(/ (NUMERATOR (EVAL CONSTANT)) (DENOMINATOR (EVAL CONSTANT)))
|
||
(EVAL FORM) ))
|
||
(PUT CONSTANT 'PRECISION (PRECISION))
|
||
(EVAL CONSTANT) )
|
||
|
||
|
||
(DEFUN EXP (N)
|
||
;(EXP n) returns e^n, accurate to the current precision.
|
||
((NUMBERP N)
|
||
((ZEROP N) 1)
|
||
((PLUSP (PRECISION))
|
||
((MINUSP N)
|
||
(/ 1 (EXP (- N))) )
|
||
((= N 1)
|
||
(GET-CONSTANT 'E '(EXP-AUX 1)) )
|
||
((> N 1)
|
||
(LET ((Q (DIVIDE (NUMERATOR N) (DENOMINATOR N))))
|
||
(* (EXPT-AUX (GET-CONSTANT 'E '(EXP-AUX 1)) (CAR Q))
|
||
(EXP-AUX (/ (CDR Q) (DENOMINATOR N)))) ) )
|
||
(EXP-AUX N) )
|
||
(BREAK (LIST 'EXP N) "Infinite Precision") )
|
||
(BREAK (LIST 'EXP N) "Nonnumeric Argument") )
|
||
|
||
(DEFUN EXP-AUX (N
|
||
;If 0<n<=1, (EXP-AUX n) returns e^n, accurate to the current
|
||
;precision, using the fact that EXP (p/q) =
|
||
;((...(((q+p)2q+p^2)3q+p^3)4q+...+p^(m-1))mq + p^m) / (m! q^m),
|
||
P Q M TERM NUMR DENR PRECISION BITLENGTH )
|
||
(SETQ PRECISION (* 32 (PRECISION))
|
||
M 1
|
||
P (NUMERATOR N)
|
||
Q (DENOMINATOR N)
|
||
TERM P
|
||
NUMR (+ P Q)
|
||
DENR Q )
|
||
(LOOP
|
||
(INCQ M)
|
||
(SETQ TERM (* P TERM)
|
||
NUMR (+ TERM (* Q NUMR M))
|
||
DENR (* Q DENR M)
|
||
BITLENGTH (- PRECISION (INTEGER-LENGTH DENR)) )
|
||
( ((MINUSP BITLENGTH)
|
||
(SETQ TERM (SHIFT TERM BITLENGTH)
|
||
DENR (SHIFT DENR BITLENGTH)
|
||
NUMR (SHIFT NUMR BITLENGTH) ) ) )
|
||
((ZEROP TERM)
|
||
(/ NUMR DENR) ) ) )
|
||
|
||
(IF (PLUSP (PRECISION)) (EXP 1)) ;Initialize the variable E
|
||
|
||
|
||
(DEFUN EXPT (N M)
|
||
;(EXPT n m) returns n^m.
|
||
((AND (NUMBERP N) (NUMBERP M))
|
||
((ZEROP M) 1)
|
||
((ZEROP N)
|
||
((MINUSP M)
|
||
(BREAK (LIST 'EXPT N M) "Zero Divide") )
|
||
0 )
|
||
((MINUSP M)
|
||
(/ 1 (EXPT-AUX N (- M))) )
|
||
(EXPT-AUX N M) )
|
||
(BREAK (LIST 'EXPT N M) "Nonnumeric Argument") )
|
||
|
||
(DEFUN EXPT-AUX (N M
|
||
;If m>0, (EXPT-AUX n m) returns n^m. If m is a ratio the result may
|
||
;be only an approximation to n^m, accurate to the current precision.
|
||
ANS )
|
||
((= N 1) 1)
|
||
((INTEGERP M)
|
||
((= M 1) N)
|
||
(SETQ ANS 1)
|
||
(LOOP ;Binary power method
|
||
( ((ODDP M)
|
||
(SETQ ANS (* N ANS)) ) )
|
||
((ZEROP (SETQ M (SHIFT M -1))) ANS)
|
||
(SETQ N (* N N)) ) )
|
||
((PLUSP (PRECISION))
|
||
((MINUSP N)
|
||
((ODDP (DENOMINATOR M))
|
||
((EVENP (NUMERATOR M))
|
||
(EXP (* M (LN-AUX (- N)))) )
|
||
(- (EXP (* M (LN-AUX (- N))))) )
|
||
(BREAK (LIST 'EXPT N M) "Invalid Argument") )
|
||
(EXP (* M (LN-AUX N))) )
|
||
(BREAK (LIST 'EXPT N M) "Infinite Precision") )
|
||
|
||
|
||
(DEFUN LOG (N M)
|
||
;(LOG n m) returns base m logarithm of n. m defaults to e, the base
|
||
;of the natural logarithms.
|
||
(SETQ N (LN N))
|
||
((NULL M) N)
|
||
((ZEROP M) 0)
|
||
(/ N (LN M)) )
|
||
|
||
(DEFUN LN (N)
|
||
;(LN n) returns ln n, the natural logarithm of n.
|
||
((NUMBERP N)
|
||
((PLUSP N)
|
||
((= N 1) 0)
|
||
((PLUSP (PRECISION))
|
||
((= N 2)
|
||
(GET-CONSTANT 'LN2 '(LN-AUX 2)) )
|
||
(LN-AUX N) )
|
||
(BREAK (LIST 'LN N) "Infinite Precision") )
|
||
(BREAK (LIST 'LN N) "Invalid Argument") )
|
||
(BREAK (LIST 'LN N) "Nonnumeric Argument") )
|
||
|
||
(DEFUN LN-AUX (N
|
||
;If n>0, (LN-AUX n) returns ln n, accurate to the current precision,
|
||
;using the fact that with p/q = (x-1)/(x+1) = u,
|
||
;LN x = 2 (u + u^3/3 + u^5/5 + ... + u^m/m) =
|
||
;(...(((6pq^2 + 2p^3)5q^2 + 2 3p^5)7q^2 + 2 3 5p^7)9q^2 +
|
||
; ...+2 3 5 ...(m-2)p^m) / (3 5 ...m q^m),
|
||
P Q PLEN QLEN SHIFT M TERM NUMR DENR PRECISION BITLENGTH )
|
||
((= N 2)
|
||
(SETQ PRECISION (* 32 (PRECISION))
|
||
M 11
|
||
TERM 945
|
||
NUMR 638195436
|
||
DENR 1841443065 )
|
||
; LN 2 ~= (2/9) (1 + (1/9)/3 + (1/9)^2/5 + ... + (1/9)^m/(2m+1)) =
|
||
; 2 (...(((9 3 + 1)9 5 + 3)9 7 + 3 5)9 9 + ... + 3 5 ...(2m-1))
|
||
; / (3 5 ...(2m+1) 3^(2m+1)), with single-precision head start
|
||
(LOOP
|
||
(SETQ TERM (* M TERM)
|
||
M (+ M 2)
|
||
NUMR (+ TERM (* 9 M NUMR))
|
||
DENR (* 9 M DENR)
|
||
BITLENGTH (- PRECISION (INTEGER-LENGTH NUMR)) )
|
||
( ((MINUSP BITLENGTH)
|
||
(SETQ TERM (SHIFT TERM BITLENGTH)
|
||
NUMR (SHIFT NUMR BITLENGTH)
|
||
DENR (SHIFT DENR BITLENGTH) ) ) )
|
||
((ZEROP TERM)
|
||
(/ (SHIFT NUMR 1) DENR) ) ) )
|
||
((< (NUMERATOR N) (DENOMINATOR N))
|
||
(- (LN-AUX (/ 1 N))) )
|
||
(SETQ PRECISION (* 32 (PRECISION))
|
||
SHIFT 0
|
||
P (NUMERATOR N)
|
||
Q (DENOMINATOR N)
|
||
PLEN (INTEGER-LENGTH P)
|
||
QLEN (INTEGER-LENGTH Q) )
|
||
( ((> PLEN QLEN) ;Make 3/4 < N <= 3/2:
|
||
((> (SHIFT P 1) (* 3 Q))
|
||
(SETQ SHIFT (- PLEN QLEN))
|
||
((> PLEN PRECISION)
|
||
(SETQ P (SHIFT P (- PRECISION PLEN))
|
||
Q (SHIFT Q (- PRECISION QLEN)))
|
||
((> (SHIFT P 1) (* 3 Q))
|
||
(SETQ SHIFT (ADD1 SHIFT)
|
||
N (/ P (SHIFT Q 1))) )
|
||
((< (SHIFT P 2) (* 3 Q))
|
||
(SETQ SHIFT (SUB1 SHIFT)
|
||
N (/ P (SHIFT Q -1))) )
|
||
(SETQ N (/ P Q)) )
|
||
((> (SHIFT P 1) (* 3 (SETQ Q (SHIFT Q SHIFT))))
|
||
(SETQ SHIFT (ADD1 SHIFT)
|
||
N (/ P (SHIFT Q 1))) )
|
||
((< (SHIFT P 2) (* 3 Q))
|
||
(SETQ SHIFT (SUB1 SHIFT)
|
||
N (/ P (SHIFT Q -1))) )
|
||
(SETQ N (/ P Q)) ) )
|
||
((> (SHIFT P 1) (* 3 Q))
|
||
(SETQ SHIFT 1
|
||
N (/ P (SHIFT Q 1))) ) )
|
||
(SETQ N (/ (- (NUMERATOR N) (DENOMINATOR N))
|
||
(+ (NUMERATOR N) (DENOMINATOR N)))
|
||
PLEN (* N N)
|
||
P (NUMERATOR PLEN)
|
||
Q (DENOMINATOR PLEN)
|
||
NUMR (SHIFT (NUMERATOR N) 1)
|
||
TERM NUMR
|
||
DENR (DENOMINATOR N)
|
||
PRECISION (- PRECISION (INTEGER-LENGTH SHIFT))
|
||
M 1)
|
||
(LOOP
|
||
(SETQ TERM (* M TERM P)
|
||
M (+ M 2)
|
||
NUMR (+ TERM (* NUMR Q M))
|
||
DENR (* M Q DENR)
|
||
BITLENGTH (- PRECISION (INTEGER-LENGTH NUMR)))
|
||
( ((MINUSP BITLENGTH)
|
||
(SETQ TERM (SHIFT TERM BITLENGTH)
|
||
NUMR (SHIFT NUMR BITLENGTH)
|
||
DENR (SHIFT DENR BITLENGTH)) ) )
|
||
((ZEROP TERM)
|
||
((ZEROP SHIFT)
|
||
(/ NUMR DENR) )
|
||
(+ (* SHIFT (GET-CONSTANT 'LN2 '(LN-AUX 2))) (/ NUMR DENR)) ) ) )
|
||
|
||
(IF (PLUSP (PRECISION)) (LN 2)) ;Initialize the variable LN2
|
||
|
||
|
||
(DEFUN SQRT (N)
|
||
;If n is positive, (SQRT n) returns square root of n.
|
||
(EXPT N 1/2) )
|
||
|
||
|
||
(DEFUN ISQRT (N)
|
||
;If n is a nonnegative integer, (ISQRT n) returns the greatest integer
|
||
;less than or equal to the positive square root of n.
|
||
((INTEGERP N)
|
||
((>= N 0)
|
||
((= N 0) 0)
|
||
(ISQRT-AUX N) )
|
||
(BREAK (LIST 'ISQRT N) "Invalid Argument") )
|
||
(BREAK (LIST 'ISQRT N) "Noninteger Argument") )
|
||
|
||
(DEFUN ISQRT-AUX (N
|
||
;If n is a positive integer, (ISQRT-AUX n) returns the greatest integer
|
||
;less than or equal to n^(1/2). ISQRT-AUX uses Newton's method.
|
||
SHIFT INC ANS)
|
||
(SETQ ANS 1
|
||
INC 1
|
||
SHIFT (* (- (TRUNCATE (SUB1 (INTEGER-LENGTH N)) 2)) 2) )
|
||
(LOOP ;Start with 1-bit precision & repeatedly doubling
|
||
((ZEROP SHIFT))
|
||
(SETQ ANS (SHIFT ANS INC)
|
||
SHIFT (+ SHIFT (SHIFT INC 1))
|
||
ANS (+ ANS (FLOOR (- (SHIFT N SHIFT) (* ANS ANS)) (* 2 ANS)))
|
||
INC (MIN (SHIFT INC 1) (TRUNCATE (- SHIFT) 2)) ) )
|
||
((<= (* ANS ANS) N) ANS)
|
||
(SUB1 ANS) )
|
||
|
||
(DEFUN PI ()
|
||
;(PI) returns pi, accurate to the current precision.
|
||
((PLUSP (PRECISION))
|
||
(GET-CONSTANT 'PI '(PI-AUX)) )
|
||
(BREAK (CONS 'PI) "Infinite Precision") )
|
||
|
||
(DEFUN PI-AUX (
|
||
;(PI-AUX) returns pi, using the fact that 4/pi =
|
||
;SIGMA ((-1)^m (1123 + 21460 m) (1 3 ...(2m-1)) (1 3 ...(4m-1))
|
||
; / ((882^(2m+1) 32^m (m!)^3), m, 0, PINF), rearranged over a common
|
||
;denominator (Ramanujan, Quart. J. Pure & Appl. Math. 45, p. 350, 1914).
|
||
N M TERM NUMR DENR PRECISION BITLENGTH )
|
||
(SETQ PRECISION (* 32 (PRECISION))
|
||
M 0
|
||
N 1123
|
||
TERM 1
|
||
NUMR 3528
|
||
DENR N )
|
||
(LOOP
|
||
(INCQ M)
|
||
(SETQ N (+ N 21460)
|
||
TERM (* TERM (- (+ M M) 1) (- 1 (* 4 M)) (- (* 4 M) 3))
|
||
BITLENGTH (* M M M 24893568)
|
||
NUMR (* NUMR BITLENGTH)
|
||
DENR (+ (* DENR BITLENGTH) (* N TERM))
|
||
BITLENGTH (- (+ PRECISION (INTEGER-LENGTH N)) (INTEGER-LENGTH DENR)) )
|
||
( ((MINUSP BITLENGTH)
|
||
(SETQ TERM (SHIFT TERM BITLENGTH)
|
||
DENR (SHIFT DENR BITLENGTH)
|
||
NUMR (SHIFT NUMR BITLENGTH)) ) )
|
||
((ZEROP TERM)
|
||
(/ NUMR DENR) ) ) )
|
||
|
||
(IF (PLUSP (PRECISION)) (PI)) ;Initialize the variable PI
|
||
|
||
|
||
(DEFUN SIN (N
|
||
; (SIN n) returns the sine of n radians.
|
||
Q )
|
||
((NUMBERP N)
|
||
((ZEROP N) 0)
|
||
((PLUSP (PRECISION))
|
||
(SETQ Q (/ N (/ (PI) 4))
|
||
N (DIVIDE (NUMERATOR Q) (DENOMINATOR Q)))
|
||
(SINCOS (MOD (CAR N) 8) (/ (CDR N) (DENOMINATOR Q))) )
|
||
(BREAK (LIST 'SIN N) "Infinite Precision") )
|
||
(BREAK (LIST 'SIN N) "Nonnumeric Argument") )
|
||
|
||
(DEFUN COS (N
|
||
; (COS n) returns the cosine of n radians.
|
||
Q )
|
||
((NUMBERP N)
|
||
((ZEROP N) 1)
|
||
((PLUSP (PRECISION))
|
||
(SETQ Q (/ N (/ (PI) 4))
|
||
N (DIVIDE (NUMERATOR Q) (DENOMINATOR Q)))
|
||
(SINCOS (MOD (+ 2 (CAR N)) 8) (/ (CDR N) (DENOMINATOR Q))) )
|
||
(BREAK (LIST 'COS N) "Infinite Precision") )
|
||
(BREAK (LIST 'COS N) "Nonnumeric Argument") )
|
||
|
||
(DEFUN TAN (N)
|
||
; (TAN n) returns the tangent of n radians.
|
||
(/ (SIN N) (COS N)) )
|
||
|
||
|
||
(DEFUN SINCOS (N Q)
|
||
; Returns the sine or cosine of an appropriately reduced angle.
|
||
((> N 3)
|
||
(- (SINCOS (- N 4) Q)) )
|
||
((ZEROP N)
|
||
(SETQ Q (* Q (/ (PI) 4)))
|
||
(SINCOS-AUX Q 1 (NUMERATOR Q) (DENOMINATOR Q)) )
|
||
((EQ N 1)
|
||
(SINCOS-AUX (* (- 1 Q) (/ (PI) 4)) 0 1 1) )
|
||
((EQ N 2)
|
||
(SINCOS-AUX (* Q (/ (PI) 4)) 0 1 1) )
|
||
(SETQ Q (* (- 1 Q) (/ (PI) 4)))
|
||
(SINCOS-AUX Q 1 (NUMERATOR Q) (DENOMINATOR Q)) )
|
||
|
||
(DEFUN SINCOS-AUX (ARG N NUMR DENR
|
||
; (SIN1 n) returns the sine of n radians, where 0 <= n <= pi/4 radians.
|
||
; SIN (x=p/q) ~= x - x^3/3! + x^5/5! - ... +|- x^n/n! =
|
||
; ((...((2*3pq^2 - p^3)4*5q^2 + p^5)6*7q^2 - ...)(n-1)nq^2 +|- p^n) / (n! q^n)
|
||
; (COS1 n) returns the cosine of n radians, where 0 <= n <= pi/4 radians.
|
||
; COS (x=p/q) ~= 1 - x^2/2! + x^3/3! - ... +|- x^n/n! =
|
||
; ((...((2q^2 - p^2)3*4q^2 + p^4)5*6q^2 - ...)(n-1)nq^2 +|- p^n) / (n! q^n)
|
||
MNARGSQ DARGSQ TERM PRECISION BITLENGTH )
|
||
(SETQ PRECISION (* 32 (PRECISION))
|
||
DARGSQ (* ARG ARG)
|
||
MNARGSQ (- (NUMERATOR DARGSQ))
|
||
DARGSQ (DENOMINATOR DARGSQ)
|
||
TERM NUMR)
|
||
(LOOP
|
||
(SETQ N (+ N 2)
|
||
ARG (* (SUB1 N) N)
|
||
DENR (* ARG DARGSQ DENR)
|
||
TERM (* MNARGSQ TERM)
|
||
NUMR (+ (* ARG DARGSQ NUMR) TERM)
|
||
BITLENGTH (- PRECISION (INTEGER-LENGTH NUMR)))
|
||
( ((MINUSP BITLENGTH)
|
||
(SETQ TERM (SHIFT TERM BITLENGTH)
|
||
NUMR (SHIFT NUMR BITLENGTH)
|
||
DENR (SHIFT DENR BITLENGTH)) ) )
|
||
((ZEROP TERM)
|
||
(/ NUMR DENR) ) ) )
|
||
|
||
|
||
(DEFUN ASIN (N)
|
||
; (ASIN n) returns the inverse sine of n in radians. Note that
|
||
; for all -1 <= n <= 1, -pi/2 <= (ASIN n) <= pi/2.
|
||
((NUMBERP N)
|
||
((PLUSP (PRECISION))
|
||
((MINUSP N)
|
||
(- (ASIN (- N))) )
|
||
((= N 1)
|
||
(/ (PI) 2) )
|
||
((< N 1)
|
||
(ATAN (NUMERATOR N)
|
||
(SQRT (* (- (DENOMINATOR N) (NUMERATOR N))
|
||
(+ (DENOMINATOR N) (NUMERATOR N))))) )
|
||
(BREAK (LIST 'ASIN N) "Invalid Argument") )
|
||
(BREAK (LIST 'ASIN N) "Infinite Precision") )
|
||
(BREAK (LIST 'ASIN N) "Nonnumeric Argument") )
|
||
|
||
(DEFUN ACOS (N)
|
||
; (ACOS n) returns the inverse cosine of n in radians. Note that
|
||
; for all -1 <= n <= 1, 0 <= (ACOS n) <= pi.
|
||
((NUMBERP N)
|
||
((= N 1) 0)
|
||
((PLUSP (PRECISION))
|
||
((= N -1)
|
||
(PI) )
|
||
((<= -1 N 1)
|
||
((< (ABS N) 1)
|
||
(ATAN (SQRT (* (- (DENOMINATOR N) (NUMERATOR N))
|
||
(+ (DENOMINATOR N) (NUMERATOR N)) ))
|
||
(NUMERATOR N)) ) )
|
||
(BREAK (LIST 'ACOS N) "Invalid Argument") )
|
||
(BREAK (LIST 'ACOS N) "Infinite Precision") )
|
||
(BREAK (LIST 'ACOS N) "Nonnumeric Argument") )
|
||
|
||
|
||
(DEFUN ATAN (N M
|
||
; (ATAN n m) returns in radians the angle corresponding to the vector
|
||
; whose opposite component is n and whose adjacent component is m.
|
||
; m defaults to 1. Note that for all n and m, -pi < (ATAN n m) <= pi.
|
||
; With v = x/(1+x^2) = r/s, u = xv = p/q, ATAN (x) ~=
|
||
; (1 + 2u/3 + 2 4u^2/(3 5) +...+ 2 4 ...(2n)u^n/(3 5 ...(2n+1))) v =
|
||
; ((...((3rq + 2rp)5q + 2 4rp^2)7q +...)(2n+1)q + 2 4 ...(2n)rp^n)
|
||
; / (3 5 ...(2n+1)sq^n)
|
||
INDX NUMR TERM DENR NARG DARG PRECISION BITLENGTH )
|
||
((PLUSP (PRECISION))
|
||
((NUMBERP N)
|
||
((NUMBERP M) ;Reduce two-argument case to one argument
|
||
((PLUSP M)
|
||
(ATAN (/ N M)) )
|
||
((ZEROP M)
|
||
((PLUSP N)
|
||
(/ (PI) 2) )
|
||
((MINUSP N)
|
||
(/ (PI) -2) )
|
||
(BREAK (LIST 'ATAN N M) "Invalid Argument") )
|
||
((ZEROP N)
|
||
(PI) )
|
||
((MINUSP N)
|
||
(- (/ (PI) -2) (ATAN (/ M N))) )
|
||
(+ (/ (PI) 2) (ATAN (/ (- M) N))) )
|
||
((NULL M)
|
||
((MINUSP N)
|
||
(- (ATAN (- N))) )
|
||
((> N 1)
|
||
(- (/ (PI) 2) (ATAN (/ 1 N))) )
|
||
(SETQ PRECISION (* 32 (PRECISION))
|
||
M (/ N (ADD1 (* N N)))
|
||
N (* N M)
|
||
NARG (NUMERATOR N)
|
||
DARG (DENOMINATOR N)
|
||
INDX 1
|
||
NUMR (NUMERATOR M)
|
||
TERM NUMR
|
||
DENR (DENOMINATOR M) )
|
||
(LOOP
|
||
(INCQ INDX 2)
|
||
(SETQ TERM (* (SUB1 INDX) NARG TERM)
|
||
NUMR (+ TERM (* INDX DARG NUMR))
|
||
DENR (* INDX DARG DENR)
|
||
BITLENGTH (- PRECISION (INTEGER-LENGTH NUMR)))
|
||
( ((MINUSP BITLENGTH)
|
||
(SETQ NUMR (SHIFT NUMR BITLENGTH)
|
||
DENR (SHIFT DENR BITLENGTH)
|
||
TERM (SHIFT TERM BITLENGTH)) ) )
|
||
((ZEROP TERM)
|
||
(/ NUMR DENR) ) ) )
|
||
(BREAK (LIST 'ATAN N M) "Nonnumeric Argument") )
|
||
(BREAK (LIST 'ATAN N M) "Nonnumeric Argument") )
|
||
(BREAK (LIST 'ATAN N M) "Infinite Precision") )
|
||
|
||
|
||
; Section 5.12.7: Bitwise Logical Functions
|
||
|
||
(MOVD 'SHIFT 'ASH)
|
||
|
||
|
||
; Section 5.12.8: Random Numbers
|
||
|
||
(DEFUN RANDOM (N STATE
|
||
BL COUNT ANS)
|
||
(IF (RANDOM-STATE-P STATE)
|
||
(SETQ *RANDOM-STATE* STATE) )
|
||
(SETQ *RANDOM-STATE*
|
||
(LOGAND (ADD1 (* 3141592653 *RANDOM-STATE*)) 4294967295))
|
||
((AND (INTEGERP N) (PLUSP N))
|
||
(SETQ ANS *RANDOM-STATE*
|
||
BL (- -10 (INTEGER-LENGTH N))
|
||
COUNT 0)
|
||
(LOOP ; concatenate 32-bit random integers
|
||
((> BL (DECQ COUNT 32))
|
||
(SHIFT (* N ANS) COUNT) )
|
||
(SETQ *RANDOM-STATE*
|
||
(LOGAND (ADD1 (* 3141592653 *RANDOM-STATE*)) 4294967295)
|
||
ANS (+ (SHIFT ANS 32) *RANDOM-STATE*)) ) )
|
||
((NUMBERP N)
|
||
(SETQ ANS (SHIFT 1 (- (* 32 (MAX (PRECISION) 1)) 10)))
|
||
(/ (* (ABS N) (RANDOM ANS)) ANS) ) )
|
||
|
||
(DEFUN MAKE-RANDOM-STATE (STATE)
|
||
((NULL STATE) *RANDOM-STATE*)
|
||
((EQ STATE 'T)
|
||
(TIME) )
|
||
((RANDOM-STATE-P STATE) STATE) )
|
||
|
||
(SETQ *RANDOM-STATE* (MAKE-RANDOM-STATE 'T))
|
||
|
||
(DEFUN RANDOM-STATE-P (OBJ)
|
||
(AND (INTEGERP OBJ) (>= OBJ 0)) )
|
||
|
||
|
||
; Section 5.13.2: Input Functions
|
||
|
||
(SETQ *LPAR* '\()
|
||
(SETQ *RPAR* '\))
|
||
|
||
(DEFUN READ-BACKQUOTE (
|
||
; This backquote facility conforms to the Common LISP standard except
|
||
; that nested backquote forms are not supported. See Section 22.1.3
|
||
; of Common LISP by Steele [1984].
|
||
CHAR FORM-LIST )
|
||
(SETQ CHAR (PEEK-CHAR T))
|
||
((EQ CHAR '\,)
|
||
(READ-CHAR)
|
||
(SETQ CHAR (PEEK-CHAR))
|
||
((OR (EQ CHAR '\@) (EQ CHAR '\.))
|
||
(BREAK CHAR "Syntax Error") )
|
||
(READ) )
|
||
((NEQ CHAR *LPAR*)
|
||
(LIST 'QUOTE (READ)) )
|
||
(READ-CHAR)
|
||
(LOOP
|
||
(SETQ CHAR (PEEK-CHAR T))
|
||
((EQ CHAR *RPAR*)
|
||
(READ-CHAR)
|
||
((NULL FORM-LIST) NIL)
|
||
((NULL (CDR FORM-LIST))
|
||
(CAR FORM-LIST) )
|
||
(CONS 'NCONC (NREVERSE FORM-LIST)) )
|
||
((EQ CHAR '\.)
|
||
(READ-CHAR)
|
||
(SETQ CHAR (PEEK-CHAR T))
|
||
((EQ CHAR '\,)
|
||
(READ-CHAR)
|
||
(SETQ CHAR (PEEK-CHAR))
|
||
((OR (EQ CHAR '\@) (EQ CHAR '\.))
|
||
(BREAK CHAR "Syntax Error") )
|
||
(PUSH (READ) FORM-LIST)
|
||
((EQ (READ-CHAR) *RPAR*)
|
||
(CONS 'NCONC (NREVERSE FORM-LIST)) )
|
||
(BREAK '\. "Syntax Error") )
|
||
(PUSH (READ-BACKQUOTE) FORM-LIST)
|
||
((EQ (READ-CHAR) *RPAR*)
|
||
(CONS 'NCONC (NREVERSE FORM-LIST)) )
|
||
(BREAK '\. "Syntax Error") )
|
||
( ((EQ CHAR '\,)
|
||
(READ-CHAR)
|
||
(SETQ CHAR (PEEK-CHAR))
|
||
((EQ CHAR '\@)
|
||
(READ-CHAR)
|
||
(PUSH (READ) FORM-LIST)
|
||
((EQ (PEEK-CHAR T) *RPAR*))
|
||
(PUSH (LIST 'COPY-LIST (POP FORM-LIST)) FORM-LIST) )
|
||
((EQ CHAR '\.)
|
||
(READ-CHAR)
|
||
(PUSH (READ) FORM-LIST) )
|
||
(PUSH (LIST 'LIST (READ)) FORM-LIST) )
|
||
(PUSH (LIST 'LIST (READ-BACKQUOTE)) FORM-LIST) ) ) )
|
||
|
||
(SET-MACRO-CHAR '\` '(LAMBDA ()
|
||
(READ-BACKQUOTE) ))
|
||
|
||
|
||
; Section 5.15.1: Evaluation Recognizers
|
||
|
||
(DEFUN EVAL-FUNCTION-P (SYM)
|
||
(EQ (GETD SYM T) 'LAMBDA) )
|
||
|
||
(DEFUN NO-EVAL-FUNCTION-P (SYM)
|
||
(EQ (GETD SYM T) 'NLAMBDA) )
|
||
|
||
(DEFUN MACRO-FUNCTION-P (SYM)
|
||
(EQ (GETD SYM T) 'MACRO) )
|
||
|
||
(DEFUN SPECIAL-FORM-P (SYM)
|
||
(EQ (GETD SYM T) 'SPECIAL) )
|
||
|
||
(DEFUN FBOUNDP (SYM)
|
||
(GETD SYM T) )
|
||
|
||
(DEFUN FUNCTIONP (OBJ)
|
||
((SYMBOLP OBJ))
|
||
((ATOM OBJ) NIL)
|
||
(EQ (CAR OBJ) 'LAMBDA) )
|
||
|
||
|
||
; Section 5.15.2: Evaluation and Function Application
|
||
|
||
(DEFUN SYMBOL-VALUE (SYM)
|
||
((SYMBOLP SYM)
|
||
(CAR SYM) ) )
|
||
|
||
(DEFUN SYMBOL-PLIST (SYM)
|
||
((SYMBOLP SYM)
|
||
(CDR SYM) ) )
|
||
|
||
(DEFUN SYMBOL-FUNCTION (SYM)
|
||
((SYMBOLP SYM)
|
||
((FBOUNDP SYM)
|
||
(GETD SYM) )
|
||
(BREAK (LIST 'SYMBOL-FUNCTION SYM) "Undefined Function") ) )
|
||
|
||
|
||
; Section 5.15.3: Macro Expansion Functions
|
||
|
||
(DEFUN MACRO-FUNCTION (SYM)
|
||
((MACRO-FUNCTION-P SYM)
|
||
(GETD SYM) ) )
|
||
|
||
|
||
; Section 5.16: Control Constructs
|
||
|
||
(DEFMACRO PROG2 (FORM1 . FORMS)
|
||
(LIST 'PROGN FORM1 (CONS 'PROG1 FORMS)) )
|
||
|
||
(DEFMACRO WHEN (TEST . BODY)
|
||
(LIST 'IF TEST (CONS 'PROGN BODY)) )
|
||
|
||
(DEFMACRO UNLESS (TEST . BODY)
|
||
(LIST 'IF TEST NIL (CONS 'PROGN BODY)) )
|
||
|
||
(DEFMACRO LET (LETLIST . BODY)
|
||
(CONS (LIST* 'LAMBDA
|
||
(MAPCAR 'CAR LETLIST)
|
||
BODY)
|
||
(MAPCAR 'CADR LETLIST)) )
|
||
|
||
(DEFMACRO LET* (LETLIST . BODY)
|
||
(LIST (LIST* 'LAMBDA
|
||
(MAPCAR 'CAR LETLIST)
|
||
(CONS 'SETQ
|
||
(MAPCAN '(LAMBDA (LST) (LIST (CAR LST) (CADR LST)))
|
||
LETLIST))
|
||
BODY)) )
|
||
|
||
(DEFMACRO DO (LETLIST . BODY)
|
||
(CONS (LIST 'LAMBDA
|
||
(MAPCAR '(LAMBDA (VAR) (IF (ATOM VAR) VAR (CAR VAR))) LETLIST)
|
||
(CONS 'LOOP
|
||
(APPEND BODY (LIST (CONS 'PSETQ
|
||
(MAPCAN '(LAMBDA (VAR)
|
||
((ATOM VAR) NIL)
|
||
((CADDR VAR)
|
||
(LIST (CAR VAR) (CADDR VAR)) ) )
|
||
LETLIST))))))
|
||
(MAPCAR '(LAMBDA (VAR) (IF (ATOM VAR) NIL (CADR VAR))) LETLIST)) )
|
||
|
||
(DEFMACRO DO* (LETLIST . BODY)
|
||
(LIST (LIST 'LAMBDA
|
||
(MAPCAR '(LAMBDA (VAR) (IF (ATOM VAR) VAR (CAR VAR)))
|
||
LETLIST)
|
||
(CONS 'SETQ
|
||
(MAPCAN '(LAMBDA (VAR)
|
||
((ATOM VAR)
|
||
(LIST VAR NIL) )
|
||
(LIST (CAR VAR) (CADR VAR)))
|
||
LETLIST))
|
||
(CONS 'LOOP
|
||
(APPEND BODY (LIST (CONS 'SETQ
|
||
(MAPCAN '(LAMBDA (VAR)
|
||
((ATOM VAR) NIL)
|
||
((CADDR VAR)
|
||
(LIST (CAR VAR) (CADDR VAR)) ) )
|
||
LETLIST))))))) )
|
||
|
||
(DEFMACRO DOLIST ((VAR LISTFORM RSLTFORM) . BODY)
|
||
(LET ((DOLIST (GENSYM)))
|
||
(LIST 'LET
|
||
(LIST (LIST DOLIST LISTFORM))
|
||
(LIST* 'LOOP
|
||
(LIST (LIST 'ATOM DOLIST) RSLTFORM)
|
||
(LIST 'SETQ VAR (LIST 'POP DOLIST))
|
||
BODY)) ) )
|
||
|
||
(DEFMACRO DOTIMES ((VAR COUNTFORM RSLTFORM) . BODY)
|
||
(LET ((DOTIMES (GENSYM)))
|
||
(LIST 'LET
|
||
(LIST (LIST VAR 0)
|
||
(LIST DOTIMES COUNTFORM))
|
||
(LIST* 'LOOP
|
||
(LIST (LIST '>= VAR DOTIMES) RSLTFORM)
|
||
(APPEND BODY (LIST (LIST 'INCQ VAR))))) ) )
|
||
|
||
|
||
; PROG [var-list, expn1, expn2, ..., expnm] sets the local variables
|
||
; in <var-list> to NIL and sequentially evaluates <expn1> through <expnm>,
|
||
; unless the functions GO or RETURN are encountered. This PROG interpreter
|
||
; is included for completeness. We strongly recommend that functions using
|
||
; PROG be translated into equivalent muLISP functions using the LOOP
|
||
; construct, since the resulting function will be much more efficient.
|
||
|
||
(DEFUN PROG (NLAMBDA LST$
|
||
(EVAL (LIST (CONS 'LAMBDA (LIST (CAR LST$) (LIST 'PROG-AUX
|
||
'(CDR LST$)))))) ))
|
||
|
||
(DEFUN PROG-AUX (BDY$
|
||
LST$ GO-LABEL$ ANS$)
|
||
(SETQ LST$ BDY$)
|
||
(LOOP
|
||
((NULL LST$) ANS$)
|
||
(SETQ ANS$ (EVAL (POP LST$)))
|
||
( ((NULL GO-LABEL$))
|
||
(SETQ LST$ (CDR (MEMBER GO-LABEL$ BDY$))
|
||
GO-LABEL$) ) ) )
|
||
|
||
|
||
;GO [label] if within a PROG, transfers control to the expression in
|
||
;the PROG body immediately following <label>.
|
||
|
||
(DEFUN GO (NLAMBDA (LABEL$)
|
||
(SETQ GO-LABEL$ LABEL$) ))
|
||
|
||
|
||
(SETQ *COMMMAND-DRIVE* "")
|
||
|
||
(DEFUN DOS (COMMAND
|
||
; (DOS command) executes the MS-DOS <command>, and returns the exit code.
|
||
; If the MS-DOS command processor is not on the default drive, the user
|
||
; is prompted for the drive containing COMMAND.COM. See the EXECUTE
|
||
; function in Section 5.16 for an example using DOS.
|
||
READ-CHAR RDS WRS )
|
||
(LOOP
|
||
((EXECUTE (PACK* *COMMAND-DRIVE* "COMMAND.COM")
|
||
(IF COMMAND (PACK* "/C " COMMAND))))
|
||
(FRESH-LINE)
|
||
(WRITE-STRING "Enter COMMAND.COM drive letter: ")
|
||
(SETQ *COMMAND-DRIVE* (PRINC (CHAR-UPCASE (READ-CHAR))))
|
||
(TERPRI)
|
||
((NOT (ALPHA-CHAR-P *COMMAND-DRIVE*)) NIL)
|
||
(SETQ *COMMAND-DRIVE* (PACK* *COMMAND-DRIVE* '\:)) ) )
|
||
|
||
|
||
; Section 22.4: Querying the User
|
||
|
||
(DEFUN Y-OR-N-P (MSG
|
||
CHAR READ-CHAR RDS WRS )
|
||
( ((NULL MSG))
|
||
(FRESH-LINE)
|
||
(WRITE-STRING (PACK* MSG " (Y/N) ")) )
|
||
(CLEAR-INPUT)
|
||
(LOOP
|
||
(SETQ CHAR (CHAR-UPCASE (READ-CHAR)))
|
||
((EQ CHAR 'Y) (WRITE-LINE CHAR) T)
|
||
((EQ CHAR 'N) (WRITE-LINE CHAR) NIL)
|
||
(WRITE-BYTE 7) ) )
|
||
|
||
(DEFUN YES-OR-NO-P (MSG
|
||
LINE READ-CHAR RDS WRS )
|
||
(SETQ READ-CHAR T)
|
||
(CLEAR-INPUT)
|
||
(LOOP
|
||
( ((NULL MSG))
|
||
(FRESH-LINE)
|
||
(WRITE-STRING (PACK* MSG " (Yes or No) ")) )
|
||
(WRITE-BYTE 7)
|
||
(SETQ LINE (CHAR-UPCASE (READ-LINE)))
|
||
((EQ LINE 'YES) T)
|
||
((EQ LINE 'NO) NIL) ) )
|
||
|
||
(RDS)
|
||
|