release/pure-fun: chp3.ml@330eff97ead2

     1 (*

     2    Original source code in SML from:

     4      Purely Functional Data Structures

     5      Chris Okasaki

     6      Cambridge University Press, 1998

     7      Copyright (c) 1998 Cambridge University Press

     9    Translation from SML to OCAML (this file):

    11      Copyright (C) 1999, 2000, 2001  Markus Mottl

    12      email:  markus.mottl@gmail.com

    13      www:    http://www.ocaml.info

    15    Unless this violates copyrights of the original sources, the following

    16    licence applies to this file:

    18    This source code is free software; you can redistribute it and/or

    19    modify it without any restrictions. It is distributed in the hope

    20    that it will be useful, but WITHOUT ANY WARRANTY.

    21 *)

    23 (***********************************************************************)

    24 (*                              Chapter 3                              *)

    25 (***********************************************************************)

    27 exception Empty

    28 exception Impossible_pattern of string

    30 let impossible_pat x = raise (Impossible_pattern x)

    33 (* A totally ordered type and its comparison functions *)

    34 module type ORDERED = sig

    35   type t

    37   val eq : t -> t -> bool

    38   val lt : t -> t -> bool

    39   val leq : t -> t -> bool

    40 end

    43 module type HEAP = sig

    44   module Elem : ORDERED

    46   type heap

    48   val empty : heap

    49   val is_empty : heap -> bool

    51   val insert : Elem.t -> heap -> heap

    52   val merge : heap -> heap -> heap

    54   val find_min : heap -> Elem.t  (* raises Empty if heap is empty *)

    55   val delete_min : heap -> heap  (* raises Empty if heap is empty *)

    56 end

    59 module LeftistHeap (Element : ORDERED) : (HEAP with module Elem = Element) =

    60 struct

    61   module Elem = Element

    63   type heap = E | T of int * Elem.t * heap * heap

    65   let rank = function E -> 0 | T (r,_,_,_) -> r

    67   let makeT x a b =

    68     if rank a >= rank b then T (rank b + 1, x, a, b)

    69     else T (rank a + 1, x, b, a)

    71   let empty = E

    72   let is_empty h = h = E

    74   let rec merge h1 h2 = match h1, h2 with

    75     | _, E -> h1

    76     | E, _ -> h2

    77     | T (_, x, a1, b1), T (_, y, a2, b2) ->

    78         if Elem.leq x y then makeT x a1 (merge b1 h2)

    79         else makeT y a2 (merge h1 b2)

    81   let insert x h = merge (T (1, x, E, E)) h

    82   let find_min = function E -> raise Empty | T (_, x, _, _) -> x

    83   let delete_min = function E -> raise Empty | T (_, x, a, b) -> merge a b

    84 end

    87 module BinomialHeap (Element : ORDERED) : (HEAP with module Elem = Element) =

    88 struct

    89   module Elem = Element

    91   type tree = Node of int * Elem.t * tree list

    92   type heap = tree list

    94   let empty = []

    95   let is_empty ts = ts = []

    97   let rank (Node (r, _, _)) = r

    98   let root (Node (_, x, _)) = x

   100   let link (Node (r, x1, c1) as t1) (Node (_, x2, c2) as t2) =

   101     if Elem.leq x1 x2 then Node (r + 1, x1, t2 :: c1)

   102     else Node (r + 1, x2, t1 :: c2)

   104   let rec ins_tree t = function

   105     | [] -> [t]

   106     | t' :: ts' as ts ->

   107         if rank t < rank t' then t :: ts

   108         else ins_tree (link t t') ts'

   110   let insert x ts = ins_tree (Node (0, x, [])) ts

   112   let rec merge ts1 ts2 = match ts1, ts2 with

   113     | _, [] -> ts1

   114     | [], _ -> ts2

   115     | t1 :: ts1', t2 :: ts2' ->

   116         if rank t1 < rank t2 then t1 :: merge ts1' ts2

   117         else if rank t2 < rank t1 then t2 :: merge ts1 ts2'

   118         else ins_tree (link t1 t2) (merge ts1' ts2')

   120   let rec remove_min_tree = function

   121     | [] -> raise Empty

   122     | [t] -> t, []

   123     | t :: ts ->

   124         let t', ts' = remove_min_tree ts in

   125         if Elem.leq (root t) (root t') then (t, ts)

   126         else (t', t :: ts')

   128   let find_min ts = root (fst (remove_min_tree ts))

   130   let delete_min ts =

   131     let Node (_, x, ts1), ts2 = remove_min_tree ts in

   132     merge (List.rev ts1) ts2

   133 end

   136 module type SET = sig

   137   type elem

   138   type set

   140   val empty : set

   141   val insert : elem -> set -> set

   142   val member : elem -> set -> bool

   143 end

   146 module RedBlackSet (Element : ORDERED) : (SET with type elem = Element.t) =

   147 struct

   148   type elem = Element.t

   150   type color = R | B

   151   type tree = E | T of color * tree * elem * tree

   152   type set = tree

   154   let empty = E

   156   let rec member x = function

   157     | E -> false

   158     | T (_, a, y, b) ->

   159         if Element.lt x y then member x a

   160         else if Element.lt y x then member x b

   161         else true

   163   let balance = function

   164     | B, T (R, T (R, a, x, b), y, c), z, d

   165     | B, T (R, a, x, T (R, b, y, c)), z, d

   166     | B, a, x, T (R, T (R, b, y, c), z, d)

   167     | B, a, x, T (R, b, y, T (R, c, z, d)) ->

   168         T (R, T (B, a, x, b), y, T (B, c, z, d))

   169     | a, b, c, d -> T (a, b, c, d)

   171   let insert x s =

   172     let rec ins = function

   173       | E -> T (R, E, x, E)

   174       | T (color, a, y, b) as s ->

   175           if Element.lt x y then balance (color, ins a, y, b)

   176           else if Element.lt y x then balance (color, a, y, ins b)

   177           else s in

   178     match ins s with  (* guaranteed to be non-empty *)

   179     | T (_, a, y, b) -> T (B, a, y, b)

   180     | _ -> impossible_pat "insert"

   181 end

release/pure-fun / file revision