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