How to identify patterns in a tensor-polynomial and replace appropriate symbol?

Question

I want to write a function tensorReplace[input] that takes a tensor polynomial in $r_i$ such as $r_i r_j r_k+r_i q_j q_k +q_i q_j q_k$ , and replaces each monomial with a function f[{idx}] using the rule $r_i\rightarrow f(\{i\})$, $r_i r_j\rightarrow f(\{i,j\})$, etc. leaving the $q$'s and another other symbols untouched.

So for in the example above, if my input is $$r_i r_j r_k+r_i q_j q_k +q_i q_j q_k\,,$$ I am shooting for an output

$$f(\{i,j,k\})+f(\{i\})q_i q_j+q_i q_j q_k\,.$$

I also need to allow the possibility where a vector with same index is squared (repeated in a monomial) given the obvious $r_i^2\rightarrow f(\{i,i\})$.

I don't know how to even begin, because my input could be an arbitrarily high order polynomial in $r$, with many terms.

Answer 1

Since you're talking about polynomials, it's only natural to try and solve this using the built-in functions for extracting polynomial coefficients and variables. It leads to this:

replaceR[poly_, name_, replacementName_] := 
 Module[{vars = Cases[Variables[poly], name[_]]}, 
  Apply[Plus, 
   CoefficientRules[poly, vars] /. 
    Rule[expo_, coeff_] :> 
     coeff replacementName[
       Inner[Table[#[[1]], {#2}] &, vars, expo, Join]]]]

replaceR[4 q[i] r[h]^2 + 2 r[i] r[j] r[k], r, f]

2 f[{i,j,k}]+4 f[{h,h}] q[i]

The first argument is the polynomial, the second the name to be replaced (r in your question), and the third argument is the name of the function you called f. First, I use Variables and select the ones that are of the form r[_]; then CoefficientRules gives us the powers of all the variables with their coefficients, in a simple list that can be rewritten one monomial at a time into a new form involving f[{...}].

The special case of a constant in the polynomial leads to a corresponding empty function,

replaceR[1, r, f]

f[{}]

I think that's consistent, but if you don't like it one can always append a replacement rule like /. f[{}] :> 1. The use of polynomial manipulation functions makes it possible in principle to input the polynomial in non-expanded form, too.

Answer 2

My interpretation:

start = r[i] r[j] r[k] + r[i] q[j] q[k] + q[i] q[j] q[k];

start /. r[x_]^y_ :> r @@ Table[x, {y}] //. r[a__] r[b_] :> r[a, b] /. r[x__] :> f[{x}]

f[{i, j, k}] + f[{i}] q[j] q[k] + q[i] q[j] q[k]

Answer 3

(r@i r@j r@k 2 + 4 q@i r@h r@h) /. x_ :> Sort /@ x /. PatternSequence[(r@x_) ..] :> f@{x} 
                   //.  f[{x_}] f[{y__}] :> f[{x, y}] //. f[{s__}]^n_ :> f[Array[s &, n]]

(*
2 f[{k, i, j}] + 4 f[{h, h}] q[i]
*)

Edit

as a function:

tensorRepl[i_, r_, f_] := i /. x_ :> Sort /@ x /. PatternSequence[(r@x_) ..] :> f@{x} //. 
                         f[{x_}] f[{y__}] :> f[{x, y}] //. f[{s__}]^n_ :> f[Array[s &, n]]

tensorRepl[(r@i r@j r@k 2 + 4 q@i r@h r@h), r, f]
(*
2 f[{k, i, j}] + 4 f[{h, h}] q[i]
*)