From b798a75c3304527171c4a8ca5b1ec43bc5b3096a Mon Sep 17 00:00:00 2001 From: dakkar Date: Fri, 28 Oct 2016 12:14:01 +0100 Subject: works! --- dist.ini | 3 +- lib/Imager/QRCode/Fancy.pm | 204 +++++++++++++++++++++++++++++++++++++++++++++ test.pl | 21 +++++ 3 files changed, 227 insertions(+), 1 deletion(-) create mode 100644 lib/Imager/QRCode/Fancy.pm create mode 100644 test.pl diff --git a/dist.ini b/dist.ini index 6081f49..c761365 100644 --- a/dist.ini +++ b/dist.ini @@ -1,7 +1,8 @@ +name = Imager-QRCode-Fancy author = Gianni Ceccarelli license = Perl_5 copyright_holder = Gianni Ceccarelli -copyright_year = 2015 +copyright_year = 2016 [GatherDir] diff --git a/lib/Imager/QRCode/Fancy.pm b/lib/Imager/QRCode/Fancy.pm new file mode 100644 index 0000000..f9e4887 --- /dev/null +++ b/lib/Imager/QRCode/Fancy.pm @@ -0,0 +1,204 @@ +package Imager::QRCode::Fancy; +use 5.010; +use strict; +use warnings; +use Data::QRCode; +use Carp; +use List::AllUtils qw(min); +use Imager; +use Types::Standard qw(Dict InstanceOf ArrayRef CodeRef Optional HashRef is_ArrayRef is_CodeRef); +use Types::Common::Numeric qw(PositiveNum); +use Types::Path::Tiny qw(Path); +use Type::Params qw(compile); +use Type::Utils qw(enum union); +use namespace::clean; + +sub make { + state $check = compile(Dict[ + qr_code => InstanceOf['Data::QRCode'], + image => Optional[union[ + InstanceOf['Imager'], + ArrayRef[InstanceOf['Imager']], + ]], + size => Optional[PositiveNum], + colormap => Optional[HashRef], + module => Optional[union[ + enum[qw(box circle)], + CodeRef, + ]], + dot_scale => Optional[PositiveNum], + ]); + my ($arg) = $check->(@_); + + my $qr = $arg->{qr_code}; + + my @images = is_ArrayRef($arg->{image}) ? @{$arg->{image}} + : defined($arg->{image}) ? $arg->{image} + : (); + + if (not $arg->{size} and not @images) { + croak 'I need a target size, or some images to overlay'; + } + my $size = $arg->{size} || min($images[0]->getwidth,$images[0]->getheight); + + state $module_map = { + box => \&draw_box, + circle => \&draw_circle, + }; + my $module = is_CodeRef($arg->{module}) ? $arg->{module} + : $module_map->{$arg->{module}||'box'}; + + my $colormap = { + empty => 'white', + data => 'black', + format => 'red', + version => 'green', + timing => 'blue', + alignment => 'navy', + finder => 'web green', + misc => 'black', + %{ $arg->{colormap} || {} }, + }; + my $dot_scale = $arg->{dot_scale} || 1/3; + + my $data_size = $qr->width; + $size -= ($size % $data_size); + my $scale = $size / $data_size; + + my $back_image = qr_image($qr,$size,$module,$colormap); + + return $back_image unless @images; + + my $front_image = qr_dots_image($qr,$size,$dot_scale,$module,$colormap); + + my @ret_images; + for my $image (@images) { + my $target = Imager->new(xsize=>$size,ysize=>$size); + $target->paste(src => $back_image); + $target->compose(src => $image); + $target->compose(src => $front_image); + push @ret_images, $target; + } + + if (@ret_images > 1) { + return \@ret_images; + } + else { + return $ret_images[0]; + } +} + +sub qr_image { + my ($qr,$size,$module,$colormap) = @_; + + my $data_size = $qr->width; + my $scale = $size / $data_size; + + my $image = Imager->new(xsize=>$size,ysize=>$size); + $image->box(filled=>1,color=>'white'); + + for my $dx (0..$data_size-1) { + for my $dy (0..$data_size-1) { + my $dp = $qr->data_at($dx,$dy); + + $module->( + image => $image, + bounding_box($dx,$dy,$scale), + color => Imager::Color->new(datapoint2color($dp,$colormap)), + ); + } + } + + return $image; +} + +sub qr_dots_image { + my ($qr,$size,$dot_scale,$module,$colormap) = @_; + + my $data_size = $qr->width; + my $scale = $size / $data_size; + + my $image = Imager->new(xsize=>$size,ysize=>$size,model=>'rgba'); + $image->box(filled=>1,color=>[0,0,0,0]); + + for my $dx (0..$data_size-1) { + for my $dy (0..$data_size-1) { + my $dp = $qr->data_at($dx,$dy); + + my @box = $dp->{in_data} + ? dot_in_bounding_box($dx,$dy,$scale,$dot_scale) + : bounding_box($dx,$dy,$scale); + + $module->( + image => $image, + @box, + color => Imager::Color->new(datapoint2color($dp,$colormap)), + ); + } + } + + return $image; +} + +sub datapoint2color { + my ($dp,$colormap) = @_; + + return $colormap->{empty} unless $dp->{color}; + + for my $k (qw(format version timing alignment finder misc data)) { + next unless $dp->{"in_$k"}; + if (my $v = $colormap->{$k}) { + return $v; + } + } + return $colormap->{misc}; # just in case +} + +sub bounding_box { + my ($x,$y,$size) = @_; + return ( + xmin => $x*$size, ymin => $y*$size, + xmax => $x*$size+$size-1, ymax => $y*$size+$size-1, + ); +} + +sub dot_in_bounding_box { + my ($x,$y,$size,$dot_scale) = @_; + my $dot_size = int($size*$dot_scale); + my $dot_offset = int(($size-$dot_size)/2); + + return ( + xmin => $x*$size+$dot_offset, ymin => $y*$size+$dot_offset, + xmax => $x*$size+$size-$dot_offset, ymax => $y*$size+$size-$dot_offset, + ); +} + +sub draw_box { + my (%args) = @_; + $args{image}->box( + %args, + filled => 1, + ); +} + +sub draw_circle { + my (%args) = @_; + + my $cx = int($args{xmax}+$args{xmin})/2; + my $cy = int($args{ymax}+$args{ymin})/2; + my $radius = min( + $args{xmax}-$cx, + $args{ymax}-$cy, + $cx-$args{xmin}, + $cy-$args{ymin}, + ); + + $args{image}->circle( + x => $cx, y => $cy, + r => $radius, + color => $args{color}, + filled => 1, + ); +} + +1; diff --git a/test.pl b/test.pl new file mode 100644 index 0000000..f8fe405 --- /dev/null +++ b/test.pl @@ -0,0 +1,21 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Data::QRCode; +use Imager::QRCode::Fancy; +use Imager; + +my $string = 'simple test string, but a bit long just in case we get a too-small QR code'; +my $data = Data::QRCode->new( + $string,'H', +); + +my $src_img = Imager->new( + file=>'/tmp/faccione.png', +)->scale(scalefactor=>2,qtype=>'mixing'); + +my $img = Imager::QRCode::Fancy::make({ + qr_code => $data, + image => $src_img, +}); +$img->write(file=>'/tmp/qr2.png'); -- cgit v1.2.3