Skip to main content

algorithm - Finding elementary cycles of (directed) graphs


I need to enumerate all the simple cycles (i.e. elementary cycles where no vertex is repeated other than the starting) of a graph which has both directed and undirected edges, where we can treat the undirected edges as doubly directed. (Specifically, I am looking at the Cayley graphs of S3 and S4, which can be produced using CayleyGraph[SymmetricGroup[3]] and CayleyGraph[SymmetricGroup[4]] respectively.)


I have tried two ways of doing this so far. First, I have tried using ExtractCycles in the Combinatorica package, as detailed in this answer by TomD. For example, entering the ordered pairs for S3 (as "el"):


el = {{1, 2}, {1, 4}, {2, 3}, {2, 5}, {3, 1}, {3, 6}, {4, 1}, {4, 6}, {5, 4}, {5, 2}, 
{6, 5}, {6, 3}}

And then using:


Needs["Combinatorica`"]
ExtractCycles@FromOrderedPairs@el


returns:


{{5, 4, 6, 5}, {6, 3, 6}, {5, 2, 5}, {4, 1, 4}, {3, 1, 2, 3}}

However, that set is incomplete - what about e.g. {{5, 4, 1, 2, 5}, {5, 4, 1, 2, 3, 6, 5}}? These are simple cycles, so why are they not included in the list? The output for S4 is also much truncated (obviously we would expect a lot of cycles there, but the output gives only eighteen).


The second thing I tried was this answer by kguler. Taking the example of S3, using CycleGraph[3, DirectedEdges -> True] gave the right results, but CycleGraph[4, DirectedEdges -> True] did not - i.e. the cycles {5, 4, 1, 2, 5} etc. were not picked up again. Presumably this is something to do with the doubly directed edges?


Any help with this would be much appreciated!


Edit: As requested, the ordered pairs for the Cayley graph of S4 are:


el2 = {{1, 2}, {1, 9}, {2, 3}, {2, 17}, {3, 4}, {3, 13}, {4, 1}, {4, 5}, {5, 4}, {5, 6},
{6, 16}, {6, 7}, {7, 8}, {7, 22}, {8, 5}, {8, 10}, {9, 1}, {9, 10}, {10, 8}, {10, 11},
{11, 12}, {11, 21}, {12, 9}, {12, 18}, {13, 14}, {13, 3}, {14, 15}, {14, 20}, {15, 16},

{15, 23}, {16, 13}, {16, 6}, {17, 2}, {17, 18}, {18, 19}, {18, 12}, {19, 24}, {19, 20},
{20, 17}, {20, 14}, {21, 11}, {21, 22}, {22, 7}, {22, 23}, {23, 15}, {23, 24}, {24, 19},
{24, 21}}

Answer



Here is a brute force method:


cycles[el_] :=
 Module[{f, edges = Rule @@@ el // Dispatch},
  f[x_, b___, x_] := {{x, b, x}};
  f[___, x_, ___, x_] = {};
  f[c___, v_] := Join @@ (f[c, v, #] & /@ ReplaceList[v, edges]);

  Join @@ f /@ Union @@ el
 ]

In the code above the line f[___, x_, ___, x_] = {}; was used for clarity, but faster duplicate tests exist. For short cycles f[c__] /; ! UnsameQ@c = {}; should be fast(est), but if long cycles may be present you should use f[c__] /; Signature@{c} === 0 = {}; or f[c__] /; {c} =!= DeleteDuplicates@{c} = {};


Test:


el = {{1, 2}, {1, 4}, {2, 3}, {2, 5}, {3, 1}, {3, 6}, {4, 1}, {4, 6},
      {5, 4}, {5, 2}, {6, 5}, {6, 3}};

cycles[el]



{{1, 2, 3, 1}, {1, 2, 3, 6, 5, 4, 1}, {1, 2, 5, 4, 1}, {1, 2, 5, 4, 6,
   3, 1}, {1, 4, 1}, {1, 4, 6, 5, 2, 3, 1}, {1, 4, 6, 3, 1}, {2, 3, 1,
   2}, {2, 3, 1, 4, 6, 5, 2}, {2, 3, 6, 5, 4, 1, 2}, {2, 3, 6, 5, 
  2}, {2, 5, 4, 1, 2}, {2, 5, 4, 6, 3, 1, 2}, {2, 5, 2}, {3, 1, 2, 
  3}, {3, 1, 2, 5, 4, 6, 3}, {3, 1, 4, 6, 5, 2, 3}, {3, 1, 4, 6, 
  3}, {3, 6, 5, 4, 1, 2, 3}, {3, 6, 5, 2, 3}, {3, 6, 3}, {4, 1, 2, 3, 
  6, 5, 4}, {4, 1, 2, 5, 4}, {4, 1, 4}, {4, 6, 5, 4}, {4, 6, 5, 2, 3, 
  1, 4}, {4, 6, 3, 1, 2, 5, 4}, {4, 6, 3, 1, 4}, {5, 4, 1, 2, 3, 6, 
  5}, {5, 4, 1, 2, 5}, {5, 4, 6, 5}, {5, 4, 6, 3, 1, 2, 5}, {5, 2, 3, 

  1, 4, 6, 5}, {5, 2, 3, 6, 5}, {5, 2, 5}, {6, 5, 4, 1, 2, 3, 6}, {6, 
  5, 4, 6}, {6, 5, 2, 3, 1, 4, 6}, {6, 5, 2, 3, 6}, {6, 3, 1, 2, 5, 4,
   6}, {6, 3, 1, 4, 6}, {6, 3, 6}}

To remove the duplicate cycles from this output one can use:


DeleteDuplicates[RotateLeft[#, Ordering[#, 1] - 1] & /@ Most /@ #]&


{{1, 2, 3}, {1, 2, 3, 6, 5, 4}, {1, 2, 5, 4}, {1, 2, 5, 4, 6, 3}, {1, 4},
 {1, 4, 6, 5, 2, 3}, {1, 4, 6, 3}, {2, 3, 6, 5}, {2, 5}, {3, 6}, {4, 6, 5}}


Here is an alternative approach to remove the duplicates on-the-fly with a form of memoization. It seems it may be more or less efficient depending on the graph; I have not tested it well yet.


cycles2[el_] :=
 Module[{f, edges = Rule @@@ el // Dispatch},
  f[x_, b___, x_] := (
    (f[##] = {}) & @@@ NestList[RotateLeft, {x, b}, Length@{x, b} - 1];
    {{x, b}}
   );
  f[c__] /; Signature@{c} === 0 = {};
  f[c___, v_] := Join @@ (f[c, v, #] & /@ ReplaceList[v, edges]);

  Join @@ f /@ Union @@ el
  ]

cycles2[el]


{{1, 2, 3}, {1, 2, 3, 6, 5, 4}, {1, 2, 5, 4}, {1, 2, 5, 4, 6, 3}, {1, 4},
 {1, 4, 6, 5, 2, 3}, {1, 4, 6, 3}, {2, 3, 6, 5}, {2, 5}, {3, 6}, {4, 6, 5}}

Comments

Post a Comment

Popular posts from this blog

plotting - How to draw lines between specified dots on ListPlot?

I would like to create a plot where I have unconnected dots and some connected. So far, I have figured out how to draw the dots. My code is the following: ListPlot[{{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4,13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full] I have thought using ListLinePlot command, but I don't know how to specify to the command to draw only selected lines between the dots. Do have any suggestions/hints on how to do that? Thank you. Answer One possibility would be to use Epilog with Line : ListPlot[ {{1, 1}, {2, 2}, {3, 3}, {4, 4}, {1, 4}, {2, 5}, {3, 6}, {4, 7}, {1, 7}, {2, 8}, {3, 9}, {4, 10}, {1, 10}, {2, 11}, {3, 12}, {4, 13}, {2.5, 7}}, Ticks -> {{1, 2, 3, 4}, None}, AxesStyle -> Thin, TicksStyle -> Directive[Black, Bold, 12], Mesh -> Full, Epilog -> { Line[ ...
Post a Comment
Read more

dynamic - How can I make a clickable ArrayPlot that returns input?

I would like to create a dynamic ArrayPlot so that the rectangles, when clicked, provide the input. Can I use ArrayPlot for this? Or is there something else I should have to use? Answer ArrayPlot is much more than just a simple array like Grid : it represents a ranged 2D dataset, and its visualization can be finetuned by options like DataReversed and DataRange . These features make it quite complicated to reproduce the same layout and order with Grid . Here I offer AnnotatedArrayPlot which comes in handy when your dataset is more than just a flat 2D array. The dynamic interface allows highlighting individual cells and possibly interacting with them. AnnotatedArrayPlot works the same way as ArrayPlot and accepts the same options plus Enabled , HighlightCoordinates , HighlightStyle and HighlightElementFunction . data = {{Missing["HasSomeMoreData"], GrayLevel[ 1], {RGBColor[0, 1, 1], RGBColor[0, 0, 1], GrayLevel[1]}, RGBColor[0, 1, 0]}, {GrayLevel[0], GrayLevel...
Post a Comment
Read more

equation solving - Invert and fit implicitly defined curve

I need to fit an implicitly defined curve. I thought I could get some data out of Solve , and then using FindFit . Therefore, I would like to find the relation the parametric curve defined by $F(x,y)=0$: Solve[-(1/2) + 1/2 (0.41202 BesselK[0, 0.1 Sqrt[x^2 + y^2]] + (0.101483 x BesselK[1, 0.1 Sqrt[x^2 + y^2]])/Sqrt[x^2 + y^2]) == 0, y] But I can't get an output: Solve was unable to solve the system with inexact coefficients or the system obtained by direct rationalization of inexact numbers present in the system. Since many of the methods used by Solve require exact input, providing Solve with an exact version of the system may help. >> Edit: In particular, I would like to fit the data coming from the curve with the expression of another curve, and not with a function $f(x)$. In particular, since this clearly looks like a cardioid , I would like it to fit to something like it. What other strategies could I try?
Post a Comment
Read more