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: Re: Numbers problem

  • To: mathgroup at smc.vnet.net
  • Subject: [mg19586] Re: [mg19524] Re: [mg19520] Numbers problem
  • From: "Andrzej Kozlowski" <andrzej at tuins.ac.jp>
  • Date: Sat, 4 Sep 1999 01:34:24 -0400
  • Sender: owner-wri-mathgroup at wolfram.com

Thanks Allan. It's indeed an elegant and worthwhile improvement. I did not
realize that the Combinatorica packge has not been updated since v. 1.2 : it
is remarkable that it still is working so well. (Since backtracking is such
a useful and important technique I think Backtrack ought to be optimized and
compiled as a built in fuction).

Your new Backtrack is certainly fast and elegant. I will try to use it as a
replacement for the original Bactrack in Combinatoorica: it should speed up
some other functions which depend on it and seems very unlikely to break
anything. Still, I must admit that elegant  "high level" Mathematica
functions have one draw-back: it seems to me that the original program, in
spite of being longer, is rather easier to understand.

Andrzej

--
Andrzej Kozlowski
Toyama International University
JAPAN
http://sigma.tuins.ac.jp
http://eri2.tuins.ac.jp


----------
>From: "Allan Hayes" <hay at haystack.demon.co.uk>
To: mathgroup at smc.vnet.net
>To: "Andrzej Kozlowski" <andrzej at tuins.ac.jp>
>Subject: [mg19586] Re: [mg19524] Re: [mg19520] Numbers problem
>Date: Thu, Sep 2, 1999, 12:42 AM
>

> 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: [mg19586] [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: [mg19586] [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.
>> >>
>> >>
>> >>
>> >>
>> >>
>> >>
>> >
>> >
>>
>
> 


  • Prev by Date: Re: Re: Numbers problem
  • Next by Date: Re: Langford's Problem
  • Previous by thread: Re: Re: Numbers problem
  • Next by thread: Re: Re: Numbers problem