Import Upstream version 3a4upstream/3a4

1 files changed, 102 insertions, 0 deletions

diff --git a/math-integer.scm b/math-integer.scm
new file mode 100644
index 0000000..1ce70f8
--- /dev/null
+++ b/math-integer.scm
@@ -0,0 +1,102 @@
+; "math-integer.scm": mathematical functions restricted to exact integers
+; Copyright (C) 2006 Aubrey Jaffer
+;
+;Permission to copy this software, to modify it, to redistribute it,
+;to distribute modified versions, 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.  I have made no warranty or representation that the operation of
+;this software will be error-free, and I am under no obligation to
+;provide any services, by way of maintenance, update, or otherwise.
+;
+;3.  In conjunction with products arising from the use of this
+;material, there shall be no use of my name in any advertising,
+;promotional, or sales literature without prior written consent in
+;each case.
+
+(require 'logical)			; srfi-60
+
+;;@code{(require 'math-integer)}
+;;@ftindex math-integer
+
+;;@body
+;;Returns @1 raised to the power @2 if that result is an exact
+;;integer; otherwise signals an error.
+;;
+;;@code{(integer-expt 0 @2)}
+;;
+;;returns 1 for @2 equal to 0;
+;;returns 0 for positive integer @2;
+;;signals an error otherwise.
+(define (integer-expt n1 n2)
+  (cond ((and (exact? n1) (integer? n1)
+	      (exact? n2) (integer? n2)
+	      (not (and (not (<= -1 n1 1)) (negative? n2))))
+	 (expt n1 n2))
+	(else (slib:error 'integer-expt n1 n2))))
+
+;;@body
+;;Returns the largest exact integer whose power of @1 is less than or
+;;equal to @2. If @1 or @2 is not a positive exact integer, then
+;;@0 signals an error.
+(define (integer-log base k)
+  (define (ilog m b k)
+    (cond ((< k b) k)
+	  (else
+	   (set! n (+ n m))
+	   (let ((q (ilog (+ m m) (* b b) (quotient k b))))
+	     (cond ((< q b) q)
+		   (else (set! n (+ m n))
+			 (quotient q b)))))))
+  (define n 1)
+  (define (eigt? k j) (and (exact? k) (integer? k) (> k j)))
+  (cond ((not (and (eigt? base 1) (eigt? k 0)))
+	 (slib:error 'integer-log base k))
+	((< k base) 0)
+	(else (ilog 1 base (quotient k base)) n)))
+
+;;;; http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/code/math/isqrt/isqrt.txt
+;;; Akira Kurihara
+;;; School of Mathematics
+;;; Japan Women's University
+
+;;@args k
+;;For non-negative integer @1 returns the largest integer whose square
+;;is less than or equal to @1; otherwise signals an error.
+(define integer-sqrt
+  (let ((table '#(0
+		  1 1 1
+		  2 2 2 2 2
+		  3 3 3 3 3 3 3
+		  4 4 4 4 4 4 4 4 4))
+	(square (lambda (x) (* x x))))
+    (lambda (n)
+      (define (isqrt n)
+	(if (> n 24)
+	    (let* ((len/4 (quotient (- (integer-length n) 1) 4))
+		   (top (isqrt (ash n (* -2 len/4))))
+		   (init (ash top len/4))
+		   (q (quotient n init))
+		   (iter (quotient (+ init q) 2)))
+	      (cond ((odd? q) iter)
+		    ((< (remainder n init) (square (- iter init))) (- iter 1))
+		    (else iter)))
+	    (vector-ref table n)))
+      (if (and (exact? n) (integer? n) (not (negative? n)))
+	  (isqrt n)
+	  (slib:error 'integer-sqrt n)))))
+
+(define (must-be-exact-integer2 name proc)
+  (lambda (n1 n2)
+    (if (and (integer? n1) (integer? n2) (exact? n1) (exact? n2)
+	     (not (zero? n2)))
+	(proc n1 n2)
+	(slib:error name n1 n2))))
+;;@body
+;;are redefined so that they accept only exact-integer arguments.
+(define quotient  (must-be-exact-integer2 'quotient quotient))
+(define remainder (must-be-exact-integer2 'remainder remainder))
+(define modulo    (must-be-exact-integer2 'modulo modulo))