; integer-length of srfi-60
; Produces list of values in order of SRFI at
; http://srfi.schemers.org/srfi-60/srfi-60.html
; When this grows up it belongs in cap-lore.com/code/Scheme/repository
; Crafted for MzScheme or Gambit (MzScheme here)

((lambda (ash land lor xor) (let* (
(integer-length (let ((z (/ (log 2)))) (lambda (x) (if (= x 0) 0
  (let ((x (if (< x 0) (- -1 x) x)))
    (let u ((y (+ 1 (inexact->exact (floor (* (log x) z))))))
      (let ((z (ash 1 y)))
        (if (<= z x) (u (+ y 1)) (if (> z (+ x x)) (u (- y 1)) y)))))))))
(count (lambda (x) (let cnt ((x (if (< x 0) (- -1 x) x))(s 0))
  (if (zero? x) s (cnt (land x (- x 1)) (+ s 1))))))
(merge (lambda (a b c) (lor (land a b) (land (- -1 a) c))))
(rotate (lambda (n count start end)
  (define width (- end start))
  (set! count (modulo count width))
  (let* ((mask (- -1 (ash -1 width)))
    (zn (land mask (arithmetic-shift n (- start)))))
    (lor (arithmetic-shift
             (lor (land mask (arithmetic-shift zn count))
                     (arithmetic-shift zn (- count width)))
             start)
            (land (- -1 (ash mask start)) n)))))
(reverse (lambda (k n)
  (do ((m (if (negative? n) (- -1 n) n) (arithmetic-shift m -1))
       (k (+ -1 k) (+ -1 k))
       (rvs 0 (lor (arithmetic-shift rvs 1) (land 1 m))))
      ((negative? k) (if (negative? n) (- -1 rvs) rvs)))))
(rev-field (lambda (n start end)
  (define width (- end start))
  (let* ((mask (- -1 (ash -1 width)))
    (zn (land mask (arithmetic-shift n (- start)))))
    (lor (arithmetic-shift (reverse width zn) start)
            (land (- -1 (ash mask start)) n)))))
(integer->list (lambda g (let* ((k (car g))
  (len (if (null? (cdr g)) (integer-length k) (cdr g))))
    (let r ((len len) (ls '()) (k k)) (if (= len 0) ls
       (r (- len 1) (cons (odd? k) ls) (ash k -1)))))))
(list->integer (lambda (l) (let p ((l l) (s 0))
  (if (null? l) s (p (cdr l) (+ (ash s 1) (if (car l) 1 0))))))))

(list land bitwise-ior bitwise-xor bitwise-not merge
(lambda (i j) (not (zero? (land i j)))) ; logtest
count integer-length
(lambda (x) (integer-length (xor x (- x 1)))) ; first-bit-set
(lambda (i x) (odd? (ash x (- i)))) ; bit-set?
(lambda (i f b) (let ((x (ash 1 i))) (if b (lor f x) (land f (- -1 x)))))
(lambda (b s e) (land (ash b (- s)) (- (ash 1 (- e s)) 1))) ; bit-field
(lambda (t f s e) (merge (- (ash 1 e) (ash 1 s)) (ash f s) t)); copy-bit-field
ash rotate rev-field integer->list list->integer
(lambda p (list->integer p)))))
arithmetic-shift bitwise-and bitwise-ior bitwise-xor)

; test:
(apply (lambda (logand logior logxor lognot bitwise-if logtest logcount
  integer-length log2-binary-factors logbit? copy-bit bit-field
  copy-bit-field ash rotate-bit-field reverse-bit-field integer->list
  list->integer booleans->integer) (let Q ((n 0) (set (list
    (cons (logand #b1100 #b1010) #b1000)
    (cons (logior #b1100 #b1010) #b1110)
    (cons (logxor #b1100 #b1010) #b110)
    (cons (lognot #b10000000) #b-10000001)
    (cons (lognot #b0) -1)
    (cons (logtest #b0100 #b1011) #f)
    (cons (logtest #b0100 #b0111) #t)
    (cons (logcount #b10101010) 4)
    (cons (logcount 0) 0)
    (cons (logcount -2) 1)
    (cons (integer-length #b10101010) 8) ; # 10
    (cons (integer-length 0) 0) 
    (cons (integer-length #b1111) 4)
    (cons (logbit? 0 #b1101) #t)
    (cons (logbit? 1 #b1101) #f)
    (cons (logbit? 2 #b1101) #t)
    (cons (logbit? 3 #b1101) #t)
    (cons (logbit? 4 #b1101) #f)
    (cons (copy-bit 0 0 #t) 1)
    (cons (copy-bit 2 0 #t) #b100)
    (cons (copy-bit 2 #b1111 #f) #b1011) ; #20
    (cons (bit-field #b1101101010 0 4) #b1010)
    (cons (bit-field #b1101101010 4 9) #b10110)
    (cons (copy-bit-field #b1101101010 0 0 4) #b1101100000)
    (cons (copy-bit-field #b1101101010 -1 0 4) #b1101101111)
    (cons (copy-bit-field #b110100100010000 -1 5 9) #b110100111110000)
    (cons (ash #b1 3) #b1000)
    (cons (ash #b1010 -1) #b101)
    (cons (rotate-bit-field #b0100 3 0 4) #b10)
    (cons (rotate-bit-field #b0100 -1 0 4) #b10)
    (cons (rotate-bit-field #b110100100010000 -1 5 9) #b110100010010000) ; #30
    (cons (rotate-bit-field #b110100100010000 1 5 9) #b110100000110000)
    (cons (reverse-bit-field #xa7 0 8) #xe5)
    (cons (integer->list #b101100) '(#t #f #t #t #f #f))
    (cons (list->integer '(#t #f #t #t #f #f)) #b101100)
    (cons (booleans->integer #t #f #t #t) 11)
)))
    (if (null? set) "Good" (let ((a (caar set))(b (cdar set)))
      (if (equal? a b) (Q (+ n 1) (cdr set))
      (begin (write (list n a b)) (newline)))))))
(fileVal "SRFI-60"))

; (define (lognot n) (- -1 n))
⊢ (= (+ n (lognot n)) -1)
⊢ (eq? (logior a b) (logand (lognot a) (lognot b)))
⊢ (eq? (logxor a b) (logior (logand a (lognot b)) (logand (lognot a) b)))
⊢ (eq? (bitwise-if m a b) (logior (logand m a) (logand (lognot m) b)))
⊢ (eq? (logtest j k) (not (zero? (logand j k))))
⊢ (eq? (odd? (logand a b)) (and (odd? a) (odd? b)))
⊢ (or (< n 0) (eq? (shl (shl a n) (- n)) a))
⊢ (= (shl a 1) (* 2 a))
⊢ (= (shl (shl n 1) a) (shl n (+ a 1)))
⊢ (= (logcount 0) 0)
⊢ (= (logcount 1) 1)
⊢ (or (< n 0) (= (logcount (* 2 n)) (logcount n)))
⊢ (or (< n 0) (= (logcount (+ (* 2 n) 1)) (+ (logcount n) 1)))
⊢ (= (integer-length 0) 0)
⊢ (= (integer-length 1) 1)
⊢ (= (integer-length (* 2 n)) (+ (integer-length n) 1))
⊢ (= (integer-length (+ (* 2 n) 1)) (+ (integer-length n) 1))
⊢ (= (integer-length (- n)) (integer-length n)) ; gessing
⊢ (= (first-set-bit 0) -1)
⊢ (= (first-set-bit 1) 0)
⊢ (or (= n 0) (= (first-set-bit (* 2 n)) (+ (first-set-bit n) 1))
⊢ (= (first-set-bit (+ (* 2 n) 1)) 0)
⊢ (eq? (logbit? n k) (odd? (shl k n)))