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