Fast way of re-ordering list

Question

I have a list which at each iteration of my algorithm is being modified. What I want to do is to find the elements that satisfy certain criterion (below it's simply being above the neighborhood average by 20%) and then moving each of these elements to the right until it bumps on the first element greater than itself. The order in which they are movied is not important. Below I wrote a few liner to output a boolean array indicating elements satisfying the criterion.

I am not sure how to proceed from here in an efficient manner. This will be done thousands of times (thousands of list generations). I can of course write loops but there should be a more efficient way to do this task.

(*I am just generating a sample list d. The actual algorithm produces a list like that*)
d = Sort @ RandomVariate[UniformDistribution[], 100];
i = RandomInteger[{1, Length[d]}, 10];
(*Mutating random elements*)
d[[i]] = RandomVariate[UniformDistribution[], Length[i]];
dm = ArrayFilter[(Max[#] - Mean[#])/Mean[#] &, d, 2 ];
bools = Thread[dm > 0.2]

An example: initial list = $\{111,122, 133, 135, 166\}$, mutated list = $\{150, 149, 133,130, 166\}$. After operation: $\{ 133,130,149, 150,166\}$ or $\{ 133,130, 150,149, 166\}$.

It seems that it is a sorting problem but with a sorting criterion depending upon some function of the neighborhood of the point.

Update

Following up on the discussion with @kglr below, I wrote a code which does the job, but it is very slow (takes about a minute for 1000 element list). To make it reasonable, it should be faster by at least two orders of magnitude. Any suggestions for improvement?

mean[x_, k_, elp_] := Module[{},
   Which[elp < k + 1, Return[Mean[x[[;; 2 k + 1]]]],

    elp > Length[x] - k, Return[Mean[x[[-(2 k + 1) ;;]]]],

    True, Return[Mean[x[[elp - k ;; elp + k]]]]]
   ];

rebalance[y_, k_, \[Sigma]_, t_: 1] := 
  Module[{x = N@y, elp, l, val, m, above, below, all, fp, choicePos, 
    moveon, leftSide, rightSide},

   (*Randomly chosing elements*)
   l = Length[x];
   (*Selecting positions of elements satisfying above criterion*)
   above = 
    Flatten@Position[
      MapThread[ 
       Greater, {x, \[Sigma] t + Map[mean[x, k, #] &, Range[l]]}], 
      True];
   below = 
    Flatten@Position[
      MapThread[ 
       Less, { x, -\[Sigma] t + Map[mean[x, k, #] &, Range[l]]}], 
      True] ;
   all = Join[above, below];

   If[Length[all] == 0, Return[x]];

   moveon = True;
   While[moveon == True ,
    choicePos = RandomInteger[{1, Length[all]}];
    elp = all[[choicePos]];
    all = Drop[all, {choicePos}];
    val = x[[elp]];
    m = mean[x, k, elp];
    (*Print["choice = ",elp,"  value = ", val, " mean = ",m];*)

    If[Length[all] == 0, Return[x]];

    Which[val > \[Sigma] t + m, 
     (*Case when elements need to move right*)
     (*First position of the occurence*)
     rightSide = x[[elp + 1 ;;]];
     fp = First@FirstPosition[rightSide, tt_ /; tt > val , {0}];
     (*Print[fp];*)
     Which[Length[rightSide] == 0, moveon == True,

      (*Preventing repetition of the number to stall the algorithm*)
      rightSide[[1]] == val, moveon = True,

      fp > 1, x = Drop[x, {elp}]; x = Insert[x, val, fp + elp - 1]; 
      moveon = False,

      fp == 1, moveon = True,

      True, 
      If[val >= Max[rightSide], x = Drop[x, {elp}]; 
       x = Insert[x, val, l]; moveon = False]
      ],


     (*Considering case when the element needs to move left*)
     val < m - \[Sigma] t, 
     leftSide = Reverse[x[[;; elp - 1]]];
     fp = First@ FirstPosition[leftSide, tt_ /; tt < val, { 0}];
     (*Print[fp];*)
     Which[Length[leftSide] == 0, moveon = True,

      (*Preventing repetition of the number to stall the algorithm*)
      leftSide[[1]] == val, moveon = True,

      fp > 1, x = Drop[x, {elp}]; x = Insert[x, val, elp - fp + 1]; 
      moveon = False,

      fp == 1, moveon = True,

      True, 
      If[val <= Min[leftSide], x = Drop[x, {elp}]; 
       x = Insert[x, val, 1]; moveon = False]
      ],

     (*In case no change happens, then moving on to the next element*)


     True, moveon = True
     ]
    ];
   x
   ];

initiallist = N@RandomInteger[200, 1000];
\[Sigma] = 2;
Print@AbsoluteTiming[
   finallist = 
     FixedPoint[rebalance[#, 2, \[Sigma], 3] &, initiallist];];
ListLinePlot[{initiallist, finallist},  
 PlotLegends -> {"initiallist", "finallist"}, 
 PlotStyle -> {Blue, Red}]

Answer 1

Update: An alternative way that perhaps better fits OP's requirements:

ClearAll[sReplace, fP2, fPL2]
sReplace = SequenceReplace[a : {__} /; Max[a]/Mean[a] > 1 + # && Length[a] == #2 :> 
     Sequence @@ Append[DeleteCases[a, Max[a]], Max[a]]] &;

fP2 = FixedPoint[sReplace @ ##2, #] &;

fPL2 = FixedPointList[sReplace @ ##2, #] &;

For the simple example list in OP both fP and fP2 give the same result:

fP2[mutatedlist, .05, 3] == fP[mutatedlist, .05]

True

fPL2[mutatedlist, .05, 3] == fPL[mutatedlist, .05]

True

In general the outputs are quite different:

ListLinePlot[{initiallist, fP2[initiallist, .2, 3]}, 
 PlotLegends -> {"initiallist", "fP2[initiallist, .2, 3]"}]

frames2 = Table[ListLinePlot[{initiallist, i}], {i, fPL2[initiallist, .2, 3]}];
Export["anim2.gif", frames2, "DisplayDurations" ->1]

Original answer:

Perhaps a combination of SequenceReplace and FixedPoint as follows?

ClearAll[fP, fPL]
fP = FixedPoint[SequenceReplace[{a_, b_, c_} /; 
       a/Mean[{a, b, c}] > 1 + #2 && a > c :> Sequence[b, c, a]], #] &;
fPL = FixedPointList[SequenceReplace[{a_, b_, c_} /; 
       a/Mean[{a, b, c}] > 1 + #2 && a > c :> Sequence[b, c, a]], #] &;

Examples:

mutatedlist = {150, 149, 133, 130, 166};
t = .05;

fP[mutatedlist, t]

 {133, 130, 150, 149, 166}

fPL[mutatedlist, t]

 {{150, 149, 133, 130, 166}, {150, 133, 130, 149, 166}, {133, 130, 150,
   149, 166}, {133, 130, 150, 149, 166}}

SeedRandom[1]
initiallist = RandomInteger[200, 40];
ListLinePlot[{initiallist , fP[initiallist , .2]},
   PlotLegends -> {"initiallist", "fP[initiallist, .2]"}]

frames = Table[ListLinePlot[{initiallist, i}], {i, fPL[initiallist, .2]}];
Export["anim.gif", frames, "DisplayDurations" -> .2]