From de956e6ce1bb55bfd2d5a300a895fc1e7fb7fcd1 Mon Sep 17 00:00:00 2001 From: Matthias Muth Date: Sat, 28 Sep 2024 22:19:13 +0200 Subject: Challenge 288 Task 1 and 2 solutions in Perl by Matthias Muth --- challenge-288/matthias-muth/README.md | 533 +++++++++++++----------------- challenge-288/matthias-muth/blog.txt | 1 + challenge-288/matthias-muth/perl/ch-1.pl | 120 +++++++ challenge-288/matthias-muth/perl/ch-2.pl | 150 +++++++++ challenge-288/matthias-muth/perl/ch-2b.pl | 106 ++++++ 5 files changed, 613 insertions(+), 297 deletions(-) create mode 100644 challenge-288/matthias-muth/blog.txt create mode 100755 challenge-288/matthias-muth/perl/ch-1.pl create mode 100755 challenge-288/matthias-muth/perl/ch-2.pl create mode 100755 challenge-288/matthias-muth/perl/ch-2b.pl diff --git a/challenge-288/matthias-muth/README.md b/challenge-288/matthias-muth/README.md index 073176fc91..fd8cd47912 100644 --- a/challenge-288/matthias-muth/README.md +++ b/challenge-288/matthias-muth/README.md @@ -1,340 +1,279 @@ -# About Passwords, Birds, and Common Regexes - -**Challenge 287 solutions in Perl by Matthias Muth** - -## Task 1: Strong Password - -> You are given a string, $str.
-> Write a program to return the minimum number of steps required to make the given string very strong password. If it is already strong then return 0.
-> Criteria:
-> - It must have at least 6 characters.
-> - It must contains at least one lowercase letter, at least one upper case letter and at least one digit.
-> - It shouldn't contain 3 repeating characters in a row.
-> -> Following can be considered as one step:
-> - Insert one character
-> - Delete one character
-> - Replace one character with another
-> +# The Simple and the Fast + +**Challenge 288 solutions in Perl by Matthias Muth** + +Two quite different solutions for Task 1:
+'The Simple', looping away from the input number until it finds a palindrome, and
+'The Fast', which *constructs* three palindromes that are candidates to be the closest, +and then chooses among them.
+Read more below! + +And for Task 2, a 'recursive flood-filling-and-counting' solution. + +Great challenges!
+Thank you, Mohammad Anwar and Peter Campbell Smith! + +## Task 1: Closest Palindrome + +> You are given a string, \$str, which is an integer.
+> Write a script to find out the closest palindrome, not including itself. If there are more than one then return the smallest.
+> The closest is defined as the absolute difference minimized between two integers.
+>
> Example 1
-> Input: \$str = "a"
-> Output: 5
+> Input: \$str = "123"
+> Output: "121"
>
> Example 2
-> Input: \$str = "aB2"
-> Output: 3
+> Input: \$str = "2"
+> Output: "1"
+> There are two closest palindrome "1" and "3". Therefore we return the smallest "1".
>
> Example 3
-> Input: \$str = "PaaSW0rd"
-> Output: 0
+> Input: \$str = "1400"
+> Output: "1441"
>
> Example 4
-> Input: \$str = "Paaasw0rd"
-> Output: 1
->
-> Example 5
-> Input: \$str = "aaaaa"
-> Output: 3
- -#### Dealing with short passwords - -If the password is too short, there is no other way than inserting characters up to the required length. - -Example 2 is a test case for this:
- `aB2` => 3 (like insert `X`, `Y`, `Z` to get `aB1XYZ` )
-but also:
- `""` => 6 (like `aB1cde`). - -#### Dealing with missing categories - -For every category (digits, upper case or lower case letters) that we don't find, we can choose to *insert* a new character or to *replace* an existing one. - -We will see later that both operations have their use, in different cases. - -We can use some extra test cases for this:
- `abcABC` => 1 (e.g. *insert* `1` to get `abcABC1`, or *replace* `b` by `1` to get `a1cABC`)
- `abcdef` => 2 (e.g. *insert* `1` and `A` to get `abcdef1A`, or *replace* `b` by `1` and `c` by `A` to get `a1Adef`)
- -#### Dealing with repeating characters (like 'aaaaa') - -The third criteria says that the password '*shouldn't contain 3 repeating characters in a row*'.
-If we find a sequence that is longer, there are three ways to modify it to comply with the rule: - -* *Insert* a different character into the sequence after every second character.
- This will split the sequence into chunks of two, separated by the new characters:
- `aaaaaa => aaiaaiaa` (2 *insert*s for a sequence of 6)
- `aaaaaaaaa => aaiaaiaaiaaia` (**4 *inserts*** for a sequence of 9)
-* *Replace* every third character by a different one.
- This also splits it into chunks of 2, but it is more efficient. - Each replaced character 'consumes' one character of the sequence and thus reduces the amount of work still left to do:
- `aaaaaa => aaraar` (2 replacements for a sequence of 6)
- `aaaaaaaaa => aaraaraar` (**3 *replacements*** for a sequence of 9)
+> Input: \$str = "1001"
+> Output: "999"
-* *Delete* all characters in excess of the first 2.
- Deleting characters is a dangerous thing, and it is inefficient:
- Dangerous, because it also reduces the overall length of the password, - and in the end we might be violating the 'at least 6 characters' criteria.
- Inefficient, because each *deletion* only takes care of exactly one excess character, - whereas at the same time, *replacing* one character at the right spot 'neutralizes' three of them:
- `aaaaaa => aa` (4 *deletions* for a sequence of 6)
- `aaaaaaaaa => aa` (**7 *deletions*** for a sequence of 9)
- So we better do not consider 'delete' operations at all. +#### The Simple -Some more examples: +I first thought about *generating* the closest palindrome, +but seeing the rich variety of cases in the examples, +I found it too complicated at first. +That's why I did a quick and simple 'brute force' approach. -| sequence length | example sequence | *insert* result | *replace* result | *insert* operations needed | *replace* operations needed | -| :-------------: | :--------------- | :------------------ | :--------------- | :------------------------: | :-------------------------: | -| 6 | `aaaaaa` | `aabaabaa` | `aabaab` | 2 | 2 | -| 7 | `aaaaaaa` | `aabaabaaba` | `aabaaba` | 3 | **2** | -| 9 | `aaaaaaaaa` | `aabaabaabaaba` | `aabaabaab` | 4 | **3** | -| 12 | `aaaaaaaaaaaa` | `aabaabaabaabaabaa` | `aaXaaXaaXaaX` | 5 | **4** | +This was really easy to write (and easy to read, I hope!).
+Testing a number for being a palindrome in Perl is as simple as it can get:
+ `reverse( $s ) eq $s`.
-These examples show that for dealing with longer sequences, *replacing* characters is more efficient than *inserting* characters.
-This leads us to some more test cases:
- `aaa1B` => 1 (e.g. *inserting* one `b` to get `aaba1B`)
`aaaa1B` => 1 (e.g. *replacing* one `a` by `b` to get `aaba1B`)
`aaaaa1B` => 1 (e.g. *replacing* one `a` by `b` to get `aabaa1B`)
`aaaaaa1B` => 2 (e.g. *replacing* 2 times `a` by `b` to get `aabaab1B`)
`aaaaaaa1B` => 2 (e.g. *replacing* 2 times `a` by `b` to get `aabaaba1B`)
`aaaaaaaa1B` => 2 (e.g. *replacing* 2 times `a` by `b` to get `aabaabaa1B`)
- `aaaaaaaaaaaa1B` => 4 (e.g. *replacing* 4 times `a` by `b` to get `aabaabaabaab1B`) - -#### Up to three birds with one shot! - -It turns out that if we are lucky, by *inserting* one character we can solve three problems at the same time: - -* make the password longer, -* add a missing category by choosing the character to be from that category, -* shorten a long repeated-character sequence by inserting the character to split off two characters of the sequence. - -In this example, one operation solves all three shortcomings, which makes it another good test case:
-`aaaBc` => 1 (e.g. by *inserting * one digit at the right place, like `aa1aBc`).
- -#### And another two birds with another shot... - -Similarly, we also can solve *two* problems at the same time by *replacing* one character: - -* add a missing category by choosing the character to be from that category, -* shorten a long repeating character sequence by choosing a 'third' character to be replaced, which will 'neutralize' the two characters preceding it. - -For example (and yet another test case):
- `aaaabC` => `aa1abC` => 1 change only for solving two shortcomings. - - -#### Solution structure - -For our solution this means that we can proceed as follows: - -1. We determine how many *inserts* are needed - for reaching the **minimum password length**.
- Every *insert* is counted as a cost for our final result - (the number of operations needed).
- In addition, we keep a separate counter for the inserted characters, - which we will decrement when we use them 'for more birds' - (to add categories or to split up long sequences). - -2. For each **missing category**, - we first use one of the characters inserted in step 1 - for adding that category.
- This causes *no additional cost*, - as long as we have any of those characters left. - -3. If we *still* are missing categories, - we *replace* existing characters of another category - by a character of the respective missing category.
- Every character to be replaced is counted as a cost.
- We don't care to choose *which* characters to be replaced here, - because we might choose good positions later, - when we try to split long repeating sequences.
- For this, we also keep another counter for the replaced characters.
- The reason why we prefer replacing to inserting here is that later on, - *replaced* characters might serve better than *inserted* ones. - -4. For every **long repeating character sequence** that we find, - we do this: - - Position any *replacement* characters from the previous step - on every third character of the sequence, - each one 'neutralizing' *three* characters of the repetition, - until we have used all the *replacement* characters, or the sequence is fully neutralized.
- There's *no additional cost* for this. - - If there are no *replaced* characters available any more, - position any *inserted* characters from step 1 - after every second character of the sequence, - neutralizing two characters of the sequence.
- Even if using the *inserted* characters is less efficient than using replacements, these here come for free, because we've paid for them already. Now they can be used with *no additional cost*. - - For the rest of the sequence, - we *replace* every third characters within the sequence to split it up further.
- These replacements count for the cost, though. - -5. We return the cost that we have determined. - -Here are some more 'combination' test cases:
- - `aaaacccc` => 2 (like `aa1accBc) - (replacing one `a` by a digit,
- and one `c` by an upper case character.
- and two `b`s by anything else but a `b`).
- `aaaaaabbbbbb` => 4 (like `aa1aaXbbYbbY`),
- (replacing one `a` by a digit,
- another `a` by an upper case character,
- and two `b`s by anything else but a `b`).
- `aaacc` => 2 (e.g. `aa1ccX`).
- -And this is my solution: +So let's try every possible distance, from close to further away. +Trying a distance value first below our number and then above +already gives us the right priority. +If the number at that distance is a palindrone: Done! ```perl -use v5.36; - -use List::Util qw( sum min ); - -use constant MIN_PASSWORD_LENGTH => 6; - -sub strong_password( $str ) { - # Make pattern matches easier to write. - $_ = $str; - - my ( $cost, $available_inserted, $available_replaced ) = ( 0, 0, 0 ); - - # 1: Do *inserts* for bringing the password up to length. - if ( length() < MIN_PASSWORD_LENGTH ) { - $available_inserted = MIN_PASSWORD_LENGTH - length(); - $cost += $available_inserted; +sub closest_palindrome() { + for ( my $distance = 1; ; ++$distance ) { + for my $try ( $str - $distance, $str + $distance ) { + return $try + if reverse( $try ) eq $try; + } } +} +``` - # 2: Use the inserted characters to add missing categories - # (*no additional cost!*), - my $n_missing_categories = sum( ! /\d/, ! /[a-z]/, ! /[A-Z]/ ); - if ( $n_missing_categories && $available_inserted ) { - my $n_to_use = min( $n_missing_categories, $available_inserted ); - $n_missing_categories -= $n_to_use; - } +This works like a breeze!
+Except that for large values, looping over all possible numbers may take a while. + +So that 'constructing' idea didn't get out of my head, +because it would be so much faster!
+And I found a solution, too! + +#### The Fast + +Let's consider input numbers with an even number of digits first. +Like `345678`.
+Splitting it into a left half and a right half, the general form is
+ $` L_{1} \cdots L_{n} R_{1} \cdots R_{n} `$.
+Looking for a palindrome that is close, +any changes we do to the original number should preferably be in the 'lower' digits +(those further to the right). +So for a good guess, let's keep the left part as it is, +and mirror it to the right to get a palindrome:
+ $` L_{1} \cdots L_{n} L_{n} \cdots L_{1} `$.
+This gives us `345543`. + +We see that actually the only degrees of freedom we have are in the left part, +because for any palindrome, the right part is fully determined by the left part. + +The left part kind of identifies a 'block' of numbers of $n$ digits on the right side, +ranging from $` 0 0 \cdots 0 `$ to $` 9 9 \cdots 9 `$. +There is exactly one palindrome in each block +(where the right side is equal to the left side reversed). +It's obvious that the palindromes 'closest' to our input number +can only be in the same block, one block above or one block below. + +As each 'block' contains exactly one palindrome, +we only need to generate the three palindromes of those three blocks, +and then choose the closest. + +To illustrate this, for our example of `345678` with its left part of `345`, +one of these three palindromes will be the closest: + +* The left part, *in*creased by one, then concatenated with the reversed result of that:
+ $L_{1} \cdots ( L_{n} + 1) ( L_{n} + 1 ) \dots L_{1}$: `346-643` + +* The left part itself, concatenated with its reversed:
+ $L_{1} \cdots L_{n} L_{n} \dots L_{1}$: `345-543` (this is the closest!) + +* The left part, *de*creased by one, then concatenated with itself reversed:
+ $L_{1} \cdots ( L_{n} - 1) ( L_{n} - 1 ) \dots L_{1}$: `344-443` + +We have a special case when the left part consists of `9`s only, +as for example for `999234` with its left part of `999`. +This becomes `1000` when increased, which is one digit longer. +We must make sure to mirror one digit less in this case, +or we can simply 'construct' the whole palindrome in this case, +using `( '1' . ( '0' x ( $n - 1 ) ) . '1' )`. +That's `1000001` (from `1000-001`) in this example. + +The second special case is when the left part is a power of ten, +as for `100234` with its left part of `100`. +The decreased left part will consist of `9`s only, +having one digit less than the original left part. +We generate that palindrome as `( '9' x ( $n - 1 ) )`, +resulting in `99999` (from `99-999`) in this example. + +From the three numbers generated, +we choose the one that is closest to our input number, +making sure that the chosen number is not the input number itself. +We also need to prefer a lower number if the distance is the same. + +For input numbers with odd lengths, it's actually the same, only that the +'left part' must include the 'middle' digit, and for the 'right' part of +the palindrome, we only use as many digits as needed, *not* including +that middle digit. +The two special cases work the same, we 'construct' the palindromes just like before. + +We need to deal with one other special case: negative numbers as input. +They are not excluded in the task description +('which is an integer' -- might be a negative integer, too!). +As `0` is a palindrome (well...ahem...), +it is the also the closest palindrome to any negative integer.
+Voilà. - # 3: If there still are categories missing, - # we *replace* existing characters. - if ( $n_missing_categories ) { - $available_replaced = $n_missing_categories; - $cost += $available_replaced; - } +```perl +use v5.36; - # 4: Deal with long repeating sequences (3 or more same characters). - while ( /(.)\1\1\1*/g ) { - my $sequence_length = length( $& ); - while ( $sequence_length > 2 && $available_replaced ) { - $sequence_length -= 3; - --$available_replaced; - } - while ( $sequence_length > 2 && $available_inserted ) { - $sequence_length -= 2; - --$available_inserted; - } - while ( $sequence_length > 2 ) { - $sequence_length -= 3; - ++$cost; +sub closest_palindrome( $str ) { + return undef unless $str =~ /^-?[0-9]+$/; + + # Edge case: negative numbers. + return "0" if $str < 0; + + my $left_part = substr( $str, 0, int( ( length( $str ) + 1 ) / 2 ) ); + my ( $closest, $closest_distance ) = ( undef, undef ); + for my $try ( $left_part - 1, $left_part, $left_part + 1 ) { + next unless $try >= 0; # Edge case on input '0'. + my $palindrome = + length $try < length $left_part + ? '9' x ( length( $str ) - 1 ) : + length $try > length $left_part + ? ( '1' . ( '0' x ( length( $str ) - 1 ) ) . '1' ) + : ( $try + . substr( reverse( $try ), length( $str ) % 2 ) ); + my $distance = abs( $palindrome - $str ); + if ( $palindrome != $str + && ( ! defined $closest_distance + || $distance < $closest_distance ) ) + { + $closest = $palindrome; + $closest_distance = abs( $palindrome - $str ); } } - return $cost; + return $closest; } ``` -The `ch-1.pl` file also contains switchable debugging output, and all the test cases. This is its output: - -```terminal -ok 1 - Example 1: strong_password( 'a' ) == 5 -ok 2 - Example 2: strong_password( 'aB2' ) == 3 -ok 3 - Example 3: strong_password( 'PaaSW0rd' ) == 0 -ok 4 - Example 4: strong_password( 'Paaasw0rd' ) == 1 -ok 5 - Example 5: strong_password( 'aaaaa' ) == 2 (like 'aa1aaB') -ok 6 - Extra 1: strong_password( '' ) == 6 (like '1aBcde') -ok 7 - Extra 2: strong_password( 'abcABC' ) == 1 (like 'a1cABC') -ok 8 - Extra 3: strong_password( 'abcdef' ) == 2 (like 'a1Adef') -ok 9 - Extra 4: strong_password( 'aaa1B' ) == 1 (like 'aaba1B' using one insert) -ok 10 - Extra 5: strong_password( 'aaaa1B' ) == 1 (like 'aaba1B' using one replace) -ok 11 - Extra 6: strong_password( 'aaaaa1B' ) == 1 (like 'aabaa1B') -ok 12 - Extra 7: strong_password( 'aaaaaa1B' ) == 2 (like 'aabaab1B') -ok 13 - Extra 8: strong_password( 'aaaaaaa1B' ) == 2 (like 'aabaaba1B') -ok 14 - Extra 9: strong_password( 'aaaaaaaa1B' ) == 2 (like 'aabaabaa1B') -ok 15 - Extra 10: strong_password( 'aaaaaaaaaaaa1B' ) == 4 (like 'aabaabaabaab1B') -ok 16 - Extra 11: strong_password( 'aaabC' ) == 1 (like 'aa1abC' using one insert) -ok 17 - Extra 12: strong_password( 'aaaabC' ) == 1 (like 'aa1abC') -ok 18 - Extra 13: strong_password( 'aaaacccc' ) == 2 (like 'aa1accBc') -ok 19 - Extra 14: strong_password( 'aaaaaabbbbbb' ) == 4 (like 'aa1aaXbbYbbY') -ok 20 - Extra 15: strong_password( 'aaacc' ) == 2 (like 'aa1ccX') -1..20 -``` +This is the more direct path to the closest palindrome.
+Palindrome algorithms for every need! :-) -It has never been easier to create good passwords! :wink::joy: +## Task 2: Contiguous Block - -## Task 2: Valid Number - -> You are given a string, $str.
-> Write a script to find if it is a valid number.
-> Conditions for a valid number:
-> -> - An integer number followed by an optional exponent.
-> - A decimal number followed by an optional exponent.
-> - An integer number is defined with an optional sign '-' or '+' followed by digits.
->
-> Decimal Number:
-> A decimal number is defined with an optional sign '-' or '+' followed by one of the following definitions:
-> - Digits followed by a dot '.'.
-> - Digits followed by a dot '.' followed by digits.
-> - A dot '.' followed by digits.
->
-> Exponent:
-> An exponent is defined with an exponent notation 'e' or 'E' followed by an integer number.
->
+> You are given a rectangular matrix where all the cells contain either x or o.
+> Write a script to determine the size of the largest contiguous block.
+> A contiguous block consists of elements containing the same symbol which share an edge (not just a corner) with other elements in the block, and where there is a path between any two of these elements that crosses only those shared edges.
>
> Example 1
-> Input: $str = "1"
-> Output: true
+> Input: \$matrix = [
+> ['x', 'x', 'x', 'x', 'o'],
+> ['x', 'o', 'o', 'o', 'o'],
+> ['x', 'o', 'o', 'o', 'o'],
+> ['x', 'x', 'x', 'o', 'o'],
+> ]
+> Ouput: 11
+> There is a block of 9 contiguous cells containing 'x'.
+> There is a block of 11 contiguous cells containing 'o'.
>
> Example 2
-> Input: $str = "a"
-> Output: false
+> Input: \$matrix = [
+> ['x', 'x', 'x', 'x', 'x'],
+> ['x', 'o', 'o', 'o', 'o'],
+> ['x', 'x', 'x', 'x', 'o'],
+> ['x', 'o', 'o', 'o', 'o'],
+> ]
+> Ouput: 11
+> There is a block of 11 contiguous cells containing 'x'.
+> There is a block of 9 contiguous cells containing 'o'.
>
> Example 3
-> Input: $str = "."
-> Output: false
->
-> Example 4
-> Input: $str = "1.2e4.2"
-> Output: false
->
-> Example 5
-> Input: $str = "-1."
-> Output: true
->
-> Example 6
-> Input: $str = "+1E-8"
-> Output: true
->
-> Example 7
-> Input: $str = ".44"
-> Output: true
+> Input: \$matrix = [
+> ['x', 'x', 'x', 'o', 'o'],
+> ['o', 'o', 'o', 'x', 'x'],
+> ['o', 'x', 'x', 'o', 'o'],
+> ['o', 'o', 'o', 'x', 'x'],
+> ]
+> Ouput: 7
+> There is a block of 7 contiguous cells containing 'o'.
+> There are two other 2-cell blocks of 'o'.
+> There are three 2-cell blocks of 'x' and one 3-cell.
-Probably the easiest way to solve this is to use the `Regexp::Common` CPAN module: +#### Easy and recursive -```perl -use v5.36; +I am using a recursive flood fill algorithm to traverse contiguous areas.
+Maybe that sounds more complicates than it actually is. -use Regexp::Common; +The main function holds a matrix `@visited`, where we mark all cells that we have identified to be part of an area. The main subroutine finds the next un-visited cell and calls the recursive `flood_and_mark` function, with the input matrix, the row and column coordinates of the cell, and a reference to the `@visited` matrix as parameters. +Of all returned values, the maximum is kept, and returned in the end. -sub valid_number( $str ) { - return $str =~ /^$RE{num}{real}$/; -} -``` -This works well for all examples. +The `flood_and_mark` function is built to return the number of cells that could be 'flood-filled'. At least one for the cell itself, but also added the results of flood-filling all neighbor cells that have the same symbol (`'x'` or `'o'`) and that are not marked visited yet. The most complicated thing here is to find the coordinates of the neighbor cells, without accessing coordinates outside of the matrix. + +The number of recursions is the number of cells in the largest contiguous area *at most*. +So for the examples and also for some bigger matrices this should not be a constraint. + +I'm using a multiple values `for` loop for iterating of the `( $r, $c )` coordinate pairs of the neighbor cells. +Together with those coordinate pairs being stored 'flat' in the `@neighbors` array this makes things easy.
(The `for_loop` feature, stable and part of the implicit feature bundle since Perl 5.36). -If you don't want to use a module, this regular expression might be used instead: ```perl use v5.36; -sub valid_number( $str ) { - return - $str =~ /^ [+-]? (?: \.\d+ | \d+(?:\.\d*)? ) (?: [Ee] [+-]? \d+ )? $/xa; +use List::Util qw( max ); + +sub flood_and_mark( $matrix, $r, $c, $visited ) { + $visited->[$r][$c] = 1; + my @neighbors = ( + $r > 0 ? ( $r - 1, $c ) : (), + $c > 0 ? ( $r, $c - 1 ) : (), + $c < $matrix->[$r]->$#* ? ( $r, $c + 1 ) : (), + $r < $matrix->$#* ? ( $r + 1, $c ) : (), + ); + my $symbol = $matrix->[$r][$c]; + my $count = 1; # For this field itself. + for my ( $next_r, $next_c ) ( @neighbors ) { + next + if $matrix->[$next_r][$next_c] ne $symbol + || $visited->[$next_r][$next_c]; + $count += flood_and_mark( $matrix, $next_r, $next_c, $visited ); + } + return $count; } -``` -Nothing really special about it, except maybe the `a` modifier, which is used to make sure that no other Unicode characters with a 'digit' property match `\d`. Basically this makes `\d` equivalent to `[0-9]`, which is the safer most of the time. +sub contiguous_block( $matrix ) { + my @visited; + my $max = 0; + for my $r ( 0..$matrix->$#* ) { + for my $c ( 0..$matrix->[$r]->$#* ) { + if ( ! $visited[$r][$c] ) { + my $area = flood_and_mark( $matrix, $r, $c, \@visited ); + $max = $area + if $area > $max; + } + } + } + return $max; +} +``` #### **Thank you for the challenge!** diff --git a/challenge-288/matthias-muth/blog.txt b/challenge-288/matthias-muth/blog.txt new file mode 100644 index 0000000000..42b74357fd --- /dev/null +++ b/challenge-288/matthias-muth/blog.txt @@ -0,0 +1 @@ +https://github.com/MatthiasMuth/perlweeklychallenge-club/tree/muthm-288/challenge-288/matthias-muth#readme diff --git a/challenge-288/matthias-muth/perl/ch-1.pl b/challenge-288/matthias-muth/perl/ch-1.pl new file mode 100755 index 0000000000..394bf7eeba --- /dev/null +++ b/challenge-288/matthias-muth/perl/ch-1.pl @@ -0,0 +1,120 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# Challenge 288 Task 1: Closest Palindrome +# +# Perl solution by Matthias Muth. +# + +use v5.36; + +our $verbose = 0; +sub vsay( @args ) { say @args if $verbose }; + +sub closest_palindrome_1( $str ) { + # Searching in two directions: down and up, until we find a number + # that is a palindrome. + for ( my $distance = 1; ; ++$distance ) { + for my $try ( $str - $distance, $str + $distance ) { + return $try + if reverse( $try ) eq $try; + } + } + # We should never get here, + # we should have found a single digit 'palindrome' at least! + warn "INTERNAL ERROR: There's something wrong with this algorithm!\n"; + return undef; +} + +sub closest_palindrome( $str ) { + return undef unless $str =~ /^-?[0-9]+$/; + + # Edge case: negative numbers. + return "0" if $str < 0; + + my $left_part = substr( $str, 0, int( ( length( $str ) + 1 ) / 2 ) ); + my ( $closest, $closest_distance ) = ( undef, undef ); + for my $try ( $left_part - 1, $left_part, $left_part + 1 ) { + next unless $try >= 0; # Edge case on input '0'. + my $palindrome = + length $try < length $left_part + ? '9' x ( length( $str ) - 1 ) : + length $try > length $left_part + ? ( '1' . ( '0' x ( length( $str ) - 1 ) ) . '1' ) + : ( $try + . substr( reverse( $try ), length( $str ) % 2 ) ); + my $distance = abs( $palindrome - $str ); + if ( $palindrome != $str + && ( ! defined $closest_distance + || $distance < $closest_distance ) ) + { + $closest = $palindrome; + $closest_distance = abs( $palindrome - $str ); + } + } + return $closest; +} + +use Test2::V0 qw( -no_srand ); +use Data::Dump qw( pp ); + +my $sub_name = "closest_palindrome"; +my @tests = ( + [ 'Example 1:', 123, 121 ], + [ 'Example 2:', 2, 1 ], + [ 'Example 3:', 1400, 1441 ], + [ 'Example 4:', 1001, 999 ], + [ 'Extra 1:', 1, 0 ], + [ 'Extra 1:', 0, 1 ], + [ 'Extra 2:', -5, 0 ], + [ 'Extra 3:', 9999, 10001 ], + [ 'Extra 4:', 10001, 9999 ], + [ 'Extra 5:', 99999, 100001 ], + [ 'Extra 6:', 100001, 99999 ], + [ 'Extra 7:', 345678, 345543 ], +); + +# This runs the tests not only for the sub named "$sub_name", +# but also for all variants with any suffix ("$subname"). +for my $sub ( sort grep /^${sub_name}/, keys %:: ) { + note "\n", "Testing $sub:\n", "\n"; + for ( @tests ) { + my ( $descr, $input, $output ) = $_->@*; + $descr .= " " . pp( $input ) . " => $output" + if substr( $descr, -1, 1 ) eq ":"; + no strict 'refs'; + is $sub->( $input ), $output, $descr; + } +} +done_testing; + +__END__ + +use Test2::V0 qw( -no_srand ); +is closest_palindrome( 123 ), 121, + 'Example 1: closest_palindrome( 123 ) == 121'; +is closest_palindrome( 2 ), 1, + 'Example 2: closest_palindrome( 2 ) == 1'; +is closest_palindrome( 1400 ), 1441, + 'Example 3: closest_palindrome( 1400 ) == 1441'; +is closest_palindrome( 1001 ), 999, + 'Example 4: closest_palindrome( 1001 ) == 999'; +is closest_palindrome( 1 ), 0, + 'Extra 1: closest_palindrome( 1 ) == 0'; +is closest_palindrome( 0 ), 1, + 'Extra 1: closest_palindrome( 0 ) == 1'; +is closest_palindrome( -5 ), 0, + 'Extra 2: closest_palindrome( -5 ) == 0'; +is closest_palindrome( 9999 ), 10001, + 'Extra 3: closest_palindrome( 9999 ) == 10001'; +is closest_palindrome( 10001 ), 9999, + 'Extra 4: closest_palindrome( 10001 ) == 9999'; +is closest_palindrome( 99999 ), 100001, + 'Extra 5: closest_palindrome( 99999 ) == 100001'; +is closest_palindrome( 100001 ), 99999, + 'Extra 6: closest_palindrome( 100001 ) == 99999'; +is closest_palindrome( 345678 ), 345543, + 'Extra 7: closest_palindrome( 345678 ) == 345543'; +done_testing; diff --git a/challenge-288/matthias-muth/perl/ch-2.pl b/challenge-288/matthias-muth/perl/ch-2.pl new file mode 100755 index 0000000000..f5b6252e48 --- /dev/null +++ b/challenge-288/matthias-muth/perl/ch-2.pl @@ -0,0 +1,150 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# Challenge 288 Task 2: Contiguous Block +# +# Perl solution by Matthias Muth. +# + +use v5.36; + +use List::Util qw( max ); + +sub flood_and_mark( $matrix, $r, $c, $visited ) { + $visited->[$r][$c] = 1; + my @neighbors = ( + $r > 0 ? ( $r - 1, $c ) : (), + $c > 0 ? ( $r, $c - 1 ) : (), + $c < $matrix->[$r]->$#* ? ( $r, $c + 1 ) : (), + $r < $matrix->$#* ? ( $r + 1, $c ) : (), + ); + my $symbol = $matrix->[$r][$c]; + my $count = 1; # For this field itself. + for my ( $next_r, $next_c ) ( @neighbors ) { + next + if $matrix->[$next_r][$next_c] ne $symbol + || $visited->[$next_r][$next_c]; + $count += flood_and_mark( $matrix, $next_r, $next_c, $visited ); + } + return $count; +} + +sub contiguous_block( $matrix ) { + my @visited; + my $max = 0; + for my $r ( 0..$matrix->$#* ) { + for my $c ( 0..$matrix->[$r]->$#* ) { + if ( ! $visited[$r][$c] ) { + my $area = flood_and_mark( $matrix, $r, $c, \@visited ); + $max = $area + if $area > $max; + } + } + } + return $max; +} + +use Test2::V0 qw( -no_srand ); +use Data::Dump qw( pp ); + +my $sub_name = "contiguous_block"; +my @tests = ( + [ 'Example 1:', [ + ["x", "x", "x", "x", "o"], + ["x", "o", "o", "o", "o"], + ["x", "o", "o", "o", "o"], + ["x", "x", "x", "o", "o"], + ], 11 ], + [ 'Example 2:', [ + ["x", "x", "x", "x", "x"], + ["x", "o", "o", "o", "o"], + ["x", "x", "x", "x", "o"], + ["x", "o", "o", "o", "o"], + ], 11 ], + [ 'Example 3:', [ + ["x", "x", "x", "o", "o"], + ["o", "o", "o", "x", "x"], + ["o", "x", "x", "o", "o"], + ["o", "o", "o", "x", "x"], + ], 7 ], + [ 'Extra 1:', [ + ["x", "o", "x", "o", "x"], + ["o", "x", "o", "x", "o"], + ["x", "o", "x", "o", "x"], + ["o", "x", "o", "x", "o"], + ], 1 ], + [ 'Extra 2: empty matrix => 0', [], 0 ], +); + +# This runs the tests not only for the sub named "$sub_name", +# but also for all variants with any suffix ("$subname"). +for my $sub ( sort grep /^${sub_name}/, keys %:: ) { + note "\n", "Testing $sub:\n", "\n"; + for ( @tests ) { + my ( $descr, $input, $output ) = $_->@*; + $descr .= " " . pp( $input ) . " => $output" + if substr( $descr, -1, 1 ) eq ":"; + no strict 'refs'; + is $sub->( $input ), $output, $descr; + } +} +done_testing; + +__END__ + +is contiguous_block( [ + ["x", "x", "x", "x", "o"], + ["x", "o", "o", "o", "o"], + ["x", "o", "o", "o", "o"], + ["x", "x", "x", "o", "o"], +] ), 11, + 'Example 1: contiguous_block( [ + ["x", "x", "x", "x", "o"], + ["x", "o", "o", "o", "o"], + ["x", "o", "o", "o", "o"], + ["x", "x", "x", "o", "o"], +] ) == 11'; +is contiguous_block( [ + ["x", "x", "x", "x", "x"], + ["x", "o", "o", "o", "o"], + ["x", "x", "x", "x", "o"], + ["x", "o", "o", "o", "o"], +] ), 11, + 'Example 2: contiguous_block( [ + ["x", "x", "x", "x", "x"], + ["x", "o", "o", "o", "o"], + ["x", "x", "x", "x", "o"], + ["x", "o", "o", "o", "o"], +] ) == 11'; +is contiguous_block( [ + ["x", "x", "x", "o", "o"], + ["o", "o", "o", "x", "x"], + ["o", "x", "x", "o", "o"], + ["o", "o", "o", "x", "x"], +] ), 7, + 'Example 3: contiguous_block( [ + ["x", "x", "x", "o", "o"], + ["o", "o", "o", "x", "x"], + ["o", "x", "x", "o", "o"], + ["o", "o", "o", "x", "x"], +] ) == 7'; + +is contiguous_block( [ + ["x", "o", "x", "o", "x"], + ["o", "x", "o", "x", "o"], + ["x", "o", "x", "o", "x"], + ["o", "x", "o", "x", "o"], +] ), 1, + 'Extra 1: contiguous_block( [ + ["x", "o", "x", "o", "x"], + ["o", "x", "o", "x", "o"], + ["x", "o", "x", "o", "x"], + ["o", "x", "o", "x", "o"], +] ) == 1'; + +is contiguous_block( [] ), 0, + 'Extra 2: contiguous_block( [] ) == 0'; + +done_testing; diff --git a/challenge-288/matthias-muth/perl/ch-2b.pl b/challenge-288/matthias-muth/perl/ch-2b.pl new file mode 100755 index 0000000000..b44e8cf412 --- /dev/null +++ b/challenge-288/matthias-muth/perl/ch-2b.pl @@ -0,0 +1,106 @@ +#!/usr/bin/env perl +# +# The Weekly Challenge - Perl & Raku +# (https://theweeklychallenge.org) +# +# Challenge 288 Task 2: Contiguous Block +# +# Perl solution by Matthias Muth. +# + +use v5.36; + +use List::Util qw( max ); +use Algorithm::Loops qw( NestedLoops ); + +sub flood_and_mark( $matrix, $r, $c, $visited ) { + $visited->[$r][$c] = 1; + my @neighbors = ( + $r > 0 ? ( $r - 1, $c ) : (), + $c > 0 ? ( $r, $c - 1 ) : (), + $c < $matrix->[$r]->$#* ? ( $r, $c + 1 ) : (), + $r < $matrix->$#* ? ( $r + 1, $c ) : (), + ); + my $symbol = $matrix->[$r][$c]; + my $count = 1; # For this field itself. + for my ( $next_r, $next_c ) ( @neighbors ) { + next + if $matrix->[$next_r][$next_c] ne $symbol + || $visited->[$next_r][$next_c]; + $count += flood_and_mark( $matrix, $next_r, $next_c, $visited ); + } + return $count; +} + +sub contiguous_block( $matrix ) { + my @visited; + my $max = 0; + + my @rows = ( 0..$matrix->$#* ); # row indices + my @columns = ( 0..$matrix->[0]->$#* ); # column indices + my $iterator = NestedLoops( [ \@rows, \@columns ] ); + while ( my ( $r, $c ) = $iterator->() ) { + if ( ! $visited[$r][$c] ) { + my $area = flood_and_mark( $matrix, $r, $c, \@visited ); + $max = $area + if $area > $max; + } + } + return $max; +} + +use Test2::V0 qw( -no_srand ); +is contiguous_block( [ + ["x", "x", "x", "x", "o"], + ["x", "o", "o", "o", "o"], + ["x", "o", "o", "o", "o"], + ["x", "x", "x", "o", "o"], +] ), 11, + 'Example 1: contiguous_block( [ + ["x", "x", "x", "x", "o"], + ["x", "o", "o", "o", "o"], + ["x", "o", "o", "o", "o"], + ["x", "x", "x", "o", "o"], +] ) == 11'; +is contiguous_block( [ + ["x", "x", "x", "x", "x"], + ["x", "o", "o", "o", "o"], + ["x", "x", "x", "x", "o"], + ["x", "o", "o", "o", "o"], +] ), 11, + 'Example 2: contiguous_block( [ + ["x", "x", "x", "x", "x"], + ["x", "o", "o", "o", "o"], + ["x", "x", "x", "x", "o"], + ["x", "o", "o", "o", "o"], +] ) == 11'; +is contiguous_block( [ + ["x", "x", "x", "o", "o"], + ["o", "o", "o", "x", "x"], + ["o", "x", "x", "o", "o"], + ["o", "o", "o", "x", "x"], +] ), 7, + 'Example 3: contiguous_block( [ + ["x", "x", "x", "o", "o"], + ["o", "o", "o", "x", "x"], + ["o", "x", "x", "o", "o"], + ["o", "o", "o", "x", "x"], +] ) == 7'; + +is contiguous_block( [ + ["x", "o", "x", "o", "x"], + ["o", "x", "o", "x", "o"], + ["x", "o", "x", "o", "x"], + ["o", "x", "o", "x", "o"], +] ), 1, + 'Extra 1: contiguous_block( [ + ["x", "o", "x", "o", "x"], + ["o", "x", "o", "x", "o"], + ["x", "o", "x", "o", "x"], + ["o", "x", "o", "x", "o"], +] ) == 1'; + +is contiguous_block( [] ), 0, + 'Extra 2: contiguous_block( [] ) == 0'; + +done_testing; -- cgit From 0f32114efbdb5375b08606058280e73ed248029d Mon Sep 17 00:00:00 2001 From: Matthias Muth Date: Sat, 28 Sep 2024 22:36:35 +0200 Subject: Challenge 288 Task 1 and 2 solutions in Perl by Matthias Muth - Cosmetics --- challenge-288/matthias-muth/perl/ch-1.pl | 3 - challenge-288/matthias-muth/perl/ch-2b.pl | 106 ------------------------------ 2 files changed, 109 deletions(-) delete mode 100755 challenge-288/matthias-muth/perl/ch-2b.pl diff --git a/challenge-288/matthias-muth/perl/ch-1.pl b/challenge-288/matthias-muth/perl/ch-1.pl index 394bf7eeba..1036cfe9d1 100755 --- a/challenge-288/matthias-muth/perl/ch-1.pl +++ b/challenge-288/matthias-muth/perl/ch-1.pl @@ -10,9 +10,6 @@ use v5.36; -our $verbose = 0; -sub vsay( @args ) { say @args if $verbose }; - sub closest_palindrome_1( $str ) { # Searching in two directions: down and up, until we find a number # that is a palindrome. diff --git a/challenge-288/matthias-muth/perl/ch-2b.pl b/challenge-288/matthias-muth/perl/ch-2b.pl deleted file mode 100755 index b44e8cf412..0000000000 --- a/challenge-288/matthias-muth/perl/ch-2b.pl +++ /dev/null @@ -1,106 +0,0 @@ -#!/usr/bin/env perl -# -# The Weekly Challenge - Perl & Raku -# (https://theweeklychallenge.org) -# -# Challenge 288 Task 2: Contiguous Block -# -# Perl solution by Matthias Muth. -# - -use v5.36; - -use List::Util qw( max ); -use Algorithm::Loops qw( NestedLoops ); - -sub flood_and_mark( $matrix, $r, $c, $visited ) { - $visited->[$r][$c] = 1; - my @neighbors = ( - $r > 0 ? ( $r - 1, $c ) : (), - $c > 0 ? ( $r, $c - 1 ) : (), - $c < $matrix->[$r]->$#* ? ( $r, $c + 1 ) : (), - $r < $matrix->$#* ? ( $r + 1, $c ) : (), - ); - my $symbol = $matrix->[$r][$c]; - my $count = 1; # For this field itself. - for my ( $next_r, $next_c ) ( @neighbors ) { - next - if $matrix->[$next_r][$next_c] ne $symbol - || $visited->[$next_r][$next_c]; - $count += flood_and_mark( $matrix, $next_r, $next_c, $visited ); - } - return $count; -} - -sub contiguous_block( $matrix ) { - my @visited; - my $max = 0; - - my @rows = ( 0..$matrix->$#* ); # row indices - my @columns = ( 0..$matrix->[0]->$#* ); # column indices - my $iterator = NestedLoops( [ \@rows, \@columns ] ); - while ( my ( $r, $c ) = $iterator->() ) { - if ( ! $visited[$r][$c] ) { - my $area = flood_and_mark( $matrix, $r, $c, \@visited ); - $max = $area - if $area > $max; - } - } - return $max; -} - -use Test2::V0 qw( -no_srand ); -is contiguous_block( [ - ["x", "x", "x", "x", "o"], - ["x", "o", "o", "o", "o"], - ["x", "o", "o", "o", "o"], - ["x", "x", "x", "o", "o"], -] ), 11, - 'Example 1: contiguous_block( [ - ["x", "x", "x", "x", "o"], - ["x", "o", "o", "o", "o"], - ["x", "o", "o", "o", "o"], - ["x", "x", "x", "o", "o"], -] ) == 11'; -is contiguous_block( [ - ["x", "x", "x", "x", "x"], - ["x", "o", "o", "o", "o"], - ["x", "x", "x", "x", "o"], - ["x", "o", "o", "o", "o"], -] ), 11, - 'Example 2: contiguous_block( [ - ["x", "x", "x", "x", "x"], - ["x", "o", "o", "o", "o"], - ["x", "x", "x", "x", "o"], - ["x", "o", "o", "o", "o"], -] ) == 11'; -is contiguous_block( [ - ["x", "x", "x", "o", "o"], - ["o", "o", "o", "x", "x"], - ["o", "x", "x", "o", "o"], - ["o", "o", "o", "x", "x"], -] ), 7, - 'Example 3: contiguous_block( [ - ["x", "x", "x", "o", "o"], - ["o", "o", "o", "x", "x"], - ["o", "x", "x", "o", "o"], - ["o", "o", "o", "x", "x"], -] ) == 7'; - -is contiguous_block( [ - ["x", "o", "x", "o", "x"], - ["o", "x", "o", "x", "o"], - ["x", "o", "x", "o", "x"], - ["o", "x", "o", "x", "o"], -] ), 1, - 'Extra 1: contiguous_block( [ - ["x", "o", "x", "o", "x"], - ["o", "x", "o", "x", "o"], - ["x", "o", "x", "o", "x"], - ["o", "x", "o", "x", "o"], -] ) == 1'; - -is contiguous_block( [] ), 0, - 'Extra 2: contiguous_block( [] ) == 0'; - -done_testing; -- cgit