Re: Re: List-Selection
- To: mathgroup at smc.vnet.net
- Subject: [mg20118] Re: [mg20060] Re: [mg20021] List-Selection
- From: "Andrzej Kozlowski" <andrzej at tuins.ac.jp>
- Date: Sat, 2 Oct 1999 03:04:50 -0400
- Sender: owner-wri-mathgroup at wolfram.com
Thanks to Rob's excellent observation I was able to solve Eugene's problem
completely. This is what happened. When I tried to find just one solution
the increase in speed was remarkable:
In[6]:=
Backtrack[space, partialQ, finalQ] // Timing
Out[6]=
{4.86667 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}}}
Finding all solutions however still took pretty long:
In[7]:=
Length[Backtrack[space, partialQ, finalQ, All] ] // Timing
Out[7]=
{6359.82 Second, 320}
This was done on a 266 mghz PowerMac G3, which was being used for other
purposes while the computation was going on, so it maybe could have been
done faster. Still, the average comes out at about 20 second per solutions
(compared to 5 for the first solution) so they are clearly not uniformly
distributed.
(I hope Eugene will now tell us where this problem comes from and what is
its significance. The matrix m is something that is known as a Latin
rectangle. Any such rectangle can be extended to a Latin square. Latin
squares are useful in lots of branches of mathematics and in applications.
But this is all I know about this.)
--
Andrzej Kozlowski
Toyama International University
JAPAN
http://sigma.tuins.ac.jp
http://eri2.tuins.ac.jp
----------
>From: Rob Pratt <rpratt at email.unc.edu>
>To: Andrzej Kozlowski <andrzej at tuins.ac.jp>
>Cc: mathgroup at smc.vnet.net
>Subject: [mg20118] Re: [mg20060] Re: [mg20021] List-Selection
>Date: Thu, 30 Sep 1999 01:18:28 -0400 (EDT)
>
> 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: [mg20118] [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: [mg20118] [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
>
>