Skip to main content
replaced http://mathematica.stackexchange.com/ with https://mathematica.stackexchange.com/
Source Link

Mostly I cribbed this from herehere. I simply changed the line that converts input to the particular sparse representation used by the main part of the code.

Mostly I cribbed this from here. I simply changed the line that converts input to the particular sparse representation used by the main part of the code.

Mostly I cribbed this from here. I simply changed the line that converts input to the particular sparse representation used by the main part of the code.

Source Link
Daniel Lichtblau
  • 60.3k
  • 2
  • 105
  • 201

Mostly I cribbed this from here. I simply changed the line that converts input to the particular sparse representation used by the main part of the code.

Important caveat: I do not know for a fact that this code is correct for the directed case.

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

cycles[mat_, k_] := Module[{n = Length[mat], m2, cyc, cyclist},
  m2 = Map[Last, Split[Sort[mat], First[#1] == First[#2] &], {2}] ;
  cyclist = 
   Flatten[Drop[MapIndexed[{#2[[1]], #1} &, m2, {2}], -k + 1], 1];
  Do[cyclist = 
    Flatten[Map[extendCycle[#, m2] &, cyclist], 1], {k - 2}];
  Map[If[MemberQ[m2[[Last[#]]], First[#]], Append[#, First[#]], 
     Null /. Null :> Sequence[]] &, cyclist]]

Your simpler example:

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

Timing[
 Table[cycles[el, j], {j, 2, Length[Union[Flatten[el]]]}] /. {} :> 
   Sequence[]]

(* Out[436]= {0., {{{1, 4, 1}, {2, 5, 2}, {3, 6, 3}, {4, 1, 4}, {5, 2, 
    5}}, {{1, 2, 3, 1}, {4, 6, 5, 4}}, {{1, 2, 5, 4, 1}, {1, 4, 6, 3, 
    1}, {2, 3, 6, 5, 2}, {3, 1, 4, 6, 3}}, {{1, 2, 3, 6, 5, 4, 1}, {1,
     2, 5, 4, 6, 3, 1}, {1, 4, 6, 5, 2, 3, 1}}}} *)

Your bigger case:

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

Timing[
 cycs2 = Table[
     cycles[el2, j], {j, 2, Length[Union[Flatten[el2]]]}] /. {} :> 
     Sequence[];]

(* Out[439]= {0.340000, Null} *)

Now check sizes.

Length[cycs2]

(* Out[440]= 10 *)

Length[Flatten[cycs2, 1]]

(* Out[443]= 199 *)

Upshot: Not too bad in performance, if it happens to be correct.