<j] ]; ]; ]; ret ] contract[g_,l_,k_]:=Module[{gnew,lnew,v,w,A,p,i,brk,last}, lnew=l; A=ToAdjacencyMatrix[g]; p = ToUnorderedPairs[g]; {v,w}=Sort[ Edges[g][[k]] ]; last=V[g]; If[v==w, (* THEN DELETE THE LOOP AND ADD 1 TO WEIGHT AT V *) A[[v,v]]--; gnew = FromAdjacencyMatrix[A]; lnew[[v]]++;, (* ELSE DELETE ONE COPY OF THE EDGE... *) brk = 0; i = 1; While[brk ==0, If [p[[i]] == {v,w}, p = Drop[p,{i,i}]; brk = 1;, i++; ]; ]; (* THEN REPLACE W->V, LAST->W *) For[i=1,i<=Length[p],i++, If[p[[i]][[1]] == w, p[[i]][[1]]=v, Null]; If[p[[i]][[2]] == w, p[[i]][[2]]=v, Null]; If[p[[i]][[1]] == last, p[[i]][[1]]=w, Null]; If[p[[i]][[2]] == last, p[[i]][[2]]=w, Null]; ]; gnew= FromUnorderedPairs[p]; (* AND EDIT LNEW: V GETS V+W, W GETS LAST, LAST GETS REMOVED *) lnew[[v]] = lnew[[v]] + lnew[[w]]; lnew[[w]] = lnew[[ Length[lnew] ]]; lnew = Delete[lnew, Length[lnew]]; ]; If[Length[lnew] == V[gnew], Null, Print ["FAIL",g,l,gnew,lnew];Pause[1];]; {gnew,lnew} ] isoq[g1_,l1_,g2_,l2_] := Module[{ret, ps, I,i}, ret = False; If [ (degseq[g1]==degseq[g2]) && (Sort[l1]==Sort[l2]), (* CHECK IF THERE IS AN ISO, SET RET = TRUE IF SO *) ps = Permutations[V[g1]]; For[i = 1, i<=Length[ps], i++, If[ IsomorphismQ[g1,g2,ps[[i]] ] && Permute[ l2,ps[[i]] ] == l1, ret = True, Null ]; ]; (* OTHERWISE, RET REMAINS 0 *) Null; ]; ret ] (* MAKE THE MAXIMAL CELLS MARKED GRAPHS *) vli={}; For[i=1,i<=Length[maxcells[[genus]]],i++, vli = Append[vli, makeobj[maxcells[[genus]][[i]]]]; ]; poset=EmptyGraph[Length[vli]]; i=1; (* FOR EACH VERTEX IN POSET... *) While[i<=V[poset], {gr, li} = vli[[i]]; (* COMPUTE ITS CONTRACTIONS ONE BY ONE... *) For[k=1,k<=M[gr],k++, {grnew,linew} = contract[gr,li,k]; (* FOR EACH CONTRACTION, IS IT ISOMORPHIC TO A KNOWN VERTEX? *) flag = 1; j = 1; While[flag==1 && j <= V[poset], {g3,l3} = vli[[j]]; (* IF YES , ADD EDGE *) If[isoq[grnew,linew, g3,l3], (* ADD AN EDGE IF THERE ISNT ONE... *) If[MemberQ[Edges[poset], {i,j}], Null, poset = AddEdge[poset, {i,j}]; ]; (* ...AND STOP LOOKING *) flag = 0;, Null; ]; j++; ]; If[flag==1, poset = AddVertex[poset]; poset = AddEdge[poset, {i, V[poset]}]; vli = Append[vli, {grnew, linew}], Null; ]; ]; i++; ]; (* MAKE GRAPHICS FOR EACH VERTEX OF THE POSET *) vscale=10; vli2={}; For[i=1,i<=Length[vli],i++, vli2=Append[vli2, GraphPlot[edges[ToAdjacencyMatrix[vli[[i]][[1]]]],ImageSize->80,MultiedgeStyle->0.3,SelfLoopStyle->1,PlotStyle->{Blue},VertexRenderingFunction->({Black,Inset[vli[[i,2]][[#2]],#1+{0.1,0}]} &)]]; ]; (* THE BOTTOM VERTEX SHOULD DISPLAY A NUMBER AND NOT THE EMPTY GRAPH *) vli2[[ Length[vli2] ]] = vli[[ Length[vli] ]][[2]][[1]]; (* COMPUTE VERTEX COORDINATES BY HAND *) (* FIRST MAKE A LIST OF NUMBERS OF EDGES *) numedges=Table[0,{Length[vli]}]; For[i=1,i<=Length[vli],i++, numedges[[i]] = M[vli[[i]][[1]] ]; ]; (* NOW COORDINATES *) coords=Table[0,{Length[vli]}]; howmanysofar=Table[0,{M[vli[[1]][[1]]]+1}]; (* Ith entry tells us how many graphs with i-1 edges we have encountered *) For[i=1,i<=Length[vli],i++, coords[[i]] = i->{(-1)*Length[Position[numedges, numedges[[i]]]]+2*howmanysofar[[ numedges[[i]]+1 ]], 2*numedges[[i]]*vscale}; howmanysofar[[ numedges[[i]]+1 ]]++; ]; GraphPlot[edges[ToAdjacencyMatrix[poset]],VertexRenderingFunction->({White,Disk[#1,.5],Black,Inset[vli2[[#2]],#1]} &),VertexCoordinateRules->coords]