#!/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

[download]

In reply to perlTk Type Tutor - useful for learning a DVORAK keyboard layout by PodMaster

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.