TWC399

Challenge Link

Task1

We find the longest repeating character:

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

sub longest_repeating_character{
  my ($s,$k) = @_;
  my ($left,$max_count,%count) = (0,0);
  my $n = length $s;
  foreach my $right(0..$n-1){
    my $c = substr($s,$right,1);
    $count{$c}++;
    $max_count = $count{$c} if $count{$c} > $max_count;
    if(($right - $left + 1) - $max_count > $k){
      $count{substr($s,$left,1)}--;
      $left++
    }
  }
  $n - $left
}

is longest_repeating_character('AAAAA',2),5,'Example 1';
is longest_repeating_character('ABCDE',4),5,'Example 2';
is longest_repeating_character('AAABBBBAA',1),5,'Example 3';
is longest_repeating_character('ABACADA',2),5,'Example 4';
is longest_repeating_character('BAAABAAAA',1),8,'Example 5';

Task2

We find the longest absolute path:

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

sub longest_absolute_path{
  my ($fs) = @_;
  my @lines = grep{length} split /\n/,$fs;
  my @depth = map{/^(\t*)/; length $1} @lines;
  my ($best,@len) = (0);
  
  foreach my $i(0..$#lines){
    my $d = $depth[$i];
    my $name = substr($lines[$i],$d);
    $len[$d] = ($d > 0 ? $len[$d-1]+1 : 0) + length $name;
    my $is_dir = ($i < $#lines && $depth[$i+1] > $d);
    if(!$is_dir && index($name,'.') >= 0){
      $best = $len[$d] if $len[$d] > $best
    }
  }
  $best
}

is longest_absolute_path("dir\n\tsubdir1\n\t\tsubsubdir1\n\tsubdir2"),0,'Example 1';
is longest_absolute_path("file1.txt\nfile2.ext\na.png"),9,'Example 2';
is longest_absolute_path("my documents\n\tproject v1.0\n\t\tnotes v1.txt\n\timage.png"),38,'Example 3';
is longest_absolute_path("root\n\ta\n\t\tb\n\t\t\tc.txt\n\td\n\t\te.txt"),14,'Example 4';
is longest_absolute_path("a\n\tb\n\t\tc\n\t\t\td\n\t\t\t\te.txt\n\tvery_long_directory_name\n\t\tf.txt"),32,'Example 5';

TWC398

Challenge Link

Task1

We filter even numbers and those numbers which are divisible by 3, then find its average:

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

sub divisible_average{
  my @arr = grep {$_ % 2 == 0 && $_ % 3 == 0} @{$_[0]};
  return 0 unless @arr;
  int((sum0 @arr) / @arr)
}

is divisible_average([18,5,7,11]),18,'Example 1';
is divisible_average([6,12,18,24,30,40]),18,'Example 2';
is divisible_average([3,9,15,21,27]),0,'Example 3';
is divisible_average([6,12,14,20]),9,'Example 4';
is divisible_average([6,6,6,12,12]),8,'Example 5';

Task2

We find the difference between letters of strings, and find the odd one:

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

sub string_difference{
  my ($words) = @_;
  my (@keys,%h);
  foreach my $w(@$words){
    my @ord = map {ord($_) - ord('a')} split '',$w;
    my $key = join ',',map{$ord[$_+1] - $ord[$_]} 0..$#ord-1;
    push @keys,$key;
    $h{$key}++
  }
  foreach my $i(0..$#$words){
    return $words->[$i] if $h{$keys[$i]} == 1;
  }
  return -1
}

is string_difference(['ab','bc','cd','zy']),'zy','Example 1';
is string_difference(['cba','fed','azy']),'azy','Example 2';
is string_difference(['pop','ada','beb','cfc']),'pop','Example 3';
is string_difference(['aaaa','zzzz','mmmm','aaba']),'aaba','Example 4';
is string_difference(['aceg','bdfh','cegi','azbz']),'azbz','Example 5';

TWC397

Challenge Link

Task1

We find the smallest number greater than average of the array:

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

sub absent_smallest_positive{
  my ($arr) = @_;
  my ($sum,%h);
  foreach(@$arr){
    $h{$_} = 1;
    $sum += $_;
  }
  my $ret = max(1,int($sum / @$arr) + 1);
  $ret++ while(exists $h{$ret});
  $ret
}

is absent_smallest_positive([1,2,4,5,6]),7,'Example 1';
is absent_smallest_positive([-5,-2,-1,3]),1,'Example 2';
is absent_smallest_positive([1..3]),4,'Example 3';
is absent_smallest_positive([2,3,7,8]),6,'Example 4';
is absent_smallest_positive([1,1,1,10]),4,'Example 5';

Task2

We first sort by binary representation, then by numbers themselves:

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

sub binary_reflection{
  my $rb = sub{oct('0b' . reverse sprintf("%b",shift))};
  [sort{$rb->($a) <=> $rb->($b) || $a <=> $b} @{$_[0]}]
}

is_deeply binary_reflection([3,6,12]),[3,6,12],'Example 1';
is_deeply binary_reflection([1,2,4,8]),[1,2,4,8],'Example 2';
is_deeply binary_reflection([7,8,9,10]),[8,10,7,9],'Example 3';
is_deeply binary_reflection([5,9,15,17]),[5,9,15,17],'Example 4';
is_deeply binary_reflection([11,13,14,19]),[14,13,11,19],'Example 5';

TWC396

Challenge Link

Task1

We sort the elements according to order array:

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

sub finishing_order{
  my %h;
  $h{$_} = 1 foreach @{$_[1]};
  [grep {$h{$_}} @{$_[0]}];
}

is_deeply finishing_order([3,1,4,2,5],[1,2,4]),[1,4,2],'Example 1';
is_deeply finishing_order([5,4,3,2,1],[1,3,5]),[5,3,1],'Example 2';
is_deeply finishing_order([2,4,1,3],[1,2,3,4]),[2,4,1,3],'Example 3';
is_deeply finishing_order([4,1,3,2],[3]),[3],'Example 4';
is_deeply finishing_order([1,3,2,6,5,4],[1,2,3]),[1,3,2],'Example 5';

Task2

We check if array is trionic:

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

sub trionic_array{
  my ($arr) = @_;
  my ($p,$n) = (0,scalar @$arr);
  $p++ while($p < $n - 2 && $arr->[$p] < $arr->[$p+1]);
  return '' if $p == 0;
  my $q = $p;
  $q++ while($q < $n-1 && $arr->[$q] > $arr->[$q+1]);
  return '' if $q == $p || $q == $n-1;
  $q++ while($q < $n-1 && $arr->[$q] < $arr->[$q+1]);
  $q == $n-1
}

is trionic_array([1,3,5,4,2,6,8]),1,'Example 1';
is trionic_array([1,4,4,2,1,3,5]),'','Example 2';
is trionic_array([2,10,3,1,9]),1,'Example 3';
is trionic_array([1,2,3,4,3,2,1]),'','Example 4';
is trionic_array([1,3,6,4,2,7,8,4]),'','Example 5';

TWC395

Challenge Link

Task1

We parse complex numbers and apply the given formula:

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

sub parse_complex{
  my ($s) = @_;
  if ($s =~ /^\s*(-?\d+)\s*\+\s*\(?\s*(-?\d+)\s*\)?\s*i\s*$/){
    return ($1, $2);
  }
  die "Invalid complex number: '$s'\n"
}

sub format_complex{
  my ($re,$im) = @_;
  my $str = $im < 0 ? "($im)" : "$im";
  "$re+${str}i"
}

sub complex_number{
  my ($n1,$n2) = @_;
  my ($a,$b) = parse_complex($n1);
  my ($c,$d) = parse_complex($n2);
  my $real = $a * $c - $b * $d;
  my $imag = $a * $d + $b * $c;
  format_complex($real,$imag)
}

is complex_number('1+1i','1+1i'),'0+2i','Example 1';
is complex_number('1+(-1)i','1+(-1)i'),'0+(-2)i','Example 2';
is complex_number('0+3i','0+4i'),'-12+0i','Example 3';
is complex_number('3+4i','3+(-4)i'),'25+0i','Example 4';
is complex_number('50+(-20)i','-10+30i'),'100+1700i','Example 5';

done_testing();

Task2

We use backtracking to find all the solutions:

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

sub word_squares{
  my ($words) = @_;
  return [] unless @$words;

  my ($n,@res,%used) = length $words->[0];
  
  my $solve;
  $solve = sub{
    my $k = @res;
    return 1 if $k == $n;
    my $prefix = join '',map{substr($res[$_],$k,1)} 0..$k-1;
    
    foreach my $i(0..$#$words){
      next if $used{$i};
      next unless substr($words->[$i],0,$k) eq $prefix;
      $used{$i} = 1;
      push @res,$words->[$i];
      return 1 if $solve->();
      pop @res;
      delete $used{$i}
    }
    0
  };

  my $found = $solve->();
  undef $solve;
  $found ? \@res : [];
}

is_deeply word_squares(['MA','AM','MY','ME']),['MA','AM'],'Example 1';

is_deeply word_squares(['SUN','USE','NET','SEE','TEN']),
  ['SUN','USE','NET'],'Example 2';

is_deeply word_squares(['BOAT','TEAL','AREA','TSAR','OGRE']),
  ['BOAT','OGRE','AREA','TEAL'],'Example 3';

is_deeply word_squares(['CARD','AREA','REAR','DART']),
  ['CARD','AREA','REAR','DART'],'Example 4';

is_deeply word_squares(['HEART','TREND','EMBER','RESIN','ABUSE']),
  ['HEART','EMBER','ABUSE','RESIN','TREND'],'Example 5';

done_testing();

TWC394

Challenge Link

Task1

We find the minimum number of required swaps to make alternating string:

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

sub alternate_case{
  my ($s) = @_;
  my @upper;
  push @upper,$-[0] while($s =~ /[A-Z]/g);
  my $cost = sub {
    my ($start) = @_;
    my $total = 0;
    foreach my $i(0..$#upper) {
      my $target = $start + 2 * $i;
      $total += abs($upper[$i] - $target)
    }
    return $total
  };
  min($cost->(0),$cost->(1))
}

is alternate_case('aAbB'),0,'Example 1';
is alternate_case('AAbb'),1,'Example 2';
is alternate_case('AAAbbb'),3,'Example 3';
is alternate_case('aABb'),1,'Example 4';
is alternate_case('bBBAaa'),2,'Example 5';

done_testing();

Task2

We find the longest substring common to all elements of the array and which is alternating between consonants and vowels:

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

sub iv {return $_[0] =~ /[aeiou]/i ? 1 : 0}

sub alternating_vowels_consonants{
  my ($strs) = @_;
  my ($src,@others) = sort {length $a <=> length $b} @$strs;
  my $max = 0;
  my (@best,%seen);
  my $n = length $src;

  foreach my $i(0..$n-1){
    foreach my $j($i..$n-1){
      last if $j > $i &&
	iv(substr($src,$j,1)) 
	== iv(substr($src,$j-1,1));
      my $len = $j - $i + 1;
      next if $len < $max;

      my $sub = substr($src,$i,$len);
      next if grep {index(lc $_,lc $sub) < 0} @others;

      if($len > $max) {
	$max = $len;
	@best = ();
	%seen = ();
      }
      push @best,$sub unless $seen{$sub}++;
    }
  }
  \@best
}

is_deeply alternating_vowels_consonants(
  ['relocate','delocate','allocate']),['locate'],'Example 1';
is_deeply alternating_vowels_consonants(
  ['apple','banana','cherry']),[],'Example 2';
is_deeply alternating_vowels_consonants(
  ['navigate','cavity','gravity']),['avi'],'Example 3';
is_deeply alternating_vowels_consonants(
  ['pedalgia','pedalboard','pedantic']),['peda'],'Example 4';
is_deeply alternating_vowels_consonants(
  ['schoolmaster','schoolhouse','schooling']),['ho','ol'],'Example 5';

done_testing();

TWC393

Challenge Link

Task1

Solving this using Euclid's formula:

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

sub pythagoras_multiplied{
  my ($n) = @_;
  my $count = 0;
  for(my $m = 2; $m * $m + 1 <= $n; $m++){
    for(my $k = 1; $k < $m; $k++){
      next if (($m - $k) % 2 == 0) || gcd($m,$k) != 1;
      my $c = $m * $m + $k * $k;
      last if $c > $n && $k == 1;
      next if $c > $n;
      $count += 2 * int($n / $c)
    }
  }
  $count
}

is pythagoras_multiplied(20),12,'Example 1';
is pythagoras_multiplied(7),2,'Example 2';
is pythagoras_multiplied(1),0,'Example 3';
is pythagoras_multiplied(15),8,'Example 4';
is pythagoras_multiplied(30),22,'Example 5';

done_testing();

Task2

We find the sum of all ascii values in the string and check for primality:

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

sub prime_step{
  my $sum = sum0 map{ord} split '',$_[0];
  my $d = 0;
  while(1){
    return $d if is_prime($sum - $d) || is_prime($sum + $d);
    $d++
  }
}

is prime_step('hello'),9,'Example 1';
is prime_step('football'),2,'Example 2';
is prime_step('a'),0,'Example 3';
is prime_step('challenge'),2,'Example 4';
is prime_step('perl'),2,'Example 5';

done_testing();