Replace repeated items differently

Question

So I have a simple replacement rule of the following form:

expr/.f[a_,b_]:> g[a,#]g[b,#]&@func[]

i.e. I want to replace each function f[a,b] with two factorised functions g[a,#]g[b,#]. However, if f is repeated in expr, I would like it to run func[] again to refresh the values of #. A simple example is

list = {a1,a2,a3,a4,a5,a6,a7,a8};
$dummy = 1; (* Global variable *)
func[] := Module[{out},
  out = list[[1 + $dummy]];
  $dummy = $dummy + f;
  out[[1]]
  ] (* Spits out a new item from the list each time it's called, e.g. *)
func[]
func[]
(* Output *)
a1
a2
(* Testing gives )
expr = f[1,2];
expr/.f[a_,b_]:> g[a,#]g[b,#]&@func[]
( Output *)
g[1,a1]g[2,a1]

Now this works fine, but the problem is when I want to evaluate products, powers etc and assign different outputs of func[] for each f[a,b]. For example for expr = f[1,2]f[3,4] I get

(* Output *)
g[1,a1]g[2,a1]g[3,a1]g[4,a1]

whereas what I want is

(* Output *)
g[1,a1]g[2,a1]g[3,a2]g[4,a2]

I figured I might want to use ReplacePart[] or something, but maybe there is a slicker way to achieve what I want?

Answer 1

You can use Symbol and RuleDelayed with a CompoundExpression utilising Increment on your global variable.

With

$i = 0;
rule = f[a_, b_] :> ($i++; 
    g[a, #] g[b, #] &@Symbol["a" <> ToString@$i]);

Then

$i = 0;
f[1, 2] /. rule

g[1, a1] g[2, a1]

and

$i = 0;
f[1, 2] f[3, 4] /. rule

g[1, a1] g[2, a1] g[3, a2] g[4, a2]

and

$i = 0;
(f[1, 2]/f[3, 4]) f[5, 6] /. rule

(g[1, a1] g[2, a1] g[5, a3] g[6, a3])/(g[3, a2] g[4, a2])

Hope this helps.

Answer 2

As mentioned in Akoben's answer, the automatic gathering of products into Power can be a nuisance when making programs that use symbolic operations/rules that involve Times. One option is to use Inactive[Times] to split the power into products. Most of the function below can be found for example in this answer (the function stoppower below also replaces Times by Inactive[Times] everywhere in the expression to have a more homogeneous expression):

---

EDIT I noticed a maybe undesirable effect when using the code below.

s*r*r^2*xr // stoppower // InputForm

Inactive[Times][ Inactive[Times][r, r, r], s, xr]

that is, stoppower transforms s*r*r^2*xr to (r*r*r)*xr*s where (r*r*r) is Inactive[Times][r, r, r] above. This is because Inactive[Times] does not not seem to inherit the Flat attribute from Times. One may instead define a custom times:

ClearAll[times];
times = Diamond;
SetAttributes[Diamond, DeleteCases[Attributes[Times], Protected]];

and then use stoppower2 instead of stoppower:

stoppower2[x_] := 
 x /. Times -> times /. a_^b_ :> times @@ ConstantArray[a, b]

With the example below:

$i = 0;
rule = f[a_, b_] :> ($i++;
    g[a, #]*g[b, #] &@Symbol["a" <> ToString@$i]);
f[1, 2]^2f[3, 4] + 5h[ba, bb] // stoppower2 // ReplaceAll[rule] // 
 ReplaceAll[times -> Times]

The code for expand below also worked using stoppower2 instead of stoppower in the example provided for expand below.

End of edit

---

Previous version

stoppower[x_] := x /. Times -> Inactive@Times /. a_^b_ :> 
Inactive[Times] @@ ConstantArray[a, b]

Now there is no need to use a second rule, no need to use Product and no need to use Optional with f[a_, b_]^n_. (notice the . at the end of _ see comment by Lukas Lang below @Akoben's answer for further details on this pattern).

Example (using @Edmund 's answer):

$i = 0;
rule = f[a_, b_] :> ($i++;
   g[a, #] g[b, #] &@Symbol["a" <> ToString@$i]);
f[1, 2]^2 f[3, 4] + 5*h[ba, bb] // stoppower // ReplaceAll[rule] // Activate

Output: (* g[1, a1] g[1, a2] g[2, a1] g[2, a2] g[3, a3] g[4, a3] + 5 h[ba, bb] *)

---

In the light of the above example one might want to swap Times for Inactive[Times] and use Activate only when needed. One issue might be that Expand does not distribute Inactive[Times]. A possible solution might be to define a custom expand function using:

expand = Map[Distribute, #, Infinity] &

Example:

a^3*(g + u) + g*n*4*(j + bb*s) // stoppower // expand 

Answer 3

Just to add to @Edmunds fantastic answer, as a quick workaround to operate on powers

$i = 0;
rule = {f[a_, b_]^n_ :> Product[($i++;
      g[a, #] g[b, #] &@Symbol["a" <> ToString@$i]), {i, n}], 
   f[a_, b_] :> ($i++;
     g[a, #] g[b, #] &@Symbol["a" <> ToString@$i])};
f[1, 2]^2 f[3, 4] /. rule
g[1, a1] g[1, a2] g[2, a1] g[2, a2] g[3, a3] g[4, a3]