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

**strict inequalities**

**Re: SymbolShape**

**Re: strict inequalities**

**Re: Re: Numbers problem**