obfuscated

Weird number generator (jimt)

So, I was off hunting for another obfuscation/golfing challenge for myself and was thinking about writing up an [wp://Abundant_number|abundant number] generator (I'd discovered an old app I'd done as a wee college student in pascal for my CS 112 class), but considered it too simple a task. A little digging around yielded [wp://Weird_Number|weird numbers], which are, of course, [wp://Abundant_number|abundant numbers] which are not [wp://Semiperfect_number|semi-perfect].

So now I give you, in only 176 characters, a weird number generator.

{$s=eval join'+',@d=grep!($n%$_),1..++$n-1;eval{w(@d,$n)if$s>$n};print$n,$/if$@=~/!/;redo}sub w{my$s=pop||die;my$t=pop||die'!';eval{w(@_,$s-$t)},$@=~/!/||die if$t<=$s;w(@_,$s)}

Note that with only small modifications, this script can also easily print out [wp://Deficient_number|deficient numbers], [wp://Abundant_number|abundant numbers], [wp://Perfect_number|perfect numbers], [wp://Semiperfect_number|semi-perfect numbers], [wp://Multiply_perfect_number|multiply perfect numbers], and who knows how many other variations on the theme. A more interested party may try stepping in to upgrade this program to print out this information (6 P, 10 D, 12 A, 20 S, 70 W, 120 3P, and so on) for all numbers it encounters.

The logic in this one is really tight, but I'm not too happy with the argument passing into the w() function. As always, in deciphering an obfuscation, our first step is to re-format into something more legible.

{  $s=eval join'+', @d = grep !($n%$_), 1..++$n-1;  eval { w(@d, $n) if $s > $n};  print $n,$/ if $@ =~ /!/;  redo}sub w{  my $s = pop || die;  my $t = pop || die '!';  eval { w( @_, $s-$t) },  $@ =~ /!/ || die  if $t <= $s;  w( @_, $s)}

And now we'll attack in parts. First, the while loop. This is extremely easy and just about self-evident.

{  $s=eval join'+', @d = grep !($n%$_), 1..++$n-1;  eval { w(@d, $n) if $s > $n};  print $n,$/ if $@ =~ /!/;  redo}

The number we're checking for weird-ness is $n. So just start off an infinite loop counting up. Note that we actually increment $n inside of the foreach loop.Start off by setting up two variables for this $n, $s (contains the sum of all of its divisors) and @d (which contains the list of all divisors). We build @d by grepping out all the divisors, then link 'em together with pluses and eval it to get the sum.

Now, we iterate in a for loop all digits between 1 and $n - 1. If that number evenly divides $n, then we add it onto the sum, and push it onto our list of divisors. The grep statement there ensures that we're only looking at proper divisors. Also note that I just arbitrarily chose to demontrate that the number is abundant by summing all proper divisors of the number and seeing if it's equal to the number itself, instead of determining that it's 2-perfect by summing all divisors including the number itself and seeing if it's equal to 2 * $n. They're equivalent definitions.

The next eval statement checks a number for semi-perfectness. We'll come back to this. But note that we only perform the check if $s > $n, that is if the sum of all divisors is greater than the number itself, which means that the number is abundant. It can't be weird if it isn't also abundant, and its critical to only perform the check for semi-perfectness if the number is abundant. If you end up checking all numbers, execution speed plummets. For comparison, on my machine, I could spit out the first 32 weird numbers in a minute by only checking the abundants for semi-perfectness. If I checked all numbers for semi-perfectness, I could only do the first 5 weird numbers in a minute.

And finally, just print out the number $n (followed by a newline, conveniently stored in the input record separator, $/) if w() did fail. w() fails if the number is not semi-perfect, and hence in this case it is weird.

Now, the tight logic is in the w() function itself. I think this thing is neat.

sub w{  my $s = pop || die;  my $t = pop || die '!';  eval { w( @_, $s-$t) },  $@ =~ /!/ || die  if $t <= $s;  w( @_, $s)}

Call as eval { w( @divisors, $sum) }

As I said, I'm not happy with the argument passing, but it's there as an extreme optimization. Re-ordering the arguments and just copying off the array ( my ($s, $t, @e) = @_;) causes performance to fall through the floor. So I take the 4 character hit in exchange for the ability to complete in real time. Even twiddling the script to pass in $s and $t as the first arguments and shifting them off grants a noticable performance hit.

Okay, this function will determine if for a given set of natural numbers, is there a subset of those numbers that add up to the given sum. I had originally approached this method completely differently, by trying to come up with all of the possible subsets for the given set, and then checking each of those to see if any of them added up to the sum. This worked, but was very expensive, and potentially wasteful. A function to build subsets by using binary counting is cheap, but character heavy.

So we go this way. First thing we do is pop off the sum we've been passed in and the number we're testing. If there's no sum, then we already recursed down to it, so we succeed - there is a semi perfect subset, so die quietly to fly out of the recursion and be done. If there is no number to test, then die with a bang ('!') - we've run out of numbers, so this sequence does not yield a semi-perfect result. If we have a number to test, we continue.

Next steps. If we're here, then we have a number to test, and we haven't reached the sum yet. If the number we're testing is less than our sum ($t < $s), then it's possible that the number is part of a semi-perfect subset. So in that case, we're going to recurse into our function, subtracting the test number from our sum. And we repeat.

Now, when we're done with that eval, if we died with a bang, then we want to keep checking - all we know is that that subset failed. However, if we died without a bang, then we found a successful subset, so we bubble up another die to jump out of our recursion with our "success" message. That is, if we died with a bang, we've got to keep checking, so we discard that test digit from out set and re-enter the function with the rest of the numbers in the set + our original sum. At this point, we've determined that that test digit cannot be in any subset that adds up to our sum. However, if we did NOT die with a bang, then we succeeded, so just bubble up the bangless die to jump out.

If we fall down to the last statement ( w(@_, $s) ), that means that our test number ($t) was greater than the sum we were checking, so we just throw it away (it was already popped off) and recurse back in w/o it. Once inside, we'll either end up succeeding or dying anyway.

12 is abundant (but not weird), so here's a sample runthrough of the function.

w(1,2,3,4,6, 12);w(1,2,3,4, 6);w(1,2,3, 2);w(1,2, 2);die (2 == 2), therefore 12 is semiperfect

Here's a runthrough of Limbic~Region's example set + sum below (1, 7, 11, 14, 18, 21), to give a more complex example:

w(1,7,11,14,18, 21)w(1,7,11,14, 3)#21 - 18 becomes new product, toss onto the end# 14 > 3, ignore it, continuew(1,7,11, 3)# 11 > 3, ignore it, continuew(1,7, 3)# 7 > 3, ignore it, continuew(1, 3)# 1 <= 3, subtract from 3, continuew(2)#pop off our sum (2), and our test digit. Oops!#No test digit, die with a bang, we failed.#hops all the way back up to here, throws away 18, and continues.#it has determined there is no subset that contains 18 and adds to 21.w(1,7,11,14, 21)w(1,7,11, 7)#21 - 14 becomes new product, toss onto the end# 11 > 7, ignore it, continuew(1,7, 7)# 7 <= 7, subtract it from 7, continuew(1, 0) #pops off the sum, which is 0 in this case, so we've succeeded. "die" with no bang -> success!

Update: Shaved off a character.

Update 2: Shaved off 10 more characters.

Update 3: Shaved off another 13 characters. Obviously, this wasn't as golfed as I'd originally thought. Wow.

Update 4: Added in another example, explaining Limbic~Region's example set below

JABWT (ailivac)

I assume this has been done before, but since the Burrows-Wheeler transform seemed like such a cool way to obfuscate text, I decided to write my own japh with it.

my$l='}(yr=etd4d)c305123826312366135714622,,,,,,,,,,,811=1,1,-(,--,,,,17-,81111-08,6-0-7,-,-,,--)0dc+t(y$$(@@@liswchhri;>!!This just takes a string that has been encoded with the BWT, decodes it, and passes it to eval. The string itself is a minimally obfucated perl program to display a string encoded as a list of numbers
Here is the short program I wrote to compute the BWT
my$in="$ARGV[0]\0";sub n{substr($_[0],1).substr($_[0],0,1)}my($r, @r)=(n($in),$in);while(${r}ne$r[0]){push@r,$r;$r = n($r);}@r=sort@r;my$l=join'',map{substr($_,-1,1)}@r;
The null character is used as an end of line indicator, just so the sorting is easier. In the first program, the null is replaced with ">!<" for storage.

integer partition golf (jimt)

Yes, yes, this has [id://78334|been done before] (hasn't everything?), but I think this still comes out to be the most compact method to actually calculate and display partitions of integers. The previous thread had people just trying to calculate them in memory. This one takes a single integer on the command line and goes to town.

sub p{my($n,@e,$o)=@_;print if!$_{$_=join$",sort@_,$/}++;p(++$o,--$n,@e)while$n-1}p(shift)

90 characters! woo hoo! I only beat [id://78389|tilly's solution] by 1 character, once I appended print@$_,$/for P(shift) to it. A more compact printer added on to it would render that one the winner.

Update: Ya know, one of these days, my golf game'll be good enough that I'll post and someone won't immediately respond and say "I can shave off another character!" heh. Props to liverpole and blazar. I incorporated their suggestions, plus another one I thought of to drop down to 83.

sub p{my($n,@e,$o)=@_;$_{$_=join$",sort@_,$/}++||print;p(++$o,$n,@e)while--$n}p pop

Update 2: And 80

sub p{my(@e,$o)=@_;$_{$_=join$",sort@_,$/}++||print;p(++$o,@e)while--$e[0]}p pop

I'm pretty proud of this one. I think my golf game is improving. As always, let's reformat for clarity.

sub p{my($n,@e,$o) = @_;print if ! $_{$_ = join$",sort@_,$/}++;p(++$o, --$n, @e) while $n-1;}p(shift)

This one's so tight it's gonna be a real bitch to explain. it's a recursive function, and each sub-call hands in one less than the number it previously had, in addition to a counter counting up to where it previously was, plus any other arguments it had received. I'll walk this through in a bit.

my($n,@e,$o) = @_;#note this is the same as:my $n = $_[0];my @e = @_;my $o;

print if ! $_{$_ = join$",sort@_,$/}++;

This is the bulk of the magic. Internally, it pulls in and sorts the arguments it was handed. So, for example, if we're partitioning 15, on one call this function would receive (11,2,1,1) (in some order). So here we sort it (1,1,2,11) along with $/ (input record terminator, defaults to "\n", invaluable for obfuscations). This has the unfortuate side effect of printing the newline first, then the output, but que sera sera.

It's sorted so that we can subsequently return with the same arguments in a different order but not reprint. It assigns that sorted business to $_, and uses the whole ball of wax as a hash key which it post-increments.

We then call print w/o arguments (defaults to $_, which we just assigned back in that hash key), only if the value of the key in the hash == 0. That is, only the first time that string is encountered. This prevents duplicates.

We then recurse. We hand off an arbitrary counter that constantly goes up, our original number, decremented, and anything else we were originally handed in. Repeat as long as the number exists.

Sample runthrough: (unless I inserted a logic error)

p(5)  outputs 5  calls p(1,4)    outputs 1,4  calls p(2,3)    outputs 2,3    calls(1,1,3)    outputs 1,1,3  calls p(3,2)    calls(2,2,1)      outputs 1,2,2      calls(1,1,2,1)        outputs 1,1,1,2  calls p(4,1)    calls p(3,2,1)      calls p(2,2,1)        calls p(1,1,2,1)      calls p(2,1,1,1)        calls p(1,1,1,1,1)          outputs 1,1,1,1,1

Faster japh (ambrus)

use warnings; use strict; @,=unpack"C*","mG\e:*\cZM\b?~O\xf"."*qGH_t2#OS/HU\ckE\34.OM\b";for$,(0..4){1<<$,&$_,or$,[uc]+=$,[2**$,+abs]-=64*($,[lc]*=2),for+0..31}print+chr($_%127)for@,,

This is a nicer variant of [id://577876] using a simple idea from [id://309529].

Polynomial JAPH (tweetiepooh)

Not sure if this belongs here but I can't hide the code and give credit to the original source.

When I worked for a company writing education software many moons ago on the BBC micro we had a product that would work out the polynonial function for a sequence of number. We actually used this in some crude protection schemes.

Excel offers a smaller version of this in trending so I thought I could use the principle to generate a JAPH. Limitations in Excel mean accuracy is limited to 6 characters at a time.

I dare say those with a more maths bent can get this even better.

#!/usr/local/bin/perl -wuse strict;map{ eval}('map{printf "%c" ,3.55*$_**5-57.583*$_**4+347.75*$_**3-972.92*$_**2+1249.2*$_-463.5}(1..6)','map{printf "%c", -0.55*$_**5+10.208*$_**4-69.833*$_**3+215.29*$_**2-292.12*$_+247.5}(1..6)','map{printf "%c", 1.25*$_**5-25.333*$_**4+191.25*$_**3-672.17*$_**2+1099*$_-561.5}(1..6)','map{printf "%c", 0.5833*$_**5-9.4583*$_**4+56.167*$_**3-148.54*$_**2+169.25*$_+36.5}(1..6)');print "\n"

Note I'm not a mathematician so if this is named wrongly and someone else already has this then I appologise.

Update

With some playing I have this down to

for('3.55*$i**5-57.583*$i**4+347.75*$i**3-972.92*$i**2+1249.2*$i-463.5','-0.55*$i**5+10.208*$i**4-69.833*$i**3+215.29*$i**2-292.12*$i+247.5','1.25*$i**5-25.333*$i**4+191.25*$i**3-672.17*$i**2+1099*$i-561.5','0.5833*$i**5-9.4583*$i**4+56.167*$i**3-148.54*$i**2+169.25*$i+36.5'){{for$i(1..6){printf"%c",eval$_}}};

Update 2This is now at 306 chars.

map{$i=$_%6+1;print chr${[3.55*$i**5-57.583*$i**4+347.75*$i**3-972.92*$i**2+1249.2*$i-463.5,-0.55*$i**5+10.208*$i**4-69.833*$i**3+215.29*$i**2-292.12*$i+247.5,1.25*$i**5-25.333*$i**4+191.25*$i**3-672.17*$i**2+1099*$i-561.5,0.5833*$i**5-9.4583*$i**4+56.167*$i**3-148.54*$i**2+169.25*$i+36.5]}[$_/6]}(0..23)

s/Perl hacker,/plagiarized node\n/; (Hue-Bond)

Since this is a hot topic, I decided to make a slightly different JAPH^HN ;^).

$~=@$b/2;for($;=$|++;(($:,$a)=($$b[$;],$$b[$;+$~]))&&$a=~/^\d+$/||($\=$/,print("@$b[$~*2...3+$~*2]"),-0);$;++){BEGIN{@$b[1,3,4,6,2,5,$|]=(("aaaa")x4,("aaa")x2,"Aaaa");@$b[9,8,12,11,7,13,10]=sort{$a<=>$b}(4853,271082,9171,17007,238034,141058,172191)}$:++for 1..$a;push@$b,$:;$;<2&&next;40%$;or$$b[$#$b-1].=pop@$b}

--
David Serrano

The Shining (reasonablekeith)

Okay, so it's not the best code ever, and I wouldn't have started it were it not for Acme::Bleach, but it made me chuckle, and it is Friday :)

NOTE 1: like Bleach, this overwrites your source code on first run.

NOTE 2: The correct pronunciation is 'shin'-'ing', (do you want us to be sued?) :)

#!/usr/bin/perluse Acme::The_Shining;all wOrK anD NO play mAKEs jAck A DuLl bOyALl WORk aND No Play mAkes jack A dulL boY.alL work ANd nO pLaY MAkeS jaCK a dUlL boY.alL WOrK ANd nO PlaY makes jAck A dUll BOy.ALL WoRK aNd no pLAy MAKes JAcK A DulL BOY.alL woRk and No PlAY MakeS JaCK A dulL boy.All wORK aND

I'm sure that this can be done a lot more efficiently, but I only did it for giggles, so all you golfers out thereplease feel free to knock this down to 6 characters.

Very simply, it encodes the original program in to a binary represention using uppercase for 1's and lowercase for 0's.

here's the source...

package Acme::The_Shining;$VERSION = '0.01';my $template = "\nall work and no play makes jack a dull boy.";my $buff = reverse $template;sub encode { while ($_[0] =~ m/(.)/sg) { foreach my $bit (split //, sprintf  "%08b", ord($1)) { while(1){($char = get_char()) !~ /[a-z]/ or last; $rts  .= $char;} $rts .= $bit ? uc($char) : $char; } }$rts }sub decode { while ($_[0] =~ m/(.)/sg) { my $char = $1; next if $char !~  m/[a-z]/i; $bin .= $char eq uc $char ? 1 : 0;if (length($bin) == 8 ) {  $rts .= chr(to_dec($bin)); $bin = ""; } }$rts }sub get_char {$buff=length($buff)<2 ? $buff. reverse$template:$buff;chop $buff}sub to_dec { return unpack("N", pack("B32", substr("0" x 32 . shift, -32))) }sub is_shiny { $_[0] =~ m/^[abcdejklmnoprsuwy. \n]*$/si };open 0 or print "Can't repolish '$0'\n" and exit;my $pgm = join "", <0>;my ($head,$code) = ($pgm =~ m/(.*^\s*use\s+Acme::The_Shining\s*;\n)(.*)/sm);exit eval($head . "\n" . decode($code)) if is_shiny($code);open 0, ">$0" or print "Can't polish '$0'\n" and exit;print {0} $head, encode($code) and exit;

---
my name's not Keith, and I'm not reasonable.

Sometimes I wonder Y (cephas)

Aristotle wrote a good journal entry about the Y-combinator here. But it really made me ask:

                            sub{        my($f        )=@_ ;sub{                             my(        $x)         =@_     ;$f                              ->(       sub         {$x    ->($x                               )->     (@_)           })   }->(                                sub   {my(                $y)=                                 @_; $f->               (sub                                  {$y->                 ($y)                                 ->(@_                  )})}                                )}->                    (sub                               {my(                     $r)=                              @_;                       sub{                             my$l                       =pop                            @_;                         print                          "$l";                         if($#_                         <0){       print$/;return;}$r->(                            @_);}})->(qw(r o t a n i b m o c                             - Y));

I find the code more interesting than the art...

The accidental fractal (jimt)

So I was golfing down my code for my [id://574225] and had gotten down to 287 characters. But I could use one of the tricks I thought up to shave down [teamster_jr]'s version to 285 characters, so I wasn't going to claim the lead yet.

I flipped around the logic in the main conditional and shaved it down to 283 characters (I thought) and figured that would do it. But instead of playing the game of life, the gameboard instantly converged on the [wp://sierpinski gasket]. That's right - instead of creating a shorter version of the game of life, I'd accidentally created a fractal generator.

I went through and ripped out all the unnecessary game of life stuff from it (looping, timers, random seeding of cells, etc.) and the result is a pure ascii output of the sierpinski gasket. I also re-formatted it to be somewhat easier to read, but remember, this is the result of golfing and obfuscation, so it still won't be that easy to read.

my $s = 150;@a = 0..$s;for $r (@a) {  $b[$r][$_] = $" for @a }{  for $r (@a) {    for (@a) {      $h = 0;      for $i ($r-1..$r+1) {        for $j ($_-1..$_+1) {          $h++ if            $b[$i][$j] ne $"            & $i >= 0            & $i <= $s            & $j >= 0            & $j <= $s            & $i ^ $r            & $j ^ $_        }      }      $e[$r][$_] = $h == 3        ? 0        : $b[$r][$_] ne $" & $h == 2          ? 0          : $"    }  }  print map{ @{$e[$_]}, $/ } @a;}

I just think it's incredible that an incorrect application of DeMorgan's rules was all it took to turn the game of life into the sierpinski gasket. Stephen Wolfram would be proud of me. It sure made my day.

Let The Games Begin! (zshzn)

I, for one, am terribly excited over the upcoming chess match in Kalmykia starting tomorrow. Finally, the chess world gets to reunite under one champion, and, not coincidentally, both competitors are very worthy of the title. It should be a match defining its generation. So I thought I would hail the coming of the new world with this humble knight, who will remind us of where the two competitors left off against each other.

       $b[$_]=chr      ($_%9?0x2E :     0xA)for 1..72;    $d="6r7k15p17p23   n25p32p34b37p39b41  P55P60 Q61P62P65q66 N67R6   9R71K";$d=~  s/\s   +//xg;$b[$1        ]=$2while$d=~        /(\d+)(\D)/g;       $d="Kramnik";$c      ="Topalov";shift      @b;unshift @b,' '          .$c,chr        10;push @b,$       d,chr 0xA; $,=     chr 0x20; print@b;

Who are you rooting for?

--
brian d foy's embarrassment to Perl, and just a mean person.

Game of Life (jimt)

I don't know if this would be considered an obfuscation or a golfing exercise, but nonetheless, in only 451 characters, I present you with [link://http://en.wikipedia.org/wiki/Conway%27s_Game_of_Life|John Conway's Game Of Life].

my($a,$c,$g,@b)=(40,10);$\=$/;for my$r(0..$a){$b[$r][$_]=!int(rand($c))?'*':$"for(0..$a)}sub g{my($d,@e);for my$r(0..$a){for(0..$a){my$h=0;formy$i(-1..1){for my$j(-1..1){my($f,$g)=($r+$i,$_+$j);next if$f<0||$f>$a||$g<0||$g>$a||!($i||$j);$h++if$b[$f][$g]ne$"}}$e[$r][$_]=($b[$r][$_]ne$"&&$h==2)||$h==3?'*':$";$d++if$e[$r][$_]ne$b[$r][$_]}}@b=@e;$d}do{print`clear`,++$g;for my$r(0..$a){print map{$b[$r][$_]} (0..$a)}select $&,$&,$&,.4}while(&g)

Update - Using a few tricks I picked up from teamster_jr's wonderful version below (and a few golf tricks I always seem to forget to implement, I knocked it down to 366 characters.

$a=40;$\=$/;@a=0..$a;for$r(@a){$b[$r][$_]=!int rand 10?0:$"for@a}sub g{my($d,@e);for$r(@a){for(@a){$h=0;for$i(-1..1){for$j(-1..1){$f=$r+$i;$k=$_+$j;$h++if$b[$f][$k]ne$"&&!($f<0||$f>$a||$k<0||$k>$a||!$i&&!$j)}}$*=$e[$r][$_]=$h==3?0:$b[$r][$_]ne$"&&$h==2?0:$";$d++if$*ne$b[$r][$_]}}@b=@e;$d}{print"\ec",++$g,$\,map{@{$b[$_]},$\}@a;select$&,$&,$&,.1;redo if&g}

Note that this spoiler applies to the original 451 character version. This one's pretty straightforward once you re-format:

my ($a, $c, $g, @b) = (40, 10);$\=$/;for my $r (0..$a) { $b[$r][$_] = ! int(rand($c)) ? '*' : $" for(0..$a)}sub g { my ($d, @e); for my $r (0..$a) {  for (0..$a) {   my $h=0;   for my $i (-1..1) {    for my $j (-1..1) {     my ($f, $g) = ($r + $i, $_ + $j);     next if $f < 0 || $f > $a      || $g < 0 || $g > $a      || !( $i || $j );     $h++ if $b[$f][$g] ne $"    }   }   $e[$r][$_] = ( $b[$r][$_] ne $" && $h == 2 ) || $h == 3    ? '*'    : $";   $d++ if $e[$r][$_] ne $b[$r][$_]  } } @b=@e; $d}do{ print`clear`, ++$g; for my $r (0..$a) {  print map { $b[$r][$_] } (0..$a) } select $&, $&, $&, .4} while (&g)

But I'll do you one better! It's even more straightforward when you rename the variables to something useful.

my ($board_size, $random_seed, $generation, @board) = (40, 10);$\=$/;for my $r (0..$board_size) { $board[$r][$_] = ! int(rand($random_seed)) ? '*' : $" for(0..$board_size)}sub generate { my ($evolved, @new_board); for my $r (0..$board_size) {  for (0..$board_size) {   my $neighbors=0;   for my $i (-1..1) {    for my $j (-1..1) {     my ($neighbor_row, $neighbor_col) = ($r + $i, $_ + $j);     next if $neighbor_row < 0 || $neighbor_row > $board_size      || $neighbor_col < 0 || $neighbor_col > $board_size      || !( $i || $j );     $neighbors++      if $board[$neighbor_row][$neighbor_col] ne $"    }   }   $new_board[$r][$_] =    ( $board[$r][$_] ne $" && $neighbors == 2 ) || $neighbors == 3     ? '*'     : $";   $evolved++ if $new_board[$r][$_] ne $board[$r][$_]  } } @board=@new_board; $evolved}do{ print`clear`, ++$generation; for my $r (0..$board_size) {  print map { $board[$r][$_] } (0..$board_size) } select $&, $&, $&, .4} while (&generate)

At this point, I'll leave the rest of the explanation as an exercise for the reader.

Looking for the Obfuscation Hints (shlomif)

Hi all!

I'm the editor of the Dmoz.org Perl "FAQs, Help and Tutorials" category. In the course of my work, I now have the following broken link:

http://jynx.perlmonk.org/content/obfuhints.shtml

This is the domain perlmonk.org which belongs here. I'd like to know where I can find this page again.

Regards, -- Shlomi Fish

The Undefinite Japh (liz)

@x=split$y,q{Tie Just Another Perl HackerFirst};$"=$y,;eval uc("*a'@x[29,18,33,24,22]").'=sub{$x[$y++],};'.uc("*a'@x[0..2]").(ref\$y).'=sub{bless\$y,$x[9]}';($a=$b="Internal::READONLY\${\\undef},0")=~s#::?#s::Sv#x;eval$a;tie${\undef},$x[9];$a=();$b=();$c=();$d=undef;print@a[99..123]=();

Inspired by Juerd's undefined presentation at YAPC::Europe 2006.

Liz

Pi golf: (Robbjedi)

One liners to output approximations of Pi to arbitrary precision!Note: The idea is for the program to directly calculate pi rather than obfuscate it in the code somehow.I will start us off at 82, a lot of room for improvement:

@_=map(1/$_,map($_**2,1...1000000));for $a(@_){$s+=$_[$i++];}$s*=6;print sqrt($s);

Edit:Cleaned up a bit for 68:

for(@_=map(6/$_,map($_**2,1..1000000))){$s+=$_[$i++]}print sqrt($s);

Edit edit: We both realized the same thing at the same time apparently.

First obfuscation (Robbjedi)

Not brilliance, but not horrible for a first ( at least I hope?)

        for($i=1;$i<1000000;               $i++)        {@.                     [$i]=((        $i+                     $i+$i+$i+             $i)        *                                   $i        )/                  (5);            $        _+=      (($.[$.[$.[               1]]]        +$.[1])                             /2        ) /$.                              [$i]        ;}$_=                              sqrt        ($_*                                ($.[        2]+2)        );print;

Mary had a Little Camel (SubStack)

perl -e'%c=map{[a..z]->[log($_)/log(2)*8-48],$_}map 2**($_/8),6*8..8*8; print((((chr)x($_/16)).("\x00"x(256-$_)/16))x128)for map{$c{$_},0}"jklkjjj0kkk0j0g0g00jklkjjjjkkjkl"=~/./g'>>/dev/dsp

Optionally, adjust x128 to make it play faster or slower.
(Thanks to tybalt89 on freenode for the =~/./g suggestion)

Visually-Interlaced Mesmerizing Japh (liverpole)

This Japh needs gvim 7.0 installed. (Note that it has to be version 7.0; earlier versions won't support the scripting commands used).

When I wrote [id://567147|this Japh], I didn't know any vim-scripting, so I had to take a more basic approach. Shortly afterwards I devised the algorithm for this one, and thought if I could learn enough vim scripting commands, it shouldn't take more than a couple of days to program. Surprisingly, it took a lot longer than expected, but partly because, as it evolved, I kept wanting to get it "just right". One challenge was "golfing" the vim script to make it all fit into the Japh. (If you know any vim commands, you'll see a lot of command abbreviations :-D).

It's been tested on both Windows and Linux. When you get tired of watching it run, just type ^C to stop. It does create a temp file "v.tmp" which can be deleted afterwards. If there's any interest, I may also provide the "meta-program" which generates the Japh. Of course, it would be fun to see if anyone can figure out the mechanics of how it works first.

s''::jjJjJ:rBBRscCC[kkKjj:JjJ*>>NN>NnFvvV2brrrBb:JZ::jj**:ZJ::JJJ*::jjJj::JBTtTDT4=[sR2rRRr*[k;ZnNn>>.>Dus37GG7GGW7BbrBBZjjjJj::*JjjJ:jZJjZZ*::JbRtddDeUuDbBBr2BrRFnoO/>N.^VB4UCWWGwWWGggffv6brJZjjl,6Vf6FgxHF6f7BrBtxRSsRvvHxrBfFG7BRSwFBr2gwbCgyyyYXxP1q@pp@>^jj:JJZZ0A?N^gG6FfvHHfvvrTsED2scFVFxX6v6FgwBBgwvrRvGG2Rf6XHyIxhQ1@P,:*:Zj</_W6VFvXh88DcsEDbswvVvGI4tfgWFrBww6BbwWgbsvFF0q9XxE=lLZ::*j*%%jJ*:Zk[Jj+K?G6FvV6FcsCBbryyVvFF7Sc7GfFRBvwgC3F_w2bw77?=,Td4MM+:jZJ*:L,**:Zj:;[jjjKkCC7wgGSCrBbgyhF6FfvBBfvvvSsFF6Rb.NFvFrbR*:L4D,.Og8XDd>.JZ*J:j6Hhhvww@`.;]t2BrN*:j%PN:%L*::*TDBR%,*BdtBB[kllJmEB2RZlL:jjZZRBrJ:j:n^NN:ZJ*::,L::JZ,,>_k;;]pnkKlA?/QXrRBmQ_/0Dbw7cm-6IE2C??q`^::+ooSwvN;;.o__JJ*:jZ,;[jj%l3wVS_pLj*M=:.o3Hxb3u8^Zl=m.?K:n>BcCJ+;jFFrbjZZ:J*;k^n``gg6;?PZjj[o.;_nJJbswfk_nJJ*;cr6gs6.:C3v.**;]jK[rFH4BZj;=%nnjRtDB*r22RBrBrC7>ZZjko>[/FbrRcw>:;?.:kK>j>?k:j>O+<^^jmm:^cshxdL+:]=@XVFTdtTjBBrBrrRbbwwCCkk/.KCV6FfwO^jZkoO_nJj^nkk;J?OZ<@Pq/>jZ;o1]k:RCE4FfbbtL::*ZZ*BBRrRbrBrBB*::jjJjZZ*::J::*ZZ*::J::j:j:ZZ*::J::J:Rr2BbBBbr2jZjJj:Z';s!$/!!g;s!%!\\!g;sub l{int((-42+ord pop)/16)}while(s/(.)(.)(.)//){$".=chr(2+5*(5*l($1)+l$2)+l$3)}eval$"#liverpole~Just+another+Perl+hacker

s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/

I'm amusing myself trying to obfuscate a little script ... (hoaf)

... that formats a text file for, um, legibility.

Just cat a file through it and voila! It's pretty.

#!/usr/local/bin/perl -n@x = ( { Begin => "{", End => "}" }, "(?:Attribute|Motion|Transform|World|Frame)" );$i-- if(/^\s*$x[1]End/ && $i);/^\s*\#/?s/^\s*//:s/^\s*/" "x(4*$i)/e;s/^(\s*$x[1](Begin|End).*)$/$1.(m|\#[\{\}]$|?"":" #$x[0]{$2}")/e;print;$i++ if(/^\s*$x[1]Begin/);

Any ideas? I figure that I should be able to do something that combines the two regular expression lines, then do something else to mask the data, but I'm new to the whole obfuscation thing. :^)

Thanks!

hoaf

some substitution code from my C parser (wojtyk)

Wasn't even trying to obfuscate.Just trying to minimize the use of vertical space by compressing maximum functionality into a small space while maintaining clarity.

$stoken = 'STRING';$ltoken = 'LITERAL';# sub out literals, strings, and one-line comments    s#('([^'\\]|\\.)*')                     |      (L?"([^"\\]|\\.)*")                   |      ((_T|_TEXT)\("([^"\\]|\\.)*"\))       |      (/\*([^*]|\*+[^/*])*\*+/)             |      (//[^\n]*)                    #            ( ( defined $1 || defined $5 ) && $ltoken ) ||              ( defined $3 && $stoken )                                    #gexo;

some trigraph conversion code from my C parser (wojtyk)

I wasn't even trying to obfuscate.It just seems senseless to break it out into multiple lines when it just works and minimizes vertical waste

# convert trigraphs automagicallymy $t;s#\?\?([=(/)'-])#($t=$1)&&($t=~tr/=(\/)'-/\#[\\]^{|}~/)&&($t)#ge;

Not a strictly punctuational JAPH (chargrill)

#!/usr/bin/perluse strict;$.=$ ^F,$;=$./$ .,$_=$.<<$ .*$.+$;,$ ==$.<<$.,$ *=$=+$.=>$ %=$.*$_;$ "=$%-$*,$-=$ =-$.=>$?=$ %-$.,$:=$;+$ .;$!=$_/$.,$ @=$"-$=-$ --$:,$/=$?+$;-$*-$:,$#=pack'c*',$_+$ *,$?+$ ;-$*,$?+$ ;-$*-$.,$ "-$.,$!,$_+$ !+$./$.,$"-$=,$"-$=+$./$ .,$ "-$.,$" -$=-$-,$ @,$/,$ !,$_+$ *+$ *-$.*$ .,$@,$/,$ "-$=-$.,$ !,$"-$=-$- ,$_+$!+$ ;,$_+$!+$;+$ . ,$?+$ . /$.-$*-$ * ,$@,$/,$ !+$ *+$ . ;print $;;

--chargrill

$,=42;for(34,0,-3,9,-11,11,-17,7,-5){$*.=pack'c'=>$,+=$_}for(reverse split//=>$*){$%++?$ %%2?push@C,$_,$":push@c,$_,$":(push@C,$_,$")&&push@c,$"}$C[$#C]=$/;($#C>$#c)?($ c=\@C)&&($ C=\@c):($ c=\@c)&&($C=\@C);$%=$|;for(@$c){print$_^$$C[$%++]}

Sinusoidal japh (imp)

My first obfu:

print join('',@$_),"\n" for map{@$_->[0]}map{[[map{@$a=(@$a,1);int sin($_*0.1)*8==$b-8?[j,a,p,h]->[$#$a%4]:' '}@$_],$b++]}([1..80])x16;

                                          phjaphjaph                                                                   hja          ja                                                                p               ph                                                            ja                  j                                                          h                     a                                                       ap                       ph                                                    j                           j                   j                             ph                             aph                 a                          ja                                  j                 p                        h                                     a                 hj                     p                                       ph                 a                  ja                                          j                 ph              ph                                             ap                 ja          ja                                                 hj                 phjaphjaph                                                     aphjaph

Egyptian fractions (jimt)

Probably not my best obfuscation, but I'm proud of some parts of it. Takes a fraction as an argument and returns the egyptian fraction for that number.

For example:

clark:~/Desktop jim$ ./egypt.pl 19/2019/20 = 1/2 + 1/3 + 1/9 + 1/180clark:~/Desktop jim$ ./egypt.pl 18/2018/20 = 1/2 + 1/3 + 1/15

sub egypt {my$f=2;do{return(--$f,egypt($_[0]/$f))unless$_[0]%$f++}while$_[0]>1}print"$ARGV[0] = ",join(' + ',pharaoh(hiero(split '/',$ARGV[0]))),"\n";sub hiero{my(%nf,%df);$nf{$_}++for egypt(shift);++$df{$_}for egypt(shift);do{($df{$_},$nf{$_})=($df{$_}-$nf{$_},$nf{$_}-$df{$_})if$df{$_}}for keys%nf;return(eval join('*',1,(map{($_)x$nf{$_}}keys%nf)),eval join('*',1,(map{($_)x$df{$_}}keys%df)))}subpharaoh {return$_[0]==1?"$_[0]/$_[1]":("1/".(int($_[1]/$_[0])+1),pharaoh(hiero($_[0]*(int($_[1]/$_[0])+1)-$_[1],$_[1]*(int($_[1]/$_[0])+1))))}

Since I know people like to know how these things work, I'll explain it. First, as always, we'll re-format to pretty it up.

sub egypt {my $f = 2;do {return (--$f, egypt($_[0] / $f)) unless $_[0] % $f++} while$_[0] > 1;}print "$ARGV[0] = " , join(' + ',pharaoh(hiero(split '/', $ARGV[0]))), "\n";sub hiero {my (%nf, %df);$nf{$_}++ for egypt(shift);$df{$_}++ for egypt(shift);do {($df{$_}, $nf{$_}) = ($df{$_} - $nf{$_}, $nf{$_} - $df{$_})if $df{$_} } for keys %nf;return (eval join('*', 1, (map {($_) x $nf{$_}} keys %nf)),eval join('*', 1, (map {($_) x $df{$_}} keys %df)));}sub pharaoh {return $_[0] == 1 ? "$_[0]/$_[1]" : ( "1/" . (int($_[1] / $_[0]) + 1), pharaoh(hiero($_[0] * (int($_[1] / $_[0]) + 1) - $_[1], $_[1] * (int($_[1] / $_[0]) + 1))))}

The first function is arbitrarily named 'egypt' to make it blend it. It returns the prime factorization of whatever number is passed into it. I'm fairly proud of this one.

sub egypt {my $f = 2;do {return (--$f, egypt($_[0] / $f)) unless $_[0] % $f++} while$_[0] > 1;}

We initialize an arbitrary variable ($f) to 2 (smallest possible divisor), then, as long as the number we've passed in is > 1, check to see if it's divisible by $f. If it is, then return a list starting with $f and appending the recursed prime factorization of the number / $f. Note that we post increment $f to let us jump up to the next number (if the modulus is nonzero), so we pre-decrement it before returning so we actually have the one that was the divisor.

print "$ARGV[0] = " , join(' + ',pharaoh(hiero(split '/', $ARGV[0]))), "\n";

The next block does the algorithm to find egyptian fractions, as defined up in that wikipedia link. It just calls the pharaoh function with the LCD fraction and displays the results. Simple.

sub hiero {my (%nf, %df);$nf{$_}++ for egypt(shift);$df{$_}++ for egypt(shift);do {($df{$_}, $nf{$_}) = ($df{$_} - $nf{$_}, $nf{$_} - $df{$_})if $df{$_} } for keys %nf;return (eval join('*', 1, (map {($_) x $nf{$_}} keys %nf)),eval join('*', 1, (map {($_) x $df{$_}} keys %df)));}

The hiero function just reduces a numerator & denominator to lowest terms. It's easy. First, we set up some hashes. Next, we populate the prime factorization of the numerator and denominator into each hash, using the number of appearances of the number as the value. So the prime factorization of 8 is 2,2,2, and we end up with 2 => 3 in our hash.

Then simply loop over the keys in the numerator hash. If that key exists in the denominator hash, then delete from the opposite hash the number of times the value occurs for you. For example, if you passed in 4/8, you'd end up with 2 => 2 in the numerator hash and 2 => 3 in the denominator hash. 2 is in both, so we subtract 3 from the numerator hash's value and 2 from the denominator hash's value, ending up with 2 => -1 in the numerator hash and 2 => 0 in the denominator hash.

This ensures that any common factors are removed from the numerator and denominator. Next, all we need to do is map out the factors and repeat them the number of times they appear in the hash. So 2 => 3 turns into (2,2,2). We toss on a 1 to this list to avoid errors when there are no factors left. Then we just join those lists with asterisks and eval 'em, yielding the LCD.

sub pharaoh {return $_[0] == 1 ? "$_[0]/$_[1]" : ( "1/" . (int($_[1] / $_[0]) + 1), pharaoh(hiero($_[0] * (int($_[1] / $_[0]) + 1) - $_[1], $_[1] * (int($_[1] / $_[0]) + 1))))}

pharaoh here is where the magic is. It takes a numerator and denominator as arguments, then recursively builds up the list of unit fractions to return. First of all, if the numerator is 1, then return numerator / denominator (we're done). Otherwise, we apply the algorithm and return a list consisting of int( 1 / (denominator / numerator) ) + 1, and the result of calling pharaoh on the LCD form of the fraction minus the value we just calculated. Further explanation is left as an exercise to the reader, but I'd recommend assigning this (int($_[1] / $_[0]) + 1) to a variable and replacing in the function, it'll be clearer.

BF interpreter (gustavderdrache)

A friend of mine, EnragedTux, wrote a BF interpreter in Perl. He wanted to shorten it up, and I came up with this. He told me to say that he helped out. :)

#!/usr/bin/perlopen P,shift;%p=('>',sub{$p++},'<',sub{$p--},'+',sub{$p[$p]++},'-',sub{$p[$p]--},'.',sub{print chr$p[$p]},',',sub{$p[$p]=ord getc},'[',sub{&c} ,);sub p{ exists$p{$_[0]}&&&{$p{$_[0]}}}p getc P until eofP; sub c{push@c,getc P until$c[@c-1]eq']';do{p$_ for@c}while$p[$p]}

"If you go on with this nuclear arms race, all you are going to do is make the rubble bounce" -- Winston Churchill

Fourth time's the charm JAPH (dewey)

I've been running this in ActivePerl, but I think it should work fairly universally...Update: thanks to Hue-Bond for the heads-up on the warnings, here's version 2:

#!/usr/bin/perlsub {$_="/(Just).*( another).*( Perl).*( hacker,)/,print\$".((caller)[2]-1);eval}->();sub {$_="/(Just).*( another).*( Perl).*( hacker,)/,print\$".((caller)[2]-1);eval}->();sub {$_="/(Just).*( another).*( Perl).*( hacker,)/,print\$".((caller)[2]-1);eval}->();sub {$_="/(Just).*( another).*( Perl).*( hacker,)/,print\$".((caller)[2]-1);eval}->();

~dewey

Emotijaph :) (chargrill)

It's been a little while for me, so I thought I'd whip something up to cheer myself up. Hopefully it brings a smile to your face as well :)

#!/usr/bin/perl          {;$ _=q(Ju       st a nothe        r Pe rl ha         cker              ,); s              [  \s              {2,}]              {}xsg;};$#         =$_ ;{;s(:        )(: :];);}       print           $=;;

--chargrill

$,=42;for(34,0,-3,9,-11,11,-17,7,-5){$*.=pack'c'=>$,+=$_}for(reverse split//=>$*){$%++?$ %%2?push@C,$_,$":push@c,$_,$":(push@C,$_,$")&&push@c,$"}$C[$#C]=$/;($#C>$#c)?($ c=\@C)&&($ C=\@c):($ c=\@c)&&($C=\@C);$%=$|;for(@$c){print$_^$$C[$%++]}

Letters to the Editor Japh (liverpole)

This one won't be obvious until you find the hidden clue and follow its instructions.

Running the program reveals the clue.

sub sub {$"='jJPPJPJJjppHjpHAjpHAjpHAjpHAjPhAjpHAjpHAjpHAjpHAjpHAjpHAjpHAjpHAjpHAjpHAjphajphajPhAjPhajPhaJPhAjphaJPHAJPHAJPHAJPhAJPhaJPHaJphajPhaJphaJPhAjpHAJPHAJPHaJphajpHAjPhAjpHaJpHaJphaJphajPhAJPHAJPHAjPhAJPHaJpHAJPHAJPHAjphajpPhjJPpjPJJAHHJaAAjAPhhJPJjahaPaPpaapaaAHahjpjJahaJAPPJapaaJPJJaPpjaPpAaPAJapAjAPaAAPhpjpjJapHaapaaAhJhAhJHaPjAaPAHAPaAJPHJJpjjahjhapjaahapApAaJPjjaJPPApjaaHjjAPPjjPJjahAHaPpAahajApPJjpjJapJajPJJJpJPjphPAHjjApHjjpjpjpjjAHHjjjppjpjjAHHjApAAAHpjAHAjApAAApHpAHjHAppAApHHApHpjpJJApjaapHpApAjjpjjApAAApAjAppAahAjjpjjAppAApHpjpjjApAHAHApAppAApHAjpHjJPjjAhapaPPaaPHaJpjjAPhHAHjpjpJJApAAAPhaApJaApjhaHJhJPhPjPJjjPJjAaJJapaaAHjPapApaPHHAhJPAphaJpJJahhjJJppjpJJAhhjaPjAjPJjAHJhApAaaPjaaHJPApjHAPPjJPjjjpPJAHjPaPaaaPaHApAAAHPJjpjjahjhapAaapJaAHjpaPjHAPPJJPJjaPpaaPHpJPJjApAAaPHAAPJAaPjhaHjHjppAJPjjApaPAPhHAHJPJpjjAHaJAppJapaaJpJJApJhAppJApjAahJPJPHPJpJJAhJHApAAAHaJJPJjAhhJjjppjPjjAHhJaaPhAJPpAPJAAaJJappjAAHAjpHpjpjjjpjjAjpAApHpjpjjAHApAppAApHAjpHjjpjjAHAjAHjpAHpAjpjjApHHahaaahAjjpjjApAjAppAApApApApaPAAahjpApAAApHpAHAjjpjjApjHApHHApHjApHHahJPjpjJaHJhaPJHaPPJapAaapHAApaaAHJhjphPJPjjjpJJahHJJjpPJpJJJPphJPhajphaJPHAjPhAJPHAjphajphajPhAjpHAJPhaJPHAjpHaJpHaJpHAjPhAJPHAJPHAjPhAjPhAJPhaJPhajphaJPhAJPhaJPHaJpHAjphajphajphaJPhAjPhAjpHaJPhAjphaJPHaJPhaJphaJPHAjpHAJPHAjphajPhAjPhAjpHAJPHAJPHaJpHaJpHaJpHAjPhAJPHAJPpHjJPpahHpAHhPppApAjJJJaJjJhAAJapaJJaaHAaaApaappPhPPPPjjaahJAJhAHJJpPPPJAPapHPJAPh';$_=$"&&s+\n++g;{$"!~s((.))() or$O=$O<<2|index lc"jApH",lc$1;unless (++$*%4){'~'ne($O=chr$O)?print$O:exit}redo}}$==& sub(liverpole.8/13/06)

Update: modified clue to take advantage of [Ray Smith]'s [id://567237|observations].

s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/

My Second, first japh (jfredett)

It appears that the first time I posted this, it did not go through, I think I missed hitting some button.Anyway; This is one of my first Japhs I've ever tried. One of my CS-geek friends told me that it might not work on all systems. But I know it works on WinXP. I thought it was pretty clever for my second day in. It's probably not, but anyway...

$Just = $0; open(JAPH, $Just); @another = split(/\s/, ); $Perl = ""; $hacker =",";$Perl =join(" ", (substr($another[0],1)),(substr($another[5],1)),(substr($another[9],1)),(substr($another[12],1))); close(JAPH); print ($Perl . $hacker);

The only thing I'd like to really do, is figure out how to remove the readability in the function names and stuff. I tried looking at B::Deparse, which was mentioned in one of these nodes. But I don't think thats what will do it for me...~~Joe

Ode for the CORE:: package (ambrus)

CORE::subCORE::for             {CORE::printCORE::lcCORE::for             $CORE::for             }CORE::for             (JAPH::                ){CORE::for             $CORE::for             ((CORE::m               ).|CORE::time            )g)CORE::xCORE::not             $CORE::lc              ){CORE::doCORE::for             (CORE::lc              )}CORE::lc              }CORE::__DATA__        )

Update: made the script a bit nicer, changing )gx) to )g)

My first (fotios)

I guess this isn't your typical obfuscation (it may not even technically count as an obfuscation. But it's a little program I wrote for a t-shirt design for Computer Science House a la the Perl camel shirt.

    my@a=("\012","\040","\103","\110",        "\123",0);sub a{my@a=@_;for(1..$a[0]){print($a[1      ]);}}subb{abs($_)}sub c{$a[$a[$#a]+=$_[0]]}sub d      {$a=!($_[0.0]) ?                        '==':$_[      0]==1.0?'>':'<';                        eval("${      _[1]}$a${_[2]}")                                      ;}sub e{&c((-$a[    $#a]))}for(-2..2    ){if(&b)      {&e;;&a(&b,&c(1)    );&a(25-(&b*2.0)    ,&c(1));      &a(1,&c(-2.000))    ;}else      {for    (-6..6){      &e;&a(5,&c(2.0))    ;;&a((              &d(0,&b,6)?15:&d(1,&b,2)?&b-1:    2)+(&d(-1,&b,2)?    ($_+2)*2:&d(0,$_,2.0)?($_+2)*2              -1:0),    &c(-1));&a(&d(1,&b,3)?15-2.0*(    &d(0      ,&b,6)    ?15:&d(1      ,&b,2.0)?&b-1:2)    :4,&c(3));&a(&d(    0,&b,3)?      3.0:0,&c(-3.0));    &a(&d(0,&b,3)?4:    0,&c(3))      ;&a(&d(1,&b,5)?0                                      :&d(0,$_,2.0)?$_                        :&d(0,$_      ,1)?$_+2:&d(-1,&b,3)?(&b+2)*2+1:&d(1,&b,5)?15:&d      (1,&b,2)?&b-1:2,&c(-3));&a(5,&d(1,&b,4)?&c(1):&d      (1,&b,3)?&c(0):&c(2));&e;&a(5,&d(1,&b,1)?&c(1.0)      :&c(3));  &c(-$a[$#a]);&a(5.0,&c(3));;&a(1,&c(        -3));}}}

Symbol Table Japh (liverpole)

In "Stages of a Perl Programmer", by Tom Christiansen, a "Hacker" (stage 5) is defined as someone who, among other things, "accesses the Perl symbol table directly".

Here is my attempt to do so, and without using any semi-colons:

                     {use B}                $a= -- $ |and map           {s|$_| sub { map{ m{^ $_[0]      (.{$a})}ix && return lc $1 } keys%B::  }->(lc $_ )|e && map { print $_ , $ " } split      // and $ | and $a += $| --} split $ "           ,".b .in ...._s u ..me v ".                "..ty ..pea cc c"                     ."he v"

s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/

Jolly Roger (SubStack)

Yarr, the Jolly Roger has a message for all ye perl pirates.

#!           /usr/bin/perl           $^X =~ y/0-9.//d,          print join$",(sort         97.110.0.do{local $"=        "";       $_=       "@{[        sort     split     //,$~        ] }"     ;eval     ";42;         y/$~/heotr/";s/(.)\1+          /\1/x;$_} , [split/          \//x,($_=   chr++$|+$=         /$]*$^F).$$_]->        [--   $.],      crypt    ($_      =pack      ("I*",    1722938    ),$_)           =~/          .(..            ..)/x,"#=6.!1"            ^$~),  chr(8).         chr            $=/     $^F+                   ++$^F,#Sub                             Stack

Some words in the result might appear jumbled for for ye Windowers and ye Applers (and ye BSD-ers) because of differences in crypt() and $^X, but it's still a pirate!(Inspired by this)
(Updated for ye Gentoo-ers.)
Harr!

Fun with code read & print (Mandrake)

An attempt to print the japh horizontally and vertically. Reads the code and prints the shape.
The code is not much unreadable though.

#!/usr/bin/perl -wuse strict;(open O    ,$0)&&      (push my @r  ,_v (   [ map{_c(join("",@{$_})   ,1)} @{ _v    ([map{_c($_  ,1) }   ])}      ]));         push    @r,_v  ((((   $r [  -1]))   ))for(      0 ..        int(    rand (  (5)))  +1);  map {   map  {      map{        $_&&    print}  @ {$_  };;;  &_p }   @{$_};      &_p}        @r ;sub _p   {  print"\n" }  sub _c{my(  $o      ,@a,        $f,@r)=($_[1],  split("",$_  [0]),0);for  (      my$i        =0,$f=0;$i< sc  (@a);$i+=$o  ){for($i..( $i      +$o)        ){($a[$_]&& $a  [$_]ne" "&&  $a[$_]ne"\n" )      && (        $f=1    );( $_  ==($i        +$o))   &&   (      push        @r,(    $f== 1  )?"@"        :" ")   && ($f      =0);        }  }    return  \@r;;        } sub   _v{my(      @r);        for(    @{$_[0  ]}  )        { for   my  $j   (0..           _m (    \@{ $_  [0]})        -1) {   push @   {$r[$j]},($_->[$j] &&$_->[$j]ne"\n")?$_->[$j ] :" ";#;   }}return[map{\@{$_}}@r];};sub _m{my $l=0;($lChange the code to a different shape to find the shape on the output.Thanks..

bigger japh (SubStack)

This one recreates a 613 byte ascii-artish japh with 448 bytes of code and data.

$_="b4lb13ib24ib3lab4lblb3lb2gfebfdf2b5gf2iblgfgb2gfgb2fdf2blf2gbgf2gbigf2eab4lblb3lb2jb4lb8k2lblb2lblb3lb2lb3lb2lblk2iblabib2lblb3lb3jb3lb7lb2lblb2lblb3lb2lb3lb2lblb4labck2cb2jkhb2jkhb3ckhb5ck2lblb2lb2jkhb3ckhblb2lbck2ebla2b17clb7lb14labigf2gbgf2gbigf2eblb7lf2gbgf2ib2gfgblb2gbgf2gbigf2eablb3lblk2iblb5lb7lb2lb2k2lblb2cblkhb2lk2iblabljkgcbck2eblb4glgb6lb2lbck2lbck2eblbjb2ck2eblb2fgablb53hablb53a";s/(\D)(\d+)/$1x$2/eg&y!a-z!\n '+-/:\\_|!&&print

One line Fibonacci generator (jimt)

I'm stuck in the airport in Baltimore waiting for my flight home. Normal people read magazines or books or stare off blankly into space. Me? I write one-liners to generate the fibonacci sequence.

print$,and$_||=!$!and$\=$/and print and($,,$_)=($,+$_,2*$_+$,)while$;

Getting from here to there (wulvrine)

Having been amazed at all of the ASCII Obfuscations, I decided to try one for myself.

@f=(22,52,0,13,5,1,160,2,2,125,53,3);@d=(15,17,19,21    );sub A{map{($a,$b,$c,@f)=@f;$o=!$c?$a+$b:$c==1?$a*$b:$c==2?    $a/$b:$a-$b;$j[$m++]=chr$o}@f}sub B{$g=pop;$c=$h{$g};$i=$r{$    g};$B='a';map{@{$i->{$_}} = reverse @{$i->{$_}} if $c->{$B++    }!=$i->{$_}[0]} qw/v V/}sub C{$g=pop;$c=$h{$g};$Z=$c->{a};$Y    =$c->{b};$S=$c->{c};$R=$c->{d};$s=abs$R-$Y>abs$S-$Z;($Z,$Y,$    R,$S)=($Y,$Z,$S,$R)if$s;($S,$Z,$R,$Y)=($Z,$S,$Y,$R)if$Z>$S;$    l=$S-$Z;$n=abs$R-$Y;$Q=0;$y=$Y;$P=($Y<$R)?1:-1;;$O=-1; ;map{$    O++;$r{$g}->{v}[$O]=($s)?$y:$_;$r{$g}->{V}[$O]= ($s)?$_:$y;;$    Q+=$n;if(2*$Q>=$l) {$y+=$P;$Q-=$l}}$Z..$S}sub D{($N,$k,$M,$L,    $K)=@_;map{$J=$L==$d[$_]}0..$K-1if($K&&$M==12);$J||print"\e["    ."$M;${L}H\e[${k}m$N\e[m";}$|=print "\e[H\e[J";A;map {$*=int     rand 50;$,=int rand 24;$h{$j[$_]}={};$"=$h{$j[$_]};$"->{a}=$    *;$"->{b}=$,;$"->{k}=101+$_;$"->{c}=$d[$_];$"->{d}=12;;$"->{I    }=$j[$_]}0..3;map{C$j[$_];;B$j[$_]}(0..$#j);@q=@{$r{$j[0]}->    {v}};@u=@{$r{$j[0]}->{V}};;map{$H=$h{$j[$_]};@q=@{$r{$j[$_]}->{v}};;@u= @{$r{$j[$_]}-> {V}};$F=$_;;map {D" ",0,$H->{b},$H->{a},$F;$H->{a}=$q[$_];;$H->{b}=$u[$_];D$H->{I},$H->{k},$H->{b},$H->{a}, $F;select$G,$G,$G,.05}0..$#q;$_=$F}0..$#j;print "\e[30;1H" #by wulvrine

I look forward to the comments and suggestions but please be gentle as this is my first 'real' obfuscation.
(My first obfu was my signature which doesn't really count.)

I am using this < a href ="http://en.wikipedia.org/wiki/Bresenham's_line_algorithm">algorithm for movement.

s&&VALKYRIE &&& print $_^q|!4 =+;' *|

Unbalanced, Introspective Japh (liverpole)

"Unbalanced" because of the unmatched parentheses, braces, and brackets. "Introspective" because ... well, you'll have to figure that out for yourself.

This works with Perl version 5.8.6 (in Linux), and 5.8.7 (in Windows), and possibly with other versions of Perl (though I can't be sure).

My apologies if this has been done before (and please let me know if so). I came up with the idea just this evening, but one can never be sure whether or not similar prior art exists.

( $ ||=  open$ ) ,$ ^X) ;; X :;{ $ ;+=  print if ($_ = lc getc $))  eq# }( split$ ,,q#- just another perl hacker# )[ $ ;];  eof$  ( ?die$ /: redo } 060630# ]

s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/

I can (sh1tn)

use strict;use warnings;I->can(print"Just Another Perl Hacker")

Perl Worst Practices (Hue-Bond)

My [id://547911|last obfuscation] was impressive on first sight, but rather disappointing at the time of breaking it, until the point that I almost posted a followup apologizing for it :^). So I decided to quit doing that lame things and make something I could be proud of. And this is the result, a little program that incorporates some tens of gotchas (to me, at least) that I've found in the documentation. They're not necessarily worst practices, but I thought it would be a nice title. Sometimes titles are more difficult that the things they give name to.

It changes its behaviour from time to time (maybe), although it can be some weeks until it decides to do so. I won't be surprised if it doesn't run on win* or older Perls (5.8 required, although the script doesn't explicitly use it), indeed I had to remove a couple of features to make it work on 5.8.7. A pity. On the bright side, and definitely not a worst practice, it's strict and warnings clean -- there's a warning but it's on purpose ;^).

It's possible that it runs too slowly on your machine; if that happens, you can alter the variable $d at the top of the script. It specifies a wait time, so increasing it will make the program run slower (although it's unlikely you will need this). Setting it to zero will make it run as fast as possible. If it's slow, you could try 15 as a first approach, and see. I forgot to check for the less-than-zero condition, but it doesn't seem to break.

Oh, and it also features a small hidden text that summarizes my overall opinion about the monastery.

Usage:
    -m: use medium-sized font
    -s: use small font (default, and overrides -m so it's pretty useless)
    -t: specify text to show instead of the default (there's another way to do this)

Example: ./pwp.pl -mt '100th post!'

(Hmm, I have a feeling I'm forgetting something...)

use warnings; use strict; our $d = 20;* ,= *EUID;-JAPH=~join'\s*',('(\S+)')x4;use Getopt::Std;getopts('smt:',\ %;);$^]=v109 if$; {m}and!$;{s} ;%~=$ ^]eq's'?(q AoA,6,q NaN,11):reverse(14,q rar,7,q pop);eval join'',map{$^[=chr qw/26 6 10 7 0/[$_]+0105;$_||($^[x=2);$/ = $_==3?'use Symbol; ':'';local$ ;=chr qw/6 1 0 5 3/[$_]+77;$ a=$ _==3?';${*alt=*{$q=gensym}} ':'';$ S::I=$_==1?'our$X;our$ s=($X=~$q);':' ';$S::S=(qw|qr/$q/\$s sub{$$q;} \*alt $q|)[$_];"package $^[;${/}sub $; {our\$k=shift;our\$q$a=shift;${S::I}bless $S::S,\$k;}";}0..4;$/=( );our($ORS,%I,$I,%~,$OFS,$RS,%a,$~,$l);sub I;sub v;sub ::{$5}if(open$/,'<',\$RS){while(read$/,$_,$=){$,=$_;nextunless ${*${P E R L M O N K S  __ v46}{">|z<|2"^"m?;p=`"}}->();//and($I,$ ~)=$ ^]eq's'?($l,$.):($:,$^);$I{255-$I^0x55}=$ ~;}(*.,*^,*l,*:)=(*",*;,*=,*b);$a{ a}='$~=join"",@ ~';our@RS;sub a{local$_=(caller(fileno$/==0))[3];&u;v36.$_}@RS=sort{sub b{local$/;@; =join' ',$ ^X=>'-e"print\''=>@_,'\';"|';eval for<>}@~= map{pack"B8",$ _}grep!/^0{3}/&&!/^1/,map{unpack"B*",$ _}split//,defined$;{t}?$ ;{t}:defined$ a{&::}&&CORE::length($ a{& ::})?$a{& ::}:'';@ ~=split//,q^Z&q>^^<0G\x01V> ^join<  >=> map{y ^1-9^ --^=>s ^[0-9]^chr^e; $ _}split qr^^,unpack,chr rand 16if!@~;$l+=ord for@ ~;return$l%2?-1:1}@RS[0177,0377]if* K::X;$I=((b a),());open$I,'<'=>\3or die-OPEN1.$!;eval'"BEGIN{use English}"';*^]=-+CORE'GLOBAL'undef;$a{a}='sub BEGIN{sub CORE::length{(undef,local$_)=@_;index$_,""=>$l*$l}}';{package S;our@l;@l[split//,hex join'','b'..'d']=([0,-1],[1,fileno((bless\($ .=rand )=>--$-),$/)==0],[-1,0],[0,1]);*l=*l=sub{splice@_,6,0=> splice@_,0,1;our@I=(shift,shift);()=return wantarray?():bless{mnm=>[@I],mmn=>$I[1]-1,mww=>0,mmw=>$I[0]-1,mwn=>0,mwm=>shift,mnw=>shift,mmm=>[shift,shift],},shift;sub END{$OFS->Tgoto('cm',0,0,*~);$OFS->Tputs('ve',1,*~);}}}our@I;b a;our@a;$ ^]=$ _ and((splice@a,($|,1,!!!$ORS)[$a++||$|],$|,0)or map{$_+=$^]}@a)or@a=map{sprintf$6,$_/$_,$_,$_,$_,$_*$_}@a for qw/10 55 46 0/;@ :=greplength,split/(??{local($ ,,$^)=((index+($.="."),"",42),substr$_,pos,1);$_ eq$^and substr$.,0,$,,""and last for@a;substr$.,0,$,,"";})/,'UE.0.ogcnoVesZeXMh';*ORS =*|;map{push@ / ,($/[-1]|| 0)-112+ord}split//,'pzw';$ _= * ^]^ 8.49.48x48.48.55;@ ^[=(split//)[@ /];$^[[$ _*2+1]=$ ^[[$_*2]=$^[[$_]for reverse 0..2;splice@I,6+@ I,0,qw/O O 0 0 @/,not do{push@I,(localtime)[8]?@ : :@ ^[}=>'@';{local$/;@/=($~{q LoL} *+CORE->length($~),$ ~{q yay});$,=S->l(@/,ref\$ .,4,-1,ref\$.);$ ^]=S->l(@/,<$I>=>eval'$ORS ++;2',$/[ref\$.]-1,$/[1]);$a{a}='@RS=();splice@RS,@RS,0=>int rand 2for split/'.'/,$~;';}@/=();our@OFS;$d/=1e3;sub END{for$^[(\@/,\@OFS){select+(),((),()),(),5e-1 if$^[==\@OFS;for($.=our$I=ref\$.;eval'$I++if!$ ^[->[$.]'||$ORS;$. ++){$ ^=$^[==\@/?@I:-1;if(-rand 1==rand -1){$ .="0+(/SDLF?.2:EFLSE?:?~&*#7[z) ?M;%42','s',@{[0..255]},%ENV)}our$,="s"."DFH!%83SOFS*(?rOfUI`96dFGASf:'2LDHGf snujfdla&HUFA6(?lBSDJl8 SIF_1 E'F^'4"."sAQFI,a.9SDFJHlN";warn"\n"x$~{q dad}.($ .^$,);BEGIN{sub RS{I sub{$OFS->Tputs('vi',1,* ~)};shift->();}(*,,*.,*EUID,*:)=(5,1,*K::X,4)}BEGIN{*~=$::{"{>b< >or/(??{substr$ \,2+pos,1})/}unless$ :!~/n(?{m#(?{$_})#&&sprintf q#\# %02x#,ref\$..q#@ OFS##&&$ substr{42}})An#"@{[defined$I&&length$I&&(sprintf$I.("6611"^"bg|a")||do{&u(q"$I/x;print{$OFS->Tgoto('cm',$^[->[$_][0]=>$^[->[$_][1],*~),*~}$I[$^ ]if((defined$ ^[->[$_]&&$ _>=ref\ $.)&&($RS[$^[ ->[$_][--$ -]/$ ~{q HoH}]?(not hex substr($ I{ordsubstr$~,int($^[->[$_][--$-]/$~{q bob})=>1},2 *$^[-> [$_][1],2)&1 <<$~{q mom}-1-$^[->[$_][--$-]%$ ~{q LoL}):(hex substr($I{ord substr$ ~,int($ ^[->[$_][--$ -]/$~{q pop} )=>1},2*$^[->[$_][1],2) &1 <<$~{q AoA}-1-$^[ ->[$_][--$-]%$~{qHoH})));}select +(),(),((),()),$d;eval '"BEGIN{* CORE::GLOBAL::open=sub{\ $_=q^?n/j_pp!|m5|meF*I,SnpI{^^q ^|!}/eJ7m3/t0W_)Z,B{./`@^^eval}}"';}or do{$^[==\@/and print * ^]^qq' ~,= <\cv\cz\ci-\cab29JJ\cz\c\\cpE\cheeded.\n';last}}lastif$I==@ I-1;}}I:}BEGIN{(*l,*ORS,*^)=(split//,0552);sub I{v sub{$OFS->Trequire(qw/cl cm ve vi/)};shift->();}* ORS=\ ('%3$*'. * 1{'p$0?'^'>e}z' }.'$.*c') }{package S;our@l;sub I{our$I=$_[our$ S=0];I: our$ww=$I->{mmm}[0]+$l[$I->{mwm}][0];our$wn=$I->{ mmm}[1]+$l[$I->{mwm}][1];$ .= ((our@I=0..3)=>'');our$ l=join' els',map{our($j,@t,$t)=unpack"b2",$_;"if(\$I->{mwm}==@{[('ref\$.',1..$#I)[$_]]}){if(\$w@{[((qw/w n/)x2)[$_]=>$::I[0],((v62)x2=>(v60)x2)[$_]]}\$I->{'m@{[((v109)x2=>(v119)x2)[$_],((qw/w n/)x2)[$_]]}'}){return undef\$ I->{mmm}if\$S;if(\$I->{mnw}==4){\$ I->{'m@{[(('m')x2=>(v119)x2)[-1+$ _]=>((qw/n w/)x2)[$_]]}'}@{[@ t=split//,$ j and(0+$ t[0] ^0 +$t[1])?'--':'++']};\$I->{mwm} = $I[-3+$_]}elsif(\$ I-> {mnw }==2){\$I->{'m@{ [(('w')x2=>(v109)x2)[- 1+$_]=>((qw/n w/)x2)[$_ ]]}'}@{[$ t=$ j and(0+substr($t,0,1) ^0+substr($t,1,1))?'++':'--']};\$I->{mwm}=$ I[-2+$ I[-3+$_]]}else{\$ K::X=int qq'${*_{qq^>|z<|`^^ qq^m?;p=2^}}'}\$ S ++;goto I}}";}@I;defined eval"$l;1"and$I->{mmm}=[$ ww,$wn]or return;!!$l}}BEGIN{* ,=\('#d4k!k#f '^'s!f\'l$m-s') ;*;=\@ARGV;sub v{$OFS=Term'Cap ->Tgetent({"h=l,"^"a" =>${\undef},"k#x}; "^'$p(8~d'=>$ .});shift->();}}while($,-> I&&$ ^]->I){eval'package S';splice@ /,@/, 0,$,->{mmm}||<$I>;splice@ OFS,0,fileno$ /== 0=>$^]->{mmm} ||();eval'package main;';}b a;require POSIX;$ .=new POSIX::Termios;$.->getattr;$.=$ .->getospeed;eval"$^";RS sub{$OFS->Tputs('cl',1,* ~)};package S;}else{die-OPEN2.$!}BEGIN{$RS=<<"EOF"0004040404040404040400 004242424242424242423c000000 214 2550018040404030404041800 003c42422418244242423c000000 215 1460001010202040808101000 004040404040404040407e000000 133 2300000000e101010100e0000 000000003a44444438205c423c00 201 2050010080404040404081000 001010107c10101010120c000000 131 222000e080808080808080e00 0018244242424242422418000000 241 1540000000000000004040408 000000003c42023e42423e000000 134 20300001212121212120c0000 007e404040784040404040000000 255 2360006080808300808080600 0000000042422418244242000000 209 2100000140814000000000000 003c424242463a02424438000000 128 1470000000404000004040408 4040202010101008080404020200 145 246001c040404040404040000 000000007e04081010207e000000 198 20800001f0404040404040000 000808001808080808083e000000 254 19500001f10101e01110e0000 004266665a5a4242424242000000 159 23100000e04040404040e0000 0018244242427e42424242000000 227 2350000000e121212160a021c 003c4242424242724a463c040200 205 25100000012121212160a0000 001824242418324a444c32000000 223 140000000001f001f00000000 0000000022222a2a2a2a14000000 151 22100001212121e1212120000 0042426262524a46464242000000 226 228001010141a121212120000 000e040404040404444438000000 194 22400001c12121c1010100000 0000000000000000000000007e00 250 245000a0a0a00000000000000 003c424204080808000808000000 136 1490000000c020e12160a0000 007f080808080808080808000000 203 2540010101214181412110000 000000003c42427e40423c000000 193 2070000001115151f0a0a0000 0204080810101010100808040200 221 1300000000019260000000000 001c2040405c624242423c000000 212 15600000e0404040404040438 1e10101010101010101010101e00 224 24100000e12202022120e0000 000000005c62424242625c404000 237 2180000000000000000000000 2010080804040404040808102000 213 1310000111b1b151511110000 3c04040404040404040404043c00 231 247000000121212120c0c0000 000000003a46424242463a020200 220 21900000c0c12121e12120000 001414143e14143e141414000000 235 13700000c12212121120c0603 007c424242427c48444242000000 251 24800001c222e2a2f201e0000 000000000000000000081c080000 234 132001010141a1212121c0000 007e02040808102020407e000000 200 2400000000204080402000000 003c424240300c0242423c000000 150 24900000e11111111110e0000 003c424240404e4242463a000000 154 2370000001a15151515150000 0000000000000000000000000000 199 2130000000000000000003f00 0000000000003e00000000000000 245 13500001010101010101e0000 3008080808080408080808083000 230 2150000000808000008080000 000000081c080000081c08000000 144 14400001c12121c12121c0000 000000005c624240404040000000 232 216000004040a0a1111000000 1824420000000000000000000000 244 244000000110a04040a110000 004040405c62424242625c000000 210 20000000e11010608101f0000 000818280808080808083e000000 152 1550004001c04040404040438 007e020404080810102020000000 192 157001c040404040404041c00 0000020408102010080402000000 247 1500000000000000008080000 000000003c42424242423c000000 132 19700001e10101c1010100000 000202023a46424242463a000000 236 20600000000001f0000000000 0000000000000000000000000000 135 1380000112a14040a15220000 0202040408080810102020404000 143 1330000040c14040404040000 00324a4c3808101c32524c000000 155 1430000121a1a161612120000 00000000342a2a2a2a2a22000000 228 1990000080808080008080000 007e40407c42020242423c000000 139 1590000001008040810000000 000000082a1c081c2a0800000000 148 1280000081e08080808060000 00040c14142424447e0404000000 222 15800081e28281c0a0a3c0800 1008040000000000000000000000 142 20200000e11110e11110e0000 0022222214140808080808000000 146 24300000c120c0d12120d0000 0000201008040204081020000000 140 1480000111515151f0a0a0000 000000003c42404040423c000000 253 20100000e11010601110e0000 003e08080808080808083e000000 153 2270000141436143614140000 0000000018180000180808100000 137 1450000001e020408101e0000 0042424242242424181818000000 208 2520000060a0a121f02020000 00083c4a4a281c0a4a4a3c080000 158 142000000141a121212120000 0000000022222214140808000000 196 22000000e11110f01110e0000 000000005c624242424242000000 147 196000011110a040404040000 003c42424242424242423c000000 243 22900001c12121c1412120000 0000000042424242463a02423c00 248 2110000001212120c0c081010 001808080808080808083e000000 211 1980000111214181412110000 0008080808080808000808000000 225 13900000e1101060004040000 20524a0400000000000000000000 149 2120000000000000000000000 000c1210107c1010101010000000 138 2040000000e101806021c0000 0000000000000000001808081000 217 134000012120c0c0c12120000 004040405c624242424242000000 242 1940804000000000000000000 007e40404078404040407e000000 202 23900001e02040c08101e0000 003c42420204040810207e000000 240 1520007081e08080808080000 000000007e00007e000000000000 204 1510000000c121212120c0000 003c42424040404042423c000000 197 2330000000c121e10100e0000 0078444242424242424478000000 207 2380002040808080808040200 002222222222222a2a2a14000000 130 25300001f0102040408080000 007e0204081c020242423c000000 157 15300000e12202020100e0000 0000000808083e08080800000000 233 1290000000b0d080808080000 0078444244784442424478000000 216 23200001e10101c10101e0000 000000003c42201804423c000000 239 2170000121212120c0c0c0000 000000004242424242463a000000 252 2230002020e121212160a0000 0042444850605048444242000000 206 22500001c12111111121c0000 0002020006020202020222221c00 238 1920004040400000000000000 1414141400000000000000000000 141 1360004001c04040404040000 0608080808081008080808080600 195 209000000141a1212121c1010 0808080808080808080808080800 218 21400000004041f0404000000 007c424242427c40404040000000 129 25000000e10100c02021c0000 0042422424181824244242000000 249 2420010100808040202010100 0808080800000000000000000000 246 14100000e11101e11110e0000 0040404044485070484442000000 156 19300000c12212121120c0000 00424242427e4242424242000000 229 2260000000e121212160a0202 001c224e525252524e201e000000 219 234EOF}

--
David Serrano

A first attempt (fatalserpent)

I made this code to amuse myself, and didn't feel like rewriting it, so I apologize for the arrogance it says when executed... I know it's not too good, but I wrote it after _just_ learning the basics of the language... so yeah sorry... I'm really not that egotistical... not that anyone would want to copy it, or that I really have any claim to copyright, but it's in the public domain

$a=116.110.101;$b=112.114.101;$c=115.108.97;$d=116.097.102;$g=32.00.00;reverse($a);reverse($b);reverse($c);reverse($d);$e=$a.$b.$c.$d;$e=reverse($e);print$e.$g;@z=split(//,$e);$f=119.121.111.117;@n=split(//,$f);print$z8.$n[0].$z10.z5.$g.$n1.$n2.$n3."\n"; print"A PD work.\n";

A first attempt (Anonymous Monk)

#Uhh this is just a (really bad) first attempt at trying to learn perl... Any CONSTRUCTIVE criticism would be aprecciated.$a=116.110.101;$b=112.114.101;$c=115.108.97;$d=116.097.102; $g=32.00.00;reverse($a);reverse($b);reverse($c);reverse($d); $e=$a.$b.$c.$d;$e=reverse($e);print$e.$g;@z=split(//,$e); $f=119.121.111.117;@n=split(//,$f);print$z8.$n0.$z10 .$z5.$g.$n1.$n2.$n3."\n"; print"SRY 4 ego\n";

Balls! Pt 4 (teamster_jr)

part 4 or an occasional series: ([339774|1],[342916|2],[550028|3])

          $_='map($            ..=pack("C",--$              _),@_=unpack"C*",            q^pqfo!g        -#?p/cnq#qbd   l#y29311#<%q>5+bubo3      )2-2*%`+%q02911fy     q))%s,%`0:*0:*0:<%y>)2  0)%i,20%i**+dpt%s<%z>)     20)%i,20%i**+tjo%s)%q      03,%s*&)3+%q*?%q@3;2             ~1//26~qs          jou!g%v^),eval$.'                                  ;s#\s##g;eval

this generates a file called o.bmp.
enjoy.
alexit's very loosly on [http://www.clowder.net/hop/Riemann/Sprsphrs.jpeg|this MC Escher print], [http://www.clowder.net/hop/Riemann/Riemann.html|this page] explains some of the maths.

Playfair Decryption (liverpole)

My good friend [chargrill] recently posted this excellent obfuscation, demonstrating a famous method of encryption called the "Playfair Cipher".

I thought it would be fun to write an obfuscated "Playfair decryption", and since today is my one-year anniversary at Perlmonks, I thought it would be fun to submit it by the end of today. (Just barely made it!)

It should work under both Windows and Linux. The 3 parameters it takes (which can be "hardwired" at the top of the script) are:

The delay factor, in fractions of a second. This defaults to no delay at all (which is fast, but less fun to watch). A suggested value is between 0.01 (quite fast) to 1.0 (very slow)
The "key", used to populate the table. (It defaults to the value used in [chargrill]'s original obfuscation).
The encrypted text (which also defaults to the original obfuscation).

$d = shift;$t = shift || "ocumentsadigjrkplhxbfqvwy";$e = shift || "slobxtfqnrgmpfbukgadarsotxdvaweoaggoodmgfbngnidculipvcmdtnmrasbuopjagqgnmktxnkjknxvjehasgncspntopfbugabutubueomrnjsfoddcnkdpqexsgxudvxmdsancdohedlmdjaslodraocqpminbxtfqnrxmpuxicecndkslomdunosloupfbugabudculipvcmbodmgfbsaxngknuqpcdlamkangjxrlxnjtadcdnnonjtibcbcaldcjadapisludrolhudehasgncspntopfbuxrtnxrslmkeckmucoxbchwgjodmkoupfbujavddcuaslodpisjcdbulhdwwngkjnslsjhagjipopmttsbqxskamkncxkmdjdpiuosloykmvcodeqdttxvdjnsjdkonjarolhudehasgncspntopfbujaneudinaqmirygnpjal"; $a=eval{require Win32::Console::ANSI }? 30: 100; $p= {map {$_ ,[ int $k/5,$ k%5,$ k++]} split //, uc$t}; $P= { map{@_=@{$p ->{ $_} } ;$_[0 ].$_ [1 ] =>$ _ } keys %$p }; sub w($){ (4+ pop )%5} p ( "\e[4;7;32m\e[2J") ;sub p{printf @_}sub P{select $A,$A,$A,$d if$d}sub c{my($c,$t,$f,$x,$y)=@_ ;if ($f){$x =3*$x+2 ;$y =3*$y+2;map{$q=$_;map{(2 ==$ q&&2 ==$_)or c($c,' ',0,$x+$_ ,$y+$q)}(-1..1)}(- 1..1)}$d&&p"\e[%d;%dH\e[4;%dm$t",$x,$y,$c+$a}map c(6,$_,1,@{$$p{$_}} ),keys% $p;p"\e[17H\e[%dm",$ a+5;p"$e\e[17H\e[s" ;P; sub l{( $u,$ v) =split// ,pop;($u,$U) =@{$ $p{$u }};($ v,$ V)=@ {$$p{$v}} ;$ h =sub {($ J,$ C,$N )=@ _;c($J,$P->{$C.$N},1, $C,$N)};($w,$W,$z,$Z)=($u==$v)?($u,w$U,$v,w$V):( $U==$V)?(w$u,$U,w$v,$V):($u,$V,$v,$U);$h->(1,$u, $U);$h->(2,$v,$V);P;$h->(6,$u,$U);$h->(6,$v,$V); $h->(1,$w,$W);$h->(2,$z,$Z);P;$h->(6,$w,$W);$h-> (6,$z,$Z);p"\e[u\e[%dm%s\e[s",$a+3,$P->{$w.$W}.$ P->{$z.$Z}}{l(uc substr($e,0,2,"")or last),redo}

s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/

Playfair cipher (chargrill)

A slightly less simple obfuscation for a slightly less simple substitution cipher. My next stop in old forgotten encryption ciphers is the Playfair cipher. This is a slightly more obfuscated encryption cipher than my last one - In case you haven't noticed, I'm increasing the obfuscation level as the encryption algorithm increases. This either takes a file as a parameter to encrypt in playfair, or provided no input encrypts it's __DATA__.

Description borrowed from [href://http://en.wikipedia.org/wiki/Playfair_cipher|Wikipedia]:

The Playfair cipher uses a 5 by 5 table containing a key word or phrase. Memorization of the keyword and 4 simple rules was all that was required to create the 5 by 5 table and use the cipher.

To generate the key table, one would first fill in the spaces in the table with the letters of the keyword (dropping any duplicate letters), then fill the remaining spaces with the rest of the letters of the alphabet in order (usually omitting "Q" to reduce the alphabet to fit, other versions put both "I" and "J" in the same space). The key can be written in the top rows of the table, from left to right, or in some other pattern, such as a spiral beginning in the upper-left-hand corner and ending in the center. The keyword together with the conventions for filling in the 5 by 5 table constitute the cipher key.To encrypt a message, one would break the message into groups of 2 letters ("HelloWorld" becomes "HE LL OW OR LD"), and map them out on the key table. We imagine simple rectangles between sets of letters. Then apply the following 4 rules, in order, to each pair of letters in the plaintext:

If both letters are the same (or only one letter is left), add an "X" after the first letter. Encrypt the new pair and continue. Some variants of Playfair use "Q" instead of "X", but any uncommon monograph will do.
If the letters appear on the same row of your table, replace them with the letters to their immediate right respectively (wrapping around to the left side of the row if a letter in the original pair was on the right side of the row).
If the letters appear on the same column of your table, replace them with the letters immediately below respectively (wrapping around to the top side of the column if a letter in the original pair was on the bottom side of the column).
If the letters are not on the same row or column, replace them with the letters on the same row respectively but at the other pair of corners of the rectangle defined by the original pair. The order is important - the first encrypted letter of the pair is the one that lies on the same row as the first plaintext letter.

To decrypt, use the inverse of these 4 rules (dropping any extra "X"s (or "Q"s) that don't make sense in the final message when you finish).

$_=q|P"\e[2J\n";SQw{my$s;select$s,$s,$s,H}SQc{P"\e[12;1f\n"}($_=pop)?open+DATA,$_:$@;$k=N"",MQuc,grep/[a-z]/,M$.{$_}++or$_,$0=~/\w/g;@s=($k=~/./g,grep/[^J$k]/,(A..Z));@Z=@s;F$r(0..4){$t[$r][$_]=H@sQFQ0..4}$t.=N"",grep/[A-Z]/,MQuc,/./gQF             ;$_=             $t;s/             (\w)\1/$1X  $1/g;(y    ///c%  2)&        &($_.     ="X     ");@e  =/.   ./g  ;$E=N"Q",@  e;$  D=1   3;$C=  1;F        $o(1.    .11){    M{P$o  %2?   ($_  -1)%4?"\e[  $o;   ${_  }f.":  "\e        [$o;$   {_} f".   ($o==  1?"   .":  ":"):($_-1  )%4   ?""  :"\e[  $o;        ${_}f  :"}   1..  21}F$  z(2   ..1  0){nextQif  $z%  2;M   {(P("  \e[        $z;${  _}f   ".(  H@Z))   &&( &c&   &w.03))if(  ($z -1)    %2)&&  !((        $_+1)  %4);}3..1  9}SQb    {($I,    $x,$y)=@_;  $r=        0;M{$  c=0        ;M{/$  y/&   &U@  $I,$c     .$r     ;/$x/&&unH  @$I        ,$c.$  r;$        c++}@  $_;   $r+  +}@t}     SQf     {P"\e[12;1  f\e        [0J\n  "}S        Qa{my  ($x   ,$y  ,$t,$     f,@     r)=H=~/./g  ;s/        J/I/F  $x,$y;$w=  0;b\@  r,$   x,$  y;M{(     $h,     $i)=/./g;$             p=++$             h>4?0             :$h;$             t.=$t[$i][$p];if($iQeq$w){$j++}else{$w=$i;$j=0}}@r;$j?$t:0}SQe{my($x,$y,$t,@r)=H=~/./g;s/J/I/F$x,$y;b\@r,$x,$y;$s=$o=$f=0;M{($c,$d)=/./g;if($o++){$f++if$s==$c}else{$s=$c}$d+=$d>3?-4:1;$t.=$t[$d][$c]}@r;$f?$t:0}SQn{my($x,$y,$t,@r,$Y)=H=~/./g;s/J/I/F$x,$y;b\@r,$x,$y;$_=N":",@r;s/(\d)(\d):(\d)(\d)/$2$3:$4$1/;M{($e,$f)=/./         g;$t.=$t[$e]   [$f]}L/:/;$t}SQ   k{($l1,$lt,@       R)=H=~/./g;b\@R,   $l1,$lt;N":",@R}S     Qj{N"-",k($_[0   ]),k$_[1]}SQ   h{   my($t,$b,$l,$r,   $c)=@_;F$o($t..$   b   ){M{P"\e[$o;$   {_}f$c"if(($   o%2   )or!(($_-1)%4)   )}$l..$r}c}SQi{   my(   $t,$b,$l,$r)   =@_;F$o($t..   $b)   {F($l..$r){P"\   e[$o;${_}f."if$   o%2   ;P"\e[$o;${_   }f".($o==1?"   ."   :":")unless($_-      1)%4}}c}SQd{         my($x,$y,$h,   $C)=@_;$l=($       x+1)*2;$c=($y+1)   *4-1;$h?h$l-1,$   l+1   ,$c-2,$c+2,$   C:i$l-1,$l+1   ,$   c-2,$c+2}SQp{my   ($p,$h,$c)=@_;M   {d/   ./g,$h,$c}L/   :/,$p}SQg{my   ($p   ,$e)=@_;$j=j$p   ,$e;($A,$B)=(L/   -/,   $j);p$A,1,"*   ";c;w.02;p$B   ,1,   "@";c;w.01;$D=   =13&&$C==1&&&f;   P"\   e[$D;${C}f$p   Q->Q$e\n";$C   +=$   D>19?$C<60?12:1-$C:0;$D+=$D<20?1:-7;p$A,0;p$B,0;c;w.01;}F(@e){if($T=a$_){g$_,$T;U@c,$T}elsif($T=e$_){g$_,$T;U@c,$T}else{$P=$_;$T=n$_;g$P,$T;U@c,$T}}|;s.\s..g;s:P:print:gx;s:U:push:g;s+N+join+g;s,M,map,g;s:S:sub:g;s'H'shift'g;s-L-split-g;;s;F;for;g;s,Q, ,g;s/([^f])or/$1||/g;eval;&f;print"encrypted:\n@c\n";chargrill__DATA__The Playfair cipher is a manual symmetric encryption technique and was thefirst literal digraph substitution cipher. The scheme was invented in 1854 byCharles Wheatstone, but bears the name of Lord Playfair who promoted the useof the cipher.  The technique encrypts pairs of letters (digraphs), instead ofsingle letters as in the simple substitution cipher and rather more complexVigenere cipher systems then in use. The Playfair is thus significantly harderto break since the frequency analysis used for simple substitution ciphersdoes not work with it.

--chargrill

$,=42;for(34,0,-3,9,-11,11,-17,7,-5){$*.=pack'c'=>$,+=$_}for(reverse split//=>$*){$%++?$ %%2?push@C,$_,$":push@c,$_,$":(push@C,$_,$")&&push@c,$"}$C[$#C]=$/;($#C>$#c)?($ c=\@C)&&($ C=\@c):($ c=\@c)&&($C=\@C);$%=$|;for(@$c){print$_^$$C[$%++]}

Morphological Japh (liverpole)

Morphological (adj):

Relating to or concerned with the formation of admissible words in a language.

Morph (verb):

Computer-assisted process in which an image (or video) is gradually transformed (morphosed) into another.

This program has been tested under both Linux and Windows with the following syntax, where "[...]" indicates an optional argument:

In Linux: perl morph.pl [[entropy-radius] delay-factor]

In Windows: morph.pl [[entropy-radius] delay-factor]

Without options, default values are supplied. A single option is taken to be a delay-factor in fractions of a second (eg. "0.05" is 5 milliseconds). If two options are provided, the second is the delay-factor, and the first is an entropy-radius, which dictates how far from the center to position elements in the most random frame. Try experimenting with different values for each to see what results are produced.

sub J{print"\e[H",$_[0];$d&&select$D,$D,$D,$d} sub A{$V={};@V=split$/,pop;for($w=$y=0;$y<@V;$y++){$Y=$V[$y];@_=split(//,$Y);map{$_[$_]eq$"or$V->{$w++}=[$_,$y]}0..@_-1}$V->{_}=$w;$V}sub P{my($X,$E)=@_;$E+=$W?31:101;$e = $W? "\e[4;7;${E}m": "\e[${E}m";$X=~s/( +)/\e[m$1$e/g&&$X}eval{require Win32::Console::ANSI};sub H{int rand pop}sub _{($j,$c,$n)=@_;$h=$j->{_};@J=($"x79)x22;$|=0;map{$Q=$j->{$_%$h};$q=$s->{$_%$s->{_}};($M,$m)=(@$Q);($O,$o)=(@$q);if($M!=$O||$m!=$o){$M=($Q->[0]-=($M<=>$O));$m=($Q->[1]-=($m<=>$o));++$|}substr($ J[$m],$M,1,chr 33+H 93)}0..$h-1;push@$c,P(join($/,@J),$n%6);$|}s''>?!O"?GIIAA??C!L!DC.?AAIGG??Aaa"_#?@DDC??!O>?!O"?GIIAA??CLLl!d!c,?Aaigg__!a&_?@DDC??!O>?!O!?OYYi!a_ckkG!`"c)?__aaigg__!a\'_@DDC??!O>?!O!?OYyi!q_ckkyrrhim}}woOP@BE]}|llqqa!yqov~~hjeeiggxxzVFFBIWWOAII?OQQ!O>?!O"?!I!Q?Ckkyrzji!}yWORRnm}}~~|}qa!yqp"~vfmiywxzz~vvBIYWW!I"Q"O>?!O!?QYYGWYYi!kyrzjquu}iGwrv~k{qrvt{uayww``nmmuu~miyoqij~|saiYYWIIY!QA?"O>?!O!?QYYGWYyi!k}vvdssuaigir~|koorbfceayww`hnneoowiyqoaajl|soiyyOAAQOO"?!O>?!O!?QYYGOQQackk}vvd{{!ywyr~|kssvffceaywwhhnffppwiyywiijn~uqiyyoaAQ\'O>?!O!?QYYI!QAckkyrrhww!ywyr~|kssvffceaywwghnnfppxiyywiijn~uqiyyoaaQ\'O>?!O??AQYYIA!QEK{yrjhwoqaigibnlkoorbb_aaywwow}}~pphiyqoaabdtsogWwoaaQOO>?!O??AQYWG??QQU[[ZBjhwoqqiggbf~l|rrb`geaywwpo!}p`hiiyoqabv|s_GWYoaaQ!O#?O>??!O?AQYWG??ARV\\\\JBJGGW!Ywwrr~n!~Nlkea!yb`fnnh`_iiyWWyzz~vfJIyoqAAOO!W"O>!?OOQAQWWG!?BV^LJBA!GYQYwwopbf~}\Llc_a!ya`FNnhg_aiIGWWyzbffnMKOQQA?#WOO>:?$_!?"_!o_"?#_$?#_%?"G>%?3O#o"Oo!_oOO!?OO#o%O"o\'OWWO>%?4O"o#O!_ooO!?#o\'O"o&OWWOO>;?"_&?!o#_*?!_%?GG>:?"_(?\'_\'?"_>9?"_&?%_?"_&?$_>7?$_9?%_';$d=pop||0;$r=pop||240;$W=($^O=~/win/i);s/\n//gs;s/>/\n/g;$I=$_;map{$K=$_;$k= chr$K+30;map{$S=chr($_+63);$I=~s/\Q$k$S\E/$S x$K/eg;}(0..63)}(3..32);@L=map{$A=$_;$;=""; map{$_.='?'x(79-y///c);map{$;.=1<<$A&(-63+ord$_)?'@':$"} split//;$;.=$/}split$/,$I;$/.$;}(0..5);print"\e[2J\n";{$F=$L[$a++%6];$T=$L[$a%6];$f=$F;$t=$T;$l=$C++%6;$u=A$f;$v=A$t;@b=@B=();$R=$v->{_};$s={};for($L=0;$L<$R;$L++){{$g=H 78;$G=H 21;(($g-40)**2+($G-10)**2)>$r and redo;$s->{$L}=[$g,$G]}}$s->{_}=$R;while(_$u,\@b,$l){}while(_$v,\@B,$l+01){}JP$f,$l;sleep 1;map{J$_}(@b,reverse@B);J P$t,($l+1)%6;redo}#~liverpole~

s''(q.S:$/9=(T1';s;(..)(..);$..=substr+crypt($1,$2),2,3;eg;print$..$/

I was bored ... (UnderMine)

It has been a long time since I last tried my hand at a bit of obs so here goes nothing.

$c="sj\x09\x03\x12(\x15*O\x18=\x0aDh\x1e5"."oR9\x03rd\x09\x16rJY+&n\\2(H|Z\x05&\x17" ;sub c{$q='';$x= $y=0;for $z (split '',pop ){for (0..$a){ $x+=2**$y if vec $z,$_,1;$y++;if (!($y%$b)) {$q.=chr($x);$y=$x=0;}}}$q;}$c.="\x16(fAc\x16\x0d]\x17:t;$c.="\x14\x08Q\x14[b"."8q\x12'\x17\x16\@>m\x0acEK\x1c]Rli\x07d";;$b=8;$c.="\\:b\@\x14[WL]0l\@\@\{";eval&c($c."\x06nN>\x20"); $k=c(e('"'.e($a[-1]).'"'));chop($k);e(k(q{er!\n";},$k,t(c("\x20D(*7"."\x0e\x1d\x10A\\=#"),in,pr))); J(A.P.H).PM;q{tP\x15\x13\x07\x04T2rX\x01A\x14l\x18\x10}

It's not too difficult to decode so next time I will try harder.P.S. This does need to be saved as file to run.

The.. ekhm (Anonymous Monk)

Excuse me if this code offends you in some way. This is one of my first obfuscated perl programs.For (and inspired by) some guy from one hackers' conference.

#!/usr/bin/perl  sub o { $_ ;return shift if @_>0;return 0;};$dick=shift||o(5);$prick_8=o($dick); [$dick];  ($dick);print(" "x($prick_8- o () +2) ."(')\n");   print(" "x ($prick_8- o () +2)."/ /\n" ) while o($prick_8--> 0);print o("(_)_)");~/8==* B-->/ig;$prick_8=o (qq(DJc\n));print  $prick_8 ;

rusty lock (jynx)

With all respect to Pratchett, "I aitn't dead"... just very rusty.
jynx

#!/usr/bin/perl -l$_=q{$|--;print join$",map{$_[$_{$_}]=sub{join$,,map{$_=(ord)-($_[0]?($_[0]+4+$=)*$=:$=);$_+=(2+$=)*2while$_<(1<<$.)-2-3*$=;chr}split$,,pop}->($_{$_},$_)}map{$_{$_}=$a++;$.++;$_}map{y; ;;d;$=/=1.5;$.++;$_}sub{split$/,join q,,,;unshift@_,map{$.=y---c-$|--;$_}shift;{undef@;;map@{[push@{$;[ord((/.{$.}(.)/)[$|])]},$_]},@_;@_=map@$_,@;;$.--&&redo}@_[$|--..$^F+$|]}->()},s,$/,,g,eval__END__uhinbylzobxiivxqsauhzozmibxtbemzujwqxzafufde

Breaking the indecipherable cipher, courtesy Charles Babbage. (chargrill)

This is a compliment to my recent obfuscated post, [id://549415]. In honor of [href://http://en.wikipedia.org/wiki/Charles_Babbage#Other_accomplishments|Charles Babbage] [href://http://en.wikipedia.org/wiki/Charles_Babbage|(pictured here so you don't have to squint too hard)], who is credited with breaking Vigenre's cipher ca. 1854, but his method was not published until several years later, and as a result credit for the development was instead given to Friedrich Kasiski, who made the same discovery some years after Babbage.

What is now commonly referred to as the Kasiski examination allows a cryptanalyst to deduce the length of the keyword used in the polyalphabetic substitution cipher. Once the length of the keyword is discovered, the cryptanalyst lines up the ciphertext in N columns, where N is the length of the keyword. Then, each column can be treated as the ciphertext of a monoalphabetic substitution cipher. As such, each column can be attacked with [href://http://en.wikipedia.org/wiki/Frequency_analysis|frequency analysis]

This homage to Charles Babbage uses this approach.

                            $_='`$t`                        `.=lc for<>;u($_`                       )for` 3..``6;%t=qw `                    `(a 82 b 15 c 28 d 43 e `                    `127 f 22 ` g 20 h 61 i 70 `                  `j 2 k 8 ```````l 40 m 24 n 67                  ` o 75`              ` p 19 q 1`                ` r `                   60 s 63 t                  ` 91                    ` u 28 v 1                  `0 w                    ` 24 x 2 y `                `20                     ` ` z 1);$k=                k()                    ` ``;$d+=$t{$`               `_}f                    o``r keys%t;$l               =$d`            /in`  ``t(`length($t)/                $k)/100 `  ;map{%n=f(t($_));@g=b(1,\`                `%n);$y.=  i(\@g)}0..$k-1;@_=(a..z);                 map{@$_=  @_;if($;++){for$"(2..$;){                  pu  `    sh`    ``   @$_,shift@$_}                 ``  ``   `}`          }@_;map{$p=i`                 n`        d`ex       `((join\'\',`                  `    `  `@`{(sp    `lit//,$y)[$c                  `   ]}),$_);` `$o```.=$p>=0?$`a`                  `` [ $p]:     $_;$c+=$c<$k-1?1                  ````:  `-$`  ``k+1}split//,$t;s                   ``ub \'b{my($e,$s  `,@g)=@_;p             `                   ``ush@             `g`,[$_,(s             pli`                    ``                ``t//,\'#\'          ``x in`                     ``             `t($$s{`$_}*$e         )`)]for                      `        `+sort+keys%$s;retur        ```n@g}s`                      ub\'c{my$x=shift;$x=g($x,shift    ```)while@_;                       return$x}sub\'f{my%d;$d{$_}++f`  or grep/[a-z]/                        ,split//,shift;$d{$_}||=0for a..z;return%d}su                        b\'g{my($x,$y)=@_;($x,$y)=($y,$x%$y)while$y;r                      eturn$x}sub\'i{my($g,@c)=@_;map{push@c,o(v($g),`       `` `          $$g[0][0]);w($g)}0..25;return(map{$_->[1]}sort{$`       b-``          >[0]<=>$a->[0]}@c)[0]} sub\'k{my@g;for(sort{$s{`      `$b}``       <=>$s{$a}}keys%s){last ``if$s{$_}<3;next unless y     `/a-```    z//>2;my@f  ;push@f,(pos   `($t)-3)while$t=~/$_/g;m`      ````````y$g=c(n(@f)   );`$g````      >2&&push@g,$g}return c(@`         g)}sub\'n{my$o=                  shift;return map{$_-$o}@_       }sub\'o{my($g,$w)                 =@_;my$c=0;map{map{/\+/&&`      $c++;/\-/&&$c--}@                 $_}@$g;return[$c,$w]}sub\'     `t{my($o)=@_;my$c=                0;my$r;map{$r.=$_ unless(   `$k-$o+$c)%$k;$c++}                split//,$t;$r=~s/[^a-z]/   /g;return$r}sub\'u{               my$l=$_[0];$s{substr($t`  ,$_,$l)}++for 0..(le              ngth($t)-$l)}sub\'v{my($  `m)=@_;my@g=b($l,\%t             );$s=\@g;$z=0;map{$x=0;ma   `p{$$s[$z][$x]=$$m`            [$z][$x]eq\'#\'&&$$s[$z][     `$x]eq\'#\'?\'+`            \':\'-\';$x++}@$_;$z++}@$m       `;return$s}sub           \'w{$R=shift;push@$R,shif`        `t@$R}print"           Key: $y\nPlaintext:\n$o\``          `n";';s-\s           \s+--gmx;s&`&&gm;eval#;`            #etur#``          `#my($x($v());$y=$z#`#`               ##````        ``#  charles   #``                #``````   ````#  babbage  #`                  #`````````` # # # # #`                     # ` ` ` `# ##`

This reads in ciphertext via STDIN. If saved as babbage.pl, and Vigenre cipher is saved as vigenere.pl, you can see it in action via:

perl vigenere.pl | perl babbage.pl

I have a more fully featured (unobfuscated, commented, and POD'd) version which even produces [href://http://www.kentcowgill.org/devig.html|HTML output] detailing the results of the Kasiski examination, and optionally the letter frequency analysis charts, which I will post to the code contributions section shortly. But not too quickly, as it's basically a giant spoiler for this :-)

I'd like to give a special thanks to [liverpole], as without his [id://520274], I wouldn't have been so easily able to generate an ascii 'portrait' of Charles Babbage that I could then turn into code.

--chargrill

$,=42;for(34,0,-3,9,-11,11,-17,7,-5){$*.=pack'c'=>$,+=$_}for(reverse split//=>$*){$%++?$ %%2?push@C,$_,$":push@c,$_,$":(push@C,$_,$")&&push@c,$"}$C[$#C]=$/;($#C>$#c)?($ c=\@C)&&($ C=\@c):($ c=\@c)&&($C=\@C);$%=$|;for(@$c){print$_^$$C[$%++]}

My First time... (widdlepuke)

perl -e "$c=1;foreach $l(a..z){if($c==13||$c==1||$c==9||$c==5){push(@m,$l);}elsif($c==7){push(@m, $l);push(@m,$l);}$c++;}($b,$f,$h,$h,$j,$n )=(shift(@m),shift(@m),shift(@m),shift(@m),shift(@m),shift(@m));@m=();push(@m,$n,$b,$h,$h,$j,$f);print @m;"

balls III (teamster_jr)

Apologies for posting two in a row.
just did this:

open F,">o.bmp";print F pack("a2L13",BM,37686,0,54,40,112,112,1572865,0,37632),map{chr(($_%112-55)**2+($_/112-55)**2<3025?255-3*(($_/112-75)**2+($_%112-75)**2)**.5:0)x3}0..12544

hope you like it.
al

time quine (teamster_jr)

based (roughly) on the later of [254692|these], here's a quick something i've knocked up as light relief while i'm working on my next serious obfu:

$_='$p=chr(39);$t=reverse"\$_=$p$_$p;\ns!".chr(92)."s!!g;eval";$_="2.;NNNO82VWiiiiiY2.8iW2/Ve<.8WMdO82WNA-77-A3ii3,ryir,K;F.;o.2O823i`VFBVVn.<82.;O82<.;O83d82!";s!.!-32+ord$&!eg;s!.!(++$c%2?$":1)x$&!eg;s!.{10}!push@_,$&!eg;{$q=$t;$z=sprintf"%2d:"x3,(localtime)[2,$|=1,0];sleep$|;my$s;for$l(0..7){map$s.=s#:##?$"x4:$_[$l+$_*8].$",split//,$z;$s.=$/}$s=~s&1&chop$q⪚$_=reverse$q;s%.{78}%$&$/%g;print"\ec$s$/$_$/";redo}';s!\s!!g;eval

there is a little golfing that could be done, which i might try and update with later.
enjoy
al
p.s. incidentally - does the title rhyme? I'm never sure whether it's pronounced qween or qwine :)

Update: fixed output layout for standard width console (and cut out a line or so)

Vigenre cipher (chargrill)

A slightly less simple obfuscation for a slightly less simple substitution cipher. My next stop in old forgotten encryption ciphers is the [wp://Vigenere cipher|Vigenre cipher]. This is a slightly more obfuscated encryption cipher than my [skytale cipher|last one] - In case you haven't noticed, I'm increasing the obfuscation level as the encryption algorithm increases. This either takes a file as a parameter to encrypt in vigenere, or provided no input encrypts it's __DATA__.

Note: if you save this locally (and I don't know how you might run it otherwise) be sure to give it a filename of a good number of characters ( > 5) - The longer the filename, the better the encryption key.

#!/usr/bin/perl$ ..=$ _ for qw|$ @=/b..u\;/_@ =vqv \?qvcl+FOTO ,_@:_$;kbv($_@ =$ @;jd/_;++\(dqR_"/2. ._;\(vz xH$ _@,xHjdy$ _@)) )$ @;$. =kbv[$ _@] ,_0= ~{}w {g|;$ _=$ . ,y,/FO\\{vzlu}\$dqR_Hjk\@yq(xybRc),(DA)/punz\\\@for\$him_to{stare},,s.. $ _.gee;print map { map { $ %= 0 ;s '([A-Z])(?{$ %=1})'lc$ 1'e ;$ ;=$ .[ $ *] [ - 97 +ord ]; $ *+= $ *== @ .-1? -$ *:1 ;ord> 96?$ %? uc$ ; :$ ; :$ _ }split//}__DATA__The Vigenere cipher, known by some as 'le chiffre indechiffrable' (French for'the indecipherable cipher') is a method of encryption that uses a series ofdifferent Caesar ciphers based on the letters of a keyword, though there issome argument among cryptographic circles as to which incarnation of thisparticular polyalphabetic substitution can accurately be attributed to Blaisede Vigenere.  This implementation is a simple form of a polyalphabeticsubstitution.  To encipher, a table of alphabets can be used, termed a tabularecta, or Vigenere table.  It consists of the alphabet written out 26 timesin different rows, each alphabet shifted cyclicly to the left compared to theprevious alphabet.  Incidentally, there's a good chance that this plaintextis long enough to display the cryptographical weakness of this particularalgorithm.  Can you spot it?

I'm currently working on the brute-force decryption for texts encrypted with this algorithm. It's working now, but I'd like to clean it up and make it more general, as well as optionally display HTML output.

I've found a somewhat reliable method for letter distribution frequency analysis that seems to work for a good number of test cases - Letter frequency analysis is the obvious weakness of this cipher. I'll post a followup with the cracking script a bit later...

--chargrill

$,=42;for(34,0,-3,9,-11,11,-17,7,-5){$*.=pack'c'=>$,+=$_}for(reverse split//=>$*){$%++?$ %%2?push@C,$_,$":push@c,$_,$":(push@C,$_,$")&&push@c,$"}$C[$#C]=$/;($#C>$#c)?($ c=\@C)&&($ C=\@c):($ c=\@c)&&($C=\@C);$%=$|;for(@$c){print$_^$$C[$%++]}

Just Another Perl Hacker (TedPride)

This displays better in an editor that allows 5 more characters of width than PM. Oh well.

@_=split//,'ZRTVOC3H4F5FA6T85FZW3ESN7K8VFHBBPIGPFTLRXCROQ6UWFW5ZSA6N4YWM0LIGGF6V9NER9N9CZDD20WY7YUQE2QBDPCS3WIDKHDU4FS58VDLG3YUFGZCKFA8EBEEZRTGD9OW9T5CO4VM9I2115HK4GI11XDFV25ANA8RO81WFOJB1F936PF6N6OSAAK2FZ1XRR1HJUIA1FHCG9ZXBR7ZSLIZ3JQSEH47RIZTDPW1EAHXF9EOZQRNBDSAF1P5NJ2S3EWNQQFGAN56HL6C5MVIXVLW6U6';$.=join'',reverse map{$_[$_*(ord('K')-ord('@'))]}1..(localtime(1271+2))[1];do{$/=substr($.,($_*3),3);$/++for(-1*-1)..10**3;print$/;}for $|..($#_-282);

My first JAPH (ColinHorne)

It's late at night, and I've just completed my first JAPH (part of my exam-revision procrastination project). Comments are most welcome, whether positive or negative!Hope you like it!

#!/usr/bin/perl -w@k=split//,'colin@colinhorne.co.uk';@p=sub{$_=shift;my@r;for(split/,/){push@r,sub{my@r;$_=shift;for(/.{8}/g){push@r,chr(eval"0b$_")}@r}->(sprintf('%032b',eval("0x$_")))}@r}->("291a1f1d,4e210d00".",18010b1a,4f220b17,4243274f,16080a1e");{my$buf=0;my$count=0;sub d{$buf=(($buf<<1)|($_?1:0))&255;print chr($buf)unless(++$count%8)}}sub{my$f=shift;for(0..$#p){for my$b(map{2**$_}(reverse(0..7))){local$_=(ord($k[$_%$#k])^ord($p[$_]))&$b;&$f}}}->(\&d);print"\n";

(PS: I'm aware of one bug to do with padding thingies to 4 bytes width, but I don't really have time to fix it)

Obfu'd signatures (wulvrine)

I finally caved into the pressures of a fellow monk [liverpole] and created an obfuscated signature file.
I've seen others list them here, so here is mine.

This is my first obfu, nothing fancy etc. Suggestions are appreciated as always.

s&&VALKYRIE &&& print $_^=q|!4 =+;' *|

Why Valkyrie? The name has high importance in my life, mayhap when I finish up my home node it will be clearer.
Thanks to [liverpole] for the hints! (Will someone please take that 2x4 away from him! ow my aching skull!)

s&&VALKYRIE &&& print $_^=q|!4 =+;' *|