#!/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__
[download]