TWC241

Challenge Link

Task1

We iterate every three-combination of the array and check if it satisfies the given condition:

#!/usr/bin/env perl
use strict;
use warnings;
use Algorithm::Combinatorics qw(combinations);

sub arithmetic_triplets{
  my $count = 0;
  my $iter = combinations($_[0],3);
  while(my $c = $iter->next){
    $count++ if($c->[1] - $c->[0]) == $_[1] == ($c->[2] - $c->[1]);
  }
  $count
}

printf "%d\n", arithmetic_triplets([0,1,4,6,7,10],3);
printf "%d\n", arithmetic_triplets([4,5,6,7,8,9],2);

Task2

We sort the array according to the number of prime factors of its elements, or the elements themselves in case the result is 0:

#!/usr/bin/env perl
use strict;
use warnings;
use ntheory qw(factor);

sub prime_order{
  sort{factor($a) <=> factor($b) || $a <=> $b} @{$_[0]};		
}

printf "(%s)\n", join ',',prime_order([11,8,27,4]);

TWC240

Challenge Link

Task1

We take the first character of each string and join them, then we check for equality of the resultant string with the check string (both case-folded):

#!/usr/bin/env perl
use strict;
use warnings;

sub acronym{
  CORE::fc (join '',map{substr $_,0,1}@{$_[0]}) eq CORE::fc $_[1];
}

printf "%d\n",acronym(["Perl", "Python", "Pascal"],"ppp");
printf "%d\n",acronym(["Perl", "Raku"],"rp");
printf "%d\n",acronym(["Oracle", "Awk", "C"],"oac");

Task2

We index the array with the array itself, since Perl allows multiple indexing like Fortran,APL,J,K,Matlab etc...

#!/usr/bin/env perl
use strict;
use warnings;

sub build_array{
  @{$_[0]}[@{$_[0]}];
}

printf "(%s)\n", join ',', build_array([0,2,1,5,3,4]);
printf "(%s)\n", join ',', build_array([5,0,1,2,3,4]);

TWC239

Challenge Link

Task1

We join each array's elements and check for equality:

1 2 3 4 5 6 7 8 9 10 11

#!/usr/bin/env perl use strict; use warnings; sub same_string{ join('',@{$_[0]}) eq join('',@{$_[1]}); } printf "%d\n",same_string(["ab","c"],["a","bc"]); printf "%d\n",same_string(["ab","c"],["ac","b"]); printf "%d\n",same_string(["ab","cd","e"],["abcde"]);

Task2

We check if each character in each string of array is in the allowed string:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16

#!/usr/bin/env perl use strict; use warnings; use List::Util qw(all); sub consistent_strings{ my ($arr,$allowed) = @_; scalar grep{all{index($allowed,$_) != -1} split '',$_}@$arr; } printf "%d\n",consistent_strings(['ad','bd','aaab','baa','badab'], 'ab'); printf "%d\n",consistent_strings(['a','b','c','ab','ac','bc','abc'], 'abc'); printf "%d\n",consistent_strings(['cc','acd','b','ba','bac','bad', 'ac','d'],'cad');

TWC238

Challenge Link

Task1

We iterate the array and add the current sum to the return value on each iteration:

#!/usr/bin/env perl
use strict;
use warnings;

sub running_sum{
  my $sum = 0;
  map{$sum += $_[0]->[$_]} 0..$#{$_[0]}
}

printf "(%s)\n",join ',',running_sum([1,2,3,4,5]);
printf "(%s)\n",join ',',running_sum([1,1,1,1,1]);
printf "(%s)\n",join ',',running_sum([0,-1,1,2]);

Task2

If the sort's helper returns 0 (meaning the items are equal after helper returns), the rhs of the <=> is used for sorting:

#!/usr/bin/env perl
use strict;
use warnings;
use List::Util qw(product);

sub persistence_sort{
  my $helper = sub{
    my ($sum,$n) = (0,@_);
    $n = do{$sum++; product split '',$n} until $n < 10;
    $sum
  };
  sort{$helper->($a) <=> $helper->($b) || $a <=> $b} @{$_[0]}
}

printf "(%s)\n",join ',',persistence_sort([15,99,1,34]);
printf "(%s)\n",join ',',persistence_sort([50,25,33,22]);

TWC237

Challenge Link

Task1

We are given a year,a month, a weekday of month and a day of week and we must print the corresponding day. The Nth_Weekday_of_Month_Year subroutine of the Date::Calc module can be used for this purpose:

1 2 3 4 5 6 7 8 9 10 11 12 13

#!/usr/bin/env perl use strict; use warnings; use Date::Calc qw(Nth_Weekday_of_Month_Year); sub seize_the_day{ my ($y,$m,$mday,$wday) = @_; (Nth_Weekday_of_Month_Year($y,$m,$wday,$mday))[2] // 0; } printf "%d\n",seize_the_day(2024,4,3,2); printf "%d\n",seize_the_day(2025,10,2,4); printf "%d\n",seize_the_day(2026,8,5,3);

Task2

We are asked to find the maximum count of when the arr[i] < perm[i] for all permutations of the given array:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18

#!/usr/bin/env perl use strict; use warnings; use Algorithm::Combinatorics qw(permutations); sub maximise_greatness{ my ($arr) = @_; my $max = 0; my $iter = permutations($arr); while(my $c = $iter->next){ my $count = grep{$arr->[$_] < $c->[$_]} 0..$#$arr; $max = $count if $count > $max; } $max } printf "%d\n",maximise_greatness([1,3,5,2,1,3,1]); printf "%d\n",maximise_greatness([1,2,3,4]);