okasaki exercises

okasaki.ml

(* Chapter 2: BST *)

type 'a tree = Empty | Node of 'a tree * 'a * 'a tree

module Set : sig
  val empty  : 'a tree
  val member : 'a tree -> 'a -> bool
  val insert : 'a tree -> 'a -> 'a tree
end = struct
  let empty = Empty

  (* Exercise 2.2: O(d + 1) membership check. *)
  let member s x =
    let rec inner s cand = match s with
      | Empty -> cand = x
      | Node (l, v, r) ->
          if x < v then
            inner l cand
          else
            inner r v
    in match s with
      | Empty -> false
      | Node (_, v, _) -> inner s v

  (* Exercise 2.3 & 2.4: no extra-copies. *)
  exception Found
  let insert s x =
    let rec inner s cand = match s with
      | Empty ->
          if cand != x then
            Node (Empty, x, Empty)
          else
            raise Found
      | Node (l, v, r) ->
          if x < v then
            Node (inner l cand, v, r)
          else
            Node (l, v, inner r v)
    in match s with
      | Empty -> Node (Empty, x, Empty)
      | Node (_, v, _) as s ->
          try
            inner s v
          with Found ->
            s
end;;


let l =  [1; 2; 3; -1; -2; 0] in
let s = Set.(List.fold_left insert empty l) in
  assert (List.for_all (Set.member s) l);
  assert (not (Set.member s 100500))
;;


module Tree = struct
  (* Exercise 2.5 (a): complete binary tree in O(d). *)
  let complete depth x =
    let rec inner t = function
      | 0 -> t
      | d -> inner (Node (t, x, t)) (d - 1)
    in inner Empty depth

  (* Exercise 2.5 (b): balanced trees of arbitrary size.
     TODO: ...
  *)
  let balanced size x = Empty
end;;


(* Exercise 2.6: naive finite map (no comparison optimization). *)
module FiniteMap : sig
  val empty  : ('a * 'b) tree
  val bind   : ('a * 'b) tree -> 'a -> 'b -> ('a * 'b) tree
  val lookup : ('a * 'b) tree -> 'a -> 'b
end = struct
  let empty = Empty

  let bind m k v =
    let rec inner = function
      | Empty -> Node (Empty, (k, v), Empty)
      | Node (l, ((k', v') as p), r) ->
        if k' < k then
          Node (inner l, p, r)
        else if k' > k then
          Node (l, p, inner r)
        else
          Node (l, (k, v), r)
    in inner m

  let lookup m k =
    let rec inner = function
      | Empty -> raise Not_found
      | Node (l, (k', v'), r) ->
        if k' < k then
          inner l
        else if k' > k then
          inner r
        else v'
    in inner m
end;;


let l = [("foo", 1); ("bar", 2)] in
let m = List.fold_left (fun m (k, v) -> FiniteMap.bind m k v)
  FiniteMap.empty l
in begin
  assert (List.for_all (fun (k, v) -> FiniteMap.lookup m k == v) l)
end;;