diff options
| -rw-r--r-- | challenge-192/bob-lied/README | 4 | ||||
| -rw-r--r-- | challenge-192/bob-lied/perl/ch-1.pl | 73 | ||||
| -rw-r--r-- | challenge-192/bob-lied/perl/ch-2.pl | 146 | ||||
| -rw-r--r-- | challenge-200/bob-lied/README | 5 | ||||
| -rw-r--r-- | challenge-200/bob-lied/perl/ch-1.pl | 69 | ||||
| -rw-r--r-- | challenge-200/bob-lied/perl/ch-2.pl | 129 |
6 files changed, 422 insertions, 4 deletions
diff --git a/challenge-192/bob-lied/README b/challenge-192/bob-lied/README index c231e3a589..d6e1415b9b 100644 --- a/challenge-192/bob-lied/README +++ b/challenge-192/bob-lied/README @@ -1,3 +1,3 @@ -Solutions to weekly challenge 138 by Bob Lied +Solutions to weekly challenge 192 by Bob Lied -https://perlweeklychallenge.org/blog/perl-weekly-challenge-138/ +https://perlweeklychallenge.org/blog/perl-weekly-challenge-192/ diff --git a/challenge-192/bob-lied/perl/ch-1.pl b/challenge-192/bob-lied/perl/ch-1.pl new file mode 100644 index 0000000000..9e68272f86 --- /dev/null +++ b/challenge-192/bob-lied/perl/ch-1.pl @@ -0,0 +1,73 @@ +#!/usr/bin/env perl +# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu: +#============================================================================= +# ch-1.pl Perl Weekly Challenge Week 192 Task 1 Binary Flip +#============================================================================= +# Copyright (c) 2023, Bob Lied +#============================================================================= +# You are given a positive integer, $n. +# Write a script to find the binary flip. +# +# Example 1 Input: $n = 5 Output: 2 +# First find the binary equivalent of the given integer, 101. +# Then flip the binary digits 0 -> 1 and 1 -> 0 and we get 010. +# So Binary 010 => Decimal 2. +# Example 2 Input: $n = 4 Output: 3 +# Decimal 4 = Binary 100 Flip 0 -> 1 and 1 -> 0, we get 011. +# Binary 011 = Decimal 3 +# Example 3 Input: $n = 6 Output: 1 +# Decimal 6 = Binary 110 Flip 0 -> 1 and 1 -> 0, we get 001. +# Binary 001 = Decimal 1 +#============================================================================= + +use v5.36; + +use Getopt::Long; +my $Verbose = 0; +my $DoTest = 0; + +GetOptions("test" => \$DoTest, "verbose" => \$Verbose); +exit(!runTest()) if $DoTest; + +say binaryFlip($_) for @ARGV; + +# Doing a binary complement will set the high bits. We can fix it with string +# operations by removing leading 1s. Or we can do it in binary by figuring +# out the highest bit that is set in $n and masking the rest. +sub binaryFlip($n) +{ + my $fn = ((~$n) & maskUpTo($n)); +} + +# Return a bitmask that will include $n. +# Find the highest bit set in $n and make a bitmask in which +# all the bits including and to the right of that are 1. +sub maskUpTo($n) +{ + my $mask = 1; + $mask = (($mask << 1) | 1 ) while ( $n >>= 1 ); + return $mask; +} + +sub runTest +{ + use Test2::V0; + + is( maskUpTo( 1), 0x0001, "Mask 1"); + is( maskUpTo( 2), 0x0003, "Mask 2"); + is( maskUpTo( 5), 0x0007, "Mask 5"); + is( maskUpTo( 27), 0x001f, "Mask 27"); + is( maskUpTo(4180), 0x1fff, "Mask 4180"); + is( maskUpTo(0x15555555), 0x1fffffff, "Mask 29 bits"); + + is( binaryFlip(0), 1, "Flip 0"); + is( binaryFlip(1), 0, "Flip 1"); + is( binaryFlip(5), 2, "Example 1"); + is( binaryFlip(4), 3, "Example 2"); + is( binaryFlip(6), 1, "Example 3"); + is( binaryFlip(0x15555555), 0xaaaaaaa, "29 bit number"); + is( binaryFlip(0x1555555555555), 0xaaaaaaaaaaaa, "48 bit number"); + + done_testing; +} + diff --git a/challenge-192/bob-lied/perl/ch-2.pl b/challenge-192/bob-lied/perl/ch-2.pl new file mode 100644 index 0000000000..62ef8f656c --- /dev/null +++ b/challenge-192/bob-lied/perl/ch-2.pl @@ -0,0 +1,146 @@ +#!/usr/bin/env perl +# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu: +#============================================================================= +# ch-2.pl Perl Weekly Challenge Task 2 Equal Distribution +#============================================================================= +# Copyright (c) 2023, Bob Lied +#============================================================================= +# You are given a list of integers greater than or equal to zero, @list. +# Write a script to distribute the number so that each members are same. +# If you succeed then print the total moves otherwise print -1. +# Please follow the rules (as suggested by Neils van Dijke [2022-11-21 13:00] +# 1) You can only move a value of '1' per move +# 2) You are only allowed to move a value of '1' to a direct neighbor/adjacent cell +# +# Example 1: Input: @list = (1, 0, 5) Output: 4 +# Move #1: 1, 1, 4 (2nd cell gets 1 from the 3rd cell) +# Move #2: 1, 2, 3 (2nd cell gets 1 from the 3rd cell) +# Move #3: 2, 1, 3 (1st cell get 1 from the 2nd cell) +# Move #4: 2, 2, 2 (2nd cell gets 1 from the 3rd cell) +# +# Example 2: Input: @list = (0, 2, 0) Output: -1 +# It is not possible to make each same. +# +# Example 3: Input: @list = (0, 3, 0) Output: 2 +# Move #1: 1, 2, 0 (1st cell gets 1 from the 2nd cell) +# Move #2: 1, 1, 1 (3rd cell gets 1 from the 2nd cell) +#============================================================================= + +use v5.36; + +use List::Util qw/sum min all/; + +use Getopt::Long; +my $Verbose = 0; +my $DoTest = 0; + +GetOptions("test" => \$DoTest, "verbose" => \$Verbose); +exit(!runTest()) if $DoTest; + +my $lst = "@ARGV"; +$lst =~ s/[[:punct:]]/ /g; + +say equalDist( [ split ' ', $lst ] ); + +sub equalDist($list) +{ + my $len = scalar(@$list); + my $target = sum($list->@*) / $len; + + say showList("_", "_", "_", $list), " target=$target" if $Verbose; + + if ( $target != int($target) ) + { + say "Can't distribute evenly, target=$target" if $Verbose; + return -1; + } + + my $move = 0; + + # Push surpluses from left to right + my $deficit = 0; + for (my $i = 0 ; $i < $len-1 ; $i++ ) + { + my $surplus = $list->[$i] - $target; + + if ( $surplus <= 0 ) + { + $deficit -= $surplus; + say showList($i, $i, 0, $list), " deficit=$deficit" if $Verbose; + next; + } + + # If we can satisfy our left neighbors, do that before + # pushing stuff right that we'll have to push back later + if ( $deficit > 0 ) + { + my $moveLeft = min($surplus, $deficit); + $move += $moveLeft; + $surplus -= $moveLeft; + $deficit -= $moveLeft; + $list->[$i] -= $moveLeft; + $list->[$i-1] += $moveLeft; + say showList($i, $i-1, $moveLeft, $list), " deficit=$deficit" if $Verbose; + next if $surplus == 0; + } + $move += $surplus; + $list->[$i] -= $surplus; + $list->[$i+1] += $surplus; + say showList($i, $i+1, $surplus, $list), " deficit=$deficit" if $Verbose; + } + + # Push surpluses from right to left + for ( my $i = $len -1 ; $i > 0 ; $i-- ) + { + if ( (my $surplus = $list->[$i] - $target) > 0 ) + { + $move += $surplus; + $list->[$i] -= $surplus; + $list->[$i-1] += $surplus; + say showList($i, $i-1, $surplus, $list) if $Verbose; + } + } + say "Total moves: $move" if $Verbose; + + die showList(0,0,$move, $list), " FAILED" if $Verbose + && ! all { $_ == $target } $list->@*; + + return $move; +} + +sub showList($from, $to, $count, $list) +{ + my $s; + if ( $from eq $to ) { $s .= "List: [" } + elsif ( $from < $to ) { $s .= "Move $count from [$from] --> [$to]: ["; } + else { $s .= "Move $count from [$from] <-- [$to]: ["; } + + for ( my $i = 0 ; $i < @$list ; $i++ ) + { + if ( $from ne $to && $i == $from ) { $s .= " $list->[$i]- " } + elsif ( $from ne $to && $i == $to ) { $s .= " $list->[$i]+ " } + else { $s .= " $list->[$i] " } + } + $s .= "]" +} + + +sub runTest +{ + use Test2::V0; + + is( equalDist( [1,0,5] ), 4, "Example 1"); + is( equalDist( [0,2,0] ), -1, "Example 2"); + is( equalDist( [0,3,0] ), 2, "Example 3"); + is( equalDist( [10,0,0,0,0] ), 20, "Stack left"); + is( equalDist( [0,0,0,0,10] ), 20, "Stack right"); + is( equalDist( [0,0,10,0,0] ), 12, "Stack middle"); + is( equalDist( [3,3,3,4,2] ), 1, "Last move"); + is( equalDist( [5,3,4,4,4] ), 1, "First move"); + is( equalDist( [2,3,1,3,1] ), 2, "Little shuffle"); + is( equalDist( [2,1,3,1,3] ), 2, "Little shuffle take 2"); + is( equalDist( [2,0,2,0,6] ), 8, "Bigger shuffle"); + + done_testing; +} + diff --git a/challenge-200/bob-lied/README b/challenge-200/bob-lied/README index 5a7d2f0335..3d4521e11d 100644 --- a/challenge-200/bob-lied/README +++ b/challenge-200/bob-lied/README @@ -1,3 +1,4 @@ -Solutions to weekly challenge 199 by Bob Lied +Solutions to weekly challenge 200 by Bob Lied -https://perlweeklychallenge.org/blog/perl-weekly-challenge-199/ +https://perlweeklychallenge.org/blog/perl-weekly-challenge-200/ +https://github.com/boblied/perlweeklychallenge-club/tree/master/challenge-200/bob-lied diff --git a/challenge-200/bob-lied/perl/ch-1.pl b/challenge-200/bob-lied/perl/ch-1.pl new file mode 100644 index 0000000000..dfd881146d --- /dev/null +++ b/challenge-200/bob-lied/perl/ch-1.pl @@ -0,0 +1,69 @@ +#!/usr/bin/env perl +# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu: +#============================================================================= +# ch-1.pl Perl Weekly Challenge Week 200 Task 1 Arithmetic Slice +#============================================================================= +# Copyright (c) 2023, Bob Lied +#============================================================================= +# You are given an array of integers. +# Write a script to find out all Arithmetic Slices for the given array of +# integers. An integer array is called arithmetic if it has at least 3 +# elements and the differences between any three consecutive elements are the same. +# +# Example 1 Input: @array = (1,2,3,4) Output: (1,2,3), (2,3,4), (1,2,3,4) +# Example 2 Input: @array = (2) Output: () as no slice found. +# +# Example 1 implies that we should get every sub-slice of length at least 3 +# and that output order should have shorter sequences first +#============================================================================= + +use v5.36; + +use List::Util qw/all/; + +use Getopt::Long; +my $Verbose = 0; +my $DoTest = 0; + +use constant MINLENGTH => 3; + +GetOptions("test" => \$DoTest, "verbose" => \$Verbose); +exit(!runTest()) if $DoTest; + +die "All args should be numeric" unless all { $_ =~ m/-?\d+/ } @ARGV; + +my $answer = aslice(@ARGV); # Should validate all numbers +say join(", ", map { "(". join(",", $_->@*) .")" } $answer->@*); + +sub aslice(@list) +{ + my @result = (); + while ( @list >= MINLENGTH ) + { + my $diff = $list[1] - $list[0]; + + for ( my $i = 2; $i < @list && $list[$i] - $list[$i-1] == $diff ; $i++ ) + { + # Push every sub-slice that is at least MINLENGTH long + push @result, [ @list[0..$i] ] if $i >= (MINLENGTH -1 ); + } + shift @list; + } + return [ sort { scalar(@$a) <=> scalar(@$b) } @result ]; +} + +sub runTest +{ + use Test2::V0; + + is( aslice( 1,2,3,4 ), [ [1,2,3], [2,3,4], [1,2,3,4] ], "Example 1"); + is( aslice( 2 ), [ ], "Example 2"); + is( aslice( 1,2,4,6,9,15,20,25,30,37 ), + [ [2,4,6], [15,20,25], [20,25,30], [15,20,25,30] ], "Bigger list, more diffs"); + is( aslice( 2,3,5,8,13,21 ), [], "No runs of 3"); + is( aslice( 3,6,4,7,10 ), [[4,7,10]], "Non-monotonic"); + is( aslice( 9,3,1,-1 ), [ [3,1,-1] ], "Negative difference"); + + done_testing; +} + diff --git a/challenge-200/bob-lied/perl/ch-2.pl b/challenge-200/bob-lied/perl/ch-2.pl new file mode 100644 index 0000000000..18c23d62fb --- /dev/null +++ b/challenge-200/bob-lied/perl/ch-2.pl @@ -0,0 +1,129 @@ +#!/usr/bin/env perl +# vim:set ts=4 sw=4 sts=4 et ai wm=0 nu: +#============================================================================= +# ch-2.pl Perl Weekly Challenge Week 200 Task 2 Seven Segment 200 +#============================================================================= +# Copyright (c) 2023, Bob Lied +#============================================================================= +# A seven segment display is an electronic component, usually used to +# display digits. The segments are labeled 'a' through 'g' as shown: +# +# -- <- a +# f| |b +# -- <- g +# e| |c +# -- <- d +# +# The encoding of each digit can be represented compactly as a truth table: +# +# my @truth = qw<abcdef bc abdeg abcdg bcfg acdfg acdefg abc abcdefg abcfg>; +# +# For example, $truth[1] = ‘bc’. The digit 1 would have segments ‘b’ and ‘c’ +# enabled. +# +# Write a program that accepts any decimal number and draws that number +# as # a horizontal sequence of ASCII seven segment displays, similar to +# the # following: +# +# ------- ------- ------- +# | | | | | +# | | | | | +# ------- +# | | | | | +# | | | | | +# ------- ------- ------- +# +# To qualify as a seven segment display, each segment must be drawn (or not +# drawn) according to your @truth table. +# The number "200" was of course chosen to celebrate our 200th week! +#============================================================================= + +use v5.36; + +# Which segments are on for each digit? + # 0 1 2 3 4 5 6 7 8 9 +my @truth = qw<abcdef bc abdeg abcdg bcfg acdfg acdefg abc abcdefg abcfg>; + +# 7x7 as one 49-character string, a few different styles +# aaaaaaa aaaaa aaaaa +# f f f b ff bb Bold version +# f b f b ff bb +# ggggggg ggggg ggggg +# e c e c ee cc +# e c e c ee cc +# ddddddd ddddd ddddd +#my $Digit = 'aaaaaaaf bf bggggggge ce cddddddd'; # Match example + my $Digit = ' aaaaa f bf b ggggg e ce c ddddd '; # Rounded corners +#my $Digit = 'aaaaaaaff bbff bbgggggggee ccee ccddddddd'; # Bold + +# Display characteristics + my %Char; +#$Char{$_} = '-' for qw(a d g); $Char{$_} = '|' for qw(b c e f); +#$Char{$_} = '=' for qw(a d g); $Char{$_} = '|' for qw(b c e f); +#$Char{$_} = '#' for qw(a b c d e f g); +#$Char{$_} = 'o' for qw(a b c d e f g); + +# Use Unicode horizontal and vertical bars +binmode(STDOUT, "encoding(UTF-8)"); # No "wide character" warning +#$Char{$_} = "\x{2500}" for qw(a d g); $Char{$_} = "\x{2502}" for qw(b c e f); + $Char{$_} = "\x{2501}" for qw(a d g); $Char{$_} = "\x{2503}" for qw(b c e f); +# $Char{$_} = "\x{2550}" for qw(a d g); $Char{$_} = "\x{2551}" for qw(b c e f); + +use Getopt::Long; +my $Verbose = 0; +my $DoTest = 0; + +GetOptions("test" => \$DoTest, "verbose" => \$Verbose); +exit(!runTest()) if $DoTest; + +displayAsSegment($_) for @ARGV; + +sub displayAsSegment($str) +{ + # Make a 49-character segment string for each digit + my @seg = map { asSegment($_) } split '', $str; + + for my $row ( 0 .. 6 ) + { + # Make a row by taking a 7-char substring of each segment + # Top row: 0 .. 6 0 .. 6 0 .. 6 + # 2: 7 13 7 .. 13 7 .. 13 + # ... + # 7: 42 .. 48 42 .. 48 42 .. 48 + say join(" ", map { substr($seg[$_], $row*7, 7) } 0 .. $#seg); + } +} + +sub asSegment($digit) +{ + my $seven = $Digit; + my $t = $truth[$digit]; + + # Turn off segments not in the digit + $seven =~ s/[^$t]/ /g; + + for my $on ( split '', $t ) + { + $seven =~ s/$on/$Char{$on}/g; + } + return $seven; +} + +sub runTest +{ + use Test2::V0; + + my $Digit = ' aaaaa f bf b ggggg e ce c ddddd '; + is( asSegment("0"), ' ----- | || | | || | ----- ', "asSegment 0"); + is( asSegment("1"), ' | | | | ', "asSegment 1"); + is( asSegment("2"), ' ----- | | ----- | | ----- ', "asSegment 2"); + is( asSegment("3"), ' ----- | | ----- | | ----- ', "asSegment 3"); + is( asSegment("4"), ' | || | ----- | | ', "asSegment 4"); + is( asSegment("5"), ' ----- | | ----- | | ----- ', "asSegment 5"); + is( asSegment("6"), ' ----- | | ----- | || | ----- ', "asSegment 6"); + is( asSegment("7"), ' ----- | | | | ', "asSegment 7"); + is( asSegment("8"), ' ----- | || | ----- | || | ----- ', "asSegment 8"); + is( asSegment("9"), ' ----- | || | ----- | | ', "asSegment 9"); + + done_testing; +} |