;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Wed Apr 04 16:46:28 2007 +0530 <enometh@net.meer>
;;;   Time-stamp: <2007-04-04 21:02:14 madhu>
;;;   Bugs-To: <enometh@net.meer>
;;;   Status: Experimental. Do not redistribute.
;;;   Copyright (C) 2007 Madhu. All Rights Reserved.
;;;
(defpackage "BIT-ARRAY-1-1"
  (:use "CL")
  (:export "MAKE-STORAGE-ARRAY" "GET-BITS" "SET-BITS"))
(in-package "BIT-ARRAY-1-1")

(defun make-storage-array (source-array-size source-element-width
			   storage-element-width &key dry-run-p)
  "Second return value is the number of bits wasted."
  (let ((storage-array-size (ceiling (* source-array-size
					source-element-width)
				     storage-element-width)))
    (values (if dry-run-p
		storage-array-size
		(make-array storage-array-size
			    :element-type `(unsigned-byte
					    ,storage-element-width)))
	     (- (* storage-element-width
		   storage-array-size)
		(* source-array-size
		   source-element-width)))))

(defun index-and-bit-position-range-in-storage (index-in-source-array source-element-width storage-element-width)
  (let ((bit-position (* index-in-source-array source-element-width)))
    (list (multiple-value-list (truncate bit-position storage-element-width))
	  (multiple-value-list (truncate (+ bit-position source-element-width)
					 storage-element-width)))))

(defun get-bits (storage-array index-in-source-array source-element-width storage-element-width)
  (destructuring-bind ((start-index start-bit-position)
		       (end-index end-bit-position))
      (index-and-bit-position-range-in-storage index-in-source-array source-element-width storage-element-width)
    (let ((result 0) index result-bit-position)
      (loop (cond (start-bit-position
		   (let ((byte-size (- storage-element-width
				       start-bit-position)))
		     (setq result-bit-position (+ 0 byte-size)
			   result (ldb (byte byte-size start-bit-position)
				       (aref storage-array start-index))
			   index (1+ start-index)
			   start-bit-position nil)))
		  ((> index end-index)
		   (return result))
		  ((= index end-index)
		   (let ((byte-size end-bit-position))
		     (unless (zerop byte-size)
		       (setf (ldb (byte byte-size result-bit-position) result)
			     (ldb (byte byte-size 0)
				  (aref storage-array index))))
		     (assert (= (+ result-bit-position byte-size) source-element-width))
		     (return result)))
		  (t (setf (ldb (byte storage-element-width
				      result-bit-position)
				result)
			   (aref storage-array index))
		     (incf result-bit-position storage-element-width)
		     (incf index)))))))

(defun set-bits (storage-array index-in-source-array bits source-element-width storage-element-width)
  (assert (<= (integer-length bits) source-element-width))
  (destructuring-bind ((start-index start-bit-position)
		       (end-index end-bit-position))
      (index-and-bit-position-range-in-storage index-in-source-array source-element-width storage-element-width)
    (let (index bit-position)
      (loop (cond (start-bit-position
		   (let ((byte-size (- storage-element-width
				       start-bit-position)))
		     (setf (ldb (byte byte-size start-bit-position)
				(aref storage-array start-index))
			   (ldb (byte byte-size 0) bits))
		     (setq bit-position (+ 0 byte-size)
			   start-bit-position nil
			   index (1+ start-index))))
		  ((> index end-index) (return))
		  ((= index end-index)
		   (let ((byte-size end-bit-position))
		     (unless (zerop end-bit-position)
		       (setf (ldb (byte byte-size 0)
				  (aref storage-array index))
			     (ldb (byte byte-size bit-position) bits)))
		     (assert (= (+ bit-position byte-size) source-element-width))
		     (return)))
		  (t (setf (aref storage-array index)
			   (ldb (byte storage-element-width bit-position)
				bits))
		     (incf bit-position storage-element-width)
		     (incf index)))))))