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

ex0910_LazyBinaryRandomAccessList.ml

(* a solution to Exercise 9.10 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
end

module LazyBinaryRandomAccessList (Element : ITEM) : RANDOMACCESSLIST
  with module Elem = Element =
struct
  module Elem = Element
  module S = SmallStream

  exception Empty
  exception Subscript

  type 'a tree = LEAF of 'a
               | NODE of int * 'a tree * 'a tree
  type 'a digit = ONE of 'a tree
                | TWO of 'a tree * 'a tree
                | TWOR of 'a tree * 'a tree
                | THREE of 'a tree * 'a tree * 'a tree
  type schedule = Elem.t digit S.stream list
  type rlist = Elem.t digit S.stream * schedule

  let empty = (lazy S.Nil, [])
  ;;

  let isEmpty = function
    | (lazy S.Nil, _) -> true
    | _ -> false
  ;;

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

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

  let exec = function
    | [] -> []
    | (lazy (S.Cons (TWOR (t1, t2), ts)) :: sched) -> ts :: sched
    | (_ :: sched) -> sched
  ;;

  let rec consTree = function
    | (t,  lazy S.Nil)                             -> lazy (S.Cons (ONE t, lazy S.Nil))
    | (t1, lazy (S.Cons (ONE t2, ts)))             -> lazy (S.Cons (TWO (t1, t2), ts))
    | (t1, lazy (S.Cons (TWO (t2, t3), ts)))       -> lazy (S.Cons (THREE (t1, t2, t3), ts))
    | (t1, lazy (S.Cons (TWOR (t2, t3), ts)))      -> lazy (S.Cons (THREE (t1, t2, t3), ts))
    | (t1, lazy (S.Cons (THREE (t2, t3, t4), ts))) -> lazy (S.Cons (TWOR (t1, t2), consTree (link (t3, t4), ts)))
  ;;

  let rec unconsTree = function
    | (lazy S.Nil) -> raise Empty
    | (lazy (S.Cons (THREE (t1, t2, t3), ts))) -> (t1, lazy (S.Cons (TWO (t2, t3), ts)))
    | (lazy (S.Cons (TWOR (t1, t2), ts)))      -> (t1, lazy (S.Cons (ONE t2, ts)))
    | (lazy (S.Cons (TWO (t1, t2), ts)))       -> (t1, lazy (S.Cons (ONE t2, ts)))
    | (lazy (S.Cons (ONE t, lazy S.Nil)))      -> (t, lazy S.Nil)
    | (lazy (S.Cons (ONE t1, ts)))             ->
        let (NODE (_, t2, t3), ts') = unconsTree ts in
        (t1, lazy (S.Cons (TWOR (t2, t3), ts')))
  ;;

  let cons (x, (ts, sched)) =
    let ts' = consTree (LEAF x, ts) in
    (ts', exec (exec (ts' :: sched)))
  ;;

  let head (ts, sched) = match ts with
    | lazy S.Nil -> raise Empty
    | lazy (S.Cons(ONE (LEAF x), _)) -> x
    | lazy (S.Cons(TWO (LEAF x, _), _)) -> x
    | lazy (S.Cons(TWOR (LEAF x, _), _)) -> x
    | lazy (S.Cons(THREE (LEAF x, _, _), _)) -> x
    | _ -> raise Subscript
  ;;

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

  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, (lazy S.Nil)) -> raise Subscript
    | (i, lazy (S.Cons (ONE t, ts))) ->
        if i < size t then lookupTree (i, t)
        else lookup' (i - size t, ts)
    | (i, lazy (S.Cons (TWO (t1, t2), ts))) ->
        if i < size t1 then lookupTree (i, t1)
        else if i < size t1 + size t2 then lookupTree (i - size t1, t2)
        else lookup' (i - size t1 - size t2, ts)
    | (i, lazy (S.Cons (TWOR (t1, t2), ts))) ->
        if i < size t1 then lookupTree (i, t1)
        else if i < size t1 + size t2 then lookupTree (i - size t1, t2)
        else lookup' (i - size t1 - size t2, ts)
    | (i, lazy (S.Cons (THREE (t1, t2, t3), ts))) ->
        if i < size t1 then lookupTree (i, t1)
        else if i < size t1 + size t2 then lookupTree (i - size t1, t2)
        else if i < size t1 + size t2 + size t3 then lookupTree (i - size t1 - size t2, t3)
        else lookup' (i - size t1 - size t2 - size t3, ts)
  ;;

  let lookup (i, (ts, sched))  = lookup' (i, 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, lazy S.Nil) -> raise Subscript
    | (i, y, lazy (S.Cons (ONE t, ts))) ->
        if i < size t then lazy (S.Cons (ONE (updateTree (i, y, t)), ts))
        else lazy (S.Cons (ONE t, update' (i - size t, y, ts)))
    | (i, y, lazy (S.Cons (TWO (t1, t2), ts))) ->
        if i < size t1 then lazy (S.Cons (TWO (updateTree (i, y, t1), t2), ts))
        else if i < size t1 + size t2 then lazy (S.Cons (TWO (t1, updateTree (i - size t1, y, t2)), ts))
        else lazy (S.Cons (TWO (t1, t2), update' (i - size t1 - size t2, y, ts)))
    | (i, y, lazy (S.Cons (TWOR (t1, t2), ts))) ->
        if i < size t1 then lazy (S.Cons (TWOR (updateTree (i, y, t1), t2), ts))
        else if i < size t1 + size t2 then lazy (S.Cons (TWOR (t1, updateTree (i - size t1, y, t2)), ts))
        else lazy (S.Cons (TWOR (t1, t2), update' (i - size t1 - size t2, y, ts)))
    | (i, y, lazy (S.Cons (THREE (t1, t2, t3), ts))) ->
        if i < size t1 then lazy (S.Cons (THREE (updateTree (i, y, t1), t2, t3), ts))
        else if i < size t1 + size t2 then lazy (S.Cons (THREE (t1, updateTree (i - size t1, y, t2), t3), ts))
        else if i < size t1 + size t2 + size t3 then lazy (S.Cons (THREE (t1, t2, updateTree (i - size t1 - size t2, y, t3)), ts))
        else lazy (S.Cons (THREE (t1, t2, t3), update' (i - size t1 - size t2 - size t3, y, ts)))
  ;;

  let update (i, y, (ts, sched)) = (update' (i, y, ts), sched)
  ;;

  let dprint show (xs, ys) =
    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
      | (ONE t) ->
          print_string "ONE (";
          print_tree t;
          print_string ")"
      | (TWO (t1, t2)) ->
          print_string "TWO (";
          print_tree t1;
          print_string ", ";
          print_tree t2;
          print_string ")"
      | (TWOR (t1, t2)) ->
          print_string "TWOR (";
          print_tree t1;
          print_string ", ";
          print_tree t2;
          print_string ")"
      | (THREE (t1, t2, t3)) ->
          print_string "THREE (";
          print_tree t1;
          print_string ", ";
          print_tree t2;
          print_string ", ";
          print_tree t3;
          print_string ")" in
    let rec print_digit_stream s =
      let print_digit_stream_val = function
        | (lazy S.Nil) -> print_string "Nil"
        | (lazy (S.Cons (d, ds))) ->
            print_string "Cons (";
            print_digit d;
            print_string ",\n";
            print_digit_stream ds;
            print_string ")" in
      if show || Lazy.lazy_is_val s
      then print_digit_stream_val s
      else print_string "SUSP" in
    let rec print_schedule = function
      | [] -> ();
      | (s :: ss) ->
          print_digit_stream s;
          print_string ";\n";
          print_schedule ss in
    print_string "rlist (\n";
    print_string "digits (\n";
    print_digit_stream xs;
    print_string "),\nsched [\n";
    print_schedule ys;
    print_string "])";
    print_newline ()
  ;;

  let print xs = dprint false xs
  ;;
end

module IntLazyBinaryRandomAccessList = LazyBinaryRandomAccessList (Int)

runTestEx0910.ml

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

(* Tests for LazyBinaryRandomAccessList *)
#use "ex0910_LazyBinaryRandomAccessList.ml";;
open IntLazyBinaryRandomAccessList;;

module L = IntLazyBinaryRandomAccessList

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

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

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

(* 3 *)
let rlist_3 = cons_rlist 3;;
print_string "n = 3:\n"; L.print rlist_3;;

(* 33 *)
let rlist_9 = cons_rlist 9;;
print_string "n = 9:\n";  L.print rlist_9;;
print_string "n = 10:\n"; L.print (L.cons (9, rlist_9));;

(* 333 *)
let rlist_21 = cons_rlist 21;;
print_string "n = 21:\n"; L.print rlist_21;;
print_string "n = 22:\n"; L.print (L.cons (21, rlist_21));;
print_string "n = 23:\n"; L.print (L.cons (22, (L.cons (21, rlist_21))));;
print_string "n = 24:\n"; L.print (cons_rlist 24);;
print_string "n = 25:\n"; L.print (cons_rlist 25);;
print_string "n = 26:\n"; L.print (cons_rlist 26);;
print_string "n = 27:\n"; L.print (cons_rlist 27);;
print_string "n = 28:\n"; L.print (cons_rlist 28);;
print_string "n = 29:\n"; L.print (cons_rlist 29);;
print_string "n = 30:\n"; L.print (cons_rlist 30);;

(* 22 *)
let rlist_21_14 = tail_rlist 14 rlist_21;;
print_string "n = 21 - 14 = 7\n"; L.print rlist_21_14;;
print_string "n = 21 - 15 = 6\n"; L.print (L.tail rlist_21_14);;

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

let test_9 _ = match L.isEmpty rlist_9 with
  | false -> assert_bool "ok" true
  | _  -> assert_failure "not correct" 
;;

let test_9_head = assert_equal (8, rlist_9)

let test_9_lookup _ =
  assert_equal 8 (L.lookup (0, rlist_9));
  assert_equal 7 (L.lookup (1, rlist_9));
  assert_equal 6 (L.lookup (2, rlist_9));
  assert_equal 5 (L.lookup (3, rlist_9));
  assert_equal 4 (L.lookup (4, rlist_9));
  assert_equal 3 (L.lookup (5, rlist_9));
  assert_equal 2 (L.lookup (6, rlist_9));
  assert_equal 1 (L.lookup (7, rlist_9));
  assert_equal 0 (L.lookup (8, rlist_9))
;;

let test_9_update _ = 
  let rlist_9a = L.update (3, 10, rlist_9) in
  let rlist_9b = L.update (8, 11, rlist_9a) in
  let rlist_9c = L.update (5, 12, rlist_9b) in
  let rlist_9d = L.update (0, 13, rlist_9c) in
  let rlist_9e = L.cons (14, rlist_9d) in
  assert_equal 13 (L.head rlist_9d);
  assert_equal 14 (L.head rlist_9e);
  assert_equal 14 (L.lookup (0, rlist_9e));
  assert_equal 13 (L.lookup (1, rlist_9e));
  assert_equal 7 (L.lookup (2, rlist_9e));
  assert_equal 6 (L.lookup (3, rlist_9e));
  assert_equal 10 (L.lookup (4, rlist_9e));
  assert_equal 4 (L.lookup (5, rlist_9e));
  assert_equal 12 (L.lookup (6, rlist_9e));
  assert_equal 2 (L.lookup (7, rlist_9e));
  assert_equal 1 (L.lookup (8, rlist_9e));
  assert_equal 11 (L.lookup (9, rlist_9e))
;;

let suite = "Test LazyBinaryRandomAccessList Exercise 9.10" >:::
  ["test_0"        >:: test_0;
   "test_9"        >:: test_9;
   "test_9_lookup" >:: test_9_lookup;
   "test_9_update" >:: test_9_update;
  ]
;;

let _ = run_test_tt_main suite;;