*Mathematica* Q&A: Four Ways to Sum Integer Digit Blocks

Got questions about *Mathematica*? The Wolfram Blog has answers! We’ll regularly answer selected questions from users around the web. You can submit your question directly to the Q&A Team using this form.

This week’s question comes from Craig, a hobbyist:

**For each six-digit number in a list, how can I check whether the sums of the first and last three digits are equal?**

For example, the sums of the first and last three digits of the number 123,222 are equal because 1 + 2 + 3 == 2 + 2 + 2.

There are several different ways of solving this straightforward programming problem in *Mathematica*, and it’s instructive to compare them. In this post you’ll see four methods demonstrating various combinations of built-in *Mathematica* functions for working with lists and digits of integers.

Let’s start with a list of random six-digit numbers:

**Method 1.** Using the built-in function `IntegerDigits`, you can define a handy function to compute the sum of the digits of an integer:

To separate the first and last three digits of a six-digit number, you could use the `Quotient` and the remainder (`Mod`) when dividing by 1,000:

Using these two functions with `DigitSum`, you have the first solution:

`Table` was used to tabulate the result (in this case, either `True` or `False`) for each value of *n* drawn from the list `nums`.

**Method 2**. Getting both the quotient and remainder together is such a common operation that there is a built-in function for it:

If you think about it, this is also the same as finding the base 1,000 digits of a number. You can do this using the two-argument form of `IntegerDigits`:

Either of these methods of splitting the six-digit number returns a list of two three-digit numbers. To proceed from there, you need to use `DigitSum` on each element of the list:

The notation f /@ list is shorthand for `Map`[*f*, *list*].

To test whether the elements in a list are equal, you need to use them as arguments to the `Equal` function. This is exactly what the built-in function `Apply` is for:

`Apply`[*f*, *list*] uses *list* as the arguments to the function *f*. In this example it returns `Equal`[19,8], which evaluates to `False`.

Putting it all together, here is the second solution:

**Method 3**. Instead of splitting the number into two three-digit numbers and using `DigitSum`, you could begin by getting all six digits as a list and then using `Partition` to break it into sublists of length three:

You can use `Total` on each sublist:

Now you can apply `Equal` as before to get the third solution:

**Method 4**. So far `Table` has always been used to operate over the list nums. (You also could have used `Map` for that.) A different approach is to take advantage of the fact that many built-in *Mathematica* functions automatically operate on lists of arguments, giving a list of results (see `Listable`).

You can get the `QuotientRemainder` of all the numbers at once:

Likewise for `IntegerDigits` (operating on a matrix of numbers and getting a matrix of results):

The optional second argument of `Total` totals a nested list specifically at depth three:

Now you can apply `Equal` to each of these lists of two arguments. There is a special built-in notation, @@@, for this common operation. This yields the fourth solution:

(The @@@ is shorthand for `Apply`[*f*, *expr*, {1}], which means “`Apply` *f* to each item at depth 1 in *expr*.”)

Method 4 is the most concise solution in this post. Can you find a shorter one? How about any fundamentally different approaches?

If you have a question you’d like answered in this blog, you can submit it to the Q&A Team using this form.

It is slightly shorter to use IntegerDigits[nums,1000] rather than QuotientRemainder[nums,1000] since we can take the number in base 1000 (there aren’t enough digits to give this properly, so Mathematica just gives the decimal equivalent). Therefore, the slightly shorter version would be:

Equal @@@ Total[IntegerDigits[IntegerDigits[nums, 1000]], {3}]

I came up with a couple more, and also some code for the timings:

Clear[DigitSum,m1,m2,m3,m4,m5,m6,m7]

DigitSum[n_]:=Total[IntegerDigits[n]]

m1[nums_List]:=Table[DigitSum[Quotient[n,1000]]==DigitSum[Mod[n,1000]],{n,nums}]

m2[nums_List]:=Table[Apply[Equal,DigitSum/@QuotientRemainder[n,1000]],{n,nums}]

m3[nums_List]:=Table[Apply[Equal,Total/@Partition[IntegerDigits[n],3]],{n,nums}]

m4[nums_List]:=Equal@@@Total[IntegerDigits[QuotientRemainder[nums,1000]],{3}]

m5[nums_List]:=Equal@@@Total[Partition[IntegerDigits[nums],{1,3}],{4}]

m6[nums_List]:=Equal@@@(({Total[Part[#,;;3]],Total[Part[#,4;;]]}&/@IntegerDigits[nums]))

m7[nums_List]:=Equal@@@Map[Total,(({Part[#,;;3],Part[#,4;;]}&/@IntegerDigits[nums])),{2}]

Clear[GetTimings,GetAverageTimings]

GetTimings[n_Integer]:=Module[{tmp,t1,t2,t3,t4,t5,t6,t7},tmp=RandomInteger[{10^5,10^6-1},n];

t1=AbsoluteTiming[m1[tmp];][[1]];

t2=AbsoluteTiming[m2[tmp];][[1]];

t3=AbsoluteTiming[m3[tmp];][[1]];

t4=AbsoluteTiming[m4[tmp];][[1]];

t5=AbsoluteTiming[m4[tmp];][[1]];

t6=AbsoluteTiming[m4[tmp];][[1]];

t7=AbsoluteTiming[m4[tmp];][[1]];

{t1,t2,t3,t4,t5,t6,t7}]

GetAverageTimings[n_Integer,m_Integer]:=Mean[Table[GetTimings[n],{m}]]

timings=Outer[List,{#},GetAverageTimings[#,4]]&/@Round[(10^Range[1,5,1/2])];

timings=timings[[All,1]]\[Transpose];

ListLogLogPlot[timings,Joined->True,Mesh->All,PlotStyle->(ColorData[“Rainbow”]/@Range[0,1,1/6])]

t=timings[[All,All,2]]\[Transpose];

n=timings[[1,All,1]];

TableForm[Ordering/@t,TableHeadings->{n,{}}]

It is quite clear that your method 1,2, and 3 are the worst, and that the others are out-performing these.

My approach to define a function that tests whether the sum of the first three digits and the last three digits is similar:

In[1]:= list = {123222, 123456, 123321, 135630, 111000}

Out[1]= {123222,123456,123321,135630,111000}

In[2]:= digitSumTest[integer_] :=

Total[IntegerDigits[integer][[1 ;; 3]]] ==

Total[IntegerDigits[integer][[4 ;; 6]]]

But Select seems like a nice way to generate a list of integers that satisfy this pattern. It seems useful to see the actual integers rather than the True / False statements.

In[3]:= Select[list, digitSumTest]

Out[3]= {123222,123321,135630}

With pure functions, the Select statement can contain the function definition:

In[4]:= Select[list,

Total[IntegerDigits[#][[1 ;; 3]]] == Total[IntegerDigits[#][[4 ;; 6]]] &]

Out[4]= {123222,123321,135630}

Nicely done! I prefer InterDigits as well.

I recently used InterDigits to work through the middle-square method of pseudo-random number generation. You can then look at the output to see how random it really is. Might be one to try for the next topic!

http://en.wikipedia.org/wiki/Middle_square_method

Matrix manipulation would be a different approach. This approach has more bytes, but it doesn’t play with the digits twice before adding. Does it make sense?

Equal @@@ (IntegerDigits[

nums].{{1, 0}, {1, 0}, {1, 0}, {0, 1}, {0, 1}, {0, 1}})

There might be a more concise way to create the matrix with 1s and 0s.

I’m still new to this, but IntegerDigits[IntegerDigits[num,1000] makes me think of Fold. Is there a way to use Fold that would be more efficient?

In Russian culture this problem has a practical sense — it is belived that if your bus ticket number has such a “lucky” property, you should eat it to have luck ;-) If you can read in Russian, you may read more about it at http://ru.wikipedia.org/wiki/%D0%A1%D1%87%D0%B0%D1%81%D1%82%D0%BB%D0%B8%D0%B2%D1%8B%D0%B9_%D0%B1%D0%B8%D0%BB%D0%B5%D1%82

By the way, the total number of 6-digit “lucky” tickets from 000000 to 999999 is calculated by … integral 1/\[Pi] NIntegrate[(Sin[10 x]/Sin[x])^6, {x, 0, \[Pi]}]

If you want to find all such numbers, it’s better not to create a test function, but generate the full list. Here is approach I use:

(*Take all 3-digit numbers from 1 to 998 + sum their digits, 0 and 999 are not neccesary — they correspond to tickets 000000 and 999999 which can be added manually*)

{#, Total[IntegerDigits[#]]} & /@ Range[1, 998];

(*Group them by total sum of digits (001,010,100), (002,020,200),…,(899,989,998)*)

Split[SortBy[%, Last], #1[[2]] == #2[[2]] &];

(*This is the technical step — transform numbers to 3-digit strings*)

(#[[;; , 1]] & /@ %) /. x_?NumberQ :> IntegerString[x, 10, 3];

(*For each group generate the Outer list (Cartesian product of the list), e.g. (001,001),(001,010),…,(100,100) and join the numbers in each pair + add 000000 and 999999*)

result=Join[{“000000”}, StringJoin /@ Flatten[Outer[List, #, #] & /@ %, 2], {“999999”}]

This code works quicker than when using Select.

I like Dan’s (May 3) though fundamentally different it is not, digitizing, summing again. Here’s a variation with a scalar product.

Inner[#1 #2 &, IntegerDigits[#],

{1, 1, 1, -1, -1, -1}, Plus] == 0 & /@ nums

P.S. #1 #2& … that’s Times, cleaner I think, a letter less also. :)

#.{1, 1, 1, -1, -1, -1} == 0 & /@ IntegerDigits[nums]

How about:

#[[;; 3]] == #[[-3 ;;]] & /@ IntegerDigits[nums]

J

Your last method using Dot is very concise Bo! Here is a variant on yours using a single call to Dot and Listability of PossibleZeroQ:

PossibleZeroQ[IntegerDigits[nums].{1, 1, 1, -1, -1, -1}]

Good job Bo! I like that dot solution.

ah, sorry, didn’t see it was the sum. Need a total around my solution:

Total[#[[;; 3]]] == Total[#[[-3 ;;]]] & /@ IntegerDigits[nums]

Thanks, Kiryl, for your interesting information !

By the way, your first 3 steps can be completed using Reap/Sow and thus run even faster in Mathematica. ( Note: no algorithmic difference )

s = Reap[Sow[ IntegerString[#, 10, 3], Total@IntegerDigits[#]] & /@

Range[1, 998];][[2]];

result = Join[{“000000”},

Flatten@Outer[StringJoin, #, #] & /@ s, {“999999”}];

The language “APL” was capable of a similar density of expression. It would be interesting to compare the number of primitives it is necessary to memorise in order to be “Fluent” (ie not having to keep looking into the “Manual”) in each of these “Languages”.

One cannot reasonably assert that: “StringJoin /@ Flatten[Outer[List, #, #] & /@ %, 2], {”999999″}]” is an immediately comprehensible “Statement” to the neophyte.

(eg: why need a space between @ and Flatten and not between / and @ ? etc etc.

Using the Pick function, with the excellent solution given:

n=RandomInteger[{100000,999999},100];

Pick[n,IntegerDigits[n].{1,1,1,-1,-1,-1},0]

{844781, 637790, 760580, 901442, 659596}

= = = = = = =

I originally started to go this route prior to the above solution.

When using QuotientRemainder…

num = {991083, 185437, 329911, 861615, 259693, 487950, 352094, 276653,

780303};

qr = QuotientRemainder[num, 1000];

The only possible chance the two sides are equal is if the ‘Rule of 9’s are equal.

Mod[qr, 9]

{{1, 2}, {5, 5}, {5, 2}, {6, 3}, {7, 0}, {1, 5}, {1, 4}, {6, 5}, {6, 6}}

Meaning that only #2, and the last, had a chance of being equal.

Extract[qr, Position[Mod[qr, 9], {x_, x_}]]

{{185, 437}, {780, 303}}

By only testing these two solutions, we see that the first is valid, but the second is not.

Again, this turned out to be a slow solution.