Valid HTML 4.0! Valid CSS!

banner.pl - beinahe ein JaPh

von Thomas Bätzler, <thomas@baetzler.de>

Ein Vortrag für die Perl-Mongers Karlsruhe (wenn es sie endlich mal gibt :-))

Perl wird ja oft vorgeworfen, unstrukturiert und unübersichtlich zu sein. Das folgende kleine Programm kann diesen Vorurteilen sicher Vorschub leisten:

#!/usr/bin/perl -w
use strict;my($t,$z,$c,$d)=('yy32:yy64:y9:y252:y14:248:yy128:31:yyy15:34:yy'.
'194:yy-1:68:3:96:y4:24:y0:y16:yyy192:7:y8:yyy2:160:18:yy20:33:224:17','=X]'.
'`YSG%U4PRI-N[GD.55&F+9SG.+8TU4\A`V[R\'-N\ARJM%"PPPZ\ARJL`X888871B*JQZ!AQ.('.
'HN-&$HT4I55,,J1;.<YQ;&FJT4+###KR\'*JC3K8888876:N\>@<YSBZK!$$>)89$QB0:J83"8'.
'94E*55&G6PPPPPNLU4\A`S-G.[:K`P,"JC3%LYSG%BJ5)54:=;####"ZSBO/;');$t=~s/y/&b?
/g;sub b{if(!$c){$c=6;$d=ord(substr$z,0,1,"")-32}$c--;($d*=2)&64}for(1..176){
$_=unpack"B16",pack("CC",eval$t,eval$t);tr/01/ #/;print"$_\n";}

(Ausgabe anzeigen)

Meine Absicht war, ein kleines Perl-Programm zu schreiben, das ich dann als Signatur für Mail und/oder News verwenden könnte - ein JaPh, das meine EMail-Adresse als Banner ausgeben würde. Mit insgesamt 7 Zeilen war aber zumindest die Maximalgröße für eine Signatur überschritten. Da ich die Idee aber sonsten ganz witzig fand, möchte ich sie im Detail vorstellen.

Von der Idee zum JaPh

Der ersten Schritt auf meinem Weg bestand darin, eine Quell-Bitmap für meinen Bannertext zu erstellen. In den guten alten Tagen der Home-Computer konnten Benutzer in der Regel auf die Daten des internen Character-Generators zugreifen, und aus diesen Daten und einem beliebigen Text dann ein Banner generieren. Heutzutage hat man es nicht mehr ganz so einfach, so daß ich für eine Grafik als Eingabe-Format entschieden hatte:

Grafik: thomas@baetzler.de

Eingabegrafix, 2x skaliert

Mit dem GD-Modul von Perl kann man PNG-Dateien wunderbar einfach lesen und analysieren, so daß ich schnell ein erstes Programm geschrieben hatte:

#!/usr/bin/perl -w

use strict;
use GD;

# pathname of the source file
my $pngfile = 'e:/thb.png';

# try to open it; bail aout if that fails.
open( PNG, $pngfile ) or die "Can't open '$pngfile': $!\n";

# try to read it as a PNG file.
my $img = GD::Image->newFromPng(\*PNG)
          or die "'$pngfile' is not a valid PNG file!\n";

close( PNG );

# get image size
my( $width, $height ) = $img->getBounds();

# height must be 16
if( $height != 16 ){
  die "Image height must be 16, not $height pixels!\n";
}

# get color index of black
my $black = $img->colorExact(0,0,0);

# this is where we collect the bitmap
my @data;

# iterate over all pixel columns
for( my $x = 0; $x < $width; $x++ ){

  my( $b1, $b2 );

  # encode set (black) pixels as '1' bit in our data bytes
  for( my $y = 7; $y >= 0; $y-- ){
    $b1 += $img->getPixel($x,$y + 8) == $black ? 2**$y : 0;
    $b2 += $img->getPixel($x,$y) == $black ? 2**$y : 0;
  }

  # save data for later use
  push @data, $b1, $b2;
}

# verification: output data as rows
{
  my @temp = @data;
  while( @temp ){
    # format data bytes into bit representation
    my $line = sprintf "%08b%08b\n", splice( @temp, 0, 2 );
    # replace 0 and 1 with 'nicer' characters and print it
    $line =~ tr/01/ #/;
    print $line;
  }
}

Für einen JaPh war der Inhalt des Array @data aber viel groß - es handelte sich ja um 352 Zahlen, bzw. über 900 Zeichen Definition für das Array alleine. Ich mußte deshalb einen Weg finden, die Informationen kompakter darzustellen.

Datenkompression

Da in meinen Quelldaten einige Zahlenwerte sehr häufig auftraten, während andere nur sehr selten vorkamen, habe ich mich für eine Kompression nach dem Huffman-Algorithmus (siehe z.B. die Seiten Huffman Entropie-Coder und Adaptiver Huffman-Coder auf der Homepage von Paul Haller Consulting) entschieden.

Da ich diesen Algorithmus selbst noch nie umgesetzt hatte, war ich zudem neugierig, ob bzw. wie ich die Theorie umsetzen könnte.

Mit den Code-Zeilen

my %huff;

foreach my $byte ( @data ){
  $huff{$byte}++;
}

$huff{'undef'} = 0;

hatte ich aus dem Daten-Array schnell einen Hash aufgebaut, dessen Schlüssel die Zahlen selbst und dess Werte ihre Häufigkeit waren. Mit der letzten Zuordnung hatte ich zudem auch ein Element für meinen End-of-File-Indikator dazugenommen.

Nach dem Huffman-Algorithmus wird der Häufigkeits-Baum aufgebaut, indem aus einer Liste von Elementen jeweils die zwei herausgesucht werden, die am seltensten vorkommen. Diese beiden Elemente werden kann kombiniert und mit der gemeinsamen Häufigkeit in den Algorithmus miteinbezogen. Der Vorgang endet, wenn nur noch ein Element vorhanden ist.

Also brauchen wir erst einmal ein Unterprogramm, das das jeweils seltenste Element findet:

sub find_smallest {
  my $hashref = shift;

  # Start: choose one element als temporary minimum
  my $minkey = (keys %$hashref)[0];
  my $minval = $hashref->{$minkey};

  # iterate over all keys, thus finding the absolute minimum
  foreach my $key ( keys %$hashref ){
    if( $hashref->{$key} < $minval ){
      $minkey = $key;
      $minval = $hashref->{$key};
    }
  }

  # return key and value of the smallest element
  return( ($minkey,$minval) );
}

Dieses Unterprogramm wird dann in einer Schleife jeweils zweimal aufgerufen, wobei jedesmal zwei Elemente entfernt werden, und eine neues kombiniertes Element hinzugefügt wird.

while( scalar( keys %huff ) > 1 ){

  my( $min1, $val1 ) = find_smallest( \%huff );
  delete $huff{$min1};

  my( $min2, $val2 ) = find_smallest( \%huff );
  delete $huff{$min2};

  $huff{"[$min1,$min2]"} = $val1 + $val2;
}

Wenn die Schleife terminiert, dann ist das verbleibende Element der komplette Häufigkeitsbaum:

my $tree = (keys %huff)[0];

Mit etwas Zusatzaufwand hätte ich auch gleich die Huffman-Codes für jede Zahl mit erzeugen können. Ich hatte ich der Einfachheit halber entschlossen, die Codes durch Parsen der Baumstruktur zu ermitteln.

Weiter oben hatten wir ja einen Baum aufgebaut, in dem wir jeweils zwei Zahlen (Blätter, Atome) durch Komma getrennt zwischen eckige Klammern verpackt haben. Mit dem rekursiven Unterprogramm woodchuck wird dieser Vorgang jetzt umgekehrt: Zuerst wird versucht, das äüßerste Klammernpaar zu entfernen. Ist das nicht möglich, so handelt es sich bei dem betrachteten Baum um ein Blatt, dessen Code wir uns merken. Anderenfalls wird der Baum an dem verbindenden Komma gespalten und für jede Hälfe der Code um eine '0' bzw. eine '1' erweitert, bevor die Teilbäume dann per Rekursion weiterverarbeitet werden. Wenn die Rekursion beendet ist, kennen wir für jeden unserer Zahlenwerte den Huffman-Code.

my %huffcode;

sub woodchuck {
  # part of the code we know so far and the tree we work on
  my( $code, $tree ) = @_;

  # see if there are any surrounding square brackets, i.e.
  # if we are at a branch in the tree or at a leaf.
  if( $tree =~ m/^\[(.*)\]$/ ){

    # remove them if present.
    $tree = $1;

    # turn string into array of characters
    my @tree = split //, $tree;

    # $open counts open square brackets.
    my $open = 0;

    # we try to locate the comma that separates the
    # two children of this branch.
    for( my $i = 0; $i < @tree; $i++ ){

      # the comma we seek is found if there are currently
      # no square brackets left open.
      if( $tree[$i] eq ',' && $open == 0 ){
        # memorize position and stop searching
        $open = $i;
        last;
      }

      # maintain count of open square brackets
      if( $tree[$i] eq '[' ){
        $open++;
      } elsif( $tree[$i] eq ']' ){
        $open--;
      }

    }

    # now do the same for the two sub-trees we identified
    woodchuck( $code."1", substr( $tree, 0, $open ) );
    woodchuck( $code."0", substr( $tree, $open+1 ) );

  } else {
    # if there was no outer square brackets, we have reached a leaf
    # of our tree. This means that the code we have built so far is
    # the final code.
    $huffcode{$tree}=$code;
  }
}

# start recursion
woodchuck( "", $tree );

Die eigentliche Kompression der Daten erfolgte dann über die folgende kleine Schleife:

my $bits;

foreach my $byte ( @data ){
  $bits .= $huffcode{$byte};
}

Nun mußten die so erzeugten Daten nur noch uucodiert werden, damit sie platzsparend in den Quelltext paßten.

Dekompression

Interessanterweise war der oben erzeugte Baum $tree eigentlich schon genau die Struktur, die wir auch zur Dekompression der Daten brauchten. Wenn wir eine Funktion "read_bit()" definieren, die jeweils ein Bit aus den komprimierten Daten liest, dann können wir den Decoder aus folgenden Ersetzungsregeln zusammenbauen:

  • ersetze "[" durch "if( read_bit() ){"

  • ersetze "," durch "} else {"

  • ersetze "]" durch "}"

  • ersetze einzelne Atome durch "return( );"

Das entsprechend modifizierte, kommentierte und strukturierte Programm würde dann wie folgt aussehen:

#!/usr/bin/perl -w

use strict;

# uuencoded data that was compressed using the Huffman algorithm
my $data = '=X]`YSG%U4PRI-N[GD.55&F+9SG.+8TU4\A`V[R\'-N\ARJM%"PPPZ\AR'.
        'JL`X888871B*JQZ!AQ.(HN-&$HT4I55,,J1;.<YQ;&FJT4+###KR\'*JC3K8'.
        '888876:N\>@<YSBZK!$$>)89$QB0:J83"894E*55&G6PPPPPNLU4\A`S-G.['.
        ':K`P,"JC3%LYSG%BJ5)54:=;####"ZSBO/;';

# read one bit of data from the uuencoded $data array. The local
# variables $count and $char are used to maintain state since we're
# basically uudecoding on the fly - i.e. we take one char from the
# string and then read 6 bits of data from it.
{
  my( $count, $char );
  my @mask = (1,2,4,8,16,32);

  sub readbit {
    # no bytes left?
    if( !$count ){
      # get a new one. We subtract the 32 from the ord value
      # to undo part of the uuencoding.
      $char = ord( substr( $data, 0 , 1, "" )) - 32;
      # now we've got 6 new bits of data.
      $count = 6;
    }

    # decrement ready bit counter
    $count--;

    # return true if the $count'th bit is set
    return( $char & $mask[ $count ] );
  }
}


# Unrolled Huffman decompressor. The readbit() function reads just
# one bit from the uuencoded data.
sub tree {

  if( readbit() ){
    if( readbit() ){
      return( chr(32) ); # code 11
    } else {
      if( readbit() ){
        if( readbit() ){
          return( chr(64) ); # code 1011
        } else {
          if( readbit() ){
            return( chr(9) ); # code 10101
          } else {
            if( readbit() ){
              return( chr(252) ); # code 101001
            } else {
              if( readbit() ){
                return( chr(14) ); # code 1010001
              } else {
                return( chr(248) ); # code 1010000
              }
            }
          }
        }
      } else {
        if( readbit() ){
          if( readbit() ){
            return( chr(128) ); # code 10011
          } else {
            return( chr(31) ); # code 10011
          }
        } else {
          if( readbit() ){
            if( readbit() ){
              if( readbit() ){
                return( chr(15) ); # code 1000111
              } else {
                return( chr(34) ); # code 1000110
              }
            } else {
              if( readbit() ){
                if( readbit() ){
                  return( chr(194) ); # code 10001011
                } else {
                  if( readbit() ){
                    if( readbit() ){
                      return( undef ); # code 1000101011
                    } else {
                      return( chr(68) ); # code 1000101010
                    }
                  } else {
                    return( chr(3) ); # code 100010100
                  }
                }
              } else {
                return( chr(96) ); # chr(1000100)
              }
            }
          } else {
            if( readbit() ){
              return( chr(4) ); # code 100001
            } else {
              return( chr(24) ); # code 100000
            }
          }
        }
      }
    }
  } else {
    if( readbit() ){
      return( chr(0) ); # code 01
    } else {
      if( readbit() ){
        return( chr(16) ); # code 001
      } else {
        if( readbit() ){
          if( readbit() ){
            if( readbit() ){
              return( chr(192) ); # code 000111
            } else {
              return( chr(7) ); # code 000110
            }
          } else {
            if( readbit() ){
              return( chr(8) ); # code 000101
            } else {
              if( readbit() ){
                if( readbit() ){
                  if( readbit() ){
                    return( chr(2) ); # code 000100111
                  } else {
                    return( chr(160) ); # code 000100110
                  }
                } else {
                  return( chr(18) ); # code 00010010
                }
              } else {
                if( readbit() ){
                  if( readbit() ){
                    return( chr(20) ); # code 000100011
                  } else {
                    return( chr(33) ); # code 000100010
                  }
                } else {
                  return( chr(224) ); # code 00010000
                }
              }
            }
          }
        } else {
          return( chr(17) ); # code 0000
        }
      }
    }
  }

}

# loop while data can be read from the decoder
while( defined( my $byte1 = tree()) && defined( my $byte2 = tree() ) ){
  # unpack data from decoder into bit representation
  my $line = unpack "B16", "$byte1$byte2";
  # change 0 and 1 into 'nicer' symbols before printing
  $line =~ tr/01/ #/;
  print "$line\n";
}

"Optimierungen"

Der Decoder wäre in dieser Form natürlich viel zu groß für ein JaPh geworden. Ich habe mich deshalb darauf verlegt, statt dessen den Huffman-Tree in leicht geänderter Form zu speichern: Die öffnenden eckigen Klammern habe ich durch den Buchstaben "y" ersetzt, und die Kommata durch Doppelpunkte.

Meine read_bit()-Funktion heißt platzsparend "b". Durch die Substitution

$t =~ s/y/&b?/g;

wird dann zur Laufzeit ein Term mit geschachtelten "?"-Operatoren aufgebaut, der dann per eval() abgearbeitet werden kann.

 


Auswege: Impressum, Haftungsausschluß, Datenschutz, thb's Perl-Ecke, meine Homepage.
Links: Imprint, thb's Perl Corner, my homepage.


Thomas Bätzler, Thomas@Baetzler.de
$Id$