#!/usr/bin/env perl

=pod

=head1 NAME

carpalx - given text input, determine optimal keyboard mapping to minimize typing effort based on a typing effort model

=head1 SYNOPSIS

  # all configuration read from etc/carpalx.conf
  carpalx -keyboard_input keyboard.conf -keyboard_output keyboard-optimized.conf
          -corpus corpus/words.txt
          -action optimize
          -conf etc/carpalx.conf
          [-debug]

=head1 DESCRIPTION

carpalx is a keyboard layout optimizer. Given a training corpus
(e.g. English text) and parameters that describe typing effort,
carpalx uses simulated annealing to find a keyboard layout to minimize
typing effort.

Typing effort is modeled using three contributions. First, base effort
is derived from finger travel distance. Second, row, hand and finger
penalties are added to limit use of weaker fingers/hands and
distinguish harder-to-reach keys. Third, stroke path effort is used to
rate the effort based on finger, row and hand alternation (e.g. asd is
much easier to type than sad).

=head1 CONFIGURATION

=head2 Configuration file name and path

carpalx will look in the following locations for a configuration file

  .
  SCRIPT_BIN/../etc
  SCRIPT_BIN/etc
  SCRIPT_BIN/
  ~/.carpalx/etc
  ~/.carpalx

where SCRIPT_BIN is the location of the carpalx script. If the name of
the configuration file is not passed via -conf, then SCRIPT_NAME.conf
is tried where SCRIPT_NAME is the name of the script. For example,

  > cd carpalx-0.10
  > bin/carpalx

will attempt to find carpalx.conf in the above paths.

Using -debug -debug will dump the configuration parameters.

  > bin/carpalx -debug -debug

=head2 Configuration structure

The configuration file comprises variable-value pairs, which may be
placed in blocks.

  a = 1
  <someblock>
    b = 2
    <anotherblock>
    c = 3
    </anotherblock>
  </someblock>

Combinations of related parameters (e.g. base effort, keyboard
configuration) are stored in individual files
(e.g. etc/mask/letters.conf) which are subsequently imported into
the main configuration file using <<include>>

  ...
  <<include etc/mask/letters.conf>>
  ...

=head1 HISTORY

=over

=item * 0.10

Packaged and versioned code.

=back

=head1 BUGS

Report!

=head1 AUTHOR

Martin Krzywinski <martink@bcgsc.ca>
http://mkweb.bcgsc.ca

=head1 CONTACT

  Martin Krzywinski
  Genome Sciences Centre
  100-570 W 7th Ave 
  Vancouver BC V5Z 4S6

=cut

################################################################
#
# Copyright 2002-2008 Martin Krzywinski <martink@bcgsc.ca> http://mkweb.bcgsc.ca
#
# This file is part of the Genome Sciences Centre Perl code base.
#
# This script is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This script is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this script; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
################################################################

################################################################
#                             ___   __
#                            | \ \ / /
#   ___ __ _ _ __ _ __   __ _| |\ V /
#  / __/ _` | '__| '_ \ / _` | | > <
# | (_| (_| | |  | |_) | (_| | |/ . \
#  \___\__,_|_|  | .__/ \__,_|_/_/ \_\
#                | |
#                |_| v0.10
#
# carpalX - keyboard layout optimizer - save your carpals
#
# Face it, typing for 10 years can leave your hands looking like
# cranky twigs. Moving that pinky over and over again and rotating
# the wrist - ouch.
#
# CarpalX processes a document and computes the total carpal
# effort required to type it using a default qwerty keyboard
# layout. Effort of each key is defined by its location on the
# keyboard as well as the finger customarily responsible for hitting
# that key.
#
# Long-range effects (double and triple) key combinations
# contribute to 1st and 2nd order effort quantities. For example,
# it requires more effort to type aaazzzaaa than zaazaazaa, because
# the wrist rotation is prolonged and the pinky must extend to hit
# three z's in a row.
#
# You have the option to optimize the keyboard layout for the
# document. The simulated annealing method is used to determine
# a key layout that minimizes total effort.
#
################################################################

################################################################
#     Martin Krzywinski <martink@bcgsc.ca> http://mkweb.bcgsc.ca
#                                                      2004-2008
################################################################

use strict;
use Cwd;
use Config::General;
use Data::Dumper;
use File::Basename;
use FindBin;
use Getopt::Long;
use GD;
use IO::File;
use Math::VecStat qw(sum min max average);
use Set::IntSpan;
use Pod::Usage;
use Storable qw(dclone);
use Digest::MD5 qw(md5_hex);
use Time::HiRes qw(gettimeofday tv_interval);
use lib "$FindBin::RealBin";
use lib "$FindBin::RealBin/../lib";
use lib "$FindBin::RealBin/lib";
use vars qw(%OPT %CONF);

GetOptions(\%OPT,
	   "keyboard_input=s",
	   "keyboard_output=s",
	   "action=s",
	   "corpus=s",
	   "words=s",
	   "wordlength=s",
	   "mode=s",
	   "triads_max_num=i",
	   "triads_overlap",
	   "configfile=s","help","man","debug+");

pod2usage() if $OPT{help};
pod2usage(-verbose=>2) if $OPT{man};
loadconfiguration($OPT{configfile});
populateconfiguration(); # copy command line options to config hash
validateconfiguration(); 
if($CONF{debug} > 1) {
  $Data::Dumper::Pad = "debug parameters";
  $Data::Dumper::Indent = 1;
  $Data::Dumper::Quotekeys = 0;
  $Data::Dumper::Terse = 1;
  print Dumper(\%CONF);
}

my @actions = split(/,/,$CONF{action});

my ($keytriads,$keyboard);

while(my $action = shift(@actions)) {
  printdebug(1,"found action",$action);
  if($action =~ /loadtriads?/i) {
    ################################################################
    #
    # read the document and extract triads
    #
    # triads are adjacent three-key combinations parsed from the
    # document based on the setting of the mode=MODE value
    # (see <mode MODE> block for filters for the MODE).
    #
    printdebug(1,"loading triad from corpus file",$CONF{corpus});
    $keytriads = read_document($CONF{corpus});
  } elsif ($action =~ /loadkeyboard/i) {
    ################################################################
    #
    # create a keyboard and the associated effort matrix
    #
    printdebug(1,"loading keyboard from",$CONF{keyboard_input});
    $keyboard = create_keyboard($CONF{keyboard_input});
  } elsif ($action =~ /reportt?riads?/i) {
    printdebug(1,"reporting triad frequency");
    report_triads($keytriads,$keyboard);
  } elsif ($action =~ /reportwordeffort/i) {
    printdebug(1,"reporting word efforts");
    report_word_effort($keyboard);
  } elsif ($action =~ /drawinputkeyboard/) {
    printdebug(1,"drawing input keyboard");
    draw_keyboard($keyboard,"$CONF{pngfile_keyboard_input}",{title=>"$CONF{keyboard_input} layout"});
    printkeyboard($keyboard);
  } elsif ($action =~ /reporteffort(.*)/i) {
    # calculate the canonical effort associated with the original
    # keyboard layout - the layout will be altered to try to minimize this
    my $effort_canonical;
    printdebug(1,"calculating effort");
    $CONF{memorize} = 0;
    report_keyboard_effort($keytriads,$keyboard,$1);
    $CONF{memorize} = 1;
  } elsif ($action =~ "optimize") {
    # optimize the keyboard layout to decrease the effort
    my $timer = [gettimeofday];
    $keyboard = optimize_keyboard($keytriads,$keyboard);
    $timer = tv_interval($timer);
    printkeyboard($keyboard);
    print "Total time spent optimizing: $timer s\n";
  } elsif ($action =~ /(exit|quit)/) {
    exit;
  } else {
    die "cannot understand action $action";
  }
}

exit;

################################################################
################################################################

=pod

=head1 INTERNAL FUNCTIONS

The content below may be out of date

=cut

sub report_keyboard_effort {

  my ($keytriads,$keyboard,$option) = @_;

  my %effort;
  $effort{all}       = calculate_effort($keytriads,$keyboard);
  my %CONF_prev      = dclone(\%CONF);
  {
    local $CONF{effort_model}{k_param}{k4}       = 0;
    my $keyboard_new   = create_keyboard($CONF{keyboard_input});
    $effort{nopath}    = calculate_effort($keytriads,$keyboard_new);
  }
  {
    local $CONF{effort_model}{k_param}{k4}                             = 0;
    local $CONF{effort_model}{weight_param}{penalties}{default}        = 0;
    local $CONF{effort_model}{weight_param}{penalties}{weight}{hand}   = 0;
    local $CONF{effort_model}{weight_param}{penalties}{weight}{row}    = 0;
    local $CONF{effort_model}{weight_param}{penalties}{weight}{finger} = 0;
    my $keyboard_new = create_keyboard($CONF{keyboard_input});
    $effort{base123}= calculate_effort($keytriads,$keyboard_new);
  }

  {
    local $CONF{effort_model}{k_param}{k4}                             = 0;
    local $CONF{effort_model}{weight_param}{penalties}{default}        = 0;
    local $CONF{effort_model}{weight_param}{penalties}{weight}{row}    = 0;
    local $CONF{effort_model}{weight_param}{penalties}{weight}{finger}    = 0;
    my $keyboard_new = create_keyboard($CONF{keyboard_input});
    $effort{base123_hand}= calculate_effort($keytriads,$keyboard_new);
  }

  {
    local $CONF{effort_model}{k_param}{k4}                             = 0;
    local $CONF{effort_model}{weight_param}{penalties}{default}        = 0;
    local $CONF{effort_model}{weight_param}{penalties}{weight}{finger} = 0;
    my $keyboard_new = create_keyboard($CONF{keyboard_input});
    $effort{base123_handrow}= calculate_effort($keytriads,$keyboard_new);
  }

  {
    local $CONF{effort_model}{k_param}{k3}                             = 0;
    local $CONF{effort_model}{k_param}{k4}                             = 0;
    local $CONF{effort_model}{weight_param}{penalties}{default}        = 0;
    local $CONF{effort_model}{weight_param}{penalties}{weight}{hand}   = 0;
    local $CONF{effort_model}{weight_param}{penalties}{weight}{row}    = 0;
    local $CONF{effort_model}{weight_param}{penalties}{weight}{finger} = 0;
    my $keyboard_new  = create_keyboard($CONF{keyboard_input});
    $effort{base12}   = calculate_effort($keytriads,$keyboard_new);
  }
  {
    local $CONF{effort_model}{k_param}{k2}                             = 0;
    local $CONF{effort_model}{k_param}{k3}                             = 0;
    local $CONF{effort_model}{k_param}{k4}                             = 0;
    local $CONF{effort_model}{weight_param}{penalties}{default}        = 0;
    local $CONF{effort_model}{weight_param}{penalties}{weight}{hand}   = 0;
    local $CONF{effort_model}{weight_param}{penalties}{weight}{row}    = 0;
    local $CONF{effort_model}{weight_param}{penalties}{weight}{finger} = 0;
    my $keyboard_new  = create_keyboard($CONF{keyboard_input});
    $effort{base1}    = calculate_effort($keytriads,$keyboard_new);
  }

  printinfo("Keyboard effort");
  printinfo("-"x60);

  my %efforts = ( k1 => [ $effort{base1},
			  100*$effort{base1}/$effort{all},
			  100*$effort{base1}/$effort{all}],
		  k12 => [ $effort{base12},
			   100*($effort{base12}-$effort{base1})/$effort{all},
			   100*$effort{base12}/$effort{all} ],
		  k123 => [ $effort{base123},
			    100*($effort{base123}-$effort{base12})/$effort{all},
			    100*$effort{base123}/$effort{all}],
		  wh => [ $effort{base123_hand},
			  100*($effort{base123_hand}-$effort{base123})/$effort{all},
			  100*$effort{base123_hand}/$effort{all} ],
		  whr => [ $effort{base123_handrow},
			   100*($effort{base123_handrow}-$effort{base123_hand})/$effort{all},
			   100*$effort{base123_handrow}/$effort{all}],
		  whrf=>[ $effort{nopath},
			  100*($effort{nopath}-$effort{base123_handrow})/$effort{all},
			  100*$effort{nopath}/$effort{all}],
		  k4 => [ $effort{all},
			  100*($effort{all}-$effort{nopath})/$effort{all},
			  100*$effort{all}/$effort{all}] );

  $efforts{k} = [ $efforts{k123}[0],
		  $efforts{k123}[2],
		  $efforts{k123}[2] ];
  $efforts{w} = [ $efforts{whrf}[0]-$efforts{k123}[0],
		  $efforts{whrf}[2]-$efforts{k123}[2],
		  $efforts{whrf}[2] ];
  $efforts{path} = [ $efforts{k4}[0]-$efforts{whrf}[0],
		     $efforts{k4}[2]-$efforts{whrf}[2],
		     $efforts{k4}[2] ];

  printinfo(sprintf("%-20s %8.3f %4.1f %5.1f","k1",
		    @{$efforts{k1}}));
  printinfo(sprintf("%-20s %8.3f %4.1f %5.1f","k1,k2",
		    @{$efforts{k12}}));
  printinfo(sprintf("%-20s %8.3f %4.1f %5.1f","k1,k2,k3",
		    @{$efforts{k123}}));
  printinfo(sprintf("%-20s %8.3f %4.1f %5.1f","k1,k2,k3,w(h)",
		    @{$efforts{wh}}));
  printinfo(sprintf("%-20s %8.3f %4.1f %5.1f","k1,k2,k3,w(h,r)",
		    @{$efforts{whr}}));
  printinfo(sprintf("%-20s %8.3f %4.1f %5.1f","k1,k2,k3,w(h,r,f)",
		    @{$efforts{whrf}}));
  printinfo(sprintf("%-20s %8.3f %4.1f %5.1f","k1,k2,k3,w(h,r,f),k4",
		    @{$efforts{k4}}));
  printinfo();
  for my $var (qw(k1 k12 k123 wh whr whrf k4 k w path)) {
    printinfo(sprintf("#data effort_%s=>[%.3f,%.3f,%.3f],",
		      $var,
		      @{$efforts{$var}}));
  }

  return if $option eq "verybrief";

  printinfo();

  my $stats;
  for my $triad (keys %$keytriads) {
    my $ntriad = $keytriads->{$triad};
    my $char   = substr($triad,0,1);
    my $row    = $keyboard->{map}{$char}{row};
    my $hand   = $keyboard->{map}{$char}{hand};
    my $finger = $keyboard->{map}{$char}{finger};
    $stats->{row}{$row} += $ntriad;
    $stats->{hand}{$hand} += $ntriad;
    $stats->{finger}{$finger} += $ntriad;
  }

  histogram($stats->{row},"keyboard row frequency","row");
  histogram($stats->{hand},"keyboard hand frequency","hand");
  histogram($stats->{finger},"keyboard finger frequency","finger");

  my $charlist = read_document($CONF{corpus},{charlist=>1});

  my $runlength;
  for my $i (0..@$charlist-1) {
    $stats->{charfreq}{$charlist->[$i]}++;
    if($i==0) {
      $runlength->{rowjump} = 1;
      $runlength->{finger}  = 1;
      $runlength->{hand}    = 1;
      $runlength->{row}     = 1;
    } else {
      if ($keyboard->{map}{$charlist->[$i]}{hand} == $keyboard->{map}{$charlist->[$i-1]}{hand} &&
	  $keyboard->{map}{$charlist->[$i]}{row} != $keyboard->{map}{$charlist->[$i-1]}{row}) {
	$runlength->{rowjump} += abs($keyboard->{map}{$charlist->[$i]}{row} - 
				     $keyboard->{map}{$charlist->[$i-1]}{row});
      } else {
	$stats->{run}{rowjump}{$runlength->{rowjump}}++;
	$runlength->{rowjump} = 1;
      }
      if($i == @$charlist-1) {
	$stats->{run}{rowjump}{$runlength->{rowjump}}++;
      }
      for my $runtype (qw(finger hand row)) {
	my $cv  = $keyboard->{map}{$charlist->[$i]}{$runtype};
	my $cvp = $keyboard->{map}{$charlist->[$i-1]}{$runtype};
	if ($cv == $cvp) {
	  $runlength->{$runtype}++;
	} else {
	  $stats->{run}{$runtype}{all}{ $runlength->{$runtype} }++;
	  if($runtype ne "finger") {
	    $stats->{run}{$runtype}{ $cvp }{ $runlength->{$runtype} }++;
	  }
	  $runlength->{$runtype} = 1;
	}
	if($i == @$charlist-1) {
	  $stats->{run}{$runtype}{all}{ $runlength->{$runtype} }++;
	  $stats->{run}{$runtype}{ $cvp }{ $runlength->{$runtype} }++ if $runtype ne "finger";
	}
      }
    }
  }
  histogram($stats->{run}{hand}{0},"keyboard left hand run length","left_hand_run");
  histogram($stats->{run}{hand}{1},"keyboard right hand run length","right_hand_run");
  histogram($stats->{run}{hand}{all},"keyboard hand run length","all_hand_run");
  histogram($stats->{run}{row}{1},"keyboard top row run length","t_row_run");
  histogram($stats->{run}{row}{2},"keyboard home row run length","h_row_run");
  histogram($stats->{run}{row}{3},"keyboard bottom row run length","b_row_run");
  histogram($stats->{run}{row}{all},"keyboard row run length","all_row_run");
  histogram($stats->{run}{finger}{all},"keyboard finger run length","finger_run");
  histogram($stats->{run}{rowjump},"keyboard same-hand row jump length","row_jump");
  histogram($stats->{charfreq},"corpus character frequency","character_frequency","value");
}

sub histogram {
  my $table = shift;
  my $title = shift;
  my $datatitle = shift;
  my $sortfunc = shift || "num";
  my @values;
  if($sortfunc eq "num") {
    @values = sort {$a <=> $b} keys %$table;
  } elsif ($sortfunc eq "ascii") {
    @values = sort {$a cmp $b} keys %$table;
  } elsif ($sortfunc eq "value") {
    @values = sort {$table->{$b} <=> $table->{$a}} keys %$table;
  }
  my $total  = sum ( map {$table->{$_}} @values );
  my $running_total = 0;
  my $data_table;
  if($title) {
    printinfo($title);
    printinfo("-"x60);
  }
  for my $value (@values) {
    $running_total += $table->{$value};
    push @{$data_table->{data}}, $value || 0;
    push @{$data_table->{freq}}, $table->{$value} / $total; 
    push @{$data_table->{cumul}}, $running_total / $total;
    printinfo(sprintf("%-20s %8d %4.1f %5.1f",
		      $value,
		      $table->{$value},
		      100*$table->{$value}/$total,
		      100*$running_total/$total));
  }
  printinfo();
  printinfo(sprintf("#data %s_data=>[qw(%s)],",$datatitle,join(" ",@{$data_table->{data}})));
  printinfo(sprintf("#data %s_frequency=>[%s],",$datatitle,join(",",map { sprintf("%.3f",$_) } @{$data_table->{freq}})));
  printinfo(sprintf("#data %s_cumulative=>[%s],",$datatitle,join(",",map { sprintf("%.3f",$_) } @{$data_table->{cumul}})));
  printinfo();
}

# report the frequency and cumulative frequency of all triads

sub find_action {
  my ($rx,@actions) = @_;     
  if ( my ($action) = grep($rx,@actions) ) {
    return $action;
  } else {
    return undef;
  }
}

sub advance_actions {
  my ($action,@actions) = @_;
  exit if $action =~ /exit|quit/;
  my @newactions;
  my $found;
  for $a (@actions) {
    if(! $found && $a eq $action) {
      $found = 1;
      next;
    }
    push @newactions, $a;
  }
  return @newactions;
}

sub report_triads {
  my ($keytriads,$keyboard) = @_;
  my $n = sum(values %$keytriads);
  my $nc = 0;
  for my $triad (sort {$keytriads->{$b} <=> $keytriads->{$a}} keys %$keytriads) {
    $nc += $keytriads->{$triad};
    my $effort = $keyboard ? calculate_triad_effort($triad,$keyboard,@{$CONF{effort_model}{k_param}}{qw(k1 k2 k3 k4)}) : "na";
    printinfo("triad",$triad,$keytriads->{$triad},$keytriads->{$triad}/$n,$nc/$n,"effort",$effort);
  }
}

sub resolve_path {
  my $file = shift;
  if($file =~ /^\//) {
    return $file;
  } else {
    return "$CONF{configdir}/$file";
  }
}

sub report_word_effort {
    my $keyboard = shift;
    open(WORDS, $CONF{words} =~ /^\// ? $CONF{words} : $FindBin::RealBin . "/$CONF{words}");
    my @words = <WORDS>;
    chomp @words;
    close(WORDS);
    if($CONF{wordlength}) {
      my $length = Set::IntSpan->new($CONF{wordlength});
      @words = grep($length->member(length($_)), @words);
    }
    @words = grep(/^\w+$/,@words);
    my $wordeffort = rankwords(\@words,$keyboard);
    summarizerankwords($wordeffort);
}

################################################################
# 
# given a list of words, return the words and associated
# efforts, as calculated using the triads of the words
#
################################################################

sub rankwords {
  my $words = shift;
  my $keyboard = shift;
  my $wordeffort;
  foreach my $word (@$words) {
    my $wordtriads;
    while($word =~ /(...)/g) {
      my $triad = lc $1;
      $wordtriads->{$triad}++;
      pos $word -= 2;
    }
    next unless keys %$wordtriads;
    my $word_effort = calculate_effort($wordtriads,$keyboard);
    $wordeffort->{lc $word} = $word_effort;
    printdebug(1,"wordeffort",lc $word,$word_effort);
  }
  return $wordeffort;
}

################################################################
#
# Produce a summary of the word effort statistics
#
################################################################

sub summarizerankwords {
  my $wordeffort = shift;
  my $topN = 25;
  # top 10
  my @sorted       = (sort {$wordeffort->{$b} <=> $wordeffort->{$a}} keys %$wordeffort);
  my @top10hardest = @sorted[0..$topN-1];
  my @top10easiest = @sorted[@sorted-1-$topN..@sorted-1];
  printinfo("wordreport","top $topN hardest",join(" ",map {sprintf ("%s:%4.1f",$_,$wordeffort->{$_})} @top10hardest));
  printinfo("wordreport","top $topN easiest",join(" ",map {sprintf ("%s:%4.1f",$_,$wordeffort->{$_})} @top10easiest));
  # percentiles
  my $groups = 10;
  for my $word (@top10hardest) {
    printinfo("wordreport group",0,$word,$wordeffort->{$word});
  }
  foreach my $idx (0..$groups-1) {
    my $elemidx = int($idx*@sorted/$groups);
    my @words = @sorted[$elemidx..$elemidx+10];
    my $cost = $wordeffort->{$words[0]};
    printf ("wordreport percentile %d cost %.1f\n",int(100*$idx/$groups),$cost);
    #print join(" ",join(" ",@words));
    #print "\n";
    for my $word (@words) {
      printinfo("wordreport group",$idx+1,$word,$wordeffort->{$word});
    }
  }
  for my $word (@top10easiest) {
    printinfo("wordreport group",$groups+1,$word,$wordeffort->{$word});
  }
}

=pod

=head2 optimize_keyboard()

  $newkeyboard = optimize_keyboard($keytriads,$keyboard);

Simulated annealing is used to search for a better keyboard layout. The function uses the list of triads, generated from the input text document, and an initial keyboard layout.

=cut

sub optimize_keyboard {
  die "more arguments needed in optimize_keyboard" unless @_ == 2;
  my ($keytriads,$keyboard) = @_;
  my $effort       = calculate_effort($keytriads,$keyboard);
  my $iterations   = $CONF{annealing}{iterations} || 1000;
  my ($t0,$k)      = @{$CONF{annealing}}{qw(t0 k)};
  # load up the mask - eligible keys for relocation
  my $mask         = _parse_mask($CONF{maskfilename});
  die "cannot create mask" unless $mask;
  # create a list of all keys that can be relocated
  my $reloc_list   = make_relocatable_list($mask);
  my $update_count = 0;
  my $last_reported_effort;

  my $keyboard_original = dclone($keyboard);
  my %seen_digests;
  for my $iter (1..$iterations) {
    my $time = [gettimeofday];
    my $keyboardnew;

    my $swap_range = $CONF{annealing}{maxswaps} - $CONF{annealing}{minswaps};
    my $swap_num   = $CONF{annealing}{minswaps};

    $swap_num      += int(rand($swap_range+1)) if $swap_range;
    if($CONF{annealing}{onestep}) {
      $keyboardnew     = _swap_keys($keyboard_original,$reloc_list,$swap_num);
      my $digest = keyboard_digest($keyboardnew);
      if($seen_digests{$digest}) {
	# already seen this layout - fetch next layout
	next;
      }
      $seen_digests{$digest}++;
    } else {
      $keyboardnew     = _swap_keys($keyboard,$reloc_list,$swap_num);
    }
    printkeyboard($keyboardnew);
    my $effortnew       = calculate_effort($keytriads,$keyboardnew);
    my $deffort         = $effortnew - $effort;
    my %report;
    $report{effort}    = $effort;
    $report{neweffort} = $effortnew;
    $report{deffort}   = $deffort;
    my $t = $t0*exp(-$iter*$k/$iterations);
    my $p = $CONF{annealing}{p0} * exp(-abs($deffort)/$t);
    $p = 1 if $p > 1; # float round-off
    $report{t} = $t;
    $report{p} = $p;

    my $keyboard_is_updated = 0;

    if( ($CONF{annealing}{action} eq "minimize" && $deffort < 0) ||
	($CONF{annealing}{action} eq "maximize" && $deffort > 0) ) {
      # always accept layouts for which the effort is lower/higher (as prescribed by action)
      $effort   = $effortnew;
      $keyboard = $keyboardnew;
      $report{move} = "better/accept";
      $keyboard_is_updated = 1;
    } else {
      # sometimes accept layouts for which the effort is higher/lower (as prescribed by action)
      if(rand() < $p) {
	$report{move} = "worse/accept";
	$effort = $effortnew;
	$keyboard = $keyboardnew;
	$keyboard_is_updated = 1;
      } else {
	$report{move} = "worse/reject";
      }
    }
    $update_count += $keyboard_is_updated;

    my $make_report;
    if($CONF{report_filter} eq "all") {
      $make_report = 1;
    } elsif ($CONF{report_filter} eq "update") {
      $make_report = 1 if $report{move} =~ /accept/;
    } elsif ($CONF{report_filter} eq "lower") {
      $make_report = 1 if $deffort < 0;
    } elsif ($CONF{report_filter} eq "higher") {
      $make_report = 1 if $deffort > 0;
    } elsif ($CONF{report_filter} eq "lower_monotonic") {
      $make_report = 1 if ! defined $last_reported_effort || $effortnew < $last_reported_effort;
    } elsif ($CONF{report_filter} eq "higher_monotonic") {
      $make_report = 1 if ! defined $last_reported_effort || $effortnew > $last_reported_effort;
    }

    $report{move} .= "/report" if $make_report;

    my $make_draw;
    if($CONF{draw_filter} eq "all") {
      $make_draw = 1;
    } elsif ($CONF{draw_filter} eq "update") {
      $make_draw = 1 if $report{move} =~ /accept/;
    } elsif ($CONF{draw_filter} eq "lower") {
      $make_draw = 1 if $deffort < 0;
    } elsif ($CONF{draw_filter} eq "higher") {
      $make_draw = 1 if $deffort > 0;
    } elsif ($CONF{draw_filter} eq "lower_monotonic") {
      $make_draw = 1 if ! defined $last_reported_effort || $effortnew < $last_reported_effort;
    } elsif ($CONF{draw_filter} eq "higher_monotonic") {
      $make_draw = 1 if ! defined $last_reported_effort || $effortnew > $last_reported_effort;
    }

    $report{move} .= "/draw" if $make_draw;

    my $parameters = {t=>$t,iter=>$iter,update_count=>$update_count,effort=>$effortnew,deffort=>$deffort};

    if($make_report && not $update_count % $CONF{report_period}) {
      report_keyboard($keyboard,$CONF{keyboard_output},$parameters);
      $last_reported_effort = $effortnew;
    }

    if($make_draw && not $update_count % $CONF{draw_period}) {
      draw_keyboard($keyboard,"$CONF{pngfile_keyboard_output}",$parameters);
      $last_reported_effort = $effortnew;
    }

    my $elapsed = tv_interval($time);
    printf ("iter %6d effort %8.6f -> %8.6f d %10.8f p %10.8f t %10.8f %s cpu %s\n",
	    $iter,@report{qw(effort neweffort deffort p t move)},$elapsed);
  }
  return $keyboard;
}

sub keyboard_digest {
  my $keyboard = shift;
  my @keys;
  for my $row (0..@{$keyboard->{key}}-1) {
    for my $col (0..@{$keyboard->{key}[$row]}-1) {
      push @keys, join("",@{$keyboard->{key}[$row][$col]}{qw(lc uc)});
    }
  }
  my $string = join(":",@keys);
  return md5_hex($string);
}

sub report_keyboard {
  my ($keyboard,$file,$parameters) = @_;
  $file = resolve_path($file);
  open(F,">$file");
  if($CONF{keyboard_output_show_parameters} =~ /current/) {
    print F "<current_parameters>\n";
    for my $parameter (keys %$parameters) {
      printf F ("%-18s = %s\n",$parameter,$parameters->{$parameter});
    }
    print F "</current_parameters>\n\n";
  }
  if($CONF{keyboard_output_show_parameters} =~ /annealing/) {
    print F "<annealing_parameters>\n";
    for my $parameter (keys %{$CONF{annealing}}) {
      printf F ("%-18s = %s\n",$parameter,$CONF{annealing}{$parameter});
    }
    print F "</annealing_parameters>\n\n";
  }

  print F "<keyboard>\n";
  for my $row (0..@{$keyboard->{key}}-1) {
    print F "<row ".($row+1).">\n";
    my (@keys,@fingers);
    for my $col (0..@{$keyboard->{key}[$row]}-1) {
      my $keystring;
      my ($lc,$uc) = @{$keyboard->{key}[$row][$col]}{qw(lc uc)};
      if($lc =~ /[a-z]/ && $uc eq uc $lc) {
	push @keys, $lc;
      } else {
	$lc = "\\".$lc if $lc eq "#";
	$uc = "\\".$uc if $uc eq "#";
	push @keys, "$lc$uc";
      }
      push @fingers, $keyboard->{key}[$row][$col]{finger};
    }
    printf F ("keys = %s\n",join(" ",@keys));
    printf F ("fingers  = %s\n",join(" ",@fingers));
    print F "</row>\n";
  }
  print F "</keyboard>\n\n";
  close(F);
}

=pod

=head2 _swap_keys()

  $newkeyboard = _swap_keys($keyboard,$reloc_list,$n);

Swap one or more pairs ($n randomly sampled pairs) of keys on the keyboard. Lower and upper case characters remain on the same key (e.g. no matter where 'a' is, A is always shift+a). This applies to both letter and non-letter characters (e.g. 1 and ! are always on the same key).

This function returns a new keyboard object with the keys swapped.

=cut

sub _swap_keys {
  my ($keyboard,$reloc_list,$n) = @_;
  my $keyboardcopy = dclone($keyboard);
  $n = 1 if ! $n;
  my $reloc_listsize = @$reloc_list;
  foreach (1..$n) {
    # pick two random keyboard locations from the list of relocatable keys
    my ($key1,$key2);
    while ( $key1 == $key2) {
      $key1 = $reloc_list->[rand($reloc_listsize)];
      $key2 = $reloc_list->[rand($reloc_listsize)];
    }
    # swap these two keys
    _swap_key_pair($keyboardcopy,@$key1,@$key2);
  }
  return $keyboardcopy;
}

=pod

=head2 _swap_key_pair()

  $key1 = [$row1,$col1];
  $key2 = [$row2,$col2];
  _swap_key_pair($keyboard,@$key1,@$key2);

This function modifies $keyboard in place.

=cut

sub _swap_key_pair {
  my ($keyboard,$row1,$col1,$row2,$col2) = @_;

  my ($k1lc,$k1uc) = @{ $keyboard->{key}[$row1][$col1] }{qw(lc uc)};
  my ($k2lc,$k2uc) = @{ $keyboard->{key}[$row2][$col2] }{qw(lc uc)};

  @{$keyboard->{key}[$row1][$col1]}{qw(lc uc)} = ($k2lc,$k2uc);
  @{$keyboard->{key}[$row2][$col2]}{qw(lc uc)} = ($k1lc,$k1uc);

  @{$keyboard->{map}}{$k1lc,$k1uc,$k2lc,$k2uc} = @{$keyboard->{map}}{$k2lc,$k2uc,$k1lc,$k1uc};
}

=pod

=head2 calculate_effort()

  my $effort = calculate_effort($triads,$keyboard);

Given a list of triads and the effort matrix, calculate the total carpal effort required to type the document from which the triads were generated. The effort is a non-negative number. The effort is a sum of the efforts for each triad. The total effort is normalized by the number of triads to remove dependency on document size. 

  abcdefg
  abc     -> effort1
   bcd    -> effort2
    cde   -> effort3
      efg -> effort4
  -------    -------
  abcdefg -> total_effort = ( effort1 + effort2 + effort3 + effort4 ) /4

Given a triad xyz, the effort is calculated by the following empirical expression

  effort = e = k1*effort(x) + k2*effort(x)*effort(y) + k3*effort(x)*effort(y)*effort(z) + k4*patheffort(x,y,z)
             = k1*effort(x)*[1 + effort(y)*(k2 + k3*effort(z))] + k4*patheffort(x,y,z)

The form of this expression is motivated by the fact that the effort of three keystrokes is dependent on not only the individual identity of the keys but also alternation of hand, finger, row and column within the triad as well as presence of hard-to-type key combinations (e.g. zxc zqz awz ). For example, it is much easier to type "ttt" than "tbt", since the left forefinger must travel quite a distance in the latter example. Thus the insertion of the "b" character should impact the effort.

In the first-order approximation k2=k3=k4=0 and the effort is simply the effort of typing the first key, effort(x). The individual effort of a key is defined in the <effort_row> blocks and is optionally modified by (a) shift penalty - CAPS are penalized and (b) hand penalty (e.g. you favour typing with your left hand). Since triads overlap, the first-order approximation for the entire document is the sum of the individual key efforts, without any long-range correlations.

The addition of parameters k2 and k3 is designed to raise the effort of repeated difficult-to-type characters. This is where the notion of a triad comes into play. Notice that if effort(x) is zero, then the whole triad effort is zero.

The patheffort(x,y,z) is a penalty which makes less desirable triads in which the keys do not follow a monotonic progression of columns, or triads which do not alternate hands. Once you try to type 'edc' on a qwerty keyboard, or 'erd' you will understand what I mean. The patheffort is a combination of two factors: hand alternation and column alternation. First, define a hand and column flag for a triad

The definition of path effort here is arbitrary. I find that if the hands alternate between each keystroke, typing is easy (e.g. hf=0x). If both hands are used, but don't alternate then it's not as easy, particuarly when some of the columns in the triad are the same (e.g. same finger has to hit two keys like in "jeu"). If the same hand has to be used for three strokes then you're in trouble, particularly when some of the columns repeat. You can redefine the value of the path effort in <path_efforts> block.

=cut 

sub calculate_effort {
  my ($keytriads,$keyboard) = @_;
  die "keyboard not defined " unless $keyboard;
  die "triads not defined" unless $keytriads;
  my $totaleffort = 0;
  my $contributing_triads = 0;
  my @k = @{$CONF{effort_model}{k_param}}{qw(k1 k2 k3 k4)};
  foreach my $triad (keys %$keytriads) {
    my $triad_effort = calculate_triad_effort($triad,$keyboard,@k);
    my $num_triads   = $keytriads->{$triad};
    $totaleffort     += $triad_effort * $num_triads ;
    $contributing_triads += $num_triads;
  }
  $totaleffort /= $contributing_triads;
  return $totaleffort;
}

{

  my $effortlookup = {};

  sub calculate_triad_effort {
    my ($triad,$keyboard,$k1,$k2,$k3,$k4) = @_;

    my $leaf = $keyboard->{map};
    # characters of the triad
    my ($c1,$c2,$c3)       = split(//,$triad);
    my ($i1,$i2,$i3)       = ($leaf->{$c1}{idx},$leaf->{$c2}{idx},$leaf->{$c3}{idx});
    if($CONF{memorize} && exists $effortlookup->{$i1}{$i2}{$i3}) {
      return $effortlookup->{$i1}{$i2}{$i3};
    } else {
      #
    }
    # keyboard effort of each character
    my ($e1,$e2,$e3)       = ($leaf->{$c1}{effort},$leaf->{$c2}{effort},$leaf->{$c3}{effort});
    # finger of each character
    my ($f1,$f2,$f3)       = ($leaf->{$c1}{finger},$leaf->{$c2}{finger},$leaf->{$c3}{finger});
    # row of each character
    my ($row1,$row2,$row3) = ($leaf->{$c1}{row},$leaf->{$c2}{row},$leaf->{$c3}{row});
    # hand of each character 
    my ($h1,$h2,$h3)       = ($leaf->{$c1}{hand},$leaf->{$c2}{hand},$leaf->{$c3}{hand});
    # effort based on keyboard effort (not dependent on position or hand)
    my $triad_effort       = $k1*$e1 * ( 1 + $e2*$k2 * ( 1 + $k3*$e3 ) );
    
    if ($k4) {

      # hand, finger, row flags for stroke path
      # see http://mkweb.bcgsc.ca/carpalx/?typing_effort

      my $hand_flag;
      if($h1 == $h3) {
	if($h2 == $h3) {
	  # same hand
	  $hand_flag = 2;
	} else {
	  # alternating
	  $hand_flag = 1;
	}
      } else {
	$hand_flag = 0;
      }

      my $finger_flag;

      if( $f1 > $f2 ) {
	if ( $f2 > $f3 ) {
	  # 1 > 2 > 3 - monotonic all different - pf=0
	  $finger_flag = 0;
	} elsif ( $f2 == $f3 ) {
	  # 1 > 2 = 3 - monotonic some different - pf=1
	  if($c2 eq $c3) {
	    $finger_flag = 1;
	  } else {
	    $finger_flag = 6;
	  }
	} elsif ( $f3 == $f1 ) {
	  $finger_flag = 4;
	} elsif ( $f1 > $f3 && $f3 > $f2 ) {
	  # rolling
	  $finger_flag = 2;
	} else {
	  # not monotonic all different - pf=3
	  $finger_flag = 3;
	}
      } elsif ( $f1 < $f2) {
	if ( $f2 < $f3 ) {
	  # 1 < 2 < 3 - monotonic all different - pf=0
	  $finger_flag = 0;
	} elsif ( $f2 == $f3 ) {
	  if($c2 eq $c3) {
	    # 1 < 2 = 3 - monotonic some different - pf=1
	    $finger_flag = 1;
	  } else {
	    $finger_flag = 6;
	  }
	} elsif ( $f3 == $f1 ) {
	  # 1 = 3 < 2 - not monotonic some different - pf=2
	  $finger_flag = 4;
	} elsif ($f1 < $f3 && $f3 < $f2) {
	  # rolling
	  $finger_flag = 2;
	} else {
	  # not monotonic all different - pf=3
	  $finger_flag = 3;
	}
      } elsif( $f1 == $f2 ) {
	if ( $f2 < $f3 || $f3 < $f1 ) {
	  # 1 = 2 < 3 
	  # 3 < 1 = 2 - monotonic some different - pf=1
	  if($c1 eq $c2) {
	    $finger_flag = 1;
	  } else {
	    $finger_flag = 6;
	  }
	} elsif ( $f2 == $f3 ) {
	  if($c1 ne $c2 && $c2 ne $c3 && $c1 ne $c3) {
	    $finger_flag = 7;
	  } else {
	    # 1 = 2 = 3 - all same - pf=4
	    $finger_flag = 5;
	  }
	}
      }

    my $row_flag;

      my @dr    = sort { ($b->[0] <=> $a->[0]) || ($a->[1] <=> $b->[1]) } 
	map { [abs($_),$_] } ($row1-$row2,$row1-$row3,$row2-$row3);
      my ($drmax_abs,$drmax) = @{$dr[0]};
      if ($row1 < $row2) {
	if ($row3 == $row2) {
	  # 1 < 2 = 3 - downward with rep
	  $row_flag = 1;
	} elsif ($row2 < $row3) {
	  # 1 < 2 < 3 - downward progression
	  $row_flag = 4;
	} elsif ($drmax_abs == 1) {
	  $row_flag = 3;
	} else {
	  # all/some different - delta row > 1
	  if($drmax < 0) {
	    $row_flag = 7;
	  } else {
	    $row_flag = 5;
	  }
	}
    } elsif ($row1 > $row2) {
      if ($row3 == $row2) {
	# 1 > 2 = 3 - upward with rep
	$row_flag = 2;
      } elsif ($row2 > $row3) {
	# 1 > 2 > 3 - upward
	$row_flag = 6;
      } elsif ($drmax_abs == 1) {
	$row_flag = 3;
      } else {
	if($drmax < 0) {
	  $row_flag = 7;
	} else {
	  $row_flag = 5;
	}
      }
    } else {
      # 1=2
      if($row2 > $row3) {
	# 1 = 2 > 3 - upward with rep
	$row_flag = 2;
      } elsif ($row2 < $row3) {
	# 1 = 2 < 3 - downward with rep
	$row_flag = 1;
      } else {
	# all same
	$row_flag = 0;
      }
    }

    my $path_flag = "$hand_flag$row_flag$finger_flag";
    my $path_cost = 0;
    if($k4) {
      $path_cost = $k4 * ( $CONF{effort_model}{weight_param}{penalties}{path_offset} + $CONF{effort_model}{path_cost}{$path_flag});
    }

    $triad_effort += $path_cost;

    $CONF{debug} && printdebug(1,"triad $c1$c2$c3 keys $c1 $c2 $c3 effort $e1 $e2 $e3 hand $h1 $h2 $h3 row $row1 $row2 $row3 finger $f1 $f2 $f3 ph $hand_flag pr $row_flag pf $finger_flag path $path_flag $path_cost effort $triad_effort");

  } else {

    $CONF{debug} && printdebug(1,"triad $c1$c2$c3 keys $c1 $c2 $c3 effort $e1 $e2 $e3 row $row1 $row2 $row3 hand $h1 $h2 $h3 ph - pr - pf - path - 0 effort $triad_effort");

  }
  $effortlookup->{$i1}{$i2}{$i3} = $triad_effort;
  return $triad_effort;

}
}

################################################################
#
# Create an image of the keyboard
#
################################################################

sub draw_keyboard {

  my $keyboard   = shift;
  my $file       = shift;
  my $parameters = shift;

  $file = resolve_path($file);

  my $imageparams = $CONF{imageparamsetdef}{ $CONF{imageparamset} };
  my $imagedetail = $CONF{imagedetaildef}{ $CONF{imagedetaillevel} };

  my $keysize    = $imageparams->{keysize};
  my $charxshift = $imageparams->{xshift};
  my $ucyshift   = $imageparams->{ucyshift};
  my $lcyshift   = $imageparams->{lcyshift};
  my $keymargin  = $imageparams->{keyspacing} < 1 ? $imageparams->{keyspacing} * $keysize : $imageparams->{keyspacing};
  my $shadow     = $imageparams->{shadowsize};

  my $width = (2+int(@{$keyboard->{key}[1]}))*($keysize+$keymargin);
  my $height = int(@{$keyboard->{key}})*($keysize+$keymargin)+$imageparams->{bottommargin};

  my $im = GD::Image->new($width,$height);

  my $colors = allocate_colors($im);

  $im->fill(0,0,$colors->{ $imageparams->{color}{background} });
  $im->rectangle(0,0,$width-1,$height-1,$colors->{ $imageparams->{color}{imageborder} } ) if $imagedetail->{imageborder};

  # get list of all unique costs

  my %costs;
  map {$costs{$_->{effort}}++} map {@{$keyboard->{key}[$_]}} (0..@{$keyboard->{key}}-1);

  my @colors = split(/[\s,]+/,$imageparams->{color}{effort});

  # rank ordered list of costs
  my @costs_ranks = sort {$a <=> $b} keys %costs;

  my %costs_colors;
  my @keycolor_i = split(/[,\s]+/,$CONF{colors}{$imageparams->{color}{effort_color_i}});
  my @keycolor_f = split(/[,\s]+/,$CONF{colors}{$imageparams->{color}{effort_color_f}});
  for my $i (0..@costs_ranks-1) {
    my @rankcolor = map { scalar int(max($keycolor_i[$_] - $i/(@costs_ranks-1)*($keycolor_i[$_]-$keycolor_f[$_]))) } (0..2);
    my $colorname = "rankcolor$i";
    $colors->{$colorname} = $im->colorAllocate( @rankcolor );
    $costs_colors{$costs_ranks[$i]} = $colorname;
  }

  foreach my $row (0..@{$keyboard->{key}} - 1) {
    my $keyy = ($row+1)*$keymargin+$row*$keysize;
    foreach my $col (0..@{$keyboard->{key}[$row]}-1) {
      my @key_x0 = (0,
		    1.5*$keysize+$keymargin,
		    2*$keysize+$keymargin,
		    2*($keysize+$keymargin)+0.25*$keysize,
		   );
      my $key_x = (1+$col)*$keymargin + $keysize*($col) + $key_x0[$row];
      my $cost = $keyboard->{key}[$row][$col]->{effort};
      my $hand = $keyboard->{key}[$row][$col]->{hand};
      my ($keycolour,$keybordercolour);
      if($imagedetail->{effortcolor}) {
	$keycolour = $costs_colors{$cost};
      } else {
	$keycolour = $imageparams->{color}{key};
      }
      $keybordercolour = $imageparams->{color}{keyborder};
      $im->filledRectangle($key_x+$shadow,$keyy+$shadow,
			   $key_x+$keysize+$shadow,$keyy+$keysize+$shadow,
			   $colors->{ $imageparams->{color}{keyshadow}} ) if $imagedetail->{keyshadow};
      $im->filledRectangle($key_x,$keyy,
			   $key_x+$keysize,$keyy+$keysize,
			   $colors->{$keycolour}) if $imagedetail->{fillkey};
      $im->rectangle($key_x,$keyy,
		     $key_x+$keysize,$keyy+$keysize,
		     $colors->{$keybordercolour}) if $imagedetail->{keyborder};
      # keys
    my $char_lc = $keyboard->{key}[$row][$col]->{lc};
    my $char_uc = $keyboard->{key}[$row][$col]->{uc};
    my $label_x = $key_x + $charxshift;
    my $labely = $keyy + $ucyshift;

    rendertext(image=>$im,
	       font=>$CONF{font},
	       x=>$label_x,
	       y=>$labely,
	       text=>$char_uc,
	       size=>$imageparams->{fontsize},
	       angle=>0,
	       color=>$colors->{black}) if $imagedetail->{upcase} =~ /y/ 
		 || ( $char_uc !~ /[A-Z]/ && $imagedetail->{upcase} eq "some");;

    rendertext(image=>$im,
	       font=>$CONF{font},
	       x=>$label_x,
	       y=>$labely + $lcyshift,
	       text=>$char_lc,
	       size=>$imageparams->{fontsize},
	       angle=>0,
	       color=>$colors->{black}) if $imagedetail->{lowcase};
    
    rendertext(image=>$im,
	       font=>$CONF{font},
	       x=>$key_x+$keysize-16,
	       y=>$keyy+$keysize-5,
	       text=>sprintf("%.1f",$cost),
	       size=>6,
	       angle=>0,
	       color=>$colors->{black}) if $imagedetail->{effort};
    
    rendertext(image=>$im,
	       font=>$CONF{font},
	       x=>$key_x+$keysize-7,
	       y=>$keyy+$keysize-15,
	       text=> $hand?"R":"L",
	       size=>6,
	       angle=>0,
	       color=>$colors->{black}) if $imagedetail->{hand};

    rendertext(image=>$im,
	       font=>$CONF{font},
	       x=>$key_x+$keysize-7,
	       y=>$keyy+$keysize-25,
	       text=> $keyboard->{key}[$row][$col]{finger},
	       size=>6,
	       angle=>0,
	       color=>$colors->{black}) if $imagedetail->{finger};
    
    sub rendertext {
	my %args = @_;
	$args{text} = uc $args{text} if $imagedetail->{capitalize};
	$args{image}->stringFT(@args{qw(color font size angle x y text)});
    }
    
  }
}

  if($parameters && $imagedetail->{parameters}) {
    my @text;
    for my $parameter (sort keys %$parameters) {
      my $format;
      my $value = $parameters->{$parameter};
      if($value =~ /-?\d+\.\d+/) {
	$format = "%.5f";
      } else {
	$format = "%s";
      }
      push @text, sprintf("%s = $format",$parameter,$value);
    }
    rendertext(image=>$im,
	       font=>$CONF{fontc},
	       x=>5,
	       y=>$height - 10,
	       text=> join(" :: ", @text),
	       size=>10,
	       angle=>0,
	       color=>$colors->{black});
  }

  printdebug(1,"creating keyboard image",$file);
  open(IM,">$file") || die "cannot open png file $file for writing";
  binmode IM;
  print IM $im->png;
  close(IM);
}

sub allocate_colors {
  my $image = shift;
  my $colors;
  foreach my $color (keys %{$CONF{colors}}) {
    my $colorvalue = $CONF{colors}{$color};
    $colors->{$color} = $image->colorAllocate(split(/[, ]+/,$colorvalue));
  }
  return $colors;
}

=pod

=head2 read_document()

 $triads = read_document(); # create hashref to triad frequencies

 $triads->{aab} = frequency of aab;
 $triads->{abc} = frequency of abc;

Read a document from file and create a list of of character triads. Triads are overlapping (more on overlapping below) 3-character combinations. Each triad is stored along with the number of times it appears in the document. All triads are stored, including overlapping triads.

For example, if the document line is

  I am a very lazy dog with big ears.

Then the triads will be

  i am              iam
    am a            ama
     m a v          mav
       a ve         ave
         ver        ver
          ery       ery
           ry l     ryl
            y la    yla
  ...

and so on. Notice that spaces in the document are disregarded during construction of the triads.

Depending on the parse mode, the input document undergoes some transformation before triads are constructed. Each mode must be defined using a <mode_def> block. Three modes are defined and you can add more.

You can control how the triads are read by the <triad> block

  <triad>
  maxnum = 1000 # limit number of triads
  overlap = yes # if set to yes, a triad potentially begins at each character (triads overlap by maximum of 2 characters)
                # if set to no, triads abut 
  </triad>
 
=over

=item mode = perl

If the mode is set to "perl", then all comment lines are disregarded. Comments are identified by lines that begin with #.

=item mode = english

English mode removes all non-alphanumeric characters before constructing triads.

=item mode = letter

All non-letter characters are removed and remaining letters are switched to lower case.

=back

=cut 

sub read_document {

  # prepend script's path before relative paths to the input text
  my $file = shift;
  my $args = shift || {};
  $file = resolve_path($file);
  
  die "cannot find input document [$file]" unless -e $file;
  die "no permission to read input document [$file]" unless -r $file;
  
  my $keytriads;
  my $triads_count=0;
  
  open(INPUT,$file) || die "cannot open input document [$file]";
  
  my $charlist;

 READLINE: while(my $line = <INPUT>) {
    chomp $line;
    # remove spaces from text - assume that a space does not influence effort of typing    
    printdebug(2,"read_document","pre-processed", $line);
    $line =~ s/\s//g;
    next unless $line;
    if($CONF{mode_def}{$CONF{mode}}{force_case} eq "lc") {
      $line =~ tr/A-Z/a-z/;
    } elsif($CONF{mode_def}{$CONF{mode}}{force_case} eq "uc") {
      $line =~ tr/a-z/A-Z/;
    }
    if($CONF{mode_def}{$CONF{mode}}{reject_char_rx}) {
      (my $rx = $CONF{mode_def}{$CONF{mode}}{reject_char_rx}) =~ s/\/\//\//g;
      $line =~ s/$rx//g;
    }
    if($CONF{mode_def}{$CONF{mode}}{reject_line_rx}) {
      (my $rx = $CONF{mode_def}{$CONF{mode}}{reject_line_rx}) =~ s/\/\//\//g;
      if($line =~ /$rx/) {
	printdebug(2,"read_document","skipping line",$line);
	next READLINE;
      }
    }
    if($CONF{mode_def}{$CONF{mode}}{accept_line_rx}) {
      (my $rx = $CONF{mode_def}{$CONF{mode}}{accept_line_rx}) =~ s/\/\//\//g;
      if($line !~ /$rx/) {
	printdebug(2,"read_document","skipping line",$line);
	next READLINE;
      }
    }
    printdebug(2,"read_document","processed", $line);

    if($args->{charlist}) {
      while($line =~ /(.)/g) {
	push @$charlist, $1;
      }
    } else {
      while($line =~ /(...)/g) {
	my $triad = $1;
	if(substr($triad,0,1) eq substr($triad,1,1) && 
	   substr($triad,1,1) eq substr($triad,2,1) && 
	   ! $CONF{mode_def}{$CONF{mode}}{accept_repeats}) {
	  # identical triplet - skip if requested 
	  printdebug(3,"skipping repeated triad $triad");
	} else {
	  $keytriads->{$triad}++;
	  $triads_count++;
	  printdebug(3,"accepting $triad");
	  if($CONF{triads_max_num} && $triads_count >= $CONF{triads_max_num}) {
	    $CONF{debug} && printdebug(1,"limiting triads to $CONF{triads_max_num}");
	    last READLINE;
	  }
	}
	pos $line -= 2 if $CONF{triads_overlap};
      }
    }
  }
  return $charlist if $args->{charlist};
  printdebug(1,"found $triads_count triads (",int(keys %$keytriads),"unique)");
  # remove low-frequency triads
  if($CONF{triads_min_freq}) {
    for my $triad (keys %$keytriads) {
      if($keytriads->{$triad} < $CONF{triads_min_freq}) {
	$CONF{debug} && printdebug(1,"removing rare triad",$triad,"freq",$keytriads->{$triad});
	delete $keytriads->{$triad};
      }
    }
  }
  # limit number of triads
  if($CONF{triads_max_num}) {
    $CONF{debug} && printdebug(1,"limiting triads to $CONF{triads_max_num}");
    my @triads_by_freq = sort {$keytriads->{$b} <=> $keytriads->{$a}} keys %$keytriads;
    for my $i ($CONF{triads_max_num} .. @triads_by_freq-1) {
      my $triad_to_del = $triads_by_freq[$i];
      $CONF{debug} && printdebug(1,"removing triad",$triad_to_del,"freq",$keytriads->{$triad_to_del});
      delete $keytriads->{$triad_to_del};
    }
  }
  return $keytriads;
}

################################################################
#
# Dump the keyboard layout to STDOUT
#
################################################################

sub printkeyboard {
  my $keyboard = shift;
  return if $CONF{stdout_quiet};
  print "-"x60,"\n";
  foreach my $row (0..@{$keyboard->{key}}-1) {
    my $lcrow = join(" ",map {$_->{lc}} @{$keyboard->{key}[$row]});
    my $ucrow = join(" ",map {$_->{uc}} @{$keyboard->{key}[$row]});
    print $lcrow," "x(30-length($lcrow)),$ucrow,"\n";
  }
  print "-"x60,"\n";
}

################################################################
#
# Load effort of hitting each key.
#
# The values here represent the baseline effort. You can add
# a effort offset in create_keyboard(), effectively adding
# a constant to all effort values.
#
# Home row keys require the least effort and therefore have
# the lowest effort. Keys assigned to the pinky have a high
# effort, especially if hitting them also requires wrist
# rotation (e.g. z requires wrist rotation but [ does not).
#
################################################################

sub _parse_finger_distance {
  my $cost;
  my $row = 0;
  my $leaf = $CONF{effort_model}{finger_distance}{row};
  die "typing effort for keyboard rows not defined - you need <effort_row ROW> blocks" unless ref($leaf) eq "HASH";
  for my $row_idx (keys %$leaf) {
    my @keycost = split(" ",$leaf->{$row_idx}{effort});
    map { $cost->[$row_idx-1][ $_ ] = $keycost[$_] } (0..@keycost-1);
  }
  return $cost;
}

=pod

=head2 _parse_keyboard_layout

Parse the <keyboard><row> blocks to determine the location of keys on the keyboard.

Keyboard structure is stored as a hashref. Each key is stored by row/col position

  $keyboard->{key}[ROW][COL]{lc}     = lower case at ROW,COL
  $keyboard->{key}[ROW][COL]{uc}     = upper case at ROW,COL
  $keyboard->{key}[ROW][COL]{finger} = finger for hitting key at ROW,COL

  $keyboard->{map}{CHAR}{row}    = ROW for key CHAR
  $keyboard->{map}{CHAR}{col}    = COL for key CHAR
  $keyboard->{map}{CHAR}{case}   = CASE of key CHAR
  $keyboard->{map}{CHAR}{finger} = FINGER for hitting key CHAR

=cut

sub _parse_keyboard_layout {
  my $keyboardfile = shift;
  $keyboardfile = resolve_path($keyboardfile);
  die "cannot file keyboard definition - $keyboardfile" unless -e $keyboardfile;
  my %keyboard = _parse_conf_file($keyboardfile);
  die "no keyboard row definitions in keyboard layout" unless $keyboard{keyboard}{row};
  my $keyboard;
  for my $row_idx (sort {$a <=> $b} keys %{$keyboard{keyboard}{row}}) {
      die "no keys defined in keyboard layout for row $row_idx" unless $keyboard{keyboard}{row}{$row_idx}{keys};
      die "no fingers defined in keyboard layout for row $row_idx" unless $keyboard{keyboard}{row}{$row_idx}{fingers};
      my @keys    = split(" ",$keyboard{keyboard}{row}{$row_idx}{keys});
      my @fingers = split(" ",$keyboard{keyboard}{row}{$row_idx}{fingers});
      my $row = $row_idx - 1;
      my $col = 0;
      for my $key_idx (0..@keys-1) {
	  my $key = $keys[$key_idx];
	  my $finger = $fingers[$key_idx];
	  die "undefined finger assignment for keyboard layout for row,col $row_idx,$col" unless defined $finger;
	  my $hand   = $finger > 5 ? 1 : 0;
	  my @char = split(//,$key);
	  # letter keys have lowercase/uppercase characters on same key
	  if($char[0] =~ /[a-z]/i) {
	      $char[1] = uc $char[0];
	  } else {
	      if(@char != 2) {
		  die "keyboard layout broken - non-letter key $key must have have two characters";
	      }
	  }
	  printdebug(2,"_parse_keyboard_layout","keyassignment","lc",$char[0],"uc",$char[1],"to row,col",$row,$col);

	  @{$keyboard->{key}[$row][$col]}{qw(row col lc uc finger hand)} = ($row,$col,@char,$finger,$hand);

	  for my $case (0,1) {
	      @{$keyboard->{map}{$char[$case]}}{qw(row col case finger hand)} = ($row,$col,$case,$finger,$hand);
	  }

	  $col++;
      }
  }
  return $keyboard;
}

################################################################
#
# Parse the keyboard mask, defined in <mask_row N> blocks in the
# configuration file. Each row block should contain an entry
#
# mask = M M M M M ...
#
# where M = 1|0 depending on whether you want the key to be
# eligible (1) or not eligible (0) for remapping. There should
# be as many Ms in each row as there are columns on the keyboard
#
################################################################

sub _parse_mask {
  my $mask;
  for my $row (sort {$a <=> $b} keys %{$CONF{mask_row}}) {
    my $row_idx = $row - 1;
    my @row_mask = split(/[\s]+/,$CONF{mask_row}{$row}{mask});
    for my $col_idx (0..@row_mask-1) {
      $mask->[$row_idx][$col_idx] = $row_mask[$col_idx];
    }
  }
  return $mask;
}

=pod

=head2 make_relocatable_list()

  my $list = make_relocatable_list($mask)

Based on the key mask generated by _parse_mask(), this function returns a list of all keys that can be relocated. The list is a set of row,col pairs.

  $list = [ ... [row,col], [row,col], ... ]

=cut

sub make_relocatable_list {
  my $mask = shift;
  my $list;
  foreach my $row (0..@$mask-1) {
    foreach my $col (0..@{$mask->[$row]}-1) {
      if($mask->[$row][$col]) {
	push @$list, [$row,$col];
      }
    }
  }
  return $list;
}

=pod

=head2 create_keyboard()

  my $keyboard = create_keyboard();

Parses the keyboard layout and creates an array that keeps track of the keys, their positions, character assignments and typing effort. The keyboard array is indexed by row and column of the key and contains a hash

  $keyboard->{key}[row][col]
                           {lc}
                           {uc}
                           {row}
                           {col}
                           {effort}

The keyboard layout is read from the <keyboard><row> blocks. The effort in the {key} part of the keyboard object is the canonical effort for the row,col combination as defined in <effort_row> plus any baseline and hand penalties.

The keymap hash is a direct mapping between a character and its position and hand assignment on the keyboard

  $keyboard->{map}{CHAR}
                       {row}
                       {col}
                       {hand}
                       {effort}

The effort in the {map} part of the keyboard object is the effort for the character, based on its row,col combination and includes the shift penalty.

For the standard qwerty layout, look at the keyboard you're using right now (true for >99% of typists). For Dvorak layout, see http://www.mwbrooks.com/dvorak.

=cut

sub create_keyboard {

  my $keyboard_type = shift;
  my $keyboard      = _parse_keyboard_layout($keyboard_type);
  my $cost          = _parse_finger_distance();

  # merge the cost into the keyboard hash 

  my $keyidx=0;
  for my $row_idx (0..@{$keyboard->{key}}-1) {
    for my $col_idx (0..@{$keyboard->{key}[$row_idx]}-1) {
      
      # this is the canonical cost of typing a key defined in the <effort_row> blocks
      
      my $base_effort = $cost->[$row_idx][$col_idx];
      my $finger     = $keyboard->{key}[$row_idx][$col_idx]{finger};
      my $hand       = $keyboard->{key}[$row_idx][$col_idx]{hand};
      my $row        = $row_idx;
      
      $keyboard->{key}[$row_idx][$col_idx]{idx} = $keyidx;
      
      die "create_keyboard - there is a key defined at row,col $row_idx,$col_idx but no associated effort in the effort file" unless defined $base_effort;
      die "create_keyboard - there is a key defined at row,col $row_idx,$col_idx but no finger assignment" unless defined $finger;
      die "create_keyboard - there is a key defined at row,col $row_idx,$col_idx but no hand assignment" unless defined $hand;
      
      my $hand_penalty   = $CONF{effort_model}{weight_param}{penalties}{hand}{ $hand ? "right" : "left" };
      my $finger_penalty = $finger < 5 ? 
	(split(/[,\s]+/,$CONF{effort_model}{weight_param}{penalties}{finger}{left}))[$finger] : 
	  (split(/[,\s]+/,$CONF{effort_model}{weight_param}{penalties}{finger}{right}))[$finger-5];
      my $row_penalty    = $CONF{effort_model}{weight_param}{penalties}{row}{$row};
      
      my $total_penalty  = 
	$CONF{effort_model}{weight_param}{penalties}{default} + 
	  $CONF{effort_model}{weight_param}{penalties}{weight}{hand}*$hand_penalty +
	    $CONF{effort_model}{weight_param}{penalties}{weight}{row}*$row_penalty +
	      $CONF{effort_model}{weight_param}{penalties}{weight}{finger}*$finger_penalty;
      
      my $total_effort  = $base_effort + $total_penalty;
	  
      for my $case (0,1) {
	$CONF{debug} && printdebug(1,
				   "create_keyboard","effortassign",
				   "key",$keyboard->{key}[$row_idx][$col_idx]{ $case ? "uc" : "lc"},
				   "at row,col",$row_idx,$col_idx,
				   "hand",$hand,
				   "row",$row,
				   "finger",$finger,
				   "base_effort",$base_effort,
				   "base_penalty",$CONF{effort_model}{weight_param}{penalties}{default},
				   "hand_penalty",$CONF{effort_model}{weight_param}{penalties}{weight}{hand},$hand_penalty,
				   "row_penalty",$CONF{effort_model}{weight_param}{penalties}{weight}{row},$row_penalty,
				   "finger_penalty",$CONF{effort_model}{weight_param}{penalties}{weight}{finger},$finger_penalty,
				   "total_penalty",$total_penalty,
				   "total_effort",$total_effort);
      }
      
      $keyboard->{key}[$row_idx][$col_idx]{effort} = $total_effort;
      
      $keyboard->{map}{ $keyboard->{key}[$row_idx][$col_idx]{"uc"} }{effort} = $total_effort;
      $keyboard->{map}{ $keyboard->{key}[$row_idx][$col_idx]{"lc"} }{effort} = $total_effort;
      $keyboard->{map}{ $keyboard->{key}[$row_idx][$col_idx]{"uc"} }{idx}    = $keyidx;
      $keyboard->{map}{ $keyboard->{key}[$row_idx][$col_idx]{"lc"} }{idx}    = $keyidx;
      
      $keyidx++;
    }
  }
  return $keyboard;
}

################################################################

################################################################
#
# Housekeeeeeping
#
################################################################

sub validateconfiguration {

}

sub populateconfiguration {
  foreach my $key (keys %OPT) {
    $CONF{$key} = $OPT{$key};
  }

  # any configuration fields of the form __XXX__ are parsed and replaced with eval(XXX). The configuration
  # can therefore depend on itself.
  #
  # flag = 10
  # note = __2*$CONF{flag}__ # would become 2*10 = 20

  _parse_conf_data(\%CONF);

}

sub _parse_conf_data {
  my $conf = shift;
  for my $key (keys %$conf) {
    my $value = $conf->{$key};
    if(ref($value) eq "HASH") {
      _parse_conf_data($value);
    } else {
      while($value =~ /__([^_].+?)__/g) {
        my $source = "__" . $1 . "__";
        my $target = eval $1;
        $value =~ s/\Q$source\E/$target/g;
      }
      if($value =~ /^eval\((.*)\)$/) {
        $conf->{$key} = eval $1;
      } else {
        $conf->{$key} = $value;
      }
    }
  }
}

sub _parse_conf_file {
  my $file = shift;
  if(-e $file && -r _) {
    my $conf_obj = new Config::General(-ConfigFile=>$file,
				       -AllowMultiOptions=>1,
				       -LowerCaseNames=>1,
				       -IncludeRelative=>1,
				       -ConfigPath=>[ "$FindBin::RealBin/../etc" ],
				       -AutoTrue=>1);
    return $conf_obj->getall;
  } else {
    die "cannot find or read configuration file $file";
  }
}

sub loadconfiguration {
  my $file = shift;
  my ($scriptname) = fileparse($0);
  $file ||= "$scriptname.conf";
  my @confpath = ("$FindBin::RealBin/../etc/",
		  "$FindBin::RealBin/etc/",
		  "$FindBin::RealBin/",
		  "$ENV{HOME}/.carpalx/etc",
		  "$ENV{HOME}/.carpalx");
  if(-e $file && -r _) {
    # great the file exists
  } else {
    my $found;
    for my $path (@confpath) {
      my $tryfile = "$path/$file";
      if (-e $tryfile && -r _) {
	$file = $tryfile;
	$found=1;
	last;
      }
    }
    return undef unless $found;
  }
  my $conf = new Config::General(-ConfigFile=>$file,
				 -AllowMultiOptions=>"yes",
				 -IncludeRelative=>"yes",
				 -LowerCaseNames=>1,
				 -ConfigPath=>\@confpath,
				 -AutoTrue=>1);
  %CONF = $conf->getall;
  $OPT{configfile} = $file;
  ($CONF{configfile}) = grep($_ =~ /$file$/, $conf->files());
  if($CONF{configfile} !~ /^\//) {
    $CONF{configfile} = sprintf("%s/%s",getcwd,$CONF{configfile});
  }
  $CONF{configdir} = dirname($CONF{configfile});
}

################################################################
#
# $CONF{debug} && printdebug(1,"this is level 1 debug");
# $CONF{debug} && printdebug(2,"this is level 2 debug");
# ...
#
################################################################

sub printdebug {
  my $level = shift;
  if($CONF{debug} >= $level) {
    printinfo("debug",@_);
  }
}

sub printinfo {
  print join(" ",@_),"\n";
}