Re: Langford's Problem

*To*: mathgroup at smc.vnet.net*Subject*: [mg19594] Re: [mg19541] Langford's Problem*From*: "Wolf, Hartmut" <hwolf at debis.com>*Date*: Sat, 4 Sep 1999 01:34:28 -0400*Organization*: debis Systemhaus*References*: <D5D914247DC2D211804D0008C75B9C19135525@winex1.win.tue.nl>*Sender*: owner-wri-mathgroup at wolfram.com

Simons, F.H. schrieb: > > Some days ago the following problem was posted in this group: > > Mecit Yaman schrieb: > > > > Hi there, > > > > I am trying to solve a problem with Mathematica. You have numbers from 1 > to n all > > numbers twice , namely. > > > > 1 1 2 2 3 3 4 4 5 5 for example for n=5 > > > > I am trying to sort the numbers o that between two 'n's there must be > exactly n > > numbers. > > > > For example if n=3 the solution is > > 2 3 1 2 1 3 . You see there is 1 number between 1 and 1. and 2 numbers > between 2 > > and 2, and 3 between 3's. > > > > I know this forum is not for asking problems. > > Hartmut Wolf replied: > > > Right! So if you do, you should not camouflage you posting behind an > > answer to an obviously unrelated question! > > With respect to this, I disagree with Hartmut. Mathematica is a very > powerful tool for solving problems and most of us can profit from studying > the various solutions of a posed problem. Being a reader of this group for > many years, I regret that indeed the tendency of the questions has changed > to only technical problems with Mathematica. Some years ago indeed > mathematical questions like this one were regularly brought up and I like > this particular problem very much. Here is a solution rather different from > Hartmut's. > > The technique I use is backtracking. For a given integer n we have to fill a > list of length 2 n with the numbers 1, 1, 2, 2, ..., n, n in such a way that > the above condition holds. > > Suppose that we have an intermediate result. If all numbers have been used, > we have a solution of the problem. Otherwise, we compute the next number to > be placed in the list of length 2 n, find all positions where this number > can be put (maybe none) so that we arrive some further intermediate results > on which we can repeat the construction. > > Here is a function that performs this operation. > > f[res_] := Block[{m = Complement[Range[n], res], pos, aux}, > If[m === {}, AppendTo[result, res], > m = m[[1]]; > pos = 1; > While[ pos < 2 n - m, > aux = res; > If[ aux[[pos]] == aux[[pos + m + 1]] == 0, > aux[[pos]] = aux[[pos + m + 1]] = m; > f[aux] ]; > pos = pos + 1] > ] ] > > For any solution, the reverse is also a solution. Hence we may restrict > ourselves to solutions for which the first number 1 is at position 1, 2 , > ... (n-1). So we find all solutions for n = 5 in the following way: > > result = {}; n = 5; > (f /@ NestList[ RotateRight, Join[ {1, 0, 1}, Table[0, {2 n - 3}]], n - > 2];) // Timing > result > > In a few seconds we are sure that there are no solutions. > > On my relatively slow computer (Windows 95, 120Mhz) it took 18 seconds to > find that for n=7 we have 26 solutions, 97 seconds to find that for n=8 we > have 150 solutions, 705 sec to find that for n=9 we have no solutions and > 5458 seconds (so within lunch and desert) that also for n=10 we have no > solutions. > > Amazing that we have so many solutions for n=7 and n=8, and none for n= 5, > 6, 9, 10, and likely also 11, 12; I did not have a complete run for these > last values of n. > > Fred Simons > Eindhoven University of Technology Dear Fred, first I want to apologize. When I saw the posting which appeared twice, first I thought "not for me", when I saw it the second time ("camouflaged") I got a little bit more interested. I could easily find the solution for n=4 by hand, but not so for n=5. Then I "saw", that there can't by any direct recursive solution, so we have to do exhaustive searching, and I became suspicious that there is no solution for n=5, and I wanted to proof that, so I did it by brute force in very short time, without thinking deeply about the algorithm. After Hans Havermann's answer it became clear that we had been hoaxed! And in retrospect, a semantic analysis of the text of the posting nearly proves that, I wrote that in a letter to Andrzej, but I don't want to repeat that here. second, we share our love for _Mathematica_ third, you'r quite right, so many interesting discussion has been arisen from innocent questions. So now let me proceed along that line: Congratulations for your splendid solution. (To me the idea -- without having it coded -- came to my mind, when a woke up too early on Tuesday: before my closed eyes I saw clamps of different sizes moving, arranging in space until they fit.) Now to your coding. I happend to succeed improving it further. I did two things (1) microoptimizing your coding, that gave an improvement of about 15% (2) second I saw that it is more efficient to work downwards, since the large "clamps" truncate search space stronger. Here is my coding In[1]:= f[sofar_, m_] := Block[{pL = 0, pR = m + 1}, With[{cut = 2 n}, While[++pR <= cut, ++pL; If[ sofar\[LeftDoubleBracket]pL\[RightDoubleBracket] == sofar\[LeftDoubleBracket]pR\[RightDoubleBracket] == 1, f[ReplacePart[sofar, m, {{pL}, {pR}}], m - 1]]]]] In[2]:= f[sofar_, m_, Start] := Block[{pL = 0, pR = m + 1}, With[{cut = Floor[n/2]}, While[++pL <= cut, ++pR; If[ sofar\[LeftDoubleBracket]pL\[RightDoubleBracket] == sofar\[LeftDoubleBracket]pR\[RightDoubleBracket] == 1, If[pL == n/2, f[ReplacePart[sofar, m, {{pL}, {pR}}], m - 1, Start], f[ReplacePart[sofar, m, {{pL}, {pR}}], m - 1]]]] ]] In[3]:= f[sofar_, 1] := If[(#2 - #1 &) @@ Flatten[Position[sofar, 1]] == 2, AppendTo[result, sofar]] In[4]:= Block[{n = 4}, start = Table[1, {2 n}]; result = {}; f[start, n, Start]; result] Out[4]= {{4, 1, 3, 1, 2, 4, 3, 2}} In[5]:= Block[{n = 7}, start = Table[1, {2 n}]; result = {}; f[start, n, Start]; 2 Length[result]] // Timing Out[5]= {1.362 Second, 52} In[6]:= Block[{n = 8}, start = Table[1, {2 n}]; result = {}; f[start, n, Start]; 2 Length[result]] // Timing Out[6]= {8.282 Second, 300} To compare with your version (of essentially the same algorithm), here its Timing on my machine: In[2]:= result = {}; n = 7; (f /@ NestList[RotateRight, Join[{1, 0, 1}, Table[0, {2 n - 3}]], n - 2];) // Timing 2 Length[result] Out[3]= {4.476 Second, Null} Out[4]= 52 In[5]:= result = {}; n = 8; (f /@ NestList[RotateRight, Join[{1, 0, 1}, Table[0, {2 n - 3}]], n - 2];) // Timing 2 Length[result] Out[6]= {29.903 Second, Null} Out[7]= 300 So you see, time gained with action (2) is dramatic! With kind regards, your Hartmut Wolf

**Re: About stochastic differential equations**

**Help: Outer of a list of lists**

**Re: Langford's Problem**

**Results Scaling**