;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; bit-fiddle.scm: VERY SLOW BIT FIDDLING
;;;
;;; Copyright (c) 2000 by Boris Schaefer
;;;
;;; You may do as you please with this code as long as you do not
;;; remove this copyright notice or hold me liable for its use.
;;; Please send bug reports to the address provided in:
;;;
;;;   http://www.uncommon-sense.net/this-site/contact.html
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (bit-shift-up value nbits)
  (if (and (integer? value)
           (integer? nbits))
      (quotient value (expt 2 nbits))
    (error "bit-shift-up: value and nbits arguments must be integers")))

(define (bit-shift-down value nbits)
  (if (and (integer? value)
           (integer? nbits))
      (* value (expt 2 nbits))
    (error "bit-shift-down: value and nbits arguments must be integers")))


(define (bit-apply proc n1 n2)
  (if (and (integer? n1)
           (integer? n2))
      (let loop ((b1 n1)
                 (b2 n2)
                 (result 0)
                 (i 0))
        (if (and (= b1 0)
                 (= b2 0))
            result
            (loop (quotient b1 2)
                  (quotient b2 2)
                  (let ((new (proc (if (even? b1) 0 1)
                                   (if (even? b2) 0 1))))
                    (if (= new 0)
                        result
                        (+ result (expt 2 i))))
                  (+ i 1))))
      (error "bit-apply: requires two integer arguments")))

(define (bit-and v1 v2)
  (bit-apply (lambda (b1 b2)
               (if (and (= b1 1) (= b2 1)) 1 0))
             v1 v2))

(define (bit-or v1 v2)
  (bit-apply (lambda (b1 b2)
               (if (or (= b1 1) (= b2 1)) 1 0))
             v1 v2))

(define (bit-xor v1 v2)
  (bit-apply (lambda (b1 b2)
               (if (or (and (= b1 0) (= b2 1))
                       (and (= b1 1) (= b2 0)))
                   1 0))
             v1 v2))