diff options
| -rw-r--r-- | challenge-057/athanasius/perl/Trie.pm | 132 | ||||
| -rw-r--r-- | challenge-057/athanasius/perl/ch-2.pl | 90 |
2 files changed, 222 insertions, 0 deletions
diff --git a/challenge-057/athanasius/perl/Trie.pm b/challenge-057/athanasius/perl/Trie.pm new file mode 100644 index 0000000000..b0fa0f871f --- /dev/null +++ b/challenge-057/athanasius/perl/Trie.pm @@ -0,0 +1,132 @@ +#!perl + +################################################################################ +=comment + +Trie + +=cut +################################################################################ + +#--------------------------------------# +# Copyright © 2020 PerlMonk Athanasius # +#--------------------------------------# + +use strict; +use warnings; + +#=============================================================================== +package Node; +#=============================================================================== + +#------------------------------------------------------------------------------- +sub new +#------------------------------------------------------------------------------- +{ + my ($class, $parent, $letter) = @_; + my %self = + ( + parent => $parent, + letter => $letter, + children => [], + ); + + return bless \%self, $class; +} + +#------------------------------------------------------------------------------- +sub add_child +#------------------------------------------------------------------------------- +{ + my ($self, $child) = @_; + + push $self->{children}->@*, $child; +} + +#------------------------------------------------------------------------------- +sub get_parent +#------------------------------------------------------------------------------- +{ + my ($self) = @_; + + return $self->{parent}; +} + +#------------------------------------------------------------------------------- +sub get_letter +#------------------------------------------------------------------------------- +{ + my ($self) = @_; + + return $self->{letter}; +} + +#------------------------------------------------------------------------------- +sub get_child +#------------------------------------------------------------------------------- +{ + my ($self, $letter) = @_; + + for my $child ( $self->{children}->@* ) + { + return $child if defined $child && $child->{letter} eq $letter; + } + + return undef; +} + +#------------------------------------------------------------------------------- +sub num_children +#------------------------------------------------------------------------------- +{ + my ($self) = @_; + + return scalar $self->{children}->@*; +} + +#=============================================================================== +package Trie; +#=============================================================================== + +#------------------------------------------------------------------------------- +sub new +#------------------------------------------------------------------------------- +{ + my ($class) = @_; + my %self = (root => Node->new(undef, '')); + + return bless \%self, $class; +} + +#------------------------------------------------------------------------------- +sub insert_word +#------------------------------------------------------------------------------- +{ + my ($self, $word) = @_; + + my $node = $self->{root}; + + for my $letter (split //, $word) + { + my $child = $node->get_child($letter); + + if (defined $child) + { + $node = $child; + } + else + { + my $new_child = Node->new($node, $letter); + + $node->add_child($new_child); + + $node = $new_child; + } + } + + return $node; +} + +################################################################################ +1; +################################################################################ diff --git a/challenge-057/athanasius/perl/ch-2.pl b/challenge-057/athanasius/perl/ch-2.pl new file mode 100644 index 0000000000..c22a4ddf22 --- /dev/null +++ b/challenge-057/athanasius/perl/ch-2.pl @@ -0,0 +1,90 @@ +#!perl + +################################################################################ +=comment + +Perl Weekly Challenge 057 +========================= + +Task #2 +------- +*Shortest Unique Prefix* + +Write a script to find the *shortest unique prefix* for each word in the given +list. The prefixes will not necessarily be of the same length. + +*Sample Input* + + [ "alphabet", "book", "carpet", "cadmium", "cadeau", "alpine" ] + +*Expected Output* + + [ "alph", "b", "car", "cadm", "cade", "alpi" ] + +=cut +################################################################################ + +#--------------------------------------# +# Copyright © 2020 PerlMonk Athanasius # +#--------------------------------------# + +use strict; +use warnings; +use List::Util qw( max ); +use lib '.'; +use Trie; + +#------------------------------------------------------------------------------- +BEGIN +#------------------------------------------------------------------------------- +{ + $| = 1; + print "\n"; +} + +#=============================================================================== +MAIN: +#=============================================================================== +{ + print "Challenge 057, Task #2: Shortest Unique Prefix (Perl)\n\n"; + + my @words = qw( alphabet book carpet cadmium cadeau alpine ); + my $width = max map { length } @words; + + # Create a trie tree of the words, and a hash mapping each word to its last + # node in the trie + + my $trie = Trie->new(); + my %word_ends; + + $word_ends{$_} = $trie->insert_word($_) for @words; + + # Find and print the shortest unique prefix for each word + + for my $word (@words) + { + my ($prefix, $last_letter); + my $in_prefix = 0; + + for (my $node = $word_ends{$word}; $node; $node = $node->get_parent) + { + if ($in_prefix) + { + $prefix = $node->get_letter . $prefix; + } + elsif ($node->num_children > 1) + { + $prefix = $node->get_letter . $last_letter; + $in_prefix = 1; + } + else + { + $last_letter = $node->get_letter; + } + } + + printf "%-*s --> %s\n", $width, $word, $prefix; + } +} + +################################################################################ |