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>