2
$\begingroup$

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. enter image description here

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.

$\endgroup$

3 Answers 3

5
$\begingroup$

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

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}

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

enter image description here

$\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.