(*
   Original source code in SML from:

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

   Translation from SML to OCAML (this file):

     Copyright (C) 1999, 2000, 2001  Markus Mottl
     email:  markus.mottl@gmail.com
     www:    http://www.ocaml.info

   Unless this violates copyrights of the original sources, the following
   licence applies to this file:

   This source code is free software; you can redistribute it and/or
   modify it without any restrictions. It is distributed in the hope
   that it will be useful, but WITHOUT ANY WARRANTY.
*)

(***********************************************************************)
(*                              Chapter 2                              *)
(***********************************************************************)

exception Empty
exception Subscript


module type STACK = sig
  type 'a stack

  val empty : 'a stack
  val is_empty : 'a stack -> bool
  val cons : 'a -> 'a stack -> 'a stack
  val head : 'a stack -> 'a        (* raises Empty if stack is empty *)
  val tail : 'a stack -> 'a stack  (* raises Empty if stack is empty *)
end


module ListStack : STACK = struct
  type 'a stack = 'a list

  let empty = []
  let is_empty s = s = []
  let cons x s = x :: s
  let head = function [] -> raise Empty | h :: _ -> h
  let tail = function [] -> raise Empty | _ :: t -> t
end


module CustomStack : STACK = struct
  type 'a stack = Nil | Cons of 'a * 'a stack

  let cons x s = Cons (x, s)
  let empty = Nil

  let is_empty s = s = Nil
  let head = function Nil -> raise Empty | Cons (x, _) -> x
  let tail = function Nil -> raise Empty | Cons (_, s) -> s

  let rec (++) xs ys =
    if is_empty xs then ys
    else cons (head xs) (tail xs ++ ys)
end


let rec (++) xs ys = match xs with
  | [] -> ys
  | xh :: xt -> xh :: (xt ++ ys)

let rec update lst i y = match lst, i with
  | [], _ -> raise Subscript
  | x :: xs, 0 -> y :: xs
  | x :: xs, _ -> x :: update xs (i - 1) y


module type SET = sig
  type elem
  type set

  val empty : set
  val insert : elem -> set -> set
  val member : elem -> set -> bool
end


(* A totally ordered type and its comparison functions *)
module type ORDERED = sig
  type t

  val eq : t -> t -> bool
  val lt : t -> t -> bool
  val leq : t -> t -> bool
end


module UnbalancedSet (Element : ORDERED) : (SET with type elem = Element.t) =
struct
  type elem = Element.t
  type tree = E | T of tree * elem * tree
  type set = tree

  let empty = E

  let rec member x = function
    | E -> false
    | T (a, y, b) ->
        if Element.lt x y then member x a
        else if Element.lt y x then member x b
        else true

  let rec insert x = function
    | E -> T (E, x, E)
    | T (a, y, b) as s ->
        if Element.lt x y then T (insert x a, y, b)
        else if Element.lt y x then T (a, y, insert x b)
        else s
end


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