File Coverage

lib/Games/Nonogram/Clue.pm

Criterion	Covered	Total	%
statement	170	236	72.0
branch	63	124	50.8
condition	10	18	55.5
subroutine	22	26	84.6
pod	18	18	100.0
total	283	422	67.0

package Games::Nonogram::Clue;

use strict;
use warnings;
use base qw( Games::Nonogram::Base );

use Games::Nonogram::Line;
use Games::Nonogram::Block;

sub new {
  my ($class, %options) = @_;

  my $size = $options{size};
  my $line = Games::Nonogram::Line->new( size => $size );

  my $self = bless {
    id      => $options{id},
    size    => $size,
    line    => $line,
    is_done => 0,
  }, $class;

  if ( $options{blocks} ) {
    $self->set( @{ $options{blocks} || [] } );
  }

  $self;
}

sub id { shift->{id} || '' }

sub set {
  my ($self, @clues) = @_;

  my $id = 0;
  my @blocks = map {
    Games::Nonogram::Block->new(
      id        => ++$id,
      length    => $_,
      line_size => $self->size,
    )
  } @clues;
  $self->{blocks} = \@blocks;

  $self->reset_blocks;

  my $free;
  unless ( @blocks ) {
    $self->line->off( from => 1, length => $self->size );
    $free = 0;
  }
  else {
    $free = $blocks[0]->right - $blocks[0]->length;
  }

  $self->{free} = $free;
}

sub reset_blocks {
  my $self = shift;

  my $left = 1;
  foreach my $block ( $self->blocks ) {
    $block->clear;
    $block->left( $left );
    $left += ( $block->length + 1 );
  }

  my $right = $self->size;
  foreach my $block ( reverse $self->blocks ) {
    $block->right( $right );
    $right -= ( $block->length + 1 );
  }

  $self->{is_done} = 0;
}

sub blocks { @{ shift->{blocks} || [] } }
sub size   { shift->{size} }
sub line   { shift->{line} }

sub block {
  my ($self, $id) = @_;
  $self->{blocks}->[$id];
}

sub as_string {
  my $self = shift;

  my $str = $self->line->as_string;

  if ( $self->debug ) {
    $str .= ' '. join ' ', map { $_->length } $self->blocks;
  }
  return $str;
}

sub dump_blocks {
  my $self = shift;

  my $str = $self->id . "\n";
  foreach my $block ( $self->blocks ) {
    for my $ct ( 1 .. $self->size ) {
      if ( $block->must_have( $ct ) ) {
        $str .= "X";
      }
      elsif ( $block->might_have( $ct ) ) {
        $str .= "_";
      }
      else {
        $str .= ".";
      }
    }
    $str .= sprintf " (%s, %s: %s)\n", $block->left, $block->right, $block->length;
  }

  $str .= $self->as_string . "\n";

  defined wantarray ? return $str : print $str;
}

sub is_done {
  my $self = shift;

  unless ( $self->{is_done} ) {
    return unless $self->line->is_done;
    $self->die_if_invalid;

    $self->{is_done} = 1;
  }
  $self->{is_done};
}

sub die_if_invalid {
  my $self = shift;

  my $ct = 1;
  foreach my $block ( $self->blocks ) {
    while ( $ct < $block->left ) {
      my $value = $self->line->value( $ct );
      if ( $value != 0 ) {
        $self->dump_blocks if $self->debug;
        die "failed at $ct: $value != 0";
      }
      $ct++;
    }
    while ( $ct <= $block->right ) {
      my $value = $self->line->value( $ct );
      if ( $value != 1 ) {
        $self->dump_blocks if $self->debug;
        die "failed at $ct: $value != 1";
      }
      $ct++;
    }
  }
  while ( $ct <= $self->size ) {
    my $value = $self->line->value( $ct );
    if ( $value != 0 ) {
      $self->dump_blocks if $self->debug;
      die "failed at $ct: $value != 0";
    }
    $ct++;
  }
  return 1;
}

sub on {
  my ($self, $id) = @_;

  $self->line->on( $id );

  my $block = $self->might_have( $id );

  return unless ref $block;

  my $offset = $block->length - 1;

  my $left = $id - $offset;
  $block->left( $left ) if $block->left < $left;

  my $right = $id + $offset;
  $block->right( $right ) if $block->right > $right;

  if ( $block->left == $id ) {
    my $left = $block->left;
    $self->line->on( $_ ) for ( $left .. $left + $offset );
  }

  if ( $block->right == $id ) {
    my $right = $block->right;
    $self->line->on( $_ ) for ( $right - $offset .. $right );
  }
}

sub off {
  my ($self, $id) = @_;

  $self->line->off( $id );

  foreach my $block ( $self->blocks ) {
    $block->cant_have( $id );
  }

  my $block = $self->might_have( $id );

  return unless ref $block;

  my $offset = $block->length - 1;

  my $left = $id + 1;
  $block->left( $left ) if $block->left + $offset > $left;

  my $right = $id - 1;
  $block->right( $right ) if $block->right - $offset < $right;
}

sub value {
  my ($self, $id, $value) = @_;

  if ( defined $value ) {
    if    ( $value == 0 ) { $self->off( $id ) }
    elsif ( $value == 1 ) { $self->on( $id ) }
  }
  else {
    $self->line->value( $id );
  }
}

sub might_have {
  my ($self, $id) = @_;

  my $hit;
  foreach my $block ( $self->blocks ) {
    if ( $block->might_have( $id ) ) {
      return -1 if $hit; # multiple candidates; cannot decide

      $hit = $block;
    }
  }
  return $hit ? $hit : 0;
}

sub update {
  my ($self, $mode) = @_;

  unless ( $mode ) {
    $self->_update_basic;
  }
  elsif ( $mode eq 'more' ) {
    $self->_update_more;
  }

  foreach my $ct ( 1 .. $self->size ) {
    my $block = $self->might_have( $ct );

    unless ( $block ) {
      $self->off( $ct );
    }
    elsif ( ref $block ) {
      my $value = $self->line->value( $ct );
      if ( $value == -1 ) {
        $self->on( $ct ) if $block->must_have( $ct );
      }
      elsif ( $value == 0 ) {
        $self->off( $ct );
      }
      elsif ( $value == 1 ) {
        $self->on( $ct ) unless $block->must_have( $ct );
      }
    }
  }
}

sub _update_basic {
  my $self = shift;

  my $left = 1;
  foreach my $block ( $self->blocks ) {
    $left = $block->left if $block->left > $left;
    while (
      $self->line->value( $left ) == 0
        or
      $left > 1 && $self->line->value( $left - 1 ) == 1
    ) {
      $left++;
      if ( $left > $self->size ) {
        die "puzzle data may be broken, unless you're trying to solve by brute force";
      }
    }

    $block->left( $left );
    $left += ( $block->length + 1 );
  }

  my $right = $self->size;
  foreach my $block ( reverse $self->blocks ) {
    $right = $block->right if $block->right < $right;

    while (
      $self->line->value( $right ) == 0
        or
      $right < $self->size && $self->line->value( $right + 1 ) == 1
    ) {
      $right--;
      if ( $right < 1 ) {
        die "puzzle data may be broken, unless you're trying to solve by brute force";
      }
    }

    $block->right( $right );
    $right -= ( $block->length + 1 );
  }

  foreach my $block ( $self->blocks ) {
    my ($from, $length) = (0, 0);
    foreach my $ct ( $block->left .. $block->right ) {
      my $value = $self->line->value( $ct );
      if ( $value == 1 ) {
        $from ||= $ct;
        $length++;
      }
      else {
        $block->try( $from, $length );
        ($from, $length) = (0, 0);
      }
    }
    $block->try( $from, $length );
  }
}

sub _update_more {
  my $self = shift;

  my ($toggle, $from, @blocks);
  foreach my $ct ( 1 .. $self->size ) {
    $from ||= $ct;

    my $value = $self->line->value( $ct );
    if ( $value == 1 ) {
      $toggle = 1;
    }
    elsif ( $value == 0 ) {
      if ( $toggle ) {
        push @blocks, { from => $from, to => $ct - 1 };
      }
      $from = $toggle = 0;
    }
  }
  if ( $toggle ) {
    push @blocks, { from => $from, to => $self->size };
  }

  if ( @blocks == $self->blocks ) {
    foreach my $block ( $self->blocks ) {
      my $href = shift @blocks;
      $block->left( $href->{from} ) if $block->left < $href->{from};
      $block->right( $href->{to} )  if $block->right > $href->{to};
    }
  }
}

sub candidates {
  my $self = shift;

  my @candidates = $self->_candidates(
    $self->line->clone,
    1,
    $self->{free},
    $self->blocks
  );
}

sub _candidates {
  my ($self, $line, $pos, $free, @blocks) = @_;

  my $clone = $line->clone;
  unless ( $free ) {
    while( my $block = shift @blocks ) {
      foreach my $ct ( 0 .. $block->length - 1 ) {
        return if $clone->value( $pos + $ct ) == 0;  # conflicted;
        $clone->on( $pos + $ct );
      }
      $pos += $block->length;
      unless ( $pos > $self->size ) {
        return if $clone->value( $pos ) == 1; # conflicted;
        $clone->off( $pos );
      }
      $pos++;
    }
  }
  unless ( @blocks ) {
    foreach my $ct ( $pos .. $self->size ) {
      return if $clone->value( $ct ) == 1;    # conflicted
      $clone->off( $ct );
    }
    return $clone->as_vec;
  }

  my @candidates;
  LOOP:
  foreach my $ct ( 0 .. $free ) {
    $clone = $line->clone;
    my @clone_blocks = @blocks;
    my $clone_pos    = $pos;

    foreach my $space_ct ( 1 .. $ct ) {
      next LOOP if $clone->value( $clone_pos ) == 1;   # conflicted
      $clone->off( $clone_pos );
      $clone_pos++;
    }

    my $block = shift @clone_blocks;
    foreach my $block_ct ( 1 .. $block->length ) {
      next LOOP if $clone->value( $clone_pos ) == 0; # conflicted
      $clone->on( $clone_pos );
      $clone_pos++;
    }
    unless ( $clone_pos > $self->size ) {
      next LOOP if $clone->value( $clone_pos ) == 1; # conflicted
      $clone->off( $clone_pos );
      $clone_pos++;

      push @candidates, $self->_candidates(
        $clone,
        $clone_pos,
        $free - $ct,
        @clone_blocks
      );
    }
    else {
      push @candidates, $clone->as_vec;
    }
  }
  return @candidates;
}

1;

__END__