#!/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, \%QWERTY]);
$f->command(-label => 'DVORAK',    -command => [\&SwitchLayout, \%DVORAK]);

$main->geometry('+300+30');  # xpos ypos, you can read this from config 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