Acme-EyeDrops
view release on metacpan or search on metacpan
lib/Acme/EyeDrops.pm view on Meta::CPAN
package Acme::EyeDrops;
require 5.006;
use strict;
use warnings;
use vars qw($VERSION @ISA @EXPORT_OK);
require Exporter; @ISA = qw(Exporter);
@EXPORT_OK = qw(ascii_to_sightly sightly_to_ascii
regex_print_sightly regex_eval_sightly clean_print_sightly
clean_eval_sightly regex_binmode_print_sightly
clean_binmode_print_sightly
get_eye_dir get_eye_shapes get_eye_string get_builtin_shapes
get_eye_properties get_eye_keywords find_eye_shapes
make_triangle make_siertri make_banner
border_shape invert_shape reflect_shape rotate_shape
reduce_shape expand_shape hjoin_shapes
pour_text pour_sightly sightly);
$VERSION = '1.62';
{ # This table was generated by demo/gentable.pl.
my @C = (
q Z('!'^'!')Z,q Z('('^')')Z,q Z('<'^'>')Z,q Z('>'^'=')Z,
q Z('>'^':')Z,q Z('>'^';')Z,q Z('+'^'-')Z,q Z('*'^'-')Z,
q Z('+'^'#')Z,q Z('*'^'#')Z,q Z('!'^'+')Z,q Z('!'^'*')Z,
q Z('!'^'-')Z,q Z('!'^',')Z,q Z('!'^'/')Z,q Z('!'^'.')Z,
q Z('?'^'/')Z,q Z('<'^'-')Z,q Z('-'^'?')Z,q Z('.'^'=')Z,
q Z('+'^'?')Z,q Z('*'^'?')Z,q Z('?'^')')Z,q Z('<'^'+')Z,
q Z('%'^'=')Z,q Z('&'^'?')Z,q Z('?'^'%')Z,q Z('>'^'%')Z,
q Z('&'^':')Z,q Z('<'^'!')Z,q Z('?'^'!')Z,q Z('%'^':')Z,
q Z('{'^'[')Z,q Z'!'Z,q Z'\\\\'.'"'Z,q Z'#'Z,
q Z'\\\\'.'$'Z,q Z'%'Z,q Z'&'Z,q Z"'"Z,q Z'('Z,q Z')'Z,
q Z'*'Z,q Z'+'Z,q Z','Z,q Z'-'Z,q Z'.'Z,q Z'/'Z,
q Z('^'^('`'|'.'))Z,q Z('^'^('`'|'/'))Z,q Z('^'^('`'|','))Z,
q Z('^'^('`'|'-'))Z,q Z('^'^('`'|'*'))Z,q Z('^'^('`'|'+'))Z,
q Z('^'^('`'|'('))Z,q Z('^'^('`'|')'))Z,q Z(':'&'=')Z,
q Z(';'&'=')Z,q Z':'Z,q Z';'Z,q Z'<'Z,q Z'='Z,q Z'>'Z,q Z'?'Z,
q Z'\\\\'.'@'Z,q Z('`'^'!')Z,q Z('`'^'"')Z,q Z('`'^'#')Z,
q Z('`'^'$')Z,q Z('`'^'%')Z,q Z('`'^'&')Z,q Z('`'^"'")Z,
q Z('`'^'(')Z,q Z('`'^')')Z,q Z('`'^'*')Z,q Z('`'^'+')Z,
q Z('`'^',')Z,q Z('`'^'-')Z,q Z('`'^'.')Z,q Z('`'^'/')Z,
q Z('{'^'+')Z,q Z('{'^'*')Z,q Z('{'^')')Z,q Z('{'^'(')Z,
q Z('{'^'/')Z,q Z('{'^'.')Z,q Z('{'^'-')Z,q Z('{'^',')Z,
q Z('{'^'#')Z,q Z('{'^'"')Z,q Z('{'^'!')Z,q Z'['Z,
q Z'\\\\'.'\\\\'Z,q Z']'Z,q Z'^'Z,q Z'_'Z,
q Z'`'Z,q Z('`'|'!')Z,q Z('`'|'"')Z,q Z('`'|'#')Z,
q Z('`'|'$')Z,q Z('`'|'%')Z,q Z('`'|'&')Z,q Z('`'|"'")Z,
q Z('`'|'(')Z,q Z('`'|')')Z,q Z('`'|'*')Z,q Z('`'|'+')Z,
q Z('`'|',')Z,q Z('`'|'-')Z,q Z('`'|'.')Z,q Z('`'|'/')Z,
q Z('['^'+')Z,q Z('['^'*')Z,q Z('['^')')Z,q Z('['^'(')Z,
q Z('['^'/')Z,q Z('['^'.')Z,q Z('['^'-')Z,q Z('['^',')Z,
q Z('['^'#')Z,q Z('['^'"')Z,q Z('['^'!')Z,q Z'\\\\'.'{'Z,
q Z'|'Z,q Z'\\\\'.'}'Z,q Z'~'Z,q Z('!'^'^')Z
);
push @C, map(join('.', q#'\\\\'#, $C[120],
map($C[$_], unpack('C*', sprintf('%x', $_)))), 128..255);
sub ascii_to_sightly { join '.', map($C[$_], unpack('C*', $_[0])) }
}
sub sightly_to_ascii { eval eval q#'"'.# . $_[0] . q#.'"'# }
sub regex_print_sightly {
q#''=~('('.'?'.'{'.# . ascii_to_sightly('print') . q#.'"'.# .
&ascii_to_sightly . q#.'"'.'}'.')')#;
}
sub regex_binmode_print_sightly {
q#''=~('('.'?'.'{'.# . ascii_to_sightly('binmode(STDOUT);print')
. q#.'"'.# . &ascii_to_sightly . q#.'"'.'}'.')')#;
}
sub regex_eval_sightly {
q#''=~('('.'?'.'{'.# . ascii_to_sightly('eval') . q#.'"'.# .
&ascii_to_sightly . q#.'"'.'}'.')')#;
}
sub clean_print_sightly {
qq#print eval '"'.\n\n\n# . &ascii_to_sightly . q#.'"'#;
}
sub clean_binmode_print_sightly {
qq#binmode(STDOUT);print eval '"'.\n\n\n# .
&ascii_to_sightly . q#.'"'#;
}
sub clean_eval_sightly {
qq#eval eval '"'.\n\n\n# . &ascii_to_sightly . q#.'"'#;
}
# -----------------------------------------------------------------
sub _slurp_tfile {
my $f = shift;
my $b = shift;
open my $fh, '<', $f or die "open '$f': $!";
$b and binmode($fh);
local $/; my $s = <$fh>; close($fh); $s;
}
# Poor man's properties (see also YAML, java.util.Properties).
# Return ref to property hash.
sub _get_properties {
my $f = shift;
open my $fh, '<', $f or die "open '$f': $!";
my $l; my %h;
while (defined($l = <$fh>)) {
chomp($l);
if ($l =~ s/\\$//) {
my $n = <$fh>; $n =~ s/^\s+//; $l .= $n;
redo unless eof($fh);
}
$l =~ s/^\s+//; $l =~ s/\s+$//;
next unless length($l);
next if $l =~ /^#/;
my ($k, $v) = split(/\s*:\s*/, $l, 2);
$h{$k} = $v;
}
close($fh);
lib/Acme/EyeDrops.pm view on Meta::CPAN
}
$s;
}
# Pour $n tokens from @{$rtok} (starting at index $sidx) into string
# of length $slen. Return string or undef if unsuccessful.
sub _pour_chunk {
my ($rtok, $sidx, $n, $slen) = @_;
my $eidx = $sidx + $n - 1; my $tlen = 0;
my $idot = my $iquote = my $i3quote = my $iparen = my $idollar = -1;
for my $i ($sidx .. $eidx) {
$tlen += length($rtok->[$i]);
if ($rtok->[$i] eq '.') { $idot = $i }
elsif ($rtok->[$i] eq '(') { $iparen = $i }
elsif (substr($rtok->[$i], 0, 1) eq '$') { $idollar = $i }
elsif ($rtok->[$i] =~ /^['"]/) {
$iquote = $i; $i3quote = $i if length($rtok->[$i]) == 3;
}
}
die "oops" if $tlen >= $slen;
my $i2 = (my $d = $slen - $tlen) >> 1;
$idot >= 0 && !($d%3) and return join("", @{$rtok}[$sidx .. $idot-1],
".''" x int($d/3), @{$rtok}[$idot .. $eidx]);
if (!($d&1) and $iquote >= 0 || $idollar >= 0) {
$iquote = $idollar if $iquote < 0;
return join("", @{$rtok}[$sidx .. $iquote-1], '(' x $i2 .
$rtok->[$iquote] . ')' x $i2, @{$rtok}[$iquote+1 .. $eidx]);
}
$i3quote >= 0 and return join("", @{$rtok}[$sidx .. $i3quote-1],
$d == 1 ? '"\\' . substr($rtok->[$i3quote], 1, 1) . '"' :
'(' x $i2 . '"\\' . substr($rtok->[$i3quote], 1, 1) . '"' .
')' x $i2, @{$rtok}[$i3quote+1 .. $eidx]);
return unless $d == 1;
$iparen >= 0 and return join("", @{$rtok}[$sidx .. $iparen-1],
'+' . $rtok->[$iparen], @{$rtok}[$iparen+1 .. $eidx]);
# ouch, can't test for eq '(' in case next chunk also adds '+'
$rtok->[$eidx] ne '=' && $rtok->[$sidx+$n] =~ /^['"]/ ?
join("", @{$rtok}[$sidx .. $eidx], '+') : undef;
}
sub _pour_compact_chunk {
my ($rtok, $sidx, $n, $slen) = @_; my @mytok;
for my $i ($sidx .. $sidx + $n - 1) {
if ($i > $sidx+1 && $rtok->[$i-1] eq '.' && substr($rtok->[$i], 0, 1)
eq "'" && substr($rtok->[$i-2], 0, 1) eq "'") {
pop(@mytok); my $qtok = pop(@mytok); # 'a'.'b' to 'ab'
push(@mytok, substr($qtok, 0, -1) . substr($rtok->[$i], 1));
} else {
push(@mytok, $rtok->[$i]);
}
}
push(@mytok, $rtok->[$sidx+$n]); # _pour_chunk checks next token
_pour_chunk(\@mytok, 0, $#mytok, $slen);
}
# Pour unsightly text $txt into shape defined by string $tlines.
sub pour_text {
my ($tlines, $txt, $gap, $tfill) = @_;
$txt =~ s/\s+//g;
my $ttlen = 0; my $txtend = length($txt);
my @tnlines = map(length() ? [map length, split/([^ ]+)/] : undef,
split(/\n/, $tlines));
for my $r (grep($_, @tnlines)) {
for my $i (0 .. $#{$r}) { $i & 1 and $ttlen += $r->[$i] }
}
my $nshape = int($txtend/$ttlen); my $rem = $txtend % $ttlen;
if ($rem || !$nshape) {
++$nshape;
$txt .= $tfill x (int(($ttlen-$rem)/length($tfill))+1)
if length($tfill);
}
my $s = ""; my $p = 0;
for (my $n = 1; 1; ++$n, $s .= "\n" x $gap) {
for my $r (@tnlines) {
if ($r) {
for my $i (0 .. $#{$r}) {
if ($i & 1) {
$s .= substr($txt, $p, $r->[$i]); $p += $r->[$i];
return "$s\n" if !length($tfill) && $p >= $txtend;
} else {
$s .= ' ' x $r->[$i];
}
}
}
$s .= "\n";
}
last if $n >= $nshape;
}
$s;
}
# Make filler code to stuff on end of program to fill last shape.
sub _make_filler {
my $fv = shift; # list reference of filler variables
my $nfv = @{$fv};
# Beware with these filler values.
# Avoid $; $" ';' (to avoid clash with " and ; in later parsing).
# END block is trouble because it is executed after this filler.
# Setting $^ or $~ (but not $:) to weird values resets $@.
# For example: $~='?'&'!'; (this looks like a Perl bug to me).
# For now, just stick with letters and numbers.
my @filleqto = (
[ q#'.'#, '^', q^'~'^ ], [ q#'@'#, '|', q^'('^ ],
[ q#')'#, '^', q^'['^ ], [ q#'`'#, '|', q^'.'^ ],
[ q#'('#, '^', q^'}'^ ], [ q#'`'#, '|', q^'!'^ ],
[ q#')'#, '^', q^'}'^ ], [ q#'*'#, '|', q^'`'^ ],
[ q#'+'#, '^', q^'_'^ ], [ q#'&'#, '|', q^'@'^ ],
[ q#'['#, '&', q^'~'^ ], [ q#','#, '^', q^'|'^ ]
);
$nfv > @filleqto and die "too many fv";
my $rem = @filleqto % $nfv;
$rem and splice(@filleqto, -$rem);
my $v = -1;
map(($fv->[++$v % $nfv], '=', @{$_}, ';'), @filleqto);
}
# Pour sightly program $prog into shape defined by string $tlines.
sub pour_sightly {
my ($tlines, $prog, $gap, $fillv, $compact, $ihandler) = @_;
$ihandler ||= \&_def_ihandler;
my $ttlen = 0;
my @tnlines = map(length() ? [map length, split/([^ ]+)/] : undef,
split(/\n/, $tlines));
for my $r (grep($_, @tnlines)) {
for my $i (0 .. $#{$r}) { $i & 1 and $ttlen += $r->[$i] }
}
my $outstr = ""; my @ptok;
if ($prog) {
if ($prog =~ /^''=~/g) {
push(@ptok, ($tlines =~ /(\S+)/ ? length($1) : 0) == 3 ?
"'?'" : "''", '=~');
} elsif ($prog =~ /(.*eval.*\n\n\n)/g) {
$outstr .= $1;
}
push(@ptok, $prog =~ /[().&|^]|'\\\\'|.../g); # ... is "'"|'.'
}
my $iendprog = @ptok;
my @filler = _make_filler(ref($fillv) ? $fillv : [ '$:', '$~', '$^' ]);
# Note: 11 is the length of a filler item, for example, $:='.'^'~';
# And there are 6 tokens in each filler item: $: = '.' ^ '~' ;
push(@ptok, 'Z', (@filler) x (int($ttlen/(11 * int(@filler / 6))) + 1));
my $sidx = 0;
for (my $nshape = 1; 1; ++$nshape, $outstr .= "\n" x $gap) {
for my $rline (@tnlines) {
unless ($rline) { $outstr .= "\n"; next }
for my $it (0 .. $#{$rline}) {
unless ($it & 1) {$outstr .= ' ' x $rline->[$it]; next }
(my $tlen = $rline->[$it]) == (my $plen = length($ptok[$sidx]))
and $outstr .= $ptok[$sidx++], next;
if ($plen > $tlen) {
$outstr .= '(' x $tlen;
splice(@ptok, $sidx+1, 0, (')') x $tlen);
$iendprog += $tlen if $sidx < $iendprog;
next;
}
my $fcompact = my $fexact = 0;
my $n = $compact ?
_guess_compact_ntok(\@ptok, $sidx, $tlen, \$fexact, \$fcompact)
: _guess_ntok(\@ptok, $sidx, $tlen, \$fexact);
if ($fexact) {
$outstr .= $fcompact ? _compact_join(\@ptok, $sidx, $n) :
join("", @ptok[$sidx .. $sidx+$n-1]);
$sidx += $n; next;
}
my $str;
--$n while $n > 0 && !defined($str = $fcompact ?
_pour_compact_chunk(\@ptok, $sidx, $n, $tlen) :
_pour_chunk(\@ptok, $sidx, $n, $tlen));
if ($n) { $outstr .= $str; $sidx += $n; next }
++$n while $n < $tlen && length($ptok[$sidx+$n]) < 2;
die "oops ($n >= $tlen)" if $n >= $tlen;
$outstr .= join("", @ptok[$sidx .. $sidx+$n-1]);
$sidx += $n;
$outstr .= '(' x (my $nleft = $tlen - $n);
splice(@ptok, $sidx+1, 0, (')') x $nleft);
$iendprog += $nleft if $sidx < $iendprog;
}
$outstr .= "\n";
}
$ihandler->("$nshape shapes completed.\n");
last if $sidx >= $iendprog;
}
my $eidx = rindex($outstr, 'Z');
substr($outstr, $eidx, 1) = ';' if $eidx >= 0;
return $outstr if $sidx == $iendprog || $sidx == $iendprog+1;
die "oops" if $eidx < 0;
ref($fillv) or return substr($outstr, 0, $eidx) . (length($fillv) ?
pour_text(substr($outstr, $eidx), "", 0, $fillv) : "\n");
(my $idx = rindex($outstr, ';')) >= 0 or return $outstr;
my @t = substr($outstr, $idx+1) =~
/[()&|^=;]|\$.|'[^'\\]*(?:\\.[^'\\]*)*'|"[^"\\]*(?:\\.[^"\\]*)*"/g
or return $outstr;
my $nl = my $nr = my $ne = 0;
for my $c (@t) {
if ($c eq '(') {++$nl} elsif ($c eq ')') {++$nr}
elsif ($c eq '=') {++$ne}
}
if ($ne == 0 || $nl != $nr || $t[-1] eq '=') {
my $f = ';'; # Trouble: wipe out last bit with filler
for my $i ($idx+1 .. length($outstr)-2) {
substr($outstr, $i, 1) =~ tr/ \n// or
substr($outstr, $i, 1) = $f = $f eq '#' ? ';' : '#';
}
} elsif ($t[-1] eq '|' or $t[-1] eq '^' or $t[-1] eq '&') {
$outstr =~ s/\S(\s*)$/;$1/;
}
$outstr;
}
# -----------------------------------------------------------------
sub _border {
my ($a, $w, $c, $l, $r, $t, $b) = @_;
my $z = $c x ($w+$l+$r); my $f = $c x $l; my $g = $c x $r;
for (@{$a}) { $_ = $f . $_ . $g }
unshift(@{$a}, ($z) x $t); push(@{$a}, ($z) x $b);
}
sub border_shape {
my ($tlines, $gl, $gr, $gt, $gb, $wl, $wr, $wt, $wb) = @_;
my @a = split(/^/, $tlines, -1); chop(@a); my $m = 0;
for my $l (@a) { $m = length($l) if length($l) > $m }
for my $l (@a) { $l .= ' ' x ($m - length($l)) }
$gl || $gr || $gt || $gb and _border(\@a, $m, ' ', $gl, $gr, $gt, $gb);
$wl || $wr || $wt || $wb and _border(\@a, $m+$gl+$gr,'#',$wl,$wr,$wt,$wb);
join("\n", @a, "");
}
sub invert_shape {
my $tlines = shift;
my @a = split(/^/, $tlines, -1); chop(@a); my $m = 0;
for my $l (@a) { $m = length($l) if length($l) > $m }
for my $l (@a) { $l .= ' ' x ($m - length($l)) }
my $s = join("\n", @a, ""); $s =~ tr/ #/# /;
$s =~ s/ +$//mg; $s;
}
sub reflect_shape {
my $tlines = shift;
my @a = split(/^/, $tlines, -1); chop(@a); my $m = 0;
for my $l (@a) { $m = length($l) if length($l) > $m }
my $s = join("\n", map(scalar reverse($_ . ' ' x ($m - length)), @a), "");
$s =~ s/ +$//mg; $s;
}
sub hjoin_shapes {
my ($g, @shapes) = @_;
my $ml = 0; my @lines;
for my $s (@shapes) { my $n = $s =~ tr/\n//; $ml = $n if $n > $ml }
for my $tlines (@shapes) {
my @a = split(/^/, $tlines, -1); chop(@a); my $m = 0;
for my $l (@a) { $m = length($l) if length($l) > $m }
for my $l (@a) { $l .= ' ' x ($m - length($l) + $g) }
push(@a, (' ' x ($m + $g)) x ($ml - @a));
for my $i (0..$#a) { $lines[$i] .= $a[$i] }
}
my $s = join("\n", @lines, "");
$s =~ s/ +$//mg; $s;
}
sub reduce_shape {
my ($tlines, $f) = @_; my $i = $f++; my $s = "";
for my $l (grep(!(++$i%$f), split(/\n/, $tlines))) {
for ($i = 0; $i < length($l); $i += $f) { $s .= substr($l, $i, 1) }
$s .= "\n";
}
$s =~ s/ +$//mg; $s;
}
sub expand_shape {
my ($s, $f) = @_; my $i = ' ' x ++$f; my $j = '#' x $f;
$s =~ s/ /$i/g; $s =~ s/#/$j/g; my $t = "";
for my $l (split(/^/, $s, -1)) { $t .= $l x $f } $t;
}
# Rotate shape clockwise: 90, 180 or 270 degrees
# (other angles are left as an exercise for the reader:-)
sub rotate_shape {
my ($tlines, $degrees, $rtype, $flip) = @_;
$degrees == 180 and
return join("\n", reverse(split(/\n/, $tlines)), "");
my $t = $rtype==0 ? 2 : 1; my $inc = $rtype==1 ? 2 : 1;
my @a = split(/^/, $tlines, -1); chop(@a); my $m = 0; my $s = "";
for my $l (@a) { $m = length($l) if length($l) > $m }
for my $l (@a) { $l .= ' ' x ($m - length($l)) }
if ($degrees == 90) {
@a = reverse(@a) unless $flip;
for (my $i = 0; $i < $m; $i += $inc) {
for (@a) {$s .= substr($_, $i, 1) x $t} $s .= "\n"
}
} elsif ($degrees == 270) {
@a = reverse(@a) if $flip;
for (my $i = $m-1; $i >= 0; $i -= $inc) {
for (@a) {$s .= substr($_, $i, 1) x $t} $s .= "\n"
}
}
$s =~ s/ +$//mg; $s;
}
sub make_triangle {
my $w = shift; $w & 1 or ++$w; $w < 9 and $w = 9;
my $n = $w >> 1; my $s;
for (my $i=1;$i<=$w;$i+=2) { $s .= ' ' x $n-- . '#' x $i . "\n" }
$s;
}
sub make_siertri {
my $w = shift; $w < 3 and $w = 5; my $n = 2 ** $w; my $s;
for my $i (0 .. $n-1) {
--$n; $s .= ' ' x $n .
join('', map($n & $_ ? ' ' : '##', 0 .. $i)) . "\n";
} $s;
}
sub make_banner {
my ($w, $src) = @_;
# Linux /usr/games/banner can be used.
# CPAN Text::Banner will hopefully be enhanced so it can be used too.
my $b_exe = '/usr/games/banner';
-x $b_exe or die "'$b_exe' not available on this platform.";
my $f = $w ? "-w $w" : ""; $src =~ s/\s+/ /g; $src =~ s/ $//;
# Following characters not in /usr/games/banner character set:
# \ [ ] { } < > ^ _ | ~
# Also must escape ' from the shell.
$src =~ tr#_\\[]{}<>^|~'`#-/()()()H!T""#;
my $s = ""; my $len = length($src);
for (my $i = 0; $i < $len; $i += 512) {
my $cmd = "$b_exe $f '" . substr($src, $i, 512) . "'";
$s .= `$cmd`; my $rc = $? >> 8; $rc and die "<$cmd>: rc=$rc";
}
$s =~ s/\s+$/\n/; $s =~ s/ +$//mg;
# Remove as many leading spaces as possible.
my $m = 32000; # regex /^ {$m}/ blows up if $m > 32766
while ($s =~ /^( *)\S/mg) { $m = length($1) if length($1) < $m }
$s =~ s/^ {$m}//mg if $m; $s;
}
# -------------------------------------------------------------------------
sub _bi_all {
join "\n" x $_[0]->{Width},
map(_get_eye_string($_[0]->{EyeDir}, $_), _get_eye_shapes($_[0]->{EyeDir}))
}
sub _bi_triangle { make_triangle($_[0]->{Width}) }
sub _bi_siertri { make_siertri($_[0]->{Width}) }
sub _bi_banner { make_banner($_[0]->{Width}, $_[0]->{BannerString}) }
sub _bi_srcbanner { make_banner($_[0]->{Width}, $_[0]->{SourceString}) }
{
my %builtin_shapes = (
'all' => \&_bi_all,
'triangle' => \&_bi_triangle,
'siertri' => \&_bi_siertri,
'banner' => \&_bi_banner,
'srcbanner' => \&_bi_srcbanner
);
sub get_builtin_shapes { sort keys %builtin_shapes }
# Return built-in shape string or undef if invalid shape.
sub _get_builtin_string {
my $shape = shift;
return unless exists($builtin_shapes{$shape});
$builtin_shapes{$shape}->(shift);
}
}
sub sightly {
my $ruarg = shift; my %arg = (
Shape => "", ShapeString => "",
SourceFile => "", SourceString => "",
SourceHandle => undef, InformHandler => undef,
Width => 0, BannerString => "",
Text => 0, TextFiller => "",
Regex => 0, Compact => 0,
Print => 0, Binary => 0,
Gap => 0, Rotate => 0,
RotateType => 0, RotateFlip => 0,
Reflect => 0, Reduce => 0,
Expand => 0, Invert => 0,
TrailingSpaces => 0, RemoveNewlines => 0,
Indent => 0, BorderGap => 0,
BorderGapLeft => 0, BorderGapRight => 0,
BorderGapTop => 0, BorderGapBottom => 0,
BorderWidth => 0, BorderWidthLeft => 0,
BorderWidthRight => 0, BorderWidthTop => 0,
BorderWidthBottom => 0, TrapEvalDie => 0,
TrapWarn => 0, FillerVar => [],
EyeDir => get_eye_dir()
);
for my $k (keys %{$ruarg}) {
exists($arg{$k}) or die "invalid parameter '$k'";
$arg{$k} = $ruarg->{$k};
}
length($arg{SourceFile}) && $arg{SourceHandle} and
die "cannot specify both SourceFile and SourceHandle";
length($arg{SourceFile}) && length($arg{SourceString}) and
die "cannot specify both SourceFile and SourceString";
length($arg{SourceString}) && $arg{SourceHandle} and
die "cannot specify both SourceString and SourceHandle";
$arg{Shape} && $arg{ShapeString} and
die "cannot specify both Shape and ShapeString";
if (length($arg{SourceFile})) {
$arg{SourceString} = _slurp_tfile($arg{SourceFile}, $arg{Binary});
} elsif ($arg{SourceHandle}) {
local $/; $arg{SourceString} = readline($arg{SourceHandle});
}
my $fill = $arg{FillerVar};
if (ref($fill) && !$arg{Text}) {
# Non-rigourous check for module (package) or END block.
@{$fill} or $fill = ($arg{SourceString} =~ /^\s*END\b/m or
$arg{SourceString} =~ /^\s*package\b/m) ?
[ '$:', '$~', '$^' ] :
[ '$:', '$~', '$^', '$/', '$,', '$\\' ];
}
$arg{RemoveNewlines} and $arg{SourceString} =~ tr/\n//d;
my $shape = my $sightly = "";
length($arg{SourceString}) && !$arg{Text} and $sightly = $arg{Print} ?
( $arg{Regex} ? ( $arg{Binary} ?
regex_binmode_print_sightly($arg{SourceString}) :
regex_print_sightly($arg{SourceString}) ) :
( $arg{Binary} ?
clean_binmode_print_sightly($arg{SourceString}) :
clean_print_sightly($arg{SourceString}) ) ) :
( $arg{Regex} ? regex_eval_sightly($arg{SourceString}) :
clean_eval_sightly($arg{SourceString}) );
if ($arg{ShapeString}) {
$shape = $arg{ShapeString};
} elsif ($arg{Shape}) {
$shape = join("\n" x $arg{Gap},
map(_get_builtin_string($_, \%arg) ||
(m#[./]# ? _slurp_tfile($_) : _get_eye_string($arg{EyeDir}, $_)),
split(/,/, $arg{Shape})));
} elsif ($arg{Width}) {
die "invalid width $arg{Width} (must be > 3)"
if !$arg{Text} && $arg{Width} < 4;
$shape = '#' x $arg{Width};
}
$shape or return "use re 'eval';\n" x ($arg{Regex} == 3 || ($arg{Regex} == 1 && $] >= 5.017)) . $sightly;
$arg{Rotate} and $shape = rotate_shape($shape, $arg{Rotate},
$arg{RotateType}, $arg{RotateFlip});
$arg{Reflect} and $shape = reflect_shape($shape);
$arg{Reduce} and $shape = reduce_shape($shape, $arg{Reduce});
$arg{Expand} and $shape = expand_shape($shape, $arg{Expand});
$arg{Invert} and $shape = invert_shape($shape);
$arg{TrailingSpaces} ||
$arg{BorderGap} || $arg{BorderWidth} ||
$arg{BorderGapLeft} || $arg{BorderWidthLeft} ||
$arg{BorderGapRight} || $arg{BorderWidthRight} ||
$arg{BorderGapTop} || $arg{BorderWidthTop} ||
$arg{BorderGapBottom} || $arg{BorderWidthBottom} and
$shape = border_shape($shape,
$arg{BorderGapLeft} || $arg{BorderGap},
$arg{BorderGapRight} || $arg{BorderGap},
$arg{BorderGapTop} || $arg{BorderGap},
$arg{BorderGapBottom} || $arg{BorderGap},
$arg{BorderWidthLeft} || $arg{BorderWidth},
$arg{BorderWidthRight} || $arg{BorderWidth},
$arg{BorderWidthTop} || $arg{BorderWidth},
$arg{BorderWidthBottom} || $arg{BorderWidth});
if ($arg{Indent}) { my $s = ' ' x $arg{Indent}; $shape =~ s/^/$s/mg }
$arg{Text} and return
pour_text($shape, $arg{SourceString}, $arg{Gap}, $arg{TextFiller});
"use re 'eval';\n" x ($arg{Regex} == 3 || ($arg{Regex} == 1 && $] >= 5.017)) .
'local $SIG{__WARN__}=sub{};' x $arg{TrapWarn} .
pour_sightly($shape, $sightly, $arg{Gap}, $fill, $arg{Compact},
$arg{InformHandler}) . "\n\n\n;die \$\@ if \$\@\n" x $arg{TrapEvalDie};
}
# -------------------------------------------------------------------------
sub _get_eye_shapes {
my $d = shift;
opendir my $dh, $d or die "opendir '$d': $!";
my @e = sort map(/(.+)\.eye$/, readdir($dh));
closedir($dh); @e;
}
sub _get_eye_string { _slurp_tfile($_[0] . '/' . $_[1] . '.eye') }
sub _get_eye_properties {
my $f = $_[0] . '/' . $_[1] . '.eyp';
-f $f or return;
_get_properties($f);
}
sub _get_eye_keywords {
my $d = shift;
my %h;
SHAPE: for my $s (_get_eye_shapes($d)) {
my $p = _get_eye_properties($d, $s) or next SHAPE; # no properties
exists($p->{keywords}) or next SHAPE; # no keywords property
my @k = split(" ", $p->{keywords}) or next SHAPE; # no keywords
for my $k (@k) { push(@{$h{$k}}, $s) }
}
return \%h;
}
sub _find_eye_shapes {
my $d = shift;
@_ or die "oops, no keywords given";
my @skey = map([split/\s+OR\s+/], @_);
my @ret;
SHAPE: for my $s (_get_eye_shapes($d)) {
my $p = _get_eye_properties($d, $s) or next SHAPE; # no properties
exists($p->{keywords}) or next SHAPE; # no keywords property
my @k = split(" ", $p->{keywords}) or next SHAPE; # no keywords
my %h; @h{@k} = ();
for my $k (@skey) {
# XXX: short-circuiting List::Util::first() better than grep here.
grep(exists($h{$_}), @{$k}) or next SHAPE; # AND, all must be true
}
push(@ret, $s);
}
return @ret;
}
sub get_eye_shapes { _get_eye_shapes(get_eye_dir()) }
sub get_eye_string { _get_eye_string(get_eye_dir(), shift) }
sub get_eye_properties { _get_eye_properties(get_eye_dir(), shift) }
sub get_eye_keywords { _get_eye_keywords(get_eye_dir()) }
sub find_eye_shapes { _find_eye_shapes(get_eye_dir(), @_) }
# $eye_dir is the directory containing the .eye file shapes.
# Note: $eye_dir is only eval-hostile line in EyeDrops.pm; do not change it
# for t/19_surrounds.t and "EyeDropping EyeDrops.pm" section of doco relies
# on it. Remove ".pm" from "...Acme/EyeDrops.pm" giving directory name.
my $eye_dir = __FILE__; chop($eye_dir);chop($eye_dir);chop($eye_dir);
sub slurp_yerself { _slurp_tfile($eye_dir . '.pm') }
sub get_eye_dir { $eye_dir }
1;
__END__
=head1 NAME
Acme::EyeDrops - Visual Programming in Perl
=head1 SYNOPSIS
use Acme::EyeDrops qw(sightly);
print sightly( { Shape => 'camel',
SourceFile => 'eyesore.pl' } );
=head1 DESCRIPTION
C<Acme::EyeDrops> converts a Perl program into an equivalent one,
but without all those unsightly letters and numbers.
In a Visual Programming breakthrough, EyeDrops allows you to pour
the generated program into various shapes, such as UML diagrams,
enabling you to instantly understand how the program works just
by glancing at its new and improved visual representation.
Unlike C<Acme::Bleach> and C<Acme::Buffy>, the generated program runs
without requiring that C<Acme::EyeDrops> be installed on the target
system.
lib/Acme/EyeDrops.pm view on Meta::CPAN
).( ( '`'
)|+ ( '/'
)). ( '['
^(( ( '+'
))) ).('`' |((
'%' ))). ( '`'
|(( '.') ) ).+
((( (( ( (((
((( ( ( (((
((( ( '\\')))
))) ) ) ) )
) )))) )))))) .'$[;' . (
( ( (( ( (
( ( ( (( ( ( (( ( ( (
( ( '`') )))) ) )
) ) ))) )
) ))) ) )
)| ( ( ( ( ((
'#' ) ) ) )))
).(('`')| ('(')).(
'`'|'/'). ('['^'+') .',(\\$'
.'=='.('[' ^'"') . '==='.+(
'`'|'#').')' . '>\\$-'
.'&&(\\$-=\\' . '$=)'.(
'`'|'&').('`' | ( '/')).(
'['^')').'\\' . '@:=<' .
('^'^(('`')| "\.")). (
'>').(';').( '!'^'+' )
.('['^'+'). ('['^')' ).('`'|
')').("\`"| "\.").( ( ('['))^
"\/").'\\$\\"'.( ( "\[")^ ( (
( ( "\#"))))). ( ( '-')) . (
( ( ('(')))).( ( ( '[')) ^ (
( '"'))).'--' . '-'. ( (
( '`'))|'#'). ( ( (
( '-')))). ( ( (
( ( '\\' ) )
) ) ) .
( ( ( (
( ( ( ( (
( ( ( ( (
( ( ( ( (
( ( ( ( (
( '$'))))))))))))))))))))))))).'-).'.('['^ ( (
( ')')))).('`'|'%').('['^'-').('`'|'%').(('[')^ (
( ')'))).('['^'(').('`'|'%').'.\\$/'.('`'|'&').( (
( '`'))|'/').('['^')').'\\@:'.('!'^'+').'"})');$:= (
( '.'))^'~';$~='@'|'(';$^=')'^'[';$/='`'|'.';$,='(' ;
This is perhaps a cleaner solution, though some people
find the plain sightly encoding more pleasing to the eye.
Showing the face upside down, rather than reflected, is more
easily solved with:
open$%;print+reverse<0>
and easier still for a self-printing shape:
open$%;print<0> # self printing
open$%;print+map{y;!-~;#;;$_}<0> # replace sightly with '#'
=head2 A Somersaulting Camel
Let's extend the Buffy example of the previous section to produce
a camel-shaped program capable of somersaulting across the screen
when run.
We start with a generator program, F<gencamel.pl>:
print sightly( { Regex => 1,
Compact => 1,
RemoveNewlines => 1,
Indent => 1,
BorderGapRight => 1,
Shape => 'camel',
SourceString => <<'END_SRC_STR' } );
$~=pop||'';open$%;
y,!-~,#,,s,(.).,$+,gs,$~&&($_=reverse)for@~=grep$|--,('')x18,<0>;
@;=map~~reverse,reverse@~;
map{system$^O=~Win?CLS:'clear';
($-=$_%3)||(--$|,map$_=reverse,@~,@;);
print$"x($=/3*abs$|*2-$-),$_,$/for$-&1?@;:@~;
sleep!$%}$%..11
END_SRC_STR
Note the use of the Compact and RemoveNewlines attributes,
necessary here to squeeze the above program into a single
camel shape.
Running this program:
perl gencamel.pl >camel.pl
produces F<camel.pl>:
''=~('(?{'.(
('`')| '%').('['^'-').
('`'|'!'). ('`'|',').'"\\$~='
.('['^'+') .('`'| '/').('['^'+').'||'.
"'"."'".';'.('`'|'/' ).('['^'+').('`'|'%').
('`'|'.').('\\$%;').( '['^'"').(',!-~,#,,').(
'['^'(').',(.).,\\' .'$+,'.('`'|"'").('['^'(')
.',\\$~&&(\\$' .'_='.('['^')').('`'|('%')).(
'['^'-').('`'| '%').('['^')').('['^'(').(('`')|
'%').')'.("\`"| '&').('`'|'/').('['^"\)").'\\@~='.(
'`'|"'").("\["^ ')').('`'|'%').('['^'+').('\\$|--,(').
"'"."'".(')').( '['^'#').('^'^('`'|'/')).(':'&'=').',<'.
('^'^('`'|'.') ).'>;\\@;='.('`'|'-').('`'|'!').('['^'+')
.'~~'.('['^')' ).('`'|'%').('['^'-').('`'|'%').('['^')').
('['^'(').('`'|'%').','.('['^')').('`'|'%').('['^'-').('`'
|'%').('['^')').('['^'(').('`'|'%').'\\@~;'.('`'|'-').('`'|
'!').('['^'+').'\\{'.('['^'(').('['^'"').('['^'(').(('[')^
'/').('`'|'%').('`'|'-').'\\$^'.('`'^'/').'=~'.('{'^"\,").(
'`'|')').('`'|'.').'?'.('`'^'#').('`'^',').('{'^'(').(':').
"'".('`'|'#').('`'|',').('`'|'%').('`'|'!').('['^')')."'".
';(\\$-=\\$_%'.('^'^('`'|'-')).')||(--\\$|,'.('`'|'-' ).(
'`'|'!').('['^'+').'\\$_='.('['^')').('`'|'%').('[' ^((
'-'))).('`'|'%').('['^')').('['^'(').('`' |('%')). ','
.'\\@~,\\@;);'.('['^'+').('['^(')')).( '`'|')' ).(
"\`"| '.').('['^'/').'\\$\\"'.("\["^ ('#')). '('
.'\\$=/'.('^'^('`'|'-')).'*'. (('`')| '!'
).("\`"| '"').('['^ "\("). '\\$|' .+
('*').( '^'^('`' |',')) .'-\\' .+
'$-),'. '\\$_,'. '\\$' .'/'. (
('`')| ('&')).( '`'| '/')
.('['^ ')').'\\' .'$' .'-'
.'&'. (('^')^( '`'| '/')
).'?' .'\\@;' .':' .''.
'\\' .'@~;' .''. ('['
^'(' ).( '`'| ',')
.''. ((( '`' ))|
'%' ).( '`' |((
'%' ))) .+( '['
^(( '+' ))) .+
(( '!')). ((
(( '\\') ))
). '$%\\}'. ((
((( '\\' ))))) .+
'$' .'%..' .''. (((
'^') )^("\`"| '/' )).(
"\^"^( ('`')|
('/'))). '"})');
I<Note: The use of a camel image in association with Perl is a
trademark of O'Reilly & Associates, Inc. Used with permission>.
You can run F<camel.pl> like this:
perl camel.pl normal forward somersaulting camel
perl camel.pl b camel somersaults backwards
perl camel.pl please do a backward somersault
same thing
You are free to add a leading C<#!/usr/bin/perl -w> line to
F<camel.pl>, so long as you also add a blank line after
this header line.
=head2 Twelve Thousand and Thirty Two Camels
In a similar way to the somersaulting camel described above,
we create a camel-shaped program capable of emitting
twelve thousand and thirty two different camels when run.
As usual, we start with a generator program, F<gencamel.pl>:
print sightly( { Regex => 1,
Compact => 1,
RemoveNewlines => 1,
BorderGap => 1,
Shape => 'camel',
SourceString => <<'END_SRC_STR' } );
$~=uc shift;$:=pop||'#';open$%;chop(@~=<0>);$~=~R&&
(@~=map{$-=$_+$_;join'',map/.{$-}(.)/,@~}$%..33);
$|--&$~=~H&&next,$~!~Q&&eval"y, ,\Q$:\E,c",$~=~I&&
eval"y, \Q$:\E,\Q$:\E ,",$~=~M&&($_=reverse),
print$~=~V?/(.).?/g:$_,$/for$~=~U?reverse@~:@~
END_SRC_STR
Running this program:
perl gencamel.pl >camel.pl
produces F<camel.pl>, which you can run like this:
perl camel.pl normal camel
perl camel.pl q quine (program prints itself)
perl camel.pl m mirror (camel looking in the mirror)
perl camel.pl i inverted camel
perl camel.pl u upside-down camel
perl camel.pl r rotated camel
perl camel.pl h horizontally-squashed camel
perl camel.pl v vertically-squashed camel
And can further combine the above options, each combination
producing a different camel, for example:
perl camel.pl uri
produces a large, bearded camel with a pony-tail, glasses,
and a tie-dyed T-shirt. :)
F<camel.pl> also accepts an optional second argument, specifying
the character to fill the camel with (default C<#>).
For example:
perl camel.pl hv small camel filled with #
perl camel.pl hv "$" small camel filled with $
Why 12,032 camels? Combining the main options q, m, i, u, r, h, v
can produce 128 different camels. And there are 94 printable
characters available for the second argument, making a total
of 128 * 94 = 12,032 camels.
=head2 Naked Arm Wrestling
The final auction at Y::E 2002 in Munich featured an epic athletic
contest which you can remember with:
use Acme::EyeDrops qw(sightly);
my $s = sightly( { Regex => 1,
Shape => 'naw',
Indent => 1,
SourceString => <<'NAKED_ARM_WRESTLING' } );
$/='';open$%;$x=<0>;$y=<0>;
substr($y,428,$%)=' AAAAARRRGGGHHH!!!';
map{system$^O=~Win?CLS:'clear';
print$_&1?$y:$x;sleep!$%+($_&1)}$%..9
NAKED_ARM_WRESTLING
$s =~ s/ +$//m;
print $s;
=head2 Baghdad Bob
Running this program:
print sightly( { Shape => 'baghdad',
Regex => 1,
Compact => 1,
RemoveNewlines => 1,
BorderGap => 1,
BorderWidthLeft => 3,
BorderWidthRight => 3,
BorderWidthTop => 2,
BorderWidthBottom => 8,
SourceString => <<'FAMOUS_COMICAL_ALI_QUOTES' } );
warn+(
"Britain is not worth an old shoe!",
"There are no American infidels in Baghdad!",
"We have them surrounded in their tanks!",
"I speak better English than this villain Bush!")[rand(4)],$/
FAMOUS_COMICAL_ALI_QUOTES
produces:
''=~('(?{'.('`'|'%').('['^'-').('`'|'!').('`'|',').'"'.('['^',').('`'|
'!').('['^')').('`'|'.').'+(\\"'.('`'^'"').('['^')').('`'|')').(('[')^
'/' ).(
'`' |'!').('`'|')' ).(
'`' |'.').('{'^'[').('`'| ')'
).( '['^'(').('{'^'[').('`'|'.' ).(
'`' |'/').('['^'/').('{'^'[').("\["^ ','
).( '`'|'/').('['^')').('['^'/').("\`"| '('
).( '{'^'[').('`'|'!').('`'|'.').('{'^'['). (((
'`' ))|'/').('`'|',').('`'|'$').("\{"^ '[' ).(
'[' ^'(').('`'|'(').('`'|'/').('`'|'%') .(( '!'
)). '\\",\\"'.('{'^'/').('`'|'(').("\`"| '%' ).(
'[' ^')').('`'|'%').('{'^'[').('`'|"\!").( '['^ ')'
).( '`'|'%').('{'^'[').('`'|'.').('`'|'/').( "\{"^ '['
).( '`'^'!').('`'|'-').('`'|'%').('['^"\)").( ('`')| ')'
).( '`'|'#').('`'|'!').('`'|'.').('{'^'[').('`'| ')').('`' |((
'.' ))).('`'|'&').('`'| ')').('`'|'$').('`'| '%'
).( '`'|',').(('[')^ '(').('{'^'['). (((
'`' ))|')').("\`"| '.').(('{')^ '['
).( '`'^('"')).( '`'|'!'). (((
'`' ))|("'")).( ('`')| '('
).( '`'|"\$").( "\`"| '!'
).( '`'|"\$"). ('!\\",\\"').( '{'^',').("\`"| '%') .+(
'{' ^('[')).( ( '`')|'(' ) .('`' |((
'!' ))).('['^'-' ) . ( ( '`')|'%').('{'^ '['
).( '['^'/') . ( ( ( '`'))| '('
).( '`'|'%') . +( ( ( ( '`'))) |((
'-' ))).('{' ^ ( ( ( '['))) ).(
'[' ^'(').( '['^'.').('[' ^')').('['^')'). +( (( '`'
))| '/'). ( ( ( '['
))^ ( ( ( ( ( '.'
))) ) ) ) . (((
lib/Acme/EyeDrops.pm view on Meta::CPAN
$==pop||99;--$=;sub
_{($;=($=||No)." bottle"."s"x!!--$=." of beer")." on the wall"}
print+_,", $;!
Take one down, pass it around,
",_,"!
"while++$=
BURP
chop($ninety_nine); $ninety_nine =~ s/\nprint/print/;
print sightly( { Regex => 1,
Compact => 1,
ShapeString => hjoin_shapes(2,
(get_eye_string('bottle2'))x6),
SourceString => $ninety_nine } );
producing:
''=~( '(?{' .('`' |'%') .('[' ^'-')
.('`' |'!') .('`' |',') .'"'. '\\$'
.'==' .('[' ^'+') .('`' |'/') .('['
^'+') .'||' .(';' &'=') .(';' &'=')
.';-' .'-'. '\\$' .'=;' .('[' ^'(')
.('[' ^'.') .('`' |'"') .('!' ^'+')
.'_\\{' .'(\\$' .';=('. '\\$=|' ."\|".( '`'^'.'
).(('`')| '/').').' .'\\"'.+( '{'^'['). ('`'|'"') .('`'|'/'
).('['^'/') .('['^'/'). ('`'|',').( '`'|('%')). '\\".\\"'.( '['^('(')).
'\\"'.('['^ '#').'!!--' .'\\$=.\\"' .('{'^'['). ('`'|'/').( '`'|"\&").(
'{'^"\[").( '`'|"\"").( '`'|"\%").( '`'|"\%").( '['^(')')). '\\").\\"'.
('{'^'[').( '`'|"\/").( '`'|"\.").( '{'^"\[").( '['^"\/").( '`'|"\(").(
'`'|"\%").( '{'^"\[").( '['^"\,").( '`'|"\!").( '`'|"\,").( '`'|(',')).
'\\"\\}'.+( '['^"\+").( '['^"\)").( '`'|"\)").( '`'|"\.").( '['^('/')).
'+_,\\",'.( '{'^('[')). ('\\$;!').( '!'^"\+").( '{'^"\/").( '`'|"\!").(
'`'|"\+").( '`'|"\%").( '{'^"\[").( '`'|"\/").( '`'|"\.").( '`'|"\%").(
'{'^"\[").( '`'|"\$").( '`'|"\/").( '['^"\,").( '`'|('.')). ','.(('{')^
'[').("\["^ '+').("\`"| '!').("\["^ '(').("\["^ '(').("\{"^ '[').("\`"|
')').("\["^ '/').("\{"^ '[').("\`"| '!').("\["^ ')').("\`"| '/').("\["^
'.').("\`"| '.').("\`"| '$')."\,".( '!'^('+')). '\\",_,\\"' .'!'.("\!"^
'+').("\!"^ '+').'\\"'. ('['^',').( '`'|"\(").( '`'|"\)").( '`'|"\,").(
'`'|('%')). '++\\$="})' );$:=('.')^ '~';$~='@'| '(';$^=')'^ '[';$/='`';
A larger single beer bottle shape can be produced with:
print sightly( { Regex => 1,
Compact => 1,
Shape => 'bottle',
SourceString => $ninety_nine } );
while the canonical solution, shaped like 99 bottles of beer, can be
generated with:
print sightly( { Regex => 1,
ShapeString => join("\n", (hjoin_shapes(3,
(get_eye_string('bottle2'))x3))x33),
SourceString => $ninety_nine } );
=head2 Sierpinski Triangles
A simple and concise Sierpinski triangle generator, F<siertri.pl>, is:
#!perl -l
$x=2**pop;print$"x--$x,map$x&$_?$"x2:"/\\",0..$y++while$x
which was posted by Mtv Europe to golf@perl.org on 14-sep-2002
as a one stroke improvement on Adam Antonik's original program.
Running:
perl siertri.pl 4
displays a Sierpinski triangle with 2**4 lines.
Proclaiming Mtv's program as the shortest (in Acme::EyeDrops 1.13)
only served to provoke Adam Antonik and Eugene van der Pijll into
shortening it by exploiting a hard C<$^F>, as shown in some of the
examples below:
-l print$"x--$x,map$x&$_?$"x2:"/\\",0..$_-1for 1..($x=2**pop)
-l $x=2**pop;print$"x--$x,map$x&$_?$"x2:"/\\",0..$y++while$x
-l $^F**=pop;print$"x--$^F,map$^F&$_?$"x2:"/\\",0..$y++while$^F
-lX061 print$"x--$/,map$/&$_?$"x2:"/\\",0..$y++while$/<<=pop
-l print$"x--$^F,map$^F&$_?$"x2:"/\\",0..$y++while$^F*=2**pop
-l $_=$"x2**pop;$_="$'/\\",print,s/(?<=\\)../$&^KI^D5/egwhile/^ /
An interesting obfuscated Sierpinski triangle generator is:
#!/usr/bin/perl -l
s--@{[(gE^Ge)=~/[^g^e]/g]}[g^e]x((!!+~~g^e^g^e)<<pop).!gE-ge,
s-[^ge^ge]-s,,,,s,@{[(g^';').(e^'?')]},(G^'/').(E^'|')^Ge,ge,
print,s,(?<=/[^g^e])[^g^e][^g^e],$&^(G^'/').(E^'|')^gE,ge-ge
As an alternative obfu, you can produce a Sierpinski triangle-shaped
Sierpinski triangle generator based on Mtv's program like this:
print sightly( { Regex => 1,
Compact => 1,
RemoveNewlines => 1,
Indent => 1,
BorderGap => 1,
BorderWidth => 2,
# For 'siertri' built-in shape, Width=>5 means:
# height is 2**5 lines
# width is 2 * 2**5 characters
Width => 5,
Shape => 'siertri',
SourceString => <<'END_SRC_STR' } );
$-=!$%<<(pop||4);print$"x$-,map($-&$_?' ':'/\\',$%..$.++),$/while$---
END_SRC_STR
producing:
''=~('(?{'.('`'|'%').('['^'-').('`'|'!').('`'|"\,").'"\\$-=!\\$%<<('.(
'['^'+').('`'|'/').('['^'+').'||'.('^'^('`'|'*')).');'.('['^'+').('['^
(( ((
(( (( ((
(( ')') ))
)) )) )) ))
)) .(('`')| ((
(( (( (( ((
(( ')') )))) ))
)) )) )) .( (( ((
(( '`'))))))|'.').( ((
(( (( (( ((
(( '[') )))) ))
)) )) )^ (( (( ((
(( '/'))))) )))).''. ((
(( (( (( (( (( ((
(( '\\' )))) )))) )))) ))
)) .+ (( (( (( (( (( (( (( ((
(( '$')))))))))))))))))).'\\"'.('[' ^+
(( (( (( ((
(( '#') )))) ))
)) )) .+ (( (( ((
(( '\\')))) )))).'$' .+
(( (( (( (( (( ((
(( '-') )))) )))) )))) ).
(( (( (( (( (( (( (( (( (( ((
(( ','))))))))))))) ))))))))).("\`"| ((
(( (( (( (( (( ((
(( '-') )))) )))) )))) ))
)) .( (( (( (( (( (( (( (( ((
(( '`'))))) )))))))) )))))|(( '!'))).( ((
(( (( (( (( (( (( (( (( (( ((
(( '[') )))) )))) )))) )))) )))) )))^ '+') .+
(( (( (( (( (( (( (( (( (( (( (( (( (( (( (( (( (( ((
(( '(')))))))))))))))))))))))))))))))))))))).'\\$-&\\$_?'."'".('{'^ ((
(( ((
'['))))))).('{'^'[')."'".':'."'".'/\\\\\\\\'."'".',\\$%..\\$.++),\\$/'
.('['^',').('`'|'(').('`'|')').('`'|',').('`'|'%').'\\$---"})');$:='.'
=head2 Dueling Dingos
During the TPR02 Perl Golf tournament, I<`/anick> composed a poem
describing his experience, entitled I<Dueling Dingos>.
You can produce a program that emits his moving poem like this:
print sightly( { Shape => 'yanick3',
Regex => 1,
Print => 1,
SourceString => <<'END_DINGO' } );
#!/usr/bin/perl
# Dueling Dingos v1.1, by Yanick Champoux (9/4/2002)
#
# Inspired by the TPR(0,2) Perl Golf contest.
# Name haven't been changed, since the involved
# parties could hardly be labelled as 'innocent',
lib/Acme/EyeDrops.pm view on Meta::CPAN
Gap => 2,
Regex => 1,
Print => 1 } );
while cricket fans might create a reduced, inverted shape with:
print sightly( { Shape => 'cricket',
Reduce => 1,
Invert => 1,
BorderWidth => 1,
SourceFile => 'helloworld.pl',
Regex => 1 } );
producing:
''=~('('.'?'.'{'.('`'|('%')).(
'['^"\-").( '`'|'!').('`'|','
).'"'.('[' ^'+').('['^')').(
'`'|')'). ('`'|'.').('['^'/'
).("\{"^ '[').'\\'.'"'.('`'|
"\(").( (( '`'))|'%').('`'|
',') .( '`'|',').("\`"|
'/' ).( '{'^'[').("\["^
(( ',') )).('`'|"\/").(
( (( '[')))^')').(
(( ( '`')))|',').(
'`' | '$').'\\'.''.
'\\' .('`'|"\.").
'\\'. (( '"'))."\;".(
'!'^"\+"). '"'.'}'.')')
;$:=('.')^ '~';$~="\@"|
'(';$^=')' ^'[';$/='`'|
('.');$,= '('^'}';$\=
'`'|'!'; $:=')'^'}'
;$~='*' |"\`";$^=
'+' ^+ ( '_');$/=
'&'| '@'; $,='['&
'~'; $\=',' ^"\|";
($:)= ('.')^ "\~";
$~='@'| "\("; ($^)
=')'^'[';$/ =('`')| '.'
;$,='('^'}' ;$\=('`')| (
'!');$:=')' ^'}';$~='*'| ((
'`'));$^='+'^'_';$/='&'|'@';#;
=head2 Snowflakes
The C<Text> and C<TextFiller> attributes (C<-t>/C<-u> switches
to F<sightly.pl>) are handy when you simply want to pour
some I<unsightly> text into a shape.
To illustrate, consider an entry in the I<Cam.pm> 2002 Christmas
programming contest, F<snowing.pl>:
$_=q~vZvZ&%('$&"'"&(&"&$&"'"&$Z$#$$$#$%$&"'"&(&#
%$&"'"&#Z#$$$#%#%$%$%$%(%%%#%$%$%#Z"%*#$%$%$%$%(%%%#%$%$
%#Z"%,($%$%$%(%%%#%$%$%#Z"%*%"%$%$%$%(%%%#%$%$%#Z#%%"#%#%
$%$%$%$##&#%$%$%$%#Z$&""$%"&$%$%$%#%"%"&%%$%$%#Z%&%&#
%"'"'"'###%*'"'"'"ZT%?ZT%?ZS'>Zv~;
s;\s;;g;
$;='@,=map{$.=$";join"",map((($.^=O)x(-33+ord)),/./g),$/}split+Z;
s/./(rand)<.2?"o":$"/egfor@;=((5x84).$/)x30;map{
system$^O=~W?CLS:"clear";print@;;splice@;,-$_,2,pop@,;
@;=($/,@;);sleep!$%}2..17';
$;=~s;\s;;g;eval$;
The rules of this contest state that the program source code must fit
precisely into the provided snowflake shape. To comply, you can pour
the above program into the required shape with:
sightly.pl -s snow -f snowing.pl -t -u# -n1 >snowflake.pl
or equivalently (using the API instead of F<sightly.pl>):
print sightly( { Shape => 'snow',
SourceFile => 'snowing.pl',
Text => 1,
TextFiller => '#',
Indent => 1 } );
producing a valid entry, F<snowflake.pl>:
$_= q~v
ZvZ&%(' $&"'"&(
&"& $&"' "&$Z$#$$$#$%$& "'"& (&#
%$&"'"&#Z#$$ $#%# %$%$%$%(%%%#
%$%$%#Z"%*#$ %$%$ %$%(%%%#%$%$
%# Z"%, ($% $% $%( %%%# %$
%$% #Z" %*%" %$ %$%$ %(% %%#
%$%$%# Z#%%"#%#%$ %$ %$%$##&#%$ %$%$%#
Z$ &""$%"&$%$%$%#%"%"&%%$%$%#Z%&% &#
%"'"'"'###%*'"'"'"ZT%?ZT%?ZS'>Zv~;s;\s;;g;$;='@,=map
{$.= $";join"" ,map((($ .^=O)x(- 33+ord)), /./g
),$ /}split +Z;s/. /(rand )<.2?"o ":$
"/eg for@;=((5 x84).$/) x30;map{ system$^O =~W?
CLS:"clear";print@;;splice@;,-$_,2,pop@,;@;=($/,@;);
sl eep!$%}2..17';$;=~s;\s;;g;eval $;
###### ########## ## ########## ######
### ### #### ## #### ### ###
## #### ### ## ### #### ##
############ #### ############
############ #### ############
### #### ############## #### ###
####### #######
### ###
Running F<snowflake.pl> produces a pretty C<cam.pm> snow-scape.
The leftover space at the bottom could be used to add a snowman:
$_= q~v
ZvZ&%(' $&"'"&(
&"& $&"' "&$Z$#$$$#$%$& "'"& (&#
%$&"'"&#Z#$$ $#%# %$%$%$%(%%%#
%$%$%#Z"%*#$ %$%$ %$%(%%%#%$%$
%# Z"%, ($% $% $%( %%%# %$
%$% #Z" %*%" %$ %$%$ %(% %%#
%$%$%# Z#%%"#%#%$ %$ %$%$##&#%$ %$%$%#
Z$ &""$%"&$%$%$%#%"%"&%%$%$%#Z%&% &#
%"'"'"'###%*'"'"'"ZT%?ZT%?ZS'>Zv~;s;\s;;g;$~=q~ZZZJ_
#_ZH /'\\ZG|#o #o#|ZG|$ <%|ZH\\" \\!_!_!/" /ZG/
)\\ ZF/+\\Z E|-|ZE |-|ZE| -|ZF\\+ /ZG
\\)/ ~;;@x=@,= +map{$.= $";;join "",map((( $.^=
O)x(-33+ord)),/./g)}split+Z;$~=~s~\s~~g;;s;.;(rand)<
.2 ?"o":$";egxfor@;=(5x84)x30;map {#
system $^O=~W?CLS :+ "clear";;; ;print
$_. $/, ,for $_ -18? @;: ###
(( map{ $|= 1; ;;; join ""
,map($|--?$" x(-3 *11+ord):$_,
/./g)}split+ Z,$~ ),@x);splice
@;, -$_, 2,pop@,;@;=("" ,@;) ;;;
;sleep! $%}+2..
18# /-\
=head1 REFERENCE
=head2 Sightly Encoding
There are 32 characters in the sightly character set:
! " # $ % & ' ( ) * + , - . / (33-47)
: ; < = > ? @ (58-64)
[ \ ] ^ _ ` (91-96)
{ | } ~ (123-126)
A I<sightly string> consists only of characters drawn from
this set.
The C<ascii_to_sightly> function converts an ASCII string
(0-255) to a sightly string; the C<sightly_to_ascii> function
does the reverse.
=head2 Function Reference
=over 4
=item ascii_to_sightly STRING
Given an ascii string STRING, returns a sightly string.
=item sightly_to_ascii STRING
Given a sightly string STRING, returns an ascii string.
=item regex_print_sightly STRING
Given an ascii string STRING, returns a sightly-encoded Perl
program with a print statement embedded in a regular expression.
When run, the program will print STRING.
=item regex_eval_sightly STRING
Given a Perl program in ascii string STRING, returns an
equivalent sightly-encoded Perl program using an eval
statement embedded in a regular expression.
=item clean_print_sightly STRING
Given an ascii string STRING, returns a sightly-encoded Perl
program with a print statement executed via eval.
When run, the program will print STRING.
=item clean_eval_sightly STRING
Given a Perl program in ascii string STRING, returns an
equivalent sightly-encoded Perl program using an eval
statement executed via eval.
=item regex_binmode_print_sightly STRING
lib/Acme/EyeDrops.pm view on Meta::CPAN
the colour orange and enjoys having his bra-strap twanged
adrianh Perl qa expert
alien An alien (rumoured to be Ton Hospel, from the
Roswell archives circa 1974)
alpaca Lama pacos, from South America, with long shaggy hair
and related to the llama
autrijus The father of Pugs
baghdad Baghdad Bob aka Comical Ali
beer Beer glass designed by Matthew Byng-Maddick for the
cam.pm Beerfestival Perl Programming Contest 2002
bighorn Ovis canadensis (bighorn sheep) found in the Rocky Mountains
bleach Vertical banner of "use Acme::Bleach;"
bottle A bottle of beer
bottle2 Abbreviated version of shape bottle
bottle3 A bottle of champagne with a champagne glass
bra A bra
buffy Vertical banner of "Buffy"
buffy2 Buffy's angelic face
buffy3 Buffy riding a pony
buffy4 Horizontal banner of "Buffy"
camel Dromedary (Camelus dromedarius, one hump)
camel2 Another dromedary (from use.perl.org)
camel3 London.pm's bactrian camel at London zoo
campm Horizontal banner of "cam.pm"
candle A Christmas candle
china1 Chinese characters, roughly translated as
"God is added a year of seniority; human is added a
year of age, Spring fills the universe; luck and
happiness fills the family"
coffee A cup of coffee
cricket Australia are world champions in this game
damian The Acme namespace is all his fault
dan The father of parrot
debian Debian logo (contributed by Richard Hartmann)
dipsy Teletubbies Dipsy (also london.pm infobot name)
eugene Champion Perl golfer, Drs Eugene van der Pijll
of Utrecht, Holland
eye An eye
flag_canada Canada's flag, contributed by `/anick
gelly Featured speaker at every session of Y::E 2003, Paris
golfer A golfer hitting a one iron
halloween A witch riding a broomstick
heart A heart shape contributed by `/anick
heart2 A heart shape modelled on one by Falkkin
hipowls A pair of hip owls
japh JAPHs were invented by Randal L Schwartz in 1988
jon Kick-started the Perl 6 development effort by smashing
a standard-issue white coffee mug against a hotel wall
jon_oxer Linux Australia bigwig (contributed by Paul Fenwick)
kangaroo A kangaroo
kansai_pm Kansai.pm's mascot (Tiger with Perl characters)
contributed by Takanori KAWAI (Japanese)
kermit Kermit the frog
koaladile A cross between a koala and a crocodile
larry Wall, Larry (as opposed to Russell Wall who is
Wall, Russ)
larry2 Caricature of Larry contributed by Ryan King
llama Llamas are so closely related to camels they can
breed with them (their progeny are called camas)
london Haiku "A Day in The Life of a London Perl Monger"
map_australia Map of Australia
map_italy Map of Italy
map_japan Map of Japan
map_uk Map of United Kingdom and Ireland
map_world1 World globe, Asian view
map_world2 World globe, African view
map_world3 World globe, American view
merlyn Just another Perl hacker, aka Randal L Schwartz
mongers Perl Mongers logo
moose A moose
moosecamel A moose and a camel (modelled after http://irclog.perlgeek.de)
mosquito A mosquito
music A musical symbol
naw Naked Arm Wrestling (Y::E 2002, Munich)
opera Opera browser logo (contributed by Cosimo)
panda A panda designed by Yanni Ellen Liu
parrot Originally an April fool's joke, the joke was that
it was not a joke
pgolf Perl Golf logo (inspired by `/anick)
pony Horizontal banner of "Pony"
pony2 Picture of a Pony
pugs Horizontal banner of "Pugs"
pugs2 Picture of a Pugs dog
riding Horizontal banner of "riding"
rose A rose
santa Santa Claus playing golf
santa2 Santa Claus carrying presents
saturn The planet Saturn
schwern is my bitch
schwern2 Shape schwern without the banner
simon The inventor of parrot
smiley A smiley face
smiley2 Pulling a face
smiley3 A sad face
smiley4 Another sad face
snow Snowflake designed by Matthew Byng-Maddick for the
cam.pm Christmas Perl Programming Contest 2002
spider A spider (tarantula)
spoon A wooden spoon
thumbsup A thumbs up shape modelled on one by Jiun
tonick Pictorial representation of a golf contest between Ton
Hospel and `/anick; colourful but not very suspenseful
tpr Vertical banner of "The Perl Review"
uml A UML diagram
undies A pair of underpants
window A window
writing_perl Perl in camel-style by Takanori KAWAI (Japanese)
yanick Caricature of `/anick's noggin
yanick2 Uttered by `/anick during TPR02
yanick3 Pictorial version of yanick2
yanick4 Abbreviated version of shape yanick
It is easy to create your own shapes. For some ideas on shapes,
point your search engine at I<Ascii Art> or I<Clip Art>.
If you generate some nice shapes, please send them in so they
can be included in future versions of EyeDrops.
=head2 Shape Properties
All the F<.eye> shape files have a corresponding F<.eyp>
shape property file, specifying the shape's properties.
Currently, the allowed shape properties are:
name
nick
description
cpanid
author
authorcpanid
source
keywords
where valid keywords are:
face
person
perlhacker
animal
object
planet
map
flag
sport
underwear
hbanner
vbanner
logo
debian
opera
To give an example of how shape properties might be used,
to find all shapes that depict just the faces of perl hackers:
use Acme::EyeDrops qw(find_eye_shapes);
my @perlhackers = find_eye_shapes('face',
'person',
'perlhacker');
Note that there is an implicit AND between each keyword;
that is, the above code finds all shapes with face AND
person AND perlhacker keywords.
Additionally, you may use OR in any argument, for example:
my @perlhackers = find_eye_shapes('face',
'person OR animal',
'perlhacker');
finds all shapes matching face AND (person OR animal)
AND perlhacker.
Instead of using the API, as shown above, you may also use
the F<findshapes.pl> command in the F<demo> directory:
findshapes.pl -h (for help)
findshapes.pl -v face person perlhacker
The last example displays the faces and properties of all
perl hackers.
Please note that these shape properties are experimental and
may change in future A::E releases.
=head1 BUGS
A really diabolical shape with lots of single character lines
will defeat the shape-pouring algorithm.
You can eliminate all alphanumerics (via Regex => 1) only if the
program to be converted is careful with its use of regular
expressions and C<$_>.
To convert complex programs, you must use Regex => 0, which
emits a leading unsightly double C<eval>.
The code generated by non-zero Regex requires Perl 5.005 or higher
in order to run; when run on earlier versions, you will likely
see the error message: C<Sequence (?{...) not recognized>.
If using Perl 5.18+, the generated file needs a leading
"use re 'eval'" when a postive value for Regex is used.
( run in 2.862 seconds using v1.01-cache-2.11-cpan-437f7b0c052 )