Re^2: Shameless plug and QR japh

[cavac]

After thinking about the problem a bit, you could, in theory, use "colspan" for a simplistic run-length compression:

#!/usr/bin/env perl

use strict;
use warnings;

use Text::QRCode;

my $qr = Text::QRCode->new()->plot("YAPH");

my $pixelsize = 15;
my $black = '<td width="' . $pixelsize . 'px" height="' . $pixelsize .
+ 'px" bgcolor="black"></td>';
my $white = '<td width="' . $pixelsize . 'px" height="' . $pixelsize .
+ 'px" bgcolor="white"></td>';
print '<table border="0">', "\n";
my $firstline = 1;
my $saved = 0;
foreach my $line (@{$qr}) {
    print "<tr>";
    my $firstelem = 1;
    my $width = 0;
    my $color = '';
    foreach my $elem (@{$line}) {
        if($firstline) {
            # First line, no compression. This sets the correct column
+ width for all columns
            if($elem eq '*') {
                print $black;
            } else {
                print $white;
            }
        } else {
            if($firstelem) {
                $color = $elem;
                $width = 1;
                $firstelem = 0;
            } else {
                if($color eq $elem) {
                    $width++;
                    $saved++;
                } else {
                    my $realcol = 'white';
                    if($elem eq '*') {
                        $realcol = 'black';
                    }
                    print '<td colspan="' . $width . '" height="' . $p
+ixelsize . 'px" bgcolor="' . $realcol . '"></td>';
                    $color = $elem;
                    $width = 1;
                }
            }
        }
        if(!$firstline) {
            # print last element of the current line
            my $realcol = 'white';
            if($elem eq '*') {
                $realcol = 'black';
            }
            print '<td colspan="' . $width . '" height="' . $pixelsize
+ . 'px" bgcolor="' . $realcol . '"></td>';
        }

        $firstline = 0;

    }
    print "</tr>\n";
}
print '<\table">', "\n";
print '<!-- run length compression saved ', $saved, ' table fields-->'
+, "\n";

I've run into a formatting problem doing this (probably some stupid oversight on my part), but it might be worth the effort if you need to "compress" your code to the 64K limit in PerlMonks. See What is PerlMonks post size limit?

[cavac]

After a bit of tinkering and bugfixing, the solution is:

#!/usr/bin/env perl

use strict;
use warnings;

use Text::QRCode;

my $qr = Text::QRCode->new()->plot("YAPH");

my $pixelsize = 15;
print '<table border="0" cellspacing="0" cellpadding="0">', "\n";
my $firstline = 1;
my $saved = 0;
foreach my $line (@{$qr}) {
    print "<tr>";
    my $firstelem = 1;
    my $width = 0;
    my $color = '';
    my $firstblockinline = 1;
    foreach my $elem (@{$line}) {
        if($firstline) {
            # First line, no compression. This sets the correct column
+ width for all columns
            my $realcol = mapColor($elem);
            print '<td width="' . $pixelsize . 'px" height="' . $pixel
+size . 'px" bgcolor="' . $realcol . '"></td>';
        } else {
            if($firstelem) {
                $color = $elem;
                $width = 1;
                $firstelem = 0;
            } else {
                if($color eq $elem) {
                    $width++;
                    $saved++;
                } else {
                    my $realcol = mapColor($color);
                    print '<td colspan="' . $width . '" ';
                    if($firstblockinline) {
                        print 'height="' . $pixelsize . 'px" ';
                        $firstblockinline = 0;
                    }
                    print 'bgcolor="' . $realcol . '"></td>';
                    $color = $elem;
                    $width = 1;
                }
            }
        }
    }
    if(!$firstline) {
        # print last element of the current line
        my $realcol = mapColor($color);
        print '<td colspan="' . $width . '" height="' . $pixelsize . '
+px" bgcolor="' . $realcol . '"></td>';
    }
    print "</tr>\n";
    $firstline = 0;
}
print '</table>', "\n";
print '<!-- run length compression saved ', $saved, ' table fields-->'
+, "\n";

sub mapColor {
    my ($inval) = @_;

    if($inval eq '*') {
        return 'black';
    }
    return 'white';
}

Which means i can turn it into this:

#!/usr/bin/env perl

use strict;
use warnings;

use GD;
my $img = GD::Image->newFromPng('tentacle.png', 0);
my ($w, $h) = $img->getBounds();


my $pixelsize = 15;
print '<table border="0" cellspacing="0" cellpadding="0">', "\n";
my $saved = 0;
for(my $y = 0; $y < $h; $y++) {
    print "<tr>";
    my $firstelem = 1;
    my $width = 0;
    my $color = '';
    my $firstblockinline = 1;
    for(my $x = 0; $x < $w; $x++) {
        my $index = $img->getPixel($x, $y);
        my ($r,$g,$b) = $img->rgb($index);
        my $elem = sprintf("#%02X%02X%02X", $r, $g, $b);
        if(!$y) {
            # First line, no compression. This sets the correct column
+ width for all columns
            print '<td width="' . $pixelsize . 'px" height="' . $pixel
+size . 'px" bgcolor="' . $elem . '"></td>';
        } else {
            if($firstelem) {
                $color = $elem;
                $width = 1;
                $firstelem = 0;
            } else {
                if($color eq $elem) {
                    $width++;
                    $saved++;
                } else {
                    print '<td colspan="' . $width . '" ';
                    if($firstblockinline) {
                        print 'height="' . $pixelsize . 'px" ';
                        $firstblockinline = 0;
                    }
                    print 'bgcolor="' . $color . '"></td>';
                    $color = $elem;
                    $width = 1;
                }
            }
        }
    }
    if($y) {
        # print last element of the current line
        print '<td colspan="' . $width . '" height="' . $pixelsize . '
+px" bgcolor="' . $color . '"></td>';
    }
    print "</tr>\n";
}
print '</table>', "\n";
print '<!-- run length compression saved ', $saved, ' table fields-->'
+, "\n";

Which results in the ability to display (low res) colorful images in PerlMonks, using nothing but allowed HTML tags:

<!-- run length compression saved 709 table fields-->