chp8.ml

(*
   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 8                              *)
(***********************************************************************)

exception Empty
exception Not_implemented
exception Impossible_pattern of string

let impossible_pat x = raise (Impossible_pattern x)


module type QUEUE = sig
  type 'a queue

  val empty : 'a queue
  val is_empty : 'a queue -> bool

  val snoc : 'a queue -> 'a -> 'a queue
  val head : 'a queue -> 'a        (* raises Empty if queue is empty *)
  val tail : 'a queue -> 'a queue  (* raises Empty if queue is empty *)
end


module type DEQUE = sig
  type 'a queue

  val empty : 'a queue
  val is_empty : 'a queue -> bool

  (* insert, inspect, and remove the front element *)
  val cons : 'a -> 'a queue -> 'a queue
  val head : 'a queue -> 'a        (* raises Empty if queue is empty *)
  val tail : 'a queue -> 'a queue  (* raises Empty if queue is empty *)

  (* insert, inspect, and remove the rear element *)
  val snoc : 'a queue -> 'a -> 'a queue
  val last : 'a queue -> 'a        (* raises Empty if queue is empty *)
  val init : 'a queue -> 'a queue  (* raises Empty if queue is empty *)
end


(* ---------- Streams as found in chapter 4 ---------- *)

let (!$) = Lazy.force

module type STREAM = sig
  type 'a stream = Nil | Cons of 'a * 'a stream Lazy.t

  val (++) : 'a stream -> 'a stream -> 'a stream  (* stream append *)
  val take : int -> 'a stream -> 'a stream
  val drop : int -> 'a stream -> 'a stream
  val reverse : 'a stream -> 'a stream
end

module Stream : STREAM = struct
  type 'a stream = Nil | Cons of 'a * 'a stream Lazy.t

  (* function lazy *)
  let rec (++) s1 s2 = match s1 with
    | Nil -> s2
    | Cons (hd, tl) -> Cons (hd, lazy (!$tl ++ s2))

  (* function lazy *)
  let rec take n s = match n, s with
    | 0, _ -> Nil
    | _, Nil -> Nil
    | _, Cons (hd, tl) -> Cons (hd, lazy (take (n - 1) !$tl))

  (* function lazy *)
  let drop n s =
    let rec drop' n s = match n, s with
      | 0, _ -> s
      | _, Nil -> Nil
      | _, Cons (_, tl) -> drop' (n - 1) !$tl in
    drop' n s

  (* function lazy *)
  let reverse s =
    let rec reverse' acc = function
      | Nil -> acc
      | Cons (hd, tl) -> reverse' (Cons (hd, lazy acc)) !$tl in
    reverse' Nil s
end


open Stream

module HoodMelvilleQueue : QUEUE = struct
  type 'a rotation_state =
    | Idle
    | Reversing of int * 'a list * 'a list * 'a list * 'a list
    | Appending of int * 'a list * 'a list
    | Done of 'a list

  type 'a queue = int * 'a list * 'a rotation_state * int * 'a list

  let exec = function
    | Reversing (ok, x :: f, f', y :: r, r') ->
        Reversing (ok + 1, f, x :: f', r, y :: r')
    | Reversing (ok, [], f', [y], r') -> Appending (ok, f', y :: r')
    | Appending (0, _, r') -> Done r'
    | Appending (ok, x :: f', r') -> Appending (ok - 1, f', x :: r')
    | state -> state

  let invalidate = function
    | Reversing (ok, f, f', r, r') -> Reversing (ok - 1, f, f', r, r')
    | Appending (0, _, _ :: r') -> Done r'
    | Appending (ok, f', r') -> Appending (ok - 1, f', r')
    | state -> state

  let exec2 (lenf, f, state, lenr, r) =
    match exec (exec state) with
    | Done newf -> (lenf, newf, Idle, lenr, r)
    | newstate -> lenf, f, newstate, lenr, r

  let check ((lenf, f, state, lenr, r) as q) =
    if lenr <= lenf then exec2 q
    else
      let newstate = Reversing (0, f, [], r, []) in
      exec2 (lenf + lenr, f, newstate, 0, [])

  let empty = 0, [], Idle, 0, []
  let is_empty (lenf, _, _, _, _) = lenf = 0

  let snoc (lenf, f, state, lenr, r) x = check (lenf, f, state, lenr + 1, x::r)

  let head = function
    | lenf, [], state, lenr, r -> raise Empty
    | lenf, x :: f, state, lenr, r -> x

  let tail = function
    | lenf, [], state, lenr, r -> raise Empty
    | lenf, x :: f, state, lenr, r ->
        check (lenf - 1, f, invalidate state, lenr, r)
end


module BankersDeque (C : sig val c : int end) : DEQUE =  (* c > 1 *)
struct
  let c = C.c

  type 'a queue = int * 'a stream * int * 'a stream

  let empty = 0, Nil, 0, Nil
  let is_empty (lenf, _, lenr, _) = lenf + lenr = 0

  let check (lenf, f, lenr, r as q) =
    if lenf > c*lenr + 1 then
      let i = (lenf + lenr) / 2 in
      i, take i f, lenf + lenr - i, r ++ reverse (drop i f)
    else if lenr > c*lenf + 1 then
      let j = (lenf + lenr) / 2 in
      lenf + lenr - j, f ++ reverse (drop j r), j, take j r
    else q

  let cons x (lenf, f, lenr, r) = check (lenf + 1, Cons (x, lazy f), lenr, r)

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

  let tail = function
    | _, Nil, _, Nil -> raise Empty
    | _, Nil, _, Cons (_, _) -> empty
    | lenf, Cons (x, f'), lenr, r -> check (lenf - 1, !$f', lenr, r)

  let snoc (lenf, f, lenr, r) x = check (lenf, f, lenr + 1, Cons (x, lazy r))

  let last = function
    | _, Nil, _, Nil -> raise Empty
    | _, Cons (x, _), _, Nil -> x
    | _, _, _, Cons (x, _) -> x

  let init = function
    | _, Nil, _, Nil -> raise Empty
    | _, Cons (_, _), _, Nil -> empty
    | lenf, f, lenr, Cons (_, r') -> check (lenf, f, lenr - 1, !$r')
end


module RealTimeDeque (C : sig val c : int end) : DEQUE =  (* c = 2 or c = 3 *)
struct
  let c = C.c

  type 'a queue = int * 'a stream * 'a stream * int * 'a stream * 'a stream

  let empty = 0, Nil, Nil, 0, Nil, Nil
  let is_empty (lenf, f, sf, lenr, r, sr) = lenf + lenr = 0

  let exec1 = function Cons (x, s) -> !$s | s -> s
  let exec2 s = exec1 (exec1 s)

  let rec rotate_rev s r a = match s, r, a with
    | Nil, _, _ -> reverse r ++ a
    | Cons (x, f), _, _ ->
        Cons (x, lazy (rotate_rev !$f (drop c r) (reverse (take c r) ++ a)))

  let rec rotate_drop f j r =
    if j < c then rotate_rev f (drop j r) Nil
    else
      match f with
      | Cons (x, f') -> Cons (x, lazy (rotate_drop !$f' (j - c) (drop c r)))
      | _ -> impossible_pat "rotate_drop"

  let check (lenf, f, sf, lenr, r, sr as q) =
    if lenf > c*lenr + 1 then
      let i = (lenf + lenr) / 2 in
      let f' = take i f
      and r' = rotate_drop r i f in
      i, f', f', lenf + lenr - i, r', r'
    else if lenr > c*lenf + 1 then
      let j = (lenf + lenr) / 2 in
      let r' = take j r
      and f' = rotate_drop f j r in
      lenf + lenr - j, f', f', j, r', r'
    else q

  let cons x (lenf, f, sf, lenr, r, sr) =
    check (lenf + 1, Cons (x, lazy f), exec1 sf, lenr, r, exec1 sr)

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

  let tail = function
    | _, Nil, _, _, Nil, _ -> raise Empty
    | _, Nil, _, _, Cons (x, _), _ -> empty
    | lenf, Cons (x, f'), sf, lenr, r, sr ->
        check (lenf - 1, !$f', exec2 sf, lenr, r, exec2 sr)

  let snoc (lenf, f, sf, lenr, r, sr) x =
    check (lenf, f, exec1 sf, lenr + 1, Cons (x, lazy r), exec1 sr)

  let last = function
    | _, Nil, _, _, Nil, _ -> raise Empty
    | _, Cons (x, _), _, _, Nil, _ -> x
    | _, _, _, _, Cons (x, _), _ -> x

  let init = function
    | _, Nil, _, _, Nil, _ -> raise Empty
    | _, Cons (x, _), _, _, Nil, _ -> empty
    | lenf, f, sf, lenr, Cons (x, r'), sr ->
        check (lenf, f, exec2 sf, lenr - 1, !$r', exec2 sr)
end