#!/usr/bin/perl -w

# ASCII Art Encoder   Clinton A. Pierce
#   Freely redistributable under the same terms as Perl
#
# Takes an ASCII art picture and some parameters and emits a JAPH-like
# thing on STDOUT.  Messages to STDERR.
# ** PAY ATTENTION TO THE MESSAGES **
# You have to adjust the picture or your encoded message so they're
#   the right size for each other!  This is a three-way balancing act
#   between the length of your message, the compression and the
#   available slots in the picture.

use strict;
require 5.6;

# The trick is to find a picture where the encoded message will
#   look like background noise or a commonly-repeated set of things.
#   Leaves and bubbles are good.  This world will do just fine for
#   a sample.
my $picture='
               ,,ggddY"""Ybbgg,,
          ,agd6EEb,_ "YE, ___`""Ybga,
       ,gdP""EEEEEEEEbaa,.""Eb    "EEbg,
     ,dP"     ]EEEEEEEEEP`  "Y     `EEEYb,
   ,dP"      ,EEEEECEEP"  db,       "FP""Yb,
  ,P"       ,EEEEEEEEEb, dEEEEa           "E,
 ,P`        dEEEEEEEEEEE,EEP"` a,          `E,
,E`         EEEEEEEEEEEEEEPP"  ""           `E,
d`          IEEEEEEEEEEEP"                   `b
E           `E"EEP""YEP`                      E
E            Y E[  _ "                        E
E              "YEdEb  "Y a                   E
E                 `""Ed,   __                 E
Y,                    `"EbdEEEb,             ,P
`b,                     ,dEEEEEEEbaaa       ,d`
 `E,                    EEEEEEEEEEEE`      ,d`
  `Ea                   "EEEECEEEEEI      aE`
   `Yba                  `YEEEEEECP`    adP`
     "Yba                 `EEEEEEP`   adY"
       `"Yba,             dEEEEP" ,adP"`
          `"YEbaa,      ,dEEEP,adEP"`
               ``""YYbaEEEEP""``
';  # Anonymous ASCII art, author unknown

# The message you want to hide in the picture
#    Remember, the longer the message the bigger the picture will
#    need to be.
my $string_to_encode="Clinton A. Pierce, Artistic Lic.";

# Charset is the characters which will be used to hide the picture
#    they should be in $picture, but will be swapped out for $schar
#    below.  So put $schar's in the picture and they'll get changed
#    out with $charset.  The larger the $charset, the better the
#    compression
my $charset=[ qw| 9 @ B | ];

# $c1 and $c2 are actually part of $charset, except that they'll be
#    alarmingly common in your picture.  Plan accordingly.
my $c1="0";
my $c2="O";

# Character which will be used to hold the codes.  Will not
# appear in the final picture.  If you do it right.
my $schar="E";

# Given a string, find and group the longest substrings
#   contained within it.  This is the start of a
#   a simple compression function.  NOTE: is is SLOW for large
#   strings.
sub longest {
        my($t)=@_;
        my($long, %repeats)=("");
        $t=~s/\n//g;  # Be anal here.
        while($t=~m/(\d\d*).*(\1)/omg) {
                $repeats{$1}=1;
                $long=$1 if ((length $1) > (length $long));
                # Reposition the start of the search to the character
        # after the first character of the first match of
        # the pair.
                pos $t=$+[1];
        }
        foreach(keys %repeats) {
                my $r=0;
                while($t=~/$_/g) {
                        $r++;
                }
                $repeats{$_}=$r;
        }
        foreach(keys %repeats) {
                delete $repeats{$_} if (length $_ < 3);
                delete $repeats{$_} if (length $_ > 20);
                delete $repeats{$_} if ($_ =~/^0/);
        }
        # Sometimes one or the other gives better compression.
        # It depends.
        my(@a,@b);
        @a=sort {length $b<=>length $a } keys %repeats;
        @b=sort { $repeats{$b}<=>$repeats{$a} } keys %repeats;
        return(\@a, \@b);
}

# Encode the message, decide which compression is best.
#
sub encode {
        my($string, $charlist, $zero, $one)=@_;
        my($r1, $r2);

        my $binary=unpack("B*", $string);
        ($r1->{list},$r2->{list})=longest($binary);
        $r1->{string}=$binary;
        $r2->{string}=$binary;

        for my $attempt ($r1, $r2) {
                for my $enc ( @$charlist ) {
                        my $s=shift @{$attempt->{list}};
                        print STDERR "$enc is encoded as $s\n";
                        $attempt->{string}=~s/$s/$enc/g;
                        $attempt->{table}->{$enc}=$s;
                }
                $attempt->{string}=~s/0/$zero/g;
        $attempt->{table}->{$zero}=0;
                $attempt->{string}=~s/1/$one/g;  
        $attempt->{table}->{$one}=1;

                print STDERR "String compressed to: ", 
            length($attempt->{string}), "\n";
                print STDERR $attempt->{string}, "\n";
        }

        return (sort { length($a->{string}) <=> length($a->{string}) }
        ($r1, $r2))[0];
}

my $strobj=encode( $string_to_encode, $charset, $c1, $c2);

# Now, make up the decoding table.  
# Decimal is okay it can be changed.
my $decodetab='%e=(';
foreach(keys %{$strobj->{table}}) {
        $decodetab .= qq{'$_'=>};
        $decodetab .= eval "0b" .$strobj->{table}->{$_};
        $decodetab .= qq{,\n};
}
$decodetab.=");";

# Now encode the top.
my $message=$strobj->{string};
while(length $message) {
        my $c=substr($message, 0, 1);  # Pull off char 1
        unless ($picture=~s/$schar/$c/ ) {
                my $l;
                $l=($picture=~tr/$schar//);
                die "Picture too small for encoding! $l characters lef
+tover";
        }
        $message=substr($message, 1);
}
if ($picture=~/$schar/) {
        warn "You've got too many $schar 's in your picture\n";
}

# The decoder appears in multiple parts.

my $cs=join("", ($c1,$c2,@$charset)); $cs="\Q$cs";
my $top=qq&=~m/(.*)/s;\$_=\$1;s![^$cs]!!g;&;
my $bottom=q~
     for$a(keys %e){$e{$a}=sprintf"%b",$e{$a};}$y= qq{(}.
     join('|',map"\Q$_\E",keys %e).qq{)}; s/$y/$e{$1}/gex;
     print pack"B*",$_;~;

# And voila!  But you still have to arrange it.
#
print qq{'} . $picture . qq{'};
print $top;
print $decodetab;
print $bottom;
[download]