Add 057 (Invert Tree & Shortest Unique Prefix) solved by E. Choroba

There are a bit more files than usually. Hopefully, I'll have enough
time to explain everything in a blog post.

6 files changed, 229 insertions, 0 deletions

diff --git a/challenge-057/e-choroba/perl/Tree.pm b/challenge-057/e-choroba/perl/Tree.pm
new file mode 100644
index 0000000000..571d89d5fa
--- /dev/null
+++ b/challenge-057/e-choroba/perl/Tree.pm
@@ -0,0 +1,86 @@
+package Tree;
+use warnings;
+use strict;
+
+use Exporter qw{ import };
+our @EXPORT_OK = qw{ from_structure from_edges
+                     to_structure to_edges to_graph
+                     invert };
+
+sub from_structure {
+    my ($structure) = @_;
+    my %tree;
+    while ($structure =~ s/([0-9]+) \( ([0-9]+) , ([0-9]+) \) /$1/x) {
+        my ($parent, $left, $right) = ($1, $2, $3);
+        $tree{$parent} = [$left, $right];
+    }
+    my ($root) = $structure =~ /[0-9]+/g;
+    return $root, \%tree
+}
+
+sub from_edges {
+    my (@edges) = @_;
+    my (%tree, @children);
+    for my $edge (@edges) {
+        my ($child, $direction, $parent) = $edge =~ /([0-9]+) ([LR]) ([0-9]+)/
+            or die "Invalid format: '$edge'.\n";
+        $tree{$parent}[ 'R' eq $direction ] = $child;
+        push @children, $child;
+    }
+    my %root;
+    undef @root{ keys %tree };
+    delete @root{ @children };
+    my @roots = keys %root;
+    die "One root not found: @roots." if @roots != 1;
+    return $roots[0], \%tree
+}
+
+sub invert {
+    my ($tree) = @_;
+    for my $parent (keys %$tree) {
+        $tree->{$parent} = [ reverse @{ $tree->{$parent} } ];
+    }
+}
+
+sub to_structure {
+    my ($node, $tree, $inner) = @_;
+    return $node unless exists $tree->{$node};
+
+    my @children = @{ $tree->{$node} };
+    my $output = $node . '('
+               . join(',', map to_structure($_, $tree, 1), @children) . ')';
+    return $inner ? $output : "($output)"
+}
+
+sub to_edges {
+    my ($tree) = @_;
+    return [ map {
+                 my $parent = $_;
+                 map [ $tree->{$parent}[$_], qw( L R )[$_], $parent ], 0, 1
+             } keys %$tree ]
+}
+
+sub to_graph {
+    my ($root, $tree) = @_;
+    _to_graph($root, $tree, my $output = []);
+    return @$output
+}
+
+sub _to_graph {
+    my ($root, $tree, $output, @lines) = @_;
+    push @$output, $root;
+
+    if (my @children = @{ $tree->{$root} // [] }) {
+        push @$output, '-+-';
+        _to_graph($children[0], $tree, $output, @lines,
+                  (' ' x length($root)) . ' | ');
+        push @$output, @lines, ' ' x length $root, ' \\-';
+        _to_graph($children[1], $tree, $output, @lines,
+                  (' ' x (2 + length($root))) . ' ');
+
+    } else {
+        push @$output, "\n";
+    }
+}
+
+__PACKAGE__
diff --git a/challenge-057/e-choroba/perl/ch-1a.pl b/challenge-057/e-choroba/perl/ch-1a.pl
new file mode 100755
index 0000000000..f726f44b8a
--- /dev/null
+++ b/challenge-057/e-choroba/perl/ch-1a.pl
@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+
+use ARGV::OrDATA;
+
+my %invert = qw( L R R L );
+
+print s/ ([LR]) / $invert{$1} /r while <DATA>;
+
+__DATA__
+4 L 2
+5 R 2
+6 L 3
+7 R 3
+2 L 1
+3 R 1
diff --git a/challenge-057/e-choroba/perl/ch-1b.pl b/challenge-057/e-choroba/perl/ch-1b.pl
new file mode 100755
index 0000000000..5af1aa8245
--- /dev/null
+++ b/challenge-057/e-choroba/perl/ch-1b.pl
@@ -0,0 +1,25 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+use feature qw{ say };
+
+use ARGV::OrDATA;
+
+use FindBin;
+use lib $FindBin::Bin;
+use Tree qw{ from_structure };
+
+sub invert {
+    my ($node, $tree) = @_;
+    return $node unless exists $tree->{$node};
+
+    my @ch = reverse @{ $tree->{$node} };
+    return $node . '(' . join(',', map invert($_, $tree), @ch) . ')'
+}
+
+chomp( my $structure = <> );
+my ($root, $tree) = from_structure($structure);
+say '(', invert($root, $tree), ')';
+
+__DATA__
+(1(2(4,5),3(6,7)))
diff --git a/challenge-057/e-choroba/perl/ch-1c.pl b/challenge-057/e-choroba/perl/ch-1c.pl
new file mode 100755
index 0000000000..ffd907a3f2
--- /dev/null
+++ b/challenge-057/e-choroba/perl/ch-1c.pl
@@ -0,0 +1,17 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+
+use FindBin;
+use lib $FindBin::Bin;
+use Tree qw{ to_graph from_structure from_edges };
+
+for my $g ('(1(2,3))',
+           '(1(200(4(8(16,17),9),5(10,11)),3(6(12,13),7(14,15))))',
+           '(10(200(4,50000),300000(6000000,700)))',
+) {
+    print to_graph(from_structure($g));
+}
+
+print to_graph(from_edges(
+    '2 L 1', '3 R 1', '4 L 2', '5 R 2', '6 L 3', '7 R 3'));
diff --git a/challenge-057/e-choroba/perl/ch-2.pl b/challenge-057/e-choroba/perl/ch-2.pl
new file mode 100755
index 0000000000..8183c969a0
--- /dev/null
+++ b/challenge-057/e-choroba/perl/ch-2.pl
@@ -0,0 +1,47 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+
+sub shortest_unique_prefixes {
+    my @words = @_;
+    my (%prefixes, %used);
+    for my $word (@words) {
+        my $i = 1;
+        while ($i <= length $word) {
+            my $prefix = substr $word, 0, $i++;
+            if (exists $prefixes{$prefix}) {
+                undef $used{$prefix};
+                my $old = $prefixes{$prefix};
+                $prefixes{ substr $old, 0, $i } = delete $prefixes{$prefix};
+                die "Duplicate prefix: $prefix ($old:$word)"
+                    if $i > length $word || $i > length $old;
+
+            } elsif (! exists $used{$prefix}) {
+                $prefixes{$prefix} = $word;
+                last
+            }
+        }
+    }
+    my %to_prefixes = reverse %prefixes;
+    return [@to_prefixes{@words}]
+}
+
+use Test::More tests => 4;
+use Test::Exception;
+
+is_deeply
+    shortest_unique_prefixes(qw( alphabet book carpet cadmium cadeau alpine )),
+    [qw[ alph b car cadm cade alpi ]],
+    'sample input';
+
+throws_ok {
+    shortest_unique_prefixes(qw( perl perl ))
+} qr/Duplicate prefix: perl /, 'detect duplicate';
+
+throws_ok {
+    shortest_unique_prefixes(qw( A AA AAA ))
+} qr/Duplicate prefix: A /, 'common prefix asc';
+
+throws_ok {
+    shortest_unique_prefixes(qw( BBB BB B ))
+} qr/Duplicate prefix: B+ /, 'common prefix desc';
diff --git a/challenge-057/e-choroba/perl/tree.t b/challenge-057/e-choroba/perl/tree.t
new file mode 100755
index 0000000000..084acf4499
--- /dev/null
+++ b/challenge-057/e-choroba/perl/tree.t
@@ -0,0 +1,37 @@
+#!/usr/bin/perl
+use warnings;
+use strict;
+
+use Tree qw{ from_structure from_edges
+             to_structure to_edges to_graph
+             invert };
+
+use Test::More;
+use Test::Deep;
+
+my @edges = ('4 L 2', '5 R 2', '6 L 3', '7 R 3', '2 L 1', '3 R 1');
+my $structure = '(1(2(4,5),3(6,7)))';
+
+my ($root_e, $tree_e) = from_edges(@edges);
+cmp_deeply to_edges($tree_e), bag(map [split], @edges), 'edges';
+
+my ($root_s, $tree_s) = from_structure($structure);
+is to_structure($root_s, $tree_s), $structure, 'structure';
+
+is to_structure($root_e, $tree_e), $structure, 'edges to structure';
+
+cmp_deeply to_edges($tree_s), bag(map [split], @edges), 'structure to edges';
+
+my ($root_i, $tree_i) = from_structure($structure);
+invert($tree_i);
+is to_structure($root_i, $tree_i), '(1(3(7,6),2(5,4)))', 'invert';
+
+cmp_deeply join("", to_graph($root_e, $tree_e)),
+           join("\n", '1-+-2-+-4',
+                      '  |   \-5',
+                      '  \-3-+-6',
+                      '      \-7', ""),
+           'graph';
+
+
+done_testing();