Re: is there a better way to do constraint logic
- To: mathgroup at smc.vnet.net
- Subject: [mg80829] Re: [mg80786] is there a better way to do constraint logic
- From: danl at wolfram.com
- Date: Mon, 3 Sep 2007 06:16:10 -0400 (EDT)
- References: <200709010436.AAA26714@smc.twtelecom.net>
>
> simplified constraint programming example in Mathematica:
>
> find a set of numbers that add to a particular value - numbers cannot be
> the same
>
> note huge timing problem as we go up in variables
>
> Above 5, it hung...
>
>
> I was really hoping Mathematica had a decent constraint solver, but not
> sure
> now!!
>
> ----
>
>
> sumgroup[num_] := (vars =
> Flatten @ Table[ ToExpression["x" <> ToString[i]], {i, 1, num}] ;
> r1 = And @@ Map[( 0 < # < 10) & , vars]; Print [r1];
> r2 = ( Plus @@ vars) == Round[ 9 num /2]; Print [r2];
> r3 = And @@ Rest @Union @
> Flatten @ Table[vars[[i]] != vars[[j]], {i, 1, num}, {j, i, num}] ;
> Print[r3];
> tim = Timing[FindInstance[r1 && r2 && r3, vars, Integers]];
> Print[tim] ; Print[]);
>
>
>
> For[ nn = 2, nn < 6, nn++, sumgroup[nn]]
>
>
>
> 0 < x1 < 10 && 0 < x2 < 10
> x1 + x2 == 9
> x1 != x2
> {5.42101*10^-19, {{x1 -> 1, x2 -> 8}}}
> ""
> 0 < x1 < 10 && 0 < x2 < 10 && 0 < x3 < 10
> x1 + x2 + x3 == 14
> x1 != x2 && x1 != x3 && x2 != x3
> {5.42101*10^-19, {{x1 -> 1, x2 -> 4, x3 -> 9}}}
> ""
> 0 < x1 < 10 && 0 < x2 < 10 && 0 < x3 < 10 && 0 < x4 < 10
> x1 + x2 + x3 + x4 == 18
> x1 != x2 && x1 != x3 && x1 != x4 && x2 != x3 && x2 != x4 && x3 =
> != x4
> {0.094, {{x1 -> 2, x2 -> 3, x3 -> 4, x4 -> 9}}}
> ""
> 0 < x1 < 10 && 0 < x2 < 10 && 0 < x3 < 10 && 0 < x4 < 10 && 0 < x5 < 10
> x1 + x2 + x3 + x4 + x5 == 22
> x1 != x2 && x1 != x3 && x1 != x4 && x1 != x5 && x2 != x3 && x2 =
> != x4 &&
> x2 != x5 && x3 != x4 && x3 != x5 && x4 != x5
> {33.062, {{x1 -> 1, x2 -> 2, x3 -> 3, x4 -> 7, x5 -> 9}}}
> ""
>
>
I'd use FindInstance but set it up differently, to take advantage of some
integer linear programming (ILP) capabilities. Use a variable for each
digit value (1-9, in your examples). Restrict variable to take on only
values 0 and 1 (more on this below). Multiply variable by corresponding
digit, enforce that sum is what you want it to be. Also insist sum of
variables gives the cardinality of the allowable subsets.
To constrain variables in an ILP setting, use an inequality making each be
between 0 and 1 inclusive. Then specify that we work over integers.
In[21]:= len = 6;
dlen = 9;
vals = Range[dlen];
vars = Array[a, dlen];
b = Round[len*dlen/2];
constraints = Map[0 <= # <= 1 &, vars];
eqns = {Total[vars] == len, vars.vals == b}
Out[27]= {a[1] + a[2] + a[3] + a[4] + a[5] + a[6] + a[7] + a[8] +
a[9] == 6,
a[1] + 2 a[2] + 3 a[3] + 4 a[4] + 5 a[5] + 6 a[6] + 7 a[7] +
8 a[8] + 9 a[9] == 27}
Now a FindInstance invocation, and minor postprocessing, gives a solution.
In[35]:= (vars*vals) /.
First[FindInstance[Flatten[{eqns, constraints}], vars, Integers]] /.
0 -> Sequence[]
Out[35]= {2, 3, 4, 5, 6, 7}
Note that one can get more solutions (all of them, for example) by using
Reduce instead of FindInstance. The postprocessing will be a bit
different.
So that is one approach. One can also tackle this as a subset sum problem.
This is a bit dicey insofar as there is no guarantee of finding a solution
even if one exists. With some monkeying around I was able to get various
examples to yield solutions but I am not sure I could make that always
happen.
The code below, which requires a bit more explanation than I am willing to
conjure, does the job for the example I show.
len = 6;
dlen = 9;
mult = 1;
v1 = 4*Range[dlen];
v2 = Table[1, {dlen}];
v3 = Table[0, {dlen}];
m1 = 2*IdentityMatrix[dlen];
m2 = Transpose[Join[{v1, v2}, m1, {v3}]];
v3 = Table[-1, {dlen + 3}];
v3[[{1, 2, -1}]] = -{Round[2*9*len], len, -1/mult}; lat =
mult*Append[m2, v3]
In[97]:= redlat = LatticeReduce[lat]
Out[97]= {{0, -1, -2, -2, 2, 0, 0, 0, 0, 0, 0, 0}, {0, -1, -2, 0, -2,
2, 0, 0, 0, 0, 0, 0}, {4, 1, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0}, {0,
0, -2, 2, 2, -2, 0, 0, 0, 0, 0, 0}, {0, -1, -2, 0, 0, -2, 2, 0, 0,
0, 0, 0}, {0, -1, -2, 0, 0, 0, -2, 2, 0, 0, 0, 0}, {0, 0, 1, 1,
1, -1, 1, -1, 1, -1, 1, 1}, {0, -1, -2, 0, 0, 0, 0, -2, 2, 0, 0,
0}, {0, -1, -1, 1, 1, -1, 1, -1, -1, 1, 1, 1}, {0, 0, -1, -1, -1, 1,
1, -1, -1, -1, 1, -1}}
Notice there are rows with zeros in columns 1 and 2, and +-1 in the last
column. These are rows that correspond to solving the two required
equations (sum of values is correct and we use the allowable number of
digits, though allowing multiplicity). We use some postprocessing to cull
out these contenders, check that they use exactly one of each digit, and
form the solutions thus provided.
In[103]:=
keep = Select[redlat, Abs[#[[{1, 2, -1}]]] === {0, 0, 1} &];
keep1 = Map[#*Last[#] &, keep];
keep2 = keep1 /. -1 -> 0;
keep3 = Select[keep2, Apply[Times, # /. 0 -> 1] == 1 &];
keep4 = Map[Take[#, {3, -2}] &, keep3]
Out[107]= {{1, 1, 1, 0, 1, 0, 1, 0, 1}, {1, 1, 1, 0, 0, 1, 1, 1, 0}}
In[109]:= solns = Map[#*Range[dlen] &, keep4] /. 0 -> Sequence[]
Out[109]= {{1, 2, 3, 5, 7, 9}, {1, 2, 3, 6, 7, 8}}
Daniel Lichtblau
Wolfram Research
- References:
- is there a better way to do constraint logic programming in Mathematica?
- From: "sdw" <warwick@jps.net>
- is there a better way to do constraint logic programming in Mathematica?