Merge pull request #3192 from jo-37/contrib

Command line handling for challenges 093 / 094

2 files changed, 174 insertions, 76 deletions

diff --git a/challenge-094/jo-37/perl/ch-1.pl b/challenge-094/jo-37/perl/ch-1.pl
index a6725762ba..0e8dc4860b 100644..100755
--- a/challenge-094/jo-37/perl/ch-1.pl
+++ b/challenge-094/jo-37/perl/ch-1.pl
@@ -1,28 +1,53 @@
-#!/usr/bin/perl
+#!/usr/bin/perl -s
 
 use v5.16;
 use Test2::V0;
 use experimental 'postderef';
 
+our $examples;
+
+run_examples() if $examples; # does not return
+
+say(<<EOS), exit unless @ARGV;
+Usage: $0 [-examples] [word ...]
+
+-examples
+    runs the given examples
+
+word ... 
+    use given words as input
+EOS
+
+# Apply "anagroup" to @ARGV and convert the result into the requested
+# format.
+say '[ ' .
+    (join ', ', map {
+        '(' . (join ', ', map {qq{"$_"}} @$_) . ')'
+        } anagroup(@ARGV)) .
+    ' ]';
+
 # Group given strings by anagrams.
 sub anagroup {
-	# Hash to collect anagrams by a canonical key.
-	my %anagroup;
-
-	# Split strings into characters, sort and rejoin to gain a
-	# "canonical anagram", decorate each string with its canonical
-	# anagram and collect the strings within the prepared hash by
-	# canonical key.
-	push $anagroup{$_->[0]}->@*, $_->[1]
-		foreach map {[join('', sort {$a cmp $b} split //), $_]} @_;
-
-	# Sort the canonical anagrams and retrieve the corresponding string
-	# lists.  (The sort is required for a stable result only.)
-	map {$anagroup{$_}} sort keys %anagroup;
+    # Hash to collect anagrams by a canonical key.
+    my %anagroup;
+
+    # Split strings into characters, sort and rejoin to gain a
+    # "canonical anagram", decorate each string with its canonical
+    # anagram and collect the strings within the prepared hash by
+    # canonical key.
+    push $anagroup{$_->[0]}->@*, $_->[1]
+        foreach map {[join('', sort split //), $_]} @_;
+
+    # Sort the canonical anagrams and retrieve the corresponding string
+    # lists.  (The sort is required for a stable result only.)
+    map {$anagroup{$_}} sort keys %anagroup;
 }
 
-is [anagroup qw(opt bat saw tab pot top was)],
-	[[qw(bat tab)], [qw(saw was)], [qw(opt pot top)]], 'Example 1';
-is [anagroup 'x'], [['x']], 'Example 2';
+sub run_examples {
+    is [anagroup qw(opt bat saw tab pot top was)],
+        [[qw(bat tab)], [qw(saw was)], [qw(opt pot top)]], 'Example 1';
+    is [anagroup 'x'], [['x']], 'Example 2';
 
-done_testing;
+    done_testing;
+    exit;
+}
diff --git a/challenge-094/jo-37/perl/ch-2.pl b/challenge-094/jo-37/perl/ch-2.pl
index 816dd3aa00..d16577d410 100644..100755
--- a/challenge-094/jo-37/perl/ch-2.pl
+++ b/challenge-094/jo-37/perl/ch-2.pl
@@ -1,4 +1,4 @@
-#!/usr/bin/perl
+#!/usr/bin/perl -s
 
 use v5.16;
 use warnings FATAL => 'all';
@@ -6,7 +6,106 @@ no warnings 'recursion';
 use experimental qw(postderef signatures);
 use Data::Dump;
 
-# $::verbose = 1;
+our ($mode, $examples, $verbose);
+$mode ||= 'NLR';
+
+run_examples() if $examples; # does not return
+
+say(<<EOS), exit unless @ARGV;
+usage: $0 [-examples] [-verbose] [-mode=MODE] [node ...]
+
+-examples
+    run examples from challenge
+
+-verbose
+    print diagnostic information
+
+-mode=MODE
+    select traversal mode, any permutation of N, L, R. Default: NLR
+    see: 
+    https://en.wikipedia.org/wiki/Tree_traversal#Depth-first_search_of_binary_tree
+    
+
+node ...
+    build binary tree from given nodes.  Each node has the form:
+    id:value[:left[:right]]
+    where
+        id is a unique node identifier
+        value is the node's value
+        left is the id of the left child node (may be missing or empty)
+        right is the id of the right child node (may be missing)
+    The nodes may be specified in any order, but the root node must have
+    an id of 'ROOT'.  The given example could be written as
+    ROOT:1:n2:n3 n2:2:n4:n5 n3:3 n4:4 n5:5:n6:n7 n6:6 n7:7
+EOS
+
+# @ARGV to BinaryTree
+my $tree = build_tree(@ARGV);
+dd $tree if $verbose;
+
+my $list = LinkedList->new;
+
+# Convert
+flatten_tree($tree, $list, $mode);
+dd $list if $verbose;
+
+# Format output
+say "$mode: ", join ' -> ', $list->as_array;
+
+# Build a binary tree from the given list of nodes
+sub build_tree {
+    # capture nodes
+    my %nodes = map {
+        my ($key, %val); ($key, @val{qw(val left right)}) = split /:/;
+        ($key => \%val)
+    } @_;
+    dd %nodes if $verbose;
+
+    # dynamically build the tree from the given nodes while traversing
+    my $tree = BinaryTree->new('ROOT');
+    $tree->traverse('NLR', sub {
+        my %node = $nodes{$_->[0]}->%*;
+        $_->[0] = $node{val};
+        $_->[1] = [$node{left}] if $node{left};
+        $_->[2] = [$node{right}] if $node{right};
+    });
+
+    $tree;
+}
+
+# The "glue" for this task: traverse given binary tree and build a
+# linked list from the visited nodes.
+sub flatten_tree ($tree, $list, $mode) {
+    $tree->traverse($mode, sub {
+            # Need to take special care at the head node.
+            $list ? $list->add($_->[0])->next :
+            $list->unshift($_->[0])->head
+        });
+}
+
+sub run_examples {
+    # Construct the binary tree from example 1.
+    my $tree = BinaryTree->new(1,
+            [2, 
+                [4],
+                [5,
+                    [6],
+                    [7],
+                ],
+            ],
+            [3]);
+    dd $tree if $verbose;
+
+    # Traverse the tree in different modes, where NLR solves this task.
+    foreach my $mode (qw(NLR LNR RNL LRN)) {
+        my $list = LinkedList->new;
+        flatten_tree($tree, $list, $mode);
+        dd $list if $verbose;
+        say "$mode: ", join ' -> ', $list->as_array;
+    }
+    exit;
+}
+
 
 package LinkedList;
 # Minimal object implementation of a singly linked list providing just
@@ -23,60 +122,60 @@ package LinkedList;
 
 # Constructor for an empty list.
 sub new ($class) {
-	bless [], $class;
+    bless [], $class;
 }
 
 # A list in boolean context shall be true when positioned on an existing
 # node.  Returns false after iterating beyond the last node or if there
 # are no nodes at all.
 use overload
-	bool => sub ($self, $, $) {!!$self->[0]};
+    bool => sub ($self, $, $) {!!$self->[0]};
 
 # Getter for the current node's data.
 sub data ($self) {
-	$self->[0][1];
+    $self->[0][1];
 }
 
 # Advance to the next node.
 sub next ($self) {
-	$self->[0] = $self->[0][0];
-	
-	# Enable method chaining.
-	$self;
+    $self->[0] = $self->[0][0];
+    
+    # Enable method chaining.
+    $self;
 }
 
 # Reset the current node to the head node.
 sub head ($self) {
-	$self->[0] = $self->[1];
+    $self->[0] = $self->[1];
 
-	# Enable method chaining.
-	$self;
+    # Enable method chaining.
+    $self;
 }
 
 # Insert a new node after the current node.  This operation cannot be
 # used to insert a (new) head node - use "unshift" instead.
 sub add ($self, $data) {
-	$self->[0][0] = [$self->[0][0], $data];
+    $self->[0][0] = [$self->[0][0], $data];
 
-	# Enable method chaining.
-	$self;
+    # Enable method chaining.
+    $self;
 }
 
 # Retrieve node data as an array, starting from the head node.
 sub as_array ($self) {
-	my @arr;
-	for ($self->head; $self; $self->next) {
-		push @arr, $self->data;
-	}
-	@arr;
+    my @arr;
+    for ($self->head; $self; $self->next) {
+        push @arr, $self->data;
+    }
+    @arr;
 }
 
 # Insert a new head node.
 sub unshift ($self, $data) {
-	$self->[1] = [$self->[1], $data];
+    $self->[1] = [$self->[1], $data];
 
-	# Enable method chaining.
-	$self;
+    # Enable method chaining.
+    $self;
 }
 
 
@@ -96,7 +195,7 @@ package BinaryTree;
 # - an optional left sub tree
 # - an optional right sub tree
 sub new ($class, $data, $left=undef, $right=undef) {
-	bless [$data, $left, $right], $class;
+    bless [$data, $left, $right], $class;
 }
 
 # Depth-first traversal of the binary tree starting from its root.  The
@@ -105,39 +204,13 @@ sub new ($class, $data, $left=undef, $right=undef) {
 # 'R' for the right sub tree.  See
 # https://en.wikipedia.org/wiki/Tree_traversal#Depth-first_search_of_binary_tree
 # The code ref is called for every node according to the specified
-# processing order with $_ set to the current node's data.
+# processing order with $_ set to the current node.
 sub traverse ($self, $mode, $code) {
-	# Recursively process the tree in the specified order.  Nodes are
-	# not blessed and thus have no methods.
-	foreach (split //, $mode) {
-		do {local $_ = $self->[0]; $code->()} if /^N$/;
-		traverse($self->[1], $mode, $code) if /^L$/ && $self->[1];
-		traverse($self->[2], $mode, $code) if /^R$/ && $self->[2];
-	}
-}
-
-
-package main;
-
-# Construct the binary tree from example 1.
-my $tree = BinaryTree->new(1,
-		[2, 
-			[4],
-			[5,
-				[6],
-				[7],
-			],
-		],
-		[3]);
-dd $tree if $::verbose;
-
-# Traverse the tree in different modes, where NLR solves this task.
-foreach my $mode (qw(NLR LNR RNL LRN)) {
-	my $list = LinkedList->new;
-	$tree->traverse($mode, sub {
-			# Need to take special care at the head node.
-			$list ? $list->add($_)->next : $list->unshift($_)->head
-		});
-	dd $list if $::verbose;
-	say "$mode: ", join ' -> ', $list->as_array;
+    # Recursively process the tree in the specified order.  Nodes are
+    # not blessed and thus have no methods.
+    foreach (split //, $mode) {
+        do {local $_ = $self; $code->()} if /^N$/;
+        traverse($self->[1], $mode, $code) if /^L$/ && $self->[1];
+        traverse($self->[2], $mode, $code) if /^R$/ && $self->[2];
+    }
 }