2
$\begingroup$

I have some multivariate systems of expressions that I want to check for equality up to allowing relabelling of the variables. For example the two expressions below would be the same:

ex1={x*y*z, x*y/v, v, y, y/v}
ex2={a*b*z, z*b/u, u, b, b/u}

Ideally I also want to allow for setting a variable to 0 as well:

ex1={x*y*z, x*y/v, v, y, y/v, p}
ex2={a*b*z, z*b/u, u, b, b/u, 0}

But these two would not be equal

ex1={x*y*z, x*y/v, v, y, y/v, p,0}
ex2={a*b*z, z*b/u, u, b, b/u, 0,q}

How can I recognize this kind of equality up to variable relabeling and zeroing?

$\endgroup$
4
  • $\begingroup$ This is the textbook use of Function if I understood what you mean. For example: ex1={#1*#2*#3, #1*#2/#4, #4, #2, #2/#4}& $\endgroup$
    – polfosol
    Nov 21, 2021 at 17:47
  • $\begingroup$ How do I then check for equality of that kind of expression? For example: ex1 = {#1*#2*#3, #1*#2/#4, #4, #2, #2/#4} &; ex2 = {#4*#3*#2, #4*#3/#1, #1, #3, #3/#1} &; SameQ[ex1, ex2] (*False*) But I want this to evaluate True $\endgroup$
    – David
    Nov 21, 2021 at 18:08
  • $\begingroup$ Simply define a function as ex={#1*#2*#3, #1*#2/#4, #4, #2, #2/#4, #5}& and check if ex1==ex@@{x,y,z,v,p} && ex2==ex@@{a,b,z,u,0} $\endgroup$
    – polfosol
    Nov 21, 2021 at 18:18
  • $\begingroup$ Those evaluate as false for me $\endgroup$
    – David
    Nov 21, 2021 at 22:04

2 Answers 2

4
$\begingroup$

This is a very naive approach by generating all possible relabelings. Function findIsomorphism returns one of the possible relabelings or False if none is found.

getSymbols[m_] := DeleteDuplicates@Cases[m, _Symbol, Infinity];

findIsomorphism[ex1_, ex2_] := Module[{sym1, sym2, perms, eq},
  sym1 = getSymbols[ex1];
  sym2 = getSymbols[ex2];
  
  If[Length@sym1 != Length@sym2, Return[False]];
  
  perms = MapThread[#1 -> #2 &, {sym1, #}] & /@ Permutations[sym2];
  
  eq = ((ex1 /. #) === ex2) & /@ perms;
  
  If[NoneTrue[eq, TrueQ], False, First@perms[[FirstPosition[eq, True]]]]
]

findIsomorphism[{x, y}, {a, b}]
(* {x -> a, y -> b} *)

findIsomorphism[{x + y, z}, {a - b, c}]
(* False *)

findIsomorphism[{x*y*z, x*y/v, v, y, y/v}, {a*b*z, z*b/u, u, b, b/u}]
(* {x -> z, y -> b, z -> a, v -> u} *)

To allow for the variables being 0, we can include 0 as a "dummy" variable.

findIsomorphismAllowZero[ex1_, ex2_] := 
 Module[{sym1, sym2, perms, eq, exx1, exx2},
  sym1 = getSymbols[ex1];
  sym2 = getSymbols[ex2];
  
  If[Length@sym1 < Length@sym2,
   {sym1, sym2} = {sym2, sym1}; {exx1, exx2} = {ex2, ex1},
   {exx1, exx2} = {ex1, ex2}
   ];
  
  perms = 
   MapThread[#1 -> #2 &, {sym1, #}] & /@ 
    Permutations[
     sym2~Join~ConstantArray[0, Length@sym1], {Length@sym1}];
  
  eq = ((exx1 /. #) === exx2) & /@ perms;
  
  If[NoneTrue[eq, TrueQ], False, First@perms[[FirstPosition[eq, True]]]]
]

findIsomorphismAllowZero[{x, y}, {a, 0}]
(* {x -> a, y -> 0} *)

findIsomorphismAllowZero[{0, x}, {a, b}]
(* {a -> 0, b -> x} *)

findIsomorphismAllowZero[{x, y}, {a + b, c}]
(* {a -> x, b -> 0, c -> y} *)

Quiet@findIsomorphismAllowZero[{x*y*z, x*y/v, v, y, y/v, p}, {a*b*z, 
   z*b/u, u, b, b/u, 0}]
(* {x -> z, y -> b, z -> a, v -> u, p -> 0} *)
$\endgroup$
7
  • $\begingroup$ This is probably too computationally intensive for my purposes as I am going to repeat this many times $\endgroup$
    – David
    Nov 21, 2021 at 22:04
  • 1
    $\begingroup$ Have you tried it and measure the timing? It takes 30 ms for the last case on my laptop. What is the performance goal you want to reach? $\endgroup$
    – Domen
    Nov 22, 2021 at 11:25
  • $\begingroup$ I just did some testing and it's more efficient than I thought it would be $\endgroup$
    – David
    Nov 22, 2021 at 17:18
  • $\begingroup$ This does work however when the number of variables grows the number permutations grows too fast for this to be practical in my case (~20 variables in each expression) $\endgroup$
    – David
    Nov 22, 2021 at 18:12
  • 1
    $\begingroup$ @David, you are absolutely right. You had four variables in your initial question, so I did not think you needed a solution for up to 20 (or even more?). I guess the code could be optimized to generate permutations on each of the term in a list separately. This would help if not all 20 of them appear in the same element. $\endgroup$
    – Domen
    Nov 22, 2021 at 19:01
1
$\begingroup$

We can Replace the leaves of an expression with Patterns and use the resulting patterns with MatchQ:

ClearAll[exprToPattern, isomorphicExpressionsQ]

exprToPattern = Replace[
       Replace[#, $s_Symbol :> pattern[$s, Blank[]], {-1}],
    {p : pattern[_, Blank[]] :> (p | _?NumericQ), 
     p_?NumericQ :> (p | _)}, 1] /. pattern -> Pattern &;

isomorphicExpressionsQ = MatchQ[exprToPattern@#] @ #2 && MatchQ[exprToPattern@#2] @ #1 &;

Examples:

exa1 = {x*y*z, x*y/v, v, y, y/v}
exa2 = {a*b*z, z*b/u, u, b, b/u}

isomorphicExpressionsQ[exa1, exa2]
True
exb1 = {x*y*z, x*y/v, v, y, y/v, p}
exb2 = {a*b*z, z*b/u, u, b, b/u, 0}
exb3 = {a*b*z, z*b/u, u, b, b/u, q + 3}

isomorphicExpressionsQ @@@ Subsets[{exb1, exb2, exb3}, {2}]
{True, False, False}
exc1 = {x*y*z, x*y/v, v, y, y/v, p, 0}
exc2 = {a*b*z, z*b/u, u, b, b/u, 0, q}
exc3 = {a*b*z, z*b/u, u, b, b/u, 0, q + 3}

isomorphicExpressionsQ @@@ Subsets[{exc1, exc2, exc3}, {2}]
{True, False, False}
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.