TWC300

Challenge Link

Task1

We check the given condition for permutations of the sequence:

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

sub beautiful_arrangement{
  my $it = permutations([1..$_[0]]);
  my $c = 0;
 perm:
  while(my $p = $it->next){
    foreach my $i(1..$_[0]){
      next perm if $p->[$i-1] % $i && $i % $p->[$i-1]
    }
    $c++
  }
  $c
}

printf "%d\n",beautiful_arrangement(2);
printf "%d\n",beautiful_arrangement(1);
printf "%d\n",beautiful_arrangement(10);

Task2

We check for the given condition and find out the maximum:

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

sub nested_array{
  my ($arr) = @_;
  my $max = 0;
  foreach my $i(0..$#$arr){
    my $len = 0;
    my $set = $arr->[$i];
    my %used;
    while(!exists $used{$set}){
      undef $used{$set};
      $set = $arr->[$set];
      ++$len
    }
    $max = $len if $len > $max
  }
  $max
}

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

TWC299

Challenge Link

Task1

We keep on searching for the prefix of words in the given sentence:

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

sub replace_words{
  my @words = split ' ',$_[1];
  my %roots;
  $roots{$_} = 1 foreach @{$_[0]};
  foreach my $i(0..$#words){
    foreach my $j(1..length $words[$i]){
      my $sub = substr $words[$i],0,$j;
      if(defined $roots{$sub}){
	$words[$i] = $sub;
	last
      }
    }
  }
  join ' ',@words
}

printf "%s\n",replace_words(['cat', 'bat', 'rat'],
			    'the cattle was rattle by the battery');
printf "%s\n",replace_words(['a','b','c'],
			    'aab aac and cac bab');
printf "%s\n",replace_words(['man','bike'],
			    'the manager was hit by a biker');

Task2

We keep on searching for the characters of the word in all four possible directions:

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

my @dir = ([-1,0],[0,1],[1,0],[0,-1]);

sub word_search{
  my ($chars,$str) = @_;
  my $visited;
  foreach my $i(0..$#$chars){
    foreach my $j(0..$#{$chars->[0]}){
      return 1 if helper($chars,$visited,$str,0,$i,$j)
    }
  }
  0
}

sub is_inside{
  my ($chars,$x,$y) = @_;
  $x >= 0 && $x < @$chars && $y >= 0 && $y < @{$chars->[0]}
}

sub helper{
  my ($chars,$visited,$word,$index,$x,$y) = @_;
  if($index eq length($word)-1) {
    return $chars->[$x][$y] eq substr($word,$index,1)
  }
  if($chars->[$x][$y] eq substr($word,$index,1)) {
    $visited->[$x][$y] = 1;
    foreach my $i(0..$#dir) {
      my ($nx,$ny) = ($x + $dir[$i][0],$y + $dir[$i][1]);
      return 1 if is_inside($chars,$nx,$ny) &&
	!$visited->[$nx][$ny] &&
	helper($chars,$visited,$word,$index+1,$nx,$ny)
    }
  }
  0
}

printf "%d\n",word_search([['A', 'B', 'D', 'E'],
			   ['C', 'B', 'C', 'A'],
			   ['B', 'A', 'A', 'D'],
			   ['D', 'B', 'B', 'C']],'BDCA');
printf "%d\n",word_search([['A', 'A', 'B', 'B'],
			   ['C', 'C', 'B', 'A'],
			   ['C', 'A', 'A', 'A'],
			   ['B', 'B', 'B', 'B']],'ABAC');
printf "%d\n",word_search([['B', 'A', 'B', 'A'],
			   ['C', 'C', 'C', 'C'],
			   ['A', 'B', 'A', 'B'],
			   ['B', 'B', 'A', 'A']],'CCCAA');

TWC296

Challenge Link

Task1

We count the characters in a hash and add the counts and the corresponding characters to the resultant string:

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

sub string_compression{
  my @chars = split '',$_[0];
  my ($ret,%h) = ('');
  $h{$_}++ foreach @chars;
  map{$ret .= $h{$_} == 1 ? $_ : $h{$_} . $_} uniq @chars;
  $ret
}

printf "%s\n",string_compression("abbc");
printf "%s\n",string_compression("aaabccc");
printf "%s\n",string_compression("abcc");

Task2

An explanation of this problem can be found here:

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

sub matchstick_square{
  my ($arr) = @_;
  return 0 if sum0(@$arr) % 4 != 0;
  my $len = sum0(@$arr) / 4;
  @$arr = sort{$b <=> $a} @$arr;
  my @sides = (0) x 4;
  my $dfs = sub {
    my ($i) = @_;
    return $len == $sides[0] == $sides[1] ==
      $sides[2] == $sides[3] if $i == @$arr;
    foreach my $j(0..3){
      if($sides[$j] + $arr->[$i] <= $len){
	$sides[$j] += $arr->[$i];
	return 1 if(__SUB__->($i+1));
	$sides[$j] -= $arr->[$i]
      }
    }
    0
  };
  $dfs->(0)
}

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

TWC294

Challenge Link

Task1

We count the number of consecutive elements according to this algorithm. (We can also use a simple Perl hash instead of the Set::Scalar module):

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

sub consecutive_sequence{
  my ($arr) = @_;
  my $s = Set::Scalar->new(@$arr);
  my $res = 0;
  foreach my $i(0..$#$arr){
    unless($s->has($arr->[$i]-1)){
      my $j = $arr->[$i];
      $j++ while($s->has($j));
      $res = max($res,$j - $arr->[$i])
    }
  }
  $res == 1 ? -1 : $res
}

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

Task2

We find the next permutation of the array according to this algorithm.

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

sub next_permutation{
  my ($arr) = @_;
  my $p = -1;
  for(my $i = $#$arr-1; $i >= 0; --$i){
    do{$p = $i; last}if($arr->[$i] < $arr->[$i+1])
  }
  return reverse @$arr if $p == -1;
  for(my $i = $#$arr; $i >= $p+1; --$i){
    if($arr->[$i] > $arr->[$p]){
      ($arr->[$i],$arr->[$p]) = ($arr->[$p],$arr->[$i]);
      last
    }
  }
  @$arr
}

printf "(%s)\n",join ', ',next_permutation([1,2,3]);
printf "(%s)\n",join ', ',next_permutation([2,1,3]);
printf "(%s)\n",join ', ',next_permutation([3,1,2]);

TWC293

Challenge Link

Task1

We count the similar dominos in a hash and return its sum:

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

sub similar_dominos{
  my %h;
  $h{join '',sort{$a <=> $b} @$_}++ foreach @{$_[0]};
  sum0 grep{$_>1} values %h
}

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

Task2

We check if 3 points form a boomerang as explained in here:

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

sub boomerang{
  my ($a) = @_;
  ($a->[1][1] - $a->[0][1]) * ($a->[2][0] - $a->[1][0]) !=
    ($a->[2][1] - $a->[1][1]) * ($a->[1][0] - $a->[0][0])
}

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

TWC290

Challenge Link

Task1

We check if the double of a key also exists in the hash:

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

sub double_exist{
  my %h;
  $h{$_}++ foreach @{$_[0]};
  map{return 1 if exists $h{$_ * 2}} keys %h;
  0
}

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

Task2

After removing the spaces and using the last digit as the payload, then if the digit is less than 9, we add it to the sum, otherwise we clamp its double to be less than or equal to 9 and add it to the sum. Finally, we check if the sum of the accumulated result and the payload is divisible by 10:

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

sub luhns_algorithm{
  my ($str) = @_;
  $str =~ tr/0-9//dc;
  my $p = chop $str;
  my ($sum,$even) = (0) x 2;
  foreach my $d(reverse split '',$str){
    $sum += $even ? $d : 2 * $d > 9 ? 2 * $d - 9 : 2 * $d;
    $even = !$even
  }
  ($sum + $p) % 10 == 0
}

printf "%d\n",luhns_algorithm('17893729974');
printf "%d\n",luhns_algorithm('4137 8947 1175 5904');
printf "%d\n",luhns_algorithm('4137 8974 1175 5904');

TWC289

Challenge Link

Task1

We deduplicate and sort the array in descending order, then we take the third maximum number if there's one, otherwise we take the max number:

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

sub third_maximum{
  my @arr = sort{$b <=> $a} uniq @{$_[0]};
  $arr[2] // $arr[0]
}

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

Task2

For each line in the input file, we shuffle the middle letters of its words, and print that line:

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

die "No file provided!\n" unless @ARGV == 1;

while(<>){
  s/(\w)(\w*)(\w)/$1.join '',shuffle split '',$2.$3/ge;
  print
}

TWC286

Challenge Link

Task1

We pick a random word from the file:

#!/usr/bin/env perl
use strict;
use warnings;
use File::Slurp;

sub self_spammer{
  my @words = grep /\S/,split /\s/, read_file(__FILE__);
  $words[rand @words]
}

print self_spammer();

Task2

We reduce the array with min and max functions as stated in the problem description:

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

sub order_game{
  my ($arr) = @_;
  while(@$arr > 2){
    my @t;
    foreach my($a,$b,$c,$d)(@$arr){
      push @t,min($a,$b),max($c,$d)
    }
    @$arr = @t;
  }
  min @$arr
}

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

TWC285

Challenge Link

Task1

We are basically looking for a node in the graph with zero out degree:

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

sub no_connection{
  my ($arr) = @_;
  my (%destinations,%sources);
  foreach my $r(@{$arr}){
    $sources{$r->[0]} = $destinations{$r->[1]} = 1;
  }
  foreach my $d(keys %destinations){
    return $d unless exists $sources{$d}
  }
  ""
}

printf "%s\n",no_connection([["B","C"],["D","B"],["C","A"]]);
printf "%s\n",no_connection([["A","Z"]]);

Task2

We can use a tree to check for all the possible solutions, but dynamic programming is more efficient:

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

sub making_change{
  my ($amount) = @_;
  my @coins = (1,5,10,25,50);
  my @dp = (0) x ($amount+1);
  $dp[0] = 1;
  foreach my $c(@coins){
    foreach my $i($c..$amount) {
      $dp[$i] += $dp[$i-$c]
    }
  }
  $dp[$amount]
}

printf "%d\n",making_change(9);
printf "%d\n",making_change(15);
printf "%d\n",making_change(100);

TWC284

Challenge Link

Task1

We look for the number which has a frequency equal to its value:

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

sub lucky_integer{
  my %h;
  $h{$_}++ foreach @{$_[0]};
  max map{$h{$_} == $_ ? $_ : -1} keys %h
}

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

Task2

We sort the elements according to their order in the second list:

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

sub relative_sort{
  my (%ranks,%ranked);
  $ranks{$_[1]->[$_]} = $_ foreach 0..$#{$_[1]};
  $ranked{$_} = defined $ranks{$_} ? 1 : 0 foreach @{$_[0]};
  sort{
    ($ranked{$b} <=> $ranked{$a}) ||
      ($ranks{$a} || 0) <=> ($ranks{$b} || 0) ||
      $a <=> $b
  } @{$_[0]}
}

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

TWC283

Challenge Link

Task1

We deduplicate the list and see if only one item remains and return it, otherwise we return undef:

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

sub unique_number{
  my @arr = singleton @{$_[0]};
  @arr == 1 ? $arr[0] : undef
}

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

Task2

We take the frequency of the array elements, and see if all of them are equivalent to the corresponding elements of the array:

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

sub digit_count_value{
  my ($i,%h) = (0,frequency(@{$_[0]}));
  all{($h{$i++} // 0) == $_} @{$_[0]}
}

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

TWC282

Challenge Link

Task1

We check if there are 3 consecutive identical digits:

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

sub good_integer {
  $_[0] =~ /(\d)\1{2}(\1)?/ ? ($2 ? -1 : $1 x 3) : ()
}

print good_integer(12344456),"\n";
print good_integer(1233334),"\n";
print good_integer(10020003),"\n";

Task2

We count the number of letter changes:

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

sub changing_keys{
  my ($c,@arr) = (0,split '',lc $_[0]);
  foreach my $i(0..$#arr-1){
    $c++ if $arr[$i] ne $arr[$i+1]
  }
  $c
}

printf "%d\n",changing_keys('pPeERrLl');
printf "%d\n",changing_keys('rRr');
printf "%d\n",changing_keys('GoO');

TWC281

Challenge Link

Task1

By observing the chessboard we can see that the if the sum of the coordinates of a square is odd, then the square is white, and black otherwise:

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

sub check_color{
  (ord(substr $_[0],0,1) + substr $_[0],1,1) % 2
}

printf "%d\n",check_color('d3');
printf "%d\n",check_color('g5');
printf "%d\n",check_color('e6');

Task2

This task can be solved using the BFS graph algorithm:

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

sub is_inside{
  $_[0] >= 0 && $_[0] <= $_[2]
    && $_[1] >= 0 && $_[1] <= $_[2]
}

sub min_steps{
  my ($k1,$k2,$t1,$t2,$n) = @_;
  my @dirs = ([-2,1],[-1,2],
	      [1,2],[2,1],
	      [2,-1],[1,-2],
	      [-1,-2],[-2,-1]);
  my (@queue,@visited);
  push @queue,[$k1,$k2,0];
  while(@queue){
    my $t = shift @queue;
    return $t->[2] if $t->[0] == $t1 && $t->[1] == $t2;
    foreach my $i(0..$#dirs){
      my $x = $t->[0] + $dirs[$i][0];
      my $y = $t->[1] + $dirs[$i][1];
      if(is_inside($x,$y,$n)){
	$visited[$x][$y] = 1;
	push @queue,[$x,$y,$t->[2]+1]
      }
    }
  }
  -1
}

sub knights_move{
  my ($s,$e) = @_;
  my ($k1,$k2,$t1,$t2) = (ord(substr($s,0,1)) - ord('a'),
			  substr($s,1,1) - '0',
			  ord(substr($e,0,1)) - ord('a'),
			  substr($e,1,1) - '0');
  min_steps($k1,$k2,$t1,$t2,8)
}

printf "%d\n",knights_move('g2','a8');
printf "%d\n",knights_move('g2','h2');

TWC280

Challenge Link

Task1

We basically count the number of occurrences of characters and return the duplicated one. We can do this more compactly with regexp:

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

sub twice_appearance{
  reverse($_[0]) =~ /.*(.).*?\1/
}

printf "%s\n",twice_appearance('acbddbca');
printf "%s\n",twice_appearance('abccd');
printf "%s\n",twice_appearance('abcdabbb');

Task2

We count the number of asterisks of the wanted portions of the string:

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

sub count_asterisks{
  my $str = $_[0] =~ s/\|[^\|]*\|//gmixr;
  $_ = () = $str =~ /(\*)/gmix;
}

printf "%d\n",count_asterisks('p|*e*rl|w**e|*ekly|');
printf "%d\n",count_asterisks('perl');
printf "%d\n",count_asterisks('th|ewe|e**|k|l***ych|alleng|e');

TWC279

Challenge Link

Task1

We make a hash out of two arrays and sort it according to values:

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

sub sort_letters{
  my %h = map {$_->[0] => $_->[1]} zip $_[0],$_[1];
  join '',sort{$h{$a} <=> $h{$b}} keys %h
}

printf "%s\n",sort_letters(['R','E','P','L'],[3,2,1,4]);
printf "%s\n",sort_letters(['A','U','R','K'],[2,4,1,3]);
printf "%s\n",sort_letters(['O','H','Y','N','P','T'],[5,4,2,6,1,3]);

Task2

tr in perl returns the number of replacements in scalar context and we just check if it is even:

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

sub split_string{
  $_[0] =~ tr/aeiouy// % 2 == 0
}

printf "%d\n",split_string('perl');
printf "%d\n",split_string('book');
printf "%d\n",split_string('good morning');

TWC278

Challenge Link

Task1

We separate the alphas from digits in each word of the string and make a hash from it, then we sort that hash according to the values and return the result as a string:

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

sub sort_string{
  my %h = map{/(\w+)(\d+)/} split ' ',$_[0];
  join ' ',sort{$h{$a} <=> $h{$b}} keys %h
}

printf "%s\n",sort_string('and2 Raku3 cousins5 Perl1 are4');
printf "%s\n",
  sort_string('guest6 Python1 most4 the3 popular5 is2 language7');
printf "%s\n",sort_string('Challenge3 The1 Weekly2');

Task2

We match the desired part non-greedily, sort it, and substitute it in the given string:

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

sub reverse_string{
  $_[0] =~ s/(.*?$_[1])/join '',sort split '',$1/er
}

printf "%s\n",reverse_string('challenge','e');
printf "%s\n",reverse_string('programming','a');
printf "%s\n",reverse_string('champion','b');

TWC277

Challenge Link

Task1

We count the array elements in a hash and check which ones are equal to two:

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

sub count_common{
  my %h;
  $h{$_}++ foreach @{$_[0]},@{$_[1]};
  (grep{$_ == 2}values %h) // 0
}

printf "%d\n",
  count_common(['Perl','is','my','friend'],
	       ['Perl','and','Raku','are','friend']);
printf "%d\n",
  count_common(['Perl','and','Python','are','very','similar'],
	       ['Python','is','top','in','guest','languages']);
printf "%d\n",
  count_common(['Perl','is','imperative','Lisp','is','functional'],
	       ['Crystal','is','similar','to','Ruby']);

Task2

We count how many times the given condition is met, for each combination of pairs of elements:

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

sub strong_pairs{
  scalar grep{abs($$_[0] - $$_[1]) < min(@$_)}
    combinations([uniq @{$_[0]}],2)
}

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

TWC276

Challenge Link

Task1

If the sum of any of the pairs is divisible by 24, we increment the count value:

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

sub complete_day{
  my ($arr) = @_;
  my $count = 0;
  foreach my $i(0..$#$arr-1){
    foreach my $j($i+1..$#$arr){
      $count++ if(($arr->[$i] + $arr->[$j]) % 24 == 0)
    }
  }
  $count
}

printf "%d\n",complete_day([12,12,30,24,24]);
printf "%d\n",complete_day([72,48,24,55]);
printf "%d\n",complete_day([12,18,24]);

Task2

We count the values, and sum the ones which have a weight equal to the max weight of the elements:

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

sub maximum_frequency{
  my %h;
  $h{$_}++ foreach @{$_[0]};
  my $max = max values %h;
  sum0 grep {$_ if $_ == $max} values %h
}

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

TWC273

Challenge Link

Task1

We count the character's occurrences and calculate its percentage:

#!/usr/bin/env perl
use strict;
use warnings;
use POSIX qw(round);

sub percentage_of_character{
  my ($str,$char) = @_;
  my $count =()= $str =~ /\Q$char/g;
  round(100 * $count / length $str)
}

printf "%d\n",percentage_of_character('perl','e');
printf "%d\n",percentage_of_character('java','a');
printf "%d\n",percentage_of_character('python','m');
printf "%d\n",percentage_of_character('ada','a');
printf "%d\n",percentage_of_character('ballerina','l');
printf "%d\n",percentage_of_character('analitik','k');

Task2

We see if there's no 'a' character after the last 'b' character:

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

sub b_after_a{
  (-1 != index($_[0],'b')) >= rindex($_[0],'a')
}

printf "%d\n",b_after_a('aabb');
printf "%d\n",b_after_a('abab');
printf "%d\n",b_after_a('aaa');
printf "%d\n",b_after_a('bbb');

TWC272

Challenge Link

Task1

Replacing each . with [.]:

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

sub defrag_ip_address{
  $_[0] =~ s/\./[.]/gr
}

printf "%s\n",defrag_ip_address('1.1.1.1');
printf "%s\n",defrag_ip_address('255.101.1.0');

Task2

Subtracting the absolute values of pairs and taking their sum:

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

sub string_score{
  sum0 slide {abs(ord($b) - ord($a))} split '',$_[0]
}

printf "%d\n",string_score('hello');
printf "%d\n",string_score('perl');
printf "%d\n",string_score('raku');

TWC271

Challenge Link

Task1

We return the index of the array with the largest sum:

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

sub maximum_ones{
  my $max = 0;
  map{my $c = sum0 @{$_[0]->[$_]}; $max = $_+1 if $c > $max} 0..$#{$_[0]};
  $max
}

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

Task2

We first sort by the pop count of the items then if they were equal, by the elements themselves:

#!/usr/bin/env perl
use strict;
use warnings;
use ntheory qw(hammingweight);
use Data::Show;

sub sort_by_one_bits{
  sort{hammingweight($a) <=> hammingweight($b) || $a <=> $b} @{$_[0]}
}

print show sort_by_one_bits([0,1,2,3,4,5,6,7,8]);
print show sort_by_one_bits([1024,512,256,128,64]);

TWC269

Challenge Link

Task1

We count the number of even numbers because an even number's right most bit is 0, and see if that count is greater than one:

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

sub bitwise_or{
  (grep{($_ & 1) == 0} @{$_[0]}) > 1
}

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

Task2

We keep pushing elements into two arrays as the requirements and concatenate and return the results:

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

sub distribute_elements{
  my @ret1 = shift @{$_[0]};
  my @ret2 = shift @{$_[0]};
  while(@{$_[0]}){
    my $e = shift @{$_[0]};
    $ret1[-1] > $ret2[-1] ? push @ret1,$e : push @ret2,$e;
  }
  @ret1,@ret2
}

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

TWC268

Challenge Link

Task1

We take the absolute value of the first elements of arrays after sorting them:

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

sub magic_number{
  my @x = sort{$a <=> $b} @{$_[0]};
  my @y = sort{$a <=> $b} @{$_[1]};
  abs($x[0] - $y[0])
}

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

Task2

After sorting the array, we keep removing pairs of elements and push its reverse to the array that we want to return:

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

sub number_game{
  my @arr = sort{$a <=> $b} @{$_[0]};
  my @ret;
  push @ret,reverse splice @arr,0,2 while(@arr);
  @ret
}

print show number_game([2,5,3,4]);
print show number_game([9,4,1,3,6,4,6,1]);
print show number_game([1,2,2,3]);

TWC266

Challenge Link

 Task1

We count the words in a hash, then check which one's count is equal to one, and sort them:

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

sub uncommon_words{
  my %h;
  $h{lc $_}++ foreach split /\W+/, $_[0] . ' ' . $_[1];
  sort grep{$h{$_} == 1} keys %h;
}

print show uncommon_words('Mango is sweet','Mango is sour');
print show uncommon_words('Mango Mango','Orange');
print show uncommon_words('Mango is Mango','Orange is Orange');

Task2

In an NxN square matrix, if the indices i and j are equal then we are on the main diagonal, and if the sum of i and j is equal to N-1, then we are on the anti-diagonal, and if these conditions are true, then we shouldn't see a 0 and if we do we return 0 immediately, and if the above 2 conditions is not met, then we must see a zero since we are not on the diagonals. If the function doesn't return inside the loops then we definitely have an X matrix:

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

sub x_matrix{
  my ($mat) = @_;
  my $n = @$mat;
  foreach my $i(0..$n-1){
    foreach my $j(0..$n-1){
      if($i == $j || $i+$j == $n-1){
	return 0 if $mat->[$i][$j] == 0
      }
      elsif($mat->[$i][$j] != 0){return 0}
    }
  }
  1
}

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

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

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

TWC265

Challenge Link

Task1

We see if the element count of an item is greater than or equal to 33% of the whole array size:

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

sub thirty_three_percent_appearance{
  my %h;
  $h{$_}++ foreach @{$_[0]};
  min grep{$h{$_} if $h{$_} >= (@{$_[0]}/3)}keys %h;
}

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

Task2

We check if the given string is a subset of any of the given strings in the array:

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

sub completing_word{
  my $s1 = Set::Scalar->new(split'',(lc $_[0] =~ s/(\s+|\d+)//gr));
  (grep{$_ if $s1 <= (Set::Scalar->new(split'',$_))}@{$_[1]})[0];
}

printf "%s\n",completing_word('aBc 11c',['accbbb','abc','abbc']);
printf "%s\n",completing_word('Da2 abc',['abcm','baacd','abaadc']);
printf "%s\n",completing_word('JB 007',['jj','bb','bjb']);

TWC264

Challenge Link

Task1

We make two sets of lowercase and uppercase letters and find their intersection:

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

sub greatest_english_letter{
  my $s1 = Set::Scalar->new;
  my $s2 = Set::Scalar->new;
  map{$_ le 'Z' ? $s1->insert($_) : $s2->insert(uc $_)} split '',$_[0];
  maxstr($s1->intersection($s2)->members) // ''
}

printf "%s\n", greatest_english_letter('PeRlwEeKLy');
printf "%s\n", greatest_english_letter('ChaLlenge');
printf "%s\n", greatest_english_letter('The');

Task2

We insert the elements at appropriate indices as per the given instructions:

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

sub target_array{
  my @ret;
  splice @ret,$_[1]->[$_],0,$_[0]->[$_] foreach(0..$#{$_[1]});
  @ret
}

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

TWC263

Challenge Link

Task1

We sort the array then return the indices of the elements equal to k:

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

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

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

Task2

We add each quantity to the count of ids in the hash and return the keys and values of the hash:

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

sub merge_items{
  my %h;
  $h{$_->[0]} += $_->[1] foreach(@{$_[0]},@{$_[1]});
  map{[$_,$h{$_}]} sort{$a <=> $b} keys %h;
}

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

TWC262

Challenge Link

Task1

We count the number of negative and positive numbers in the array and return the maximum:

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

sub max_positive_negative{
  my ($neg,$pos) = 0 x 2;
  map{$neg++ if $_ < 0;$pos++ if $_ > 0}@{$_[0]};
  max $neg,$pos
}

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

Task2

For each (i,j) pair we check if the condition (i * j mod k == 0) holds and count them:

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

sub count_equal_divisible{
  my ($arr,$k) = @_;
  my $count = 0;
  foreach my $i(0..@$arr-2){
    foreach my $j($i+1..@$arr-1){
      ++$count if $arr->[$i] == $arr->[$j] && ($i*$j) % $k == 0
    }
  }
  $count
}

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

TWC261

Challenge Link

Task1

We subtract the sum of each digit in each number from the sum of the numbers and take its absolute value:

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

sub element_digit_sum{
  abs(sum0(map{split ''}@{$_[0]}) - sum0(@{$_[0]}))
}

printf "%d\n",element_digit_sum([1,2,3,45]);
printf "%d\n",element_digit_sum([1,12,3]);
printf "%d\n",element_digit_sum([1,2,3,4]);
printf "%d\n",element_digit_sum([236,416,336,350]);

Task2

While $start is in the list, we keep multiplying it by 2:

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

sub multiply_by_two{
  my ($arr,$start) = @_;
  $start *= 2 while((firstidx{$start == $_}@$arr)!=-1);
  $start
}

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

TWC260

Challenge Link

Task1

We count the occurrences of each integer in a hash, then check if the length of the values of that hash is equal to the length of the unique values,  if so we return 1 else 0:

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

sub unique_occurences{
  my %h;
  $h{$_}++ foreach @{$_[0]};
  my @values = values %h;
  @values == (uniq @values) || 0
}

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

Task2

We construct an array of all permutations of the given string, join each tuple to a string, and remove the duplicates, then sort and find the index of the string which is equal to the argument of the subroutine:

#!/usr/bin/env perl
use strict;
use warnings;
use Algorithm::Combinatorics qw(permutations);
use List::MoreUtils qw(onlyidx uniq);

sub dictionary_rank{
  1+onlyidx{$_ eq $_[0]}
    sort{$a cmp $b}
    uniq map{join'',@$_}
    permutations([split '',$_[0]])
}

printf "%d\n",dictionary_rank('CAT');
printf "%d\n",dictionary_rank('GOOGLE');
printf "%d\n",dictionary_rank('SECRET');

TWC258

 Challenge Link

Task1

we split the number into its digits and check if it is even:

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

sub count_even_digits_number{
  scalar grep{(split'',$_)%2==0}@{$_[0]}
}

printf "%d\n",count_even_digits_number([10,1,111,24,1000]);
printf "%d\n",count_even_digits_number([111,1,11111]);
printf "%d\n",count_even_digits_number([2,8,1024,256]);

Task2

We get the popcount of each index and if it is equal to $k, we include the number at that index in the resultant array, else we skip it:

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

sub sum_of_values{
  sum0 map{hammingweight$_==$_[1]?$_[0]->[$_]:()}0..$#{$_[0]}
}

printf "%d\n",sum_of_values([2,5,9,11,3],1);
printf "%d\n",sum_of_values([2,5,9,11,3],2);
printf "%d\n",sum_of_values([2,5,9,11,3],0);

TWC256

Challenge Link

Task1

We check each string with the reverse of all others and increment the count if they are equal:

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

sub maximum_pairs{
  my ($a) = @_;
  my $c = 0;
  map{my $i = $_;
      map{$c++ if $a->[$i] eq reverse $a->[$_]}$i+1..$#$a}0..$#$a;
  $c
}

printf "%d\n", maximum_pairs(['ab','de','ed','bc']);
printf "%d\n", maximum_pairs(['aa','ba','cd','ed']);
printf "%d\n", maximum_pairs(['uv','qp','st','vu','mn','pq']);

Task2

We keep picking a character from each string alternatively until we exhaust the strings:

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

sub merge_strings{
  my ($res,$m,$n) = ('',length $_[0],length $_[1]);
  for(my $i = 0; $i < $m || $i < $n; ++$i){
    $res .= substr $_[0],$i,1 if $i < $m;
    $res .= substr $_[1],$i,1 if $i < $n;
  }
  $res
}

printf "%s\n",merge_strings('abcd','1234');
printf "%s\n",merge_strings('abc','12345');
printf "%s\n",merge_strings('abcde','123');

TWC255

Challenge Link

Task1

We count the characters' occurrences of the first string, and do the same thing for the second string too but this time we decrement the count or if we hit 0 (false), then we delete that hash entry, leaving us with the only odd character as the remaining key to be returned:

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

sub odd_character{
  my %h;
  map{++$h{$_}}split '',$_[0];
  map{--$h{$_}||delete $h{$_}}split '',$_[1];
  keys %h
}

printf "%s\n",odd_character("Perl","Preel");
printf "%s\n",odd_character("Weekly","Weeakly");
printf "%s\n",odd_character("Box","Boxy");

Task2

We count the occurrences of each word excluding the banned word, and return the one with the highest count:

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

sub most_frequent_word{
  my %h;
  map{$h{$_}++ if $_ ne $_[1]} split /[^\w]/,$_[0];
  (sort{$h{$b}<=>$h{$a}}keys %h)[0]
}

printf "%s\n",most_frequent_word("Joe hit a ball, the hit ball ".
				 "flew far after it was hit.",
				 "hit");
printf "%s\n",most_frequent_word("Perl and Raku belong to the same family.".
				 " Perl is the most popular language ".
				 "in the weekly challenge.",
				 "the");

TWC254

Challenge Link

Task1

First one is a math trick that we use to find out if a number is a power of 3 or not:

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

sub three_power{
  $_[0] == int($_[0]**(1/3))**3
}

printf "%d\n",three_power(27);
printf "%d\n",three_power(0);
printf "%d\n",three_power(6);

Task2

We reverse the list of vowels and replace them in the string, and capitalize the first letter:

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

sub reverse_vowels{
  my ($str) = @_;
  my @vowels = $str =~ /[aeiou]/gi;
  $str =~ s/([aeiou])/pop @vowels/egi;
  ucfirst $str
}

printf "%s\n",reverse_vowels('Raku');
printf "%s\n",reverse_vowels('Perl');
printf "%s\n",reverse_vowels('Julia');
printf "%s\n",reverse_vowels('Uiua');

TWC253

Challenge Link

Task1

We apply split on each element of the array then filter those which are of length > 0:

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

sub split_strings{
  my ($arr,$sep) = @_;
  grep {length} map{split /\Q$sep\E/} @$arr
}

print show split_strings(['one.two.three','four.five','six'],'.');
print show split_strings(['$perl$$', '$$raku$'],'$');

Task2

We sort the indices according to the sum of each subarray in the matrix, or in case of them being equal, on the indices themselves:

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

sub weakest_row{
  my ($mat) = @_;
  sort{sum0(@{$$mat[$a]}) <=> sum0(@{$$mat[$b]}) || $a <=> $b}
    0..$#$mat
}

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

TWC252

Challenge Link

Task1

We check if the array's length is divisible by index+1, if so we square the array at that index, at last we sum the whole acquired array:

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

sub special_numbers{
  my ($arr) = @_;
  sum0 map{($arr->[$_] ** 2) if @$arr % ($_+1) == 0} 0..$#$arr;
}

printf "%d\n",special_numbers([1,2,3,4]);
printf "%d\n",special_numbers([2,7,1,19,18,3]);

Task2

Starting from 1 to the half of the given number, we keep pushing the number and its negation to an array, then if the given number is odd, we push an extra zero at the end:

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

sub unique_sum_zero{
  my ($n,@ret) = @_;
  foreach(1..$n/2){
    push(@ret,$_,-$_);
  }
  $n % 2 ? (@ret,0) : @ret;
}

print show unique_sum_zero(5);
print show unique_sum_zero(3);
print show unique_sum_zero(1);

TWC250

Challenge Link

Task1

We iterate the array, and if the result of index mod 10 is equal to the array's element at that index, we return that index, otherwise we return -1:

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

sub smallest_index{
  map{return $_ if $_ % 10 == $_[0]->[$_]}0..$#{$_[0]};
  -1
}

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

Task2

We iterate the array, if the element is numeric, we use it, else we get the length of the string and assign it to $n, then get the max of array:

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

sub alphanumeric_string_value{
  max map{my $n = (/^\d+$/) ? $_ : length}@{$_[0]};
}

printf "%d\n",alphanumeric_string_value(['perl','2','000','python','r4ku']);
printf "%d\n",alphanumeric_string_value(['001','1','000','0001']);