Merge pull request #3273 from jo-37/contrib

 Solutions to challenge 095

3 files changed, 290 insertions, 0 deletions

diff --git a/challenge-095/jo-37/perl/ch-1.pl b/challenge-095/jo-37/perl/ch-1.pl
new file mode 100755
index 0000000000..f3c19491d6
--- /dev/null
+++ b/challenge-095/jo-37/perl/ch-1.pl
@@ -0,0 +1,113 @@
+#!/usr/bin/perl -s
+
+use v5.16;
+use Test2::V0;
+use warnings FATAL => 'all';
+use Scalar::Util 'looks_like_number';
+use experimental 'signatures';
+
+our ($tests, $examples, $verbose);
+
+run_tests() if $tests || $examples;    # does not return
+
+say(<<EOS), exit unless @ARGV;
+usage: $0 [-examples] [-tests] [--] [string]
+
+-examples
+    run the examples from the challenge
+ 
+-tests
+    run some tests
+
+-verbose
+    print diagnostic information
+
+string
+    string to test if it represents a palindrome number
+
+EOS
+
+### Input and Output
+
+my $ret = palindrome_number($ARGV[0]);
+
+if ($verbose) {
+    say "got $ARGV[0]" if $verbose;
+    if (!defined $ret) {
+        say 'is not a number';
+    } else {
+        say "has value ", 0 + $ARGV[0];
+        if ($ret eq '') {
+            say 'reverse value is not a number';
+        } elsif ($ret) {
+            say "is palindrome";
+        } else {
+            say "is not palindrome";
+        }
+    }
+}
+
+say 0 + !!$ret;
+
+### Implementation
+
+# The concept of "number palindromes" needs further specifications to be
+# well defined because "palindromic" is a string property and there is no
+# unique string representation of a number.  Following the examples I'll
+# take the decimal representation of a number that has to form a palindrome.
+# Though there seems to be some consensus on considering integer numbers
+# only, *any* numeric value is allowed here.
+#
+# A string shall be considered as palindromic number, iff the
+# transformation chain
+#   numify->stringify->reverse->numify->stringify 
+# resembles the input string. (All transformations from a Perl view.)
+#
+# This sub uses different false return values to signal the failed test:
+# - undef for a non-numeric input string
+# - the empty string for a non-numeric reversed numified input string
+# - zero for a numeric forward and backward value that is not a palindrome
+#   number
+sub palindrome_number ($str) {
+    return unless looks_like_number $str;
+    my $reverse = reverse $str + 0;
+    return '' unless looks_like_number $reverse;
+
+    0 + ($str eq $reverse + 0);
+}
+
+### Examples and tests
+
+sub run_tests {
+    SKIP: {
+        skip "examples" unless $examples;
+        ok palindrome_number(1221), 'example 1: 1221 is palindrome';
+        ok !palindrome_number(-101), 'example 2: -101 is not palindrome';
+        ok !palindrome_number(90), 'example 3: 90 is not palindrome';
+    }
+
+    SKIP: {
+        skip "tests" unless $tests;
+        for my $str (qw(21e12 1.221e3 0012100 00121 0012.2100)) {
+            ok !palindrome_number($str), "$str is not palindrome";
+        }
+        for my $str (qw(12.21 1221)) {
+            ok palindrome_number($str), "$str is palindrome";
+        }
+
+        # specific return codes
+        is palindrome_number('1O2O1'), U(), 'not a number';
+        is palindrome_number('-101'), '', 'reverse not a number';
+        is palindrome_number('1e-21'), '', 'reverse not a number';
+        is palindrome_number('12327'), 0, 'not palindrome';
+        is palindrome_number('+121.0'), 0, 'not palindrome';
+        is palindrome_number('121'), 1, 'palindrome';
+
+        # exotic cases: NaN vs. nan
+        is palindrome_number('NaN'), 0, 'NaN is numeric';
+        is palindrome_number('nan'), 1, 'possibly the strangest case';
+    }
+
+    done_testing;
+    exit;
+}
diff --git a/challenge-095/jo-37/perl/ch-2-ex.pl b/challenge-095/jo-37/perl/ch-2-ex.pl
new file mode 100644
index 0000000000..ec63be8f36
--- /dev/null
+++ b/challenge-095/jo-37/perl/ch-2-ex.pl
@@ -0,0 +1,19 @@
+use v5.16;
+
+# Let "Stack" print calls and results
+$Stack::verbose = 1;
+
+say 'create Stack';
+my $stack = Stack->new;
+
+$stack->push(2);
+$stack->push(-1);
+$stack->push(0);
+$stack->pop;
+$stack->top;
+$stack->push(0);
+
+$stack->min;
+
+$stack->max;
+$stack->size;
diff --git a/challenge-095/jo-37/perl/ch-2.pl b/challenge-095/jo-37/perl/ch-2.pl
new file mode 100755
index 0000000000..693759a17d
--- /dev/null
+++ b/challenge-095/jo-37/perl/ch-2.pl
@@ -0,0 +1,158 @@
+#!/usr/bin/perl -s
+
+use v5.16;
+use Test2::V0;
+use warnings FATAL => 'all';
+use experimental 'signatures';
+
+our ($tests, $examples, $verbose);
+
+$Stack::verbose = 1 if $verbose;
+
+run_tests() if $tests;    # does not return
+
+# prepare example run
+unshift @ARGV, 'ch-2-ex.pl' if $examples;
+
+say(<<EOS), exit unless @ARGV;
+usage: $0 [-tests] [-examples] [-verbose] [--] [file]
+
+-tests
+    run some tests
+
+-examples
+    run example
+
+-verbose
+    show stack operations
+
+file
+    run commands from file
+    (use 'ch-2-ex.pl' to run the example)
+
+EOS
+
+
+### Process input script
+
+do "$ARGV[0]";
+die $@ if $@;
+die "$ARGV[0]: ", $! if $!;
+
+
+### Implementation
+
+# Taking this task as an opportunity to practice AUTOLOADing methods and
+# overriding "can".  Though this is highly flexible and extensible it
+# comes with some overhead.
+# Using a blessed array ref as Stack object.
+
+package Stack;
+
+use Carp 'croak';
+use List::Util;
+
+our ($verbose, @stack, $arg);
+
+BEGIN {
+    # The %method hash maps the name of a method to a subref providing
+    # its "base" functionality.  The subs will be called with the
+    # variables @stack and $arg set to the current stack and the
+    # optional method argument respective.
+    my %method = (
+        push => sub {push @stack, $arg}, # returns new stack size
+        pop => sub {pop @stack},         # returns removed element
+        top => sub {$stack[$#stack]},
+        min => sub {List::Util::min @stack},
+        max => sub {List::Util::max @stack},
+        size => sub {@stack},            # returns current stack size
+        clear => sub {splice @stack},    # returns top element
+    );
+
+    # Wrapping the "base" functionality in an object.  For this purpose
+    # override "can" to return an existing or generated $method.  Must
+    # be available at compile time.
+    sub can ($self, $method) {
+        # Retrieve parent methods as well as the defined methods
+        # of this class.
+        my $can = $self->SUPER::can($method);
+        return $can if $can;
+
+        my $call = $method{$method};
+        return unless $call;
+
+        # Generate a method to perform the configured call.
+        sub ($self, $val=undef) {
+            # Provide variables and call method sub.
+            local $arg = $val;
+            local *stack = $self; # make @$self available as @stack
+            my $result = &$call();
+
+            # Benefit from method generation: single code for every
+            # method.
+            no warnings 'uninitialized';
+            say "$method($val): $result" if $verbose;
+
+            $result;
+        }
+    }
+}
+
+# Autoload dynamic methods
+our $AUTOLOAD;
+sub AUTOLOAD ($self, @args) {
+    my $called = $AUTOLOAD =~ s/.*:://r;
+    my $method = $self->can($called);
+    croak qq{Can't locate object method "$called" via package "}
+        . __PACKAGE__ . '"' unless $method;
+
+    $self->$method(@args);
+}
+
+# Creates an empty Stack.
+sub new ($class) {
+    bless [], $class;
+}
+
+
+### Tests
+
+package main;
+
+sub run_tests {
+    my $stack = Stack->new;
+
+    is $stack->size, 0, 'empty';
+    is $stack->min, U(), 'no min from empty stack';
+    is $stack->max, U(), 'no max from empty stack';
+    is $stack->top, U(), 'no top from empty stack';
+    is $stack->pop, U(), 'no pop from empty stack';
+    is $stack->push(2), 1, '1 element on stack';
+    is $stack->size, 1, 'after first push';
+    is $stack->push(-1), 2, '2 elements on stack';
+    is $stack->size, 2, 'after second push';
+    is $stack->push(0), 3, '3 elements on stack';
+    is $stack->size, 3, 'after third push';
+    is $stack->pop, 0, 'pop';
+    is $stack->size, 2, 'after pop';
+    is $stack->top, -1, 'top';
+    is $stack->push(0), 3, '3 elements on stack';
+    is $stack->size, 3,  'after fourth push';
+    is $stack->min, -1, 'minimum';
+    is $stack->max, 2, 'maximum';
+    is $stack->clear, 0, 'clear stack';
+    is $stack->size, 0, 'empty stack';
+
+    SKIP: {
+        $stack->push(-1);
+        ok my $can = $stack->can('can'), 'inquires parent for "can"'
+            or skip 'cannot can';
+        ok my $pop = $stack->$can('pop'), 'retrieve "pop" ref'
+            or skip 'cannot pop';
+        is $stack->$pop, -1, 'invoke "pop" ref';
+    }
+    like dies {$stack->foo}, qr/Can't locate object method/, 'method missing';
+
+    done_testing;
+    exit;
+}