| 06 February 2026 | Challenge 359 |
Reduced Roots
Task 1: Digital Root
Submitted by: Mohammad Sajid Anwar
You are given a positive integer, $int.
Write a function that calculates the additive persistence of a positive integer and also return the digital root.
Digital root is the recursive sum of all digits in a number until a single digit is obtained.
Additive persistence is the number of times you need to sum the digits to reach a single digit.
Example 1
Input: $int = 38
Output: Persistence = 2
Digital Root = 2
38 => 3 + 8 => 11
11 => 1 + 1 => 2
Example 2
Input: $int = 7
Output: Persistence = 0
Digital Root = 7
Example 3
Input: $int = 999
Output: Persistence = 2
Digital Root = 9
999 => 9 + 9 + 9 => 27
27 => 2 + 7 => 9
Example 4
Input: $int = 1999999999
Output: Persistence = 3
Digital Root = 1
1999999999 => 1 + 9 + 9 + 9 + 9 + 9 + 9 + 9 + 9 + 9 => 82
82 => 8 + 2 => 10
10 => 1 + 0 => 1
Example 5
Input: $int = 101010
Output: Persistence = 1
Digital Root = 3
101010 => 1 + 0 + 1 + 0 + 1 + 0 => 3
Solution
Even in an arbitrary base the procedure is straight forward: Calculate the digit sum until the number is less than the base.
Extended precision is required for larger numbers when operating on true numbers.
In base 10:
19999999999999999999999 -> 199
199 -> 19
19 -> 10
10 -> 1
p = 4
or in base 2:
2^127 - 1 = 170141183460469231731687303715884105727 (1...1) -> 127
127 (1111111) -> 7
7 (111) -> 3
3 (11) -> 2
2 (10) -> 1
p = 5
Perl
use bigint for larger numbers, see above.
Results are always small.
use strict;
use warnings;
use Math::Prime::Util qw(todigits vecsum);
sub digital_root ($int, $base) {
use bigint;
my $persistence = 0;
$persistence++, $int = vecsum todigits $int, $base while $int >= $base;
($persistence, $int);
}
See the full solution to task 1.
J
As not only the digit root is requested but also the number of steps towards it, this is another case for a “Fold Single” conjunction.
First define a verb “digit sum with termination”, that calculates the digit sum of y in an arbitrary base x and that calls “Terminate Fold” when y is smaller than x
dst =: {{x (([: +/ #.^:_1) [ 1 Z: >) y}}
NB. DD CCCCCC B AAAAAA
A: terminate fold when x > y
B: use result of left verb C, D as result
C: convert y to base x
D: sum over the digits
Then define a verb that provides the additive persistence and the digital root:
pr =: {{(Z:2) , y}}
NB. BBB A
A: the result from the previous loop
B: the number of completed loops (can be zero)
These verbs are combined in the fold:
digitroot =: pr F. dst
echo 10 digitroot 1999999999
echo 8 digitroot 63
echo 10 digitroot 19999999999999999999999x
echo 2 digitroot (_1 + 2x^127)
See the full solution.
Task 2: String Reduction
Submitted by: Mohammad Sajid Anwar
You are given a word containing only alphabets,
Write a function that repeatedly removes adjacent duplicate characters from a string until no adjacent duplicates remain and return the final word.
Example 1
Input: $word = "aabbccdd"
Output: ""
Iteration 1: remove "aa", "bb", "cc", "dd" => ""
Example 2
Input: $word = "abccba"
Output: ""
Iteration 1: remove "cc" => "abba"
Iteration 2: remove "bb" => "aa"
Iteration 3: remove "aa" => ""
Example 3
Input: $word = "abcdef"
Output: "abcdef"
No duplicate found.
Example 4
Input: $word = "aabbaeaccdd"
Output: "aea"
Iteration 1: remove "aa", "bb", "cc", "dd" => "aea"
Example 5
Input: $word = "mississippi"
Output: "m"
Iteration 1: Remove "ss", "ss", "pp" => "miiii"
Iteration 2: Remove "ii", "ii" => "m"
Solution
This task seems to be a duplicate of task 1 from challenge 340. As the tasks are not adjacent, we’ll keep both of them 😁.
There is a small ambiguity in this task: does “adjacent duplicate characters” include more than two characters?
Example 5 answers this question with “strict pairs”, as the two "ii" pairs are removed separately.
Therefore an odd number of adjacent equal characters will be reduce to a single character.
Perl
An obvious solution in Perl uses a regular expression:
Substitute any single character followed by itself with the empty string.
Loop while there are pairs of adjacent equal characters.
use strict;
use warnings;
sub reduce_string ($str) {
1 while $str =~ s/(.)\1//g;
$str;
}
See the full solution to task 2.
J
Following a different approach in J.
Lately I implemented a verb Rle to run-length encode a list - just as an exercise.
It comes handy for this task:
- run-length encode the list
- take the lengths modulo 2
- re-apply the lengths, i.e. run-length decode with the modified lengths
- repeat until the list has not changed
There is no reference to strings in this procedure. It can be used on a list of any kind. Therefore the approach is applicable to e.g. strings, numeric lists, rows of a matrix, lists of strings,…
First comes Rle:
Rle =: ([: (#@> ; <@:({.@>)) ] </.~ [: +/\. [: -. 1 ,~ 2&(-:/\))
Don’t want to go into detail with this. The usage is:
'freq val' =. Rle list
where val is the sublist of items from list such that none of them is repeated more than once and
freq is a list of positive integers representing the repetition factors for each item in val
to reproduce the list list.
Then reducelist can be implemented as:
reducelist =: (#~ 2&|)~&>/@Rle (^:^:_) (*@#)
NB. HH GGG F ED CCC BBBBB AAA
A: does y contain items?
B: repeat the left verb C-H while A is one and the result changes
C: run-length encode y
D: apply left verb E-H between frequency and value
E: unbox
F: swap frequency and value
G: frequency modulo 2
H: repeat the value F times
Here reducelist is applied to example 5 and the rows of a 5 x 2 matrix:
reducelist 'mississippi'
m
]mat =. 5 2 $ 1 2 1 2 3 4 3 4 5 6
1 2
1 2
3 4
3 4
5 6
reducelist mat
5 6
See the full solution.