Beefy Boxes and Bandwidth Generously Provided by pair Networks
No such thing as a small change
 
PerlMonks  

perlTk Type Tutor - useful for learning a DVORAK keyboard layout

by PodMaster (Abbot)
on Jan 26, 2003 at 11:20 UTC ( [id://229960]=sourcecode: print w/replies, xml ) Need Help??
Category: GUI Programming
Author/Contact Info /tell PodMaster
Description: A primitive (for the time being) typetutor. You click keys on your keyboard, and they light up on the screen.

Has a menu option for switching the virtual keyboard representation to/from QWERTY/DVORAK but it doesn't work. Thanks to JaWi 

#!/usr/bin/perl

=head1 NAME

perlTk Type Tutor - useful for learning a DVORAK layout

=head1 The KeyBoard

is based on the following map

     `  1  2  3  4  5  6  7  8  9  0  -  =  backspace
    tab  q  w  e  r  t  y  u  i  o  p  [  ] \
    caps  a  s  d  f  g  h  j  k  l  ;  '   enter
    shift  z  x  c  v  b  n  m  ,  .  /  shift
    ctrl  meta  alt  spacebar  alt  meta  hyper  ctrl

The keys are mapped  from left to right, by row (top to bottom).
The following "special" keys are ignored from the above mapping,
and mapped last in the following order.

    Shift_L
    Shift_R
    Control_L
    Control_R
    Meta_L
    Meta_R
    Alt_L
    Alt_R
    Hyper
    CapsLock
    Enter
    Tab
    Backspace
    Spacebar

=cut

use Tk 8;
use strict;
use warnings;

use vars qw[ $theKeyboard  ];
$theKeyboard = {};
my @KeyBoard;
my %QWERTY;
my %DVORAK;

$KeyBoard[ 0] = [     0,    36,    23,    59, ];
$KeyBoard[ 1] = [    28,    36,    51,    59, ];
$KeyBoard[ 2] = [    56,    36,    79,    59, ];
$KeyBoard[ 3] = [    84,    36,   107,    59, ];
$KeyBoard[ 4] = [   112,    36,   135,    59, ];
$KeyBoard[ 5] = [   140,    36,   163,    59, ];
$KeyBoard[ 6] = [   168,    36,   191,    59, ];
$KeyBoard[ 7] = [   196,    36,   219,    59, ];
$KeyBoard[ 8] = [   224,    36,   247,    59, ];
$KeyBoard[ 9] = [   252,    36,   275,    59, ];
$KeyBoard[10] = [   280,    36,   303,    59, ];
$KeyBoard[11] = [   308,    36,   331,    59, ];
$KeyBoard[12] = [   336,    36,   359,    59, ];
$KeyBoard[13] = [    42,    64,    65,    87, ];
$KeyBoard[14] = [    70,    64,    93,    87, ];
$KeyBoard[15] = [    98,    64,   121,    87, ];
$KeyBoard[16] = [   126,    64,   149,    87, ];
$KeyBoard[17] = [   154,    64,   177,    87, ];
$KeyBoard[18] = [   182,    64,   205,    87, ];
$KeyBoard[19] = [   210,    64,   233,    87, ];
$KeyBoard[20] = [   238,    64,   261,    87, ];
$KeyBoard[21] = [   266,    64,   289,    87, ];
$KeyBoard[22] = [   294,    64,   317,    87, ];
$KeyBoard[23] = [   322,    64,   345,    87, ];
$KeyBoard[24] = [   350,    64,   373,    87, ];
$KeyBoard[25] = [   378,    64,   401,    87, ];
$KeyBoard[26] = [  50.4,    92,  73.4,   115, ];
$KeyBoard[27] = [  78.4,    92, 101.4,   115, ];
$KeyBoard[28] = [ 106.4,    92, 129.4,   115, ];
$KeyBoard[29] = [ 134.4,    92, 157.4,   115, ];
$KeyBoard[30] = [ 162.4,    92, 185.4,   115, ];
$KeyBoard[31] = [ 190.4,    92, 213.4,   115, ];
$KeyBoard[32] = [ 218.4,    92, 241.4,   115, ];
$KeyBoard[33] = [ 246.4,    92, 269.4,   115, ];
$KeyBoard[34] = [ 274.4,    92, 297.4,   115, ];
$KeyBoard[35] = [ 302.4,    92, 325.4,   115, ];
$KeyBoard[36] = [ 330.4,    92, 353.4,   115, ];
$KeyBoard[37] = [  64.4,   120,  87.4,   143, ];
$KeyBoard[38] = [  92.4,   120, 115.4,   143, ];
$KeyBoard[39] = [ 120.4,   120, 143.4,   143, ];
$KeyBoard[40] = [ 148.4,   120, 171.4,   143, ];
$KeyBoard[41] = [ 176.4,   120, 199.4,   143, ];
$KeyBoard[42] = [ 204.4,   120, 227.4,   143, ];
$KeyBoard[43] = [ 232.4,   120, 255.4,   143, ];
$KeyBoard[44] = [ 260.4,   120, 283.4,   143, ];
$KeyBoard[45] = [ 288.4,   120, 311.4,   143, ];
$KeyBoard[46] = [ 316.4,   120, 339.4,   143, ];
$KeyBoard[47] = [     0,   120,    59,   143, ];
$KeyBoard[48] = [ 344.4,   120, 403.4,   143, ];
$KeyBoard[49] = [     0,   148,    37,   171, ];
$KeyBoard[50] = [   366,   148,   403,   171, ];
$KeyBoard[51] = [    42,   148,    79,   171, ];
$KeyBoard[52] = [   282,   148,   319,   171, ];
$KeyBoard[53] = [    84,   148,   121,   171, ];
$KeyBoard[54] = [   240,   148,   277,   171, ];
$KeyBoard[55] = [   324,   148,   361,   171, ];
$KeyBoard[56] = [     0,    92,    45,   115, ];
$KeyBoard[57] = [ 358.4,    92, 403.4,   115, ];
$KeyBoard[58] = [     0,    64,    37,    87, ];
$KeyBoard[59] = [   364,    36,   401,    59, ];
$KeyBoard[60] = [   126,   148,   235,   171, ];


$QWERTY{'?'} = $KeyBoard[46];
$QWERTY{'}'} = $KeyBoard[24];
$QWERTY{'~'} = $KeyBoard[0];
$QWERTY{'@'} = $KeyBoard[2];
$QWERTY{'['} = $KeyBoard[23];
$QWERTY{'\\'} = $KeyBoard[25];
$QWERTY{']'} = $KeyBoard[24];
$QWERTY{'^'} = $KeyBoard[6];
$QWERTY{'_'} = $KeyBoard[11];
$QWERTY{'!'} = $KeyBoard[1];
$QWERTY{'"'} = $KeyBoard[36];
$QWERTY{'`'} = $KeyBoard[0];
$QWERTY{'#'} = $KeyBoard[3];
$QWERTY{'a'} = $KeyBoard[26];
$QWERTY{'$'} = $KeyBoard[4];
$QWERTY{'b'} = $KeyBoard[41];
$QWERTY{'%'} = $KeyBoard[5];
$QWERTY{'c'} = $KeyBoard[39];
$QWERTY{'&'} = $KeyBoard[7];
$QWERTY{'d'} = $KeyBoard[28];
$QWERTY{'\''} = $KeyBoard[36];
$QWERTY{'e'} = $KeyBoard[15];
$QWERTY{'('} = $KeyBoard[9];
$QWERTY{'f'} = $KeyBoard[29];
$QWERTY{')'} = $KeyBoard[10];
$QWERTY{'g'} = $KeyBoard[30];
$QWERTY{'*'} = $KeyBoard[8];
$QWERTY{'h'} = $KeyBoard[31];
$QWERTY{'+'} = $KeyBoard[12];
$QWERTY{'i'} = $KeyBoard[20];
$QWERTY{','} = $KeyBoard[44];
$QWERTY{'j'} = $KeyBoard[32];
$QWERTY{'k'} = $KeyBoard[33];
$QWERTY{'-'} = $KeyBoard[11];
$QWERTY{'.'} = $KeyBoard[45];
$QWERTY{'l'} = $KeyBoard[34];
$QWERTY{'/'} = $KeyBoard[46];
$QWERTY{'m'} = $KeyBoard[43];
$QWERTY{'n'} = $KeyBoard[42];
$QWERTY{'0'} = $KeyBoard[10];
$QWERTY{'1'} = $KeyBoard[1];
$QWERTY{'o'} = $KeyBoard[21];
$QWERTY{'2'} = $KeyBoard[2];
$QWERTY{'p'} = $KeyBoard[22];
$QWERTY{'q'} = $KeyBoard[13];
$QWERTY{'3'} = $KeyBoard[3];
$QWERTY{'r'} = $KeyBoard[16];
$QWERTY{'4'} = $KeyBoard[4];
$QWERTY{'5'} = $KeyBoard[5];
$QWERTY{'s'} = $KeyBoard[27];
$QWERTY{'t'} = $KeyBoard[17];
$QWERTY{'6'} = $KeyBoard[6];
$QWERTY{'7'} = $KeyBoard[7];
$QWERTY{'u'} = $KeyBoard[19];
$QWERTY{'v'} = $KeyBoard[40];
$QWERTY{'8'} = $KeyBoard[8];
$QWERTY{'w'} = $KeyBoard[14];
$QWERTY{'9'} = $KeyBoard[9];
$QWERTY{':'} = $KeyBoard[35];
$QWERTY{'x'} = $KeyBoard[38];
$QWERTY{';'} = $KeyBoard[35];
$QWERTY{'y'} = $KeyBoard[18];
$QWERTY{'<'} = $KeyBoard[44];
$QWERTY{'z'} = $KeyBoard[37];
$QWERTY{'{'} = $KeyBoard[23];
$QWERTY{'='} = $KeyBoard[12];
$QWERTY{'>'} = $KeyBoard[45];
$QWERTY{'|'} = $KeyBoard[25];

$DVORAK{'`'} = $KeyBoard[0];
$DVORAK{'}'} = $KeyBoard[12];
$DVORAK{'~'} = $KeyBoard[0];
$DVORAK{'!'} = $KeyBoard[1];
$DVORAK{'"'} = $KeyBoard[13];
$DVORAK{'#'} = $KeyBoard[3];
$DVORAK{'$'} = $KeyBoard[4];
$DVORAK{'%'} = $KeyBoard[5];
$DVORAK{'&'} = $KeyBoard[7];
$DVORAK{'\''} = $KeyBoard[13];
$DVORAK{'('} = $KeyBoard[9];
$DVORAK{')'} = $KeyBoard[10];
$DVORAK{'*'} = $KeyBoard[8];
$DVORAK{'+'} = $KeyBoard[24];
$DVORAK{','} = $KeyBoard[14];
$DVORAK{'-'} = $KeyBoard[36];
$DVORAK{'.'} = $KeyBoard[15];
$DVORAK{'/'} = $KeyBoard[23];
$DVORAK{'0'} = $KeyBoard[10];
$DVORAK{'1'} = $KeyBoard[1];
$DVORAK{'2'} = $KeyBoard[2];
$DVORAK{'3'} = $KeyBoard[3];
$DVORAK{'4'} = $KeyBoard[4];
$DVORAK{'5'} = $KeyBoard[5];
$DVORAK{'6'} = $KeyBoard[6];
$DVORAK{'7'} = $KeyBoard[7];
$DVORAK{'8'} = $KeyBoard[8];
$DVORAK{'9'} = $KeyBoard[9];
$DVORAK{':'} = $KeyBoard[37];
$DVORAK{';'} = $KeyBoard[37];
$DVORAK{'<'} = $KeyBoard[14];
$DVORAK{'='} = $KeyBoard[24];
$DVORAK{'>'} = $KeyBoard[15];
$DVORAK{'?'} = $KeyBoard[23];
$DVORAK{'@'} = $KeyBoard[2];
$DVORAK{'['} = $KeyBoard[11];
$DVORAK{'\\'} = $KeyBoard[25];
$DVORAK{']'} = $KeyBoard[12];
$DVORAK{'^'} = $KeyBoard[6];
$DVORAK{'_'} = $KeyBoard[36];
$DVORAK{'a'} = $KeyBoard[26];
$DVORAK{'b'} = $KeyBoard[42];
$DVORAK{'c'} = $KeyBoard[20];
$DVORAK{'d'} = $KeyBoard[31];
$DVORAK{'e'} = $KeyBoard[28];
$DVORAK{'f'} = $KeyBoard[18];
$DVORAK{'g'} = $KeyBoard[19];
$DVORAK{'h'} = $KeyBoard[32];
$DVORAK{'i'} = $KeyBoard[30];
$DVORAK{'j'} = $KeyBoard[39];
$DVORAK{'k'} = $KeyBoard[40];
$DVORAK{'l'} = $KeyBoard[22];
$DVORAK{'m'} = $KeyBoard[43];
$DVORAK{'n'} = $KeyBoard[34];
$DVORAK{'o'} = $KeyBoard[27];
$DVORAK{'p'} = $KeyBoard[16];
$DVORAK{'q'} = $KeyBoard[38];
$DVORAK{'r'} = $KeyBoard[21];
$DVORAK{'s'} = $KeyBoard[35];
$DVORAK{'t'} = $KeyBoard[33];
$DVORAK{'u'} = $KeyBoard[29];
$DVORAK{'v'} = $KeyBoard[45];
$DVORAK{'w'} = $KeyBoard[44];
$DVORAK{'x'} = $KeyBoard[41];
$DVORAK{'y'} = $KeyBoard[17];
$DVORAK{'z'} = $KeyBoard[46];
$DVORAK{'{'} = $KeyBoard[11];
$DVORAK{'|'} = $KeyBoard[25];

{
    local $theKeyboard = \%DVORAK;
    $theKeyboard->{shift_l} = [47];
    $theKeyboard->{shift_r} = [48];
    $theKeyboard->{control_l} = [ 49];
    $theKeyboard->{control_r} = [ 50];
    $theKeyboard->{meta_l} = [ 51];
    $theKeyboard->{91} = [ 51];
    $theKeyboard->{meta_r} = [ 52];
    $theKeyboard->{92} = [ 52];
    $theKeyboard->{alt_l} = [ 53];
    $theKeyboard->{alt_r} = [ 54];
    $theKeyboard->{backspace} = [ Backspace => 59];
    $theKeyboard->{return} = [ Enter => 57]; #????
    $theKeyboard->{"\t"} = [ Tab => 58];
    $theKeyboard->{" "}  = [ Spacebar => 60];
    $theKeyboard->{93} = [ Hyper => 55];
    $theKeyboard->{20} = [ CapsLock => 56];
    
}

{
    local $theKeyboard = \%QWERTY;
    $theKeyboard->{shift_l} = [47];
    $theKeyboard->{shift_r} = [48];
    $theKeyboard->{control_l} = [ 49];
    $theKeyboard->{control_r} = [ 50];
    $theKeyboard->{meta_l} = [ 51];
    $theKeyboard->{91} = [ 51];
    $theKeyboard->{meta_r} = [ 52];
    $theKeyboard->{92} = [ 52];
    $theKeyboard->{alt_l} = [ 53];
    $theKeyboard->{alt_r} = [ 54];
    $theKeyboard->{backspace} = [ Backspace => 59];
    $theKeyboard->{return} = [ Enter => 57]; #????
    $theKeyboard->{"\t"} = [ Tab => 58];
    $theKeyboard->{" "}  = [ Spacebar => 60];
    $theKeyboard->{93} = [ Hyper => 55];
    $theKeyboard->{20} = [ CapsLock => 56];
    
}

warn DVORAK => scalar keys %DVORAK;
warn QWERTY => scalar keys %QWERTY;

my $main = MainWindow->new( # tkinit
    -borderwidth => 0,
    -relief      => 'flat',
    -width => 333,
    -height => 555,
#    -background  => undef,
);

my $menubar = $main->Menu(-type => 'menubar');
$main->configure(-menu => $menubar);
my $f = $menubar->cascade(-label => '~Layout', -tearoff => 0);
$f->command(-label => 'QWERTY',    -command => [\&SwitchLayout, \%QWER
+TY]);
$f->command(-label => 'DVORAK',    -command => [\&SwitchLayout, \%DVOR
+AK]);

$main->geometry('+300+30');  # xpos ypos, you can read this from confi
+g as well
$main->withdraw(); # saw jouke do it (too tired to investigate ;)
$main->deiconify();         # not minimized
$main->raise();             # bring to top (how do i do always on top?
+ hmm, event handler?)

my $c1 = $main->Canvas(
    -relief      => 'solid',
    -borderwidth => 0,
    -highlightthickness => 0,
    -height => 200,
    -width  => 404,
    -background => 'white',
)->pack(
    -anchor => 'center',
    -side => 'top',
);

$main->Scrolled(
    Text => 
    -scrollbars => 'se'
)->pack(
    -expand => 'yes',
    -fill => 'both',
);

for( 0 .. 46 ) {
    $c1->createRectangle(
        @{$KeyBoard[$_]},
        -tag => "roy$_",
        -fill => 'white',
        -disabledfill => 'green'
    );
    push @{$KeyBoard[$_]}, $_; # tag tag tag
}


{ # the homekeys (qwerty F and J)
    my($x,$y, $X, $Y ) = @{$KeyBoard[29]};
    $c1->createRectangle($X-5,$Y-4,$x+5,$Y-3);
    ($x,$y, $X, $Y ) = @{$KeyBoard[32]};
    $c1->createRectangle($X-5,$Y-4,$x+5,$Y-3);
}

for( 47 .. $#KeyBoard ) {
    $c1->createRectangle(
        @{$KeyBoard[$_]},
        -tag => "roy$_",
        -fill => 'pink',
        -disabledfill => 'red'
    );

    push @{$KeyBoard[$_]}, $_; # tag tag tag
}


## Due to limitations in Tk and/or the underlying OS,
## some of these won't work
## for example, on my machine, Shift_L and Shift_R issue the exact
## same keycode(windows' fault)

$main->bind('<KeyPress>', [ \&RockOn, Ev('k'),Ev('A'), ]);
$main->bind('<KeyRelease>', [ \&RockOff, Ev('k'),Ev('A'), ]);

$main->bind('<KeyPress-Shift_L>',   [ \&RockOn,  1,'Shift_L', ]);
$main->bind('<KeyRelease-Shift_L>', [ \&RockOff, 1,'Shift_L', ]);

$main->bind('<KeyPress-Shift_R>',   [ \&RockOn,  1,'Shift_R', ]);
$main->bind('<KeyRelease-Shift_R>', [ \&RockOff, 1,'Shift_R', ]);

$main->bind('<KeyPress-Control_L>',   [ \&RockOn,  1,'Control_L', ]);
$main->bind('<KeyRelease-Control_L>', [ \&RockOff, 1,'Control_L', ]);

$main->bind('<KeyPress-Control_R>',   [ \&RockOn,  1,'Control_R', ]);
$main->bind('<KeyRelease-Control_R>', [ \&RockOff, 1,'Control_R', ]);


$main->bind('<KeyPress-Meta_L>',   [ \&RockOn,  1,'Meta_L', ]);
$main->bind('<KeyRelease-Meta_L>', [ \&RockOff, 1,'Meta_L', ]);

$main->bind('<KeyPress-Meta_R>',   [ \&RockOn,  1,'Meta_R', ]);
$main->bind('<KeyRelease-Meta_R>', [ \&RockOff, 1,'Meta_R', ]);

$main->bind('<KeyPress-Alt_L>',   [ \&RockOn,  1,'Alt_L', ]);
$main->bind('<KeyRelease-Alt_L>', [ \&RockOff, 1,'Alt_L', ]);

$main->bind('<KeyPress-Alt_R>',   [ \&RockOn,  1,'Alt_R', ]);
$main->bind('<KeyRelease-Alt_R>', [ \&RockOff, 1,'Alt_R', ]);

$main->bind('<KeyPress-BackSpace>',   [ \&RockOn,  1,'BackSpace', ]);
$main->bind('<KeyRelease-BackSpace>', [ \&RockOff, 1,'BackSpace', ]);

$main->bind('<KeyPress-Return>',   [ \&RockOn,  1,'Return', ]);
$main->bind('<KeyRelease-Return>', [ \&RockOff, 1,'Return', ]);
    

SwitchLayout(\%DVORAK );
SwitchLayout(\%QWERTY ) if @ARGV; # cause I ain't learned yet ;D

MainLoop();

## subland
        
sub RockOn {
    my( $m, $k, $A ) = @_;

    $k = $theKeyboard->{lc $A} || $theKeyboard->{$k} || 0;

    $c1->itemconfigure( "roy$$k[-1]" => -state => 'disabled') if ref $
+k;
}

sub RockOff {
    my( $m, $k, $A ) = @_;

    $k = $theKeyboard->{lc $A} || $theKeyboard->{$k} || 0;
    $c1->itemconfigure( "roy$$k[-1]" => -state => 'normal') if  ref $k
+;
}

sub SwitchLayout {
    $theKeyboard = shift;
    $c1->delete("letter");

    for( qw[ q w e r t y u i o p a s d f g h j k l z x c v b n m ], qw
+[-] ){
        my($x , $y) = @{$theKeyboard->{$_}}[0,1];
        $x += 10;
        $y += 10;
    
        $c1->createText(
            $x, $y,
            -tag => "letter",
            -font => 'courier 12',
            -text => uc $_,
        );
    }
    
    for( qw[ _ ] ){
        my($x , $y) = @{$theKeyboard->{$_}}[0,1];
        $x += 10;
        $y += 10;
    
        $c1->createText(
            $x, $y,
            -font => 'courier 9',
            -fill => 'red',
            -tag => "letter",
            -text => $_,
        );
    }
    
    
    for( qw[ . / ; ' [ ] ` 1 2 3 4 5 6 7 8 9 0 = \ ], ',' ){
        my($x , $y) = @{$theKeyboard->{$_}}[0,1];
        $x += 7;
        $y += 14;
    
        $c1->createText(
            $x, $y,
            -tag => "letter",
            -font => 'courier 12',
            -text => $_,
        );
    }
    
    
    for( qw[  < > ? : { } | & * ( ) + ~ ! @ $ % ^ " ], '#' ){
        my($x , $y) = @{$theKeyboard->{$_}}[0,1];
        $x += 17;
        $y += 6;
    
        $c1->createText(
            $x, $y,
            -font => 'courier 9',
            -fill => 'red',
            -tag => "letter",
            -text => $_,
        );
    }
}


=head1 AUTHOR

PodMaster - a perlmonk

=head1 THANKX

Juerd for I<inspiration> and everybody else for helping me fix this up

=cut
Replies are listed 'Best First'.
Re: perlTk Type Tutor - useful for learning a DVORAK keyboard layout
by JaWi (Hermit) on Jan 26, 2003 at 12:17 UTC
    First, PodMaster++!

    Second, the switching of the keyboard didn't work because your SwitchLayout function takes a HoH as argument, while your menu-commands only supplies a single hash. It works like a charm if you would change lines 305/306 to: 

    $f->command(-label=>'QWERTY', -command=>[\&SwitchLayout, $a=>\%QWERTY]
+);
$f->command(-label=>'DVORAK', -command => [\&SwitchLayout, $a=>\%DVORA
+K]);

    [download]
    (Yes, I misabused the global $a for this purpose ;-)

    Hope it helps,

    -- JaWi

    "A chicken is an egg's way of producing more eggs."

[reply]
[d/l]
[select]
      Thanks.

      I guess I was thinking $f (the ~Layout menu) would be the first thing passed ~ anyway, I've updated the original post and fixed sub SwitchLayout, and all the calls to it ;)(no dumb 2arg blah)

      Now I can work on some kind of prompting wizard type dealie (now type 'A', and 'A' would light up)

      MJD says you can't just make shit up and expect the computer to know what you mean, retardo!
      ** The Third rule of perl club is a statement of fact: pod is sexy.

[reply]

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Domain Nodelet?

www.com | www.net | www.org
Node Status?
node history
Node Type: sourcecode [id://229960]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? • Last hour • Other CB clients
Other Users?
Others exploiting the Monastery: (7)
As of 2024-04-24 09:00 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found