Mathematica 9 is now available
Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
1999
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*December
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 1999

[Date Index] [Thread Index] [Author Index]

Search the Archive

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



  • Prev by Date: Re: About stochastic differential equations
  • Next by Date: Help: Outer of a list of lists
  • Previous by thread: Re: Langford's Problem
  • Next by thread: Results Scaling