How to replace While construct to NestWhile(functional-style) correctly?

Question

Recently,I find the program of @J.M. about Get a "step-by-step" evaluation in Mathematica is a very useful example for learning Mathematica programming.

In the function WalkD,I see the construct of While(it is common in procedural programming paradigm).I know Mathematica's functional programming paradigm is very elegent,so I'd like to use the function NestWhile to rewrite the the construct of While.

Origin program:

WalkD[f_, x_] := Module[{derivative, oldderivative, k}, 
    derivative = d[f, x]; displayStart[derivative];

   (*First While construct*)
    While[! FreeQ[derivative, d],
        oldderivative = derivative; k = 0;

        (*Second while construct*)
        While[oldderivative == derivative,
                  k++;
                  derivative = derivative /. 
                          ToExpression[StringReplace[$RuleNames[[k]], " " -> ""]]];
        displayDerivative[derivative, k]];
    D[f, x]]

My trial to rewrite the inner While construct

WalkDRewrite[f_, x_] :=
 Module[
  {derivative, oldderivative, k},
   derivative = d[f, x];
   displayStart[derivative];

 While[! FreeQ[derivative, d],
  oldderivative = derivative;
  k = 0;

 (*begin to rewrite*)
 NestWhile[
   CompoundExpression[#2++,
     #1 = #1 /. ToExpression[StringReplace[$RuleNames[[k]], " " -> ""]]] &,
   Sequence[derivative, k],
   oldderivative != derivative
 ]
 (*end *)

  displayDerivative[derivative, k]
 ];
 D[f, x]
]

However,I failed after debugging all morning.

Question:

Is it possible to use NestWhile to replace While?Thanks sincerely!

Answer 1

Let's look at the inner loop:

While[oldderivative == derivative,
          k++;
          derivative = derivative /. 
                  ToExpression[StringReplace[$RuleNames[[k]], " " -> ""]]];

The first observation is that you have two variables which you change in the original While loop, derivative and k, but NestWhile supports only one function argument. But that is easily solved by passing a list containing those two variables.

The test function therefore is easy:

#[[1]] == oldderivative &

The actual evaluation function gives the new values as function of the old values. Note that #[[2]] is the old value of k, therefore an extra +1 is needed:

{ #[[1]] /. ToExpression[StringReplace[$RuleNames[[ #[[2]]+1 ]], " " -> ""]],
  #[[2]]+1 }&

And the initial values are, of course, derivative and 0.

Now we already see that the expressions get quite complicated, therefore we should make use of some function definitions, which also allows to make the code more readable through pattern matching. The inner loop body function makes a great candidate for this:

derivativeReplace[{derivative_, k_}] :=
   { derivative /. ToExpression[StringReplace[$RuleNames[[k+1]], " " -> ""]],
     k+1 }

Therefore the inner loop should look like this:

{derivative, k} =
  NestWhile[derivativeReplace, {derivative, 0}, #[[1]] == oldderivative &]

And thus the outer loop now is

While[! FreeQ[derivative, d],
    oldderivative = derivative;

    {derivative, k} =
      NestWhile[derivativeReplace, {derivative, 0},#[[1]] == oldderivative &]
    displayDerivative[derivative, k]];

Now the first thing you see is that derivative is no longer changed before NestList returns, therefore we can completely get rid of oldderivative:

While[! FreeQ[derivative, d],
    {derivative, k} =
      NestWhile[derivativeReplace, {derivative, 0}, #[[1]] == derivative &];
    displayDerivative[derivative, k]];

Note that k is only needed for displayDerivative, and not further used. To isolate the reassignment of derivative (which we need to do to replace the outer loop), we can use an anonymous helper function:

While[! FreeQ[derivative, d],
  derivative = Function[{deriv, k},
                        displayDerivative[deriv, k]; deriv] @@
      NestWhile[derivativeReplace, {derivative, 0}, #[[1]] == derivative &]];

Now the outer loop is in the perfect form for translation into NestWhile:

NestWhile[
  Function[derivative,
    Function[{deriv, k}, displayDerivative[deriv, k]; deriv] @@
      NestWhile[derivativeReplace, {derivative, 0}, #[[1]] == derivative &]],
        derivative, ! FreeQ[#, d]&];

Note that I ignore the return value of the outer NestWhile since derivative is no longer used after the rule. The complete function replacement therefore reads:

derivativeReplace[{derivative_, k_}] :=
   { derivative /. ToExpression[StringReplace[$RuleNames[[k+1]], " " -> ""]],
     k+1 }

WalkDReplacement[f_, x_] := Module[{derivative}, 
  derivative = d[f, x]; displayStart[derivative];

  NestWhile[
    Function[derivative,
      Function[{deriv, k}, displayDerivative[deriv, k]; deriv] @@
        NestWhile[derivativeReplace, {derivative, 0}, #[[1]] == derivative &]],
        derivative, ! FreeQ[#, d]&];

  D[f, x]]