(*
   Example solutions to exercises from

        Purely Functional Data Structures
        Chris Okasaki
        Cambridge University Press, 1998
        Copyright (c) 1998 Cambridge University Press

   Copyright of the solutions (C) 1999 - 2002 Markus Mottl
   This is free software.

   No guarantee for correctness! Some parts untested!
   Mail any bugs or suggestions to: markus.mottl@gmail.com

   Note for students:
   Unless you want to compare your solution with mine or have seriously
   tried (at least one day ;-) to find one without success, you should
   not look at this file.

   Following Mr. Okasaki's proposition to not publish any example
   solutions, I will restrict myself from publishing more unless solutions
   appear on other web sites / in other languages.

   The sources from the book ported from SML to OCAML can be downloaded
   from:

     http://www.ocaml.info/home/ocaml_sources.html
*)


(* Exercise 2.1 *)
let rec suffixes = function
  | [] -> [[]]
  | _ :: t as lst -> lst :: suffixes t


(* declarations for the following exercises *)

(* type of binary trees *)
type 'a btree = E | T of 'a btree * 'a * 'a btree


(* Exercise 2.2 *)

(* Traditional "member" function *)
let rec member x = function
  | E -> false
  | T (l, y, r) ->
      if x < y then member x l
      else if x > y then member x r
      else true

(* Alternative "member" function *)
let member1 x =
  let rec loop_none = function
    | E -> false
    | T (l, y, r) ->
        if x < y then loop_none l
        else loop_some y r
  and loop_some last = function
    | E -> last = x
    | T (l, y, r) ->
        if x < y then loop_some last l
        else loop_some y r in
  loop_none


(* Exercise 2.3 *)

(* Traditional "insert" function *)
let rec insert x = function
  | E -> T (E, x, E)
  | T (l, y, r) as t ->
      if x < y then T (insert x l, y, r)
      else if x > y then T (l, y, insert x r)
      else t

(* Alternative "insert" function *)
let insert1 x t =
  let rec insert' = function
    | E -> T (E, x, E)
    | T (l, y, r) ->
        if x < y then T (insert' l, y, r)
        else if x > y then T (l, y, insert' r)
        else raise Exit in
  try insert' t with Exit -> t


(* Exercise 2.4 *)

(* Very alternative "insert" function *)
let insert2 x t =
  let rec loop_none = function
    | E -> T (E, x, E)
    | T (l, y, r) ->
        if x < y then let nl = loop_none l in T (nl, y, r)
        else let nr = loop_some y r in T (l, y, nr)
  and loop_some last = function
    | E -> if last = x then raise Exit else T (E, x, E)
    | T (l, y, r) ->
        if x < y then let nl = loop_some last l in T (nl, y, r)
        else let nr = loop_some y r in T (l, y, nr) in
  try loop_none t with Exit -> t


(* Exercise 2.5a *)
let rec complete x = function
  | 0 -> E
  | d when d < 0 -> failwith "complete: negative depth"
  | d -> let d' = complete x (d - 1) in T (d', x, d')


(* Exercise 2.5b *)
(* This one is a bit tricky! Try to solve it without the solution! *)
let rec complete2 x =
  let makeT (tl, tr) = T (tl, x, tr) in
  let rec create2 m =
    if m = 0 then T (E, x, E), E
    else
      let (t_big, t_small) = create2 ((m - 1) lsl 1) in
      if m mod 2 = 0 then makeT (t_big, t_big), makeT (t_big, t_small)
      else makeT (t_big, t_small), makeT (t_small, t_small) in
  function
  | 0 -> E
  | n when n < 0 -> failwith "complete2: negative size"
  | n ->
      let n' = n - 1 in
      let n1 = n' lsl 1 in
      if n1 = n' - n1 then let t = complete2 x n1 in makeT (t, t)
      else makeT (create2 n1)


(* Exercise 2.6 *)

(* the type of ordered elements *)
module type ORDERED =
sig
  type t
  
  val eq  : t -> t -> bool
  val lt  : t -> t -> bool
  val leq : t -> t -> bool
end

(* the type of finite maps *)
module type FINITE_MAP = 
sig 
  type key
  type 'a map

  val empty  : 'a map
  val bind   : key -> 'a -> 'a map -> 'a map
  val lookup : key -> 'a map -> 'a (* raise Not_found if key is not found *)
end

(* implementation of a finite map (unbalanced) *)
(* this version is sugared with the property to not copy
   paths on insertion if the binding already exists *)
module UnbalancedMap (Key : ORDERED) : (FINITE_MAP with type key = Key.t) =
struct
  type key = Key.t
  type 'a map = E | T of key * 'a * 'a map * 'a map

  let empty = E

  let bind kx vx map =
    let rec bind' = function
      | E -> T (kx, vx, E, E)
      | T (ky, vy, l, r) ->
          if kx < ky then let nl = bind' l in T (ky, vy, nl, r)
          else if kx > ky then let nr = bind' r in T (ky, vy, l, nr)
          else if vy = vx then raise Exit
          else T (kx, vx, l, r) in
    try bind' map with Exit -> map

  let rec lookup kx = function
    | E -> raise Not_found
    | T (ky, v, l, r) ->
        if kx < ky then lookup kx l
        else if kx > ky then lookup kx r
        else v
end