summaryrefslogtreecommitdiffstats
path: root/logical.scm
diff options
context:
space:
mode:
Diffstat (limited to 'logical.scm')
-rw-r--r--logical.scm335
1 files changed, 224 insertions, 111 deletions
diff --git a/logical.scm b/logical.scm
index 963202f..90808e6 100644
--- a/logical.scm
+++ b/logical.scm
@@ -1,5 +1,5 @@
;;;; "logical.scm", bit access and operations for integers for Scheme
-;;; Copyright (C) 1991, 1993 Aubrey Jaffer
+;;; Copyright (C) 1991, 1993, 2001, 2003 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
@@ -8,7 +8,7 @@
;1. Any copy made of this software must include this copyright notice
;in full.
;
-;2. I have made no warrantee or representation that the operation of
+;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.
;
@@ -17,103 +17,19 @@
;promotional, or sales literature without prior written consent in
;each case.
-(define logical:integer-expt
+;@
+(define integer-expt
(if (provided? 'inexact)
expt
(lambda (n k)
- (logical:ipow-by-squaring n k 1 *))))
-
-(define (logical:ipow-by-squaring x k acc proc)
- (cond ((zero? k) acc)
- ((= 1 k) (proc acc x))
- (else (logical:ipow-by-squaring (proc x x)
- (quotient k 2)
- (if (even? k) acc (proc acc x))
- proc))))
-
-(define (logical:logand n1 n2)
- (cond ((= n1 n2) n1)
- ((zero? n1) 0)
- ((zero? n2) 0)
- (else
- (+ (* (logical:logand (logical:ash-4 n1) (logical:ash-4 n2)) 16)
- (vector-ref (vector-ref logical:boole-and (modulo n1 16))
- (modulo n2 16))))))
-
-(define (logical:logior n1 n2)
- (cond ((= n1 n2) n1)
- ((zero? n1) n2)
- ((zero? n2) n1)
- (else
- (+ (* (logical:logior (logical:ash-4 n1) (logical:ash-4 n2)) 16)
- (- 15 (vector-ref (vector-ref logical:boole-and
- (- 15 (modulo n1 16)))
- (- 15 (modulo n2 16))))))))
-
-(define (logical:logxor n1 n2)
- (cond ((= n1 n2) 0)
- ((zero? n1) n2)
- ((zero? n2) n1)
- (else
- (+ (* (logical:logxor (logical:ash-4 n1) (logical:ash-4 n2)) 16)
- (vector-ref (vector-ref logical:boole-xor (modulo n1 16))
- (modulo n2 16))))))
-
-(define (logical:lognot n) (- -1 n))
-
-(define (logical:logtest int1 int2)
- (not (zero? (logical:logand int1 int2))))
-
-(define (logical:logbit? index int)
- (logical:logtest (logical:integer-expt 2 index) int))
-
-(define (logical:copy-bit index to bool)
- (if bool
- (logical:logior to (logical:ash 1 index))
- (logical:logand to (logical:lognot (logical:ash 1 index)))))
-
-(define (logical:bit-field n start end)
- (logical:logand (- (logical:integer-expt 2 (- end start)) 1)
- (logical:ash n (- start))))
-
-(define (logical:bitwise-if mask n0 n1)
- (logical:logior (logical:logand mask n0)
- (logical:logand (logical:lognot mask) n1)))
-
-(define (logical:copy-bit-field to start end from)
- (logical:bitwise-if
- (logical:ash (- (logical:integer-expt 2 (- end start)) 1) start)
- (logical:ash from start)
- to))
-
-(define (logical:ash int cnt)
- (if (negative? cnt)
- (let ((n (logical:integer-expt 2 (- cnt))))
- (if (negative? int)
- (+ -1 (quotient (+ 1 int) n))
- (quotient int n)))
- (* (logical:integer-expt 2 cnt) int)))
-
-(define (logical:ash-4 x)
- (if (negative? x)
- (+ -1 (quotient (+ 1 x) 16))
- (quotient x 16)))
-
-(define (logical:logcount n)
- (cond ((zero? n) 0)
- ((negative? n) (logical:logcount (logical:lognot n)))
- (else
- (+ (logical:logcount (logical:ash-4 n))
- (vector-ref '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4)
- (modulo n 16))))))
-
-(define (logical:integer-length n)
- (case n
- ((0 -1) 0)
- ((1 -2) 1)
- ((2 3 -3 -4) 2)
- ((4 5 6 7 -5 -6 -7 -8) 3)
- (else (+ 4 (logical:integer-length (logical:ash-4 n))))))
+ (do ((x n (* x x))
+ (j k (quotient j 2))
+ (acc 1 (if (even? j) acc (* x acc))))
+ ((<= j 1)
+ (case j
+ ((0) acc)
+ ((1) (* x acc))
+ (else (slib:error 'integer-expt n k))))))))
(define logical:boole-xor
'#(#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
@@ -151,18 +67,215 @@
#(0 0 2 2 4 4 6 6 8 8 10 10 12 12 14 14)
#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)))
-(define logand logical:logand)
-(define logior logical:logior)
-(define logxor logical:logxor)
-(define lognot logical:lognot)
-(define logtest logical:logtest)
-(define logbit? logical:logbit?)
-(define copy-bit logical:copy-bit)
-(define ash logical:ash)
-(define logcount logical:logcount)
-(define integer-length logical:integer-length)
-(define bit-field logical:bit-field)
-(define bit-extract logical:bit-field)
-(define copy-bit-field logical:copy-bit-field)
-(define ipow-by-squaring logical:ipow-by-squaring)
-(define integer-expt logical:integer-expt)
+(define (logical:ash-4 x)
+ (if (negative? x)
+ (+ -1 (quotient (+ 1 x) 16))
+ (quotient x 16)))
+;@
+(define logand
+ (letrec
+ ((lgand
+ (lambda (n2 n1 scl acc)
+ (cond ((= n1 n2) (+ acc (* scl n1)))
+ ((zero? n2) acc)
+ ((zero? n1) acc)
+ (else (lgand (logical:ash-4 n2)
+ (logical:ash-4 n1)
+ (* 16 scl)
+ (+ (* (vector-ref (vector-ref logical:boole-and
+ (modulo n1 16))
+ (modulo n2 16))
+ scl)
+ acc)))))))
+ (lambda (n1 n2) (lgand n2 n1 1 0))))
+;@
+(define logior
+ (letrec
+ ((lgior
+ (lambda (n2 n1 scl acc)
+ (cond ((= n1 n2) (+ acc (* scl n1)))
+ ((zero? n2) (+ acc (* scl n1)))
+ ((zero? n1) (+ acc (* scl n2)))
+ (else (lgior (logical:ash-4 n2)
+ (logical:ash-4 n1)
+ (* 16 scl)
+ (+ (* (- 15 (vector-ref
+ (vector-ref logical:boole-and
+ (- 15 (modulo n1 16)))
+ (- 15 (modulo n2 16))))
+ scl)
+ acc)))))))
+ (lambda (n1 n2) (lgior n2 n1 1 0))))
+;@
+(define logxor
+ (letrec
+ ((lgxor
+ (lambda (n2 n1 scl acc)
+ (cond ((= n1 n2) acc)
+ ((zero? n2) (+ acc (* scl n1)))
+ ((zero? n1) (+ acc (* scl n2)))
+ (else (lgxor (logical:ash-4 n2)
+ (logical:ash-4 n1)
+ (* 16 scl)
+ (+ (* (vector-ref (vector-ref logical:boole-xor
+ (modulo n1 16))
+ (modulo n2 16))
+ scl)
+ acc)))))))
+ (lambda (n1 n2) (lgxor n2 n1 1 0))))
+;@
+(define (lognot n) (- -1 n))
+;@
+(define (logtest n1 n2)
+ (not (zero? (logical:logand n1 n2))))
+;@
+(define (logbit? index n)
+ (logical:logtest (logical:integer-expt 2 index) n))
+;@
+(define (copy-bit index to bool)
+ (if bool
+ (logical:logior to (logical:ash 1 index))
+ (logical:logand to (logical:lognot (logical:ash 1 index)))))
+
+;;@ This procedure is careful not to use more than DEG bits in
+;; computing (- (expt 2 DEG) 1)
+(define (logical:ones deg)
+ (if (zero? deg) 0 (+ (* 2 (+ -1 (logical:integer-expt 2 (- deg 1)))) 1)))
+;@
+(define (bit-field n start end)
+ (logical:logand (logical:ones (- end start))
+ (logical:ash n (- start))))
+;@
+(define (bitwise-if mask n0 n1)
+ (logical:logior (logical:logand mask n0)
+ (logical:logand (logical:lognot mask) n1)))
+;@
+(define (copy-bit-field to start end from)
+ (logical:bitwise-if (logical:ash (logical:ones (- end start)) start)
+ (logical:ash from start)
+ to))
+;@
+(define (ash n count)
+ (if (negative? count)
+ (let ((k (logical:integer-expt 2 (- count))))
+ (if (negative? n)
+ (+ -1 (quotient (+ 1 n) k))
+ (quotient n k)))
+ (* (logical:integer-expt 2 count) n)))
+;@
+(define integer-length
+ (letrec ((intlen (lambda (n tot)
+ (case n
+ ((0 -1) (+ 0 tot))
+ ((1 -2) (+ 1 tot))
+ ((2 3 -3 -4) (+ 2 tot))
+ ((4 5 6 7 -5 -6 -7 -8) (+ 3 tot))
+ (else (intlen (logical:ash-4 n) (+ 4 tot)))))))
+ (lambda (n) (intlen n 0))))
+;@
+(define logcount
+ (letrec ((logcnt (lambda (n tot)
+ (if (zero? n)
+ tot
+ (logcnt (quotient n 16)
+ (+ (vector-ref
+ '#(0 1 1 2 1 2 2 3 1 2 2 3 2 3 3 4)
+ (modulo n 16))
+ tot))))))
+ (lambda (n)
+ (cond ((negative? n) (logcnt (logical:lognot n) 0))
+ ((positive? n) (logcnt n 0))
+ (else 0)))))
+
+;;;; Bit order and lamination
+;@
+(define (logical:rotate k count len)
+ (set! count (modulo count len))
+ (logical:logior (logical:logand (ash k count) (logical:ones len))
+ (logical:ash k (- count len))))
+;@
+(define (bit-reverse k n)
+ (do ((m (if (negative? n) (lognot n) n) (ash m -1))
+ (k (+ -1 k) (+ -1 k))
+ (rvs 0 (logior (ash rvs 1) (logand 1 m))))
+ ((negative? k) (if (negative? n) (lognot rvs) rvs))))
+;@
+(define (integer->list k . len)
+ (if (null? len)
+ (do ((k k (ash k -1))
+ (lst '() (cons (odd? k) lst)))
+ ((<= k 0) lst))
+ (do ((idx (+ -1 (car len)) (+ -1 idx))
+ (k k (ash k -1))
+ (lst '() (cons (odd? k) lst)))
+ ((negative? idx) lst))))
+;@
+(define (list->integer bools)
+ (do ((bs bools (cdr bs))
+ (acc 0 (+ acc acc (if (car bs) 1 0))))
+ ((null? bs) acc)))
+(define (booleans->integer . bools)
+ (list->integer bools))
+;@
+(define (bitwise:laminate . ks)
+ (define nks (length ks))
+ (define nbs (apply max (map integer-length ks)))
+ (do ((kdx (+ -1 nbs) (+ -1 kdx))
+ (ibs 0 (+ (list->integer (map (lambda (k) (logbit? kdx k)) ks))
+ (ash ibs nks))))
+ ((negative? kdx) ibs)))
+;@
+(define (bitwise:delaminate count k)
+ (define nbs (* count (+ 1 (quotient (integer-length k) count))))
+ (do ((kdx (- nbs count) (- kdx count))
+ (lst (vector->list (make-vector count 0))
+ (map (lambda (k bool) (+ (if bool 1 0) (ash k 1)))
+ lst
+ (integer->list (ash k (- kdx)) count))))
+ ((negative? kdx) lst)))
+
+;;;; Gray-code
+;@
+(define (integer->gray-code k)
+ (logxor k (ash k -1)))
+;@
+(define (gray-code->integer k)
+ (if (negative? k)
+ (slib:error 'gray-code->integer 'negative? k)
+ (let ((kln (integer-length k)))
+ (do ((d 1 (* d 2))
+ (ans (logxor k (ash k -1)) ; == (integer->gray-code k)
+ (logxor ans (ash ans (* d -2)))))
+ ((>= (* 2 d) kln) ans)))))
+
+(define (grayter k1 k2)
+ (define kl1 (integer-length k1))
+ (define kl2 (integer-length k2))
+ (if (eqv? kl1 kl2)
+ (> (gray-code->integer k1) (gray-code->integer k2))
+ (> kl1 kl2)))
+;@
+(define (gray-code<? k1 k2)
+ (not (or (eqv? k1 k2) (grayter k1 k2))))
+(define (gray-code<=? k1 k2)
+ (or (eqv? k1 k2) (not (grayter k1 k2))))
+(define (gray-code>? k1 k2)
+ (and (not (eqv? k1 k2)) (grayter k1 k2)))
+(define (gray-code>=? k1 k2)
+ (or (eqv? k1 k2) (grayter k1 k2)))
+
+(define logical:logand logand)
+(define logical:logior logior)
+;;(define logical:logxor logxor)
+(define logical:lognot lognot)
+(define logical:logtest logtest)
+;;(define logical:logbit? logbit?)
+;;(define logical:copy-bit copy-bit)
+(define logical:ash ash)
+;;(define logical:logcount logcount)
+;;(define logical:integer-length integer-length)
+;;(define logical:bit-field bit-field)
+;;(define bit-extract bit-field)
+(define logical:bitwise-if bitwise-if)
+;;(define logical:copy-bit-field copy-bit-field)
+(define logical:integer-expt integer-expt)