Re: Re: Numbers problem
- To: mathgroup at smc.vnet.net
- Subject: [mg19573] Re: [mg19524] Re: [mg19520] Numbers problem
- From: "Allan Hayes" <hay at haystack.demon.co.uk>
- Date: Wed, 1 Sep 1999 23:07:06 -0400
- References: <7qfn5a$aq9@smc.vnet.net>
- Sender: owner-wri-mathgroup at wolfram.com
Andrzej,
Your solution suggested that it might be worthwhile trying to speed up
Backtrack - which was written with Mathematica 1.2. Backtrack2, below, seems tro be
more than twice as fast as Backtrack.
First with DiscreteMath`Combinatorica`Backtrack
<< DiscreteMath`Combinatorica`
space[n_] := Table[Range[n], {2n}]
test[l_List, i_] := (Last[#] - First[#]) &@Flatten[Position[l, i]] - 1 == i
partialQ[l_] := (Count[l, Last[l]] <=
2 && (test[l, Last[l]] || Count[l, Last[l]] == 1))
finalQ[l_] := Apply[And, Map[test[l, #] &, Union[l]]]
problem[n_] := Backtrack[space[n], partialQ, finalQ, All]
In[339]:=
problem[4] // Timing
{1.65 Second, {{2, 3, 4, 2, 1, 3, 1, 4}, {4, 1, 3, 1, 2, 4, 3, 2}}}
In[340]:=
problem[5] // Timing
{22.08 Second, {}}
Now with a new Backtrack
Backtrack2[space_, partialQ_, solutionQ_, number_:1] :=
Cases[
Fold[Cases[
Join @@ Outer[Append, #1, space[[#2]], 1], _?
partialQ, {1}] &, {{}}, Range[Length[space]]]
, _?solutionQ, {1}, number]
Backtrack2[ space[4], partialQ, finalQ, Infinity] // Timing
{0.66 Second, {{2, 3, 4, 2, 1, 3, 1, 4}, {4, 1, 3, 1, 2, 4, 3, 2}}}
Backtrack2[ space[5], partialQ, finalQ, Infinity] // Timing
{5.99 Second, {}}
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
Andrzej Kozlowski <andrzej at tuins.ac.jp> wrote in message
news:7qfn5a$aq9 at smc.vnet.net...
> Just after I sent my previous message I realized that there is an well
known
> algorithm which is at least superior to the stupid one I used below. It is
> known as backtracking and a function which does the main job for you is
> included in the DiscreteMath`Combinatorica` package.
>
> First we load the package.
> << DiscreteMath`Combinatorica`
>
> In[1]:=
> ?Backtrack
> "Backtrack[s, partialQ, solutionQ] performs a backtrack search of the
state
> space s, expanding a partial solution so long as partialQ is True and
> returning the first complete solution, as identified by solutionQ."
>
> What Backtrack does is basically constructs partial solutions and then
tests
> them. If they are O.K. it extends them, if not it goes back and tries
> another.
>
> Our solution space will be
>
> In[2]:=
> space[n_] := Table[Range[n], {2n}]
>
> Just as before we define the function test:
>
> In[3]:=
> test[l_List, i_] := (Last[#] - First[#]) &@Flatten[Position[l, i]] - 1 ==
i
>
> A list will be a partial solution if its last element appears in in less
> then 2 times, and it either satisifes the condition given in test or it
only
> occurs once:
>
> In[4]:=
> partialQ[l_] := (Count[l, Last[l]] <=
> 2 && (test[l, Last[l]] || Count[l, Last[l]] == 1))
>
> Thus
>
> In[5]:=
> partialQ[{2, 3, 1, 2}]
>
> Out[5]=
> True
>
> but
>
> In[6]:=
> partialQ[{2, 3, 1, 3}]
> Out[6]=
> False
>
> The test for a final solution is as before:
>
> In[7]:=
> finalQ[l_] := Apply[And, Map[test[l, #] &, Union[l]]]
>
> Now we can look for our solutions:
>
> In[8]:=
> problem[n_] := Backtrack[space[n], partialQ, finalQ, All]
>
> In[9]:=
> problem[3]
> Out[9]=
> {{2, 3, 1, 2, 1, 3}, {3, 1, 2, 1, 3, 2}}
>
> In[10]:=
> problem[4]
> Out[10]=
> {{2, 3, 4, 2, 1, 3, 1, 4}, {4, 1, 3, 1, 2, 4, 3, 2}}
>
> In[11]:=
> problem[5]
> Out[11]=
> {}
>
> In[12]:=
> problem[6]
> Out[12]=
> {}
>
> There is a surprisingly large number of solutions in the case n=7
>
> In[13]:=
> problem[7]
>
> Out[13]=
> {{1, 4, 1, 5, 6, 7, 4, 2, 3, 5, 2, 6, 3, 7}, {1, 4, 1, 6, 7, 3, 4, 5, 2,
3,
> 6, 2, 7, 5}, {1, 5, 1, 4, 6, 7, 3, 5, 4, 2, 3, 6, 2, 7}, {1, 5, 1, 6, 3,
7,
> 4, 5, 3, 2, 6, 4, 2, 7}, {1, 5, 1, 6, 7, 2, 4, 5, 2, 3, 6, 4, 7, 3}, {1,
5,
> 1, 7, 3, 4, 6, 5, 3, 2, 4, 7, 2, 6}, {1, 6, 1, 3, 5, 7, 4, 3, 6, 2, 5, 4,
2,
> 7}, {1, 6, 1, 7, 2, 4, 5, 2, 6, 3, 4, 7, 5, 3}, {1, 7, 1, 2, 5, 6, 2, 3,
4,
> 7, 5, 3, 6, 4}, {1, 7, 1, 2, 6, 4, 2, 5, 3, 7, 4, 6, 3, 5}, {2, 3, 6, 2,
7,
> 3, 4, 5, 1, 6, 1, 4, 7, 5}, {2, 3, 7, 2, 6, 3, 5, 1, 4, 1, 7, 6, 5, 4},
{2,
> 4, 7, 2, 3, 6, 4, 5, 3, 1, 7, 1, 6, 5}, {2, 5, 6, 2, 3, 7, 4, 5, 3, 6, 1,
4,
> 1, 7}, {2, 6, 3, 2, 5, 7, 3, 4, 6, 1, 5, 1, 4, 7}, {2, 6, 3, 2, 7, 4, 3,
5,
> 6, 1, 4, 1, 7, 5}, {2, 6, 7, 2, 1, 5, 1, 4, 6, 3, 7, 5, 4, 3}, {2, 7, 4,
2,
> 3, 5, 6, 4, 3, 7, 1, 5, 1, 6}, {3, 4, 5, 7, 3, 6, 4, 1, 5, 1, 2, 7, 6, 2},
> {3, 4, 6, 7, 3, 2, 4, 5, 2, 6, 1, 7, 1, 5}, {3, 5, 7, 2, 3, 6, 2, 5, 4, 1,
> 7, 1, 6, 4}, {3, 5, 7, 4, 3, 6, 2, 5, 4, 2, 7, 1, 6, 1}, {3, 6, 7, 1, 3,
1,
> 4, 5, 6, 2, 7, 4, 2, 5}, {3, 7, 4, 6, 3, 2, 5, 4, 2, 7, 6, 1, 5, 1}, {4,
1,
> 6, 1, 7, 4, 3, 5, 2, 6, 3, 2, 7, 5}, {4, 1, 7, 1, 6, 4, 2, 5, 3, 2, 7, 6,
3,
> 5}, {4, 5, 6, 7, 1, 4, 1, 5, 3, 6, 2, 7, 3, 2}, {4, 6, 1, 7, 1, 4, 3, 5,
6,
> 2, 3, 7, 2, 5}, {4, 6, 1, 7, 1, 4, 5, 2, 6, 3, 2, 7, 5, 3}, {4, 6, 3, 5,
7,
> 4, 3, 2, 6, 5, 2, 1, 7, 1}, {5, 1, 7, 1, 6, 2, 5, 4, 2, 3, 7, 6, 4, 3},
{5,
> 2, 4, 6, 2, 7, 5, 4, 3, 1, 6, 1, 3, 7}, {5, 2, 4, 7, 2, 6, 5, 4, 1, 3, 1,
7,
> 6, 3}, {5, 2, 6, 4, 2, 7, 5, 3, 4, 6, 1, 3, 1, 7}, {5, 2, 7, 3, 2, 6, 5,
3,
> 4, 1, 7, 1, 6, 4}, {5, 3, 6, 4, 7, 3, 5, 2, 4, 6, 2, 1, 7, 1}, {5, 3, 6,
7,
> 2, 3, 5, 2, 4, 6, 1, 7, 1, 4}, {5, 6, 1, 7, 1, 3, 5, 4, 6, 3, 2, 7, 4, 2},
> {5, 7, 1, 4, 1, 6, 5, 3, 4, 7, 2, 3, 6, 2}, {5, 7, 2, 3, 6, 2, 5, 3, 4, 7,
> 1, 6, 1, 4}, {5, 7, 2, 6, 3, 2, 5, 4, 3, 7, 6, 1, 4, 1}, {5, 7, 4, 1, 6,
1,
> 5, 4, 3, 7, 2, 6, 3, 2}, {6, 1, 5, 1, 7, 3, 4, 6, 5, 3, 2, 4, 7, 2}, {6,
2,
> 7, 4, 2, 3, 5, 6, 4, 3, 7, 1, 5, 1}, {7, 1, 3, 1, 6, 4, 3, 5, 7, 2, 4, 6,
2,
> 5}, {7, 1, 4, 1, 6, 3, 5, 4, 7, 3, 2, 6, 5, 2}, {7, 2, 4, 5, 2, 6, 3, 4,
7,
> 5, 3, 1, 6, 1}, {7, 2, 4, 6, 2, 3, 5, 4, 7, 3, 6, 1, 5, 1}, {7, 2, 6, 3,
2,
> 4, 5, 3, 7, 6, 4, 1, 5, 1}, {7, 3, 1, 6, 1, 3, 4, 5, 7, 2, 6, 4, 2, 5},
{7,
> 3, 6, 2, 5, 3, 2, 4, 7, 6, 5, 1, 4, 1}, {7, 4, 1, 5, 1, 6, 4, 3, 7, 5, 2,
3,
> 6, 2}}
>
> It took about half an hour to get this, which is about the limit of my
> patience in this case. However, I gues sth ealgorithm is still capable of
a
> few more answers.
>
>
> Andrzej Kozlowski
> Toyama International University
> JAPAN
> http://sigma.tuins.ac.jp
> http://eri2.tuins.ac.jp
>
>
> ----------
> >From: "Andrzej Kozlowski" <andrzej at tuins.ac.jp>
To: mathgroup at smc.vnet.net
> >To: mathgroup at smc.vnet.net
> >Subject: [mg19573] [mg19524] Re: [mg19520] Numbers problem
> >Date: Sun, Aug 29, 1999, 10:21 PM
> >
>
> > Problems like this one consist of two parts, a hard one and a
(realtively)
> > easy one. The hard one is finding a workable algorithm. The easy one is
> > writing a mathematica program to implement it. In your case I do not
know
> > any workable algorithm (but then I have given this matter no time at
all). I
> > know of course the obvious one: find all possible distinct permutations
of a
> > list of your type and select from it elements satisfying your condition.
> > Clearly no implementation of this algorithm will be workable for
anything
> > but small values of n. But anyway, here is a quick implementation of
this
> > essentially useless method:
> >
> > First we load the combinatorica package in order to use its
> > DistinctPermutations function:
> >
> > In[1]:=
> > << DiscreteMath`Combinatorica`
> >
> >
> > Next we define our test function.
> >
> > In[2]:=
> > test[l_List, i_] := (Last[#] - First[#]) &@Flatten[Position[l, i]] - 1
== i;
> > test[l_List] := Apply[And, Map[test[l, #] &, Union[l]]]
> >
> > Now we can find the solution of your example:
> >
> > In[3]:=
> > Select[DistinctPermutations[{1, 1, 2, 2, 3, 3}], test]
> > Out[3]=
> > {{2, 3, 1, 2, 1, 3}, {3, 1, 2, 1, 3, 2}}
> >
> > We can also get the next case:
> >
> > In[4]:=
> > Select[DistinctPermutations[{1, 1, 2, 2, 3, 3, 4, 4}], test]
> > Out[4]=
> > {{2, 3, 4, 2, 1, 3, 1, 4}, {4, 1, 3, 1, 2, 4, 3, 2}}
> >
> > Beyond that things will get very slow. I have not considered the
efficiency
> > of my implementation at all because I am pretty sure that unless you or
> > someone else can propose a better algorithm not even a Mathematica speed
> > demon like Carl Woll can make any significant difference here.
> > --
> > Andrzej Kozlowski
> > Toyama International University
> > JAPAN
> > http://sigma.tuins.ac.jp
> > http://eri2.tuins.ac.jp
> >
> >
> > ----------
> >>From: Mecit Yaman <mecit at iname.com>
To: mathgroup at smc.vnet.net
> > To: mathgroup at smc.vnet.net
> >>To: mathgroup at smc.vnet.net
> >>Subject: [mg19573] [mg19524] [mg19520] Numbers problem
> >>Date: Sun, Aug 29, 1999, 8:00 AM
> >>
> >
> >>
> >> 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. But i am
> >> learning Mathematica and
> >> wanna see how professionals solve a real problem with
> >> Mathematica.
> >>
> >> Thank you very much for giving me a chance to ask my
> >> question.
> >> Best wishes to everyone.
> >>
> >>
> >>
> >>
> >>
> >>
> >
> >
>