Markus Mottl avatar Markus Mottl committed 105fceb

Imported pure-fun

Comments (0)

Files changed (12)

+2006-03-29:  Removed superfluous thunking of "empty" values in polymorphic
+             datastructures due to relaxed value restriction in new
+             OCaml-releases.
+
+2002-07-23:  Small beautification.
+
+2001-06-05:  Made code more idiomatic.
+             Implemented stubs in chapter 8.
+
+1999-04-09:  Initial release.
+These files contain an SML-to-OCAML translation of source examples taken
+from the following book:
+
+     Purely Functional Data Structures
+     Chris Okasaki
+     Cambridge University Press, 1998
+     Copyright (c) 1998 Cambridge University Press
+
+
+Some short notes regarding my port:
+
+I have tried to stick as close as possible to the original code, but
+sometimes this cannot be done.
+
+The first nine chapters are translated now. Although there are two further
+chapters, I will not translate them anymore, because of restrictions
+that exist not only in SML but also in OCAML:
+
+The basic idea of chapter 10 and 11 is the application of techniques
+called "structural decomposition" and "structural abstraction" (10)
++ their combination and generalization with ideas in chapter 9 (lazy
+redundant binary numbers) in a framework called "implicit recursive
+slowdown" (11).
+
+Structural decomposition and abstraction require socalled "polymorphic
+recursion". Type inference is unfortunately undecidable in the presence
+of the latter, so neither OCAML nor SML support it.
+
+Thus, the author presents two versions for his examples in these chapters:
+one which does not pass the type checker because of polymorphic recursion
+(for demonstration purposes only), anotherone for showing how to work
+around this restriction.
+
+In a question posted to the OCAML-list, I learnt from the OCAML-developers
+that they are actively researching ways to circumvent the problem of
+polymorphic recursion (e.g. with "forward"-definitions that allow the
+user to restrict the type of a polymorphically recursive definition). In
+the not unlikely case that they succeed, I will continue to translate
+the remaining chapters.
+
+If someone wants to translate the "workaround"-solutions, I will be glad
+to include them in this distribution. In the meanwhile I will wait and
+see what happens in future OCAML-releases.
+
+
+Notes on efficiency:
+
+Because the data structures are purely functional, they profit a lot from
+garbage collector settings. In case you find that some of them are not
+efficient enough, you might want to raise the memory overhead parameter
+of the garbage collector. See "http://caml.inria.fr/ocaml/speed.html"
+for more details. Performance is in general excellent.
+
+
+The following rules / differences to the original sources exist:
+
+* No base module
+
+Since there is hardly anything really necessary in the base module,
+I copied the few relevant declarations into the modules. This allows
+easier testing, because the modules do not depend on others.
+
+
+* Syntax
+
+Names are created by the following rules:
+
+  * Module types are written in capitals. If they consist of more than
+    a word, an underscore ('_') is placed between the words.
+
+  * Names of exceptions follow the same rule as modules types.
+
+  * Module implementations have to start with a capital letter, the
+    rest of the name is lowercase - except if it consists of more than
+    one word. In this case the first letter of the following word is
+    uppercase. There is no underscore between words.
+
+
+* Currying of function parameters
+
+Currying is not used anywhere in the original source. I have tried to
+curry parameters, where it makes sense. Tuples that represent a named type
+(e.g. some data structure) are *not* curried in functions that are hidden
+by a signature restriction -> more comprehensible.  Functions offered
+via the module interface (signature) do not reveal such implementation
+details (concrete type) anyway, of course.
+
+
+* Superfluous bindings
+
+If a parameter is never used in a following expression, it is not bound
+to any name, but '_' will hold its place.
+
+
+* Lazy evaluation
+
+Lazy evaluation is neither an integral part of SML nor of OCAML.
+The original author uses an experimental syntax for describing data
+structures that have to be evaluated lazily. To give people a hint,
+how lazy behaviour can be done, I have used the "Lazy"-module found in
+the standard distribution of OCAML.
+
+To make the syntax at least a bit more similar to the original, I
+have introduced the prefix operator '!$', which stands for 'force" -
+it forces evaluation of a lazy expression. To make an expression lazy,
+the expression 'lazy' is used.
+
+There is a test function at the end of the translation of chapter 4,
+the chapter in which lazy evaluation and streams (= lazy lists) are
+introduced. Uncomment it to try out, how lazy evaluation behaves.
+
+
+* Interface QUEUE
+
+Due to the impossibility to safely generalize expressions in modules
+when parameterized types are used together with "Lazy.t", I had to change
+the interface (most convenient workaround):
+
+Instead of the value
+
+  val empty    : 'a queue
+
+the function
+
+  val empty    : unit -> 'a queue
+
+is used now. This guarantees that the empty value can be generated
+without anomalies.
+
+For details see:
+
+  http://caml.inria.fr/FAQ/FAQ_EXPERT-eng.html#variables_de_types_faibles
+
+This change allowed e.g. the translation of "PhysicstsQueue".  Of course,
+you have to use "empty ()" to get the empty value of queues now.
+
+---------------------------------------------------------------------------
+
+Enjoy the data structures!
+
+Vienna, April 9, 1999
+Markus Mottl (markus.mottl@gmail.com)
+This directory contains the Standard ML source code from
+
+    Purely Functional Data Structures
+    Chris Okasaki
+    Cambridge University Press, 1998
+
+The code is organized into files according to chapter, from "chp2.sml" to
+"chp11.sml".  Each file is self-contained, except for a few miscellaneous
+definitions in "base.sml".
+
+The code in the book assumes two non-standard language extensions: support for
+lazy evaluation and support for polymorphic recursion.  I have modified the
+on-line code to work around the lack of polymorphic recursion, but I have
+made only minor changes regarding lazy evaluation.  IN PARTICULAR, IF YOU
+COMPILE THE CODE "AS IS", IT WILL NOT USE LAZY EVALUATION, AND SO WILL NOT
+ACHIEVE THE RUNNING TIMES CLAIMED IN THE BOOK.
+
+In the book, I assumed that lazy evaluation was supported in the language with
+a $ operator: "$ exp" would create a suspension for the expression "exp", and
+matching that suspension against a pattern of the form "$ pat" would evaluate
+and memoize the suspension.  In the on-line code, I simulate this with the
+following definition in "base.sml":
+
+  datatype 'a susp = $ of 'a
+
+But, of course, this $ constructor is not lazy!  
+
+There are two further differences related to lazy evaluation.  First, the 
+code in the book assumes that $ parses with a lower precedence than an ordinary
+constructor.  Therefore, in the on-line code, I have replaced some occurrences
+of "$ exp" with "$ (exp)".  Second, the code in the book assumes the
+ability to write lazy functions using a special "fun lazy" syntax.  In the
+on-line code, I have eliminated dependence on this form.
+
+Note that Standard ML of New Jersey now supports lazy evaluation using a 
+similar, but not quite identical, syntax.  Updating the on-line code
+to use their syntax requires the following changes:
+
+  - replace each occurrence of
+        val s = $ (exp)
+    with
+        val lazy s = $ (exp)
+
+  - replace each remaining occurrence of
+        ... $ (exp) ...
+    with
+        let val lazy s = $ (exp)
+        in ... s ... end
+
+
+Chris Okasaki
+cdo@cs.columbia.edu
+release-1-0-6
+(*
+   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
+(*
+   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 3                              *)
+(***********************************************************************)
+
+exception Empty
+exception Impossible_pattern of string
+
+let impossible_pat x = raise (Impossible_pattern x)
+
+
+(* 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 type HEAP = sig
+  module Elem : ORDERED
+
+  type heap
+
+  val empty : heap
+  val is_empty : heap -> bool
+
+  val insert : Elem.t -> heap -> heap
+  val merge : heap -> heap -> heap
+
+  val find_min : heap -> Elem.t  (* raises Empty if heap is empty *)
+  val delete_min : heap -> heap  (* raises Empty if heap is empty *)
+end
+
+
+module LeftistHeap (Element : ORDERED) : (HEAP with module Elem = Element) =
+struct
+  module Elem = Element
+
+  type heap = E | T of int * Elem.t * heap * heap
+
+  let rank = function E -> 0 | T (r,_,_,_) -> r
+
+  let makeT x a b =
+    if rank a >= rank b then T (rank b + 1, x, a, b)
+    else T (rank a + 1, x, b, a)
+
+  let empty = E
+  let is_empty h = h = E
+
+  let rec merge h1 h2 = match h1, h2 with
+    | _, E -> h1
+    | E, _ -> h2
+    | T (_, x, a1, b1), T (_, y, a2, b2) ->
+        if Elem.leq x y then makeT x a1 (merge b1 h2)
+        else makeT y a2 (merge h1 b2)
+
+  let insert x h = merge (T (1, x, E, E)) h
+  let find_min = function E -> raise Empty | T (_, x, _, _) -> x
+  let delete_min = function E -> raise Empty | T (_, x, a, b) -> merge a b
+end
+
+
+module BinomialHeap (Element : ORDERED) : (HEAP with module Elem = Element) =
+struct
+  module Elem = Element
+
+  type tree = Node of int * Elem.t * tree list
+  type heap = tree list
+
+  let empty = []
+  let is_empty ts = ts = []
+
+  let rank (Node (r, _, _)) = r
+  let root (Node (_, x, _)) = x
+
+  let link (Node (r, x1, c1) as t1) (Node (_, x2, c2) as t2) =
+    if Elem.leq x1 x2 then Node (r + 1, x1, t2 :: c1)
+    else Node (r + 1, x2, t1 :: c2)
+
+  let rec ins_tree t = function
+    | [] -> [t]
+    | t' :: ts' as ts ->
+        if rank t < rank t' then t :: ts
+        else ins_tree (link t t') ts'
+
+  let insert x ts = ins_tree (Node (0, x, [])) ts
+
+  let rec merge ts1 ts2 = match ts1, ts2 with
+    | _, [] -> ts1
+    | [], _ -> ts2
+    | t1 :: ts1', t2 :: ts2' ->
+        if rank t1 < rank t2 then t1 :: merge ts1' ts2
+        else if rank t2 < rank t1 then t2 :: merge ts1 ts2'
+        else ins_tree (link t1 t2) (merge ts1' ts2')
+
+  let rec remove_min_tree = function
+    | [] -> raise Empty
+    | [t] -> t, []
+    | t :: ts ->
+        let t', ts' = remove_min_tree ts in
+        if Elem.leq (root t) (root t') then (t, ts)
+        else (t', t :: ts')
+
+  let find_min ts = root (fst (remove_min_tree ts))
+
+  let delete_min ts =
+    let Node (_, x, ts1), ts2 = remove_min_tree ts in
+    merge (List.rev ts1) ts2
+end
+
+
+module type SET = sig
+  type elem
+  type set
+
+  val empty : set
+  val insert : elem -> set -> set
+  val member : elem -> set -> bool
+end
+
+
+module RedBlackSet (Element : ORDERED) : (SET with type elem = Element.t) =
+struct
+  type elem = Element.t
+
+  type color = R | B
+  type tree = E | T of color * 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 balance = function
+    | B, T (R, T (R, a, x, b), y, c), z, d
+    | B, T (R, a, x, T (R, b, y, c)), z, d
+    | B, a, x, T (R, T (R, b, y, c), z, d)
+    | B, a, x, T (R, b, y, T (R, c, z, d)) ->
+        T (R, T (B, a, x, b), y, T (B, c, z, d))
+    | a, b, c, d -> T (a, b, c, d)
+
+  let insert x s =
+    let rec ins = function
+      | E -> T (R, E, x, E)
+      | T (color, a, y, b) as s ->
+          if Element.lt x y then balance (color, ins a, y, b)
+          else if Element.lt y x then balance (color, a, y, ins b)
+          else s in
+    match ins s with  (* guaranteed to be non-empty *)
+    | T (_, a, y, b) -> T (B, a, y, b)
+    | _ -> impossible_pat "insert"
+end
+(*
+   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 - 2002  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 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 = function
+    | _ when n = 0 -> Nil
+    | Nil -> Nil
+    | Cons (hd, tl) -> Cons (hd, lazy (take (n - 1) !$tl))
+
+  (* function lazy *)
+  let rec drop n = function
+    | s when n = 0 -> s
+    | Nil -> Nil
+    | Cons (_, tl) -> drop (n - 1) !$tl
+
+  (* 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
+
+(*
+(* MM: for demonstration purposes *)
+open Stream
+
+let rec l_map f = function
+  | Nil -> Nil
+  | Cons (hd, tl) -> Cons (f hd, lazy (l_map f !$tl))
+
+let rec l_iter f n = function
+  | Nil -> ()
+  | Cons (hd, tl) -> if n > 0 then begin f hd; l_iter f (n-1) !$tl end
+
+let rec nat = Cons (0, lazy (l_map succ nat))
+
+let _ =
+  let test = reverse (take 10 (drop 50 (take 1000000000 nat))) in
+  l_iter (fun n -> print_int n; print_newline ()) 1000 test
+*)
+(*
+   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 5                              *)
+(***********************************************************************)
+
+exception Empty
+
+
+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 BatchedQueue : QUEUE = struct
+  type 'a queue = 'a list * 'a list
+
+  let empty = [], []
+  let is_empty (f, r) = f = []
+
+  let checkf (f, r as q) = if f = [] then List.rev r, f else q
+
+  let snoc (f, r) x = checkf (f, x :: r)
+  let head = function [], _ -> raise Empty | x :: _, _ -> x
+  let tail = function [], _ -> raise Empty | _ :: f, r -> checkf (f, r)
+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
+
+
+(* 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 type HEAP = sig
+  module Elem : ORDERED
+
+  type heap
+
+  val empty : heap
+  val is_empty : heap -> bool
+
+  val insert : Elem.t -> heap -> heap
+  val merge : heap -> heap -> heap
+
+  val find_min : heap -> Elem.t  (* raises Empty if heap is empty *)
+  val delete_min : heap -> heap  (* raises Empty if heap is empty *)
+end
+
+
+module SplayHeap (Element : ORDERED) : (HEAP with module Elem = Element) =
+struct
+  module Elem = Element
+
+  type heap = E | T of heap * Elem.t * heap
+
+  let empty = E
+  let is_empty h = h = E
+
+  let rec partition pivot = function
+    | E -> E, E
+    | T (a, x, b) as t ->
+        if Elem.leq x pivot then
+          match b with
+          | E -> t, E
+          | T (b1, y, b2) ->
+              if Elem.leq y pivot then
+                let small, big = partition pivot b2 in
+                T (T (a, x, b1), y, small), big
+              else
+                let small, big = partition pivot b1 in
+                T (a, x, small), T (big, y, b2)
+        else
+          match a with
+          | E -> E, t
+          | T (a1, y, a2) ->
+              if Elem.leq y pivot then
+                let small, big = partition pivot a2 in
+                T (a1, y, small), T (big, x, b)
+              else
+                let small, big = partition pivot a1 in
+                small, T (big, y, T (a2, x, b))
+
+  let insert x t = let a, b = partition x t in T (a, x, b)
+
+  let rec merge s t = match s, t with
+    | E, _ -> t
+    | T (a, x, b), _ ->
+        let ta, tb = partition x t in
+        T (merge ta a, x, merge tb b)
+
+  let rec find_min = function
+    | E -> raise Empty
+    | T (E, x, _) -> x
+    | T (a, x, _) -> find_min a
+
+  let rec delete_min = function
+    | E -> raise Empty
+    | T (E, _, b) -> b
+    | T (T (E, _, b), y, c) -> T (b, y, c)
+    | T (T (a, x, b), y, c) -> T (delete_min a, x, T (b, y, c))
+end
+
+
+module PairingHeap (Element : ORDERED) : (HEAP with module Elem = Element) =
+struct
+  module Elem = Element
+
+  type heap = E | T of Elem.t * heap list
+
+  let empty = E
+  let is_empty h = h = E
+
+  let merge h1 h2 = match h1, h2 with
+    | _, E -> h1
+    | E, _ -> h2
+    | T (x, hs1), T (y, hs2) ->
+        if Elem.leq x y then T (x, h2 :: hs1)
+        else T (y, h1 :: hs2)
+
+  let insert x h = merge (T (x, [])) h
+
+  let rec merge_pairs = function
+    | [] -> E
+    | [h] -> h
+    | h1 :: h2 :: hs -> merge (merge h1 h2) (merge_pairs hs)
+
+  let find_min = function
+    | E -> raise Empty
+    | T (x, hs) -> x
+
+  let delete_min = function
+    | E -> raise Empty
+    | T (x, hs) -> merge_pairs hs
+end
+(*
+   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 6                              *)
+(***********************************************************************)
+
+exception Empty
+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
+
+
+(* 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 type HEAP = sig
+  module Elem : ORDERED
+
+  type heap
+
+  val empty : heap
+  val is_empty : heap -> bool
+
+  val insert : Elem.t -> heap -> heap
+  val merge : heap -> heap -> heap
+
+  val find_min : heap -> Elem.t  (* raises Empty if heap is empty *)
+  val delete_min : heap -> heap  (* raises Empty if heap 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 BankersQueue : QUEUE = struct
+  type 'a queue = int * 'a stream * int * 'a stream
+
+  let empty = 0, Nil, 0, Nil
+  let is_empty (lenf, _, _, _) = lenf = 0
+
+  let check (lenf, f, lenr, r as q) =
+    if lenr <= lenf then q
+    else (lenf + lenr, f ++ reverse r, 0, Nil)
+
+  let snoc (lenf, f, lenr, r) x = check (lenf, f, lenr + 1, Cons (x, lazy r))
+
+  let head = function
+    | _, Nil, _, _ -> raise Empty
+    | _, Cons (x, _), _, _ -> x
+
+  let tail = function
+    | _, Nil, _, _ -> raise Empty
+    | lenf, Cons (_, f'), lenr, r -> check (lenf - 1, !$f', lenr, r)
+end
+
+
+module LazyBinomialHeap (Element : ORDERED)
+  : (HEAP with module Elem = Element) =
+struct
+  module Elem = Element
+
+  type tree = Node of int * Elem.t * tree list
+  type heap = tree list Lazy.t
+
+  let empty = lazy []
+  let is_empty ts = !$ts = []
+
+  let rank (Node (r, _, _)) = r
+  let root (Node (_, x, _)) = x
+
+  let link (Node (r, x1, c1) as t1) (Node (_, x2, c2) as t2) =
+    if Elem.leq x1 x2 then Node (r + 1, x1, t2 :: c1)
+    else Node (r + 1, x2, t1 :: c2)
+
+  let rec ins_tree t ts = match t, ts with
+    | _, [] -> [t]
+    | t, t' :: ts' ->
+        if rank t < rank t' then t :: ts
+        else ins_tree (link t t') ts'
+
+  let rec mrg ts1 ts2 = match ts1, ts2 with
+    | _, [] -> ts1
+    | [], _ -> ts2
+    | t1 :: ts1', t2 :: ts2' ->
+        if rank t1 < rank t2 then t1 :: mrg ts1' ts2
+        else if rank t2 < rank t1 then t2 :: mrg ts1 ts2'
+        else ins_tree (link t1 t2) (mrg ts1' ts2')
+
+  (* fun lazy *)
+  let insert x ts = lazy (ins_tree (Node (0, x, [])) !$ts)
+
+  (* fun lazy *)
+  let merge ts1 ts2 = lazy (mrg !$ts1 !$ts2)
+
+  let rec remove_min_tree = function
+    | [] -> raise Empty
+    | [t] -> t, []
+    | t :: ts ->
+        let t', ts' = remove_min_tree ts in
+        if Elem.leq (root t) (root t') then t, ts
+        else t', t :: ts'
+
+  let find_min ts = let t, _ = remove_min_tree !$ts in root t
+
+  (* fun lazy *)
+  let delete_min ts =
+    let Node (_, _, ts1), ts2 = remove_min_tree !$ts in
+    lazy (mrg (List.rev ts1) ts2)
+end
+
+
+module PhysicistsQueue : QUEUE = struct
+  type 'a queue = 'a list * int * 'a list Lazy.t * int * 'a list
+
+  let empty = [], 0, lazy [], 0, []
+  let is_empty (_, lenf, _, _, _) = lenf = 0
+
+  let checkw = function
+    | [], lenf, f, lenr, r -> !$f, lenf, f, lenr, r
+    | q -> q
+
+  let check (w, lenf, f, lenr, r as q) =
+    if lenr <= lenf then checkw q
+    else
+      let f' = !$f in
+      checkw (f', lenf + lenr, lazy (f' @ List.rev r), 0, [])
+
+  let snoc (w, lenf, f, lenr, r) x = check (w, lenf, f, lenr + 1, x :: r)
+
+  let head = function
+    | [], _, _, _, _ -> raise Empty
+    | x :: _, _, _, _, _ -> x
+
+  let tail = function
+    | [], _, _, _, _ -> raise Empty
+    | x :: w, lenf, f, lenr, r ->
+        check (w, lenf - 1, lazy (List.tl !$f), lenr, r)
+end
+
+
+module type SORTABLE = sig
+  module Elem : ORDERED
+
+  type sortable
+
+  val empty : sortable
+  val add : Elem.t -> sortable -> sortable
+  val sort : sortable -> Elem.t list
+end
+
+
+module BottomUpMergeSort (Element : ORDERED)
+  : (SORTABLE with module Elem = Element) =
+struct
+  module Elem = Element
+
+  type sortable = int * Elem.t list list Lazy.t
+
+  let rec mrg xs ys = match xs, ys with
+    | [], _ -> ys
+    | _, [] -> xs
+    | x :: xs', y :: ys' ->
+        if Elem.leq x y then x :: mrg xs' ys
+        else y :: mrg xs ys'
+
+  let empty = 0, lazy []
+
+  let add x (size, segs) =
+    let rec add_seg seg size segs =
+      if size mod 2 = 0 then seg :: segs
+      else add_seg (mrg seg (List.hd segs)) (size / 2) (List.tl segs) in
+    size + 1, lazy (add_seg [x] size !$segs)
+
+  let sort (size, segs) =
+    let rec mrg_all xs = function
+      | [] -> xs
+      | seg :: segs -> mrg_all (mrg xs seg) segs in
+    mrg_all [] !$segs
+end
+
+
+module LazyPairingHeap (Element : ORDERED) : (HEAP with module Elem = Element) =
+struct
+  module Elem = Element
+
+  type heap = E | T of Elem.t * heap * heap Lazy.t
+
+  let empty = E
+  let is_empty h = h = E
+
+  let rec merge a b = match a, b with
+    | _, E -> a
+    | E, _ -> b
+    | T (x, _, _), T (y, _, _) -> if Elem.leq x y then link a b else link b a
+
+  and link h a = match h with
+    | T (x, E, m) -> T (x, a, m)
+    | T (x, b, m) -> T (x, E, lazy (merge (merge a b) !$m))
+    | _ -> impossible_pat "link"
+
+  let insert x a = merge (T (x, E, lazy E)) a
+
+  let find_min = function E -> raise Empty | T (x, _, _) -> x
+  let delete_min = function E -> raise Empty | T (_, a, b) -> merge a !$b
+end
+(*
+   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 7                              *)
+(***********************************************************************)
+
+exception Empty
+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
+
+
+(* 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 type HEAP = sig
+  module Elem : ORDERED
+
+  type heap
+
+  val empty : heap
+  val is_empty : heap -> bool
+
+  val insert : Elem.t -> heap -> heap
+  val merge : heap -> heap -> heap
+
+  val find_min : heap -> Elem.t  (* raises Empty if heap is empty *)
+  val delete_min : heap -> heap  (* raises Empty if heap is empty *)
+end
+
+
+module type SORTABLE = sig
+  module Elem : ORDERED
+
+  type sortable
+
+  val empty : sortable
+  val add : Elem.t -> sortable -> sortable
+  val sort : sortable -> Elem.t list
+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 RealTimeQueue : QUEUE = struct
+  type 'a queue = 'a stream * 'a list * 'a stream
+
+  let empty = Nil, [], Nil
+
+  let is_empty = function Nil, _, _ -> true | _ -> false
+
+  let rec rotate = function
+    | Nil, y :: _, a -> Cons (y, lazy a)
+    | Cons (x, xs), y :: ys, a ->
+        Cons (x, lazy (rotate (!$xs, ys, Cons (y, lazy a))))
+    | _, [], _ -> impossible_pat "rotate"
+
+  let exec = function
+    | f, r, Cons (x, s) -> f, r, !$s
+    | f, r, Nil -> let f' = rotate (f, r, Nil) in f', [], f'
+
+  let snoc (f, r, s) x = exec (f, x :: r, s)
+
+  let head (f, _, _) = match f with
+    | Nil -> raise Empty
+    | Cons (x, _) -> x
+
+  let tail = function
+    | Nil, _, _ -> raise Empty
+    | Cons (_, f), r, s -> exec (!$f, r, s)
+end
+
+
+let rec list_to_stream = function
+  | [] -> Nil
+  | x :: xs -> Cons (x, lazy (list_to_stream xs))
+
+
+module ScheduledBinomialHeap (Element : ORDERED)
+  : (HEAP with module Elem = Element) =
+struct
+  module Elem = Element
+
+  type tree = Node of Elem.t * tree list
+  type digit = Zero | One of tree
+  type schedule = digit stream list
+  type heap = digit stream * schedule
+
+  let empty = Nil, []
+  let is_empty (ds, _) = ds = Nil
+
+  let link (Node (x1, c1) as t1) (Node (x2, c2) as t2) =
+    if Elem.leq x1 x2 then Node (x1, t2 :: c1)
+    else Node (x2, t1 :: c2)
+
+  let rec ins_tree t = function
+    | Nil -> Cons (One t, lazy Nil)
+    | Cons (Zero, ds) -> Cons (One t, ds)
+    | Cons (One t', ds) -> Cons (Zero, lazy (ins_tree (link t t') !$ds))
+
+  let rec mrg a b = match a, b with
+    | ds1, Nil -> ds1
+    | Nil, ds2 -> ds2
+    | Cons (Zero, ds1), Cons (d, ds2) -> Cons (d, lazy (mrg !$ds1 !$ds2))
+    | Cons (d, ds1), Cons (Zero, ds2) -> Cons (d, lazy (mrg !$ds1 !$ds2))
+    | Cons (One t1, ds1), Cons (One t2, ds2) ->
+        Cons (Zero, lazy (ins_tree (link t1 t2) (mrg !$ds1 !$ds2)))
+
+  let rec normalize ds = match ds with
+    | Nil -> ds
+    | Cons (_, ds') -> normalize (!$ds'); ds
+
+  let exec = function
+    | [] -> []
+    | Cons (Zero, job) :: sched -> !$job :: sched
+    | _ :: sched -> sched
+
+  let insert x (ds, sched) =
+    let ds' = ins_tree (Node (x, [])) ds in
+    ds', exec (exec (ds' :: sched))
+
+  let merge (ds1, _) (ds2, _) = normalize (mrg ds1 ds2), []
+
+  let rec remove_min_tree = function
+    | Nil -> raise Empty
+    | Cons (hd, tl) ->
+        match hd, !$tl with
+        | One t, Nil -> t, Nil
+        | Zero, ds ->
+            let t', ds' = remove_min_tree ds in t', Cons (Zero, lazy ds')
+        | One (Node (x, _) as t), ds ->
+            let Node (x', _) as t', ds' = remove_min_tree ds in
+            if Elem.leq x x' then t, Cons (Zero, tl)
+            else t', Cons (One t, lazy ds')
+
+  let find_min (ds, _) = let Node (x, _), _ = remove_min_tree ds in x
+
+  let delete_min (ds, _) =
+    let Node (_, c), ds' = remove_min_tree ds in
+    let ds'' =
+      mrg (list_to_stream (List.map (fun e -> One e) (List.rev c))) ds' in
+    normalize ds'', []
+end
+
+
+let rec stream_to_list = function
+  | Nil -> []
+  | Cons (x, xs) -> x :: stream_to_list !$xs
+
+
+module ScheduledBottomUpMergeSort (Element : ORDERED)
+  : (SORTABLE with module Elem = Element) =
+struct
+  module Elem = Element
+
+  type schedule = Elem.t stream list
+  type sortable = int * (Elem.t stream * schedule) list
+
+  (* fun lazy *)
+  let rec mrg xs ys = match xs, ys with
+    | Nil, _ -> ys
+    | _, Nil -> xs
+    | Cons (x, xs'), Cons (y, ys') ->
+        if Elem.leq x y then Cons (x, lazy (mrg !$xs' ys))
+        else Cons (y, lazy (mrg xs !$ys'))
+
+  let rec exec1 = function
+    | [] -> []
+    | Nil :: sched -> exec1 sched
+    | Cons (x, xs) :: sched -> !$xs :: sched
+
+  let exec2 (xs, sched) = xs, exec1 (exec1 sched)
+
+  let empty = 0, []
+
+  let add x (size, segs) =
+    let rec add_seg xs segs size rsched =
+      if size mod 2 = 0 then (xs, List.rev rsched) :: segs
+      else
+        match segs with
+        | (xs', []) :: segs' ->
+            let xs'' = mrg xs xs' in
+            add_seg xs'' segs' (size / 2) (xs'' :: rsched)
+        | _ -> impossible_pat "add" in
+    let segs' = add_seg ((Cons (x, lazy Nil))) segs size [] in
+    size + 1, List.map exec2 segs'
+
+  let sort (size, segs) =
+    let rec mrg_all = function
+      | xs, [] -> xs
+      | xs, (xs', _) :: segs -> mrg_all (mrg xs xs', segs) in
+    stream_to_list (mrg_all (Nil, segs))
+end
+(*
+   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
+(*
+   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 9                               *)
+(************************************************************************)
+
+exception Empty
+exception Subscript
+exception Impossible_pattern of string
+
+let impossible_pat x = raise (Impossible_pattern x)
+
+
+module Dense = struct
+  type digit = Zero | One
+  type nat = digit list  (* increasing order of significance *)
+
+  let rec inc = function
+    | [] -> [One]
+    | Zero :: ds -> One :: ds
+    | One :: ds -> Zero :: inc ds  (* carry *)
+
+  let rec dec = function
+    | [One] -> []
+    | One :: ds -> Zero :: ds
+    | Zero :: ds -> One :: dec ds  (* borrow *)
+    | [] -> impossible_pat "dec"
+
+  let rec add d1 d2 = match d1, d2 with
+    | ds, [] -> ds
+    | [], ds -> ds
+    | d :: ds1, Zero :: ds2 -> d :: add ds1 ds2
+    | Zero :: ds1, d :: ds2 -> d :: add ds1 ds2
+    | One :: ds1, One :: ds2 -> Zero :: inc (add ds1 ds2)  (* carry *)
+end
+
+
+module SparseByWeight = struct
+  type nat = int list  (* increasing list of weights, each a power of two *)
+
+  let rec carry w = function
+    | [] -> [w]
+    | w' :: ws' as ws -> if w < w' then w :: ws else carry (2*w) ws'
+
+  let rec borrow w = function
+    | w' :: ws' as ws -> if w = w' then ws' else w :: borrow (2*w) ws
+    | [] -> impossible_pat "borrow"
+
+  let inc ws = carry 1 ws
+  let dec ws = borrow 1 ws
+
+  let rec add m n = match m, n with
+    | _, [] -> m
+    | [], _ -> n
+    | w1 :: ws1, w2 :: ws2 ->
+        if w1 < w2 then w1 :: add ws1 n
+        else if w2 < w1 then w2 :: add m ws2
+        else carry (2*w1) (add ws1 ws2)
+end
+
+
+module type RANDOM_ACCESS_LIST = sig
+  type 'a ra_list
+
+  val empty : 'a ra_list
+  val is_empty : 'a ra_list -> bool
+
+  val cons : 'a -> 'a ra_list -> 'a ra_list
+  val head : 'a ra_list -> 'a
+  val tail : 'a ra_list -> 'a ra_list
+    (* head and tail raise Empty if list is empty *)
+
+  val lookup : int -> 'a ra_list -> 'a
+  val update : int -> 'a -> 'a ra_list -> 'a ra_list
+    (* lookup and update raise Subscript if index is out of bounds *)
+end
+
+
+module BinaryRandomAccessList : RANDOM_ACCESS_LIST = struct
+  type 'a tree = Leaf of 'a | Node of int * 'a tree * 'a tree
+  type 'a digit = Zero | One of 'a tree
+  type 'a ra_list = 'a digit list
+
+  let empty = []
+  let is_empty ts = ts = []
+
+  let size = function
+    | Leaf x -> 1
+    | Node (w, _, _) -> w
+
+  let link t1 t2 = Node (size t1 + size t2, t1, t2)
+
+  let rec cons_tree t = function
+    | [] -> [One t]
+    | Zero :: ts -> One t :: ts
+    | One t' :: ts -> Zero :: cons_tree (link t t') ts
+
+  let rec uncons_tree = function
+    | [] -> raise Empty
+    | [One t] -> t, []
+    | One t :: ts -> t, Zero :: ts
+    | Zero :: ts ->
+        match uncons_tree ts with
+        | Node (_, t1, t2), ts' -> t1, One t2 :: ts'
+        | _ -> impossible_pat "uncons_tree"
+
+  let cons x ts = cons_tree (Leaf x) ts
+
+  let head ts =
+    match uncons_tree ts with
+    | Leaf x, _ -> x
+    | _ -> impossible_pat "head"
+
+  let tail ts = snd (uncons_tree ts)
+
+  let rec lookup_tree i t = match i, t with
+    | 0, Leaf x -> x
+    | i, Leaf x -> raise Subscript
+    | i, Node (w, t1, t2) ->
+        if i < w/2 then lookup_tree i t1
+        else lookup_tree (i - w/2) t2
+
+  let rec update_tree i y t = match i, t with
+    | 0, Leaf x -> Leaf y
+    | _, Leaf x -> raise Subscript
+    | _, Node (w, t1, t2) ->
+        if i < w/2 then Node (w, update_tree i y t1, t2)
+        else Node (w, t1, update_tree (i - w/2) y t2)
+
+  let rec lookup i = function
+    | [] -> raise Subscript
+    | Zero :: ts -> lookup i ts
+    | One t :: ts ->
+        if i < size t then lookup_tree i t
+        else lookup (i - size t) ts
+
+  let rec update i y = function
+    | [] -> raise Subscript
+    | Zero :: ts -> Zero :: update i y ts
+    | One t :: ts ->
+        if i < size t then One (update_tree i y t) :: ts
+        else One t :: update (i - size t) y ts
+end
+
+
+module SkewBinaryRandomAccessList : RANDOM_ACCESS_LIST = struct
+  type 'a tree = Leaf of 'a | Node of 'a * 'a tree * 'a tree
+  type 'a ra_list = (int * 'a tree) list (* integer is the weight of the tree *)
+
+  let empty = []
+  let is_empty ts = ts = []
+
+  let cons x = function
+    | (w1, t1) :: (w2, t2) :: ts' as ts ->
+        if w1 = w2 then (1 + w1 + w2, Node (x, t1, t2)) :: ts'
+        else (1, Leaf x) :: ts
+    | ts -> (1, Leaf x) :: ts
+
+  let head = function
+    | [] -> raise Empty
+    | (1, Leaf x) :: _ -> x
+    | (_, Node (x, _, _)) :: _ -> x
+    | _ -> impossible_pat "head"
+
+  let tail = function
+    | [] -> raise Empty
+    | (1, Leaf _) :: ts -> ts
+    | (w, Node (x, t1, t2)) :: ts -> (w/2, t1) :: (w/2, t2) :: ts
+    | _ -> impossible_pat "tail"
+
+  let rec lookup_tree w i t = match w, i, t with
+    | 1, 0, Leaf x -> x
+    | 1, _, Leaf x -> raise Subscript
+    | _, 0, Node (x, t1, t2) -> x
+    | _, _, Node (x, t1, t2) ->
+        if i <= w/2 then lookup_tree (w/2) (i - 1) t1
+        else lookup_tree (w/2) (i - 1 - w/2) t2
+    | _ -> impossible_pat "lookup_tree"
+
+  let rec update_tree = function
+    | 1, 0, y, Leaf x -> Leaf y
+    | 1, i, y, Leaf x -> raise Subscript
+    | w, 0, y, Node (x, t1, t2) -> Node (y, t1, t2)
+    | w, i, y, Node (x, t1, t2) ->
+        if i <= w/2 then Node (x, update_tree (w/2, i - 1, y, t1), t2)
+        else Node (x, t1, update_tree (w/2, i - 1 - w/2, y, t2))
+    | _ -> impossible_pat "update_tree"
+
+  let rec lookup i = function
+    | [] -> raise Subscript
+    | (w, t) :: ts ->
+        if i < w then lookup_tree w i t
+        else lookup (i - w) ts
+
+  let rec update i y = function
+    | [] -> raise Subscript
+    | (w, t) :: ts ->
+        if i < w then (w, update_tree (w, i, y, t)) :: ts
+        else (w, t) :: update (i - w) y ts
+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 type HEAP = sig
+  module Elem : ORDERED
+
+  type heap
+
+  val empty : heap
+  val is_empty : heap -> bool
+
+  val insert : Elem.t -> heap -> heap
+  val merge : heap -> heap -> heap
+
+  val find_min : heap -> Elem.t  (* raises Empty if heap is empty *)
+  val delete_min : heap -> heap  (* raises Empty if heap is empty *)
+end
+
+
+module SkewBinomialHeap (Element : ORDERED)
+  : (HEAP with module Elem = Element) =
+struct
+  module Elem = Element
+
+  type tree = Node of int * Elem.t * Elem.t list * tree list
+  type heap = tree list
+
+  let empty = []
+  let is_empty ts = ts = []
+
+  let rank (Node (r, _, _, _)) = r
+  let root (Node (_, x, _, _)) = x
+
+  let link (Node (r, x1, xs1, c1) as t1) (Node (_, x2, xs2, c2) as t2) =
+    if Elem.leq x1 x2 then Node (r + 1, x1, xs1, t2 :: c1)
+    else Node (r + 1, x2, xs2, t1 :: c2)
+
+  let skew_link x t1 t2 =
+    let Node (r, y, ys, c) = link t1 t2 in
+    if Elem.leq x y then Node (r, x, y :: ys, c)
+    else Node (r, y, x :: ys, c)
+
+  let rec ins_tree t = function
+    | [] -> [t]
+    | t' :: ts ->
+        if rank t < rank t' then t :: t' :: ts
+        else ins_tree (link t t') ts
+
+  let rec merge_trees ts1 ts2 = match ts1, ts2 with
+    | _, [] -> ts1
+    | [], _ -> ts2
+    | t1 :: ts1', t2 :: ts2' ->
+        if rank t1 < rank t2 then t1 :: merge_trees ts1' ts2
+        else if rank t2 < rank t1 then t2 :: merge_trees ts1 ts2'
+        else ins_tree (link t1 t2) (merge_trees ts1' ts2')
+
+  let normalize = function
+    | [] -> []
+    | t :: ts -> ins_tree t ts
+
+  let insert x = function
+    | t1 :: t2 :: rest as ts ->
+        if rank t1 = rank t2 then skew_link x t1 t2 :: rest
+        else Node (0, x, [], []) :: ts
+    | ts -> Node (0, x, [], []) :: ts
+
+  let merge ts1 ts2 = merge_trees (normalize ts1) (normalize ts2)
+
+  let rec remove_min_tree = function
+    | [] -> raise Empty
+    | [t] -> t, []
+    | t :: ts ->
+        let t', ts' = remove_min_tree ts in
+        if Elem.leq (root t) (root t') then t, ts else t', t :: ts'
+
+  let find_min ts = root (fst (remove_min_tree ts))
+
+  let delete_min ts =
+    let Node (_, x, xs, ts1), ts2 = remove_min_tree ts in
+      let rec insert_all ts = function
+        | [] -> ts
+        | x :: xs' -> insert_all (insert x ts) xs' in
+    insert_all (merge (List.rev ts1) ts2) xs
+end
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.