From 79a7f90ad0d1c0bd19f6c4d9f6dd181559e753c0 Mon Sep 17 00:00:00 2001 From: Petr Baudis Date: Wed, 28 Sep 2011 23:47:41 +0200 Subject: [PATCH] Gaming version of fb, with slightly different calibration as well --- fb-game.pl | 487 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 487 insertions(+) create mode 100755 fb-game.pl diff --git a/fb-game.pl b/fb-game.pl new file mode 100755 index 0000000..b66e858 --- /dev/null +++ b/fb-game.pl @@ -0,0 +1,487 @@ +#!/usr/bin/perl +# +# Fluffy Ball Signal Analyzer (c) 2011 Petr Baudis +# MIT licence +# +# http://brmlab.cz/project/fluffyball +# +# Example: fb.pl -r sound hw:1,0 +# ...will show rectangle labels instead of frequency, and take input +# from the second soundcard instead of the first. + +use warnings; +use strict; + +use Math::FFT; +use List::Util qw(min max sum); +use List::MoreUtils qw(pairwise); +use Tk; +use Tk::widgets qw/JPEG PNG/; + + +our ($render, $label_recti, $delay, $debug); +$render = 1; +if ($ARGV[0] eq '-n') { + shift @ARGV; + $render = 0; +} +if ($ARGV[0] eq '-r') { + shift @ARGV; + $label_recti = 1; +} +if ($ARGV[0] eq '-s') { + shift @ARGV; + $delay = shift @ARGV; +} +if ($ARGV[0] eq '-d') { + shift @ARGV; + $debug = 1; +} + +my $mode = shift @ARGV; +my ($devname, $playfile); +if (not $mode or $mode eq 'sound') { + ($devname) = @ARGV; + $devname ||= 'default'; +} elsif ($mode eq 'replay') { + ($playfile) = @ARGV; + $playfile or die "no file specified"; +} else { + print STDERR "Usage: $0 [-n] [-r] [-s USEC] [-d] [sound [DEVNAME]] | replay FILENAME\n"; + exit 1; +} + + +our ($time); + +our ($mw, $canvas, $text, $content); +our ($dsp); +our ($sampleno, $sampling); + +our ($chan, $fmt, $rate, $sps) = (1, 16, 16384, 8); +our $bps = ($chan * $fmt * $rate) / 8; +our $buf = $bps / $sps; + +our @avgsteps = (2, 4); + +# How much to amplify the spectrum +our $amplifier = 1; + +# Rectangles cover averages in various bands. They also include averages +# of surrounding of the rectangle picture. E.g. with step 20, over 10, +# the average includes average of 20 of the covered area + 10 on each side. +our $rect_step = 10; +our $rect_over = 5; + +our $draw_lines = 0; # this makes for real pretty graphs but it is a huge slowdown +our $draw_rect = 1; + + +our $state = 'ticho'; + +sub assess { + my ($finfo) = @_; + + # Jingle inside of our ball. If we did not have it, + # alternative detection methods could be possible too. + my ($jingle) = $finfo->{rect_2}->[29]; + + # Look at mid-frequency average level over longer time + # and check that it is universal in that range. + my @midrange = 25..50; + my ($fidgetl, $fidgetm); + $fidgetl = sum (@{$finfo->{rect_2}}[@midrange]) / @midrange; + $fidgetm = min (@{$finfo->{rect_2}}[@midrange]); + + # Look at dynamics of the sound; too much change means + # this is more likely buch fallout. + my ($dynamics); + my (@mid_rect_now) = @{$finfo->{rect_now}}[@midrange]; + my (@mid_rect_2) = @{$finfo->{rect_4}}[@midrange]; + $dynamics = sqrt(sum (pairwise { ($a - $b) * ($a - $b) } @mid_rect_now, @mid_rect_2)) / @midrange; + + if ($debug) { + print "(jingle $jingle) (fidget $fidgetl $fidgetm) (dynamics $dynamics)\n"; + #print join(' ', @{$finfo->{rect_4}}[29, 46, 47, 48])."\n"; + } + + my $newstate = $state; + if ($state ne 'buch' and $jingle > 0.3) { + $newstate = 'buch'; + + # buch -> hlazeni not allowed + } elsif ($state eq 'ticho' and ($fidgetl > 0.05 and $fidgetm > 0.03 and $dynamics < 0.005)) { + $newstate = 'hlazeni'; + + } elsif ($state eq 'hlazeni' and ($fidgetl < 0.04 or $fidgetm < 0.03 or $dynamics > 0.02)) { + $newstate = 'ticho'; + + } elsif ($state eq 'buch' and $jingle < 0.2) { + $newstate = 'ticho'; + } + + $newstate ne $state and print "$newstate\n"; + $state = $newstate; + + if ($render) { + $text->delete('all'); + if ($newstate ne 'ticho') { + $text->createText(0, 20, -anchor => 'nw', -font => 'Small', -text => "[$newstate]", -fill => 'blue'); + } + } +} + +sub render_spectrum { + my ($finfo, $label, $reflabel, $fir, $srows, $xofs, $yofs, $w, $h, $hs) = @_; + my @fi = @$fir; + my @f = @{$finfo->{"freq_$label"}}; + my @fref; defined $reflabel and @fref = @{$finfo->{"freq_$reflabel"}}; + my @r = @{$finfo->{"rect_$label"}}; + my @rref; defined $reflabel and @rref = @{$finfo->{"rect_$reflabel"}}; + for my $y (0..($srows-1)) { + for my $x (0..($w-1)) { + my $hb = $yofs + $h * ($y + 1) + $hs * $y; + my $i = $w * $y + $x; + + if ($draw_lines) { + my $barh = $h * ($draw_rect ? 2/3 : 1); + my $bar = $h * $f[$i] * $amplifier; + $bar = min ($barh, $bar); + $canvas->createLine($xofs + $x, $hb, $xofs + $x, $hb - $bar); + if (defined $reflabel) { + my $refbar = $h * $fref[$i] * $amplifier; + $refbar = min ($barh, $refbar); + if ($refbar > $bar) { + $canvas->createLine($xofs + $x, $hb - $bar, $xofs + $x, $hb - $refbar, -fill => 'darkred'); + } else { + $canvas->createLine($xofs + $x, $hb - $refbar, $xofs + $x, $hb - $bar, -fill => 'red'); + } + } + } + + if ($draw_rect and !($i % $rect_step) and $i >= $rect_over and $i <= @f - $rect_step - $rect_over) { + my $recth = $h * ($draw_lines ? 2/3 : 1); + my $avg = $recth * $amplifier * $r[$i / $rect_step]; + $avg = min ($h, $avg); + my $rhb = $hb - $h; + $canvas->createRectangle($xofs + $x, $rhb, $xofs + $x + $rect_step, $rhb + $avg, -fill => 'black'); + if (defined $reflabel) { + my $refavg = $recth * $amplifier * $rref[$i / $rect_step]; + $refavg = min ($h, $refavg); + if ($refavg > $avg) { + $canvas->createRectangle($xofs + $x, $rhb + $avg, $xofs + $x + $rect_step, $rhb + $refavg, -fill => 'darkred', -outline => 'darkred'); + } else { + $canvas->createRectangle($xofs + $x, $rhb + $refavg, $xofs + $x + $rect_step, $rhb + $avg, -fill => 'red', -outline => 'red'); + } + } + } + + if (!($x % ($w/4))) { + $canvas->createLine($xofs + $x, $hb + 0, $xofs + $x, $hb + 5, -fill => 'blue'); + $canvas->createText($xofs + $x, $hb + 15, -fill => 'blue', -font => 'small', -text => $label_recti ? $i/$rect_step : $fi[$i]); + } + } + } + $canvas->createText($xofs, $yofs, -fill => 'darkgreen', -font => 'small', -text => $label); +} + +sub render { + my ($finfo) = @_; + my @fi = @{$finfo->{freqi}}; + + # main plot + my $srows = 32/$sps; # spectrum rows; "density" of data depends on sps + my $w = @fi / $srows; # width + my $ws = 20; # spacing + my $h = 150; # height + my $hs = 20; # spacing + + my $htot = $hs + ($h + $hs) * $srows; + + # averages plots + my $acols = 1; + my $arows = @avgsteps / $acols; # rows of plots; each plot is further divided to $srows rows of spectrum + my $aw = $w; + my $ahtot = ($htot - 3 * $hs) / $arows; + my $ah = $ahtot / $srows - $hs; + + unless ($canvas) { + $canvas = $mw->Canvas(-width => $ws + $w + $ws*3 + ($aw + $ws) * $acols + $ws, -height => $htot); + $canvas->pack; + } + $canvas->delete('all'); + + render_spectrum($finfo, 'now', $avgsteps[0], $finfo->{freqi}, $srows, $ws, $hs, $w, $h, $hs); + for my $i (0..$#avgsteps) { + my $ax = $i % $acols; + my $ay = sprintf('%d', $i / $acols); + my $su = $avgsteps[$i]; + render_spectrum($finfo, $su, $i < $#avgsteps ? $avgsteps[$i+1] : undef, $finfo->{freqi}, $srows, + $ws + $w + $ws*3 + ($ws + $aw) * $ax, + ($ahtot + $hs*2) * $ay + $hs, + $aw, $ah, $hs); + } + + render_user_content($time, $state); + + $mw->update(); +} + +sub getdata { + my $w; + read $dsp, $w, $buf or die "read: $!"; + return $w; +} + +# Array with frequencies corresponding to elements of fftsig +sub fftfreq { + my @freqs; + my $dft_size = $rate / $sps; + for (my $i = 0; $i < $dft_size / 2; $i++) { + $freqs[$i] = $i / $dft_size * $rate; + } + return @freqs; +} + +sub fftsig { + my ($bytes) = @_; + + my @samples; + if ($fmt == 8) { + while (length($bytes) > 0) { + my $sample = unpack('c', substr($bytes, 0, 1, '')); + push(@samples, $sample); + } + } elsif ($fmt == 16) { + while (length($bytes) > 0) { + my $sample = unpack('s<', substr($bytes, 0, 2, '')); + push(@samples, $sample); + } + } else { + die "unsupported $fmt bits per sample\n"; + } + + # Magic from Audio::Analyze: + my $fft = Math::FFT->new(\@samples); + my $coeff = $fft->rdft; + my $size = scalar(@$coeff); + my $k = 0; + my @mag; + + $mag[$k] = sqrt($coeff->[$k*2]**2); + for($k = 1; $k < $size / 2; $k++) { + $mag[$k] = sqrt(($coeff->[$k * 2] ** 2) + ($coeff->[$k * 2 + 1] ** 2)); + } + + # Rescale to 0..1 + my $avgmag = sum (@mag) / @mag; #[1000..$#mag]; + @mag = map { $_ / $avgmag * 0.3 } @mag; + return @mag; +} + +sub rectsof { + my ($finfo, $l) = @_; + my @f = @{$finfo->{"freq_$l"}}; + my @r; + for (my ($fi, $ri) = ($rect_step, 1); $fi <= $#f - $rect_step - $rect_over; $fi += $rect_step, $ri++) { + $r[$ri] = sum (@f[$fi - $rect_over .. $fi + $rect_step + $rect_over]) / ($rect_step + 2 * $rect_over); + } + $finfo->{"rect_$l"} = \@r; +} + +sub ticks { + my $finfo; + $time = 0; + + while (1) { + my $w = getdata(); + defined $sampling and $sampling .= $w; + $finfo->{freqi} = [fftfreq()]; + $finfo->{freq_now} = [fftsig($w)]; + + # Create averaged rects + rectsof($finfo, 'now'); + + # Update floating freq. averages + for my $su (@avgsteps) { + for my $i (0..$#{$finfo->{freqi}}) { + my $fn = $finfo->{freq_now}->[$i]; + my $fs = $finfo->{"freq_$su"}->[$i]; + $fs ||= $fn; + $finfo->{"freq_$su"}->[$i] = ($fs * ($su - 1) + $fn) / $su; + } + rectsof($finfo, $su); + } + + assess($finfo); + $render and render($finfo); + + if ($delay) { + use Time::HiRes qw(usleep); + usleep($delay); + } + + $render and $mw->idletasks(); + + $time++; + } +} + + +sub recStart { + if (defined $sampling) { + recCancel(); + return; + } + $sampleno++; + $sampling = ''; + $text->delete('all'); + $text->createText(0, 20, -anchor => 'nw', -font => 'Small', -text => "Recording $sampleno", -fill => 'red'); +} + +sub recCancel { + $sampleno--; + $sampling = undef; + $text->delete('all'); +} + +sub recSave { + open my $fh, '>'.sprintf('sample-%04d.raw', $sampleno) or die "$!"; + print $fh $sampling; + close $fh; + $sampling = undef; + $text->delete('all'); +} + + +if ($mode eq 'replay') { + open ($dsp, $playfile) or die "$playfile: $!"; +} else { + # '-c', $chan, + print join(' ', 'arecord', '-D', $devname, '-t', 'raw', '-r', $rate, '-f', 'S'.$fmt)."\n"; + open ($dsp, '-|', 'arecord', '-D', $devname, '-t', 'raw', '-r', $rate, '-f', 'S'.$fmt) or die "arecord: $!"; + use IO::Handle; + $dsp->autoflush(1); +} + +if ($render) { + $mw = MainWindow->new; + $mw->bind('' => \&recStart); + $mw->bind('' => \&recCancel); + $mw->bind('' => \&recSave); + $text = $mw->Canvas(-width => 400, -height => 40); + $text->pack; + $content = $mw->Canvas(-width => 400, -height => 400); + $content->pack(-side => 'left'); + + $mw->after(1, \&ticks); + MainLoop; +} else { + ticks(); +} + + + +### TADY ZAČÍNÁ TO ZAJÍMAVÉ! + +use vars qw(%dogs); + +sub render_user_content { + my ($time, $state) = @_; + # $time je (roustoucí) číslo frame + # $state je buď "ticho", "hlazeni" nebo "buch" + # $content je tvůj Tk canvas (plátno) - příklady Ti ukáží, jak s ním zacházet + + # Sdílená data - tváře psů v různých náladách: + $dogs{ticho} ||= $mw->Photo(-file => "img/pes4.png"), + $dogs{hlazeni} ||= $mw->Photo(-file => "img/pes5.png"), + $dogs{buch} ||= $mw->Photo(-file => "img/pes2.png"), + $dogs{meh} ||= $mw->Photo(-file => "img/pes6.png"), + # Prohlédněte si obrázky v podadresáři img/ - příkaz: geeqie img/ + + # Vyber si a odkomentuj některý příklad, nebo si napiš něco vlastního! + return example1($time, $state); + #return example2($time, $state); + + # Nápady: + # * 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ě? + # * 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. + + # Větší úkol: + # * Automatická kalibrace rozpoznávacích konstant (viz assess) podle celkové úrovně hluku. +} + +sub example1 { + my ($time, $state) = @_; + + # Pes mění výraz podle toho, co mu děláte. + + $content->delete('all'); + $content->createImage(200, 200, -image => $dogs{$state}); + + # Nápad: Dokážete měnit náladu psa plynuleji? + # (Ukazujte teploměr nálady! Kreslení obdélníčků viz výše kód pro spektrogram.) +} + +use vars qw($pos $dir); +BEGIN { + $pos = -50; + $dir = 1; +} + +sub example2 { + my ($time, $state) = @_; + + # Pes se hýbe, trefte ho, když projíždí terčem! + + # Naše proměnné zachovávající hodnotu mezi jednotlivými framy: + # $pos: Pozice psa. + # $dir: Směr pohybu psa. + + # Postrč psa. + if ($pos >= 100 or $pos <= -100) { + $dir = -$dir; + } + $pos += $dir; + + # Barva terče - sekundární feedback (ne)úspěchu. + my $color = 'darkred'; + + # Vyčisti pole po předchozím frame. + $content->delete('all'); + + # Nakresli psa... + + if ($state eq 'ticho') { + if ($pos < -20 || $pos > 20) { + $content->createImage(200+$pos, 200, -image => $dogs{ticho}); + } else { + $content->createImage(200+$pos, 200, -image => $dogs{ticho}); + $color = 'green'; + } + + } elsif ($state eq 'hlazeni') { + $content->createImage(200+$pos, 200, -image => $dogs{meh}); + $color = 'blue'; + + } else { # $state eq 'buch' + if ($pos < -20 || $pos > 20) { + $content->createImage(200+$pos, 200, -image => $dogs{meh}); + $color = 'blue'; + } else { + $content->createImage(200+$pos, 200, -image => $dogs{buch}); + $color = 'red'; + } + } + + # ...a terč. + $content->createLine(200, 180, 200, 220, -fill => $color); + $content->createLine(180, 200, 220, 200, -fill => $color); + + # Nápad: Dokážete psem jezdit sem a tam bez explicitní proměnné? + # Nápad: Tohle je programátorsky mizerný kus kódu, protože natvrdo používá + # různé nepojmenované číslené konstany. Zkuste kód pročistit. + + # Nápad: Udržujte skóre. Co třeba +50 za trefu, -1 za jeden frame + # se špatným vstupem. +} -- 2.11.4.GIT