#!c:\perl\bin\perl.exe
# gus_mpt_elast_static_def.pl version 2004-03-30
# Copyright 2004 by Gan Uesli Starling
# Re-calculate static deflection stiffness from MTS specimen.dat files
# See POD at EOF for full description.

our $formal_name = 'MPT Elastormer Static Deflection';
our $formal_date = '2004-03-30';

print "\n\n\n\n\n\n\n";    # For debugging with T-Pad

use Tk;
use strict;

#use warnings; # Complains too much of ininitialized strings.

use vars qw (
  $debug_flag
  $input_path
  $output_path
  $output_name
  @output_files
  $DTG
  $regex_test
  $regex_rows
  $rows
  $feedback
  @parsed_cells_array
  @stiffness_calcs
  @lines $line $line_ptr
  $test_count
  $chord_span $chord_min $chord_max $chord_window_flag
  $pct_calc_offset
  @static_chans
  @static_chans_done
  $chan_ptr
  $chan_max
  @show_list
  $hanning_subtlety
  $hanning_passes
  $noise_ratio
  @units
);

############################################
############################################
###                                      ###
###  Begin stuff the user may configure  ###
###                                      ###
############################################
############################################

$debug_flag = 1;
$input_path = '';                                   # User browse to file path.
$regex_test = '^Static Deflection Process Data';    # Default column regex key.
$regex_rows = '';                                   # Let find own row regex key.
$chord_span        = 6;    # Length of shortest chord for stiffness hunting.
$pct_calc_offset   = 2;    # Often drops unreasonably between 1st and 2nd tests.
$hanning_subtlety  = 5;    # 0 is coarse despiking, 10 subtle smoothing.
$hanning_passes    = 10;   # 0 is unfiltered, 20 is a lot.
$noise_ratio       = 2.0;  # Max/min threshold for a acceptable chord.

# The main purpose of plotting a specimen's static deflection is to characterize
# its stiffness as determined by the slope of the curve at some region of interest.
# This program seeks the shallowest slope (region of linear least stiffness) within
# allowed boundaries. The flag below, if set to zero will allow hunting for
# shallowest stiffness along the whole curve from end to end. If set to one, narrower
# boundaries will need be elected by the user by means of a pop up a window to
# appear for each channel.
$chord_window_flag = 1;    # 0 = end-to-end, 1 = ask for limits (recommended).

# In the case when a pop-up window may appear asking user to narrow the boundaries for
# hunting least stiffness on a given channel, that window will contain two scale widgets.
# These widgets may, if desired, present themselves already with recommended pre-sets. Here
# is where to set those recommended pre-sets. Comment out to override and thereby not offer
# any recomended presets.
$chord_min = -600;         # Stiffness hunting-range min boundary.
$chord_max = 600;          # Stiffness hunting-range max boundary.

# Array below elects elements (some as pairs*) to include in output file. Study the
# list, comparing against each's comment to right to know what's what. (Sorry to be
# so unintuitive, but is necessary. The integers are indexes to the @siblings array.)
# @show_list = ( 1, 2, 3, 4, 5, 6, 7 ); # Show raw*, Hanned*, deltas* and N/mm.
  @show_list = ( 1, 2, 3, 4, 7 );       # Show raw*, Hanned* and N/mm. (Recommended)
# @show_list = ( 3, 4, 7 );             # Show Hanned* and N/mm.
# @show_list = ( 7 );                   # Show N/mm.

##########################################
##########################################
###                                    ###
###  End stuff the user may configure  ###
###                                    ###
##########################################
##########################################

# Start out with a hint to the user.
$feedback = 'Browse for input file, then click run.';

######################
# Begin GUI stuff
######################

my $label_width = 12;
my $entry_width = 50;

# First declare the main GUI frame and all her daughters.

my $mw = MainWindow->new( -title => 'MPT Static Deflection Stiffness' );

# Begin MENU BAR
$mw->configure( -menu => my $menubar = $mw->Menu );

# Begin MENU CONFIG
my $menu_config = $menubar->cascade( -label => '~Config' );
$menu_config->command(
  -label   => "Configure",
  -command => sub { configure::start_MainLoop() }
);

# Begin MENU HELP
my $menu_help = $menubar->cascade( -label => '~Help' );
$menu_help->command(
  -label   => "About",
  -command => sub { GUS::help_about::start_MainLoop() }
);

my $fm_top = $mw->Frame(
  -relief      => 'sunken',
  -borderwidth => 5 )->pack( -side => 'top', -expand => 1, -fill => 'x' );
my $fm_btm = $mw->Frame(
  -relief      => 'flat',
  -borderwidth => 5 )->pack( -side => 'top', -expand => 1, -fill => 'x' );
my $fm_btns = $fm_btm->Frame(
  -relief      => 'flat',
  -borderwidth => 5 )->pack( -side => 'top', -expand => 1, -fill => 'x' );
my $fm_fdbk = $fm_btm->Frame(
  -relief      => 'flat',
  -borderwidth => 5 )->pack( -side => 'top', -expand => 1, -fill => 'x' );

our $file_basename = '';

GUS::tk::frame_label_entry_button(
  $fm_top, 'Input path:', \$input_path, 7, 'Browse', sub {
      $input_path = $mw->getOpenFile( -filetypes => [ [ 'Data files', '.dat', 'TEXT' ] ] );
  },
  'gray',
  'red',
  'blue',
);
GUS::tk::frame_label_entry_button( $fm_top, 'Output name:', \$output_name );
GUS::tk::frame_label_entry_button( $fm_top, 'Chan RegEx:',  \$regex_rows );

# Build the label and button widgets for the 'Controls' frame.

# Build the label and button widgets for the 'Controls' frame.

my @buttons = GUS::tk::frame_label_buttons(
  $fm_btns, 'Action:', [ 'Run', 'Back', 'Skip', 'Show', 'Quit' ], [
      sub {
          tell_then_do( "Parsing file for channels with static deflection data...",
          \&mine_for_channels );
      },
      \&backup_one_channel,
      sub { $feedback = "No channels yet. Click 'Run' to parse for channels."},
      \&show_file,
      \&quit_MainLoop,
  ],
  [ 'red', 'orange', 'orange', 'blue', 'green' ]
);

my @foo_4 = GUS::tk::frame_label_entry( $fm_fdbk, 'Feedback:', \$feedback );

MainLoop;

# Close down the Perl/Tk GUI
sub quit_MainLoop {
    $mw->destroy() if Tk::Exists($mw);
    configure::quit_MainLoop();
    calc_region::quit_MainLoop();
    GUS::help_about::quit_MainLoop();
}


#################
# End GUI stuff #
#################

sub init_lines { $line_ptr = -1 };

sub next_line {
    my $line;
    $line_ptr++;
    $line = $lines[$line_ptr] if $line_ptr <= $#lines;
    return $line;
}

sub mine_for_channels {
    $chan_ptr = 0;

    # Open the file.
    if ( open( IN_FILE, "< $input_path" ) ) {
        my $red_flag = 0;

        # Read all lines of file into array.
        @lines = <IN_FILE>;
        close(IN_FILE);
        while ( defined( my $line = next_line() ) ) {
            next unless $line =~ /$regex_test/;
            $line = $lines[ $line_ptr + 1 ];
            chomp $line;

            foreach my $channel(@static_chans) {
                $red_flag = 1 if $channel eq $line;
            }
            push @static_chans, $line unless $red_flag;
            $red_flag = 0;

        }
        $chan_max = @static_chans;
        prep_next_channel();
    }
    else {
        if ( $input_path ) { $feedback = "Can't read from $input_path." }
        else { $feedback = "Input path is empty. Click 'Browse' to open a file." }
    }
}

sub backup_one_channel {
    if ( $#static_chans_done > 0 ) {
        unshift @static_chans, pop @static_chans_done;
        $chan_ptr--;
        run_button_mode('calc');
        shift @output_files; # For 'Show' button to track.
        $output_name = 'chan_' . "$chan_ptr" . '_of_' . "$chan_max";
        $feedback = "Found $chan_ptr of $chan_max. " . "Click 'Run'";
        $feedback .= ", 'Back'," if $chan_ptr > 1;
        $feedback .= " or 'Skip'. "; }
    else { $feedback = "Found no prior channels. "; }
}

sub run_button_mode {
    if ( $_[0] eq "calc" ) {
        $buttons[2]->configure(
          -command => sub {
              tell_then_do( "Calculating stiffnesses for channel $chan_ptr of $chan_max.",
              \&get_stiffness );
          } );
    }
    if ( $_[0] eq "parse" ) {
        $buttons[2]->configure(
          -command => sub {
              tell_then_do( "Parsing file for channels with static deflection data...",
              \&mine_for_channels );
          } );
    }

}

sub prep_next_channel {
    if ( defined( $regex_rows = shift @static_chans ) ) {

        # Remember channel just done so user can go back.
        push @static_chans_done, $regex_rows;

        $chan_ptr++;
        init_lines();
        $output_name = 'chan_' . "$chan_ptr" . '_of_' . "$chan_max";
		run_button_mode('calc');
        $buttons[4]->configure(
          -command => sub {
              tell_then_do( "Skipping channel $chan_ptr of $chan_max...",
              \&prep_next_channel );
          } );
        $feedback = "Found $chan_ptr of $chan_max. " . "Click 'Run'";
        $feedback .= ", 'Back'," if $chan_ptr > 1;
        $feedback .= " or 'Skip'. ";
        $feedback .= "Note: Before clicking 'Run' you might first like to edit the output name.";
    }
    else {
		run_button_mode('parse');
        $feedback = "Extraction complete. Select new file or quit.";
    }
}

sub tell_then_do {
    my $pause = 100;    # Default if no $_[2]
    $pause    = $_[2] if $_[2];
    $feedback = $_[0];
    $mw->after( $pause, $_[1] );
}

# Process the file.
sub get_stiffness {
    $rows = 0;
    @parsed_cells_array = ();
    @stiffness_calcs    = ();
    unless ( $chord_window_flag ) {
        # Lest user should edit supplied defaults and so create
        # an incompatible combination...
        undef $chord_min;
        undef $chord_max;
    }
    $output_path        = mk_appended_name( $input_path, $output_name );
    process_and_write($output_path);
    prep_next_channel();
}

# Make new name for output file.
sub mk_appended_name {
    my ( $file_path, $output_name ) = @_;
    my $morphed_path = $file_path;

    # Get path from file name for writing.
    $morphed_path = $file_path;
    $morphed_path =~ s(\.[a-zA-Z0-9_\-]{1,3}$)(_);    # Strip file suffix from path.
    $DTG = update_DTG();    # Get ISO Date Time Group.
    $DTG =~ s/:/-/g;        # Change time format from '00:00:01' to '00-00-01'.
    $DTG =~ s/ /_/g;        # Change space to u-score between date & time.
    $DTG =~ s/ /_/g;        # Change space to u-score everywhere.
    $output_name .= '_' unless $output_name =~ /_$/;
    $output_name =~ s/ /_/g;
    $morphed_path .= $output_name . $DTG . ".dat";
    return ($morphed_path);
}

# For multiple chord span columns, make each bigger by at least one,
# or by 1.X if won't round down to same.
sub this_span {
    if ( $chord_span < 10 )    { return $chord_span + $_[0]; }
    elsif ( $chord_span < 15 ) { return $chord_span + $_[0] * 2; }
    elsif ( $chord_span < 20 ) { return $chord_span + $_[0] * 3; }
    else { return int( $chord_span * ( 1 + $_[0] / 10 ) ) }
}

sub process_and_write {
    my ($output_path) = @_;

    # Open new file in same directory for output.
    if ( open( OUT_FILE, "> $output_path" ) ) {

        print( OUT_FILE "Stiffnesses re-calcuated from file path single-quoted below:"
          . "\n'$input_path'\n\n" . "RegEx extracted this channel per match single-quoted below:"
          . "\n'$regex_rows\n\n" . "RegEx extracted these data sets per match single-quoted below:"
          . "\n'$regex_test'\n\n"
          . "Han filtering algorithm: Subtlety = $hanning_subtlety; Passes = $hanning_passes \n\n"
          . "Chord suitability factor: Max/Min noise ratio < $noise_ratio (worst of N points)\n\n"
        );

        sift_through_channels($regex_rows);

        # Print headers for the colated chords at EOF.
        my $unit = $units[2] . '/' . $units[1] . ' Avg'; # Construct like 'N/mm Avg';
        print OUT_FILE "Average stiffnesses at shallowest slope for all tests:\n\n";
        printf( OUT_FILE "%4s\t%9s\t%9s\t%9s\t%9s\t%9s\t%9s\t%9s\t%9s\t\n", 'Test',
          $unit, $unit, $unit, $unit, 'Percent', 'Percent', 'Percent', 'Percent', );
        printf( OUT_FILE "%4s\t%9s\t%9s\t%9s\t%9s\t%9s\t%9s\t%9s\t%9s\t\n", 'No.',
          "$chord_span pts", ( this_span(1) ) . ' pts', ( this_span(2) ) . ' pts',
          ( this_span(3) ) . ' pts', "$chord_span pts", ( this_span(1) ) . ' pts',
          ( this_span(2) ) . ' pts', ( this_span(3) ) . ' pts', );

        # Calcuate percentages of Nth test for all four chords.
        for ( my $i = 0 ; $i < 4 ; $i++ ) {
            push ( @stiffness_calcs,
              percent_vs_nth_test( $stiffness_calcs[$i], $pct_calc_offset - 1 ) );
        }

        colate_to_outfile(@stiffness_calcs);    # Print colation of chords.

        print( OUT_FILE "\n\nEnd of re-calculated stiffness data. \n" );
        close(OUT_FILE);

        unshift @output_files, $output_path; # For the 'Show' & 'Back' buttons.

        # append_note_to_infile();
        $feedback = "Done: $rows rows extracted to '$output_path'.";
    }    # end if open outfile.
    else { $feedback = "Can't open for writing to $output_path." }
}    # end sub

# Only interested in one channel of data this pass.
sub sift_through_channels {
    my ($regex) = @_;
    $test_count = 1;
    while ( defined( my $line = next_line() ) ) {

        # Don't munge until matching data.
        while ( defined( $line = next_line() ) ) {
            last if $line =~ m/$regex/;
        }    # end while

        # Don't be fooled by EOF lines.
        if ( $line =~ m/$regex/ ) {
            print_units_of_measure($test_count) if $#show_list >= 0;
            munge_single_channel();
            $test_count++;
        }    # end if
    }    # end while
}

# Pass through header row.
sub print_units_of_measure {
    my ($test_count) = @_;
    while ( defined( my $line = next_line() ) ) {
        if ( $line =~ m/sec\s/ ) {
            chomp($line);
			@units = split /\s/, $line;
            my @elems_mask = ( '%4s', '%9s', '%9s', '%9s', '%9s', '%9s', '%9s', '%9s', );
            my @elems_upper =
              ( 'Data', 'Raw', 'Raw', 'Hanned', 'Hanned', 'Delta', 'Delta', 'Result', );
            my @elems_lower = (
              'row',
              "$units[1]", "$units[2]",
              "$units[1]", "$units[2]",
              "$units[1]", "$units[2]",
              "$units[2]" . '/' . "$units[1]", );
            print OUT_FILE "TEST NUMBER $test_count \n";

            # Zero preceeds the @show_list because 'Data row' is not unelectable by
            # user as a config.
            printf( OUT_FILE join ( "\t", @elems_mask[ 0, @show_list ] ) . "\n",
              @elems_upper[ 0, @show_list ] );
            printf( OUT_FILE join ( "\t", @elems_mask[ 0, @show_list ] ) . "\n",
              @elems_lower[ 0, @show_list ] );
            last;
        }
    }    # end while
}

# Work with specified channel.
sub munge_single_channel {
    my @mm_data  = ();
    my @sec_data = ();
    my @N_data   = ();
    my @N_div_mm = ();
    while ( defined( my $line = next_line() ) ) {
        last if $line =~ m/^\s$/;
        my @data = split /\t/, $line;

        push @sec_data, $data[0];
        push @mm_data,  $data[1];
        push @N_data,   $data[2];
        $rows += 1;
    }    # end while
    my @siblings = sort_aligned_arrays( 1, \@sec_data, \@mm_data, \@N_data, );

    # Do chord average only on mm and N, not seconds.
    foreach my $ref( @siblings[ 1, 2 ] ) {
        average_chord($ref);
    }

    # Eliminate mirrored redundancy from.
    delete_mirror_halves(@siblings);

    # Smooth out the mm and N data by hanning.
    push ( @siblings, hanned_delta_array( $siblings[1] ) );
    push ( @siblings, hanned_delta_array( $siblings[2] ) );

    # If so configured, pop up a window on 1st pass to set calculation region.
    if ( $test_count == 1) {
        $calc_region::ll_min = ${$siblings[2]}[0];  # Set scale left extreme.
        $calc_region::ur_max = ${$siblings[2]}[-1]; # Set scale right extreme.

        print "Max = $calc_region::ur_max ... Min = $calc_region::ll_min \n"
            if $debug_flag;
        calc_region::start_MainLoop() if $chord_window_flag ;
        $calc_region::mw_calc_region->waitWindow()
            if Tk::Exists($calc_region::mw_calc_region);
    }

    # Create arrays of delta values for calculating slope.
    push ( @siblings, delta_increment_array( $siblings[3] ) );
    push ( @siblings, delta_increment_array( $siblings[4] ) );

    # Create array of incremental N/mm values from smoothed deltas.
    push ( @siblings, divide_arrays( $siblings[6], $siblings[5] ) );

    resolve_chord_stiffnesses( \@siblings );

}

# Solve for the shallowest stiffness
sub resolve_chord_stiffnesses {
    my @siblings = @{$_[0]};
    my $print_flag = $#show_list >= 0 ;

    # NOTE: Print only when @show_list not empty. By default it won't be; but
    # user can un-check all fields in config menu. So test for $#show_list and
    # don't print if -1 for rest of this sub.
    if ( $print_flag ) {
        print "Show list = ", join " ", @show_list, "\n" if $debug_flag;
        colate_to_outfile( @siblings[@show_list] );
        print OUT_FILE "\nAveraged stiffness at least slope ";
        print OUT_FILE "between $chord_min $units[2] and $chord_max $units[2] "
            if $chord_window_flag ;
        print OUT_FILE "on test $test_count:\n";
    }

    for ( my $i = 0 ; $i <= 3 ; $i++ ) {
        my $points = this_span($i);
        my ($stiffness, $noise_flag) = shallowest_slope(
            $siblings[7],
            $points,
            index_window( $siblings[2], $chord_min, $chord_max ) );

        push @{ $stiffness_calcs[$i] }, $stiffness;
        if ( $print_flag ) {
            print  OUT_FILE 'Least stiff ',  $points;
            printf OUT_FILE "-point slope = %8.4f N/mm ", $stiffness ;
            print  OUT_FILE '-- Noisy/Non-linear: ratio of max/min deltas > ',
			  $noise_ratio, ' for all ', $points, '-pt continua.'
			  if $noise_flag;
            print OUT_FILE "\n" ;
        }
    }
    print OUT_FILE "\n\n" if $print_flag;

}

# Print array of arrays to output file.
sub colate_to_outfile {
    my (@refs) = @_;

    # For each test/row of array ref'd in @siblings, print out the columnar
    # values of user-selected (or default) data: row, raw, hanned, delta, N/mm.
    for ( my $i = 0 ; $i <= $#{ $refs[0] } ; $i++ ) {
        print OUT_FILE "\n";

        # If $show_list[0] != 0 then user has opted out from test/row numbers.
        printf OUT_FILE "%4s\t", $i + 1;    #

        foreach my $ref(@refs) {
            if ( $ref->[$i] eq 'n/a' ) { printf OUT_FILE "%9s\t", $ref->[$i]; }
            else { printf OUT_FILE "%9.3f\t", $ref->[$i]; }
        }
    }
}

# Sort an array of arrays. One array is key for the sort, sibling arrays
# keep tracked with sorted one, row by row.
sub sort_aligned_arrays {
    my ( $ptr, @siblings ) = @_;

    # One array is key for alignment.
    my @sorted = sort { $a <=> $b } @{ $siblings[$ptr] };

    # print "\nLowest mm = $sorted[0]";
    # Align one array end-to-end. Have others keep pace.
    until ( ${ $siblings[$ptr] }[0] == $sorted[0] ) {
        # Rotate arrays together.linearity_smoothness_arraymultiply_arrays
        foreach my $ref(@siblings) {
            push ( @$ref, shift (@$ref) );
        }
    }
    return @siblings;
}

# Once arrays are aligned, average them from ends toward middle.
sub average_chord {
    my $a_ref = $_[0];

    # Stiffness curve looks like mirrored, fallen-over S shaped balloon
    # letter, fat in middle, pointy on ends.
    my $btm = 0;             # Lower part of S trace, LL point to UR point.
    my $top = $#{$a_ref};    # Upper part of S trace, LL point to UR point.
    until ( $btm >= $top ) {

        # This works too, because $foo->[0] same as ${$foo}[0] but I am
        # prefering the arrow dereferencer this season.
        #${$a_ref}[$btm] = ( ${$a_ref}[$btm] + ${$a_ref}[$top] ) / 2;
        #${$a_ref}[$top] = ${$a_ref}[$btm];

        $a_ref->[$btm] = ( $a_ref->[$btm] + $a_ref->[$top] ) / 2;
        $a_ref->[$top] = $a_ref->[$btm];
        $btm++;
        $top--;
    }

    # No return as sub performs hanning on array in situ.
}

# If array has been fed to sub average_chord, then its whole
# lower half will be a useless mirror of the upper. Cut it off.
sub delete_mirror_halves {    # This def not finished
    foreach my $a_ref(@_) {
        @{$a_ref} = @{$a_ref}[ 0 .. int( $#{$a_ref} / 2 - 1 ) ];
    }

    # No return as sub truncates plural arrays in situ.
}

# Given a circular input array, return another containing the input's
# inter-element deltas.
sub delta_increment_array {
    my @delta = @{ $_[0] };
    for ( my $i = 0 ; $i < $#delta ; $i++ ) {
        $delta[ $i - 1 ] = abs( $delta[ $i - 1 ] - $delta[$i] );
    }
    return \@delta;
}

# Return a hanned copy of any array.
sub hanned_delta_array {

    # Subtlety factor: 0 = coarse, 10 very subtle, 1.5 is a nice light touch.
    my @input = @{ $_[0] };
    for ( my $j = 0 ; $j < $hanning_passes ; $j++ ) {
        my @han = @input;
        for ( my $i = 2 ; $i < ( $#input - 1 ) ; $i++ ) {

            # Nudge current point a bit more linearly between its neighbors.
            $han[$i] =
              ( $input[ $i - 2 ] + $input[ $i - 1 ] * 2 + $input[$i] * $hanning_subtlety +
              $input[ $i + 1 ] * 2 + $input[ $i + 2 ] ) / ( 6 + $hanning_subtlety );
        }
        @input = @han;
    }

    # Return a hanned copy of the still-virgin @{$_[1]} array.
    return \@input;
}

sub divide_arrays {
    my @x_val     = @{ $_[0] };
    my @y_val     = @{ $_[1] };
    my @dividends = ();
    for ( my $i = 0 ; $i <= $#y_val ; $i++ ) {
        push ( @dividends, $x_val[$i] / ( $y_val[$i] + 0.000000001 ) );
    }
    return \@dividends;
}

# Used at end on the chords to compare against 2nd test of each.
sub percent_vs_nth_test {
    my @val = @{ $_[0] };       # Array whose values are to be compared.
    my $std = $val[ $_[1] ];    # Array member to compare against.
    $std = 0.0000000000001 if $std == 0;    # Avoid div by zero.
    my @percents = ();

    for ( my $i = 0 ; $i <= $#val ; $i++ ) {
        # If stiffness calculated correctly, it will be pure numeric.
        # In that case, figure its percent and keep it.
        if ( $val[$i] =~ m/^[0-9|\.]+$/ ) {
            push @percents,  $val[$i] / $std * 100 ; }
        # If didn't calculate, pass through the string instead.
        else { push @percents, $val[$i]; }
    }
    return \@percents;
}

# Return the corresponding indices from array where the lower
# and upper values first occur. These will be used to bracket
# the region where sub shallowest_slope() shall return its value.
sub index_window {
    my ($a_ref, $lh_min, $rh_max, ) = @_;
    my $lh_index = 0;
    my $rh_index = $#{ $a_ref };
    # Scan up from bottom to find index just before low value.
	print "\nArray low = $a_ref->[0], high = $a_ref->[-1]\n" if $debug_flag;
    for ( my $i = 1 ; $i < $#{ $a_ref } ; $i++ ) {
        if ( $a_ref->[$i] > $lh_min ) { $lh_index = $i - 1; last; }
    }
    # Scan down from top to find index just after hi value. Stop if
    # may overrun low value first.
    for ( my $j = $#{ $a_ref } - 1; $j > $lh_index ; $j-- ) {
        if ( $a_ref->[$j] < $rh_max ) { $rh_index = $j + 1; last; }
    }
    # Expand as necessary to allow sub shallowest_slope() some elbow room.
	until ( ( ($rh_index - $lh_index) > ($chord_span * 4 ) ) ||
	        ( ($lh_index == 0) && ($rh_index == $#{ $a_ref }) )
	      ) {
		$lh_index-- unless $lh_index == 0; # Nudge left, not too far.
		$rh_index++ unless $rh_index == $#{ $a_ref }; # Likewise right.
		print ".";
	}
	print "\nLow limit = $lh_min at LH index of $lh_index \n"
		. "High limit = $rh_max at RH index of $rh_index \n" if $debug_flag;
    return $lh_index, $rh_index;
}

# Calculate stiffness from the linear portion
# of an S-shaped pattern.
sub shallowest_slope {
    my ($a_ref, $span, $lh, $rh, ) = @_;

    # Work within a given window, if args provided.
    $lh = 0 unless defined( $lh ); # Left hand index limit.
    $rh = $#{ $a_ref } unless defined( $rh ); # Right hand index limit.

    my $lowest_result = $a_ref->[$lh];    # Lower left corner will be steep.
	my $noise_flag = 0;  # So can tell if meets noise threshold.
    # For all readings of N/mm in array...
    for ( my $i = $lh ; $i < $rh - $span ; $i++ ) {
        my $result = 0;    # Init sum of chord.
        # To disinclude spikes, track max and min magnitudes.
        my $min = $a_ref->[$i]; # Init both to first value.
        my $max = $min;
        my $stiffness;

        # Sum together every N/mm reading in the chord.
        for ( my $j = 0 ; $j < $span ; $j++ ) {
            $stiffness = $a_ref->[ $j + $i ];
            $result += $stiffness; # Accumulate a running sum.
            $min = $stiffness if $min > $stiffness;
            $max = $stiffness if $max < $stiffness;
        }

        # Calculate the average by dividing chord sum by chord span.
        $result /= $span;
        if ( $result < $lowest_result ) {
            $lowest_result = $result;
            $noise_flag = ( $max / $min > $noise_ratio );
        }
    }
    return $lowest_result, $noise_flag;
}

# Append a note to input file about location of output file.
sub append_note_to_infile {

    # Now append a note about the extraction to the input file.
    if ( open( IN_FILE, ">> $input_path" ) ) {
        print( IN_FILE "\n\nStiffnesses recalculated from data above to file path below:"
          . "\n'$output_path'" . "\nRow identification regex = '$regex_rows'"
          . "\nData set identification regex = '$regex_test'\n\n" );    # end print
        close(IN_FILE);
    }
    else { $feedback = "Can't append to $input_path"; }
}

# Display file when asked. Path is for Win2K.
sub show_file {
    if ( defined $output_files[0] ) {
        system( 'C:\Program Files\Windows NT\Accessories\wordpad.exe', "$output_files[0]" );
        $feedback = "Opening WordPad to file '$output_files[0]'";
    }
    else { $feedback = 'Oops! No file to show.'; }
}

# Return Date Time Group in ISO 8601 approved fashion.
sub update_DTG {
    my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime(time);
    my $DTG =
      sprintf( "%04d-%02d-%02d_%02d:%02d:%02d", $year + 1900, $mon + 1, $mday, $hour, $min, $sec );
    return ("$DTG");
}
####################################
# Begin Configure Defaults Package #
####################################

# This is a separate package for convenience.

package configure;
BEGIN {}

use Tk;
use strict;
use warnings;

# Declare variables for strict.
use vars qw( $mw_configure @scale_1 @scale_2 @scale_3 @scale_4 @scale_5 @checks_1 @checks_2 );

# Automate the build of a lable & entry wiget set inside a frame.

sub start_MainLoop {
    $mw_configure = MainWindow->new( -title => ' Configure' );

    GUS::tk::frame_label_entry_button( $mw_configure, 'Test RegEx:', \$main::regex_test );

    @scale_1 = GUS::tk::frame_label_scale( $mw_configure, 'Offset for 100%:', 1, 10 );
    $scale_1[2]->set($main::pct_calc_offset);

    @scale_2 = GUS::tk::frame_label_scale( $mw_configure, 'Han subtlety:', 0, 10, 0.2 );
    $scale_2[2]->set($main::hanning_subtlety);

    @scale_3 = GUS::tk::frame_label_scale( $mw_configure, 'Han passes:', 0, 20 );
    $scale_3[2]->set($main::hanning_passes);

    @scale_4 = GUS::tk::frame_label_scale( $mw_configure, 'Noise ratio:', 1, 3, 0.05 );
    $scale_4[2]->set($main::noise_ratio);

    @scale_5 = GUS::tk::frame_label_scale( $mw_configure, 'Chord span:', 5, 30 );
    $scale_5[2]->set($main::chord_span);

    @checks_1 = GUS::tk::frame_label_checks(
      7, $mw_configure, 'Show:', [ 'Raw', 'Hanned', 'Delta', 'Stiffness' ],
      [ 1, 1, 1, 1 ],    # on-value refs
      [ 0, 0, 0, 0 ],    # off-value refs
      [ poll_show_list(1,2),
        poll_show_list(3,4),
        poll_show_list(5,6),
        poll_show_list(7)
      ] # Checked-or-not is a user preference.
    );

    @checks_2 = GUS::tk::frame_label_checks(
      14, $mw_configure, 'Options:',
	  [ 'Constrain lower-left and upper-right curve hunting '
	  	. 'boundaries via per-channel pop-up windows.' ],
      [ 1, ],    # on-value refs
      [ 0, ],    # off-value refs
      [ $main::chord_window_flag, ],    # checked or not
    );

    GUS::tk::frame_label_buttons(
      $mw_configure, 'Action:', [ 'Accept', 'Cancel' ], [
          sub { accept_config(); },
          sub { quit_MainLoop(); }
      ],
      [ 'red', 'green' ],
    );

    MainLoop;
}

# Poll the array @show_list from user configs at head of script.
sub poll_show_list {
    my $flag = 0;
    foreach my $item ( @main::show_list ) {
        foreach my $thing ( @_ ) {
            if ( $item == $thing ) { $flag = 1; last; }
        }
    }
    return $flag;
}

sub accept_config {
    $main::pct_calc_offset  = $scale_1[2]->get();
    $main::hanning_subtlety = $scale_2[2]->get();
    $main::hanning_passes   = $scale_3[2]->get();
    $main::noise_ratio      = $scale_4[2]->get();
    $main::chord_span       = $scale_5[2]->get();
    # Reconfigure the show list for individual tests.
    @main::show_list        = ();
    # Elect which data to show on individual tests.
    my @list_1 = GUS::tk::poll_frame_label_checks(@checks_1);
    push @main::show_list, ( 1, 2 ) if $list_1[0];
    push @main::show_list, ( 3, 4 ) if $list_1[1];
    push @main::show_list, ( 5, 6 ) if $list_1[2];
    push @main::show_list, (7) if $list_1[3];
    # Elect whether to calculate stiffness from whole curve or part.
    my @list_2 = GUS::tk::poll_frame_label_checks(@checks_2);
    $main::chord_window_flag = $list_2[0];
    quit_MainLoop();
}

# Close down the Perl/Tk GUI
sub quit_MainLoop {
    $mw_configure->destroy() if Tk::Exists($mw_configure);
}

END {}

##################################
# End Configure Defaults Package #
##################################

####################################
# Begin Calculation Region Package #
####################################

# A pop-up window for when calculating stiffness inside a user-selected
# region rather than the entire S-curve of the whole of collected data.
# Must be pop-up after read-in of first data set because sets region to
# fall (as is reasonable) inside the actual data boundaries.

package calc_region;
BEGIN {}

use Tk;
use strict;
use warnings;

# Declare variables for strict.
use vars qw( $mw_calc_region @scale_1 @scale_2 $res $ll_min $ur_max $unit );

# Automate the build of a lable & entry wiget set inside a frame.

sub start_MainLoop {
    $res = 1; # Default res of scales.
    $res = 0.1  if $ur_max - $ll_min < 10;
    $res = 0.01 if $ur_max - $ll_min < 1;

    $ll_min = sprintf( "%4f2", $ll_min) ;
    $ur_max = sprintf( "%4f2", $ur_max) ;

    $unit = $main::units[2] . '/' . $main::units[1];

    $mw_calc_region = MainWindow->new( -title => ' Constrain curve-hunting boundaries' );

    @scale_1 = GUS::tk::frame_label_scale( $mw_calc_region, "Min $unit:", $ll_min, $ur_max, $res );
    @scale_2 = GUS::tk::frame_label_scale( $mw_calc_region, "Max $unit:", $ll_min, $ur_max, $res );

    # Carry through last-used settings if between limits.
    if ( ( defined $main::chord_min ) &&    # Defined from previous use?
         ( defined $main::chord_max ) &&
         ( $main::chord_min > $ll_min ) &&  # Within left-hand boundary?
         ( $main::chord_max > $ll_min ) &&
         ( $main::chord_min < $ur_max ) &&  # Within right-hand boundary?
         ( $main::chord_max < $ur_max )
       ) {
        # Previous settings are defined and will fit, use them.
        $scale_1[2]->set( $main::chord_min );
        $scale_2[2]->set( $main::chord_max ); }
    else {
        # Previous settings are not defined or won't fit, use widest possible.
        $scale_1[2]->set( $ll_min );
        $scale_2[2]->set( $ur_max ); }

    GUS::tk::frame_label_buttons(
      $mw_calc_region, 'Action:', [ 'Accept', 'Cancel' ], [
          sub { accept_config(); },
          sub { quit_MainLoop(); }
      ],
      [ 'red', 'green' ],
    );

    MainLoop;
}

sub accept_config {
    my $min = $scale_1[2]->get();
    my $max = $scale_2[2]->get();
    if ( $min < $max ) {

        $main::chord_min = $min; # To be fed to index_window() for its $ll_min.
        $main::chord_max = $max; # To be fed to index_window() for its $rh_max.

        quit_MainLoop(); }
    else {
        $scale_1[2]->set( $ll_min  );
        $scale_2[2]->set( $ur_max  );
        $main::feedback = "Oops! Min stiffness region must be less than max."; }
}

# Close down the Perl/Tk GUI
sub quit_MainLoop {
    $mw_calc_region->destroy() if Tk::Exists($mw_calc_region);
}

END {}

##################################
# End Calculation Region Package #
##################################

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

################################
# Begin GUS Tk widgets Package #
# Version 2004-03-12           #
################################

# A separate package for ease of re-use.

package GUS::tk;

use Tk;
use Tk::pane;
use Tk::DirTree;

use vars
  qw( $debug_flag $widget_id $label_width $entry_width $button_width $file_basename $feedback );

BEGIN {
    $debug_flag          = 0;
    $widget_id           = 0;
    $label_width         = 12;
    $entry_width         = 12;
    $button_width        = 12;
    $main::file_basename = 'foo.txt' unless defined $file_basename;
}

use vars qw(
  %frame
  %frame_label_radio
  $dir_toplevel
);

sub new_widget { $widget_id++; return $widget_id; }

# Automate the build of a lable & entry wiget set inside a frame.
sub frame_label_entry {
    my ( $parent, $label_text, $text_var_ref ) = @_;
    my @widgets = ();
    push @widgets, $parent->Frame(
      -relief      => 'flat',
      -borderwidth => 5 )->pack(
      -side        => 'top',
      -expand      => 1,
      -fill        => 'x'
    );
    push @widgets, $widgets[0]->Label(
      -width => $label_width,
      -text  => " $label_text " )->pack( -side => 'left' );
    push @widgets, $widgets[0]->Scrolled(
      'Entry', -textvariable => $text_var_ref,
      -width      => $entry_width,
      -background => "white",
      -foreground => 'blue',
      -relief     => 'sunken',
      -font       => 'courier' )->pack(
      -side       => 'left',
      -expand     => 1,
      -fill       => 'x'
    );
    return @widgets;
}

sub frame_label_entry_button {
    my @widgets_1 = frame_label_entry( @_[ 0 .. 2 ] );
    my @widgets_2 = ();
    my ( $width, $text, $cmd_ref, $bg, $abg, $fg ) = @_[ 3 .. 8 ];
    $width   = 7 unless defined($width);
    $text    = ' Clear ' unless defined($text);
    $bg      = 'gray' unless defined($bg);
    $abg     = 'green' unless defined($abg);
    $fg      = 'blue' unless defined($fg);
    $cmd_ref = sub {
        $widgets_1[2]->delete( 0, 'end' );
    }

    unless defined($cmd_ref);
    $widgets_1[0]->Button(
      -width            => $width,
      -relief           => 'raised',
      -foreground       => $fg,
      -background       => $bg,
      -activebackground => $abg,
      -command          => $cmd_ref,
      -text             => $text )->pack( -side => 'left' );
    return ( @widgets_1, @widgets_2 );
}

# Automate the build of a lable & radiobutton wiget set inside a frame.
sub frame_label_radio {
    my ( $parent, $label, $text_array_ref, $var_ref, $cmd_ref ) = @_;
    my @widgets = ();
    push @widgets, $parent->Frame(
      -relief      => 'flat',
      -borderwidth => 5 )->pack(
      -side        => 'top',
      -expand      => 1,
      -fill        => 'x'
    );
    push @widgets, $widgets[0]->Label(
      -width => $label_width,
      -text  => " $label " )->pack( -side => 'left' );

    # Make N radiobuttons.
    foreach my $text(@$text_array_ref) {
        push @widgets, $widgets[0]->Radiobutton(
          -text     => $text,
          -value    => $text,
          -variable => $var_ref,
          -command  => $cmd_ref )->pack(
          -side     => 'left',
          -expand   => 1,
          -fill     => 'x'
        );
    }    # End of foreach.
	return @widgets;
}

# Automate the build of a lable & scale wiget set inside a frame.
sub frame_label_scale {
    my ( $parent, $text, $from, $to, $res, $orient ) = @_;
    $orient = 'horizontal' unless defined($orient);    # Default option.
    $res    = 1 unless defined($res);                  # Default option.
    my @widgets = ();
    push @widgets, $parent->Frame(
      -relief      => 'flat',
      -borderwidth => 5 )->pack(
      -side        => 'top',
      -expand      => 1,
      -fill        => 'x'
    );
    push @widgets, $widgets[0]->Label(
      -width => $label_width,
      -text  => " $text " )->pack( -side => 'left' );

    push @widgets, $widgets[0]->Scale(
      -from       => $from,
      -to         => $to,
      -resolution => $res,
      -orient     => $orient )->pack(
      -side       => 'left',
      -expand     => 1,
      -fill       => 'x'
    );
    return @widgets;
}

# Automate the build of a lable & button wiget set inside a frame.
sub frame_label_buttons {
    my ( $parent, $label_text, $text_array_ref, $cmd_ref_array_ref, $color_array_ref ) = @_;
    my @widgets = ();
    push @widgets, $parent->Frame(
      -relief      => 'flat',
      -borderwidth => 5 )->pack(
      -side        => 'top',
      -expand      => 1,
      -fill        => 'x'
    );
    push @widgets, $widgets[0]->Label(
      -width => $label_width,
      -text  => " $label_text " )->pack( -side => 'left' );

    # Make N buttons.
    foreach my $text(@$text_array_ref) {
        push @widgets, $widgets[0]->Button(
          -width            => $button_width,
          -text             => $text,
          -command          => shift ( @{$cmd_ref_array_ref} ),
          -background       => 'gray',
          -activebackground => shift ( @{$color_array_ref} ),
          -relief           => 'raised',
          )->pack(
          -side   => 'left',
          -expand => 1,
          -fill   => 'x'
        );
    }    # End of foreach.
    return @widgets;
}

#============ Begin subs for N checkbutton frames ============

# Automate the build of a lable & button wiget set inside a frame.
sub frame_label_checks {

    # The var_ref's in var_ref_array_ref are on-off values.
    my ( $width, $parent, $label_text, $text_array_ref, $on_array_ref, $off_array_ref,
      $bool_array_ref, $cmd_ref_array_ref ) = @_;
    my @widgets_and_vars = ();
    push @widgets_and_vars, $parent->Frame(
      -relief      => 'flat',
      -borderwidth => 5 )->pack(
      -side        => 'top',
      -expand      => 1,
      -fill        => 'x'
    );
    push @widgets_and_vars, $widgets_and_vars[0]->Label(
      -width => $label_width,
      -text  => " $label_text " )->pack( -side => 'left' );

    # Make N checkbuttons.
    foreach my $text(@$text_array_ref) {
        my $check_var = 0;
        push @widgets_and_vars, $widgets_and_vars[0]->Checkbutton(
          -text       => $text,
          -justify    => 'left',
          -anchor     => 'w',
          -width      => $width,
          -variable   => \$check_var,
          -background => 'gray',
          -relief     => 'groove',
          )->pack(
          -side   => 'left',
          -expand => 1,
          -fill   => 'x',
        );
        push @widgets_and_vars, \$check_var;

        # Assign the default on-value, if present.
        $widgets_and_vars[-2]->configure( -onvalue => shift @$on_array_ref )
          if defined $on_array_ref;

        # Assign the default off-value, if present.
        $widgets_and_vars[-2]->configure( -offvalue => shift @$off_array_ref )
          if defined $off_array_ref;

        # Assign checked or not-checked condition, if present.
        if ( defined $bool_array_ref ) {
            if ( shift @$bool_array_ref ) { $widgets_and_vars[-2]->select(); }
            else { $widgets_and_vars[-2]->deselect(); }
        }

        # Assign subroutine , if present.
        $widgets_and_vars[-2]->configure( -command => shift @$cmd_ref_array_ref )
          if defined $cmd_ref_array_ref;

    }    # End of foreach.
    return @widgets_and_vars;
}

# Return values of checkbutton widget set.
sub poll_frame_label_checks {

    # Input @_ = ( frame, label, check_1, var_1, check_2, var_2 ...)
    print "Checklist poll input = ", join " ", @_, "\n" if $debug_flag;
    my @bar = ();
    for ( my $i = 3 ; defined( $_[$i] ) ; $i += 2 ) {
        push @bar, ${ $_[$i] };
    }
    print "Checklist poll output = ", join " ", @_, "\n" if $debug_flag;
    return @bar;
}

#============ End subs for N checkbutton frames ============
#============ Begin subs for N file browse entry frames ============

# One var and three subs below require sub label_entry defined above. Use them to
# make one-or-more file-browse widgets. Can add new ones underneath as required. Can also
# delete them, one-at-a-time, except for the top one.

my @auto_path_widgets = ();

# List of supported file patterns
@main::filetypes =
  ( [ 'TAB delimited', '.dat', 'TEXT' ], [ 'ASCII', '.txt', 'TEXT' ], [ 'Any', '*.*', 'TEXT' ] )
  unless defined @main::filetypes;

sub add_path_widget {
    my ( $frame, $var_ref, ) = @_;

    my @path_widgets = frame_label_entry_button(
      $frame, 'Input path:', $var_ref, 7, 'Browse', sub {
          $$var_ref = $mw->getOpenFile( -filetypes => \@main::filetypes );
      },
      'gray',
      'red',
      'blue',
    );
    push @auto_path_widgets, \@path_widgets;
    return @path_widgets;
}

sub delete_path_widget {
    if ( $#auto_path_widgets > 0 ) {
		my $a_ref = $auto_path_widgets[-1];
		${$a_ref}[0]->destroy();
        $main::feedback = "Row " . ( $#auto_path_widgets + 1 ) . " has been removed.";
		pop @auto_path_widgets;
    }
    else { $main::feedback = "Oops! Can't remove only remaining row."; }
}

sub auto_path_widgets {
    my ( $count, $frame, ) = @_;
    if ( $count > 0 ) {
        for ( my $i = 1 ; $i <= $count ; $i++ ) {
			my $var = '';
            add_path_widget($frame, $var);
        }
		return @auto_path_widgets;
    }

    if ( $count < 0 ) {
        for ( my $i = 1 ; $i >= $count ; $i-- ) {
            delete_path_widget();
        }
    }
}

#============ End subs for N file browse entry frames ============
#============ Begin subs for N directory browse entry frames ============

# NOTE: This sucks! Why ain't there as proper dir browse widget in Tk like
# the getOpenFile() and getSaveFile() widgets?

my $dir_widget_count = 0;

sub add_dir_widget {
    my ( $which_frame, $start_dir, ) = @_;
    $dir_widget_count++;
    my $this_widget_id = $dir_widget_count;    # Avoid later interpolation.
    $frame{"dir_$this_widget_id"}        = $main::file_basename;
    $frame{"dir_status_$this_widget_id"} = 'foobar';

    my $dir_label = 'Directory';
    $dir_label .= " $this_widget_id" if $this_widget_id > 1;
    $dir_label .= ":";

    label_entry( "dir_$this_widget_id", $which_frame, $dir_label, \$frame{"dir_$this_widget_id"} );

    # Button to browse for entry widget above.
    $frame{"frame_dir_$this_widget_id"}->Button(
      -width   => 8,
      -text    => 'Browse',
      -command => sub {
          dir_tree_window( \$frame{ 'dir_' . $this_widget_id } );
      },
      -background       => 'gray',
      -activebackground => 'red',
      -relief           => 'raised',
      )->pack( -side => 'left', );
}

# Return list of drives for Windoze.
sub drives {
    my @drives;
    for my $i( 'C' .. 'Z' ) {
        $i = "$i" . ':';
        push ( @drives, $i ) if ( -d "$i\\" );
    }
    return @drives;
}

sub dir_tree_window {
    my ( $dir_path_ref, ) = @_;
    if ( !Exists($dir_toplevel) ) {
        $dir_toplevel = $mw->Toplevel( -title => 'Browse to directory...' );
        my $dir_tree = $dir_toplevel->Scrolled('DirTree')
          ->pack( -side => 'top', -expand => 1, -fill => 'both', );
        $dir_tree->delete('all');

        # Test if Windoze or a real OS...
        if ( $Config::Config{'osname'} =~ /Win/i ) {

            # Cobble up for use with Windoze.
            foreach my $dir( drives() ) { $dir_tree->chdir("$dir"); }
        }
        else { $dir_tree->chdir('/'); }    # For when Unician.

        my $button_frame = $dir_toplevel->Frame()->pack( -expand => 0, -fill => 'x' );

        frame_label_buttons(
          $button_frame, 'Action:', [ 'Accept', 'Cancel' ], [
              sub {
                  $$dir_path_ref = $dir_tree->selectionGet();
                  $dir_toplevel->destroy;
              },
              sub { $dir_toplevel->destroy; }
          ],
          [ 'red', 'green' ],
        );
    }
}

#============ End subs for directory browse entry frames ============

END {}

##############################
# End GUS Tk widgets package #
##############################

###############################
# Begin GUS OS Detect package #
# Version 2004-03-02          #
###############################

# A separate package for ease of re-use.

package GUS::os_detect;
use strict;

# Declare variables for strict.
use vars qw( $OS $home $delim $browser $font $txt_viewer $ttf_dir );

BEGIN {

    #$OS = '';

    #unless ($OS) {
    #    unless ( $OS = $^O ) {
    require Config;
    $OS = $Config::Config{'osname'};

    #    }
    #}

    if ( $OS =~ /Win/i ) {
        $OS         = 'WINDOWS';
        $home       = "C:/";
        $delim      = '\\';
        $browser    = 'C:/Program Files/Internet Explorer/IEXPLORE.EXE';
        $txt_viewer = 'C:/Program Files/Windows NT/Accessories/wordpad.exe';
        $ttf_dir    = 'C:\\WINNT\\Fonts\\';
        $font       = $ttf_dir . 'arial.ttf';
    }
    elsif ( $OS =~ /^netbsd$/i ) {
        $OS         = 'NetBSD';
        $home       = '~/';
        $delim      = '/';
        $browser    = '/usr/pkg/bin/mozilla';
        $txt_viewer = '/usr/pkg/bin/nedit';
        $ttf_dir    = '';
        $font       = $ttf_dir . 'Generic.ttf';
    }
    elsif ( $OS =~ /^MacOS$/i ) {
        $OS         = 'MACINTOSH';
        $home       = '~/';
        $delim      = '/';
        $browser    = '';
        $txt_viewer = '';
        $ttf_dir    = '';
        $font       = $ttf_dir . 'Generic.ttf';
    }
    elsif ( $OS =~ /os2/i ) {
        $OS         = 'OS2';
        $home       = '';
        $delim      = '/';
        $browser    = '';
        $txt_viewer = '';
        $ttf_dir    = '';
        $font       = $ttf_dir . 'Generic.ttf';
    }
    else {
        $OS         = 'UNIX';
        $home       = '~/';
        $delim      = '/';
        $browser    = '/usr/local/bin/mozilla/';
        $txt_viewer = '';
        $ttf_dir    = '';
        $font       = $ttf_dir . 'Generic.ttf';
    }
}

sub os_path {
    my ( $path, ) = @_;
    $path =~ s/\//\\/g if $OS eq 'WINDOWS';
    return ($path);
}

sub show_in_viewer {
    system( "start \"$txt_viewer\" \"$txt_viewer\"", "\"$_[0]\"" ) && warn "OOPS! ";
}

sub show_in_browser {
    system( "start \"$browser\" \"$browser\"", "\"$_[0]\"" ) && warn "OOPS! ";
}

END {}

#########################
# End OS Detect Package #
#########################

############################
# Begin Help About Package #
# Version 2004-03-06       #
############################

# Note: Two vars required in package main as/per following example...
# our $formal_name = 'Gan Uesli Starling'; # However it's officially called.
# our $formal_date = '1955-12-24'; # Official date of this of relase.

package GUS::help_about;
BEGIN {}

use Tk;
use strict;
no strict "refs";

# Declare variables for strict.
use vars qw( $mw_about );

sub start_MainLoop {
    $mw_about = MainWindow->new( -title => 'About' );
    my $text =
      $mw_about->Label( -text => "$main::formal_name\n" . "Release $main::formal_date\n\n"
      . "Copyright 2004, Gan Uesli Starling\n\nTrailing Edge Technologies\n"
      . "http://starling.us/tet\n" . "email gan\@starling.us" . "\n" )->pack();
    my $bn_okay = $mw_about->Button(
      -width            => 8,
      -relief           => 'raised',
      -foreground       => 'blue',
      -activebackground => 'green',
      -command          => \&quit_MainLoop,
      -text             => 'Okay' )->pack( -side => 'top' );
    MainLoop;
}

# Close down the Perl/Tk GUI
sub quit_MainLoop {
    $mw_about->destroy() if Tk::Exists($mw_about);
}

END {}

###############################
# End Menu Help About Package #
###############################

__END__

=head1 NAME

MTS MPT Elastomer Static Deflection

=head1 VERSION

Release date = 2004-03-30. Resolved the endless-loop condition occuring in the subroutine C<index_window()> when applied to very short, strongly aliased C<*.dat> files.

=head1 SYNOPSIS

perl gus_mpt_elast_static_def.pl

=head1 DESCRIPTION

An ex-post-facto recalculator for static deflection stiffness data.

=head1 README

Reads in one or more MTS-default C<specimen.dat> files. From amongst any other formats therein, the script will seek out only static deflection records. It then re-calculates every test intelligently seeking the shallowest slope via lightly hanned, average chords of 6, 7, 8 and 9 points. It lastly reports loss-of-stiffness in percent as compared against a user-selected N-th test from the series.

=head1 PREREQUISITES

This script requires the C<Tk> a graphical user interface toolkit module for Perl.

=head1 SEE ALSO

=over 8

=item Stand-alone *.exe version

If you absolutely, positively can't get Perl on your PC, then drop me a email. I'll run it through PAR on Win2K and reply with the B<C<*.exe>> attached. The script is free but burning stand-alone B<C<*.exe>>'s for Win32 is a service. My own time I value quite the same as you. Thus will I expect a half-hour's pay (at your own rate, whatever it be) to appear in my mailbox a week or so later.

=item gus_mpt_dynamic_char.pl

For extracting data embeded in C<specimen.dat> files by the Dynamic Characterization process in the Elastomer module of MultiPurpose TestWare by MTS.  No matter that said file may also contain other data of unlike format there embeded by other MPT processes (such as Static Deflection, etc.).

=item gus_crpc_fmc_klt.pl

A Perl/Tk GUI for extrating MTS cRPC iteration data according to Ford Motor Company's own Key Life Test formating requirements.

=item Others will follow...

This is fun! I intend to write further Perl/Tk GUI scripts for various sorts of data embeded by MPT within its default C<specimen.dat> ASCII file format. If you have a specific need which I've yet to addres, feel free to write. Include an example of the C<specimen.dat> file and how you'd like to see it munged.

=back

=head1 AUTHOR

Gan Uesli Starling <F<gan@starling.us>>

=head1 COPYRIGHT

Copyright (c) 2004, Gan Uesli Starling. All rights reserved.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=head1 SCRIPT CATEGORIES

MTS/MultiPurpose Test

=cut