Re: Re: List-Selection
- To: mathgroup at smc.vnet.net
- Subject: [mg20170] Re: [mg20060] Re: [mg20021] List-Selection
- From: Rob Pratt <rpratt at email.unc.edu>
- Date: Sun, 3 Oct 1999 21:07:38 -0400
- Sender: owner-wri-mathgroup at wolfram.com
I first tried Backtrack as follows, where m2 is the matrix for the larger
problem (64 by 7).
Needs["DiscreteMath`Combinatorica`"];
space = Table[Drop[m2, i], {i, 0, 11}];
partialQ[{a_}] := True;
partialQ[l_] :=
Last[l[[-1]]] < Last[l[[-2]]] &&
7 Length[l] - Length[Union[Flatten[l]]] <= 20;
finalQ[l_] := Length[Union[Flatten[l]]] == 64;
Backtrack[space, partialQ, finalQ] // Timing
$Aborted
But I got no results after several hours, so I Aborted.
Then I thought of attacking the problem via MinimumVertexCover in the
Combinatorica package. Here, m1 is the matrix for the smaller problem (32
by 6).
SubsetToVector[s_List,n_Integer]:=Table[If[MemberQ[s,i],1,0],{i,1,n}]
adj1=Map[SubsetToVector[#,32]&,m1];
g1=Graph[adj1,CircularVertices[Length[adj1]]];
MinimumVertexCover[g1]//Timing
$Aborted
Since this method was fruitless even on the smaller problem, I won't
bother describing the details of the formulation.
I then tried a third approach using integer programming. Both problems
can be subsumed into the following general (and NP-complete!) problem:
given a collection of k arbitrary subsets of the set S = {1,2,,...,n},
find the minimum number of subsets whose union is S (and return these
subsets). This general problem can be formulated as an integer
programming problem. For 1 <= i <= n define decision variable x_i to be 1
if subset i is chosen and 0 otherwise. For 1 <= i <= n and 1 <= j <= k,
let a_{i,j} be 1 if subset i contains element j and 0 otherwise. Then we
want to
Minimize Sum[x_i, {i,1,n}]
Subject To Sum[a_{i,j} x_i, {i,1,n}] >= 1 for 1 <= j <= k
x_i = 0 or x_i = 1 for all i
If we ignore the integrality constraints (or replace them with
0 <= x_i <= 1), we can use Mathematica to solve the resulting linear
programming relaxation.
?LinearProgramming
LinearProgramming[c, m, b] finds the vector x which minimizes the quantity
c.x subject to the constraints m.x >= b and x >= 0.
c1=Table[1,{32}];b1=Table[1,{32}];
adj1=Map[SubsetToVector[#,32]&,m1];
Timing[sol1=LinearProgramming[c1,adj1,b1]]
\!\({1.10000000000218278`\ Second, {1\/3, 0, 1\/3, 0, 0, 1\/3, 0, 1\/3, 0 ,
0,
1\/3, 1\/3, 0, 0, 1\/3, 1\/3, 0, 1\/3, 0, 1\/3, 1\/3, 0, 1\/3, 0,
1\/3,
1\/3, 0, 0, 1\/3, 1\/3, 0, 0}}\)
c1.sol1
\!\(16\/3\)
Ceiling[16/3]
6
c2=Table[1,{64}];b2=Table[1,{64}];
adj2=Map[SubsetToVector[#,64]&,m2];
Timing[sol2=LinearProgramming[c2,adj2,b2]]
\!\({3.3499999999985448`\ Second, {1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7,
1\/7,
1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7,
1\/7,
1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7,
1\/7,
1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7,
1\/7,
1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7,
1\/7,
1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7, 1\/7}}\)
c2.sol2
\!\(64\/7\)
Ceiling[64/7]
10
As you can see, the LP solutions are not integer in either case.
Furthermore, the lower bounds they provide (for the IP solutions) are the
same as the trivial lower bounds Ceiling[32/6] = 6 and Ceiling[64/7] == 10,
respectively.
As Mathematica seems to have no IntegerProgramming command (neither
built-in nor on MathSource), I resorted to a commercial IP solver and
obtained a solution in a few minutes.
sol={7,16,18,21,28,29,39,48,51,54,57,62};
Union[Flatten[Table[m2[[sol[[i]]]],{i,1,Length[sol]}]]]==Range[64]
True
I should mention that most of the computational time was in verifying
optimality of the integer solution. If you happen to know the minimum
number of subsets a priori (as you apparently did in these two cases),
that constraint could be added to the formulation to save time.
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 Fri, 1 Oct 1999, Kew Joinery wrote:
> Hello Everyone ,
> I would like to thank Mr. Kozlowski for spending more then 2 hours for this
> problem. (I spent much more- Human is curious about unknown).
> The example illustrate the ability of Mathematica to be weak in the most important
> spectrum of Discrete Mathematics Searching (Sorting is handily controlled). There
> is no build in function Search (probably is impossible to build
in one). The
> best custom implementation is Combinatoricas Backtrack, because is using bit vector
> (incrementing) and one could be able to search longer without run out of memory.
> Mr. Hayess backtrack is faster but is memory hungry .So Mathematica
needs one
> build-in function just to perform at least exhaustive search over a candidate
> solutions. Better one would be to involve pruning possibilities like cut off
> k-subsets from rank r1 to rank r2.
> Consider in this case custom implementation construct all 7-subsets from 32 set
> (which is 3365856) and map them over the matrix, then perform exhaustive search.
> Thanks to Mr. Pratt for the nice pruning in the solution space. So Mr.Kozlowski was
> patient to perform complete search and to find all 320 solutions.
> Now I ask you how to approach the next instance?
> This is steal small instance: n=6 so the desirable matrix is m(64x7)
> Note: to construct matrix whit property NO number appears twice in the same column
> or the same row + that all numbers are equally distributed the
matrix should be
> long prime^n.
> *** the task is: Find JUST ONE solution satisfying the condition:
> Union[Flatten[ some 12 rows of m ]] = = Range[64]
>
> Here is the modest matrix for n=6 =96>m( 2^6=64 x n+1=7)
>
> {{1,2,4,8,16,32,64},{2,1,3,7,15,31,63},{3,4,2,6,14,30,62},{4,3,1,5,13,29,61},{
> 5,6,8,4,12,28,60},{6,5,7,3,11,27,59},{7,8,6,2,10,26,58},{8,7,5,1,9,25,
> 57},{9,10,12,16,8,24,56},{10,9,11,15,7,23,55},{11,12,10,14,6,22,54},{12,
> 11,9,13,5,21,53},{13,14,16,12,4,20,52},{14,13,15,11,3,19,51},{15,16,14,10,
> 2,18,50},{16,15,13,9,1,17,49},{17,18,20,24,32,16,48},{18,17,19,23,31,15,
> 47},{19,20,18,22,30,14,46},{20,19,17,21,29,13,45},{21,22,24,20,28,12,44},{
> 22,21,23,19,27,11,43},{23,24,22,18,26,10,42},{24,23,21,17,25,9,41},{25,26,
> 28,32,24,8,40},{26,25,27,31,23,7,39},{27,28,26,30,22,6,38},{28,27,25,29,
> 21,5,37},{29,30,32,28,20,4,36},{30,29,31,27,19,3,35},{31,32,30,26,18,2,
> 34},{32,31,29,25,17,1,33},{33,34,36,40,48,64,32},{34,33,35,39,47,63,31},{
> 35,36,34,38,46,62,30},{36,35,33,37,45,61,29},{37,38,40,36,44,60,28}
,{38,
> 37,39,35,43,59,27},{39,40,38,34,42,58,26},{40,39,37,33,41,57,25},{41,42,
> 44,48,40,56,24},{42,41,43,47,39,55,23},{43,44,42,46,38,54,22},{44,43,41,
> 45,37,53,21},{45,46,48,44,36,52,20},{46,45,47,43,35,51,19},{47,48,46,42,
> 34,50,18},{48,47,45,41,33,49,17},{49,50,52,56,64,48,16},{50,49,51,55,63,
> 47,15},{51,52,50,54,62,46,14},{52,51,49,53,61,45,13},{53,54,56,52,60,44,
> 12},{54,53,55,51,59,43,11},{55,56,54,50,58,42,10},{56,55,53,49,57,41,9},{
> 57,58,60,64,56,40,8},{58,57,59,63,55,39,7},{59,60,58,62,54,38,6},{6
0,59,
> 57,61,53,37,5},{61,62,64,60,52,36,4},{62,61,63,59,51,35,3},{63,64,62,58,
> 50,34,2},{64,63,61,57,49,33,1}}
>
> Note: use ColumnForm to see some nice features of m.
>
> Thank you for your attention and any suggestions.
> Eugene
>
>
>
>