This is my basic puzzle solver method.
Keep a queue of partial solutions. Throw out ones that violate the rules.
Then add new partial solutions (one for each square of the next color) on the queue.
You're solved if no colors are left, because you've put a tree in each color, and you fail if the queue is empty.

Simple, eh?

#!/usr/bin/perl

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

use strict;
use warnings;

my $start = <<END;
GRBBB
GRBBW
ORBBW
OOOWW
OOOOW
END

my $gap = $start =~ /\n/ && $-[0] - 1;
my $egap = $gap + 2;

my @queue = $start;
while( @queue )
  {
  local $_ = shift @queue;
  /#.*#/ and next;                      # same row
  /#(?:.{$gap}..)*.{$gap}.#/s and next; # same column
  /#(.{$gap,$egap}|)#/s and next;       # adjacent trees
  if( /[A-Z]/ ) # pick a color
    {
    push @queue, "$`#$'" =~ s/$&/\l$&/gr while /$&/g;
    }
  else
    {
    print "$start\nwin with\n\n$_";
    exit;
    }
  }
die "failed to find solution\n";
[download]

Simple, eh?

It gets simpler after you look up @-, $`, $&, $', \l modifier, add a couple of data dumps, think through the regex greediness and backtracking, dig into precedence..

/#.*#/ and next;       # same row
[download]

That is pretty easy to see how it works, without the /s modifier, . does not match newline, so two #s in the same line. Your comment spells it out, but it makes your intent clear for the next couple lines which are a little bit harder to see how they work.

  /#(?:.{$gap}..)*.{$gap}.#/s and next; # same column
[download]

The greediness of the first portion (?:.{$gap}..)* marches the regex all the way to the end of the grid while .{$gap}.# backtracks so it tries to make a match.

Then of course the best line and, also would like to mention that, I super searched for 'while /$&/g' just to see if it was somewhere else, and only this node came up making it pretty unique.

push @queue, "$`#$'" =~ s/$&/\l$&/gr while /$&/g;
[download]

That line makes me love and hate perl at the same time. Creating and pushing the partial solutions to @queue in one line. It iterates through the grid, for the letter it has matched earlier [A-Z], adds this grid with the instance of the letter changed to #, and all other instances of the letter lowercased with \l.

The alternation operator in /#(.{$gap,$egap}|)#/s is not used or maybe I don't understand, I think perl should not compile that, but

print 'yes' if 'a' =~ /(b|)/;
[download]

works and matches, so back to the books, seems that empty alternations always match, so that means this alternative is checking for two '#'s in a row, which would already be matched by that point. In other search result coincidences, exactly one year ago today, someone tried to get perl critic to disallow empty alternations.

Very neat solution to a fun problem, easy enough to dig into and understand a little bit more perl. Thanks for sharing.

Good catch on the empty alternative! As far as I can tell it's there from the beginning when I tried to write the three tests in one regex. I missed it when I split them up to make them clearer. It doesn't hurt anything, however.

The line push @queue, "$`#$'" =~ s/$&/\l$&/gr while /$&/g; made me giggle a little when I wrote it :)
I often giggle when writing perl, it's one heck of a great language.

I don't know this particular puzzle, but whenever I see anything that might involve trial & error, I consider Dancing Links (https://en.wikipedia.org/wiki/Dancing_Links). Masak gave a talk on this to the London Perl Workshop >5 years ago. It is probably on line somewhere, but I have no idea where. He used Perl 6 in his examples, but the techniques were certainly obvious to me.

Regards,

John Davies

Update: having had a VERY quick look at the site (it's not something I want to get), my first thought is that it is a variant on the N queens problem. See, for example, Efficient N-Queen solution with Perl.

Please, you've been a member longer than I have. Show some code before you throw out such a broad request.

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";
[download]

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--
[download]

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.

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";
[download]

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

So let's see the Prolog code for your fun solution to Parks Puzzle...