package Games::Nonogram::Block;
use strict;
use warnings;
use base qw( Games::Nonogram::Base );
sub new {
my ($class, %options) = @_;
my $self = bless {
id => $options{id},
length => $options{length},
line_size => $options{line_size},
left => 0,
right => 0,
forbidden => {},
}, $class;
}
sub id { shift->{id} }
sub clear {
my $self = shift;
$self->{left} = $self->{right} = 0;
$self->{forbidden} = {};
}
sub length {
my ($self, $value) = @_;
if ( defined $value ) {
$self->die_if_overflowed( $value );
$self->{length} = $value;
}
$self->{length};
}
sub left {
my ($self, $value) = @_;
if ( defined $value ) {
$self->die_if_overflowed( $value );
$self->{left} = $value;
}
$self->{left};
}
sub right {
my ($self, $value) = @_;
if ( defined $value ) {
$self->die_if_overflowed( $value );
$self->{right} = $value;
}
$self->{right};
}
sub die_if_overflowed {
my ($self, $value) = @_;
if ( $self->is_overflowed( $value ) ) {
my ( $package, $file, $line, $subr ) = caller(1);
die <<"__MESSAGE__";
Block $$self{id} is broken. ($subr overflow: $value)
Unless you're trying to solve by brute force,
there may be something wrong in the puzzle data.
LEFT: $$self{left}
RIGHT: $$self{right}
LENGTH: $$self{length}
__MESSAGE__
}
}
sub is_overflowed {
my ($self, $value) = @_;
return 1 if $value > $self->{line_size} || $value < 1;
my $left = $self->{left} or return;
my $right = $self->{right} or return;
return 1 if $left > $right;
}
sub cant_have {
my $self = shift;
if ( @_ == 1 ) {
my $id = shift;
$self->{forbidden}->{$id} = 1;
}
elsif ( @_ ) {
$self->{forbidden}->{$_} = 1 for ( $self->range( @_ ) );
}
if ( $self->length > 1 ) {
my @forbiddens = sort { $a <=> $b }
grep { $_ > $self->left && $_ < $self->right }
keys %{ $self->{forbidden} || {} };
push @forbiddens, $self->right + 1;
my $prev = $self->left - 1;
foreach my $pos ( @forbiddens ) {
if ( $prev + 1 == $pos ) {
$prev = $pos;
next;
}
if ( ( $pos - 1 ) - ( $prev + 1 ) + 1 < $self->length ) {
$self->log(
'block ', $self->id, ': ',
( $prev + 1 ), "-", ( $pos - 1 ),
" cannot have ", $self->length
);
$self->{forbidden}->{$_} = 1 for ( $prev + 1 .. $pos - 1 );
}
$prev = $pos;
}
while( $self->{forbidden}->{ $self->left } ) {
$self->left( $self->left + 1 );
}
while( $self->{forbidden}->{ $self->right } ) {
$self->right( $self->right - 1 );
}
}
}
sub might_have {
my ($self, $id) = @_;
return 0 if $self->{forbidden}->{$id};
( $self->left > $id or $self->right < $id ) ? 0 : 1;
}
sub must_have {
my ($self, $id) = @_;
return 0 if $self->{forbidden}->{$id};
my $offset = $self->length - 1;
( $self->left + $offset < $id
or
$self->right - $offset > $id ) ? 0 : 1;
}
sub try {
my ($self, $from, $length) = @_;
if ( $length > $self->length ) {
$self->cant_have( from => $from - 1, length => $length + 2 );
}
elsif ( $length == $self->length ) {
$self->cant_have( $from - 1 );
$self->cant_have( $from + $length );
}
}
1;
__END__
=head1 NAME
Games::Nonogram::Block
=head1 SYNOPSIS
use Games::Nonogram::Block;
my $block = Games::Nonogram::Block->new(
id => 'row 1 block 1',
length => 2,
line_size => 20,
);
=head1 DESCRIPTION
This is used internally to decide where each box (block) be placed in a row or a column. For example, in a row of 5 cells with two clues (1, 2), the first block should not be placed at cell 3, 4 and 5: see all the possible combinations.
1 2 3 4 5
X . X X .
X . . X X
. X . X X
In this case, the first ::Block object should have properties like
* left: 1
* right: 2
and the second,
* left: 3
* right: 5
* must_have: 4
Actually this ::Block can handle a bit more complicated cases, though I don't explain here.
=head1 METHODS
=head2 new
creates an object.
=head2 clear
clears information of the block.
=head2 die_if_overflowed
sometimes this block may receive an out-of-range value (while brute-forcing, or when the puzzle is broken, perhaps). In that case, it dies to notify an error, which should be caught somewhere else.
=head2 is_overflowed
is used to see if the block is overflowed or not.
=head2 cant_have
sets forbidden area for the block (which is (or, should be) occupied by other blocks, or is known to be blank).
=head2 might_have
returns if the given cell (id) may belong to the block or not.
=head2 must_have
returns if the given cell (id) belongs to the block or not.
=head2 try
sees if the given area (cells) can belong to the block or not, and sets the result. If it can't belong to the block, all the cells in the area "cant_have" the block, and if the area is exactly the same as the block, both of the adjacent cells must be blank by the rule.
=head1 ACCESSORS
=head2 id
returns a block id.
=head2 length
returns of the length of the block.
=head2 left
returns the leftmost id the block can stay.
=head2 right
returns the rightmost id the block can stay.
=head1 AUTHOR
Kenichi Ishigaki, E<lt>ishigaki at cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2007 by Kenichi Ishigaki
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut