TWC335

Challenge Link

Task1

We find the common characters between all words:

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

sub common_characters{
  my @f = map{{frequency split ''}} @{$_[0]};
  map{my $l = $_;
      ($l) x min map{$_->{$l} // 0} @f
    } 'a'..'z'
}

print show common_characters(["bella","label","roller"]);
print show common_characters(["cool","lock","cook"]);
print show common_characters(["hello","world","pole"]);
print show common_characters(["abc","def","ghi"]);
print show common_characters(["aab","aac","aaa"]);

Task2

We find the winner by only keeping track of the moves, instead of simulating the whole grid:

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

sub find_winner{
  my ($m) = @_;
  my @cnt = (0) x 8;
  for(my $k = $#$m; $k >= 0; $k -= 2){
    my ($i,$j) = ($m->[$k][0],$m->[$k][1]);
    $cnt[$i]++;
    $cnt[$j+3]++;
    $cnt[6]++ if $i == $j;
    $cnt[7]++ if $i + $j == 2;
    if(any{$_ == 3} ($cnt[$i],$cnt[$j+3],$cnt[6],$cnt[7])) {
      return $k % 2 == 0 ? 'A' : 'B'
    }
  }
  @$m == 9 ? 'Draw' : 'Pending'
}

printf "%s\n",find_winner([[0,0],[2,0],[1,1],[2,1],[2,2]]);
printf "%s\n",find_winner([[0,0],[1,1],[0,1],[0,2],[1,0],[2,0]]);
printf "%s\n",find_winner([[0,0],[1,1],[2,0],[1,0],[1,2],[2,1],
			   [0,1],[0,2],[2,2]]);
printf "%s\n",find_winner([[0,0],[1,1]]);
printf "%s\n",find_winner([[1,1],[0,0],[2,2],[0,1],[1,0],[0,2]]);

TWC334

Challenge Link

Task1

We find the sum of the given range:

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

sub range_sum{
  sum0 @{$_[0]}[$_[1]..$_[2]];
}

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

Task2

We find the nearest point to the given x and y using Manhattan distance:

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

sub nearest_valid_point{
  my ($p,$x,$y) = @_;
  my ($res,$min) = (-1,1000);
  foreach my $i(0..$#$p) {
    my ($a,$b) = ($p->[$i][0],$p->[$i][1]);
    if($a == $x || $b == $y){
      my $d = abs($a - $x) + abs($b - $y);
      if($d < $min) {
	$min = $d;
	$res = $i
      }
    }
  }
  $res
}

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

TWC333

Challenge Link

Task1

We check if the coordinates form a straight line:

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

sub straight_line{
  my ($m) = @_;
  my ($x1,$y1,$x2,$y2) = ($m->[0][0],$m->[0][1],$m->[1][0],$m->[1][1]);
  for(my $i = 2; $i < @$m; ++$i) {
    my ($x,$y) = ($m->[$i][0],$m->[$i][1]);
    return 0 if(($x - $x1) * ($y2 - $y1) != ($y - $y1) * ($x2 - $x1))
  }
  1
}

printf "%d\n",straight_line([[2,1],[2,3],[2,5]]);
printf "%d\n",straight_line([[1,4],[3,4],[10,4]]);
printf "%d\n",straight_line([[0,0],[1,1],[2,3]]);
printf "%d\n",straight_line([[1,1],[1,1],[1,1]]);
printf "%d\n",straight_line([[1000000,1000000],
			     [2000000,2000000],
			     [3000000,3000000]]);

Task2

We duplicate each zero twice until we reach array size and stop:

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

sub duplicate_zeros{
  my ($arr) = @_;
  my ($i,@stk) = (0);
  while($i < @$arr && @stk != @$arr){
    if($arr->[$i] == 0 && (@stk+1 < @$arr)) {
      push @stk,0 for 0..1;
      $i++
    } else {
      push @stk,$arr->[$i++]
    }
  }
  @stk
}

print show duplicate_zeros([1,0,2,3,0,4,5,0]);
print show duplicate_zeros([1,2,3]);
print show duplicate_zeros([1,2,3,0]);
print show duplicate_zeros([0,0,1,2]);
print show duplicate_zeros([1,2,0,3,4]);

TWC332

Challenge Link

Task1

We convert each number into binary and join them with dashes:

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

sub binary_date{
  $_[0] =~ s/(\d+)/{sprintf "%b",$1}/rge
}

printf "%s\n",binary_date('2025-07-26');
printf "%s\n",binary_date('2000-02-02');
printf "%s\n",binary_date('2024-12-31');

Task2

We check if each letters occurred odd number of times:

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

sub odd_letters{
  my %h;
  $h{$_}++ foreach split '',$_[0];
  all{$h{$_} & 1} keys %h
}

printf "%d\n",odd_letters('weekly');
printf "%d\n",odd_letters('perl');
printf "%d\n",odd_letters('challenge');

TWC331

Challenge Link

Task1

We return length of the last word in the string:

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

sub last_word{
  length((split /\s/,$_[0])[-1])
}

printf "%d\n",last_word('The Weekly Challenge');
printf "%d\n",last_word('    Hello World    ');
printf "%d\n",last_word('Let\'s begin the fun');

Task2

We check if the strings are of the same length and only differ in one position:

#!/usr/bin/env perl
use strict;
use warnings;
use List::MoreUtils qw(uniq pairwise);

sub buddy_strings{
  return 0 if length($_[0]) != length($_[1]);
  my @s1 = split '',$_[0];
  return 1 if $_[0] eq $_[1] and @s1 > uniq(@s1);
  my @s2 = split '',$_[1];
  return 0 if (join('',sort @s1) ne join('',sort @s2));
  (grep{$_ != 0} (pairwise{$a cmp $b} @s1,@s2)) == 2
}

printf "%d\n",buddy_strings('fuck','fcuk');
printf "%d\n",buddy_strings('love','love');
printf "%d\n",buddy_strings('fodo','food');
printf "%d\n",buddy_strings('feed','feed');

TWC330

Challenge Link

Task1

We keep on clearing adjacent letter and digit pairs:

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

sub clear_digits{
  my ($str) = @_;
  1 while($str =~ s/\D\d//);
  $str
}

printf "%s\n",clear_digits('cab12');
printf "%s\n",clear_digits('xy99');
printf "%s\n",clear_digits('pa1erl');

Task2

We make each word lowercase if its length is less than 3, otherwise make it titlecase:

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

sub title_capital{
  join ' ',map{length($_) < 3 ? lc : ucfirst lc} split ' ',$_[0];
}

printf "%s\n",title_capital('PERL IS gREAT');
printf "%s\n",title_capital('THE weekly challenge');
printf "%s\n",title_capital('YoU ARE A stAR');

TWC329

Challenge Link

Task1

We extract the unique numbers:

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

sub counter_integers{
  uniq $_[0] =~ /(\d+)/g
}

print show counter_integers('the1weekly2challenge2');
print show counter_integers('go21od1lu5c7k');
print show counter_integers('4p3e2r1l');

Task2

We find letters which appear both in lower and upper case:

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

sub nice_string{
  my ($str) = @_;
  my %h;
  $h{lc $_} |= 1 + /[a-z]/ foreach split '',$str;
  foreach my $c(keys %h){
    next if $h{$c} == 3;
    $str =~ s/$c//gi;
  }
  $str
}

printf "%s\n",nice_string('YaaAho');
printf "%s\n",nice_string('cC');
printf "%s\n",nice_string('A');

TWC328

 Challenge Link

Task1

We replace the ? mark with the first letter that isn't in the string already:

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

sub replace_all{
  my %h = map{$_ => 1} split '',$_[0];
  my @chars = grep{!exists $h{$_}} 'a'..'z';
  $_[0] =~ s/\?/$chars[0]/r
}

printf "%s\n",replace_all('a?z');
printf "%s\n",replace_all('pe?k');
printf "%s\n",replace_all('gra?te');

Task2

As long as there are pairs of consecutive capital and lowercase letters (irrespective of their order), we remove it from the string:

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

sub good_string{
  my ($str) = @_;
  my $chars = join '|',map{"$_\u$_|\u$_$_"} 'a'..'z';
  1 while $str =~ s/$chars//;
  $str
}

printf "%s\n",good_string('WeEeekly');
printf "%s\n",good_string('abBAdD');
printf "%s\n",good_string('abc');

TWC327

Challenge Link

Task1

Symmetric difference of two sets gives the missing integers:

#!/usr/bin/env perl
use strict;
use warnings;
use Set::Scalar;
use feature qw(say);

sub missing_integers{
  Set::Scalar->new(@{$_[0]}) / Set::Scalar->new(1..@{$_[0]})
}

say missing_integers([1,2,1,3,2,5]);
say missing_integers([1,1,1]);
say missing_integers([2,2,1]);

Task2

We return the pairs of numbers with minimum absolute value difference:

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

sub mad{
  my @s = sort{$a <=> $b} @{$_[0]};
  my @mad = $s[1] - $s[0];
  foreach my $i(1..$#s){
    my $diff = abs $s[$i] - $s[$i-1];
    $mad[0] = $diff if $diff < $mad[0];
    push @mad,[@s[$i-1,$i]] if $diff == $mad[0]
  }
  @mad[1..$#mad]
}

print show mad([4,1,2,3]);
print show mad([1,3,7,11,15]);
print show mad([1,5,3,8]);

TWC326

Challenge Link

Task1

We find day number using Time::Piece module:

#!/usr/bin/env perl
use strict;
use warnings;
use Time::Piece;

sub day_of_the_year{
  Time::Piece->strptime($_[0],'%Y-%m-%d')->yday + 1
}

printf "%d\n",day_of_the_year('2025-02-02');
printf "%d\n",day_of_the_year('2025-04-10');
printf "%d\n",day_of_the_year('2025-09-07');

Task2

For each pair of numbers, we append the j value i times to the result:

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

sub decompressed_list{
  my ($arr) = @_;
  my ($i,@res) = (0);
  while($i < $#{$arr}){
    push @res, ($arr->[$i+1]) x $arr->[$i];
    $i += 2
  }
  @res
}

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

TWC325

Challenge Link

Task1

We find the count of maximum runs of ones:

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

sub consecutive_one{
  max 0,map length,split /[^1]+/,join '',@{$_[0]}
}

printf "%d\n",consecutive_one([0,1,1,0,1,1,1]);
printf "%d\n",consecutive_one([0,0,0,0]);
printf "%d\n",consecutive_one([1,0,1,0,1,1]);

Task2

We subtract each price from its immediate smaller price to find the discounts:

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

sub final_price {
  my ($p) = @_;
  my @stack;
  my @res = @$p;
  foreach my $i(0..$#$p){
    while(@stack && ($p->[$stack[-1]] >= $p->[$i])) {
      my $j = pop @stack;
      $res[$j] = $p->[$j] - $p->[$i]
    }
    push @stack,$i
  }
  @res
}

print show final_price([8,4,6,2,3]);
print show final_price([1,2,3,4,5]);
print show final_price([7,1,1,5]);

TWC324

Challenge Link

Task1

We take $c columns from the array each $r time through the map:

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

sub twod_array{
  my ($arr,$r,$c) = @_;
  map{[splice @$arr,0,$c]} 1..$r
}

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

Task2

We find the sum of xoring each subset of the array:

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

sub total_xor{
  my $it = subsets($_[0]);
  my $sum = 0;
  while(my $s = $it->next){
    $sum += reduce {$a ^ $b} 0, @$s
  }
  $sum
}

printf "%d\n",total_xor([1,3]);
printf "%d\n",total_xor([5,1,6]);
printf "%d\n",total_xor([3,4,5,6,7,8]);

TWC323

Challenge Link

Task1

We increment and decrement x according to ++ or -- signs:

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

sub increment_decrement{
  my $x = 0;
  map{/\+\+/ ? $x++ : $x--} @{$_[0]};
  $x
}

printf "%d\n",increment_decrement(["--x","x++","x++"]);
printf "%d\n",increment_decrement(["x++","++x","x++"]);
printf "%d\n",increment_decrement(["x++","++x","--x","x--"]);

Task2

We calculate the tax amount according to the given formula:

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

sub tax_amount{
  my ($res,$prev) = (0,0);
  foreach(@{$_[1]}){
    $res += max(0,min($_[0],$_->[0]) - $prev) * $_->[1];
    $prev = $_->[0]
  }
  $res / 100.0
}

printf "%.2f\n",tax_amount(10,[[3,50],[7,10],[12,25]]);
printf "%.2f\n",tax_amount(2,[[1,0],[4,25],[5,50]]);
printf "%.2f\n",tax_amount(0,[[2,50]]);

TWC322

Challenge Link

Task1

We keep on grouping items from the right, then prepend the remainder and join the array with "-":

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

sub string_format{
  my $str = $_[0] =~ s/-//gr;
  my ($rem,@ret) = (length($str) % $_[1]);
  $rem and push @ret,substr($str,0,$rem,'');
  push @ret,substr($str,0,$_[1],'') while(length($str) > 0);
  join '-',@ret
}

printf "%s\n", string_format('ABC-D-E-F',3);
printf "%s\n", string_format('A-BC-D-E',2);
printf "%s\n", string_format('-A-B-CD-E',4);

Task2

We give each element its rank and put the ranks in their corresponding indices:

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

sub rank_array{
  my @uniq = sort{$a <=> $b} uniq @{$_[0]};
  my %h;
  @h{@uniq} = 1..@uniq;
  @h{@{$_[0]}}
}

print show rank_array([55,22,44,33]);
print show rank_array([10,10,10]);
print show rank_array([5,1,1,4,3]);

TWC321

Challenge Link

Task1

We sort the array and pair min and max elements, then take their averages and count the distinct ones:

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

sub distinct_average{
  my @arr = sort{$a <=> $b} @{$_[0]};
  my %h;
  undef $h{($arr[$_] + $arr[$#arr-$_]) / 2} foreach 0..@arr/2;
  scalar keys %h
}

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

Task2

We transform the strings by removing the characters when we see a # character, and then compare the strings:

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

sub backspace_compare{
  my ($s1,$s2) = @_;
  for($s1,$s2){
    1 while s/[^#]#//
  }
  $s1 eq $s2
}

printf "%d\n",backspace_compare('ab#c','ad#c');
printf "%d\n",backspace_compare('ab##','a#b#');
printf "%d\n",backspace_compare('a#b','c');

TWC320

Challenge Link

Task1

We find the max of count of negative and positive numbers:

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

sub maximum_count{
  my ($n,$p) = (0,0);
  map{if($_ != 0) {$_ < 0 ? $n++ : $p++}} @{$_[0]};
  max($n,$p)
}

printf "%d\n",maximum_count([-3,-2,-1,1,2,3]);
printf "%d\n",maximum_count([-2,-1,0,0,1]);
printf "%d\n",maximum_count([1,2,3,4]);

Task2

We find the absolute value of sum of array and sum of each element's digits in the array:

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

sub sum_diffrence{
  abs(sum0(@{$_[0]}) - sum0(split '',join '',@{$_[0]}))
}

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

TWC319

Challenge Link

Task1

We check if the first or last character the strings are vowels and count them:

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

sub word_count{
  scalar grep {/^[aeiou]|[aeiou]$/} @{$_[0]}
}

printf "%d\n",word_count(["unicode","xml","raku","perl"]);
printf "%d\n",word_count(["the","weekly","challenge"]);
printf "%d\n",word_count(["perl","python","postgres"]);

Task2

We find the common items in the two arrays, then find the minimum:

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

sub minimum_common{
  (min (Set::Scalar->new(@{$_[0]})
	->intersection(Set::Scalar->new(@{$_[1]}))
	->members)) // -1
}

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

TWC318

Challenge Link

Task1

We return an array of runs of 3 or more characters:

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

sub group_position{
  my @ret;
  push @ret,$1.$2 while($_[0] =~ m/(.)(\1{2,})/g);
  @ret
}

print show group_position('abccccd');
print show group_position('aaabcddddeefff');
print show group_position('abcdd');

Task2

We check if the two arrays are reverse of each other:

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

sub reverse_equals{
  my ($src,$target) = @_;
  my $from = first {$src->[$_] != $target->[$_]} 0..$#$src;
  return 1 unless defined $from;
  my $to = first {$src->[$_] != $target->[$_]} reverse $from..$#$src;
  foreach my $i(0..$to-$from){
    return 0 if $src->[$from+$i] != $target->[$to-$i]
  }
  1;
}

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

TWC317

Challenge Link

Task1

We join first character of each string and check if it is equal to the given word:

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

sub acronyms {
  (join '',map{substr $_,0,1} @{$_[0]}) eq $_[1];
}

printf"%d\n",acronyms(['Perl','Weekly','Challenge'],'PWC');
printf"%d\n",acronyms(['Bob','Charlie','Joe'],'BCJ');
printf"%d\n",acronyms(['Morning','Good'],'MM');

Task2

We can make two sets from the strings or sort the strings and check if they are equal, both methods work:

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

sub friendly_strings {
  (join '',sort split '',$_[0]) eq (join '',sort split '',$_[1])
}

printf "%d\n",friendly_strings('desc','dsec');
printf "%d\n",friendly_strings('fuck','fcuk');
printf "%d\n",friendly_strings('poo','eop');
printf "%d\n",friendly_strings('stripe','sprite');

TWC316

Challenge Link

Task1

For each pair we check if the last character of first one is equal to first of second:

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

sub circular{
  for(my $i = 0; $i < $#{$_[0]}; $i++) {
    my $l = substr($_[0]->[$i],-1);
    my $f = substr($_[0]->[$i+1],0,1);
    return 0 unless $l eq $f
  }
  1
}

printf "%d\n",circular(['perl','loves','scala']);
printf "%d\n",circular(['love','the','programming']);
printf "%d\n",circular(['java','awk','kotlin','node.js']);

Task2

We check if the characters of first string occur in the second in order:

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

sub subsequence{
  my @idx = map{index $_[1],$_} split '',$_[0];
  join('',@idx) eq join '',sort{$a <=> $b} @idx
}

printf "%d\n",subsequence('uvw','bcudvew');
printf "%d\n",subsequence('aec','abcde');
printf "%d\n",subsequence('sip','javascript');

TWC315

Challenge Link

Task1

We return the indices of the words where the character is present in that word:

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

sub find_words{
  grep {$_[0]->[$_] =~ $_[1]} 0..$#{$_[0]}
}

print show find_words(['the','weekly','challenge'],'e');
print show find_words(['perl','raku','python'],'p');
print show find_words(['abc','def','bbb','bcd'],'b');

Task2

If the words first and second happen consecutively we accumulate the word after it:

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

sub find_third{
  my ($s,$first,$second) = @_;
  my (@words,@ret) = split ' ',$s;
  foreach my $i(0..$#words-1){
    push @ret,$words[$i+2] =~ /\W$/ ? substr($words[$i+2],0,-1) : $words[$i+2]
      if ($words[$i] eq $first) && ($words[$i+1] eq $second)
  }
  @ret
}

print show find_third('Perl is a my favourite language but Python is my favourite too.',
		      'my',
		      'favourite');
print show find_third('Barbie is a beautiful doll also also a beautiful princess.',
		      'a',
		      'beautiful');
print show find_third('we will we will rock you rock you.','we','will');

TWC314

Challenge Link

Task1

We look for common prefixes:

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

sub equal_strings{
  my @lens = map{length} @_;
  my $sum = sum0 @lens;
  my $n = min @lens;
  foreach my $i(0..$n){
    if(!(substr($_[0],$i,1) eq substr($_[1],$i,1) &&
       substr($_[1],$i,1) eq substr($_[2],$i,1))){
      return $i == 0 ? -1 : $sum - 3 * $i
    }
  }
  $sum - 3 * $n
}

printf "%d\n",equal_strings('abc','abb','ab');
printf "%d\n",equal_strings('ayz','cyz','xyz');
printf "%d\n",equal_strings('yza','yzb','yzc');

Task2

We count sorted columns:

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

sub sort_column{
  my ($arr) = @_;
  my $ret = 0;
  foreach my $j(0..length($arr->[0])-1){
    foreach my $i(1..$#$arr){
      if(substr($arr->[$i],$j,1) lt substr($arr->[$i-1],$j,1)){
	$ret++;
	last
      }
    }
  }
  $ret
}

printf "%d\n",sort_column(['swpc','tyad','azbe']);
printf "%d\n",sort_column(['cba','daf','ghi']);
printf "%d\n",sort_column(['a','b','c']);

TWC313

Challenge Link

Task1

We check if name is a subset of typed:

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

sub broken_keys{
  my $s1 = Set::Scalar->new(split '',$_[0]);
  my $s2 = Set::Scalar->new(split '',$_[1]);
  $s1 <= $s2
}

printf "%d\n",broken_keys('perl','perrrl');
printf "%d\n",broken_keys('raku','rrakuuuu');
printf "%d\n",broken_keys('python','perl');
printf "%d\n",broken_keys('coffeescript','cofffeescccript');

Task2

We make an array from the input string and only reverse the letters:

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

sub reverse_letters{
  my @chars = split '',$_[0];
  my ($i,$j) = (0,$#chars);
  while($i < $j){
    $i++ while($i < $j and $chars[$i] !~ /[[:alpha:]]/);
    $j-- while($i < $j and $chars[$j] !~ /[[:alpha:]]/);
    ($chars[$i++],$chars[$j--]) = ($chars[$j],$chars[$i]) if $i < $j;
  }
  join '',@chars
}

printf "%s\n",reverse_letters('p-er?l');
printf "%s\n",reverse_letters('wee-k!L-y');
printf "%s\n",reverse_letters('_c-!h_all-en!g_e');

TWC312

Challenge Link

Task1

We calculate the distance by keeping track of the last letter written:

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

sub minimum_time{
  my ($str) = @_;
  my ($res,$prev) = (0,0);
  foreach my $c(split '',$str){
    my $curr = ord($c) - ord('a');
    my $t = abs($prev - $curr);
    $t = min($t,26-$t);
    $res += $t+1;
    $prev = $curr
  }
  $res
}

printf "%d\n",minimum_time('abc');
printf "%d\n",minimum_time('bza');
printf "%d\n",minimum_time('zjpc');

Task2

We check if a box contains balls of all the three given colors:

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

sub balls_and_boxes{
  my ($sum,%h) = (0);
  $h{$2} .= $1 while($_[0] =~ /([RGB])(\d)/g);
  foreach my $v(values %h){
    $sum++ if all{index($v,$_) != -1} ('R','G','B')
  }
  $sum
}

printf "%d\n",balls_and_boxes('G0B1R2R0B0');
printf "%d\n",balls_and_boxes('G1R3R6B3G6B1B6R1G3');
printf "%d\n",balls_and_boxes('B3B2G1B3');

TWC311

Challenge Link

Task1

We swap the case of each letter in the string:

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

sub upper_lower{
  $_[0] =~ tr/A-Za-z/a-zA-Z/r
}

printf "%s\n",upper_lower('pERl');
printf "%s\n",upper_lower('rakU');
printf "%s\n",upper_lower('PyThOn');

Task2

We sum the digits of each group while the length of the string is greater than n:

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

sub group_digit_sum{
  my ($str,$n) = @_;
  while(length $str > $n){
    my @gps = unpack("(A$n)*",$str);
    $str = join('',map{sum0 split '',$_} @gps)
  }
  $str
}

printf "%s\n",group_digit_sum('111122333',3);
printf "%s\n",group_digit_sum('1222312',2);
printf "%s\n",group_digit_sum('100012121001',4);

TWC310

Challenge Link

Task1

We take the intersection of arrays:

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

sub arrays_intersection{
  my ($arr) = @_;
  return () unless @$arr;
  my $s = Set::Scalar->new($arr->[0]->@*);
  map{$s *= Set::Scalar->new(@$_)} @{$arr}[1..$#$arr];
  $s->elements
}

print show arrays_intersection([[1,2,3,4],[4,5,6,1],[4,2,1,3]]);
print show arrays_intersection([[1,0,2,3],[2,4,5]]);
print show arrays_intersection([[1,2,3],[4,5],[6]]);

Task2

We sort the array based on even and odd indices:

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

sub sort_even_odd{
  grep {defined}
    (mesh[sort{$a <=> $b}@{$_[0]}[grep{!($_%2)} 0..$#{$_[0]}]],
     [sort{$b <=> $a}@{$_[0]}[grep{$_%2} 0..$#{$_[0]}]]);
}

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

TWC309

Challenge Link

Task1

We look for the minimum difference between the pairs and return the found index:

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

sub min_gap{
  my ($arr) = @_;
  my $min = $arr->[0];
  my $min_gap = $arr->[1] - $arr->[0];
  foreach my $i(2..$#$arr){
    my $gap = $arr->[$i] - $arr->[$i-1];
    if($gap < $min_gap){
      $min = $arr->[$i];
      $min_gap = $gap
    }
  }
  $min
}

printf "%d\n",min_gap([2,8,10,11,15]);
printf "%d\n",min_gap([1,5,6,7,14]);
printf "%d\n",min_gap([8,20,25,28]);

Task2

We find the minimum difference of any two elements:

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

sub min_diff{
  my @sorted = sort{$a<=>$b}@{$_[0]};
  min(map{$sorted[$_] - $sorted[$_-1]}1..$#sorted)
}

printf "%d\n",min_diff([1,5,8,9]);
printf "%d\n",min_diff([9,4,1,7]);

TWC304

Challenge Link

Task1

We count the consecutive pairs of zeros and check if the count is greater than the given n:

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

sub arrange_binary{
  my $c = 0;
  map{$c++ if $_[0]->[$_] == 0 && $_[0]->[$_+1] == 0} 0..$#{$_[0]}-1;
  $c > $_[1]
}

printf "%d\n",arrange_binary([1,0,0,0,1],1);
printf "%d\n",arrange_binary([1,0,0,0,1],2);

Task2

We find the maximum sub array sum of the given length n:

#!/usr/bin/env perl
use strict;
use warnings;
use List::Util qw(sum0 min);
use feature qw(say);

sub maximum_average{
  my ($arr,$n) = @_;
  my $max = min @$arr;
  foreach my $start(0..@$arr-$n){
    my $subsum = sum0(@{$arr}[$start..$start+$n-1]);
    my $avg = $subsum / $n;
    $max = $avg if $avg > $max
  }
  $max
}

say maximum_average([1,12,-5,-6,50,3],4);
say maximum_average([5],1);

TWC308

Challenge Link

Task1

We find the intersection of two arrays:

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

sub count_common{
  my %h;
  $h{$_}++ for @{$_[0]};
  scalar grep{exists $h{$_} && $h{$_}++ < 2} @{$_[1]}
}

printf "%d\n",count_common(['perl','weekly','challenge'],
			   ['raku','weekly','challenge']);
printf "%d\n",count_common(['perl','raku','python'],
			   ['python','java']);
printf "%d\n",count_common(['guest','contribution'],
			   ['fun','weekly','challenge']);

Task2

We find the resultant array by xoring the elements starting with the given first:

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

sub decode_xor{
  my @res = ($_[1]);
  push @res,$res[-1] ^ $_ foreach @{$_[0]};
  @res
}

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

TWC307

Challenge Link

Task1

We sort the array and return those indices where elements differ:

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

sub check_order{
  my @sorted = sort{$a <=> $b} @{$_[0]};
  map{$sorted[$_] != $_[0]->[$_] ? $_ : ()} 0..$#sorted
}

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

Task2

We find the anagrams by sorting each string and counting any differing two consecutive elements:

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

sub find_anagrams{
  my ($arr) = @_;
  my @sorted = map {join'',sort split ''} @$arr;
  my $sum = 1;
  map{$sum++ if $sorted[$_-1] ne $sorted[$_]} 1..$#sorted;
  $sum
}

printf "%d\n",find_anagrams(['acca','dog','god','perl','repl']);
printf "%d\n",find_anagrams(['abba','baba','aabb','ab','ab']);

TWC305

Challenge Link

Task1

We check for primality of the binary prefixes:

#!/usr/bin/env perl
use strict;
use warnings;
use Math::Prime::Util qw(is_prime);
use Data::Show;

sub binary_prefix{
  my ($arr) = @_;
  my ($bin,@res) = ('');
  map{$bin .= $_; push @res,is_prime(oct("0b$bin")) ? 1 : 0} @$arr;
  @res
}

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

Task2

We sort the array according to the alien dictionary:

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

sub alien_dictionary{
  my ($words,$alien) = @_;
  my $r = join '',@$alien;
  sort{eval "\$a =~ tr/a-z/$r/r" cmp
       eval "\$b =~ tr/a-z/$r/r"} @$words
}

print show alien_dictionary(['perl','python','raku'],
			    [qw/h l a b y d e f g i r k m n o p q j s t u v w x c z/]);
print show alien_dictionary(['the','weekly','challenge'],
			    [qw/c o r l d a b t e f g h i j k m n p q s w u v x y z/]);

TWC303

Challenge Link

Task1

We find all 3 variations of digits, and check if it is even, then remove the duplicates:

#!/usr/bin/env perl
use strict;
use warnings;
use Algorithm::Combinatorics qw(variations);
use List::Util qw(uniq);
use Data::Show;

sub three_digits_even{
  @{$_[0]} = sort{$a <=> $b} @{$_[0]};
  uniq map{join '',@$_} grep{$_->[0] && !($_->[2] % 2)}
    variations($_[0],3)
}

print show three_digits_even([2,1,3,0]);
print show three_digits_even([2,2,8,8,2]);

Task2

We keep deleting and keeping points to get the final result:

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

sub delete_and_earn{
  my $max = max @{$_[0]};
  my @total = (0) x ($max+1);
  map{$total[$_] += $_} @{$_[0]};
  my $first = $total[0];
  my $second = max($total[0],$total[1]);
  foreach my $i(2..$max){
    my $curr = max(($first+$total[$i]),$second);
    $first = $second;
    $second = $curr
  }
  $second
}

printf "%d\n",delete_and_earn([3,4,2]);
printf "%d\n",delete_and_earn([2,2,3,3,3,4]);

TWC302

Challenge Link

Task1

For each combination of the array of size 1 to N, we check to see if the count of zeros and ones are subset of the given x and y:

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

sub ones_and_zeros{
  foreach my $s(reverse 1..@{$_[0]}){
    my $it = combinations($_[0],$s);
    while(my $comb = $it->next){
      my $joined = join '',@$comb;
      my $zeroes = $joined =~ tr/0//;
      my $ones = $joined =~ tr/1//;
      return $s if $zeroes <= $_[1] && $ones <= $_[2]
    }
  }
  0
}

printf "%d\n",ones_and_zeros(["10","0001","111001","1","0"],5,3);
printf "%d\n",ones_and_zeros(["10","1","0"],1,1);

Task2

We find the minimum value needed so that step-wide sum won't become less than 1:

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

sub step_by_step{
  my $s = 0;
  my $t = $_[0]->[0];
  map{$s += $_; $t = min $t,$s} @{$_[0]};
  max 1,1-$t
}

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