source: Deliverables/D4.1/tentative.ml @ 86

module Vect :
 sig
  type bit = bool

  type 'a vect

  type nibble = [`Four] vect
  type byte7 = [`Seven] vect
  type byte = [`Eight] vect
  type word = [`Sixteen] vect
  type word11 = [`Eleven] vect

  val mk_nibble: bit -> bit -> bit -> bit -> nibble
  val from_nibble: nibble -> bit * bit * bit * bit
  val mk_byte7: bit -> bit -> bit -> nibble -> byte7
  val from_byte7: byte7 -> bit * bit * bit * nibble
  val mk_byte: nibble -> nibble -> byte
  val from_byte: byte -> nibble * nibble
  val mk_word: byte -> byte -> word
  val from_word: word -> byte * byte
  val mk_word11: bit -> bit -> bit -> byte -> word11
  val from_word11: word11 -> bit * bit * bit * byte

  val to_bits: 'a vect -> bit list
  val get_bit: 'a vect -> int -> bit option
  val set_bit: 'a vect -> int -> bit -> 'a vect option

  val (-&-): 'a vect -> 'a vect -> 'a vect
  val (-|-): 'a vect -> 'a vect -> 'a vect
  val (-^-): 'a vect -> 'a vect -> 'a vect
  val not: 'a vect -> 'a vect

  val iter_bits: (bit -> string) -> 'a vect -> string
  val map_bits: (bit -> bit) -> 'a vect -> 'a vect
  val map2_bits: (bit -> bit -> bit) -> 'a vect -> 'a vect -> 'a vect

  val string_of_vect: 'a vect -> string

  val half_add: 'a vect -> 'a vect -> bit * 'a vect
  val full_add: 'a vect -> 'a vect -> bit -> bit * 'a vect

  val rotate_left : 'a vect -> 'a vect
  val rotate_right : 'a vect -> 'a vect
  val shift_right : 'a vect -> 'a vect
  val shift_left : 'a vect -> 'a vect
 end
=
 struct
  type bit = bool
  type 'a vect = bit list
  type nibble = [`Four] vect
  type byte7 = [`Seven] vect
  type byte = [`Eight] vect
  type word = [`Sixteen] vect
  type word11 = [`Eleven] vect

  let mk_nibble b1 b2 b3 b4 = [b1; b2; b3; b4]
  let from_nibble =
   function
      [b1; b2; b3; b4] -> b1,b2,b3,b4
    | _ -> assert false
  let mk_byte n1 n2 = n1 @ n2
  let from_byte =
   function
      b1::b2::b3::b4::r -> [b1;b2;b3;b4],r
    | _ -> assert false
  let mk_byte7 b1 b2 b3 n1 = b1::b2::b3::n1
  let from_byte7 =
   function
      b1::b2::b3::r -> b1,b2,b3,r
    | _ -> assert false
  let mk_word = mk_byte
  let from_word =
   function
      b1::b2::b3::b4::b5::b6::b7::b8::r -> [b1;b2;b3;b4;b5;b6;b7;b8],r
    | _ -> assert false
  let mk_word11 = mk_byte7
  let from_word11 = from_byte7

  let to_bits l = l

  let get_bit index l =
    try
      Some (List.nth index l)
    with (Failure _ | Invalid_argument _) -> None

  let set_bit l index new_val =
    try
      let rec aux index l = 
        match index, l with
          _, [] -> raise (Invalid_argument "")
        | 0,_::tl -> new_val::tl
        | n,hd::tl -> hd::(aux (n-1) tl) in
       Some (List.rev (aux index (List.rev l)))
    with Invalid_argument "" -> None

  let (-&-) l1 l2 = List.map2 (fun b1 b2 -> b1 & b2) l1 l2
  let (-|-) l1 l2 = List.map2 (fun b1 b2 -> b1 || b2) l1 l2
  let xor b1 b2 = b1 <> b2
  let (-^-) l1 l2 = List.map2 xor l1 l2
  let not l1 = List.map (not) l1

  let iter_bits f v = String.concat "" (List.map f v)
  let map_bits = List.map
  let map2_bits = List.map2

  let string_of_vect l =
   String.concat "" (List.map (function false -> "0" | true -> "1") l)

  let full_add l r c = List.fold_right2 (fun b1 b2 (c,r) -> b1 & b2 || c & (b1 || b2),xor (xor b1 b2) c::r) l r (c,[])
  let half_add l r = full_add l r false

  let rec split_last = function [] -> assert false | [he] -> he,[] | he::tl -> let l,res = split_last tl in l,he::res

  let shift_left = function [] -> assert false | _::tl -> tl @ [false]
  let shift_right l = false :: snd (split_last l)
  let rotate_left = function [] -> assert false | he::tl -> tl @ [he]
  let rotate_right l = let he,tl = split_last l in he::tl
 end
;;