Re: a little nasty problem?

*To*: mathgroup at smc.vnet.net*Subject*: [mg108801] Re: a little nasty problem?*From*: David Bevan <david.bevan at pb.com>*Date*: Thu, 1 Apr 2010 05:59:44 -0500 (EST)

Unfortunately, the Combinatorica functions seem to arbitrarily reverse the direction of directed edges :( The following works though: In[]:== <<GraphUtilities` makeGraph[v_,f_,lf_]:==Map[lf[v[[#]]]&,Select[Flatten[Table[i->j,{i,Length[v]},{j,Length[v]}]],f[v[[#[[1]]]],v[[#[[2]]]]]&],{2}] intCmp[{_,x_},{_,y_}]:==x[[1]]>==y[[1]]&&x[[2]]>==y[[2]]&&x!==y intLabel[z_]:==First[z] In[]:== intData=={{"C",{0.5,0.6}},{"D",{0.1,0.2}},{"A",{0.8,0.9}},{"B",{0.4,0.6}},{"F",{0.6,0.65}},{"G",{0,0.7}}}; In[]:== intGraph==makeGraph[intData,intCmp,intLabel] Out[]== {C->D,C->B,A->C,A->D,A->B,A->F,A->G,B->D,F->C,F->D,F->B} In[]:== transRed[g_]:==Module[{m==AdjacencyMatrix[g],r,n,i,j,k},r==m;n==Length[m];Do[If[m[[i,j]]!==0&&m[[j,k]]!==0 &&m[[i,k]]!==0&&(i!==j)&&(j!==k)&&(i!==k),r[[i,k]]==0],{i,n},{j,n},{k,n}];Rule@@#&/@Map[VertexList[g][[#]]&,Position[Normal[r],1],{2}]] In[]:== redIntGraph==transRed[intGraph] Out[]== {C->B,B->D,A->F,A->G,F->C} In[]:== LayeredGraphPlot[redIntGraph,VertexLabeling->True] In[]:== LayeredGraphPlot[transRed[makeGraph[Table[{i,Sort[{RandomInteger[{0,100}],RandomInteger[{0,100}]}]},{i,20}],intCmp,intLabel]],VertexLabeling->True] David %^> ________________________________________ From: David Bevan Sent: 31 March 2010 13:33 To: mathgroup at smc.vnet.net Subject: [mg108801] RE: [mg108791] Re: a little nasty problem? The Combinatorica functions MakeGraph[] and either TransitiveReduction[] or HasseDiagram[] may do what you require. Then you could use LayeredGraphPlot[]. David %^> > -----Original Message----- > From: dh [mailto:dh at metrohm.com] > Sent: 31 March 2010 12:22 > To: mathgroup at smc.vnet.net > Subject: [mg108791] Re: a little nasty problem? > > Hi Francisco, > I am not sure if I understood correctly. > 1) Create a chain by starting at the highest interval and take all > intervals that a lower than the preceding one. > 2) delete the found intevalls with the exception of the highest one. > 3) repeat until only the highest one remains > > This can be done e.g. by: > > int == {{"C", {0.5, 0.6}}, {"D", {0.1, 0.2}}, {"A", {0.8, > 0.9}}, {"B", {0.4, 0.6}}, {"F", {0.6, 0.65}}, {"G", {0, 0.7}}}; > alpha == int[[All, 1]]; > low == int[[All, 2, 1]];(*lower indices*) > high == int[[All, 2, 2]];(*upper indices*) > ord == Reverse@Ordering[low]; > res == {}; > While[Length[ord] > 1, > AppendTo[res, > FoldList[If[high[[#1]] >== high[[#2]], #2, #1] &, First@ord, Rest@ord] > ]; > ord == Prepend[Complement[ord, Union[Flatten@res]], First[ord]]; > ];(*create chains*) > res == res /. {x1___, x_, x_, x2___} -> {x1, x, > x2};(*remove duplicates*) > Map[alpha[[#]] &, res, {2}](*replace numbers by characters*) > > Daniel > > On 30.03.2010 12:00, Francisco Gutierrez wrote: > > Dear Mathgroup: > > Suppose I have a series of intervals, and I create an order relation. > E.g., x is a typical interval, x=={0.6,0.9}, and x>==y if x[[1]]>==y[[1]]= and > x[[2]]>==y[[2]]. > > If x[[1]]>==y[[1]] and x[[2]]<y[[2]], or viceversa, the intervals are > incomparable. > > This relation violates [weakly] transitivity. > > Now, I have a set of intervals, and I want to create the lattice that > this order relation generates (suppose the weak violation of transitivity > does not pop up).. > > For example,int== > {{C,{0.5,0.6}},{D,{0.1,0.2}},{A,{0.8,0.9}},{B,{0.4,0.6}},{F,{0.6,0.65}},{= G > ,{0,0.7}}} > > > > I would like my code to put A at the top, with two chains: {A,F,C,B, D} > and {A,G}. Of course, it ought to flag any antichain if it exists. > > Now, there are several ways to do this. But what I have been able to > cook up is TERRIBLY inefficient. With 10 intervals it works no more. Is > there an efficient code to make the job? I am trying to do something that > is unfeasible? > > > > Perhaps I am naively attacking a problem that has no solution. Or > perhaps I am naively suggesting an easy problem is solvable. Some help ou= t > there? > > Francisco > > > > > -- > > Daniel Huber > Metrohm Ltd. > Oberdorfstr. 68 > CH-9100 Herisau > Tel. +41 71 353 8585, Fax +41 71 353 8907 > E-Mail:<mailto:dh at metrohm.com> > Internet:<http://www.metrohm.com> > >