aboutsummaryrefslogtreecommitdiff
path: root/challenge-209/bob-lied
diff options
context:
space:
mode:
Diffstat (limited to 'challenge-209/bob-lied')
-rw-r--r--challenge-209/bob-lied/README6
-rw-r--r--challenge-209/bob-lied/perl/ch-1.gv14
-rw-r--r--challenge-209/bob-lied/perl/ch-1.pl157
-rw-r--r--challenge-209/bob-lied/perl/ch-2.pl121
4 files changed, 295 insertions, 3 deletions
diff --git a/challenge-209/bob-lied/README b/challenge-209/bob-lied/README
index 13fcdf5b47..e6e0735fcb 100644
--- a/challenge-209/bob-lied/README
+++ b/challenge-209/bob-lied/README
@@ -1,4 +1,4 @@
-Solutions to weekly challenge 208 by Bob Lied
+Solutions to weekly challenge 209 by Bob Lied
-https://perlweeklychallenge.org/blog/perl-weekly-challenge-208/
-https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-208/bob-lied
+https://perlweeklychallenge.org/blog/perl-weekly-challenge-209/
+https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-209/bob-lied
diff --git a/challenge-209/bob-lied/perl/ch-1.gv b/challenge-209/bob-lied/perl/ch-1.gv
new file mode 100644
index 0000000000..4a3b850017
--- /dev/null
+++ b/challenge-209/bob-lied/perl/ch-1.gv
@@ -0,0 +1,14 @@
+digraph {
+ rankdir="LR"
+
+START -> a [label="0"];
+START -> bc [label="1"];
+a -> a [label="0"];
+a -> bc [label="1"];
+bc -> b [label="0"];
+bc -> c [label="1"];
+b -> a [label="0"];
+c -> a [label="0"];
+b -> bc [label="1"];
+c -> bc [label="1"];
+}
diff --git a/challenge-209/bob-lied/perl/ch-1.pl b/challenge-209/bob-lied/perl/ch-1.pl
new file mode 100644
index 0000000000..0ab59cc4f1
--- /dev/null
+++ b/challenge-209/bob-lied/perl/ch-1.pl
@@ -0,0 +1,157 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-1.pl Perl Weekly Challenge 209 Task 1 Special Bit Charactioners
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given an array of binary bits that ends with 0.
+# Valid sequences in the bit string are:
+# [0] -decodes-to-> "a"
+# [1, 0] -> "b"
+# [1, 1] -> "c"
+# Write a script to print 1 if the last charactioner is an “a” otherwise print 0.
+# Example 1 Input: @bits = (1, 0, 0) Output: 1
+# The given array bits can be decoded as 2-bits charactioner (10) followed
+# by 1-bit charactioner (0).
+# Example 2 Input: @bits = (1, 1, 1, 0) Output: 0
+# Possible decode can be 2-bits charactioner (11) followed by 2-bits charactioner
+# (10) i.e. the last charactioner is not 1-bit charactioner.
+#---------
+# Recognizing bit sequences is a good use of state machines. If we end in
+# state a, then we have a valid sequence.
+#
+#
+# +------+
+# | |
+# +---v---+ -|
+# | |--+
+# | |<--------------------+
+# +---->| a |<--------+ |
+# | | | | |
+# |0 +-------+ 0| |
+# +----------+ | 1 +--------+ |
+# | Start | 1| +---------| b | |
+# +----------+ | | +--------+ |
+# |1 v v ^ |
+# | +-------+ 0 | |
+# +---->| |---------+ |
+# | bc |-----------------+ |
+# +-------+ 1 | |
+# ^ v |0
+# | 1 +-------+
+# +-----------------| c |
+# +-------+
+#
+# This state machine can be represented as a table that maps a current state
+# and input to a next state. The 'b' and 'c' states could be combined.
+#
+#
+# Current State | 0 | 1 |
+# --------------+=====+=====+
+# Start| a | bc |
+# a| a | bc |
+# bc| b | c |
+# b| a | bc |
+# c| a | bc |
+#
+# We can extend the state machine to decode the output, not just test it,
+# by adding an action that emits the character to transitions where a
+# character is recognized.
+#=============================================================================
+
+use v5.36;
+
+use builtin qw(false true); no warnings "experimental::builtin";
+
+use enum qw(:ST_ START A B C BC);
+
+my @StateMachineValidate;
+# current state 0 1
+# ---------- ---- -----
+$StateMachineValidate[ST_START] = [ ST_A, ST_BC ];
+$StateMachineValidate[ST_A ] = [ ST_A, ST_BC ];
+$StateMachineValidate[ST_BC ] = [ ST_B, ST_C ];
+$StateMachineValidate[ST_B ] = [ ST_A, ST_BC ];
+$StateMachineValidate[ST_C ] = [ ST_A, ST_BC ];
+
+my @StateMachineDecode;
+$StateMachineDecode[ST_START] = [ { next => ST_A, action => sub { 'a' } },
+ { next => ST_BC, action => sub { } } ];
+
+$StateMachineDecode[ST_A ] = [ { next => ST_A, action => sub { 'a' } },
+ { next => ST_BC, action => sub { } } ];
+
+$StateMachineDecode[ST_BC ] = [ { next => ST_B, action => sub { 'b' } },
+ { next => ST_C, action => sub { 'c' } } ];
+
+$StateMachineDecode[ST_B ] = [ { next => ST_A, action => sub { 'a' } },
+ { next => ST_BC, action => sub { } } ];
+
+$StateMachineDecode[ST_C ] = [ { next => ST_A, action => sub { 'a' } },
+ { next => ST_BC, action => sub { } } ];
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+say decodeSeq(\@ARGV, $Verbose);
+
+sub isValidInput($in)
+{
+ if ( not ( $in == 1 || $in == 0 ) )
+ {
+ warn "Unexpected input: $in";
+ return false;
+ }
+ return true;
+}
+
+sub validateSeq($bit)
+{
+ my $state = ST_START;
+ while ( defined ( my $input = shift @$bit ) )
+ {
+ return 0 if ( not isValidInput($input) );
+ $state = $StateMachineValidate[$state][$input];
+ }
+ return $state == ST_A ? 1 : 0;
+}
+
+sub onTransition($out, $val) { push @$out, $val; }
+
+sub decodeSeq($bit, $show=false)
+{
+ my @output;
+ my $state = ST_START;
+ while ( defined ( my $input = shift @$bit ) )
+ {
+ return 0 if ( not isValidInput($input) );
+
+ my $transition = $StateMachineDecode[$state][$input];
+ $state = $transition->{next};
+ push @output, $transition->{action}();
+ }
+ my $isValid = ( $state == ST_A ? 1 : 0 );
+
+ say join("", @output) if $show && $isValid;
+ return $isValid;
+}
+
+sub runTest
+{
+ use Test2::V0;
+
+ is( decodeSeq([1,0,0 ]), 1, "Example 1");
+ is( decodeSeq([1,1,1,0]), 0, "Example 2");
+
+ is( decodeSeq([0,0,0,0]), 1, "aaaa");
+ is( decodeSeq([1,1,0,0]), 1, "caa");
+ is( decodeSeq([0,1,0,0]), 1, "aba");
+ is( decodeSeq([0,1,0,1,1]), 0, "abc");
+
+ done_testing;
+}
diff --git a/challenge-209/bob-lied/perl/ch-2.pl b/challenge-209/bob-lied/perl/ch-2.pl
new file mode 100644
index 0000000000..fac55c92fb
--- /dev/null
+++ b/challenge-209/bob-lied/perl/ch-2.pl
@@ -0,0 +1,121 @@
+#!/usr/bin/env perl
+# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu:
+#=============================================================================
+# ch-2.pl Perl Weekly Challenge 209 Task 2 Merge Account
+#=============================================================================
+# Copyright (c) 2023, Bob Lied
+#=============================================================================
+# You are given an array of accounts i.e. name with list of email addresses.
+# Write a script to merge the accounts where possible. The accounts can only
+# be merged if they have at least one email address in common.
+# Example 1:
+# Input: @accounts = [ ["A", "a1@a.com", "a2@a.com"],
+# ["B", "b1@b.com"],
+# ["A", "a3@a.com", "a1@a.com"] ]
+# Output: [ ["A", "a1@a.com", "a2@a.com", "a3@a.com"], ["B", "b1@b.com"] ]
+#
+# Example 2: Input: @accounts = [ ["A", "a1@a.com", "a2@a.com"],
+# ["B", "b1@b.com"],
+# ["A", "a3@a.com"],
+# ["B", "b2@b.com", "b1@b.com"] ]
+# Output: [ ["A", "a1@a.com", "a2@a.com"],
+# ["A", "a3@a.com"],
+# ["B", "b1@b.com", "b2@b.com"] ]
+#
+#=============================================================================
+
+use v5.36;
+
+use List::Util qw/uniq first/;
+
+use Getopt::Long;
+my $Verbose = 0;
+my $DoTest = 0;
+
+GetOptions("test" => \$DoTest, "verbose" => \$Verbose);
+exit(!runTest()) if $DoTest;
+
+# Merge two lists if they have an element in common. If they can be
+# merged, then the first list will be modified.
+sub merge($one, $two)
+{
+ # For each email in the first list (first element is account name)
+ for my $email ( $one->@[1 .. $#{$one}] )
+ {
+ # If it exists in the second list, then they have something
+ # in common and should be merged.
+ if ( first { $_ eq $email } $two->@[1 .. $#{$two}] )
+ {
+ # Make a combined list, but with unique elements
+ return [ sort { $a cmp $b } uniq @$one, @$two ];
+ }
+ }
+ return undef;
+}
+
+sub mergeAccount($accounts)
+{
+ my @merged;
+
+ # Collect all the account names, first element in each array
+ my @acctName = sort { $a cmp $b } uniq map { $_->[0] } @$accounts;
+ for my $n ( @acctName )
+ {
+ my @list = ( grep { $_->[0] eq $n } @$accounts );
+ for ( my $i = 0 ; $i < $#list ; $i++ )
+ {
+ for ( my $j = 0; $j <= $#list ; $j++ )
+ {
+ next if $j == $i;
+ next unless defined $list[$j];
+ if ( my $m = merge($list[$i], $list[$j]) )
+ {
+ $list[$i] = $m;
+ $list[$j] = undef;
+ $j = 0; # Rescan
+ }
+ }
+ }
+ push @merged, grep { defined $_ } @list;
+ }
+ return \@merged;
+}
+
+sub runTest
+{
+ use Test2::V0;
+ my @accounts = ( ["A", 'a1@a.com', 'a2@a.com'],
+ ["B", 'b1@b.com'],
+ ["A", 'a3@a.com', 'a1@a.com'] );
+
+ is( mergeAccount(\@accounts),
+ [ [ qw(A a1@a.com a2@a.com a3@a.com) ], [ qw(B b1@b.com) ] ],
+ , "Example 1");
+
+ @accounts = ( ['A', 'a1@a.com', 'a2@a.com'],
+ ['B', 'b1@b.com'],
+ ['A', 'a3@a.com'],
+ ['B', 'b2@b.com', 'b1@b.com'] );
+
+ is( mergeAccount(\@accounts),
+ [ [ qw(A a1@a.com a2@a.com) ],
+ [ qw(A a3@a.com) ],
+ [ qw(B b1@b.com b2@b.com) ] ],
+ , "Example 2");
+
+ @accounts = ( ['A', 'a1@a.com', 'a2@a.com'],
+ ['B', 'b1@b.com'],
+ ['A', 'a3@a.com'],
+ ['B', 'b2@b.com', 'b1@b.com'],
+ ['A', 'a3@a.com', 'a4@a.com' ],
+ ['A', 'a1@a.com', 'a4@a.com' ],
+ ['B', 'b3@b.com'] );
+ my $expected = [ [ qw(A a1@a.com a2@a.com a3@a.com a4@a.com) ],
+ [ qw(B b1@b.com b2@b.com) ],
+ [ qw(B b3@b.com) ] ];
+
+ my $actual = mergeAccount(\@accounts);
+ is( $actual, $expected, "Transitive merge all A");
+
+ done_testing;
+}
generated by cgit (git 2.34.1) at 2026-07-04 16:23:29 +0000