# Use Fold and If to define "remove three repetitions"

I am working on the text Programming with Mathematica by Paul Wellin. I some exercise is asked to define the following function using If in conjunction with Map or Fold.

I tried using Fold without success because of don't know well which expresion in Fold[expr, a, list] to use. I made my own version using For as follows

remove3Repetitions[lis_] := Module[{positions = {}, lis2, i = 1},
For[i = 1, i <= Length[lis] - 2, i++,
If[lis[[i]] == lis[[i + 1]] && lis[[i + 1]] == lis[[i + 2]],
positions = Append[positions, {i}];
];
];
lis2 = Delete[lis, positions]
]



This works fine, for example,

In[177]:= remove3Repetitions[{0, 1, 1, 2, 2, 2, 1}]

Out[177]= {0, 1, 1, 2, 2, 1}



But, using the Higher order functions Fold or Map may be a better approach. The text ask for this. I would like any suggestion.

1. If you have to use Fold and If:

ClearAll[shortenRepetitions]
shortenRepetitions[k_] := Fold[If[{#2} == Union[#[[-(k - 1) ;;]]], #,
Flatten[{#, #2}]] &, #[[;; k - 1]], #[[k ;;]]] &;

shortenRepetitions[3]@{0, 1, 1, 2, 2, 2, 1}

{0, 1, 1, 2, 2, 1}

shortenRepetitions[3]@{0, 1, 1, 2, 2, 2, 1, 3, 3, 3, 3, 3, 2, 1, 1, 1}

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

shortenRepetitions[4]@{0, 1, 1, 2, 2, 2, 1, 3, 3, 3, 3, 3, 2, 1, 1, 1}

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


Alternative ways:

2. using Split:

ClearAll[shortenRepetitions2]
shortenRepetitions2[k_] := Flatten[Split[#][[All, ;; UpTo[k - 1]]]] &;

shortenRepetitions2[3][{0, 1, 1, 2, 2, 2, 1}]

{0, 1, 1, 2, 2, 1}


3. using SequenceReplace:

ClearAll[shortenRepetitions3]
shortenRepetitions3[k_] :=  SequenceReplace[{Repeated[x_, {k, ∞}]} :>
Sequence @@ ConstantArray[x, k - 1]] ;

shortenRepetitions3[3][{0, 1, 1, 2, 2, 2, 1}]

  {0, 1, 1, 2, 2, 1}


1.

Only one triple

list = {0, 1, 1, 2, 2, 2, 1};


Using SubsetReplace (new in 12.1) and SequenceCases

SubsetReplace[list, # -> Splice @ Most @ #]& @
First @ SequenceCases[list, {x_, x_, x_}]


{0, 1, 1, 2, 2, 1}

2.

More than one triple

list = {0, 1, 1, 2, 2, 2, 1, 4, 4, 4};

Fold[
SubsetReplace[#1, {#2, #2, #2} -> Sequence[#2, #2]]&,
list,
SequenceCases[list, {x_, x_, x_} :> x]]


{0, 1, 1, 2, 2, 1, 4, 4}

3.

More generally

list = {0, 1, 1, 2, 2, 2, 2, 1, 4, 4, 4};

Fold[
SubsetReplace[#1, {Repeated[#2, {3, Infinity}]} :> Sequence[#2, #2]] &,
list,
SequenceCases[list, {Repeated[x_, {3, Infinity}]} :> x]]


{0, 1, 1, 2, 2, 1, 4, 4}

4.

For the first two cases we can also use

list = {0, 1, 1, 2, 2, 2, 1, 4, 4, 4};

Delete[list, Map[List @* First] @ SequencePosition[list, {x_, x_, x_}]]


{0, 1, 1, 2, 2, 1, 4, 4}

l1 = {0, 1, 1, 2, 2, 2, 1};

l2 = {0, 1, 1, 2, 2, 2, 1, 4, 4, 4};

l3 = {0, 1, 1, 2, 2, 2, 2, 1, 4, 4, 4};


Another way to do this using DeleteElements:

remove3Repetitions[l_List] := Module[{patt, del},
patt = s : {Repeated[x_, {3, ∞}]} :> {Splice@{Length@s[[3 ;;]]},s[[1]]};
del = Rule @@ Transpose@Cases[patt]@Split[l];
DeleteElements[l, del]]

remove3Repetitions /@ {l1, l2, l3} // Column


Results: