# Partition a random sequence composed of three numbers

I want to partition an array composed of 1s, 2s and 3s in such a way that, going from left to right, each bin (1) contains all three numbers and (2) is as short as possible.

Some examples:

{1, 1, 1} -> {}

{1, 3, 2, 1} -> {1, 3, 2}

{1, 1, 2, 3, 3, 3, 1, 2, 1} -> {{1, 1, 2, 3}, {3, 3, 1, 2}}

{1, 2, 3, 1, 1, 2, 2, 3, 3, 2, 2, 3, 1, 1} -> {{1, 2, 3}, {1, 1, 2, 2, 3}, {3, 2, 2, 3, 1}}


I tried many variations with SequenceCases and similar functions but didn't even come close.

splitByUnion =  Module[{u = {}}, # -> Select[Union @ # === Range @ 3 &] @
Split[#, x |-> Or[(u = Union[u, {x}]) != Range[3], u = {};]]] &;


Examples:

lists = {{1, 1, 1}, {1, 3, 2, 1}, {1, 1, 2, 3, 3, 3, 1, 2, 1},
{1, 2, 3, 1, 1, 2, 2, 3, 3, 2, 2, 3, 1, 1}};

splitByUnion /@ lists // Column


sequenceSplitByUnion = # -> Select[Union @ # === Range[3] &] @
SequenceSplit[#, {x : Shortest[__]} /; Union[{x}] == Range[3] :> {x}] &;


Examples:

Map[sequenceSplitByUnion]@lists === Map[splitByUnion]@lists

 True

• The code with SequenceSplit does not seem to work on 13.0.1.0. It outputs unchanged input. What has changed in latest version? Sep 3, 2023 at 16:41
• @azerbajdzan, I don't know what has changed since version 13.0.1.0. Documentation does not mention any updates to SequenceSplit since its introduction.
– kglr
Sep 3, 2023 at 16:58
• It does not have to be change in SequenceSplit maybe somewhere else like for example in Shortest. Sep 3, 2023 at 17:11
• very good point.
– kglr
Sep 3, 2023 at 17:15

We may scan "list" and add its elements to a temporary list "tmp" until "tmp" fulfills the conditions. Then we store "tmp" and start over. For an example, we first create a random list:

Random[1];
list = RandomChoice[{1, 2, 3}, 15]

{3, 1, 1, 2, 2, 1, 1, 2, 1, 3, 1, 2, 2, 3, 3}


Then we proceed as explained above:

tmp = {};
Reap[
(AppendTo[tmp, #];
If[MemberQ[#, 1] && MemberQ[#, 2] && MemberQ[#, 3] &[tmp],
Sow[tmp]; tmp = {}]
) & /@ list
][[2, 1]]

{{3, 1, 1, 2}, {2, 1, 1, 2, 1, 3}, {1, 2, 2, 3}}


A fancy way:

SpecialPartition[list_] :=
MapAt[If[ContainsAll[#, {1, 2, 3}], #, Nothing] &, -1]@
FoldPair[
If[
ContainsAll[Last[#1], {1, 2, 3}],
{Null, Append[#1, {#2}]},
{Null, Insert[#1, #2, {-1, -1}]}] &,
{{}},
list,
Last]


A non-fancy way:

list = {1, 2, 3, 1, 1, 2, 2, 3, 3, 2, 2, 3, 1, 1};
parts = {}; temp = {};
n = 3;
While[n <= Length[list],
temp = list[[1 ;; n]];
If[Length[Union[temp]] == 3, {
parts = Append[parts, temp],
list = Drop[list, n];
n = 2};
]; n++]

parts
(* {{1, 2, 3}, {1, 1, 2, 2, 3}, {3, 2, 2, 3, 1}} *)
$$$$


It can be done using SequenceCases in one-liner SequenceCases[r, {x__, y_} /;FreeQ[{x},y]\[And] {x, y} \[Intersection] {1, 2, 3} == {1, 2, 3}] but "good old" For overcomes it in performance 452 times (7.0625/0.015625=452.) for list of length only 1000.

r = RandomChoice[{1, 2, 3}, 1000];
vys1 = SequenceCases[
r, {x__, y_} /;
FreeQ[{x},
y] \[And] {x, y} \[Intersection] {1, 2, 3} == {1, 2, 3}] //
Timing;
vys1[[1]]
a = False; b = False; c = False;
s = 1;
vys2 = {};
For[i = 1, i <= Length[r], i++,
Which[r[[i]] == 1, a = True, r[[i]] == 2, b = True, True, c = True];
If[a \[And] b \[And] c, a = False; b = False; c = False;
AppendTo[vys2, r[[s ;; i]]]; s = i + 1;]
] // Timing
vys1[[2]] == vys2

Clear[r, a, b, c, s, vys1, vys2, i]

(* 7.0625 *)
(* {0.015625, Null} *)
(* True *)


You could try something like this:

SpecialPartition[list_] := SpecialPartition[{{}}, list];
SpecialPartition[groups_, {}] := Select[groups, ContainsAll[{1, 2, 3}]];
SpecialPartition[{previousGroups___, currentGroup_}, list : {next_, ___}] :=
If[
ContainsAll[currentGroup, {1, 2, 3}],
SpecialPartition[{previousGroups, currentGroup, {}}, list],
SpecialPartition[{previousGroups, Append[currentGroup, next]}, Rest@list]]


This is slightly different than your requirements in that

SpecialPartition[{1, 3, 2, 1}]


gives

{{1, 3, 2}}


which is more idiomatic for Wolfram Language functions.

I feel like needing ContainsAll twice is sub-optimal, but I haven't tried to streamline it.

Update

I went ahead and removed the redundancy, by changing the terminal case:

SpecialPartition[{previousGroups___, currentGroup_}, {}] :=
If[
ContainsAll[currentGroup, {1, 2, 3}],
{previousGroups, currentGroup},
{previousGroups}]


Using ReplaceList:

Clear["Global*"];
elems = {1, 2, 3};
lists = {{1, 1, 1}, {1, 3, 2, 1}, {1, 1, 2, 3, 3, 3, 1, 2, 1}, {1, 2,
3, 1, 1, 2, 2, 3, 3, 2, 2, 3, 1, 1}};

allinPartition[k_List, elems_List] := NestWhileList[
ReplaceList[
Last@#
, {a__, b___} /; Union[{a}] == elems :> Sequence[{a}, {b}]
, 1] &
, {{}, k}
, # != {} &
] //
Rest //
Replace[#, {} -> Nothing, {1}] & // #[[All, 1]] &


Usage:

{#, allinPartition[#, elems]} & /@ lists //
Grid[#, Alignment -> Left, ItemSize -> {{24, 24}, {1}}] &


\$Version


13.3.0 for Mac OS X ARM (64-bit) (June 3, 2023)

RepeatedTimings of

list = RandomChoice[{1, 2, 3}, 10^5]


f=TakeDrop[Last@#,MinMax@PositionIndex[Last@#][[All,1]]]&;

f@{lst5}

(* {{1,2,3},{1,1,2,2,3,3,2,2,3,1,1,2,2,2,2,3}} *)


Combining with NestWhileList:

NestWhileList[f,{lst1},Length@Union@#[[-1]]>2&,1,100][[2;;]][[All,1]]

NestWhileList[f,{lst2},Length@Union@#[[-1]]>2&,1,100][[2;;]][[All,1]]

NestWhileList[f,{lst3},Length@Union@#[[-1]]>2&,1,100][[2;;]][[All,1]]

NestWhileList[f,{lst4},Length@Union@#[[-1]]>2&,1,100][[2;;]][[All,1]]

NestWhileList[f,{lst5},Length@Union@#[[-1]]>2&,1,100][[2;;]][[All,1]]

(*

{}
{{1,3,2}}
{{1,1,2,3},{3,3,1,2}}
{{1,2,3},{1,1,2,2,3},{3,2,2,3,1}}
{{1,2,3},{1,1,2,2,3},{3,2,2,3,1},{1,2,2,2,2,3}}

*)


Lists

lst1={1, 1, 1} ;
lst2={1, 3, 2, 1};
lst3={1, 1, 2, 3, 3, 3, 1, 2, 1} ;
lst4={1, 2, 3, 1, 1, 2, 2, 3, 3, 2, 2, 3, 1, 1};
lst5={1, 2, 3, 1, 1, 2, 2, 3, 3, 2, 2, 3, 1, 1,2,2,2,2,3};