TWC249

Challenge Link

Task1

We count the values in a hash, if there are any odd number counts, we return an empty array, else we pair up the elements:

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

sub equal_pairs{
  my %h;
  $h{$_}++ foreach @{$_[0]};
  (all{$_%2} values %h) ? () : map{my $k=$_;map{[$k,$k]}1..$h{$k}/2}keys %h;
}

print show equal_pairs([3,2,3,2,2,2]);
print show equal_pairs([1,2,3,4]);

Task2

We initialize two variables $i and $j to 0 and length of the string respectively, if the character in the string is equal to 'I' then we increment $i else we decrement $j, and lastly append the $i to the end of the result:

#!/usr/bin/env perl
use strict;
use warnings;
use Data::Show;

sub di_string_match{
  my ($i,$j) = (0,length $_[0]);
  (map{$_ eq 'I' ? $i++ : $j--}split '',$_[0]),$i;
}

print show di_string_match('IDID');
print show di_string_match('III');
print show di_string_match('DDI');

TWC248

Challenge Link

Task1

We take the distances and append them to an array:

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

sub shortest_distance{
  my @arr = split'',$_[0];
  map{my $i = $_; min map{abs $i - $_}indexes{$_ eq $_[1]}@arr}0..$#arr;
}

printf "(%s)\n",join ',',shortest_distance('loveleetcode','e');
printf "(%s)\n",join ',',shortest_distance('aaab','b');

Task2

We use the given formula to calculate the sums:

#!/usr/bin/env perl
use strict;
use warnings;
use Data::Show;

sub submatrix_sum{
  my ($m) = @_;
  my @ret;
  foreach my $i(0..$#$m-1){
    push @ret,[];
    foreach my $j(0..$#{$m->[0]}-1){
      $ret[$i][$j] = $m->[$i][$j] + $m->[$i][$j+1] +
	$m->[$i+1][$j] + $m->[$i+1][$j+1]
    }
  }
  @ret
}

print show submatrix_sum([[1,2,3,4],[5,6,7,8],[9,10,11,12]]);
print show submatrix_sum([[1,0,0,0],[0,1,0,0],[0,0,1,0],[0,0,0,1]]);

TWC245

Challenge Link

Task1

Subtract 1 from popularity indices and index the array to get a sorted array by popularity:

#!/usr/bin/env perl
use strict;
use warnings;
use Data::Show;

sub sort_language{
  @{$_[0]}[map{$_-1}@{$_[1]}];
}

print show sort_language(['perl','c','python'],[2,1,3]);
print show sort_language(['c++','haskell','java'],[1,3,2]);

Task2

We iterate over each permutation of subsets of the array and check for the given condition:

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

sub largest_of_three{
  my $res = -1;
  foreach my $i(0..@{$_[0]}){
    foreach my $subset(subsets $_[0],$i){
      foreach my $p(permutations $subset){
        next unless @$p;
        my $n = join '',@$p;
        $res = $n if $n > $res && $n % 3 == 0;
      }
    }
  }
  $res
}

printf "%d\n",largest_of_three([8,1,9]);
printf "%d\n",largest_of_three([8,6,7,1,0]);
printf "%d\n",largest_of_three([1]);

TWC244

Challenge Link

Task1

for each element we count the elements which are smaller that it:

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

sub count_smaller{
  my ($arr) = @_;
  map{my $e = $_;scalar grep{$_ < $e}@$arr}@$arr;
}

printf "(%s)\n",join ',',count_smaller([8,1,2,2,3]);
printf "(%s)\n",join ',',count_smaller([6,5,4,8]);
printf "(%s)\n",join ',',count_smaller([2,2,2]);

Task2

We iterate all the subsets of of the list and accumulate the sum according to the given rules:

#!/usr/bin/env perl
use strict;
use warnings;
use List::Util qw(min max);
use Algorithm::Combinatorics qw(subsets);

sub group_hero{
  my $sum = 0;
  my $it = subsets($_[0]);
  while(my $c = $it->next){
    $sum += (max(@$c) ** 2) * min(@$c) if @$c;
  }
  $sum
}

printf "%d\n", group_hero([2,1,4]);

TWC243

Challenge Link

Task1

We take each two-combination of the list and check if it satisfies the condition:

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

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

printf "%d\n",reverse_pairs([1,3,2,3,1]);
printf "%d\n",reverse_pairs([2,4,3,5,1]);

Task2

We take each two-pairs of the resultant cross product of the list and accumulate their floor sums:

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

sub floor_sum{
  my $it = variations_with_repetition($_[0],2);
  my $sum = 0;
  while(my $c = $it->next){
    $sum += int($c->[0] / $c->[1]);
  }
  $sum
}

printf "%d\n",floor_sum([2,5,9]);
printf "%d\n",floor_sum([7,7,7,7,7,7,7]);

TWC242

Challenge Link

Task1

We convert each array to a set, then take their difference:

#!/usr/bin/env perl
use strict;
use warnings;
use Data::Show;
use Set::Scalar;

sub missing_members{
  my $s1 = Set::Scalar->new(@{$_[0]});
  my $s2 = Set::Scalar->new(@{$_[1]});
  [($s1-$s2)->members],[($s2-$s1)->members]
}

print show missing_members([1,2,3],[2,4,6]);
print show missing_members([1,2,3,3],[1,1,2,2]);

Task2

We reverse each sub-array of the matrix and xor each bit with 1 to flip it:

#!/usr/bin/env perl
use strict;
use warnings;
use Data::Show;

sub flip_matrix{
  map{[map {$_^1} reverse @$_]}@{$_[0]};
}

print show flip_matrix([[1,1,0],[1,0,1],[0,0,0]]);
print show flip_matrix([[1,1,0,0],[1,0,0,1],[0,1,1,1],[1,0,1,0]]);

TWC127

Challenge Link

Task1

Two sets are disjoint if they have no common elements, which means the count of the items in both sets are all 1.

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

sub disjoint_sets{
  my ($s1,$s2) = @_;
  my %h;
  map{$h{$s1->[$_]}++; $h{$s2->[$_]}++} 0..$#$s1;
  all{$_ == 1} values %h;
}

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

Task2

Two intervals conflict if x1 >= x2 and x1 <= y2 where (x1,y1),(x2,y2) are our intervals:

#!/usr/bin/env perl
use strict;
use warnings;
use Data::Show;

sub conflict_intervals{
  my ($arr) = @_;
  my @ret;
  foreach my $i(1..$#$arr){
    my $b = 0;
    foreach my $j(0..$i-1){
      $b = 1 if $arr->[$i][0] >= $arr->[$j][0] &&
	$arr->[$i][0] <= $arr->[$j][1];
    }
    push @ret, $arr->[$i] if $b;
  }
  @ret
}

print show conflict_intervals([[1,4],[3,5],[6,8],[12,13],[3,20]]);
print show conflict_intervals([[3,4],[5,7],[6,9],[10,12],[13,15]]);

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]);

TWC236

 Challenge Link

Task1

We are asked to see if we can return exact change while selling juice for $5 each. The inputs are only of 5,10, and 20 dollars. We check for each one and make our decision:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23

#!/usr/bin/env perl use strict; use warnings; sub exact_change{ my ($arr) = @_; my %hash; foreach(@$arr){ if($_ == 10){ return 0 unless $hash{5}--; } elsif($_ == 20){ $hash{5} && $hash{10} ? do{--$hash{$_} foreach(5,10)} : $hash{5} > 2 ? $hash{5} -= 3 : return 0; } $hash{$_}++; } 1 } printf "%d\n",exact_change([5,5,5,10,20]); printf "%d\n",exact_change([5,5,10,10,20]); printf "%d\n",exact_change([5,5,5,20]);

Task2

We are asked to count the loops in the array. To find a loop we start at an index and go to that index's element until we reach that first index again:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23

#!/usr/bin/env perl use strict; use warnings; sub array_loops{ my ($count,@indices) = (0); foreach my $i(0..$#{$_[0]}){ next if $indices[$i]; $count++; while(!$indices[$i]){ $indices[$i] = 1; $i = $_[0]->[$i]; } } $count } printf "%d\n", array_loops([4,6,3,8,15,0,13,18,7,16,14,19,17,5,11,1,12,2,9,10]); printf "%d\n", array_loops([0,1,13,7,6,8,10,11,2,14,16,4,12,9,17,5,3,18,15,19]); printf "%d\n", array_loops([9,8,3,11,5,7,13,19,12,4,14,10,18,2,16,1,0,15,6,17]);

TWC235

Challenge Link

Task1

We are asked to see if by removing only one integer we can make the array to be in increasing order. We remove an element each time and check if without it the array is in ascending order or not:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26

#!/usr/bin/env perl use strict; use warnings; sub is_ascending{ my ($arr) = @_; my $cursor = 0; map{$cursor++ if $arr->[$_] < $arr->[$_+1]} 0..$#$arr-1; $cursor == $#$arr } sub remove_one{ my @arr = @{$_[0]}; my $res = 0; foreach my $i(0..$#arr){ my @ret = @arr[0..$i-1,$i+1..$#arr]; if($i == 0){@ret = @arr[1..$#arr]} elsif($i == $#arr){@ret = @arr[0..$#arr-1]} $res = 1 if is_ascending(\@ret); } $res } printf "%d\n",remove_one([0,2,9,4,5]); printf "%d\n",remove_one([5,1,3,2]); printf "%d\n",remove_one([2,2,3]);

Task2

We are asked to duplicate any zero seen and stop when the array's length is equal to that of the original:

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

#!/usr/bin/env perl use strict; use warnings; sub duplicate_zeros{ my ($arr) = @_; my @ret; foreach(@$arr){ last if @ret == @$arr; $_ == 0 ? splice @ret,@ret,0,0,0 : push @ret,$_; } @ret } printf "(%s)\n", join ',',duplicate_zeros([1,0,2,3,0,4,5,0]); printf "(%s)\n", join ',',duplicate_zeros([1,2,3]); printf "(%s)\n", join ',',duplicate_zeros([0,3,0,4,5]);

TWC234

Challenge Link

Task1

We are asked to find the common characters in all words including duplicates. First we count the characters of each string in a hash, then we take the first string's letters and their counts and see if they are duplicated in other ones and find the minimum of that which gives us the number of times that character needs to be repeated:

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

#!/usr/bin/env perl use strict; use warnings; use List::Util qw(min); sub common_characters{ my @letters; map{my %h; $h{$_}++ for split ''; push @letters,\%h} @{$_[0]}; map{my $letter = $_; my $rep = min map{$letters[$_]{$letter} // 0} 0..$#letters; ($letter) x $rep } keys %{$letters[0]}; } printf "(%s)\n", join ',', common_characters([qw/java javascript julia/]); printf "(%s)\n", join ',', common_characters([qw/bella label roller/]); printf "(%s)\n", join ',', common_characters([qw/cool lock cook/]);

Task2

We are asked to find the triplets (i,j,k) such that num[i] != num[j], num[j] != num[k], and num[k] != num[i]. First we find the unique items of the list, if the result is less than 3 items, then the answer would be zero since we don't have 3 items, else we find the sum of the product of every 3 item combinations of those items for the answer:

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(sum0 product); use Algorithm::Combinatorics qw(combinations); sub unequal_triplets{ my %h; $h{$_}++ foreach @{$_[0]}; my @keys = keys %h; @keys < 3 ? 0 : sum0 map{product @h{@$_}} combinations(\@keys,3); } printf "%d\n", unequal_triplets([4,4,2,4,3]); printf "%d\n", unequal_triplets([1,1,1,1,1]); printf "%d\n", unequal_triplets([4,7,1,10,7,4,1,1]);

TWC233

 Challenge Link

Task1

We are asked to find and count the number of similar words. Two words are similar if they consist of the same characters. This can be done with sorting the unique characters of a string and keep their count in a hash:

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

#!/usr/bin/env perl use strict; use warnings; use List::Util qw(uniq sum0); sub similar_words{ my ($count,%h) = (0); map{$h{join '',uniq sort split ''}++} @{$_[0]}; $count += ($_ * ($_-1)) / 2 foreach values %h; $count } printf "%d\n", similar_words(["aba","aabb","abcd","bac","aabc"]); printf "%d\n", similar_words(["aabb","ab","ba"]); printf "%d\n", similar_words(["nba","cba","dba"]);

Task2

We are asked to sort an array based on the frequency of the items, and if the frequency of two items are the same, we have to sort them in decreasing order:

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

#!/usr/bin/env perl use strict; use warnings; sub frequency_sort{ my ($arr) = @_; my %h; $h{$_}++ foreach @$arr; sort{$h{$a} <=> $h{$b} || $b <=> $a} @$arr; } printf "(%s)\n", join ',', frequency_sort([1,1,2,2,2,3]); printf "(%s)\n", join ',', frequency_sort([2,3,1,3,2]); printf "(%s)\n", join ',', frequency_sort([-1,1,-6,4,5,-6,1,4,1]);

TWC231

 Challenge Link

Task1

We are asked to find the min and max elements of the array and then return those elements which are not equal to them. If the array length is less than 3 items we simply return -1 since there cannot be any other elements than that of min and max:

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(min max); sub min_max { my ($arr) = @_; return "-1\n" if @$arr < 3; my ($min,$max) = (min(@$arr),max(@$arr)); sprintf "(%s)\n", join ',', grep{$_ != $min && $_ != $max} @$arr; } print min_max([3,2,1,4]); print min_max([3,1]); print min_max([2,1,3]);

Task2

The age is in the 4th position from the end of the string so we use substr to extract that and count how many of them are greater than or equal to 60:

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

#!/usr/bin/env perl use strict; use warnings; sub senior_citizens { scalar grep{substr($_,-4,2) >= 60} @{$_[0]}; } printf "%d\n",senior_citizens(["7868190130M7522", "5303914400F9211", "9273338290F4010"]); printf "%d\n",senior_citizens(["1313579440F2036", "2921522980M5644"]);

TWC230

 Challenge Link

Task1

We are asked to break the numbers which are greater than 9 to their constituent digits and splice them into the array which can be simply done with a split on an empty string in Perl:

1 2 3 4 5 6 7 8 9 10 11

#!/usr/bin/env perl use strict; use warnings; sub separate_digits { map{split ''} @{$_[0]}; } printf "(%s)\n", join ",", separate_digits([1,34,5,6]); printf "(%s)\n", join ",", separate_digits([1,24,51,60]);

Task2

We are asked to count the words starting with a prefix, which can be done with the '^' symbol and the regexp's powerful mechanism. I've also used the quotemeta to escape magic characters so that the variable is correctly interpolated inside the regex pattern:

1 2 3 4 5 6 7 8 9 10 11

#!/usr/bin/env perl use strict; use warnings; sub count_words { scalar grep{/^\Q$_[1]/} @{$_[0]}; } printf "%d\n",count_words([qw/pay attention practice attend/],'at'); printf "%d\n",count_words([qw/janet julia java javascript/],'ja');

TWC229

 Challenge Link

Task1

We are asked to delete the elements which are not lexicographically sorted forwards and backwards, and return the count of the deletions. We are actually not deleting anything from the array in the code, just counting them.

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

#!/usr/bin/env perl use strict; use warnings; sub lexicographic_order { my $count = 0; map{ my $s = join '',sort split ''; $count++ if(($s ne $_) && (reverse($s) ne $_))} @{$_[0]}; $count; } printf "%d\n",lexicographic_order(["abc", "bce", "cae"]); printf "%d\n",lexicographic_order(["yxz", "cba", "mon"]);

Task2

We are asked to return the elements present at least in 2 of the arrays, so this is a simple intersection which can be accomplished by counting the elements' occurrences with a hash.

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

#!/usr/bin/env perl use strict; use warnings; use List::Util qw(uniq); sub two_out_of_three { my %hash; map{$hash{$_}++ foreach uniq @$_} @{$_[0]}; sort{$a <=> $b} grep{$hash{$_} >= 2} keys %hash } printf "(%s)\n", join ',' => two_out_of_three([[1,1,2,4],[2,4],[4]]); printf "(%s)\n", join ',' => two_out_of_three([[4,1],[2,4],[1,2]]);