2
$\begingroup$

I'm working with a custom binary 'operation' $F$ which takes $x, y$ and produces $F[x, y]$, where the possible arguments are already given by some list $\{ \text{one}, a, b, c, d, x, y, e, f\}$ where $\text{one}, x, y$ are ‘special’ as they have simplification rules given below. I need to deal with ‘monomial’ expressions like

F[b, F[x, F[x, F[x, F[y, F[y, F[e, e]]]]]]]

In general, I can encounter linear combinations of these ‘monomial’ expressions, but the coefficients may be symbolic (assuming a valid coefficient is any expression not appearing in the earlier list of variables). For instance I can encounter the expression

2*m*F[a, F[x, y]] - 10*m^2*F[d, F[x, F[f, f]]]

I need to implement the following simplification rules:

  • $F[x, y]$ and $F[y, x]$ each simplify to $\text{one}$.
  • Both $F[\text{one}, z]$ and $F[z, \text{one}]$ simplify to $z$, where $z$ is some larger expression.
  • If $x, y$ appear next to one another as arguments in these nested expressions, they can be eliminated. For instance $F[a, F[x, F[y, e]]]$ has an $x$ and $y$ 'next to' one another, so will simplify to $F[a, e]$.

Work so far

My attempt involves taking a monomial expression like $F[b, F[x, F[x, F[x, F[y, F[y, F[e, e]]]]]]]$, extracting the arguments to a list $\{b, x, x, x, y, y, e, e\}$, counting the pairs and then removing them to be left with ${b, x, e, e}$. Then I take this list and recreate the expression $F[b, F[x, F[e, e]]]$.

My code is below – I'm not attached to it if someone has a better approach. Also I’m not a coder and fairly new to Mathematica so please excuse any messiness/clumsiness in my code.

FLoop[2,myArgs_]:=F[myArgs[[Length[myArgs]-1]], myArgs[[Length[myArgs]]]];

FLoop[loopLevel_,myArgs_]:=F[myArgs[[Length[myArgs]-loopLevel+1]], FLoop[loopLevel-1, myArgs]];

ExtractArgumentStep[expr_, list_,0]:=list~Join~{ expr }

ExtractArgumentStep[expr_, list_, checkMore_]:=ExtractArgumentStep[expr[[2]],list~Join~{ expr[[1]]}, Length[expr[[2]]]]

ExtractArguments[expr_]:=Module[{arguments},
  If[Length[expr[[2]]]==0,
   arguments={ expr[[1]], expr[[2]]},
   ExtractArgumentStep[expr, {},Length[expr[[2]]]]
   ]
  ]

RemoveCancellingPairs[field_, field1_, field2_] := Module[
  {fieldArguments, numFirstField, numSecondField, numPairs, 
   newfieldArguments, newField},
  fieldArguments = ExtractArguments[field];
  numFirstField = Count[fieldArguments, field1];
  numSecondField = Count[fieldArguments, field2];
  numPairs = Min[numFirstField, numSecondField];
  newfieldArguments = 
   DeleteElements[
    fieldArguments, {numPairs, numPairs} -> {field1, field2}];
  If[Length[newfieldArguments] == 0,
   newField = One,
   If[Length[newfieldArguments] == 1,
    newField = newfieldArguments[[1]],
    newField = NOLoop[Length[newfieldArguments], newfieldArguments]
    ]
   ]
  ]

testExpr1=F[b, F[x, F[x, F[x, F[y, F[y, F[e, e]]]]]]];
RemoveCancellingPairs[testExpr1, x, y]

testExpr2=2*m*a - 10*m^2*F[d, F[x, F[f, f]]]
RemoveCancellingPairs[testExpr2, x, y]

Current Issue

The issue is this code only works for monomial expressions. For instance testExpr1 seems to work, but testExpr2 does not due to the sum and 'coefficients'. If I have linear combinations, it fails. For instance testExpr2 should simplify to

2*m*a - 10*m^2*F[d, F[x, F[f, f]]]

This is exactly the result of taking

2*m*F[a, F[x, y]] - 10*m^2*F[d, F[x, F[f, f]]]

and applying the simplification rules to the 'monomials' F[a, F[x, y]] and F[d, F[x, F[f, f]]].

Currently I’m unsure how to make my function ‘symbol-linear’ in the first argument so it distributes over addition and ignores factors like 2m and 10m^2. Alternatively if that is difficult to fix, I'm also interested in alternative ways to implementing these simplification rules.

$\endgroup$
8
  • $\begingroup$ Please edit the question to limit it to a specific problem with enough detail to identify an adequate answer. $\endgroup$
    – Community Bot
    Dec 26, 2023 at 12:12
  • $\begingroup$ I'm not really sure how to make it more specific, and don't want the question getting any longer. I've added in another test case to help identify an appropriate answer. $\endgroup$ Dec 26, 2023 at 12:22
  • $\begingroup$ Welcome to Mathematica StackExchange! You seem to be making this very complicated and not using the powers of pattern-matching in Mathematica. For example: you can just define the appropriate patterns: Clear[F]; F[x, y] = one; F[y, x] = one; F[one, z_] := z; F[z_, one] := z; F[x, F[y, e]] = e; $\endgroup$
    – Domen
    Dec 26, 2023 at 13:09
  • $\begingroup$ What should be the result of simplifying testExpr2? $\endgroup$
    – Domen
    Dec 26, 2023 at 13:46
  • $\begingroup$ @Domen Edited to make it clearer. $\endgroup$ Dec 26, 2023 at 13:49

3 Answers 3

3
$\begingroup$

You are probably coming from some other programming language and you are not taking into account the power of patterns and transformations in Mathematica (see also this elementary introduction to patterns).

You can approach this in two ways. Either write down the definitions for F, which will automatically simplify any expression containing Fs:

Clear[F];
F[x, y] = one;
F[y, x] = one;
F[one, z_] := z;
F[z_, one] := z;
F[x, F[y, e_]] := e;
F[y, F[x, e_]] := e;

2*m*F[a, F[x, y]] - 10*m^2*F[d, F[x, F[f, f]]]
(* 2 a m - 10 m^2 F[d, F[x, F[f, f]]] *)

F[b, F[x, F[x, F[x, F[y, F[y, F[e, e]]]]]]]
(* F[b, F[x, F[e, e]]] *)

Alternatively, if you want to make simplifications only at certain places, you can define transformation rules, and use ReplaceAll or ReplaceRepeated:

Clear[F];
rules = {
   F[x, y] -> one,
   F[y, x] -> one,
   F[one, z_] :> z,
   F[z_, one] :> z,
   F[x, F[y, e_]] :> e,
   F[y, F[x, e_]] :> e,
   };

2*m*F[a, F[x, y]] - 10*m^2*F[d, F[x, F[f, f]]] //. rules
(* 2 a m - 10 m^2 F[d, F[x, F[f, f]]] *)

F[b, F[x, F[x, F[x, F[y, F[y, F[e, e]]]]]]] //. rules
(* F[b, F[x, F[e, e]]] *)
$\endgroup$
5
  • $\begingroup$ I think pattern matching helps me implement rules 1, 2 more easily than my initial attempt (as you've shown here). However I think rule 3 still poses an issue. For instance every pair of $x, y$ in an arbitrary nested expression should be removed, which means I can't just list out F[x, F[y, e]] = e. Apologies, this may not have been sufficiently clear. $\endgroup$ Dec 26, 2023 at 13:58
  • $\begingroup$ For instance my first example is testExpr1=F[b, F[x, F[x, F[x, F[y, F[y, F[e, e]]]]]]] and this should simplify to F[b,F[x,F[e,e]]]. Similarly any arbitrary nested expression should remove all $x, y$ pairs in this way. Syed's answer achieves this in a more efficient way for testExpr1 than my attempt, but doesn't seem to work for linear combinations like testExpr2. $\endgroup$ Dec 26, 2023 at 14:00
  • $\begingroup$ @VertexVexed, please look at my update. $\endgroup$
    – Domen
    Dec 26, 2023 at 14:08
  • $\begingroup$ Ah fantastic, thanks Domen! I think I want a slightly modified version of this, for instance with F[a_, F[x, F[y, e_]]] = F[a, e]; rather than F[x, F[y, e_]] :> e in case the $x, y$ pair appear midway through an expression. However this seems to work wonderfully. I'll read the intro to patterns link now. I'll be using mathematica more in the future, and clearly it has some useful features I'm unfamiliar with. Thank you for being patience! :) $\endgroup$ Dec 26, 2023 at 14:14
  • $\begingroup$ Ah I just realized your expression is a sub-expression of mine anyway, so what you have covers my case anyway. Thanks again! $\endgroup$ Dec 27, 2023 at 0:01
3
$\begingroup$

EDIT (to incorporate the linear combinations)

Clear[convert]
convert[F[args__]] := Module[{xin, x2},
  xin = Flatten[F[args] /. F :> List];
  (*Echo[xin];*)
  x2 = xin //. {g___, OrderlessPatternSequence[x, y], h___} -> {g, h};
  (*Echo[x2];*)
  If[Length@x2 == 1, First@x2, Fold[F[#2, #1] &, Reverse@x2]]
  ]

testexpr1 = 2*m*F[a, F[x, y]] - 10*m^2*F[d, F[x, F[f, f]]];
testexpr2 = F[b, F[x, F[x, F[x, F[y, F[y, F[e, e]]]]]]];

testexpr1 /. F[x__] :> convert[F[x]]
testexpr2 /. F[x__] :> convert[F[x]]

2 a m - 10 m^2 F[d, F[x, F[f, f]]]

F[b, F[x, F[e, e]]]

Original

Here is my attempt at a solution, assuming that I have understood this correctly:

Clear["Global`*"];
testExpr = F[b, F[x, F[x, F[x, F[y, F[y, F[e, e]]]]]]];
xin = Flatten[testExpr /. F :> List]

{b, x, x, x, y, y, e, e}

x2 = xin //. {g___, OrderlessPatternSequence[x, y], h___} -> {g, h}

{b, x, e, e}

Fold[F[#2, #1] &, Reverse@x2]

F[b, F[x, F[e, e]]]

$\endgroup$
2
  • $\begingroup$ This is a great simplification! I'll sit down and try to unpack what you've done now. However I think this also gets stuck on 'linearity', like my attempt. This works on monomial expressions like testExpr1, but not sums like testExpr2 in my question, where the simplification should be applied individually to the $F[a, F[x, y]]$ and $F[d, F[x, F[f, f]]]$ terms. I'll try and edit my question to make this clearer. $\endgroup$ Dec 26, 2023 at 13:35
  • $\begingroup$ I have updated the answer. Thanks for the additional explanation. $\endgroup$
    – Syed
    Dec 26, 2023 at 14:27
2
$\begingroup$

We may define rules to achieve what you want:

rules = {"*" -> " ", F[x, y] -> one, F[y, x] -> one, F[z__, one] -> z,
    F[one, z__] -> z, F[q__, F[x, F[y, w__]]] -> F[q, w]};

With this we get for your test cases:

testExpr1 = F[b, F[x, F[x, F[x, F[y, F[y, F[e, e]]]]]]];
testExpr2 = 2*m*a - 10*m^2*F[d, F[x, F[f, f]]];

testExpr1 /. rules
testExpr2 /. rules

F[b, F[x, F[x, F[y, F[e, e]]]]]
2 a m - 10 m^2 F[d, F[x, F[f, f]]]
$\endgroup$
2
  • 1
    $\begingroup$ Why would space vs asterisk for ordinary multiplication make any difference for the task at hand? $\endgroup$ Dec 26, 2023 at 18:16
  • 1
    $\begingroup$ @ Daniel Lichtblau Maybe I fooled myself, but when I tried the rules on test cases, it did not work with asteriks. $\endgroup$ Dec 26, 2023 at 20:09

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.