Beefy Boxes and Bandwidth Generously Provided by pair Networks
good chemistry is complicated,
and a little bit messy -LW

Number Theory Monster

by jynx (Priest)
on May 28, 2001 at 08:25 UTC ( #83693=obfuscated: print w/replies, xml ) Need Help??

This code has a "feature" that is truly random. How many letters of JAPH will you get?
#!/usr/local/bin/perl use strict;my@l=(1);my($c,$d )=(75,0);push@l,q|-84|;sub t{my$o=shift ;print$o @_}push@l,qw{-1 43 -2};unshift@l,@l[$#l- 2..$#l];pop@l;pop@l;pop@l;sub c{my$f=pop;open M,$f;my @l=<M>;chomp@l;pop@l while$l[$#l]ne'__END__';open M, ">$f";t *M,(join"\n",@l),$/}push@l,qw-33 45 1 5-;push @l,qw @-12 -3@;sub i {my(@a ,$n)= @_;$n+=shift@a while $n++, @a&&!--$a[0];{ @a|| last; @a=($a[0]<$n?$ a[0]: $n,@a );($n-=$a[0])&& redo} @a}unshift@l,qw[13 -82];push@l,@l[0,1];shift@l;shift@ l;sub P{my($P,$p)=@_;$P<$p?0:$P==1||$p==1||$P-$p==1?1 :P($P-1,$p-1)+P($P-$p,$p)}push@l,qw-48 21 13-,q;-6;; $l[$#l+1]=-76;push@l,qw/40 25 2 8/,q#-6#;sub p{my$e; my@r=[];$e=$_,@r=map{my@a=@$_;map[@a[0..$_-1],$e,@a[ $_..$#a]],0..@a}@r for@_;@r}push@l,qw@13 -104@;if(my @t=unpack"C*",do{local($/);<DATA>}){my$t=0;{$t[0]==126 ?((t *STDERR,chr$t),last):($t+=shift@t)and redo}c $0; $d=$t[$#t];$c+=$l[$_]for 0..$d}else{$c+=$l[0];$d=0}if ($d<@l){open M,">>$0";my@p=$c;my$r;do{$r=int(rand&P($ c,int(rand($c-($ c/3))+1)+int(2* $c/3)))+1}while $r==1;@p=i@p while$r--;(@p <1<<3)?(@p=p( @p)and t(* M,(map{chr} @{$p[int( rand(0+@ p))+1]}), '~',chr($ d+1))) :(t(*M, (map{chr }@p) ,'~', chr( $d +1) )) ;exec"perl $0"} __END__

PS it looks better in fixed-width font ;-)

Replies are listed 'Best First'.
Re: Number Theory Monster
by Starky (Chaplain) on May 28, 2001 at 10:34 UTC
    Looks like a winner! But I seem to be having some problems.

    It seems to spin ad infinitum sucking up 80%+ CPU. (I let it go about 5 minutes before I sent a SIGINT.)

    A quick run through the debugger seems to indicate it gets stuck on

    DB<1> main::(./ @t=unpack"C*",do{local($/);&lt;DATA&gt;}){my$t +=0;{$t[0]==126 DB<1> main::(./ @t=unpack"C*",do{local($/);&lt;DATA&gt;}){my$t +=0;{$t[0]==126 DB<1> etc. etc. etc.
    Am I just being daft, or is there a __DATA__ block missing?

    Follow-up: I was being daft. Make sure there are no blank lines after __END__. Doh!

    Edit: chipmunk 2001-05-28

Re: Number Theory Monster
by tachyon (Chancellor) on May 29, 2001 at 21:35 UTC

    Truly a monster, here it is with whitespace

    use strict; my@l=(1); my($c,$d)=(75,0); push@l,q|-84|; sub t{ my$o=shift; print$o @_ } push@l,qw{-1 43 -2}; unshift@l,@l[$#l-2..$#l]; pop@l; pop@l; pop@l; sub c{ my$f=pop; open M,$f; my @l=<M>; chomp@l; pop@l while$l[$#l]ne'__END__'; open M,">$f"; t *M,(join"\n",@l),$/ } push@l,qw-33 45 1 5-; push @l,qw @-12 -3@; sub i{ my(@a,$n)=@_; $n+=shift@a while$n++,@a&&!--$a[0]; { @a||last; @a=($a[0]<$n?$a[0]:$n,@a); ($n-=$a[0])&&redo } @a } unshift@l,qw[13-82]; push@l,@l[0,1]; shift@l; shift@l; sub P{ my($P,$p)=@_; $P<$p? 0 : $P==1 || $p==1 || $P-$p==1 ? 1 : P($P-1,$p-1)+P($P-$p,$p) } push@l,qw-48 21 13-,q;-6;; $l[$#l+1]=-76; push@l,qw/40 25 2 8/,q#-6#; sub p{ my$e; my@r=[]; $e=$_,@r=map{my@a=@$_;map[@a[0..$_-1],$e,@a[$_..$#a]],0..@a}@r for +@_; @r } push@l,qw@13-104@; if(my@t=unpack"C*",do{local($/);<DATA>}) { my$t=0; { $t[0]==126 ?((t *STDERR,chr$t),last): ($t+=shift@t)and redo } c $0; $d=$t[$#t]; $c+=$l[$_]for 0..$d } else { $c+=$l[0]; $d=0 } if($d<@l){ open M,">>$0"; my@p=$c; my$r; do{$r=int(rand&P($c,int(rand($c-($c/3))+1)+int(2*$c/3)))+1}while$r +==1; @p=i@pwhile$r--; (@p<1<<3)?(@p=p(@p)and t(*M,(map{chr}@{$p[int(rand(0+@p))+1]}),'~' +,chr($d+1))):(t(*M,(map{chr}@p),'~',chr($d+1); exec"perl $0" } __END__

    Hmm, that's heaps clearer now! This may take longer than I thought.....



      It's been a couple of days, so i thought i would post the spoiler, there has been at least some request for it, so here goes:

      Firstly, look at the post that i replied this to, that post has the monster written out with white space. We'll start at that incarnation (because it saves me from typing).

      @l: This is a list of numbers that determines what the next letter of 'Just Another Perl Hacker' will be. If we put everything together, @l becomes the following:

      @l = qw( -1 43 -2 1 -84 33 45 1 5 -12 -3 13 -82 48 21 13 -6 -76 40 25 2 8 -6 13 -104);
      If we take the starting number ($c at 75) and start adding numbers sequentially we get the following list of numbers:
      74 117 115 116 32 65 110 111 116 104 101 114 32 80 101 114 108 32 72 97 99 107 101 114 10
      These just happen to be the ordinal values of the letters 'Just Another Perl Hacker' (32 is space and 10 is newline). So, that was the easy part. What do all those subroutines do? Many may find the code familiar as i used this japh to test the results of some of the golf contests. In order:
      t: prints to the filehandle passed in.
      c: reformats a file, making it only have the lines above the __END__ token.
      i: tye's context insensitive number partitioner.
      P: returns the number of partitions for a given number of a given size.
      p: tilly's non-recursive permutation finder.

      Now we have to use those. The if block

      if(my@t=unpack"C*",do{local($/);<DATA>}) { my$t=0; { $t[0]==126 ? ((t *STDERR,chr$t),last): ($t+=shift@t)and redo } c $0; $d=$t[$#t]; $c+=$l[$_]for 0..$d } else { $c+=$l[0]; $d=0 }
      checks to see if there is already a value set under the __END__ tag. If there is, It takes the numbers before the ord value 126 (tilde or '~') and adds them together, to receive the ordinal value of the character to print. Then the number after the tilde becomes the spot in the array (@l) where we currently belong. Also we clean up the file at this point, to remove anything after the __END__ token. At this point we set the current letter ($c) to the next letter in the series, and the pointer ($d) to the position of that letter in the array.

      If there is nothing after the __END__ token, we simply set $c to 74 (ordinal 'J') and $d to 0 (beginning of array).

      Now, if our spot in the array is equivalent to the size of the array, we're done, there's no more. Note that because of the placement, when we're done, there will be nothing after the __END__ token, so we can run the program again.

      if($d<@l){ open M,">>$0"; my@p=$c; my$r; do{ $r=int(rand &P($c,int(rand($c-($c/3))+1)+int(2*$c/3)) )+1 } while $r==1; @p=i@pwhile$r--; (@p<1<<3) ? (@p=p(@p)and t(*M,(map{chr}@{$p[int(rand(0+@p))+1]}),'~',chr($d+1)) +): (t(*M,(map{chr}@p),'~',chr($d+1); exec"perl $0" }
      If we are not done, we open ourself for appending and get down to business. $r is the number of times that we will loop through the partition finder. In order to find $r we want to know how many times we can take partitions of $r, and i use a random value for the size that i want the final partition to be to make things interesting. In order to not have the program run toward infinite however, i have to bound how big $r can be. Also, if i wanted to remove the nifty missing letter feature, i could further restrict $r to do so. But i like that feature, i'm not perfect, why should my japh be?

      Anyway, After finding a reasonable $r, we run through the iterations of i. Then, if there are less than 8 things in our partition, we randomize the locations of the numbers by running the permutation finder, and select one of those permutations to print. If there are more than 8 things in the list, than we don't permute them because it will take far too bloody long to find the permutation of more than 7 things (with any of the algorithms suggested by the golf contest).

      During printing, we also print out a tilde to seperate the letter from the pointer, and print out the pointer.

      After we've printed out the characters, we run the program again. This will close the file for us, and since we are 'exec'ing the file, the current script goes away.

      And there's the spoiler,

Log In?

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: obfuscated [id://83693]
Approved by root
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others surveying the Monastery: (3)
As of 2021-11-28 08:23 GMT
Find Nodes?
    Voting Booth?

    No recent polls found