Re: Re: programing: reduce list to cycle

*To*: mathgroup at smc.vnet.net*Subject*: [mg8629] Re: [mg8615] Re: programing: reduce list to cycle*From*: Allan Hayes <hay at haystack.demon.co.uk>*Date*: Fri, 12 Sep 1997 04:10:43 -0400*Sender*: owner-wri-mathgroup at wolfram.com

"Xah" <xah at best.com> in [mg8615] Re: programing: reduce list to cycle writes > This is a summary of the shortest cycle problem. > Problem: > I want to reduce a list to its shortest cycle. For example, if > myList={3,1,0,3,3,1,0,3,3,1,0,3}, then the desired result should be >{3,1,0,3}. How to do it? myList are not always complete cycles, in > such case, the whole list should be returned. He give two solutions, copied below the line *******************. Here are two variants on the first one shortestCycle2[x_]:= If[MatchQ[Partition[x, #], {u_ ..}], Throw[Take[x,#]] ]&/@ Divisors[Length[x]]//Catch This is about the same speed as the original on shorter cycles but, due to the use of Divisors is much quicker where there the cycles are long shortestCycle3[x_]:= If[Take[x,#]==Take[x,-#] && MatchQ[Partition[x, #], {u_ ..}], Throw[Take[x,#]] ]&/@ Divisors[Length[x]]//Catch The opportunistic initial quick check Take[x,#]==Take[x,-#] makes this much quicker on the test given - but this speed up cannot be guaranteed. Here are some timing (see below line ************ for details) shortestCycle2[niceCycle]//Timing {2.8434 Second,{6,3,9,5,1,5,7,4,7,5,7,9,6,9,6,2,3,6,7,3}} shortestCycle3[niceCycle]//Timing {0.23429 Second,{6,3,9,5,1,5,7,4,7,5,7,9,6,9,6,2,3,6,7,3}} shortestCycle[niceCycle]//Timing {2.70202 Second,{6,3,9,5,1,5,7,4,7,5,7,9,6,9,6,2,3,6,7,3}} minrep[niceCycle]//Timing {2.24899 Second,{6,3,9,5,1,5,7,4,7,5,7,9,6,9,6,2,3,6,7,3}} shortestCycle2[notCycle];//Timing {2.10858 Second,Null} shortestCycle3[notCycle];//Timing {1.12401 Second,Null} shortestCycle[notCycle];//Timing {10.4668 Second,Null} minrep[notCycle];//Timing {1.85865 Second,Null} Allan Hayes hay at haystack.demon.co.uk http://www.haystack.demon.co.uk/training.html voice:+44 (0)116 2714198 fax: +44 (0)116 2718642 Leicester, UK ****************************************************************** Xah's posting, continued. Solutions: (*from a friend*) shortestCycle[lis_List] := With[{l = Length[lis]}, Take[lis, Do[If[Mod[l,i]===0 && MatchQ[Partition[lis,i],{(x_)..}], Return[i]],{i,1,l}]]]; (*from Will Self wself at viking.emcmt.edu*) repe[x_List,n_Integer?Positive]:=Flatten[Table[x,{n}],1] factors[n_Integer?Positive]:= If[n==1,1, Sort[Flatten[Outer[Times, Sequence@@(Table[#[[1]]^x,{x,0,#[[2]]}]& /@ FactorInteger[n]) ]]]] minrep[x_List]:= Module[{m,f,temp}, m=Length[x];f=factors[m]; Do[If[repe[temp=Take[x,f[[k]] ],m/f[[k]]] == x, Return[temp]],{k,1,Length[f]}]] (*Speed comparison*) cycList=Table[Random[Integer,{1,9}],{i,1,20}] niceCycle=Flatten at Table[cycList,{i,1,1000}]; notCycle=Flatten[{niceCycle,a}]; Length at Flatten@niceCycle {2,9,4,4,1,4,8,6,1,3,7,9,2,9,6,4,5,9,7,5} 20000 a1=Timing at shortestCycle[niceCycle]; a2=Timing at minrep[niceCycle]; b1=Timing at shortestCycle[notCycle]; b2=Timing at minrep[notCycle]; (First/@{a1,a2}) (First/@{b1,b2}) {1.11667 Second,0.933333 Second} {3.56667 Second,0.966667 Second} Equal@(Last/@{a1,a2})&&Equal@(Last/@{b1,b2}) True ---------------- They are both based on the same principle: by testing the divisibility of the length of the list, then compare original to a created list. The former is easy to understand, the latter is faster. There should be a pure pattern matching solution. Xah xah at best.com http://www.best.com/~xah/SpecialPlaneCurves_dir/specialPlaneCurves.html Mountain View, CA, USA