(* ========================================================================= *)
(* FINITE SETS WITH A FIXED ELEMENT TYPE *)
(* Copyright (c) 2004 Joe Leslie-Hurd, distributed under the BSD License *)
(* ========================================================================= *)
functor ElementSet (
KM : KeyMap
) :> ElementSet
where
type element = KM.key
and type 'a map = 'a KM.
map =
struct
(* ------------------------------------------------------------------------- *)
(* A type of set elements. *)
(* ------------------------------------------------------------------------- *)
type element = KM.key;
val compareElement = KM.compareKey;
val equalElement = KM.equalKey;
(* ------------------------------------------------------------------------- *)
(* A type of finite sets. *)
(* ------------------------------------------------------------------------- *)
type 'a map = 'a KM.
map;
datatype set =
Set of unit
map;
(* ------------------------------------------------------------------------- *)
(* Converting to and from maps. *)
(* ------------------------------------------------------------------------- *)
fun dest (
Set m) = m;
fun mapPartial f =
let
fun mf (elt,()) = f elt
in
fn
Set m => KM.mapPartial mf m
end;
fun map f =
let
fun mf (elt,()) = f elt
in
fn
Set m => KM.
map mf m
end;
fun domain m =
Set (KM.transform (fn _ => ()) m);
(* ------------------------------------------------------------------------- *)
(* Constructors. *)
(* ------------------------------------------------------------------------- *)
val empty =
Set (KM.new ());
fun singleton elt =
Set (KM.singleton (elt,()));
(* ------------------------------------------------------------------------- *)
(* Set size. *)
(* ------------------------------------------------------------------------- *)
fun null (
Set m) = KM.null m;
fun size (
Set m) = KM.
size m;
(* ------------------------------------------------------------------------- *)
(* Querying. *)
(* ------------------------------------------------------------------------- *)
fun peek (
Set m) elt =
case KM.peekKey m elt
of
SOME (elt,()) => SOME elt
| NONE => NONE;
fun member elt (
Set m) = KM.inDomain elt m;
fun pick (
Set m) =
let
val (elt,_) = KM.pick m
in
elt
end;
fun nth (
Set m) n =
let
val (elt,_) = KM.nth m n
in
elt
end;
fun random (
Set m) =
let
val (elt,_) = KM.random m
in
elt
end;
(* ------------------------------------------------------------------------- *)
(* Adding. *)
(* ------------------------------------------------------------------------- *)
fun add (
Set m) elt =
let
val m = KM.insert m (elt,())
in
Set m
end;
local
fun uncurriedAdd (elt,
set) = add
set elt;
in
fun addList
set =
List.foldl uncurriedAdd
set;
end;
(* ------------------------------------------------------------------------- *)
(* Removing. *)
(* ------------------------------------------------------------------------- *)
fun delete (
Set m) elt =
let
val m = KM.delete m elt
in
Set m
end;
fun remove (
Set m) elt =
let
val m = KM.remove m elt
in
Set m
end;
fun deletePick (
Set m) =
let
val ((elt,()),m) = KM.deletePick m
in
(elt,
Set m)
end;
fun deleteNth (
Set m) n =
let
val ((elt,()),m) = KM.deleteNth m n
in
(elt,
Set m)
end;
fun deleteRandom (
Set m) =
let
val ((elt,()),m) = KM.deleteRandom m
in
(elt,
Set m)
end;
(* ------------------------------------------------------------------------- *)
(* Joining. *)
(* ------------------------------------------------------------------------- *)
fun union (
Set m1) (
Set m2) =
Set (KM.unionDomain m1 m2);
fun unionList sets =
let
val ms =
List.
map dest sets
in
Set (KM.unionListDomain ms)
end;
fun intersect (
Set m1) (
Set m2) =
Set (KM.intersectDomain m1 m2);
fun intersectList sets =
let
val ms =
List.
map dest sets
in
Set (KM.intersectListDomain ms)
end;
fun difference (
Set m1) (
Set m2) =
Set (KM.differenceDomain m1 m2);
fun symmetricDifference (
Set m1) (
Set m2) =
Set (KM.symmetricDifferenceDomain m1 m2);
(* ------------------------------------------------------------------------- *)
(* Mapping and folding. *)
(* ------------------------------------------------------------------------- *)
fun filter pred =
let
fun mpred (elt,()) = pred elt
in
fn
Set m =>
Set (KM.
filter mpred m)
end;
fun partition pred =
let
fun mpred (elt,()) = pred elt
in
fn
Set m =>
let
val (m1,m2) = KM.partition mpred m
in
(
Set m1,
Set m2)
end
end;
fun app f =
let
fun mf (elt,()) = f elt
in
fn
Set m => KM.
app mf m
end;
fun foldl f =
let
fun mf (elt,(),acc) = f (elt,acc)
in
fn acc => fn
Set m => KM.foldl mf acc m
end;
fun foldr f =
let
fun mf (elt,(),acc) = f (elt,acc)
in
fn acc => fn
Set m => KM.foldr mf acc m
end;
(* ------------------------------------------------------------------------- *)
(* Searching. *)
(* ------------------------------------------------------------------------- *)
fun findl p =
let
fun mp (elt,()) = p elt
in
fn
Set m =>
case KM.findl mp m
of
SOME (elt,()) => SOME elt
| NONE => NONE
end;
fun findr p =
let
fun mp (elt,()) = p elt
in
fn
Set m =>
case KM.findr mp m
of
SOME (elt,()) => SOME elt
| NONE => NONE
end;
fun firstl f =
let
fun mf (elt,()) = f elt
in
fn
Set m => KM.firstl mf m
end;
fun firstr f =
let
fun mf (elt,()) = f elt
in
fn
Set m => KM.firstr mf m
end;
fun exists p =
let
fun mp (elt,()) = p elt
in
fn
Set m => KM.
exists mp m
end;
fun all p =
let
fun mp (elt,()) = p elt
in
fn
Set m => KM.
all mp m
end;
fun count p =
let
fun mp (elt,()) = p elt
in
fn
Set m => KM.count mp m
end;
(* ------------------------------------------------------------------------- *)
(* Comparing. *)
(* ------------------------------------------------------------------------- *)
fun compareValue ((),()) = EQUAL;
fun equalValue () () =
true;
fun compare (
Set m1,
Set m2) = KM.compare compareValue (m1,m2);
fun equal (
Set m1) (
Set m2) = KM.equal equalValue m1 m2;
fun subset (
Set m1) (
Set m2) = KM.subsetDomain m1 m2;
fun disjoint (
Set m1) (
Set m2) = KM.disjointDomain m1 m2;
(* ------------------------------------------------------------------------- *)
(* Pointwise operations. *)
(* ------------------------------------------------------------------------- *)
fun lift f =
let
fun inc (elt,
set) = union
set (f elt)
in
foldl inc empty
end;
fun closedAdd f =
let
fun adds acc
set = foldl check acc
set
and check (elt,acc) =
if member elt acc
then acc
else expand (add acc elt) elt
and expand acc elt = adds acc (f elt)
in
adds
end;
fun close f = closedAdd f empty;
(* ------------------------------------------------------------------------- *)
(* Converting to and from lists. *)
(* ------------------------------------------------------------------------- *)
fun transform f =
let
fun inc (x,l) = f x :: l
in
foldr inc []
end;
fun toList (
Set m) = KM.keys m;
fun fromList elts = addList empty elts;
(* ------------------------------------------------------------------------- *)
(* Depth-first search. *)
(* ------------------------------------------------------------------------- *)
datatype ordering =
Linear
of element
list
| Cycle
of element
list;
fun postOrdered children =
let
fun check acc elts =
case elts
of
[] =>
true
| elt :: elts =>
not (member elt acc) andalso
let
val acc = closedAdd children acc (singleton elt)
in
check acc elts
end
in
check empty
end;
fun preOrdered children elts = postOrdered children (
List.rev elts);
local
fun takeStackset elt =
let
fun notElement (e,_,_) =
not (equalElement e elt)
in
Useful.takeWhile notElement
end;
fun consElement ((e,_,_),el) = e :: el;
fun depthFirstSearch children =
let
fun traverse (dealt,dealtset) (stack,stackset) work =
case work
of
[] =>
(
case stack
of
[] => Linear dealt
| (elt,work,stackset) :: stack =>
let
val dealt = elt :: dealt
val dealtset = add dealtset elt
in
traverse (dealt,dealtset) (stack,stackset) work
end)
| elt :: work =>
if member elt dealtset
then
traverse (dealt,dealtset) (stack,stackset) work
else if member elt stackset
then
let
val cycle = takeStackset elt stack
val cycle = elt ::
List.foldl consElement [elt] cycle
in
Cycle cycle
end
else
let
val stack = (elt,work,stackset) :: stack
val stackset = add stackset elt
val work = toList (children elt)
in
traverse (dealt,dealtset) (stack,stackset) work
end
val dealt = []
and dealtset = empty
and stack = []
and stackset = empty
in
traverse (dealt,dealtset) (stack,stackset)
end;
in
fun preOrder children roots =
let
val result = depthFirstSearch children (toList roots)
(*BasicDebug
val () =
case result of
Cycle _ => ()
| Linear l =>
let
val () =
if subset roots (fromList l) then ()
else raise Useful.Bug "ElementSet.preOrder: missing roots"
val () =
if preOrdered children l then ()
else raise Useful.Bug "ElementSet.preOrder: bad ordering"
in
()
end
*)
in
result
end;
fun postOrder children roots =
case depthFirstSearch children (toList roots)
of
Linear l =>
let
val l =
List.rev l
(*BasicDebug
val () =
if subset roots (fromList l) then ()
else raise Useful.Bug "ElementSet.postOrder: missing roots"
val () =
if postOrdered children l then ()
else raise Useful.Bug "ElementSet.postOrder: bad ordering"
*)
in
Linear l
end
| cycle => cycle;
end;
(* ------------------------------------------------------------------------- *)
(* Strongly connected components. *)
(* ------------------------------------------------------------------------- *)
fun postOrderedSCC children =
let
fun check acc eltsl =
case eltsl
of
[] =>
true
| elts :: eltsl =>
not (null elts) andalso
disjoint elts acc andalso
let
fun addElt elt = closedAdd children acc (singleton elt)
val (root,elts) = deletePick elts
fun checkElt elt = member root (addElt elt)
in
all checkElt elts andalso
let
val acc = addElt root
in
subset elts acc andalso
check acc eltsl
end
end
in
check empty
end;
fun preOrderedSCC children eltsl = postOrderedSCC children (
List.rev eltsl);
(* An implementation of Tarjan's algorithm: *)
(* http://en.wikipedia.org/wiki/Tarjan%27s_strongly_connected_components_algorithm *)
local
datatype stackSCC = StackSCC
of set * (element *
set)
list;
val emptyStack = StackSCC (empty,[]);
fun pushStack (StackSCC (elts,eltl)) elt =
StackSCC (add elts elt, (elt,elts) :: eltl);
fun inStack elt (StackSCC (elts,_)) = member elt elts;
fun popStack root =
let
fun pop scc eltl =
case eltl
of
[] =>
raise Useful.Bug
"ElementSet.popStack"
| (elt,elts) :: eltl =>
let
val scc = add scc elt
in
if equalElement elt root
then (scc, StackSCC (elts,eltl))
else pop scc eltl
end
in
fn sccs => fn StackSCC (_,eltl) =>
let
val (scc,stack) = pop empty eltl
in
(scc :: sccs, stack)
end
end;
fun getIndex indices e : int =
case KM.peek indices e
of
SOME i => i
| NONE =>
raise Useful.Bug
"ElementSet.getIndex";
fun isRoot indices lows e = getIndex indices e = getIndex lows e;
fun reduceIndex indices (e,i) =
let
val j = getIndex indices e
in
if j <= i
then indices
else KM.insert indices (e,i)
end;
fun tarjan children =
let
fun dfsVertex sccs callstack index indices lows stack elt =
let
val indices = KM.insert indices (elt,index)
and lows = KM.insert lows (elt,index)
val index = index + 1
val stack = pushStack stack elt
val chil = toList (children elt)
in
dfsSuccessors sccs callstack index indices lows stack elt chil
end
and dfsSuccessors sccs callstack index indices lows stack elt chil =
case chil
of
[] =>
let
val (sccs,stack) =
if isRoot indices lows elt
then popStack elt sccs stack
else (sccs,stack)
in
case callstack
of
[] => (sccs,index,indices,lows)
| (p,elts) :: callstack =>
let
val lows = reduceIndex lows (p, getIndex lows elt)
in
dfsSuccessors sccs callstack index indices lows stack p elts
end
end
| c :: chil =>
case KM.peek indices c
of
NONE =>
let
val callstack = (elt,chil) :: callstack
in
dfsVertex sccs callstack index indices lows stack c
end
| SOME cind =>
let
val lows =
if inStack c stack
then reduceIndex lows (elt,cind)
else lows
in
dfsSuccessors sccs callstack index indices lows stack elt chil
end
fun dfsRoots sccs index indices lows elts =
case elts
of
[] => sccs
| elt :: elts =>
if KM.inDomain elt indices
then
dfsRoots sccs index indices lows elts
else
let
val callstack = []
val (sccs,index,indices,lows) =
dfsVertex sccs callstack index indices lows emptyStack elt
in
dfsRoots sccs index indices lows elts
end
val sccs = []
and index = 0
and indices = KM.new ()
and lows = KM.new ()
in
dfsRoots sccs index indices lows
end;
in
fun preOrderSCC children roots =
let
val result = tarjan children (toList roots)
(*BasicDebug
val () =
if subset roots (unionList result) then ()
else raise Useful.Bug "ElementSet.preOrderSCC: missing roots"
val () =
if preOrderedSCC children result then ()
else raise Useful.Bug "ElementSet.preOrderSCC: bad ordering"
*)
in
result
end;
fun postOrderSCC children roots =
let
val result =
List.rev (tarjan children (toList roots))
(*BasicDebug
val () =
if subset roots (unionList result) then ()
else raise Useful.Bug "ElementSet.postOrderSCC: missing roots"
val () =
if postOrderedSCC children result then ()
else raise Useful.Bug "ElementSet.postOrderSCC: bad ordering"
*)
in
result
end;
end;
(* ------------------------------------------------------------------------- *)
(* Pretty-printing. *)
(* ------------------------------------------------------------------------- *)
fun toString
set =
"{" ^ (
if null
set then "" else Int.toString (
size set)) ^
"}";
(* ------------------------------------------------------------------------- *)
(* Iterators over sets *)
(* ------------------------------------------------------------------------- *)
type iterator = unit KM.iterator;
fun mkIterator (
Set m) = KM.mkIterator m;
fun mkRevIterator (
Set m) = KM.mkRevIterator m;
fun readIterator iter =
let
val (elt,()) = KM.readIterator iter
in
elt
end;
fun advanceIterator iter = KM.advanceIterator iter;
end
structure IntSet =
ElementSet (IntMap);
structure IntPairSet =
ElementSet (IntPairMap);
structure StringSet =
ElementSet (StringMap);
