6
$\begingroup$

This question already has an answer here:

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.

$\endgroup$

marked as duplicate by MarcoB, m_goldberg, user9660, dr.blochwave, ilian Nov 25 '15 at 15:32

This question has been asked before and already has an answer. If those answers do not fully address your question, please ask a new question.

  • $\begingroup$ @J.M. That's a better title. I rescind my earlier comment, therefore. $\endgroup$ – march Nov 25 '15 at 4:16
  • 1
    $\begingroup$ Meta-question: Is there some (here invisible) context where you must move on through the list before finishing with the current list element? Why not finish each list element before passing to the next element? $\endgroup$ – Eric Towers Nov 25 '15 at 7:22
  • 1
    $\begingroup$ f[TakeWhile[myList,myCriteria]] where f is listable goes a long way to answering the title of your question, if not particularly efficiently the exact task you have. $\endgroup$ – image_doctor Nov 25 '15 at 13:36
13
$\begingroup$

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 list bit here is a common Mathematica idiom for signaling an error while returning the expression unchanged.

$\endgroup$
  • 1
    $\begingroup$ This is exactly the sort of answer I was looking for. I had a hunch there had to be a lambda style approach to simplify the expression. The only issue is when I run the FixedPoint[Total@*IntegerDigits, n]; it complains about the prefix operator can't be followed by *IntegerDigits. I am using Mathematica 9, maybe that's the issue? Either way this should be more than enough to figure out what to do next. Thanks for sharing! $\endgroup$ – Dustin Darcy Nov 25 '15 at 3:38
  • 1
    $\begingroup$ @Dustin, yes, that new notation only started in version 10. You'll want to use Composition[Total, IntegerDigits] instead. $\endgroup$ – J. M. is away Nov 25 '15 at 3:58
  • $\begingroup$ @J.M. You're good, that got it. Thank you both guys! $\endgroup$ – Dustin Darcy Nov 25 '15 at 4:00

Not the answer you're looking for? Browse other questions tagged or ask your own question.