Checking if one partition is a subpartition of another

Question

Say I've got two partitions of a list (not necessarily containing numbers, and not necessarily distinct), and I want to check that one is a subpartition of the other. Let's look at some examples:

list = {1, 2, 3, 4, 5, 6};
p1 = {{1,   2,   3}, {4,   5,   6}};
p2 = {{1}, {2,   3}, {4,   5}, {6}};
p3 = {{1,   2}, {3,   4}, {5,   6}};

subpartitionQ[p1, p2] (* True *)
subpartitionQ[p1, p3] (* False *)

The second is a subpartition of the first in that the first can be formed by joining some consecutive subsets of the second back together. Note that this is not possible with p3: this one contains 3 and 4 in the same sublist, whereas p1 doesn't, so I can't recover p1 merely by joining consecutive sublists.

Note that I also can't check whether all lists of pn are subsets of some sublist of p1, because the elements aren't necessarily distinct. E.g. list could also have been {1, 1, 1, 1, 1, 1}. This is only about the structure of the partitions.

Of course I could get all partitions of pn, join each segment together and check if one of them is equal to p1 but that seems horribly inefficient and inelegant. Are there better ways to solve this?

Answer 1

Sometimes you just need to think about it for 5 more minutes... I just found a solution myself which I think is fairly elegant:

subpartitionQ[p1_,p2_] := SubsetQ[Accumulate[Length /@ p2], Accumulate[Length /@ p1]]

The idea is to check that the lengths of the subpartition need to sum to all the lengths in the superpartition at some point. The preprocessing step Accumulate[Length /@ pn] turns the three partitions from the question into

{3, 6}
{1, 3, 5, 6}
{2, 4, 6}

respectively. We can now see that the 3 from p1 is missing in p3 which indicates that this is not a subpartition, whereas p2 contains both 3 and 6.

If someone has a better solution, I'd still be very interested!

Answer 2

Using the function CoarserSetPartitionQ from the Combinatorica package with a function that numbers elements consecutively while keeping the structure of a nested list (see, e.g., this):

numbering[x_]:= Block[{n = 0}, Map[++n &, x, {-1}]]

Needs["Combinatorica`"]
refinementQ = With[{a = numbering@#, b= numbering@#2}, CoarserSetPartitionQ[b, a]] &;

Examples:

list = {1, 2, 3, 4, 5, 6};
p1 = {{1, 2, 3}, {4, 5, 6}};
p2 = {{1}, {2, 3}, {4, 5}, {6}};
p3 = {{1, 2}, {3, 4}, {5, 6}};
{p1b, p2b, p3b} = Map[1 &, #, {-1}] & /@ {p1, p2, p3}
(* {{{1, 1, 1}, {1, 1, 1}}, {{1}, {1, 1}, {1, 1}, {1}}, {{1, 1}, {1, 1}, {1, 1}}}*)

refinementQ @@@ {{p1, p2}, {p1, p3}, {p1b, p2b}, {p1b, p3b}}
(* {True, False, True, False} *)