) {
print TEMP;
}
close OMNI;
print TEMP "\n";
close TEMP;
}
# Write out entire RPC file.
sub write_out_RPC_file {
# By default, support MTS norm, not 3rd party
# Changed on 2005-11-04
$params{INT_FULL_SCALE} = 32752;
update_params_for_all_chans();
reduce_file_length( $params{PTS_PER_FRAME} );
check_some_things();
show_chan_array_end_addrs('write_out_RPC_file') if $debug_flag;
show_some_data(7) if $debug_flag;
# Retained temp channels are for graphing only. Do not export them.
delete_tucked_channel(2) if $retain_temp_checked[0]; # Delete pythag
delete_tucked_channel(1) if $retain_temp_checked[1]; # Delete slope
delete_tucked_channel(0) if $retain_temp_checked[2]; # Delete expand points
open_files_for_writing();
if ( $output_path !~ /\.dat|txt$/ ) {
$params{FORMAT} = 'BINARY_IEEE_LITTLE_END';
write_out_header('binary');
write_out_data_binary();
}
else {
$params{FORMAT} = 'ASCII';
# User has option to include headers or not in ASCII *.dat files.
# May want raw data only for graphing in DPlot, etc.
write_out_header('ascii') if $header_flag eq 'headers & data';
reduce_file_length(5) if $tail_flag eq 'truncate';
write_out_data_ascii("\t");
};
close_files_after_writing();
}
# Called after writing with GUI 'Write' button. No siblinghood test
# is performed on this one because of the edits.
sub reopen_output_file {
$input_path = $output_path;
read_in_RPC_file();
}
######################
# End write-out subs #
######################
########################
# Begin auto-edit subs #
########################
# XML subs for auto-edit graphing.
@graph_list_xml = ( );
# Create a line for insertion into a tag of HTML.
sub add_graph_link {
my $graph_name = my $text_name = my $rsp_name = $_[0];
$graph_name =~ s/\.[A-Z|a-z]+$/.png/;
$text_name =~ s/\.[A-Z|a-z]+$/.txt/;
# $rsp_name =~ s/\.[A-Z|a-z]+$/.rsp/;
push @graph_list_xml, qq|
|;
push @graph_list_xml, qq|
Download: ./$rsp_name |
if $rsp_name !~ /^ref_/;
}
sub write_graphs_xml {
my $xml_path = $_[0];
my $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.
my $xml_filename = $auto_edit_prefix . "rpc_graphs_$DTG.xml";
open XML, ">$xml_path/$xml_filename";
print XML $xml_top;
print XML $xml_alt_1;
print XML "\n";
print XML join "\n", @graph_list_xml;
print XML $xml_btm;
close XML;
@graph_list_xml = ( );
}
sub write_index_xml {
my $xml_path = $_[0];
my $xml_filename = "index.xml";
opendir RPC_DIR, "$xml_path";
my @file_list = sort( grep { /.*rpc_graphs_.*\.xml/ } readdir(RPC_DIR) );
closedir RPC_DIR;
if ( scalar @file_list ) {
if ( open INDEX, ">$xml_path/$xml_filename" ) {
print INDEX $xml_top;
print INDEX $xml_alt_2;
print INDEX "\n\tMaster Index of RPC Data\n";
print INDEX "\tEach entry in the Table of Contents represents a particular editing approach. For each such approach a further XML index page also exists. Each of those further pages are described and linked to below. To peruse any one of them just click on its link in the Table of Contents, read its description, then click on its link button.
";
print INDEX "\tNote: This XML page is the master index of RPC data only for a single directory. It was auto generated by the Perl script gus_rpc_edit.pl when last run in auto-edit mode. Other such master indices may exist, each in their own directory, on this or possibly other servers.
";
print INDEX "\n";
foreach (@file_list) {
my $title = $_;
$title =~ s/_rpc_graphs_.*//;
print INDEX "\n\t$title";;
if ( open XML, "$xml_path/$_" ) {
my @xml_lines = ;
close XML;
my $intro = $xml_lines[22];
$intro =~ s/.*//;
print INDEX qq|\t
$intro
|;
print INDEX qq|\tView graphs: ./$_
|;
print INDEX qq||;
}
else {
print "\nOops! Could not open file '$_' for reading in foreach loop at &write_index_xml() \n" ;
last;
}
}
print INDEX $xml_btm;
close INDEX;
}
else { print "\nOops! Could not write to file $xml_path/$xml_filename \n\n" }
}
else { print "\nNote: File ./$xml_filename not written because \@file_list was empty when &write_index_xml() ran.\n" }
}
# Graphing subs for auto-edit
sub auto_edit_graph {
my ($flag, @concat_list) = @_;
# Autoconfigure names and paths.
my ( $initial_path, $next_file ) = mk_output_filename($input_path);
$next_file =~ s/csv$/rsp/;
$params{'DESCRIPTION'} = "$next_file";
if ($flag) { $next_file = "$auto_edit_prefix$next_file" }
else { $next_file = "ref_$auto_edit_prefix$next_file" }
if ( $flag == 1 ) {
# File a single-copy of self (not concatenated to itself).
$params{'DESCRIPTION'} .= " edited as $next_file";
}
elsif ( $flag == 2 ) {
# File contaning multiple copies of self concatenated as one.
$params{'DESCRIPTION'} = 'Concatenated: ' . join(', ', @concat_list);
$next_file =~ s/.*\.//; # Keep only suffix.
my $concat_name = '_' . join('_', @concat_list); # Describe fully if able.
$concat_name = '' if length($concat_name) > 76; # But not if gets too long.
$next_file = mk_output_filename("concat$concat_name$next_file"); # Add DTG to name.
}
else { print "Oops! Flag to sub auto_edit_graph = $flag \n" unless $flag == 0 }
$output_path = "$initial_path/$next_file";
$graph_path = $output_path;
$graph_path =~ s/\.[A-Z|a-z]+$/.png/;
if ( defined(@graph_checked) && (scalar @graph_checked) ) {
&GUS::gd_graph::start_MainLoop(); # Call the module that makes the graph.
add_graph_link($next_file); # Add a link to the XML file of all graphs.
}
}
sub concat_edited_chans {
if ( @concatenated_chans == () ) { @concatenated_chans = @all_chans }
elsif ( $#concatenated_chans == $#all_chans ) {
for ( 0 ... $#all_chans ) {
push @{$concatenated_chans[$_]}, @{$all_chans[$_]};
print "Concatenating channel ", $_ + 1, ". Data points = ", scalar @{$concatenated_chans[$_]}, ".\n";
}
}
else {
print "Oops! @all_chans = ", scalar @all_chans,
" while @concatenated_chans = ", scalar @concatenated_chans, "channels. \n";
}
}
sub auto_write_files {
my ($flag, @concat_list) = @_;
print "Output frames = $params{'FRAMES'} \n";
print "Output path = $output_path \n";
auto_edit_graph($flag, @concat_list); # Graph the edited output.
write_out_RPC_file();
$feedback = "Okay! Output file written.";
}
sub auto_edit_next_file {
if ( $input_path =~ /\.csv|\.CSV$/ ) {
read_in_CSV_file();
}
else { read_in_RPC_file() }
print "Input frames = $params{'FRAMES'} \n";
siblinghood_test();
if ( $siblinghood_flag ) {
# Elective, paste-in Perl code sequenced for start.
eval "package main; $main::edits_via_perl{'Initial'}";
print "Error in eval: $@" if $@ ne '';
&GUS::rpc_edit_parameters::start_MainLoop();
# Elective, paste-in Perl code sequenced for start.
eval "package main; $main::edits_via_perl{'Median'}";
print "Error in eval: $@" if $@ ne '';
# Show a graph of unedited input when appropriate.
if ( $ref_graph_flag_xml && ( $edit_open_flag eq 'replace' ) ) {
auto_edit_graph(0);
};
if ( $error_msg eq '') {
&GUS::rpc_edit_datapoints::start_MainLoop();
# Elective, paste-in Perl code sequenced for start.
eval "package main; $main::edits_via_perl{'Final'}";
print "Error in eval: $@" if $@ ne '';
if ( $edit_open_flag eq 'replace' ) { auto_write_files(1) }
else { concat_edited_chans() }
}
}
}
sub auto_edit_all_files {
GUS::gd_graph::quit_MainLoop();
GUS::pop_up_window::quit_MainLoop();
my @path = split /\//, $input_path;
my $suffix = pop @path;
$suffix =~ s/.*\.//;
my $path = join '/', @path;
# Because XML needs its XSLT to be viewed in browser.
if ( copy $xslt_path, $path ) {
print "Copying XSLT for XML: $xslt_path \n";
}
else { print "Oops! Could not copy out XSLT from $xslt_path \n" }
opendir IN_DIR, $path;
my @edit_list = grep { /.*\.$suffix/ } readdir(IN_DIR);
@edit_list = grep { /^$auto_edit_regex/ } @edit_list;
@edit_list = grep { !/^$auto_edit_prefix/ } @edit_list;
@edit_list = sort @edit_list;
closedir IN_DIR;
print "\n\nPreparing to auto-edit these files...\n";
print join("\n", @edit_list), "\n\n";
foreach my $edit_file ( @edit_list ) {
$input_path = "$path/$edit_file";
print "\nAuto-editing next file: $edit_file \n";
push @graph_list_xml, qq|$edit_file|;
auto_edit_next_file();
push @graph_list_xml, "
";
last unless $siblinghood_flag;
}
# For when concatenating files together.
if ( $edit_open_flag eq 'concat') {
foreach ( 0 ... $#edit_list ) {
$edit_list[$_] =~ s/$auto_edit_prefix//; # Strip off prefix.
$edit_list[$_] =~ s/\..*//; # Strip off suffix.
$edit_list[$_] =~ s/_[0-9]{4}-[0-9]{2}-[0-9]{2}_[0-9]{2}-[0-9]{2}-[0-9]{2}$//; # Strip off date & time.
}
print "Concat list: ", join ", ", @edit_list, " \n";
@all_chans = @concatenated_chans;
# Expand concatenated files all together versus separately.
expand_chans( $concat_expand_pts, $expand_ratio, 1 );
update_params_for_all_chans();
auto_write_files(2, @edit_list);
}
# Return to default modes.
$edit_mode_flag = 'manual';
$edit_open_flag = 'replace';
$graph_name_flag = 'manual';
$batch_sanity_flag = 'enforce';
$main::edits_via_perl = ();
write_graphs_xml( $path );
write_index_xml( $path );
print "\nAll done!\n";
}
######################
# End auto-edit subs #
######################
#########################################
# End auto-edit subs begin resample subs
#########################################
####################
# Bezier Functions #
####################
# Return a factorial.
sub fact {
my ( $n ) = @_;
if ( $n < 2 ) { return $n }
else { return $n * fact( $n - 1 ) }
}
# Return a point P from the Bezier blending functions
# for any order of Bezier cubical spline curve.
sub bezier_pt {
# 0 <= $u <= 1
# 2 < scalar @p
# All points $p[?] = any real number.
my ($u, @p) = @_;
my $bezier = 0;
my $k = my $i = scalar @p - 1;
# Iterate over the blending functions for U at all points P.
for ( my $j = 0; $j <= $k; ++$j ) {
my $bez = $p[$j] * $u ** $j * ( 1 - $u ) ** $i;
$bez *= fact($k) / fact($j) / fact($i) if $i * $j > 0;
--$i;
$bezier += $bez;
}
return $bezier;
}
# Return an array of points for a Bezier curve.
sub bezier {
# How many steps and the Bezier control points array.
my ($i, @p) = @_;
my @curve = ();
for ( my $r = 1/$i; $r <= 1; $r += 0.999/$i ) {
push @curve, bezier_pt($r, @p);
}
# Equate first point with target if not a slope.
$curve[0] = $p[0] if $p[0] == $p[1];
# Equate final point with target if not a slope.
$curve[-1] = $p[3] if $p[3] == $p[2];
# print "+" if scalar @curve > $i;
# print "-" if scalar @curve < $i;
return @curve;
}
# Used in both resolution and expansion subs.
sub bezier_range {
my ($cnt, $p0, $p1, $p2, $p3) = @_;
# Set control points assuming a slope.
my $lh_ctrl = $p1 + ($p1 - $p0) / 3;
my $rh_ctrl = $p2 - ($p3 - $p2) / 3;
# Flatten control points if at a peak or valley.
$lh_ctrl = $p1 if (($p1 > $p0) && ($p1 > $p2)) || (($p1 < $p0) && ($p1 < $p2));
$rh_ctrl = $p2 if (($p2 > $p1) && ($p2 > $p3)) || (($p2 < $p1) && ($p2 < $p3));
return bezier($cnt, $p1, $lh_ctrl, $rh_ctrl, $p2);
}
########################
# Resolution Functions #
########################
# Increase length of all chans till justified to a frame.
sub justify_chans_to_frame {
foreach my $i ( @all_chans ) {
until ( scalar @$i % $params{PTS_PER_FRAME} == 0) {
push @$i, $i->[-1];
}
}
}
# Increase sampling rate by N
sub increase_res_one_chan {
my ($chan_id, $cnt) = @_;
my @this_chan = @{ $all_chans[$chan_id] };
# So that slopes can be calculated also at start and end.
@this_chan = ($this_chan[0], @this_chan, $this_chan[-1]);
my @resampled = ();
# Interpolate between points as a Bezier curve.
for ( my $j = 0; $j < $#this_chan - 2; ++$j) {
my @seg = bezier_range($cnt, @this_chan[$j, $j + 1, $j + 2, $j + 3]);
push @resampled, @seg;
}
push @resampled, $this_chan[-1];
until ( scalar @resampled % $cnt == 0) { push @resampled, $this_chan[-1]}
@{ $all_chans[$chan_id] } = @resampled;
}
# Decrease sampling rate by N
sub decrease_res_one_chan {
my ($chan_id, $cnt) = @_;
my @this_chan = @{ $all_chans[$chan_id] };
# Start with first point always.
my @resampled = ($this_chan[0]);
if ( $cnt == int($cnt) ) {
# Simply pluck out every Nth value from array.
for ( my $j = $cnt; $j <= $#this_chan; $j += $cnt ) {
push @resampled, $this_chan[$j];
}
}
else {
# Interpolate between datapoints.
for ( my $j = $cnt; $j <= $#this_chan; $j += $cnt ) {
push @resampled, (
$this_chan[int($j)] +
( $this_chan[int($j) + 1] - $this_chan[int($j)] ) * ($j - int($j) )
);
}
}
@{ $all_chans[$chan_id] } = @resampled;
}
sub increase_res {
print "Resampling up by factor of $_[0] \n";
foreach ( my $i = 0; $i <= $#all_chans; ++$i ) { increase_res_one_chan($i, $_[0]); }
print "Data points = ", scalar @{ $all_chans[0] }, "\n" if $debug_flag;
}
sub decrease_res {
print "Resampling down by factor of $_[0] \n";
foreach ( my $i = 0; $i <= $#all_chans; ++$i ) { decrease_res_one_chan($i, $_[0]); }
print "Data points = ", scalar @{ $all_chans[0] }, "\n" if $debug_flag;
}
sub get_sample_rate {
my $sample_rate = 0;
my $sample_rate = sprintf "%.1f", 1 / $params{'DELTA_T'};
$sample_rate = int($sample_rate) if $sample_rate =~ m/^[0-9]+\.0$/;
return $sample_rate;
}
sub resample {
# Round off to reasonable digits for comparison.
my $delta_t_new = sprintf "%0.9E", 1 / $_[0];
my $delta_t_old = $params{'DELTA_T'};
my @delta_t_vals = ();
foreach ( @sample_rates ) {
push @delta_t_vals, 1 / $_;
}
# Use vars versus array for readability.
my $res_102r4 = $delta_t_vals[0];
my $res_128r0 = $delta_t_vals[1];
my $res_204r8 = $delta_t_vals[2];
my $res_256r0 = $delta_t_vals[3];
my $res_409r6 = $delta_t_vals[4];
my $res_512r0 = $delta_t_vals[5];
my $res_1000 = $delta_t_vals[6];
my $res_1024 = $delta_t_vals[7];
my $tol = 0.2; # Tolerance in percent for DELTA_T matching.
print "Old DELTA_T = $params{'DELTA_T'} \n";
print "Old data points = ", scalar @{ $all_chans[0] }, "\n" if $debug_flag;
# When old resolution was 1024.0 Hz
if ( abs( $delta_t_old - $res_1024 ) / $delta_t_old * 100 < $tol ) {
# When new resolution is 102.4 Hz
if ($delta_t_new == $res_102r4 ) { decrease_res(10); }
# When new resolution is 128.0 Hz
if ($delta_t_new == $res_128r0 ) { decrease_res(8); }
# When new resolution is 204.8 Hz
if ($delta_t_new == $res_204r8 ) { decrease_res(5); }
# When new resolution is 256.0 Hz
if ($delta_t_new == $res_256r0 ) { decrease_res(4); }
# When new resolution is 409.6 Hz
if ($delta_t_new == $res_409r6 ) { increase_res(2); decrease_res(5); }
# When new resolution is 512.0 Hz
if ($delta_t_new == $res_512r0 ) { decrease_res(2); }
# When new resolution is 1000 Hz
if ($delta_t_new == $res_1000 ) { decrease_res(1024/1000); }
}
# When old resolution was 1000 Hz
elsif ( abs( $delta_t_old - $res_1000 ) / $delta_t_old * 100 < $tol ) {
# When new resolution is 102.4 Hz
if ($delta_t_new == $res_102r4 ) { decrease_res(1000/102.4); }
# When new resolution is 128.0 Hz
if ($delta_t_new == $res_128r0 ) { decrease_res(1000/128); }
# When new resolution is 204.8 Hz
if ($delta_t_new == $res_204r8 ) { decrease_res(1000/204.8); }
# When new resolution is 256.0 Hz
if ($delta_t_new == $res_256r0 ) { decrease_res(1000/256); }
# When new resolution is 409.6 Hz
if ($delta_t_new == $res_409r6 ) { decrease_res(1000/496); }
# When new resolution is 512.0 Hz
if ($delta_t_new == $res_512r0 ) { decrease_res(1000/512); }
# When new resolution is 1024 Hz
if ($delta_t_new == $res_1024 ) { increase_res(2); decrease_res(1000/512); }
}
# When old resolution was 512 Hz
elsif ( abs( $delta_t_old - $res_512r0 ) / $delta_t_old * 100 < $tol ) {
# When new resolution is 102.4 Hz
if ($delta_t_new == $res_102r4 ) { decrease_res(5); }
# When new resolution is 128.0 Hz
if ($delta_t_new == $res_128r0 ) { decrease_res(4); }
# When new resolution is 204.8 Hz
if ($delta_t_new == $res_204r8 ) { increase_res(2); decrease_res(5); }
# When new resolution is 256.0 Hz
if ($delta_t_new == $res_256r0 ) { decrease_res(2); }
# When new resolution is 409.6 Hz
if ($delta_t_new == $res_409r6 ) { increase_res(4); decrease_res(5); }
# When new resolution is 1000 Hz
if ($delta_t_new == $res_1000 ) { increase_res(2); decrease_res(1024/1000); }
# When new resolution is 1024 Hz
if ($delta_t_new == $res_1024 ) { increase_res(2); }
}
# When old resolution was 409.6 Hz
elsif ( abs( $delta_t_old - $res_409r6 ) / $delta_t_old * 100 < $tol ) {
# When new resolution is 102.4 Hz
if ($delta_t_new == $res_102r4 ) { decrease_res(4);}
# When new resolution is 128.0 Hz
if ($delta_t_new == $res_128r0 ) { increase_res(5); decrease_res(16); }
# When new resolution is 204.8 Hz
if ($delta_t_new == $res_204r8 ) { decrease_res(2); }
# When new resolution is 256.0 Hz$delta_t_vals
if ($delta_t_new == $res_256r0 ) { increase_res(5); decrease_res(8); }
# When new resolution is 512.0 Hz
if ($delta_t_new == $res_512r0 ) { increase_res(5); decrease_res(4); }
# When new resolution is 1000 Hz
if ($delta_t_new == $res_1000 ) { increase_res(4); decrease_res(4*409.6/1000); }
# When new resolution is 1024 Hz
if ($delta_t_new == $res_1024 ) { increase_res(5); decrease_res(2); }
}
# When old resolution was 256.0 Hz
elsif ( abs( $delta_t_old - $res_256r0 ) / $delta_t_old * 100 < $tol ) {
# When new resolution is 102.4 Hz$delta_t_vals
if ($delta_t_new == $res_102r4 ) { increase_res(2); decrease_res(5); }
# When new resolution is 128.0 Hz
if ($delta_t_new == $res_128r0 ) { decrease_res(2); }
# When new resolution is 204.8 Hz
if ($delta_t_new == $res_204r8 ) { increase_res(4); decrease_res(5); }
# When new resolution is 409.6 Hz
if ($delta_t_new == $res_409r6 ) { increase_res(8); decrease_res(5); }
# When new resolution is 512.0 Hz
if ($delta_t_new == $res_512r0 ) { increase_res(2); }
# When new resolution is 1000 Hz
if ($delta_t_new == $res_1000 ) { increase_res(4); decrease_res(1024/1000); }
# When new resolution is 1024 Hz$delta_t_vals
if ($delta_t_new == $res_1024 ) { increase_res(4); }
}
# When old resolution was 204.8 Hz
elsif ( abs( $delta_t_old - $res_204r8 ) / $delta_t_old * 100 < $tol ) {
# When new resolution is 102.4 Hz
if ($delta_t_new == $res_102r4 ) { decrease_res(2); }
# When new resolution is 128.0 Hz
if ($delta_t_new == $res_128r0 ) { increase_res(5); decrease_res(8); }
# When new resolution is 256.0 Hz
if ($delta_t_new == $res_256r0 ) { increase_res(5); decrease_res(4); }
# When new resolution is 409.6 Hz
if ($delta_t_new == $res_409r6 ) { increase_res(2); }
# When new resolution is 512.0 Hz
if ($delta_t_new == $res_512r0 ) { increase_res(5); decrease_res(2); }
# When new resolution is 1000 Hz
if ($delta_t_new == $res_1000 ) { increase_res(5); decrease_res(1024/1000); }
# When new resolution is 1024 Hz
if ($delta_t_new == $res_1024 ) { increase_res(5); }
}
# When old resolution was 128.0 Hz
elsif ( abs( $delta_t_old - $res_128r0 ) / $delta_t_old * 100 < $tol ) {
# When new resolution is 102.4 Hz
if ($delta_t_new == $res_102r4 ) { increase_res(4); decrease_res(5); }
# When new resolution is 204.8 Hz
if ($delta_t_new == $res_204r8 ) { increase_res(8); decrease_res(5); }
# When new resolution is 256.0 Hz
if ($delta_t_new == $res_256r0 ) { increase_res(4); }
# When new resolution is 409.6 Hz
if ($delta_t_new == $res_409r6 ) { increase_res(16); decrease_res(5); }
# When new resolution is 512.0 Hz
if ($delta_t_new == $res_512r0 ) { increase_res(4); }
# When new resolution is 1000 Hz
if ($delta_t_new == $res_1000 ) { increase_res(8); decrease_res(1024/1000); }
# When new resolution is 1024 Hz
if ($delta_t_new == $res_1024 ) { increase_res(8); }
}
# When old resolution was 102.4 Hz
elsif ( abs( $delta_t_old - $res_102r4 ) / $delta_t_old * 100 < $tol ) {
# When new resolution is 128.0 Hz
if ($delta_t_new == $res_128r0 ) { increase_res(5); decrease_res(4); }
# When new resolution is 204.8 Hz
if ($delta_t_new == $res_204r8 ) { increase_res(2); }
# When new resolution is 256.0 Hz
if ($delta_t_new == $res_256r0 ) { increase_res(5); decrease_res(2); }
# When new resolution is 409.6 Hz
if ($delta_t_new == $res_409r6 ) { increase_res(4); }
# When new resolution is 512.0 Hz
if ($delta_t_new == $res_512r0 ) { increase_res(5); }
# When new resolution is 1000 Hz
if ($delta_t_new == $res_1000 ) { increase_res(10); decrease_res(1024/1000); }
# When new resolution is 1024 Hz
if ($delta_t_new == $res_1024 ) { increase_res(10); }
}
else {
my $message = "Unusual parameter value!\n\n";
$message .= sprintf "%-16s = %16s \n\n", 'DELTA_T', $params{'DELTA_T'};
$message .= "Resampling was not performed. \n";
$message .= "\nDELTA_T parameter should match one of the following +/- $tol: \n";
foreach ( @delta_t_vals ) {
$message .= sprintf "%0.7E", $_;
$message .= "\n";
}
GUS::pop_up_window::start_MainLoop(
'red', 'Problem while re-sampling',
'Acknowledge', $message, sub{}, []
)
}
$params{'DELTA_T'} = $delta_t_new;
justify_chans_to_frame();
my $data_points_new = scalar @{ $all_chans[0] };
$params{'FRAMES'} = $data_points_new / $params{'PTS_PER_FRAME'};
print "New DELTA_T = $delta_t_new \n";
print "New data points = $data_points_new \n" if $debug_flag;
print "New frames = $params{'FRAMES'} \n" if $debug_flag;
}
################################################################################
################################################################################
## GUS PACKAGES -- CUSTOM SET ##
## FOR USE IN THIS PROGRAM ONLY ##
## REQUIRES INCLUSION OF GUS PACKAGES STANDARD SET ##
################################################################################
################################################################################
# Semi-arbitrary packages which make use of GUS::foo from standard set.
##########################
# Begin RPC Copy Package #
# Version 2005-03-01 #
##########################
# Used to copy files form one dir to another, renaming them with prepend strings
# in the process.
package GUS::rpc_copy;
BEGIN { }
use Tk;
use Tk::Pane;
use Tk::Balloon;
use File::Copy;
use strict;
no strict "refs";
# Declare variables for strict.
use vars qw(
$mw_rpc_copy $pane_rpc_copy
$help_info $balloon $error_msg
$copy_input_path $copy_output_path
@input_list_widget @output_list_widget
@filter );
$error_msg = '';
# Only one copy window at a time.
quit_MainLoop() if Tk::Exists $mw_rpc_copy;
sub start_MainLoop {
$mw_rpc_copy = MainWindow->new( -title => ' File Renaming Window' );
# An outermost pane to scroll all sub-panes within.
$pane_rpc_copy = $mw_rpc_copy->Scrolled(
'Pane',
-scrollbars => 'osow',
-sticky => 'new'
)->pack( -side => 'top', -expand => 1, -fill => 'both' );
# Provide help info as balloon widgets.
$help_info = $mw_rpc_copy->Label(
-borderwidth => 2,
-relief => 'groove',
-background => $main::balloon_bg,
-foreground => $main::balloon_fg,
);
$balloon = $mw_rpc_copy->Balloon(
-statusbar => $help_info,
-balloonposition => 'mouse',
-background => $main::balloon_bg,
-foreground => $main::balloon_fg,
);
$balloon->attach( $help_info, -msg => 'Hover mouse on any widget then read here.' );
#####################
# Begin input frame #
#####################
use vars qw( $copy_input_path );
# A separate frame for adding input file widget sets.
my $frame_input_dir = $pane_rpc_copy->Frame(
-relief => 'flat',
-borderwidth => 5
);
# Start out with a default file path as convenience.
my @input_dir = GUS::tk::add_dir_widget( $frame_input_dir, \$copy_input_path, 'Input Dir:' );
# Give hints to user
$balloon->attach(
$input_dir[1],
-balloonmsg => 'Input directory.',
-statusmsg => "Whatever directory contains the files to be copied."
);
$balloon->attach(
$input_dir[2],
-balloonmsg => 'Input directory path here.',
-statusmsg => "Browse or type directory path for RPC-3 files-to-be-copied."
);
###################
# End input frame #
###################
######################
# Begin output frame #
######################
use vars qw( $copy_output_path );
# A separate frame for adding input file widget sets.
my $frame_output_dir = $pane_rpc_copy->Frame(
-relief => 'flat',
-borderwidth => 5
);
# Start out with a default file path as convenience.
my @output_dir = GUS::tk::add_dir_widget( $frame_output_dir, \$copy_output_path, 'Output Dir:' );
# Give hints to user
$balloon->attach(
$output_dir[1],
-balloonmsg => 'Output directory.',
-statusmsg => "Whatever directory into which the files are to be copied."
);
$balloon->attach(
$output_dir[2],
-balloonmsg => 'Outut directory path here.',
-statusmsg => "Browse or type directory path for which you have write priveledges."
);
####################
# End output frame #
####################
######################
# Begin filter frame #
######################
use vars qw( );
$main::copy_input_regex = '.*' unless defined $main::copy_input_regex;
# A separate frame for adding input file widget sets.
my $frame_filter = $pane_rpc_copy->Frame(
-relief => 'flat',
-borderwidth => 5
);
# Start out with a default file path as convenience.
@filter = GUS::tk::frame_label_entry( $frame_filter, 'Filter RE:', \$main::copy_input_regex, );
# Give hints to user
$balloon->attach(
$filter[1],
-balloonmsg => 'Perl Regular Expression.',
-statusmsg => "Used as file name filter. Refer to Perl programming manual or http://weitz.de/regex-coach/ "
);
$balloon->attach(
$filter[2],
-balloonmsg => 'Enter a RegEx.',
-statusmsg => "Examples: .* .*\\.[tex|TEX] [0-9|A-Z|a-z|_]\\.[RSP|rsp] Turns yellow if invalid, red if unsafe. "
);
####################
# End filter frame #
####################
####################
# Begin edit frame #
####################
use vars qw( @edit );
$main::copy_edit_lh = '_[0-9]{4}-[0-9]{2}-[0-9]{2}_[0-9]{2}-[0-9]{2}-[0-9]{2}' unless defined $main::copy_edit_lh;
$main::copy_edit_rh = '' unless defined $main::copy_edit_rh;
# A separate frame for adding input file widget sets.
my $frame_edit = $pane_rpc_copy->Frame(
-relief => 'flat',
-borderwidth => 5
);
# Start out with a default file path as convenience.
@edit = GUS::tk::frame_label_entries( $frame_edit, 'Edit RE:', \$main::copy_edit_lh, \$main::copy_edit_rh );
# Give hints to user
$balloon->attach(
$edit[1],
-balloonmsg => 'Perl Regular Expression.',
-statusmsg => "Used as file re-naming filter. Refer to Perl programming manual or http://weitz.de/regex-coach/ "
);
$balloon->attach(
$edit[2],
-balloonmsg => "What to swap out?",
-statusmsg => "Enter the 'foo' part of an s/foo/bar/ regex."
);
$balloon->attach(
$edit[3],
-balloonmsg => "What to swap in?",
-statusmsg => "Enter the 'bar' part of an s/foo/bar/ regex."
);
##################
# End edit frame #
##################
#######################
# Begin prepend frame #
#######################
use vars qw( $prepend_str );
# A separate frame for adding input file widget sets.
my $frame_prepend = $pane_rpc_copy->Frame(
-relief => 'flat',
-borderwidth => 5
);
# Start out with a default file path as convenience.
my @prepend = GUS::tk::frame_label_entry( $frame_prepend, 'Prepend:', \$prepend_str, );
# Give hints to user
$balloon->attach(
$prepend[1],
-balloonmsg => 'File name prepend string.',
-statusmsg => "Any text to be prepended onto the original name when copying."
);
$balloon->attach(
$prepend[2],
-balloonmsg => 'Enter text string.',
-statusmsg => "Use only chars (A-Z, a-z), numbers (0-9) and underscores (_). Avoid spaces and punctuation."
);
#####################
# End prepend frame #
#####################
##########################
# Begin input list frame #
##########################
use vars qw( @input_list @input_list_prior );
# A separate frame for adding input file widget sets.
my $frame_input_list = $pane_rpc_copy->Frame(
-relief => 'flat',
-borderwidth => 5
);
@input_list_widget = GUS::tk::frame_label_listbox( $frame_input_list, 'Input list:', \@input_list, 'single', 0);
########################
# End input list frame #
########################
###########################
# Begin output list frame #
###########################
use vars qw( @output_list @output_list_prior);
# A separate frame for adding input file widget sets.
my $frame_output_list = $pane_rpc_copy->Frame(
-relief => 'flat',
-borderwidth => 5
);
@output_list_widget = GUS::tk::frame_label_listbox( $frame_output_list, 'Output list:', \@output_list, 'single', 0);
#########################
# End output list frame #
#########################
# A sunken frame for buttons, etc.
my $frame_btm = $mw_rpc_copy->Frame(
-relief => 'flat',
-borderwidth => 5
);
my @buttons = GUS::tk::frame_label_buttons(
$frame_btm, 'Action:',
[ 'Copy', 'Delete', 'Cancel' ],
[ sub { copy_files() }, sub { delete_files() }, sub { quit_MainLoop() } ],
[ 'gold', 'red', 'green' ],
);
# Give hints to user
$balloon->attach(
$buttons[1],
-balloonmsg => 'Actions.',
-statusmsg => "Careful or you may delete excessively! "
);
$balloon->attach(
$buttons[2],
-balloonmsg => "Copy files?",
-statusmsg => "Copy all files in input listbox?"
);
$balloon->attach(
$buttons[3],
-balloonmsg => "Delete all listed files?",
-statusmsg => "Double check the input listbox! Make absolutely certain you want those deleted!"
);
$balloon->attach(
$buttons[4],
-balloonmsg => "What to swap in?",
-statusmsg => "Enter the 'bar' part of an s/foo/bar/ regex."
);
$frame_input_dir->pack( -side => 'top', -expand => 1, -fill => 'x' );
$frame_filter->pack( -side => 'top', -expand => 1, -fill => 'x' );
$frame_input_list->pack( -side => 'top', -expand => 1, -fill => 'x' );
$frame_output_dir->pack( -side => 'top', -expand => 1, -fill => 'x' );
$frame_edit->pack( -side => 'top', -expand => 1, -fill => 'x' );
$frame_prepend->pack( -side => 'top', -expand => 1, -fill => 'x' );
$frame_output_list->pack( -side => 'top', -expand => 1, -fill => 'x' );
$help_info->pack( -side => 'top', -expand => 0, -fill => 'x' );
$frame_btm->pack( -side => 'top', -expand => 0, -fill => 'x' );
$mw_rpc_copy->repeat( 1500, \&refresh_listboxes );
MainLoop;
}
sub refresh_file_list {
my ($path, $list_ref) = @_;
opendir DIR, $path;
@$list_ref = readdir DIR;
closedir DIR;
}
sub filter_list {
my ($list_ref, $regex) = @_;
my @filtered = ();
foreach my $item ( @$list_ref ) {
push @filtered, $item if $item =~ m/$regex/;
}
@$list_ref = @filtered;
}
sub refresh_listbox {
my ($widget, $path, $list_ref, $list_prior_ref, $regex) = @_;
# Skip until path has been browsed to.
if ( defined $path ) {
refresh_file_list( $path, $list_ref );
filter_list( $list_ref, $regex );
@$list_ref = sort @$list_ref;
# Skip update unless list has changed.
unless ( GUS::general::comp_string_arrays( $list_ref, $list_prior_ref ) ) {
$widget->delete(0, 'end');
$widget->insert(0, @$list_ref);
@$list_prior_ref = @$list_ref;
}
}
}
# Test regex for match-only validity.
sub test_regex {
# Check validity.
my $re = eval { qr/$_[0]/ };
my $valid = defined($re) ? 1 : 0 ;
# Check safety.
my @foo = split '/', $_[0];
my $safe = scalar @foo <= 1;
unless ( $valid && $safe ) {
# print "FOO:\n\t", join "\n\t", @foo, "\n";
$safe |= $foo[0] eq 'm'; # Match only.
$safe |= $foo[0] eq ''; # Match only.
$safe &= $foo[0] !~ /s/; # No substitution.
$safe &= $foo[-1] !~ /e/; # No execution
}
return($valid, $safe, $re);
}
sub refresh_listboxes {
# Assume malicious intent.
my ( $valid, $safe, $re ) = test_regex( $main::copy_input_regex );
if ( $valid ) {
if ( $safe ) {
$filter[2]->configure( -background => 'white');
refresh_listbox(
$input_list_widget[2], $copy_input_path,
\@input_list, \@input_list_prior,
$main::copy_input_regex
);
# print "RE: $re \n";
}
else { $filter[2]->configure( -background => 'red') }
}
else { $filter[2]->configure( -background => 'red') }
refresh_listbox($output_list_widget[2], $copy_output_path, \@output_list, \@output_list_prior, '.*');
}
sub copy_files {
if ( 1 ) {
if ( $error_msg ne '' ) {
$main::error_msg = "Oops! Error while renaming file: $error_msg";
$main::feedback = $main::error_msg;
# Pop up a window about problem.
GUS::pop_up_window::start_MainLoop(
'red', ' Renaming Error',
$main::error_msg,
'Acknowledge', sub {}, []
);
$error_msg = '';
}
else {
foreach my $file ( @input_list ) {
my @elems = split '/', $file;
$elems[-1] =~ s/$main::copy_edit_lh/$main::copy_edit_rh/;
copy( "$copy_input_path/$file", ("$copy_output_path/$prepend_str" . $elems[-1]) )
or $error_msg = "$!";
last if $error_msg ne '';
}
}
}
}
sub unlink_files {
if ( 1 ) {
if ( $error_msg ne '' ) {
$main::error_msg = "Oops! Error while deleting file: $error_msg";
$main::feedback = $main::error_msg;
# Pop up a window about problem.
GUS::pop_up_window::start_MainLoop(
'red', ' Deletion Error',
$main::error_msg,
'Acknowledge', sub {}, []
);
$error_msg = '';
}
else {
foreach my $file ( @input_list ) {
my @elems = split '/', $file;
unlink( "$copy_input_path/$file" )
or $error_msg = "$!";
last if $error_msg ne '';
}
}
}
}
# Close down the Perl/Tk GUI
sub quit_MainLoop {
$mw_rpc_copy->destroy() if Tk::Exists($mw_rpc_copy);
}
END { }
########################
# End RPC Copy Package #
########################
###############################
# Begin RPC Edit Perl Package #
# Version 2005-12-15 #
###############################
package GUS::rpc_edit_perl;
BEGIN { }
use Tk;
use Tk::Pane;
use Tk::Balloon;
use strict;
#no strict "refs";
# Declare variables for strict.
use vars qw(
$mw_rpc_edit_perl $pane_rpc_edit_perl
$help_info $balloon );
sub start_MainLoop {
$mw_rpc_edit_perl = MainWindow->new( -title => ' Paste-In Perl Editing' );
# An outermost pane to scroll all sub-panes within.
$pane_rpc_edit_perl = $mw_rpc_edit_perl->Scrolled(
'Pane',
-scrollbars => 'osow',
-sticky => 'new'
)->pack( -side => 'top', -expand => 1, -fill => 'both' );
# Provide help info as balloon widgets.
$help_info = $mw_rpc_edit_perl->Label(
-borderwidth => 2,
-relief => 'groove',
-background => $main::balloon_bg,
-foreground => $main::balloon_fg,
);
$balloon = $mw_rpc_edit_perl->Balloon(
-statusbar => $help_info,
-balloonposition => 'mouse',
-background => $main::balloon_bg,
-foreground => $main::balloon_fg,
);
$balloon->attach( $help_info, -msg => 'Hover mouse on any widget then read here.' );
####################
# Begin perl frame #
####################
use vars qw( $frame_perl @perl_widgets);
# A sunken frame for buttons, etc.
$frame_perl = $pane_rpc_edit_perl->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'RPC Editing via User-Authored Perl',
);
push @perl_widgets, GUS::tk::frame_label_text( $frame_perl, "Perl: ", 24, 50);
$perl_widgets[-1]->insert( 'end', "# Paste in user-authored Perl code and or subroutine calls here.\n");
$perl_widgets[-1]->insert( 'end', "# Channel 1 = \@{\$main::all_chans[0]} \n\n");
$perl_widgets[-1]->insert( 'end', "# Example 1: Han Ch 3 for 300 loops from 6 to 11 seconds, \n");
$perl_widgets[-1]->insert( 'end', "# from 36 to 41 seconds and 37 to 38.5 seconds (at 409.6Hz SR)...\n\n");
$perl_widgets[-1]->insert( 'end', "# smooth_chan_between_addrs( 2, 300, 2457, 4505, 14745, 16793, 15155, 15770 );\n");
$perl_widgets[-1]->insert( 'end', "\n# Example 2: Clip all chans above or below zero.\n");
$perl_widgets[-1]->insert( 'end', "# clip_chans_above_zero();\n");
$perl_widgets[-1]->insert( 'end', "# clip_chans_below_zero();\n");
$perl_widgets[-1]->insert( 'end', "\n# Example 3: Clip Ch 1 above 600 and below -600 with 7-point hanning.\n");
$perl_widgets[-1]->insert( 'end', "# clip_chan(0, 600, -600, 7);\n");
###################
# End perl frame #
###################
# A sunken frame for buttons, etc.
my $frame_radio_1 = $mw_rpc_edit_perl->Frame(
-relief => 'flat',
-borderwidth => 5
);
my @edits_radio = GUS::tk::frame_label_radio(
8, $frame_radio_1, 'Batch:',
['Initial', 'Median', 'Final'],
\$main::edits_via_perl{'timing'},
sub { },
);
# Attach a balloon to each entry widget.
$balloon->attach(
$edits_radio[1],
-balloonmsg => 'Batch timing.',
-statusmsg => 'Whether to do first, in middle, or last during batch file editing.'
);
$balloon->attach(
$edits_radio[2],
-balloonmsg => 'Do at start.',
-statusmsg => 'Execute this Perl code as first step (before params) for each file edited.'
);
$balloon->attach(
$edits_radio[3],
-balloonmsg => 'Do in middle.',
-statusmsg => 'Execute this Perl code in middle (between parameters and datapoints) for each file edited.'
);
$balloon->attach(
$edits_radio[4],
-balloonmsg => 'Do at end.',
-statusmsg => 'Execute this Perl code as final step for each file edited.'
);
# A sunken frame for buttons, etc.
my $frame_btm = $mw_rpc_edit_perl->Frame(
-relief => 'flat',
-borderwidth => 5
);
GUS::tk::frame_label_buttons(
$frame_btm, 'Action:',
[ 'Accept', 'Cancel' ],
[ sub { accept_edits(); }, sub { quit_MainLoop(); } ],
[ 'red', 'green' ],
);
$frame_perl->pack( -side => 'top', -expand => 1, -fill => 'both' );
$help_info->pack( -side => 'top', -expand => 0, -fill => 'x' );
$frame_radio_1->pack( -side => 'top', -expand => 0, -fill => 'x' );
$frame_btm->pack( -side => 'top', -expand => 0, -fill => 'x' );
MainLoop;
}
######################################
# BEGIN EXPERIMENTAL EDITING SCRIPTS #
# NOT YET READY FOR MAIN PACKAGE #
######################################
# NOTE: REMOVE 'main::' FROM SUB CALLS BEFORE IMPORTING TO MAIN.
# Reduce slope of chan below a given floor.
sub main::round_below_floor {
my ($chan, $floor, $i) = @_; # Chan number, clip-below-value, percent.
my $a_ref = $main::all_chans[$chan]; # Array of channel datapoints.
for ( $i .. $#$a_ref - $i ) { # For all points of channel 3.
if ( $a_ref->[$_] < $floor ) { # Check if value below floor.
$a_ref->[$_] = $floor; # Attenuate sub-floor slope.
main::han_chan_between_addrs( $chan, $_ - $i, $_ + $i, 2 );
}
}
}
# Reduce slope of chan below a given floor.
sub main::round_above_ceil {
my ($chan, $ceil, $i) = @_; # Chan number, clip-below-value, percent.
my $a_ref = $main::all_chans[$chan]; # Array of channel datapoints.
for ( $i .. $#$a_ref - $i ) { # For all points of channel N.
if ( $a_ref->[$_] > $ceil ) { # Check if value above ceiling.
$a_ref->[$_] = $ceil ; # Attenuate over-ceiling slope.
main::han_chan_between_addrs( $chan, $_ - $i, $_ + $i, 2 );
}
}
}
# Clip chan and han for smoothness
sub main::clip_chan {
my ($chan, $ceil, $floor, $i) = @_;
my ($max, $min) = main::chan_max_and_min($chan);
my $j = 0;
# Round slope again and again until below ceiling.
print "Begin smooth-clipping channel " . ($chan + 1) . " to ceiling of $ceil.\n";
while ($max > $ceil) {
++$j;
my $diff = $max - $ceil;
last if abs($diff) < abs($ceil / 200); # A half percent is close enough;
print "Max peak above ceiling = $diff for loop $j\n";
main::round_above_ceil($chan, ($ceil + $max)/2, $i);
($max, $min) = main::chan_max_and_min($chan);
}
print "Done smooth-clipping of chan" . ($chan + 1) . " to ceiling of $ceil.\n";
print "Final maximum = $max. \n";
$j = 0;
# Round slope again and again until above floor.
print "Begin smooth-clipping channel " . ($chan + 1) . " to floor of $floor.\n";
while ($min < $floor) {
++$j;
my $diff = $min - $floor;
last if abs($diff) < abs($floor / 200); # A half percent is close enough;
print "Min valley below floor = $diff for loop $j\n";
main::round_below_floor($chan, ($floor + $min)/2, $i);
($max, $min) = main::chan_max_and_min($chan);
}
print "Smooth-clipping done to floor of $floor.\n";
print "Final minimum = $min. \n";
}
####################################
# END EXPERIMENTAL EDITING SCRIPTS #
# NOT YET READY FOR MAIN PACKAGE #
####################################
# Sub below moved to here from MainLoop to avoid
# the 'will not stay shared' error.
sub perform_perl {
my $perl_code = $perl_widgets[-1]->get("1.0", "end");
$perl_code .= ' main::update_params_for_all_chans();';
# Remember custom edits in correct order for batch editing.
$main::edits_via_perl{"$main::edits_via_perl{'timing'}"} = $perl_code;
eval "package main; $perl_code";
print "Error in eval: $@" if $@ ne '';
}
sub accept_edits {
if ( defined $main::params{CHANNELS} ) {
main::update_params_for_all_chans();
perform_perl();
main::show_chan_array_end_addrs('rpc_edit_params');
quit_MainLoop();
}
}
# Close down the Perl/Tk GUI
sub quit_MainLoop {
$mw_rpc_edit_perl->destroy() if Tk::Exists($mw_rpc_edit_perl);
}
END { }
#############################
# End RPC Edit Perl Package #
#############################
#####################################
# Begin RPC Edit Parameters Package #
# Version 2005-12-15 #
#####################################
package GUS::rpc_edit_parameters;
BEGIN { }
use Tk;
use Tk::Pane;
use Tk::Balloon;
use strict;
no strict "refs";
# Declare variables for strict.
use vars qw(
$mw_rpc_edit_parameters $pane_rpc_edit_parameters
$help_info $balloon );
sub start_MainLoop {
$main::edits_via_perl{'timing'} = 'Median';
$mw_rpc_edit_parameters = MainWindow->new( -title => ' Parameter Editing Sequence' );
# An outermost pane to scroll all sub-panes within.
$pane_rpc_edit_parameters = $mw_rpc_edit_parameters->Scrolled(
'Pane',
-scrollbars => 'osow',
-sticky => 'new'
)->pack( -side => 'top', -expand => 1, -fill => 'both' );
# Provide help info as balloon widgets.
$help_info = $mw_rpc_edit_parameters->Label(
-borderwidth => 2,
-relief => 'groove',
-background => $main::balloon_bg,
-foreground => $main::balloon_fg,
);
$balloon = $mw_rpc_edit_parameters->Balloon(
-statusbar => $help_info,
-balloonposition => 'mouse',
-background => $main::balloon_bg,
-foreground => $main::balloon_fg,
);
$balloon->attach( $help_info, -msg => 'Hover mouse on any widget then read here.' );
&main::update_params_for_all_chans(); # Must know max and min to go on...
###########################
# Begin description frame #
###########################
use vars qw( $frame_description );
# Create new description before pushing into widget.
my @path_elems = split /\//, $main::input_path;
$main::params{'DESCRIPTION'} = "Opened as file $path_elems[-1]";
$main::params{'OPERATION'} = "gus_rpc_edit.pl";
# Opened file because new first ancestor file.
#my $ancestors = 2;
#foreach ( keys %main::params ) { ++$ancestors if $_ =~ /PARENT_/ }
$main::params{"PARENT_1"} = "$path_elems[-1]";
# A sunken frame for buttons, etc.
$frame_description = $pane_rpc_edit_parameters->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Descriptions',
);
my @params_widgets;
# So that 'DESCRIPTION' will be on top.
my @chan_desc_keys = ('DESCRIPTION');
# Get descriptions in manner that will sort numerically
# above channel 9.
for ( my $i = 1; defined $main::params{"DESC_r_CHAN_$i"} ; ++$i ) {
push @chan_desc_keys, "DESC_r_CHAN_$i";
}
foreach my $key ( @chan_desc_keys ) {
# Do not preserve prior descriptions because extraction/realignment of this edit sequence
# will discombobulate the effort.
my $label_text = $key;
$label_text =~ s/DESC_r_CHAN_/Desc. Ch /;
$label_text =~ s/DESCRIPTION/Desc. File/;
push @params_widgets, GUS::tk::frame_label_entry( $frame_description, $label_text, \$main::params{$key}, );
$params_widgets[-1]->configure( -fg => 'gray33', -bg => 'white', -state => 'disabled', );
# Attach a balloon to each entry widget.
$balloon->attach(
$params_widgets[-1],
-balloonmsg => 'Shown for reference only in this window. See below.',
-statusmsg => 'Editing of channel descriptions will be enabled come the next window.'
);
}
#########################
# End description frame #
#########################
#############################
# Begin set CSV sample rate #
#############################
# Avoid "illegal divide by zero error" when lowest channel not sequential time data.
if ($main::input_path =~ /.(csv|CSV)$/) {
use vars qw(
$frame_sample_csv
@radio_sample_csv
@set_sample_csv
@frames_sample_csv );
# A sunken frame for buttons, etc.
$frame_sample_csv = $pane_rpc_edit_parameters->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'CSV File Input Sampling Rate',
);
# Create a sample rate from 1st column of CSV file, provided it is named as 'time'.
if ($main::params{"DESC_r_CHAN_1"} =~ /time/i) {
$main::params{DELTA_T} = $main::all_chans[0]->[1] - $main::all_chans[0]->[0];
$main::sample_rate_csv = sprintf( "%4.1f", 1 / $main::params{DELTA_T});
$main::sample_rate_csv = int($main::sample_rate_csv) if $main::sample_rate_csv =~ /\.0$/;
}
# Widget set for selecting CSV input file sample rate.
@radio_sample_csv = GUS::tk::frame_label_radio( 8, $frame_sample_csv,
'Hertz:', \@main::sample_rates, \$main::sample_rate_csv, \&colorized_wgt );
# If CSV sample rate not proper for RPC-III, insist upon change to acceptable.
sub colorized_wgt {
# Warn of non-standard sample rate from CSV file by turning widgets red.
my $color = 'gray';
my $sample_regex = join '|', @main::sample_rates;
$color = 'red' unless $main::sample_rate_csv =~ /$sample_regex/;
$frame_sample_csv->configure(-background => $color);
foreach (@radio_sample_csv) { $_->configure(-background => $color) }
$main::params{DELTA_T} = sprintf "%.12e", 1 / $main::sample_rate_csv;
}
# Initialize the color for widget.
colorized_wgt();
# Attach a balloon to each checkbutton widget.
for ( my $j = 2 ; $j < $#radio_sample_csv ; ++$j ) {
$balloon->attach(
$radio_sample_csv[$j],
-balloonmsg => "Averaged CSV sampling rate = $main::sample_rate_csv",
-statusmsg => 'RPC supports only a few sample rates. Select closest approximate to CSV sample rate.'
);
}
sub perform_sample_csv {
$main::params{DELTA_T} = 1 / $main::sample_rate_csv;
}
}
###########################
# End set CSV sample rate #
###########################
########################
# Begin resample frame #
########################
use vars qw(
$frame_resample
@radio_resample @resample_cmd
@frames_resample );
# A sunken frame for buttons, etc.
$frame_resample = $pane_rpc_edit_parameters->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Sampling Rate',
);
# Distinguish separately if CSV file was read in.
if ($main::input_path =~ /\.csv/i) {
$frame_resample->configure(-label => 'RPC Output File Sampling Rate');
}
# Carry over settings across session to next sibling file.
$main::sample_rate = main::get_sample_rate() unless $main::siblinghood_flag;
@radio_resample = GUS::tk::frame_label_radio( 8, $frame_resample, 'Hertz:', \@main::sample_rates, \$main::sample_rate, sub { } );
# Attach a balloon to each checkbutton widget.
for ( my $j = 2 ; $j < $#radio_resample ; ++$j ) {
$balloon->attach(
$radio_resample[$j],
-balloonmsg => 'Change data sampling rate?',
-statusmsg => 'Lowering the sampling rate causes permanent loss of data. If planing to reduce data, wait until output.'
);
}
sub perform_resample {
# Main program's sub will skip if no change in rate.
main::resample($main::sample_rate);
}
######################
# End resample frame #
######################
#######################
# Begin rescale frame #
#######################
use vars qw(
$frame_rescale
@checks_rescale @entries_rescale @scales_rescale @rescale_values @rescale_cmd
@frames_rescale $offscale_count $offscale_msg );
# A sunken frame for buttons, etc.
$frame_rescale = $pane_rpc_edit_parameters->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Rescale Channels',
);
# Create checkboxes to select channels to be rescaled.
my ( @rescale_chans, @rescale_on, @rescale_off, @rescale_checked );
# Carry over settings across session to next sibling file.
@main::rescale_checked = @rescale_checked unless $main::siblinghood_flag;
for ( 1 .. $main::params{CHANNELS} ) {
push @rescale_chans, "$_";
push @rescale_on, 1;
push @rescale_off, 0;
push @rescale_checked, 0;
push @rescale_cmd, \&show_rescale_scales;
}
@checks_rescale = GUS::tk::frame_label_checks(
14, $frame_rescale, 'Channels:',
\@rescale_chans, # Channels
\@rescale_on, # on-value refs
\@rescale_off, # off-value refs
\@main::rescale_checked, # checked or not
\@rescale_cmd, # actions taken when checked
);
# Attach a balloon to each checkbutton widget.
for ( my $j = 2 ; $j < $#checks_rescale ; $j += 2 ) {
my $Nth = $j/2;
my $UoM = $main::params{"UNITS_r_CHAN_$Nth"};
$balloon->attach(
$checks_rescale[$j],
-balloonmsg => qq|Channel $Nth = $main::params{"DESC_r_CHAN_$Nth"}|,
-statusmsg => qq|Channel $Nth: |
. qq| Full Scale = $main::params{"FULL_SCALE_r_CHAN_$Nth"} $UoM |
. qq| Max Peak = $main::params{"MAX_UNITS_$Nth"} $UoM |
. qq| Min Valley = $main::params{"MIN_UNITS_$Nth"} $UoM |
);
}
sub show_rescale_scales {
my @flags = GUS::tk::poll_frame_label_checks(@checks_rescale);
for (@frames_rescale) { $_->destroy if Tk::Exists($_); }
main::update_params_for_all_chans();
# Old widgets have been destroyed along with their frame. Toss 'em.
@scales_rescale = ();
@entries_rescale = ();
# Don't allow a rescale range to clip signal. Set rescale ranges so peak or valley may not overshoot.
for ( 1 .. $main::params{CHANNELS} ) {
if ( shift @flags ) {
# Set limit on scale bloatage.
my $fs = $main::params{"FULL_SCALE_r_CHAN_$_"};
# Set limit on scale shrinkage.
my $min_rescale;
if ( abs( $main::params{"MAX_UNITS_$_"} ) > abs( $main::params{"MIN_UNITS_$_"} ) ) {
$min_rescale = abs( $main::params{"MAX_UNITS_$_"} );
}
else { $min_rescale = abs( $main::params{"MIN_UNITS_$_"} ); }
# Set reasonable slider resolution.
my $fs_res = 1;
if ($fs < 1000) {$fs_res = 0.1}
if ($fs < 100) {$fs_res = 0.01}
if ($fs < 10) {$fs_res = 0.001}
my $max_rescale = $fs * 100000;
# Create the double scale widget.
my @array = GUS::tk::frame_label_entry_label_zoom_label_zoom(
# ARRAY INPUTS:
# $parent,
# $text_1, $text_var_ref,
# $text_2, $from_2, $to_2, $min_limit_2, $max_limit_2, $res_limit_2,
# $text_3, $from_3, $to_3, $min_limit_3, $max_limit_3, $res_limit_3,
# $orient
# Note: Max chan mult is 2000 so can simultaneously increase value
# by up to 200% while changing scales from kN to N or KLBS to LBS, etc.
$frame_rescale,
qq|Ch $_:|, \$main::params{"UNITS_r_CHAN_$_"},
" Ch $_ Mult:", 0.1, 10, 0.001, 2000, 0.001,
" Ch $_ FS:", $fs/10, $fs*10, $min_rescale, $max_rescale, $fs_res
);
$array[4]->set( 1 );
$array[8]->set( $main::params{"FULL_SCALE_r_CHAN_$_"} );
# Give help to user.
$balloon->attach(
$array[4],
-balloonmsg => qq|Channel $_ multiplier.|,
-statusmsg => qq|Rescale channel $_, multiplying it by this factor.|
);
$balloon->attach(
$array[8],
-balloonmsg => qq|Set full scale for channel $_.|,
-statusmsg => qq|Anti-clipping rescale limits for channel $_|
. qq|: Max = $max_rescale * multiplier |
. qq|; Min = $min_rescale * multiplier |
);
push @frames_rescale, $array[0];
push @entries_rescale, $array[2];
push @scales_rescale, @array[4,8];
}
}
}
# Build any carry-overs from earlier in same session.
show_rescale_scales();
# Carry over settings across session from prior sibling file.
if ( $main::siblinghood_flag ) {
my $i = 0;
my $j = 0;
foreach my $scale (@scales_rescale) {
# Retain any settings from prior edits.
GUS::tk::scale_cfg_restore( $scale, \@main::rescale_cfg, $i);
$scale->set( $main::rescale_values[$j] );
$i += 4;
$j += 1;
}
$i = 0;
foreach my $entry (@entries_rescale) {
$entry->delete(0,'end');
$entry->insert(0, $main::rescale_units[$i]);
++$i;
}
}
sub perform_rescale {
@main::rescale_checked = GUS::tk::poll_frame_label_checks(@checks_rescale);
@main::rescale_values = ();
@main::rescale_units = ();
@main::rescale_cfg = ();
$offscale_msg = '';
# Retain scale values across session.
foreach my $scale (@scales_rescale) {
if ( Tk::Exists($scale) ) {
GUS::tk::scale_cfg_save( $scale, \@main::rescale_cfg );
push @main::rescale_values, $scale->get();
}
else {
push @main::rescale_values, 0;
}
}
# Retain entry values across session.
foreach my $entry (@entries_rescale) {
if ( Tk::Exists($entry) ) {
push @main::rescale_units, $entry->get();
}
else {
# push @main::rescale_units, '';
}
}
my $i = 0;
my $j = 0;
my @rescale_chans = ();
my @rescale_values = ();
# Collect for rescale only those checked.
foreach my $flag (@main::rescale_checked) {
if ($flag) {
my $k = $i + 1; # RPC has no channel zero.
push @rescale_chans, $i;
push @rescale_values, @main::rescale_values[$j, $j + 1];
$main::params{"FULL_SCALE_r_CHAN_$k"} = $main::rescale_values[$j + 1];
my $multiplier = $main::rescale_values[$j];
# Scale channel's data points accordingly.
$offscale_count = 0;
for ( 0 .. scalar $#{ $main::all_chans[$i] } ) {
my $datum_ref = \${ $main::all_chans[$i] }[$_];
$$datum_ref *= $multiplier;
++$offscale_count if $$datum_ref > $main::params{"FULL_SCALE_r_CHAN_$k"}
}
$offscale_msg .= "Chan $k = $offscale_count pts, " if $offscale_count;
print qq|Ch$k Multipler = $multiplier \n|
. qq|Chan $k Full Scale = $main::params{"FULL_SCALE_r_CHAN_$k"} \n|;
$j += 2;
}
++$i;
}
# So that the FULL_SCALE carries through to SCALE for each chan.
main::update_params_for_all_chans();
}
#######################
# End rescale frame #
#######################
#######################
# Begin realign frame #
#######################
use vars qw(
$frame_realign
@checks_realign @scales_realign @realign_values @realign_cmd
@frames_realign $realign_compare @realign_dupes @realign_gaps );
# A sunken frame for buttons, etc.
$frame_realign = $pane_rpc_edit_parameters->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Extract/Re-align Channels',
);
# Create checkboxes to select channels to be realigned
my ( @realign_chans, @realign_on, @realign_off, @realign_checked );
# Carry over settings across session to next sibling file.
@main::realign_checked = @realign_checked unless $main::siblinghood_flag;
for ( 1 .. $main::params{CHANNELS} ) {
push @realign_chans, "$_";
push @realign_on, 1;
push @realign_off, 0;
push @realign_checked, 0;
push @realign_cmd, \&show_realign_scales;
}
@checks_realign = GUS::tk::frame_label_checks(
14, $frame_realign, 'Channels:',
\@realign_chans, # Channels
\@realign_on, # on-value refs
\@realign_off, # off-value refs
\@main::realign_checked, # checked or not
\@realign_cmd, # actions taken when checked
);
# Attach a balloon to each checkbutton widget.
for ( my $j = 2 ; $j < $#checks_realign ; $j += 2 ) {
my $Nth = $j/2;
$balloon->attach(
$checks_realign[$j],
-balloonmsg => qq|Channel $Nth = $main::params{"DESC_r_CHAN_$Nth"}|,
-statusmsg => "Check to extract and/or realign channel $Nth "
);
}
sub show_realign_scales {
my @flags = GUS::tk::poll_frame_label_checks(@checks_realign);
for (@frames_realign) { $_->destroy if Tk::Exists($_); }
# Show current alignments of all original channels.
@scales_realign = ();
for ( 1 .. $main::params{CHANNELS} ) {
if ( shift @flags ) {
my $max_realign = $#main::all_chans + 1;
my $min_realign = 1;
my @array =
GUS::tk::frame_label_scale( $frame_realign, qq|Ch $_ becomes:|, $min_realign, $max_realign, 1 );
$balloon->attach(
$array[2],
-balloonmsg => qq|Realign from position $_ to another?|,
-statusmsg => qq|Description = '$main::params{"DESC_r_CHAN_$_"}'. |
);
$array[2]->set($_); # Keep original position to start.
push @scales_realign, $array[2];
push @frames_realign, $array[0];
}
}
}
show_realign_scales();
# Carry over settings across session from prior sibling file.
if ( $main::siblinghood_flag ) {
my $i = 0;
foreach my $scale (@scales_realign) {
$scale->set( $main::realign_values[$i] );
++$i;
}
}
# Test that all elems in array should be unique.
sub check_for_dupes {
my $dupes = 0;
for ( my $i = 0 ; $i < $#_ ; ++$i ) {
for ( my $j = $i + 1 ; $j <= $#_ ; ++$j ) {
if ( $_[$i] == $_[$j] ) {
++$dupes;
foreach my $scale (@scales_realign) {
if ( $scale->get() == $_[$j] ) {
# Highlight all duplicate scales.
$scale->configure( -background => 'gold' );
}
}
}
}
}
return $dupes == 0;
}
# Test that there should be no gaps in array elems 1-to-N.
sub check_for_gaps {
my @seq = sort {$a <=> $b} @_;
my $gaps = 0;
my $j = 1;
for ( my $i = 0 ; $i <= $#_ ; ++$i ) {
if ( $seq[$i] != $j ) {
++$gaps;
foreach my $scale (@scales_realign) {
if ( $scale->get() == $seq[$i] ) {
# Highlight all scales with a gap before them.
$scale->configure( -background => 'orangered' );
$i += $#_;
last;
}
}
}
++$j;
}
return $gaps == 0;
}
# Give color warnings about inappropriate user choices.
sub realign_precheck {
my @realign_checked = GUS::tk::poll_frame_label_checks(@checks_realign);
my @chans = ();
my $j = 0;
foreach my $flag (@realign_checked) {
if ($flag) {
push @chans, $scales_realign[$j]->get();
++$j;
}
}
foreach my $scale (@scales_realign) {
$scale->configure( -background => 'gray' );
}
# Priority 1: Mark YELLOW all duplications of channel position.
# Priority 2: Mark ORANGE any position with a gap to the left (if not also a dupe).
my $ok_gap = check_for_gaps(@chans); # Do separately so && won't skip 2nd if 1st is false.
my $ok_dup = check_for_dupes(@chans); # Do separately so && won't skip 2nd if 1st is false.
if ( $ok_dup && $ok_gap ) { return 1; }
#if ( check_for_dupes(@chans) && check_for_gaps(@chans) ) { return 1;}
else { return 0; }
}
$mw_rpc_edit_parameters->repeat( 500, \&realign_precheck );
# Delete params for deleted channels. Note that after re-alignment is
# already performed, sorting is done. To-be-deleted channels will all
# have migrated to top of numberic sequence. So delete from top down
# regardless of actual key name.
sub delete_extinct_params {
my $i = 1;
foreach my $flag (@main::realign_checked) {
unless ($flag) {
print "Channel $i deleted. \n" if $main::debug_flag;
while ( my ( $key, $value ) = each %main::params ) {
if ( $key =~ m/_r_CHAN_$main::params{CHANNELS}/ ) {
print "\tDeleted param = $key \n" if $main::debug_flag > 1;
delete $main::params{$key};
}
}
--$main::params{CHANNELS};
}
++$i;
}
}
sub perform_realign {
# To prevent channel-naming from going awry later (re-alignment does not upset
# siblinghood test), here make ready to compare against last time's selection...
my @prior_realign_checked = @main::realign_checked if defined @main::realign_checked;
# Now attend to the current selection....
@main::realign_checked = GUS::tk::poll_frame_label_checks(@checks_realign);
# Lastly compare the prior and current selections, setting a flag accordingly
if ( GUS::general::comp_numeric_arrays( \@prior_realign_checked, \@main::realign_checked ) ) {
# So prior channel-name choices will carry through.
$main::realign_change_flag = 0;
}
else {
# Elsewise, they should stay as from input file.
$main::realign_change_flag = 1;
}
@main::realign_values = ();
# Retain values across session.
foreach my $scale (@scales_realign) {
if ( Tk::Exists($scale) ) { push @main::realign_values, $scale->get(); }
else { push @main::realign_values, 0; }
}
print "\nRealign flags = ", join ", ", @main::realign_checked, " \n" if $main::debug_flag;
print "Realign values = ", join ", ", @main::realign_values, " \n\n" if $main::debug_flag;
# Extract/re-align references to selected channels.
my @new_alignment = ();
my $i = 0; # Index to @main::realign_checked with 1's & 0's for each.
my $j = 0; # Index to @main::realign_values with an int for every 1 in @main::realign_checked
foreach my $flag (@main::realign_checked) {
if ($flag) {
print( "Migrating channel array indices: $i -> ", ( $main::realign_values[$j] - 1 ), " \n" )
if $main::debug_flag;
$new_alignment[ $main::realign_values[$j] - 1 ] = $main::all_chans[$i];
++$j;
}
++$i;
}
# Make the swap, provided any channels were actually realigned.
@main::all_chans = @new_alignment;
# Redefine params for re-aligned channels.
$i = 1;
$j = 0;
my %params = (); # A temporary storage hash.
# Copy any to-be-realigned parameter into temporary storage.
foreach my $flag (@main::realign_checked) {
if ($flag) {
while ( my ( $key, $value ) = each %main::params ) {
if ( $key =~ m/_r_CHAN_$i/ ) {
$key =~ s/$i/$main::realign_values[$j]/;
$params{$key} = $value;
}
}
++$j;
}
++$i;
}
# Force channel mapping as 1:1.
$i = scalar @main::all_chans;
while ( $i > 0 ) { $params{"MAP_r_CHAN_$i"} = $i; --$i }
# Copy back from temporary into main, thereby avoiding round-robin overwrite.
while ( my ( $key, $value ) = each %params ) {
$main::params{$key} = $value;
print "\tRedefined: param key = $key, value = $value \n" if $main::debug_flag > 1;
delete $params{$key};
}
delete_extinct_params();
}
#######################
# End realign frame #
#######################
########################
# Begin format frame #
########################
use vars qw( $frame_format );
# A sunken frame for buttons, etc.
$frame_format = $pane_rpc_edit_parameters->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Data Grouping Format',
);
# Set carry-over default if not first file edited.
$main::pts_per_frame = $main::params{'PTS_PER_FRAME'} unless defined $main::pts_per_frame;
my @pts_format = GUS::tk::frame_label_radio(
8, $frame_format, 'Frame Size:',
['512', '1024', '2048', '4096'],
\$main::pts_per_frame,
sub { },
);
######################
# End format frame #
######################
# A sunken frame for buttons, etc.
my $frame_btm = $mw_rpc_edit_parameters->Frame(
-relief => 'flat',
-borderwidth => 5
);
GUS::tk::frame_label_buttons(
$frame_btm, 'Action:',
[ 'Accept', 'Cancel' ],
[ sub { accept_edits(); }, sub { quit_MainLoop(); } ],
[ 'red', 'green' ],
);
$frame_description->pack( -side => 'top', -expand => 1, -fill => 'both' );
$frame_format->pack( -side => 'top', -expand => 1, -fill => 'both' );
$frame_sample_csv->pack( -side => 'top', -expand => 1, -fill => 'both' ) if $main::input_path =~ /\.csv/i;
$frame_resample->pack( -side => 'top', -expand => 1, -fill => 'both' );
$frame_rescale->pack( -side => 'top', -expand => 1, -fill => 'both' );
$frame_realign->pack( -side => 'top', -expand => 1, -fill => 'both' );
$help_info->pack( -side => 'top', -expand => 0, -fill => 'x' );
$frame_btm->pack( -side => 'top', -expand => 0, -fill => 'x' );
# Proceed automatically when so configured.
accept_edits() unless $main::edit_mode_flag =~ 'manual';
MainLoop;
# FIX THIS! Below makes vertical overshoot, partly obscuring buttons at bottom.
# $mw_rpc_edit_parameters->packPropagate(0);
# $mw_rpc_edit_parameters->FullScreen;
}
sub accept_edits {
if ( realign_precheck() ) {
main::update_params_for_all_chans();
# Set the RPC data grouping params.
$main::params{'PTS_PER_FRAME'} = $main::pts_per_frame;
$main::params{'PTS_PER_GROUP'} = $main::pts_per_frame;
# Note: there is no sub '&perform_description()' because label-widgets point directly.
perform_sample_csv() if $main::input_path =~ /\.csv/i;
perform_resample();
perform_rescale();
# Extract/re-align channels only when one or more are checked. Else would
# delete all channels! No scales will exist unless checked. So test for those.
perform_realign() if Tk::Exists( $scales_realign[0] );
if ( $main::edit_mode_flag =~ 'manual') {
# Go on to 2nd stage editing with possibly fewer and/or re-named channels.
GUS::rpc_edit_datapoints::start_MainLoop() unless $offscale_count;
}
main::show_chan_array_end_addrs('rpc_edit_params');
quit_MainLoop();
if ( $offscale_msg ne '' ) {
$main::error_msg = "Oops! Offscale data counts: $offscale_msg";
$main::feedback = $main::error_msg;
# Pop up a window about non-siblinghood.
GUS::pop_up_window::start_MainLoop(
'red', ' Rescaling Error',
$main::error_msg,
'Acknowledge', sub {}, []
);
}
}
}
# Close down the Perl/Tk GUI
sub quit_MainLoop {
# Preset radiobutton for custom, paste-in edits.
$main::edits_via_perl{'timing'} = 'Final';
$mw_rpc_edit_parameters->destroy() if Tk::Exists($mw_rpc_edit_parameters);
}
END { }
###################################
# End RPC Edit Parameters Package #
###################################
#####################################
# Begin RPC Edit Datapoints Package #
# Version 2005-01-28 #
#####################################
package GUS::rpc_edit_datapoints;
BEGIN { }
use Tk;
use Tk::Pane;
use Tk::Balloon;
use strict;
no strict "refs";
# Declare variables for strict.
use vars qw(
$mw_rpc_edit_datapoints $pane_rpc_edit_datapoints
$help_info $balloon );
sub start_MainLoop {
$mw_rpc_edit_datapoints = MainWindow->new( -title => ' Datapoint Editing Sequence' );
# $mw_rpc_edit_datapoints = $main::mw->TopLevel( -title => ' Datapoint Editing Sequence' );
# An outermost pane to scroll all sub-panes within.
$pane_rpc_edit_datapoints = $mw_rpc_edit_datapoints->Scrolled(
'Pane',
-scrollbars => 'osow',
-sticky => 'new'
)->pack( -side => 'top', -expand => 1, -fill => 'both' );
# Provide help info as balloon widgets.
$help_info = $mw_rpc_edit_datapoints->Label(
-borderwidth => 2,
-relief => 'groove',
-background => $main::balloon_bg,
-foreground => $main::balloon_fg,
);
$balloon = $mw_rpc_edit_datapoints->Balloon(
-statusbar => $help_info,
-balloonposition => 'mouse',
-background => $main::balloon_bg,
-foreground => $main::balloon_fg,
);
$balloon->attach( $help_info, -msg => 'Hover mouse on any widget then read here.' );
&main::update_params_for_all_chans(); # Must know max and min to go on...
###########################
# Begin description frame #
###########################
# NOTE: This frame has a pseudo-twin in the RPC Edit Parameters Package above.
use vars qw( $frame_description );
# A sunken frame for buttons, etc.
$frame_description = $pane_rpc_edit_datapoints->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Descriptions',
);
my @params_widgets;
#my @param_keys = keys %main::params;
my @chan_desc_keys = ();
# So that 'DESCRIPTION' will be on top.
if ( defined $main::params{DESCRIPTION} ) { $chan_desc_keys[0] = 'DESCRIPTION' }
# Get descriptions in manner that will sort numerically
# above channel 9.
for ( my $i = 1; defined $main::params{"DESC_r_CHAN_$i"} ; ++$i ) {
push @chan_desc_keys, "DESC_r_CHAN_$i";
}
foreach my $key ( @chan_desc_keys ) {
# Preserve prior descriptions across a session of sibling files. Don't loose if user clicks
# the 'Read' button without real cause.
if ( $main::siblinghood_flag ) {
if ( defined $main::desc{$key} ) {
if ( $main::realign_change_flag == 0 ) {
$main::params{$key} = $main::desc{$key};
print "Chan desc $key = $main::desc{$key} as carried over from prior edit. \n ";
}
# else { print "Note: Chan desc $key not renamed because \$main::realign_change_flag != 0 \n" }
}
# else { print "Note: Chan desc $key not renamed because \$main::desc{\$key} not defined. \n" }
}
my $label_text = $key;
$label_text =~ s/DESC_r_CHAN_/Desc. Ch /;
$label_text =~ s/DESCRIPTION/Desc. File/;
push @params_widgets, GUS::tk::frame_label_entry( $frame_description, $label_text, \$main::params{$key}, );
$balloon->attach(
$params_widgets[-1],
-balloonmsg => 'Edit now, if desired.',
-statusmsg => 'You may edit channel name now (since extraction/realignment are done).'
);
}
sub perform_description {
my @param_keys = keys %main::params;
foreach my $key ( sort @param_keys ) {
$main::desc{$key} = $main::params{$key} if $key =~ /DESC/;
}
}
#########################
# End description frame #
#########################
###########################
# Begin remove mean frame #
###########################
use vars qw(
$frame_remove_mean
@checks_remove_mean @remove_mean_cmd
@frames_remove_mean );
# A sunken frame for buttons, etc.
$frame_remove_mean = $pane_rpc_edit_datapoints->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Remove Mean',
);
# Create checkboxes to select channels for mean-removal
my ( @remove_mean_chans, @remove_mean_on, @remove_mean_off, @remove_mean_checked );
# Carry over settings across session to next sibling file.
@main::remove_mean_checked = @remove_mean_checked unless $main::siblinghood_flag;
for ( 1 .. $main::params{CHANNELS} ) {
push @remove_mean_chans, "$_";
push @remove_mean_on, 1;
push @remove_mean_off, 0;
push @remove_mean_checked, 0;
push @remove_mean_cmd, sub {};
}
@checks_remove_mean = GUS::tk::frame_label_checks(
14, $frame_remove_mean, 'Channels:',
\@remove_mean_chans, # Channels
\@remove_mean_on, # on-value refs
\@remove_mean_off, # off-value refs
\@main::remove_mean_checked, # checked or not
\@remove_mean_cmd, # actions taken when checked
);
# Attach a balloon to each checkbutton widget.
for ( my $j = 2 ; $j < $#checks_remove_mean ; $j += 2 ) {
$balloon->attach(
$checks_remove_mean[$j],
-balloonmsg => 'Remove mean from channel ' . ( $j / 2 ) . '?',
-statusmsg => 'Check to have mean removed from channel ' . ( $j / 2 ) . '.'
);
}
sub perform_remove_mean {
@main::remove_mean_checked = GUS::tk::poll_frame_label_checks(@checks_remove_mean);
@main::remove_mean_chans = ();
my $i = 0;
my $j = 0;
# Collect only those checked.
foreach my $flag (@main::remove_mean_checked) {
if ($flag) {
push @main::remove_mean_chans, $i;
&main::remove_from_one_chan( 'mean', $i );
++$j;
}
++$i;
}
}
###########################
# End remove mean frame #
###########################
#############################
# Begin remove offset frame #
#############################
use vars qw(
$frame_remove_offset
@checks_remove_offset @remove_offset_cmd
@frames_remove_offset );
# A sunken frame for buttons, etc.
$frame_remove_offset = $pane_rpc_edit_datapoints->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Remove Initial Offset',
);
# Create checkboxes to select channels for offset removal.
my ( @remove_offset_chans, @remove_offset_on, @remove_offset_off, @remove_offset_checked );
# Carry over settings across session to next sibling file.
@main::remove_offset_checked = @remove_offset_checked unless $main::siblinghood_flag;
for ( 1 .. $main::params{CHANNELS} ) {
push @remove_offset_chans, "$_";
push @remove_offset_on, 1;
push @remove_offset_off, 0;
push @remove_offset_checked, 0;
push @remove_offset_cmd, sub {};
}
@checks_remove_offset = GUS::tk::frame_label_checks(
14, $frame_remove_offset, 'Channels:',
\@remove_offset_chans, # Channels
\@remove_offset_on, # on-value refs
\@remove_offset_off, # off-value refs
\@main::remove_offset_checked, # checked or not
\@remove_offset_cmd, # actions taken when checked
);
# Attach a balloon to each checkbutton widget.
for ( my $j = 2 ; $j < $#checks_remove_offset ; $j += 2 ) {
$balloon->attach(
$checks_remove_offset[$j],
-balloonmsg => 'Remove offset from channel ' . ( $j / 2 ) . '?',
-statusmsg => 'Check to have inital offset (calculated as average of 1st ten points) removed from channel ' . ( $j / 2 ) . '.'
);
}
sub perform_remove_offset {
@main::remove_offset_checked = GUS::tk::poll_frame_label_checks(@checks_remove_offset);
@main::remove_offset_chans = ();
my $i = 0;
my $j = 0;
# Collect only those checked.
foreach my $flag (@main::remove_offset_checked) {
if ($flag) {
push @main::remove_offset_chans, $i;
&main::remove_from_one_chan( 'offset', $i );
++$j;
}
++$i;
}
}
#############################
# End remove offset frame #
#############################
################################
# Begin reverse polarity frame #
################################
use vars qw(
$frame_reverse_polarity
@checks_reverse_polarity @reverse_polarity_cmd
@frames_reverse_polarity );
# A sunken frame for buttons, etc.
$frame_reverse_polarity = $pane_rpc_edit_datapoints->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Reverse Polarity',
);
# Create checkboxes to select channels for polarity reversal.
my ( @reverse_polarity_chans, @reverse_polarity_on, @reverse_polarity_off, @reverse_polarity_checked );
# Carry over settings across session to next sibling file.
@main::reverse_polarity_checked = @reverse_polarity_checked unless $main::siblinghood_flag;
for ( 1 .. $main::params{CHANNELS} ) {
push @reverse_polarity_chans, "$_";
push @reverse_polarity_on, 1;
push @reverse_polarity_off, 0;
push @reverse_polarity_checked, 0;
push @reverse_polarity_cmd, sub {};
}
@checks_reverse_polarity = GUS::tk::frame_label_checks(
14, $frame_reverse_polarity, 'Channels:',
\@reverse_polarity_chans, # Channels
\@reverse_polarity_on, # on-value refs
\@reverse_polarity_off, # off-value refs
\@main::reverse_polarity_checked, # checked or not
\@reverse_polarity_cmd, # actions taken when checked
);
# Attach a balloon to label and each checkbutton widget.
$balloon->attach(
$checks_reverse_polarity[1],
-balloonmsg => 'Reverse channels?',
-statusmsg => 'Flip polarity on selected channels.'
);
for ( my $j = 2 ; $j < $#checks_reverse_polarity ; $j += 2 ) {
$balloon->attach(
$checks_reverse_polarity[$j],
-balloonmsg => 'Reverse polarity of channel ' . ( $j / 2 ) . '?',
-statusmsg => 'Check to reverse polarity of channel ' . ( $j / 2 ) . '.'
);
}
sub perform_reverse_polarity {
@main::reverse_polarity_checked = GUS::tk::poll_frame_label_checks(@checks_reverse_polarity);
@main::reverse_polarity_chans = ();
my $i = 0;
my $j = 0;
# Collect for offset only those checked.
foreach my $flag (@main::reverse_polarity_checked) {
if ($flag) {
push @main::reverse_polarity_chans, $i;
&main::reverse_chan_polarity( $i );
++$j;
}
++$i;
}
}
################################
# End reverse polarity frame #
################################
#######################
# Begin hanning frame #
#######################
use vars qw(
$frame_han @checks_han @han_noise_band @han_chans @han_on @han_off @han_checked @han_cmd
@scale_han @scale_han_subtlety @scale_han_noise_band
);
# A sunken frame for buttons, etc.
$frame_han = $pane_rpc_edit_datapoints->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Hanning Filter',
);
my ( @han_chans, @han_on, @han_off, @han_checked ); # Keep strict happy.
# Carry over settings across session to next sibling file.
@main::han_checked = @han_checked unless $main::siblinghood_flag;
for ( 1 .. $main::params{CHANNELS} ) {
push @han_chans, "$_";
push @han_on, 1;
push @han_off, 0;
push @han_checked, 0;
push @han_cmd, \&show_han_scales;
}
# A checkbox widget for selecting which channels to han.
@checks_han = GUS::tk::frame_label_checks(
14, $frame_han, 'Channels:',
\@han_chans, # Channels
\@han_on, # on-value refs
\@han_off, # off-value refs
\@main::han_checked, # checked or not
\@han_cmd, # actions taken when checked
);
# Attach a balloon to the label and checkbutton widgets.
$balloon->attach(
$checks_han[1],
-balloonmsg => 'Han channels?',
-statusmsg => 'Filter selected channels by the hanning method.'
);
for ( my $j = 2 ; $j < $#checks_han ; $j += 2 ) {
$balloon->attach(
$checks_han[$j],
-balloonmsg => 'Han filter channel ' . ( $j / 2 ) . '?',
-statusmsg => 'Select if channel ' . ( $j / 2 ) . ' should be smoothed with a hanning filter.'
);
}
# A scale widget for selecting a noise band for peak-to-peak hanning.
sub mk_han_noise_band_scale {
# Build a Tk scale with zoom buttons.
# ARRAY: parent_frame, label_text, from, to, min_limit, max_limit, res_limit, orient
@scale_han_noise_band = GUS::tk::frame_label_zoom( $frame_han, "Noise Band:", 1, 10, 0,20, 0.1, 'horizontal' );
# Retain any settings from prior edits.
GUS::tk::scale_cfg_restore( $scale_han_noise_band[2], \@main::han_noise_band_cfg, 0)
if $main::siblinghood_flag;
# Default or retained setting.
$scale_han_noise_band[2]->set( $main::han_noise_band );
$balloon->attach(
$scale_han_noise_band[1],
-balloonmsg => 'Peak detector algorithm.',
-statusmsg => "Nails down peaks and valleys so hanning won't soften them."
);
$balloon->attach(
$scale_han_noise_band[2],
-balloonmsg => 'Sensitivity to peaks.',
-statusmsg => 'Any peak or valley outside the noise band will be preserved during hanning.'
);
}
# A scale widget for selecting how many times to han a channel.
sub mk_han_scale {
# Build a Tk scale with zoom buttons.
# ARRAY: parent_frame, label_text, from, to, min_limit, max_limit, res_limit, orient
@scale_han = GUS::tk::frame_label_zoom( $frame_han, 'Passes:', 0, 10, 0, 100, 1 );
# Retain any settings from prior edits.
GUS::tk::scale_cfg_restore( $scale_han[2], \@main::han_passes_cfg, 0)
if $main::siblinghood_flag;
# Default or retained setting.
$scale_han[2]->set($main::han_passes);
$balloon->attach(
$scale_han[1],
-balloonmsg => 'Filter loop.',
-statusmsg => 'Set for the number of loops to run through the hanning filter.'
);
$balloon->attach(
$scale_han[2],
-balloonmsg => 'Loop index.',
-statusmsg => 'Hint! More subtle passes smoothes better than fewer coarse ones'
);
}
#A scale widget for selecting how subtly to han channels.
sub mk_han_subtlety_scale {
# Build a Tk scale with zoom buttons.
# ARRAY: parent_frame, label_text, from, to, min_limit, max_limit, res_limit, orient
@scale_han_subtlety = GUS::tk::frame_label_zoom( $frame_han, 'Subtlety:', 0, 5, 0, 100, 0.1 );
# Retain any settings from prior edits.
GUS::tk::scale_cfg_restore( $scale_han_subtlety[2], \@main::han_subtlety_cfg, 0)
if $main::siblinghood_flag;
# Default or retained setting.
$scale_han_subtlety[2]->set($main::han_subtlety);
$balloon->attach(
$scale_han_subtlety[1],
-balloonmsg => 'Han softening algorithm.',
-statusmsg => "Higher values make the hanning softer."
);
$balloon->attach(
$scale_han_subtlety[2],
-balloonmsg => 'Index S for all points P.',
-statusmsg => "Zero is coarse and ten subtle per the algorithm: " . "P2' = (P1 + S*P2 + P3)/(S + 2)"
);
}
# Display scale widgets only when a channel is checked.
sub show_han_scales {
$scale_han[0]->destroy if Tk::Exists( $scale_han[0] );
$scale_han_subtlety[0]->destroy if Tk::Exists( $scale_han_subtlety[0] );
$scale_han_noise_band[0]->destroy if Tk::Exists( $scale_han_noise_band[0] );
my @flags = GUS::tk::poll_frame_label_checks(@checks_han);
for (@flags) {
if ($_) {
unless ( Tk::Exists( $scale_han_noise_band[0] ) ) { mk_han_noise_band_scale() }
unless ( Tk::Exists( $scale_han[0] ) ) { mk_han_scale() }
unless ( Tk::Exists( $scale_han_subtlety[0] ) ) { mk_han_subtlety_scale() }
}
}
}
# Build any carry-overs from earlier in same session.
show_han_scales();
# Han selected channels the selected number of times.
sub perform_hanning {
@main::han_checked = GUS::tk::poll_frame_label_checks(@checks_han);
# Retain values across session for future edits edits.
if ( Tk::Exists($scale_han[2]) ) {
$main::han_noise_band = $scale_han_noise_band[2]->get();
GUS::tk::scale_cfg_save( $scale_han_noise_band[2], \@main::han_noise_band_cfg);
$main::han_passes = $scale_han[2]->get();
GUS::tk::scale_cfg_save( $scale_han[2], \@main::han_passes_cfg);
$main::han_subtlety = $scale_han_subtlety[2]->get();
GUS::tk::scale_cfg_save( $scale_han_subtlety[2], \@main::han_subtlety_cfg);
};
my $i = 0; # Index to array ref in @all_chans.
foreach my $flag (@main::han_checked) {
if ( $flag && $main::han_passes ) {
main::han_chan_n_times( $i, $main::han_passes, $main::han_subtlety, $main::han_noise_band / 100 );
}
++$i;
}
}
#######################
# End hanning frame #
#######################
#######################
# Begin Pythag Frame #
#######################
use vars qw(
$frame_pythag @frames_pythag @checks_pythag @scales_pythag
@pythag_weights @pythag_cmd @noise_band
@repeats
@expand_freq @expand_ratio @expand_min );
# A sunken frame for buttons, etc.
$frame_pythag = $pane_rpc_edit_datapoints->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Pythagorized Data Reduction',
);
####################################
# Begin reduction method selection #
####################################
my ( @pythag_method, $pythag_flag, @expand_method, $expand_flag );
@pythag_method = GUS::tk::frame_label_radio(
8, $frame_pythag, 'Winnow:', ['Peak Slice', 'Vector Envelope'], \$main::pythag_flag, sub { }
);
$main::pythag_flag = 'Vector Envelope' unless defined $main::pythag_flag;
# Attach a balloon to the label and radiobutton widgets.
$balloon->attach(
$pythag_method[1],
-balloonmsg => 'How to winnow?',
-statusmsg => 'Method for winnowing data points to reduce file length.'
);
$balloon->attach(
$pythag_method[2],
-balloonmsg => 'Keep only peaks & valleys?',
-statusmsg => 'Eliminate all points not simultaneous with either a peak or valley.'
);
$balloon->attach(
$pythag_method[3],
-balloonmsg => 'Lose all <= min vector?',
-statusmsg => 'Straighten to chords every vector of less than the given magnitude from channel mean.'
);
##################################
# Begin trigger method selection #
##################################
my ( @pythag_trigger );
@pythag_trigger = GUS::tk::frame_label_radio(
8, $frame_pythag, 'Trigger:', ['Simple', 'Complex'], \$main::trigger_flag, sub { }
);
$main::trigger_flag = 'Complex' unless defined $main::trigger_flag;
# Attach a balloon to label and radiobutton widgets.
$balloon->attach(
$pythag_trigger[1],
-balloonmsg => 'Trigger winnowing how?',
-statusmsg => 'Select how many triggers to use in winnowing data points.'
);
$balloon->attach(
$pythag_trigger[2],
-balloonmsg => 'Pythagorized only?',
-statusmsg => "Data winnowed from each channel in proportion to that channel's fraction of the Pythagorized whole."
. " Culls the most data points."
);
$balloon->attach(
$pythag_trigger[3],
-balloonmsg => 'Selected channels too?',
-statusmsg => "Data winnowed from each channel in proportion to itself as well as to the Pythagorized whole."
. " Culls fewer data points."
);
##############################
# Begin NB Percent selection #
##############################
my ( @pythag_range );
@pythag_range = GUS::tk::frame_label_radio(
8, $frame_pythag, 'Percentage:', ['Relative', 'Absolute'], \$main::range_flag, sub { }
);
$main::range_flag = 'Absolute' unless defined $main::range_flag;
# Attach a balloon to label and radiobutton widgets.
$balloon->attach(
$pythag_range[1],
-balloonmsg => 'Noise band range?',
-statusmsg => 'Noise band is a percent of some range. Choose which range.'
);
$balloon->attach(
$pythag_range[2],
-balloonmsg => 'N% of data max/min?',
-statusmsg => "A 50% percent noise band represents half of each channel's max/min data-point range."
. "Output is relative to waveform envelope."
);
$balloon->attach(
$pythag_range[3],
-balloonmsg => 'N% of full scale?',
-statusmsg => "A 50% percent noise band represents half of each channel's full scale range."
. "Output is independent of waveform envelope."
);
##################################
# Begin winnow options selection #
##################################
my ( @winnow_options );
@winnow_options = GUS::tk::frame_label_radio(
8, $frame_pythag, 'Baseline:', ['Sans Mean', 'Sans Offset', 'As Is'], \$main::winnow_flag, sub { }
);
$main::winnow_flag = 'As Is' unless defined $main::winnow_flag;
# Attach a balloon to only the radiobutton widgets.
$balloon->attach(
$winnow_options[1],
-balloonmsg => "Baseline for winnowing.",
-statusmsg => 'Insignificant data points will be winnowed out according to baseline selected here.'
);
$balloon->attach(
$winnow_options[2],
-balloonmsg => 'As if mean removed?',
-statusmsg => 'Remove mean temporarily while winnowing data points. Restore after.'
);
$balloon->attach(
$winnow_options[3],
-balloonmsg => 'As if offset removed?',
-statusmsg => 'Remove initial offset temporarily while winnowing data points. Restore after.'
);
$balloon->attach(
$winnow_options[4],
-balloonmsg => 'As is?',
-statusmsg => 'Remove nothing temporarily. Winnow data points just as they are.'
);
####################################
# Begin expansion method selection #
####################################
@expand_method = GUS::tk::frame_label_radio(
8, $frame_pythag, 'Inflate:', ['Haversine', 'Bezier', 'None'], \$main::expand_flag, sub { }
);
$main::expand_flag = 'Bezier' unless defined $main::expand_flag;
# Attach a balloon to only the radiobutton widgets.
$balloon->attach(
$expand_method[1],
-balloonmsg => 'Inflate channels?',
-statusmsg => 'After reduction, retained data segments will be inflated according to chosen algorithm.'
);
$balloon->attach(
$expand_method[2],
-balloonmsg => 'Haversine curves?',
-statusmsg => 'Concatenate by haversine: dwell at peaks, valleys and simultaneous midpoints.'
);
$balloon->attach(
$expand_method[3],
-balloonmsg => 'Bezier curves?',
-statusmsg => 'Concatenate by 3rd order splines: dwell only at peaks & valleys; slope through mid-points.'
);
$balloon->attach(
$expand_method[4],
-balloonmsg => 'Leave as may be?',
-statusmsg => 'Concatenate without inflation: crowd kept data at center; null pad to left & right.'
);
####################################
# Begin reduction method selection #
####################################
# Create checkboxes to select channels for pythagorization into new chan.
my ( @pythag_chans, @pythag_on, @pythag_off, @pythag_checked );
# Carry over settings across session to next sibling file.
@main::pythag_checked = @pythag_checked unless $main::siblinghood_flag;
for ( 1 .. $main::params{CHANNELS} ) {
push @pythag_chans, "$_";
push @pythag_on, 1;
push @pythag_off, 0;
push @pythag_checked, 0;
push @pythag_cmd, \&show_pythag_scales;
}
@checks_pythag = GUS::tk::frame_label_checks(
14, $frame_pythag, 'Channels:',
\@pythag_chans, # Channels
\@pythag_on, # on-value refs
\@pythag_off, # off-value refs
\@main::pythag_checked, # checked or not
\@pythag_cmd, # action taken when checked
);
# Attach a balloon to only the checkbutton widgets.
for ( my $j = 2 ; $j < $#checks_pythag ; $j += 2 ) {
$balloon->attach(
$checks_pythag[1],
-balloonmsg => 'Which trigger channels?',
-statusmsg => 'Selected channels will be employed to trigger data point winnowing.'
);
$balloon->attach(
$checks_pythag[$j],
-balloonmsg => 'Include channel ' . ( $j / 2 ) . '?',
-statusmsg => 'Select if channel ' . ( $j / 2 ) . ' should be included when Pythagorizing.'
);
}
sub mk_pythag_scale {
my @array = GUS::tk::frame_label_zoom( $frame_pythag, "Weight Ch $_:", 0.05, 10, 0, 100, 0.01, 'horizontal' );
$balloon->attach(
$array[1],
-balloonmsg => 'Weight this channel?',
-statusmsg => "How heavy will this channel's magnitude weigh in the data winnowing algorithm?"
);
$balloon->attach(
$array[2],
-balloonmsg => qq|Weight channel $_| . qq|'s value in $main::params{"UNITS_r_CHAN_$_"} by this multiple.|,
-statusmsg => qq|A 2-axis vector calculates as V = sqrt(x^2 + y^2). An N-axis vector |
. qq|calculates as Y = sqrt( A^2 + B^2 + C^2 ... + Z^2). Pythagorize a single |
. qq|composit channel for analysis or peak slicing. |
);
$array[2]->set(1); # Default is unity.
push @scales_pythag, $array[2];
push @frames_pythag, $array[0];
}
sub mk_noise_band_scale {
@noise_band = GUS::tk::frame_label_zoom( $frame_pythag, "Noise Band:", 0,
$main::noise_band * 2, 0, 80, 0.001, 'horizontal' );
$balloon->attach(
$noise_band[1],
-balloonmsg => 'Noise band for winnowing',
-statusmsg => "Set the noise band (threshold) for winnowing out data points."
);
$balloon->attach(
$noise_band[2],
-balloonmsg => qq|Change noiseband?|,
-statusmsg => qq|Noise band of 5 filters out peaks less than 5% of Pythagorized maximum peak. |
);
$noise_band[2]->set( $main::noise_band ); # Default noise band.
push @frames_pythag, $noise_band[0];
}
# Build a frame and scale for concatenating waveform to self N times.
sub mk_repeats_scale {
@repeats = GUS::tk::frame_label_zoom( $frame_pythag, "Repeats:", 1, 10, 1, 100, 1, 'horizontal' );
$balloon->attach(
$repeats[1],
-balloonmsg => qq|How many repeats?|,
-statusmsg => qq|After winnowing, copy entire result to end. In effect, loop N times thorough data. |
);
$balloon->attach(
$repeats[2],
-balloonmsg => qq|Multiple repeats?|,
-statusmsg => qq|Repeat value of 3 concatenates 2 copies of same data to end. |
);
$repeats[2]->set( $main::repeats ); # Default noise band.
push @frames_pythag, $repeats[0];
}
########################################
# Begin flatness sensitivity selection #
########################################
# By flatness I refer to a region of the time history file where the resultant vector
# of all channels combined is a kind of fuzzy plateau. These are to be foreshortened
# in the time domain.
use vars qw( $frame_antiflats );
# Flatness detection only appropriate for vector envelope method, not peak slice.
sub mk_antiflats_frame {
$frame_antiflats->destroy() if Tk::Exists($frame_antiflats);
# A grooved frame for special option.
$frame_antiflats = $frame_pythag->Frame(
-relief => 'groove',
-borderwidth => 3,
-label => 'Data Reduction Options for Vector Envelope',
)->pack( -side => 'top', -expand => 1, -fill => 'both' );
mk_antiflats_checks();
mk_antiflats_nb_scale();
mk_antiflats_ms_scale();
}
use vars qw( @checks_antiflats @antiflats_cmd @antiflats_nb @antiflats_ms );
@antiflats_cmd = ( sub{}, sub{}, sub{} );
sub mk_antiflats_checks {
# A checkbox widget for selecting where to remove fuzzy plateaus.
@checks_antiflats = GUS::tk::frame_label_checks(
14, $frame_antiflats, 'Fuzz sweep:',
['Start', 'Across', 'End'], # Sweeps
[1,1,1], # on-value refs
[0,0,0], # off-value refs
\@main::antiflats_checked, # checked or not
\@antiflats_cmd, # actions taken when checked
);
# Attach a balloon to the label and checkbutton widgets.
$balloon->attach(
$checks_antiflats[1],
-balloonmsg => 'Fuzz sweep directions',
-statusmsg => 'Sweep to winnow out fuzzy plateaus without compromising phase.'
);
$balloon->attach(
$checks_antiflats[2],
-balloonmsg => 'Sweep from front',
-statusmsg => 'Reduce fuzzy plateau found at LH terminus.'
);
$balloon->attach(
$checks_antiflats[4],
-balloonmsg => 'Sweep across',
-statusmsg => 'Reduce fuzzy plateaus found not at the termini.'
);
$balloon->attach(
$checks_antiflats[6],
-balloonmsg => 'Sweep from end',
-statusmsg => 'Reduce fuzzy plateau from RH terminus.'
);
}
# Build a frame and scale for the anti-flatness noise band selection.
sub mk_antiflats_nb_scale {
@antiflats_nb = GUS::tk::frame_label_zoom( $frame_antiflats, "Fuzz NB:",
0, $main::antiflats_nb * 2, 0, 80, 0.001, 'horizontal' );
$balloon->attach(
$antiflats_nb[1],
-balloonmsg => 'Vert fuzz window.',
-statusmsg => "Magnitude sensitivity: height of sliding window for detection of fuzzy plateaus."
);
$balloon->attach(
$antiflats_nb[2],
-balloonmsg => qq|Max fuzz magnitude?|,
-statusmsg => qq|Setting similar to VE noise band, but for detecting plateaus to be reduced. |
);
$antiflats_nb[2]->set( $main::antiflats_nb ); # Default noise band.
push @frames_pythag, $antiflats_nb[0];
}
# Build a frame and scale for the anti-flatness width selection.
sub mk_antiflats_ms_scale {
@antiflats_ms = GUS::tk::frame_label_zoom( $frame_antiflats, "Fuzz mS:",
0, $main::antiflats_ms * 2, 0, 2000, 1, 'horizontal' );
$balloon->attach(
$antiflats_ms[1],
-balloonmsg => 'Horiz fuzz window.',
-statusmsg => "Time sensivity: width of sliding window for detection of fuzzy plateaus."
);
$balloon->attach(
$antiflats_ms[2],
-balloonmsg => qq|Max fuzz duration|,
-statusmsg => qq|Setting of 500mS will cause fuzzy plateaus longer than that to be reduced. |
);
$antiflats_ms[2]->set( $main::antiflats_ms );
push @frames_pythag, $antiflats_ms[0];
}
sub perform_antiflats {
# Dosen't do more than set flags for fuzzy platform winnowing.
@main::antiflats_checked = GUS::tk::poll_frame_label_checks(@checks_antiflats);
}
######################################
# Begin peak slice options selection #
######################################
use vars qw( $frame_ps_options );
# Flatness detection only appropriate for vector envelope method, not peak slice.
sub mk_ps_options_frame {
$frame_ps_options->destroy() if Tk::Exists($frame_ps_options);
# A grooved frame for special option.
$frame_ps_options = $frame_pythag->Frame(
-relief => 'groove',
-borderwidth => 3,
-label => 'Data Inflation Options for Peak Slice',
)->pack( -side => 'top', -expand => 1, -fill => 'both' );
mk_expand_freq_scale();
mk_expand_ratio_scale();
mk_expand_min_scale();
mk_resample_radio();
}
# Build a frame and scale for setting the minimum number of bezier points when expanding.
sub mk_expand_freq_scale {
@expand_freq = GUS::tk::frame_label_zoom( $frame_ps_options, "Hertz:", 1, $main::expand_freq * 2,
1, $main::expand_freq * 5, .5, 'horizontal' );
$balloon->attach(
$expand_freq[1],
-balloonmsg => qq|Average frequency?|,
-statusmsg => qq|When inflating time accordion-wise, approximate this many Hz. |
);
$balloon->attach(
$expand_freq[2],
-balloonmsg => qq|Time inflation target|,
-statusmsg => qq|Only a rough approximation. |
);
$expand_freq[2]->set( $main::expand_freq );
push @frames_pythag, $expand_freq[0];
}
sub mk_expand_ratio_scale {
@expand_ratio = GUS::tk::frame_label_scale( $frame_ps_options, "Ratio:", 0.01, 1, 0.01, 'horizontal' );
$balloon->attach(
$expand_ratio[1],
-balloonmsg => qq|Inflation ratio|,
-statusmsg => qq|How closely to approximate the same slope for every wave. |
);
$balloon->attach(
$expand_ratio[2],
-balloonmsg => qq|Inflation ratio|,
-statusmsg => qq|Higher value spreads out large peaks and valleys the most. |
);
$expand_ratio[2]->set( $main::expand_ratio ); # Default expansion.
push @frames_pythag, $expand_ratio[0];
}
sub mk_expand_min_scale {
@expand_min = GUS::tk::frame_label_zoom( $frame_ps_options, "Min Pts:", 1, 10,
1, $main::params{'PTS_PER_FRAME'} / 10, 1, 'horizontal' );
$balloon->attach(
$expand_min[1],
-balloonmsg => qq|Minimum points|,
-statusmsg => qq|Minimum number of points by which to expand segments and/or space repeats.|
);
$balloon->attach(
$expand_min[2],
-balloonmsg => qq|Minimum points of smallest curve.|,
-statusmsg => qq|Every smallest peak/valley pair expands to a wave at least this wide.|
);
$expand_min[2]->set( $main::expand_min ); # Default expansion.
push @frames_pythag, $expand_min[0];
}
####################################
# End peak slice options selection #
####################################
use vars qw( $pythag_flag_last_time );
$pythag_flag_last_time = $main::pythag_flag;
# Display appropriate submenu for current pythag method.
sub show_method_subframes {
if ( $pythag_flag_last_time ne $main::pythag_flag ) {
if ( $main::pythag_flag eq "Peak Slice") {
$frame_antiflats->destroy() if Tk::Exists($frame_antiflats);
mk_ps_options_frame();
}
elsif ( $main::pythag_flag eq "Vector Envelope") {
$frame_ps_options->destroy() if Tk::Exists($frame_ps_options);
mk_antiflats_frame();
}
}
$pythag_flag_last_time = $main::pythag_flag;
}
$mw_rpc_edit_datapoints->repeat( 1000, \&show_method_subframes );
# Chans may be different scales, N vs mm, so let user weight them as to significance.
sub show_pythag_scales {
my @flags = GUS::tk::poll_frame_label_checks(@checks_pythag);
for (@frames_pythag) { $_->destroy if Tk::Exists($_); }
@scales_pythag = ();
for ( 1 .. $main::params{CHANNELS} ) {
if ( shift @flags ) { mk_pythag_scale(); }
}
# Don't show unless a channel is selected.
if ( scalar @scales_pythag ) {
mk_noise_band_scale();
mk_repeats_scale();
$pythag_flag_last_time = ''; # Cheap trick.
show_method_subframes();
}
}
# Build any carry-overs from earlier in same session.
show_pythag_scales();
########################
# Begin resample frame #
########################
use vars qw(
@radio_resample @resample_cmd
@frames_resample
$sample_rate_pythag );
sub mk_resample_radio {
# Set to carry-over or else to default.
if ( $main::siblinghood_flag && defined($main::sample_rate_pythag) ) {
$sample_rate_pythag = $main::sample_rate_pythag; }
else { $sample_rate_pythag = $main::sample_rate; }
@radio_resample = GUS::tk::frame_label_radio( 8, $frame_ps_options, 'Hertz:', \@main::sample_rates, \$sample_rate_pythag, sub { } );
# Attach a balloon to each checkbutton widget.
for ( my $j = 2 ; $j < $#radio_resample ; ++$j ) {
$balloon->attach(
$radio_resample[$j],
-balloonmsg => 'Change output sampling rate?',
-statusmsg => 'No loss of data results. Only the RPC parameter DELTA_T is affected.'
)
}
# So can be destroyed and rebuilt. Else will appear multiple times.
push @frames_pythag, $radio_resample[0];
}
sub perform_resample {
# Main program's sub will skip if no change in rate.
main::params{'DELTA_T'} = sprintf "%.12e", 1 / $sample_rate_pythag;
}
######################
# End resample frame #
######################
###############################################################
# BEGIN ABOUT TEMPORARY CHANNELS: Pythag, Slope, Expand Pts
# Used early on, but now only for debugging. They are always
# created. But when debugging, user has opportunity to graph
# them.
###############################################################
if ( $main::debug_flag ) {
use vars qw( @checks_retain_temp @retain_temp_cmd
);
# Create checkboxes to select channels for pythagorization into new chan.
my ( @retain_temp_chans, @retain_temp_on, @retain_temp_off, @retain_temp_checked );
# Carry over settings across session to next sibling file.
@main::retain_temp_checked = @retain_temp_checked
unless $main::siblinghood_flag && defined @main::retain_temp_checked;
my @temp_chans = (
$main::params{CHANNELS} + 1,
$main::params{CHANNELS} + 2,
$main::params{CHANNELS} + 3,);
for ( @temp_chans ) {
push @retain_temp_chans, "$_";
push @retain_temp_on, 1;
push @retain_temp_off, 0;
push @retain_temp_checked, 0;
push @retain_temp_cmd, sub { }
}
@checks_retain_temp = GUS::tk::frame_label_checks(
14, $frame_pythag, 'Temp. Ch.:',
\@retain_temp_chans, # Channels
\@retain_temp_on, # on-value refs
\@retain_temp_off, # off-value refs
\@main::retain_temp_checked, # checked or not
\@retain_temp_cmd, # action taken when checked
);
my $temp_type = '';
# Attach a balloon to only the checkbutton widgets.
for ( my $j = 2 ; $j < $#checks_retain_temp ; $j += 2 ) {
if ( $j == 2) { $temp_type = "PYTHAGORIZED" }
elsif ( $j == 4) { $temp_type = "SLOPE" }
elsif ( $j == 6) { $temp_type = "EXPANSION POINTS" }
$balloon->attach(
$checks_retain_temp[$j],
-balloonmsg => "Retain $temp_type channel?",
-statusmsg => "The $temp_type channel (used to peak slice/re-expand) will not be exported. You may it for graphing only."
);
}
} # end if
###############################################################
# END ABOUT TEMPORARY CHANNELS: Pythag, Slope, Expand Pts
# Used early on, but no only for debugging.
###############################################################
sub retain_pythag_settings {
# Preserve the pythag weight scales.
@main::pythag_weights = ();
foreach my $scale (@scales_pythag) {
GUS::tk::scale_cfg_save( $scale, \@main::pythag_weights );
push @main::pythag_weights, $scale->get();
$main::sample_rate_pythag = $sample_rate_pythag;
}
# Collect values.
@main::pythag_cfg = ();
GUS::tk::scale_cfg_save( $noise_band[2], \@main::pythag_cfg, $noise_band[2]->get() );
GUS::tk::scale_cfg_save( $repeats[2], \@main::pythag_cfg, $repeats[2]->get() );
if ( Tk::Exists($frame_ps_options) ) {
GUS::tk::scale_cfg_save( $expand_freq[2], \@main::pythag_cfg, $expand_freq[2]->get() );
GUS::tk::scale_cfg_save( $expand_ratio[2], \@main::pythag_cfg, $expand_ratio[2]->get() );
GUS::tk::scale_cfg_save( $expand_min[2], \@main::pythag_cfg, $expand_min[2]->get() );
}
elsif ( Tk::Exists($frame_antiflats) ) {
GUS::tk::scale_cfg_save( $antiflats_nb[2], \@main::pythag_cfg, $antiflats_nb[2]->get() );
GUS::tk::scale_cfg_save( $antiflats_ms[2], \@main::pythag_cfg, $antiflats_ms[2]->get() );
}
}
sub restore_pythag_settings {
# Restore the pythag weight scales.
my $i = 0;
foreach my $scale (@scales_pythag) {
# Retain any settings from prior edits.
GUS::tk::scale_cfg_restore( $scale, \@main::pythag_weights, $i);
$scale->set( $main::pythag_weights[$i + 4] );
$i += 5;
}
# Restore noise band values.
GUS::tk::scale_cfg_restore( $noise_band[2], \@main::pythag_cfg, 0);
$noise_band[2]->set( $main::pythag_cfg[4] );
# Restore repeats values.
GUS::tk::scale_cfg_restore( $repeats[2], \@main::pythag_cfg, 5);
$repeats[2]->set( $main::pythag_cfg[9] );
if ( Tk::Exists($frame_ps_options) ) {
# Restore frequency target.
GUS::tk::scale_cfg_restore( $expand_freq[2], \@main::pythag_cfg, 10);
$expand_freq[2]->set( $main::pythag_cfg[14] );
# Restore expand ratio values.
GUS::tk::scale_cfg_restore( $expand_ratio[2], \@main::pythag_cfg, 15);
$expand_ratio[2]->set( $main::pythag_cfg[19] );
# Restore minimum expand points values.
GUS::tk::scale_cfg_restore( $expand_min[2], \@main::pythag_cfg, 20);
$expand_min[2]->set( $main::pythag_cfg[24] );
}
elsif ( Tk::Exists($frame_antiflats) ) {
# Restore antiflats noise band values.
GUS::tk::scale_cfg_restore( $antiflats_nb[2], \@main::pythag_cfg, 10);
$antiflats_nb[2]->set( $main::pythag_cfg[14] );
# Restore expand ratio values.
GUS::tk::scale_cfg_restore( $antiflats_ms[2], \@main::pythag_cfg, 15);
$antiflats_ms[2]->set( $main::pythag_cfg[19] );
}
}
# Carry over settings from prior session with sibling file.
restore_pythag_settings() if $main::siblinghood_flag && Tk::Exists($noise_band[2]);
sub perform_pythag {
@main::pythag_checked = GUS::tk::poll_frame_label_checks(@checks_pythag);
@main::retain_temp_checked = GUS::tk::poll_frame_label_checks(@checks_retain_temp) if $main::debug_flag;
if ( Tk::Exists($noise_band[2]) ) {
retain_pythag_settings();
# Not redunant. Used for auto edit xml_intro text box.
$main::noise_band = $noise_band[2]->get();
}
my $i = 0;
my @pythag_chans = ();
my @pythag_weights = ();
# Collect for pythagorizing only those checked.
foreach my $flag (@main::pythag_checked) {
if ($flag) {
push @pythag_chans, $i;
}
++$i;
}
foreach my $scale (@scales_pythag) {
push @pythag_weights, $scale->get();
}
if ( $#pythag_chans >= 0 ) {
# Set up option for Vector Envelope if option window exists.
perform_antiflats() if Tk::Exists($frame_antiflats);
# Means and static offsets may skew results.
main::remove_from_chans( $main::winnow_flag );
# Create a temporary channel of pythagorized values.
main::new_chan_pythagorized( \@pythag_chans, \@pythag_weights );
# Calculate real-use noise band ranging from zero to one.
my $noise_band = $noise_band[2]->get() / 100;
my $repeats = $repeats[2]->get();
my ( $expand_freq, $expand_ratio, $expand_min ) = ( $main::expand_freq, 0.5, 1 );
if ( Tk::Exists( $frame_ps_options) ) {
$expand_freq = $expand_freq[2]->get();
$expand_ratio = $expand_ratio[2]->get();
$expand_min = $expand_min[2]->get();
}
elsif ( Tk::Exists($frame_antiflats) ) {
$main::antiflats_nb = $antiflats_nb[2]->get();
$main::antiflats_ms = $antiflats_ms[2]->get();
}
# Pythagorized channel is trigger for peak-slice.
main::slice_all_chans( \@pythag_chans, \@pythag_weights, $noise_band );
# Exert contrnol over frequency when so directed.
my $expand_pts;
if ( $main::expand_flag eq 'None' ) { $expand_pts = $main::params{'PTS_PER_FRAME'} }
else { $expand_pts = expand_pts_by_freq($expand_freq, @pythag_chans) }
# Append additional repeats of reduced data.
main::repeat_data_for_all_chans($repeats, $expand_pts, $expand_min );
# Ratiometrically expand channels, except when concatenating.
main::expand_chans( $expand_pts, $expand_ratio, $expand_min ) unless $main::edit_open_flag eq 'concat';
$main::concat_expand_pts += $expand_pts;
# Pin all-zero tails on retained temp chans.
main::zero_tail_expand_temp_chans();
# Put back as was before calling &remove_from_chans.
main::restore_to_chans();
}
}
# Have $expand_pts auto-configure for given average frequency.
# Used only after having peak sliced.
sub expand_pts_by_freq {
my ($hertz, @pythag_chans) = @_;
# Talley up the sources for peak/valley pairs.
my $cnt = 1; # Include Pythag chan in talley.
foreach (@pythag_chans) {++$cnt if $_}
# Time of frame in seconds.
my $secs_per_frame = $main::params{'PTS_PER_FRAME'} * $main::params{'DELTA_T'};
# After having peak sliced, all chans have same qty of points. Each two points
# originated from a peak/valley pair in one of N trigger channels.
my $secs_at_freq = scalar @{$main::all_chans[0]} / 2 / $cnt / $hertz;
# Return justified to nearest full frame.
return int( sprintf '%.0f', ($secs_at_freq / $secs_per_frame) ) * $main::params{'PTS_PER_FRAME'};
}
#######################
# End Pythag frame #
#######################
######################
# Begin offset frame #
######################
use vars qw(
$frame_offset
@checks_offset @scales_offset @offset_values @offset_cmd
@frames_offset );
# A sunken frame for buttons, etc.
$frame_offset = $pane_rpc_edit_datapoints->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Apply New Offset',
);
# Create checkboxes to select channels to be offset.
my ( @offset_chans, @offset_on, @offset_off, @offset_checked );
# Carry over settings across session to next sibling file.
@main::offset_checked = @offset_checked unless $main::siblinghood_flag;
for ( 1 .. $main::params{CHANNELS} ) {
push @offset_chans, "$_";
push @offset_on, 1;
push @offset_off, 0;
push @offset_checked, 0;
push @offset_cmd, \&show_offset_scales;
}
@checks_offset = GUS::tk::frame_label_checks(
14, $frame_offset, 'Channels:',
\@offset_chans, # Channels
\@offset_on, # on-value refs
\@offset_off, # off-value refs
\@main::offset_checked, # checked or not
\@offset_cmd, # actions taken when checked
);
# Attach a balloon to each checkbutton widget.
for ( my $j = 2 ; $j < $#checks_offset ; $j += 2 ) {
$balloon->attach(
$checks_offset[$j],
-balloonmsg => 'Offset channel ' . ( $j / 2 ) . '?',
-statusmsg => 'Check to apply offset from slider for channel ' . ( $j / 2 ) . '.'
);
}
# Build according to carry-overs from prior sibling files.
sub show_offset_scales {
my @flags = GUS::tk::poll_frame_label_checks(@checks_offset);
for (@frames_offset) { $_->destroy if Tk::Exists($_); }
# Don't allow an offset range to clip signal. Set offset ranges so peak or valley may not overshoot.
@scales_offset = ();
for ( 1 .. $main::params{CHANNELS} ) {
if ( shift @flags ) {
my $max_offset = $main::params{"FULL_SCALE_r_CHAN_$_"} - $main::params{"MAX_UNITS_$_"};
my $min_offset = -$main::params{"FULL_SCALE_r_CHAN_$_"} - $main::params{"MIN_UNITS_$_"};
# Build a Tk scale with zoom buttons.
# ARRAY: parent_frame, label_text, from, to, min_limit, max_limit, res_limit, orient
my @array = GUS::tk::frame_label_zoom(
$frame_offset,
qq|$main::params{"UNITS_r_CHAN_$_"} Ch $_:|,
$min_offset, $max_offset, $min_offset, $max_offset, .1, 'horizontal' );
$balloon->attach(
$array[2],
-balloonmsg => qq|Offset value in $main::params{"UNITS_r_CHAN_$_"} for channel $_.|,
-statusmsg => qq|Anti-clipping offset limits for channel $_|
. qq|: Max = $main::params{"MAX_UNITS_$_"}$main::params{"UNITS_r_CHAN_$_"}|
. qq|; Min = $main::params{"MIN_UNITS_$_"}$main::params{"UNITS_r_CHAN_$_"}|
);
push @scales_offset, $array[2];
push @frames_offset, $array[0];
}
}
}
# Build according to carry-overs from prior sibling files.
show_offset_scales();
# Carry over settings across session from prior sibling file.
if ( $main::siblinghood_flag ) {
my $i = 0;
my $j = 0;
foreach my $scale (@scales_offset) {
GUS::tk::scale_cfg_restore( $scale, \@main::offset_cfg, $i);
$scale->set( $main::offset_values[$j] );
$i += 4;
$j += 1;
}
}
sub perform_offset {
@main::offset_checked = GUS::tk::poll_frame_label_checks(@checks_offset);
@main::offset_values = ();
@main::offset_cfg = ();
# Retain values across session.
foreach my $scale (@scales_offset) {
if ( Tk::Exists($scale) ) {
GUS::tk::scale_cfg_save( $scale, \@main::offset_cfg );
push @main::offset_values, $scale->get();
}
else { push @main::offset_values, 0 }
}
my $i = 0;
my $j = 0;
my @offset_chans = ();
my @offset_values = ();
# Collect for offset only those checked.
foreach my $flag (@main::offset_checked) {
if ($flag) {
push @offset_chans, $i;
push @offset_values, $main::offset_values[$j];
&main::apply_chan_offset( $i, $main::offset_values[$j] );
++$j;
}
++$i;
}
}
######################
# End offset frame #
######################
########################
# Begin tapering frame #
########################
use vars qw(
$frame_taper @frames_ramp @checks_taper
@scale_taper @scales_taper
@scale_ramp @scales_ramp
@taper_chans @taper_on @taper_off @taper_checked @taper_cmd
);
# A sunken frame for buttons, etc.
$frame_taper = $pane_rpc_edit_datapoints->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Taper Ends',
);
my ( @taper_chans, @taper_on, @taper_off, @taper_checked ); # Keep strict happy.
# Carry over settings across session to next sibling file.
@main::taper_checked = @taper_checked unless $main::siblinghood_flag;
for ( 1 .. $main::params{CHANNELS} ) {
push @taper_chans, "$_";
push @taper_on, 1;
push @taper_off, 0;
push @taper_checked, 0;
push @taper_cmd, \&show_taper_scales;
}
# A checkbox widget for selecting which channels to taper.
@checks_taper = GUS::tk::frame_label_checks(
14, $frame_taper, 'Channels:',
\@taper_chans, # channels
\@taper_on, # on-value refs
\@taper_off, # off-value refs
\@main::taper_checked, # checked or not
\@taper_cmd, # actions taken when checked
);
# Attach a balloon to each checkbutton widget.
for ( my $j = 2 ; $j < $#checks_taper ; $j += 2 ) {
$balloon->attach(
$checks_taper[$j],
-balloonmsg => 'Taper channel ' . ( $j / 2 ) . '?',
-statusmsg => 'Check to enable tapering of channel ' . ( $j / 2 ) . '.'
);
}
sub mk_taper_points_scale {
unless ( Tk::Exists( $scale_taper[0] ) ) {
# A scale widget for selecting how many times to taper a channel.
$main::taper_points = int( $main::params{PTS_PER_FRAME} / 4 )
unless defined $main::taper_points;
@scale_taper =
GUS::tk::frame_label_scale( $frame_taper, 'Data Points:', 0, $main::params{PTS_PER_FRAME} * 4 );
$scale_taper[2]->set($main::taper_points);
$balloon->attach(
$scale_taper[2],
-balloonmsg => "Data points tapered from each end.",
-statusmsg => 'How many data points to taper? ' . 'Same for both ends of each selected channel.'
);
}
}
# Pack a scale for each channel to be tapered.
sub mk_taper_channel_scales {
# Build a Tk scale with zoom buttons.
# ARRAY: parent_frame, label_text, from, to, min_limit, max_limit, res_limit, orient
my @array = GUS::tk::frame_label_zoom(
$frame_taper, qq|$main::params{"UNITS_r_CHAN_$_"} Ch $_:|,
-$main::params{"FULL_SCALE_r_CHAN_$_"}, $main::params{"FULL_SCALE_r_CHAN_$_"},
-$main::params{"FULL_SCALE_r_CHAN_$_"}, $main::params{"FULL_SCALE_r_CHAN_$_"},
1
);
$balloon->attach(
$array[2],
-balloonmsg => qq|Value in $main::params{"UNITS_r_CHAN_$_"} | . qq|where channel $_ should start and end.|,
-statusmsg => qq|End-point range for channel $_ taper: +FS = |
. qq|$main::params{"FULL_SCALE_r_CHAN_$_"}$main::params{"UNITS_r_CHAN_$_"}|
. qq|; -FS = -|
. qq|$main::params{"FULL_SCALE_r_CHAN_$_"}$main::params{"UNITS_r_CHAN_$_"}|
);
push @scales_ramp, $array[2];
push @frames_ramp, $array[0];
}
# Show scales only for those channels checked.
sub show_taper_scales {
my @flags = GUS::tk::poll_frame_label_checks(@checks_taper);
for (@frames_ramp) { $_->destroy if Tk::Exists($_); }
$scale_taper[0]->destroy if Tk::Exists( $scale_taper[0] );
# Chans may be different scales, N vs mm, so let user weight them as to significance.
@scales_ramp = ();
for ( 1 .. $main::params{CHANNELS} ) {
if ( shift @flags ) {
mk_taper_points_scale();
mk_taper_channel_scales();
}
}
}
# Build any carry-overs from earlier in same session.
show_taper_scales();
# Carry over settings across session from last sibling file.
if ( $main::siblinghood_flag ) {
my $i = 0;
my $j = 0;
foreach my $scale (@scales_ramp) {
GUS::tk::scale_cfg_restore( $scale, \@main::ramp_cfg, $i);
$scale->set( $main::ramp_values[$j] );
$i += 4;
$j += 1;
}
}
# Taper selected channels the selected number of times.
sub perform_taper {
@main::taper_checked = GUS::tk::poll_frame_label_checks(@checks_taper);
$main::taper_points = $scale_taper[2]->get()
if Tk::Exists( $scale_taper[2] );
# Preserve selected ramp values for next time.
@main::ramp_values = ();
foreach my $scale (@scales_ramp) {
GUS::tk::scale_cfg_save( $scale, \@main::ramp_cfg );
push @main::ramp_values, $scale->get();
}
my $i = 0; # Index to array ref in @all_chans.
foreach my $flag (@main::taper_checked) {
if ( $flag && $main::taper_points ) {
main::taper_chan_ends( $i, $main::taper_points, $main::ramp_values[$i] );
}
++$i;
}
}
########################
# End tapering frame #
########################
# A sunken frame for buttons, etc.
my $frame_btm = $mw_rpc_edit_datapoints->Frame(
-relief => 'flat',
-borderwidth => 5
);
GUS::tk::frame_label_buttons(
$frame_btm, 'Action:',
[ 'Accept', 'Cancel' ],
[ sub { accept_edits(); }, sub { quit_MainLoop(); } ],
[ 'red', 'green' ],
);
$frame_description->pack( -side => 'top', -expand => 1, -fill => 'both' );
$frame_reverse_polarity->pack( -side => 'top', -expand => 1, -fill => 'both' );
$frame_han->pack( -side => 'top', -expand => 1, -fill => 'both' );
$frame_remove_mean->pack( -side => 'top', -expand => 1, -fill => 'both' );
$frame_remove_offset->pack( -side => 'top', -expand => 1, -fill => 'both' );
$frame_pythag->pack( -side => 'top', -expand => 1, -fill => 'both' );
$frame_offset->pack( -side => 'top', -expand => 1, -fill => 'both' );
$frame_taper->pack( -side => 'top', -expand => 1, -fill => 'both' );
$help_info->pack( -side => 'top', -expand => 0, -fill => 'x' );
$frame_btm->pack( -side => 'top', -expand => 0, -fill => 'x' );
# Proceed automatically when so configured.
accept_edits() unless $main::edit_mode_flag =~ 'manual';
MainLoop;
}
sub accept_edits {
if (1) {
perform_description();
perform_reverse_polarity();
perform_hanning();
perform_remove_mean();
perform_remove_offset();
perform_pythag();
perform_offset();
perform_taper();
main::update_params_for_all_chans();
main::show_chan_array_end_addrs('rpc_edit_datapoints');
quit_MainLoop();
}
}
# Close down the Perl/Tk GUI
sub quit_MainLoop {
$mw_rpc_edit_datapoints->destroy() if Tk::Exists($mw_rpc_edit_datapoints);
}
END { }
###################################
# End RPC Edit Datapoints Package #
###################################
##########################
# Begin GD Graph Package #
# Version 2006-04-11 #
##########################
# This is a semi-arbitrary package for use with GUS::tk package.
package GUS::gd_graph;
BEGIN { }
use Tk;
use Tk::Pane;
use strict;
use warnings;
use GD;
use GD::Graph::lines;
use Image::Magick;
# Declare variables for strict.
our $mw_gd_graph;
use vars qw(
$pane_gd_graph $graph_path $help_info $balloon
@pixels_x @pixels_y $feedback );
sub start_MainLoop {
# Only one window open at a time.
quit_MainLoop() if Tk::Exists $mw_gd_graph;
# So that graph builds with latest span values.
main::update_params_for_all_chans();
$mw_gd_graph = MainWindow->new( -title => ' Graph as PNG' );
# An outermost pane to scroll all sub-panes within.
$pane_gd_graph = $mw_gd_graph->Scrolled(
'Pane',
-scrollbars => 'osow',
-sticky => 'new'
)->pack( -side => 'top', -expand => 1, -fill => 'both' );
# Provide help info as balloon widgets.
$help_info = $mw_gd_graph->Label(
-borderwidth => 2,
-relief => 'groove',
-background => $main::balloon_bg,
-foreground => $main::balloon_fg,
);
$balloon = $mw_gd_graph->Balloon(
-statusbar => $help_info,
-balloonposition => 'mouse',
-background => $main::balloon_bg,
-foreground => $main::balloon_fg,
);
$balloon->attach( $help_info, -msg => 'Hover mouse on any widget then read here.' );
########################
# Begin channels frame #
########################
use vars qw( $frame_channels @graph_cmd @checks_graph );
# A sunken frame for buttons, etc.
$frame_channels = $pane_gd_graph->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Channel Selection',
);
# Create checkboxes to select channels for pythagorization into new chan.
my ( @graph_chans, @graph_on, @graph_off, @graph_checked );
# Retain selections across packet sessions.
@main::graph_checked = @graph_checked unless defined @main::graph_checked;
for ( 1 .. $main::params{'CHANNELS'} ) {
push @graph_chans, "$_";
push @graph_on, 1;
push @graph_off, 0;
push @graph_checked, 0;
push @graph_cmd, sub { };
}
@checks_graph = GUS::tk::frame_label_checks(
14, $frame_channels, 'Channels:',
\@graph_chans, # Channels
\@graph_on, # on-value refs
\@graph_off, # off-value refs
\@main::graph_checked, # checked or not
\@graph_cmd, # action taken when checked
);
# Attach a balloon to only the checkbutton widgets.
for ( my $j = 2 ; $j < $#checks_graph ; $j += 2 ) {
my $k = $j / 2;
# Build full-scale info for balloon.
my $fs = $main::params{"FULL_SCALE_r_CHAN_$k"};
$fs .= qq| $main::params{"UNITS_r_CHAN_$k"}|;
$fs =~ s/\s//;
$balloon->attach(
$checks_graph[$j],
-balloonmsg => "FS = $fs",
-statusmsg => qq|Description = $main::params{"DESC_r_CHAN_$k"} Peak = $main::params{"MAX_UNITS_$k"} Valley = $main::params{"MIN_UNITS_$k"}|
);
}
sub set_channels {
my ( $graph, $data_ref ) = @_;
@main::graph_checked = GUS::tk::poll_frame_label_checks(@checks_graph);
my @graph_legends;
my $ptr = 0;
my @units;
foreach (@main::graph_checked) {
if ($_) {
# Graph a copy so orignal won't be trashed by various 'set' funcs.
my @chan_copy = @{$main::all_chans[$ptr]};
push @$data_ref, \@chan_copy;
push @graph_legends, ( $ptr + 1 );
push @units, $main::params{"UNITS_r_CHAN_$ptr"};
}
++$ptr;
}
$graph->set_legend(@graph_legends);
}
######################
# End channels frame #
######################
######################
# Begin pixels frame #
######################
use vars qw( $frame_pixels );
# A sunken frame for buttons, etc.
$frame_pixels = $pane_gd_graph->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Graph Size',
);
# $parent, $text, $from, $to, $res, $orient
@pixels_x = GUS::tk::frame_label_scale( $frame_pixels, "Width:", 400, 1024, 4, 'horizontal' );
$balloon->attach(
$pixels_x[2],
-balloonmsg => qq|Change graph width?|,
-statusmsg => qq|Adjust graph to desired width in pixels. |
);
$pixels_x[2]->set( $main::graph_pixels[0] ); # Default width.
# $parent, $text, $from, $to, $res, $orient
@pixels_y = GUS::tk::frame_label_scale( $frame_pixels, "Height:", 200, 1024, 4, 'horizontal' );
$balloon->attach(
$pixels_y[2],
-balloonmsg => qq|Change graph height?|,
-statusmsg => qq|Adjust graph to desired height in pixels. |
);
$pixels_y[2]->set( $main::graph_pixels[1] ); # Default height.
####################
# End pixels frame #
####################
######################
# Begin X axis frame #
######################
use vars qw( $frame_x_axis $datum_count @scale_x_axis_max @scale_x_axis_min );
# A sunken frame for buttons, etc.
$frame_x_axis = $pane_gd_graph->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'X-Axis Range',
);
# How many points on X axis?
$datum_count = scalar @{ $main::all_chans[0] };
# A scale to set minimum X range.
@scale_x_axis_min = GUS::tk::frame_label_zoom(
$frame_x_axis, 'Min X:', 1, $datum_count, 1, $datum_count, 8, ); #$main::params{'PTS_PER_FRAME'} / 16, );
$balloon->attach(
$scale_x_axis_min[2],
-balloonmsg => qq|Graph leftmost point|,
-statusmsg => qq|Zoom in on graph by setting X-axis left-hand range. |,
);
$scale_x_axis_min[2]->set(1); # Default setting.
# A scale to set maximum X range.
@scale_x_axis_max = GUS::tk::frame_label_zoom(
$frame_x_axis, 'Max X:', 1, $datum_count, 1, $datum_count, 8, ); #$main::params{'PTS_PER_FRAME'} / 16, );
$balloon->attach(
$scale_x_axis_max[2],
-balloonmsg => qq|Graph rightmost point|,
-statusmsg => qq|Zoom in on graph by setting X-axis right-hand range. |,
);
$scale_x_axis_max[2]->set($datum_count); # Default setting.
# For use with repeat below.
# Assuming user will adjust upper scale first, it has priority.
sub adjust_x_scales {
my $max = $scale_x_axis_max[2]->get();
my $min = $scale_x_axis_min[2]->get();
my $res_max = $scale_x_axis_max[2]->cget('-resolution');
my $res_min = $scale_x_axis_min[2]->cget('-resolution');
if ( $min == $datum_count) { $scale_x_axis_min[2]->set( $datum_count - $res_min ); }
if ( $max <= $min ) { $scale_x_axis_max[2]->set( $min + $res_max ); }
}
# Prevent user from setting max below min.
$mw_gd_graph->repeat( 500, \&adjust_x_scales ) if Tk::Exists($frame_x_axis);
# Assuming user will adjust upper scale first, it has priority.
sub set_x_range {
my ( $graph, $data_ref ) = @_;
my $x_label_skip = $main::params{PTS_PER_FRAME} / 16;
$x_label_skip *= 2 if $main::params{FRAMES} > 2;
$x_label_skip *= 2 if $main::params{FRAMES} > 4;
$x_label_skip *= 2 if $main::params{FRAMES} > 8;
$x_label_skip *= 2 if $main::params{FRAMES} > 16;
$x_label_skip *= 2 if $main::params{FRAMES} > 32;
$x_label_skip *= 2 if $main::params{FRAMES} > 64;
$x_label_skip *= 2 if $main::params{FRAMES} > 128;
# Fix under- and/or over-run due to Tk resolution coarseness.
my $lh = $scale_x_axis_min[2]->get() - 1;
my $rh = $scale_x_axis_max[2]->get() - 1;
$lh = 0 if $lh < 0;
$rh = $datum_count if $rh > $datum_count - 1;
foreach my $chan_ref (@$data_ref) {
@$chan_ref = @$chan_ref[ $lh .. $rh ];
}
$graph->set(
x_label => 'Data Points',
x_all_ticks => 0,
x_labels_vertical => 1,
x_label_skip => $x_label_skip,
);
}
####################
# End X axis frame #
####################
######################
# Begin Y axis frame #
######################
# Assuming user will adjust upper scale first, it has priority.
use vars qw(
$frame_y_axis @scale_y_axis_max @scale_y_axis_min
@fs_y $max_fs
@clip_y $max_clip $min_clip
);
# A sunken frame for widgets.
$frame_y_axis = $pane_gd_graph->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Y-Axis Range',
);
# Determin what values are full scale.
for ( 1 .. $main::params{CHANNELS} ) {
push @fs_y, $main::params{"FULL_SCALE_r_CHAN_$_"};
}
$max_fs = ( sort { $a <=> $b } @fs_y )[-1]; # FS has no polarity.
# Determin what values will cause clipping.
@clip_y = ();
for ( 1 .. $main::params{CHANNELS} ) {
push @clip_y, $main::params{"MAX_UNITS_$_"};
push @clip_y, $main::params{"MIN_UNITS_$_"};
}
( $min_clip, $max_clip ) = ( sort { $a <=> $b } @clip_y )[ 0, -1 ];
# A scale to set minimum Y range.
@scale_y_axis_min = GUS::tk::frame_label_zoom( $frame_y_axis, 'Min Y:', -$max_fs, $max_fs, -$max_fs, $max_fs, 1, );
$balloon->attach(
$scale_y_axis_min[2],
-balloonmsg => qq|Lowest valley = $min_clip|,
-statusmsg => qq|Clipping may occur if set above lowest valley of $min_clip (of all chans available). |,
);
$scale_y_axis_min[2]->set( $min_clip + -$max_fs / 20 ); # Default setting.
# A scale to set maximum Y range.
@scale_y_axis_max = GUS::tk::frame_label_zoom( $frame_y_axis, 'Max Y:', -$max_fs, $max_fs, -$max_fs, $max_fs, 1, );
$balloon->attach(
$scale_y_axis_max[2],
-balloonmsg => qq|Highest peak = $max_clip|,
-statusmsg => qq|Clipping may occur if set below hightest peak of $max_clip (of all chans available). |,
);
$scale_y_axis_max[2]->set( $max_clip + $max_fs / 20); # Default setting.
# For use with repeat below.
# Assuming user will adjust upper scale first, it has priority.
sub adjust_y_scales {
my $max = $scale_y_axis_max[2]->get();
my $min = $scale_y_axis_min[2]->get();
my $res_max = $scale_y_axis_max[2]->cget('-resolution');
my $res_min = $scale_y_axis_min[2]->cget('-resolution');
if ( $min == $max_fs ) { $scale_y_axis_max[2]->set( $min - $res_min ); }
if ( $max <= $min ) { $scale_y_axis_max[2]->set( $min + $res_max ); }
}
# Prevent user from setting max below min.
$mw_gd_graph->repeat( 500, \&adjust_y_scales ) if Tk::Exists($frame_y_axis);
sub set_y_range {
my ( $graph, ) = @_;
$graph->set(
y_max_value => $scale_y_axis_max[2]->get(),
y_min_value => $scale_y_axis_min[2]->get(),
y_all_ticks => 1,
);
}
####################
# End Y axis frame #
####################
########################
# Begin bg color frame #
########################
use vars qw( $pane_colors_bg $frame_colors_bg @colors_gd @colors_bg $color_bg @gd_clr_attrs );
# A sunken frame for buttons, etc.
$frame_colors_bg = $pane_gd_graph->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Background',
);
# An outermost pane to scroll because of so many colors.
$pane_colors_bg = $frame_colors_bg->Scrolled(
'Pane',
-scrollbars => 's',
-sticky => 'new'
);
sub get_gd_colors {
return sort( GD::Graph::colour::colour_list() );
}
@colors_gd = get_gd_colors();
foreach my $color (@colors_gd) {
$color =~ s/^l/lt /;
$color =~ s/^d/dk /;
}
unshift @colors_gd, 'none';
@colors_bg = GUS::tk::frame_label_radio( 8, $pane_colors_bg, 'Color:', \@colors_gd, \$color_bg, sub { } );
$color_bg = $main::graph_color_bg if defined $main::graph_color_bg;
@gd_clr_attrs = qw( bgclr fgclr boxcolor textclr labelclr axislabelclr legendclr valuesclr accentclr shadowclr );
sub set_bg_color {
my ( $graph, $bg_color_new ) = @_;
# Unexpand radio-button name back to attribute name.
$bg_color_new =~ s/^lt /l/;
$bg_color_new =~ s/^dk /d/;
# Whether to be transparent or not.
if ( $bg_color_new ne 'none' ) {
# Set new bg and recycle old.
my $bg_color_old = $graph->get('bgclr');
$graph->set( 'bgclr' => $bg_color_new );
# Don't share bg color with other attributes
foreach my $attr (@gd_clr_attrs) {
next if $attr eq 'bgclr';
# Attrs like 'boxclr' may be undefined.
$graph->set( $attr => $bg_color_old ) if
defined( $graph->get($attr) ) &&
$graph->get($attr) eq $bg_color_new;
}
# Don't share bg color with data line colors.
my @data_colors = @{ $graph->get('dclrs') };
foreach my $dclr (@data_colors) {
$dclr = $bg_color_old if $dclr eq $bg_color_new;
}
$graph->set(
transparent => 0,
dclrs => \@data_colors,
);
}
else { $graph->set( 'transparent' => 1 ) }
}
######################
# End bg color frame #
######################
############################
# Begin graph naming frame #
############################
use vars qw( @graph_flags @graph_name $frame_naming $graph_flag $graph_flag );
# A sunken frame for buttons, etc.
$frame_naming = $pane_gd_graph->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Auto/Manual File Names:',
);
@graph_flags = ( 'auto', 'manual' );
@graph_name = GUS::tk::frame_label_radio( 8, $frame_naming, 'Graph Name:', \@graph_flags, \$graph_flag, sub { } );
$balloon->attach(
$graph_name[2],
-balloonmsg => qq|Best for scripting|,
-statusmsg => qq|Graph filename will be by input file name and date (*_yyyy-mm-dd.png). |,
);
$balloon->attach(
$graph_name[3],
-balloonmsg => qq|Manually name|,
-statusmsg => qq|A file save dialog box will pop up for each file. |,
);
$graph_flag = 'auto';
$graph_flag = $main::graph_name_flag if defined $main::graph_name_flag;
##########################
# End graph naming frame #
##########################
# A sunken frame for buttons, etc.
my $frame_btm = $mw_gd_graph->Frame(
-relief => 'flat',
-borderwidth => 5
);
my @fdbk = GUS::tk::frame_label_entry( $frame_btm, 'Feedback:', \$feedback );
$balloon->attach(
$fdbk[2],
-balloonmsg => 'Graphing feedback.',
-statusmsg => "Graphing-related problems will be reported in the feedback window.."
);
GUS::tk::frame_label_buttons(
$frame_btm,
'Action:',
[ 'Create', 'Show', 'Close' ],
[
sub {
my $bool = 0;
foreach ( GUS::tk::poll_frame_label_checks(@checks_graph) ) { $bool = $bool || $_ }
if ($bool) {
$feedback = "Creating graph...";
create_graph(0);
}
else { $feedback = "Oops! Must select at least one channel to graph." }
},
sub {
GUS::os_detect::show_graphic($graph_path);
$feedback = "Showing graph...";
},
sub { set_carryover_flags(); quit_MainLoop(); }
],
[ 'red', 'blue', 'green' ],
);
$frame_channels->pack( -side => 'top', -expand => 1, -fill => 'both' );
$frame_x_axis->pack( -side => 'top', -expand => 1, -fill => 'x' );
$frame_y_axis->pack( -side => 'top', -expand => 1, -fill => 'x' );
$frame_pixels->pack( -side => 'top', -expand => 1, -fill => 'x' );
$frame_colors_bg->pack( -side => 'top', -expand => 1, -fill => 'x' );
$pane_colors_bg->pack( -side => 'top', -expand => 0, -fill => 'x' );
$frame_naming->pack( -side => 'top', -expand => 1, -fill => 'x' );
$help_info->pack( -side => 'top', -expand => 0, -fill => 'x' );
$frame_btm->pack( -side => 'top', -expand => 0, -fill => 'x' );
# Proceed automatically when so configured.
unless ( $main::edit_mode_flag =~ 'manual' ) {
$graph_flag = 'auto';
$graph_path = $main::graph_path;
$graph_path =~ s/\.[A-Z|a-z]+$/.png/;
create_graph();
quit_MainLoop();
}
MainLoop;
}
# Maintain default across graphing sessions.
sub set_carryover_flags {
$main::graph_pixels[0] = $pixels_x[2]->get();
$main::graph_pixels[1] = $pixels_y[2]->get();
$main::graph_color_bg = $color_bg;
$main::graph_name_flag = $graph_flag;
}
sub create_graph {
set_carryover_flags();
my $graph = new GD::Graph::lines(@main::graph_pixels);
# Generate an X axis measured in points of data.
my @data_points = ( 1 .. scalar @{ $main::all_chans[0] } );
# The new X axis becomes channel zero.
my @data = ( \@data_points, );
# Create a suitable title for graph.
my $title = '';
$title = $main::params{'DESCRIPTION'} if defined $main::params{'DESCRIPTION'};
$title = "RPC-III $main::params{'FILE_TYPE'}" if $title !~ m/[A-Za-z0-9]/;
# Shorten title if too long for graph header.
if ( ( $title =~ m/ edited as / ) && ( length($title) > 50 ) ) {
my @title = split( / edited as /, $title );
$title = $title[-1];
}
# Generate a suitable title.
my $data_points = scalar @{ $main::all_chans[0] };
my $frames = int( $data_points / $main::params{'PTS_PER_FRAME'} );
my $seconds = $data_points * $main::params{'DELTA_T'};
$title .= sprintf( " -- $data_points Points, $frames Frames, %.2f Secs", $seconds);
$graph->set(
title => $title,
r_margin => 5,
l_margin => 2,
t_margin => 1,
b_margin => 1,
zero_axis => 1,
);
set_channels( $graph, \@data );
set_bg_color( $graph, $color_bg );
set_x_range( $graph, \@data );
set_y_range($graph);
$graph->set_legend_font('GD::gdFontTiny');
my $gd = $graph->plot( \@data );
# Bug in new version of Perl/Tk won't accept a single referenced
# array inside outer referenced array like so: [['FOO','.foo']]
# but insists there be two or more nested inside.
my @file_types = (
['PNG', '.png'],
['Any', '*']
);
# Best to auto-name graphs so can script for multiple files.
if ( $graph_flag eq 'manual') {
# NOTE: Will see this error...
#
# Tk::Error: image "image1" doesn't exist at /usr/pkg/lib/perl5/site_perl/5.8.0/i386-netbsd/Tk/FBox.pm line 91
#
# ...if use either $main::mw-> or $mw_gd_graph-> for getSaveFile().
# It makes no sense and GOOGLE had little or nothing about it.
$graph_path = $mw->getSaveFile( -filetypes => [ [ 'PNG', '.png', 'TEXT' ], ] );
}
if ( open( GRAPH, "> $graph_path" ) ) {
binmode(GRAPH);
print GRAPH $gd->png();
close GRAPH;
$feedback = "Graph written to $graph_path";
}
else { $main::feedback = "Oops! Can\'t open $graph_path: $!"; }
# For each graph, create an info file.
my $info_path = $graph_path;
$info_path =~ s/\.png$/.txt/;
if ( open( INFO, "> $info_path" ) ) {
print INFO "Selected parameters extracted from graph: \n\n";
print INFO qq|Frames = $main::params{'FRAMES'} \n|;
printf INFO "Time = %.2f seconds \n",
$main::params{'FRAMES'} * $main::params{'PTS_PER_FRAME'} * $main::params{'DELTA_T'};
my $i = 1;
foreach my $check ( @main::graph_checked ) {
if ( $check ) {
printf INFO qq|Chan $i Max = %+9.3f $main::params{"UNITS_r_CHAN_$i"} \n|, $main::params{"MAX_UNITS_$i"};
printf INFO qq|Chan $i Min = %+9.3f $main::params{"UNITS_r_CHAN_$i"} \n|, $main::params{"MIN_UNITS_$i"};
}
++$i;
}
close INFO;
}
}
# Close down the Perl/Tk GUI
sub quit_MainLoop {
$mw_gd_graph->destroy() if Tk::Exists($mw_gd_graph);
}
END { }
#########################
# End GD Graph Package #
#########################
#############################
# Begin User Config Package #
# Version 2006-04-11 #
#############################
# This is a semi-arbitrary package for use with GUS::tk package.
package GUS::user_config;
BEGIN { }
use Tk;
use strict;
use warnings;
# Declare variables for strict.
use vars qw( $mw_user_config $frame_user_options $frame_btm @regex );
sub start_MainLoop {
$mw_user_config = MainWindow->new( -title => ' Configure' );
my $pane_options = $mw_user_config->Scrolled(
'Pane',
-scrollbars => 'osow',
-sticky => 'new'
)->pack( -side => 'top', -expand => 1, -fill => 'both' );
# Provide help info as balloon widgets.
my $help_info = $mw_user_config->Label(
-borderwidth => 2,
-relief => 'groove',
-background => $main::balloon_bg,
-foreground => $main::balloon_fg,
);
my $balloon = $mw_user_config->Balloon(
-statusbar => $help_info,
-balloonposition => 'mouse',
-background => $main::balloon_bg,
-foreground => $main::balloon_fg,
);
$balloon->attach( $help_info, -msg => 'Hover mouse on any widget then read here.' );
#########################
# Begin edit mode frame #
#########################
use vars qw( @edit_mode_flags @edit_mode $edit_mode_flag );
my $frame_edit_mode = $pane_options->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Edit Mode Options:',
);
@edit_mode_flags = ( 'manual', 'repeat once', 'repeat for all' );
@edit_mode = GUS::tk::frame_label_radio( 8, $frame_edit_mode, 'Edit mode:', \@edit_mode_flags, \$edit_mode_flag, sub { } );
$edit_mode_flag = 'manual';
$edit_mode_flag = $main::edit_mode_flag if defined $main::edit_mode_flag;
# Give hints to user
$balloon->attach(
$edit_mode[1],
-balloonmsg => 'Choose how to edit.',
-statusmsg => 'Choose from: manual mode, semi-auto next-pass mode or full-auto edit mode.'
);
$balloon->attach(
$edit_mode[2],
-balloonmsg => 'Edit manually.',
-statusmsg => 'Edit files one-at-a-time. See each edit menu in sequence every time.'
);
$balloon->attach(
$edit_mode[3],
-balloonmsg => 'Do same once again.',
-statusmsg => 'Edit next opened file the same way as last. See no edit menu at all.'
);
$balloon->attach(
$edit_mode[4],
-balloonmsg => 'Do same for all matching.',
-statusmsg => 'Edit all files the same way as last. See no edit menus at all.'
);
# Options for whether to replace or concatenate files when opening.
use vars qw( @edit_open_flags @edit_open $edit_open_flag );
@edit_open_flags = ( 'replace', 'concat' );
@edit_open = GUS::tk::frame_label_radio( 8, $frame_edit_mode, 'Open mode:', \@edit_open_flags, \$edit_open_flag, sub { } );
$edit_open_flag = 'replace';
$edit_open_flag = $main::edit_open_flag if defined $main::edit_open_flag;
# Give hints to user
$balloon->attach(
$edit_open[1],
-balloonmsg => 'File opening options.',
-statusmsg => 'Choose what to do when opening 2nd, 3rd ... Nth files.'
);
$balloon->attach(
$edit_open[2],
-balloonmsg => 'Replace prior.',
-statusmsg => 'Discard prior file and replace with that newly opened.'
);
$balloon->attach(
$edit_open[3],
-balloonmsg => 'Concatenate.',
-statusmsg => 'Keep prior file and concatenate to it the newly opened.'
);
####################################
# Begin FS integer options widgets #
####################################
my @fs_integer = GUS::tk::frame_label_radio(
8, $frame_edit_mode, 'Integer FS:', ['32752', '32768'], \$main::int_full_scale, sub { }
);
$main::int_full_scale = 32752 unless defined $main::int_full_scale;
# Attach a balloon to only the radiobutton widgets.
$balloon->attach(
$fs_integer[1],
-balloonmsg => "RPC header keyword INT_FULL_SCALE",
-statusmsg => 'Some 3rd party files will spike due to undeclared, non-standard INT_FULL_SCALE keyword.'
);
$balloon->attach(
$fs_integer[2],
-balloonmsg => 'RPC standard 12-bit A/D',
-statusmsg => 'RPC standard assumes data were sampled by a 12-bit A/D (16-bit with 4 lsb masked), thus 32752.'
);
$balloon->attach(
$fs_integer[3],
-balloonmsg => '3-rd party 16-bit A/D',
-statusmsg => '3-rd party data are sometimes sampled by a 16-bit A/D, thus 32768. '
. 'Try this only if 12-bit default gives full-scale spikes at max peak or min valley.'
);
##################################
# End FS integer options widgets #
##################################
#################################
# Begin filename option widgets #
#################################
$main::append_dtg_flag = 'Dated' unless defined $main::append_dtg_flag;
my @fn_dtg = GUS::tk::frame_label_radio(
8, $frame_edit_mode, 'Filename:', ['Dated', 'Undated',], \$main::append_dtg_flag, sub{}
);
# Attach a balloon to only the radiobutton widgets.
$balloon->attach(
$fn_dtg[1],
-balloonmsg => "Output files date-appended?",
-statusmsg => 'Appending date & time to output file names insures they will be unique.'
);
$balloon->attach(
$fn_dtg[2],
-balloonmsg => 'Append date and time.',
-statusmsg => 'The date and time in format YYYY-MM-DD_HH-MM-SS will be appended to file names.'
);
$balloon->attach(
$fn_dtg[3],
-balloonmsg => 'Do not date file names.',
-statusmsg => 'You risk overwriting files by not appending date and time.'
);
################################
# Begin sanity options widgets #
################################
my @batch_sanity_options = GUS::tk::frame_label_radio(
8, $frame_edit_mode, 'Siblinghood:', ['enforce', 'ignore'], \$main::batch_sanity_flag, sub { }
);
$main::batch_sanity_flag = 'enforce' unless defined $main::batch_sanity_flag;
# Attach a balloon to only the radiobutton widgets.
$balloon->attach(
$batch_sanity_options[1],
-balloonmsg => "Siblinghood test.",
-statusmsg => 'A sanity check for batch editing. Checks name, full scale, etc. for each channel.'
);
$balloon->attach(
$batch_sanity_options[2],
-balloonmsg => 'Enforce siblinghood?',
-statusmsg => 'During batch editing, raise an error if files are too dissimilar. '
. 'Required to prevent clobbering of output data during batch editing.'
);
$balloon->attach(
$batch_sanity_options[3],
-balloonmsg => 'Ignore siblinghood?',
-statusmsg => 'Unsafe! Skip sanity checks while batch editing, risking erroneous output.'
);
BEGIN { $main::siblinghood_traits = 'UNITS|DESC'; }
use vars qw( @checks_sanity );
# Sanity check to assemble RegEx for testing siblinghood traits.
sub san_re {
my @traits = GUS::tk::poll_frame_label_checks(@checks_sanity);
$main::siblinghood_traits = join '', @traits;
$main::siblinghood_traits =~ s/\|$//;
}
@checks_sanity = GUS::tk::frame_label_checks(
8, $frame_edit_mode, 'Sibling Traits:',
['UNITS', 'DESC', 'SCALE', 'UPPER_LIMIT', 'LOWER_LIMIT'], # Sibling traits
['UNITS|','DESC|','SCALE|','UPPER_LIMIT|','LOWER_LIMIT|'], # on-value refs
['','','','',''], # off-value refs
[1,1,0,0,0], # checked or not
[\&san_re, \&san_re, \&san_re, \&san_re, \&san_re],
);
# Attach a balloon to only the checkbutton widgets.
$balloon->attach(
$checks_sanity[1],
-balloonmsg => "Siblinghood identifiers.",
-statusmsg => 'Which traits to compare for siblinghood during batch editing to prevent data clobbering.'
);
$balloon->attach(
$checks_sanity[2],
-balloonmsg => "Unit of measure.",
-statusmsg => 'Test siblinghood of files by their channel units being identical. '
. 'Required to prevent clobbering of output data during batch editing.'
);
$balloon->attach(
$checks_sanity[4],
-balloonmsg => "Channel names.",
-statusmsg => 'Test siblinghood of files by their channel names being identical. '
. 'Strongly recommended clobbering of output data during batch editing.'
);
$balloon->attach(
$checks_sanity[6],
-balloonmsg => "Channel scales.",
-statusmsg => 'Test siblinghood of files by their channel scales being identical. '
. 'May further help to prevent clobbering of output data during batch editing.'
);
$balloon->attach(
$checks_sanity[8],
-balloonmsg => "Channel lower limit.",
-statusmsg => 'Test siblinghood of files by their channel lower limits being identical. '
. 'May further help to prevent clobbering of output data during batch editing.'
);
$balloon->attach(
$checks_sanity[10],
-balloonmsg => "Channel upper limit.",
-statusmsg => 'Test siblinghood of files by their channel upper limits being identical. '
. 'May further help to prevent clobbering of output data during batch editing.'
);
##############################
# End sanity options widgets #
##############################
###############################
# End filename option widgets #
###############################
my @regex = GUS::tk::frame_label_entry( $frame_edit_mode, 'Reg Ex:', \$main::auto_edit_regex );
# Give hints to user
$balloon->attach(
$regex[1],
-balloonmsg => 'Enter Perl RegEx.',
-statusmsg => "Like the DOS '*' file glob on steroids. See any Perl programming manual for details on regular expression."
);
$balloon->attach(
$regex[2],
-balloonmsg => 'Auto edit input filter.',
-statusmsg => 'The Perl regular expression by which to filter input files for auto-editing.'
);
# Text with which to prepend auto-edited output files.
my @prefix = GUS::tk::frame_label_entry( $frame_edit_mode, 'Prepend:', \$main::auto_edit_prefix );
$balloon->attach(
$prefix[1],
-balloonmsg => 'Enter prefix for output file.',
-statusmsg => 'String to be prepended onto output file names when auto-editing.'
);
$balloon->attach(
$prefix[2],
-balloonmsg => 'Auto-edit prefix.',
-statusmsg => 'Prepend this string onto output file names when auto-editing.'
);
my $af_cks = ''; # Flag for antiflats checked or not.
# Give user head start in prefixing output file names when Pythag or Vector Envelop editing.
my $prefix_str = "";
if ( count_pythag_chans() > 0 ) {
if ( $main::pythag_flag eq "Peak Slice" ) {
$prefix_str .= "PS-";
$prefix_str .= "Rel-" if $main::range_flag eq "Relative";
$prefix_str .= "Abs-" if $main::range_flag eq "Absolute";
$prefix_str .= "$main::noise_band" . "pct-";
$prefix_str .= "$main::expand_freq" . "Hz_";
}
elsif ( $main::pythag_flag eq "Vector Envelope" ) {
$prefix_str .= "VE-";
$prefix_str .= "Rel-" if $main::range_flag eq "Relative";
$prefix_str .= "Abs-" if $main::range_flag eq "Absolute";
$prefix_str .= "$main::noise_band" . "pct_";
# Determine if antiflats modes were checked.
$af_cks .= 'S' if $main::antiflats_checked[0];
$af_cks .= 'A' if $main::antiflats_checked[1];
$af_cks .= 'E' if $main::antiflats_checked[2];
# Ammend for any checked antiflats modes.
if ( $af_cks ne '' ) {
$prefix_str .= "PR-$af_cks-" . "$main::antiflats_nb" . "pct_";
$prefix_str .= "$main::antiflats_ms" . "mS_";
}
}
}
$prefix[2]->delete( 0, 'end' );
$prefix[2]->insert( 0, $prefix_str );
# For user input of descriptor text on XML page of auto-edited graphs.
use vars qw( @xml_intro );
@xml_intro = GUS::tk::frame_label_text( $frame_edit_mode, 'Graph intro:', 3, 50 );
$xml_intro[-1]->insert( 'end', "$main::xml_intro");
$balloon->attach(
$xml_intro[1],
-balloonmsg => 'Introduction for graphs page.',
-statusmsg => 'When auto-editing, an XML of all graphs is created.'
);
$balloon->attach(
$xml_intro[2],
-balloonmsg => 'Text to introduce auto-edited graphs.',
-statusmsg => 'In top section of XML showing all graphs, display this text in the top-most section.'
);
# Give user head start in identifying editing constraints.
my @intro_items;
# This set of info applys only when channels were pythag-modified.
if ( count_pythag_chans() > 0 ) {
push @intro_items, "Reduced by " . lc($main::pythag_flag);
if ( $main::pythag_flag eq "Peak Slice" ) {
push @intro_items, "triggered in " . lc($main::trigger_flag) . " mode";
push @intro_items, "at $main::expand_ratio expansion ratio";
push @intro_items, "using a $main::expand_flag wave shape";
push @intro_items, "averaging near $main::expand_freq Hz.";
}
else { $intro_items[-1] .= "."}
push @intro_items, "Noise band was $main::noise_band%";
push @intro_items, "of signal maximum amplitude." if $main::range_flag eq "Relative";
push @intro_items, "of channel full scale." if $main::range_flag eq "Absolute";
push @intro_items, "Data points winnowed relative to";
push @intro_items, "zero." if $main::winnow_flag eq "As Is";
push @intro_items, "channel mean." if $main::winnow_flag eq "Mean";
push @intro_items, "channel initial offset." if $main::winnow_flag eq "Offset";
# FIX THIS
# Add info about antiflats if any were checked.
if ( $af_cks ne '') {
my $af_str = "Plateau reduction noise band was " . "$main::antiflats_nb" . "% ";
$af_str .= "and $main::antiflats_ms" . "mS duration at: ";
$af_str .= "beginning, " if $af_cks =~ /B/;
$af_str .= "middle, " if $af_cks =~ /M/;
$af_str .= "end." if $af_cks =~ /E/;
$af_str =~ s/, $/. /;
push @intro_items, $af_str;
}
push @intro_items, "Original data repeated herein $main::repeats times." if $main::repeats;
}
$xml_intro[2]->delete( 0.1, 'end' );
$xml_intro[2]->insert( 'end', join " ", @intro_items );
#######################
# End edit mode frame #
#######################
############################
# Begin graph naming frame #
############################
use vars qw( @graph_flags @graph_name $graph_flag );
my $frame_graph = $pane_options->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Graph Options:',
);
@graph_flags = ( 'auto', 'manual' );
@graph_name = GUS::tk::frame_label_radio( 8, $frame_graph, 'Graph Name:', \@graph_flags, \$graph_flag, sub { } );
$graph_flag = 'auto';
$graph_flag = $main::graph_name_flag if defined $main::graph_name_flag;
##########################
# End graph naming frame #
##########################
############################
# Begin ascii header frame #
############################
use vars qw(
@header_flags @header_option $header_flag
@tail_flags @tail_option $tail_flag
);
my $frame_header = $pane_options->Frame(
-relief => 'sunken',
-borderwidth => 3,
-label => 'Options for *.dat files:',
);
@header_flags = ( 'headers & data', 'data only' );
@header_option = GUS::tk::frame_label_radio( 8, $frame_header, 'Ascii Output:', \@header_flags, \$header_flag, sub { } );
$header_flag = 'data only';
$header_flag = $main::header_flag if defined $main::header_flag;
@tail_flags = ( 'retain', 'truncate' );
@tail_option = GUS::tk::frame_label_radio( 8, $frame_header, 'Zero Tail:', \@tail_flags, \$tail_flag, sub { } );
$tail_flag = 'truncate';
$tail_flag = $main::tail_flag if defined $main::tail_flag;
##########################
# End ascii header frame #
##########################
# A flat frame for buttons, etc.
my $frame_btm = $mw_user_config->Frame(
-relief => 'flat',
-borderwidth => 5
);
GUS::tk::frame_label_buttons(
$frame_btm, 'Action:',
[ 'Accept', 'Cancel' ],
[ sub { accept_config(); }, sub { quit_MainLoop(); } ],
[ 'red', 'green' ],
);
$frame_edit_mode->pack( -side => 'top', -expand => 0, -fill => 'x' );
$frame_graph->pack( -side => 'top', -expand => 0, -fill => 'x' );
$frame_header->pack( -side => 'top', -expand => 0, -fill => 'x' );
$help_info->pack( -side => 'top', -expand => 0, -fill => 'x' );
$frame_btm->pack( -side => 'top', -expand => 0, -fill => 'x' );
MainLoop;
}
sub accept_config {
$main::edit_mode_flag = $edit_mode_flag;
$main::edit_open_flag = $edit_open_flag;
$main::graph_name_flag = $graph_flag;
$main::xml_intro = $xml_intro[-1]->get("1.0", "end");
quit_MainLoop();
}
# Count how many chans were pythag-modified. Just a test
# for file prefix and intro paragraph options. Prevents info
# about pythag editing because of default selections when no
# channels were selected for those defaluts to apply to.
sub count_pythag_chans {
my $count = 0;
foreach (@main::pythag_checked) {
++$count if $_;
}
return $count;
}
# Close down the Perl/Tk GUI
sub quit_MainLoop {
$mw_user_config->destroy() if Tk::Exists($mw_user_config);
}
END { }
###########################
# End User Config Package #
###########################
################################################################################
################################################################################
## GUS PACKAGES -- STANDARD SET ##
## FOR USE UNEDITED ACROSS ANY PROGRAM ##
## VERSION 2004-11-22 ##
################################################################################
################################################################################
################################
# Begin GUS Tk widgets Package #
# Version 2004-11-29 #
################################
# 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 $text_height $text_width $file_basename $feedback
$color_bg $color_fg $color_bg_balloon $color_fg_balloon $color_bg_active $color_bg_inactive );
BEGIN {
$debug_flag = 0;
$widget_id = 0;
$label_width = 12;
$entry_width = 12;
$button_width = 12;
$main::file_basename = 'foo.txt' unless defined $main::file_basename;
}
use vars qw(
%frame
$dir_toplevel
);
sub new_widget { $widget_id++; return $widget_id; }
# Automate the build of a lable & entry wiget set inside GUS::tk 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;
}
# Automate the build of a lable & entry wiget set inside GUS::tk frame.
sub frame_label_listbox {
my ( $parent, $label_text, $list_ref, $selectmode, $takefocus ) = @_;
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(
'Listbox',
-selectmode => $selectmode,
-takefocus => $takefocus,
-width => $entry_width,
-background => "white",
-foreground => 'blue',
-relief => 'sunken',
-font => 'courier'
)->pack(
-side => 'left',
-expand => 1,
-fill => 'x'
);
return @widgets;
}
# Automate the build of a lable & set of entry widgets set inside GUS::tk frame.
sub frame_label_entries {
my $parent = shift;
my $label_text = shift;
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' );
foreach my $text_var_ref (@_) {
push @widgets, $widgets[0]->Scrolled(
'Entry',
-textvariable => $text_var_ref,
-background => "white",
-foreground => 'blue',
-relief => 'sunken',
-font => 'courier',
-justify => 'right',
-width => 3,
)->pack(
-side => 'left',
-expand => 1,
-fill => 'x',
);
# Just a spacer between plural entryboxes.
if ( scalar @_ ) { $widgets[0]->Label( -width => 2 )->pack( -side => 'left' ) }
}
return @widgets;
}
# Automate the build of a lable & text wiget set inside GUS::tk frame.
sub frame_label_text {
my ( $parent, $label_text, $text_height, $text_width ) = @_;
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(
'Text',
-height => $text_height,
-width => $text_width,
-background => "white",
-foreground => 'blue',
-relief => 'sunken',
-font => 'courier',
-wrap => 'word',
)->pack(
-side => 'left',
-expand => 1,
-fill => 'x'
);
return @widgets;
}
# Automate the build of a lable & set of label widgets set inside GUS::tk frame.
sub frame_label_labels {
my $parent = shift;
my $label_text = shift;
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' );
foreach $label_text (@_) {
push @widgets, $widgets[0]->Label(
-text => "$label_text",
-relief => 'flat',
)->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 ( $width, $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,
-justify => 'left',
-anchor => 'w',
-width => $width,
-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;
}
# Just like &frame_label_scale above but with zoom-in, zoom-out buttons.
sub frame_label_zoom {
my ( $parent, $text, $from, $to, $min_limit, $max_limit, $res_limit, $orient ) = @_;
$orient = 'horizontal' unless defined($orient);
my $res = zoom_res( ( $to - $from ) / 20, $res_limit ); # Set reasonable default.
$res = $res_limit if $res < $res_limit; # Prevent starting out below limit.
my @widgets = ();
my $tick_interval = ( $to - $from ) / 1.99999;
$tick_interval = int( $tick_interval) if $tick_interval == 1;
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,
-tickinterval => $tick_interval,
)->pack(
-side => 'left',
-expand => 1,
-fill => 'x'
);
push @widgets, $widgets[0]->Button(
-width => 3,
-text => '-',
-command => sub { zoom_scale( $widgets[2], 5, $min_limit, $max_limit, $res_limit ); },
-activebackground => 'blue',
-relief => 'raised',
)->pack(
-side => 'left',
-expand => 0,
);
push @widgets, $widgets[0]->Button(
-width => 3,
-text => '+',
-command => sub { zoom_scale( $widgets[2], 0.2, $min_limit, $max_limit, $res_limit ); },
-activebackground => 'orange',
-relief => 'raised',
)->pack(
-side => 'left',
-expand => 0,
);
return @widgets;
}
# Just like &frame_label_zoom above but with an entry box.
sub frame_label_entry_label_zoom_label_zoom {
my ( $parent, $text_1, $text_var_ref,
$text_2, $from_2, $to_2, $min_limit_2, $max_limit_2, $res_limit_2,
$text_3, $from_3, $to_3, $min_limit_3, $max_limit_3, $res_limit_3,
$orient ) = @_;
$orient = 'horizontal' unless defined($orient);
my $res_2 = zoom_res( ( $to_2 - $from_2 ) / 20, $res_limit_2 ); # Set reasonable default.
my $res_3 = zoom_res( ( $to_3 - $from_3 ) / 20, $res_limit_3 ); # Set reasonable default.
$res_2 = $res_limit_2 if $res_3 < $res_limit_2; # Prevent starting out below limit.
$res_3 = $res_limit_3 if $res_3 < $res_limit_3; # Prevent starting out below limit.
my @widgets = ();
my $tick_interval_2 = ( $to_2 - $from_2 ) / 1.99999;
my $tick_interval_3 = ( $to_3 - $from_3 ) / 1.99999;
$tick_interval_2 = int( $tick_interval_2) if $tick_interval_2 == 1;
$tick_interval_3 = int( $tick_interval_3) if $tick_interval_3 == 1;
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_1 ",
)->pack( -side => 'left' );
push @widgets, $widgets[0]->Entry(
-textvariable => $text_var_ref,
-background => "white",
-foreground => 'blue',
-relief => 'sunken',
-font => 'courier',
-justify => 'right',
-width => $label_width,
)->pack(
-side => 'left',
-expand => 0,
-fill => 'x'
);
push @widgets, $widgets[0]->Label(
-width => $label_width,
-text => " $text_2 ",
)->pack( -side => 'left' );
push @widgets, $widgets[0]->Scale(
-from => $from_2,
-to => $to_2,
-resolution => $res_2,
-orient => $orient,
-tickinterval => $tick_interval_2,
)->pack(
-side => 'left',
-expand => 1,
-fill => 'x'
);
push @widgets, $widgets[0]->Button(
-width => 3,
-text => '-',
-command => sub { zoom_scale( $widgets[4], 5, $min_limit_2, $max_limit_2, $res_limit_2 ); },
-activebackground => 'blue',
-relief => 'raised',
)->pack(
-side => 'left',
-expand => 0,
);
push @widgets, $widgets[0]->Button(
-width => 3,
-text => '+',
-command => sub { zoom_scale( $widgets[4], 0.2, $min_limit_2, $max_limit_2, $res_limit_2 ); },
-activebackground => 'orange',
-relief => 'raised',
)->pack(
-side => 'left',
-expand => 0,
);
push @widgets, $widgets[0]->Label(
-width => $label_width,
-text => " $text_3 ",
)->pack( -side => 'left' );
push @widgets, $widgets[0]->Scale(
-from => $from_3,
-to => $to_3,
-resolution => $res_3,
-orient => $orient,
-tickinterval => $tick_interval_3,
)->pack(
-side => 'left',
-expand => 1,
-fill => 'x'
);
push @widgets, $widgets[0]->Button(
-width => 3,
-text => '-',
-command => sub { zoom_scale( $widgets[8], 5, $min_limit_3, $max_limit_3, $res_limit_3 ); },
-activebackground => 'blue',
-relief => 'raised',
)->pack(
-side => 'left',
-expand => 0,
);
push @widgets, $widgets[0]->Button(
-width => 3,
-text => '+',
-command => sub { zoom_scale( $widgets[8], 0.2, $min_limit_3, $max_limit_3, $res_limit_3 ); },
-activebackground => 'orange',
-relief => 'raised',
)->pack(
-side => 'left',
-expand => 0,
);
return @widgets;
}
sub zoom_res {
my ( $range, $res_limit ) = @_; # Compare to margin.
my $res = 1;
while ( $range / $res < 500 ) { last if $res < 0.000001; $res /= 10; }
# When 1 is too small.
while ( $range / $res > 500 ) { last if $res > 999_999; $res *= 10 }
# Range is okay now.
print "At zoom_res, \$res = $res & \$res_limit = $res_limit \n" if $debug_flag > 1;
$res = $res_limit if $res < $res_limit; # Prevent going below limit.
return $res;
}
# Sub below called by &frame_label_zoom when zoom button clicked.
sub zoom_scale {
my ( $scale_ref, $power, $min_limit, $max_limit, $res_limit ) = @_;
my $to = $scale_ref->cget( -to );
my $from = $scale_ref->cget( -from );
my $value = $scale_ref->get();
my $margin = ( ( $value - $from ) + ( $to - $value ) ) / 2;
# Above are as-was values, now zoom in or out to new values.
my $res = zoom_res( $margin * $power, $res_limit );
$from = $value - $margin * $power;
$to = $value + $margin * $power;
# Limit leftmost if required.
if ( ( defined $min_limit ) && ( $from < $min_limit ) ) {
$from = $min_limit;
}
# Limit rightmost if required.
if ( ( defined $max_limit ) && ( $to > $max_limit ) ) {
$to = $max_limit;
}
# Accomodate possible limiting from above.
$margin = ( $to - $from ) / 2;
$res = zoom_res( $margin, $res_limit );
# Adjust scale zoom within limits.
unless ( defined($res_limit)
&& ( $power < 1 )
&& ( $res < $res_limit ) )
{
# Remake the scale at the new zoom level, avoiding
# any zoom so close that no increments remain.
$scale_ref->configure(
-from => $from,
-to => $to,
-resolution => $res,
-tickinterval => $margin * 0.99999,
) if $to - $from > $res * 5;
}
}
# 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} ),
-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 )
= @_;
# So the Scrolled method of Pane can accomodate varying widths prettily.
if ( $width == 0 ) {
foreach ( @$text_array_ref ) { $width = length $_ if $_ > $width }
}
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,
-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 " ", @bar, "\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, $label_str, ) = @_;
$label_str = 'Input Path:' unless defined $label_str;
my @path_widgets = frame_label_entry_button(
$frame,
$label_str,
$var_ref, 7, 'Browse',
sub {
$$var_ref = $mw->getOpenFile( -filetypes => \@main::filetypes );
},
'gray',
'red',
'black',
);
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, $label_str ) = @_;
$label_str = 'Input Path:' unless defined $label_str;
if ( $count > 0 ) {
for ( my $i = 1 ; $i <= $count ; $i++ ) {
my $var = '';
add_path_widget( $frame, $var, $label_str, );
}
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 is there no proper dir browse widget in Tk like
# the getOpenFile() and getSaveFile() widgets?
sub add_dir_widget {
my ( $frame, $var_ref, $label_str,) = @_;
$label_str = 'Input Dir:' unless defined $label_str;
my @dir_widgets =
frame_label_entry_button( $frame, $label_str, $var_ref, 7, 'Browse', sub { \&dir_tree_window($var_ref); },
'gray', 'red', 'blue', );
return @dir_widgets;
}
# 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');
chdir $GUS::os_detect::home;
# Test if Windoze or a real OS...
if ( $GUS::os_detect::OS eq 'WINDOWS' ) {
# 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 ============
# Preserve scale configuration in an array.
sub scale_cfg_save {
my ( $tk_scl, $a_ref, $setting ) = @_;
foreach ( '-from', '-to', '-res', '-tickinterval') {
push @$a_ref, $tk_scl->cget($_);
}
push @$a_ref, $setting if defined $setting;
}
sub scale_cfg_restore {
my ( $tk_scl, $a_ref, $i ) = @_;
foreach ( '-from', '-to', '-res', '-tickinterval') {
$tk_scl->configure($_, $$a_ref[$i]);
++$i;
}
}
END { }
##############################
# End GUS Tk widgets package #
##############################
###############################
# Begin GUS OS Detect package #
# Version 2004-10-09 #
###############################
# A separate package for ease of re-use.
package GUS::os_detect;
use File::Find;
use strict;
# Declare variables for strict.
use vars qw( $OS $home $delim $browser $txt_viewer $ttf_dir $font $win_dir);
# Allow for configuration in main module.
$browser = $main::browser_filepath if $main::browser_filepath;
BEGIN {
require Config;
$OS = $Config::Config{'osname'};
if ( $OS =~ /Win/i ) {
$OS = 'WINDOWS';
# Determin whether NT or not by testing for directory.
if ( -e "C:/WINNT" ) { $win_dir = 'C:/WINNT/';}
else { $win_dir = 'C:/WINDOWS/'; }
$home = "C:/";
$delim = '\\';
$browser = 'C:/Program Files/Internet Explorer/IEXPLORE.EXE' ; #unless $browser;
$txt_viewer = $win_dir . 'notepad.exe';
$ttf_dir = $win_dir . 'Fonts/';
$font = $ttf_dir . 'arial.ttf';
$main::imdisplay_path = '';
# For use with File::Find
sub win32_seek {
if ( /imdisplay\.exe$/ ) {
$main::imdisplay_path = "$File::Find::dir";
$main::imdisplay_path .= "/imdisplay.exe";
}
}
# Because ImageMagick self-installs into variant paths according to version.
find( \&win32_seek, 'C:/Program Files/' );
}
elsif ( $OS =~ /^netbsd$/i ) {
$OS = 'NetBSD';
$home = '~/';
$delim = '/';
$browser = '/usr/pkg/bin/firefox'
unless $browser;
$txt_viewer = '/usr/pkg/bin/nedit';
$ttf_dir = '';
$font = $ttf_dir . 'Generic.ttf';
}
elsif ( $OS =~ /^MacOS$/i ) {
$OS = 'MACINTOSH';
$home = '~/';
$delim = '/';
$browser = ''
unless $browser;
$txt_viewer = '';
$ttf_dir = '';
$font = $ttf_dir . 'Generic.ttf';
}
elsif ( $OS =~ /os2/i ) {
$OS = 'OS2';
$home = '';
$delim = '/';
$browser = ''
unless $browser;
$txt_viewer = '';
$ttf_dir = '';
$font = $ttf_dir . 'Generic.ttf';
}
else {
$OS = 'UNIX';
$home = '~/';
$delim = '/';
$browser = '/usr/local/bin/mozilla/'
unless $browser;
$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( qq|start "$txt_viewer" "$txt_viewer"|, qq|"$_[0]"| ) && warn "Oops! ";
}
sub show_graphic {
if ( $OS eq 'WINDOWS' ) {
# This path for ImageMagick's 'display' works on Windows 2000.
my $graphic_viewer = "$main::imdisplay_path";
# Just in case, however, include a fallback to MSIE. An error will pop up if
# imdisplay.exe not there. When clicked, MSIE will come up instead.
system( qq|start "$graphic_viewer" "$graphic_viewer"|, qq|"$_[0]"| )
&& system( qq|start "$browser" "$browser"|, qq|"$_[0]"| );
}
elsif ( $OS =~ /NetBSD|UNIX/ ) {
# These three ways put Tk on hold
# `display $_[0] &`;
# exec "display", "$_[0]";
# system "display", "$_[0]", "&";
#
# This way doesn't...
if ( defined( my $kid = fork ) ) {
unless ($kid) { exec "display", "$_[0]"; }
}
else { $main::feedback = "Oops! Could not fork display of $_[0]" }
}
else {
$main::feedback = 'Oops! Operation not defined for this OS.';
}
}
sub hog_memory {
my @procs = @_;
# Get max datasize from NetBSD.
my @lines = split ' ', `sysctl proc | grep datasize.hard`;
my $datasize_max = $lines[-1];
foreach my $proc ( @procs ) {
@lines = split "\n", `ps -xa | grep $proc`;
# May be more than one copy of editor running.
foreach my $line ( @lines ) {
next if $line =~ /ps -xa|grep/;
my @line = split ' ', $line;
print "Increasing datasize to maximum for process $line[4]\n";
print `sysctl -w proc.$line[0].rlimit.datasize.soft=$datasize_max`, "\n";
}
}
}
################################################
# Begin credit for Perl snippet. #
# See "Mozilla -remote made simple" from: #
# http://perlmonks.com/index.pl?node_id=204134 #
################################################
# Display a file in the user's own favorite browser.
use constant URL => 'openURL(%s, new-tab)';
use constant MAIL => 'mailto(%s)';
sub abs_path {
require File::Spec;
File::Spec->rel2abs(shift);
}
sub show_in_browser {
if ( $browser =~ m/mozilla|firefox/ ) {
# Display in Mozilla or its derivatives...
$_ = shift || '';
my $command =
m!^(?:ftp|http|file)://! ? sprintf URL, $_
: -r ($_) ? sprintf URL, 'file://' . abs_path($_)
: s!^(www\..+)!http://$1! ? sprintf URL, $_
: s!^(ftp\..+)!ftp://$1! ? sprintf URL, $_
: s/^mailto:// ? sprintf MAIL, $_
: warn "usage: $0 (filename|URL|mailto:foo\@bar.com)\n";
$main::feedback = system "$browser", -remote => sprintf( $command, $_ );
}
else {
system( qq|start "$browser" "$browser"|, qq|"$_[0]"| )
&& warn "Oops! Trouble opening $browser ";
}
}
###############################
# End credit for Perl snippet #
###############################
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 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 2003 through 2006, 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 #
###############################
###############################
# Begin Pop Up Window Package #
# Version 2005-09-07 #
###############################
package GUS::pop_up_window;
use Tk;
use strict;
no strict "refs";
# Declare variables for strict.
use vars qw(
$mw_pop_up $pane_pop_up $background $title $message
$text_1 $cmd_ref_1 $cmd_args_array_ref_1
$text_2 $cmd_ref_2 $cmd_args_array_ref_2
$frame_bn $font
);
# Calculate dimensions of message for pane, etc. Then
# configure widget to that height and width.
sub size_widget_for_string {
my ($wgt, $msg, $font) = @_;
# Measure widest line of string for given font.
my @msg = split "\n", $msg;
my $hght = 1.5 * $wgt->fontMetrics($font, -linespace);
my $wdth = 0;
foreach (@msg) {
my $line_wdth = $wgt->fontMeasure($font, " $_ ");
$wdth = $line_wdth if $wdth < $line_wdth;
$hght += $wgt->fontMetrics($font, -linespace);
}
# Limit size to reasonable maximums.
my $max_hght = 0.6 * $wgt->screenheight;
my $max_wdth = 0.9 * $wgt->screenwidth;
$hght = $max_hght if $hght > $max_hght;
$wdth = $max_wdth if $wdth > $max_wdth;
# Configure the widget.
$wgt->configure( -width => $wdth, -height => $hght );
}
sub start_MainLoop {
# Only one pop-up at a time.
quit_MainLoop() if Tk::Exists $mw_pop_up;
( $background, $title, $message,
$text_1, $cmd_ref_1, $cmd_args_array_ref_1,
$text_2, $cmd_ref_2, $cmd_args_array_ref_2,
) = @_;
my $font = 'courier';
$mw_pop_up = MainWindow->new(
-title => " $title",
);
# An outermost pane to scroll all sub-panes within.
$pane_pop_up = $mw_pop_up->Scrolled(
'Pane',
-scrollbars => 'osow',
-sticky => 'new',
)->pack( -side => 'top', -expand => 1, -fill => 'both' );
# Custom pane size for the label it will contain.
size_widget_for_string($pane_pop_up, $message, $font);
my $text = $pane_pop_up->Label(
-text => "$message",
-background => $background,
-justify => 'left',
-font => $font,
)->pack( -side => 'top', -expand => 1, -fill => 'both' );
my $btn_width = 12;
$btn_width *= 2 if defined $cmd_ref_2;
$frame_bn = $mw_pop_up->Frame(
-width => $btn_width,
-relief => 'flat',
-borderwidth => 0,
)->pack( -side => 'top', -expand => 0 );
# One button is requried.
my $bn_1 = $frame_bn->Button(
-width => 12,
-relief => 'raised',
-foreground => 'blue',
-activebackground => 'green',
-command => \&action_1,
-text => " $text_1 ",
)->pack( -side => 'left', -expand => 1, -fill => 'both');
# A second button is optional.
if ( defined $cmd_ref_2 ) {
my $bn_1 = $frame_bn->Button(
-width => 12,
-relief => 'raised',
-foreground => 'blue',
-activebackground => 'green',
-command => \&action_2,
-text => " $text_2 ",
)->pack( -side => 'left', -expand => 1, -fill => 'both');
}
MainLoop;
}
# What happens when you click the left or only button.
sub action_1 {
if ( defined( $cmd_ref_1 ) ) {
&{$cmd_ref_1}( @{$cmd_args_array_ref_1} );
quit_MainLoop();
}
}
# What happens when you click the (optional) right button.
sub action_2 {
if ( defined( $cmd_ref_2 ) ) {
&{$cmd_ref_2}( @{$cmd_args_array_ref_2} );
quit_MainLoop();
}
}
# Close down the Perl/Tk GUI
sub quit_MainLoop {
$mw_pop_up->destroy() if Tk::Exists($mw_pop_up);
}
#################################
# Begin General Purpose Package #
# Version 2005-03-08 #
#################################
package GUS::general;
BEGIN { }
use Tk;
use strict;
no strict "refs";
# See if (0,0,1) and (0,1,0) are equal.
sub comp_numeric_arrays {
my ($aref_1, $aref_2) = @_;
my $bool = 1;
for ( my $i = 0; $i <= $#$aref_1; ++$i ) {
$bool = 0 unless $$aref_1[$i] == $$aref_2[$i] ;
}
$bool = 0 unless scalar @$aref_1 == scalar @$aref_2;
return $bool;
}
# See if ('a', 'b', 'c') and ('d', 'e', 'f') are equal.
sub comp_string_arrays {
my ($aref_1, $aref_2) = @_;
my $bool = 1;
for ( my $i = 0; $i <= $#$aref_1; ++$i ) {
# $bool = 0 unless $$aref_1[$i] eq $$aref_2[$i] ;
}
$bool = 0 unless scalar @$aref_1 == scalar @$aref_2;
return $bool;
}
END { }
###############################
# End General Purpose Package #
###############################
######################
# Begin CSV Package #
# Version 2006-06-07 #
######################
# THIS PACKAGE IS UNDER CONSTRUCTION.
# ORIGINAL USE WAS TO IMPORT DATA FROM 'LMS PIMENTO SYSTEM'
# AKA 'ROAD RUNNER' VERSION 'Rev 5.A SL1' FOR ANALYSIS.
# CURRENTLY TRYING TO MAKE IT FULLY CSV-GENERIC.
package GUS::CSV;
BEGIN { }
use Tk;
use strict;
no strict "refs";
use Text::CSV::Simple;
# Returns true if array has duplicate elems.
sub dup_elems_test {
@_ = sort @_;
while ($#_) {
last unless $_[0] cmp $_[1];
shift @_;
}
return scalar @_ > 1;
}
# Prevent channel obfuscation by idiots who name CSV data columns (channels) identically.
sub enumerate_csv_keys {
my $i = 1;
my @columnated;
foreach (@_) {push @columnated, "CSV Col $i: $_"; ++$i;}
return @columnated;
}
# Winnow first N lines of input file.
# Return array of keys for future hash.
sub get_csv_keys {
my ($path,) = @_;
my @keys;
if (open CSV, $path) {
my $line_1 = ;
chomp $line_1;
close CSV;
@keys = split ',', $line_1; # Return array of keys for parser.
# Enumerate all keys if any one duplicates another.
@keys = enumerate_csv_keys(@keys) if dup_elems_test(@keys);
return @keys;
}
else { print "Oops! Problem at get_csv_keys. \n" }
}
# If 1st-column is time data, extract it and average out the scan rate.
sub extract_time_channel {
my $t = shift; # Get aref of @keys leaving @_ holding @hrefs only.
$t = shift @$t if $t->[0] =~ /[T|t]ime/; # Scalar reused as time channel name.
if ($t) { # If a valid time channel...
my ($i, $t_prior, $t_total) = (0, 0, 0);
foreach (@_) { # Extract time column from all hrefs.
next unless $_->{$t} =~ /([0-9]\.*)[0-9]+(E|e).[0-9]+/;
$t_total += $_->{$t} - $t_prior;
$t_prior = $_->{$t};
++$i;
}
coerce_sample_rate( sprintf "%4.3f", $i / $t_total);
}
}
# If average sample rate within 2% of known standard, coerce to standard.
sub coerce_sample_rate {
my $sr = shift;
foreach (@main::sample_rates) {
my $ratio = $sr / $_;
if ($ratio > 0.98 && $ratio < 1.02) {
$main::sample_rate_csv = sprintf "%4.1f", $_;
last;
}
}
$main::sample_rate_csv =~ s/\.0$//;
$main::params{DELTA_T} = sprintf("%.12e", 1 / $main::sample_rate_csv);
}
sub csv_to_arrays {
my ($in_file,) = @_;
my @keys = get_csv_keys( $in_file );
my @data_keys;
my $parser = Text::CSV::Simple->new;
$parser->field_map( @keys );
my @hrefs = $parser->read_file($in_file); # Array of hrefs, one href per record.
my @arefs;
extract_time_channel(\@keys, @hrefs);
foreach my $key (@keys) {
next if $key =~ /[T|t]ime/;
push @data_keys, $key;
push @arefs, [];
foreach my $href (@hrefs) {
push @{$arefs[-1]}, $href->{$key};
}
}
foreach (@arefs){ shift @{$_} }; # Lose each chan's description text from 1st row.
return \@data_keys, \@arefs;
}
# Take a 2d aref of arefs, tip over on own axis, return.
sub tip_2d_axis {
my $arefs = shift;
my @tipped_arefs;
foreach my $aref (@$arefs){
push @tipped_arefs, [];
while ( scalar @$aref ) {
push @{$tipped_arefs[-1]}, shift @$aref;
}
}
return \@tipped_arefs;
}
sub parse_CSV_file {
my $in_file = shift;
$main::params{DELTA_T} = 1.0000000E-03; # FIX THIS
my ($keys, $arefs) = csv_to_arrays($in_file);
$arefs = tip_2d_axis($arefs);
my $i = 1;
foreach (@$keys) {
$main::params{"DESC_r_CHAN_$i"} = $_;
$main::params{"UNITS_r_CHAN_$i"} = '?';
my @attribs = main::chan_max_and_min($i - 1);
$main::params{"SCALE_r_CHAN_$i"} = $attribs[-1];
++$i;
}
@main::all_chans = @$arefs;
main::update_params_for_all_chans();
}
END { }
###################
# End CSV Package #
###################
__END__
=head1 NAME
RPC Edit
=head1 VERSION
Release date = 2006-06-07
=head1 SYNOPSIS
perl gus_rpc_edit.pl
=head1 DESCRIPTION
Editor for RPC-III road load data files
=head1 FEATURES
This editor works a bit differently from others which you may have used. In this it saves much time and effort. But you'll have to approach it on its own terms. I've tried to make it as intuitive as possible. So before you devote yourself to studying any of what I've written below, may I suggest you just start the editor and play around with it for a while? You will find that it has most of the expected features for RLD files in RPC-III format.
=head1 SUPPORTED FILE FORMATS
=over 4
=head2 INPUT
You may read in MTS RPC time history files in all their variants: *.tim, *.edt, *.rsp, *.drv, *.des, *.tex, etc. You may also read in Comma Separated Value (*.csv) files provided that they adhere to the IETF standard for CSV.
Any *.csv files not complying with the IETF standard for CSV must be rectified prior to read-in. Among those not complying are CSV files from Pimento Software as output by their Roadrunner hardware. These are easily rectified, however. All you need do is pass them through the included Perl script F<> which can perform the needed adjustments.
=head2 OUTPUT
You may write out MTS RPC time history files in binary or ASCII (TAB delimited) formats. Writing out CSV files is not supported.
=back
=head1 DATA REDUCTION FEATURES
You may reduce data by peak slice or by vector envelope. The best way to learn how these work is to pick any file, edit it both ways and then scrutinize the graphs and/or perform other analyses. The GUI is fairly intuitive, so best that you just try both and see.
=head1 BATCH EDITING FEATURE
You can batch edit any number of files all the same way. I will describe this in more detail at a later date. Find it in the pull-down menu labeled options.
=head1 ARBITRARY WAVEFORM FEATURE
Interpolates a list of arbitrary peaks and valleys. The input file format is ASCII (C<*.dat>) with a head and body. The header contains minimal RPC header paramters (CHANNELS = 1, UNITS.CHAN_1 = N, FRAMES = 1, DELTA_T = 2.441406E-03) one per row. The body contains rows of tab delimited columns. Each row represents simultaneous TAB delimited channel points. Waveform will be monotonic of semi-arbitrary frequency so as to occupy the designated number of frames. Output is as a binary RPC Time History file. If monotonic results prove difficult to iterate, use the Pythagorized peak/slice peak slice feature to bias the time axis, horizontally streatching out and compressing peaks according to their amplitude. Refer to the example file http://starling.us/tet/gus_perl/gus_rpc_edit_pl/rpc_files/example_arb_wav.dat
=head1 BLOCK CYCLE FEATURE
Interpolates a list of peak/valley blocks with exacting control of frequency. The input file format is ASCII (C<*.dat>) with head and body very like that described above but somewhat more complicated. Frequency control is afforded by the addition of a Hertz-Cycles channel. For instance, a block cycle C<*.dat> file designed to output a 3-channel RPC file would itself contain four channels. This forth channel requires its own parameter (UNITS.CHAN_4 = Hz-Cycles) in the head and its own column in each row of the body. Refer to the example file http://starling.us/tet/gus_perl/gus_rpc_edit_pl/rpc_files/example_block_cycle.dat
=head1 GRAPHING FEATURE
Output as PNG files, graphs are user-configurable as to channels, X and Y scales, background color, etc. Graphs are each accompanied by a text file listing channel max/min data, etc. The C button will send any just-created graph to the system web browser for viewing. A serious shortcoming however is that you can not yet superimpose two files, nor display them as 3D ball-of-string vector diagrams. For that refer to the section on 3rd party softwares near the end of this document.
=head1 CAVEATS
This program is free software and a perpetual beta-release besides. That is to say, I work on improving it I so that it is I stable. Know therfor that it carries absolutely no warranties or guarantees of any kind (expressed, implied, or even vaguely hinted at). Use at own risk and back up your data. Before playing out in the lab I files output by this editor, analyse them thoroughly to be sure you are personally satisfied with their contents. That's what I do.
=head1 DEPENDENCIES
=over 4
=head2 Perl Modules
Install these into Perl via ActiveState PPM, NetBSD pkgsrc or CPAN as appropriate for your OS: C
=head2 Browsers
Pre-configured with these defaults: MSIE when OS = Win32; Mozilla when OS = NetBSD. Other OS's not tested. Send email to make a recommendation.
=head2 For Unix
Nothing here presentes itself as a difficulty. Required external dependencies are available from the expected sources: C for NetBSD and/or CPAN for Perl. I can't say for Linux, since I have yet to try it. If any report a problem for Linux, I'd very like to help work it out and document the solution here.
=head2 For Win32
No especial problems here either, except that some things are not where most folks expect to find them.
=back
=over 8
=head3 ImageMagick for ActiveState Perl 5.8
The Perl Image::Magick module is not maintained by ActiveState. Instead it is packaged together with the free external software ImageMagick downloadable from http://imagemagick.org/www/download.html?
=head3 PPM commands for ActiveState Perl 5.8
The GD and GD::Graph modules are not maintained by ActiveState. They say it is too difficult and complicated. Other kind folks have graciously ammended this lack. Type like so into ActiveState's PPM...
ppm> help repository
ppm> repository add "Lincoln Stein" http://stein.cshl.org/ppm
ppm> repository add "Randy Kobes" http://theoryx5.uwinnipeg.ca/ppms
=back
=head1 RECOMMENDED 3RD-PARTY SOFTWARES
=head2 OpenDX
OpenDX is a data visualization program originally from IBM but now gone open source. Whatever it is you want to see by way of visualizing your data, however you may want to see it, OpenDX is up to the task. Its complexity is intimidating at first glance. Also it is a memory hog beyond all else that you may ever have used before. But what it can show and how it can show it is simply not to be done without. Nothing else at all compares. Soon I'll devote a separate howto for OpenDX to present in conjunction with this very RPC3 editor of mine. Here is the URL: >
=head2 DPlot
A very, very distant second place indeed to OpenDX is DPlot. Actually, I was fairly happy with DPlot until I discovered OpenDX. DPlot can do some quite pretty 3D scatter plots provided that the data are none too very complicated. There is even a free viewer program. At under $40 it is well worth the cost even if it does only work on Win32. Here is the URL for DPlot >
=head1 AUTHOR
Gan Uesli Starling >
=head1 COPYRIGHT
Copyright (c) 2003, 2004, 2005, 2006 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.
=cut