A Recreational Endeavour To: mathgroup at smc.vnet.net Subject: [mg8692] A Recreational Endeavour From: Hans Havermann Date: Fri, 19 Sep 1997 02:47:36 -0400 Sender: owner-wri-mathgroup at wolfram.com 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[1]= {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. Re: A Recreational Endeavour To: mathgroup at smc.vnet.net Subject: [mg8751] Re: [mg8692] A Recreational Endeavour From: "w.meeussen" 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. Dr. Wouter L. J. MEEUSSEN wm.vdmcc at pophost.eunet.be w.meeussen.vdmcc at vandemoortele.be Re: A Recreational Endeavour To: mathgroup at smc.vnet.net Subject: [mg8762] Re: [mg8751] A Recreational Endeavour From: Hans Havermann Date: Sun, 21 Sep 1997 20:51:06 -0400 Sender: owner-wri-mathgroup at wolfram.com Dr. Wouter L.J. Meeussen writes: >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. Thank you for all this. It will take me a little time to go through it. The algorithm is perhaps a little more understandable from the perspective of its origin... Row01: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ... Row02: 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 ... Row03: 4 2 5 6 7 8 9 10 11 12 13 14 15 16 17 ... Row04: 6 2 7 4 8 9 10 11 12 13 14 15 16 17 18 ... Row05: 8 7 9 2 10 6 11 12 13 14 15 16 17 18 19 ... Row06: 6 2 11 9 12 7 13 8 14 15 16 17 18 19 20 ... Row07: 13 12 8 9 14 11 15 2 16 6 17 18 19 20 21 ... Row08: 2 11 16 14 6 9 17 8 18 12 19 13 20 21 22 ... Row09: 18 17 12 9 19 6 13 14 20 16 21 11 22 2 23 ... Row10: 16 14 21 13 11 6 22 19 2 9 23 12 24 17 25 ... To generate Row'n+1' from Row'n': expel the n-th number (it is these expelled "diagonal" numbers that comprise my sought-after set); *rewrite* beginning with the first number to the right of the dropped number followed by the first number to the left (if any); then the second number to the right of the dropped number followed by the second number to the left (if any); and so on. The idea was proposed by Clark Kimberling as problem #1615 in the Canadian "Crux Mathematicorum" in 1991. He asks: (a) Is 2 eventually expelled? (b) Is every positive integer eventually expelled? In the March 1992 issue of Crux (Vol.18, #3), a solution to part (a) is given by Iliya Bluskov, who developed an algorithm for the general case and applies it for all n < 51. He notes that '19' is expelled in Row 49595. The editor of Crux comments on the general case, citing Richard and Andy Guy as having done work on it. Specifically, they had shown "that every integer up to 1200 is eventually expelled" with, for instance, '669' being expelled in Row 653494691. Richard also found several infinite "families" of expelled integers. *My* interest in all this: Having calculated a 4491 element set for x, we notice: Do[If[x[[i]]==i,Print[i]],{i,1,Length[x]}] 1 4 8 14 171 This immediately suggests: Do[If[x[[i]]<=Length[x],If[x[[i]]!=i,If[x[[x[[i]]]]==i,Print[i]]]],{i,1, Length[x]}] 813 985 In other words x[[813]]=985 and x[[985]]=813. So now I'm thinking: what other "loops" like this can we discover? My guess: not many (without some serious computing power). Some years ago, in Basic, I had calculated quite a few terms of the "loop" in which '2' finds itself [... 1523, 43, 25, 2, 3, 5, 10, 9, 20, ... ]. It is possible *algorithmically* to go forward (or backward) along this loop finding the next (or previous) term. I love the *asymmetry* of this sequence: Going forward, the next number is always guaranteed, never more than three times as large. Going backwards, who knows? There may not even be a previous number! We think we can understand why the numbers must get bigger (on average) as we move forward, *but* we must remind ourselves that we have gotten to '2' from some very large "ancestor" in the same process of moving forward! :-) I lost all my primary data on this a couple of years ago in a hard-drive crash. :-( Hans Havermann Rarebit Dreams