Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change


by Erudil (Prior)
on Aug 29, 2001 at 14:38 UTC ( #108730=obfuscated: print w/replies, xml ) Need Help??

  • You'll have to download this and run it from a file
  • Run it more than once to get the full effect
  • Save output to a file and print for best results
Update2: fixed platform dependent bug noticed by stefan k
#!/usr/bin/perl -w # find-a-func use strict; $_='$;="per l";map{map {s}^\s+}} ;$_{$_}++unless(/[^a- z]/)}split(/ [\s,]+/)i f(/alpha. *$;/i../w ait/)}`$; doc\040$; toc`;;;@[=k eys%_;$; =20;$:=15;;for(0..($;*$:-1 )){$;[$_]="_" ;}until($%++>3*$;||@]>2*$:-3){@_=split(//,splice(@[,rand( @[),1));if(3>@_){next;}$~=int(rand($;));$^=int(rand($:)); $-=$~+$^*$;;my$Erudil=0;{if($Erudil++>2*$:){next;}$a=(-1, 0,1)[rand(3)];$b=(-1,0,1)[rand(3)];unless(($a||$b)&&$~ +$a*@_<=$;&&$~+$a*@_>=0&&$^+$b*@_<=$:&&$^+$b*@_>=0){re do;;}my$llama=0;;for(0..$#_){unless($;[$-+$a*$_+$b* $;*$_]eq$_[$_]||$;[$-+$a*$_+$b*$;*$_]eq"_"){$llam a++;last;}}if($llama){redo;}push@],join("",@_);f or(0..$#_){$;[$-+$a*$_+$b*$;*$_]=$_[$_];}}}@_ =sort@];unshift@_ ,"Find:","-"x5;for$a(0. .$:-1){for$b(0. .$;-1){$~=("a".."z") [rand(26)];$_ ="$;[$a*$;+$b]". $";s;_;$~; ;print;}$_=s hift@_|| $";;print$ ",$", $_,$ /;$_ =shi ft@_ ||$ ";pr int $"x $;, $"x $;, $", $", $_ ,$/;; ;}' ;;; s[\s+] $$g; eval; __DATA__ The use of the llama image in association with Perl is a trademark of O'Reilly & Associates, Inc. Used with permission.

Replies are listed 'Best First'.
Re: find-a-func
by grinder (Bishop) on Aug 29, 2001 at 16:46 UTC

    Okay, let's pull this one apart. First of all, there is a big assignment to $_ (as in $_='....') which is then eval'ed. Cutting this bit out, and leaving just the code, and cutting all the blanks out gives us some perl code that can be fed to B::Deparse (this can be done with perl -MO=Deparse find-a-func >find-a-func.deparsed. Depending on your version of Perl a slew of warnings may be emitted. You can run the deparsed code to ensure the script still works correctly. In this case we strike it lucky -- it does). We can then start to look at the code.

    $; = 'perl'; map { map { s/^\s+//; $_{$_}++ unless /[^a-z]/ } split(/[\s,]+/, $_, 0) if /alpha.*$;/i .. /wait/ } `$;doc $;toc`; @[ = keys %_;
    Here we grab the output of the backticked command "perldoc perltoc". The flip-flop operator is used to isolate the section of interest from the line that contains alpha (actually Alphabetical in the text) and the word Perl (what $; is currently) down to the line that contains the word 'wait'. The %_ hash is used to store all the Perl keywords (anything that is in lowercase). Once we've done that we can transfer the hash keys to the @[ array.
    $; = 20; $: = 15; foreach $_ (0 .. $; * $: - 1) { $;[$_] = '_'; }
    A 20 x 15 grid is created. Each cell is set to an underscore. System variables are used where possible to avoid the needless creation of lexicals (we are running under strict, remember). The grid is unfolded out into a linear string such that grid point (x,y) is mapped to (x*ylen)+y.
    until ($%++ > 3 * $; or @] > 2 * $: - 3) {
    We loop through a number of times, 3 times the number of rows, or until we have placed a bit less than half the Perl keywords in the grid. Hmm, not quite. As my inbox puts it Erudil says the line until ($%++ > 3 * $; or @] > 2 * $: - 3) { is used to keep the list from being longer than the grid.
    @_ = split(//, splice(@[, rand @[, 1), 0); if (3 > @_) { next; }
    Take a random Perl keyword, remove it from the array, and chop it up into letters. If it's a less than three letter keyword, throw it away and try again.
    $~ = int rand $;; $^ = int rand $:; $- = $~ + $^ * $;;
    Find a random (x,y) spot on the grid, and also convert that spot to the linear form.
    my $Erudil = 0;
    Create a dead man switch for use in the following scope.
    { if ($Erudil++ > 2 * $:) { next; }
    Open a scope. Increment the dead man, and if we have come through here too many times (via the redos, below), then give up trying to place this word, and go and get another one.</blockquute>
    $a = (-1, 0, 1)[rand 3]; $b = (-1, 0, 1)[rand 3];
    Generate a point somewhere in the Conway (à la game of Life, not Damian) neighbourhood.
    unless ($a || $b and $~ + $a * @_ <= $; and $~ + $a * @_ >= 0 and $^ + $b * @_ <= $: and $^ + $b * @_ >= 0) { redo; }
    Ensure that we haven't fallen off the end of the grid.
    my $llama = 0; foreach $_ (0 .. $#_) { unless ($;[$- + $a * $_ + $b * $; * $_] eq $_[$_] or $;[$- + $a * $_ + $b * $; * $_] eq '_') { ++$llama; last; } }
    Now try and place the word, letter by letter, walking away in the direction we started with. If the grid point being inspected is an underscore, that means we haven't placed any letter there yet, which is cool, on the other hand if it is a letter, and it is the same as the letter we want to place, that's cool too (in fact, it's a big win for it means we've managed to position two (or more) words sharing a common position on the grid). Otherwise, if we collide, raise a llama flag and get out -- we are blocked by a word that has laid a prior claim to this grid point.
    if ($llama) { redo; }
    It wasn't ok, so let's try placing it somewhere else. Ha, the joys of brute force. It's stuff like this that explains why the script takes a second or three to generate its output.
    push @], join('', @_); foreach $_ (0 .. $#_) { $;[$- + $a * $_ + $b * $; * $_] = $_[$_]; }
    Join the letters back up into the word. Push that word onto the list of words we have to find. Then, mark up the grid with the definitive letters that have been used.
    } } @_ = sort(@]); unshift @_, 'Find:', '-' x 5;
    Sort the words into alphabetical order, and add two elements to the beginning of the array, which will become the header.
    foreach $a (0 .. $: - 1) {
    For each row...
    foreach $b (0 .. $; - 1) {
    ... and for each column...
    $~ = ('a'..'z')[rand 26]; $_ = "$;[$a * $; + $b]" . $"; s/_/$~/; print $_; }
    Choose a random letter. Get the current point in the grid. If it's a _ then there's no placed letter, so use the random letter instead. Print that.
    $_ = shift @_ || $"; print $", $", $_, $/; $_ = shift @_ || $"; print $" x $;, $" x $;, $", $", $_, $/; }
    Print out the next word in the list of words to find. Then print a new line, a raft of spaces ($" is just a space (by default), after all), and the next word after that. In this manner we get a nice airy layout.

    update: Erudil pointed out a small B::Deparse artifact in my deconstruction. Corrected.

    g r i n d e r
      One of the things that I initially thought when I saw this obfu was that the llama copyright warning in the __DATA__ section was a significant part of the obfu; however, as Grinder's dissection above shows, it's just there.

      Not to belittle Erudil's work, but I think an interesting take off of this would be to add just enough words to make the copyright notice into a pangram (a sentence containing every letter of the alphabet), and then modify:

      $~ = (('a'..'z'))[rand 26];
      into something that randomly picks a letter from this new __DATA__ section. The end effect would be about the same, except that now the distribution of random letters would closely mimic the english distribution ('eaton...') roughtly.

      Of course, that would completely require Erudil to re-plot out the llama, since this change would probably add from 5 to 15 characters, and may not be possible to keep the code shape.

      Dr. Michael K. Neylon - || "You've left the lens cap of your mind on again, Pinky" - The Brain
      It's not what you know, but knowing how to find it if you don't know that's important

        A very nice additional idea, Masem. I wouldn't change the copyright statement in any way, though. Just pick a random character from it, it is an English sentence at the moment so it already matches the distribution of letters (or at least as roughly as anything else) and the main point is just to get a random letter ... I don't think it's a problem if you never get an x.

        Although the '&' might look a bit strange as a letter. And I don't think you can get that out of the copyright ;-)

        Update: Added the '&' remark.

        -- Hofmator

Re: find-a-func
by Masem (Monsignor) on Aug 29, 2001 at 15:21 UTC
    A few things of note that we're discovering in the CB right now:

    Make sure to d/l the code instead of just copying and pasting. There appears to be a small error (not fatal) that comes from copying the code.

    You'll need to wait a few moments for output; on my 200mhz machine, it was about a minute, while it was less than 5 seconds on a 1.2ghz.

    Gadzooks, he's done it again!

    Dr. Michael K. Neylon - || "You've left the lens cap of your mind on again, Pinky" - The Brain
    It's not what you know, but knowing how to find it if you don't know that's important

      For those encountering the error:
      Unrecognized escape \d passed through at (eval 1) line 1.
      (like I did) and for whom it doesn't disappear if they download the code: open in $EDITOR, goto line 12:
      and change it to
      Well, this works for me, I hope it does for others

      And then... I bow down low in respect of this work. Marvellous!

      Update: This won't be necessary anymore since Erudil changed the code in that line. :)

      Regards... Stefan
      you begin bashing the string with a +42 regexp of confusion

Re: find-a-func
by mrmick (Curate) on Aug 29, 2001 at 16:11 UTC

    The master strikes again! Great work, Erudil!

Re: find-a-func
by TStanley (Canon) on Aug 30, 2001 at 03:46 UTC
    /me thinks it's time for a new T-Shirt :-)
    Great job Erudil!

    There's an infinite number of monkeys outside who want to talk to us
    about this script for Hamlet they've worked out
    -- Douglas Adams/Hitchhiker's Guide to the Galaxy
Re: find-a-func
by dmmiller2k (Chaplain) on Aug 30, 2001 at 01:39 UTC
    Very clever. I like it!


    Just call me the Anti-Gates ...
Re: find-a-func
by marvell (Pilgrim) on Sep 03, 2001 at 16:47 UTC


    If I had time, I'd write a Camel to play it :)

    Brother Marvell


Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: obfuscated [id://108730]
Approved by root
[Corion]: Oh - jwz gives us interesting insight in cloud hosting. I'm amazed how many people suggest he rework his setup into AWS, even though that brings a lot of rearchitecting just to make it wo
[Corion]: ... work
[erix]: interesting...

How do I use this? | Other CB clients
Other Users?
Others chanting in the Monastery: (5)
As of 2017-06-24 07:12 GMT
Find Nodes?
    Voting Booth?
    How many monitors do you use while coding?

    Results (557 votes). Check out past polls.