fb.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
  20
  21 our ($render, $label_recti, $delay, $debug);
  22 $render = 1;
  23 if ($ARGV[0] eq '-n') {
  24         shift @ARGV;
  25         $render = 0;
  26 }
  27 if ($ARGV[0] eq '-r') {
  28         shift @ARGV;
  29         $label_recti = 1;
  30 }
  31 if ($ARGV[0] eq '-s') {
  32         shift @ARGV;
  33         $delay = shift @ARGV;
  34 }
  35 if ($ARGV[0] eq '-d') {
  36         shift @ARGV;
  37         $debug = 1;
  38 }
  39
  40 my $mode = shift @ARGV;
  41 my ($devname, $playfile);
  42 if (not $mode or $mode eq 'sound') {
  43         ($devname) = @ARGV;
  44         $devname ||= 'default';
  45 } elsif ($mode eq 'replay') {
  46         ($playfile) = @ARGV;
  47         $playfile or die "no file specified";
  48 } else {
  49         print STDERR "Usage: $0 [-n] [-r] [-s USEC] [-d] [sound [DEVNAME]] | replay FILENAME\n";
  50         exit 1;
  51 }
  52
  53
  54 our ($mw, $canvas, $text);
  55 our ($dsp);
  56 our ($sampleno, $sampling);
  57
  58 our ($chan, $fmt, $rate, $sps) = (1, 16, 16384, 8);
  59 our $bps = ($chan * $fmt * $rate) / 8;
  60 our $buf = $bps / $sps;
  61
  62 our @avgsteps = (2, 4);
  63
  64 # How much to amplify the spectrum
  65 our $amplifier = 1;
  66
  67 # Rectangles cover averages in various bands. They also include averages
  68 # of surrounding of the rectangle picture. E.g. with step 20, over 10,
  69 # the average includes average of 20 of the covered area + 10 on each side.
  70 our $rect_step = 10;
  71 our $rect_over = 5;
  72
  73 our $draw_lines = 0; # this makes for real pretty graphs but it is a huge slowdown
  74 our $draw_rect = 1;
  75
  76
  77 our $state = 'ticho';
  78
  79 sub assess {
  80         my ($finfo) = @_;
  81
  82         # Jingle inside of our ball. If we did not have it,
  83         # alternative detection methods could be possible too.
  84         my ($jingle) = $finfo->{rect_2}->[29];
  85
  86         # Look at mid-frequency average level over longer time
  87         # and check that it is universal in that range.
  88         my @midrange = 25..50;
  89         my ($fidgetl, $fidgetm);
  90         $fidgetl = sum (@{$finfo->{rect_2}}[@midrange]) / @midrange;
  91         $fidgetm = min (@{$finfo->{rect_2}}[@midrange]);
  92
  93         # Look at dynamics of the sound; too much change means
  94         # this is more likely buch fallout.
  95         my ($dynamics);
  96         my (@mid_rect_now) = @{$finfo->{rect_now}}[@midrange];
  97         my (@mid_rect_2) = @{$finfo->{rect_4}}[@midrange];
  98         $dynamics = sqrt(sum (pairwise { ($a - $b) * ($a - $b) } @mid_rect_now, @mid_rect_2)) / @midrange;
  99
 100         if ($debug) {
 101                 print "(jingle $jingle) (fidget $fidgetl $fidgetm) (dynamics $dynamics)\n";
 102                 #print join(' ', @{$finfo->{rect_4}}[29, 46, 47, 48])."\n";
 103         }
 104
 105         my $newstate = $state;
 106         if ($state ne 'buch' and $jingle > 0.15) {
 107                 $newstate = 'buch';
 108
 109         # buch -> hlazeni not allowed
 110         } elsif ($state eq 'ticho' and ($fidgetl > 0.03 and $fidgetm > 0.02 and $dynamics < 0.005)) {
 111                 $newstate = 'hlazeni';
 112
 113         } elsif ($state eq 'hlazeni' and ($fidgetl < 0.02 or $fidgetm < 0.015 or $dynamics > 0.02)) {
 114                 $newstate = 'ticho';
 115
 116         } elsif ($state eq 'buch' and $jingle < 0.05) {
 117                 $newstate = 'ticho';
 118         }
 119
 120         $newstate ne $state and print "$newstate\n";
 121         $state = $newstate;
 122
 123         if ($render) {
 124                 $text->delete('all');
 125                 if ($newstate ne 'ticho') {
 126                         $text->createText(0, 20, -anchor => 'nw', -font => 'Small', -text => "[$newstate]", -fill => 'blue');
 127                 }
 128         }
 129 }
 130
 131 sub render_spectrum {
 132         my ($finfo, $label, $reflabel, $fir, $srows, $xofs, $yofs, $w, $h, $hs) = @_;
 133         my @fi = @$fir;
 134         my @f = @{$finfo->{"freq_$label"}};
 135         my @fref; defined $reflabel and @fref = @{$finfo->{"freq_$reflabel"}};
 136         my @r = @{$finfo->{"rect_$label"}};
 137         my @rref; defined $reflabel and @rref = @{$finfo->{"rect_$reflabel"}};
 138         for my $y (0..($srows-1)) {
 139                 for my $x (0..($w-1)) {
 140                         my $hb = $yofs + $h * ($y + 1) + $hs * $y;
 141                         my $i = $w * $y + $x;
 142
 143                         if ($draw_lines) {
 144                                 my $barh = $h * ($draw_rect ? 2/3 : 1);
 145                                 my $bar = $h * $f[$i] * $amplifier;
 146                                 $bar = min ($barh, $bar);
 147                                 $canvas->createLine($xofs + $x, $hb, $xofs + $x, $hb - $bar);
 148                                 if (defined $reflabel) {
 149                                         my $refbar = $h * $fref[$i] * $amplifier;
 150                                         $refbar = min ($barh, $refbar);
 151                                         if ($refbar > $bar) {
 152                                                 $canvas->createLine($xofs + $x, $hb - $bar, $xofs + $x, $hb - $refbar, -fill => 'darkred');
 153                                         } else {
 154                                                 $canvas->createLine($xofs + $x, $hb - $refbar, $xofs + $x, $hb - $bar, -fill => 'red');
 155                                         }
 156                                 }
 157                         }
 158
 159                         if ($draw_rect and !($i % $rect_step) and $i >= $rect_over and $i <= @f - $rect_step - $rect_over) {
 160                                 my $recth = $h * ($draw_lines ? 2/3 : 1);
 161                                 my $avg = $recth * $amplifier * $r[$i / $rect_step];
 162                                 $avg = min ($h, $avg);
 163                                 my $rhb = $hb - $h;
 164                                 $canvas->createRectangle($xofs + $x, $rhb, $xofs + $x + $rect_step, $rhb + $avg, -fill => 'black');
 165                                 if (defined $reflabel) {
 166                                         my $refavg = $recth * $amplifier * $rref[$i / $rect_step];
 167                                         $refavg = min ($h, $refavg);
 168                                         if ($refavg > $avg) {
 169                                                 $canvas->createRectangle($xofs + $x, $rhb + $avg, $xofs + $x + $rect_step, $rhb + $refavg, -fill => 'darkred', -outline => 'darkred');
 170                                         } else {
 171                                                 $canvas->createRectangle($xofs + $x, $rhb + $refavg, $xofs + $x + $rect_step, $rhb + $avg, -fill => 'red', -outline => 'red');
 172                                         }
 173                                 }
 174                         }
 175
 176                         if (!($x % ($w/4))) {
 177                                 $canvas->createLine($xofs + $x, $hb + 0, $xofs + $x, $hb + 5, -fill => 'blue');
 178                                 $canvas->createText($xofs + $x, $hb + 15, -fill => 'blue', -font => 'small', -text => $label_recti ? $i/$rect_step : $fi[$i]);
 179                         }
 180                 }
 181         }
 182         $canvas->createText($xofs, $yofs, -fill => 'darkgreen', -font => 'small', -text => $label);
 183 }
 184
 185 sub render {
 186         my ($finfo) = @_;
 187         my @fi = @{$finfo->{freqi}};
 188
 189         # main plot
 190         my $srows = 32/$sps; # spectrum rows; "density" of data depends on sps
 191         my $w = @fi / $srows; # width
 192         my $ws = 20; # spacing
 193         my $h = 150; # height
 194         my $hs = 20; # spacing
 195
 196         my $htot = $hs + ($h + $hs) * $srows;
 197
 198         # averages plots
 199         my $acols = 1;
 200         my $arows = @avgsteps / $acols; # rows of plots; each plot is further divided to $srows rows of spectrum
 201         my $aw = $w;
 202         my $ahtot = ($htot - 3 * $hs) / $arows;
 203         my $ah = $ahtot / $srows - $hs;
 204
 205         unless ($canvas) {
 206                 $canvas = $mw->Canvas(-width => $ws + $w + $ws*3 + ($aw + $ws) * $acols + $ws, -height => $htot);
 207                 $canvas->pack;
 208         }
 209         $canvas->delete('all');
 210
 211         render_spectrum($finfo, 'now', $avgsteps[0], $finfo->{freqi}, $srows, $ws, $hs, $w, $h, $hs);
 212         for my $i (0..$#avgsteps) {
 213                 my $ax = $i % $acols;
 214                 my $ay = sprintf('%d', $i / $acols);
 215                 my $su = $avgsteps[$i];
 216                 render_spectrum($finfo, $su, $i < $#avgsteps ? $avgsteps[$i+1] : undef, $finfo->{freqi}, $srows,
 217                                 $ws + $w + $ws*3 + ($ws + $aw) * $ax,
 218                                 ($ahtot + $hs*2) * $ay + $hs,
 219                                 $aw, $ah, $hs);
 220         }
 221
 222         $mw->update();
 223 }
 224
 225 sub getdata {
 226         my $w;
 227         read $dsp, $w, $buf or die "read: $!";
 228         return $w;
 229 }
 230
 231 # Array with frequencies corresponding to elements of fftsig
 232 sub fftfreq {
 233         my @freqs;
 234         my $dft_size = $rate / $sps;
 235         for (my $i = 0; $i < $dft_size / 2; $i++) {
 236                 $freqs[$i] = $i / $dft_size * $rate;
 237         }
 238         return @freqs;
 239 }
 240
 241 sub fftsig {
 242         my ($bytes) = @_;
 243
 244         my @samples;
 245         if ($fmt == 8) {
 246                 while (length($bytes) > 0) {
 247                         my $sample = unpack('c', substr($bytes, 0, 1, ''));
 248                         push(@samples, $sample);
 249                 }
 250         } elsif ($fmt == 16) {
 251                 while (length($bytes) > 0) {
 252                         my $sample = unpack('s<', substr($bytes, 0, 2, ''));
 253                         push(@samples, $sample);
 254                 }
 255         } else {
 256                 die "unsupported $fmt bits per sample\n";
 257         }
 258
 259         # Magic from Audio::Analyze:
 260         my $fft = Math::FFT->new(\@samples);
 261         my $coeff = $fft->rdft;
 262         my $size = scalar(@$coeff);
 263         my $k = 0;
 264         my @mag;
 265
 266         $mag[$k] = sqrt($coeff->[$k*2]**2);
 267         for($k = 1; $k < $size / 2; $k++) {
 268                 $mag[$k] = sqrt(($coeff->[$k * 2] ** 2) + ($coeff->[$k * 2 + 1] ** 2));
 269         }
 270
 271         # Rescale to 0..1
 272         my $avgmag = sum (@mag) / @mag; #[1000..$#mag];
 273         @mag = map { $_ / $avgmag * 0.3 } @mag;
 274         return @mag;
 275 }
 276
 277 sub rectsof {
 278         my ($finfo, $l) = @_;
 279         my @f = @{$finfo->{"freq_$l"}};
 280         my @r;
 281         for (my ($fi, $ri) = ($rect_step, 1); $fi <= $#f - $rect_step - $rect_over; $fi += $rect_step, $ri++) {
 282                 $r[$ri] = sum (@f[$fi - $rect_over .. $fi + $rect_step + $rect_over]) / ($rect_step + 2 * $rect_over);
 283         }
 284         $finfo->{"rect_$l"} = \@r;
 285 }
 286
 287 sub ticks {
 288         my $s = 0;
 289         my $finfo;
 290
 291         while (1) {
 292                 my $w = getdata();
 293                 defined $sampling and $sampling .= $w;
 294                 $finfo->{freqi} = [fftfreq()];
 295                 $finfo->{freq_now} = [fftsig($w)];
 296
 297                 # Create averaged rects
 298                 rectsof($finfo, 'now');
 299
 300                 # Update floating freq. averages
 301                 for my $su (@avgsteps) {
 302                         for my $i (0..$#{$finfo->{freqi}}) {
 303                                 my $fn = $finfo->{freq_now}->[$i];
 304                                 my $fs = $finfo->{"freq_$su"}->[$i];
 305                                 $fs ||= $fn;
 306                                 $finfo->{"freq_$su"}->[$i] = ($fs * ($su - 1) + $fn) / $su;
 307                         }
 308                         rectsof($finfo, $su);
 309                 }
 310
 311                 assess($finfo);
 312                 $render and render($finfo);
 313
 314                 if ($delay) {
 315                         use Time::HiRes qw(usleep);
 316                         usleep($delay);
 317                 }
 318
 319                 $render and $mw->idletasks();
 320
 321                 $s++;
 322         }
 323 }
 324
 325
 326 sub recStart {
 327         if (defined $sampling) {
 328                 recCancel();
 329                 return;
 330         }
 331         $sampleno++;
 332         $sampling = '';
 333         $text->delete('all');
 334         $text->createText(0, 20, -anchor => 'nw', -font => 'Small', -text => "Recording $sampleno", -fill => 'red');
 335 }
 336
 337 sub recCancel {
 338         $sampleno--;
 339         $sampling = undef;
 340         $text->delete('all');
 341 }
 342
 343 sub recSave {
 344         open my $fh, '>'.sprintf('sample-%04d.raw', $sampleno) or die "$!";
 345         print $fh $sampling;
 346         close $fh;
 347         $sampling = undef;
 348         $text->delete('all');
 349 }
 350
 351
 352 if ($mode eq 'replay') {
 353         open ($dsp, $playfile) or die "$playfile: $!";
 354 } else {
 355         # '-c', $chan,
 356         print join(' ', 'arecord', '-D', $devname, '-t', 'raw', '-r', $rate, '-f', 'S'.$fmt)."\n";
 357         open ($dsp, '-|', 'arecord', '-D', $devname, '-t', 'raw', '-r', $rate, '-f', 'S'.$fmt) or die "arecord: $!";
 358         use IO::Handle;
 359         $dsp->autoflush(1);
 360 }
 361
 362 if ($render) {
 363         $mw = MainWindow->new;
 364         $mw->bind('<space>' => \&recStart);
 365         $mw->bind('<Escape>' => \&recCancel);
 366         $mw->bind('<Return>' => \&recSave);
 367         $text = $mw->Canvas(-width => 400, -height => 40);
 368         $text->pack;
 369
 370         $mw->after(1, \&ticks);
 371         MainLoop;
 372 } else {
 373         ticks();
 374 }