Perl Weekly Challenge 357.
My solutions (task 1 and task 2 ) to the The Weekly Challenge - 357.
Task 1: Kaprekar Constant
Submitted by: Mohammad Sajid Anwar
Write a function that takes a 4-digit integer and returns how many iterations are required to reach Kaprekar’s
constant (6174). For more information about Kaprekar's Constant please follow the wikipedia page.
Example 1
Input: $int = 3524
Output: 3
Iteration 1: 5432 - 2345 = 3087
Iteration 2: 8730 - 0378 = 8352
Iteration 3: 8532 - 2358 = 6174
Example 2
Input: $int = 6174
Output: 0
Example 3
Input: $int = 9998
Output: 5
Iteration 1: 9998 - 8999 = 0999
Iteration 2: 9990 - 0999 = 8991
Iteration 3: 9981 - 1899 = 8082
Iteration 4: 8820 - 0288 = 8532
Iteration 5: 8532 - 2358 = 6174
Example 4
Input: $int = 1001
Output: 4
Iteration 1: 1100 - 0011 = 1089
Iteration 2: 9810 - 0189 = 9621
Iteration 3: 9621 - 1269 = 8352
Iteration 4: 8532 - 2358 = 6174
Example 5
Input: $int = 9000
Output: 4
Iteration 1: 9000 - 0009 = 8991
Iteration 2: 9981 - 1899 = 8082
Iteration 3: 8820 - 0288 = 8532
Iteration 4: 8532 - 2358 = 6174
Example 6
Input: $int = 1111
Output: -1
The sequence does not converge on 6174, so return -1.
Given a four digit number N, I order its digits
toproduce two numbers abcd and dcba,
subtract them, where a>=b>=c=>d, and repeat until I reach a fixed point, either 0000
or Kaprekar’s constant. I use sprintf with the format “%04d” to add
leading zeroes if necessary. I set the special variable $” so that
arrays of digits are stringified as numbers. The code takes a two-liner.
perl -E '
$"="";for(@ARGV){$n=0;$x=$_;while(1){@d=sort split"",sprintf"%04d",$y=$x;
$x=reverse(@d)-"@d";last if $x==$y; ++$n}say"$_ -> ",$x?$n:-1}
' 3524 6174 9998 1001 9000 1111
Results:
3524 -> 3
6174 -> 0
9998 -> 5
1001 -> 4
9000 -> 4
1111 -> -1
The full code is:
1 # Perl weekly challenge 357
2 # Task 1: Kaprekar Constant
3 #
4 # See https://wlmb.github.io/2026/01/19/PWC357/#task-1-kaprekar-constant
5 use v5.36;
6 use English;
7 use feature qw(try);
8 die <<~"FIN" unless @ARGV;
9 Usage: $0 N0 N1...
10 to find how many iterations are required to convert the
11 four digit numbers Nk to Kaprekar's constant 6174.
12 In each iteration the digits of the current number are
13 ordered and the smallest resulting integer is subtracted
14 from the largest;
15 FIN
16 $LIST_SEPARATOR="";
17 for(@ARGV){
18 try {
19 die "Expected four-digit inputs: $_" unless /^\d{4}$/;
20 my $iterations=0;
21 my $next=$_;
22 while(1){
23 my @digits = sort {$a<=>$b} split "", sprintf "%04d", my $current=$next;
24 $next = "".reverse(@digits)-"@digits";
25 last if $current==$next;
26 ++$iterations
27 }
28 say"$_ -> ", $next!=0?$iterations:-1
29 }
30 catch($e){warn $e;}
31 }
Example:
./ch-1.pl 3524 6174 9998 1001 9000 1111
Results:
3524 -> 3
6174 -> 0
9998 -> 5
1001 -> 4
9000 -> 4
1111 -> -1
Task 2: Unique Fraction Generator
Submitted by: Yary
Given a positive integer N, generate all unique fractions you can create using
integers from 1 to N and follow the rules below:
- Use numbers 1 through N only (no zero)
- Create fractions like numerator/denominator
- List them in ascending order (from smallest to largest)
- If two fractions have the same value (like 1/2 and 2/4),
only show the one with the smallest numerator
Example 1
Input: $int = 3
Output: 1/3, 1/2, 2/3, 1/1, 3/2, 2/1, 3/1
Example 2
Input: $int = 4
Output: 1/4, 1/3, 1/2, 2/3, 3/4, 1/1, 4/3, 3/2, 2/1, 3/1, 4/1
Example 3
Input: $int = 1
Output: 1/1
Example 4
Input: $int = 6
Output: 1/6, 1/5, 1/4, 1/3, 2/5, 1/2, 3/5, 2/3, 3/4,
4/5, 5/6, 1/1, 6/5, 5/4, 4/3, 3/2, 5/3, 2/1,
5/2, 3/1, 4/1, 5/1, 6/1
Example 5
Input: $int = 5
Output: 1/5, 1/4, 1/3, 2/5, 1/2, 3/5, 2/3, 3/4, 4/5, 1/1,
5/4, 4/3, 3/2, 5/3, 2/1, 5/2, 3/1, 4/1, 5/1
I can use variations_with_repetition from Algorithm::Combinatorics
to generate all pairs of numbers taken from 1 up to the given number,
filter them to keep only relative primes, i.e., pairs that have no
common factor, and sort them as rationals (to compare the fractions a/b to
c/d, compare the integers a*d to b*c). The result takes a 1.5-liner.
perl -MMath::Prime::Util=gcd -MAlgorithm::Combinatorics=variations_with_repetition -E '
for(@ARGV){say"$_->", map{" $_->[0]/$_->[1]"} sort{$a->[0]*$b->[1]<=>$a->[1]*$b->[0]}
grep{gcd(@$_)==1} variations_with_repetition [1..$_],2 ;
}
' 3 4 1 6 5
Results:
3-> 1/3 1/2 2/3 1/1 3/2 2/1 3/1
4-> 1/4 1/3 1/2 2/3 3/4 1/1 4/3 3/2 2/1 3/1 4/1
1-> 1/1
6-> 1/6 1/5 1/4 1/3 2/5 1/2 3/5 2/3 3/4 4/5 5/6 1/1 6/5 5/4 4/3 3/2 5/3 2/1 5/2 3/1 4/1 5/1 6/1
5-> 1/5 1/4 1/3 2/5 1/2 3/5 2/3 3/4 4/5 1/1 5/4 4/3 3/2 5/3 2/1 5/2 3/1 4/1 5/1
The full code is almost identical:
1 # Perl weekly challenge 357
2 # Task 2: Unique Fraction Generator
3 #
4 # See https://wlmb.github.io/2026/01/19/PWC357/#task-2-unique-fraction-generator
5 use v5.36;
6 use feature qw(try);
7 use Math::Prime::Util qw(gcd);
8 use Algorithm::Combinatorics qw(variations_with_repetition);
9 use Text::Wrap;
10 $Text::Wrap::columns=60;
11 die <<~"FIN" unless @ARGV;
12 Usage: $0 N0 N1...
13 to sort and print all proper fractions than can be built
14 with the integers 1..Nn
15 FIN
16 for(@ARGV){
17 try{
18 die "Expected a positive integer: $_" unless /^\+?\d+$/;
19 say wrap("", " ",
20 "$_->",
21 map{"$_->[0]/$_->[1]"}
22 sort{$a->[0]*$b->[1]<=>$a->[1]*$b->[0]}
23 grep{gcd(@$_)==1}
24 variations_with_repetition [1..$_],2
25 );
26 }
27 catch($e){warn $e;}
28 }
Example:
./ch-2.pl 3 4 1 6 5
Results:
3-> 1/3 1/2 2/3 1/1 3/2 2/1 3/1
4-> 1/4 1/3 1/2 2/3 3/4 1/1 4/3 3/2 2/1 3/1 4/1
1-> 1/1
6-> 1/6 1/5 1/4 1/3 2/5 1/2 3/5 2/3 3/4 4/5 5/6 1/1 6/5 5/4
4/3 3/2 5/3 2/1 5/2 3/1 4/1 5/1 6/1
5-> 1/5 1/4 1/3 2/5 1/2 3/5 2/3 3/4 4/5 1/1 5/4 4/3 3/2 5/3
2/1 5/2 3/1 4/1 5/1
/;
Written on January 19, 2026