DataMuseum.dk

top - metrics - download

    Length: 9379 (0x24a3)
    Types: TextFile
    Names: »narith.scm.26«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/narith.scm.26« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, and to use it for any
;;;	purpose is granted, subject to the following restrictions and
;;;	understandings.
;;;
;;;	1. Any copy made of this software must include this copyright
;;;	notice in full.
;;;
;;;	2. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;

;;;; Scheme Arithmetic

(declare (usual-integrations))
\f


(define zero? (make-primitive-procedure 'ZERO?))
(define positive? (make-primitive-procedure 'POSITIVE?))
(define negative? (make-primitive-procedure 'NEGATIVE?))

(define 1+ (make-primitive-procedure '1+))
(define -1+ (make-primitive-procedure '-1+))

(define integer-divide (make-primitive-procedure 'INTEGER-DIVIDE))
(define integer-divide-quotient (make-primitive-procedure 'CAR))
(define integer-divide-remainder (make-primitive-procedure 'CDR))
(define (quotient x y) (integer-divide-quotient (integer-divide x y)))
(define (remainder x y) (integer-divide-remainder (integer-divide x y)))
(define (even? x) (zero? (integer-divide-remainder (integer-divide x 2))))
(define (odd? x) (= (integer-divide-remainder (integer-divide x 2)) 1))

(define sqrt (make-primitive-procedure 'SQRT))
(define exp (make-primitive-procedure 'EXP))
(define log (make-primitive-procedure 'LOG))
(define sin (make-primitive-procedure 'SIN))
(define cos (make-primitive-procedure 'COS))

(define truncate (make-primitive-procedure 'TRUNCATE))
(define round (make-primitive-procedure 'ROUND))
(define floor (make-primitive-procedure 'FLOOR))
(define ceiling (make-primitive-procedure 'CEILING))

(define integer?)
(define number?)

(define =)
(define <)
(define >)
(define <=)
(define >=)

(define +)
(define -)
(define *)
(define /)

(define abs)

(define integer-expt)
(define expt)

(define tan)
(define atan)

(define min)
(define max)

(define random)
(define randomize)
\f


(let ((fixnum-type (microcode-type 'FIXNUM))
      (bignum-type (microcode-type 'BIGNUM))
      (flonum-type (microcode-type 'FLONUM))
      (&= (make-primitive-procedure '&=))
      (&< (make-primitive-procedure '&<))
      (&> (make-primitive-procedure '&>))
      (&+ (make-primitive-procedure '&+))
      (&- (make-primitive-procedure '&-))
      (&* (make-primitive-procedure '&*))
      (&/ (make-primitive-procedure '&/))
      (&atan (make-primitive-procedure '&ATAN)))

(declare (compilable-primitive-functions
	  &= &< &> &+ &- &* &/ &atan
	  zero? positive? negative? 1+ -1+ integer-divide
	  (integer-divide-quotient car) (integer-divide-remainder cdr)
	  sqrt exp log sin cos truncate round floor ceiling))


(set! integer?
      (named-lambda (integer? object)
	(disjunction (primitive-type? fixnum-type object)
		     (primitive-type? bignum-type object))))

(set! number?
      (named-lambda (number? object)
	(disjunction (primitive-type? fixnum-type object)
		     (primitive-type? bignum-type object)
		     (primitive-type? flonum-type object))))
\f


;;;; Order Operations

(let-syntax
 ((define-pairwise-test
   (macro (name p)
     `(SET! ,name
	    (NAMED-LAMBDA (,name . ARGUMENTS)
	      (COND ((NULL? ARGUMENTS)
		     #!FALSE)
		    ((NULL? (CDR ARGUMENTS))
		     #!FALSE)
		    ((NULL? (GENERAL-CAR-CDR ARGUMENTS #b100))
		     (,p (CAR ARGUMENTS)
			 (GENERAL-CAR-CDR ARGUMENTS #b110)))
		    (ELSE
		     (LET TEST-LOOP
		       ((RESULT (,p (CAR ARGUMENTS)
				    (GENERAL-CAR-CDR ARGUMENTS #b110)))
			(CDR1 (CDR ARGUMENTS))
			(CDR2 (GENERAL-CAR-CDR ARGUMENTS #b100)))
		       (IF RESULT
			   (IF (NULL? CDR2)
			       #!TRUE
			       (TEST-LOOP (,p (CAR CDR1) (CAR CDR2))
					  CDR2
					  (CDR CDR2)))
			   #!FALSE)))))))))
 (define-pairwise-test = &=)
 (define-pairwise-test < &<)
 (define-pairwise-test > &>))

(let-syntax
 ((define-pairwise-test
   (macro (name p)
     `(SET! ,name
	    (NAMED-LAMBDA (,name . ARGUMENTS)
	      (COND ((NULL? ARGUMENTS)
		     #!FALSE)
		    ((NULL? (CDR ARGUMENTS))
		     #!FALSE)
		    ((NULL? (GENERAL-CAR-CDR ARGUMENTS #b100))
		     (NOT (,p (CAR ARGUMENTS)
			      (GENERAL-CAR-CDR ARGUMENTS #b110))))
		    (ELSE
		     (LET TEST-LOOP
		       ((RESULT (,p (CAR ARGUMENTS)
				    (GENERAL-CAR-CDR ARGUMENTS #b110)))
			(CDR1 (CDR ARGUMENTS))
			(CDR2 (GENERAL-CAR-CDR ARGUMENTS #b100)))
		       (IF RESULT
			   #!FALSE
			   (IF (NULL? CDR2)
			       #!TRUE
			       (TEST-LOOP (,p (CAR CDR1) (CAR CDR2))
					  CDR2
					  (CDR CDR2))))))))))))
 (define-pairwise-test <= &>)
 (define-pairwise-test >= &<))
\f


;;;; Field Operations

(let-syntax
 ((define-right-accumulation
   (macro (name f i)
     `(SET! ,name
	    (NAMED-LAMBDA (,name . ARGUMENTS)
	      (COND ((NULL? ARGUMENTS)
		     ,i)
		    ((NULL? (CDR ARGUMENTS))
		     (CAR ARGUMENTS))
		    ((NULL? (GENERAL-CAR-CDR ARGUMENTS #b100))
		     (,f (CAR ARGUMENTS)
			 (GENERAL-CAR-CDR ARGUMENTS #b110)))
		    (ELSE
		     (LET ACCUMULATION-LOOP
		       ((ARGUMENTS (GENERAL-CAR-CDR ARGUMENTS #b100))
			(ACCUMULATOR (,f (CAR ARGUMENTS)
					 (GENERAL-CAR-CDR ARGUMENTS #b110))))
		       (IF (NULL? ARGUMENTS)
			   ACCUMULATOR
			   (ACCUMULATION-LOOP (CDR ARGUMENTS)
					      (,f (CAR ARGUMENTS)
						  ACCUMULATOR)))))))))))
 (define-right-accumulation + &+ 0)
 (define-right-accumulation * &* 1))

(let-syntax
 ((define-right-accumulation
    (macro (name f f-1 i)
      `(SET! ,name
	     (NAMED-LAMBDA (,name X . REST)
	       (COND ((NULL? REST)
		      (,f ,i X))
		     ((NULL? (CDR REST))
		      (,f X (CAR REST)))
		     (ELSE
		      (LET ACCUMULATION-LOOP
			((ARGUMENTS (GENERAL-CAR-CDR REST #b100))
			 (ACCUMULATOR (,f-1 (CAR REST)
					    (GENERAL-CAR-CDR REST #b110))))
			(IF (NULL? ARGUMENTS)
			    (,f X ACCUMULATOR)
			    (ACCUMULATION-LOOP (CDR ARGUMENTS)
					       (,f-1 (CAR ARGUMENTS)
						     ACCUMULATOR)))))))))))
 (define-right-accumulation - &- &+ 0)
 (define-right-accumulation / &/ &* 1))
\f


;;;; Other Operations

(set! expt
      (named-lambda (expt x y)
	(if (integer? y)
	    (integer-expt x y)
	    (exp (&* (log x) y)))))

(set! integer-expt
      (named-lambda (integer-expt base exponent)
	(if (not (integer? exponent))
	    (error "Non-integer exponent" 'INTEGER-EXPT exponent))
	(if (negative? exponent)
	    (&/ 1 (expt-iter base (&- 0 exponent) 1))
	    (expt-iter base exponent 1))))

(define (expt-iter x count answer)
  (if (zero? count)
      answer
      (let ((qr (integer-divide count 2)))
	(if (zero? (integer-divide-remainder qr))
	    (expt-iter (&* x x) (integer-divide-quotient qr) answer)
	    (expt-iter x (-1+ count) (&* x answer))))))

(set! tan
      (named-lambda (tan x)
	(&/ (sin x) (cos x))))

(set! atan
      (named-lambda (atan y x)
	(cond ((zero? x)
	       (if (negative? y) 3pi/2 pi/2))
	      ((negative? x)
	       (&+ pi (&atan (&/ y x))))
	      ((negative? y)
	       (&+ 2pi (&atan (&/ y x))))
	      (else
	       (&atan (&/ y x))))))

(define pi/4  (&atan 1))
(define pi/2  (&* pi/4 2))
(define pi    (&* pi/4 4))
(define 3pi/2 (&+ pi pi/2))
(define 2pi   (&* pi/4 8))
\f


(set! abs
      (named-lambda (abs x)
	(if (negative? x) (&- 0 x) x)))

(let-syntax
 ((min-max-generator
   (macro (name predicate)
     `(SET! ,name
	    (NAMED-LAMBDA (,name FIRST . REST)
	      (LET LOOP ((RESULT FIRST)
			 (VALUE-LIST REST))
		   (IF (NULL? VALUE-LIST)
		       RESULT
		       (LOOP (IF (,predicate RESULT (CAR VALUE-LIST))
				 RESULT
				 (CAR VALUE-LIST))
			     (CDR VALUE-LIST)))))))))
  (min-max-generator min &<)
  (min-max-generator max &>))

(let ((seed 1)
      (a (+ (* 3141 1000 1000)
	    (* 592  1000)
	    621))
      (m (integer-expt 2 63))
      (c 1))
  (set! random
	(named-lambda (random k)
	  (cond ((not (integer? k))
		 (error "RANDOM is valid ony for integers" k))
		((<= 1 k m)
		 (set! seed
		       (remainder (&+ (&* a seed) c)
				  m))
		 (quotient (&* seed k) m))
		(else
		 (error "RANDOM is valid only for integers from 1 to" m)))))
  (set! randomize
	(named-lambda (randomize new-seed)
	  (set! seed new-seed))))

)

(define (gcd x y)
  (if (not (conjunction (integer? x) (not (zero? x))
			(integer? y) (not (zero? y))))
      (error "Bad arguments" 'GCD x y))
  (let gcd-loop ((x x) (y y))
    (if (zero? y)
	x
	(gcd-loop y
		  (remainder x y)))))