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