Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
1997
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 1997

[Date Index] [Thread Index] [Author Index]

Search the Archive

Re: programing: reduce list to cycle

  • To: mathgroup at smc.vnet.net
  • Subject: [mg8650] Re: programing: reduce list to cycle
  • From: "Xah" <xah at best.com>
  • Date: Fri, 12 Sep 1997 04:11:03 -0400
  • Organization: smtp.best.com
  • Sender: owner-wri-mathgroup at wolfram.com

This is the second summary of the problem shortest Cycle posted around
(1997/09).

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.

(*A friend:*)

Clear[shortestCycle];
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}]]];

(*Will Self wself at viking.emcmt.edu*)

Clear[repe,shortestCycleWillS];
repe[x_List,n_Integer?Positive]:=Flatten[Table[x,{n}],1];
shortestCycleWillS[x_List]:=
  Module[{m,f,temp},m=Length[x];f=(Divisors at m);
    Do[If[repe[temp=Take[x,f[[k]] ],m/(f[[k]])]==x,Return[temp]],{k,1,
        Length[f]}]];


(*Alan Hayes (hay at haystack.demon.co.uk)*)

(*a variant on the first one*)

Clear[shortestCycleAlanH];
shortestCycleAlanH[x_]:=
  If[MatchQ[Partition[x, #],{u_
..}],Throw[Take[x,#]]]&/@Divisors[Length[x]]//
    Catch

(*Wouter Meeussen <w.meeussen.vdmcc at vandemoortele.be>*)

Clear[shortestCycleWouter];
shortestCycleWouter[li_]:=
  First@(Partition[li,#]&)@Module[{i=1},While[RotateRight[li,i]=!=li,i++];i]

(*Timing comparison*)

cycList=Table[Random[Integer,{1,9}],{i,1,5}]
niceCycle=Flatten at Table[cycList,{i,1,2000}];
notCycle=Flatten[{niceCycle,a}];
Length at Flatten@niceCycle

solutions={shortestCycle,shortestCycleAlanH,shortestCycleWillS,
    shortestCycleWouter};

results=(Timing at #@niceCycle)&/@solutions;

{First at #,Equal@@Last at #}&@Transpose at results

{{0.433333 Second,0.416667 Second,0.333333 Second,0.15 Second},True}

results=(Timing at #@notCycle)&/@solutions;

{First at #,Equal@@Last at #}&@Transpose at results

{{1.83333 Second,0.35 Second,0.25 Second,285.683 Second},True}

(*Conclusion*)

Wouter's solution is the fastest by several orders if the input is a nice
cycle, otherwise it's several order slower. The overall fastest is Will's
solution. Still, we are missing a pure pattern-matching solution.

 Xah
 xah at best.com
 http://www.best.com/~xah/SpecialPlaneCurves_dir/specialPlaneCurves.html
 Mountain View, CA, USA



  • Prev by Date: Re: NSolve
  • Next by Date: Re: Re: programing: reduce list to cycle
  • Previous by thread: Re: programing: reduce list to cycle
  • Next by thread: Re: Re: programing: reduce list to cycle