1.1 new file mode 100644
1.2 --- /dev/null
1.3 +++ b/chp3.ml
1.4 @@ -0,0 +1,181 @@
1.5 +(*
1.6 + Original source code in SML from:
1.7 +
1.8 + Purely Functional Data Structures
1.9 + Chris Okasaki
1.10 + Cambridge University Press, 1998
1.11 + Copyright (c) 1998 Cambridge University Press
1.12 +
1.13 + Translation from SML to OCAML (this file):
1.14 +
1.15 + Copyright (C) 1999, 2000, 2001 Markus Mottl
1.16 + email: markus.mottl@gmail.com
1.17 + www: http://www.ocaml.info
1.18 +
1.19 + Unless this violates copyrights of the original sources, the following
1.20 + licence applies to this file:
1.21 +
1.22 + This source code is free software; you can redistribute it and/or
1.23 + modify it without any restrictions. It is distributed in the hope
1.24 + that it will be useful, but WITHOUT ANY WARRANTY.
1.25 +*)
1.26 +
1.27 +(***********************************************************************)
1.28 +(* Chapter 3 *)
1.29 +(***********************************************************************)
1.30 +
1.31 +exception Empty
1.32 +exception Impossible_pattern of string
1.33 +
1.34 +let impossible_pat x = raise (Impossible_pattern x)
1.35 +
1.36 +
1.37 +(* A totally ordered type and its comparison functions *)
1.38 +module type ORDERED = sig
1.39 + type t
1.40 +
1.41 + val eq : t -> t -> bool
1.42 + val lt : t -> t -> bool
1.43 + val leq : t -> t -> bool
1.44 +end
1.45 +
1.46 +
1.47 +module type HEAP = sig
1.48 + module Elem : ORDERED
1.49 +
1.50 + type heap
1.51 +
1.52 + val empty : heap
1.53 + val is_empty : heap -> bool
1.54 +
1.55 + val insert : Elem.t -> heap -> heap
1.56 + val merge : heap -> heap -> heap
1.57 +
1.58 + val find_min : heap -> Elem.t (* raises Empty if heap is empty *)
1.59 + val delete_min : heap -> heap (* raises Empty if heap is empty *)
1.60 +end
1.61 +
1.62 +
1.63 +module LeftistHeap (Element : ORDERED) : (HEAP with module Elem = Element) =
1.64 +struct
1.65 + module Elem = Element
1.66 +
1.67 + type heap = E | T of int * Elem.t * heap * heap
1.68 +
1.69 + let rank = function E -> 0 | T (r,_,_,_) -> r
1.70 +
1.71 + let makeT x a b =
1.72 + if rank a >= rank b then T (rank b + 1, x, a, b)
1.73 + else T (rank a + 1, x, b, a)
1.74 +
1.75 + let empty = E
1.76 + let is_empty h = h = E
1.77 +
1.78 + let rec merge h1 h2 = match h1, h2 with
1.79 + | _, E -> h1
1.80 + | E, _ -> h2
1.81 + | T (_, x, a1, b1), T (_, y, a2, b2) ->
1.82 + if Elem.leq x y then makeT x a1 (merge b1 h2)
1.83 + else makeT y a2 (merge h1 b2)
1.84 +
1.85 + let insert x h = merge (T (1, x, E, E)) h
1.86 + let find_min = function E -> raise Empty | T (_, x, _, _) -> x
1.87 + let delete_min = function E -> raise Empty | T (_, x, a, b) -> merge a b
1.88 +end
1.89 +
1.90 +
1.91 +module BinomialHeap (Element : ORDERED) : (HEAP with module Elem = Element) =
1.92 +struct
1.93 + module Elem = Element
1.94 +
1.95 + type tree = Node of int * Elem.t * tree list
1.96 + type heap = tree list
1.97 +
1.98 + let empty = []
1.99 + let is_empty ts = ts = []
1.100 +
1.101 + let rank (Node (r, _, _)) = r
1.102 + let root (Node (_, x, _)) = x
1.103 +
1.104 + let link (Node (r, x1, c1) as t1) (Node (_, x2, c2) as t2) =
1.105 + if Elem.leq x1 x2 then Node (r + 1, x1, t2 :: c1)
1.106 + else Node (r + 1, x2, t1 :: c2)
1.107 +
1.108 + let rec ins_tree t = function
1.109 + | [] -> [t]
1.110 + | t' :: ts' as ts ->
1.111 + if rank t < rank t' then t :: ts
1.112 + else ins_tree (link t t') ts'
1.113 +
1.114 + let insert x ts = ins_tree (Node (0, x, [])) ts
1.115 +
1.116 + let rec merge ts1 ts2 = match ts1, ts2 with
1.117 + | _, [] -> ts1
1.118 + | [], _ -> ts2
1.119 + | t1 :: ts1', t2 :: ts2' ->
1.120 + if rank t1 < rank t2 then t1 :: merge ts1' ts2
1.121 + else if rank t2 < rank t1 then t2 :: merge ts1 ts2'
1.122 + else ins_tree (link t1 t2) (merge ts1' ts2')
1.123 +
1.124 + let rec remove_min_tree = function
1.125 + | [] -> raise Empty
1.126 + | [t] -> t, []
1.127 + | t :: ts ->
1.128 + let t', ts' = remove_min_tree ts in
1.129 + if Elem.leq (root t) (root t') then (t, ts)
1.130 + else (t', t :: ts')
1.131 +
1.132 + let find_min ts = root (fst (remove_min_tree ts))
1.133 +
1.134 + let delete_min ts =
1.135 + let Node (_, x, ts1), ts2 = remove_min_tree ts in
1.136 + merge (List.rev ts1) ts2
1.137 +end
1.138 +
1.139 +
1.140 +module type SET = sig
1.141 + type elem
1.142 + type set
1.143 +
1.144 + val empty : set
1.145 + val insert : elem -> set -> set
1.146 + val member : elem -> set -> bool
1.147 +end
1.148 +
1.149 +
1.150 +module RedBlackSet (Element : ORDERED) : (SET with type elem = Element.t) =
1.151 +struct
1.152 + type elem = Element.t
1.153 +
1.154 + type color = R | B
1.155 + type tree = E | T of color * tree * elem * tree
1.156 + type set = tree
1.157 +
1.158 + let empty = E
1.159 +
1.160 + let rec member x = function
1.161 + | E -> false
1.162 + | T (_, a, y, b) ->
1.163 + if Element.lt x y then member x a
1.164 + else if Element.lt y x then member x b
1.165 + else true
1.166 +
1.167 + let balance = function
1.168 + | B, T (R, T (R, a, x, b), y, c), z, d
1.169 + | B, T (R, a, x, T (R, b, y, c)), z, d
1.170 + | B, a, x, T (R, T (R, b, y, c), z, d)
1.171 + | B, a, x, T (R, b, y, T (R, c, z, d)) ->
1.172 + T (R, T (B, a, x, b), y, T (B, c, z, d))
1.173 + | a, b, c, d -> T (a, b, c, d)
1.174 +
1.175 + let insert x s =
1.176 + let rec ins = function
1.177 + | E -> T (R, E, x, E)
1.178 + | T (color, a, y, b) as s ->
1.179 + if Element.lt x y then balance (color, ins a, y, b)
1.180 + else if Element.lt y x then balance (color, a, y, ins b)
1.181 + else s in
1.182 + match ins s with (* guaranteed to be non-empty *)
1.183 + | T (_, a, y, b) -> T (B, a, y, b)
1.184 + | _ -> impossible_pat "insert"
1.185 +end
