Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
2004
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 2004

[Date Index] [Thread Index] [Author Index]

Search the Archive

Re: Computing sets of equivalences

  • To: mathgroup at smc.vnet.net
  • Subject: [mg46486] Re: Computing sets of equivalences
  • From: drbob at bigfoot.com (Bobby R. Treat)
  • Date: Fri, 20 Feb 2004 00:29:32 -0500 (EST)
  • References: <c11sa4$mef$1@smc.vnet.net>
  • Sender: owner-wri-mathgroup at wolfram.com

Ingolf,

I love that solution.

This may make it a trifle faster (or not). I took a hint from
UnsortedUnion (under Help for Union).

unsortedUnion[a_List, b_List] := Module[{f},
     f[y_] := (f[y] = Sequence[]; y); f /@ Join[a, b]]
intersectingQ[x_List, y_List] := Module[
    {f, g},
    g[a_] := False; f[a_] := g[a] = Hold@Throw@True;
    f /@ x; Catch[Scan[ReleaseHold@g@# &, y, {1}]; False]
    ]
equivalence = List[a___, x_List, b___, y_List, c___] /; intersectingQ[
    x, y] :> List[a, unsortedUnion[x, y], b, c];

test = {{8, 7}, {12, 11}, {13, 12, 13}, {1, 
    5}, {2, 3}, {1, 2}, {3, 4}, {5, 6}, {14, 10}};
test //. equivalence

{{8, 7}, {12, 11, 13}, {1, 5, 2, 3, 4, 6}, {14, 10}}

This avoids sorting, and stops as soon as a duplicate is found rather
than building the full Intersection.

Bobby

"Ingolf Dahl" <ingolf.dahl at telia.com> wrote in message news:<c11sa4$mef$1 at smc.vnet.net>...
> Mariusz,
> 
> Here is one slightly more compact way to express your ideas in Mathematica:
> 
> expr = {{1, 2}, {1, 5}, {2, 3}, {3, 4}, {5, 6}, {7, 8}, {11, 12}, {12,
>       13}, {10, 14}};
> 
> equivalences[mylist_List] :=
>   mylist //.
>     List[a___, x_List, b___, y_List, c___] /; Intersection[x, y] != {} :>
>       List[a, Union[x, y], b, c]
> 
> equivalences[expr]
> 
> (Output {{1, 2, 3, 4, 5, 6}, {7, 8}, {11, 12, 13}, {10, 14}})
> 
> If you want to change the sorting order, you might apply some variant of
> Sort afterwards.
> 
> Best regards
> 
> Ingolf Dahl
> Sweden
> 
> >-----Original Message-----
> >From: Mariusz Jankowski [mailto:mjankowski at usm.maine.edu]
To: mathgroup at smc.vnet.net
> >Sent: Wednesday, February 18, 2004 06:37
> >To: mathgroup at smc.vnet.net
> >Subject: [mg46486]  Computing sets of equivalences
> >
> >
> >Dear Mathgroup, I think this falls into the "classic algorithms" category,
> >so I hope some of you will find this interesting. I checked archives and
> >mathsource but did not find anything useful.
> >
> >I have a list of lists, each sublist implying an equivalence. I am
> >trying to
> >split the list into lists of equivalences (this is part of a connected
> >components algorithm).  For example, given
> >
> >{{1,2},{1,5},{2,3},{3,4},{5,6},{7,8},{11,12},{12,13},{10,14}}
> >
> >I want
> >
> >{{1,2,3,4,5,6},{7,8},{10,14},{11,12,13}}.
> >
> >Here is my currently "best" attempt. I accumulate the equivalences by
> >comparing pairs of list, merging them if they have common elements. At the
> >end of each iteration I remove all merged pairs from original list and
> >repeat.
> >
> > iselectEquivalences[v_]:=Module[{x,y,tmp,pos},
> >     x=v;y={};
> >     While[x=!={},
> >       tmp=x[[1]];
> >       pos={{1}};
> >       Do[
> >         If[Intersection[tmp,x[[i]]]==={}, tmp, tmp=Union[tmp,x[[i]]];
> >           pos=Join[pos, {{i}}]], {i, 2, Length[x]}];
> >       x=Delete[x, pos];
> >       y=Join[y, {tmp}] ];
> > y]
> >
> >
> >Can you tell me if you have or know of a realization of this classic
> >operation that works better/faster? Are there alternative paradigms for
> >solving this kind of problem.
> >
> >
> >Thanks, Mariusz
> >


  • Prev by Date: RE: RE: Computing sets of equivalences
  • Next by Date: corrected RE: Re: Computing sets of equivalences
  • Previous by thread: RE: RE: Computing sets of equivalences
  • Next by thread: Re: Computing sets of equivalences