From 257d5834801afe7d9ddffa81f78d6b7f8d08822a Mon Sep 17 00:00:00 2001 From: dakkar Date: Thu, 25 Nov 2010 22:45:20 +0000 Subject: scaler, and __DATA__ also, better validation --- lib/GridFiller.pm | 15 ++++-- lib/GridFiller/Scaler.pm | 32 +++++++++++++ lib/GridFiller/Status.pm | 18 ++++++-- lib/GridFiller/Types.pm | 2 +- script/qr-color.pl | 116 +++++++++++++++++++++++++++++++++++++++++++---- 5 files changed, 165 insertions(+), 18 deletions(-) create mode 100644 lib/GridFiller/Scaler.pm diff --git a/lib/GridFiller.pm b/lib/GridFiller.pm index 2b92285..dbe7010 100644 --- a/lib/GridFiller.pm +++ b/lib/GridFiller.pm @@ -6,6 +6,7 @@ use GridFiller::Status; use GridFiller::Result; use GridFiller::Chooser::Smarter; use Carp; +use Class::MOP; with 'MooseX::Log::Log4perl'; @@ -22,11 +23,19 @@ has grid => ( ); sub fill { - my ($self) = @_; + my ($self,$args) = @_; + + my $status = GridFiller::Status->new({ + grid => $self->grid, + words => $self->words, + mode => $args->{mode} + }); + + my $chooser_class = 'GridFiller::Chooser::'.($args->{chooser} || 'Random'); + Class::MOP::load_class($chooser_class); - my $status = GridFiller::Status->new({grid => $self->grid, words => $self->words}); my $result = GridFiller::Result->new({source_grid => $self->grid}); - my $chooser = GridFiller::Chooser::Smarter->new({status => $status}); + my $chooser = $chooser_class->new({status => $status}); while ($status->unfilled() && $status->has_next_word()) { my $word = $status->get_next_word(); diff --git a/lib/GridFiller/Scaler.pm b/lib/GridFiller/Scaler.pm new file mode 100644 index 0000000..21d11c9 --- /dev/null +++ b/lib/GridFiller/Scaler.pm @@ -0,0 +1,32 @@ +package GridFiller::Scaler; +use Moose; +use namespace::autoclean; +use GridFiller::Types qw(GridT); +use MooseX::Types::Moose qw(Int); +use Carp; +use MooseX::Params::Validate 'pos_validated_list'; + +sub scale { + shift; # class + my ($input_grid,$scale) = pos_validated_list( + \@_, + { isa => GridT }, + { isa => Int }, + ); + + my @output_grid; + + for my $row (@$input_grid) { + my @out_row; + + for my $cell (@$row) { + push @out_row, $cell for 1..$scale; + } + + push @output_grid,[@out_row] for 1..$scale; + } + + return \@output_grid; +} + +1; diff --git a/lib/GridFiller/Status.pm b/lib/GridFiller/Status.pm index 4f55c6f..b14f870 100644 --- a/lib/GridFiller/Status.pm +++ b/lib/GridFiller/Status.pm @@ -6,6 +6,7 @@ use List::MoreUtils qw(uniq); use GridFiller::Types qw(WordListT GridStatusT); use GridFiller::Constants ':all'; use Carp; +use feature 'switch'; with 'MooseX::Log::Log4perl'; @@ -30,7 +31,7 @@ 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->{words_to_use} = _munge_words_to_use(delete $args->{words},$args); $args->{grid_status} = _munge_grid_status(delete $args->{grid}); } @@ -38,13 +39,22 @@ around BUILDARGS => sub { }; sub _munge_words_to_use { - my $words=shift; + my ($words,$args) = @_; # clone initial word list - return [ shuffle uniq @$words ]; + + my $mode = delete $args->{mode} || 'random'; + + given ($mode) { + when ('random') { return [ shuffle uniq @$words ] } + when ('given') { return [ uniq @$words ] } + when ('longest') { return [ sort {length($b) <=> length($a)} uniq @$words ] } + when ('shortest') { return [ sort {length($a) <=> length($b)} uniq @$words ] } + default { croak "Unknown mode $mode" } + } } sub _munge_grid_status { - my $grid=shift; + my ($grid) = @_; return [ map { [ diff --git a/lib/GridFiller/Types.pm b/lib/GridFiller/Types.pm index fb7fc9b..8beb715 100644 --- a/lib/GridFiller/Types.pm +++ b/lib/GridFiller/Types.pm @@ -5,7 +5,7 @@ use MooseX::Types -declare => CharT LetterCellT ResultT WordListT )]; -use MooseX::Types::Moose qw(Str ArrayRef Bool Int); +use MooseX::Types::Moose qw(Str ArrayRef Int); use MooseX::Types::Structured qw(Tuple); subtype CharT, diff --git a/script/qr-color.pl b/script/qr-color.pl index 8d78a2f..5841e0f 100644 --- a/script/qr-color.pl +++ b/script/qr-color.pl @@ -1,15 +1,21 @@ #!/usr/bin/perl +use utf8; use strict; use warnings; use Text::QRCode; use TextPrinter::ColourGrid; use TextPrinter::StarGrid; use GridFiller; -use Path::Class; +use GridFiller::Scaler; +use feature 'say'; +use open ':std',':locale'; use Log::Log4perl qw(:easy); -Log::Log4perl->easy_init($DEBUG); +Log::Log4perl->easy_init($INFO); -my $data='MECARD:N:Ceccarelli,Gianni;TEL:+447564023056;EMAIL:dakkar@thenautilus.net;URL:http://www.thenautilus.net/contacts/;NICKNAME:dakkar;;'; +binmode DATA,':utf8'; + +my $data = do { local $/="\n__WORDS__\n";my $x=;chomp $x;$x }; +my @words = ;chomp @words; my $qr=Text::QRCode->new( level=>'H', @@ -18,15 +24,105 @@ my $qr=Text::QRCode->new( my $arr=$qr->plot($data); -my @words = grep { length($_) > 2 } - file('/usr/share/dict/propernames')->slurp(chomp=>1); - -my $filler=GridFiller->new({words=>\@words,grid=>$arr}); +my $filler=GridFiller->new({ + words=>\@words, + grid=> GridFiller::Scaler->scale($arr,2), +}); -my $result = $filler->fill; +my $result = $filler->fill({ + mode => 'longest', + chooser => 'Smarter', +}); TextPrinter::ColourGrid->new->draw_whole($result->grid,1); -print "\n\n"; +say ''; +say 'Leftovers:'; +say for @{$result->leftover_words}; -TextPrinter::StarGrid->new->draw_whole($arr,1); +__DATA__ +MECARD:N:Ceccarelli,Gianni;TEL:+447564023056;EMAIL:dakkar@thenautilus.net;URL:http://www.thenautilus.net/contacts/;NICKNAME:dakkar;; +__WORDS__ +Lois McMaster Bujold +Kage Baker +David Weber +Robert Heinlein +Douglas Adams +Neal Stephenson +Lewis Carrol +Terry Pratchett +Jorge Luis Borges +Frank Herbert +Alessandro Bergonzoni +Stefano Benni +Jules Verne +Neil Gaiman +H.G. Wells +Isaac Asimov +Arthur C. Clarke +Philip K. Dick +JRR Tolkien +Ed Wood +Tim Burton +Monty Python +Terry Gilliam +Orson Welles +Peter Greenaway +David Cronenberg +Stanley Kubrick +Joss Whedon +Quentin Tarantino +Mel Brooks +MIYAZAKI Hayao +OSHII Mamoru +ANNO Hideaki +Alan Moore +KITOH Mohiro +TEZUKA Osamu +YUKI Masami +URASAWA Naoki +YUKINOBU Hoshino +yoshitoshi ABe +SHIROW Masamune +Amanda Palmer +Marian Call +Jonathan Coulton +The Flaming Lips +The Pillows +Nightwish +Stefano Nosei +Jethro Tull +KANNO Yoko +Franco Battiato +Enya +Helloween +Mike Oldfield +Alan Parsons Project +Emerson, Lake & Palmer +Fabrizio De André +Kenji Kawai +David Bowie +Girl Genius +Gunnerkrigg Court +Cyrano de Bergerac +Watership Down +RHPS +Thunderbirds +Doctor Who +The Twilight Zone +Blade Runner +Forbidden Planet +Cowboy Bebop +FLCL +Gundam +Macross +Fushigi no umi no Nadia +SUZUMIYA Haruhi +Cutey Honey +Dennou Coil +Haibane Renmei +Star Trek +D&D +Go +Shogi +Perl -- cgit v1.2.3