#!/usr/bin/perl -w
use strict;
use Tk;
use Tk::FileSelect;
use Tk::Balloon;


=head1 tksort -- A Sort Demonstration Program

tksort was inspired by the book I<Mastering Algorithms with Perl>.  It is 
designed to graphically demonstrate the operation of several
standard sorting algorithms.  Additionally, tksort allows the user to add
his or her own sorts to be profiled alongside the standard sorts.  

User sorts are added via the "register" class method of the GraphicSort 
class.  By default, compares and moves are tracked on user sorts, but 
facilities are provided to allow the user to add visual cues to the sort 
canvas, or to add variables to be tracked along with Moves and Compares.

The "register" method, as well as other methods, are described in more 
detail in the following sections.

=cut


# The shuffle subroutine is lifted directly from Abigail's 
# Algorithm::Numerical::Shuffle module.  This was done strictly
# for the convenience of the user of tksort, so they wouldn't have
# to download and install A::N::S to use tksort.  Many thanks to 
# Abigail.

sub shuffle {
    return @_ if !@_ || ref $_ [0] eq 'ARRAY' && !@$_ [0];
    my $array = @_ == 1 && ref $_ [0] eq 'ARRAY' ? shift : [@_];
    for (my $i = @$array; -- $i;) {
        my $r = int rand ($i + 1);
       ($array -> [$i], $array -> [$r]) = ($array -> [$r], $array -> [$i]);
    }
    wantarray ? @$array : $array;
}


# Sortable objects are what go in a SortArray.  The objects themselves
# are read-only.  The value is passed in as an extra parameter with the
# tie.  Any attempt to modify the value results in a croak.

package Sortable;
use Carp;

sub new {
  my ($class, $value) = @_;
  bless {Value     => $value, 
         Rank      => undef,  
         Index     => undef,
         Duplicate => 0}, $class
}

sub getvalue {
  $_[0]{Value};
}

sub setindex {
  $_[0]{Index} = $_[1];
}

sub getindex {
  $_[0]{Index};
}

sub setrank {
  $_[0]{Rank} = $_[1];
}

sub getrank {
  $_[0]{Rank};
}

sub setduplicate {
  $_[0]{Duplicate} = $_[1];
}

sub getduplicate {
  $_[0]{Duplicate};
}

sub numcmp {
  my ($op1, $op2, $reversed) = @_;
  ($op1, $op2) = ($op2, $op1) if $reversed;
  print 'COMPARE ', $op1->getindex, ' ', $op2->getindex, "\n";
  $op1->getvalue <=> $op2->getvalue;
}

sub strcmp {
  my ($op1, $op2, $reversed) = @_;
  ($op1, $op2) = ($op2, $op1) if $reversed;
  print 'COMPARE ', $op1->getindex, ' ', $op2->getindex, "\n";
  $op1->getvalue cmp $op2->getvalue;
}

use overload '""'   => \&getvalue,
             '0+'   => \&getvalue,
             'bool' => \&getvalue,
             '<=>'  => \&numcmp,
             'cmp'  => \&strcmp;



# A SortArray is an array of Sortable objects.  This class is meant to 
# be tied to an array of integers or strings.  This is an internal class
# to tksort.  The user never needs to know it's here.

package SortArray;
use Carp;

my $toprank;

sub presort {
  # Use a bubble sort to pre-sort the data so I can set the ranks
  my ($self, $sorttype) = @_;
  my @sorted = @$self;
  my $rank = -1;
  my ($i, $j, $start) = ($#sorted, undef,0);
  my $compare = $sorttype eq 'string' ? sub { $_[0] gt $_[1] }
                                      : sub { $_[0] > $_[1] };
  while ( 1 ) {
        my $new_start;    # The new start index of the bubbling scan.
        my $new_end = 0;  # The new end index of the bubbling scan.

        for ( my $j = $start || 1; $j <= $i; $j++ ) {
            if ( $compare->($sorted[$j-1]->getvalue,$sorted[$j]->getvalue) ) {
                @sorted[$j,$j-1] = @sorted[$j-1,$j];
                $new_end   = $j - 1;
                $new_start = $j - 1 unless defined $new_start;
            }
        }
        last unless defined $new_start; # No swaps: we're done.
        $i     = $new_end;
        $start = $new_start;
  }
  my $last;
  foreach (@sorted) {
      $_->setrank(++$rank);
      if (defined $last && $last->getvalue eq $_->getvalue) {
        $_->setduplicate(1);
        $last->setduplicate(1);
      }
      $last = $_;
  }
  $toprank = $rank;
}


# When an array is tied to SortArray, the syntax is:
#
#   tie @newarray, 'SortArray', 'string', @stringdata;
#
# or 
#
#   tie @newarray, 'SortArray', 'numeric', @numericdata;

sub TIEARRAY {
  my ($class, $sorttype, @elements) = @_;
  my @impl;
  foreach (@elements) {
    my $thingy = Sortable->new($_, \@impl);
    $thingy->setindex(scalar @impl);
    push @impl, $thingy;
  }
  my $ref = bless \@impl, $class;
  $ref->presort($sorttype);
  $ref;
}

sub FETCH {
  my ($impl, $index) = @_;
  $impl->[$index];
}

sub STORE {
  my ($impl, $index, $newval) = @_;
  croak "Invalid data:  item to be stored is not of class Sortable"
    unless ref $newval eq 'Sortable';
  croak "The size of a SortArray may not be altered"
    if $index > $#{$impl};
  $impl->[$index] = $newval;
  print(join(' ', 'MOVE', $newval->getindex, $index, 
             $newval->getrank, $newval->getduplicate, $newval->getvalue), 
        "\n");
  $newval->setindex($index);
}

sub FETCHSIZE {
  my ($impl) = @_;
  scalar @$impl;
}

sub PUSH {croak "The size of a SortArray may not be altered"}
sub POP {croak "The size of a SortArray may not be altered"}
sub SHIFT {croak "The size of a SortArray may not be altered"}
sub UNSHIFT {croak "The size of a SortArray may not be altered"}
sub STORESIZE {croak "The size of a SortArray may not be altered"}
sub EXTEND {croak "The size of a SortArray may not be altered"}
sub CLEAR {croak "The size of a SortArray may not be altered"}
sub SPLICE {croak "The size of a SortArray may not be altered"}

sub DESTROY {}


# A TrackableVariable is one that the user has passed to the
# track_variable function.

package TrackableVariable;


sub TIESCALAR {
  my ($class, $key, $value) = @_;
  bless {Key => $key, Value => $value}, $class;
}


sub FETCH {
  my ($impl) = @_;
  return $impl->{Value};
}


sub STORE {
  my ($impl, $newvalue) = @_;
  $impl->{Value} = $newvalue;
  print "TRACKVAR $impl->{Key} $newvalue\n";
}


sub DESTROY {
}
  


package GraphicSort;

my %sortsubs;
my @kids;
my $waittime = 1;
my $middleframe;
my $sorttype = 'numeric';
my ($data_fileselect, $sort_fileselect);
my $error_dialog;

my $dataorder = 'random';
my $howmany = 20;
my $pause_when_done = 1;
my $pause_on_request = 1;
my @data;
my %rawdata = (numeric => [], string => []);
my $balloon;
my %balloondata;

my $message = '';


_setdata();

my $size = 3;
my ($canvas_width, $canvas_height);
my $v_pad = 8;

my $mw = MainWindow->new();

# Internal subroutines

my $mode = 'reset';  # can be 'reset', 'running', 'stopped', or 'finished'
my @valid_modes = qw/reset running stopped finished/;
my %mode_buttons;

sub _change_mode {
  $mode = shift;
  foreach my $key (keys %mode_buttons) {
    if ($mode_buttons{$key}{$mode}) {
      $mode_buttons{$key}{Button}->configure(-state => 'normal') 
    }
    else {
      $mode_buttons{$key}{Button}->configure(-state => 'disabled') 
    }
  }
}

sub _register_button {
  my ($button, @modes) = @_;
  $mode_buttons{$button} =  {Button => $button};
  @{$mode_buttons{$button}}{@valid_modes} = (0) x @valid_modes;
  @{$mode_buttons{$button}}{@modes} = (1) x @modes;
  if ($mode_buttons{$button}{$mode}) {
    $mode_buttons{$button}{Button}->configure(-state => 'normal') 
  }
  else {
    $mode_buttons{$button}{Button}->configure(-state => 'disabled') 
  }
}

sub _unregister_button {
  my ($button) = @_;
  delete $mode_buttons{$button};
}



sub _move {
  my ($key, $r1, $r2, $rank, $duplicate, $value) = @_;
  $sortsubs{$key}{Moves}++;
  my $canvas = $sortsubs{$key}{Canvas};
  my @coords_dot1 = $canvas->coords($sortsubs{$key}{Dots}[$r1]);
  my @coords_dot2 = $canvas->coords($sortsubs{$key}{Dots}[$r2]);
  my @coords_bar0 = $canvas->coords($sortsubs{$key}{Bars}[0]);
  my @coords_bar1 = $canvas->coords($sortsubs{$key}{Bars}[1]);
  $canvas->coords($sortsubs{$key}{Bars}[0], 
                  $coords_dot1[0], $coords_bar0[1], 
                  $coords_dot1[2], $coords_bar0[3]);
  $canvas->itemconfigure($sortsubs{$key}{Bars}[0], 
                         -outline => 'green', -fill => 'green');
  $balloondata{$canvas}{$sortsubs{$key}{Bars}[0]} = 'Move indicator';
  $canvas->coords($sortsubs{$key}{Bars}[1], 
                  $coords_dot2[0], $coords_bar1[1], 
                  $coords_dot2[2], $coords_bar1[3]);
  $canvas->itemconfigure($sortsubs{$key}{Bars}[1], 
                         -outline => 'green', -fill => 'green');
  $balloondata{$canvas}{$sortsubs{$key}{Bars}[1]} = 'Move indicator';
  $canvas->coords($sortsubs{$key}{Dots}[$r2],
                  $coords_dot2[0],
                  $canvas_height - $size * ($rank+1) - $v_pad - 1,
                  $coords_dot2[2],
                  $canvas_height - $size * $rank - 1 - $v_pad - 1);
  my $color = $duplicate ? 'magenta' : 'black';
  $canvas->itemconfigure($sortsubs{$key}{Dots}[$r2],
                         -outline => $color, -fill => $color);
  $balloondata{$canvas}{$sortsubs{$key}{Dots}[$r2]} = "Value: $value\nRank: $rank";
  $mw->update;
}

sub _compare {
  my ($key, $r1, $r2) = @_;
  $sortsubs{$key}{Compares}++;
  my $canvas = $sortsubs{$key}{Canvas};
  my @coords_dot1 = $canvas->coords($sortsubs{$key}{Dots}[$r1]);
  my @coords_dot2 = $canvas->coords($sortsubs{$key}{Dots}[$r2]);
  my @coords_bar0 = $canvas->coords($sortsubs{$key}{Bars}[0]);
  my @coords_bar1 = $canvas->coords($sortsubs{$key}{Bars}[1]);
  $canvas->coords($sortsubs{$key}{Bars}[0], 
                  $coords_dot1[0], $coords_bar0[1], 
                  $coords_dot1[2], $coords_bar0[3]);
  $canvas->coords($sortsubs{$key}{Bars}[1], 
                  $coords_dot2[0], $coords_bar1[1], 
                  $coords_dot2[2], $coords_bar1[3]);
  $canvas->itemconfigure($sortsubs{$key}{Bars}[0], 
                         -outline => 'yellow', -fill => 'yellow');
  $canvas->itemconfigure($sortsubs{$key}{Bars}[1], 
                         -outline => 'yellow', -fill => 'yellow');
  $balloondata{$canvas}{$sortsubs{$key}{Bars}[0]} = 'Comparison indicator';
  $balloondata{$canvas}{$sortsubs{$key}{Bars}[1]} = 'Comparison indicator';
  $mw->update;
}

sub _highlight {
  my ($key, $bar, $color, $index, $msg) = @_;
  my $canvas = $sortsubs{$key}{Canvas};
  my @coords_dot = $canvas->coords($sortsubs{$key}{Dots}[$index]);
  my @coords_bar = $canvas->coords($sortsubs{$key}{Bars}[$bar]);
  $canvas->coords($sortsubs{$key}{Bars}[$bar], 
                  $coords_dot[0], $coords_bar[1], 
                  $coords_dot[2], $coords_bar[3]);
  $canvas->itemconfigure($sortsubs{$key}{Bars}[$bar], 
                         -outline => $color, -fill => $color);
  $balloondata{$canvas}{$sortsubs{$key}{Bars}[$bar]} = $msg;
  $mw->update;
}

sub _prepare_canvas_frame {
  my $name = shift;
  my @lines;
  my $canvas;
  if (exists $sortsubs{$name}{CanvasFrame}) {
    $canvas = $sortsubs{$name}{Canvas};
    $canvas->configure(-background => 'white');
    GraphicSort::_blanklines($name);
    $canvas->delete(@{$sortsubs{$name}{Dots}}, @{$sortsubs{$name}{Bars}});
    @{$sortsubs{$name}{Dots}} = @{$sortsubs{$name}{Bars}} = ();
  }
  else {
    my $canvasframe = $middleframe->Frame(-relief      => 'groove',
                                          -borderwidth => 2);
    $sortsubs{$name}{CanvasFrame} = $canvasframe;

    $canvasframe->Label(-text => $name)
                ->grid(-column     => 0, 
                       -row        => 0, 
                       -columnspan => 2);
    $canvas = $canvasframe->Canvas(-background => 'white')
                          ->grid(-column     => 0, 
                                 -row        => 1, 
                                 -columnspan => 2);
;
    $sortsubs{$name}{Canvas} = $canvas;

    $canvasframe->Label(-text => 'Compares')
                ->grid(-column => 0, -row => 2, -sticky => 'w');
    $canvasframe->Label(-text => 'Moves')
                ->grid(-column => 0, -row => 3, -sticky => 'w');
    $canvasframe->Label(-width => 5, -anchor => 'e',
                        -textvariable => \$sortsubs{$name}{Compares})
                ->grid(-column => 1, -row => 2, -sticky => 'e');
    $canvasframe->Label(-width => 5, -anchor => 'e',
                        -textvariable => \$sortsubs{$name}{Moves})
                ->grid(-column => 1, -row => 3, -sticky => 'e');
    $sortsubs{$name}{LastRow} = 3;
  }

  $sortsubs{$name}{Compares}  = 0;
  $sortsubs{$name}{Moves}     = 0;
  $sortsubs{$name}{GrayedOut} = 0;
  foreach my $key (keys %{$sortsubs{$name}{TrackVariables}}) {
    $sortsubs{$name}{TrackVariables}{$key}{Value} = 
      $sortsubs{$name}{TrackVariables}{$key}{InitValue};
  }
  
  $canvas_width = @data * $size + 6;
  $canvas_height = ($toprank + 1) * $size + $v_pad * 2 + 1;
  $canvas->configure(-height => $canvas_height, -width => $canvas_width);

  # 4 highlight bars... 2 for compares and moves and 2 for the user.  The
  # two for the user extend above and below the other two by $v_pad pixels.
  # I unshift them so that the ones in the back are at the end of the array.
  unshift @{$sortsubs{$name}{Bars}}, 
          $canvas->createRectangle(0, 0, $size - 1, $v_pad - 1,
                                   -outline => 'white', 
                                   -fill => 'white');
  unshift @{$sortsubs{$name}{Bars}}, 
          $canvas->createRectangle(0, $canvas_height - $v_pad, 
                                   $size - 1, $canvas_height - 1,
                                   -outline => 'white', 
                                   -fill => 'white');
  foreach (1..2) {
    unshift @{$sortsubs{$name}{Bars}}, 
            $canvas->createRectangle(0, $v_pad, $size-1, 
                                     $canvas_height - $v_pad - 1,
                                     -outline => 'white', 
                                     -fill => 'white');
  }

  foreach my $bar (@{$sortsubs{$name}{Bars}}) {
    $balloondata{$canvas}{$bar} = '';
  }

  my $i = 0;
  foreach (@data) {
    my $color = $_->getduplicate ? 'magenta' : 'black';
    push @{$sortsubs{$name}{Dots}}, 
         $canvas->createRectangle(
           $i * $size + 5,
           $canvas_height - $size * ($_->getrank()+1) - $v_pad - 1,
           ($i + 1) * $size - 1 + 5,
           $canvas_height - $size * $_->getrank() - 1 - $v_pad - 1,
           -outline => $color, 
           -fill => $color);
    $balloondata{$canvas}{$sortsubs{$name}{Dots}[-1]} = "Value: $_\nRank: " . 
                                                        $_->getrank;
    $i++;
  }
  $balloon->attach($canvas, -msg => $balloondata{$canvas});
}


sub _refresh_canvas_frames {
  foreach my $name (keys %sortsubs) {
    _prepare_canvas_frame($name);
  }
}

sub _blanklines {
  my ($key) = @_;
  my $canvas = $sortsubs{$key}{Canvas};
  foreach my $bar (0..3) {
    $canvas->itemconfigure($sortsubs{$key}{Bars}[$bar], 
                           -outline => 'white', -fill => 'white');
  }
}

sub _killkids {
  foreach my $key (@kids) {
    my $fh = $sortsubs{$key}{FH};
    kill 9, $sortsubs{$key}{PID};
    close $fh;
    delete $sortsubs{$key}{PID};
    #GraphicSort::_blanklines($key);
  }
  @kids = ();
}

my %filehandles;
my $stop = 0;
sub _run {
  return unless @data;
  _change_mode('running');
  foreach my $key (keys %sortsubs) {
    if ($sortsubs{$key}{Run} && !exists $sortsubs{$key}{PID}) {
      local *FH;
      my $pid = $sortsubs{$key}{PID} = open(FH, "-|");
      if ($pid) {
        $sortsubs{$key}{FH} = *FH;
        push(@kids, $key);
      }
      elsif (defined $pid) {
        &{$sortsubs{$key}{$sorttype}}(\@data);
        print "DONE\n" while 1;
      }
      else {
        die "Couldn't start child: $!";
      }
    }
  }
  my $done = 0;
  do {
    $done = 1;
    $message = '';
    foreach my $key (@kids) {
      my $fh = $sortsubs{$key}{FH};
      my $line = <$fh>;
      unless (defined $line) {
        _killkids();
        die "Fatal error in child process";
      }
      chomp $line;
      if ($line eq 'DONE') {
        unless ($sortsubs{$key}{GrayedOut}) {
          my $canvas = $sortsubs{$key}{Canvas};
          $canvas->configure(-background => 'grey');
          foreach my $i (0..3) {
            $canvas->itemconfigure($sortsubs{$key}{Bars}[$i], 
                                   -outline => 'grey', -fill => 'grey');
            $balloondata{$canvas}{$sortsubs{$key}{Bars}[$i]} = '';
          }
          if ($pause_when_done) {
            $stop = 1;
            $message = "$key finished.";
          }
        }
        $sortsubs{$key}{GrayedOut} = 1;
        next;
      }
      $done = 0;
      my ($cmd, $therest) = split(' ', $line, 2);
      if ($cmd eq 'COMPARE') {
        my ($x, $y) = split(' ', $therest);
        GraphicSort::_compare($key, $x, $y);
      }
      elsif ($cmd eq 'MOVE') {
        my ($x, $y, $rank, $duplicate, $value) = split(' ', $therest);
        GraphicSort::_move($key, $x, $y, $rank, $duplicate, $value);
      }
      elsif ($cmd eq 'HIGHLIGHT') {
        my ($bar, $color, $index, $msg) = split(' ', $therest, 4);
        GraphicSort::_highlight($key, $bar, $color, $index, $msg);
        redo;
      }
      elsif ($cmd eq 'ERROR') {
        $error_dialog->configure(-text => $therest);
        $error_dialog->Show;
      }
      elsif ($cmd eq 'PAUSE') {
        if ($pause_on_request) {
          $stop = 1;
          $message = "Paused by $key";
        }
      }
      elsif ($cmd eq 'TRACKVAR') {
        my ($varname, $value) = split(' ', $therest, 2);
        $sortsubs{$key}{TrackVariables}{$varname}{Value} = $value;
        redo;
      }
      else {
        $error_dialog->configure(-text => "Unexpected command '$cmd'.");
        $error_dialog->Show;
      }
    }
    select undef, undef, undef, 1-$waittime;
  } until ($done || $stop);
  if ($done) {
    _killkids();
    _change_mode('finished');
  }
  else {
    _change_mode('stopped');
  }
}


sub _arrange_canvasframes {
  my ($row, $col) = (0, 0);
  foreach my $key (keys %sortsubs) {
    if ($sortsubs{$key}{Run}) {
      $sortsubs{$key}{CanvasFrame}->grid(-row => $row, 
                                         -column => $col++,
                                         -sticky => 'n');
      if ($col > 3) {
        $row++;
        $col = 0;
      }
    }
    else {
      $sortsubs{$key}{CanvasFrame}->gridForget;
    }
  }
}


sub _resetbutton {
  &_killkids;
  _change_mode('reset');
  _refresh_canvas_frames();
}


sub _setdata {
  @{$rawdata{string}} = ();
  @{$rawdata{numeric}} = (0..$howmany-1);
  @{$rawdata{numeric}} = reverse @{$rawdata{numeric}} 
    if $dataorder eq 'descending';
  @{$rawdata{numeric}} = main::shuffle(@{$rawdata{numeric}}) 
    if $dataorder eq 'random';
  foreach (@{$rawdata{numeric}}) {
    my $value = $_;
    my $length = int($howmany / 26) + 1;
    my $str = '';
    while ($value) {
      $str = chr(65 + $value % 26) . $str;
      $value = int($value / 26);
    }
    $str = 'A' . $str while length($str) < $length;
    push @{$rawdata{string}}, $str;
  }
  tie @data, 'SortArray', $sorttype, @{$rawdata{$sorttype}};
  _refresh_canvas_frames();
}


sub _make_duplicates {
  foreach (1..@{$rawdata{$sorttype}}/10) {
    my $i = rand(@{$rawdata{$sorttype}});
    my $j = rand(@{$rawdata{$sorttype}});
    $rawdata{numeric}[$i] = $rawdata{numeric}[$j];
    $rawdata{string}[$i] = $rawdata{string}[$j];
  }
  tie @data, 'SortArray', $sorttype, @{$rawdata{$sorttype}};
  _refresh_canvas_frames();
}


sub _change_sorttype {
  foreach my $key (keys %sortsubs) {
    if (exists $sortsubs{$key}{$sorttype}) {
      _register_button($sortsubs{$key}{Checkbutton}, 'reset');
    }
    else {
      $sortsubs{$key}{Run} = 0;
      _register_button($sortsubs{$key}{Checkbutton});
    }
  }
  tie @data, 'SortArray', $sorttype, @{$rawdata{$sorttype}};
  _refresh_canvas_frames();
  _arrange_canvasframes();
}


sub _load_sort {
  my $filename = $sort_fileselect->Show;
  return unless defined $filename;
  my $retval = do $filename;
  if (!defined $retval) {
    if ($! ne '') {
      $error_dialog->configure(-text => "Couldn't open $filename: $!");
      $error_dialog->Show;
      return;
    }
    elsif ($@ ne '') {
      $error_dialog->configure(-text => "Couldn't compile $filename: $@");
      $error_dialog->Show;
      return;
    }
  }
}


sub _load_data {
  my $filename = $data_fileselect->Show;
  return unless defined $filename;
  unless (open(INFILE, $filename)) {
    $error_dialog->configure(-text => "Couldn't open $filename: $!");
    $error_dialog->Show;
    return;
  }
  my @filedata = <INFILE>;
  chomp @filedata;
  @{$rawdata{numeric}} = @{$rawdata{string}} = ();
  $sorttype = 'numeric';
  foreach (@filedata) {
    unless (/^\s*\d+\s*$/) {
      $sorttype = 'string';
      last;
    }
  }
  if ($sorttype eq 'numeric') {
    @{$rawdata{numeric}} = @filedata;
  }
  else {
    @{$rawdata{string}} = @filedata;
  }
  tie @data, 'SortArray', $sorttype, @{$rawdata{$sorttype}};
  _change_sorttype();
  _refresh_canvas_frames();
}


sub _save_data {
  my $filename = $data_fileselect->Show;
  return unless defined $filename;
  unless (open(OUTFILE, ">$filename")) {
    $error_dialog->configure(-text => "Couldn't write $filename: $!");
    $error_dialog->Show;
    return;
  }
  foreach my $item (@data) {
    print OUTFILE (($sorttype eq 'numeric' ? +$item : "$item"), "\n");
  }
  close OUTFILE;
}

my $sort_data_window;
sub _configure_sort_data {
  return if defined $sort_data_window;
  $sort_data_window = $mw->Toplevel(-title => 'Config');
  my $howmanyframe = $sort_data_window->Frame()->pack;
  $howmanyframe->Entry(-width => 3, -textvariable => \$howmany)
               ->pack(-side => 'left');
  $howmanyframe->Label(-text => 'Items')
               ->pack(-side => 'left');
  $sort_data_window->Radiobutton(-variable => \$dataorder, 
                                 -value    => 'random',
                                 -text     => 'Random')
                   ->pack(-anchor => 'w');
  $sort_data_window->Radiobutton(-variable => \$dataorder, 
                                 -value    => 'ascending',
                                 -text     => 'Ascending')
                   ->pack(-anchor => 'w');
  $sort_data_window->Radiobutton(-variable => \$dataorder, 
                                 -value    => 'descending',
                                 -text     => 'Descending')
                   ->pack(-anchor => 'w');
  my $setdatabutton = $sort_data_window->Button(-text => 'Set', 
                                                -command => \&_setdata)
                                       ->pack(-fill => 'x');
  _register_button($setdatabutton, 'reset');
  my $duplicatesbutton = $sort_data_window->Button(-text => 'Duplicates', 
                                                   -command => \&_make_duplicates)
                                          ->pack(-fill => 'x');
  _register_button($duplicatesbutton, 'reset');
  $sort_data_window->Button(-text    => 'Dismiss', 
                            -command => sub {$sort_data_window->destroy;
                                             undef $sort_data_window;
                                             _unregister_button($setdatabutton);
                                             _unregister_button($duplicatesbutton)})
                   ->pack(-fill => 'x');
}



$mw->title('Tk Sort');
my $w_menu = $mw->Frame(-relief => 'raised', -borderwidth => 2)
                ->pack(-side => 'top', -fill => 'x');
$data_fileselect = $mw->FileSelect;
$sort_fileselect = $mw->FileSelect;
$error_dialog = $mw->Dialog(-width => 50, -wraplength => 400);
$w_menu->Menubutton(-text => 'File', -menuitems => 
                    [
                     [Button => 'Load data...',
                      -command => \&_load_data
                     ],
                     [Button => 'Save data...',
                      -command => \&_save_data
                     ],
                     [Button => 'Load sort...',
                      -command => \&_load_sort
                     ],
                     [Button => 'Exit',
                      -command => sub {_killkids(); $mw->destroy}
                     ],
                    ])
       ->pack(-side => 'left');
my $sortmenu = $w_menu->Menubutton(-text => 'Sorts')
                      ->pack(-side => 'left');
$w_menu->Menubutton(-text => 'Configure', -menuitems => 
                    [
                     [Cascade => 'Sort Type', -menuitems =>
                      [
                       [Radiobutton => "String", 
                        -variable   => \$sorttype, 
                        -value      => 'string',
                        -command    => \&_change_sorttype],
                       [Radiobutton => "Numeric", 
                        -variable   => \$sorttype, 
                        -value      => 'numeric',
                        -command    => \&_change_sorttype]
                      ]
                     ],
                     [Cascade => 'Dot Size', -menuitems =>
                      [
                       [Radiobutton => "Small", 
                        -variable   => \$size, 
                        -value      => 1,
                        -command    => \&_refresh_canvas_frames],
                       [Radiobutton => "Big", 
                        -variable   => \$size, 
                        -value      => 3,
                        -command    => \&_refresh_canvas_frames]
                      ]
                     ],
                     [Cascade => 'Pause', -menuitems =>
                      [
                       [Checkbutton => "Pause when done", 
                        -variable   => \$pause_when_done
                       ],
                       [Checkbutton => "Pause on request", 
                        -variable   => \$pause_on_request
                       ]
                      ]
                     ],
                     [Button => 'Sort Data...',
                      -command => \&_configure_sort_data
                     ]
                    ])
       ->pack(-side => 'left');

$middleframe = $mw->Frame()
                  ->pack(-side => 'top', 
                         -fill => 'none', 
                         -padx => 5, 
                         -pady => 5);

my $buttonframe = $mw->Frame(-borderwidth => 2)
                     ->pack(-side   => 'top', 
                            -fill   => 'x', 
                            -expand => 'yes');

my $go_image = $mw->Bitmap(-data => <<EOT);
#define play_width 30
#define play_height 20
static unsigned char play_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x70, 0x00, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00, 0xf0, 0x1f, 0x00, 0x00,
   0xf0, 0xff, 0x00, 0x00, 0xf0, 0xff, 0x07, 0x00, 0xf0, 0xff, 0x3f, 0x00,
   0xf0, 0xff, 0xff, 0x01, 0xf0, 0xff, 0x3f, 0x00, 0xf0, 0xff, 0x07, 0x00,
   0xf0, 0xff, 0x00, 0x00, 0xf0, 0x1f, 0x00, 0x00, 0xf0, 0x03, 0x00, 0x00,
   0x70, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
EOT

my $stop_image = $mw->Bitmap(-data => <<EOT);
#define stop_width 20
#define stop_height 20
static unsigned char stop_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf8, 0xff, 0x00,
   0xf8, 0xff, 0x00, 0xf8, 0xff, 0x00, 0xf8, 0xff, 0x00, 0xf8, 0xff, 0x00,
   0xf8, 0xff, 0x00, 0xf8, 0xff, 0x00, 0xf8, 0xff, 0x00, 0xf8, 0xff, 0x00,
   0xf8, 0xff, 0x00, 0xf8, 0xff, 0x00, 0xf8, 0xff, 0x00, 0xf8, 0xff, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
EOT

my $step_image = $mw->Bitmap(-data => <<EOT);
#define step_width 30
#define step_height 20
static unsigned char step_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x38, 0x00, 0x80, 0x03, 0xf8, 0x01, 0x80, 0x03, 0xf8, 0x0f, 0x80, 0x03,
   0xf8, 0x7f, 0x80, 0x03, 0xf8, 0xff, 0x83, 0x03, 0xf8, 0xff, 0x9f, 0x03,
   0xf8, 0xff, 0xff, 0x03, 0xf8, 0xff, 0x9f, 0x03, 0xf8, 0xff, 0x83, 0x03,
   0xf8, 0x7f, 0x80, 0x03, 0xf8, 0x0f, 0x80, 0x03, 0xf8, 0x01, 0x80, 0x03,
   0x38, 0x00, 0x80, 0x03, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
EOT

my $reset_image = $mw->Bitmap(-data => <<EOT);
#define reset_width 35
#define reset_height 20
static unsigned char reset_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x38, 0x00, 0x06, 0xc0, 0x00, 0x38, 0x80, 0x07, 0xf0,
   0x00, 0x38, 0xe0, 0x07, 0xfc, 0x00, 0x38, 0xf8, 0x07, 0xff, 0x00, 0x38,
   0xfe, 0xc7, 0xff, 0x00, 0xb8, 0xff, 0xf7, 0xff, 0x00, 0xf8, 0xff, 0xff,
   0xff, 0x00, 0xb8, 0xff, 0xf7, 0xff, 0x00, 0x38, 0xfe, 0xc7, 0xff, 0x00,
   0x38, 0xf8, 0x07, 0xff, 0x00, 0x38, 0xe0, 0x07, 0xfc, 0x00, 0x38, 0x80,
   0x07, 0xf0, 0x00, 0x38, 0x00, 0x06, 0xc0, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00};
EOT

my $tortoise_image = $mw->Bitmap(-data => <<EOT);
#define tortoise_width 30
#define tortoise_height 20
static unsigned char tortoise_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x60, 0xf0, 0xc1, 0x00, 0xe0, 0xfc, 0xe7, 0x00,
   0xe0, 0xff, 0xff, 0x00, 0xc0, 0xff, 0x7f, 0x00, 0x80, 0xff, 0x3f, 0x00,
   0x80, 0xff, 0x3f, 0x00, 0xc0, 0xff, 0x7f, 0x3e, 0xc0, 0xff, 0xff, 0x3f,
   0xf0, 0xff, 0xff, 0x3f, 0xc0, 0xff, 0xff, 0x3f, 0xc0, 0xff, 0x7f, 0x3e,
   0x80, 0xff, 0x3f, 0x00, 0x80, 0xff, 0x3f, 0x00, 0xc0, 0xff, 0x7f, 0x00,
   0xe0, 0xff, 0xff, 0x00, 0xe0, 0xfc, 0xe7, 0x00, 0x60, 0xf0, 0xc1, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
EOT

my $hare_image = $mw->Bitmap(-data => <<EOT);
#define hare_width 30
#define hare_height 20
static unsigned char hare_bits[] = {
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x01, 0x00, 0x00, 0x00, 0x07, 0x00,
   0x00, 0x1f, 0x0c, 0x00, 0xc0, 0x7f, 0x18, 0x00, 0xe0, 0xff, 0x38, 0x00,
   0xf0, 0xff, 0x79, 0x00, 0xfb, 0xff, 0xff, 0x00, 0xff, 0xff, 0xff, 0x01,
   0xff, 0xff, 0xff, 0x01, 0xfc, 0xff, 0xff, 0x00, 0xf8, 0xff, 0x7f, 0x00,
   0xf8, 0x0f, 0x06, 0x00, 0xfc, 0x1f, 0x0c, 0x00, 0x00, 0x00, 0x00, 0x00,
   0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
EOT

$balloon = $mw->Balloon(-state           => 'balloon', 
                        -background      => 'bisque',
                        -initwait        => 1000,
                        -balloonposition => 'mouse');

my $tempbutton = $buttonframe->Button(-image   => $go_image,
                                      -command => sub {$stop = 0; &_run})
                             ->pack(-side   => 'left', 
                                    -anchor => 'w', 
                                    -fill   => 'x');
_register_button($tempbutton, 'reset', 'stopped');
$balloon->attach($tempbutton, -msg => 'Start');

$tempbutton = $buttonframe->Button(-image   => $stop_image,
                                   -command => sub {$stop = 1;})
                          ->pack(-side   => 'left', 
                                 -anchor => 'w', 
                                 -fill   => 'x');
_register_button($tempbutton, 'running');
$balloon->attach($tempbutton, -msg => 'Stop');

$tempbutton = $buttonframe->Button(-image   => $step_image,
                                   -command => sub {$stop = 1; &_run})
                          ->pack(-side   => 'left', 
                                 -anchor => 'w', 
                                 -fill   => 'x');
_register_button($tempbutton, 'reset', 'stopped');
$balloon->attach($tempbutton, -msg => 'Single-step');

$tempbutton = $buttonframe->Button(-image   => $reset_image,
                                   -state   => 'disabled',
                                   -command => \&_resetbutton)
                          ->pack(-side   => 'left', 
                                 -anchor => 'w', 
                                 -fill   => 'x');
_register_button($tempbutton, 'stopped', 'finished');
$balloon->attach($tempbutton, -msg => 'Reset');

$buttonframe->Label(-width => 10)
            ->pack(-side => 'left', -anchor => 'w');

$buttonframe->Label(-image => $tortoise_image)
            ->pack(-side => 'left', -anchor => 'w');

$buttonframe->Scale(-variable     => \$waittime,
                    -orient       => 'horizontal',
                    -from         => 0.0,
                    -to           => 1.0,
                    -tickinterval => 0,
                    -showvalue    => 0,
                    -resolution   => 0.1)
            ->pack(-side => 'left', -anchor => 'w');

$buttonframe->Label(-image => $hare_image)
            ->pack(-side => 'left', -anchor => 'w');

$mw->Label(-textvariable => \$message)
   ->pack(-side => 'top', -fill => 'x', -expand => 'yes');



# External subroutines

=head2 register

register is a class method of the GraphicSort class.  Its parameters are:

=over 4

=item $name

This is the name of your sort as you want it to appear in the Tk display.

=item $sort_function

This is a reference to the function that will be called to do the sort.

=item $sort_type

This tells tksort whether your sort expects string data ('string'), 
numeric data ('numeric'), or if it can operate on either ('both').  

=back

register returns a "badge" -- actually an object, which should be used 
for all other GraphicSort method calls.

When your sort function is invoked, it will be passed only one parameter -- a 
reference to an array containing the data to be sorted.  The function is
expected to modify the array in-place.  Any value it returns will be ignored.

The only restriction on your sort function is that it may not change the
length of the array.  Unfortunately, a side effect of this restriction is
that the splice function may not be used on the array.  However, assignments
using array slices are allowed, and may be used any place you would normally
use splice.

One final caution... keep in mind that doing string comparisons on numeric
data probably isn't what you want to do, since the number 12 would sort before
the number 2 using string comparisons.  So, think twice before registering
your sort with a $sort_type of 'both'.

Sample invocation:

C<    $badge = GraphicSort-E<gt>register('Snazzy Sort', 
                                   \&snazzy_sort,
                                   'numeric');>

=cut

sub register {
  my ($class, $name, $sortfunc, $sorttype) = @_;
  my $item;
  if (exists $sortsubs{$name}) {
    $item = $sortsubs{$name};
  }
  else {
    $item = $sortsubs{$name} = {};
    @{$item}{qw/Run Compares Moves/} = (0, 0, 0);
    $item->{Checkbutton} = 
      $sortmenu->checkbutton(-label    => $name, 
                             -variable => \$item->{Run},
                             -command  => \&_arrange_canvasframes);
    _register_button($item->{Checkbutton}, 'reset');
    _prepare_canvas_frame($name);
  }
  if ($sorttype eq 'both') {
    $item->{'string'} = $sortfunc;
    $sorttype = 'numeric';
  }
  $item->{$sorttype} = $sortfunc;
  _change_sorttype;
  bless \$name, $class;
}


=head2 highlight

When you register your sort, you're given two bars on the canvas, similar to 
the compare/move indicators, to use as you please.  The highlight method 
allows you to use these bars to highlight any array element you wish with
any color you wish.  It accepts four parameters:

=over 4

=item $bar

The integer "1" or "2", indicating which bar you wish to use.

=item $element

The element you wish to highlight.  Note that this is the element itself, 
NOT an index into the array, nor a reference to the element.

=item $color

The color you want the bar to be.

=item $msg

This is the message you want displayed in the balloon that appears
if you hold the mouse cursor over the bar.  A null string causes no
balloon to be displayed.

=back

Sample invocation:

C<    $badge-E<gt>highlight(1, $array-E<gt>[$i], 'blue', 'pivot');>

=cut

sub highlight {
  my ($self, $bar, $element, $color, $msg) = @_;
  die "Invalid bar $bar" unless $bar == 1 || $bar == 2;
  $bar++;
  print "HIGHLIGHT $bar $color ", $element->getindex, " $msg\n";
}


=head2 pause

This causes the entire execution of tksort to be paused, as if you 
had hit the stop button.

Sample invocation:

C<    $badge-E<gt>pause;>

=cut

sub pause {
  print "PAUSE\n";
}


=head2 track_variable

By default, tksort tracks Compares and Moves.  If there are other things
you wish to track (recursion level, for example), the track_variable method
allows you to add variables to the display.  They will appear directly 
underneath the Compares and Moves.

track_variable takes two parameters:

=over 4

=item $variable_name

This is the text you want displayed in the Tk window.

=item $variable_reference

This is a reference to the variable you want tracked.

=back

Sample invocation:

C<    $badge-E<gt>track_variable("Recursion level", 
                           \$recurse_level);>

=cut

sub track_variable {
  my ($self, $varname, $variable) = @_;
  my $key = $varname;
  $key =~ s/\s+//g;
  unless (exists $sortsubs{$$self}{TrackVariables}{$key}) {
    $sortsubs{$$self}{TrackVariables}{$key} = 
       {Name => $varname, Value => $$variable, InitValue => $$variable};
    $sortsubs{$$self}{CanvasFrame}->Label(-text => $varname)
                                   ->grid(-column => 0, 
                                          -row => ++$sortsubs{$$self}{LastRow},
                                          -sticky => 'w');
    $sortsubs{$$self}{TrackVariables}{$key}{Label} = 
      $sortsubs{$$self}{CanvasFrame}->Label(-width => 5, -anchor => 'e')
                                     ->grid(-column => 1, 
                                            -row => $sortsubs{$$self}{LastRow},
                                            -sticky => 'e');
  }
  $sortsubs{$$self}{TrackVariables}{$key}{Label}
    ->configure(-textvariable => \$sortsubs{$$self}{TrackVariables}{$key}{Value});
  tie $$variable, 'TrackableVariable', $key, $$variable;
}




# Built-in sort routines

{
  sub bubblesort {
      my $array = shift;

      my $i;              # The initial index for the bubbling scan.
      my $j;              # The running index for the bubbling scan.

      for ( $i = $#$array; $i; $i-- ) {
          for ( $j = 1; $j <= $i; $j++ ) {
              # Swap if needed.
              if ( $sorttype eq 'numeric'              && 
                   $array->[ $j - 1 ] > $array->[ $j ] ||
                   $sorttype eq 'string'               && 
                   $array->[ $j - 1 ] gt $array->[ $j ] ) {
                  @$array[ $j, $j - 1 ] = @$array[ $j - 1, $j ];
              }
          }
      }
  }

  my $badge = GraphicSort->register('Bubble Sort', \&bubblesort, 'both');
}



{
  sub bubblesmart {
      my $array = shift;
      my $start = 0;        # The start index of the bubbling scan.

      my $i = $#$array;

      while ( 1 ) {
          my $new_start;    # The new start index of the bubbling scan.
          my $new_end = 0;  # The new end index of the bubbling scan.

          for ( my $j = $start || 1; $j <= $i; $j++ ) {
              if ( $sorttype eq 'numeric'              && 
                   $array->[ $j - 1 ] > $array->[ $j ] ||
                   $sorttype eq 'string'               && 
                   $array->[ $j - 1 ] gt $array->[ $j ] ) {
                  @$array[ $j, $j - 1 ] = @$array[ $j - 1, $j ];
                  $new_end   = $j - 1;
                  $new_start = $j - 1 unless defined $new_start;
              }
          }
          last unless defined $new_start; # No swaps: we're done.
          $i     = $new_end;
          $start = $new_start;
      }
  }

  my $badge = GraphicSort->register('Smart Bubble', \&bubblesmart, 'both');
}



{
  sub selection_sort {
      my $array = shift;

      my $i;      # The starting index of a minimum-finding scan.
      my $j;      # The running  index of a minimum-finding scan.

      for ( $i = 0; $i < $#$array ; $i++ ) {
          my $m = $i;             # The index of the minimum element.
          my $x = $array->[ $m ]; # The minimum value.

          for ( $j = $i + 1; $j < @$array; $j++ ) {
              ( $m, $x ) = ( $j, $array->[ $j ] ) # Update minimum.
                if $sorttype eq 'numeric' && $array->[ $j ]  < $x ||
                   $sorttype eq 'string'  && $array->[ $j ] lt $x;
          }

          # Swap if needed.
          @$array[ $m, $i ] = @$array[ $i, $m ] unless $m == $i;
      }
  }

  my $badge = GraphicSort->register('Selection Sort', \&selection_sort, 'both');
}



{
  sub insertion_sort {
      my $array = shift;

      my $i;      # The initial index for the minimum element.
      my $j;      # The running index for the minimum-finding scan.

      for ( $i = 0; $i < $#$array; $i++ ) {
          my $m = $i;             # The final index for the minimum element.
          my $x = $array->[ $m ]; # The minimum value.

          for ( $j = $i + 1; $j < @$array; $j++ ) {
              ( $m, $x ) = ( $j, $array->[ $j ] ) # Update minimum.
                if $sorttype eq 'numeric' && $array->[ $j ]  < $x ||
                   $sorttype eq 'string'  && $array->[ $j ] lt $x;
          }

          @$array[$i..$m] = @$array[$m,$i..$m-1] if $m > $i;
      }
  }

  my $badge = GraphicSort->register('Insertion Sort', \&insertion_sort, 'both');
}



{
  sub shellsort {
      my $array = shift;

      my $i;              # The initial index for the bubbling scan.
      my $j;              # The running index for the bubbling scan.
      my $shell;          # The shell size.

      for ( $shell = 1; $shell < @$array; $shell = 2 * $shell + 1 ) {
          # Do nothing here, just let the shell grow.
      }

      do {
          $shell = int( ( $shell - 1 ) / 2 );
          for ( $i = $shell; $i < @$array; $i++ ) {
              for ( $j = $i - $shell;
                    $j >= 0 && ($sorttype eq 'numeric'                    && 
                                $array->[ $j ]  > $array->[ $j + $shell ] ||
                                $sorttype eq 'string'                     && 
                                $array->[ $j ] gt $array->[ $j + $shell ]);
                    $j -= $shell ) {
                  @$array[ $j, $j + $shell ] = @$array[ $j + $shell, $j ];
              }
          }
      } while $shell > 1;
  }

  my $badge = GraphicSort->register('Shell Sort', \&shellsort, 'both');
}



{
  sub heapify;

  sub heapsort {
      my $array = shift;

      foreach ( my $index = int(1 + @$array / 2); $index--; ) {
          heapify $array, $index;
      }

      foreach ( my $last = @$array; --$last; ) {
          @{ $array }[ 0, $last ] = @{ $array }[ $last, 0 ];
          heapify $array, 0, $last;
      }
  }

  sub heapify {
      my ($array, $index, $last) = @_;

      $last = @$array unless defined $last;

      my $swap = $index;
      my $high = $index * 2 + 1;

      foreach ( my $try = $index * 2;
                   $try < $last && $try <= $high;
                   $try ++ ) {
          $swap = $try if $sorttype eq 'numeric'                &&
                          $array->[ $try ]  > $array->[ $swap ] ||
                          $sorttype eq 'string'                 &&
                          $array->[ $try ] gt $array->[ $swap ];
      }

      unless ( $swap == $index ) {
          # The heap is in disorder: must reshuffle.
          @{ $array }[ $swap, $index ] = @{ $array }[ $index, $swap ];
          heapify $array, $swap, $last;
      }
  }

  my $badge = GraphicSort->register('Heap Sort', \&heapsort, 'both');
}



{
  my @work; # A global work array.
  #my ($bar1, $bar2);
  my $badge;

  sub mergesort {
      mergesort_recurse($_[0], 0, $#{ $_[0] });
  }

  sub mergesort_recurse {
      my ( $array, $first, $last ) = @_;

      if ( $last > $first ) {
          local $^W = 0;               # Silence deep recursion warning.
          my $middle = int(( $last + $first ) / 2);

          mergesort_recurse( $array, $first,       $middle );
          mergesort_recurse( $array, $middle + 1,  $last   );
          merge( $array, $first, $middle, $last );
      }
  }


  sub merge {
      my ( $array, $first, $middle, $last ) = @_;
      #$bar1->highlight($array->[$first], 'red');
      #$bar2->highlight($array->[$last], 'red');
      $badge->highlight(1, $array->[$first], 'red', 'Lower bound');
      $badge->highlight(2, $array->[$last], 'red', 'Upper bound');

      my $n = $last - $first + 1;

      # Initialize work with relevant elements from the array.
      for ( my $i = $first, my $j = 0; $i <= $last; ) {
          $work[ $j++ ] = $array->[ $i++ ];
      }

      # Now do the actual merge.  Proceed through the work array
      # and copy the elements in order back to the original array.
      # $i is the index for the merge result, $j is the index in
      # first half of the working copy, $k the index in the second half.

      $middle = int(($first + $last) / 2) if $middle > $last;

      my $n1 = $middle - $first + 1;    # The size of the 1st half.

      for ( my $i = $first, my $j = 0, my $k = $n1; $i <= $last; $i++ ) {
          $array->[ $i ] =
              $j < $n1 &&
                ( $k == $n || ($sorttype eq 'numeric'     &&
                               $work[ $j ]  < $work[ $k ] ||
                               $sorttype eq 'string'      &&
                               $work[ $j ] lt $work[ $k ])) 
                ? $work[ $j++ ] 
                : $work[ $k++ ];
      }
  }

  $badge = GraphicSort->register('Merge Sort', \&mergesort, 'both');

}  # End of merge sort closure



# quicksort
{

  my $badge;
  my ($recurselevel, $maxrecurse) = (0, 0);

  sub partition {
      my ( $array, $first, $last ) = @_;

      my $i = $first;
      my $j = $last - 1;
      my $pivot = $array->[ $last ];
      $badge->highlight(1, $pivot, 'red', 'Pivot');

   SCAN: {
          do {
              # $first <= $i <= $j <= $last - 1
              # Point 1.

              # Move $i as far as possible.
              while ( $sorttype eq 'numeric' && $array->[ $i ] <= $pivot ||
                      $sorttype eq 'string'  && $array->[ $i ] le $pivot ) {  
                  $i++;
                  last SCAN if $j < $i;
              }

              # Move $j as far as possible.
              while ( $sorttype eq 'numeric' && $array->[ $j ] >= $pivot ||
                      $sorttype eq 'string'  && $array->[ $j ] ge $pivot ) {  
                  $j--;
                  last SCAN if $j < $i;
              }

              # $i and $j did not cross over, so swap a low and a high value.
              @$array[ $j, $i ] = @$array[ $i, $j ];
          } while ( --$j >= ++$i );
      }
      # $first - 1 <= $j < $i <= $last
      # Point 2.

      # Swap the pivot with the first larger element (if there is one).
      if ( $i < $last ) {
          @$array[ $last, $i ] = @$array[ $i, $last ];
          ++$i;
      }

      # Point 3.

      return ( $i, $j );   # The new bounds exclude the middle.
  }

  sub quicksort_recurse {
      my ( $array, $first, $last ) = @_;
      $recurselevel++;
      $maxrecurse = $recurselevel if $recurselevel > $maxrecurse;

      if ( $last > $first ) {
          my ( $first_of_last, $last_of_first ) =
                                  partition( $array, $first, $last );

          local $^W = 0;               # Silence deep recursion warning.
          quicksort_recurse($array, $first,         $last_of_first);
          quicksort_recurse($array, $first_of_last, $last);
      }
      $recurselevel--;
  }

  sub quicksort {
      # The recursive version is bad with BIG lists
      # because the function call stack gets REALLY deep.
      quicksort_recurse($_[ 0 ], 0, $#{ $_[ 0 ] });
  }

  $badge = GraphicSort->register('Quick Sort', \&quicksort, 'both');
  $badge->track_variable('Recurse', \$recurselevel);
  $badge->track_variable('Recurse (max)', \$maxrecurse);

}




{
  my $badge;
  my $stackdepth = 0;
  my $stackdepthmax = 0;
  my $sortmode = 'quick';

  sub qbsort_quick;
  sub qbsort_bubblesmart;
  sub partitionMo3;

  sub qbsort {
      qbsort_quick( $_[0], 0, $#{ $_[0] }, defined $_[1] ? $_[1] : 10 );
      $sortmode = 'bubble';
      $badge->pause;  # pause between quick sort and bubble sort
      qbsort_bubblesmart( $_[0] ); # Use the variant that's fast for almost sorted data.
  }

  # The first half of the quickbubblesort: quicksort.
  # A completely normal quicksort (using median-of-three)
  # except that only partitions larger than $width are sorted.

  sub qbsort_quick {
      my ( $array, $first, $last, $width ) = @_;
      my @stack = ( $first, $last );

      do {
          if ( $last - $first > $width ) {
              my ( $last_of_first, $first_of_last ) =
                  partitionMo3( $array, $first, $last );

              if ( $first_of_last - $first > $last - $last_of_first ) {
                  push @stack, $first, $first_of_last;
                  $first = $last_of_first;
              } else {
                  push @stack, $last_of_first, $last;
                  $last = $first_of_last;
              }
          } else { # Pop.
              ( $first, $last ) = splice @stack, -2, 2;
          }
          $stackdepth = @stack/2;
          $stackdepthmax = $stackdepth if $stackdepth > $stackdepthmax;
      } while @stack;
  }

  sub partitionMo3 {
      my ( $array, $first, $last ) = @_;

      use integer;

      my $middle = int(( $first + $last ) / 2);

      # Shuffle the first, middle, and last so that the median
      # is at the middle.

      @$array[ $first, $middle ] = @$array[ $middle, $first ]
          if ( $sorttype eq 'numeric' && 
               $array->[ $first ] >  $array->[ $middle ] ||
               $sorttype eq 'string'  && 
               $array->[ $first ] gt $array->[ $middle ] );

      @$array[ $first, $last ] = @$array[ $last, $first ]
          if ( $sorttype eq 'numeric' && 
               $array->[ $first ] >  $array->[ $last ] ||
               $sorttype eq 'string'  && 
               $array->[ $first ] gt $array->[ $last ] );

      @$array[ $middle, $last ] = @$array[ $last, $middle ]
          if ( $sorttype eq 'numeric' && 
               $array->[ $middle ] <  $array->[ $last ] ||
               $sorttype eq 'string'  && 
               $array->[ $middle ] lt $array->[ $last ] );

      my $i = $first;
      my $j = $last - 1;
      my $pivot = $$array[ $last ];
      $badge->highlight(1, $pivot, 'red', 'Pivot');

      # Now do the partitioning around the median.

   SCAN: {
          do {
              # $first <= $i <= $j <= $last - 1
              # Point 1.

              # Move $i as far as possible.
              while ( $sorttype eq 'numeric' && $array->[ $i ] <= $pivot ||
                      $sorttype eq 'string'  && $array->[ $i ] le $pivot ) {  
                  $i++;
                  last SCAN if $j < $i;
              }

              # Move $j as far as possible.
              while ( $sorttype eq 'numeric' && $array->[ $j ] >= $pivot ||
                      $sorttype eq 'string'  && $array->[ $j ] ge $pivot ) {  
                  $j--;
                  last SCAN if $j < $i;
              }

              # $i and $j did not cross over,
              # swap a low and a high value.
              @$array[ $j, $i ] = @$array[ $i, $j ];
          } while ( --$j >= ++$i );
      }
      # $first - 1 <= $j <= $i <= $last
      # Point 2.

      # Swap the pivot with the first larger element
      # (if there is one).
      if( $i < $last ) {
          @$array[ $last, $i ] = @$array[ $i, $last ];
          ++$i;
      }

      # Point 3.

      return ( $i, $j );   # The new bounds exclude the middle.
  }

  sub qbsort_bubblesmart {
      my $array = shift;
      my $start = 0;        # The start index of the bubbling scan.
      my $ncomp = 0;        # The number of comparisons.
      my $nswap = 0;        # The number of swaps.

      my $i = $#$array;

      while ( 1 ) {
          my $new_start;    # The new start index of the bubbling scan.
          my $new_end = 0;  # The new end index of the bubbling scan.

          for ( my $j = $start || 1; $j <= $i; $j++ ) {
              $ncomp++;
              if ( $sorttype eq 'numeric' && 
                   $array->[ $j - 1 ] >  $array->[ $j ] ||
                   $sorttype eq 'string'  && 
                   $array->[ $j - 1 ] gt $array->[ $j ] ) {
                  @$array[ $j, $j - 1 ] = @$array[ $j - 1, $j ];
                  $nswap++;
                  $new_end   = $j - 1;
                  $new_start = $j - 1 unless defined $new_start;
              }
          }
          last unless defined $new_start; # No swaps: we're done.
          $i     = $new_end;
          $start = $new_start;
      }
  }

  $badge = GraphicSort->register('Quickbubble Sort', \&qbsort, 'both');
  $badge->track_variable('Stack Depth', \$stackdepth);
  $badge->track_variable('Stack Depth (max)', \$stackdepthmax);
  $badge->track_variable('Sort Mode', \$sortmode);
}




{
  sub max {
    my $retval = shift->getvalue;
    foreach (@_) {
      $retval = $_->getvalue if $_->getvalue > $retval;
    }
    return $retval;
  }

  sub min {
    my $retval = shift->getvalue;
    foreach (@_) {
      $retval = $_->getvalue if $_->getvalue < $retval;
    }
    return $retval;
  }

  sub counting_sort {
      my ($array) = @_; 
      unless (min(@$array) >= 0) {
        print "ERROR Can't use counting sort with negative numbers.\n";
        return;
      }
      my $max = max(@$array);
      my @counter;
      foreach my $i (0..$max) {
        $counter[$i] = [];
      }
      foreach my $elem ( @$array ) { 
        push(@{$counter[+$elem]}, $elem);
      }
      @$array[0..$#{$array}] = map { @{$counter[$_]} } 0..$max;
  }

  my $badge = GraphicSort->register('Counting Sort', \&counting_sort, 'numeric');
}



{
  my $badge;

  sub radix_sort {
      my $array = shift;

      my $length = length($array->[0]);
      foreach my $item (@$array[1..$#{$array}]) {
        unless (length($item) == $length) {
          print "ERROR Can't use radix sort with varying length keys.\n";
          return;
        }
      }

      # All lengths expected equal.
      for ( my $i = $length - 1; $i >= 0; $i-- ) {
          # A new sorting bin.
          my $from = $array;
          my $to = [ ];
          foreach my $card ( @$from ) {
              # Stability is essential, so we use push().
              push @{ $to->[ ord( substr $card, $i ) ] }, $card;
          }

          # Concatenate the bins.

          @$array[0..$#{$array}] = ( map { @{ $_ || [ ] } } @$to );
          #print "PAUSE\n";
          $badge->pause;
      }
  }

  $badge = GraphicSort->register('Radix Sort', \&radix_sort, 'string');
}



# End of built-in sort routines





package main;

GraphicSort::_change_sorttype();
Tk::MainLoop();

__END__

=head1 Internals

The internal structure of tksort may be of interest to some.  IMHO, there's
lots of spiffy stuff under the hood.

When I started writing this program, I wasn't doing anything any fancier than
normal Tk programming.  I was requiring that the user sort routines use special
functions to compare elements and move them, so that I could keep track of
compares and moves on the Tk side.  Of course, this was a very fragile
approach, as there was nothing to prevent the programmer from moving things
around inside the array behind my back.  This wouldn't normally be intentional.
As I found, it happened quite frequently by accident as I translated the sample
programs from I<Mastering Algorithms>.

The more I thought about it, the more I knew that the best thing to do was
to track moves and compares in a way that would be transparent to the user.
That way, they could just import a working sort routine into tksort with no
changes at all.

Perl, of course, makes this fairly easy.  To track moves, I made the data
array a tied array.  So, the array that's passed to the user's sort routine
is actually a SortArray object, and STOREs are recorded as Moves by tksort.

Tracking comparisons was made relatively simple by use of operator overloading.
You see, SortArrays are made up of Sortables, and sortables have the following
operators overloaded:  '<=>', 'cmp', '""', '0+', and 'bool'.  The first two
allow tksort to track all Compares, while the last three allow a Sortable 
to masquerade as a string, a number, or a boolean value.

Perl's scalar tying mechanism came in handy when I implemented the
track_variable method.  When the user passes in a reference to the
variable to be tracked, that variable becomes a Trackable object, and 
tksort is apprised whenever its value is changed.

You might wonder why this would be necessary.  After all, given a
reference to a variable, it would be trivial to track the contents
of the variable via the -textvariable option.  The answer is simple.
The reason special steps are needed to keep track of tracked variables
is because those variables are being changed in a different process.

When you press the "Start" button, one child process is spawned for each
sort you've selected.  The spawnings are done via pipe opens, making it
simple for the child processes to communicate with the parent process by
printing to STDOUT.  A comparison results in a "COMPARE" message being
sent to the parent process.  A move results in a "MOVE" message.  Similarly, 
pause sends a "PAUSE" message, highlight sends a "HIGHLIGHT", and a 
modification to a tracked variable sends a "TRACKVAR".

After your sort finishes, a "DONE" message is repeatedly sent to the
parent process.  When you hit the Reset button, all the kids are killed.


=head1 SCRIPT CATEGORIES

none appropriate

=head1 PREREQUISITES

Tk

=head1 OSNAMES

UNIX

=head1 README

tksort graphically demonstrates sorting algorithms

=cut