Another week, time for another Weekly Perl Challenge!

Task 1: Lexicographic Order

You are given an array of strings.

Write a script to delete element which is not lexicographically sorted (forwards or backwards) and return the count of deletions.

Example 1

Input: @str = ("abc", "bce", "cae")
Output: 1

In the given array "cae" is the only element which is not lexicographically sorted.

Example 2

Input: @str = ("yxz", "cba", "mon")
Output: 2

In the given array "yxz" and "mon" are not lexicographically sorted.

I had to look up when “Lexicographic Order” was on the off chance that it wasn’t what I thought it was. Essentially, it means it’s sorted alphabetically. That was pretty obvious from the examples, so I just dove in:

#!/usr/bin/env perl

use v5.38;

sub quoted_list {
  # given a list, quote the elements and join them with commas
  my @quoted = map { qq{"$_"} } @_;
  return join q{, }, @quoted;
}

sub quoted_english_list {
  # given a list, quote the elements and join them 
  # in a way that makes sense to english speakers
  my @quoted = map { qq{"$_"} } @_;
  my $last = pop @quoted; # last element in array
  if (@quoted == 0) {
    # using an array in a scalar context returns
    # the number of elements in the array

    # there was only one element in the list
    return $last;
  }
  my $joined = join q{, }, @quoted;
  if (@quoted > 1) {
    # if there's more than element, add an Oxford comma
    $joined .= q{,};
  }
  return "$joined and $last";
}

sub is_lexically_sorted {
  my $input = shift @_;

  # get the characters in the input string
  my @characters = split //, $input;

  # generate a string of the characters sorted ascending
  # (with case folding)
  my $forwards  = join q{}, sort {
    fc($a) cmp fc($b)
  } @characters;

  # generate a string of the characters sorted descending
  # (with case folding)
  my $backwards = join q{}, sort {
    fc($b) cmp fc($a)
  } @characters;

  # if the input string is matches either sorted string,
  # then return true
  return( $input eq $forwards || $input eq $backwards );
}

sub solution {
  my @str = @_;
  say "Input: \@str = (" . quoted_list(@str) . ")";

  my @not_lexically_sorted = grep {
    ! is_lexically_sorted($_)
  } @str;

  say "Output: " . scalar(@not_lexically_sorted);
  say "";

  if (@not_lexically_sorted == 0) {
    say "In the given array all elements are"
      . " lexicographically sorted.";
  }
  elsif (@not_lexically_sorted == 1) {
    say "In the given array "
      . quoted_list(@not_lexically_sorted)
      . " is the only element which is not"
      . " lexicographically sorted.";
  }
  else {
    say "In the given array "
      . quoted_english_list(@not_lexically_sorted)
      . " are not lexicographically sorted.";
  }
}

say "Example 1:";
solution("abc", "bce", "cae");

say "";

say "Example 2:";
solution("yxz", "cba", "mon");

I added a bunch of extra subroutines to make the code more readable: quoted_list and quoted_english_list let me just say how I want to display the list, rather than repeating the code every time I want to display it. And the is_lexically_sorted function make the grep that I’m using to determine which array elements aren’t lexicographically sorted more readable as well. Whether it’s Perl or not, sometimes it’s just good coding practice to pull out pieces of your code that represent a concept and make them their own function, even if they’re only being used in only one place, because it just makes the code conceptually easier to understand.

The Raku version

#!/usr/bin/env raku

use v6;

sub quoted_list ( *@list ) {
  # given a list, quote the elements and join them with commas
  my @quoted = @list.map: { qq{"$_"} };
  return @quoted.join(q{, });
}

sub quoted_english_list ( *@list ) {
  # given a list, quote the elements and join them 
  # in a way that makes sense to english speakers
  my @quoted = @list.map: { qq{"$_"} };
  my $last = @quoted.pop(); # last element in array
  if (@quoted == 0) {
    # using an array in a scalar context returns
    # the number of elements in the array

    # there was only one element in the list
    return $last;
  }
  my $joined = join q{, }, @quoted;
  if (@quoted > 1) {
    # if there's more than element, add an Oxford comma
    $joined ~= q{,};
  }
  return "$joined and $last";
}

sub is_lexically_sorted ($input) {
  # get the characters in the input string
  # putting $input in quotes casts it as a Str
  my @characters = "$input".split("", :skip-empty);

  # sort the characters ascending
  my @forwards  = @characters.sort: { $^a.fc cmp $^b.fc };

  # sort the characters descending
  my @backwards = @characters.sort: { $^b.fc cmp $^a.fc };

  # if the input string is matches either sorted string,
  # then return true
  return( $input eq @forwards.join("")
          ||
          $input eq @backwards.join("") );
}

sub solution (*@str) {
  say "Input: \@str = (" ~ quoted_list(@str) ~ ")";

  my @not_lexically_sorted = @str.grep({
    !is_lexically_sorted($_)
  });

  say "Output: " ~ @not_lexically_sorted.elems;
  say "";

  if (@not_lexically_sorted.elems == 0) {
    say "In the given array all elements are"
      ~ " lexicographically sorted.";
  }
  elsif (@not_lexically_sorted.elems == 1) {
    say "In the given array "
      ~ quoted_list(@not_lexically_sorted)
      ~ " is the only element which is not"
      ~ " lexicographically sorted.";
  }
  else {
    say "In the given array "
      ~ quoted_english_list(@not_lexically_sorted)
      ~ " are not lexicographically sorted.";
  }
}

say "Example 1:";
solution("abc", "bce", "cae");

say "";

say "Example 2:";
solution("yxz", "cba", "mon");

This is mostly like the Perl solution above, but I decided to play around a little with slurpy parameters in my function signatures.

Task 2: Two out of Three

You are given three array of integers.

Write a script to return all the elements that are present in at least 2 out of 3 given arrays.

Example 1

Input: @array1 = (1, 1, 2, 4)
       @array2 = (2, 4)
       @array3 = (4)
Ouput: (2, 4)

Example 2

Input: @array1 = (4, 1)
       @array2 = (2, 4)
       @array3 = (1, 2)
Ouput: (1, 2, 4)

Perl version:

#!/usr/bin/env perl

use v5.38;

# function to return unique elements in array
use List::Util qw( uniq );

sub display_array {
  return "(" . join(q{, }, @_) . ")";
}

sub solution {
  my @arrays = @_;
  say "Input: \@array1 = " . display_array( @{ $arrays[0] } );
  say "       \@array2 = " . display_array( @{ $arrays[1] } );
  say "       \@array3 = " . display_array( @{ $arrays[2] } );

  # Return all the elements that are present in at least 2 out
  # of 3 given arrays.  In the sample input, there are arrays 
  # where there elements appear multiple times in a given
  # array, so we want to examine only UNIQUE elements
  my @unique;
  foreach my $arrayref ( @arrays ) {
    push @unique, [ uniq @$arrayref ];
  }

  # now that we have arrays of only unique elements, let's find
  # elements that occur in more than one array using a hash
  my %occurrences;
  foreach my $arrayref ( @unique ) {
    foreach my $element ( @$arrayref ) {
      $occurrences{$element}++;
    }
  }

  say "Output: " . display_array(
    sort # sort the resulting array of elements numerically
    grep {
      # only include elements that were counted more than once
      $occurrences{$_} > 1;
    } keys %occurrences
  );
}

say "Example 1:";
solution(
  [1, 1, 2, 4],
  [2, 4],
  [4]
);

say "";

say "Example 2:";
solution(
  [4, 1],
  [2, 4],
  [1, 2]
);

Raku version

#!/usr/bin/env raku

use v6;

sub display_array (@array) {
  return "(" ~ @array.join(q{, }) ~ ")";
}

sub solution (@array1, @array2, @array3) {
  say "Input: \@array1 = " ~ display_array(@array1);
  say "       \@array2 = " ~ display_array(@array2);
  say "       \@array3 = " ~ display_array(@array3);

  # Return all the elements that are present in at least 2 out
  # of 3 given arrays.  In the sample input, there are arrays
  # where there elements appear multiple times in a given
  # array, so we want to examine only UNIQUE elements, then
  # find elements that occur in more than one array using
  # a hash
  my %occurrences;
  for ( @array1.unique,
        @array2.unique,
        @array3.unique ).flat -> $element {
    %occurrences{$element}++;
  }

  say "Output: " ~ display_array(
    # only include elements that were counted more than once
    %occurrences.keys().grep: { %occurrences{$_} > 1 } 
  ).sort; # sort the resulting array of elements numerically
}

say "Example 1:";
solution(
  (1, 1, 2, 4),
  (2, 4),
  (4,)
);

say "";

say "Example 2:";
solution(
  (4, 1),
  (2, 4),
  (1, 2)
);

I want to point out my discovering the .flat method for Arrays.

Note that in the Perl version, I’m passing around array references to keep the three lists, separate, but in Raku, I’m able to make the three different parameters full-on arrays. Also, in Perl I had to pull in a function from a core module to get a list of unique elements in an array, but in Raku, the .unique method is provide on the base class Any.

Here’s my solutions in GitHub: https://github.com/manwar/perlweeklychallenge-club/tree/master/challenge-229/packy-anderson

Another week, time for another Perl Weekly Challenge!

Task 1: Unique Sum

You are given an array of integers.

Write a script to find out the sum of unique elements in the given array.

Example 1

Input: @int = (2, 1, 3, 2)
Output: 4

In the given array we have 2 unique elements (1, 3).

Example 2

Input: @int = (1, 1, 1, 1)
Output: 0

In the given array no unique element found.

Example 3

Input: @int = (2, 1, 3, 4)
Output: 10

In the given array every element is unique.

The examples make what this challenge is looking for pretty clear. We find the unique elements in the array, and sum those up. I immediately thought of using a hash to accomplish the task:

# find the unique elements
my %unique;
foreach my $int ( @ints ) {
  $unique{$int}++;
}

# make a list of ONLY the unique ints
my @unique_ints = grep { $unique{$_} == 1 } @ints;

It’s a common use-case in Perl to use a hash to count how many times something occurs, whether it’s to only do something once or to actually count up occurrences.

I guess I could have populated the %unique hash via a map, but I wanted to keep what the code was doing obvious, and sometimes I think using a map just to execute code in the code block and not to return an array/hash can be confusing.

map { $unique{$_}++ } @ints;

The other thing I knew I wanted to do was show off some List::Util functions

use List::Util qw( sum );

# sum the unique elements
my $sum = sum(@unique_ints) // 0;

Sure, it would be easy enough to say

my $sum = 0;
foreach my $int ( @unique_ints ) {
  $sum += $int;
}

But sum makes it is a lot shorter. So here’s the entire script…

#!/usr/bin/env perl

use v5.38;

use List::Util qw( sum );

# just accept the list of integers on the command line
my @ints = @ARGV;

# find the unique elements
my %unique;
foreach my $int ( @ints ) {
  $unique{$int}++;
}

# make a list of ONLY the unique ints
my @unique_ints = grep { $unique{$_} == 1 } @ints;

# sum the unique elements
my $sum = sum(@unique_ints) // 0;

# produce the output
say "Input: \@int = (" . join(', ', @ints) . ")";
say "Output: $sum";
say "";

print "In the given array ";
if ( scalar(@unique_ints) == scalar(@ints) ) {
  say "every element is unique.";
}
elsif ( scalar(@unique_ints) == 0 ) {
  say "no unique element found.";
}
else {
  say "we have " . scalar(@unique_ints) . " unique elements ("
    . join(', ', @unique_ints) . ").";
}

As always, I started with my Perl script and made changes to make it valid Raku:

#!/usr/bin/env raku

use v6;

# just accept the list of integers on the command line
my @ints = @*ARGS;

# find the unique elements
my %unique;
for @ints -> $int {
  %unique{$int}++;
}

# make a list of ONLY the unique ints
my @unique_ints = grep { %unique{$_} == 1 }, @ints;

# sum the unique elements
my $sum = [+] @unique_ints;

# produce the output
say "Input: \@int = (" ~ @ints.join(', ') ~ ")";
say "Output: $sum";
say "";

print "In the given array ";
if ( @unique_ints.elems == @ints.elems ) {
  say "every element is unique.";
}
elsif ( @unique_ints.elems == 0 ) {
  say "no unique element found.";
}
else {
  say "we have " ~ @unique_ints.elems ~ " unique elements ("
    ~ @unique_ints.join(', ') ~ ").";
}

Now, the big decision I had to make was how to do the sum. I picked showing off Raku’s Reduction Metaoperator: [ ]. When you put an operator between square brackets and put that in front of a Raku Positional (like an Array), it turns the Positional into a single value by applying the operator to the first two elements, and then applying the operator to the result and the next element, and so on until the Positional has run out of elements. You can multiply all the elements of a Positional using [*], you can concatenate all the elements of a Positional using [~], There’s even a max infix operator that given two operands will return the larger of the two, and this can be applied to a Positional to find the largest value using [max].

But I could have used the .sum routine provided by Raku’s List class (which Arrays are a subclass of):

my $sum = @unique_ints.sum;

Task 2: Empty Array

You are given an array of integers in which all elements are unique.

Write a script to perform the following operations until the array is empty and return the total count of operations.

If the first element is the smallest then remove it otherwise move it to the end.

Example 1

Input: @int = (3, 4, 2)
Output: 5

Operation 1: move 3 to the end: (4, 2, 3)
Operation 2: move 4 to the end: (2, 3, 4)
Operation 3: remove element 2: (3, 4)
Operation 4: remove element 3: (4)
Operation 5: remove element 4: ()

Example 2

Input: @int = (1, 2, 3)
Output: 3

Operation 1: remove element 1: (2, 3)
Operation 2: remove element 2: (3)
Operation 3: remove element 3: ()

This time, the List::Util function I wanted to use was min:

#!/usr/bin/env perl

use v5.38;

use List::Util qw( min );

# just accept the list of integers on the command line
my @ints = @ARGV;

my @operations;
my $count = 1;
while ( scalar(@ints) > 0 ) {
  my $min = min @ints;

  # in either case, we're removing the first element from the list
  my $first = shift @ints;

  if ($min == $first) {
    # the first element is the minimum, discard it
    push @operations, "Operation $count: "
                    . "remove element $min: ("
                    . join(',', @ints) . ")";
  }
  else {
    # the first element is NOT the minimum, add it to the end
    push @ints, $first;
    push @operations, "Operation $count: "
                    . "move $first to the end: ("
                    . join(',', @ints) . ")";
  }
  $count++;
}

# produce the output
# let's use @ARGV again, since we modify @ints as we go along
say "Input: \@int = (" . join(', ', @ARGV) . ")";
say "Output: " . scalar(@operations);
say "";
say join "\n", @operations;

This also does an excellent job of showing off array operations: shift to remove the first element of an array, and push to append an element to the end of an array (though, I will admit I really like the way PHP allows you to append to the end of an array: $ints[] = $first).

At first, I was using $ints[0] to examine the first element in the array and then using shift to remove it and discard the value if the first element was the minimum value, and if it wasn’t, using shift to remove the first value and save itm like this:

if ($min == $ints[0]) {
  shift @ints;
  push @operations, ...;
}
else {
  my $first = shift @ints;
  push @operations, ...;
}

But then I realized that I was shift-ing the value off @ints in either case, and it would just be cleaner to do it before the comparison so I could use $first instead of $ints[0].

The Raku version is nothing fancy this time:

#!/usr/bin/env raku

use v6;

# just accept the list of integers on the command line
my @ints = @*ARGS;

my @operations;
my $count = 1;
while ( @ints.elems > 0 ) {
  my $min = @ints.min;

  # in either case, we're removing the first element
  # from the list
  my $first = @ints.shift;

  if ($min == $first) {
    # the first element is the minimum, discard it
    push @operations, "Operation $count: "
                    ~ "remove element $min: ("
                    ~ @ints.join(', ') ~ ")";
  }
  else {
    # the first element is NOT the minimum, add it to the end
    push @ints, $first;
    push @operations, "Operation $count: "
                    ~ "move $first to the end: ("
                    ~ @ints.join(', ') ~ ")";
  }
  $count++;
}

# produce the output
# let's use @ARGV again, since we modofy @ints as we go along
say "Input: \@int = (" ~ @*ARGS.join(', ') ~ ")";
say "Output: " ~ @operations.elems;
say "";
say join "\n", @operations;

This week’s challenge brought two new tasks: Friday the 13^th & Roman Maths.

Task 1: Friday 13th

You are given a year number in the range 1753 to 9999.

Write a script to find out how many dates in the year are Friday 13th, assume that the current Gregorian calendar applies.

Example

Input: $year = 2023
Output: 2

Since there are only 2 Friday 13th in the given year 2023 i.e. 13th Jan and 13th Oct.

This was going to be easy, because I knew there were date manipulation modules in the core distribution: Time::Piece and Time::Seconds. I figured I wanted to start at the first of the year, add one day in a loop until I found the first Friday, and then skip from one Friday to the next by adding seven days, using the wday property of a Time::Piece object to check whether or not the date was the 13^th. Yes, instantiating the first day of the year would have been easier using the DateTime module, but I wanted to use only core modules if they did what I needed (and, really how much more complex is Time::Piece->strptime("$year-01-01", "%Y-%m-%d")->truncate(to => 'day'); versus DateTime->new(year => $year, month => 1, day => 1)->truncate(to => 'day');).

#!/usr/bin/env perl
use v5.38;

# let's use the core modules for date manipulation
use Time::Piece;
use Time::Seconds qw( ONE_DAY );

# get the year from the command line
my $year = shift @ARGV
  or die "usage: $0 year\n";

# do bounds checking as specified in the problem
if ($year < 1753 || $year > 9999) {
  die "Only years between 1753 to 9999 are allowed ($year is out of range)\n";
}

# create an object for Jan 01 of the given year
my $t = Time::Piece->strptime("$year-01-01", "%Y-%m-%d")
                   ->truncate(to => 'day');

# find the first friday
# in Time::Piece->wday, 1 = Sunday, 6 = Friday
while ( $t->wday != 6) {
  $t += ONE_DAY; # add 1 day
}

# now keep adding 7 days to the date until the year changes,
# noting how many times the day of the month is 13
my $thirteen_count = 0;
while ( $t->year == $year ) {
  $thirteen_count++ if $t->mday == 13;
  $t += ONE_DAY * 7;
}

say "Input: \$year = $year";
say "Output: $thirteen_count";

Doing this problem in Raku wound up being even easier, because in Raku, Date objects are a native part of the language, and incrementing a Date object increases the value by one day. Even instantiating a Date object was easier, because I didn’t need to parse a date format or specify an array with 0-indexed months or years with 1900 subtracted from them, I was able to specify a year, month, day in my new() call:

#!/usr/bin/env raku

sub MAIN($year) {
  # do bounds checking as specified in the problem
  if ($year < 1753 || $year > 9999) {
    say "Only years between 1753 to 9999 are allowed ($year is out of range)";
    exit 1;
  }

  # create an object for Jan 01 of the given year
  my $t = Date.new($year, 1, 1);

  # find the first friday
  # in Date.day-of-week, 0 = Sunday, 5 = Friday
  while ( $t.day-of-week != 5) {
    $t++; # add 1 day
  }

  # now keep adding 7 days to the date until the year changes,
  # noting how many times the day of the month is 13
  my $thirteen_count = 0;
  while ( $t.year == $year ) {
    $thirteen_count++ if $t.day == 13;
    $t += 7;
  }

  say "Input: \$year = $year";
  say "Output: $thirteen_count";
}

Task 2: Roman Maths

Write a script to handle a 2-term arithmetic operation expressed in Roman numeral.

Example

IV + V     => IX
M - I      => CMXCIX
X / II     => V
XI * VI    => LXVI
VII ** III => CCCXLIII
V - V      => nulla (they knew about zero but didn't have a symbol)
V / II     => non potest (they didn't do fractions)
MMM + M    => non potest (they only went up to 3999)
V - X      => non potest (they didn't do negative numbers)

Now, I’m not going to get into how Roman numerals did have ways of expressing fractions or numbers larger that 3,999, because that’s not part of the challenge. Remember, I want to showcase how easy it is to solve problems in Perl & Raku. And I knew just the module to use: Roman. Unfortunately, none of the modules for manipulating Roman numerals are in the core Perl distribution, so I had to use cpanm to install it: $ cpanm Roman (I could have used $ cpan install Roman instead, but I like the cpanm tool).

#!/usr/bin/env perl
use v5.38;

use Roman; # there's a module for handling Roman Numerals!

sub do_arithmetic {
  my $line = shift;
  # split the inout line into the three parts:
  # the two operands and the infix operator
  my($operand1r, $operator, $operand2r) = split /\s+/, $line;
  unless (defined $operand1r &&
          defined $operator  &&
          defined $operand2r) {
    say q{Lines must be of the form "operand1 operator operand2"};
    say q{where both operands are valid roman numerals and the};
    say q{operator is one of the following:  +  -  *  /  **};
    return;
  }

  my($operand1a, $operand2a);

  # check that the first operand is a roman numeral
  if (isroman($operand1r)) {
    # it is a roman numeral, convert it
    $operand1a = arabic($operand1r);
  }
  else {
    say "'$operand1r' is not a roman numberal!";
    return;
  }

  # check that the second operand is a roman numeral
  if (isroman($operand2r)) {
    # it is a roman numeral, convert it
    $operand2a = arabic($operand2r);
  }
  else {
    say "'$operand2r' is not a roman numberal!";
    return;
  }

  # calculate the results
  my $result;
  if ($operator eq '+') {
    $result = $operand1a + $operand2a;
  }
  elsif ($operator eq '-') {
    $result = $operand1a - $operand2a;
  }
  elsif ($operator eq '*') {
    $result = $operand1a * $operand2a;
  }
  elsif ($operator eq '/') {
    $result = $operand1a / $operand2a;
  }
  elsif ($operator eq '**') {
    $result = $operand1a ** $operand2a;
  }
  else {
    die "Unknown operator '$operator'; valid operators are + - * / **\n";
  }

  # handle all the special output cases
  if ($result == 0) {
    say "$operand1r $operator $operand2r => nulla "
      . "(they knew about zero but didn't have a symbol)";
  }
  elsif (int($result) != $result) {
    say "$operand1r $operator $operand2r => non potest "
      . "(they didn't do fractions)";
  }
  elsif ($result > 3999) {
    say "$operand1r $operator $operand2r => non potest "
      . "(they only went up to 3999)";
  }
  elsif ($result < 0) {
    say "$operand1r $operator $operand2r => non potest "
      . "(they didn't do negative numbers)";
  }
  else {
    say "$operand1r $operator $operand2r => " . uc roman($result);
  }
}

# while we have input on STDIN, process the calculations
while (my $line = <>) {
  chomp $line;
  do_arithmetic($line);
}

At first, I whipped it up as a command-line tool that accepted the two operands and the operator on the command line, but I realized it wouldn’t be easy to produce output as close to the sample as possible doing things this way, so I modified it to read the operations from STDIN. This also allowed me to add a file that could be used by both my Perl and Raku solutions to make the input standardized.

I also wanted to do some extra checking: not just the stuff between lines 53-72 to handle the special cases called out in the example; I wanted to check for invalid Roman numerals and for input that didn’t have two operands separated by an operator. Lines 22-40 do the check using the isroman() function provided by the Roman module, and lines 49-51 make sure that we generate an error if we’re not passed one of the five operators specified in the requirements.

The Raku version of this proved slightly more challenging, because the Math::Roman module available for Raku didn’t have a function corresponding to Perl’s Roman module’s isroman() function. So I had to make one:

#!/usr/bin/env raku
use Math::Roman; # it's v0.0.1, but usable

sub isroman ( $var ) {
  # Math::Roman doesn't have a test to see if a string is
  # a Roman numeral, but it does throw an exception if it
  # cannot convert it
  my $result;
  try {
    CATCH {
      default {
        return False;
      }
    }
    $result = Math::Roman.new: $var;
  }
  # Math::Roman also doesn't respect the maximum of 3999
  if ($result.as-arabic > 3999) {
    return False;
  }

  return True;
}

sub do_arithmetic (Str $line) {
  # split the inout line into the three parts:
  # the two operands and the infix operator
  my ($operand1, $operator, $operand2) = $line.split(/\s+/);

  unless (defined $operand1 &&
          defined $operator  &&
          defined $operand2) {
    say q{Lines must be of the form "operand1 operator operand2"};
    say q{where both operands are valid roman numerals and the};
    say q{operator is one of the following:  +  -  *  /  **};
    return;
  }

  # check that the first operand is a roman numeral
  if (isroman($operand1)) {
    # it is a roman numeral, convert it
    $operand1 = Math::Roman.new: $operand1;
  }
  else {
    say "'$operand1' is not a roman numberal!";
    return;
  }

  # check that the second operand is a roman numeral
  if (isroman($operand2)) {
    # it is a roman numeral, convert it
    $operand2 = Math::Roman.new: $operand2;
  }
  else {
    say "'$operand2' is not a roman numberal!";
    return;
  }

  # # calculate the results
  my $result;
  if ($operator eq '+')     {
    $result = $operand1.as-arabic + $operand2.as-arabic;
  }
  elsif ($operator eq '-')  {
    $result = $operand1.as-arabic - $operand2.as-arabic;
  }
  elsif ($operator eq '*')  {
    $result = $operand1.as-arabic * $operand2.as-arabic;
  }
  elsif ($operator eq '/')  {
    $result = $operand1.as-arabic / $operand2.as-arabic;
  }
  elsif ($operator eq '**') {
    $result = $operand1.as-arabic ** $operand2.as-arabic;
  }
  else {
    die "Unknown operator '$operator'; valid operators are + - * / **\n";
  }

  # handle all the special output cases
  if ($result == 0) {
    say "$operand1 $operator $operand2 => nulla "
      ~ "(they knew about zero but didn't have a symbol)";
  }
  elsif ($result.truncate != $result) {
    say "$operand1 $operator $operand2 => non potest "
      ~ "(they didn't do fractions)";
  }
  elsif ($result > 3999) {
    say "$operand1 $operator $operand2 => non potest "
      ~ "(they only went up to 3999)";
  }
  elsif ($result < 0) {
    say "$operand1 $operator $operand2 => non potest "
      ~ "(they didn't do negative numbers)";
  }
  else {
    $result = Math::Roman.new: value => $result.Int;
    say "$operand1 $operator $operand2 => $result";
  }
}

# while we have input on STDIN, process the calculations
for $*IN.lines -> $line {
  do_arithmetic($line);
}

I went to the Perl and Raku Conference in Toronto, ON, two weeks ago. I went because I really wanted to reconnect with the Perl community that I’d fallen out of touch with while I was working at a job where Perl was actively ridiculed.

While I was there, I was talking to one of the people giving talks, Bruce Gray. He suggested that one of the best ways to reconnect would be to do the weekly challenge.

I’d seen the challenge being talked about in emails I subscribed to, but I hadn’t given it much thought. But I wanted to reconnect, keep my Perl chops up to date, and generally start participating in the community again. So when I got the email for Challenge #226, I thought about it a bit. What I realized was that the challenge wasn’t just a way for people to showcase their Perl skills; it was a way for the community to showcase how easy Perl and Raku were to use. So I decided that was the approach I was going to take: not try to be clever, but try to show how easy this language I love is to solve problems.

Task 1: Shuffle String

Here’s the description provided in the challenge:

You are given a string and an array of indices of same length as string.
Write a script to return the string after re-arranging the indices in the correct order.

Example 1

Input: $string = 'lacelengh', @indices = (3,2,0,5,4,8,6,7,1)
Output: 'challenge'

Example 2

Input: $string = 'rulepark', @indices = (4,7,3,1,0,5,2,6)
Output: 'perlraku'

I won’t lie, it took me a little while to understand what it wanted me to do. Finally, I realized that the @indicies array was showing me where in the output string the character from the input string should be moved to: the first character in the input string should be moved to the 3rd position in the output, the second character to the 2nd position, the third to the 0th position and so on. Once I grokked that requirement, the Perl implementation came easily:

#!/usr/bin/env perl
use v5.36;

sub shuffle_string {
  my($string, $indices) = @_;
  my @chars = split //, $string; # split input string into characters
  my @result;
  foreach my $index ( @$indices ) {
    my $char  = shift @chars;     # get the next character
    $result[$index] = $char;      # put the character at that index in the result
  }
  say "Input: \$string = '$string', \@indices = (" . join(',', @$indices) . ")";
  say "Output: '" . join(q{}, @result) . "'";
}

say "Task 1: Shuffle String";
say "\nExample 1";
shuffle_string('lacelengh', [3,2,0,5,4,8,6,7,1]);
say "\nExample 2";
shuffle_string('rulepark', [4,7,3,1,0,5,2,6]);

Note how Perl makes handling the parts of the problem easy: splitting a string into its component characters is easy, recombining them back into a string is easy, passing the data around is easy.

Now, I don’t have a lot of experience with Raku; but I want to get better at it, so that’s why I’m doing the challenges in Raku as well. Unfortunately, for the moment my Raku solutions will look a lot like my Perl solutions:

#!/usr/bin/env raku

sub shuffle_string ($string, @indices) {
  my @chars = $string.split("", :skip-empty);
  my @result;
  for @indices -> $index {
    my $char = shift @chars;   # get the next character
    @result[$index] = $char;   # put the character at that index in the result
  }
  say "Input: \$string = '$string', \@indices = (" ~ @indices.join(',') ~ ")";
  say "Output: '" ~ @result.join('') ~ "'";
}

say "Task 1: Shuffle String";
say "\nExample 1";
shuffle_string('lacelengh', (3,2,0,5,4,8,6,7,1));
say "\nExample 2";
shuffle_string('rulepark', (4,7,3,1,0,5,2,6));

Task 2: Zero Array

You are given an array of non-negative integers, @ints.

Write a script to return the minimum number of operations to make every element equal zero.

In each operation, you are required to pick a positive number less than or equal to the smallest element in the array, then subtract that from each positive element in the array.

Example 1:

Input: @ints = (1, 5, 0, 3, 5)
Output: 3

operation 1: pick 1 => (0, 4, 0, 2, 4)
operation 2: pick 2 => (0, 2, 0, 0, 2)
operation 3: pick 2 => (0, 0, 0, 0, 0)

Example 2:

Input: @ints = (0)
Output: 0

Example 3:

Input: @ints = (2, 1, 4, 0, 3)
Output: 4

operation 1: pick 1 => (1, 0, 3, 0, 2)
operation 2: pick 1 => (0, 0, 2, 0, 1)
operation 3: pick 1 => (0, 0, 1, 0, 0)
operation 4: pick 1 => (0, 0, 0, 0, 0)

This one I found a lot easier to understand for some reason.

#!/usr/bin/env perl
use v5.36;

use List::Util qw( min );

sub min_positive {
  my @ints = grep { $_ > 0 } @_; # only consider positive numbers
  return min @ints; # find smallest, undef if empty list
}

sub zero_array {
  my @ints = @_;
  say "Input: \@ints = (" . join(', ', @ints) . ")";
  my @operations;
  while ( my $min = min_positive(@ints) ) {
    my $op_num = scalar(@operations) + 1;
    foreach my $int ( @ints ) {
      $int -= $min if $int > 0;
    }
    push @operations, "operation $op_num: pick $min => (" . join(', ', @ints) . ")";
  }
  say "Output: " . scalar(@operations);
  if (@operations) {
    say "";
    say join "\n", @operations;
  }
}

say "Task 2: Zero Array";
say "\nExample 1";
zero_array(1, 5, 0, 3, 5);

say "\nExample 2";
zero_array(0);

say "\nExample 3";
zero_array(2, 1, 4, 0, 3);

This one I’d like to pull apart a bit more. Picking “a positive number less than or equal to the smallest element in the array” sounded a lot like the min function found in the List::Util module, but that gives us the minimum value, not the minimum non-zero value, so I needed to filter the values equal to zero out of the array first. Initially, I did it like this:

min grep { $_ > 0 } @ints

but then I realized I needed to do that as part of the conditional to a loop, and I decided it would be a lot more readable if I pulled it out into it’s own function. Remember, I’m trying to express how easy things are in Perl, so I want to make my solutions completely readable and understandable to people who have never used Perl before.

I wanted the output to look exactly like the text in the examples, so I made the minimal extra effort to build an array of operations and put a bit of formatting into that so I could just dump the operations when I’d found out how many operations were necessary.

Again, my Raku solution looks like my Perl solution with a few syntax tweaks:

#!/usr/bin/env raku

sub min_positive (@ints) {
  my @positive = @ints.grep({ $_ > 0 }); # only consider positive numbers
  return unless @positive.elems;         # return early if no positive nums
  return @positive.reduce(&min);         # find smallest
}

sub zero_array (@ints) {
  say "Input: \@ints = (" ~ @ints.join(', ') ~ ")";
  my @operations;
  while ( my $min = min_positive(@ints) ) {
    my $op_num = @operations.elems + 1;
    for @ints <-> $int {
      $int -= $min if $int > 0;
    }
    @operations.push("operation $op_num: pick $min => (" ~ @ints.join(', ') ~ ")");
  }
  say "Output: " ~ @operations.elems;
  if (@operations) {
    say "";
    say @operations.join("\n");
  }
}

say "Task 2: Zero Array";
say "\nExample 1";
zero_array([1, 5, 0, 3, 5]);

say "\nExample 2";
zero_array([0]);

say "\nExample 3";
zero_array([2, 1, 4, 0, 3]);

If you really want a good example of how Raku can be used to solve this problem, take a look at Bruce Gray’s solution.

And that’s it. I’ve already coded my solutions for Challenge #227, and I’ll be blogging about them soon.