A program that really makes waves

[liverpole]

This runs on Windows platforms.  It may take a few seconds to produce output, so please be patient.

It will take a single string argument, but supplies a default if one is not given.  If the passed string is invalid, the program simply prints the string and exits.

Once you've discovered what the program does, see if you can figure out what kinds of strings will work.

Update:  Modified slightly to work with Linux too.  Thank you teamster_jr for the info!  (Under Linux the 3 modules Gnome::Sound, Time::HiRes, and Tk must be installed).

#!/usr/bin/perl

###############
## Libraries ##
###############
use FileHandle; use Time::HiRes qw(usleep gettimeofday);use Tk;
$B = eval { require Win32::Sound }; $B or require Gnome::Sound;

####################
## Initialization ##
####################
$F={1,{qw[f 1 S 1 q 1 s 1]},2,{qw[f 1 S 1 q 1]},4,{qw[f 1 S 1]},8,{qw
[S 1]},};sub X{length$_[0]}foreach$b(keys%$F){$p=$F->{$b};map{$F->{$b
*1.5}->{$_}=$F->{$b}->{$_} } (keys%$p); $F->{$b *1.5}->{d}=1} $,='li'
; $;='a.wav'; @i = map { $o = $_; map {$o.$_ }('A'..'G')}(1..5);$si-=
3; $px = { }; for (@i) { $px->{$_} = $si++ ; last if ($_ eq '5E')}map
{$px->{"$_#"}=$px->{$_.'b'}=$px->{$_}} (keys%$px);$E={qw(1A 3- 1B 2%-
1C 2- 1D 1%- 1E 1 3C 1 5A 1 5B 1%+ 5C 2+ 5D 2%+ 5E 3+)};map {$E->{$_.
'#'}=$E->{$_} } ( keys % $E); $G = 4; $ja = 472; $n = 55; $Y= $Z=100;
$I={};$T= $J=3; $j = $U = $v = $W = $z = $oo = 0;$w = { };$V = {};sub
P{my($p, $q, $r, $s) = @_; $st = $I->{$q.$r}; $s/=100;$ha =0;$ck=$st/
11025;$er= $s *11025; map { $X = 327.67* $Y*sin($ha*6.2831853); if($R
>=@$p) {push @$p,$X}else{$p->[$R]+= $X } $R++; $ha += $ck } (1..$er)}

##################
## Command-line ##
##################
my $input = shift||
   '<75>[1]vV+|:{1(1)/1C/DEFG+ABCDEFG+ABCBAAbADCBAA-GF#GrG+E-GrF+'.
   'E-FrF+D-FrE+D-ErE+C-ErD+C-DrD+B-D^+Cr}:||:(.25)2G+CEDCBA-GFED'.
   'CBA-GF*E+EFF#G.E`Dr:|=1vV-|:{2(2)1C/E~CF~CE+CAB-G#+A-FGCr}:||'.
   ':(2)EDCB:|=2vV-|:{3(2)0C/ECFCE+CAB-G#+A-FGCr}:||:(2)GGGG:|=3';

##################
## Main Program ##
##################
 $x=55; $D= 2**(1/12); map{$U=$_;$y=$x*(2**$U);for($i=0;$i<7;$i++)
  {$t=[qw(A B C D E F G)]->[$i]; $u = $U.$t; $I->{$u} = $y;last if(
   '5E'eq$u);$I->{"${u}b"}=$y/$D; $I->{"${u}#"} = $y * $D; $y *= ($D
     ** [2,1,2,2,1,2,2]->[$i])}}( 1..5 );W($input,50,20);$cv= tkinit->
     Scrolled ('Canvas', -scrollbars,'se')->form; $cv->configure (-wi,
     850,-he, $ja,-bg, 'white',-confine, 1); S(0,$G-1); update $cv;$B?
    Win32::Sound::Volume(0xffffffff):Gnome::Sound::init('localhost');
   $B? Win32::Sound::Play($;,1):Gnome::Sound::play($;);$nt=$ot=-0.2+
  gettimeofday; $k = 0;while($k<=$V->{V}){$tt=$ot+($k+1)/128;while(
 $nt<$tt){usleep(1/4096);$nt=gettimeofday()}while($ot+($k+1)*1/128
 <=$nt){$nb=$V->{$k++};while(@{$V->{$k}}>0){push@$nb,@{$V->{$k++}}
 }($k%128)or i(12);if($nb){while(@$nb){($nn,$dd)=splice(@$nb,0,2);
  $sd=($nn=~s/([-+])$//)? $1:0; $dd*=8;t($nn, $dd,$sd)} $cv->update
   ;i(18)}}}while(1){$cv->update;usleep 100000}#5/3/2006 - liverpole


##################
## Subroutines ###
##################
sub C { create $cv(@_) } sub i{ $n+=$_[0];if($n+18>=822){$n=55;if
  (++$j>=$G){S($G,$G);$ja+=114;$cv->configure(-scrollregion,[0,0,
  850,$ja]);$cv->yviewMoveto(1-(1/$G));++$G}}}sub S {my ($C,$c)=@
  _; for ($i=$C;$i<=$c;$i++) {$jo=$i*114; map{$xy=35+$jo+6*$_;5eq
  $_ or create$cv($,, 20,$xy, 830, $xy) }(0..10)}}sub R{my($C)=@_
  ;$l=0;$d={};while($C=~s/{(.)([^}]*)}/$2/){my$sm=$1;$d->{$sm}=$2
  }while($C=~/=(.)/){my$sm=$1;$c=$d->{$sm};$C=~s/=\Q$sm\E/$c/}map
  {if (/\|:/) { $c[++$l] = "" } elsif (/:\|/) { $c[$l-1] .= $c[$l
  ]x2; --$l } else { $c[$l] .= $_ } }split(/(\|:|:\|)/,$C); $c[0]
  }sub W{my($a,$b,$c)=@_;$_=R($a);$v=$Z=$b;$U=$W=$c;my$p=[];while
  ($_) { if (s/^\(([.\d]+)\)//){$v=$Z*$1}elsif(s/^<(\d+)>//) { $Y
  =$1} elsif (s/^\[([-\d]+)\]//){$oo=$1}elsif(s/^(\-|\+)//){$T+=(
  $1eq'+')?1:-1}elsif(s/^(\d+)//) { $T = $1 }elsif(s/^(\*|\/)//){
  $v*=($1eq'*')?2:.5}elsif(s/^(\^|_)//){$v*=($1eq'^')?4:.25}elsif
  (s/^!(\d+)!//){$U = $1} elsif (s/^@(.)//) {$w->{$1}||=$R}elsif(
  s/^&(.)//){$R=$w->{$1}}elsif(s/^v//){ ++$z;$R=$S =0; $T = $J;$v
  =$Z;$U=$W}elsif(s/^V(.)//){$S=$1}else{D(\$_,$p)}}sysopen($A,$;,
  O_WRONLY|O_CREAT)or die$!.$/;$N=4*@$p;$H=pack('A4Va4A4VvvVVvv'.
  'a4V','RIFF',$N+36,'WAVE','fmt',16,1,2,11025,44100,4,16,'data',
  $N);syswrite($A,$H,44);for($i=0;$i<@$p;$i++){my$vu=$p->[$i]/($z
  ||1);$da=pack('s',$vu);$O.=$da.$da;if(X$O>4096){syswrite($A,$O,
  X $O); $O =""}($i< @$p) or last } syswrite ($A,$O,X$O);close$A;
}

sub t {
  my ($nn, $nb, $sd) = @_;
  my$pd=$F->{$nb};my$yy=35+$j*114;$yy+=69;$x=$n;$nn=~/(.)(.+)/;$et=$2;
  my$idx=$px->{$1.$et};defined($idx)or return;my$y=$yy-($idx*3);if($et
  =~/[#b]/){$x-=8;if($et=~/#/){C($,,$x-4,$y-1,$x+3,$y-3);C($,,$x-3,$y+
  3,$x+4,$y+1);C($,,$x-3,$y-4,$x,$y+5);C($,,$x,$y-5,$x+3,$y+4)}else{C(
  $,,$x-2, $y-8,$x-2,$y+4);C($,,$x-2,$y+3,$x+3,$y+1);C($,,$x+2,$y+1,$x
  +3,$y-1);C($,,$x+2,$y-1,$x-2,$y-3)}$x+=8}@a=$pd->{'f'}?(-fi,'blue'):
  ();create$cv ('ov',$x-3, $y-3, $x+3, $y+3, @a); $pd->{'d'} and $cv->
  createOval($x+3+3,$y+1,$x+3+6,$y+4,-fi,'black');if($pd->{S}||0){my($
  sx,$sy)=($x,$y);$sd||=0;$g=20;$di=1;if('-'eq$sd||(!$sd&&$idx<$px ->{
  '3C'})){$di=-1;$sx-=2*3;$g=-$g}create$cv($,,$sx+3,$sy,$sx+3,$sy-$g);
  if($pd->{q}||0){$sx+=3;$sy-=$g;$Q=8;$P=4;$P=$di*$P;create$cv($,,$sx,
  $sy,$sx+$Q,$sy+$P);if($pd->{s}||0){$sy+=$P;create$cv($,,$sx,$sy,$sx+
  $Q,$sy+$P)}}} if($_=$E->{$nn}){/(\d)(%?)([-+]?)/;($rp,$eq,$le)=($1,$
  2,$3);$le=('-'eq$le)?-3:3;($eq eq'%')and$y+=$le; while($rp--){create
  $cv($,, $x-7, $y, $x+7, $y);$y += 2 * $le}}
}

###################
## Program notes ##
###################
                    sub
                     D{
                     my(
                     $p,
                     $P)
                     =@_;
                     ($$p
                     =~s/
                     ^( (
                     [A-G]
                     [#b%]?
                     )|[Rr]
                     )(\.|`?
                     )(~?)//x)
                     or die$$p.
                     $/;$M=$1;$
                     dv=$3||0;$
                     sv= $4||0;
                     $dd   =$v;(
                     'R'    eq$M)
                     and      $dd
                     *=2      ;$dv
                     and       $dd
                     *=(       '.'
                     eq$        dv)
                     ?1.5       :.5
                     ; $         tc
                     = $         sv
                     ?0:         $U
                     ;$r         =$
                     dd*        $tc
                    /100        ;$
                    q= $       dd
              -$r;$k=int      (
            128*$R/11025     )
          ;(($V->{V}||0)
          <$k)and$V->{V}
        =$k;$V->{$k}||=[
        ];$L=$T+$oo;$K=$
        L.$M;$S and$K.=
        $S;push@{$V->{
        $k}},"$K",($dd
        /100);P($P,$L,
         $M,$q);P($P
         ,'r','r',$
            r);}

[teamster_jr]

++liverpole, That's absolutely awesome.
there's some stuff in there that i shall definitely steal use for some stuff i've been thinking about doing (especially as it generates stuff that's missing from my previous obfu :) ).
you can make it work on 'nix systems either by doing
 # `cat $; > /dev/snd`
(not the safest thing to do! - i've played around with this idea in the past)
or more realistically by using Gnome::Sound rather than Win32::Sound thusly:
Read more... (8 kB)
al
Update: fixed bad code upload

[wulvrine]

Music to my ears!

What can I say, you've upped the 'staff' of obfuscation yet again!

[liverpole]

As I promised yesterday, here are several more strings which, when used as the argument to the "Waves obfuscation", produce some of the variations of "Twinkle Twinkle Little Star":

# The THEME
'vV+[1]|:{aCCGG+AA-GGFFEED/D.E`^C/}:|GGFFEEDDGGFFE/E.F`*E~D=avV-[-1]|:
+{bC+CECFCECDBCA-FG*C/}:|+E-G+D-G+C-G+B-G+E-G+D-G+C/C.D`@n*C~B-=bvV-[-
+1]&n*G';

# Variation 1
'vV+[1]_|:{aDCBCBCBC+A-GF#GF#GF#GG#+ACBDCBAA~-G+EDCBA-GG~F+DCBA-GFF~E+
+CBA-GFE*D+A~-GB*Cr_}:|+A-GF#GF#G+A-GGFEFEFGFFED#ED#EFEEDC#DC#DED+A-GF
+#G+ECA-GGFEF+DB-GFFED#E+C-GFE*G.~E`*D_=avV-[-1]{bC~+C~E~C~F~C@nE/r.C#
+`*D/r.B`*C/r.A`*-FG/}+C-GEG*=b*+C-C+E~-G~+D~-G+C~-G~+F~-G*@o+ED/C/r.C
+`E.C`*B[-2]=b*+C-CvV-[0]&nC&o*-GG/GrG';

# Variation 2
'vV+[1]|:CCGG@nGFFEEDDCCB-Gr+:||:|:GG~FF/E.D`E.F`*E~D:|C~/CB`C`*GG~+AA
+~-GG~F#F~EE~DDCr:|vV-[1]|:*R+A-G/FFEEDDCr:||:CC~CB/C.D`E.F`^B/CC~CB/-
+G.+D`E.F`^-G/Grr+C~CC~CBbAAb-G+A~A/-G.F`*Er+:|vV-[-1]|:_C+CBCDCBC-E+C
+BCDCBC-F+CBCDCBC-C+CBCDCBC-A+AAbA-B+BBbB-C+CBC-A+AAbA--F+FEF-G+GF#G^-
+C+C:||:_G+EEbEFEEbE-G+DDbDEDDbD-G+GF#G+A-GF#G-G+FEFGFEF-G+EEbEFEEbE-G
++DC#DEDC#D-G+CBCDCBC-G+BBbBCBBbB-C+CBCDCBC-E+CBCDCBC-F+CBCDCBC-C+CBC-
+C#+C#BC#-D+DC#D-B+BBbB-C+CBC-A+AAbA--F+FEF-G+GF#G^-C+C:|';

# Variation 5
'vV+!40!+|:C/rC*G/rG*+A/rA-*G/rGrFrFrErErDrD*Cr:||:G/rG~*F#/rF~*E/rEb~
+*D/r-G+*G/r/G~F#~^F/r/F~E~^Eb/r/F#~G~^D/r/F~D~^C/r/C~E~^G/r/G~E~+^A/r
+/A~C~^-G/r/E~GRG~F#RD~FRF~ERG~ERC#~DRF~DRB~C^r:|vV-!40!+|:RRRr/rErErD
+rDrCrCrB*Cr:|vV-!40!|:/rCERECRFCRECrDrBrCrA-rFrGR+C-*C+:||:|:/rE-*G/r
++D-*G/r+C-*G/r+B-*G+:|-/r/C~E~^G/r/+C~E~^G/r/F~+A~-^C/r/E~G~^C/DrBrCr
+-ErFrGr+Cr-Cr+*:|';

[QM]

I've made 2 changes to your code, to randomly play any of these:

my $input;
unless ( $input = shift )
{
    # read from DATA
    my @tunes = grep { $_ !~ /^#/ and /\S/ } <DATA>;
    chomp($input = $tunes[rand(@tunes)]);
}

and

__DATA__
# Original: 
<75>[1]vV+|:{1(1)/1C/DEFG+ABCDEFG+ABCBAAbADCBAA-GF#GrG+E-GrF+E-FrF+D-F
+rE+D-ErE+C-ErD+C-DrD+B-D^+Cr}:||:(.25)2G+CEDCBA-GFEDCBA-GF*E+EFF#G.E`
+Dr:|=1vV-|:{2(2)1C/E~CF~CE+CAB-G#+A-FGCr}:||:(2)EDCB:|=2vV-|:{3(2)0C/
+ECFCE+CAB-G#+A-FGCr}:||:(2)GGGG:|=3

# Twinkle Twinkle Little Star (Main Theme)
vV+[1]|:{aCCGG+AA-GGFFEED/D.E`^C/}:|GGFFEEDDGGFFE/E.F`*E~D=avV-[-1]|:{
+bC+CECFCECDBCA-FG*C/}:|+E-G+D-G+C-G+B-G+E-G+D-G+C/C.D`@n*C~B-=bvV-[-1
+]&n*G

# TTLS Variation 1
vV+[1]_|:{aDCBCBCBC+A-GF#GF#GF#GG#+ACBDCBAA~-G+EDCBA-GG~F+DCBA-GFF~E+C
+BA-GFE*D+A~-GB*Cr_}:|+A-GF#GF#G+A-GGFEFEFGFFED#ED#EFEEDC#DC#DED+A-GF#
+G+ECA-GGFEF+DB-GFFED#E+C-GFE*G.~E`*D_=avV-[-1]{bC~+C~E~C~F~C@nE/r.C#`
+*D/r.B`*C/r.A`*-FG/}+C-GEG*=b*+C-C+E~-G~+D~-G+C~-G~+F~-G*@o+ED/C/r.C`
+E.C`*B[-2]=b*+C-CvV-[0]&nC&o*-GG/GrG

# TTLS Variation 2
vV+[1]|:CCGG@nGFFEEDDCCB-Gr+:||:|:GG~FF/E.D`E.F`*E~D:|C~/CB`C`*GG~+AA~
+-GG~F#F~EE~DDCr:|vV-[1]|:*R+A-G/FFEEDDCr:||:CC~CB/C.D`E.F`^B/CC~CB/-G
+.+D`E.F`^-G/Grr+C~CC~CBbAAb-G+A~A/-G.F`*Er+:|vV-[-1]|:_C+CBCDCBC-E+CB
+CDCBC-F+CBCDCBC-C+CBCDCBC-A+AAbA-B+BBbB-C+CBC-A+AAbA--F+FEF-G+GF#G^-C
++C:||:_G+EEbEFEEbE-G+DDbDEDDbD-G+GF#G+A-GF#G-G+FEFGFEF-G+EEbEFEEbE-G+
+DC#DEDC#D-G+CBCDCBC-G+BBbBCBBbB-C+CBCDCBC-E+CBCDCBC-F+CBCDCBC-C+CBC-C
+#+C#BC#-D+DC#D-B+BBbB-C+CBC-A+AAbA--F+FEF-G+GF#G^-C+C:|

# TTLS Variation 5
vV+!40!+|:C/rC*G/rG*+A/rA-*G/rGrFrFrErErDrD*Cr:||:G/rG~*F#/rF~*E/rEb~*
+D/r-G+*G/r/G~F#~^F/r/F~E~^Eb/r/F#~G~^D/r/F~D~^C/r/C~E~^G/r/G~E~+^A/r/
+A~C~^-G/r/E~GRG~F#RD~FRF~ERG~ERC#~DRF~DRB~C^r:|vV-!40!+|:RRRr/rErErDr
+DrCrCrB*Cr:|vV-!40!|:/rCERECRFCRECrDrBrCrA-rFrGR+C-*C+:||:|:/rE-*G/r+
+D-*G/r+C-*G/r+B-*G+:|-/r/C~E~^G/r/+C~E~^G/r/F~+A~-^C/r/E~G~^C/DrBrCr-
+ErFrGr+Cr-Cr+*:|

I'm sure you can work up the obfu magic.

Even better, add some "computer generated music" functionality, to get something harmonious and interesting, yet different every time.

[eff_i_g]

liverpole: Neat! What instruments do you play (besides Perl)?

[liverpole]

An interesting question.  Mostly piano, though only 2 years of lessons, so I'm not especially good.  I wanted to play the piano ever since my mother played the 1st movement of Moonlight Sonata for me (she couldn't read music at all when she was younger, but had laboriously counted out each note, and gradually committed the entire piece to memory!)

My first instrument was trumpet, and I've taught myself to play flute a little (and to a lesser degree clarinet and sax).

One of the best classes I ever had was in music theory, in junior high school, from a woman who really had a skill for teaching it.  Being able read and understand the relationships between musical notes, as well as distinguishing musical notes as they're played, is a very useful thing to know!

When I get some time, I'll post some more "strings" for the above obfuscation.  The default tune is variation #7 of the twelve variations on the theme of "Ah, vous dirai-je, Maman" by Mozart, more commonly known nowadays as "Twinkle, Twinkle Little Star".