Solving a system of equations with constraints in specific order

This code gives about 1000 solutions for the variables a,b,c,d,e,f,g,h:

Solve[{
Max[{a, b, c, d, e, f, g, h}] == 14,
Min[{a, b, c, d, e, f, g, h}] == 1,
Total[{a, b, c, d, e, f, g, h} - Sort[{a, b, c, d, e, f, g, h}]] ==
0,
a == 11, h == 4,
a + h == 15, b + g == 15, c + f == 15, d + e == 15,
a + b + c + d + e + f + g + h == 60
},
{a, b, c, d, e, f, g, h}, Integers]


I would like to add the further constraints, ie:

Mod[a, 2] > 0, Mod[b, 2] == 0, Mod[c, 3] > 0, etc

However if I add those constraints into the code above it seems very inefficient and slow. Is there a way to select the order that constraints are applied, or use the output of Solve as input to another Solve[] with more constraints? Thanks.

cheers, Jamie

(update1, edited twice)

In your version 3 code, the 5 equations:

Abs[Total[Table[v[[i]],{i,n/2}]]-Total[Table[v[[i]],{i,n/2+1,n}]]]==
Abs[Total[Take[v,n/2]]-Total[Drop[v,n/2]]]==
Abs[Total[Take[v,n/2]]-(35*24-Total[Take[v,n/2]])]==
Abs[Total[Take[v,n/2]]-35*24+Total[Take[v,n/2]]]==
Abs[2*Total[Take[v,n/2]]-35*24]


I verified those 5 equations are all equal for n=48. After replacing 35 and 24 with the correct values for n, (ie for n=48: 35=constant2 = constant1/(n/2)). The output of those 5 equations is = constant5:

n=8: all five equations equal: 16 (16=8*2)

n=48: all five equations equal: 192 (192=48*4)

n=480: all five equations equal: 3840 (3840=480*8)

n=5760: all five equations equal: 552960 (552960=5760*96)

For n=8,48,480,5760,... I think that gives the sequence 2,4,8,96,... = OEIS A058262.

Also for the product of prime factors > 2 in 192,3840,552960,...: 3, 3x5=15, 3x3x3x5=135,.. gives 3,15,135 which is OEIS A059861 I think.

I have to convert a lot of the other patterns into equations still, may be a couple days but will work on it. If you are interested to see the patterns I have a word doc I could email.

(*Version 1*)
Clear[a,b,c,d,e,f,g,h];
sol={a,b,c,d,e,f,g,h}/.Solve[{
Max[{a, b, c, d, e, f, g, h}] == 14,
Min[{a, b, c, d, e, f, g, h}] == 1,
a == 11, h == 4, b + g == 15, c + f == 15, d + e == 15},
{a, b, c, d, e, f, g, h},Integers
];
Select[sol,({a,b,c,d,e,f,g,h}=#; Mod[b, 2] == 0 && Mod[c, 3] > 0 (*&&etc*))&]


If you can complete the work on all equations for n==8 and describe what form you want the code to be in to directly generate the result then I will see what I can do. Thanks.

Begin to generalize for any even n variables.

Thank you for the pastebin, that was essential for doing this.

(*Version 2*)
n=8;(*must be even*)
vars=Table[v[i],{i,1,n}];
cons=Join[
{ Total[vars - Sort[vars]] == 0,(*I think this line is always true*)
Abs[Total[Take[vars,n/2]]-Total[Drop[vars,n/2]]]==16,(*Is there a formula of n to replace 16 *)
v[n-1]>0
},
Table[v[i]+v[n-i+1]==15,{i,1,n/2}],
{ Total[Table[v[i],{i,1,n}]]==60 },(*Is there a formula of n to replace 60*)
Table[v[i]-v[i+1]==v[n-i]-v[n-i+1],{i,1,n/2-1}],
{ v[4]-v[5]==v[2]-v[3],
v[4]-v[5]==v[6]-v[7],
v[1]-v[8]==7,
v[8]-v[1]== -7},
{ Total[Abs[Table[v[i]-v[i+1],{i,1,n-1}]]]==35}
];
sol=vars/.Solve[cons,  vars,Integers]
(* returns {{11, 2, 1, 8, 7, 14, 13, 4}} *)


Please check to see if your code returns the same result and if not then let me know what the result should be.

Revised

(*Version 3*)
n = 48;
(* Goal
v = {27, -18, 1, 4, 23, 26, 13, 32, 19, 22, 41, 44,
31, 18, 37, 24, 27, 46, 33, 36, 23, -6, -3, 16,
19, 38, 41, 12, -1, 2, -11, 8, 11, -2, 17, 4,
-9, -6, 13, 16, 3, 22, 9, 12, 31, 34, 53, 8};
*)

(*Verify that this returns True so that doesn't seem to solve for any unknowns*)
v=Table[x[i],{i,n}];
Total[Total[Table[v[[i]]-Sort[Table[v[[i]],{i,n}]],{i,n}]]] == 0

(*Verify this is correct*)
Table[v[[i]]+v[[n-i+1]]==constant2,{i,n/2}];
(*so*)
Table[v[[n-i+1]]==35-v[[i]],{i,n/2}];
(*so*)
Reverse[Table[v[[n-i+1]]==35-v[[i]],{i,n/2}]];
(*so this reduces 48 unknowns to 24 unknowns*)
Join[Table[x[i],{i,n/2}],Reverse[Table[35-v[[i]],{i,n/2}]]];

v={x[1], x[2], x[3], x[4], x[5], x[6], x[7], x[8], x[9], x[10], x[11], x[12],
x[13], x[14], x[15], x[16], x[17], x[18], x[19], x[20], x[21], x[22], x[23], x[24],
35-x[24], 35-x[23], 35-x[22], 35-x[21], 35-x[20], 35-x[19], 35-x[18], 35-x[17],
35-x[16], 35-x[15], 35-x[14], 35-x[13], 35-x[12], 35-x[11], 35-x[10], 35-x[9],
35-x[8], 35-x[7], 35-x[6], 35-x[5], 35-x[4], 35-x[3], 35-x[2], 35-x[1]};

(*Verify this returns True so that doesn't seem to solve for any unknowns*)
Total[v]==840

(*Verify this returns True so that doesn't seem to solve for any unknowns*)
Total[v]==Total[Table[v[[i]],{i,n/2-n/4+1,n/2+n/4}]]*2

(*Verify this returns True so that doesn't seem to solve for any unknowns*)
Total[Table[v[[i]],{i,n/2-n/4+1,n/2+n/4}]]==Total[Table[v[[i]],{i,n/2-n/8+1,n/2+n/8}]]*2

(*Verify this returns {True,True,True...} so that doesn't seem to solve for any unknowns*)
Table[v[[i]]-v[[i+1]]==v[[n-i]]-v[[n-i+1]], {i,n/2-1}]

(*Verify this returns x[1]==27*)
Total[Table[v[[i]]-v[[i+1]],{i,1,n-1}]]==19//Simplify

(*Verify this returns x[1]==27*)
v[[1]]-v[[n]]==19//Simplify

(*Verify this returns x[1]==27*)
v[[n]]-v[[1]]== -19//Simplify

(*Verify this returns 35+x[22]==x[23]+2*x[24]*)
v[[n/2]]-v[[n/2+1]]==v[[n/2-2]]-v[[n/2-1]]//Simplify

(*Verify this returns 35+x[22]==x[23]+2*x[24]*)
v[[n/2]]-v[[n/2+1]]==v[[n/2+2]]-v[[n/2+3]]//Simplify

Min[Table[v[[i]]-v[[i+1]],{i,n-1}]]== -19

Max[Table[v[[i]]-v[[i+1]],{i,n-1}]]==45

Total[Abs[Table[v[[i]]-v[[i+1]],{i,n-1}]]]==641

Abs[Total[Table[v[[i]],{i,n/2}]]-Total[Table[v[[i]],{i,n/2+1,n}]]]==192

(*Verify this is correct*)
Abs[Total[Table[v[[i]],{i,n/2}]]-Total[Table[v[[i]],{i,n/2+1,n}]]]==
Abs[Total[Take[v,n/2]]-Total[Drop[v,n/2]]]==
Abs[Total[Take[v,n/2]]-(35*24-Total[Take[v,n/2]])]==
Abs[Total[Take[v,n/2]]-35*24+Total[Take[v,n/2]]]==
Abs[2*Total[Take[v,n/2]]-35*24]
(*I think I can verify everything except the last line of that
and the last line of that seems like it should also be correct.
This should simplify even further and possibly solve for no more variables.*)

(*This seems to simplify the problem as much as I can see to do now*)
n=48;
v={x[1], x[2], x[3], x[4], x[5], x[6], x[7], x[8], x[9], x[10], x[11], x[12],
x[13], x[14], x[15], x[16], x[17], x[18], x[19], x[20], x[21], x[22], x[23], x[24],
35-x[24], 35-x[23], 35-x[22], 35-x[21], 35-x[20], 35-x[19], 35-x[18], 35-x[17],
35-x[16], 35-x[15], 35-x[14], 35-x[13], 35-x[12], 35-x[11], 35-x[10], 35-x[9],
35-x[8], 35-x[7], 35-x[6], 35-x[5], 35-x[4], 35-x[3], 35-x[2], 35-x[1]};
Reduce[{x[1]==27,35+x[22]==x[23]+2*x[24],
Min[Table[v[[i]]-v[[i+1]],{i,n-1}]]== -19,
Max[Table[v[[i]]-v[[i+1]],{i,n-1}]]==45,
Total[Abs[Table[v[[i]]-v[[i+1]], {i,n-1}]]]==641,
Abs[Total[Table[v[[i]],{i,n/2}]]-Total[Table[v[[i]],{i,n/2+1,n}]]]==192},
{x[1], x[2], x[3], x[4], x[5], x[6], x[7], x[8], x[9], x[10], x[11], x[12],
x[13], x[14], x[15], x[16], x[17], x[18], x[19], x[20], x[21], x[22], x[23], x[24]}]


But that is still 24 unknowns and only 6 equations. And it seems to run forever. It might, but there is no guarantee, be faster if there were another 18 reasonably simple equations constraining the solution. But the Min and Max and Abs mean that some methods of speeding this up cannot be used.

• Thanks, I was able to add more constraints and find the unique solution for 8 variables. My next problem has 48 variables, and then 480 variables after that.. Is there a way to declare how many variables need to be solved for without writing them all out individually? Thanks. – Jamie M May 19 '19 at 3:00
• Hi, thanks that is interesting, I tried to convert the 8 variable code to your format but am not sure how to do it. I put the code that gives the correct unique solution here: pastebin.com/gas1vr7t There are lots of commented out constraints that werent necessary to give the correct solution but are still useful for considering for the 48 variable problem. I will try to add the 48 variable one to see if I can find the unique solution constraints, that would be great to have it work in the format of code you posted. – Jamie M May 20 '19 at 3:06
• Thanks the code you made gives the correct result. Here is a pastebin link for some constraints for the 48 variables, along with the actual 48 values: pastebin.com/HBPtciLR That would be great if the code can be generalized for 8,48,480,5760,.. variables. I will add some more constraints to the pastebin tomorrow – Jamie M May 20 '19 at 9:34
• I added some more constraints, still have quite a few more to add.. The same set of constraints are working for 8,48,480,... That would be cool if you figure out how to generate the 48 values with these constraints. Here is the code: pastebin.com/de0GNXmR – Jamie M May 22 '19 at 8:47
• Thanks, I will get back to this, but one question about your version 2 code which returns {{11, 2, 1, 8, 7, 14, 13, 4}} , are there formulas to directly generate those as well that can be output in terms of the other values? – Jamie M May 26 '19 at 18:16

Does this work?

sol = Solve[{Max[{a, b, c, d, e, f, g, h}] == 14, Min[{a, b, c, d, e, f, g, h}] == 1,
Total[{a, b, c, d, e, f, g, h} - Sort[{a, b, c, d, e, f, g, h}]] == 0, a == 11, h == 4,
a + h == 15, b + g == 15, c + f == 15, d + e == 15,
a + b + c + d + e + f + g + h == 60}, {a, b, c, d, e, f, g, h}, Integers];

sol2 = sol[[Flatten[Position[Mod[a, 2] > 0 && Mod[b, 2] == 0 && Mod[c, 3] > 0 /. sol, True]]]];

Dimensions[sol2]
(* {404, 8} *)