File Coverage

lib/Games/Nonogram/Block.pm

Criterion	Covered	Total	%
statement	69	75	92.0
branch	33	42	78.5
condition	7	9	77.7
subroutine	15	15	100.0
pod	12	12	100.0
total	136	153	88.8

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__