(* bitlist.ml *)
(* 15-411 *)
(* by Roland Flury *)
(* @version $Id: bitlist.ml,v 1.1 2004/11/01 09:23:14 ajo Exp $ *)

(* Description:
   Implements a module that provieds bitList
   BitLists are mutable objects, i.e. the object itself does not get
   copied all the time, but is just like an object pointed to by a pointer. 
   
   Available functions
   -------------------
   - Create a new Bit_list with at least n entries
   - set a bit to 1 (bit specified through the offset)
   - set a bit to 0 (bit specified through the offset)
   - Read content of bit (bit specified through the offset)
   - AND / OR / NOT / XOR two BitArrays;
   - Iterate over a bitList
*)

module AR = Array

type bitList_t = int array ref

(* Creates a new BitList and returns a reference to it.
 * Initilizes all entries to 0 (false). 
 * The size of the bitList is **at least** as big as specified *)
let newBitList n =
  let len = n / 31 + 2 in (* maximal length a bit bigger *)
  ref (AR.make len 0)
    
(* Set the bit at offset n to true == 1, first element has offset 0 
 * Raises Invalid_argument if n is out of range  *)
let setBit bli n = 
  let intpos = n / 31 in (* get number of integer *)
  let shift = n mod 31 in (* get number of bit in integer *)
  let oldInt = AR.get !bli intpos in (* get Integer: first element has number 0 *)
  let bit = 1 lsl shift in (* prepare mask *)
  let newInt = oldInt lor bit in (* write 1 *)
  AR.set !bli intpos newInt  (* write back *)
    
(* Set the bit at offset n to false == 0, first element has offset 0 
 * Raises Invalid_argument if n is out of range *)
let resetBit bli n =    
  let intpos = n / 31 in (* get number of integer *)
  let shift = n mod 31 in (* get number of bit in integer *)
  let oldInt = AR.get !bli intpos in (* get Integer: first element has number 0 *)
  let bit = lnot (1 lsl shift) in (* prepare mask *)
  let newInt = oldInt land bit in (* write 0 *)
  AR.set !bli intpos newInt  (* write back *)


(* Reads the bit at offset n and returns either true (for 1) or false (for 0) 
 * Raises Invalid_argument if n is out of range *)
let getBit bli n = 
  let intpos = n / 31 in (* get number of integer *)
  let shift = n mod 31 in (* get number of bit in integer *)
  let oldInt = AR.get !bli intpos in (* get Integer: first element has number 0 *)
  let bit = 1 lsl shift in (* prepare mask *)
  let newInt = oldInt land bit in (* delete all other bits *)
  if(newInt = 0) then false else true

(* Returns the (maximal) number of bits in a bitList *)
let getLength bli =
  (AR.length !bli) * 31 (* 31 bits per integer *)


(* Copies the content of a BitList to a second BitList 
 * Raises Invalid_argument if length(toL) < length(fromL) *)
let copyBitList fromL toL =
  AR.iteri (fun i ele -> AR.set !toL i ele) !fromL

(* Makes a copy of a BitList and returns a new BitList
 * Raises Invalid_argument if length(toL) < length(fromL) *)
let copyBitListNew from = 
  let n = AR.length !from in
  ref (AR.init n (fun i -> !from.(i)))

(* Sets all entries in the bit-list bl to zero *)
let nullBitList bl =
  AR.iteri (fun i ele -> AR.set !bl i 0) !bl

(* Returns true if the two bitlists a and b are equal. *)
let isEqual a b =
  try 
    let res =
      AR.fold_left (fun (count, r)  ele -> 
	(count + 1, ((AR.get (!b) count) = ele) && r)
		   ) (0, true) !a
    in
    snd res
  with Invalid_argument(s) -> false

(* Returns a list of temps that are set in the bit list 
 * bl is the bitlist and f is a fun mapping offset to temps *)
let getTempList bl f = 
  let res = 
    AR.fold_left (fun (count, li) b -> 
      match b with
      | 0 -> (count +1, li)
      | _ -> 
	  let temp = ref [] in
	  for i = 0 to 30 do
	    if( ((1 lsl i) land b) != 0) then
	      temp := (f (count*31 + i)) :: !temp
	  done;
	  (count+1, !temp @ li)
		 ) (0, []) !bl
  in
  snd res

(***********************************************************************)
(* AND OR XOR NOT; write the result in a new bitList *)
(***********************************************************************)

(* and's the two bitLists 'a' and 'b' and returns a NEW BitList with the
 * result
 * a, b: int Array ref
 * Raises Invalid_argument if length(a) > length(b) *)
let andBLnew a b =
  let n = AR.length !a in
  ref (AR.init n (fun i -> !a.(i) land !b.(i) ) ) 
    
(* or's the two bitLists 'a' and 'b' and returns a NEW BitList with the
 * result
 * a, b: int Array ref
 * Raises Invalid_argument if length(a) > length(b) *)
let orBLnew a b =
  let n = AR.length !a in
  ref (AR.init n (fun i -> !a.(i) lor !b.(i) ) )  
    
(* xor's the two bitLists 'a' and 'b' and returns a NEW BitList with the
 * result
 * a, b: int Array ref
 * Raises Invalid_argument if length(a) > length(b) *)
let xorBLnew a b =
  let n = AR.length !a in
  ref (AR.init n (fun i -> !a.(i) lxor !b.(i) ) )  
    
(* not's the bitList 'a' and returns a NEW BitList with the result
 * a: int Array ref *)
let notBLnew a =
  let n = AR.length !a in
  ref (AR.init n (fun i -> lnot !a.(i) ) )  

(***********************************************************************)
(* AND OR XOR NOT; write the result in the second operand *)
(***********************************************************************)

(* and's the two bitLists 'a' and 'b' and writes the result in 'b'.
 * a, b: int Array ref
 * Raises Invalid_argument if length(a) < length(b)
 * returns void *)
let andBLto2 a b =
  AR.iteri (fun i ele -> AR.set !b i (ele land !a.(i))) !b
    
(* or's the two bitLists 'a' and 'b' and writes the result in 'b'.
 * a, b: int Array ref
 * Raises Invalid_argument if length(a) < length(b)
 * returns void *)
let orBLto2 a b =
  AR.iteri (fun i ele -> AR.set !b i (ele lor !a.(i))) !b
    
(* xor's the two bitLists 'a' and 'b' and writes the result in 'b'.
 * a, b: int Array ref
 * Raises Invalid_argument if length(a) < length(b)
 * returns void *)
let xorBLto2 a b =
  AR.iteri (fun i ele -> AR.set !b i (ele lxor !a.(i))) !b

(* not's the bitList 'a' and writes the result in 'a'.
 * a: int Array ref
 * Raises Invalid_argument if length(a) < length(b)
 * returns void *)
let notBLto1 a =
  AR.iteri (fun i ele -> AR.set !a i (lnot ele)) !a

(***********************************************************************)
(* Iterators *)
(***********************************************************************)
    
(* Iterate over set bits in a bitlist *)
let iterTrue f bl =  
  let _ = AR.fold_left (fun count b -> 
    match b with
    | 0 -> count + 1
    | _ -> 
	for i = 0 to 30 do
	  if( ((1 lsl i) land b) != 0) then
	    f (count*31 + i)
	done;
	count + 1
		       ) 0 !bl
  in 
  ()

(* Iterate over all bits in a bitlist *)
let iter f bl = 
  let _ = AR.fold_left (fun count b -> 
    for i = 0 to 30 do
      if( ((1 lsl i) land b) != 0) then
	f (count*31 + i) true
      else
	f (count*31 + i) false
    done;
    count + 1
		       ) 0 !bl
  in 
  ()

exception Found of int
    
(* Find the first set bit, returns -1 if none was found *)
let findSet bl = 
  (try
    let _ = AR.fold_left (fun count b -> 
      for i = 0 to 30 do
	if( ((1 lsl i) land b) != 0) then
	  raise (Found((count*31 + i)))
      done;
      count + 1
			 ) 0 !bl
    in 
    -1
  with Found(x) -> x
  )

(* Executes the given function for every offset that is set to true *)
let fold f res bl =
  let tmp = ref res in
  iterTrue (fun off -> 
    tmp := f !tmp off;
	   ) bl;
  !tmp