# Equation solving with Reduce does not converge

I'm trying to solve the following equation, but it runs for three days and does not converge to a solution. Do you have any suggestion on how to solve it?

 Reduce[1/(
4 (1 - (1 - 2 p)^(2 (d1 + d3 + d4))) Log[
2]) (-4 (-1 + (1 - 2 p)^(d1 + d3)) (1 + (1 - 2 p)^
d4) (1 + (1 - 2 p)^(d1 + d3 +d4)) Log[((-1 + (1 - 2 p)^(d1 + d3)) (1 +
(1 - 2 p)^d4))/(
2 (-1 + (1 - 2 p)^(d1 + d3 + d4)))] -
2 (1 + (1 - 2 p)^d1) (1 + (1 - 2 p)^d4) (-1 + (1 - 2 p)^(
d1 + d3 + d4)) Log[((1 + (1 - 2 p)^d1) (1 + (1 - 2 p)^d4))/(
2 (1 + (1 - 2 p)^(d1 + d3 + d4)))] +
2 (1 + (1 - 2 p)^d1) (-1 + (1 - 2 p)^(
d3 + d4)) (-1 + (1 - 2 p)^(
d1 + d3 +
d4)) Log[-(((1 + (1 - 2 p)^d1) (-1 + (1 - 2 p)^(d3 + d4)))/(
2 (1 + (1 - 2 p)^(d1 + d3 + d4))))]) >
1/(4 (1 - (1 - 2 p)^(2 (d1 + d3 + d4))) Log[
2]) (-2 (1 + (1 - 2 p)^(d1 + d3 + d4)) (-1 + (1 - 2 p)^(
d1 + d2) + (1 - 2 p)^(d1 + d3 + d4) - (1 - 2 p)^(
d2 + d3 + d4)) Log[(-1 + (1 - 2 p)^(d1 + d2) + (1 - 2 p)^(
d1 + d3 + d4) - (1 - 2 p)^(d2 + d3 + d4))/(
2 (-1 + (1 - 2 p)^(d1 + d3 + d4)))] +
4 (1 + (1 - 2 p)^d1) (-1 + (1 - 2 p)^(
d1 + d3 + d4)) (-1 + (1 - 2 p)^(
d2 + d3 +
d4)) Log[-(((1 + (1 - 2 p)^d1) (-1 + (1 - 2 p)^(
d2 + d3 + d4)))/(2 (1 + (1 - 2 p)^(d1 + d3 + d4))))] -
2 (1 + (1 - 2 p)^d1) (-1 + (1 - 2 p)^(
d1 + d3 + d4)) (1 + (1 - 2 p)^(
d2 + d3 +
d4)) Log[((1 + (1 - 2 p)^d1) (1 + (1 - 2 p)^(
d2 + d3 + d4)))/(2 (1 + (1 - 2 p)^(d1 + d3 + d4)))])
&& 1 > p > 1/2 && d1 > d2 && Element[d1, Integers] &&
Element[d2, Integers] && Element[d3, Integers] &&
Element[d4, Integers], {d1, d2, d3, d4, p}]

• 3 days ,Wow !!!. Probably you need a quantum computer or a good HINT. – Mariusz Iwaniuk May 13 '18 at 17:27
• Yes, good hint will be great – Kiril Danilchenko May 13 '18 at 17:29
• Maybe you can try with FindInstance[ YourEquation && 0 < d1 < 100 && 0 < d2 < 100 && 0 < d3 < 100 && 0 < d4 < 100, {d1, d2, d3, d4, p}, Reals], if FindInstance can't find solution then expand search domain for: d1,d2,d3,d4. – Mariusz Iwaniuk May 13 '18 at 17:40

You can get numerical results for given d1,d2,d3,d4.

Therefore track the curve with NDSolve and collect the p values, where inequation is True.

eq[d1_, d2_, d3_, d4_, p_] :=
1/(4 (1 - (1 - 2 p)^(2 (d1 + d3 + d4))) Log[
2]) (-4 (-1 + (1 - 2 p)^(d1 + d3)) (1 + (1 - 2 p)^
d4) (1 + (1 - 2 p)^(d1 + d3 +
d4)) Log[((-1 + (1 - 2 p)^(d1 + d3)) (1 + (1 - 2 p)^
d4))/(2 (-1 + (1 - 2 p)^(d1 + d3 + d4)))] -
2 (1 + (1 - 2 p)^d1) (1 + (1 - 2 p)^
d4) (-1 + (1 - 2 p)^(d1 + d3 +
d4)) Log[((1 + (1 - 2 p)^d1) (1 + (1 - 2 p)^
d4))/(2 (1 + (1 - 2 p)^(d1 + d3 + d4)))] +
2 (1 + (1 - 2 p)^
d1) (-1 + (1 - 2 p)^(d3 + d4)) (-1 + (1 - 2 p)^(d1 + d3 +
d4)) Log[-(((1 + (1 - 2 p)^
d1) (-1 + (1 - 2 p)^(d3 + d4)))/(2 (1 + (1 -
2 p)^(d1 + d3 + d4))))]) >
1/(4 (1 - (1 - 2 p)^(2 (d1 + d3 + d4))) Log[
2]) (-2 (1 + (1 - 2 p)^(d1 + d3 + d4)) (-1 + (1 - 2 p)^(d1 +
d2) + (1 - 2 p)^(d1 + d3 + d4) - (1 - 2 p)^(d2 + d3 +
d4)) Log[(-1 + (1 - 2 p)^(d1 + d2) + (1 - 2 p)^(d1 + d3 +
d4) - (1 - 2 p)^(d2 + d3 +
d4))/(2 (-1 + (1 - 2 p)^(d1 + d3 + d4)))] +
4 (1 + (1 - 2 p)^
d1) (-1 + (1 - 2 p)^(d1 + d3 + d4)) (-1 + (1 - 2 p)^(d2 +
d3 +
d4)) Log[-(((1 + (1 - 2 p)^
d1) (-1 + (1 - 2 p)^(d2 + d3 + d4)))/(2 (1 + (1 -
2 p)^(d1 + d3 + d4))))] -
2 (1 + (1 - 2 p)^
d1) (-1 + (1 - 2 p)^(d1 + d3 + d4)) (1 + (1 - 2 p)^(d2 +
d3 + d4)) Log[((1 + (1 - 2 p)^
d1) (1 + (1 - 2 p)^(d2 + d3 + d4)))/(2 (1 + (1 -
2 p)^(d1 + d3 + d4)))]);


Give the d1,d2,d3,d4

eq2[p_] = eq[4, 3, 2, 1, p] // Simplify[#, 1/2 < p < 1] &;


Simplify orders to left side less/Greater zero, shown in condit

condit = Head[eq2[p]] @@ {f[p], 0}; rp =
Reap[NDSolve[{f'[p] == D[eq2[p][[1]], p],
f[1/2] == (eq2[p][[1]] /. p -> 1/2)}, f, {p, 1/2, 1},
EvaluationMonitor :> Sow[If[condit, p, {}]],
Method -> {"EventLocator", "Event" -> f[p],
"EventAction" :> (Sow[p]; Continue)}]];


Eventlocatoor finds p where f[p] is zero and Reap collects all p values, that satisfiy inequality.

Now find Min and Max of the reaped interval.

se = Select[rp[[2, 1]], 1/2 < # < 1 &]; {Min[se], Max[se]}

(*   {0.747797, 1.}   *)


Test

FindRoot[Evaluate[(eq2[p][[1]])] == 0, {p, .7}]

(*   {p -> 0.747797}   *)


(I just had no more time to adjust it for the cases, where there are more than one interval.)

Plot shows whether result is true.

Plot[Evaluate[eq2[p][[1]]], {p, 1/2, 1}]


I don't know whether you are looking for an algebraic solution from Reduce which will give you equations defining all possible solutions or, as Mariusz Iwaniuk suggested, an instance satisfying your conditions would be enough. If it is the later then perhaps this will help.

Let's call your large inequality lhs > rhs just to be compact. Then

q = 3; zed = Quiet[Table[
p = RandomReal[{1/2, 1}];
{lhs-rhs, d4, d3, d2, d1, p},
{d4,-q,q}, {d3,-q,q}, {d2,-q,q}, {d1,d2+1,q}]];
Select[DeleteCases[Partition[Flatten[zed], 6], {Indeterminate, __}],
Abs[Im[First[#]]] == 0. && First[#] > 0 &]


will quickly display a long list of satisfying values.

The Quiet was in there even though I don't like hiding informative warnings, but the number of indeterminates, usually of the form 0^0, filled the screen and so I used that to discard those warnings.

{{1.6851133758028167 + 0. I, -3, 0, 0, 1, 0.6310084382590684},
{8.67534492845964, -2, 1, 2, 3, 0.6404193003833524},
{7.850823083033637, -2, 3, 0, 1, 0.6365522504180247},
....


Picking the last one of those shown as an example

Clear[d4, d3, d2, d1, p];
lhs > rhs /. {d4->-2, d3->3, d2->0, d1->1, p->0.6365522504180247}


displays True showing that this satisfies your conditions. And it does that in a fraction of a minute instead of in three days plus an unknown amount more time.

• Thanks @Bill I am looking for ranges where inequality will be true rather than a single instance. – Kiril Danilchenko May 14 '18 at 4:12
• With all the powers of negative reals that you have in denominators I don't think you are going to have much luck getting a solution. Perhaps you could try a simpler problem, where will your Logs all be real? That appears likely to be a condition for your solution and seems somewhat simpler than your full problem. Perhaps with the insight from that you might gain some ideas on how to then tackle your full problem. – Bill May 14 '18 at 4:48