RabbitFarm

2026-07-25

Similar and Nearest but in No Way Clearest

The examples used here are from the weekly challenge problem statement and demonstrate the working solution.

Part 1: Similar List

You are given three list of strings. Write a script to find out if the first two list are similar with the help the third list. The third list contains the similar words map.

The code can be contained in a single file which has the following structure. The different code sections are explained in detail later.

"ch-1.pl" 1≡


use builtin q/true/, q/false/;
⟨build map 2 ⟩
⟨check similar 4 ⟩
⟨main 5 ⟩
◇

Some preliminary work is needed, to build the map given into a useful data structure. Given the relatively short lists involved we’ll just use a multi-valued hash. That is, a hash whose value is an array reference.

⟨build map 2 ⟩≡


sub build_map{
my($m) = @_;
my $h = {};
{
my $l = pop @{$m};
my $k = shift @{$l};
for my $x (@{$l}){
$h->{$x} = $k;
}
redo if @{$m};
}
return $h;
}
◇

Fragment referenced in 1.

Uses: $m 4.

Now, first off, we can abandon all further processing if the lists are not of equal length. We’ll use this section inside the larger subroutine.

⟨check lengths 3 ⟩≡


return false if @{$u} ne @{$v};
◇

Fragment referenced in 4.

Uses: $u 4, $v 4.

Otherwise we can loop over the lists and compare using the map.

⟨check similar 4 ⟩≡


sub similar{
my($u, $v, $m) = @_;
⟨check lengths 3 ⟩
my $mapping = build_map($m);
{
my $vv = pop @{$v};
my $uu = pop @{$u};
return false unless($vv eq $uu || $mapping->{$vv} eq $uu
|| $mapping->{$uu} eq $vv);
redo if @{$u};
}
return true;
}
◇

Fragment referenced in 1.

Defines: $m 2, $u 3, $v 3.

Just to make sure things work as expected we’ll define a few short tests.

⟨main 5 ⟩≡


MAIN:{
print similar ["great", "acting"],
["fine", "drama"],
[["great", "fine"], ["acting", "drama"]];
print qq/\n/;
print similar ["apple", "pie"], ["banana", "pie"],
[["apple", "peach"], ["peach", "banana"]];
print qq/\n/;
print similar ["perl4", "python"], ["raku", "python"],
[["perl4", "perl5", "raku"]];
print qq/\n/;
print similar ["enjoy", "challenge"],
["love", "weekly", "challenge"],
[["enjoy", "love"]];
print qq/\n/;
print similar ["fast", "car"],
["quick", "vehicle"],
[["quick", "fast"], ["vehicle", "car"]];
print qq/\n/;
}
◇

Fragment referenced in 1.

Sample Run
% perl perl/ch-1.pl 
1 
 
1 
 
1

Part 2: Nearest RGB

You are given a 6-digit hex color. Write a script to round the RGB channels to the nearest web-safe value and return the nearest RGB color.

"ch-2.pl" 6≡


use feature q/say/;
⟨nearest rgb 9 ⟩
⟨main 10 ⟩
◇

To be clear, in order to convert any hex color to its nearest web-safe equivalent, you need to convert the hex string to RGB decimal values, round each channel to the nearest multiple of 51 (since 0x33 is 51), and convert it back to hex.

Let’s first consider the removal of any leading octothorpe and make sure the input is of the right length.

⟨remove leading hash and check length 7 ⟩≡


$color =~ tr/#//d;
return undef if length($color) != 6;
◇

Fragment referenced in 9.

Uses: $color 9.

⟨nearest multiple of 51 8 ⟩≡


my $r_safe = int(($r + 25.5) / 51) * 51;
my $g_safe = int(($g + 25.5) / 51) * 51;
my $b_safe = int(($b + 25.5) / 51) * 51;
◇

Fragment referenced in 9.

Defines: $b_safe 9, $g_safe 9, $r_safe 9.

Uses: $b 9, $g 9, $r 9.

⟨nearest rgb 9 ⟩≡


sub nearest_rgb{
my ($color) = @_;

⟨remove leading hash and check length 7 ⟩

my $r = hex(substr($color, 0, 2));
my $g = hex(substr($color, 2, 2));
my $b = hex(substr($color, 4, 2));

⟨nearest multiple of 51 8 ⟩

return sprintf(q/#%02X%02X%02X/, $r_safe, $g_safe, $b_safe);
}
◇

Fragment referenced in 6.

Defines: $b 8, $color 7, $g 8, $r 8.

Uses: $b_safe 8, $g_safe 8, $r_safe 8.

The main section is just some basic tests.

⟨main 10 ⟩≡


MAIN:{
say nearest_rgb q/#F4B2D1/;
say nearest_rgb q/#15E6E5/;
say nearest_rgb q/#191A65/;
say nearest_rgb q/#2D5A1B/;
say nearest_rgb q/#00FF66/;
}
◇

Fragment referenced in 6.

Sample Run
% perl perl/ch-2.pl 
#FF99CC 
#00FFCC 
#003366 
#336633 
#00FF66

References

The Weekly Challenge 383
Generated Code

posted at: 16:39 by: Adam Russell | path: /perl | permanent link to this entry