a solution to Exercise 9.1 of "Purely Functional Data Structures (PFDS)"

ex0901_BinaryRandomAccessList.ml

(* a solution to Exercise 9.1 of "Purely Functional Data Structures (PFDS)" *)

module type ITEM =
sig
  type t
  val print : t -> unit
end

module Int : (ITEM with type t = int) =
struct
  type t = int
  let print = print_int
  ;;
end

module type SMALLSTREAM =
sig
  type 'a cell = Nil | Cons of 'a * 'a stream
  and  'a stream = 'a cell Lazy.t;;

  exception Empty;;

  val empty : 'a stream
  val cons : 'a -> 'a stream -> 'a stream
end

module SmallStream : SMALLSTREAM =
struct
  type 'a cell = Nil | Cons of 'a * 'a stream
  and  'a stream = 'a cell Lazy.t

  exception Empty

  let empty = lazy Nil
  ;;

  let cons x xs = lazy (Cons (x, xs))
  ;;
end

module type RANDOMACCESSLIST =
sig
  module Elem : ITEM

  type rlist

  exception Empty
  exception Subscript

  val empty   : rlist
  val isEmpty : rlist -> bool

  val cons    : Elem.t * rlist -> rlist
  val head    : rlist -> Elem.t
  val tail    : rlist -> rlist

  val lookup  : int * rlist -> Elem.t
  val update  : int * Elem.t * rlist -> rlist

  val print   : rlist -> unit
  val dprint  : bool -> rlist -> unit
  
  val drop     : int * rlist -> rlist
end

module BinaryRandomAccessList (Element : ITEM) : RANDOMACCESSLIST
  with module Elem = Element =
struct
  module Elem = Element

  type 'a tree = LEAF of 'a
               | NODE of int * 'a tree * 'a tree
  type 'a digit = ZERO
                | ONE of 'a tree
  type rlist = Element.t digit list
  
  exception Empty
  exception Subscript

  let size = function
    | (LEAF x) -> 1
    | (NODE (w, t1, t2)) -> w
  ;;

  let empty = []
  ;;

  let isEmpty ts = ts = []
  ;;

  let link (t1, t2) = NODE (size t1 + size t2, t1, t2)
  ;;

  let rec consTree = function
    | (t, []) -> [ONE t]
    | (t, ZERO :: ts) -> ONE t :: ts
    | (t1, ONE t2 :: ts) -> ZERO :: consTree (link (t1, t2), ts)
  ;;

  let rec unconsTree = function
    | [] -> raise Empty
    | [ONE t] -> (t, [])
    | (ONE t :: ts) -> (t, ZERO :: ts)
    | (ZERO :: ts) ->
        let (NODE (_, t1, t2), ts') = unconsTree ts in
        (t1, ONE t2 :: ts')
  ;;

  let cons (x, ts) = consTree (LEAF x, ts)
  ;;

  let head ts =
    let (LEAF x, _) = unconsTree ts in
    x
  ;;

  let tail ts =
    let (_, ts') = unconsTree ts in
    ts'
  ;;

  let rec lookupTree = function
    | (0, LEAF x) -> x
    | (i, LEAF x) -> raise Subscript
    | (i, NODE (w, t1, t2)) ->
        if i < (w/2) then lookupTree (i, t1)
        else lookupTree (i - (w/2), t2)
  ;;

  let rec lookup = function
    | (i, []) -> raise Subscript
    | (i, ZERO :: ts) -> lookup (i, ts)
    | (i, ONE t :: ts) ->
        if i < size t then lookupTree (i, t)
        else lookup (i - size t, ts)
  ;;

  let rec updateTree = function
    | (0, y, LEAF x) -> LEAF y
    | (i, y, LEAF x) -> raise Subscript
    | (i, y, NODE (w, t1, t2)) ->
        if i < (w/2) then NODE (w, updateTree (i, y, t1), t2)
        else NODE (w, t1, updateTree (i - (w/2), y, t2))
  ;;

  let rec update = function
    | (i, y, []) -> raise Subscript
    | (i, y, ZERO :: ts) -> ZERO :: update (i, y, ts)
    | (i, y, ONE t :: ts) ->
        if i < size t then ONE (updateTree (i, y, t)) :: ts
        else ONE t :: update (i - size t, y, ts)
  ;;

  let print xs =
    let rec print_tree = function
      | (LEAF x) ->
          print_string "LEAF (";
          Elem.print x;
          print_string ")"
      | (NODE (w, t1, t2)) ->
          print_string "NODE (";
          print_int w;
          print_string ", ";
          print_tree t1;
          print_string ", ";
          print_tree t2;
          print_string ")" in
    let print_digit = function
      | (ZERO) -> print_string "ZERO"
      | (ONE t) ->
          print_string "ONE (";
          print_tree t;
          print_string ")" in
    let rec print_digit_list = function
      | [] -> ()
      | (x :: xs) ->
          print_digit x;
          print_string ";\n";
          print_digit_list xs in
    print_string "rlist ([\n";
    print_digit_list xs;
    print_string "])";
    print_newline ()
  ;;

  let dprint _ xs = print xs
  ;;

  let rec fillZero : Elem.t tree * rlist -> rlist = function
    | (LEAF x, a) -> a
    | (NODE (w, t1, t2), a) -> fillZero (t1, ZERO :: a)
  ;;
  
  let rec dropTreeLeft : int * Elem.t tree * rlist -> rlist = function
    | (0, t, a) -> fillZero (t, ONE t :: a)
    | (i, LEAF x, a) -> raise Subscript
    | (i, NODE (w, t1, t2), a) ->
        if i < (w/2)
        then dropTreeLeft (i, t1, ONE t2 :: a)
        else dropTreeRight (i - (w/2), t2, a)
  and dropTreeRight  : int * Elem.t tree * rlist -> rlist = function
    | (0, t, a) -> fillZero (t, ONE t :: a)
    | (i, LEAF x, a) -> raise Subscript
    | (i, NODE (w, t1, t2), a) ->
        match a with
          | [] ->
              if i < (w/2)
              then dropTreeLeft (i, t1, ONE t2 :: a)
              else dropTreeRight (i - (w/2), t2, a)
          | a ->
              if i < (w/2)
              then dropTreeLeft (i, t1, ONE t2 :: ZERO :: a)
              else dropTreeRight (i - (w/2), t2, ZERO :: a)
  ;;

  let rec drop : int * rlist -> rlist = function
    | (i, []) -> []
    | (i, ZERO :: ts) -> drop (i, ts)
    | (i, ONE t :: ts) ->
        if i < size t
        then dropTreeRight (i, t, ts)
        else drop (i - size t, ts)
  ;;
end

module IntBinaryRandomAccessList = BinaryRandomAccessList (Int)

runTestEx0901.ml

#use "topfind";;
#require "OUnit";;
open OUnit;;

(* Tests for BinaryRandomAccessList *)
#use "ex0901_BinaryRandomAccessList.ml";;
open IntBinaryRandomAccessList;;

module B = IntBinaryRandomAccessList

let cons_rlist n =
  let rec cons_rlist' = function
    | (0, a) -> a
    | (i, a) -> cons_rlist' (i-1, B.cons (n-i, a))
  in cons_rlist' (n, B.empty)
;;

let rec tail_rlist n rlist = match n with
  | 0 -> rlist
  | i -> tail_rlist (i-1) (B.tail rlist)
;;

(* 0 *)
let rlist_0 = cons_rlist 0;;
print_string "n = 0:\n"; B.print rlist_0;;

(* 11 *)
let rlist_11 = cons_rlist 11;;
print_string "n = 11:\n"; B.print rlist_11;;

(* test *)
let test_0 _ = assert_bool "ok" (B.isEmpty rlist_0)
;;

let test_11 _ = match B.isEmpty rlist_11 with
  | false -> assert_bool "ok" true
  | _  -> assert_failure "not correct" 
;;

let test_11_head = assert_equal (10, rlist_11)

let test_11_lookup _ =
  assert_equal 10 (B.lookup (0, rlist_11));
  assert_equal 9 (B.lookup (1, rlist_11));
  assert_equal 8 (B.lookup (2, rlist_11));
  assert_equal 7 (B.lookup (3, rlist_11));
  assert_equal 6 (B.lookup (4, rlist_11));
  assert_equal 5 (B.lookup (5, rlist_11));
  assert_equal 4 (B.lookup (6, rlist_11));
  assert_equal 3 (B.lookup (7, rlist_11));
  assert_equal 2 (B.lookup (8, rlist_11));
  assert_equal 1 (B.lookup (9, rlist_11));
  assert_equal 0 (B.lookup (10, rlist_11))
;;

let test_11_update _ = 
  let rlist_11a = B.update (3, 11, rlist_11) in
  let rlist_11b = B.update (8, 12, rlist_11a) in
  let rlist_11c = B.update (5, 13, rlist_11b) in
  let rlist_11d = B.update (0, 14, rlist_11c) in
  let rlist_11e = B.cons (15, rlist_11d) in
  assert_equal 14 (B.head rlist_11d);
  assert_equal 15 (B.head rlist_11e);
  assert_equal 15 (B.lookup (0, rlist_11e));
  assert_equal 14 (B.lookup (1, rlist_11e));
  assert_equal 9 (B.lookup (2, rlist_11e));
  assert_equal 8 (B.lookup (3, rlist_11e));
  assert_equal 11 (B.lookup (4, rlist_11e));
  assert_equal 6 (B.lookup (5, rlist_11e));
  assert_equal 13 (B.lookup (6, rlist_11e));
  assert_equal 4 (B.lookup (7, rlist_11e));
  assert_equal 3 (B.lookup (8, rlist_11e));
  assert_equal 12 (B.lookup (9, rlist_11e));
  assert_equal 1 (B.lookup (10, rlist_11e));
  assert_equal 0 (B.lookup (11, rlist_11e))
;;

let test_11_drop _ =
  let rlist_11a = B.drop (6, rlist_11) in
  print_string "n = 11 - 6 = 5:\n"; B.print rlist_11a;
  assert_equal 5 (B.lookup (5, rlist_11));
  assert_equal 4 (B.lookup (6, rlist_11));
  assert_equal 3 (B.lookup (7, rlist_11));
  assert_equal 2 (B.lookup (8, rlist_11));
  assert_equal 1 (B.lookup (9, rlist_11))
;;

let suite = "Test BinaryRandomAccessList Exercise 9.1" >:::
  ["test_0"         >:: test_0;
   "test_11"        >:: test_11;
   "test_11_lookup" >:: test_11_lookup;
   "test_11_update" >:: test_11_update;
   "test_11_drop"   >:: test_11_drop;
  ]
;;

let _ = run_test_tt_main suite;;