Re: List-Selection

*To*: mathgroup at smc.vnet.net*Subject*: [mg20060] Re: [mg20021] List-Selection*From*: "Andrzej Kozlowski" <andrzej at tuins.ac.jp>*Date*: Wed, 29 Sep 1999 03:33:22 -0400*Sender*: owner-wri-mathgroup at wolfram.com

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: kewjoi at hixnet.co.za (Kew Joinery), mathgroup at smc.vnet.net >Subject: [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 >>Subject: [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 >> >>