Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

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.

share|improve this question
    
Have a look at this - you can download the author code which enumerates cycles in a DG, from that just take shortest result. –  rasher Jun 1 at 21:57

1 Answer 1

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

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

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.