Re: Re: Langford's Problem (yet another improvement!)
- To: mathgroup at smc.vnet.net
- Subject: [mg19753] Re: [mg19717] Re: [mg19644] Langford's Problem (yet another improvement!)
- From: "Carl K.Woll" <carlw at fermi.phys.washington.edu>
- Date: Wed, 15 Sep 1999 03:53:04 -0400
- Organization: Department of Physics
- References: <7qv31d$34c$1@dragonfly.wolfram.com> <199909070428.AAA06911@smc.vnet.net.> <7r7jd9$cgf@smc.vnet.net> <199909130640.CAA08817@smc.vnet.net.>
- Sender: owner-wri-mathgroup at wolfram.com
Hi all,
I expect people are getting tired of seeing this thread, but I have another
algorithm to propose, which on my computer is ~20 times faster than Hartmut
Wolf (and Allan Hayes' version) algorithm. Before presenting this solution,
I'll give a couple comments. First, as presented, my algorithm does not find
the actual solutions, only the number of them. I suppose it may be possible to
include the actual solutions, but probably at the cost of a significant hit on
the speed (i.e., it would probably be slower than Wolf's solution). Second,
instead of using lists to represent possible solutions, I use the bits in an
integer to do so, and work with these bits using the new version 4 functions
BitAnd and BitOr. Third, I compile my functions, so that my algorithm will only
work for n=15 (maybe 16?) or less, since my computer uses 32 bit integers. Of
course, this is academic, since my computer runs out of memory when n=12.
Finally, I use a function that I created called SilentCheck, which works
exactly like Check, except that instead of spitting out the error messages and
returning the alternate failure expression, SilentCheck does not spit out any
error messages. In fact, this SilentCheck function may be useful in it's own
right for some people. I gave it the usage message
In[5]:=
?SilentCheck
SilentCheck[expr,failexpr] evaluates expr, and returns the result, unless
messages were generated, in which case it evaluates and returns failexpr.
SilentCheck suppresses the output of the messages generated in evaluating expr.
The code for my Langford algorithm follows:
In[6]:=
fc = Compile[{{x, _Integer, 1}, {y, _Integer, 1}},
Flatten at Position[Flatten@(BitAnd[#1, y] & /@ x), 0]];
pc = Compile[{{x, _Integer, 1}, {y, _Integer, 1}},
Flatten@(BitOr[#, y] & /@ x)];
LangfordStep[newclamps_, oldlist_] :=
pc[newclamps, oldlist][[fc[newclamps, oldlist]]]
In[9]:=
Langford1[n_] := Module[{clamps,pos,clamplist},
clamps = 2^(Reverse[Range[n]] + 1) + 1;
pos = Table[2^j, {i, 1, n}, {j, 0, i + n - 3}];
clamplist = clamps pos;
SilentCheck[
Fold[LangfordStep, clamplist[[1]], Rest[clamplist]],
{}]
]
Timings for Langford1 are as follows:
In[10]:=
Timing[Length[Langford1[7]]]
Timing[Length[Langford1[8]]]
Timing[Length[Langford1[9]]]
Timing[Length[Langford1[10]]]
Timing[Length[Langford1[11]]]
Out[10]=
{0.032 Second, 52}
Out[11]=
{0.125 Second, 300}
Out[12]=
{0.812 Second, 0}
Out[13]=
{5.015 Second, 0}
Out[14]=
{36.688 Second, 35584}
For comparison purposes, here are the timings using Allan Hayes version of
Wolf's algorithm
In[15]:=
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
Out[18]=
{0.391 Second, 52}
Out[19]=
{2.218 Second, 300}
Out[20]=
{14.906 Second, 0}
Out[21]=
{101. Second, 0}
Finally, for those interested in SilentCheck, here is it's definition.
ClearAll[SilentCheck]
SetAttributes[SilentCheck, {HoldAll}]
SilentCheck::usage =
"SilentCheck[expr,failexpr] evaluates expr, and returns the result, \
unless messages were generated, in which case it evaluates and returns \
failexpr. SilentCheck suppresses the output of the messages generated in \
evaluating expr.";
SilentCheck[expr_, err_] := Module[{ans, flag},
Unprotect[Message];
_Message := Throw[flag, SilentCheck];
ans = Catch[expr, SilentCheck];
Clear[Message];
Protect[Message];
If[ans === flag, err, ans]
]
Carl Woll
Physics Dept
U of Washington
Allan Hayes wrote:
> 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
> >
> >
- References:
- Re: Re: Langford's Problem (another solution improved)
- From: "Allan Hayes" <hay@haystack.demon.co.uk>
- Re: Langford's Problem (yet another improvement!)
- From: "Allan Hayes" <hay@haystack.demon.co.uk>
- Re: Re: Langford's Problem (another solution improved)