#!/usr/bin/perl
### ntXAERLX.perl  -*- Perl -*-
## Prepare a page with QR code labels using Imager.

### Ivan Shmakov, 2020

## To the extent possible under law, the author(s) have dedicated
## all copyright and related and neighboring rights to this software
## to the public domain worldwide.  This software is distributed
## without any warranty.

## You should have received a copy of the CC0 Public Domain Dedication
## along with this software.  If not, see
## <http://creativecommons.org/publicdomain/zero/1.0/>.

### History:

## 0.1  2020-03-01
##      Initial revision.

### Code:
use common::sense;
use English qw (-no_match_vars);

require Data::Dump;
require Imager;
require Imager::QRCode;

our $reduce
    = ($ENV{"REDUCE"} =~ m {^[1-9][0-9]*$} ? $ENV{"REDUCE"} : 5);
our ($black, $white, $clear)
    = map { Imager::Color->new ($_); } (qw (#000 #fff #0000));
my $font_file
    =  ($ENV{"FONTFILE"}
        // "/usr/share/fonts/truetype/ttf-bitstream-vera/Vera.ttf");
our $font
    = Imager::Font->new  ("color" => $black, "file" => $font_file)
                          or die ("*** ", $!, "***");
# warn ("D: " . Data::Dump::dump ($font), "\n") if (0);
our $qr_coder
    = Imager::QRCode->new  (qw (version 0 level M),
                            "size" => int (15 / $reduce),
                            qw (mode 8-bit casesensitive 1));

my $ic
    = Imager->new ("xsize" => 9, "ysize" => 9, "channels" => 1);
$ic->box ("color" => $white, "filled" => 1);
$ic->line ("color" => $black, qw (x1 4 y1 0 x2 4 y2 8));
$ic->line ("color" => $black, qw (x1 0 y1 4 x2 8 y2 4));
$ic = $ic->scale ("scalefactor" => int (20 / $reduce), qw (qtype preview));
# $ic->write ("fh" => \*STDOUT, "type" => "pnm") if (0);

## FIXME: ->align_string does not work with grayscale (channels 1) images
my $il
    = Imager->new ("xsize" => int (5100 / 4 / $reduce),
                   "ysize" => int (211 / $reduce),
                   qw (channels 4));
do {
    $il->align_string  ("x" => ($il->getwidth () >> 1),
                        "y" => ($il->getheight () * .75),
                        "font" => $font, "color" => $black,
                        "size" => int (137 / $reduce),
                        qw (halign center string Checked));
    # $il = $il->to_paletted (qw (make_colors mono)) if (0);
};

my $im
    = Imager->new ("xsize" => 5100 / $reduce, "ysize" => 6600 / $reduce,
                   qw (channels 1));
$im->box ("color" => $white, "filled" => 1);

my ($xs, $ys, $xa, $ya)
    =  ($im->getwidth (), $im->getheight (),
        $ic->getwidth (), $ic->getheight ());
for (my $i = 0; $i < 25; $i++) {
    my ($x, $y)
        =  ((($i % 5) * $xs / 2 - $xa) / 2,
            (int ($i / 5) * $ys / 2 - $ya) / 2);
    warn ("D: ", sprintf ("%+d%+d", $x, $y), "\n") if (0);
    $im->compose ("src" => $ic, "left" => $x, "top" => $y);
}

my ($xb, $yb)
    =  ($il->getwidth (), $il->getheight ());
for (my $i = 0; $i < 16; $i++) {
    my ($x, $y, $yq)
        =  ((($i % 4) + .5) * $xs / 4,
            (int ($i / 4) + .57)  * $ys / 4,
            (int ($i / 4) + .2)   * $ys / 4);
    my ($xl, $yl)
        = ($x - ($xb >> 1), $y - ($yb >> 1));
    my $uri_s
        = ($i < @ARGV ? $ARGV[$i] : "http://example.net/");
    warn ("D: ", sprintf ("%+d%+d", $x, $y), ": ", $uri_s, "\n") if (0);

    $im->circle ("x" => $x, "y" => $y, "r" => 5, "color" => $black) if (0);
    $im->compose ("src" => $il, "left" => $xl, "top" => $yl);

    my $iu = $il->copy ();
    $iu->box ("color" => $clear, "filled" => 1);
    my @s
        = ($uri_s =~ m { ^ (.{7,}?) (/.{7,})? $ }x);
    warn ("D: ", join (", ", @s)) if (0);
    pop (@s)
        unless ($s[$#s] ne "");
    my @up
        =  ("x" => ($iu->getwidth () >> 1),
            qw (halign center),
            "font"  => $font, "color" => $black,
            "size"  => int ((@s < 2 ? 107 : 71) / $reduce));
    warn ("D: " . Data::Dump::dump (\@up)) if (0);
    $iu->align_string  (@up,
                        "y" => ($iu->getheight () * (@s < 2 ? .75 : .4)),
                        "string"  => $s[0]);
    $iu->align_string  (@up,
                        "y" => ($iu->getheight () * .85),
                        "string"  => $s[1])
        if (@s > 1);
    $im->compose ("src" => $iu, "left" => $xl,
                  "top" => $yl - $il->getheight ());

    my $qr
        = $qr_coder->plot ($uri_s); 
    $im->compose ("src"   => $qr,
                  "left"  => ($x  - ($qr->getwidth () >> 1)),
                  "top"   => ($yq - ($qr->getheight () >> 1)));
}

warn ("D: " . Data::Dump::dump ($im), "\n") if (0);

$im->write ("fh" => \*STDOUT, "type" => "pnm");

### ntXAERLX.perl ends here