Services & ResourcesWolfram ForumsMathGroup Archive

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

Re: Langford's Problem (yet another improvement!)

• To: mathgroup at smc.vnet.net
• Subject: [mg19669] Re: [mg19644] Langford's Problem (yet another improvement!)
• From: "Wolf, Hartmut" <hwolf at debis.com>
• Date: Thu, 9 Sep 1999 02:19:44 -0400
• Organization: debis Systemhaus
• References: <7qv31d$34c$1@dragonfly.wolfram.com> <199909070428.AAA06911@smc.vnet.net.>
• Sender: owner-wri-mathgroup at wolfram.com

Allan Hayes schrieb:
> 
> I came up with the following solution using ReplaceList.
> The method seems fairly general - certainly, little thought was needed once
> the idea of using ReplaceList occurred to me.
> 
> Langford[n_] :=
> Module[{sol = {Table[0, {2n}]}},
>     Do[sol =
>         Join @@
>           Map[
>                ReplaceList[#1, {x___, 0, y__ /; Length[{y}] === k, 0, z___}
> :> {x, k, y, k, z}] &,
>                sol
>            ],
>       {k, n,  1, -1}]
>     ; sol
> ]
> 
------<snipped>-----

> Some refinements are possible;
> 
------<snipped>-----
> 
> 3) we could use Fold instead of Do
> 

Dear Allan,

I am very fond of your way of writing down the core algorithm in
_Mathematica_, and I was also searching for something like that. However
I couldn't find the expression for the matching pattern, namely

   {x___, 0, y__ /; Length[{y}] === k, 0, z___}

That marvellous condition in the middle! (My prior success with the
pattern in my brute force solution had let me into false tracks and I
couldn't manage to give my pattern a name.)

Deplorably your solution doesn't perform as well as Fred Simons'
procedural solution (with my improvements). 

    *But this has changed now!*

I felt that sequential patten matching on the linear structure should be
better than doing the Do. But where is the imperformance hidden? It
certainly is that
'marvellous' y__/;Length[{y}], where amoungst many possible matches only
one is good. So I tried again with my ansatz: the solution is, not to
build up the pattern but the replacement rule!

Because it's so pretty I'll show you nearly all of my notebook

Here is your version rewritten with Fold:

In[1]:= LangfordStep[partialSolution_, k_] :=
  Flatten[
    Map[(ReplaceList[#, {x___, 0, y__ /; Length[{y}] === k, 0, z___} :>
{x, k,
                 y, k, z}] &), partialSolution], 1]

In[2]:= Langford[n_] :=
  Fold[LangfordStep, {Table[0, {2n}]},
    Reverse[Range[n]]  ]

In[4]:= Length[Langford[7]] // Timing
Out[4]= {5.748 Second, 52}
In[5]:= Length[Langford[8]] // Timing
Out[5]= {38.325 Second, 300}

In[6]:= Remove[Langford, LangfordStep]
________________________________________

Now to find the improved replacement rule:

In[7]:= makeBlankSeqN[1] := Module[{y}, {{y_}, {y}}]
In[8]:= makeBlankSeqN[n_] := 
  Module[{y},{Append[#[[1]], y_],Append[#[[2]], y]}&@ makeBlankSeqN[n -
1]]

In[11]:= ruleClamp[n_] := 
  RuleDelayed @@ {{x___,0,Sequence @@ #[[1]],0,z___}, 
                  {x, n,Sequence @@ #[[2]], n, z}}&@ makeBlankSeqN[n]

In[12]:= ruleClamp[4]
Out[12]= {x___,0,y$12_,y$11_,y$10_,y$9_,0,z___} :>
{x,4,y$12,y$11,y$10,y$9,4,z}


In[13]:= LangfordStep[partialSolution_, k_] := (ruleClamp[k] =
ruleClamp[k];
    Flatten[Map[ReplaceList[#, ruleClamp[k]] &, partialSolution], 1])

In[14]:= Langford[n_] :=
  Fold[LangfordStep, {Table[0, {2n}]}, Reverse[Range[n]]  ]

In[16]:= Length[Langford[7]] // Timing
Out[16]= {0.611 Second, 52}
In[17]:= Length[Langford[8]] // Timing
Out[17]= {3.515 Second, 300}


And now if you add my improvements to Fred's Solution (including his
idea to compute only one of the solution pairs each) then you get

In[10]:= Length[Langford[7]] // Timing
Out[10]= {0.31 Second, 26}
In[21]:= Length[Langford[8]] // Timing
Out[21]= {1.682 Second, 150}

In[22]:= Length[Langford[11]] // Timing
Out[22]= {566.955 Second, 17792}

Is it possible to further improve? I think so! But then do it at the
very core of the algorithm. Every LangfordStep generates solutions and
deletes some. If you can manage to recognize false tracks and delete
*early*, you'll improve. If you look at the results, you'll see that
certain patterns don't show up there. So the question is, how to get at
those rules and *prove* them. That's the mathematical side of the
problem, after the _Mathematica_ side has been settled (or -- hopefully!
-- not?)


With kind regards,
	Hartmut Wolf

• References:
  • Re: Re: Langford's Problem (another solution improved)
    • From: "Allan Hayes" <hay@haystack.demon.co.uk>