[hcoop/debian/mlton.git] / lib / mlton / set / bit-vector-set.fun

(* Copyright (C) 2009 Matthew Fluet.
 * Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 *
 * MLton is released under a BSD-style license.
 * See the file MLton-LICENSE for details.
 *)

functor BitVectorSet (Element : sig 
                                  include T
                                  val fromInt: int -> t
                                  val size: int
                                  val toInt: t -> int
                                end) : SET =
struct
   structure Element = Element

   structure Bin :> sig 
                      eqtype t 
                      val binSize: int 
                      val difference : t * t -> t
                      val empty : t
                      val equals : t * t -> bool
                      val fold : t * 'a * (int * 'a -> 'a) -> 'a
                      val intersect : t * t -> t
                      val singleton : int -> t
                      val union : t * t -> t
                    end = 
   struct 
     open Word
     val binSize = wordSize

     val equals : t * t -> bool = op =
     val empty : t = 0wx0
     fun singleton i = <<(0wx1, Word.fromInt i)
     val difference = fn (b1, b2) => andb (b1, notb b2)
     val intersect = fn (b1, b2) => andb (b1, b2)
     val union = fn (b1, b2) => orb (b1, b2)
     fun fold (w, a, f)
       = let
           fun loop (w, a, i) 
             = if Int.< (i, wordSize)
                 then let
                        val a = if andb (w, 0wx1) <> 0wx0
                                  then f (i, a)
                                  else a
                      in
                        loop (>>(w, 0wx1), a, Int.+ (i, 1))
                      end
                 else a
         in
           loop (w, a, 0)
         end
   end
   type bin = Bin.t
   type t = bin vector 
   type index = int (* position in t *)
   type slot = int (* position in bin *)
   type pos = index * slot

   val ltPos : pos * pos -> bool
     = fn ((index1, slot1), (index2, slot2)) =>
       index1 < index2 orelse
       (index1 = index2 andalso slot1 < slot2)

   val intToPos : int -> pos
     = fn pos => (Int.quot (pos, Bin.binSize), Int.rem (pos, Bin.binSize))
   val posToInt : pos -> int
     = fn (index, slot) => index * Bin.binSize + slot
   val slotToBin : slot -> bin = fn slot => Bin.singleton slot

   val eltToPos = intToPos o Element.toInt
   fun eltToPosBin x = let val pos as (index, slot) = eltToPos x
                       in (pos, slotToBin slot)
                       end
   val posToElt = Element.fromInt o posToInt

   val maxPos as (maxIndex,maxSlot) = intToPos (Element.size - 1)

   val empty : t = Vector.new (maxIndex + 1, Bin.empty)
   fun isEmpty (v : t) = Vector.forall (v, fn b => b = Bin.empty)
   fun singleton x = let val ((index,_), bin) = eltToPosBin x
                     in Vector.tabulate (maxIndex + 1, fn i =>
                                         if i = index
                                           then bin
                                           else Bin.empty)
                     end
   fun contains (v, x) = let val ((index,_), bin) = eltToPosBin x
                         in Bin.intersect (bin, Vector.sub (v, index)) <> Bin.empty
                         end
   fun add (v, x) = let val ((index, _), bin) = eltToPosBin x
                    in Vector.mapi (v, fn (i, b) =>
                                    if i = index
                                      then Bin.union (bin, b)
                                      else b)
                    end
   fun remove (v, x) = let val ((index, _), bin) = eltToPosBin x
                       in Vector.mapi (v, fn (i, b) =>
                                       if i = index
                                         then Bin.difference (b, bin)
                                         else b)
                       end
   fun difference (v1, v2) 
     = Vector.map2 (v1, v2, fn (b1, b2) => Bin.difference (b1, b2))
   fun intersect (v1, v2) 
     = Vector.map2 (v1, v2, fn (b1, b2) => Bin.intersect (b1, b2))
   fun union (v1, v2) 
     = Vector.map2 (v1, v2, fn (b1, b2) => Bin.union (b1, b2))
   fun unions ss = List.fold (ss, empty, union)
   fun equals (v1, v2) = Vector.equals (v1, v2, Bin.equals)
   fun isSubsetEq (v1, v2)
     = Exn.withEscape
       (fn escape =>
        Vector.fold2
        (v1, v2, true, fn (b1, b2, a) =>
         if Bin.difference (b1, b2) = Bin.empty
           then a
           else escape false))
   fun isSubset (s1, s2) = isSubsetEq (s1, s2) andalso not (equals (s1, s2))
   fun isSupersetEq (s1, s2) = isSubsetEq (s2, s1)
   fun isSuperset (s1, s2) = isSubset (s2, s1)

   fun areDisjoint (v1, v2)
     = Exn.withEscape
       (fn escape =>
        Vector.fold2
        (v1, v2, true, fn (b1, b2, a) =>
         if Bin.intersect(b1, b2) = Bin.empty
           then a
           else escape false))


   fun fold (v, a, f) 
     = Vector.foldi
       (v, a, fn (i, b, a) =>
        let
          val check = if i < maxIndex
                        then fn s => true
                        else fn s => s < maxSlot
        in
          Bin.fold (b, a, fn (s, a) => if check s
                                         then f (posToElt (i, s), a)
                                         else a)
        end)
   fun foreach (s, f) = fold (s, (), fn (x, ()) => f x)
   fun peekGen (s, no, f)
     = Exn.withEscape
       (fn escape =>
        (foreach (s, fn x => 
                  case f x 
                    of NONE => ()
                     | SOME yes => escape yes)
         ; no ()))
   fun exists (s, p) = peekGen (s, 
                                fn () => false, 
                                fn x => if p x then SOME true else NONE)
   fun forall (s, p) = not (exists (s, not o p))

   fun subsetSize (s, p)
     = fold (s, 0 : int, fn (x, a) => if p x then a + 1 else a)
   fun size s = subsetSize (s, fn _ => true)

   fun replace (s, f) = fold(s, empty, fn (x, s) =>
                             case f x
                               of NONE => s
                                | SOME x' => add (s, x'))
   fun map (s, f) = replace (s, fn x => SOME (f x))
   fun subset (s, p) = replace (s, fn x => if p x then SOME x else NONE)
   fun partition (s, p) = let val yes = subset (s, p)
                          in {yes = yes, no = difference (s, yes)}
                          end

   fun fromList l = List.fold (l, empty, fn (x, s) => add (s, x))
   fun toList s = fold (s, nil, op ::)
   fun layout s = List.layout Element.layout (toList s)

   val op + = union
   val op - = difference
   val op < = isSubset
   val op <= = isSubsetEq
   val op > = isSuperset
   val op >= = isSupersetEq

   fun power _ = Error.unimplemented "BitVectorSet.power"
   fun subsets _ = Error.unimplemented "BitVectorSet.subsets"
end
Commit	Line	Data
7f918cf1 CE	1	(* Copyright (C) 2009 Matthew Fluet.
	2	* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
	3	* Jagannathan, and Stephen Weeks.
	4	*
	5	* MLton is released under a BSD-style license.
	6	* See the file MLton-LICENSE for details.
	7	*)
	8
	9	functor BitVectorSet (Element : sig
	10	include T
	11	val fromInt: int -> t
	12	val size: int
	13	val toInt: t -> int
	14	end) : SET =
	15	struct
	16	structure Element = Element
	17
	18	structure Bin :> sig
	19	eqtype t
	20	val binSize: int
	21	val difference : t * t -> t
	22	val empty : t
	23	val equals : t * t -> bool
	24	val fold : t * 'a * (int * 'a -> 'a) -> 'a
	25	val intersect : t * t -> t
	26	val singleton : int -> t
	27	val union : t * t -> t
	28	end =
	29	struct
	30	open Word
	31	val binSize = wordSize
	32
	33	val equals : t * t -> bool = op =
	34	val empty : t = 0wx0
	35	fun singleton i = <<(0wx1, Word.fromInt i)
	36	val difference = fn (b1, b2) => andb (b1, notb b2)
	37	val intersect = fn (b1, b2) => andb (b1, b2)
	38	val union = fn (b1, b2) => orb (b1, b2)
	39	fun fold (w, a, f)
	40	= let
	41	fun loop (w, a, i)
	42	= if Int.< (i, wordSize)
	43	then let
	44	val a = if andb (w, 0wx1) <> 0wx0
	45	then f (i, a)
	46	else a
	47	in
	48	loop (>>(w, 0wx1), a, Int.+ (i, 1))
	49	end
	50	else a
	51	in
	52	loop (w, a, 0)
	53	end
	54	end
	55	type bin = Bin.t
	56	type t = bin vector
	57	type index = int (* position in t *)
	58	type slot = int (* position in bin *)
	59	type pos = index * slot
	60
	61	val ltPos : pos * pos -> bool
	62	= fn ((index1, slot1), (index2, slot2)) =>
	63	index1 < index2 orelse
	64	(index1 = index2 andalso slot1 < slot2)
65
66	val intToPos : int -> pos
67	= fn pos => (Int.quot (pos, Bin.binSize), Int.rem (pos, Bin.binSize))
68	val posToInt : pos -> int
69	= fn (index, slot) => index * Bin.binSize + slot
70	val slotToBin : slot -> bin = fn slot => Bin.singleton slot
71
72	val eltToPos = intToPos o Element.toInt
73	fun eltToPosBin x = let val pos as (index, slot) = eltToPos x
74	in (pos, slotToBin slot)
75	end
76	val posToElt = Element.fromInt o posToInt
77
78	val maxPos as (maxIndex,maxSlot) = intToPos (Element.size - 1)
79
80	val empty : t = Vector.new (maxIndex + 1, Bin.empty)
81	fun isEmpty (v : t) = Vector.forall (v, fn b => b = Bin.empty)
82	fun singleton x = let val ((index,_), bin) = eltToPosBin x
83	in Vector.tabulate (maxIndex + 1, fn i =>
84	if i = index
85	then bin
86	else Bin.empty)
87	end
88	fun contains (v, x) = let val ((index,_), bin) = eltToPosBin x
89	in Bin.intersect (bin, Vector.sub (v, index)) <> Bin.empty
90	end
91	fun add (v, x) = let val ((index, _), bin) = eltToPosBin x
92	in Vector.mapi (v, fn (i, b) =>
93	if i = index
94	then Bin.union (bin, b)
95	else b)
96	end
97	fun remove (v, x) = let val ((index, _), bin) = eltToPosBin x
98	in Vector.mapi (v, fn (i, b) =>
99	if i = index
100	then Bin.difference (b, bin)
101	else b)
102	end
103	fun difference (v1, v2)
104	= Vector.map2 (v1, v2, fn (b1, b2) => Bin.difference (b1, b2))
105	fun intersect (v1, v2)
106	= Vector.map2 (v1, v2, fn (b1, b2) => Bin.intersect (b1, b2))
107	fun union (v1, v2)
108	= Vector.map2 (v1, v2, fn (b1, b2) => Bin.union (b1, b2))
109	fun unions ss = List.fold (ss, empty, union)
110	fun equals (v1, v2) = Vector.equals (v1, v2, Bin.equals)
111	fun isSubsetEq (v1, v2)
112	= Exn.withEscape
113	(fn escape =>
114	Vector.fold2
115	(v1, v2, true, fn (b1, b2, a) =>
116	if Bin.difference (b1, b2) = Bin.empty
117	then a
118	else escape false))
119	fun isSubset (s1, s2) = isSubsetEq (s1, s2) andalso not (equals (s1, s2))
120	fun isSupersetEq (s1, s2) = isSubsetEq (s2, s1)
121	fun isSuperset (s1, s2) = isSubset (s2, s1)
122
123	fun areDisjoint (v1, v2)
124	= Exn.withEscape
125	(fn escape =>
126	Vector.fold2
127	(v1, v2, true, fn (b1, b2, a) =>
128	if Bin.intersect(b1, b2) = Bin.empty
129	then a
130	else escape false))
131
132
133	fun fold (v, a, f)
134	= Vector.foldi
135	(v, a, fn (i, b, a) =>
136	let
137	val check = if i < maxIndex
138	then fn s => true
139	else fn s => s < maxSlot
140	in
141	Bin.fold (b, a, fn (s, a) => if check s
142	then f (posToElt (i, s), a)
143	else a)
144	end)
145	fun foreach (s, f) = fold (s, (), fn (x, ()) => f x)
146	fun peekGen (s, no, f)
147	= Exn.withEscape
148	(fn escape =>
149	(foreach (s, fn x =>
150	case f x
151	of NONE => ()
152	\| SOME yes => escape yes)
153	; no ()))
154	fun exists (s, p) = peekGen (s,
155	fn () => false,
156	fn x => if p x then SOME true else NONE)
157	fun forall (s, p) = not (exists (s, not o p))
158
159	fun subsetSize (s, p)
160	= fold (s, 0 : int, fn (x, a) => if p x then a + 1 else a)
161	fun size s = subsetSize (s, fn _ => true)
162
163	fun replace (s, f) = fold(s, empty, fn (x, s) =>
164	case f x
165	of NONE => s
166	\| SOME x' => add (s, x'))
167	fun map (s, f) = replace (s, fn x => SOME (f x))
168	fun subset (s, p) = replace (s, fn x => if p x then SOME x else NONE)
169	fun partition (s, p) = let val yes = subset (s, p)
170	in {yes = yes, no = difference (s, yes)}
171	end
172
173	fun fromList l = List.fold (l, empty, fn (x, s) => add (s, x))
174	fun toList s = fold (s, nil, op ::)
175	fun layout s = List.layout Element.layout (toList s)
176
177	val op + = union
178	val op - = difference
179	val op < = isSubset
180	val op <= = isSubsetEq
181	val op > = isSuperset
182	val op >= = isSupersetEq
183
184	fun power _ = Error.unimplemented "BitVectorSet.power"
185	fun subsets _ = Error.unimplemented "BitVectorSet.subsets"
186	end