1 files changed, 204 insertions, 0 deletions
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;