Tk Morse Code Ear tutor

[zentara]

Hi, another Perl/Tk app. :-) Any comments or improvements welcome. The details are at the top of the script. Basically, this tutor forces you to use your ear to recognize letters, forcing the brain to make a direct auditory connection to the letter. It also demonstrates how to make PCM tones of any frequency and duration without the obsolete /dev/dsp.

#!/usr/bin/perl
use strict;
use warnings;
use threads;
use threads::shared;

# Ear training for Morse Code by KN4OND
# aka zentara on perlmonks.

# This program is totally free and released
# purely to help people learn Morse Code,
# and possibly PCM tone generation.

# IF YOUR WINDOW MANAGER HAS MOUSE FOCUS,
# BE SURE TO KEEP MOUSE OVER TK WINDOW
# TO MAINTAIN FOCUS, OR IT WILL NOT
# RESPOND TO KEYBOARD INPUT. DUH!

# Most available code trainers don't force
# you to use your ear to decipher letters. 
# They don't force you to hear it, and get
# it right, this app does.
# This one will play a morse code character
# and keep looping it until you enter the
# right character on the keyboard. 
# Hitting Escape will toggle showing you 
# the dits and dahs.
# The correct letter is displayed when
# you correctly enter it on the keyboard.
# SpaceBar plays next letter, or replays
# current letter until correct key is entered.

# The default quiz set is a .. z, but there
# is a button to pop a dialog and set it to any
# collection of tokens you need to practice on.

# There is a bind key hack where the numeric
# value of keys are returned, in order that
# punctuation symbols work. Its a hack, that
# includes using 
# binmode STDOUT, ':utf8';
# to avoid wide print error messages

# An interesting aspect of this script, is
# the way tones are generated and played with
# the PulseAudio system.
# Under the widely used PulseAudio, the
# /dev/dsp can only be used by running a script
# with the padsp utility. A real hack.

# I avoid using /dev/dsp in this script.
# To accomplish this, I open a pipe in the thread 
# to aplay, and pipe raw generated PCM tones
# to it. If you look at the code for the aplay
# pipe, it has a setting -R 10. I found this
# setting fixed audio buffer problems where
# letters were not completely played, and
# somehow were prefaced to the next pipe write.
# It has something to do with audio buffer
# latency.

# The upper rate limit is set to 1.5 because
# above that, the buffer seems to leave dits
# in there for the next letter. It is especially
# obvious at high rates with repititions of e or t.
# To observe the problem, select e as the quiz letter,
# and repeatedly hit the Space Bar to repeat it.
# If anyone has a clue on how to remedy this
# any advice would be welcome. At the default rate,
# there dosn't seem to be an issue. It only
# seems a problem on very short fast beeps.

# This script has been minimally tested on
# my very up-to-date Slackware-current Linux 
# system.  YMMV :-)
#############################################


# keep all unnecessary vars out of thread
# create thread before Tk is invoked
# declare, share then assign shared vars
my $morse_in:shared = '';
my $freq:shared = 440;
my $rate:shared = 1;
my $vol:shared = .5; # half volume used in thread
my $audio_pid:shared = '';
my $go_control:shared = 0;
my $die_control:shared = 0;
# see thread code for sample rate, default is 8000

#create thread before any tk code is called
my $thr = threads->create( \&worker );

# THREAD CREATED AT THIS POINT    

# helps get correct keycodes
binmode STDOUT, ':utf8';

my $help_toggle = 1; #turned on by default
my $correct_key = ''; #loop control for quiz
my $correct = 1; # loop control

# array to store tokens for testing
my @selected = ('a'..'z'); #default list is a to z 


my %m;

$m{a} = '.-';   $m{q} = '--.-';  $m{6} = '-....';
$m{b} = '-...'; $m{r} = '.-.';   $m{7} = '--...';
$m{c} = '-.-.'; $m{s} = '...';   $m{8} = '---..';
$m{d} = '-..';  $m{t} = '-';     $m{9} = '----.';
$m{e} = '.';    $m{u} = '..-';   $m{"'"} = '.----.';
$m{f} = '..-.'; $m{v} = '...-';  $m{'.'} = '.-.-.-';
$m{g} = '--.';  $m{w} = '.--';   $m{','} = '--..--';
$m{h} = '....'; $m{x} = '-..-';  $m{'?'} = '..--..';
$m{i} = '..';   $m{y} = '-.--';  $m{':'} = '---...';
$m{j} = '.---'; $m{z} = '--..';  $m{'"'} = '.-..-.';
$m{k} = '-.-';  $m{0} = '-----'; $m{'-'} = '-....-';
$m{l} = '.-..'; $m{1} = '.----'; $m{'('} = '-.--.';
$m{m} = '--';   $m{2} = '..---'; $m{')'} = '-.--.-';
$m{n} = '-.';   $m{3} = '...--'; $m{'='} = '-...-';
$m{o} = '---';  $m{4} = '....-'; $m{'+'} = '.-.-.';
$m{p} = '.--.'; $m{5} = '.....'; $m{'!'} = '-.-.--';
                                 $m{'@'} = '.--.-.';
                                 $m{';'} = '-.-.-';

#foreach my $key (keys %m){print "$key\t$m{$key}\n"}; 

use List::Util qw(shuffle);
use Tk; 
use Tk::DialogBox;
use Tk::Pane;

my $mw = MainWindow->new();
$mw->protocol('WM_DELETE_WINDOW' => sub { &clean_exit });
$mw->geometry("+100+100");

# whatever your default font is at size 20
$mw->fontCreate('big', -size=> 20 );
$mw->fontCreate('huge', -size=> 60 );

my $info = "Enter key as you hear it.
Hit Esc key for a hint.
Hit SpaceBar for Start/Next";

my $canvas = $mw->Canvas( -bg => 'black',
             width => 600, height => 200,
            )->pack(-expand => 1,-fill =>'both');

my $subframe = $mw->Frame(-background =>'gray50')->pack(-fill => 'x');

$subframe->Button(-text =>'Exit',
            -font => 'big',
            -background => 'hotpink',
            -activebackground => 'red',
        -command => sub{ clean_exit() },
            )->pack(-side=>'left');

# a spacer
$subframe->Label(-text =>' ',
            -font => 'big',
            -background => 'gray50',
        -foreground => 'gray50',
            )->pack(-side=>'left');

$subframe->Label(-text =>'Freq ',
            -font => 'big',
            -background => 'black',
        -foreground => 'green',
            )->pack(-side=>'left');

$subframe->Spinbox(
            -font => 'big',
            -textvariable => \$freq,
            -width => 5,
            -from => 300.0,
            -to   => 2000.0,
            -increment => 10.0,
            -background => 'black',
        -foreground => 'green',
            -buttonbackground => 'black',
            )->pack(-side=>'left');

# a spacer
$subframe->Label(-text =>' ',
            -font => 'big',
            -background => 'gray50',
        -foreground => 'gray50',
            )->pack(-side=>'left');


$subframe->Label(-text =>'Rate ',
            -font => 'big',
            -background => '#260c00',
        -foreground => 'lightyellow',
            )->pack(-side=>'left');

$subframe->Spinbox(
            -font => 'big',
            -textvariable => \$rate,
            -width => 5,
            -from => .5,
            -to   => 1.5,
            -increment => 0.1,
            -background => '#260c00',
        -foreground => 'lightyellow',
            -buttonbackground => '#260c00',
            )->pack(-side=>'left');

$subframe->Label(-text =>' ',
            -font => 'big',
            -background => 'gray50',
        -foreground => 'gray50',
            )->pack(-side=>'left');


$subframe->Label(-text =>'Vol ',
            -font => 'big',
            -background => '#260c99',
        -foreground => 'lightyellow',
            )->pack(-side=>'left');

$subframe->Spinbox(
            -font => 'big',
            -textvariable => \$vol,
            -width => 5,
            -from => 0.0,
            -to   => 1.0,
            -increment => 0.1,
            -background => '#260c99',
        -foreground => 'lightyellow',
            -buttonbackground => '#260c99',
            )->pack(-side=>'left');

$subframe->Button(-text =>'Select tokens',
              -background =>'lightsteelblue',
          -activebackground =>'lightskyblue',
              -command => sub { sel_let() },
             )->pack(-side=>'right',-padx=>5);


$mw->bind("<Key>", [ sub { 
         my $key = $_[1];
         analyze_key($key);
           # }, Ev('K') ] ); #keysym text misses punctuation
            }, Ev('N') ] );  #keysym decimal
# hack: must use decimal keycodes
# to avoid @ being translated as "at",
# and ? being returned as "question"
# This is part of Tk suckiness.           

# display usage
$canvas->createText(10,50,
           -anchor=>'w',
           -font => 'big',
       -fill => 'lightyellow',
       -text => $info,
           -tags => ['info'],
          );

MainLoop;

sub analyze_key{
   my $key = shift;
   my $key_in = chr($key);

   if( $key_in eq $correct_key ){ 
       
          $correct = 1; 
          
          $canvas->createText(450,100,
               -anchor=>'w',
               -font => 'huge',
               -fill => 'green',
               -text => $key_in,
               -tags => ['key'],
            );
         }

   if( $key == 32 ){ #space key 
        $canvas->delete('help'); 
        #print "correct-> $correct_key\n";
        begin(); 
        }

   if( $key eq '65307' ){ #Escape key 
        $help_toggle *= -1; # multiply by -1 to toggle
        $canvas->delete('help');
      }

}

sub begin {
 
          $canvas->delete('key');         
          $canvas->delete('quiz');
          my $quiz = join ("",@selected);
          $canvas->createText(10,120,
               -anchor=>'w',
               -font => 'big',
               -fill => 'green',
               -text => $quiz,
               -tags => ['quiz'],
            );
 
        if( $correct == 1){ #do next letter
          my @shuffled = shuffle (@selected);      
          $morse_in = $m{$shuffled[0]};
          $correct_key = $shuffled[0];
      print "$correct_key\n";
          $correct = 0; #reset loop control
        }
        
       if($help_toggle == 1){
           $canvas->createText(10,150,
           -anchor=>'w',
           -font => 'huge',
       -fill => 'green',
       -text => $morse_in,
           -tags => ['help'],
          );
      }
      $go_control =1;    
  }

sub sel_let{
  
  $canvas->delete('help');
  
  my $d  = $mw->DialogBox(-buttons => ["OK", "Cancel"]);
  $d->geometry("700x400+100+100");
  my $f  = $d->add('Frame')->pack(-expand => 1, -fill => 'both');
  my $sp = $f->Scrolled('Pane', -scrollbars=>'osoe', 
             sticky=>'nwse', -bg=>'lightblue')
                ->pack(-expand=>1, -fill=>'both' );

#my @tokens =  sort keys(%m); # not quite sorted right, so do it manua
+l
my @tokens = split //, 'abcdefghijklmnopqrstuvwxyz0123456789!"\'()+,-.
+:;=?@';

my @cbvalues;
my @cbnames;
my $count = 0;

for ( my $x = 0 ; $x < 5 ; ++$x ) {
    for ( my $y = 0 ; $y < 10 ; ++$y ) {

  $cbnames[$count] = shift @tokens;

  $sp->Checkbutton(-text => $cbnames[$count],
  #$sp->Checkbutton(-text => $text,
        -font=>[arial => 12],
        -onvalue => 1,
        -offvalue => 0,
        -variable => \$cbvalues[$count],
        -font => 'big',
        -bg => 'black',
        -fg => 'lightyellow',
     )->grid(-row => $x, -column =>$y);

$count++;
}
}

$d->Show;

 $canvas->delete('quiz');
 @selected = ();
   foreach my $c( 0.. $count ){
          if ( $cbvalues[$c] ){
              push @selected, $cbnames[$c];
            }
       }
 print "@selected\n"; 
 # if cancel button is hit, return to default quiz
 if (scalar @selected == 0){ @selected = ('a'..'z')}
 
 $correct = 1; # break out of old loop and reset
 
  begin();
}

sub clean_exit{
   # $timer->cancel;
     
     # stop audio immediately otherwise it
     # will finish it's buffer
     system( "kill -9 $audio_pid");
     # stop thread
     $die_control = 1;
     $thr->join;
     exit;
 }


# no Tk code in thread
sub worker {

my $PI = 3.1415926;
#my $sample_rate = 11250;
#my $sample_rate = 44100;
my $sample_rate = 8000; 

# define time increment for calculating the wave
my $inc = 1 / $sample_rate;
#print "$inc\n";  # 1/8000 = 0.000125

#piped open to aplay .... paplay was also tried
  $audio_pid = open (my $ah, "| aplay -R 10 -t raw -f S16_LE -r $sampl
+e_rate 2>/dev/null") 
#  $audio_pid = open (my $ah, "| paplay -v -p --latency=100  --raw --f
+ormat s16le --rate $sample_rate ") 
                                or  die "Cannot open pipe $!";

# start actual thread listening loop
 while(1){
      
      if($die_control){
             print "thread finishing\n"; 
             return} 
      
      #wait for $go_control  
      if($go_control){      

        if($die_control){
             print "thread finishing\n"; 
             return} 
    
    #compute volume once           
    my $vol1 = $vol*32678; 

    #print "$morse_in\n";

    $"=''; # change array separator to make for easier parsing 
    my @chars = split //, $morse_in;
#    print "Chars->@chars ", scalar @chars,"\n";
        
    foreach(@chars){ #process each morse string
         
      if($_ eq '.'){
          #dih
             for (my $t = 0; $t <= (.1 / $rate ); $t += $inc ) {
              my $signal = $vol1 * sin($freq * 2 * $PI * $t);
              print $ah pack("v", $signal);
              } 
              $ah->flush();
           #intra-letter                      
               for (my $t = 0; $t <= (.1 / $rate ); $t += $inc ) {
               print $ah pack("v", 0);
              }
              $ah->flush(); 
       }elsif ($_ eq '-'){
          #dah
               for (my $t = 0; $t <= (.3 / $rate ); $t += $inc ) {
               my $signal = $vol1 * sin($freq * 2 * $PI * $t);
               print $ah pack("v", $signal);
              }
              $ah->flush();
         #intra-letter
               for (my $t = 0; $t <= (.1 / $rate ); $t += $inc ) {
               print $ah pack("v", 0);
              }
               $ah->flush();
       }elsif ($_ eq ' ') #add inter-letter delay
             {
               for (my $t = 0; $t <= (.3 / $rate ); $t += $inc ) {
               print $ah pack("v", 0);
               }
             $ah->flush();
             }
   }
 
     # flush out previous audio's buffer
      $ah->flush();
    
    $go_control =0;
      
        }else{ 
              # sleep until awakened with $go_control 
              select(undef,undef,undef,.25); }
   }
      
  return;
}
__END__

[Discipulus]

Hello zentara and thanks for this useful program!

> Any comments or improvements welcome..

Why did you used aplay instead of using a more portable way to play sounds, as you already demonstrated to us in Tk Game Sound demo using SDL?

Did you considered to put this software on github? Well you have gigas of tk perl code to post there, if you want..

L*

UPDATE

ok, effectively SDL seems unable to produce sounds, but investigating I found an old module named Audio::Beep that seems fun to use: zentara can you hear me?

#linux quoting
perl -MAudio::Beep -e 'for("--.. . -. - .- .-. .-"=~/./g){ /\./ ? beep
+(1000,100) : /\-/ ? beep(1000,200) : sleep 1}'

#double quoting
perl -MAudio::Beep -e "for('--.. . -. - .- .-. .-'=~/./g){ /\./ ? beep
+(1000,100) : /\-/ ? beep(1000,200) : sleep 1}"

if you install the module dont miss the oneliner that comes along docs: perl -MAudio::Beep -e 'beep(21 + rand 1000, rand 300) while 1'

[zentara]

Update: Discipulus Audio::Beep requires /dev/dsp, and under Pulsaudio you would have to run any program using it with the padsp utility. Like:

padsp ./my_audio_app

I preferred to avoid any use of /dev/dsp, since PulseAudio dosn't really like it. /dev/dsp usage is going obsolete. Also here is an excerpt from the Audio::Beep pod. Requires either the beep program by Johnathan Nightingale (you should find sources in this tarball) SUID root or you to be root (that's because we need writing access to the /dev/console device). If you don't have the beep program this library will also assume some kernel constants which may vary from kernel to kernel (or not, i'm no kernel expert). So..... you need the beep program installed, you need the /dev/dsp and padsp cludges, and it's an obsolete module.

END Update.

I thought about using SDL but I could only find modules to play audio files, not raw PCM data. If I used premade dits and dahs audio files say in mp3 or ogg format, I would have been forced to use a Time::HiRes hack to get the audio files to play for the correct durations. A dit is one time unit, and a dah is 3 times the length of a dit. There is also the space required between the dits and dahs, programmed silence. That seemed like alot of computer overhead, since it is at millisecond accuracy. I stuck with the simpler method of directly generating the raw PCM. There may be a clever way in SDL but I couldn't find a way to avoid external sound files.

I'm beginning to think that I may make an improvement by using syswrite, instead of print, to the pipe's $ah filehandle. This may help the buffer latency problem.

[zentara]

Hi again Discipulus, I have found the correct alternative, its called Audio::PortAudio, but there still seems to be glitches getting it to run under the widely used PulseAudio system. I think my simple pipe to aplay is the easiest thing to do. If anyone can show a Audio::PortAudio script that works with the PulseAudio system, I would be grateful to see it posted. PortAudio c programs seems to work fine.

UPDATE... duh.... I answered my own question. :-)

#!/usr/bin/perl
use warnings;
use strict;
use Audio::PortAudio;

my $api = Audio::PortAudio::default_host_api();
my $device  = $api->default_output_device;


my $pi = 3.14159265358979323846;
my $sine = pack "f*", map { sin( $pi * $_ / 100 ) / 8 } 0 .. 399;

my $stream = $device->open_write_stream(
    {
        channel_count => 1,
    },
    44100,
    400,
    0
);
for (0 .. 10) {
    $stream->write($sine);
}

[ForgotPasswordAgain]

When I learned (have since forgot) Morse code for a ham license, I used a great DOS program that played at full speed, but started simple and added more letters as you got most of them right (and would back off if you got them wrong). The idea is basically to learn the kinda overall pattern of the letters rather than the individual dits and dahs. After googling, I think it must've been using the Koch method from what I can tell.

[zentara]

Yeah, the Koch method is the best.

Most of the current radio amateurs are using digital modes now, like FT31, but I think everyone should be able to send out an SOS, and location, if the need arises. Like WW3 :-) It looks like keyboard to keyboard communication is the wave of the future, especially with the rise of low power weak signal modes. JT65 lets you bounce signals off of the moon, see WSJT if interested. It's amazing what modern signal analysis can do with just a few watts of power.... around the world.

My ultimate goal with this program is to make it an encoder, to generate perfect morse from whatever I type on my keyboard, or generate with a Perl program. It would only take a few slight modifications to make it do that. But I need to understand the responses. One way cw is kindof useless. :-) Nobody, as of yet, has made a cw decoder that really works.... its my new Holy Grail. Even the high priced commercial encoder/decoders don't work on decode, if you carefully read the reviews, there are too many errors from the many variables. It seems the human ear and brain is still the best decoder. Yet, I think there has to be a way.