This is the program which made up the Joyce Kilmer tree. It's an
original, and there's another hack contained with in it. (It's
primed for your enjoyment. :)
#!/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;