This is my response to the Perl Weekly Challenge #065.
$N and $S.
$N digits
where sum of all digits equals to $S.
Input:
$N = 2
$S = 4
Output:
13, 22, 31, 40
The challenge can be divided in two parts. The first is finding «all positive
numbers having exactly $N digits. We can get the lower and upper limits
by string concatenation. Let us say that $N = 2:
> my $N = 2;
> my $start = 1 ~ '0' x ($N - 1); # -> 10
> my $stop = '9' x $N; # -> 99
See
docs.raku.org/routine/x for more
information about the string repetition operator x.
The values we end up with are strings, but they are coerced to integers automatically when we use them in numerical context (in a Range, as shown later on).
Or we can use a mathematical formula:
> my $N = 2;
> my $start = 10 ** ($N - 1); # -> 10
> my $stop = (10 ** $N) -1; # -> 99
See
docs.raku.org/routine/** for more
information about the exponentiation operator **.
The result is the same.
Then we plug the start and stop values into a Range to get all the (integer) values:
my @all = ($start .. $stop);
See
docs.raku.org/language/operators#index-entry-Range_operator
for more information about the Range operator ...
Sorting out the numbers where the sum of all digits equals to
$S is a task for grep:
my @some = @all.grep({ $_.comb.sum == $S });
# 1 ### # 2 #####
[1] For each value (number), split it into each individual digit
with comb (giving a list of single digits).
[2] Add those digits together with sum, and compare with
$S. Matching values are collected in @some.
See
docs.raku.org/routine/grep
for more information about grep.
See
docs.raku.org/routine/comb
for more information about comb.
See
docs.raku.org/routine/sum
for more information about sum.
The program:
File: digits-sum
#! /usr/bin/env raku
unit sub MAIN (Int $N where $N > 0, Int $S where $S > 0, :$verbose); # [1]
my $start = 10 ** ($N - 1);
my $stop = (10 ** $N) -1;
say ": Max Range ($start .. $stop)" if $verbose;
say ($start .. $stop).grep({ $_.comb.sum == $S }).join(", "); # [2]
[1] Ensure that the two values are positive integers. I have added verbose mode as well.
[2] The last part (join) gives the values as a comma separated list,
as requested by the challenge.
See
docs.raku.org/routine/join
for more information about join.
Running it:
$ raku digits-sum 2 4
13, 22, 31, 40
$ raku digits-sum --verbose 2 4
: Max Range (10 .. 99)
13, 22, 31, 40
$ raku digits-sum --verbose 3 4
: Max Range (100 .. 999)
103, 112, 121, 130, 202, 211, 220, 301, 310, 400
$ raku digits-sum --verbose 4 3
: Max Range (1000 .. 9999)
1002, 1011, 1020, 1101, 1110, 1200, 2001, 2010, 2100, 3000
#! /usr/bin/env perl
use strict;
use feature 'say';
my $verbose = 0;
if ($ARGV[0] eq "--verbose")
{
$verbose = 1;
shift @ARGV;
}
my $N = shift @ARGV || die "No 'N' value";
my $S = shift @ARGV || die "No 'S' value";
die "Illegal 'N' value" if int($N) ne $N && $N <= 1;
die "Illegal 'S' value" if int($S) ne $S && $S <= 1;
my $start = 10 ** ($N - 1);
my $stop = (10 ** $N) -1;
my @all = ($start .. $stop);
my @some = grep { get_sum($_) == $S } @all;
say ": Max Range ($start .. $stop)" if $verbose;
say join(", ", @some);
sub get_sum
{
my $integer = shift;
my $sum = 0;
for my $digit (split(//, $integer))
{
$sum += $digit;
}
return $sum;
}
It is quite a bit longer than the Raku version; Raku: 260 bytes vs Perl: 680 bytes.
Running it gives the same output as the Raku version:
$ perl digits-sum-perl 2 4
13, 22, 31, 40
$ perl digits-sum-perl --verbose 2 4
: Max Range (10 .. 99)
13, 22, 31, 40
$ perl digits-sum-perl --verbose 3 4
: Max Range (100 .. 999)
103, 112, 121, 130, 202, 211, 220, 301, 310, 400
$ perl digits-sum-perl --verbose 4 3
: Max Range (1000 .. 9999)
1002, 1011, 1020, 1101, 1110, 1200, 2001, 2010, 2100, 3000
$S. Write a script print all possible partitions
that gives Palindrome. Return -1 if none found.
Input: $S = 'aabaab'
Ouput:
There are 3 possible solutions.
a) 'aabaa'
b) 'aa', 'baab'
c) 'aba'
Input: $S = 'abbaba'
Output:
There are 3 possible solutions.
a) 'abba'
b) 'bb', 'aba'
c) 'bab'
You may think that this is an excellent task for a parser (and a grammer).
But it can be done with a recursive procedure as well. Here it is:
File: palindrome-partition
#! /usr/bin/env raku
unit sub MAIN (Str $S = 'aabaab', :$verbose);
my @result; # [1]
my %match-with-remainder; # [2]
my $matches = 0; # [3]
for 0 .. $S.chars -2 -> $start # [4]
{
say ":: Start at pos $start (string: '{ $S.substr($start) }')" if $verbose;
check($S.substr($start, 2), $S.substr($start + 2)); # [5]
}
sub check($string, $remainder) # [6]
{
say ":: Check '$string' (Remainder: '$remainder')" if $verbose;
if $string eq $string.flip # [7]
{
next if %match-with-remainder{$remainder.chars}; # [8]
%match-with-remainder{$remainder.chars} = True; # [9]
@result.push: $string; # [10]
$matches++; # [3]
say ":: Match: '$string'" if $verbose;
check($remainder.substr(0,2), $remainder.substr(2)) # [11]
if $remainder.chars >= 2;
if @result # [12]
{
say @result.map({ "'{ $_ }'" }).join(", "); # [12a]
@result = (); # [12b]
}
}
check($string ~ $remainder.substr(0,1), $remainder.substr(1))
if $remainder.chars >= 1; # [13]
}
say "-1" unless $matches; # [3]
[1] All the partitions that we can get out of the string simultaneously (a single line in the output).
[2] When we have found a palindrome, take note of the number of remaining characters so that we can skip already found palindromes.
[3] No matches at all, print «-1».
[4] Iterate over the substrings; first time all of it, then without the first character, the two first, and so on.
[5] Pass on the two first characters (of the current substring) and the remaining characters to the recursive function doing the work.
[6] The recurive procedure (or monster).
[7] If the current string is a palindrome,
[8] • abort the recursion if we have already registered it (see «Stopped by [8]» in the Verbose output later on).
[9] • set it up so that we can detect the situation in [8], using the length of the remaining string as that is always the same (regardless of where we start (in [4]).
[10] Add the palindrome to the the result array.
[11] Recursively go on with the remaining string, if any.
[12] If we have a result, print it as a comma separated list with quoted strings [12a] and clear out the matches ready for the next iteration [12b].
[13] The block above (the if-block in [7]) gives the shortes match. This one gives the longest match. (Or rather, it adds another character to the string and does the recursion again, which in turn does both shortest and longest matching. Recursively.)
I may be easier to understand what is going on if you run the porgram with verbose mode (as shown later on), and walk through the output and the program code.
The expressions «shortest match» and «longest match» (in [13]) may remind you of «Shortest Token Matching» and «Longest Token Matching». So if you want to look into doing this with Regexes or a Grammar, you have a starting point.
Running it on the strings given in the challenge:
$ raku palindrome-partition 'aabaab'
'aa', 'baab'
'aabaa'
'aba'
$ raku palindrome-partition 'abbaba'
'abba'
'bb', 'aba'
'bab'
And with verbose mode (with some coloured comments, referring to the code):
$ raku palindrome-partition --verbose 'aabaab'
:: Start at pos 0 (string: 'aabaab')
:: Check 'aa' (Remainder: 'baab')
:: Match: 'aa'
:: Check 'ba' (Remainder: 'ab')
:: Check 'baa' (Remainder: 'b')
:: Check 'baab' (Remainder: '')
:: Match: 'baab'
'aa', 'baab'
:: Check 'aab' (Remainder: 'aab') # Given by [13]
:: Check 'aaba' (Remainder: 'ab')
:: Check 'aabaa' (Remainder: 'b')
:: Match: 'aabaa'
'aabaa'
:: Check 'aabaab' (Remainder: '')
:: Start at pos 1 (string: 'abaab')
:: Check 'ab' (Remainder: 'aab')
:: Check 'aba' (Remainder: 'ab')
:: Match: 'aba'
:: Check 'ab' (Remainder: '')
'aba'
:: Check 'abaa' (Remainder: 'b')
:: Check 'abaab' (Remainder: '')
:: Start at pos 2 (string: 'baab')
:: Check 'ba' (Remainder: 'ab')
:: Check 'baa' (Remainder: 'b')
:: Check 'baab' (Remainder: '') # Stopped by [8]
:: Start at pos 3 (string: 'aab')
:: Check 'aa' (Remainder: 'b')
:: Start at pos 4 (string: 'ab')
:: Check 'ab' (Remainder: '')
$ raku palindrome-partition --verbose 'abbaba'
:: Start at pos 0 (string: 'abbaba')
:: Check 'ab' (Remainder: 'baba')
:: Check 'abb' (Remainder: 'aba')
:: Check 'abba' (Remainder: 'ba')
:: Match: 'abba'
:: Check 'ba' (Remainder: '')
'abba'
:: Check 'abbab' (Remainder: 'a')
:: Check 'abbaba' (Remainder: '')
:: Start at pos 1 (string: 'bbaba')
:: Check 'bb' (Remainder: 'aba')
:: Match: 'bb'
:: Check 'ab' (Remainder: 'a')
:: Check 'aba' (Remainder: '')
:: Match: 'aba'
'bb', 'aba'
:: Check 'bba' (Remainder: 'ba')
:: Check 'bbab' (Remainder: 'a')
:: Check 'bbaba' (Remainder: '')
:: Start at pos 2 (string: 'baba')
:: Check 'ba' (Remainder: 'ba')
:: Check 'bab' (Remainder: 'a')
:: Match: 'bab'
'bab'
:: Check 'baba' (Remainder: '')
:: Start at pos 3 (string: 'aba')
:: Check 'ab' (Remainder: 'a')
:: Check 'aba' (Remainder: '')
:: Start at pos 4 (string: 'ba')
:: Check 'ba' (Remainder: '')
If you want the output in the same order as in the challenge, just move line [13] before line [7]. (The updated file «palindrome-partition2» is included in the zip file.)
Running it:
$ raku palindrome-partition2 'aabaab'
'aabaa'
'aa', 'baab'
'aba'
$ raku palindrome-partition2 'abbaba'
'abba'
'bb', 'aba'
'bab'
#! /usr/bin/env perl
use feature 'say';
use feature 'signatures';
no warnings qw(experimental::signatures);
my $verbose = 0;
if ($ARGV[0] eq "--verbose")
{
$verbose++;
shift @ARGV;
}
my $S = shift @ARGV || 'aabaab';
my @result;
my %match_with_remainder;
my $matches = 0;
for my $start (0 .. length($S) -2)
{
say ":: Start at pos $start (string: '" . substr($S, $start) . "')" if $verbose;
check(substr($S, $start, 2), substr($S, $start + 2));
}
sub check($string, $remainder)
{
say ":: Check '$string' (Remainder: '$remainder')" if $verbose;
check($string . substr($remainder, 0,1), substr($remainder, 1)) if length $remainder >= 1;
if ($string eq reverse $string)
{
next if $match_with_remainder{length $remainder};
$match_with_remainder{length $remainder} = 1;
push(@result, $string);
$matches++;
say ":: Match: '$string'" if $verbose;
check(substr($remainder,0,2), substr($remainder,2)) if length $remainder >= 2;
if (@result)
{
say join(", ", map { "'$_'" } @result);
@result = ();
}
}
}
say "-1" unless $matches;
Running it gives the same result as the Raku version.
And that's it.