summaryrefslogtreecommitdiffstats
path: root/math-integer.scm
diff options
context:
space:
mode:
Diffstat (limited to 'math-integer.scm')
-rw-r--r--math-integer.scm102
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))