aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--challenge-095/dave-jacoby/blog.txt1
-rw-r--r--challenge-095/dave-jacoby/perl/ch-1.pl34
-rw-r--r--challenge-095/dave-jacoby/perl/ch-2.pl85
-rw-r--r--challenge-096/dave-jacoby/blog.txt1
-rw-r--r--challenge-096/dave-jacoby/perl/ch-1.pl49
-rw-r--r--challenge-096/dave-jacoby/perl/ch-2.pl190
6 files changed, 360 insertions, 0 deletions
diff --git a/challenge-095/dave-jacoby/blog.txt b/challenge-095/dave-jacoby/blog.txt
new file mode 100644
index 0000000000..b7f76f7f29
--- /dev/null
+++ b/challenge-095/dave-jacoby/blog.txt
@@ -0,0 +1 @@
+https://jacoby.github.io/2021/01/11/ada-bob-hannah-nin-perl-weekly-challenge-95.html \ No newline at end of file
diff --git a/challenge-095/dave-jacoby/perl/ch-1.pl b/challenge-095/dave-jacoby/perl/ch-1.pl
new file mode 100644
index 0000000000..b6fe19801a
--- /dev/null
+++ b/challenge-095/dave-jacoby/perl/ch-1.pl
@@ -0,0 +1,34 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature qw{ say signatures state };
+no warnings qw{ experimental };
+
+use Scalar::Util qw{looks_like_number};
+
+my @numbers = ( 1221, -101, 90, 2112, 9, 90.09 );
+
+for my $num (@numbers) {
+ my $r = is_palindrome_number($num);
+ say qq{Input: $num};
+ say qq{Output: $r};
+ say '';
+}
+
+# this is specifically about numbers, so we'll use
+# looks_like_number from Scalar::Util. Otherwise we'll
+# assume base-10 and treat it like a decimal, which is
+# how Perl likes to stringify numbers.
+
+# returns 0 if not a number
+# returns 0 if not a palindrome
+# what remains should only be palindromic numbers,
+# so returns 1
+
+sub is_palindrome_number($num = 0) {
+ return 0 unless looks_like_number($num);
+ my $mun = join '', reverse split //, $num;
+ return 0 unless $mun eq $num;
+ return 1;
+}
diff --git a/challenge-095/dave-jacoby/perl/ch-2.pl b/challenge-095/dave-jacoby/perl/ch-2.pl
new file mode 100644
index 0000000000..62cab6323a
--- /dev/null
+++ b/challenge-095/dave-jacoby/perl/ch-2.pl
@@ -0,0 +1,85 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature qw{ say signatures state };
+no warnings qw{ experimental };
+
+# I use `say` instead of `print` because the newlines
+# improve readability in the output
+
+my $stack = Stack->new;
+$stack->push(2);
+$stack->push(-1);
+$stack->push(0);
+$stack->all; # 2, -1, 0
+
+$stack->pop; # removes 0
+$stack->all;
+
+say $stack->top; # prints -1
+$stack->push(0);
+
+$stack->all;
+say $stack->min; # prints -1
+
+say 'DONE';
+exit;
+
+# I think a Moose-style implementation would be good for me
+package Stack;
+
+# see min, below.
+use List::Util;
+
+# creates a new Stack object. Except for the "min" function,
+# there's nothing to keep this from handling anything that a
+# scalar can hold: number, string, hashref, arrayref, closure
+sub newx ( $class ) {
+ my $self = {};
+ $self->{values} = [];
+ return bless $self, $class;
+}
+
+sub new ( $class, @values ) {
+ my $self = {};
+ $self->{values} = [];
+ push $self->{values}->@*, @values;
+ return bless $self, $class;
+}
+
+# 'push' and 'pop' are methods used by Perl's Array type
+# to handle stack values, so here we just use them
+sub push ( $self, $value ) {
+ push $self->{values}->@*, $value;
+ return 1;
+}
+
+sub pop ( $self ) {
+ return pop $self->{values}->@*;
+}
+
+# it's harder to reuse subroutines from libraries than
+# it is to reuse those provided by Perl, so we have to
+# use List::Util and use min's long name rather than
+# use List::Util qw{min}, because Perl would think we're
+# rewriting min.
+sub min ( $self ) {
+ return List::Util::min( $self->{values}->@* );
+}
+
+# the thing I had to remember that push and pop occur from
+# the back of the stack, not the front, and thus top is the
+# _last_ value, not the _first_. I could use {values}[0]
+# if instead I used shift and unshift.
+sub top ( $self ) {
+ return $self->{values}[-1];
+ return 1;
+}
+
+# bookkeeping function so I know what's going on inside
+sub all ( $self ) {
+ say join "\n\t", 'Size: ' . scalar $self->{values}->@*,
+ $self->{values}->@*, '';
+ return 1;
+}
diff --git a/challenge-096/dave-jacoby/blog.txt b/challenge-096/dave-jacoby/blog.txt
new file mode 100644
index 0000000000..7ec383b99e
--- /dev/null
+++ b/challenge-096/dave-jacoby/blog.txt
@@ -0,0 +1 @@
+https://jacoby.github.io/2021/01/19/going-the-distance-perl-weekly-challenge-96.html
diff --git a/challenge-096/dave-jacoby/perl/ch-1.pl b/challenge-096/dave-jacoby/perl/ch-1.pl
new file mode 100644
index 0000000000..336009661b
--- /dev/null
+++ b/challenge-096/dave-jacoby/perl/ch-1.pl
@@ -0,0 +1,49 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature qw{ say signatures state };
+no warnings qw{ experimental };
+
+# I suppose I'm commenting instead of blogging, or pre-blogging,
+# but the key questions with this challenge are:
+# * "What is a word?"
+# * "What is a word boundary?"
+
+# Mohammad gives us an easy one with "The Weekly Challenge",
+# where we can easily split on spaces and reverse, but padding
+# spaces at the front and end of the next example make things harder.
+# I mean, we COULD just use a regular expression to pull out the
+# begining and ending spaces, but splitting on /\s/ (space characters)
+# and grepping for /\S/ (non-space characters would be OK)
+
+# but a space character isn't a word boundary. I asked and brian d foy
+# gave me good advice about word boundaries. I mean, I asked the Internet
+# and found his blog post:
+# https://www.effectiveperlprogramming.com/2016/06/perl-v5-22-adds-fancy-unicode-word-boundaries/
+
+# I threw in the line from Buffalo Springfield's "For What It's Worth"
+# because it adds an apostrophe, which confounds the pre-5.22 default
+# word border separation.
+
+my @inputs;
+push @inputs, 'The Weekly Challenge';
+push @inputs, ' Perl and Raku are part of the same family ';
+push @inputs, q{Nobody's right if everybody's wrong};
+
+for my $s (@inputs) {
+ my $r = reverse_words($s);
+ say <<"END";
+ Input: "$s"
+ Output: "$r"
+END
+}
+
+# This is a very pipe-y, very Dave way of doing this. Beyond the
+# sub signature, I split on word boundaries as the blog suggests,
+# grep to make sure that there's something non-space, revers and
+# join with a space. I am sure a confounding string can be created
+# but I'll engage that when the challenge is presented.
+sub reverse_words ( $string ) {
+ return join ' ', reverse grep /\S/, split /\b{wb}/, $string;
+}
diff --git a/challenge-096/dave-jacoby/perl/ch-2.pl b/challenge-096/dave-jacoby/perl/ch-2.pl
new file mode 100644
index 0000000000..8e113ffa1d
--- /dev/null
+++ b/challenge-096/dave-jacoby/perl/ch-2.pl
@@ -0,0 +1,190 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+use feature qw{ say signatures state };
+no warnings qw{ experimental };
+
+use List::Util qw{min};
+
+my @input;
+push @input, [qw{ kitten sitting }];
+push @input, [qw{ sunday monday }];
+push @input, [qw{ slight lights }];
+push @input, [qw{ fed feed }];
+push @input, [qw{ test test }];
+push @input, [qw{ test text }];
+
+for my $x (@input) {
+ edit_distance( $x->@* );
+}
+
+# I first found the Levenshtein distance when poking in the center of
+# perlbrew. This is how it knows, when you type `perlbrew xeec` to
+# suggest you try `perlbrew exec` instead. This gives us the first
+# part, the number of changes you'd need to get from S1 to S2. I thought
+# about but never implemented it as a kind-of 404 page for endpoints:
+# you look like you're looking for "index" but typed "idnex", for example.
+
+# What we don't get from editdist is WHICH changes those would be.
+# therefore, it's a half-solution for this problem.
+
+sub edit_distance ( $s1, $s2 ) {
+ editdist( $s1, $s2 );
+}
+
+# let's try to make this a whole solution
+sub editdist ( $s1, $s2 ) {
+ my @s1 = split //, $s1;
+ my @s2 = split //, $s2;
+ my @d;
+ $d[$_][0] = $_ for ( 0 .. @s1 );
+ $d[0][$_] = $_ for ( 0 .. @s2 );
+
+ # this creates a two-dimensional array that starts like this:
+ # [0,1,2,3,4,5,6]
+ # [1, , , , , , ]
+ # [2, , , , , , ]
+ # [3, , , , , , ]
+ # [4, , , , , , ]
+ # [5, , , , , , ]
+ # which gets filled in iteratively in the nested loops below
+
+ for my $i ( 1 .. @s1 ) {
+ for my $j ( 1 .. @s2 ) {
+
+ # Let's understand this. For a particular i and j position
+ # if the two agree, D[i][j] equals D[-i][-j]
+
+ # if they don't however, we find the value above
+ # the value before and the one above and before, find
+ # the lowest, and add one.
+
+ # this means that $d[-1][-1] would have the total
+
+ $d[$i][$j] = (
+ $s1[ $i - 1 ] eq $s2[ $j - 1 ]
+ ? $d[ $i - 1 ][ $j - 1 ]
+ : 1 + min(
+ $d[ $i - 1 ][$j],
+ $d[$i][ $j - 1 ],
+ $d[ $i - 1 ][ $j - 1 ]
+ )
+
+ );
+ }
+ }
+
+ print <<"END";
+
+ Input: S1: $s1
+ S2: $s2
+ Change Count: $d[-1][-1]
+END
+
+ my @operations = find_changes( \@d, \@s1, \@s2 );
+
+ my $c = 1;
+ for my $operation ( reverse @operations ) {
+ say qq{ Operation $c: $operation};
+ $c++;
+ }
+
+ # returns the last column of the last row, which SHOULD
+ # be the min changes.
+ return $d[-1][-1];
+}
+
+# d = 2-dimensional array, result of LD
+# s1 = array of first input
+# s2 = array of second input
+# i = current row
+# j = current column
+
+sub find_changes ( $d, $s1, $s2, $i = -1, $j = -1 ) {
+
+ # -1 means implicit end of array, which gets turned
+ # into explicit end of array
+ $i = $i == -1 ? -1 + scalar $d->@* : $i;
+ $j = $j == -1 ? -1 + scalar $d->[-1]->@* : $j;
+
+ # zero means that there are no more changes
+ return if $d->[$i][$j] == 0;
+
+ my $v = $d->[$i][$j];
+ my $v1 = $d->[ $i - 1 ][ $j - 1 ];
+ my $v2 = $d->[$i][ $j - 1 ];
+ my $v3 = $d->[ $i - 1 ][$j];
+
+ my @output;
+ if (0) {
+
+ # The impossible situation we never planned for.
+ # I LIKE to put an if ( false ) statement first,
+ # so it's easy to just move the elsifs around
+ # should I decide or discern that I have the order
+ # wrong.
+ }
+ elsif ( $v1 == $v - 1 ) {
+ my $c1 = $s1->[ $i - 1 ];
+ my $c2 = $s2->[ $j - 1 ];
+ push @output, qq{replace '$c1' with '$c2'};
+ push @output, find_changes( $d, $s1, $s2, $i - 1, $j - 1 );
+ }
+ elsif ( $v2 == $v - 1 ) {
+ my $c1 = $s1->[ $i - 1 ];
+ my $c2 = $s2->[ $j - 1 ];
+ if ( $j == scalar $s2->@* ) {
+ push @output, qq{insert '$c2' at the end};
+ }
+ else { push @output, qq{insert '$c2'}; }
+ push @output, find_changes( $d, $s1, $s2, $i, $j - 1 );
+ }
+ elsif ( $v3 == $v - 1 ) {
+ my $c1 = $s1->[ $i - 1 ];
+ my $c2 = $s2->[ $j - 1 ];
+ push @output, qq{remove '$c1' from beginning} if $i == 1;
+ push @output, qq{remove '$c1'} if $i != 1;
+ push @output, find_changes( $d, $s1, $s2, $i - 1, $j );
+ }
+ elsif ( $v1 == $v ) {
+ push @output, find_changes( $d, $s1, $s2, $i - 1, $j - 1 );
+ }
+ elsif ( $v2 == $v ) {
+ push @output, find_changes( $d, $s1, $s2, $i, $j - 1 );
+ }
+ elsif ( $v3 == $v ) {
+ push @output, find_changes( $d, $s1, $s2, $i - 1, $j );
+ }
+ return @output;
+}
+
+# -------------------------------------------------------------------
+# straight copy of Wikipedia's "Levenshtein Distance"
+sub levenshtein_distance {
+ my ( $f, $g ) = @_;
+ my @a = split //, $f;
+ my @b = split //, $g;
+
+ # There is an extra row and column in the matrix. This is the
+ # distance from the empty string to a substring of the target.
+ my @d;
+ $d[$_][0] = $_ for ( 0 .. @a );
+ $d[0][$_] = $_ for ( 0 .. @b );
+
+ for my $i ( 1 .. @a ) {
+ for my $j ( 1 .. @b ) {
+ $d[$i][$j] = (
+ $a[ $i - 1 ] eq $b[ $j - 1 ]
+ ? $d[ $i - 1 ][ $j - 1 ]
+ : 1 + min(
+ $d[ $i - 1 ][$j],
+ $d[$i][ $j - 1 ],
+ $d[ $i - 1 ][ $j - 1 ]
+ )
+ );
+ }
+ }
+ return $d[@a][@b];
+}
+
generated by cgit (git 2.34.1) at 2026-07-03 22:00:43 +0000