Skip to content

Commit 7946eb7

Browse files
jacobyjacoby
committed
292 Blogged
1 parent d8f19bf commit 7946eb7

File tree

1 file changed

+225
-0
lines changed

1 file changed

+225
-0
lines changed

‎_posts/2024-10-21-comes-a-time-weekly-challenge-292.markdown‎

Lines changed: 225 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,225 @@
1+
---
2+
layout: post
3+
title: "Comes A Time: Weekly Challenge #292"
4+
author: "Dave Jacoby"
5+
date: "2024-10-21 17:35:04 -0400"
6+
categories: ""
7+
---
8+
9+
Welcome to [**_Weekly Challenge #292_**](https://theweeklychallenge.org/blog/perl-weekly-challenge-292/). **292** the product of **2 _ 2 _ 73**. I would dig up more interesting numerical things, but this was a bit of a challenge (funny, that) and took longer than I had expected.
10+
11+
My other hobby is music, and my band, Greg Jones and the Wabash Ramblers, will be playing this Saturday. If you're in west central Indiana and are interested in corn and roots rock, hit me up for details!
12+
13+
### Task 1: Twice Largest
14+
15+
> Submitted by: Mohammad Sajid Anwar
16+
> You are given an array of integers, `@ints`, where the largest integer is unique.
17+
>
18+
> Write a script to find whether the largest element in the array is at least twice as big as every element in the given array. If it is return the index of the largest element or return `-1` otherwise.
19+
20+
#### Let's Talk About It
21+
22+
These are heavy [List::Util](https://metacpan.org/pod/List::Util) tasks. We're comparing the highest value entry in an array with the others, and we can find that with `max`.
23+
24+
> `my $max = max @array`
25+
26+
And once you have the max, you can find the index fairly easily with `first`.
27+
28+
> `my $index = first { $array[$\_] == $max } 0 .. -1 + scalar @array;
29+
30+
And now we loop through the array, skipping `$index`, and testing if `$max >= 2 * $v`.
31+
32+
#### Show Me The Code!
33+
34+
```perl
35+
#!/usr/bin/env perl
36+
37+
use strict;
38+
use warnings;
39+
use experimental qw{ say state postderef signatures };
40+
41+
use List::Util qw{ first max };
42+
43+
my @examples = (
44+
45+
[ 2, 4, 1, 0 ],
46+
[ 1 .. 4 ],
47+
[ 1, 3, 5, 7, 11 ],
48+
[ 1, 3, 5, 7, 15 ],
49+
);
50+
51+
for my $example (@examples) {
52+
my $output = twice_largest( $example->@* );
53+
my $input = join ', ', $example->@*;
54+
say <<"END";
55+
Input: \$ints = ($input)
56+
Output: $output
57+
END
58+
}
59+
60+
sub twice_largest (@array) {
61+
my $max = max @array;
62+
my $i = first { $array[$_] == $max } 0 .. -1 + scalar @array;
63+
for my $j ( 0 .. -1 + scalar @array ) {
64+
next if $i == $j;
65+
my $v = $array[$j];
66+
my $r = $max >= 2 * $v ? 1 : 0;
67+
if ( !$r ) {
68+
return -1;
69+
}
70+
}
71+
return $i;
72+
}
73+
74+
```
75+
76+
```text
77+
$ ./ch-1.pl
78+
Input: $ints = (2, 4, 1, 0)
79+
Output: 1
80+
81+
Input: $ints = (1, 2, 3, 4)
82+
Output: -1
83+
84+
Input: $ints = (1, 3, 5, 7, 11)
85+
Output: -1
86+
87+
Input: $ints = (1, 3, 5, 7, 15)
88+
Output: 4
89+
```
90+
91+
### Task 2: Zuma Game
92+
93+
> Submitted by: Mohammad Sajid Anwar
94+
> You are given a single row of colored balls, `$row` and a random number of colored balls in `$hand`.
95+
>
96+
> Here is the variation of **Zuma** game as your goal is to clear all of the balls from the board. Pick any ball from your hand and insert it in between two balls in the row or on either end of the row. If there is a group of _three or more consecutive balls of the same color_ then remove the group of balls from the board. If there are no more balls on the board then you win the game. Repeat this process until you either win or do not have any more balls in your hand.
97+
>
98+
> Write a script to minimum number of balls you have to insert to clear all the balls from the board. If you cannot clear all the balls from the board using the balls in your hand, return `-1`.
99+
100+
#### Let's Talk About It
101+
102+
> Some people, when confronted with a problem, think "I know, I'll use regular expressions." Now they have two problems.
103+
> — Jamie Zawinski
104+
105+
I get that. Really, I do. But a good chunk of the power of Perl is the power of their regular expressions. I'm sure I could do this in a way that didn't use regular expressions, but it seems tedious. I mean, I'm seeing substring manipulation and named while loops. As wild as you can get with regular expressions, and as unreadable as they can get, that's really the better choice.
106+
107+
And that'll be the first place to start. Assume we're given `WWBBWW` and given a chance to add a `B`. There are 3 useful places that can go: before the first `B`, between the `B`s and after the last `B`. The result will be identical, which is ending up with `WWBBBWW`, which means we can match and remove `BBB` and end up with `WWWWW`. The thing to remember is that we aren't just taking out `BBB`. Once that issue is resolved, we can take out `WWWW`. It's a cascade of removal.
108+
109+
Logically, it's simple. It's why we have `while` loops. `while ( test_for_issue() ) { fix_issue() }`, to pseudocode it. So the question goes to matching three or more of the same character.
110+
111+
If we were looking for any specific character, then `$char{3,}` would do it, but we're looking for anything. `[A-Z]` matches anything we're calling a ball in the Zuma context, and within the realm of regular expressions, we can group them with `([A-Z])`, and address it with `\1`. So, that's `while ( $board =~ /([A-Z])\1\1/mx) { ... }` to find 'em, and then we use substitution to do the fix. `$board =~ /([A-Z])\1\1+//gmx` does that substitution to everything that fits, and then we loop and try again.
112+
113+
And from there, there are things that just cut down on time. We're given a hand and a board. Take the second example hand, `WRBRW`. When we're testing, it just doesn't matter if we take the first or the second `W` or the first or second `R`, so I sort them and run `uniq` and `first` to only run `BRW`, while being sure to pass on the secondary `R` and `W` to the next recursion, because , ... `ahem` ...
114+
115+
_This Looks Like A Job For **Recursion!**_
116+
117+
I'm going to have to put that on RedBubble some day.
118+
119+
Anyway, similarly, as mentioned with the `WWBBWW` board, When we add in a `B`, it doesn't matter if we add it between the `B`s, before the first `B` or after the last. I often do something like `next if $hash{$hand}{$board}++`. Any truthiness to `$hash{$hand}{$board}` would result in going on to the next position.
120+
121+
I will admit that I did play a little with [Memoize](https://metacpan.org/pod/Memoize), but I wrote by passing hashes. If I used `zuma( $board, $hand, $used )`, then I probably would've been able make more use of it and thus worrying less about editing out unuseful paths, but alas, I am happy with what I have.
122+
123+
I suppose that means I have to get to what `$used` is for. I believe that naming variables counts as documentation, at least the most tertiary versio of it, and so `$used` is the balls that have been *used*, concatenated in order, and when we get, for example, a `2`, that means we got to a satisfactory ending by adding two characters/balls to `$used`, so `length $used` is `2`.
124+
125+
Within the recursion, I only save a value if it's `0` or greater, when I return, I return either the minimum value or `-1`, which handles a lot of thing very cleanly. This may have lots and lots of paths that end in failure, but we can just ignore them. `min`, of course, comes from List::Util.
126+
127+
And then there's `substr`. It is wonderful because it can be used as both an **lvalue** and an **rvalue**. By rvalue, I mean you can put it in the right side of an expression. `$value = substr($string,0,4)`, for example. It can also be assigned to, making it an lvalue. `substr( $string, 0, 0) = 'This string now starts with this sentence.`, for example. Very, very cool.
128+
129+
#### Show Me The Code!
130+
131+
```perl
132+
#!/usr/bin/env perl
133+
134+
use strict;
135+
use warnings;
136+
use experimental qw{ say state postderef signatures };
137+
138+
use List::Util qw{ first max min uniq };
139+
140+
my @examples = (
141+
142+
{ board => "WRRBBW", hand => "RB" },
143+
{ board => "WWRRBBWW", hand => "WRBRW" },
144+
{ board => "G", hand => "" },
145+
{ board => "", hand => "GGGGG" },
146+
{ board => "GG", hand => "GGGGG" },
147+
{ board => "G", hand => "GGGGG" },
148+
);
149+
150+
for my $example (@examples) {
151+
$example->{hand} = join '', sort split //, $example->{hand};
152+
$example->{used} = '';
153+
my @output = zuma($example);
154+
my $output = join ' ', @output;
155+
my ( $board, $hand ) = map { $example->{$_} } qw{board hand};
156+
say <<"END";
157+
Input: \$board = "$board", \$hand = "$hand"
158+
Output: $output
159+
END
160+
}
161+
162+
sub zuma ($example) {
163+
my @output;
164+
my %done;
165+
my ( $board, $hand, $used ) =
166+
map { $example->{$_} || '' } qw{board hand used};
167+
my $lboard = length $board || 0;
168+
my $lhand = length $hand || 0;
169+
my $lused = length $used || 0;
170+
171+
# you've run out of balls on the board and have thus won
172+
if ( length $board == 0 ) { return $lused; }
173+
174+
# You've run out of balls and cannot win
175+
if ( length $hand == 0 ) { return -1; }
176+
177+
my @chars = uniq sort split //, $hand;
178+
for my $h (@chars) {
179+
my $chand = $hand;
180+
my $i =
181+
first { substr( $chand, $_, 1 ) eq $h } 0 .. -1 + length $chand;
182+
substr( $chand, $i, 1 ) = '';
183+
for my $j ( 0 .. length $board ) {
184+
my $cboard = $board;
185+
substr( $cboard, $j, 0 ) = $h;
186+
while ( $cboard =~ m{([A-Z])\1\1}mx ) {
187+
$cboard =~ s/([A-Z])\1\1+//gmx;
188+
}
189+
next if $done{$chand}{$cboard}++;
190+
my $obj = {};
191+
$obj->{board} = $cboard;
192+
$obj->{hand} = $chand;
193+
$obj->{used} = $used . $h;
194+
my $o = zuma($obj);
195+
push @output, $o if $o >= 0;
196+
}
197+
}
198+
@output = uniq sort { $a <=> $b } grep { defined } @output;
199+
if ( scalar @output ) { return min @output; }
200+
return -1;
201+
}
202+
```
203+
204+
```text
205+
$ ./ch-2.pl
206+
Input: $board = "WRRBBW", $hand = "RB"
207+
Output: -1
208+
209+
Input: $board = "WWRRBBWW", $hand = "WRBRW"
210+
Output: 2
211+
212+
Input: $board = "G", $hand = ""
213+
Output: -1
214+
215+
Input: $board = "", $hand = "GGGGG"
216+
Output: 0
217+
218+
Input: $board = "GG", $hand = "GGGGG"
219+
Output: 1
220+
221+
Input: $board = "G", $hand = "GGGGG"
222+
Output: 2
223+
```
224+
225+
#### If you have any questions or comments, I would be glad to hear it. Ask me on [Mastodon](https://mastodon.xyz/@jacobydave) or [make an issue on my blog repo.](https://github.com/jacoby/jacoby.github.io)

0 commit comments

Comments
 (0)