src/custom.ml

   1 (* also taken from CDuce misc/custom.ml
   2    this module should always be included not referenced with Open
   3 *)
   4
   5 module Dummy =
   6 struct
   7   let dump _ _ = failwith "dump not implemented"
   8   let check _ = failwith "check not implemented"
   9   let equal  _ _ = failwith "equal not implemented"
  10   let hash _ = failwith "hash not implemented"
  11   let compare _ _ = failwith "compare not implemented"
  12   let print _ _ = failwith "print not implemented"
  13 end
  14
  15 (* Some of this borrowed from Jean-Christophe Filliâtre :
  16    http://www.lri.fr/~filliatr/ftp/ocaml/ds/bitset.ml.html
  17 *)
  18
  19 module IntSet : Set.S with type elt = int=
  20 struct
  21   let max = Sys.word_size - 2
  22   type t = int
  23   type elt = int
  24
  25   let empty = 0
  26   let full = -1
  27   let is_empty x = x == 0
  28   let mem e s = ((1 lsl e) land s) != 0
  29   let add e s = (1 lsl e) lor s
  30   let singleton e = (1 lsl e)
  31   let union = (lor)
  32   let inter = (land)
  33   let diff a b = a land (lnot b)
  34   let remove e s = (lnot (1 lsl e) land s)
  35   let compare = (-)
  36   let equal = (==)
  37   let subset a b = a land (lnot b) == 0
  38   let cardinal s =
  39     let rec loop n s =
  40       if s == 0 then n else loop (succ n) (s - (s land (-s)))
  41     in
  42   loop 0 s
  43 (* inverse of bit i = 1 lsl i i.e. tib i = log_2(i) *)
  44 let log2 = Array.create 255 0
  45 let () = for i = 0 to 7 do log2.(1 lsl i) <- i done
  46
  47 (* assumption: x is a power of 2 *)
  48 let tib32 x =
  49   if x land 0xFFFF == 0 then
  50     let x = x lsr 16 in
  51     if x land 0xFF == 0 then 24 + log2.(x lsr 8) else 16 + log2.(x)
  52   else
  53     if x land 0xFF == 0 then 8 + log2.(x lsr 8) else log2.(x)
  54
  55 let ffffffff = (0xffff lsl 16) lor 0xffff
  56 let tib64 x =
  57   if x land ffffffff == 0 then 32 + tib32 (x lsr 32) else tib32 x
  58
  59 let tib =
  60   match Sys.word_size with 32 -> tib32 | 64 -> tib64 | _ -> assert false
  61
  62 let min_elt s =
  63   if s == 0 then raise Not_found;
  64   tib (s land (-s))
  65
  66 let choose = min_elt
  67
  68 (* TODO: improve? *)
  69 let max_elt s =
  70   if s == 0 then raise Not_found;
  71   let rec loop i =
  72     if s land i != 0 then tib i
  73     else if i = 1 then raise Not_found else loop (i lsr 1)
  74   in
  75   loop min_int
  76
  77 let rec elements s =
  78   if s == 0 then [] else let i = s land (-s) in tib i :: elements (s - i)
  79
  80 let rec iter f s =
  81   if s != 0 then let i = s land (-s) in f (tib i); iter f (s - i)
  82
  83 let rec fold f s acc =
  84   if s == 0 then acc else let i = s land (-s) in fold f (s - i) (f (tib i) acc)
  85
  86 let rec for_all p s =
  87   s == 0 || let i = s land (-s) in p (tib i) && for_all p (s - i)
  88
  89 let rec exists p s =
  90   s != 0 && let i = s land (-s) in p (tib i) || exists p (s - i)
  91
  92 let rec filter p s =
  93   if s == 0 then
  94     0
  95   else
  96     let i = s land (-s) in
  97     let s = filter p (s - i) in
  98     if p (tib i) then s + i else s
  99
 100 let rec partition p s =
 101    if s == 0 then
 102     0, 0
 103   else
 104     let i = s land (-s) in
 105     let st,sf = partition p (s - i) in
 106     if p (tib i) then st + i, sf else st, sf + i
 107
 108 let split i s =
 109   let bi = 1 lsl i in
 110   s land (bi - 1), s land bi != 0, s land (-1 lsl (i+1))
 111 end
 112
 113
 114 module Bool  =
 115 struct
 116   module Make (X : Sigs.T) (Y : Sigs.T) :
 117     Sigs.T with type t = X.t*Y.t =
 118   struct
 119     module Fst = X
 120     module Snd = Y
 121     type t = X.t*Y.t
 122     let dump ppf (x,y) =
 123       X.dump ppf x;
 124       Y.dump ppf y
 125
 126     let check (x,y) = X.check x; Y.check y
 127     let equal  (x,y) (z,t) =
 128       X.equal x z && Y.equal y t
 129     let hash (x,y) = (X.hash x) + 4093 * Y.hash y
 130     let compare (x,y) (z,t) =
 131       let r = X.compare x z in
 132         if r == 0
 133         then Y.compare y t
 134         else r
 135
 136     let print _ _ = failwith "compare not implemented"
 137   end
 138 end