Skip to content

Instantly share code, notes, and snippets.

@yuga
Created September 30, 2012 00:59
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save yuga/3805535 to your computer and use it in GitHub Desktop.
Save yuga/3805535 to your computer and use it in GitHub Desktop.
a solution to Exercise 9.10 of "Purely Functional Data Structures (PFDS)"
(* 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)
#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;;
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment