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. >> >> >> >> >> >> >> >> >> >> >> >> >> > >> > >> > >