2 files changed, 98 insertions, 0 deletions
diff --git a/challenge-057/dracos/perl/ch-1.pl b/challenge-057/dracos/perl/ch-1.pl
new file mode 100644
index 0000000000..286314b53f
--- /dev/null
+++ b/challenge-057/dracos/perl/ch-1.pl
@@ -0,0 +1,56 @@
+#!/usr/bin/env perl
+
+=head1 invert_tree
+
+A solution to task 1 of week 57 of the Perl Weekly Challenge.
+
+=cut
+
+use strict;
+use warnings;
+use Tree::DAG_Node;
+use Test::More;
+
+my $tree = Tree::DAG_Node->new({ name => 1 });
+$tree->new_daughter({ name => 2 })->new_daughter({ name => 4 })->mother->new_daughter({ name => 5 });
+$tree->new_daughter({ name => 3 })->new_daughter({ name => 6 })->mother->new_daughter({ name => 7 });
+
+my $inverted = Tree::DAG_Node->new({ name => 1 });
+$inverted->new_daughter({ name => 3 })->new_daughter({ name => 7 })->mother->new_daughter({ name => 6 });
+$inverted->new_daughter({ name => 2 })->new_daughter({ name => 5 })->mother->new_daughter({ name => 4 });
+
+is print_tree(invert_tree($tree)), print_tree($inverted);
+
+done_testing;
+
+=over
+
+=item invert_tree
+
+Given a Tree::DAG_Node tree of numbers, returns an inverted tree.
+
+=cut
+
+sub invert_tree {
+    my $tree = shift;
+    $tree = $tree->copy_tree if $tree->is_root;
+    $tree->set_daughters(reverse $tree->daughters);
+    foreach ($tree->daughters) {
+        invert_tree($_);
+    }
+    return $tree;
+}
+
+=item print_tree
+
+Given a Tree::DAG_Node tree, prints it out
+
+=cut
+
+sub print_tree {
+    my $tree = shift;
+    die unless $tree && $tree->isa('Tree::DAG_Node');
+    return join("\n", @{$tree->draw_ascii_tree});
+}
+
+=back
diff --git a/challenge-057/dracos/perl/ch-2.pl b/challenge-057/dracos/perl/ch-2.pl
new file mode 100644
index 0000000000..4c40118919
--- /dev/null
+++ b/challenge-057/dracos/perl/ch-2.pl
@@ -0,0 +1,42 @@
+#!/usr/bin/env perl
+
+=head1 unique_prefix
+
+A solution to task 2 of week 57 of the Perl Weekly Challenge.
+
+=cut
+
+use strict;
+use warnings;
+use Test::More;
+
+my $in = ["alphabet", "book", "carpet", "cadmium", "cadeau", "alpine"];
+my $out = ["alph", "b", "car", "cadm", "cade", "alpi"];
+is_deeply unique_prefix($in), $out;
+done_testing;
+
+=over
+
+=item unique_prefix
+
+Given an arrayref of words, constructs a new arrayref of shortest unique prefixes.
+
+=cut
+
+sub unique_prefix {
+    my ($words, $i) = @_;
+    $words = [@$words] unless $i; # Clone at the start, alters in place
+    $i ||= 1;
+    my %c;
+    map { $c{substr($_, 0, $i)}++ } @$words;
+    foreach(@$words) {
+        if ($c{substr($_, 0, $i)} == 1) {
+            $_ = substr($_, 0, $i);
+        } elsif ($i < length $_) {
+            unique_prefix($words, $i+1);
+        }
+    }
+    return $words;
+}
+
+=back