9
$\begingroup$

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.

$\endgroup$

9 Answers 9

9
$\begingroup$
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

enter image description here

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

Examples:

Map[sequenceSplitByUnion]@lists === Map[splitByUnion]@lists
 True
$\endgroup$
4
  • $\begingroup$ The code with SequenceSplit does not seem to work on 13.0.1.0. It outputs unchanged input. What has changed in latest version? $\endgroup$ Sep 3, 2023 at 16:41
  • $\begingroup$ @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. $\endgroup$
    – kglr
    Sep 3, 2023 at 16:58
  • 2
    $\begingroup$ It does not have to be change in SequenceSplit maybe somewhere else like for example in Shortest. $\endgroup$ Sep 3, 2023 at 17:11
  • $\begingroup$ very good point. $\endgroup$
    – kglr
    Sep 3, 2023 at 17:15
9
$\begingroup$

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}}
$\endgroup$
7
$\begingroup$

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]
$\endgroup$
7
$\begingroup$

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}} *)
```
$\endgroup$
7
$\begingroup$

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 *)
$\endgroup$
5
$\begingroup$

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}]
$\endgroup$
3
$\begingroup$

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}}] &

enter image description here

$\endgroup$
2
$\begingroup$
$Version

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

RepeatedTimings of

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

enter image description here

$\endgroup$
2
$\begingroup$
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};
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.