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