Merge pull request #9304 from kjetillll/challenge-249-kjetillll

https://theweeklychallenge.org/blog/perl-weekly-challenge-249/

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";
+}