Showing symbolic equality up to some transformation of variables

Question

I'm trying to show that there exists some transformation of variables between the following two expressions such that they are equivalent.

expr1 = a1  a2 + 1/(a1  a2) + a1  a3 + 1/(a1  a3) + a1 + 1/a1 + 
   a3/a2 + a2/a3 + a2 + 1/a2 + a3 + 1/a3;
expr2 = z1/z2^2 + z2^2/z1 + z1/z3^2 + 1/(z2  z3) + z1^2/(z2  z3) + 
   z2/(z1  z3) + z1  z2/z3 + z3/(z1  z2) + z1  z3/z2 + z2  z3 + 
   z2  z3/z1^2 + z3^2/z1;

I have tried the following brute force method:

expr = 3 + z1^(-1) + z1 + z2^(-1) + 1/(z1*z2) + z2 + z1*z2 + 
   z3^(-1) + 1/(z1*z3) + z2/z3 + z3 + z1*z3 + z3/z2;

expr2 = 3 + z1/z2^2 + z2^2/z1 + z1/z3^2 + 1/(z2*z3) + z1^2/(z2*z3) + 
   z2/(z1*z3) + z1*z2/z3 + z3/(z1*z2) + z1*z3/z2 + z2*z3 + 
   z2*z3/z1^2 + z3^2/z1;

found = False;
counter = 0
Do[new = 
   expr /. {z1 -> z1^a*z2^b*z3^c, z2 -> z1^d*z2^e*z3^f, 
     z3 -> z1^g*z2^h*z3^i};
  counter = counter + 1;
  Print[counter];
  If[Simplify[new == expr2], 
   Print["Found solution: ", {a, b, c, d, e, f, g, h, i}];
   found = True;
   Break[];], {a, -1, 1}, {b, -1, 1}, {c, -1, 1}, {d, -1, 1}, {e, -1, 
   1}, {f, -1, 1}, {g, -1, 1}, {h, -1, 1}, {i, -1, 1}];

If[! found, Print["No solution found"]];

However this takes far too long already, and the necessary range may be {-2,2}. I have also tried:

expr1 = a1 a2 + 1/(a1 a2) + a1 a3 + 1/(a1 a3) + a1 + 1/a1 + a3/a2 + a2/a3 + a2 + 1/a2 + a3 + 1/a3;
expr2 = z1/z2^2 + z2^2/z1 + z1/z3^2 + 1/(z2 z3) + z1^2/(z2 z3) + z2/(z1 z3) + z1 z2/z3 + z3/(z1 z2) + z1 z3/z2 + z2 z3 + z2 z3/z1^2 + z3^2/z1;

transformations = {a1 -> z1^a * z2^b * z3^c, a2 -> z1^d * z2^e * z3^f, a3 -> z1^g * z2^h * z3^i};

transformedExpr1 = expr1 /. transformations;

eq = Simplify[transformedExpr1 == expr2];

solution = Reduce[eq, {a, b, c, d, e, f, g, h, i}, Reals]

solution

This also did not seem to terminate. How can I solve this problem more efficiently? An ideal output would be some transformation:

{a1 -> z2*z3, a2 -> z1/z2, a3 -> z1/z3} or something like this.

Thank you very much.

Answer 1

I guess there is no easy way to tackle such problem in general. But in the try and error approach I will explain below, Mathematica will be of great help.

You want the change of variables (a1,a2,a3) and (z1,z2,z3) such that exponent vectors are related by a linear transformation with integral coefficients. So, following geometric approach is possible (probably you know Newton polytopes):

1. List up the exponent (3-dim) vectors.
2. Using these vectors as vertex coordinates, construct a convex polyhedron for each expression.
3. Compare the polytopes of those points and find a candidate 3d linear transformation.

Now, let's try.

expr1=a1 a2+1/(a1 a2)+a1 a3+1/(a1 a3)+a1+1/a1+a3/a2+a2/a3+a2+1/a2+a3+1/a3;
expr2=z1/z2^2+z2^2/z1+z1/z3^2+1/(z2 z3)+z1^2/(z2 z3)+z2/(z1  z3)+z1 z2/z3+z3/(z1 z2)+z1 z3/z2+z2 z3+z2 z3/z1^2+z3^2/z1;

Prepare a small tool expvec to obtain exponent vectors.

ClearAll[expvec];
expvec[f_, vars_List] := 
  Table[Exponent[term, v], {term, List @@ f}, {v, vars}];

v1 = expvec[expr1, {a1, a2, a3}]

(* {{-1,0,0},{1,0,0},{0,-1,0},{-1,-1,0},{0,1,0},{1,1,0},{0,0,-1},{-1,0,-1},{0,1,-1},{0,0,1},{1,0,1},{0,-1,1}}*)

v2=expvec[expr2,{z1,z2,z3}]

(* {{1,-2,0},{-1,2,0},{1,0,-2},{0,-1,-1},{2,-1,-1},{-1,1,-1},{1,1,-1},{-1,-1,1},{1,-1,1},{0,1,1},{-2,1,1},{-1,0,2}}*)

p1=ConvexHullRegion[v1]
(* Polyhedron[Number of points: 12 Number of faces: 14] *)

p2=ConvexHullRegion[v2]
(* Polyhedron[Number of points: 12 Number of faces: 14] *)

Graphics3D/@{p1,p2} 

These two polyhedra have the same number of vertices and faces, so there is a good chance of having linear equivalent polyhedra.

The faces consist of triangles and quadrilaterals. So, pick a triangle t1 from polyhedron p1, and similarly t2 from p2.

t1=p1[[1]][[SelectFirst[p1[[2]],Length[#]==3&]]]
(* {{0,-1,0},{0,0,-1},{1,0,0}} *)

t2=p2[[1]][[SelectFirst[p2[[2]],Length[#]==3&]]]
(* {{1,-1,1},{1,-2,0},{2,-1,-1}} *)

Let's compute the linear transformation P which sends the vertices of t1 to those of t2:

P=Inverse[t1].t2

(* {{2,-1,-1},{-1,1,-1},{-1,2,0}} *)

If you are lucky, this matrix P would realize the wanted change of variables.

change=Thread[{a1,a2,a3}->(Times@@Power[{z1,z2,z3},#]&/@P)]

(* {a1->z1^2/(z2 z3),a2->z2/(z1 z3),a3->z2^2/z1} *)

expr1/.change

(* z1/z2^2+z2^2/z1+z1/z3^2+1/(z2 z3)+z1^2/(z2 z3)+z2/(z1 z3)+(z1 z2)/z3+z3/(z1 z2)+(z1 z3)/z2+z2 z3+(z2 z3)/z1^2+z3^2/z1 *)

(expr1/.change)===expr2
(* True *)