find cycle in directed graph

Question

Given a digraph G in the form of a list of edges, is there implemented some command that returns a directed cycle in G of shortest length? The combinatorica package does this with GG=ToCombinatoricaGraph[G]; FindCycle[GG], but converting a graph as a set of edges into a combinatorica graph messes things up.

For example, Combinatorica renames the vertices, so I don't know what the original vertices of the returned cycle are. Also, I'm not sure the returned cycle is shortest in the graph. And drawing Combinatorica graphs via ShowGraph[GG] is uglier that using GraphPlot[G].

More concretely,

 G={{2,2}->{1},{1,2,1}->{2,2},{2,1,1}->{2,2},{1,1,1,1}->{1,1,2},{1,1,1,1}->{1,2,1},     
 {1,1,1,1}->{2,1,1},{1,2,2,2}->{1,1,2},{1,2,2,2}->{1,2,1},{2,1,2,2}->{1,1,2},{2,1,2,2}->
 {2,1,1},{2,2,1,2}->{1,1,2},{2,2,1,2}->{1,2,1},{2,2,2,1}->{1,2,1},{2,2,2,1}->{2,1,1},
 {1,1,1,2,2}->{1,1,1,1},{1,1,1,2,2}->{1,2,2,2},{1,1,2,2,1}->{1,1,1,1},{1,1,2,2,1}->
 {2,1,2,2},{1,2,1,2,1}->{2,2,1,2},{1,2,2,1,1}->{1,1,1,1},{1,2,2,1,1}->{1,2,2,2},
 {1,2,2,1,1}->{2,2,2,1},{2,1,1,1,2}->{1,1,1,1},{2,1,1,1,2}->{2,1,2,2},{2,1,1,1,2}->
 {2,2,1,2},{2,1,1,2,1}->{2,2,2,1},{2,1,2,1,1}->{2,1,2,2},{2,2,1,1,1}->{1,1,1,1},
 {2,2,1,1,1}->{2,2,1,2},{2,2,1,1,1}->{2,2,2,1},{2,2,2,2,2}->{1,2,2,2},{2,2,2,2,2}->
 {2,1,2,2},{2,2,2,2,2}->{2,2,1,2},{2,2,2,2,2}->{2,2,2,1},{1,1,1,1,1,2}->{1,1,1,2,2},     
 {1,1,1,1,1,2}->{1,1,2,1,2},{1,1,1,1,1,2}->{1,2,1,1,2},{1,1,1,1,2,1}->{1,1,2,2,1},
 {1,1,1,1,2,1}->{1,2,1,2,1},{1,1,1,1,2,1}->{2,1,1,1,2},{1,1,1,2,1,1}->{1,1,1,2,2},
 {1,1,1,2,1,1}->{1,2,2,1,1},{1,1,1,2,1,1}->{2,1,1,2,1},{1,1,2,1,1,1}->{1,1,2,1,2},
 {1,1,2,1,1,1}->{1,1,2,2,1},{1,1,2,1,1,1}->{2,1,2,1,1},{1,1,2,2,2,2}->{1,1,1,2,2},
 {1,1,2,2,2,2}->{1,1,2,1,2},{1,1,2,2,2,2}->{1,1,2,2,1},{1,2,1,1,1,1}->{1,2,1,1,2},
 {1,2,1,1,1,1}->{1,2,1,2,1},{1,2,1,1,1,1}->{2,2,1,1,1},{1,2,1,2,2,2}->{1,2,1,1,2},
 {1,2,1,2,2,2}->{1,2,1,2,1},{1,2,2,1,2,2}->{1,1,1,2,2},{1,2,2,1,2,2}->{1,2,2,1,1},
 {1,2,2,2,1,2}->{1,1,2,1,2},{1,2,2,2,1,2}->{1,2,1,1,2},{1,2,2,2,2,1}->{1,1,2,2,1},
 {1,2,2,2,2,1}->{1,2,1,2,1},{1,2,2,2,2,1}->{1,2,2,1,1},{1,2,2,2,2,1}->{2,2,2,2,2},
 {2,1,1,1,1,1}->{2,1,1,1,2},{2,1,1,1,1,1}->{2,1,1,2,1},{2,1,1,1,1,1}->{2,1,2,1,1},
 {2,1,1,1,1,1}->{2,2,1,1,1},{2,1,1,2,2,2}->{1,1,1,2,2},{2,1,1,2,2,2}->{2,1,1,1,2},
 {2,1,1,2,2,2}->{2,1,1,2,1},{2,1,1,2,2,2}->{2,2,2,2,2},{2,1,2,1,2,2}->{1,1,2,1,2},
 {2,1,2,1,2,2}->{2,1,2,1,1},{2,1,2,2,1,2}->{1,1,2,2,1},{2,1,2,2,1,2}->{2,1,1,1,2},
 {2,1,2,2,2,1}->{2,1,1,2,1},{2,1,2,2,2,1}->{2,1,2,1,1},{2,2,1,1,2,2}->{1,1,1,2,2},
 {2,2,1,1,2,2}->{1,2,1,1,2},{2,2,1,1,2,2}->{2,2,1,1,1},{2,2,1,1,2,2}->{2,2,2,2,2},     
 {2,2,1,2,1,2}->{1,1,2,1,2},{2,2,1,2,1,2}->{1,2,1,2,1},{2,2,1,2,2,1}->{1,1,2,2,1},
 {2,2,1,2,2,1}->{2,2,1,1,1},{2,2,2,1,1,2}->{1,2,1,1,2},{2,2,2,1,1,2}->{1,2,2,1,1},
 {2,2,2,1,1,2}->{2,1,1,1,2},{2,2,2,1,1,2}->{2,2,2,2,2},{2,2,2,1,2,1}->{1,2,1,2,1},
 {2,2,2,1,2,1}->{2,1,1,2,1},{2,2,2,2,1,1}->{1,2,2,1,1},{2,2,2,2,1,1}->{2,1,2,1,1},
 {2,2,2,2,1,1}->{2,2,1,1,1},{2,2,2,2,1,1}->{2,2,2,2,2},{2,2}->{1,1,2},{2,1,2,2}->
 {1,1,1,2,2},{2,2,1,2}->{1,1,2,1,2},{2,2,2,1}->{1,1,2,2,1},{1,2,2,2}->{1,2,1,1,2},
 {2,1,1,1,2}->{1,1,1,1,1,2},{2,1,1,2,1}->{1,1,1,1,2,1},{2,1,2,1,1}->{1,1,1,2,1,1},
 {2,2,1,1,1}->{1,1,2,1,1,1},{2,2,2,2,2}->{1,1,2,2,2,2},{1,2,2,1,1}->{1,2,1,1,1,1}};
   G0=Join@@Table[Tuples[{1,2},k], {k, 6}];
   GraphPlot[G, VertexLabeling->True, EdgeLabeling->False, DirectedEdges->True, 
   VertexCoordinateRules->((#->{Length[#],Automatic}) & /@ G0)]
   Needs["Combinatorica`", "GraphUtilities`"]
   GG=ToCombinatoricaGraph[G]; FindCycle[GG]

returns {24, 14, 27, 18, 25, 17, 24}. enter image description here

My digraph represents a chain complex of modules (homological algebra), hence the desire to draw it in such a way.

Have a look at this - you can download the author code which enumerates cycles in a DG, from that just take shortest result. — ciao, Jun 01 '14 at 21:57

score 8 · Answer 1 · edited Apr 13 '17 at 12:55

By using this answer from Daniel Lichtblau you can do the following:

G={{2,2}->{1},{1,2,1}->{2,2},{2,1,1}->{2,2},{1,1,1,1}->{1,1,2},{1,1,1,1}->{1,2,1},     
 {1,1,1,1}->{2,1,1},{1,2,2,2}->{1,1,2},{1,2,2,2}->{1,2,1},{2,1,2,2}->{1,1,2},{2,1,2,2}->
 {2,1,1},{2,2,1,2}->{1,1,2},{2,2,1,2}->{1,2,1},{2,2,2,1}->{1,2,1},{2,2,2,1}->{2,1,1},
 {1,1,1,2,2}->{1,1,1,1},{1,1,1,2,2}->{1,2,2,2},{1,1,2,2,1}->{1,1,1,1},{1,1,2,2,1}->
 {2,1,2,2},{1,2,1,2,1}->{2,2,1,2},{1,2,2,1,1}->{1,1,1,1},{1,2,2,1,1}->{1,2,2,2},
 {1,2,2,1,1}->{2,2,2,1},{2,1,1,1,2}->{1,1,1,1},{2,1,1,1,2}->{2,1,2,2},{2,1,1,1,2}->
 {2,2,1,2},{2,1,1,2,1}->{2,2,2,1},{2,1,2,1,1}->{2,1,2,2},{2,2,1,1,1}->{1,1,1,1},
 {2,2,1,1,1}->{2,2,1,2},{2,2,1,1,1}->{2,2,2,1},{2,2,2,2,2}->{1,2,2,2},{2,2,2,2,2}->
 {2,1,2,2},{2,2,2,2,2}->{2,2,1,2},{2,2,2,2,2}->{2,2,2,1},{1,1,1,1,1,2}->{1,1,1,2,2},     
 {1,1,1,1,1,2}->{1,1,2,1,2},{1,1,1,1,1,2}->{1,2,1,1,2},{1,1,1,1,2,1}->{1,1,2,2,1},
 {1,1,1,1,2,1}->{1,2,1,2,1},{1,1,1,1,2,1}->{2,1,1,1,2},{1,1,1,2,1,1}->{1,1,1,2,2},
 {1,1,1,2,1,1}->{1,2,2,1,1},{1,1,1,2,1,1}->{2,1,1,2,1},{1,1,2,1,1,1}->{1,1,2,1,2},
 {1,1,2,1,1,1}->{1,1,2,2,1},{1,1,2,1,1,1}->{2,1,2,1,1},{1,1,2,2,2,2}->{1,1,1,2,2},
 {1,1,2,2,2,2}->{1,1,2,1,2},{1,1,2,2,2,2}->{1,1,2,2,1},{1,2,1,1,1,1}->{1,2,1,1,2},
 {1,2,1,1,1,1}->{1,2,1,2,1},{1,2,1,1,1,1}->{2,2,1,1,1},{1,2,1,2,2,2}->{1,2,1,1,2},
 {1,2,1,2,2,2}->{1,2,1,2,1},{1,2,2,1,2,2}->{1,1,1,2,2},{1,2,2,1,2,2}->{1,2,2,1,1},
 {1,2,2,2,1,2}->{1,1,2,1,2},{1,2,2,2,1,2}->{1,2,1,1,2},{1,2,2,2,2,1}->{1,1,2,2,1},
 {1,2,2,2,2,1}->{1,2,1,2,1},{1,2,2,2,2,1}->{1,2,2,1,1},{1,2,2,2,2,1}->{2,2,2,2,2},
 {2,1,1,1,1,1}->{2,1,1,1,2},{2,1,1,1,1,1}->{2,1,1,2,1},{2,1,1,1,1,1}->{2,1,2,1,1},
 {2,1,1,1,1,1}->{2,2,1,1,1},{2,1,1,2,2,2}->{1,1,1,2,2},{2,1,1,2,2,2}->{2,1,1,1,2},
 {2,1,1,2,2,2}->{2,1,1,2,1},{2,1,1,2,2,2}->{2,2,2,2,2},{2,1,2,1,2,2}->{1,1,2,1,2},
 {2,1,2,1,2,2}->{2,1,2,1,1},{2,1,2,2,1,2}->{1,1,2,2,1},{2,1,2,2,1,2}->{2,1,1,1,2},
 {2,1,2,2,2,1}->{2,1,1,2,1},{2,1,2,2,2,1}->{2,1,2,1,1},{2,2,1,1,2,2}->{1,1,1,2,2},
 {2,2,1,1,2,2}->{1,2,1,1,2},{2,2,1,1,2,2}->{2,2,1,1,1},{2,2,1,1,2,2}->{2,2,2,2,2},     
 {2,2,1,2,1,2}->{1,1,2,1,2},{2,2,1,2,1,2}->{1,2,1,2,1},{2,2,1,2,2,1}->{1,1,2,2,1},
 {2,2,1,2,2,1}->{2,2,1,1,1},{2,2,2,1,1,2}->{1,2,1,1,2},{2,2,2,1,1,2}->{1,2,2,1,1},
 {2,2,2,1,1,2}->{2,1,1,1,2},{2,2,2,1,1,2}->{2,2,2,2,2},{2,2,2,1,2,1}->{1,2,1,2,1},
 {2,2,2,1,2,1}->{2,1,1,2,1},{2,2,2,2,1,1}->{1,2,2,1,1},{2,2,2,2,1,1}->{2,1,2,1,1},
 {2,2,2,2,1,1}->{2,2,1,1,1},{2,2,2,2,1,1}->{2,2,2,2,2},{2,2}->{1,1,2},{2,1,2,2}->
 {1,1,1,2,2},{2,2,1,2}->{1,1,2,1,2},{2,2,2,1}->{1,1,2,2,1},{1,2,2,2}->{1,2,1,1,2},
 {2,1,1,1,2}->{1,1,1,1,1,2},{2,1,1,2,1}->{1,1,1,1,2,1},{2,1,2,1,1}->{1,1,1,2,1,1},
 {2,2,1,1,1}->{1,1,2,1,1,1},{2,2,2,2,2}->{1,1,2,2,2,2},{1,2,2,1,1}->{1,2,1,1,1,1}};
G0=Join@@Table[Tuples[{1,2},k], {k, 6}];
g = Graph[G, DirectedEdges -> True, 
  VertexCoordinates -> ((# -> {Length[#], Automatic}) & /@ G0),
  VertexLabels -> "Name", ImagePadding -> 20, ImageSize -> 700,
  EdgeStyle -> Opacity@.5, VertexStyle -> Opacity@.5]

Mathematica graphics

Daniel Lichtblau part:

ee = EdgeList[g];
vv = VertexList[g];
reprule = Thread[vv -> Range[Length[vv]]];
revrule = Map[Reverse, reprule];
pairs = ee /. reprule /. DirectedEdge -> List;

extendCycle[cyc_List, edges_List] := 
 Map[If[# > First[cyc] && ! MemberQ[cyc, #], Append[cyc, #], 
    Null ] &, edges[[Last[cyc]]]] /. Null :> Sequence[]

cycles[omat_, k_] := Module[
  {n = Length[Union[Flatten@omat]], m2, cyc, cyclist, mat},
  mat = Join[omat, Thread[{Range[n], 0}]];
  m2 = Map[Last, SplitBy[Sort[mat], First], {2}];
  m2 = m2 /. 0 :> Sequence[];
  cyclist = 
   Flatten[Drop[MapIndexed[{#2[[1]], #1} &, m2, {2}], -k + 1], 1];
  cyclist = Select[cyclist, #[[2]] > #[[1]] &];
  Do[cyclist = 
    Flatten[Map[extendCycle[#, m2] &, cyclist], 1], {k - 2}];
  Map[If[MemberQ[m2[[Last[#]]], First[#]], Append[#, First[#]], 
      Null] &, cyclist] /. Null :> Sequence[]]

Usage:

cycles[pairs, 6]

{{14, 27, 18, 25, 17, 24, 14}}

Then you can easily use HighlightGraph:

vertices = Part[vv, #] & /@ First[cycles[pairs, 6]];
sub = DirectedEdge @@@ Thread[{vertices, RotateLeft@vertices}];
HighlightGraph[
  SetProperty[g, 
    VertexLabelStyle -> {# -> {Red, Bold, 12}} & /@ vertices],
  {sub, vertices}]

Mathematica graphics

The next version will have a FindCycle which I suspect will be much more efficient than what I coded. — Daniel Lichtblau, Jun 02 '14 at 14:00
@DanielLichtblau We will have to wait to compare.. :) I hope you don't mind me "stealing" your code though, I can CW my answer if you prefer. — Öskå, Jun 02 '14 at 14:03
@Öskå I'm always happy to see code I write get used (and anyway I don't know what "CW" means). As for comparing, I did once, and thought it must be really great to be young and smart. — Daniel Lichtblau, Jun 02 '14 at 14:07
@DanielLichtblau CW stands for Community Wiki. Since I'm using your code it would be legitimate. — Öskå, Jun 02 '14 at 14:09
You should have specified in your question that you were using v6. — Öskå, Jun 02 '14 at 14:43
Actually I have v7, but I'm currently installing v9. Still, it would be nice if the pictures were drawn with k-tuples having x-coordinate k. — Leo, Jun 02 '14 at 14:47
I guess that can be done easily by playing with VertexCoordinates :) I have to go now but I will take a look later. — Öskå, Jun 02 '14 at 14:49
@LeonLampret After playing around a little I can propose you that. — Öskå, Jun 02 '14 at 18:36

find cycle in directed graph

1 Answers1