# find cycle in directed graph

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}.

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
Commented Jun 1, 2014 at 21:57

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 -> [email protected], VertexStyle -> [email protected]]


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}]


• Nice answer, +1, I've used DL's linked answer often.
– ciao
Commented Jun 1, 2014 at 23:37
• The next version will have a FindCycle which I suspect will be much more efficient than what I coded. Commented Jun 2, 2014 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å
Commented Jun 2, 2014 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. Commented Jun 2, 2014 at 14:07
• @DanielLichtblau CW stands for Community Wiki. Since I'm using your code it would be legitimate.
– Öskå
Commented Jun 2, 2014 at 14:09