commons/ocamlextra/mapb.ml

   1 (*pad: same than for Setb,  module Make(Ord: OrderedType) = struct *)
   2
   3 (***********************************************************************)
   4 (*                                                                     *)
   5 (*                           Objective Caml                            *)
   6 (*                                                                     *)
   7 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   8 (*                                                                     *)
   9 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
  10 (*  en Automatique.  All rights reserved.  This file is distributed    *)
  11 (*  under the terms of the GNU Library General Public License, with    *)
  12 (*  the special exception on linking described in file ../LICENSE.     *)
  13 (*                                                                     *)
  14 (***********************************************************************)
  15
  16 (* map.ml 1.15 2004/04/23 10:01:33 xleroy Exp  *)
  17
  18
  19 (*
  20     type key = Ord.t
  21
  22     type 'a t =
  23         Empty
  24       | Node of 'a t * key * 'a * 'a t * int
  25 *)
  26   type ('key, 'v) t =
  27       Empty
  28     | Node of ('key, 'v) t * 'key * 'v * ('key, 'v) t * int
  29
  30     let empty = Empty
  31
  32     let height = function
  33         Empty -> 0
  34       | Node(_,_,_,_,h) -> h
  35
  36     let create l x d r =
  37       let hl = height l and hr = height r in
  38       Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
  39
  40     let bal l x d r =
  41       let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
  42       let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
  43       if hl > hr + 2 then begin
  44         match l with
  45           Empty -> invalid_arg "Map.bal"
  46         | Node(ll, lv, ld, lr, _) ->
  47             if height ll >= height lr then
  48               create ll lv ld (create lr x d r)
  49             else begin
  50               match lr with
  51                 Empty -> invalid_arg "Map.bal"
  52               | Node(lrl, lrv, lrd, lrr, _)->
  53                   create (create ll lv ld lrl) lrv lrd (create lrr x d r)
  54             end
  55       end else if hr > hl + 2 then begin
  56         match r with
  57           Empty -> invalid_arg "Map.bal"
  58         | Node(rl, rv, rd, rr, _) ->
  59             if height rr >= height rl then
  60               create (create l x d rl) rv rd rr
  61             else begin
  62               match rl with
  63                 Empty -> invalid_arg "Map.bal"
  64               | Node(rll, rlv, rld, rlr, _) ->
  65                   create (create l x d rll) rlv rld (create rlr rv rd rr)
  66             end
  67       end else
  68         Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
  69
  70     let rec add x data = function
  71         Empty ->
  72           Node(Empty, x, data, Empty, 1)
  73       | Node(l, v, d, r, h) ->
  74           let c = compare x v in
  75           if c = 0 then
  76             Node(l, x, data, r, h)
  77           else if c < 0 then
  78             bal (add x data l) v d r
  79           else
  80             bal l v d (add x data r)
  81
  82     let rec find x = function
  83         Empty ->
  84           raise Not_found
  85       | Node(l, v, d, r, _) ->
  86           let c = compare x v in
  87           if c = 0 then d
  88           else find x (if c < 0 then l else r)
  89
  90     let rec mem x = function
  91         Empty ->
  92           false
  93       | Node(l, v, d, r, _) ->
  94           let c = compare x v in
  95           c = 0 || mem x (if c < 0 then l else r)
  96
  97     let rec min_binding = function
  98         Empty -> raise Not_found
  99       | Node(Empty, x, d, r, _) -> (x, d)
 100       | Node(l, x, d, r, _) -> min_binding l
 101
 102     let rec remove_min_binding = function
 103         Empty -> invalid_arg "Map.remove_min_elt"
 104       | Node(Empty, x, d, r, _) -> r
 105       | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r
 106
 107     let merge t1 t2 =
 108       match (t1, t2) with
 109         (Empty, t) -> t
 110       | (t, Empty) -> t
 111       | (_, _) ->
 112           let (x, d) = min_binding t2 in
 113           bal t1 x d (remove_min_binding t2)
 114
 115     let rec remove x = function
 116         Empty ->
 117           Empty
 118       | Node(l, v, d, r, h) ->
 119           let c = compare x v in
 120           if c = 0 then
 121             merge l r
 122           else if c < 0 then
 123             bal (remove x l) v d r
 124           else
 125             bal l v d (remove x r)
 126
 127     let rec iter f = function
 128         Empty -> ()
 129       | Node(l, v, d, r, _) ->
 130           iter f l; f v d; iter f r
 131
 132     let rec map f = function
 133         Empty               -> Empty
 134       | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h)
 135
 136     let rec mapi f = function
 137         Empty               -> Empty
 138       | Node(l, v, d, r, h) -> Node(mapi f l, v, f v d, mapi f r, h)
 139
 140     let rec fold f m accu =
 141       match m with
 142         Empty -> accu
 143       | Node(l, v, d, r, _) ->
 144           fold f l (f v d (fold f r accu))