diff options
| -rw-r--r-- | challenge-249/kjetillll/perl/ch-1.pl | 34 | ||||
| -rw-r--r-- | challenge-249/kjetillll/perl/ch-2.pl | 38 |
2 files changed, 72 insertions, 0 deletions
diff --git a/challenge-249/kjetillll/perl/ch-1.pl b/challenge-249/kjetillll/perl/ch-1.pl new file mode 100644 index 0000000000..0861beead8 --- /dev/null +++ b/challenge-249/kjetillll/perl/ch-1.pl @@ -0,0 +1,34 @@ +#!/usr/bin/perl +#https://theweeklychallenge.org/blog/perl-weekly-challenge-249/ +use strict; use warnings; use v5.10; + +if( @ARGV ) { say "@$_" for equal_pairs( @ARGV ) } +else { run_tests() } + +sub equal_pairs { + my %ptr; #keeps track of where to add last elem of a pair + my $all_is_pairs = 1; #true until otherwise proven + grep $all_is_pairs, #return nothing unless all_is_pairs + grep $all_is_pairs *= @$_ == 2, #turned false for all if one array ref isn't a pair + grep ref, #exclude array elements from push (push dont return ref's) + map $ptr{$_} #if ptr for curr input value exists then + ? push( @{ delete $ptr{$_} }, $_ ) #...pair up curr value with last equal value and forget/delete pointer, delete returns deleted value + : ($ptr{$_} = [$_]), #...else create a new pair where currently only one value exists + @_; #input array +} + +sub run_tests { + for( + [ [3, 2, 3, 2, 2, 2] => [ [3, 3], [2, 2], [2, 2] ] ], + [ [1, 2, 3, 4] => [] ], + [ [1, 2, 2, 4] => [] ], + [ [2, 2, 4, 4, 7] => [] ], + [ [7, 2, 2, 4, 4] => [] ], + [ [1..4,1..4] => [ [1,1], [2,2], [3,3], [4,4] ] ], + ) { + my( $input, $expected_pairs ) = @$_; + my @got_pairs = equal_pairs( @$input ); + my($e, $g) = map "@{[map join('+',@$_), @$_]}", $expected_pairs, \@got_pairs; + printf "%s input: @$input got: $g expected_pairs: $e\n", $e eq $g ? 'ok' : '***NOT OK' + } +} diff --git a/challenge-249/kjetillll/perl/ch-2.pl b/challenge-249/kjetillll/perl/ch-2.pl new file mode 100644 index 0000000000..b14aafa1d9 --- /dev/null +++ b/challenge-249/kjetillll/perl/ch-2.pl @@ -0,0 +1,38 @@ +#!/usr/bin/perl +#https://theweeklychallenge.org/blog/perl-weekly-challenge-249/ +use strict; use warnings; no warnings 'recursion'; use v5.10; + +sub DI_perm { + my($str, $i, $d) = @_ == 3 ? @_ : ( $_[0] =~ s/.$/$&$&/r, 0, length $_[0] ); + $str =~ /./ ? ( $& eq 'I' ? $i++ : $d--, DI_perm( $', $i, $d ) ) : () +} + +#-------------------------------------------------------------------------------- + +if( @ARGV ) { say join' ', DI_perm( $ARGV[0] ) } +else { run_tests() } + +sub run_tests { + for( + [ "IDID" => 0, 4, 1, 3, 2 ], + [ "III" => 0, 1, 2, 3 ], + [ "DDI" => 3, 2, 0, 1 ], + [ join'',map{.5<rand?'I':'D'}0..29 ], + ){ + my( $input, @expected ) = @$_; + my @got = DI_perm( $input ); + printf "%s input: $input got: @got expected: @expected\n", "@expected" eq "@got" ? 'ok' : '***NOT OK' if @expected; + check_result($input,@got); + } +} + +sub check_result { + my($s, @perm)=@_; + my @s=split//,$s; + for my $i (0..$#s){ + die if $s[$i] eq 'I' and not $perm[$i] < $perm[$i+1] ; + die if $s[$i] eq 'D' and not $perm[$i] > $perm[$i+1] ; + } + die if "@{[ sort{$a<=>$b}@perm ]}" ne "@{[ 0 .. @s ]}"; + print "ok check: $s => @perm\n"; +} |