TWC389

Challenge Link

Task1

We reorder notes according to the permutation array:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub reorder_notes{
  my ($composer,$notes,$perm) = @{$_[0]};
  my @reordered;
  $reordered[$perm->[$_]-1] = $notes->[$_] foreach 0..$#$perm;
  uc($composer) . ' => ' . join ' ',@reordered
}

is reorder_notes(['Bach',['C','D','E','F#','G','A','B'],
		  [7,1,6,2,5,3,4]]),
  'BACH => D F# A B G E C','Example 1';
is reorder_notes(['Beethoven',
		  ['C','D','F#','G','Ab'],
		  [1, 3, 5, 2, 4]]),
  'BEETHOVEN => C G D Ab F#','Example 2';
is reorder_notes(['Brahms',
		  ['C','Db','Eb','F','G','Ab','Bb','C','D'],
		  [9,3,7,1,8,5,2,6,4]]),
  'BRAHMS => F Bb Db D Ab C Eb G C','Example 3';
is reorder_notes(['Bruckner',
		  ['G','F#','Bb','C','D','Eb','F'],
		  [4,7,2,6,1,5,3]]),
  'BRUCKNER => D Bb F G Eb C F#','Example 4';
is reorder_notes(['Berg',
		  ['C#'],
		  [1]]),'BERG => C#','Example 5';

done_testing();

Task2

We find the length of longest zig-zag subarray:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub zig_zag_subarray{
  my ($arr) = @_;
  return 1 if @{$arr} == 1;
  return 2 if @{$arr} == 2 && $arr->[0] != $arr->[1];
  my ($max,$from,$to) = (1,0,0);
  while($to++ < $#$arr){
    $from = $to, next if $arr->[$to-1] == $arr->[$to];
    $from = $to-1, next if $to - $from > 1
      && ($arr->[$to] <=> $arr->[$to-1]) 
      == ($arr->[$to-1] <=> $arr->[$to-2]);
    my $curr = 1 + $to - $from;
    $max = $curr if $curr > $max
  }
  $max
}

is zig_zag_subarray([9,4,2,10,7,8,8,1,9]),5,'Example 1';
is zig_zag_subarray([1,7,4,9,2,5]),6,'Example 2';
is zig_zag_subarray([1..5]),2,'Example 3';
is zig_zag_subarray([4,4,4]),1,'Example 4';
is zig_zag_subarray([10,20,15,12,18]),3,'Example 5';

done_testing();

TWC388

Challenge Link

Task1

We find the dyck words using a stack:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub dyck_words{
  my ($n) = @_;
  return [''] if $n == 0;
  my @res;
  my @stack = [0,0,''];
  while(@stack){
    my $state = pop @stack;
    my ($o,$c,$curr) = @$state;
    if($o == $n && $c == $n) {
      push @res,$curr;
      next
    }
    push @stack,[$o+1,$c,$curr . 'U'] if $o < $n;
    push @stack,[$o,$c+1,$curr . 'D'] if $c < $n && $o > $c;
  }
  @res = sort @res;
  \@res
}

is_deeply dyck_words(1),['UD'],'Example 1';
is_deeply dyck_words(2),['UDUD','UUDD'],'Example 2';
is_deeply dyck_words(3),['UDUDUD','UDUUDD','UUDDUD','UUDUDD',
			 'UUUDDD'],'Example 3';
is_deeply dyck_words(0),[''],'Example 4';
is_deeply dyck_words(4),['UDUDUDUD','UDUDUUDD','UDUUDDUD',
			 'UDUUDUDD','UDUUUDDD','UUDDUDUD',
			 'UUDDUUDD','UUDUDDUD','UUDUDUDD',
			 'UUDUUDDD','UUUDDDUD','UUUDDUDD',
			 'UUUDUDDD','UUUUDDDD'],'Example 5';

done_testing();

Task2

We find the number of valid gifts:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;
use Memoize;

memoize qw(derange);
sub derange{
  my ($n) = @_;
  return 1 if $n == 0;
  $n * derange($n-1) + ($n % 2 == 0 ? 1 : -1)
}

is derange(1),0,'Example 1';
is derange(2),1,'Example 2';
is derange(3),2,'Example 3';
is derange(4),9,'Example 4';
is derange(5),44,'Example 5';

done_testing();

TWC387

Challenge Link

Task1

We replace "01" with "10" until none exists:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub rearrange_binary_string{
  my ($s) = @_;
  my $c = 0;
  $c++ while $s =~ s/01/10/g;
  $c
}

is rearrange_binary_string('111000'),0,'Example 1';
is rearrange_binary_string('00011'),4,'Example 2';
is rearrange_binary_string('01011'),3,'Example 3';
is rearrange_binary_string('010101'),3,'Example 4';
is rearrange_binary_string('00001'),4,'Example 5';

done_testing();

Task2

We follow the given instructions:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub rational_numbers{
  my ($s) = @_;
  my %h;
  $s =~ s/([A-Z][a-z]?)(\d+)/$1 x $2/gex;
  1 while $s =~ s/\(([^()]+)\) (\d+)/$1 x $2/gex;
  $h{$_}++ foreach $s =~ /[A-Z][a-z]?/gx;
  join '',map {$_ . ($h{$_} > 1 ? $h{$_} : '')} sort keys %h
}

is rational_numbers('((N2O)3(H2O)2)2'),'H8N12O10','Example 1';
is rational_numbers('Mg3(PO4)2'),'Mg3O8P2','Example 2';
is rational_numbers('(((H)2)3)4'),'H24','Example 3';
is rational_numbers('NaCl3(O2(S10)2)2Mg'),'Cl3MgNaO4S40','Example 4';
is rational_numbers('Z2Y3(X2W)2'),'W2X4Y3Z2','Example 5';

done_testing();

TWC386

Challenge Link

Task1

We do the conversion according to the given base:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

my $i = 0;
my %val = map {$_ => $i++} 0..9,'A'..'Z','a'..'z','+','/';

sub reverse_base{
  my ($num,$base) = @_;
  my $res = 0;
  for(my $n = 1; length $num; $n *= $base) {
    $res += $n * $val{substr $num,-1,1,''}
  }
  $res
}

is reverse_base('101010',2),42,'Example 1';
is reverse_base('EEADEE',16),15642094,'Example 2';
is reverse_base('755',8),493,'Example 3';
is reverse_base('1BRJB',36),2228519,'Example 4';
is reverse_base('7MyqL',64),123456789,'Example 5';

done_testing();

Task2

We find if the two rationals are equal:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub rational_numbers{
  my ($rat1,$rat2) = @_;
  my @rats;
  foreach my $r($rat1,$rat2) {
    $r .= '.' if -1 == index $r,'.';
    $r =~ /([-+]?\d+)\.(\d*)(?:\((\d+)\))?$/;
    my ($int,$prefix,$repeated) = @{^CAPTURE};
    $repeated //= '';
    $repeated = $1 if $repeated =~ /^(.+?)\1+$/;
    while(length $repeated &&
	  substr($repeated,-1,1) eq substr $prefix,-1,1) {
      substr $repeated,0,0,substr $prefix,-1,1,'';
      substr $repeated,-1,1,'';
      if('9' eq $repeated) {
	$repeated = '';
	if(length $prefix) {
	  if($prefix =~ /9$/) {
	    $prefix =~ s/9+$//;
	    if(length $prefix) {
	      ++$prefix
	    } else {
	      ++$int
	    }
	  } else {
	    ++$prefix
	  }
	} else {
	  ++$int
	}
	last
      }
    }
    $repeated = '' if '0' eq $repeated;
    $prefix = '' if '' eq $repeated && '0' eq $prefix;
    push @rats,"$int|$prefix|$repeated"
  }
  return $rats[0] eq $rats[1]
}

is rational_numbers('0.(12)','0.(121)'),'','Example 1';
is rational_numbers('0.1(23)','0.12(32)'),1, 'Example 2';
is rational_numbers('0.1(234)','0.12(342)'),1,'Example 3';
is rational_numbers('12.99(99)','13.'),1,'Example 4';
is rational_numbers('0.(123)','0.1(231)'),1,'Example 5';

done_testing();

TWC385

Challenge Link

Task1

We look for words uncommon to both strings:

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

sub uncommon_words{
  my %h;
  $h{$_}++ foreach split /\s+/,"$_[0] $_[1]";
  grep {$h{$_} == 1} keys %h
}

show uncommon_words('apple banana apple','banana orange');
show uncommon_words('cat dog','bird fish');
show uncommon_words('the quick brown fox','the quick');
show uncommon_words('hello','hello');
show uncommon_words('blue blue red','red green green yellow');

Task2

We remove outermost parentheses:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub outermost_parentheses{
  my %h = ('(' => 1, ')' => 0);
  my $depth = 0;
  join '',
    map $h{$_} == ($depth += $_ eq '(' ? 1 : -1) ? '' : $_,
    split '',$_[0]
}

is outermost_parentheses('()()()'),'','Example 1';
is outermost_parentheses('(((())))'),'((()))','Example 2';
is outermost_parentheses('(()())(())'),'()()()','Example 3';
is outermost_parentheses('()((()))()'),'(())','Example 4';
is outermost_parentheses('(()(()))(()())'),'()(())()()','Example 5';

done_testing();

TWC384

Challenge Link

Task1

Simple base conversion:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub base_n{
  my ($num,$base) = @_;
  my @chars = ('0'..'9','A'..'Z','a'..'z','+','/');
  my @digits;
  if($num == 0){
    @digits = (0);
  } else {
    while($num > 0){
      unshift @digits,$num % $base;
      $num = int($num / $base)
    }
  }
  join '',map{$chars[$_]} @digits
}

is base_n(42,2),'101010','Example 1';
is base_n(15642094,16),'EEADEE','Example 2';
is base_n(493,8),'755','Example 3';
is base_n(2228519,36),'1BRJB','Example 4';
is base_n(123456789,64),'7MyqL','Example 5';

done_testing();

Task2

We enumerate each candidate and find ones which have equal length and same number of zeros and ones:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub special_binary_substrings {
  my ($b) = @_;
  my @m;
  foreach my $pos(0..length($b)-1){
    foreach my $len(2..length($b) - $pos) {
      my $sub = substr($b,$pos,$len);
      next unless $sub =~ /^(0+1+|1+0+)$/;
      my ($f,$s) = $sub =~ /^(0+)(1+)$/ 
	? ($1,$2) 
	: $sub =~ /^(1+)(0+)$/;
      push @m, $sub if length($f) == length($s);
    }
  }
  \@m;
}

is_deeply special_binary_substrings('0101'),
  ['01','10','01'],'Example 1';
is_deeply special_binary_substrings('000111'),
  ['000111','0011','01'],'Example 2';
is_deeply special_binary_substrings('000011'),
  ['0011','01'],'Example 3';
is_deeply special_binary_substrings('10011100'),
  ['10','0011','01','1100','10'],'Example 4';
is_deeply special_binary_substrings('00000'),[],'Example 5';

done_testing();

TWC383

Challenge Link

Task1

We check if elements belong to the same synonym group:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub similar_list{
  return 0 unless @{$_[0]} == @{$_[1]};
 OUTER:
  foreach my $i(0..$#{$_[0]}){
    next OUTER if $_[0]->[$i] eq $_[1]->[$i];
    foreach my $sub(@{$_[2]}){
      next OUTER if in($_[0]->[$i],$sub) &&
	in($_[1]->[$i],$sub)
      }
    return 0
  }
  1
}

sub in{
  my ($e,$l) = @_;
  grep {$_ eq $e} @$l
}

is similar_list(['great','acting'],
		['fine','drama'],
		[['great','fine'],
		 ['acting','drama']]),1,'Example 1';
is similar_list(['apple','pie'],
		['banana','pie'],
		[['apple','peach'],
		 ['peach','banana']]),0,'Example 2';
is similar_list(['perl4','python'],
		['raku','python'],
		[['perl4','perl5','raku']]),1,'Example 3';
is similar_list(['enjoy','challenge'],
		['love', 'weekly', 'challenge'],
		[['enjoy','love']]),0,'Example 4';
is similar_list(['fast','car'],
		['quick','vehicle'],
		[['quick','fast'],['vehicle','car']]),1,'Example 5';
done_testing();

Task2

We make the colors web safe according to the given rules:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub nearest_rgb{
  my @web_safe = (0,51,102,153,204,255);
  my ($r,$g,$b) = map hex,$_[0] =~ /#(..)(..)(..)/;
  my $safe = '#';
  foreach my $c($r,$g,$b) {
    my $best = 0;
    foreach my $s(@web_safe){
      $best = $s if abs($c - $s) < abs($best - $c)
    }
    $safe .= sprintf '%02X',$best
  }
  $safe
}

is nearest_rgb('#F4B2D1'),'#FF99CC','Example 1';
is nearest_rgb('#15E6E5'),'#00FFCC','Example 2';
is nearest_rgb('#191A65'),'#003366','Example 3';
is nearest_rgb('#2D5A1B'),'#336633','Example 4';
is nearest_rgb('#00FF66'),'#00FF66','Example 5';

done_testing();

TWC381

Challenge Link

Task1

We check if every row and column contains digits from 1 to n:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub same_row_column{
  my ($m) = @_;
  my $n = @$m;

  foreach my $row (@$m){
    my %h;
    foreach my $num(@$row){
      return 0 if ($num < 1 || $num > $n || $h{$num}++);
    }
  }
  
  foreach my $col(0..$n-1){
    my %h;
    foreach my $row(@$m){
      my $num = $row->[$col];
      return 0 if ($num < 1 || $num > $n || $h{$num}++);
    }
  }
  1
}

is same_row_column([[1,2,3,4],[2,3,4,1],
		    [3,4,1,2],[4,1,2,3]]),1,'Example 1';
is same_row_column([[1]]),1,'Example 2';
is same_row_column([[1,2,5],[5,1,2],[2,5,1]]),0,'Example 3';
is same_row_column([[1,2,3],[1,2,3],[1,2,3]]),0,'Example 4';
is same_row_column([[1,2,3],[3,2,1],[3,2,1]]),0,'Example 5';

done_testing();

Task2

We count the numbers which have strictly smaller and greater elements than themselves:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub smaller_greater_element{
  my ($arr) = @_;
  my ($min,$max) = ($arr->[0],$arr->[0]);
  ($_ < $min) ? ($min = $_)
    : ($max < $_) && ($max = $_) foreach @$arr;
  @$arr - grep {$min == $_ || $max == $_} @$arr
}

is smaller_greater_element([2,4]),0,'Example 1';
is smaller_greater_element([1,1,1,1]),0,'Example 2';
is smaller_greater_element([1,1,4,8,12,12]),2,'Example 3';
is smaller_greater_element([3,6,6,9]),2,'Example 4';
is smaller_greater_element([0,-5,10,-2,4]),3,'Example 5';

done_testing();

TWC377

Challenge Link

Task1

We check if a pair of chars exists in the reverse of the given string:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub reverse_existence{
  0 + $_[0] =~ /(?=(.)(.))(?=.*\2\1)/
}

is reverse_existence('abcba'),1,'Example 1';
is reverse_existence('racecar'),1,'Example 2';
is reverse_existence('abcd'),0,'Example 3';
is reverse_existence('banana'),1,'Example 4';
is reverse_existence('hello'),1,'Example 5';

done_testing();

Task2

We count strings which are both prefix and suffix of another one:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 6;

sub prefix_suffix{
  my ($arr) = @_;
  my %h;
  foreach my $i(0..$#$arr){
    my $s1 = $arr->[$i];
    foreach my $j($i+1..$#$arr){
      my $s2 = $arr->[$j];
      next if 0 != index($s2,$s1)
	|| abs(length($s2) - length($s1)) != rindex $s2,$s1;
      undef $h{join ':',sort {$a <=> $b} $i,$j}
    }
  }
  scalar keys %h
}

is prefix_suffix(['a','aba','ababa','aa']),4,'Example 1';
is prefix_suffix(['pa','papa','ma','mama']),2,'Example 2';
is prefix_suffix(['abao','ab']),0,'Example 3';
is prefix_suffix(['abab','abab']),1,'Example 4';
is prefix_suffix(['ab','abab','ababab']),3,'Example 5';
is prefix_suffix(['abc','def','ghij']),0,'Example 6';

done_testing();

TWC374

Challenge Link

Task1

We return the substrings which consists of vowels and has all 5 of them:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub count_vowel{
  my @res;
  my $len = length $_[0];
  foreach my $s(0..$len-1){
    foreach my $l(5..$len-$s){
      my $sub = substr($_[0],$s,$l);
      next unless $sub =~ /^[aeiou]+$/;
      next unless (5 == grep {$sub =~ /$_/} qw(a e i o u));
      push @res,$sub
    }
  }
  \@res
}

is_deeply count_vowel('aeiou'),['aeiou'],'Example 1';
is_deeply count_vowel('aaeeeiioouu'),
  ['aaeeeiioou','aaeeeiioouu','aeeeiioou','aeeeiioouu'],'Example 2';
is_deeply count_vowel('aeiouuaxaeiou'),
  ['aeiou','aeiouu','aeiouua','eiouua','aeiou'],'Example 3';
is_deeply count_vowel('uaeiou'),['uaeio','uaeiou','aeiou'],'Example 4';
is_deeply count_vowel('aeioaeioa'),[],'Example 5';

done_testing();

Task2

We group the digits and find the maximum:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub largest_same_digit_number{
  my $r = -1;
  while($_[0] =~ /((.)\2*)/g){
    $r = $1 if $r < $1
  }
  0 + $r
}

is largest_same_digit_number('6777133339'),3333,'Example 1';
is largest_same_digit_number('1200034'),4,'Example 2';
is largest_same_digit_number('44221155'),55,'Example 3';
is largest_same_digit_number('88888'),88888,'Example 4';
is largest_same_digit_number('11122233'),222,'Example 5';

done_testing();

TWC372

Challenge Link

Task1

We rearrange the spaces per the given instructions:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub rearrange_spaces{
  my $c = $_[0] =~ tr/ //;
  my @words = split ' ',$_[0];
  my $width = @words > 1 ? int($c / $#words) : 0;
  my $rest = @words > 1 ? $c % $#words : $c;
  join(' ' x $width,@words) . ' ' x $rest
}

is rearrange_spaces('  challenge  '),'challenge    ','Example 1';
is rearrange_spaces('coding  is  fun'),'coding  is  fun','Example 2';
is rearrange_spaces('a b c  d'),'a b c d ','Example 3';
is rearrange_spaces('  team      pwc  '),
  'team          pwc','Example 4';
is rearrange_spaces('   the  weekly  challenge  '),
  'the    weekly    challenge ','Example 5';

Task2

We find the largest substring in-between two equal characters:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub largest_string{
  my $l = 0;
  $l < length $2 and $l = length $2 while $_[0] =~ /(.)(?=(.*)\1)/g;
  $l
}

is largest_string('aaaaa'),3,'Example 1';
is largest_string('abcdeba'),5,'Example 2';
is largest_string('abbc'),0,'Example 3';
is largest_string('abcaacbc'),4,'Example 4';
is largest_string('laptop'),2,'Example 5';

TWC380

Challenge Link

Task1

We count the maximum frequencies of vowels and consonants and sum them:

#!/usr/bin/env perl
use strict;
use warnings;
use List::Util qw(max);
use Test::More tests => 5;

sub sum_of_frequencies {
  my %h;
  $h{$_}++ foreach split '', lc $_[0];
  my ($c, $v) = (0, 0);
  foreach (keys %h) {
    /[aeiou]/ ? ($v = max($v, $h{$_})) : ($c = max($c, $h{$_}));
  }
  $c + $v;
}

is sum_of_frequencies('banana'),5,'Example 1';
is sum_of_frequencies('teestett'),7,'Example 2';
is sum_of_frequencies('aeiouuaa'),3,'Example 3';
is sum_of_frequencies('rhythm'),2,'Example 4';
is sum_of_frequencies('x'),1,'Example 5';

Task2

We calculate the score of each letter according to its position in the string and reverse alphabet enumeration and then sum the result:

#!/usr/bin/env perl
use strict;
use warnings;
use List::Util qw(sum0);
use Test::More tests => 5;

sub reverse_degree{
  my ($i,%h) = (1);
  @h{'a'..'z'} = reverse 1..26;
  sum0 map {$h{$_} * $i++} split '',lc $_[0]
}

is reverse_degree('z'),1,'Example 1';
is reverse_degree('a'),26,'Example 2';
is reverse_degree('bbc'),147,'Example 3';
is reverse_degree('racecar'),560,'Example 4';
is reverse_degree('zyx'),14,'Example 5';

done_testing();

TWC368

Challenge Link

Task1

We find the index of the number which if removed, makes the number the maximum possible:

#!/usr/bin/env perl
use strict;
use warnings;
use List::Util qw(max);
use Test::More tests => 5;

sub make_it_bigger{
  my $idx = -1;
  my @res;
  while(($idx = index $_[0],$_[1],$idx+1) != -1){
    substr my $s = $_[0],$idx,1,'';
    push @res,$s
  }
  max(@res)
}

is make_it_bigger('15456','5'),'1546','Example 1';
is make_it_bigger('7332','3'),'732','Example 2';
is make_it_bigger('2231','2'),'231','Example 3';
is make_it_bigger('543251','5'),'54321','Example 4';
is make_it_bigger('1921','1'),'921','Example 5';

Task2

We calculate the little or big omega of the number according to the given instructions:

#!/usr/bin/env perl
use strict;
use warnings;
use ntheory qw(factor factor_exp);
use Test::More tests => 5;

sub big_and_little_omega{
  my @funcs = (\&factor_exp,\&factor);
  scalar($funcs[!!$_[1]]($_[0]))
}

is big_and_little_omega(100061,0),3,'Example 1';
is big_and_little_omega(971088,0),3,'Example 2';
is big_and_little_omega(63640,1),6,'Example 3';
is big_and_little_omega(988841,1),2,'Example 4';
is big_and_little_omega(211529,0),2,'Example 5';

TWC366

Challenge Link

Task1

We count the strings which are prefixes of the given string:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub count_prefixes{
  scalar grep {index($_[1], $_) == 0} @{$_[0]}
}

is count_prefixes(['a','ap','app','apple','banana'],'apple'),
  4,'Example 1';
is count_prefixes(['cat','dog','fish'],'bird'),0,'Example 2';
is count_prefixes(['hello','he','hell','heaven','he'],'hello'),
  4,'Example 3';
is count_prefixes(['','code','coding','cod'],'coding'),
  3,'Example 4';
is count_prefixes(['p','pr','pro','prog','progr','progra','program'],
		  'program'),7,'Example 5';

Task2

We check for valid times by enumerating different possibilities of hours and minutes:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub valid_times{
  my $res = 1;
  my @t = split '',$_[0];
  if($t[0] eq '?') {
    $res = $t[1] eq '?' ? 24 : $t[1] lt '4' ? 3 : 2
  } elsif($t[1] eq '?') {
    $res = $t[0] lt '2' ? 10 : 4
  }
  $res * ($t[3] eq '?' ? 6 : 1) * ($t[4] eq '?' ? 10 : 1)
}

is valid_times('?2:34'),3,'Example 1';
is valid_times('?4:?0'),12,'Example 2';
is valid_times('??:??'),1440,'Example 3';
is valid_times('?3:45'),3,'Example 4';
is valid_times('2?:15'),4,'Example 5';

TWC365

Challenge Link

Task1

We assign to each letter its positional value and sum its digits k times:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub digits_sum{
  my ($n) = @_;
  my $sum = 0;
  while($n > 0){
    $sum += $n % 10;
    $n /= 10
  }
  $sum
}

sub alphabet_index_digit_sum{
  my $n = '';
  foreach(split '',$_[0]){
    $n .= int(ord($_) - ord('a') + 1)
  }
  for(my $i = 0; $i < $_[1]; ++$i){
    $n = digits_sum($n)
  }
  $n
}

is alphabet_index_digit_sum('abc',1),6,'Example 1';
is alphabet_index_digit_sum('az',2),9,'Example 2';
is alphabet_index_digit_sum('cat',1),6,'Example 3';
is alphabet_index_digit_sum('dog',2),8,'Example 4';
is alphabet_index_digit_sum('perl',3),6,'Example 5';

Task2

We check for the given conditions and count each word that satisfies it:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub valid_token_counter{
  scalar grep {/^(?:[a-z]+-)?[a-z]+[?!.,]?$/} split /\s+/,$_[0];
}

is valid_token_counter("cat and dog"),3,'Example 1';
is valid_token_counter("a-b c! d,e"),2,'Example 2';
is valid_token_counter("hello-world! this is fun"),4,'Example 3';
is valid_token_counter("ab- cd-ef gh- ij!"),2,'Example 4';
is valid_token_counter("wow! a-b-c nice."),2,'Example 5';

TWC364

Challenge Link

Task1

We decrypt the string according to the given rules, were single digits are handled differently from two-digit sequences:

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub decrypt_string{
  my %h;
  my ($i,$c) = (1,'a');
  $h{$i++} = $c++ foreach 1..9;
  $h{$i++ . '#'} = $c++ foreach 10..26;
  $_[0] =~ s/((?:1\d|2[0-6])#|\d)/$h{$1}/gr
}

is decrypt_string('10#11#12'),'jkab','Example 1';
is decrypt_string('1326#'),'acz','Example 2';
is decrypt_string('25#24#123'),'yxabc','Example 3';
is decrypt_string('20#5'),'te','Example 4';
is decrypt_string('1910#26#'),'aijz','Example 5';

Task2

We replace "()" with "o" and "(al)" with "al":

#!/usr/bin/env perl
use strict;
use warnings;
use Test::More tests => 5;

sub goal_parser{
  my %h = ('' => 'o',al => 'al');
  $_[0] =~ s/\(((?:al)?)\)/$h{$1}/gr
}

is goal_parser('G()(al)'),'Goal','Example 1';
is goal_parser('G()()()()(al)'),'Gooooal','Example 2';
is goal_parser('(al)G(al)()()'),'alGaloo','Example 3';
is goal_parser('()G()G'),'oGoG','Example 4';
is goal_parser('(al)(al)G()()'),'alalGoo','Example 5';

TWC379

Challenge Link

Task1

We reverse the string:

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

sub reverse_string{
  my ($s) = @_;
  my $res = '';
  $res .= chop $s while length $s;
  $res
}

printf "%s\n",reverse_string('');
printf "%s\n",reverse_string('reverse the given string');
printf "%s\n",reverse_string('Perl is Awesome');
printf "%s\n",reverse_string('v1.0.0-Beta!');
printf "%s\n",reverse_string('racecar');

Task2

We find all armstrong numbers under the given limit:

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

sub is_armstrong{
  my ($base,$limit) = @_;
  grep{
    my ($v,$sum,@digits) = (0,0,split '',$_);
    $v = $v * $base + $_,$sum += $_ ** @digits for @digits;
    $v == $sum
  } 0..$limit
}

show is_armstrong(10,1000);
show is_armstrong(7,1000);
show is_armstrong(16,1000);

TWC373

Challenge Link

Task1

We concatenate two string lists to strings and check for equality:

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

sub equal_list{
  (join '',@{$_[0]}) eq (join '',@{$_[1]})
}

printf "%d\n",equal_list(['a','bc'],['ab','c']);
printf "%d\n",equal_list(['a','b','c'],['a','bc']);
printf "%d\n",equal_list(['a','bc'],['a','c','b']);
printf "%d\n",equal_list(['ab','c',''],['','a','bc']);
printf "%d\n",equal_list(['p','e','r','l'],['perl']);

Task2

We try to divide the list two equal parts as long as possible:

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

sub list_division{
  my ($arr,$n) = @_;
  my $sz = int(@$arr / $n);
  return -1 if $n > @$arr;

  my $rest = @$arr % $n;
  my @res;
  foreach my $i(1..$n){
    push @res,[splice @$arr,0,$sz + ($i <= $rest)]
  }
  @res
}

show list_division([1..5],2);
show list_division([1..6],3);
show list_division([1..3],2);
show list_division([1..10],5);
show list_division([1..3],4);
show list_division([72,57,89,55,36,84,10,95,99,35],7);

TWC378

Challenge Link

Task1

We find the second largest number after filtering alphabetic characters:

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

sub second_largest_digit{
  (sort {$b <=> $a} uniq $_[0] =~ /\d/g)[1] // -1
}

show second_largest_digit('aaaaa77777');
show second_largest_digit('abcde');
show second_largest_digit('9zero8eight7seven9');
show second_largest_digit('xyz9876543210');
show second_largest_digit('4abc4def2ghi8jkl2');

Task2

We calculate the sum of each character and see if the sum of first two is equal the third string:

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

sub f{
  reduce {$a * 10 - (ord($b) - ord('a'))} 0, split '',$_[0];
}

sub sum_of_words{
  f($_[0]) + f($_[1]) == f($_[2])
}

show sum_of_words('acb','cba','cdb');
show sum_of_words('aab','aac','ad');
show sum_of_words('bc','je','jg');
show sum_of_words('a','aaaa','aa');
show sum_of_words('c','d','h');
show sum_of_words('gfi','hbf','bdhd');

TWC362

Challenge Link

Task1

We repeat each letter i times:

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

sub echo_chamber{
  my ($s) = @_;
  my @res;
  foreach my $i(0..length($s)-1) {
    push @res,substr($s,$i,1) x ($i+1)
  }
  join '',@res
}

printf "%s\n",echo_chamber('abca');
printf "%s\n",echo_chamber('xyz');
printf "%s\n",echo_chamber('code');
printf "%s\n",echo_chamber('hello');
printf "%s\n",echo_chamber('a');

Task2

We spell out the numbers according to this algorithm:

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

sub to_en{
  my ($n) = @_;
  return 'minus ' . to_en(-$n) if $n < 0;
  my @units = qw(zero one two three four five six seven eight nine);
  my %teens = (10 => 'ten',11 => 'eleven',12 => 'twelve',
	       13 => 'thirteen',14 => 'fourteen', 15 => 'fifteen',
	       16 => 'sixteen',17 => 'seventeen', 18 => 'eighteen',
	       19 => 'nineteen');
  my %tens = (20 => 'twenty',30 => 'thirty', 40 => 'forty',
	      50 => 'fifty',60 => 'sixty',70 => 'seventy',
	      80 => 'eighty',90 => 'ninety');

  return $units[$n] if $n < 10;
  return $teens{$n} if $n < 20;

  if($n < 100) {
    my $t = int($n / 10) * 10;
    my $u = $n % 10;
    return $u == 0 ? $tens{$t} : "$tens{$t}-$units[$u]"
  }

  if($n < 1000) {
    my $h = int($n/100);
    my $r = $n % 100;
    my $base = "$units[$h] hundred";
    return $r == 0 ? $base : "$base and " . to_en($r)
  }
  
  if($n < 1_000_000) {
    my $th = int($n/1000);
    my $r = $n % 1000;
    my $base = to_en($th) . ' thousand';
    return $r == 0 ? $base : "$base " . to_en($r)
  }

  die "Number is out of supported range\n"
}

sub spellbound_sorting{
  my ($arr) = @_;
  my %words;
  foreach my $n(@$arr){$words{$n} = to_en($n)}
  sort {$words{$a} cmp $words{$b}} @$arr
}

show spellbound_sorting([6,7,8,9,10]);
show spellbound_sorting([-3,0,1000,99]);
show spellbound_sorting([1,2,3,4,5]);
show spellbound_sorting([0,-1,-2,-3,-4]);
show spellbound_sorting([100,101,102]);