Re: Parks Puzzle

[tybalt89]

Let's solve it with a simple? regex :)

#!/usr/bin/perl -l

# http://perlmonks.org/?node_id=1207373

use strict; # regex Parks Puzzle
use warnings;
use re 'eval';

print "Initial grid:\n\n", my $board = <<END;
GRBBB
GRBBW
ORBBW
OOOWW
OOOOW
END

my $N = $board =~ /\n/ && $-[0];
my @letters = sort keys %{{ map {;$_, $_} $board =~ /\w/g }};
my @squares;
push @squares, "$&" . $` =~ tr/\n// . ',' . length($`) % ($N + 1)
  while $board =~ /\w/g;
$_ = join ' ', sort @squares;        # string to be matched
print "String to be matched (color,row,col):\n\n$_";

my $count = 0;
my $regex = '';
for my $color ( @letters )
  {
  my $y = 2 * $count + 1;
  my $x = $y + 1;
  $count and $regex .= ".*\n";
  $regex .= "$color(\\d+),(\\d+)\\b\n";
  my @tests;
  for my $prev ( 0 .. $count - 1 )
    {
    my $yy = 2 * $prev + 1;
    my $xx = $yy + 1;
    push @tests, "\$$yy == \$$y", "\$$xx == \$$x",    # same row & sam
+e col
      "abs \$$yy - \$$y < 2 && abs \$$xx - \$$x < 2"  # diagonal neigh
+bor
      ;
    }
  @tests and $regex .= "(??{" . join(' || ', @tests) . " ? 'fail' : ''
+})\n";
  $count++;
  }
print "\nRegex (match one of each color with conditions):\n\n$regex";

my $matches = join ' ', /$regex/x;             # let regex do the hard
+ work
print "Captures from regex (row,col pairs of solution):\n\n$matches\n"
+;

my $grid = $board =~ s/\w/-/gr;                  # build grid & insert
+ answer
substr $grid, $1 * ($N + 1) + $2, 1, shift @letters
  while $matches =~ /(\d+) (\d+)/g;
print "Formatted solution:\n\n$grid";

Outputs:

Initial grid:

GRBBB
GRBBW
ORBBW
OOOWW
OOOOW

String to be matched (color,row,col):

B0,2 B0,3 B0,4 B1,2 B1,3 B2,2 B2,3 G0,0 G1,0 O2,0 O3,0 O3,1 O3,2 O4,0 
+O4,1 O4,2 O4,3 R0,1 R1,1 R2,1 W1,4 W2,4 W3,3 W3,4 W4,4

Regex (match one of each color with conditions):

B(\d+),(\d+)\b
.*
G(\d+),(\d+)\b
(??{$1 == $3 || $2 == $4 || abs $1 - $3 < 2 && abs $2 - $4 < 2 ? 'fail
+' : ''})
.*
O(\d+),(\d+)\b
(??{$1 == $5 || $2 == $6 || abs $1 - $5 < 2 && abs $2 - $6 < 2 || $3 =
+= $5 || $4 == $6 || abs $3 - $5 < 2 && abs $4 - $6 < 2 ? 'fail' : ''}
+)
.*
R(\d+),(\d+)\b
(??{$1 == $7 || $2 == $8 || abs $1 - $7 < 2 && abs $2 - $8 < 2 || $3 =
+= $7 || $4 == $8 || abs $3 - $7 < 2 && abs $4 - $8 < 2 || $5 == $7 ||
+ $6 == $8 || abs $5 - $7 < 2 && abs $6 - $8 < 2 ? 'fail' : ''})
.*
W(\d+),(\d+)\b
(??{$1 == $9 || $2 == $10 || abs $1 - $9 < 2 && abs $2 - $10 < 2 || $3
+ == $9 || $4 == $10 || abs $3 - $9 < 2 && abs $4 - $10 < 2 || $5 == $
+9 || $6 == $10 || abs $5 - $9 < 2 && abs $6 - $10 < 2 || $7 == $9 || 
+$8 == $10 || abs $7 - $9 < 2 && abs $8 - $10 < 2 ? 'fail' : ''})

Captures from regex (row,col pairs of solution):

1 3 0 0 4 2 2 1 3 4

Formatted solution:

G----
---B-
-R---
----W
--O--

[aartist]

Thank you, for the wonderful solution that works for puzzle.

Having said that, my original idea is to provide rules to human being to solve the puzzle with limited observation at a time. For example, simple observation that if it finds any color is occupied by only a single row or columns than all the other cell of that row or column are 'blanked'. simple rules. It is more about detecting small patterns in the data visually and provide an action associated with it. Pattern needs to be small enough to be identified visually. Thus, in other words, I am looking for helping hand algorithm rather than brute force solution. It is like see the 'X' if you can and do the 'Y'. In the end, solution will be there.

[tybalt89]

In setting up a game playing program to allow easy addition of patterns (see X -> do Y), I discovered the complete list of patterns for this puzzle:

1. Find a square that, if you plant a tree there, will cause the elimination of at least one color. Mark that square as unavailable.
2. Repeat step 1. until solved.


That's it :)

Here's the code for it:

#!/usr/bin/perl

# http://perlmonks.org/?node_id=1207779

use strict;
use warnings;

print local $_ = my $grid = <<END, "starting\n";
GRBBB
GRBBW
ORBBW
OOOWW
OOOOW
END

my $N = $grid =~ /\n/ && $-[0];
my $n = $N - 1;

sub clear # the no longer available squares
  {
  my $pick = qr/[a-z]/;
  local $_ = shift;
  1 while s/\w(?=.*?$pick)/-/ + s/$pick.*?\K\w/-/  # row
    + s/\w(?=(?:.{$N}.)*.{$N}$pick)/-/s          # column
    + s/$pick(?:.{$N}.)*.{$N}\K\w/-/s            # column
    + s/$pick.{$n}(..)?\K\w/-/s                  # lower diagonals
    + s/\w(?=.{$n}(..)?$pick)/-/s                # upper diagonals
    ;
  return $_;
  }

sub missingcolor { $N > keys %{{ map +($_, $_), shift =~ /\w/g }} }

while( /[A-Z]/g ) # mark square to '-' if tree there causes a missing 
+color
  {
  missingcolor( lc clear( "$`\l$&$'" ) ) and
    $_ = "$`-$'",
    print $_, ' ' x $N, " mark ",
      $-[0] % ($N + 1), ',', int $-[0] / ($N + 1), "\n"; # x,y coords
  }

print s/[A-Z]/$&/g == $N ? "\nSolved!\n" : "Failed\n";

It prints a grid for each step of the solution (slightly more than 120 lines).