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