diff options
| -rw-r--r-- | challenge-057/jaredor/blog.txt | 1 | ||||
| -rwxr-xr-x | challenge-057/jaredor/perl/ch-1.pl | 153 | ||||
| -rwxr-xr-x | challenge-057/jaredor/perl/ch-2.pl | 25 |
3 files changed, 179 insertions, 0 deletions
diff --git a/challenge-057/jaredor/blog.txt b/challenge-057/jaredor/blog.txt new file mode 100644 index 0000000000..13056dfb8d --- /dev/null +++ b/challenge-057/jaredor/blog.txt @@ -0,0 +1 @@ +http://blogs.perl.org/users/jared_martin/2020/04/pwc-057-task-1-invert-tree-task-2-shortest-unique-prefix.html diff --git a/challenge-057/jaredor/perl/ch-1.pl b/challenge-057/jaredor/perl/ch-1.pl new file mode 100755 index 0000000000..16bc829df7 --- /dev/null +++ b/challenge-057/jaredor/perl/ch-1.pl @@ -0,0 +1,153 @@ +#!/usr/bin/perl +use strict; +use warnings; +use List::Util qw(max); +use Scalar::Util qw(looks_like_number); + +# PWC 057, Task #1 : Invert Tree + +# Run on the command line. The binary tree will be input as the argument array +# to the script. Any argument perl does not think is a number will be considered +# a null element, i.e., not a node in the tree. +# +# Examples +# +# ./ch-1.pl 1 2 3 +# ./ch-1.pl $(seq 7) +# ./ch-1.pl $(seq 15) +# ./ch-1.pl $(seq 31) +# +# If you want to get wild and crazy. Use a non-full binary tree: +# (You might want to widen your terminal window.) +# +# ./ch-1.pl $(seq 22) X X $(seq 25 45) X X X X $(seq 50 56) + +sub create_btree { + + my ( @N, @node ) = map { looks_like_number $_ ? 0 + $_ : undef } @_; + + my ( $i, $btlevel ) = ( 0, 1 ); + + $node[$i] = [ undef, undef, $N[$i] ]; # Root node. + + die "The root node cannot be NULL." unless defined $N[$i]; + + for $i ( 1 .. $#N ) { + + $btlevel = 2 * $btlevel - 1 if $i > 2 * ( $btlevel + 1 ); + my $parentidx = $btlevel - 1 + int( ( $i - $btlevel ) / 2 ); + + if ( defined $N[$i] ) { + die + "Not a binary tree. The parent node to element $i does not exist." + if not defined $N[$parentidx]; + $node[$i] = [ undef, undef, $N[$i] ]; + $node[$parentidx]->[ ( $i + 1 ) % 2 ] = $node[$i]; + } + } + return $node[0]; +} + +sub df_walk { # Depth first binary tree walk. + my ( $btree, $action, $level, ) = @_; + $level += 1; + $action->( $btree, $level ); + df_walk( $_, $action, $level ) for grep { defined $_ } @{$btree}[ 0, 1 ]; +} + +sub bf_walk { # Breadth first binary tree walk. + my ( $btree, $action ) = @_; + my @roster = ($btree); + while (@roster) { + my $node = shift @roster; + $action->($node); + push @roster, $_ for grep { defined $_ } @{$node}[ 0, 1 ]; + } +} + +sub get_levels { + my ( $btree, ) = @_; + my %levels; + my $get_level = sub { + my ( $btree, $level ) = @_; + push @{ $levels{$level} }, + [ $btree->[2], defined( $btree->[0] ), defined( $btree->[1] ) ]; + }; + df_walk( $btree, $get_level, 0 ); + return %levels; +} + +sub pretty_print { # Ironically, ugly code. + my ( $btree, ) = @_; + my %levels = get_levels($btree); + for my $level ( sort { $b <=> $a } keys %levels ) { + my $prev = delete $levels{ $level + 1 }; + my $idx = -1; + for my $ninfo ( @{ $levels{$level} } ) { + my ( $data, $Lidx, $Ridx ) = @$ninfo; + my ( @Lstrs, @Rstrs, @Sstrs ); + my ( $Llen, $Rlen, $Slen ) = ( 0, 0, 0 ); + my $spacer = ' ' x ( length $data ); + if ($Lidx) { + $data = "/$data"; + $Lidx = ++$idx; + @Lstrs = map { "$_ " } split( "\n", $prev->[$Lidx][0] ); + $Llen = max map { length $_ } @Lstrs; + } + if ($Ridx) { + $data = "$data\\"; + $Ridx = ++$idx; + @Rstrs = map { " $_" } split( "\n", $prev->[$Ridx][0] ); + $Rlen = max map { length $_ } @Rstrs; + } + push @Lstrs, ' ' x $Llen while @Lstrs < @Rstrs; + push @Rstrs, ' ' x $Rlen while @Rstrs < @Lstrs; + @Sstrs = map { $Lstrs[$_] . $spacer . $Rstrs[$_] } 0 .. $#Lstrs; + $Slen = @Sstrs ? max map { length $_ } @Sstrs : 0; + my ( $Nval, $Nstr ) = ( $data, ' ' x $Slen ); + substr( $Nstr, ( $Slen - length $Nval ) / 2, length $Nval ) = $Nval; + $ninfo->[0] = join( "\n", $Nstr, @Sstrs ); + } + } + my @pp_nodes = map { s([/\\])( )xmsg; $_ } split( "\n", $levels{1}[0][0] ); + my @pp_lines = map { s([^/\\])( )xmsg; $_ } split( "\n", $levels{1}[0][0] ); + pop @pp_lines; + my @pp = + map { s([/\\])( )xmsg; s(\S)(@)xmsg; $_ } split( "\n", $levels{1}[0][0] ); + for my $i ( 1 .. $#pp ) { + my ( $pos, $idx ) = ( 0, 0 ); + while ( $idx > -1 ) { + $idx = index $pp[$i], '@', $pos; + substr( $pp_lines[ $i - 1 ], $idx, 1 ) = substr( $pp[$i], $idx, 1 ) + if substr( $pp_lines[ $i - 1 ], $idx, 1 ) eq ' '; + $pos = $idx + 1; + } + $pp_lines[ $i - 1 ] =~ s{@ (\s*) /}{'@'.('-' x length($1)).'/'}xmseg; + $pp_lines[ $i - 1 ] =~ s{@-}{@.}xmsg; + $pp_lines[ $i - 1 ] =~ s{\\ (\s*) @}{'\\'.('-' x length($1)).'@'}xmseg; + $pp_lines[ $i - 1 ] =~ s{-@}{.@}xmsg; + $pp_lines[ $i - 1 ] =~ tr/@/ /; + } + @pp = map { ( $pp_nodes[$_], $pp_lines[$_] ) } 0 .. $#pp_lines; + push @pp, $pp_nodes[-1]; + print "\n", join( "\n", @pp ), "\n\n"; +} + +my $print_node = sub { print "$_[0]->[2]\n"; }; +my $flip_branches = sub { @{ $_[0] }[ 0, 1 ] = @{ $_[0] }[ 1, 0 ]; }; + +die "The binary tree must be input as arguments to this script." unless @ARGV; + +my $btree = create_btree @ARGV; + +print "\n\nInput binary tree:\n"; + +#bf_walk( $btree, $print_node ); +pretty_print $btree; + +bf_walk( $btree, $flip_branches ); + +print "\n\nOutput flipped binary tree:\n"; + +#bf_walk( $btree, $print_node ); +pretty_print $btree; diff --git a/challenge-057/jaredor/perl/ch-2.pl b/challenge-057/jaredor/perl/ch-2.pl new file mode 100755 index 0000000000..e3b9e39301 --- /dev/null +++ b/challenge-057/jaredor/perl/ch-2.pl @@ -0,0 +1,25 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use List::Util qw(uniq); + +# PWC 057 Task #2: Shortest Unique Prefix + +# Run on the command line. Give the words as arguments, e.g., + +# ./ch-2.pl alphabet book carpet cadmium cadeau alpine + +sub get_abvmap { + my ( @strings, %abbv ) = @_; + push @{ $abbv{ substr( $_, 0, 1, '' ) } }, $_ for @strings; + for my $mult ( grep { $#{ $abbv{$_} } } keys %abbv ) { + my %mult_abbv = get_abvmap( @{ delete $abbv{$mult} } ); + $abbv{ $mult . $_ } = [ $mult_abbv{$_} ] for keys %mult_abbv; + } + $abbv{$_} = $abbv{$_}->[0] for keys %abbv; + return %abbv; +} + +my %abvmap = get_abvmap( uniq @ARGV ); +my %abbrev = map { ( $_ . $abvmap{$_}, $_ ) } keys %abvmap; +print join( ' ', @abbrev{@ARGV} ), "\n"; |