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