source: Deliverables/D4.1/Nibble.ml @ 71

(*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*)
(* FILENAME:    Nibble.ml                                                    *)
(* DESCRIPTION: An ADT implementing 4 bit nibbles, and common operations on  *)
(*              them.                                                        *)
(* CREATED:     10/09/2010, Dominic Mulligan                                 *)
(* BUGS:                                                                     *)
(*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*^*)

open Bit;;

module type NIBBLE =
sig
  type bit
  type nibble

  val from_bits: bit -> bit -> bit -> bit -> nibble
  val from_bit: bit -> nibble
  val from_int: int -> nibble option
  (* val from_string: string -> nibble option *)

  val to_bits: nibble -> (bit * bit * bit * bit)
  val to_bit: nibble -> bit option
  val to_int: nibble -> int
  val to_string: nibble -> string

  val get_bit_at: int -> nibble -> bit option
  val set_bit_at: int -> bit -> nibble -> nibble option

  val (-&-): nibble -> nibble -> nibble
  val (-|-): nibble -> nibble -> nibble
  val (-^-): nibble -> nibble -> nibble
  val rotate_right: nibble -> nibble
  val rotate_left: nibble -> nibble
  val shift_right: nibble -> nibble
  val shift_left: nibble -> nibble
  val not: nibble -> nibble

  val map_bit: (bit -> bit) -> nibble -> nibble
  val iter_bit: (bit -> string) -> nibble -> string
  val zip_bit: (bit -> bit -> bit) -> nibble -> nibble -> nibble
end

module NibbleFunctor(Bit: BIT) : NIBBLE
  with type bit = Bit.bit =
struct
  type bit = Bit.bit
  type nibble = bit * bit * bit * bit

  let from_bits b1 b2 b3 b4 = (b1, b2, b3, b4)
  let from_bit h = (Bit.from_bool false, Bit.from_bool false, Bit.from_bool false, h)
  let from_int int_val =
    match int_val with
      0 -> Some (Bit.from_int 0, Bit.from_int 0, Bit.from_int 0, Bit.from_int 0)
    | 1 -> Some (Bit.from_int 0, Bit.from_int 0, Bit.from_int 0, Bit.from_int 1)
    | 2 -> Some (Bit.from_int 0, Bit.from_int 0, Bit.from_int 1, Bit.from_int 0)
    | 3 -> Some (Bit.from_int 0, Bit.from_int 0, Bit.from_int 1, Bit.from_int 1)
    | 4 -> Some (Bit.from_int 0, Bit.from_int 1, Bit.from_int 0, Bit.from_int 0)
    | 5 -> Some (Bit.from_int 0, Bit.from_int 1, Bit.from_int 0, Bit.from_int 1)
    | 6 -> Some (Bit.from_int 0, Bit.from_int 1, Bit.from_int 1, Bit.from_int 0)
    | 7 -> Some (Bit.from_int 0, Bit.from_int 1, Bit.from_int 1, Bit.from_int 1)
    | 8 -> Some (Bit.from_int 1, Bit.from_int 0, Bit.from_int 0, Bit.from_int 0)
    | 9 -> Some (Bit.from_int 1, Bit.from_int 0, Bit.from_int 0, Bit.from_int 1)
    | 10 -> Some (Bit.from_int 1, Bit.from_int 0, Bit.from_int 1, Bit.from_int 0)
    | 11 -> Some (Bit.from_int 1, Bit.from_int 0, Bit.from_int 1, Bit.from_int 1)
    | 12 -> Some (Bit.from_int 1, Bit.from_int 1, Bit.from_int 0, Bit.from_int 0)
    | 13 -> Some (Bit.from_int 1, Bit.from_int 1, Bit.from_int 0, Bit.from_int 1)
    | 14 -> Some (Bit.from_int 1, Bit.from_int 1, Bit.from_int 1, Bit.from_int 0)
    | 15 -> Some (Bit.from_int 1, Bit.from_int 1, Bit.from_int 1, Bit.from_int 1)
    | _ -> None

  let to_bit (b1, b2, b3, b4) =
    let (d1, d2, d3, d4) = Bit.to_bool b1, Bit.to_bool b2, Bit.to_bool b3, Bit.to_bool b4 in
    match (d1, d2, d3, d4) with
      (false, false, false, b) -> Some (Bit.from_bool b)
   |  _ -> None
  let to_bits (b1, b2, b3, b4) = (b1, b2, b3, b4)
  let to_int (b1, b2, b3, b4) = (8 * Bit.to_int b1) + (4 * Bit.to_int b2) + 
                                (2 * Bit.to_int b3) + Bit.to_int b4

  let get_bit_at index (b1, b2, b3, b4) =
    match index with
      0 -> Some b4
    | 1 -> Some b3
    | 2 -> Some b2
    | 3 -> Some b1
    | _ -> None

  let set_bit_at index new_bit (b1, b2, b3, b4) =
    match index with
      0 -> Some (b1, b2, b3, new_bit)
    | 1 -> Some (b1, b2, new_bit, b4)
    | 2 -> Some (b1, new_bit, b3, b4)
    | 3 -> Some (new_bit, b2, b3, b4)
    | _ -> None

  let (-&-) (l1, l2, l3, l4) (r1, r2, r3, r4) =
     (Bit.(-&-) l1 r1, Bit.(-&-) l2 r2, Bit.(-&-) l3 r3, Bit.(-&-) l4 r4)
  let (-|-) (l1, l2, l3, l4) (r1, r2, r3, r4) =
     (Bit.(-|-) l1 r1, Bit.(-|-) l2 r2, Bit.(-|-) l3 r3, Bit.(-|-) l4 r4)
  let (-^-) (l1, l2, l3, l4) (r1, r2, r3, r4) =
     (Bit.(-^-) l1 r1, Bit.(-^-) l2 r2, Bit.(-^-) l3 r3, Bit.(-^-) l4 r4)
  let rotate_right (b1, b2, b3, b4) = (b4, b1, b2, b3)
  let rotate_left (b1, b2, b3, b4) = (b2, b3, b4, b1)
  let shift_right (b1, b2, b3, b4) = (Bit.from_bool false, b1, b2, b3)
  let shift_left (b1, b2, b3, b4) = (b2, b3, b4, Bit.from_bool false)
  let not (b1, b2, b3, b4) = (Bit.not b1, Bit.not b2, Bit.not b3, Bit.not b4)

  let map_bit f (b1, b2, b3, b4) = (f b1, f b2, f b3, f b4)
  let iter_bit f (b1, b2, b3, b4) =
    let str_b1 = f b1 in
    let str_b2 = f b2 in
    let str_b3 = f b3 in
    let str_b4 = f b4 in
      str_b1 ^ str_b2 ^ str_b3 ^ str_b4
  let zip_bit f (l1, l2, l3, l4) (r1, r2, r3, r4) = (f l1 r1, f l2 r2, f l3 r3, f l4 r4)

  let to_string = iter_bit Bit.to_string
end

module Nibble = NibbleFunctor(Bit)