File: number.scm

package info (click to toggle)
scsh 0.5.1-2
  • links: PTS
  • area: non-free
  • in suites: potato, slink
  • size: 6,540 kB
  • ctags: 8,656
  • sloc: lisp: 39,346; ansic: 13,466; sh: 1,669; makefile: 624
file content (78 lines) | stat: -rw-r--r-- 1,490 bytes parent folder | download
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
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.

; This is file number.scm.


;;;; Numbers

(define (inexact? n) (not (exact? n)))

(define (modulo x y)
  (let ((r (remainder x y)))
    (if (eq? (< r 0) (< y 0))
        r
	(+ r y))))

(define (ceiling x)
  (- 0 (floor (- 0 x))))		;floor is primitive

(define (truncate x)
  (if (< x 0)
      (ceiling x)
      (floor x)))

(define (round x)
  (let* ((x+1/2 (+ x (/ 1 2)))
	 (r (floor x+1/2)))
    (if (and (= r x+1/2)
	     (odd? r))
	(- r 1)
	r)))
	
; GCD

(define (gcd . integers)
  (reduce (lambda (x y)
	    (cond ((< x 0) (gcd (- 0 x) y))
		  ((< y 0) (gcd x (- 0 y)))
		  ((< x y) (euclid y x))
		  (else (euclid x y))))
	  0
	  integers))

(define (euclid x y)
  (if (= y 0)
      (if (and (inexact? y)
	       (exact? x))
	  (exact->inexact x)
	  x)
      (euclid y (remainder x y))))

; LCM

(define (lcm . integers)
  (reduce (lambda (x y)
	    (let ((g (gcd x y)))
	      (cond ((= g 0) g)
		    (else (* (quotient (abs x) g) (abs y))))))
	  1
	  integers))

; Exponentiation.

(define (expt x n)
  (if (and (integer? n) (exact? n))
      (if (>= n 0)
	  (raise-to-integer-power x n)
	  (/ 1 (raise-to-integer-power x (- 0 n))))
      (exp (* n (log x)))))

(define (raise-to-integer-power x n)
  (if (= n 0)
      1
      (let loop ((s x) (i n) (a 1))	;invariant: a * s^i = x^n
	(let ((a (if (odd? i) (* a s) a))
	      (i (quotient i 2)))
	  (if (= i 0)
	      a
	      (loop (* s s) i a))))))