Re: Langford's Problem (yet another improvement!)
- To: mathgroup at smc.vnet.net
- Subject: [mg19717] Re: [mg19644] Langford's Problem (yet another improvement!)
- From: "Allan Hayes" <hay at haystack.demon.co.uk>
- Date: Mon, 13 Sep 1999 02:40:53 -0400
- References: <7qv31d$34c$1@dragonfly.wolfram.com> <199909070428.AAA06911@smc.vnet.net.> <7r7jd9$cgf@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
Dear Hartmut,
Your idea of using , for example
{x___,0,y$1_,y$2_,y$3_,y$4_,0,z___} :>
{x,4,y$1,y$2,y$3,y$4,4,z}
instead of
{x___, 0, y__ /; Length[{y}] === 4, 0, z___}
:> {x, 4, y, 4, z}]
is an excellent example of efficient use of pattern matching
Rule: use simple tests and conditions - avoid them completely if possible
in favour of pattern "shapes".
I give a slight modification, amongst other changes I use Unique instead of
Module - there is very little difference in the timing.
Clear["`*"]
makeBlankSeqN[n_] :=
Transpose[Table[{Pattern[#, Blank[]], #} &[Unique[y]], {n}]]
ruleClamp[n_] :=
(ruleClamp[n] = {x___, 0, Sequence @@ #[[1]], 0, z___} -> {x, n,
Sequence @@ #[[2]], n, z} &@makeBlankSeqN[n])
Langford[n_] :=
Fold[With[{rl=ruleClamp[#2]}, Join @@
Map[
ReplaceList[#1,rl]&,#1]] & , {Table[0, {2n}]},
Reverse[Range[n]]]
Length[Langford[7]] // Timing
Length[Langford[8]] // Timing
Length[Langford[9]] // Timing
Length[Langford[10]] // Timing
{0.82 Second, 52}
{4.5 Second, 300}
{29.82 Second, 0}
{221.3 Second, 0}
The times for your original, without special start to take advantage of the
symmety (copied after the times), were
Length[Langford[7]] // Timing
Length[Langford[8]] // Timing
Length[Langford[9]] // Timing
Length[Langford[10]] // Timing
{0.76 Second, 52}
{5.66 Second, 300}
{31.52 Second, 0}
{222.62 Second, 0}
Clear["`*"]
makeBlankSeqN[1] := Module[{y}, {{y_}, {y}}]
makeBlankSeqN[n_] :=
Module[{y}, {Append[#[[1]], y_], Append[#[[2]], y]} &@makeBlankSeqN[n -
1]]
ruleClamp[n_] :=
RuleDelayed @@ {{x___, 0, Sequence @@ #[[1]], 0, z___}, {x, n,
Sequence @@ #[[2]], n, z}} &@makeBlankSeqN[n]
LangfordStep[partialSolution_, k_] := (ruleClamp[k] = ruleClamp[k];
Flatten[Map[ReplaceList[#, ruleClamp[k]] &, partialSolution], 1])
Langford[n_] := Fold[LangfordStep, {Table[0, {2n}]}, Reverse[Range[n]]]
Thanks for finding the error in my suggested improvement 2).
Allan
---------------------
Allan Hayes
Mathematica Training and Consulting
Leicester UK
www.haystack.demon.co.uk
hay at haystack.demon.co.uk
Voice: +44 (0)116 271 4198
Fax: +44 (0)870 164 0565
Wolf, Hartmut <hwolf at debis.com> wrote in message
news:7r7jd9$cgf at smc.vnet.net...
> 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
>
>
- Follow-Ups:
- Re: Re: Langford's Problem (yet another improvement!)
- From: "Carl K.Woll" <carlw@fermi.phys.washington.edu>
- Re: Re: Langford's Problem (yet another improvement!)
- References:
- Re: Re: Langford's Problem (another solution improved)
- From: "Allan Hayes" <hay@haystack.demon.co.uk>
- Re: Re: Langford's Problem (another solution improved)