extracted/untrusted/pset.ml

   1 (* Copied from OCaml's set.ml *)
   2
   3     type 'a set = Empty | Node of 'a set * 'a * 'a set * int
   4
   5     let empty = Empty
   6
   7     let is_empty = function Empty -> true | Node _ -> false
   8
   9     let height = function
  10         Empty -> 0
  11       | Node(_, _, _, h) -> h
  12
  13     let create l v r =
  14       let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
  15       let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
  16       Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1))
  17
  18     let bal l v r =
  19       let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
  20       let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
  21       if hl > hr + 2 then begin
  22         match l with
  23           Empty -> invalid_arg "Set.bal"
  24         | Node(ll, lv, lr, _) ->
  25             if height ll >= height lr then
  26               create ll lv (create lr v r)
  27             else begin
  28               match lr with
  29                 Empty -> invalid_arg "Set.bal"
  30               | Node(lrl, lrv, lrr, _)->
  31                   create (create ll lv lrl) lrv (create lrr v r)
  32             end
  33       end else if hr > hl + 2 then begin
  34         match r with
  35           Empty -> invalid_arg "Set.bal"
  36         | Node(rl, rv, rr, _) ->
  37             if height rr >= height rl then
  38               create (create l v rl) rv rr
  39             else begin
  40               match rl with
  41                 Empty -> invalid_arg "Set.bal"
  42               | Node(rll, rlv, rlr, _) ->
  43                   create (create l v rll) rlv (create rlr rv rr)
  44             end
  45       end else
  46         Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1))
  47
  48     let rec add x = function
  49        Empty -> Node(Empty, x, Empty, 1)
  50      | Node(l, v, r, _) as t ->
  51          let c = compare x v in
  52          if c = 0 then t else
  53          if c < 0 then bal (add x l) v r else bal l v (add x r)
  54
  55     let singleton elt = add elt Empty
  56
  57     let rec min_elt = function
  58         Empty -> raise Not_found
  59       | Node(Empty, v, r, _) -> v
  60       | Node(l, v, r, _) -> min_elt l
  61
  62     let rec remove_min_elt = function
  63         Empty -> invalid_arg "Set.remove_min_elt"
  64       | Node(Empty, v, r, _) -> r
  65       | Node(l, v, r, _) -> bal (remove_min_elt l) v r
  66
  67     let merge t1 t2 =
  68       match (t1, t2) with
  69         (Empty, t) -> t
  70       | (t, Empty) -> t
  71       | (_, _) -> bal t1 (min_elt t2) (remove_min_elt t2)
  72
  73     let rec remove x = function
  74         Empty -> Empty
  75       | Node(l, v, r, _) ->
  76           let c = compare x v in
  77           if c = 0 then merge l r else
  78           if c < 0 then bal (remove x l) v r else bal l v (remove x r)
  79
  80     let rec fold f s accu =
  81       match s with
  82         Empty -> accu
  83       | Node(l, v, r, _) -> fold f r (f v (fold f l accu))
  84
  85     let rec iter f = function
  86         Empty -> ()
  87       | Node(l, v, r, _) -> iter f l; f v; iter f r
  88
  89     let rec cardinal = function
  90         Empty -> 0
  91       | Node(l, v, r, _) -> cardinal l + 1 + cardinal r
  92
  93     let rec join l v r =
  94       match (l, r) with
  95         (Empty, _) -> add v r
  96       | (_, Empty) -> add v l
  97       | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) ->
  98           if lh > rh + 2 then bal ll lv (join lr v r) else
  99           if rh > lh + 2 then bal (join l v rl) rv rr else
 100           create l v r
 101
 102     let rec split x = function
 103         Empty ->
 104           (Empty, false, Empty)
 105       | Node(l, v, r, _) ->
 106           let c = compare x v in
 107           if c = 0 then (l, true, r)
 108           else if c < 0 then
 109             let (ll, pres, rl) = split x l in (ll, pres, join rl v r)
 110           else
 111             let (lr, pres, rr) = split x r in (join l v lr, pres, rr)
 112
 113     let rec union s1 s2 =
 114       match (s1, s2) with
 115         (Empty, t2) -> t2
 116       | (t1, Empty) -> t1
 117       | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
 118           if h1 >= h2 then
 119             if h2 = 1 then add v2 s1 else begin
 120               let (l2, _, r2) = split v1 s2 in
 121               join (union l1 l2) v1 (union r1 r2)
 122             end
 123           else
 124             if h1 = 1 then add v1 s2 else begin
 125               let (l1, _, r1) = split v2 s1 in
 126               join (union l1 l2) v2 (union r1 r2)
 127             end
 128
 129     let concat t1 t2 =
 130       match (t1, t2) with
 131         (Empty, t) -> t
 132       | (t, Empty) -> t
 133       | (_, _) -> join t1 (min_elt t2) (remove_min_elt t2)
 134
 135     let rec mem x = function
 136         Empty -> false
 137       | Node(l, v, r, _) ->
 138           let c = compare x v in
 139           c = 0 || mem x (if c < 0 then l else r)
 140
 141     let rec for_all p = function
 142         Empty -> true
 143       | Node(l, v, r, _) -> p v && for_all p l && for_all p r
 144
 145     let rec exists p = function
 146         Empty -> false
 147       | Node(l, v, r, _) -> p v || exists p l || exists p r
 148
 149     let rec subset s1 s2 =
 150       match (s1, s2) with
 151         Empty, _ ->
 152           true
 153       | _, Empty ->
 154           false
 155       | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
 156           let c = compare v1 v2 in
 157           if c = 0 then
 158             subset l1 l2 && subset r1 r2
 159           else if c < 0 then
 160             subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
 161           else
 162             subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2
 163
 164     let rec diff s1 s2 =
 165       match (s1, s2) with
 166         (Empty, t2) -> Empty
 167       | (t1, Empty) -> t1
 168       | (Node(l1, v1, r1, _), t2) ->
 169           match split v1 t2 with
 170             (l2, false, r2) ->
 171               join (diff l1 l2) v1 (diff r1 r2)
 172           | (l2, true, r2) ->
 173               concat (diff l1 l2) (diff r1 r2)
 174
 175     type 'a enumeration = End | More of 'a * 'a set * 'a enumeration
 176
 177     let rec cons_enum s e =
 178       match s with
 179         Empty -> e
 180       | Node(l, v, r, _) -> cons_enum l (More(v, r, e))
 181
 182     let rec compare_aux e1 e2 =
 183         match (e1, e2) with
 184         (End, End) -> 0
 185       | (End, _)  -> -1
 186       | (_, End) -> 1
 187       | (More(v1, r1, e1), More(v2, r2, e2)) ->
 188           let c = compare v1 v2 in
 189           if c <> 0
 190           then c
 191           else compare_aux (cons_enum r1 e1) (cons_enum r2 e2)
 192
 193     let compare s1 s2 =
 194       compare_aux (cons_enum s1 End) (cons_enum s2 End)
 195
 196     let equal s1 s2 =
 197       compare s1 s2 = 0