5
$\begingroup$

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.

Improve this question
$\endgroup$
1
  • $\begingroup$ Have a look at this - you can download the author code which enumerates cycles in a DG, from that just take shortest result. $\endgroup$
    – ciao
    Commented Jun 1, 2014 at 21:57

1 Answer 1

Reset to default
8
$\begingroup$

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

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

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

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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