summaryrefslogtreecommitdiffstats
path: root/math-integer.scm
blob: 1ce70f8de1fe31b209416c758b8885ef251b4b23 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
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))