How should i write the code to minimize this function?

Question

I am not a mathematica user. I need to find the solution to a given problem, which we already described there for theoretical analysis. I'll rewrite here the problem:

Let $\mathbf a = (a_1,...,a_d)$ is a constant in $\mathbb R_{+}^d \setminus \{\mathbf 0\}$ (some $a_i$ can be $0$ but not all, all are $\ge 0$).

Define the set $$S(\mathbf a) = \left\{\mathbf x \in \mathbb C^d:\; \sum_{i=1}^d \frac{x_i +1}{x_i -1}a_i = 1 \right\}.$$

Define the distance of the set to zero as :

$$d(\mathbf a) = \min\limits_{\mathbf x \in S(a)} \sum_{i=1}^d \lvert x_i \rvert$$

We found out that this distance is always greater than $1$, and I am wandering if there could be a simple function that computes it from $\mathbf a$.

When $d = 1$, we already solved the problem by hand.

If $d=2$ and for particular values of $a_1,a_2$, wolfram alpha finds a theoretical minimum with the following command:

Minimize[{Abs[x] + Abs[y], (3 (1 + x))/(-1 + x) + (2 (1 + y))/(-1 + y) == 1}, {x, y}]

wich produces the same output in a mathematica kernel.

How can i generalize this command to tell mathematica to find the function $d(\mathbf a)$ for me ? (let's say for a given dimension $d$, i can run it once for each dimension if needed). I want it to consider $\mathbf a$ as a nuisance parameter and give me a minimum that depends on $\mathbf a$.

Answer 1

Here we use $z$ instead of $x$ to express the complex number.

It seems that when d=2 and the min attain, the $z_1,z_2$ should be a real.

d = 2;
r = 1;
reg = Annulus[{0, 0}, {0.1, r}, {0.01, π/2}];
{a[1], a[2]} = RandomPoint[reg];
result = NMinimize[{Sum[Sqrt[x[i]^2 + y[i]^2], {i, 1, d}], 
   Sum[(z[i] + 1)/(z[i] - 1) a[i] /. z[i] -> x[i] + I*y[i] // ReIm // 
      ComplexExpand, {i, 1, d}] == {1, 0}}, 
  Riffle[Array[x, d], Array[y, d]], 
  Method -> "DifferentialEvolution"]
Graphics[{Circle[{0, 0}, r], Point[Array[a, d]], 
  Text["a", {a[1], a[2]}, {-1, -1}], Red, 
  Point[Table[{x[i], y[i]}, {i, 1, 2}] /. result[[2]]], 
  Text["z1", {x[1], y[1]} /. result[[2]], {1, 1}], 
  Text["z2", {x[2], y[2]} /. result[[2]], {1, 1}], EdgeForm[Green], 
  FaceForm[], reg}]

For $d=4$, we also use numeric method to test the solution.

Clear["Global`*"];
d = 4;
r = 3;
reg = ImplicitRegion[
   And @@ Thread[Array[a, d] > 0]  && 
     Array[a, d] ∈ Ball[Array[0 &, d], r] // Evaluate, 
   Array[a, d] // Evaluate];
Evaluate[Array[a, d]] = RandomPoint[reg]
result = NMinimize[{Sum[Sqrt[x[i]^2 + y[i]^2], {i, 1, d}], 
   Sum[(z[i] + 1)/(z[i] - 1) a[i] /. z[i] -> x[i] + I*y[i] // ReIm // 
      ComplexExpand, {i, 1, d}] == {1, 0}}, 
  Riffle[Array[x, d], Array[y, d]], Method -> "DifferentialEvolution"]

Answer 2

You can use Norm[_,1] as the objective function in Minimize:

ClearAll[minOneNorm]

minOneNorm[a_] := Module[{xx = Array[x, Length@a]}, 
    Minimize[{Norm[xx, 1], a.((1 + xx)/(xx - 1)) == 1}, xx]]

Examples:

minOneNorm[{3}]

{2, {x[1] -> -2}}

minOneNorm[{3, 2}] // Simplify

{-(1/2) + Sqrt[6],
 {x[1] -> 1/2 (-1 + Sqrt[6]), x[2] -> Sqrt[3/2]}}

minOneNorm[{3, 2, 1}] // Simplify

 {7/5, 
 {x[1] -> 0, x[2] -> 0, x[3] -> 7/5}}

sol = minOneNorm[{3, 2}] // Simplify;
argmin = {x[1], x[2]} /. sol[[2]]

 {1/2 (-1 + Sqrt[6]), Sqrt[3/2]}

minvalue = sol[[1]]

 -(1/2) + Sqrt[6]

We can use ContourPlot to show the locus of points where the objective function value is equal to minvalue and RegionPlot to show the locus of points that satisfy the constraint (representing the constraint as an ImplicitRegion):

ClearAll[impReg]
impReg[a_] := With[{xx = Array[x, Length @ a]}, 
  ImplicitRegion[{a.((1 + xx)/(xx - 1)) == 1}, xx]]

Show[ContourPlot[Norm[{x, y}, 1] == minvalue, {x, -4, 4}, {y, -6, 2}, 
  ContourStyle -> Directive[Thick, Blue], 
  Epilog -> {PointSize[Large], Green, Point[argmin]}], 
 RegionPlot[impReg[{3, 2}], BoundaryStyle -> Directive[Thick, Red]]]

Answer 3

For larger dimensions Minimize may take unreasonably long. NMinimize may be more appropriate. In the following I ignore the case where a={0,0,..} as this is easily spotted and complicates things.

To make things tidy, we first create functions for the needed variables and the equations:

sum[a_] := Sum[
  a[[i]] (Subscript[x, i] + 1)/(Subscript[x, i] - 1), {i, Length[a]}];
vars[a_] := Table[Subscript[x, i], {i, Length[a]}];

An example for dimension=3:

a = {1, 2, 3};
Minimize[{Norm[vars[a],1], sum[a] == 1, vars[a] >= 0}, vars[a]]