Re: Re: List-Selection
- To: mathgroup at smc.vnet.net
- Subject: [mg20114] Re: [mg20060] Re: [mg20021] List-Selection
- From: Rob Pratt <rpratt at email.unc.edu>
- Date: Thu, 30 Sep 1999 02:43:19 -0400
- Sender: owner-wri-mathgroup at wolfram.com
We can speed things up by a factor of more than 10 (without compiling) by adding a condition to partialQ: we can't have more than 7*6 - 32 = 10 repeats at any stage if we want the final union to have all 32 elements. Explicitly, partialQ[l_] := Last[l[[-1]]] < Last[l[[-2]]] && 6 Length[l] - Length[Union[Flatten[l]]] <= 10; Rob Pratt Department of Operations Research The University of North Carolina at Chapel Hill rpratt at email.unc.edu http://www.unc.edu/~rpratt/ On Wed, 29 Sep 1999, Andrzej Kozlowski wrote: > I have succeeded in simplifying my backtracking program by remembering the > condition that no number appears twice in the same column. So now it goes > like this: > > In[7]:= > << DiscreteMath`Combinatorica` > In[8]:= > m = {{1, 2, 4, 8, 16, 32}, {2, 1, 3, 7, 15, 31}, {3, 4, 2, 6, 14, 30}, {4, > 3, 1, 5, 13, 29}, {5, 6, 8, 4, 12, 28}, {6, 5, 7, 3, 11, 27}, {7, 8, 6, 2, > 10, 26}, {8, 7, 5, 1, 9, 25}, {9, 10, 12, 16, 8, 24}, {10, 9, 11, 15, 7, > 23}, {11, 12, 10, 14, 6, 22}, {12, 11, 9, 13, 5, 21}, {13, 14, 16, 12, 4, > 20}, {14, 13, 15, 11, 3, 19}, {15, 16, 14, 10, 2, 18}, {16, 15, 13, 9, 1, > 17}, {17, 18, 20, 24, 32, 16}, {18, 17, 19, 23, 31, 15}, {19, 20, 18, 22, > 30, 14}, {20, 19, 17, 21, 29, 13}, {21, 22, 24, 20, 28, 12}, {22, 21, 23, > 19, 27, 11}, {23, 24, 22, 18, 26, 10}, {24, 23, 21, 17, 25, 9}, {25, 26, 28, > 32, 24, 8}, {26, 25, 27, 31, 23, 7}, {27, 28, 26, 30, 22, 6}, {28, 27, 25, > 29, 21, 5}, {29, 30, 32, 28, 20, 4}, {30, 29, 31, 27, 19, 3}, {31, 32, 30, > 26, 18, 2}, {32, 31, 29, 25, 17, 1}}; > > In[9]:= > space = Table[Drop[m, i], {i, 0, 6}]; > In[10]:= > partialQ[{a_}] := True > In[11]:= > partialQ[l_] := Last[l[[-1]]] < Last[l[[-2]]] > > In[12]:= > finalQ[l_] := Length[Union[Flatten[l]]] == 32 > > In[13]:= > Backtrack[space, partialQ, finalQ] // Timing > Out[16]= > {63.95 Second, {{1, 2, 4, 8, 16, 32}, {2, 1, 3, 7, 15, 31}, {3, 4, 2, 6, 14, > 30}, {12, 11, 9, 13, 5, 21}, {20, 19, 17, 21, 29, 13}, {23, 24, 22, 18, 26, > 10}, {28, 27, 25, 29, 21, 5}}} > > The program is now as simple as one might hope for. Unfortunately the > increase in speed is too slight to make much difference when trying to > compute all solutions :-( > > -- > 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 > >To: kewjoi at hixnet.co.za (Kew Joinery), mathgroup at smc.vnet.net > >Subject: [mg20114] [mg20060] Re: [mg20021] List-Selection > >Date: Sun, Sep 26, 1999, 8:57 AM > > > > > This seems to be a very computation intensive problem. One natural way to > > solv eit is using backtracking. I can give a solution which I am sure is > > not the most efficient but probably the easiest to write down. > > The "simple" way to solve such problems is to use the Backtrack function > > from the Combinatorica package. This function is unfortunately rather slow > > and Allan Hayes has written a much faster version (which doesn't really > > backtrack) in connection with the Langford problem discussed here recently. > > Unfortunately Allan'S function, although much faster, has a tendency to run > > out of memory, and particularly in this problem. So I will use the built in > > Backtrack. > > > > We first load in the Combinatorica package. > > > > In[1]:= > > << DiscreteMath`Combinatorica` > > > > I will use the matrix provided by Eugene as my example. For convenience I > > will first sort it: > > > > In[2]:= > > m = Sort[{{1, 2, 4, 8, 16, 32}, {2, 1, 3, 7, 15, 31}, {3, 4, 2, 6, 14, 30}, > > {4, 3, 1, 5, 13, 29}, {5, 6, 8, 4, 12, 28}, {6, 5, 7, 3, 11, 27}, {7, 8, 6, > > 2, 10, 26}, {8, 7, 5, 1, 9, 25}, {9, 10, 12, 16, 8, 24}, {10, 9, 11, 15, 7, > > 23}, {11, 12, 10, 14, 6, 22}, {12, 11, 9, 13, 5, 21}, {13, 14, 16, 12, 4, > > 20}, {14, 13, 15, 11, 3, 19}, {15, 16, 14, 10, 2, 18}, {16, 15, 13, 9, 1, > > 17}, {17, 18, 20, 24, 32, 16}, {18, 17, 19, 23, 31, 15}, {19, 20, 18, 22, > > 30, 14}, {20, 19, 17, 21, 29, 13}, {21, 22, 24, 20, 28, 12}, {22, 21, 23, > > 19, 27, 11}, {23, 24, 22, 18, 26, 10}, {24, 23, 21, 17, 25, 9}, {25, 26, 28, > > 32, 24, 8}, {26, 25, 27, 31, 23, 7}, {27, 28, 26, 30, 22, 6}, {28, 27, 25, > > 29, 21, 5}, {29, 30, 32, 28, 20, 4}, {30, 29, 31, 27, 19, 3}, {31, 32, 30, > > 26, 18, 2}, {32, 31, 29, 25, 17, 1}}]; > > > > > > To use backtrack we need to define the state space, a partial test function > > and a final test function. We shall look for solutions ordered in the usual > > way only. Therefore as our state space we can take: > > > > In[3]:= > > space = Table[Drop[m, i], {i, 0, 6}]; > > > > The partial test function says that a partial solution can be extended > > provided its last element comes later in the ordering than the previous one > > and they are not equal: > > > > In[4]:= > > partialQ[{a_}] := True > > In[5]:= > > partialQ[l_] := (Sort[{l[[-2]], l[[-1]]}] == {l[[-2]], l[[-1]]}) && (l[[-2]] > > != l[[-1]]) > > > > the final tes tis Eugene7s condition: > > > > In[6]:= > > finalQ[l_] := Union[Flatten[l]] == Range[32] > > > > Now by default Bactrack finds only one solution and at least in thsi case > > it does it reasonably fast: > > > > In[7]:= > > Backtrack[space, partialQ, finalQ] // Timing > > Out[7]= > > {70.1333 Second, {{1, 2, 4, 8, 16, 32}, {2, 1, 3, 7, 15, 31}, {3, 4, 2, 6, > > 14, 30}, {12, 11, 9, 13, 5, 21}, {20, 19, 17, 21, 29, 13}, {23, 24, 22, 18, > > 26, 10}, {28, 27, 25, 29, 21, 5}}} > > > > It's quite a different matter if we try to find all solutions using: > > > > In[8]:= > > Backtrack[space, partialQ, finalQ, All] // Timing > > > > After an hour I lost patience and aborted. > > > > There is a natural way to speed this up but I do not want to try to do > > this. The way is to try to re-write all this code including the Backtrack > > function in such a way that it could be compiled, in the way used by Carl > > Woll in recent examples. In principle this shoudl be possible, all the > > parameters seems to be of compilable type (one woudl have to change space > > to a tensor, e.g. Table[m,{7}]. This is wasteful but probably woudl be more > > than compenseted for by the extra speed due to compiling). > > > > Or maybe all this is just a false lead and someone can find a much better > > algorithm. > > > > > > -- > > Andrzej Kozlowski > > Toyama International University > > JAPAN > > http://sigma.tuins.ac.jp > > http://eri2.tuins.ac.jp > > > > > > ---------- > >>From: kewjoi at hixnet.co.za (Kew Joinery) To: mathgroup at smc.vnet.net > To: mathgroup at smc.vnet.net > >>To: mathgroup at smc.vnet.net > >>Subject: [mg20114] [mg20060] [mg20021] List-Selection > >>Date: Sat, Sep 25, 1999, 3:40 PM > >> > > > >> Hello everyone, > >> The item FastList-Selection (finding 7 consecutive elements) was solved > >> efficiently. Is there a way to do so for slightly different task? > >> Given matrix m(32x6) , find exactly 7 elements(rows) to satisfy the > condition: > >> Union[Flatten[some 7 rows of m]] = = Range[32] > >> > >> Note: each number NEVER happens to be twice in same row or column! > >> Here is some matrix (satisfying the Note): > >> > >> > >> {{1,2,4,8,16,32},{2,1,3,7,15,31},{3,4,2,6,14,30},{4,3,1,5,13,29},{5,6,8,4,12, > >> 28},{6,5,7,3,11,27},{7,8,6,2,10,26},{8,7,5,1,9,25},{9,10,12,16,8,24},{10, > >> > 9,11,15,7,23},{11,12,10,14,6,22},{12,11,9,13,5,21},{13,14,16,12,4,20},{14, > >> 13,15,11,3,19},{15,16,14,10,2,18},{16,15,13,9,1,17},{17,18,20,24,32,16},{ > >> 18,17,19,23,31,15},{19,20,18,22,30,14},{20,19,17,21,29,13},{21,22,24,20, > >> 28,12},{22,21,23,19,27,11},{23,24,22,18,26,10},{24,23,21,17,25,9},{25,26, > >> 28,32,24,8},{26,25,27,31,23,7},{27,28,26,30,22,6},{28,27,25,29,21,5},{29, > >> 30,32,28,20,4},{30,29,31,27,19,3},{31,32,30,26,18,2},{32,31,29,25,17,1}} > >> > >> Thank you for your attention . > >> Eugene