Re: A Recreational Endeavour

*To*: mathgroup at smc.vnet.net*Subject*: [mg8751] Re: [mg8692] A Recreational Endeavour*From*: "w.meeussen" <meeussen.vdmcc at vandemoortele.be>*Date*: Sat, 20 Sep 1997 22:28:16 -0400*Sender*: owner-wri-mathgroup at wolfram.com

***************************************************************************** hi Hans, a few ideas: If you put both x and y in the returned answer, then you get a "real" permutation as result : containing all integers from 1 up to 4+3n, the first n from x, the rest in y. Reversing the first two integers in y can be omitted so that a different permutation results. The program has a certain charm in that it defeats (my) attempts to find a non-iterative calculation method. It is vaguely similar to Cellular Automatons. HavermannPermutation[q_]:= Module[{x={1},y={2,3,4} } , Do[ x={x,y[[n+1]]}; y= Flatten[ { Transpose[ Reverse[Partition[Delete[ y ,n+1],n] (* /.{a_List,b__}:>{Reverse[a],b} *) ] ], {3*n+2,3*n+3,3*n+4} } ], {n,1,q}]; (* Do *) Flatten[{x,y}] ] This function performs one step only, and can be iterated using Nest[havermann,{1,2,3,4},n] : havermann[li_List]:= Module[{len=Length[li],n}, n=(len-1)/3; Flatten[ { Take[li,n],li[[2n+1]], Transpose[ { Take[li,-n] , Take[li,{n+1,2n}]//Reverse } ], {3*n+2,3*n+3,3*n+4} }] ] both are only a bit (about 1/3) faster than your code, and memory requirements are the same. wouter. ***************************************************************************** >I am an amateur in both Mathematica and mathematics. Consider the following >bit of (likely) very inefficient code: > >In[1]:= >x={1};y={2,3,4}; >Do[x=Append[x,y[[n+1]]]; > y=Flatten[ > Append[Transpose[ > Reverse[ReplacePart[Partition[Delete[y,n+1],n], > Reverse[First[Partition[Delete[y,n+1],n]]],1]]],{3*n+2,3*n+3, > 3*n+4}]],{n,1,100}] >x >Out[2]= >{1,3,5,4,10,7,15,8,20,9,18,24,31,14,28,22,42,35,33,46,53,6,36,23,2,55,62,59, > 76,65,54,11,34,48,70,79,99,95,44,97,58,84,25,13,122,83,26,115,82,91,52,138, > 67,90,71,119,64,37,81,39,169,88,108,141,38,16,146,41,21,175,158,165,86,191, > 45,198,216,166,124,128,204,160,12,232,126,208,114,161,156,151,249,236,263, > 243,101,121,72,120,47,229,178} > >The resulting set is a permutation of the positive Integers, with the >caveat that it is not known (and, perhaps, not knowable) if *every* number >eventually appears. > >I would like to generate x for values much greater than 100. Using >Mathematica 3.0 on a Macintosh with some 50 MB assigned to the MathKernel, >I can generate x with a Length of about 4400 before running out of memory. >If there is some way to squeeze more data points out of my existing code, I >would be pleased to hear of it. > >-- >Nature requires five, >Custom allows seven, >Idleness takes nine, >And wickedness eleven. > > >In[1]:= >x={1};y={2,3,4}; >Do[x=Append[x,y[[n+1]]]; > y=Flatten[ > Append[Transpose[ > Reverse[ReplacePart[Partition[Delete[y,n+1],n], > Reverse[First[Partition[Delete[y,n+1],n]]],1]]],{3*n+2,3*n+3, > 3*n+4}]],{n,1,100}] >x >Out[3]= >{1, 3, 5, 4, 10, 7, 15, 8, 20, 9, 18, 24, 31, 14, 28, 22, > > 42, 35, 33, 46, 53, 6, 36, 23, 2, 55, 62, 59, 76, 65, 54, > > 11, 34, 48, 70, 79, 99, 95, 44, 97, 58, 84, 25, 13, 122, > > 83, 26, 115, 82, 91, 52, 138, 67, 90, 71, 119, 64, 37, > > 81, 39, 169, 88, 108, 141, 38, 16, 146, 41, 21, 175, 158, > > 165, 86, 191, 45, 198, 216, 166, 124, 128, 204, 160, 12, > > 232, 126, 208, 114, 161, 156, 151, 249, 236, 263, 243, > > 101, 121, 72, 120, 47, 229, 178} >In[104]:= >x={1};y={2,3,4}; >Do[Print[x,y];x=Append[x,y[[n+1]]]; >Print[x]; > y=Flatten[ > Append[ > Transpose[ > Reverse[ > ReplacePart[ > pa= Partition[ > Delete[ y ,n+1], > n], (* Partition *) > Reverse[ > First[ pa > (* Partition[ > Delete[y,n+1], > n] *) > ] > ], (* Reverse *) > 1] > ] > ], (* Transpose[ ... , 1] *) > {3*n+2,3*n+3,3*n+4}] > ], > {n,1,3}]; (* Do *) >x >>From In[104]:= >{1}{2, 3, 4} >{1, 3} >{1, 3}{4, 2, 5, 6, 7} >{1, 3, 5} >{1, 3, 5}{6, 2, 7, 4, 8, 9, 10} >{1, 3, 5, 4} >Out[106]= >{1, 3, 5, 4} >In[110]:= >x={1};y={2,3,4};Clear[w,z]; >Do[Print[x," | ",y," | ",z," | ",w]; >x={x,y[[n+1]]}; > > y=Flatten[w= > { > Transpose[ > z= Reverse[Partition[Delete[ y ,n+1],n] > /.{a_List,b__}:>{Reverse[a],b} > ] > ], > {3*n+2,3*n+3,3*n+4} > } > ], > {n,1,5}]; (* Do *) >x >>From In[110]:= >{1} | {2, 3, 4} | z | w >{{1}, 3} | {4, 2, 5, 6, 7} | {{4}, {2}} | {{{4, 2}}, {5, 6, 7}} >{{{1}, 3}, 5} | {6, 2, 7, 4, 8, 9, 10} | {{6, 7}, {2, 4}} | {{{6, 2}, {7, 4}}, > {8, 9, 10}} >{{{{1}, 3}, 5}, 4} | {8, 7, 9, 2, 10, 6, 11, 12, 13} | {{8, 9, 10}, {7, 2, 6}} > | {{{8, 7}, {9, 2}, {10, 6}}, {11, 12, 13}} >{{{{{1}, 3}, 5}, 4}, 10} | {6, 2, 11, 9, 12, 7, 13, 8, 14, 15, 16} | {{6, 11, >12, 13}, {2, 9, 7, 8}} | > > {{{6, 2}, {11, 9}, {12, 7}, {13, 8}}, {14, 15, 16}} >Out[112]= >{{{{{{1}, 3}, 5}, 4}, 10}, 7} >In[113]:= >y >Out[113]= >{13, 12, 8, 9, 14, 11, 15, 2, 16, 6, 17, 18, 19} >In[165]:= >x={1};y={2,3,4};Clear[w,z]; >Do[ > (* Print[x," | ",y," | ",z," | ",w]; *) >x={x,y[[n+1]]}; > > y=Flatten[w= > { > Transpose[ > z= Reverse[Partition[Delete[ y ,n+1],n] > (* /.{a_List,b__}:>{Reverse[a],b} *) > ] > ], > {3*n+2,3*n+3,3*n+4} > } > ], > {n,1,10}]; (* Do *) >Flatten[{x,y}] >Out[167]= >{1, 3, 5, 2, 10, 9, 15, 8, 20, 19, 7, 14, 23, 26, 12, 22, 16, 27, 18, 13, 24, >28, 21, 17, 11, 29, 6, 30, 25, 31, 4, 32, 33, 34} >In[168]:= >y >Out[168]= >{14, 23, 26, 12, 22, 16, 27, 18, 13, 24, 28, 21, 17, 11, 29, 6, 30, 25, 31, 4, > 32, 33, 34} >In[178]:= >HavermannPermutationA[q_]:= >Module[{x={1},y={2,3,4} } , >Do[ > >x={x,y[[n+1]]}; > > y= Flatten[ > { > Transpose[ > Reverse[Partition[Delete[ y ,n+1],n] > (* /.{a_List,b__}:>{Reverse[a],b} *) > ] > ], > {3*n+2,3*n+3,3*n+4} > } > ], > {n,1,q}]; (* Do *) >Flatten[{x,y}] >] >In[181]:= >Table[HavermannPermutationA[i],{i,16}]//ColumnForm >Out[181]= >{1, 3, 4, 2, 5, 6, 7} >{1, 3, 5, 6, 4, 7, 2, 8, 9, 10} >{1, 3, 5, 2, 8, 6, 9, 4, 10, 7, 11, 12, 13} >{1, 3, 5, 2, 10, 7, 8, 11, 6, 12, 9, 13, 4, 14, 15, 16} >{1, 3, 5, 2, 10, 9, 13, 7, 4, 8, 14, 11, 15, 6, 16, 12, 17, 18, 19} >{1, 3, 5, 2, 10, 9, 15, 6, 13, 16, 7, 12, 4, 17, 8, 18, 14, 19, 11, 20, 21, >22} >{1, 3, 5, 2, 10, 9, 15, 8, 18, 6, 14, 13, 19, 16, 11, 7, 20, 12, 21, 4, 22, >17, 23, 24, 25} >{1, 3, 5, 2, 10, 9, 15, 8, 20, 12, 18, 21, 6, 4, 14, 22, 13, 17, 19, 23, 16, >24, 11, 25, 7, 26, 27, 28} >{1, 3, 5, 2, 10, 9, 15, 8, 20, 19, 23, 12, 16, 18, 24, 21, 11, 6, 25, 4, 7, >14, 26, 22, 27, 13, 28, 17, 29, 30, 31} >{1, 3, 5, 2, 10, 9, 15, 8, 20, 19, 7, 14, 23, 26, 12, 22, 16, 27, 18, 13, 24, >28, 21, 17, 11, 29, 6, 30, 25, 31, 4, 32, 33, 34} >{1, 3, 5, 2, 10, 9, 15, 8, 20, 19, 7, 21, 17, 14, 11, 23, 29, 26, 6, 12, 30, >22, 25, 16, 31, 27, 4, 18, 32, 13, 33, 24, 34, 28, 35, > > 36, 37} >{1, 3, 5, 2, 10, 9, 15, 8, 20, 19, 7, 21, 31, 27, 17, 4, 14, 18, 11, 32, 23, >13, 29, 33, 26, 24, 6, 34, 12, 28, 30, 35, 22, 36, 25, > > 37, 16, 38, 39, 40} >{1, 3, 5, 2, 10, 9, 15, 8, 20, 19, 7, 21, 31, 6, 34, 27, 12, 17, 28, 4, 30, >14, 35, 18, 22, 11, 36, 32, 25, 23, 37, 13, 16, 29, 38, > > 33, 39, 26, 40, 24, 41, 42, 43} >{1, 3, 5, 2, 10, 9, 15, 8, 20, 19, 7, 21, 31, 6, 25, 23, 34, 37, 27, 13, 12, >16, 17, 29, 28, 38, 4, 33, 30, 39, 14, 26, 35, 40, 18, > > 24, 22, 41, 11, 42, 36, 43, 32, 44, 45, 46} >{1, 3, 5, 2, 10, 9, 15, 8, 20, 19, 7, 21, 31, 6, 25, 14, 26, 23, 35, 34, 40, >37, 18, 27, 24, 13, 22, 12, 41, 16, 11, 17, 42, 29, > > 36, 28, 43, 38, 32, 4, 44, 33, 45, 30, 46, 39, 47, 48, 49} >{1, 3, 5, 2, 10, 9, 15, 8, 20, 19, 7, 21, 31, 6, 25, 14, 42, 29, 26, 36, 23, >28, 35, 43, 34, 38, 40, 32, 37, 4, 18, 44, 27, 33, 24, > > 45, 13, 30, 22, 46, 12, 39, 41, 47, 16, 48, 11, 49, 17, 50, 51, 52} >In[159]:= >Clear[n,HavermannPermutationA] > >NV Vandemoortele Coordination Center >Oils & Fats Applied Research >Prins Albertlaan 79 >Postbus 40 >B-8870 Izegem (Belgium) >Tel: +/32/51/33 21 11 >Fax: +/32/51/33 21 75 >vdmcc at vandemoortele.be > > Dr. Wouter L. J. MEEUSSEN wm.vdmcc at pophost.eunet.be w.meeussen.vdmcc at vandemoortele.be