https://theweeklychallenge.org/blog/perl-weekly-challenge-203/#TASK1

2 files changed, 108 insertions, 0 deletions

diff --git a/challenge-203/kjetillll/perl/ch-1.pl b/challenge-203/kjetillll/perl/ch-1.pl
new file mode 100644
index 0000000000..354a6666c0
--- /dev/null
+++ b/challenge-203/kjetillll/perl/ch-1.pl
@@ -0,0 +1,46 @@
+#!/usr/bin/perl
+use strict; use warnings; #yes mom
+
+=pod
+
+Run with arguments to use those as the input list or
+run without to run the included tests with this output:
+
+ok     input: 1 2 3 6                expected: 1   got: 1
+ok     input: 1 1 1 3 5              expected: 4   got: 4
+ok     input: 3 3 6 4 5              expected: 0   got: 0
+ok     input: 1 2 3 4 5 6 7 8 9 10   expected: 11   got: 11
+
+For large input lists, use Algorithm::Combinatorics::combinations()
+instead of sub comb. It's faster, otherwise they are compatible.
+Install this with `sudo apt install libalgorithm-combinatorics-perl`
+or `cpanm Algorithm::Combinatorics` or manually.
+
+=cut
+
+if( @ARGV ){ printf "Special quadruplets: %d\n", count_special_quad(@ARGV) }
+else       { run_tests() }
+exit;
+
+sub comb { my($l,$k,$s)=(@_,0); $k ? map {my $i=$_; map[$$l[$i],@$_], comb($l,$k-1,$i+1) } $s..@$l-$k : [] }
+sub is_special_quad { my( $a, $b, $c, $d ) = @_; $a + $b + $c == $d }
+sub count_special_quad { 0 + grep is_special_quad(@$_), comb([ @_ ], 4) }
+
+sub run_tests {
+    for my $test (
+	[1,2,3,6   => 1],
+	[1,1,1,3,5 => 4],
+	[3,3,6,4,5 => 0],
+	[1..10     => 11],
+    ){
+	my $exp = pop @$test;
+	my @input = @$test;
+	my $got = count_special_quad(@input);
+	printf "%-6s input: %-20s   expected: %d   got: %d\n",
+	    $exp==$got ? 'ok': 'NOT OK',
+	    "@input",
+	    $exp,
+	    $got
+    }
+}
+
diff --git a/challenge-203/kjetillll/perl/ch-2.pl b/challenge-203/kjetillll/perl/ch-2.pl
new file mode 100644
index 0000000000..4e72f888ea
--- /dev/null
+++ b/challenge-203/kjetillll/perl/ch-2.pl
@@ -0,0 +1,62 @@
+#!/usr/bin/perl
+use strict; use warnings;
+
+=pod
+
+Run with arguments to use those as the input list or
+run without to run the included tests with this output:
+
+Uses File::Find, a core module (included in all normal Perl installations),
+to traverse down the source directory to get all directories.
+
+=cut
+
+use File::Find qw(find);
+use File::Path qw(make_path remove_tree);
+use Carp       qw(croak);
+
+if( @ARGV ){ copydir(@ARGV) }
+else       { run_test('/tmp/challenge-203') }
+exit;
+
+sub copydir {
+    my($src, $trg) = @_;
+    my @d = dirs( $src );
+    s/^$src/$trg/ for @d;
+    my @e = grep -d, @d;
+    croak "ERR: @e already exists! Did nothing!" if @e;
+    make_path(@d);
+}
+
+sub run_test {
+
+    #-- setup work dir
+    my $dir = shift;
+    die if $dir ne '/tmp/challenge-203'; #you'd better
+    remove_tree($dir); #cleanup if need be
+    make_path( map "$dir/a/b/c/$_", 1..5 );
+    sub touch { open my $fh, '>', $_ or die"ERR: $!"; close $fh };
+    touch for map "$dir/a/b/c/$_/$_.txt", 1,2,3, 5;
+
+    #-- copy directory structure
+    copydir( "$dir/a/b/c", "$dir/x/y" );
+
+    #--check
+    my @dirs = dirs($dir);
+    my @files = files($dir);
+    my @dirs_wanted = glob $dir.'{,/a{,/b{,/c{,/{1,2,3,4,5}}}},/x{,/y{,/{1,2,3,4,5}}}}';
+    my @files_wanted = map "$dir/a/b/c/$_/$_.txt", 1,2,3, 5;
+    print "Checking ".@dirs. " dirs: ", join(';',@dirs) eq join(';',@dirs_wanted) ? 'ok' : 'NOT OK', "\n";
+    print "Checking ".@files." files: ", join(';',@files) eq join(';',@files_wanted) ? 'ok' : 'NOT OK', "\n";
+
+    #-- cleanup
+    remove_tree($dir);
+}
+
+sub dirs  { _traverse(shift,sub{-d}) }
+sub files { _traverse(shift,sub{-f}) }
+sub _traverse {
+    my($dir, $cond, @lst) = @_;
+    find( { no_chdir=>1, wanted=>sub{ push @lst, $_ if &$cond } },  $dir );
+    sort @lst
+}