;;; -*- Mode:LISP; Package:USER; Base:10; Readtable:CL -*-

(defsubst make-bit-string (size)
  (global::make-array size :type art-1b))

(defsubst bit-string-size (b)
  (length b))

(defun with-bit-string-destination (source receiver)
  (let ((size (length source)))
    (funcall receiver (make-bit-string size) size)))

(defun for-bits-in-bit-string (b receiver)
  (dotimes (index (bit-string-size b))
    (funcall receiver index (elt b index))))

(defun mirror-bit-string (b)
  (with-bit-string-destination b
    #'(lambda (dest size)
	(dotimes (i size)
	  (setf (elt dest i) (elt b (- size i 1))))
	dest)))

(defun rotate-bit-string (b distance)
  (with-bit-string-destination b
    #'(lambda (dest-string size)
	(let* ((rotation (remainder distance size))
	       (real-rot (if (minusp rotation)
			     (+ rotation size)
			     rotation)))
	  (copy-array-portion b 0 (- size real-rot)  dest-string real-rot size)
	  (copy-array-portion b (- size real-rot) size dest-string 0 real-rot))
	dest-string)))

(defun ldb-from-bit-string (byte string)
  (let* ((destination-size (byte-size byte))
	 (source-pos  (byte-position byte))
	 (destination-string (make-bit-string destination-size)))
    (copy-array-portion string source-pos (+ source-pos destination-size)
			destination-string 0 destination-size)
    destination-string))

(defun concat-two-bit-strings (lsb msb)
  (let* ((l-size (bit-string-size lsb))
	 (m-size (bit-string-size msb))
	 (total-size (+ l-size m-size))
	 (dest (make-bit-string total-size)))
    (copy-array-portion lsb 0 l-size dest 0 l-size)
    (copy-array-portion msb 0 m-size dest l-size total-size)
    dest))

(deff concat-bit-strings
      (binary-function->left-associating-lexpr #'concat-two-bit-strings #*))

(defun %%boxed->bit-string (byte)
  #'(lambda (frob)
      (let ((b (make-bit-string (byte-size byte))))
	(%p-dpb-offset frob byte b 1)
	b)))

(defun %%bit-string->boxed (byte type)
  #'(lambda (b)
      (let ((f (ncons nil)))
	(%p-store-tag-and-pointer f type (%p-ldb-offset byte b 1))
	(car f))))

(deff %fixnum->bit-string (%%boxed->bit-string %%q-pointer))
(deff %char->bit-string   (%%boxed->bit-string %%ch-char))
(deff %bit-string->fixnum (%%bit-string->boxed %%q-pointer dtp-fix))
(deff %bit-string->char   (%%bit-string->boxed %%ch-char   dtp-character))

(defun bit-string->fixnum (b)
  (%bit-string->fixnum
    (concat-bit-strings b (make-bit-string (byte-size %%q-pointer)))))

(defun fixnum->bit-string (f &optional (size (max (integer-length f) 24.)))
  (let ((f   f)
	(bs (make-bit-string (max size 24.)))
	bit)
    (dotimes (i size)
      (multiple-value-setq (f bit) (floor f 2.))
      (setf (elt bs i) bit))
    bs))

(defun bit-string->fixnum (bs)
  (let ((n 0)
	(s (length bs)))
    (tagbody
     loop
	(if (zerop s) (return-from bit-string->fixnum n))
	(setq s (1- s))
	(setq n (+ (ash n 1.) (elt bs s)))
	(go loop))))