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