Does Mathematica have a functional programming idiom to loop over a list till a condition is met? [duplicate]

Question

The module below takes a list of integers and performs fadic addition on it (if a bit slowly).

  f[l_] := Module[{result = l},
    While[True,
      result = Plus@@@IntegerDigits[result];
      ForEach[e_, result,
        If[IntegerLength[e] > 1, Continue[]]
      ];
      Break[];
    ];
    result
  ]

The ForEach is defined as:

SetAttributes[ForEach, HoldAll];
ForEach[pat_, lst_, bod_] := 
  ReleaseHold[Hold[Cases[Evaluate@lst, pat :> bod];]];

Example output:

threes = Table[3*x, {x, 1, 30}]
{3, 6, 9, 12, 15, 18, 21, 24, 27, 30, 33, 36, 39, 42, 45, 48, \
51, 54, 57, 60, 63, 66, 69, 72, 75, 78, 81, 84, 87, 90}

f[threes]
{3, 6, 9, 3, 6, 9, 3, 6, 9, 3, 6, 9, 3, 6, 9, 3, \
 6, 9, 3, 6, 9, 3, 6, 9, 3, 6, 9, 3, 6, 9}

Since Mathematica doesn't have a do/while construct I have to manually set the loop condition true upon entry and put a test at the bottom of the loop to determine whether we continue or break. In all, using While[] adds an extra line or two depending on how you decide to format the function as compared to just using a goto.

f[l_] := Module[{result = l},
  Label[begin];
  result = Plus@@@IntegerDigits[result];
  ForEach[e_, result,
   If[IntegerLength[e] > 1, Goto[begin]]
  ];
  result
]

Even though it works I can't help but think there has to be a better way to break out of and exit the first loop. I'm curious if there is a cleaner way to do this in Mathematica or is this as good as it gets with the current grammar?

Edit to add: The main goal is to look for a functional programming approach to repeatedly loop over the list and run Plus[] till the Integer length for all of the elements is equal to 1.

Answer 1

This is one area where Mathematica's support for functional programming idioms is helpful. Using higher-order functions (in this case FixedPoint, which always evaluates its function argument at least once) we can replace the While loop with a single line, and then use the Listable attribute to thread over lists passed in as inputs, which nicely separates concerns of whether to keep looping from handling multiple elements at once.

Attributes[digitalRoot] = {Listable};
digitalRoot[n_Integer] := FixedPoint[Total@*IntegerDigits, n];

Then we have

digitalRoot[threes] === f[threes]
(* True *)

I took the liberty of giving the function a name I'm more familiar with, and assumed that the behavior you wanted for a single number is just what would happen with a single element of the list.

If you want to use the test on the number of digits, you can use NestWhile instead, like so:

Attributes[digitalRootNW] = {Listable};
digitalRootNW[n_Integer] :=
 NestWhile[Total@*IntegerDigits, n, 1 < IntegerLength@# &];

digitalRootNW[threes] === f[threes]
(* True *)

EDIT to add: for version 9 and below, the infix @* operator for function Composition doesn't work, so the function can be defined like so:

Attributes[digitalRoot] = {Listable};
digitalRoot[n_Integer] := FixedPoint[Total ~Composition~ IntegerDigits, n];

Here, I'm using the Mathematica notation for Infix application, where x ~g~ y === g[x, y]. Also, as a bonus, here's a loop-free formula for the digital root of a number on the Wikipedia page:

digitalRootFloor[n_] := n - 9*Floor[(n - 1)/9]]

digitalRootFloor[threes] === f[threes]
(* True *)

No need to make this version Listable, as all the operations involved are already Listable. The result will differ from f for negative integers, and it will also return a (not very meaningful) value for non-integral arguments; pattern matching and going back Listable allows us to restrict our function's domain:

Attributes[digitalRootNN] = {Listable};
digitalRootNN[n_Integer?NonNegative] := n - 9*Floor[(n - 1)/9]]

digitalRootNN::intnn = "Non-negative integer argument expected in ``";
expr : digitalRootNN[_?NumericQ] /; 
  Message[digitalRootNN::intnn, HoldForm[expr]] = Null (* not reached *)

digitalRootNN[{1, -7, 2}]
(* {1, digitalRootNN[-7], 2} *)

The last bit here is a common Mathematica idiom for signaling an error while returning the expression unchanged.