bundles/menhirLib/menhir-20120123/src/compressedBitSet.ml

   1 (**************************************************************************)
   2 (*                                                                        *)
   3 (*  Menhir                                                                *)
   4 (*                                                                        *)
   5 (*  François Pottier, INRIA Rocquencourt                                  *)
   6 (*  Yann Régis-Gianas, PPS, Université Paris Diderot                      *)
   7 (*                                                                        *)
   8 (*  Copyright 2005-2008 Institut National de Recherche en Informatique    *)
   9 (*  et en Automatique. All rights reserved. This file is distributed      *)
  10 (*  under the terms of the Q Public License version 1.0, with the change  *)
  11 (*  described in file LICENSE.                                            *)
  12 (*                                                                        *)
  13 (**************************************************************************)
  14
  15 (* A compressed (or should we say sparse?) bit set is a list of pairs
  16    of integers. The first component of every pair is an index, while
  17    the second component is a bit field. The list is sorted by order
  18    of increasing indices. *)
  19
  20 type t =
  21   | N
  22   | C of int * int * t
  23
  24 type element =
  25     int
  26
  27 let word_size =
  28   Sys.word_size - 1
  29
  30 let empty =
  31   N
  32
  33 let is_empty = function
  34   | N ->
  35       true
  36   | C _ ->
  37       false
  38
  39 let add i s =
  40   let ioffset = i mod word_size in
  41   let iaddr = i - ioffset
  42   and imask = 1 lsl ioffset in
  43   let rec add = function
  44     | N ->
  45         (* Insert at end. *)
  46         C (iaddr, imask, N)
  47     | C (addr, ss, qs) as s ->
  48         if iaddr < addr then
  49           (* Insert in front. *)
  50           C (iaddr, imask, s)
  51         else if iaddr = addr then
  52           (* Found appropriate cell, update bit field. *)
  53           let ss' = ss lor imask in
  54           if ss' = ss then
  55             s
  56           else
  57             C (addr, ss', qs)
  58         else
  59           (* Not there yet, continue. *)
  60           let qs' = add qs in
  61           if qs == qs' then
  62             s
  63           else
  64             C (addr, ss, qs')
  65   in
  66   add s
  67
  68 let singleton i =
  69    add i N
  70
  71 let remove i s =
  72   let ioffset = i mod word_size in
  73   let iaddr = i - ioffset
  74   and imask = 1 lsl ioffset in
  75   let rec remove = function
  76     | N ->
  77         N
  78     | C (addr, ss, qs) as s ->
  79         if iaddr < addr then
  80           s
  81         else if iaddr = addr then
  82           (* Found appropriate cell, update bit field. *)
  83           let ss' = ss land (lnot imask) in
  84           if ss' = 0 then
  85             qs
  86           else if ss' = ss then
  87             s
  88           else
  89             C (addr, ss', qs)
  90         else
  91           (* Not there yet, continue. *)
  92           let qs' = remove qs in
  93           if qs == qs' then
  94             s
  95           else
  96             C (addr, ss, qs')
  97   in
  98   remove s
  99
 100 let rec fold f s accu =
 101   match s with
 102   | N ->
 103       accu
 104   | C (base, ss, qs) ->
 105       let limit = base + word_size in
 106       let rec loop i ss accu =
 107         if i = limit then
 108           accu
 109         else
 110           loop (i + 1) (ss lsr 1) (if ss land 1 = 1 then f i accu else accu)
 111       in
 112       fold f qs (loop base ss accu)
 113
 114 let iter f s =
 115   fold (fun x () -> f x) s ()
 116
 117 let cardinal s =
 118   fold (fun _ m -> m + 1) s 0
 119
 120 let elements s =
 121   fold (fun tl hd -> tl :: hd) s []
 122
 123 let rec subset s1 s2 =
 124   match s1, s2 with
 125   | N, _ ->
 126       true
 127   | _, N ->
 128       false
 129   | C (addr1, ss1, qs1), C (addr2, ss2, qs2) ->
 130       if addr1 < addr2 then
 131         false
 132       else if addr1 = addr2 then
 133         if (ss1 land ss2) <> ss1 then
 134           false
 135         else
 136           subset qs1 qs2
 137       else
 138         subset s1 qs2
 139
 140 let mem i s =
 141   subset (singleton i) s
 142
 143 let rec union s1 s2 =
 144   match s1, s2 with
 145   | N, s
 146   | s, N ->
 147       s
 148   | C (addr1, ss1, qs1), C (addr2, ss2, qs2) ->
 149       if addr1 < addr2 then
 150         C (addr1, ss1, union qs1 s2)
 151       else if addr1 > addr2 then
 152         let s = union s1 qs2 in
 153         if s == qs2 then
 154           s2
 155         else
 156           C (addr2, ss2, s)
 157       else
 158         let ss = ss1 lor ss2 in
 159         let s = union qs1 qs2 in
 160         if ss == ss2 && s == qs2 then
 161           s2
 162         else
 163           C (addr1, ss, s)
 164
 165 let rec inter s1 s2 =
 166   match s1, s2 with
 167   | N, _
 168   | _, N ->
 169       N
 170   | C (addr1, ss1, qs1), C (addr2, ss2, qs2) ->
 171       if addr1 < addr2 then
 172         inter qs1 s2
 173       else if addr1 > addr2 then
 174         inter s1 qs2
 175       else
 176         let ss = ss1 land ss2 in
 177         let s = inter qs1 qs2 in
 178         if ss = 0 then
 179           s
 180         else
 181           if (ss = ss1) && (s == qs1) then
 182             s1
 183           else
 184             C (addr1, ss, s)
 185
 186 exception Found of int
 187
 188 let choose s =
 189   try
 190     iter (fun x ->
 191       raise (Found x)
 192     ) s;
 193     raise Not_found
 194   with Found x ->
 195     x
 196
 197 let rec compare s1 s2 =
 198   match s1, s2 with
 199       N, N ->  0
 200     | _, N ->  1
 201     | N, _ -> -1
 202     | C (addr1, ss1, qs1), C (addr2, ss2, qs2) ->
 203         if addr1 < addr2 then -1
 204         else if addr1 > addr2 then 1
 205         else if ss1 < ss2 then -1
 206         else if ss1 > ss2 then 1
 207         else compare qs1 qs2
 208
 209 let rec equal s1 s2 =
 210   compare s1 s2 = 0
 211
 212 let rec disjoint s1 s2 =
 213   match s1, s2 with
 214   | N, _
 215   | _, N ->
 216       true
 217   | C (addr1, ss1, qs1), C (addr2, ss2, qs2) ->
 218       if addr1 = addr2 then
 219         if (ss1 land ss2) = 0 then
 220           disjoint qs1 qs2
 221         else
 222           false
 223       else if addr1 < addr2 then
 224         disjoint qs1 s2
 225       else
 226         disjoint s1 qs2
 227