From 26f864e4b84dfae2364b6e7f42818df2b4ec5f1e Mon Sep 17 00:00:00 2001 From: dakkar Date: Thu, 25 Nov 2010 21:16:35 +0000 Subject: big refactoring --- lib/GridFiller.pm | 313 +++----------------------------------------- lib/GridFiller/Constants.pm | 30 +++++ lib/GridFiller/Result.pm | 144 ++++++++++++++++++++ lib/GridFiller/Status.pm | 198 ++++++++++++++++++++++++++++ lib/GridFiller/Types.pm | 26 ++++ script/qr-color.pl | 6 +- 6 files changed, 416 insertions(+), 301 deletions(-) create mode 100644 lib/GridFiller/Constants.pm create mode 100644 lib/GridFiller/Result.pm create mode 100644 lib/GridFiller/Status.pm create mode 100644 lib/GridFiller/Types.pm diff --git a/lib/GridFiller.pm b/lib/GridFiller.pm index 38bf7f6..44f0a50 100644 --- a/lib/GridFiller.pm +++ b/lib/GridFiller.pm @@ -1,25 +1,15 @@ package GridFiller; use Moose; use namespace::autoclean; -use List::Util qw(shuffle); -use List::MoreUtils qw(uniq); -use MooseX::Types -declare => [qw( GridT Char LetterCell )]; -use MooseX::Types::Moose qw(Str ArrayRef Bool Int); -use MooseX::Types::Structured qw(Tuple); +use GridFiller::Types qw(GridT WordListT); +use GridFiller::Status; +use GridFiller::Result; use Carp; with 'MooseX::Log::Log4perl'; -my $VERTICAL = 1; -my $HORIZONTAL = 2; - -my $BLACK = 1; -my $WHITE = 2; - -subtype GridT, as ArrayRef[ArrayRef[Str]]; - has words => ( - isa => ArrayRef[Str], + isa => WordListT, required => 1, is => 'ro', ); @@ -30,308 +20,35 @@ has grid => ( 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 { - $_ eq '*' ? $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 _reset { - my ($self) = @_; - - $self->_reset_words_to_use(); - $self->_reset_grid_status(); - $self->_reset_leftovers(); - $self->_reset_result(); -} - sub fill { my ($self) = @_; - $self->_reset(); + my $status = GridFiller::Status->new({grid => $self->grid, words => $self->words}); + my $result = GridFiller::Result->new({source_grid => $self->grid}); - while ($self->_unfilled() && $self->_has_next_word()) { - my $word = $self->_get_next_word(); + while ($status->unfilled() && $status->has_next_word()) { + my $word = $status->get_next_word(); $self->log->debug("Placing $word"); - my ($x,$y,$dir) = $self->_find_place_for($word); + my ($x,$y,$dir) = $status->find_place_for($word); if (! defined $x) { $self->log->debug("No place for $word"); - $self->_mark_leftover($word); + $result->mark_leftover($word); next; }; - $self->_place_word_at($word,$x,$y,$dir); + $result->place_word_at($word,$x,$y,$dir); + $status->place_word_at($word,$x,$y,$dir); if ($self->log->is_debug) { - $self->_log_status; - } - } -} - -sub _place_word_at { - my ($self, $word, $x, $y, $dir) = @_; - - my $colour = $self->_find_colour_for($x,$y,$dir); - - $self->log->debug("Placing $word at ${x}:${y} ($dir) in colour $colour"); - - 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); + $self->log->debug($status->to_string); + $self->log->debug($result->to_string); } } - else { - croak "What dir $dir?"; - } -} - -sub _mark_occupied { - my ($self,$x,$y) = @_; - - $self->_grid_status->[$y][$x]=0; - return; -} - -sub _unfilled { - my ($self) = @_; - - for my $row (@{$self->_grid_status}) { - for my $cell (@$row) { - return 1 if $cell != 0; - } - } - return 0; -} - -sub _put_letter_at { - my ($self,$letter,$x,$y,$colour) = @_; - - $self->result()->[$y][$x]=[$colour,$letter]; - return; -} - -{ -my %colourmap = ( - '*' => { - $HORIZONTAL => { - 0 => 1, - 1 => 2, - }, - $VERTICAL => { - 0 => 3, - 1 => 4, - }, - }, - ' ' => { - $HORIZONTAL => { - 0 => 5, - 1 => 6, - }, - $VERTICAL => { - 0 => 7, - 1 => 8, - }, - }, -); - -sub _build_result { - return [ - map { - [ - map { - [ $colourmap{$_}->{$HORIZONTAL}->{0}, ' ' ], - } @$_ - ] - } @{shift->grid} - ]; -} - -sub _find_colour_for { - my ($self,$x,$y,$dir) = @_; - - my $parity = ($dir == $HORIZONTAL) ? ($y % 2) : ($x % 2); - - my $chosen = $colourmap{$self->grid->[$y][$x]}->{$dir}->{$parity}; - - # avoid colour runs - if ( ( $x>0 && $dir == $HORIZONTAL && $self->result->[$y][$x-1][0] == $chosen ) - or - ( $y>0 && $dir == $VERTICAL && $self->result->[$y-1][$x][0] == $chosen ) - ) { - $chosen = $colourmap{$self->grid->[$y][$x]}->{$dir}->{1-$parity}; - } - return $chosen; -} -} - -sub _find_place_for { - my ($self,$word) = @_; - - my $dir = int(rand(2)) ? $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; - } - - return @ret; -} - -sub _find_place_horiz { - my ($self,$length) = @_; - - my $rows = scalar @{$self->grid}; - my $col; - - for my $row (0..$rows-1) { - $col = $self->_find_in_row($row,$length); - return ($col,$row,$HORIZONTAL) if defined $col; - } - return; -} - -sub _find_place_vert { - my ($self,$length) = @_; - - my $cols = scalar @{$self->grid->[0]}; - my $row; - - for my $col (0..$cols-1) { - $row = $self->_find_in_col($col,$length); - return ($col,$row,$VERTICAL) if defined $row; - } - return; -} - -{ -my @symbols=(' ','X','O'); - -sub _do_find { - my ($self,$str,$length) = @_; - - my ($skip) = ($str =~ m{^ (.*?) (?: X{$length} | O{$length} ) }x); - - $self->log->debug(defined $skip ? " skip <$skip>" : " nope"); - - return length($skip) if defined $skip; - return; -} - -sub _find_in_row { - my ($self,$row,$length) = @_; - - my $str = join '',map { $symbols[$_] } @{$self->_grid_status->[$row]}; - - $self->log->debug("row $row = $str"); - - return $self->_do_find($str,$length); -} - -sub _find_in_col { - my ($self,$col,$length) = @_; - my $str = join '',map { $symbols[$_->[$col]] } @{$self->_grid_status}; - - $self->log->debug("col $col = $str"); - - return $self->_do_find($str,$length); -} - -sub _log_status { - my ($self) = @_; - - my $str = "\n"; - - my $rows = scalar @{$self->grid}; - - for my $row (0..$rows-1) { - for my $cell (@{$self->_grid_status->[$row]}) { - $str .= $symbols[$cell]; - } - $str .= ' '; - for my $cell (@{$self->result->[$row]}) { - $str .= $cell->[1] eq ' ' ? '.' : $cell->[1]; - } - $str .= "\n"; - } - $self->log->debug($str); -} + return $result; } 1; diff --git a/lib/GridFiller/Constants.pm b/lib/GridFiller/Constants.pm new file mode 100644 index 0000000..d707782 --- /dev/null +++ b/lib/GridFiller/Constants.pm @@ -0,0 +1,30 @@ +package GridFiller::Constants; +use strict; +use warnings; +use Scalar::Readonly qw(readonly_on); +use namespace::autoclean; +require Exporter; + +our @ISA='Exporter'; +our @EXPORT=(); +our @EXPORT_OK=qw($HORIZONTAL $VERTICAL $BLACK $WHITE $NOTHING); +our %EXPORT_TAGS=( + colours => [qw($BLACK $WHITE $NOTHING)], + directions => [qw($HORIZONTAL $VERTICAL)], + all => [@EXPORT_OK], +); + +our $VERTICAL = 1; +our $HORIZONTAL = 2; + +our $NOTHING = 0; +our $BLACK = 1; +our $WHITE = 2; + +readonly_on($VERTICAL); +readonly_on($HORIZONTAL); +readonly_on($NOTHING); +readonly_on($BLACK); +readonly_on($WHITE); + +1; diff --git a/lib/GridFiller/Result.pm b/lib/GridFiller/Result.pm new file mode 100644 index 0000000..56ae3c2 --- /dev/null +++ b/lib/GridFiller/Result.pm @@ -0,0 +1,144 @@ +package GridFiller::Result; +use Moose; +use namespace::autoclean; +use GridFiller::Types qw(GridT ResultT WordListT); +use GridFiller::Constants ':directions'; +use Carp; + +with 'MooseX::Log::Log4perl'; + +has leftover_words => ( + isa => WordListT, + is => 'ro', + default => sub { [ ] }, + traits => ['Array'], + handles => { + mark_leftover => 'push', + }, +); + +has grid => ( + isa => ResultT, + is => 'ro', + lazy_build => 1, +); + +has source_grid => ( + isa => GridT, + is => 'ro', +); + +{ +my %colourmap = ( + '*' => { + $HORIZONTAL => { + 0 => 1, + 1 => 2, + }, + $VERTICAL => { + 0 => 3, + 1 => 4, + }, + }, + ' ' => { + $HORIZONTAL => { + 0 => 5, + 1 => 6, + }, + $VERTICAL => { + 0 => 7, + 1 => 8, + }, + }, +); + +sub _build_grid { + return [ + map { + [ + map { + [ $colourmap{$_}->{$HORIZONTAL}->{0}, ' ' ], + } @$_ + ] + } @{shift->source_grid} + ]; +} + +sub _find_colour_for { + my ($self,$x,$y,$dir) = @_; + + my $parity = ($dir == $HORIZONTAL) ? ($y % 2) : ($x % 2); + + my $chosen = $colourmap{$self->source_grid->[$y][$x]}->{$dir}->{$parity}; + + # avoid colour runs + if ( ( $x>0 && $dir == $HORIZONTAL && $self->grid->[$y][$x-1][0] == $chosen ) + or + ( $y>0 && $dir == $VERTICAL && $self->grid->[$y-1][$x][0] == $chosen ) + ) { + $chosen = $colourmap{$self->source_grid->[$y][$x]}->{$dir}->{1-$parity}; + } + + if (!defined $chosen) { + $self->log->warn(sprintf(q{Can't decide on colour for %d:%d (%s) direction %d}, + $x,$y,$self->source_grid->[$y][$x],$dir)); + } + + return $chosen; +} +} + +sub place_word_at { + my ($self, $word, $x, $y, $dir) = @_; + + my $colour = $self->_find_colour_for($x,$y,$dir); + + $self->log->debug("Placing $word at ${x}:${y} ($dir) in colour $colour"); + + if ($dir == $HORIZONTAL) { + for my $i (0..length($word)-1) { + $self->_put_letter_at(substr($word,$i,1), + $x+$i,$y, + $colour); + } + } + elsif ($dir == $VERTICAL) { + for my $i (0..length($word)-1) { + $self->_put_letter_at(substr($word,$i,1), + $x,$y+$i, + $colour); + } + } + else { + croak "What dir $dir?"; + } +} + +sub _put_letter_at { + my ($self,$letter,$x,$y,$colour) = @_; + + croak "undef colour" unless defined $colour; + croak "undef letter" unless defined $letter; + + $self->grid->[$y][$x]=[$colour,$letter]; + return; +} + +sub to_string { + my ($self) = @_; + + my $rows = scalar @{$self->grid}; + + my $str; + + for my $row (0..$rows-1) { + for my $cell (@{$self->grid->[$row]}) { + $str .= $cell->[1] eq ' ' ? '.' : $cell->[1]; + } + $str .= "\n"; + } + + return $str; +} + +1; diff --git a/lib/GridFiller/Status.pm b/lib/GridFiller/Status.pm new file mode 100644 index 0000000..873d252 --- /dev/null +++ b/lib/GridFiller/Status.pm @@ -0,0 +1,198 @@ +package GridFiller::Status; +use Moose; +use namespace::autoclean; +use List::Util qw(shuffle); +use List::MoreUtils qw(uniq); +use GridFiller::Types qw(WordListT GridStatusT); +use GridFiller::Constants ':all'; +use Carp; + +with 'MooseX::Log::Log4perl'; + +has words_to_use => ( + isa => WordListT, + traits => ['Array'], + handles => { + has_next_word => 'count', + get_next_word => 'shift', + }, + is => 'rw', +); + +has grid_status => ( + isa => GridStatusT, + is => 'rw', +); + +around BUILDARGS => sub { + my ($orig, $class, $args, @rest) = @_; + + if (exists $args->{words} && exists $args->{grid}) { + $args->{words_to_use} = _munge_words_to_use(delete $args->{words}); + $args->{grid_status} = _munge_grid_status(delete $args->{grid}); + } + + return $class->$orig($args,@rest); +}; + +sub _munge_words_to_use { + my $words=shift; + # clone initial word list + return [ shuffle uniq @$words ]; +} + +sub _munge_grid_status { + my $grid=shift; + return [ + map { + [ + map { + $_ eq '*' ? $BLACK : $WHITE + } @$_ + ] + } @$grid + ]; +} + +sub place_word_at { + my ($self, $word, $x, $y, $dir) = @_; + + $self->log->debug("Marking <$word> occupied at ${x}:${y} ($dir)"); + + if ($dir == $HORIZONTAL) { + for my $i (0..length($word)-1) { + $self->_mark_occupied($x+$i,$y); + } + } + elsif ($dir == $VERTICAL) { + for my $i (0..length($word)-1) { + $self->_mark_occupied($x,$y+$i); + } + } + else { + croak "What dir $dir?"; + } +} + +sub _mark_occupied { + my ($self,$x,$y) = @_; + + $self->grid_status->[$y][$x]=$NOTHING; + return; +} + +sub unfilled { + my ($self) = @_; + + for my $row (@{$self->grid_status}) { + for my $cell (@$row) { + return 1 if $cell != $NOTHING; + } + } + return 0; +} + +sub find_place_for { + my ($self,$word) = @_; + + my $dir = int(rand(2)) ? $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; + } + + return @ret; +} + +sub _find_place_horiz { + my ($self,$length) = @_; + + my $rows = scalar @{$self->grid_status}; + my $col; + + for my $row (0..$rows-1) { + $col = $self->_find_in_row($row,$length); + return ($col,$row,$HORIZONTAL) if defined $col; + } + return; +} + +sub _find_place_vert { + my ($self,$length) = @_; + + my $cols = scalar @{$self->grid_status->[0]}; + my $row; + + for my $col (0..$cols-1) { + $row = $self->_find_in_col($col,$length); + return ($col,$row,$VERTICAL) if defined $row; + } + return; +} + +{ +my %symbols=( + $NOTHING => ' ', + $BLACK => 'X', + $WHITE => 'O', +); + +sub _do_find { + my ($self,$str,$length) = @_; + + my ($skip) = ($str =~ m{^ (.*?) (?: X{$length} | O{$length} ) }x); + + $self->log->debug(defined $skip ? " skip <$skip>" : " nope"); + + return length($skip) if defined $skip; + return; +} + +sub _find_in_row { + my ($self,$row,$length) = @_; + + my $str = join '',map { $symbols{$_} } @{$self->grid_status->[$row]}; + + $self->log->debug("row $row = $str"); + + return $self->_do_find($str,$length); +} + +sub _find_in_col { + my ($self,$col,$length) = @_; + + my $str = join '',map { $symbols{$_->[$col]} } @{$self->grid_status}; + + $self->log->debug("col $col = $str"); + + return $self->_do_find($str,$length); +} + +sub to_string { + my ($self) = @_; + + my $rows = scalar @{$self->grid_status}; + + my $str; + + for my $row (0..$rows-1) { + for my $cell (@{$self->grid_status->[$row]}) { + $str .= $symbols{$cell}; + } + $str .= "\n"; + } + + return $str; +} +} + +1; diff --git a/lib/GridFiller/Types.pm b/lib/GridFiller/Types.pm new file mode 100644 index 0000000..fb7fc9b --- /dev/null +++ b/lib/GridFiller/Types.pm @@ -0,0 +1,26 @@ +package GridFiller::Types; +use MooseX::Types -declare => + [qw( + GridT GridStatusT + CharT LetterCellT ResultT + WordListT + )]; +use MooseX::Types::Moose qw(Str ArrayRef Bool Int); +use MooseX::Types::Structured qw(Tuple); + +subtype CharT, + as Str, + where { length($_) == 1 }; + +subtype LetterCellT, + as Tuple[Int,CharT]; + +subtype GridT, as ArrayRef[ArrayRef[Str]]; + +subtype GridStatusT, as ArrayRef[ArrayRef[Int]]; + +subtype WordListT, as ArrayRef[Str]; + +subtype ResultT, as ArrayRef[ArrayRef[LetterCellT]]; + +1; diff --git a/script/qr-color.pl b/script/qr-color.pl index 35f22dd..8d78a2f 100644 --- a/script/qr-color.pl +++ b/script/qr-color.pl @@ -7,7 +7,7 @@ use TextPrinter::StarGrid; use GridFiller; use Path::Class; use Log::Log4perl qw(:easy); -Log::Log4perl->easy_init($INFO); +Log::Log4perl->easy_init($DEBUG); my $data='MECARD:N:Ceccarelli,Gianni;TEL:+447564023056;EMAIL:dakkar@thenautilus.net;URL:http://www.thenautilus.net/contacts/;NICKNAME:dakkar;;'; @@ -23,9 +23,9 @@ my @words = grep { length($_) > 2 } my $filler=GridFiller->new({words=>\@words,grid=>$arr}); -$filler->fill; +my $result = $filler->fill; -TextPrinter::ColourGrid->new->draw_whole($filler->result,1); +TextPrinter::ColourGrid->new->draw_whole($result->grid,1); print "\n\n"; -- cgit v1.2.3