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