Mathematica 9 is now available
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

corrected RE: Re: Computing sets of equivalences

  • To: mathgroup at smc.vnet.net
  • Subject: [mg46479] corrected RE: [mg46459] Re: Computing sets of equivalences
  • From: "Wolf, Hartmut" <Hartmut.Wolf at t-systems.com>
  • Date: Fri, 20 Feb 2004 00:29:23 -0500 (EST)
  • Sender: owner-wri-mathgroup at wolfram.com

Carl,

I managed to repair my proposal. The problem was to unify classes if they
are linked later. I do that now "repeating the trick":

classesFrom3[equis_] := Module[{nex, ext, class},
    nex[_] := True;
    ext[_] := {};
    If[nex[#1],
          If[nex[#2], nex[#1] = nex[#2] = class[Min[#1, #2]], , 
            nex[#1] = nex[#2]], , 
          If[nex[#2], nex[#2] = nex[#1], , 
            Evaluate[nex[Max[#1, #2]]] = nex[Min[#1, #2]]]] & @@@ equis;
    nex[_] =.;
    class[i_] = i;
    Scan[(ext[nex[#]] = {ext[nex[#]], #}) &, 
      DownValues[nex][[All, 1, 1, 1]]];
    ext[_] =.;
    Flatten /@ DownValues[ext][[All, 2]]
    ]

Of course that costs me something, the advantage compared to yours now has
now diminshed to the cubic root of 2.



Here is also a method to produce test data:
 
In[337]:=
cycs = Union[Prepend[Table[Random[Integer, {1, 30}], {5}], 0]]

Out[337]= {0, 13, 20, 24, 25, 30}

In[341]:=
rngs = DeleteCases[{1, 0} + # & /@ Partition[cycs, 2, 1], {x_, x_}]
Out[341]= {{1, 13}, {14, 20}, {21, 24}, {26, 30}}

In[342]:=
prob = Join @@ (Join[Partition[Range[#1, #2], 2, 1], 
              Block[{rnd}, 
                rnd := Random[Integer, {#1, #2}]; {Take[
                    NestWhileList[rnd &, rnd, (#1 === #2 &), 2], -2]}]] &
@@@ 
          rngs);

In[343]:= eqs = prob[[RandomPermutation[Length[prob]]]];

In[344]:= classesFrom3[eqs]
Out[344]=
{{1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13},
 {14, 15, 16, 17, 18, 19, 20},
 {21, 22, 23, 24}, {26, 27, 28, 29, 30}}

In[345]:= Range @@@ rngs
Out[345]=
{{1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13},
 {14, 15, 16, 17, 18, 19, 20},
 {21, 22, 23, 24}, {26, 27, 28, 29, 30}}



Your program gets recursion problems with that data, perhaps you may arrage
this with some preordering (but you'll loose O[n] then).


Both programs from Mariusz give wrong answers. Also that from Jens-Peer. The
program from Ingolf Dahl gives the same answer as mine, in a different
ordering. But of course it is not competitive with the performance. It is
however a nice example, to produce a (possible slow but) provable correct
solution first!


Hartmut





>-----Original Message-----
>From: Wolf, Hartmut 
To: mathgroup at smc.vnet.net
>Sent: Thursday, February 19, 2004 4:24 PM
>To: 'Carl K. Woll'
>Cc: 'Mariusz Jankowski'
>Subject: [mg46479] Re: RE: [mg46459] Re: Computing sets of equivalences
>
>
>Yes, Carl, 
>
>just saw it, re-reading my explanations, it's wrong! As are 
>both solution from Marisz, not yours.
>
>Sorry, Hartmut
>
>
>>-----Original Message-----
>>From: Wolf, Hartmut 
To: mathgroup at smc.vnet.net
>>Sent: Thursday, February 19, 2004 4:07 PM
>>To: 'Carl K. Woll'; mathgroup at smc.vnet.net
>>Cc: 'Mariusz Jankowski'
>>Subject: [mg46479] RE: [mg46459] Re: Computing sets of equivalences
>>
>>
>>Dear Carl,
>>
>>miserably I missed the challenge yesterday. I tried today 
>>without looking at the solutions, and came up with something 
>>which appears to be similiar to yours (no wonder I learnt that 
>>from you!).
>>
>>It is robust against ordering and repetitions (and is faster 
>>than yours by a square root of 2).  In fact it is 2 solutions, 
>>the first one is this
>>
>>
>>classesFrom[equis_] := 
>>  Module[{objs = Union[Flatten[equis]], nex, ext, classes}, 
>>nex[_] := True;
>>    ext[_] := {};
>>    classes = 
>>      Union[If[nex[#1], 
>>              If[nex[#2], nex[#1] = nex[#2] = #1, , nex[#1] = 
>>nex[#2]], , 
>>              If[nex[#2], nex[#2] = nex[#1], , nex[#1]]] & @@@ equis];
>>    Scan[(ext[nex[#]] = {ext[nex[#]], #}) &, objs];
>>    Flatten[ext[#]] & /@ classes
>>    ]
>>
>>and derived from that, as obj and classes can be replaced by 
>>DownValues, this one:
>>
>>classesFrom2[equis_] := Module[{nex, ext},
>>    nex[_] := True;
>>    ext[_] := {};
>>    If[nex[#1], If[nex[#2], nex[#1] = nex[#2] = #1, , nex[#1] 
>>= nex[#2]], , 
>>          If[nex[#2], nex[#2] = nex[#1], ,]] & @@@ equis;
>>    nex[_] =.;
>>    Scan[(ext[nex[#]] = {ext[nex[#]], #}) &, 
>>      DownValues[nex][[All, 1, 1, 1]]];
>>    ext[_] =.;
>>    Flatten /@ DownValues[ext][[All, 2]]
>>    ]
>>
>>This avoids Union, but is only marginally faster, such O[n] vs 
>>O[n log n] seems not to be a practical issue here.
>>
>>The algorithmic idea is quite simple: if for an associated 
>>pair both entries have not been encountered, a new equivalence 
>>class is created (which gets its name from the first object) 
>>and both objects are linked to that class by definitions for 
>>nex[obj].  If only one object has not been encountered, then 
>>it is linked to the class the other obj refers to.  If both 
>>have been encountered we simply pass on.
>>
>>Done that, we collect the classes passing through all objects 
>>(represented by the DownValues of nex) and finally display the 
>>classes (represented by the DownValues of ext) forgetting their names.
>>
>>yours,
>>Hartmut
>>
>>---
>>P.S. I didn't look into the books, but this seems to be a 
>>classical problem; perhaps it's somewhere in the AddOns.
>>
>>
>>
>[...]
>


  • Prev by Date: Re: Computing sets of equivalences
  • Next by Date: Re: Re: Help Browser issue in 5.0.1 on Mac OS X
  • Previous by thread: Re: Help!!!!
  • Next by thread: Re: corrected RE: Re: Computing sets of equivalences