package GridFiller; use Moose; use namespace::autoclean; use List::Util qw(shuffle); use List::MoreUtils qw(uniq); use TryCatch; use MooseX::Types -declare => [qw( GridT Char LetterCell )]; use MooseX::Types::Moose qw(Str ArrayRef Bool Int); use MooseX::Types::Structured qw(Tuple); use Carp; my $VERTICAL = 1; my $HORIZONTAL = 2; my $BLACK = 1; my $WHITE = 2; subtype GridT, as ArrayRef[ArrayRef[Bool]]; coerce GridT, from ArrayRef[ArrayRef[Str]], via { [ map { [ map { $_ eq '*' } @$_ ] } @$_ ] }; has words => ( isa => ArrayRef[Str], required => 1, is => 'ro', ); has grid => ( isa => GridT, required => 1, is => 'ro', ); has _words_to_use => ( isa => ArrayRef[Str], traits => ['Array'], handles => { _has_next_word => 'count', _get_next_word => 'shift', }, is => 'rw', lazy_build => 1, clearer => '_reset_words_to_use', ); sub _build__words_to_use { # clone initial word list return [ shuffle uniq @{shift->words} ]; } has leftover_words => ( isa => ArrayRef[Str], is => 'ro', traits => ['Array'], handles => { _mark_leftover => 'push', }, clearer => '_reset_leftovers', ); has _grid_status => ( isa => ArrayRef[ArrayRef[Int]], is => 'rw', lazy_build => 1, clearer => '_reset_grid_status', ); sub _build__grid_status { return [ map { [ map { $_ ? $BLACK : $WHITE } @$_ ] } @{shift->grid} ]; } subtype Char, as Str, where { length($_) == 1 }; subtype LetterCell, as Tuple[Int,Char]; has result => ( isa => ArrayRef[ArrayRef[LetterCell]], is => 'ro', lazy_build => 1, clearer => '_reset_result', ); sub _build_result { return [ map { [ map { [0,' '], } @$_ ] } @{shift->grid} ]; } sub _reset { my ($self) = @_; $self->_reset_words_to_use(); $self->_reset_grid_status(); $self->_reset_leftovers(); $self->_reset_result(); } sub fill { my ($self) = @_; $self->_reset(); while ($self->_unfilled() && $self->_has_next_word()) { my $word = $self->_get_next_word(); my ($x,$y,$dir); try { ($x,$y,$dir) = $self->_find_place_for($word) } catch { $self->_mark_leftover($word); next; }; $self->_place_word_at($word,$x,$y,$dir); } } sub _place_word_at { my ($self, $word, $x, $y, $dir) = @_; my $colour = $self->_find_colour_for($x,$y); if ($dir == $HORIZONTAL) { for my $i (0..length($word)-1) { $self->_mark_occupied($x+$i,$y); $self->_put_letter_at(substr($word,$i,1), $x+$i,$y, $colour); } } elsif ($dir == $VERTICAL) { for my $i (0..length($word)-1) { $self->_mark_occupied($x,$y+$i); $self->_put_letter_at(substr($word,$i,1), $x,$y+$i, $colour); } } else { croak "What dir $dir?"; } } sub _mark_occupied { my ($self,$x,$y) = @_; $self->_grid_status->[$y][$x]=0; return; } sub _put_letter_at { my ($self,$letter,$x,$y,$colour) = @_; $self->result()->[$y][$x]=[$colour,$letter]; return; } sub _find_colour_for { my ($self,$x,$y,$dir) = @_; # let's be easy if ($dir == $HORIZONTAL) { return $self->grid->[$y][$x]==$WHITE ? 1 : 3; } else { return $self->grid->[$y][$x]==$WHITE ? 2 : 4; } } sub _find_place_for { my ($self,$word) = @_; my $dir = int(rand(2)) > 1 ? $HORIZONTAL : $VERTICAL; my $length = length $word; my @ret; if ($dir == $HORIZONTAL) { @ret = $self->_find_place_horiz($length); @ret = $self->_find_place_vert($length) unless @ret; } else { @ret = $self->_find_place_vert($length); @ret = $self->_find_place_horiz($length) unless @ret; } die "No place for $word" unless @ret; return @ret; } sub _find_place_horiz { my ($self,$length) = @_; my $cols = scalar @{$self->grid->[0]}; my $col; for my $row (0..$cols) { $col = $self->_find_in_row($row,$length); return ($row,$col,$HORIZONTAL) if defined $col; } return; } sub _find_place_vert { my ($self,$length) = @_; my $rows = scalar @{$self->grid}; my $row; for my $col (0..$rows) { $row = $self->_find_in_col($col,$length); return ($row,$col,$VERTICAL) if defined $row; } return; } sub _find_in_row { my ($self,$row,$length) = @_; my $str = join '',map { $_ ? '*' : ' ' } @{$self->_grid_status->[$row]}; my ($skip) = ($str =~ m{^ (.*?) (?: \*{$length})}x); return length($skip) if defined $skip; return; } sub _find_in_col { my ($self,$col,$length) = @_; my $str = join '',map { $_->[$col] ? '*' : ' ' } @{$self->_grid_status}; my ($skip) = ($str =~ m{^ (.*?) (?: \*{$length})}x); return length($skip) if defined $skip; return; } sub _unfilled { my ($self) = @_; for my $row (@{$self->_grid_status}) { for my $cell (@$row) { return 1 if $cell != 0; } } return 0; } 1;