Selective replacements

I would like to replace parts of the expression, with variables p and p, that are invariant under inversion p <-> p. Namely I would like to replace p * p as pro, and p + p as sum.

exp = x /. Solve[{
x == 2 p p + p q (2 + x) + q (1 + y),
y == 2 p p + q p (2 + y) + q (1 + x)},
{x, y}][] /. q[i_] :> 1 - p[i] // Simplify

This is nearly there, but for this expression specifically. Although I think my goal is posed loosely, my question is: how would I go about this in a convenient way?

MapAt[ExpandAll
, exp, {2}] //. {p^a_.*p^a_. :> pro^a, b_.*p + b_.*p :> b*sum}
• Shouldn't p^2 p be p pro? – Kuba Oct 25 '17 at 12:18
• @Kuba Yes, hence nearly. Ok, I see I can replace general pattern p^a_.*p^b_. correctly. Can I do without prior ExpandAll selective mapping? – BoLe Oct 25 '17 at 12:23
• Eliminate[ {exp == 0, pro == p p, sum == p + p}, {p, p}] – Kuba Oct 25 '17 at 12:25
• @Kuba No, not what I would like to have. The expression is not totally invariant, I'd like to replace just the invariant parts and see what is left that is not invariant ... I can do it by hand quickly. – BoLe Oct 25 '17 at 12:30

You could use Simplify/FullSimplify with ComplexityFunction to indicate the correctness of the output.

t1[e_] := ReplacePart[e, RandomChoice[Position[e, p]] -> pro/p]
t2[e_] := ReplacePart[e, RandomChoice[Position[e, p]] -> pro/p]
t3[e_] := ReplacePart[e, RandomChoice[Position[e, p]] -> sum - p]
t4[e_] := ReplacePart[e, RandomChoice[Position[e, p]] -> sum - p]

FullSimplify[exp, TransformationFunctions -> {t1, t2, t3, t4, Automatic},
ComplexityFunction -> (LeafCount[#] + Length[Position[#, p | p]] &)]

$\frac{(p(1)-1) \text{pro}+2}{\text{pro} (\text{pro}-\text{sum}+2)}$

Maybe multiply the second term of the complexity function by more than 1.

• This is sort of amazing. Also works: -> RandomChoice[{pro/p, sum - p}]], halving the number of t's. – BoLe Oct 26 '17 at 12:52