# Find the smallest subexpression containing all subexpressions matching a given pattern

I need to write a function that, given an expression like

1/x + 1/(Abs[x] + 1/(1 + Abs[y - Abs[x]]))


finds all its subexpressions matching a certain pattern (say, _Abs) and then returns the smallest subexpression containing all of those occurrences. In this example, there are 3 subexpressions matching the pattern (2 of them are identical, but we need to include both of them): Abs[x], Abs[x], Abs[y - Abs[x]], so the smallest subexpression containing all of them is Abs[x] + 1/(1 + Abs[y - Abs[x]]).

A more precise definition: An expression containing all occurrences matching a given pattern is the smallest if it does not contain a proper subexpression that already contains all of the occurrences. For example, 1/(Abs[x] + 1/(1 + Abs[y - Abs[x]])) is not the smallest, because it contains a proper subexpression Abs[x] + 1/(1 + Abs[y - Abs[x]]) that already contains all 3 occurrences.

What is the best way to solve this problem?

• Union@ Level[expr, Infinity] will give you all the distinct subexpressions. Cases[expr, _Abs, All] will give you the instances to look for. After that it's a question of some tedious pattern matching, I think. Commented Jul 25, 2022 at 21:25

The following should be reasonably efficient:

expr = 1/x + 1/(Abs[x] + 1/(1 + Abs[y - Abs[x]]));
Position[expr,_Abs]/.
{{Longest[pos___],___}...}:>
Extract[expr,{pos}]


This works by first getting the position of all occurrences of the pattern (here _Abs). The smallest subexpression containing all of them is then given by the longest common prefix of the positions, which is exactly what we identify using the pattern in the ReplaceAll call. Finally, we extract the relevant subexpression.

With your expressions, first extract the terms you seek using Cases:

expr = 1/x + 1/(Abs[x] + 1/(1 + Abs[y - Abs[x]]));

cases = Cases[expr, _Abs, Infinity]
(* Out: {Abs[x], Abs[x], Abs[y - Abs[x]]} *)


Then generate a list of unique subexpressions of your expression at all levels, using Level and Union to get a sorted duplicate-free list:

subexpressions = Union@Level[expr, Infinity]
(* Out:
{-1, 1, 1/x, x, y, y - Abs[x], -Abs[x], Abs[x], Abs[y - Abs[x]],
1/(1 + Abs[y - Abs[x]]), 1 + Abs[y - Abs[x]],
1/(Abs[x] + 1/(1 + Abs[y - Abs[x]])), Abs[x] + 1/(1 + Abs[y - Abs[x]])} *)


Now 1) group your expressions by the types of Abs subexpressions they contain (GroupBy by the output of Cases on each subexpression); 2) from the resulting association, extract the entry that contains all the desired cases by using the association[key] syntax; 3) take the shortest of the subexpressions returned, here defined as the one with the minimal LeafCount:

MinimalBy[LeafCount]@
GroupBy[subexpressions, Cases[#, _Abs, Infinity]&][cases]
(* Out: {Abs[x] + 1/(1 + Abs[y - Abs[x]])} *)