[Date Index]
[Thread Index]
[Author Index]
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
Prev by Date:
**Re: Q: NSolve with conditions**
Next by Date:
**RE: checking for overlap**
Previous by thread:
**Re: List-Selection**
Next by thread:
**NotebookPrint versus File->Print**
| |