[Date Index]
[Thread Index]
[Author Index]
Re: Re: List-Selection
*To*: mathgroup at smc.vnet.net
*Subject*: [mg20176] Re: [mg20060] Re: [mg20021] List-Selection
*From*: "Andrzej Kozlowski" <andrzej at tuins.ac.jp>
*Date*: Sun, 3 Oct 1999 21:07:42 -0400
*Sender*: owner-wri-mathgroup at wolfram.com
This is very interesting. Its well outside my area of expertise but one
thing has intrigued me particularly. Mathematica indeed has no
IntegerProgramming function. However, I remember from reading Cox, Little
and O'Shea's "Using Algebraic Geometry" that Groebner basis can be used to
do just that. I think they say that the built in Groebner basis in
Mathematica is not flexible enough to do that, but I think they were only
familiar with Mathematica 2. The main point seemed to be the ability to
specify suitably weighted monomial orders, which I think can be done in
Mathematica 4.0. Can this really be done? Could we hope to solve this
problem using Groebner basis? I don't think I could try to answer this
without a great deal of work but I think this should be something Daniel
Lichtblau could tell us.
--
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: Kew Joinery <kewjoi at hixnet.co.za>
>Cc: Andrzej Kozlowski <andrzej at tuins.ac.jp>, mathgroup at smc.vnet.net
>Subject: [mg20176] Re: [mg20060] Re: [mg20021] List-Selection
>Date: Fri, 1 Oct 1999 16:26:13 -0400 (EDT)
>
> 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 Combinatorica Backtrack, because is using
> bit vector
>> (incrementing) and one could be able to search longer without run out
> of memory.
>> Mr. Hayes 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 cutoff
>> 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 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 >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,2
5,
>> 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},{60
,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
>>
>>
>>
>>
>
>
Prev by Date:
**Re: NonlinearRegress and numerical functions...**
Next by Date:
**Rationalize[] in Mathematica3 vs. Mathematica4**
Previous by thread:
**Re: Re: List-Selection**
Next by thread:
**Re: Re: Re: List-Selection**
| |