fb-game.pl

   1 #!/usr/bin/perl
   2 #
   3 # Fluffy Ball Signal Analyzer (c) 2011 Petr Baudis <pasky@ucw.cz>
   4 # MIT licence
   5 #
   6 # http://brmlab.cz/project/fluffyball
   7 #
   8 # Example: fb.pl -r sound hw:1,0
   9 # ...will show rectangle labels instead of frequency, and take input
  10 # from the second soundcard instead of the first.
  11
  12 use warnings;
  13 use strict;
  14
  15 use Math::FFT;
  16 use List::Util qw(min max sum);
  17 use List::MoreUtils qw(pairwise);
  18 use Tk;
  19 use Tk::widgets qw/JPEG PNG/;
  20
  21
  22 our ($render, $label_recti, $delay, $debug);
  23 $render = 1;
  24 if ($ARGV[0] eq '-n') {
  25         shift @ARGV;
  26         $render = 0;
  27 }
  28 if ($ARGV[0] eq '-r') {
  29         shift @ARGV;
  30         $label_recti = 1;
  31 }
  32 if ($ARGV[0] eq '-s') {
  33         shift @ARGV;
  34         $delay = shift @ARGV;
  35 }
  36 if ($ARGV[0] eq '-d') {
  37         shift @ARGV;
  38         $debug = 1;
  39 }
  40
  41 my $mode = shift @ARGV;
  42 my ($devname, $playfile);
  43 if (not $mode or $mode eq 'sound') {
  44         ($devname) = @ARGV;
  45         $devname ||= 'default';
  46 } elsif ($mode eq 'replay') {
  47         ($playfile) = @ARGV;
  48         $playfile or die "no file specified";
  49 } else {
  50         print STDERR "Usage: $0 [-n] [-r] [-s USEC] [-d] [sound [DEVNAME]] | replay FILENAME\n";
  51         exit 1;
  52 }
  53
  54
  55 our ($time);
  56
  57 our ($mw, $canvas, $text, $content);
  58 our ($dsp);
  59 our ($sampleno, $sampling);
  60
  61 our ($chan, $fmt, $rate, $sps) = (1, 16, 16384, 8);
  62 our $bps = ($chan * $fmt * $rate) / 8;
  63 our $buf = $bps / $sps;
  64
  65 our @avgsteps = (2, 4);
  66
  67 # How much to amplify the spectrum
  68 our $amplifier = 1;
  69
  70 # Rectangles cover averages in various bands. They also include averages
  71 # of surrounding of the rectangle picture. E.g. with step 20, over 10,
  72 # the average includes average of 20 of the covered area + 10 on each side.
  73 our $rect_step = 10;
  74 our $rect_over = 5;
  75
  76 our $draw_lines = 0; # this makes for real pretty graphs but it is a huge slowdown
  77 our $draw_rect = 1;
  78
  79
  80 our $state = 'ticho';
  81
  82 sub assess {
  83         my ($finfo) = @_;
  84
  85         # Jingle inside of our ball. If we did not have it,
  86         # alternative detection methods could be possible too.
  87         my ($jingle) = $finfo->{rect_2}->[29];
  88
  89         # Look at mid-frequency average level over longer time
  90         # and check that it is universal in that range.
  91         my @midrange = 25..50;
  92         my ($fidgetl, $fidgetm);
  93         $fidgetl = sum (@{$finfo->{rect_2}}[@midrange]) / @midrange;
  94         $fidgetm = min (@{$finfo->{rect_2}}[@midrange]);
  95
  96         # Look at dynamics of the sound; too much change means
  97         # this is more likely buch fallout.
  98         my ($dynamics);
  99         my (@mid_rect_now) = @{$finfo->{rect_now}}[@midrange];
 100         my (@mid_rect_2) = @{$finfo->{rect_4}}[@midrange];
 101         $dynamics = sqrt(sum (pairwise { ($a - $b) * ($a - $b) } @mid_rect_now, @mid_rect_2)) / @midrange;
 102
 103         if ($debug) {
 104                 print "(jingle $jingle) (fidget $fidgetl $fidgetm) (dynamics $dynamics)\n";
 105                 #print join(' ', @{$finfo->{rect_4}}[29, 46, 47, 48])."\n";
 106         }
 107
 108         my $newstate = $state;
 109         if ($state ne 'buch' and $jingle > 0.3) {
 110                 $newstate = 'buch';
 111
 112         # buch -> hlazeni not allowed
 113         } elsif ($state eq 'ticho' and ($fidgetl > 0.05 and $fidgetm > 0.03 and $dynamics < 0.005)) {
 114                 $newstate = 'hlazeni';
 115
 116         } elsif ($state eq 'hlazeni' and ($fidgetl < 0.04 or $fidgetm < 0.03 or $dynamics > 0.02)) {
 117                 $newstate = 'ticho';
 118
 119         } elsif ($state eq 'buch' and $jingle < 0.2) {
 120                 $newstate = 'ticho';
 121         }
 122
 123         $newstate ne $state and print "$newstate\n";
 124         $state = $newstate;
 125
 126         if ($render) {
 127                 $text->delete('all');
 128                 if ($newstate ne 'ticho') {
 129                         $text->createText(0, 20, -anchor => 'nw', -font => 'Small', -text => "[$newstate]", -fill => 'blue');
 130                 }
 131         }
 132 }
 133
 134 sub render_spectrum {
 135         my ($finfo, $label, $reflabel, $fir, $srows, $xofs, $yofs, $w, $h, $hs) = @_;
 136         my @fi = @$fir;
 137         my @f = @{$finfo->{"freq_$label"}};
 138         my @fref; defined $reflabel and @fref = @{$finfo->{"freq_$reflabel"}};
 139         my @r = @{$finfo->{"rect_$label"}};
 140         my @rref; defined $reflabel and @rref = @{$finfo->{"rect_$reflabel"}};
 141         for my $y (0..($srows-1)) {
 142                 for my $x (0..($w-1)) {
 143                         my $hb = $yofs + $h * ($y + 1) + $hs * $y;
 144                         my $i = $w * $y + $x;
 145
 146                         if ($draw_lines) {
 147                                 my $barh = $h * ($draw_rect ? 2/3 : 1);
 148                                 my $bar = $h * $f[$i] * $amplifier;
 149                                 $bar = min ($barh, $bar);
 150                                 $canvas->createLine($xofs + $x, $hb, $xofs + $x, $hb - $bar);
 151                                 if (defined $reflabel) {
 152                                         my $refbar = $h * $fref[$i] * $amplifier;
 153                                         $refbar = min ($barh, $refbar);
 154                                         if ($refbar > $bar) {
 155                                                 $canvas->createLine($xofs + $x, $hb - $bar, $xofs + $x, $hb - $refbar, -fill => 'darkred');
 156                                         } else {
 157                                                 $canvas->createLine($xofs + $x, $hb - $refbar, $xofs + $x, $hb - $bar, -fill => 'red');
 158                                         }
 159                                 }
 160                         }
 161
 162                         if ($draw_rect and !($i % $rect_step) and $i >= $rect_over and $i <= @f - $rect_step - $rect_over) {
 163                                 my $recth = $h * ($draw_lines ? 2/3 : 1);
 164                                 my $avg = $recth * $amplifier * $r[$i / $rect_step];
 165                                 $avg = min ($h, $avg);
 166                                 my $rhb = $hb - $h;
 167                                 $canvas->createRectangle($xofs + $x, $rhb, $xofs + $x + $rect_step, $rhb + $avg, -fill => 'black');
 168                                 if (defined $reflabel) {
 169                                         my $refavg = $recth * $amplifier * $rref[$i / $rect_step];
 170                                         $refavg = min ($h, $refavg);
 171                                         if ($refavg > $avg) {
 172                                                 $canvas->createRectangle($xofs + $x, $rhb + $avg, $xofs + $x + $rect_step, $rhb + $refavg, -fill => 'darkred', -outline => 'darkred');
 173                                         } else {
 174                                                 $canvas->createRectangle($xofs + $x, $rhb + $refavg, $xofs + $x + $rect_step, $rhb + $avg, -fill => 'red', -outline => 'red');
 175                                         }
 176                                 }
 177                         }
 178
 179                         if (!($x % ($w/4))) {
 180                                 $canvas->createLine($xofs + $x, $hb + 0, $xofs + $x, $hb + 5, -fill => 'blue');
 181                                 $canvas->createText($xofs + $x, $hb + 15, -fill => 'blue', -font => 'small', -text => $label_recti ? $i/$rect_step : $fi[$i]);
 182                         }
 183                 }
 184         }
 185         $canvas->createText($xofs, $yofs, -fill => 'darkgreen', -font => 'small', -text => $label);
 186 }
 187
 188 sub render {
 189         my ($finfo) = @_;
 190         my @fi = @{$finfo->{freqi}};
 191
 192         # main plot
 193         my $srows = 32/$sps; # spectrum rows; "density" of data depends on sps
 194         my $w = @fi / $srows; # width
 195         my $ws = 20; # spacing
 196         my $h = 150; # height
 197         my $hs = 20; # spacing
 198
 199         my $htot = $hs + ($h + $hs) * $srows;
 200
 201         # averages plots
 202         my $acols = 1;
 203         my $arows = @avgsteps / $acols; # rows of plots; each plot is further divided to $srows rows of spectrum
 204         my $aw = $w;
 205         my $ahtot = ($htot - 3 * $hs) / $arows;
 206         my $ah = $ahtot / $srows - $hs;
 207
 208         unless ($canvas) {
 209                 $canvas = $mw->Canvas(-width => $ws + $w + $ws*3 + ($aw + $ws) * $acols + $ws, -height => $htot);
 210                 $canvas->pack;
 211         }
 212         $canvas->delete('all');
 213
 214         render_spectrum($finfo, 'now', $avgsteps[0], $finfo->{freqi}, $srows, $ws, $hs, $w, $h, $hs);
 215         for my $i (0..$#avgsteps) {
 216                 my $ax = $i % $acols;
 217                 my $ay = sprintf('%d', $i / $acols);
 218                 my $su = $avgsteps[$i];
 219                 render_spectrum($finfo, $su, $i < $#avgsteps ? $avgsteps[$i+1] : undef, $finfo->{freqi}, $srows,
 220                                 $ws + $w + $ws*3 + ($ws + $aw) * $ax,
 221                                 ($ahtot + $hs*2) * $ay + $hs,
 222                                 $aw, $ah, $hs);
 223         }
 224
 225         render_user_content($time, $state);
 226
 227         $mw->update();
 228 }
 229
 230 sub getdata {
 231         my $w;
 232         read $dsp, $w, $buf or die "read: $!";
 233         return $w;
 234 }
 235
 236 # Array with frequencies corresponding to elements of fftsig
 237 sub fftfreq {
 238         my @freqs;
 239         my $dft_size = $rate / $sps;
 240         for (my $i = 0; $i < $dft_size / 2; $i++) {
 241                 $freqs[$i] = $i / $dft_size * $rate;
 242         }
 243         return @freqs;
 244 }
 245
 246 sub fftsig {
 247         my ($bytes) = @_;
 248
 249         my @samples;
 250         if ($fmt == 8) {
 251                 while (length($bytes) > 0) {
 252                         my $sample = unpack('c', substr($bytes, 0, 1, ''));
 253                         push(@samples, $sample);
 254                 }
 255         } elsif ($fmt == 16) {
 256                 while (length($bytes) > 0) {
 257                         my $sample = unpack('s<', substr($bytes, 0, 2, ''));
 258                         push(@samples, $sample);
 259                 }
 260         } else {
 261                 die "unsupported $fmt bits per sample\n";
 262         }
 263
 264         # Magic from Audio::Analyze:
 265         my $fft = Math::FFT->new(\@samples);
 266         my $coeff = $fft->rdft;
 267         my $size = scalar(@$coeff);
 268         my $k = 0;
 269         my @mag;
 270
 271         $mag[$k] = sqrt($coeff->[$k*2]**2);
 272         for($k = 1; $k < $size / 2; $k++) {
 273                 $mag[$k] = sqrt(($coeff->[$k * 2] ** 2) + ($coeff->[$k * 2 + 1] ** 2));
 274         }
 275
 276         # Rescale to 0..1
 277         my $avgmag = sum (@mag) / @mag; #[1000..$#mag];
 278         @mag = map { $_ / $avgmag * 0.3 } @mag;
 279         return @mag;
 280 }
 281
 282 sub rectsof {
 283         my ($finfo, $l) = @_;
 284         my @f = @{$finfo->{"freq_$l"}};
 285         my @r;
 286         for (my ($fi, $ri) = ($rect_step, 1); $fi <= $#f - $rect_step - $rect_over; $fi += $rect_step, $ri++) {
 287                 $r[$ri] = sum (@f[$fi - $rect_over .. $fi + $rect_step + $rect_over]) / ($rect_step + 2 * $rect_over);
 288         }
 289         $finfo->{"rect_$l"} = \@r;
 290 }
 291
 292 sub ticks {
 293         my $finfo;
 294         $time = 0;
 295
 296         while (1) {
 297                 my $w = getdata();
 298                 defined $sampling and $sampling .= $w;
 299                 $finfo->{freqi} = [fftfreq()];
 300                 $finfo->{freq_now} = [fftsig($w)];
 301
 302                 # Create averaged rects
 303                 rectsof($finfo, 'now');
 304
 305                 # Update floating freq. averages
 306                 for my $su (@avgsteps) {
 307                         for my $i (0..$#{$finfo->{freqi}}) {
 308                                 my $fn = $finfo->{freq_now}->[$i];
 309                                 my $fs = $finfo->{"freq_$su"}->[$i];
 310                                 $fs ||= $fn;
 311                                 $finfo->{"freq_$su"}->[$i] = ($fs * ($su - 1) + $fn) / $su;
 312                         }
 313                         rectsof($finfo, $su);
 314                 }
 315
 316                 assess($finfo);
 317                 $render and render($finfo);
 318
 319                 if ($delay) {
 320                         use Time::HiRes qw(usleep);
 321                         usleep($delay);
 322                 }
 323
 324                 $render and $mw->idletasks();
 325
 326                 $time++;
 327         }
 328 }
 329
 330
 331 sub recStart {
 332         if (defined $sampling) {
 333                 recCancel();
 334                 return;
 335         }
 336         $sampleno++;
 337         $sampling = '';
 338         $text->delete('all');
 339         $text->createText(0, 20, -anchor => 'nw', -font => 'Small', -text => "Recording $sampleno", -fill => 'red');
 340 }
 341
 342 sub recCancel {
 343         $sampleno--;
 344         $sampling = undef;
 345         $text->delete('all');
 346 }
 347
 348 sub recSave {
 349         open my $fh, '>'.sprintf('sample-%04d.raw', $sampleno) or die "$!";
 350         print $fh $sampling;
 351         close $fh;
 352         $sampling = undef;
 353         $text->delete('all');
 354 }
 355
 356
 357 if ($mode eq 'replay') {
 358         open ($dsp, $playfile) or die "$playfile: $!";
 359 } else {
 360         # '-c', $chan,
 361         print join(' ', 'arecord', '-D', $devname, '-t', 'raw', '-r', $rate, '-f', 'S'.$fmt)."\n";
 362         open ($dsp, '-|', 'arecord', '-D', $devname, '-t', 'raw', '-r', $rate, '-f', 'S'.$fmt) or die "arecord: $!";
 363         use IO::Handle;
 364         $dsp->autoflush(1);
 365 }
 366
 367 if ($render) {
 368         $mw = MainWindow->new;
 369         $mw->bind('<space>' => \&recStart);
 370         $mw->bind('<Escape>' => \&recCancel);
 371         $mw->bind('<Return>' => \&recSave);
 372         $text = $mw->Canvas(-width => 400, -height => 40);
 373         $text->pack;
 374         $content = $mw->Canvas(-width => 400, -height => 400);
 375         $content->pack(-side => 'left');
 376
 377         $mw->after(1, \&ticks);
 378         MainLoop;
 379 } else {
 380         ticks();
 381 }
 382
 383
 384
 385 ### TADY ZAČÍNÁ TO ZAJÍMAVÉ!
 386
 387 use vars qw(%dogs);
 388
 389 sub render_user_content {
 390         my ($time, $state) = @_;
 391         # $time je (roustoucí) číslo frame
 392         # $state je buď "ticho", "hlazeni" nebo "buch"
 393         # $content je tvůj Tk canvas (plátno) - příklady Ti ukáží, jak s ním zacházet
 394
 395         # Sdílená data - tváře psů v různých náladách:
 396         $dogs{ticho} ||= $mw->Photo(-file => "img/pes4.png"),
 397         $dogs{hlazeni} ||= $mw->Photo(-file => "img/pes5.png"),
 398         $dogs{buch} ||= $mw->Photo(-file => "img/pes2.png"),
 399         $dogs{meh} ||= $mw->Photo(-file => "img/pes6.png"),
 400         # Prohlédněte si obrázky v podadresáři img/ - příkaz: geeqie img/
 401
 402         # Vyber si a odkomentuj některý příklad, nebo si napiš něco vlastního!
 403         return example1($time, $state);
 404         #return example2($time, $state);
 405
 406         # Nápady:
 407         # * Pes jde po dráze; hlazením ho povzbuzujete a utíká dopředu, ale boucháním couvá. Dokážete ho zastavit na přesně daném místě?
 408         # * Whack-a-mole: Pes vyskakuje v náhodných pozicích, bouchnutím ho sejměte. Ale musíte hladit, aby chtěl vylézt.
 409
 410         # Větší úkol:
 411         # * Automatická kalibrace rozpoznávacích konstant (viz assess) podle celkové úrovně hluku.
 412 }
 413
 414 sub example1 {
 415         my ($time, $state) = @_;
 416
 417         # Pes mění výraz podle toho, co mu děláte.
 418
 419         $content->delete('all');
 420         $content->createImage(200, 200, -image => $dogs{$state});
 421
 422         # Nápad: Dokážete měnit náladu psa plynuleji?
 423         #       (Ukazujte teploměr nálady! Kreslení obdélníčků viz výše kód pro spektrogram.)
 424 }
 425
 426 use vars qw($pos $dir);
 427 BEGIN {
 428         $pos = -50;
 429         $dir = 1;
 430 }
 431
 432 sub example2 {
 433         my ($time, $state) = @_;
 434
 435         # Pes se hýbe, trefte ho, když projíždí terčem!
 436
 437         # Naše proměnné zachovávající hodnotu mezi jednotlivými framy:
 438         # $pos: Pozice psa.
 439         # $dir: Směr pohybu psa.
 440
 441         # Postrč psa.
 442         if ($pos >= 100 or $pos <= -100) {
 443                 $dir = -$dir;
 444         }
 445         $pos += $dir;
 446
 447         # Barva terče - sekundární feedback (ne)úspěchu.
 448         my $color = 'darkred';
 449
 450         # Vyčisti pole po předchozím frame.
 451         $content->delete('all');
 452
 453         # Nakresli psa...
 454
 455         if ($state eq 'ticho') {
 456                 if ($pos < -20 || $pos > 20) {
 457                         $content->createImage(200+$pos, 200, -image => $dogs{ticho});
 458                 } else {
 459                         $content->createImage(200+$pos, 200, -image => $dogs{ticho});
 460                         $color = 'green';
 461                 }
 462
 463         } elsif ($state eq 'hlazeni') {
 464                 $content->createImage(200+$pos, 200, -image => $dogs{meh});
 465                 $color = 'blue';
 466
 467         } else { # $state eq 'buch'
 468                 if ($pos < -20 || $pos > 20) {
 469                         $content->createImage(200+$pos, 200, -image => $dogs{meh});
 470                         $color = 'blue';
 471                 } else {
 472                         $content->createImage(200+$pos, 200, -image => $dogs{buch});
 473                         $color = 'red';
 474                 }
 475         }
 476
 477         # ...a terč.
 478         $content->createLine(200, 180, 200, 220, -fill => $color);
 479         $content->createLine(180, 200, 220, 200, -fill => $color);
 480
 481         # Nápad: Dokážete psem jezdit sem a tam bez explicitní proměnné?
 482         # Nápad: Tohle je programátorsky mizerný kus kódu, protože natvrdo používá
 483         #       různé nepojmenované číslené konstany. Zkuste kód pročistit.
 484
 485         # Nápad: Udržujte skóre. Co třeba +50 za trefu, -1 za jeden frame
 486         #       se špatným vstupem.
 487 }