From 48af72352a9ce1b48c370332958cf6200c77e511 Mon Sep 17 00:00:00 2001
From: Alex Smith <ais523@dell.linuxdev.us.dell.com>
Date: Wed, 5 Aug 2009 19:13:12 +0100
Subject: [PATCH] Boulder tracking for Sokoban

This change attempts to distinguish genuine boulders and mimics,
to be able to tell where it is in terms of solving Sokoban.
---
 lib/TAEB/Action/Move.pm      | 20 ++++++++++++++++++--
 lib/TAEB/Spoilers/Sokoban.pm | 20 +++++++++++++++++++-
 lib/TAEB/World/Tile.pm       |  8 ++++++++
 3 files changed, 45 insertions(+), 3 deletions(-)

diff --git a/lib/TAEB/Action/Move.pm b/lib/TAEB/Action/Move.pm
index ddf54222..58bd1c41 100644
--- a/lib/TAEB/Action/Move.pm
+++ b/lib/TAEB/Action/Move.pm
@@ -10,14 +10,14 @@ has path => (
     provided => 1,
 );
 
-has [qw/hit_obscured_monster hit_immobile_boulder/] => (
+has [qw/hit_obscured_monster hit_immobile_boulder pushing/] => (
     is      => 'rw',
     isa     => 'Bool',
     default => 0,
 );
 
 # if the first movement is < or >, then just use the Ascend or Descend actions
-# if the first movement would move us into a monster, rest instead
+# if the first movement moves us into a boulder, record the fact
 around new => sub {
     my $orig  = shift;
     my $class = shift;
@@ -42,6 +42,10 @@ around new => sub {
         $action = 'Descend';
     }
 
+    if (TAEB->current_tile->at_direction($start)->has_boulder) {
+        $args{pushing} = 1;
+    }
+
     if ($action) {
         return "TAEB::Action::$action"->new(%args);
     }
@@ -75,6 +79,18 @@ sub done {
     if ($walked) {
         TAEB->send_message('walked');
 
+        if ($self->pushing) {
+            # If we pushed a boulder, then if it's still there, it
+            # must be genuine.
+            TAEB->current_tile->known_genuine_boulder(0);
+            my $beyond =
+                TAEB->current_level->at_safe(
+                    TAEB->x * 2 - $self->starting_tile->x,
+                    TAEB->y * 2 - $self->starting_tile->y);
+            $beyond->known_genuine_boulder(1)
+                if $beyond && $beyond->has_boulder;
+        }
+
         # the rest applies only if we haven't moved
         return;
     }
diff --git a/lib/TAEB/Spoilers/Sokoban.pm b/lib/TAEB/Spoilers/Sokoban.pm
index 765cec09..230e709c 100644
--- a/lib/TAEB/Spoilers/Sokoban.pm
+++ b/lib/TAEB/Spoilers/Sokoban.pm
@@ -399,6 +399,15 @@ sub first_solvable_sokoban_level {
     });
 }
 
+sub probably_has_genuine_boulder {
+    my $self = shift;
+    my $tile = shift;
+    return 0 unless $tile->has_boulder;
+    return 1 if $tile->type eq 'obscured';
+    return 1 if $tile->known_genuine_boulder;
+    return 0; # probably a mimic
+}
+
 sub next_sokoban_step {
     my $self = shift;
     my $level = shift;
@@ -463,7 +472,7 @@ sub next_sokoban_step {
 
     $level->each_tile(sub {
         my $t = shift;
-        if ($t->has_boulder) {
+        if ($self->probably_has_genuine_boulder($t)) {
             my $y = $t->y - $top;
             my $x = $t->x - $left;
             my $char = $map->[$y]->[$x];
@@ -612,6 +621,15 @@ argument is a string giving the variant, which can be added to avoid
 recalculating the variant if it's already known; if omitted, the
 variant will be calculated by looking ath the level map.
 
+=head2 probably_has_genuine_boulder Tile -> Bool
+
+Returns true if the tile appears to have a boulder on, and it probably
+is a genuine boulder, rather than a mimic pretending. To be precise,
+this returns true if we've pushed a boulder onto the square and
+haven't pushed it off again, or if the tile is obscured and appears to
+have a boulder; this handles all cases but that of a mimic visible
+when we arrive on the level, and a search should detect that.
+
 =head2 next_sokoban_step Level [Pathable] -> Maybe Tile
 
 Return the tile that we need to head to next to solve the Sokoban
diff --git a/lib/TAEB/World/Tile.pm b/lib/TAEB/World/Tile.pm
index 3affcd5d..ecc2d8de 100644
--- a/lib/TAEB/World/Tile.pm
+++ b/lib/TAEB/World/Tile.pm
@@ -84,6 +84,14 @@ has nondiggable => (
     default  => 0,
 );
 
+# Is there an object on this square that's known to be a boulder,
+# rather than a mimic just pretending?
+has known_genuine_boulder => (
+    is       => 'rw',
+    isa      => 'Bool',
+    default  => 0,
+);
+
 has engraving => (
     is      => 'rw',
     isa     => 'Str',