HOME
ABOUT
- RESULTS
- differences
- BENEFITS
- HISTORY
- TEAM
- LOCATION
- FACILITIES
- BANKING
- MEMBERSHIPS
- APPROVALS
- LICENCES
- SUPPLIERS
- SPONSORSHIPS
- MEDIA
- PRIVACY
AUCTIONS
SHIPPING
FEES
- TS REWARDS
TOOLS
guides
FAQ
CONTACT
- CONNECT

VEHICLES
BRAND
- JAPANESE CARS
  - DAIHATSU
  - EUNOS
  - FORD
  - HONDA
  - ISUZU
  - LEXUS
  - MAZDA
  - MITSUBISHI
  - MITSUOKA
  - NISSAN
  - SUBARU
  - SUZUKI
  - TOYOTA
- GERMAN CARS
- AMERICAN CARS
- BRITISH CARS
- ITALIAN CARS
- FRENCH CARS
- SWEDISH CARS
- KOREAN CARS
TYPE
- mobility
- VENDING
- instruction
- TAXIS
- AMBULANCES
- FIRE ENGINES
- HEARSES
- LIMOUSINES
- COMMERCIAL
CLASS
FUEL
TRUCKS
minitrucks
- DAIHATSU
- HONDA
- MAZDA
- MITSUBISHI
- NISSAN
- SUBARU
- SUZUKI
- DUMP
- CRANE
- CAMPER
- REFRIGERATED
- 4WD
- NEW
BUSES
MOTORHOMES
- YAHOO!
- RAKUTEN
- DEALER

PARTS
- FREE REPORT
- PARTS CONTAINERS
- PARTS SYSTEMS
- PARTS PROTECTION
- BODY SHELLS
- DISMANTLING
- ONLINE PARTS
- NEW PARTS
- INTERIOR PARTS
- EXTERIOR PARTS
  - BONNETS
  - BUMPERS
  - GRILLES
  - FENDERS
  - DOORS
  - TRUNKS
  - SPOILERS
  - LIGHTS
  - EMBLEMS
  - CAMERAS
- ENGINES
- TRANSMISSIONS
- WHEELS & TYRES
  - WHEELS
  - TYRES
CUTS
PERFORMANCE PARTS
TRUCK PARTS
MOTORBIKE PARTS
- MOTORBIKE ENGINES
- MOTORBIKE ACCESSORIES

MOTORBIKES
MARINE
FORKLIFTS
MACHINERY
AGRICULTURAL
OTHER
COUNTRY
- AUSTRALIA
- CANADA
- KENYA
- MYANMAR
- NEW ZEALAND
- PAKISTAN
- TANZANIA
- UNITED STATES

CARVIEW

MOTORHOMES

Select Language

HTTP/2 200 date: Wed, 15 Oct 2025 02:41:34 GMT content-type: text/html; charset=UTF-8 server: cloudflare x-frame-options: DENY x-content-type-options: nosniff x-xss-protection: 1;mode=block vary: accept-encoding cf-cache-status: DYNAMIC content-encoding: gzip set-cookie: _csrf-frontend=9bf4fee110122ef56e7e0316c68c4d25661ebea1d9166844b8192001e1e2405da%3A2%3A%7Bi%3A0%3Bs%3A14%3A%22_csrf-frontend%22%3Bi%3A1%3Bs%3A32%3A%22QO5zgjQRKkU1IxyRBG_DcoRd0fHpAUiL%22%3B%7D; HttpOnly; Path=/ cf-ray: 98ebf54cea2a8cf1-BLR p.pl - Pastebin.com

Pastebin

API tools faq

paste

p.pl

johnkris

Oct 9th, 2025

Never

Add comment

Not a member of Pastebin yet? Sign Up, it unlocks many cool features!

C 242.00 KB | Source Code | 0 0

raw download clone embed print report

#!/usr/bin/env perl
###################################
# THIS PROGRAMM IS DOCUMENTED WITH INLINE PODs
# There are different comments for users and programmers
# Extract pod with
# USERs: sed '/=PROG/,/=cut/d' p.pl | sed 's/=USER/=/g' | pod2html
# PROGRAMMERs: sed '/=USER/,/=cut/d' p.pl | sed 's/=PROG/=/g' | pod2html
#
# Use script
# ./pray2doc
# for the lazy ones
############
###################################
# Define used modules
use strict;
use warnings;
use Tk;
use Tk::Pretty;
use Tk::BrowseEntry;
use Tk::Balloon;
use Tk::Dialog;
use Tk::LabEntry;
use Tk::ROText;
#use lib LabOptionmenu;
use lib "./lib";
use lib '/opt/pray/lib';
#use lib "/opt/pray/lib";
use Tk::Menu;
use Tk::PNG;
use FileHandle;
use strict;
use warnings;
use Carp;
use Getopt::Long;
use POSIX ('ceil', 'floor');
use feature qw(switch say);
use Cwd;
use Cwd 'abs_path';
use Statistics::Basic qw(:all);
use File::Copy;
#use Imager::Screenshot 'screenshot';
use Data::Dumper;
use Tk::Pane;
use File::Basename;
use File::Compare;
use File::Path;
use List::Util qw/ max min /;
use List::MoreUtils qw( minmax );
#use Tk::Animation;
#use Tk::Splashscreen;
# PRAY modules
use lib dirname(__FILE__) . '/lib';
use lib 'lib';
use Model;
use commons;
use version;
use codes;
########################################################################
# Start user documentation
# - Requirements, installation, running program
########
=USERhead1 NAME
PRay - a graphical user interface for plotting and editing rayinvr models
PRay
l
o
t
=USERhead1 README
This is the user README for PRay.
Please read status messages and command line output. I've tried to display user relevant
messages in status line of main window. But not everything important goes there, so
it's wise to keep an eye to the command line output, especially if something goes wrong.
=USERhead2 Installation/Preparations
PRay is written in the script language Perl with Tk for graphical features.
Therefore PRay does not need to be compiled but a couple of preparations
are necessary.
=USERhead3 System requirements
Because I'm a lazy person I try to make use of existing programms when possible.
Required software:
=over
=item perl/Tk
Perl and Tk graphics modules are necessary. PRay does not run without them.
Perl is usually available by default on Unix-like systems but Tk and some other modules
need to be added. See below for installation.
=item rayinvr
Working rayinvr/xrayinvr with dmplsqr is necessary for ray tracing and inversion.
A slightly modified source code is provided in this package. PRay can run
without rayinvr but of course traveltimes and ray paths cannot be calculated.
=item GMT (optional)
Some features require GMT-commands. It has been tested with GMT 4.5.6. Changes
may become necessary for future GMT-versions. This applies for contours, gridding and the provided
external plotting scripts.
=back
=USERhead3 Installation of Perl modules
=USERhead4 Installation as root
If you have root privileges and want to install perl modules systemwide,
start the cpan shell
sudo perl -MCPAN -e shell # Start the cpan shell
=USERhead4 Installation as user
If you only want to install it for yourself or perl tries to install modules
to a folder with no write permissions (eg in /opt/local/..), you need
to change the target installation directory within the cpan-shell
(before installing modules):
perl -MCPAN -e shell # Start the cpan shell
cpan> o conf mbuildpl_arg "--install_base $HOME/perl/"
cpan> o conf makepl_arg "PREFIX=$HOME/perl/"
UPDATE: the above method works with older perl installations (error
message: C<Only one of PREFIX or INSTALL_BASE can be given. Not both.>).
If so, you need to change the environment variable (e.g. for csh) before
starting the CPAN shell:
setenv PERL_MB_OPT '--install_base "$HOME/perl5"'
setenv PERL_MM_OPT INSTALL_BASE=$HOME/perl5
perl -MCPAN -e shell
=USERhead4 Install modules
cpan> install modulname
e.g.:
cpan> install Tk
cpan> install Graphics::ColorUtils
cpan> install Number::Format
cpan> install List::MoreUtils
cpan> install Statistics::Basic
cpan> install Tk::Splashscreen.pm
..
(list might not be complete, check error output)
Experience has shown that force is needed to install those two modules. So use
cpan> force install Tk
cpan> force install Graphics::ColorUtils
=USERhead3 Setting your environment
- Include C<PRay>-directory in your executable path
- Set C<PERL5LIB> to your perl module and library directorys
tcsh:
setenv PERL5LIB /your/path/to/pm/
eg.:
setenv PATH ${PATH}:$HOME/pray
setenv PERL5LIB $HOME/perl/lib64/perl5/
setenv PERL5LIB ${PERL5LIB}:$HOME/perl/share/perl5
setenv PERL5LIB ${PERL5LIB}:$HOME/pray
bash:
# export PERL5LIB=/your/path/to/pm/
export PERL5LIB=/usr/lib64/perl15/vendor_perl/Tk.pm
=USERhead3 Running C<PRay>
Use a command line and type
p.pl
in the same directory where you keep your model C<v.in> and C<r.in>.
=head3 Errors
Have you run into problems? The most common problem are missing modules indicated by
following error message:
Can't locate Tk.pm in @INC (@INC contains: /projects//nam2011/bin/ ... )
at /projects//nam2011/bin/pray/p.pl line 15.
BEGIN failed--compilation aborted at /projects//nam2011/bin/pray/p.pl line 15.
In this case the module C<Tk.pm> is missing (first sentence) and cannot be
found in the listed directories (C< @INC contains: dir1 dir2 .. >)
Your either have not (successfully) installed the perl modules or the
module location is not in the C<@INC> list.
Use above description to install the mentioned module and make sure
that the directories containing your newly installed
modules and PRays module files e.g. C<model.pm> is included in this
path. If not, add that directory to C<PERL5LIB> environment variable.
If you don't know, where your newly installed perl-modules are, look for
them, e.g. in the cpan shell:
cpan[1]> i Tk
CPAN: Storable loaded ok (v2.41)
Reading '/Users/tfromm/.cpan/Metadata'
Database was generated on Wed, 19 Aug 2015 12:53:29 GMT
CPAN: YAML loaded ok (v1.15)
CPAN: Time::HiRes loaded ok (v1.9725)
Reading 8 yaml files from /Users/tfromm/.cpan/build/
.........................................................DONE
Restored the state of none (in 0.4535 secs)
Module id = Tk
DESCRIPTION a graphical user interface toolkit for Perl
CPAN_USERID TKML (The Tk Perl Mailing list <[email protected]>)
CPAN_VERSION 804.033
CPAN_FILE S/SR/SREZIC/Tk-804.033.tar.gz
UPLOAD_DATE 2015-02-21
DSLIP_STATUS bmcOo (beta,mailing-list,C,object-oriented,open-source)
MANPAGE Tk - a graphical user interface toolkit for Perl
INST_FILE /Library/Perl/5.18/darwin-thread-multi-2level/Tk.pm
INST_VERSION 804.033
or with C< find / -name "Tk.pm" > or use C< instmodsh >
You can check the content of Perls C<@INC>-variable with following command:
perl -V
Another error message:
1dyld: lazy symbol binding failed: Symbol not found: _Perl_sv_utf8_upgrade_flags
Referenced from: /Library//Perl/5.10.0/darwin-thread-multi-2level//auto/Tk/Tk.bundle
Expected in: flat namespace
dyld: Symbol not found: _Perl_sv_utf8_upgrade_flags
Referenced from: /Library//Perl/5.10.0/darwin-thread-multi-2level//auto/Tk/Tk.bundle
Expected in: flat namespace
Trace/BPT trap
This happens when Tk was not installed with the perl version you are using. In this case
perl was version 5.12 but Tk was installed with perl 5.10. Make sure you are using the same
perl version, that was used in for the Tk installation with either changing your
C<$PATH>-variable or install Tk with the current perl version.
=USERhead3 rayinvr-Settings
Following parameter must be set in rayinvrs C<r.in> to create output needed by PRay:
iplot = 0
idump = 1
itxout = 3
# ray = ivray # Not literally, but they should have the same length
ray = 1.2, 1.3, ...
ivray = 12, 13, ...
raysl=1
PRay automatically checks iplot, idump and itxout. But you
need to set the 'ray' and 'ivray' arrays yourself.
=over
=item *
Setting 'ray' and 'ivray':
Please be aware that
using the same phasecode (ivray) for different rays leads to confusions
in the displayed output (but it does work and might be easier for modelling).
PRay uses the phases (ivray) associated with raycodes (ray) from r.in.
ray = 1.1, 2.1, 2.2, 3.2, 4.3
ivray = 1, 1, 2, 3, 4
That means that rays 1.1 and 2.1 use the same phase (1). So the
theoretical arrivals for 1.1 and 2.1 get the phasecode 1 in tx.out.
There is no way to distinguish them without a lot of extra
calculations and the picks will be displayed for only one raycode.
=item *
C<iplot> can be C<1>, but then you'll have a rayinvr display popping up
every time you run rayinvr. A quick switch is include in the graphical editor
for r.in
=item *
txout can be 2 or 3. Make sure, output is generated in tx.out. Sometimes
you need to switch between 2 and 3 without an obvious reason.
=back
=USERhead2 Installation done
You should now have a working PRay. You can try out the rayinvr model examples
provided in the C<rayinvr/examples> directory (be aware that not all rayinvr
functions are included in PRay). There's more documentation about the feature
usage in C<docs/>.
Need help?
Improvements for the installation instruction?
Interested in joining the project?
Please drop me a mail.
=cut
######################################################################
# Programmers documentation
#######
=PROGhead1 NAME p.pl
PRay - programmers documentation
This is the programmers documentation. It's written as embeded POD inside the source
code to simplify documentation for programmers. Unfortunately this has some drawbacks for
users. First: it's not just a textfile you can simply edit and update. Second: Explainations
are sorted as in source and not content related.
Sorry for this inconvenience.
=PROGhead2 Subroutine naming
Name Comment
i_.. initialization routines
b_.. associated with buttons or menubar
m_.. associated with modelspace
t_.. associated with timespace
=cut
######################################################################
# Global Variables
#######
GLOBAL:
my $PRAYPATH = dirname(abs_path($0));
my $ICONS = "$PRAYPATH/icons";
# Programmers switches
my $tree = 0;
my $debug = 0;
my $dev = 0;
# User switches
my $verbose = 0;
my $quiet = 0;
my $EXPORT = 0;
GetOptions(
'tree|t' => \$tree,
'debug|d' => \$debug,
'dev' => \$dev,
'verbose|v' => \$verbose,
'quiet|q' => \$quiet,
'export|e' => \$EXPORT,
);
my %DEBUG = (tree => $tree, debug => $debug, dev => $dev,
verbose => $verbose, quiet => $quiet);
print "(I) echoing subroutines enabled\n" if $tree;
print "(I) debugging infos enabled\n" if $debug;
print "(I) developer infos enabled\n" if $dev;
print "(I) Printing more user information\n" if $verbose;
print "(I) Reduced program verbosity\n" if $quiet;
=PROGpod
Control verbosity.
GetOptions(
'tree|t' => \$tree,
'debug|d' => \$debug,
'dev' => \$dev,
'verbose|v' => \$verbose,
'quiet|q' => \$quiet,
'export|e' => \$EXPORT,
);
my %DEBUG = (tree => $tree, debug => $debug, dev => $dev,
verbose => $verbose, quiet => $quiet);
There are five levels of verbosity of the program for debugging.
Those variables are passed to the modules.
=cut
=USERhead3 Verbosity
Verbosity can be controlled with command line switches
-t [--tree] print subroutine names (usefull for programmers)
-d [--debug] print debug messages (usefull for programmers)
[--dev] print development messages (usefull for programmers)
-v [--verbose] be more verbose (for users)
-q [--quiet] be quiet, only important messages are printed (for users)
=cut
print
"######################################################################\n"
."# Starting PRay #\n"
."# a Plotting programm for RAYinvr #\n"
."######################################################################\n" unless $quiet;
my $DIR = cwd();
my $PROG = "PRay";
print "Working in directory: $DIR\n" unless $quiet;
my $INITMSG = ""; # Collect messages during startup and display once GUI has started
######################################################################
# DEFAULT CONFIGURATION
my $file; # File for zp2ray. This is not nice but quick and dirty. See in b_zp2ray for usage
my %CONFIG;
my %CONFIGDOC;
my %STATUS; # Store status information from p.status (!!! NOT COMPLETELY IMPLEMENTED !!!)
$STATUS{PRayVersion} = '1970-01-01';
# Set PRayVersion to default date. That means, that update messages
# for new PRay versions are displayed.
# A new PRay version is set, if stored in config file.
######################################################################
# Get initial configuration from r.in and overwrite default %CONFIG
# Check if a rayinvr model is present
unless (-f "r.in" ) {
my $dw = new MainWindow();
my $text = "Can't find a rayinvr model\nCreate simple start model?";
my $title = "Create simple start model?";
my $m = $dw->Dialog(-popover => $dw,
-title => $title,
-text => $text,
-buttons => ['Yes', 'No']
);
if ($m->Show eq "Yes") {
i_createModel();
}
$dw->destroy;
}
my $RIN = commons::readRin();
#$CONFIG{rin}=$RIN;
i_ConfigInit(); # Also replaces CONFIG with rin values
# Overwrite r.in and default values with user defined values
my $CONFIGFILE = "p.config";
i_ConfigRead($CONFIGFILE);
=PROGhead2 Initialization process
=PROGhead2 Used subs
i_ConfigRead()
=cut
=PROGhead3 Phasecodes
Phasecodes are read from r.in
my $CODES = new codes( 'phasecodes' => $RIN->{ivray}, 'raycodes' => $RIN->{ray});
=cut
my @ADDITIONALPHASES = split /\s+/, $CONFIG{additionalPhases} if ( $CONFIG{additionalPhases} );
my @ADDITIONALCOLORS = split /\s+/, $CONFIG{additionalPhaseColors} if ( $CONFIG{additionalPhaseColors} );
my $CODES = new codes( 'phasecodes' => $RIN->{ivray}, 'raycodes' => $RIN->{ray}, 'debug' => \%DEBUG);
my %PHASECOLORS;
my @REFLECTED;
my @REFRACTED;
my @HEAD;
i_Colors();
#################################
my %RAYSTATUS; # Stores status of checkbuttons for rayphase-switching
my %stationlist; # Hash of Arrays. Used for listbox to select
# single station used for zp or other programs
# for only one station
# $stationlist{"$obs"} =
# ["OBS $obs", "100st$obs.h.ent.head", "zp.par",0, $km];
# Array contains:
# 0 Stationlabel
# 1 zp-file
# 2 zp-parameterfile
# 3 flag for drawing rays and times
# 4 Profilekm. Important for OOP
my $station="136"; # Selected station to use for zp
my @DRAWNSTATIONS;
my @DRAWNRAYS = ("5.1");# Save initial drawnRays for model
my @DRAWNPHASES = (51); # Save initial drawnPhases for model
# DRAWNRAYS and PHASES might be unneccessary. %RAYSTATUS combines values
# for both of them.
my $profilelength = $CONFIG{xmax}-$CONFIG{xmin};
my $totaldepth = abs($CONFIG{zmin})+abs($CONFIG{zmax});
#print
##"Profile is $profilelength km long. ".
#"Extending from $CONFIG{xmin} to $CONFIG{xmax}\n";
####################################################################################
# GUI Varibles
my $canvaswidth = $CONFIG{screenwidth}; # Width of cavas for time and model
my $canvasheigth = ($CONFIG{screenheight}-200)/2; # Heigth of cavas for time and model
my $box = [0, 0, $canvaswidth, $canvasheigth]; # Size of model and runtimediagram in px
my $zoomRect; # Variables for zooming in model
my $zoomRectzeit; # and runtimediagram
my @zoomRectCoords; # Holds coordinates for zooming
my $oldx = 0; # buffer for old node coordinates
my $oldy = 0; # buffer for old node coordinates
my $initx = 0; # Save initial node position
my $inity = 0; # Save initial node position
my @drawnAxes;
my $yscale = $box->[3]/($totaldepth);
my $ytscale = $box->[3]/($CONFIG{tmax} - $CONFIG{tmin}); # Scalefactor for TT-diagramm
#my $xscale = $box->[2]/$CONFIG{xmax};
my $xscale = $box->[2]/$profilelength;
my $zoomhistory = []; # keep zoomboxes for later unzooming
#print "Initialzoom yscales in ZoomOriginal: $yscale\n";
my $vredbutton = 1;
my $allRaysButton = 0; # Draw all available rays
my $allRflButton = 0; # Draw all reflections
my $allRfrButton = 0; # Draw all refractions
my $allMulButton = 0; # Draw all Multiples
my $showBlocks = 0; # show rayinvr blocks?
my $showNodes = 1; # Editing nodes?
my $showVNodes = 0; # Editing velocity nodes?
my $annotVNodes = 1; # Label velocity nodes?
my $showGrid = -1; # Show velocity gradient
my $showTomoGrid = -1; # Show velocity gradient
my $showTomoContours = -1; # Show velocity gradient with contourlines
my $showContours = 0; # Show contourlines
my $contourcolor = 0; # Contourlines in colors (1) or grey (0)
my $showStreamer = 0; # Show stremaer picks
my $glueNodes = 0;
my $PicksManButton = 1;
my $PicksCalButton = 1;
my $ShowRaysButton = 1;
my $selectedNodes = 0; # Flag for selecting nodes. Used in m_B1node
my ($startnode, $endnode); # Save start and end nodes for toggling
my $editNode = ""; # Save type of edit you want to do to nodes
my $movenode = 0; # Flag for moving node
my $RMS = 0; # Flag for measuring rms velocity in traveltime canvas
my $VERSION = -1; # Historyindex for undo
my @markedmodels = (); # Save all version numbers for marked models
my $depthvelocityprofiles = "10,120,300,460"; # default km for extracting velocity profiles
my @choosePicks = (); # Flag for choosing picks to change phase, and place to store the chosen
# picks
my %COMMENTS; # Save comments for model versions
my $commentfile = 'comments.txt'; # filename of commentfile
=PROGpod
i_ReadStatus()
i_Comments()
=cut
i_ReadStatus();
i_Comments();
if ($VERSION == -1 ) {
$VERSION = 1;
_historyAdd();
$VERSION = 1;
}
#$VERSION = _GetVersionNumber(); # Historyindex for undo
###################################
# Define GUI
#######
GUIDEFINITION:
my $mw = new MainWindow();
_setWindowTitle();
i_checkPRayVersion();
my $balloon = $mw->Balloon(-background => "yellow");
# Making right click popup menu.
# Commands are added, when clicking on an object, so it gets information about it
my $menuRightClick = $mw->Menu(-tearoff => 0);
#######
# Create runtimediagram region
my $lzd = $mw -> Canvas(-confine=> 1, -relief=>"sunken", -background=>"#F1F1F1",
-width=> $canvaswidth, -height => $canvasheigth, -scrollregion => $box);
$lzd -> pack(-side=>'bottom');
$lzd->createRectangle(0, 0, $canvaswidth, $canvasheigth, -fill => $CONFIG{ttbg}, tags=>['background']);
#######
# Create model region
my $cns = $mw -> Canvas(-confine=> 1, -relief=>"sunken",
-width=> $canvaswidth, -height => $canvasheigth, -scrollregion => $box);
$cns -> pack( -side=>'bottom');
$cns->createRectangle(0, 0, $canvaswidth, $canvasheigth, -fill => $CONFIG{modelbg}, tags=>['background','off model limits']);
i_BindSpace(); # Display info for stations, layers, .. Move nodes
i_BindTime();
# Status line as Read-Only text
my $stline = $mw->Scrolled ("ROText", -scrollbars => 'w')
-> pack ( -side => 'bottom', -expand => 1, -fill => 'both', -before => $lzd);
$stline->insert ('end', "Status Messages");
$stline->configure(-height => 2);
##################################################
# CREATE MODEL
MODEL:
my $model = new model('space'=> $cns, "time" => $lzd, "statusline" => $stline,
"mainwindow" => $mw, "icons" => $ICONS,
"balloon" => $balloon,
#"profilelength" => $profilelength,
"zmin" => $CONFIG{zmin}, "zmax" => $CONFIG{zmax},
"tmin" => $CONFIG{tmin}, "tmax" => $CONFIG{tmax},
"yscale" => $yscale, "ytscale" => $ytscale, "xscale" => $xscale,
"phasecolors" => \%PHASECOLORS,
"config" => \%CONFIG, "debug" => \%DEBUG, "rin" => $RIN,
"glueNodes" => $glueNodes, "contourcolor" => $contourcolor,
#"phasecodes" => $PHASECODES, "raycode" => $RAYCODES,
"drawnRays" => \@DRAWNRAYS, "drawnPhases" => \@DRAWNPHASES,
"codes" => $CODES,
"version" => $VERSION);
=PROGpod
new Model()
i_MenuBar();
i_AddStations(); # Needs to stay here, until all buttons are included in model
=cut
i_MenuBar();
i_AddStations(); # Needs to stay here, until all buttons are included in model
my $r = $model->init("splash" => $CONFIG{splash}); # Reads v.in, rays and times
# Cannot be run with $model->new() because stations need to be defined
#if ($r ) {
#_printStatusMessage("\n$r");
#}
#$model->get('1d');
#exit;
EXPORT:
if ( $EXPORT ){
print "Export rays&picks to $CONFIG{exportpath} and quit\n";
# copy r.export to r.in, run rayinvr and then export stuff
#copy ("r.in", "r.tmp");
#copy ("r.export", "r.in");
#b_rayinvr();
b_export();
#copy ("r.tmp", "r.in");
#unlink("r.tmp"); # delete temporary r.in
die;
}
=PROGpod
i_DrawButtons(); # Needs to be after i_AddStations
b_drawAll();
=cut
i_DrawButtons(); # Needs to be after i_AddStations
b_drawAll();
#$model->writeVin;
#exit
my ($id) = (q '$Id: p.pl 17 2016-10-18 13:10:13Z tafro $' );
print " $id \n";
print
"
#############################################
# Program initialized. Using #
# $id #
# Enjoy. #
#############################################
" unless $quiet;
# Check rayinvr if no p.config is present
unless (-f "p.status" ) {
my $t =
"You seem to run PRay for the first time. Do you want me to check your
r.in file and fix settings according to my needs?";
my $m = $mw->Dialog(-popover => $mw,
-title => "Check r.in?",
-text => $t,
-buttons => ['Yes', 'No']
);
if ($m->Show eq "Yes") {
commons::checkRin($RIN);
}
}
#$mw->focusFollowsMouse();
$cns->Tk::focus;
#$model->_readContours;
#print "No printing to Status messages:\n $INITMSG\n";
_printStatusMessage($INITMSG);
#$model->status('range' => [185, 410]);
# For testing
#b_resolution();
#b_export();
#b_igmas();
#$model->exportPolygons();
#exit;
$mw->deiconify();
###########################################################################
# MainLoop
###########################################################################
MAINLOOP:
MainLoop;
=PROGhead2 Basic procedures
=head3 Configuration
Define configuration values in C<sub i_ConfigInit>. E.g:
$CONFIG{exportpath} = "./data"; $CONFIGDOC{exportpath} =
'Default: ./data
Outputpath for exporting rays and times in GMT format
(Menu->Export rays&picks)';
Use the configured value with the global variable C<$CONFIG{parameter}>.
The variable C<$CONFIGDOC> stores the text for the popup menu in the graphical
editor.
To include a config-parameter in the graphical editor add the new parameter name
in C<sub b_configEdit>
You can call the parameter with C<< $model->getConfig('parameter') >>.
=head3 Drawings
b_drawAll() # extracts current enabled phases and stations
$model->drawPhaseStationList("phases" => [@DRAWNPHASES], "stations" => [@stationlist])
b_drawPhase called from 'Phasebutton'
b_drawStation called from 'Stationbutton'
=head3 Tags
Tags are the key to interact with the drawn objects and to hand over
information between the object and further processing.
Layer:
my $msg = sprintf("B %s, average velocities: v = %6.2f km/s, v_up = %6.2f km/s, v_low %6.2f km/s",
$self->{number}, $self->{vav}, $self->{vuav}, $self->{vlav});
'LAYER', "B$self->{number}", "$msg"
Boundary (no interaction):
'BOUND', "BOUND$number"
Nodes:
'NODE', "$self->{number}", "$i", "N$self->{number}"
$self->{number} = Layer number
i = index position in node array
Station:
"STATION", "$station->{name}", "$station->{position}", "$station->{depth}"
Ray:
'RAYS'.$station->{name}, "Ph$phase",'RAYS'
TT caluclated/picked:
"PICK", 'RAYS'.$station->{name}, "Ph$phase","km$km t$t unc$unc offset$off", $key
when drawn as dash, cross or circle
OR:
"PICK", 'RAYS'.$station->{name}, "Ph$phase", "$key"
when drawn as line
key = txin, txout, txTomo
AXES (no interaction):
'AXES'
=head3 Modeling
b_rayinvr> run rayinvr
$model->read( "vin", "rays", "times" )
b_drawAll()
b_writeModel
_historyAdd()
$model->writeVin;
$model->set("version" => $VERSION)
b_rayinvr();
_setWindowTitle()
=cut
###########################################################################
# Defining subs
###########################################################################
sub i_AddStations {
=PROGhead2 C<i_AddStations()>
Reads C<$CONFIG{stationfile}> and initializes stations. Stations with
zpfiles are added to C<stationlist>.
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
##############
# Add stations
my $file = $CONFIG{stationfile};
# ADD STATIONS FROM R.IN
if (! -e $file) {
###### OLD ->
print "(D) WARNING: Stationfile $file does not exist\n" if $debug;
#"I'm reading r.in to create one\n";
#commons::createStatxz();
###### OLD <-
###### NEW
# read from r.in
for ( my $i = 0; $i <= $#{$RIN->{xshot}}; $i++) {
my $obs = sprintf("%3d", $i);
my $name = sprintf("%3d", $i);
# Add to stationlist:
# keys of hashes are strings, so 12.4 is not equal to 12.40
my $km = sprintf("%.3f", $RIN->{xshot}[$i]);
my $depth = 0;
$depth = $RIN->{zshot}[$i]*1000 if ($RIN->{zshot}[$i]);
my $switch = (grep {$_ eq $km} @DRAWNSTATIONS) ? 1 : 0; # 0 ist der schalter fuer an/aus
#$stationlist{"$obs"} = [$name, $zpfile, $zppar, $switch, $km];
$stationlist{"$obs"} = [$name, '', '', $switch, $km];
# Add station to model:
# zpfile is needed for changing pick-files
$model->addStation("name" => $obs, "position" => $km, "depth" => $depth);
print "(D) add station $obs, km $km, depth $depth to model\n" if $debug;
} # foreach xshot
return 0;
}
###
# ADD FROM STATXZ
open (STATIONS, $file) or die "Can't open $file\n";
# stationname profilekm depth
# 100st105 422.15 96.4
print "Reading stationpositions from $file\n" unless $quiet;
while (<STATIONS>){
chomp;
s/^\s+//; # no leading white
s/\s+$//; # no trailing white
s/#.*//; # no comments
next unless length; # anything left?
my ($name, $km, $depth, $zpfile, $zppar) = split;
#print "Add station >$name, $km, $depth<\n";
(my $obs = $name); # Keep only the last bit of 100st136
#(my $obs = $name) =~ s/\d.*st//; # Keep only the last bit of 100st136
#print "HEAD: $zpfile\n" if (defined $zpfile);
$zppar = "zp.par" unless (defined $zppar);
if ( $CONFIG{zpFileMask} ){
($zpfile = $CONFIG{zpFileMask}) =~ s/\$obs/${obs}/g unless (defined $zpfile);
}
#print "Add $obs: Mask $CONFIG{zpFileMask} dir:$CONFIG{zpdir} file: $zpfile, par $zppar\n";
# Add to stationlist:
# keys of hashes are strings, so 12.4 is not equal to 12.40
$km = sprintf("%.3f",$km);
my $switch = (grep {$_ eq $km} @DRAWNSTATIONS) ? 1 : 0; # 0 ist der schalter fuer an/aus
$stationlist{"$obs"} = [$name, $zpfile, $zppar, $switch, $km];
# Add station to model:
# zpfile is needed for changing pick-files
$model->addStation("name" => $obs, "position" => $km, "depth" => $depth, "zpfile" => $zpfile);
}
close(STATIONS);
=USERhead3 statxz
This file contains information about stationnames, positions and zpfiles.
It is necessary if you want to address your stations with stationnames.
If PRay cannot find this file it will create one from your r.in. Users may change the
station labels there to suit there own naming.
Additional information about C<zp> parameter can be given in this file.
Columns contain:
Stationname profilekm shotdepth(m) [ZP-Headfile] [zp-parfile]
zp specific columns are optional if diverge from zp filemask (given in C<config>) or zp.par
You can create a statxz-file by the command C<rin.pl -statxz>. This helper-tool is included
in the PRay-directory. It reads in your r.in
file and writes out a statxz-file with numbered xshot and zshot.
You can then manually change the names according to your stations.
All stations in this file are used by PRay when reading traced rays,
creating the station selectors and zp menu. If you have a station traced
that is not in your statxz-file PRay will not know what to do and where to display it.
=cut
}
sub i_BindSpace {
=PROGhead2 C<i_BindSpace>
Defines interactions with model diagram.
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Make Model zoomable
$cns->CanvasBind('<z><1>' => [\&zoomCanvasInit,"m"]);
$cns->CanvasBind('<z><B1-Motion>' => [\&zoomCanvasSize,"m"]);
$cns->CanvasBind('<z><B1-ButtonRelease>' => [\&zoomCanvasFinish,"m"]);
$cns->CanvasBind('<Double-1>' => \&zoomOriginal);
$cns->CanvasBind('<o>' => \&zoomOut);
$cns->CanvasBind('<i>' => \&zoomIn);
# Measure
$cns->CanvasBind('<1>' => [\&m_B1]);
$cns->CanvasBind('<B1-Motion>' => [\&m_B1motion]);
$cns->CanvasBind('<B1-ButtonRelease>' => [\&m_B1release]);
# Edit Nodes
$cns->bind('NODE' => '<1>' => \&m_B1node);
$cns->bind('VNODE' => '<1>' => \&m_B1node);
$cns->bind('NODE' => '<B1-Motion>' => \&m_B1nodemotion);
# Popupmenu
$cns->bind('LAYER' => '<3>' => [\&m_B3menu, Ev('x'), Ev('y')]);
$cns->bind('BOUND' => '<3>' => [\&m_B3menu, Ev('x'), Ev('y')]);
$cns->bind('NODE' => '<3>' => [\&m_B3menu, Ev('x'), Ev('y')]);
$cns->bind('VNODE' => '<3>' => [\&m_B3menu, Ev('x'), Ev('y')]);
$cns->bind('STATION' => '<3>' => [\&m_B3menu, Ev('x'), Ev('y')]);
# Pipi
$cns->bind('SUN' => '<1>' => \&b_help);
=USERhead2 Features
=USERhead3 Interactions with model diagram
Several features are associated with mouse clicks on the model diagram.
=USERhead4 Zooming in model diagram
Key C<z> and left mouse click initiate a zooming rectangle. Keep keys pressed
and move mouse to select model area for zooming. Double left click in model
area resets view to original size.
=USERhead3 Pinched layers
Layers may be pinched together using right click menu on a boundary or layer.
To move overlaid nodes enable the 'magnet'-button. If moving nodes all other layers are check
for identical nodes so the whole program might become slower. Enable this switch only if you
need to move several identical nodes.
=cut
}
sub m_B1 { # Draw line, display coords
my $canvas = shift;
#my ($oldkm, $oldd) = @_;
# Show current coordinates, give layer information, ..
my $x = $cns->canvasx($Tk::event->x);
my $y = $cns->canvasy($Tk::event->y);
$oldx = $x;
$oldy = $y;
my ($oldkm, $oldd) = $model->screen2model([$x, $y], "space");
#my $msg = sprintf ("\nx = %6.2fkm, z = %4.2fkm",
#$oldkm, $oldd);
#_printStatusMessage($msg);
print "(DEV) Start measuring >$x,$y< from >$oldx,$oldy< = km $oldkm, $oldd\n" if $dev;
$cns->Tk::focus;
};
sub m_B1node {
=PROGhead2 m_B1node()
Function to select nodes defining a range for toggling/snapping. Called
when clicking on a node but has only effects if toggling was enabled by
node menu in m_selectNodes
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# save old nodeposition
#my ($x, $y) = ($Tk::event->x, $Tk::event->y);
# Gives absolute screen coordinates
my $x = $cns->canvasx($Tk::event->x);
my $y = $cns->canvasy($Tk::event->y);
$oldx = $x;
$oldy = $y;
$initx = $x;
$inity = $y;
$movenode = 1;
# Moving nodes
my $id = $cns->find(qw/withtag current/);
my @c = $cns->coords($id);
my @tags = $cns->gettags($id);
print "(DEV) Start move Node >$x,$y< from >$oldx,$oldy< tags: @tags from coords >@c<\n" if $dev;
return unless ($selectedNodes !=0); # return if no node is selected
############################
# This is only needed when you want to choose nodes for toggling partial derivatives
#my $id = $cns->find(qw/withtag current/);
#my @tags = $cns->gettags($id);
#print "I'm >@tags<, id @$id\n" if $debug;
if ($selectedNodes == 2 ) {
# Two nodes are choosen. Now write the changes to model
#print "Second node chosen\n" if $debug;
$endnode = \@tags;
$selectedNodes =0;
# Check if both nodes belong to the same layer. If not return.
if ($startnode->[1] != $endnode->[1]) {
my $msg = "\nERROR: Start and end node belong to different layers. $startnode->[1] != $endnode->[1]. Abort operation!";
print "$msg\n";
_printStatusMessage($msg);
$selectedNodes = 0;
return;
}
print "Toggling between <@$startnode> and <@$endnode>\n"if $debug;
_printStatusMessage(" to ".($endnode->[2]/2));
# Ensure to go from smaller to larger value
my ($start, $end);
if ($tags[0] eq 'NODE') {
$start = $startnode->[2] < $endnode->[2] ? $startnode->[2]/2 : $endnode->[2]/2;
$end = $startnode->[2] > $endnode->[2] ? $startnode->[2]/2 : $endnode->[2]/2;
} elsif ($tags[0] eq 'VNODE') {
$start = $startnode->[2] < $endnode->[2] ? $startnode->[2] : $endnode->[2];
$end = $startnode->[2] > $endnode->[2] ? $startnode->[2] : $endnode->[2];
}
#print "Edit Node = $editNode\n";
if ( $editNode eq "toggle" ) {
print "Toggling between nodes $start and $end\n" if $debug;
# Loop through nodes in between start and endnode and toggle them
for (my $i = $start; $i <= $end; $i++ ){
print "Toggling node $i\n" if $debug;
my @madetags = @$startnode;
if ($tags[0] eq 'NODE') {
$madetags[2] = $i*2;
$model->edit( "tags" => \@madetags , "op" => "edit");
} elsif ($tags[0] eq 'VNODE') {
print "Toggle vnode ";
$madetags[2] = $i;
$model->edit( "tags" => \@madetags , "op" => "togglePar");
}
}
# $editNode eq 'toggle'
} elsif ($editNode =~ /snap.*/) {
_printStatusMessage("\nSnap to $editNode");
$model->edit( "tags" => $startnode, "end" => $endnode, "op" => $editNode);
} elsif ($editNode =~ /edit/ && $tags[0] eq 'NODE') {
# Nodes of a layer shall be edited
# Get value of change
my $change = 1; # Get change from user input
my $mode = 'move'; # move or delete nodes?
#########################
# Create the dialog
my $dia = $mw->Toplevel( #-popover => $mw,
-title => "$PROG: Change depth nodes",);
my $bframe = $dia->Frame () -> pack(-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'no');
my $modeframe = $dia->Frame () -> pack(-side=>'left', -anchor => 'n', -fill => 'none', -expand => 'no');
my $changeEntry = $bframe -> LabEntry ( -label => 'Amount of change ',
-labelPack => [qw/-side left -anchor w -expand yes -fill both/],
-textvariable => \$change,
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
my $text = $bframe -> ROText(-width => '30', -height => 4, -borderwidth => 0)
-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$text->insert('end', "Move selected nodes or delete them");
$bframe->Button(-text=>"Apply",
-command => sub {
#################
# Apply change
# Get all nodes of this layer (this is necessary, because
# I don't know how to find the tags of a specific node)
# Node tags: 'NODE', '$layer', '$index*2', 'N $layer'
my $nodes = $tags[3];
print "Start moving nodes from $start to $end\n";
for (my $i = $start; $i <= $end; $i++ ){
my @ids = $cns->find('withtag', $nodes); # Look for ids again, because
# nodes gets newly drawn, once the first node has been edited
#print "--------------------------------------\n";
#print "Moving node $i = $ids[$i] from @ids\n";
my $id = $ids[$i];
my @tags = $cns->gettags($id);
my @coords = $cns->coords($id);
@coords = $model->screen2model(\@coords, "space");
$coords[1]+=$change;
$coords[3]+=$change;
#print "I'm here\n".
#"Node id $id "
#."with tags @tags "
#."wants to move to coords @coords\n";
if ($mode eq 'del') {
@coords = ($end-$start+1); # Gives number of nodes to delete
$model->edit("tags" => \@tags, "value" => \@coords, "op" => $mode);
$dia->destroy; return;
}
$model->edit("tags" => \@tags, "value" => \@coords, "op" => $mode);
}
}
, -width => 10)->pack(qw/-side left/);
$bframe->Button(-text=>"Done", -command => sub { $dia->destroy; return}, -width => 10)->pack(qw/-side left /);
$balloon->attach( $modeframe->Radiobutton(
-text => "move", -value => "move", -variable => \$mode,
)-> pack (-side=>'top', -anchor => 'w', -fill => 'none', -expand => 'no')
, -balloonmsg => "Move selected nodes $change");
$balloon->attach( $modeframe->Radiobutton(
-text => "delete", -value => "del", -variable => \$mode,
)-> pack (-side=>'top', -anchor => 'w', -fill => 'none', -expand => 'no')
, -balloonmsg => "Delete nodes from layer");
}
} # end of selectedNodes == 2
if ($selectedNodes == 1 ) {
print "--------------------------Node: Toggle partial derivatives\n" if $debug;
print "First node chosen\n" if $debug;
$startnode = \@tags;
print "Choose second node!\n" if $debug;
$selectedNodes =2;
_printStatusMessage("\nToggling from ".($startnode->[2]/2));
}
}
sub m_B1nodemotion {
#printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Gives screen coordinates within visible window
#my ($x, $y) = ($Tk::event->x, $Tk::event->y);
# Gives absolute screen coordinates
my ($x, $y) = ($cns->canvasx($Tk::event->x), $cns->canvasy($Tk::event->y));
# Moving nodes
my $id = $cns->find(qw/withtag current/);
print "(DEV) oldx,oldy >$oldx,$oldy<\n" if $dev;
my @c = $cns->coords($id);
my $newx = $x - $oldx;
my $newy = $y - $oldy;
$cns->move($id => $newx, $newy);
$oldx = $x;
$oldy = $y;
$movenode = 1;
print "(DEV) Node is moving, mouse: >$x,$y< from @c to >$newx,$newy<\n" if $dev;
@c = $cns->coords($id);
print "(DEV) new coords >@c<\n" if $dev;
}
sub m_B1motion {
print "(DEV) B1 motion move node? >$movenode<\n" if $dev;
# Draw line, display depth/length(km) of line
# DO NOT DRAW LINE AND MEASURE if a node is mooving
# or if we are zooming
return if ($movenode == 1);
# Look for a zoom rubber
my $zoom = 0;
$zoom = $cns->find('withtag','ZOOM');
#print "(DEV) Is there a zoom rubber? $zoom\n" if $dev;
return if ( $zoom );
my @line = ($oldx, $oldy, $oldx, $oldy);
$cns->createLine(@line, -fill => 'red', #-arrow => 'last',
-tags => ['MEASURE']);
my $x = $cns->canvasx($Tk::event->x);
my $y = $cns->canvasy($Tk::event->y);
my @coords = $cns->coords('MEASURE');
$coords[2] = $x;
$coords[3] = $y;
$cns->coords('MEASURE', @coords);
print "(DEV) Create line: @coords\n" if $dev;
}
sub m_B1release{
=PROGhead2 m_B1release()
Function is called if a click is released anywhere inside the model.
Function depending on what has happened before.
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $id = $cns->find(qw/withtag current/);
my @tags = $cns->gettags($id);
#print "I'm >@tags<, id @$id\n";
@tags = grep {$_ ne 'current'} @tags;
my $msg = "";;
my $x = $cns->canvasx($Tk::event->x);
my $y = $cns->canvasy($Tk::event->y);
my @coords = $model->screen2model([$x, $y], "space");
$msg = sprintf("\n%s; km %6.2f, d %6.2f", "@tags", $coords[0], $coords[1]);
my ($oldkm, $oldd) = $model->screen2model([$oldx, $oldy], "space");
#######################
# Model was measured
if ($cns->find(qw/withtag MEASURE/)) {
#print "(DEV) Measure Release Got arguments @_\n" if $dev;
#my $canvas = shift;
#my ($oldkm, $oldd) = @_;
$cns->delete('MEASURE');
print "(DEV) Measuring depth and distance from $oldkm, $oldd to @coords\n" if $dev;
my $dkm = abs($oldkm - $coords[0]);
my $dd = abs($oldd - $coords[1]);
if ($dd == 0 && $dkm == 0) {
$msg = "";
} else {
$msg = sprintf ("\nx = %6.2fkm, z = %4.2fkm to x = %6.2fkm, z = %4.2fkm; dx = %6.2fkm, dz = %4.2fkm",
$oldkm, $oldd, $coords[0], $coords[1], $dkm, $dd,);
}
}
#######################
# NODES have moved
if ((grep {$_ eq 'NODE'} @tags) && $movenode == 1){
my @coords = $cns->coords($id);
print "(DEV) --- Node mooved to >@coords<\n" if $dev;
@coords = $model->screen2model(\@coords, "space");
my $x = $coords[0]+($coords[2]-$coords[0])/2;
my $y = $coords[1]+($coords[3]-$coords[1])/2;
($oldx, $oldy) = $model->screen2model([$initx, $inity], "space");
$msg = sprintf ("\nNode moved from %6.2f, %6.2f to %6.2f, %6.2f. TAGS: @tags", $oldx, $oldy, $x, $y);
#print "Message $msg\n";
#print "Node with tags @tags has moved to coords @coords\n";
$model->edit("tags" => \@tags, "value" => \@coords, "op" => "move");
$movenode = 0;
#_printStatusMessage("\nRaised layer $tags[3]");
$cns->raise($tags[3]);
} elsif (grep {$_ eq 'STATION'} @tags){
print "This is station: @tags\n" if $debug;
} elsif (grep {$_ eq 'LAYER'} @tags){
print "This is Layer: @tags\n" if $debug;
$msg = "\n@tags";
my $x = $cns->canvasx($Tk::event->x);
my $y = $cns->canvasy($Tk::event->y);
my @coords = $model->screen2model([$x, $y], "space");
#print "x $x, y $y, -> @coords\n";
#$msg = "\n@tags; x,y: @coords";
$msg = sprintf("\n%s; km %6.2f, d %6.2f", "@tags", $coords[0], $coords[1]);
} elsif (grep {$_ eq 'VNODE'} @tags){
print "This is a velocity node: @tags\n" if $debug;
$msg = "\n@tags";
} elsif (grep {$_ eq 'TOMOGRID'} @tags){
#print "This is a velocity node: @tags\n";
$msg = "\n@tags";
} else {
# Shouldn't happen
#my $x = $cns->canvasx($Tk::event->x);
#my $y = $cns->canvasy($Tk::event->y);
print "i_BindSpace() doesn't know, what to do, <@tags>\n" if $verbose;
#print "x $x, y $y\n";
#my @ids = $cns->find('closest', $x, $y, 'LAYER');
#@tags = $cns->gettags(@ids);
#print "i_BindSpace() below current:, <@ids> <@tags>\n";
}
_printStatusMessage($msg);
#$stline->insert ('end', "$msg");
#$stline->see('end');
$cns->Tk::focus;
}
# Called when right mouse button is clicked on the main window.
sub m_B3menu {
=PROGhead2 m_B3menu()
Function displays menu when right clicking on model area in main window.
Depending on the kind of object clicked on, the menu is different.
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my ($self, $x, $y) = @_;
my $cx = $cns->canvasx($Tk::event->x);
my $cy = $cns->canvasy($Tk::event->y);
my $id = $cns->find(qw/withtag current/);
my @tags = $cns->gettags($id);
#print "I'm >$tags[1]<, id @$id\n";
@tags = grep {$_ ne 'current'} @tags;
my $type = $tags[0];
my @coords = $model->screen2model([$cx, $cy], "space");
#print "m_B3menu: Type $type, coords @coords, tags @tags\n";
# Clean menu, then adding entrys for this type of object
$menuRightClick->delete(0, 'last');
if ($type eq 'LAYER' || $type eq 'BOUND') {
$menuRightClick->add('command', -label => "Layer $tags[1]", -state => 'disabled');
$menuRightClick->add('command', -label => 'Add depth node', -command => [\&m_addNode, \@tags, \@coords]);
$menuRightClick->add('command', -label => 'Add velocity node', -command => [\&m_addVNode, \@tags, \@coords]);
$menuRightClick->add('command', -label => 'Move/Remove nodes ..', -command => [\&m_selectNodes, \@tags, \@coords, "edit"]);
#$menuRightClick->add('command', -label => 'Read nodes from file', -command => [\&m_selectNodes, \@tags, \@coords, "file"]);
$menuRightClick->add('command', -label => 'Snap nodes to upper layer ..', -command => [\&m_selectNodes, \@tags, \@coords, "snapUp"]);
$menuRightClick->add('command', -label => 'Snap nodes to lower layer ..', -command => [\&m_selectNodes, \@tags, \@coords, "snapDown"]);
$menuRightClick->add('command', -label => 'Toggle partial derivatives for nodes ..', -command => [\&m_selectNodes, \@tags, \@coords, "toggle"]);
$menuRightClick->add('command', -label => 'Unset partial derivatives for all nodes',
-command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "unsetPar"]);
$menuRightClick->add('command', -label => 'Set partial derivatives for all velocity nodes',
-command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "setPar"]);
$menuRightClick->add('command', -label => 'Raise boundary', -command =>
sub {
(my $n = $tags[1]) =~ s/BOUND//;
$cns->raise("BOUND$n");
$cns->raise("N$n");
#print "Raise boundary >$n<\n";
}); #TODO: Put this raising/lowering function into model->order(raise, BOUND X)
$menuRightClick->add('command', -label => 'Lower boundary', -command =>
sub {
(my $n = $tags[1]) =~ s/BOUND//;
$cns->lower("BOUND$n");
$cns->lower("N$n");
$cns->lower("LAYER");
$cns->lower("background");
});
} elsif ( $type eq 'NODE' ) {
print "Its a node >@tags<\n";
$menuRightClick->add('command', -label => "Depthnode", -state => 'disabled');
$menuRightClick->add('command', -label => 'Toggle partial derivative value',
-command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "edit"]);
$menuRightClick->add('command', -label => 'Delete depth node', -command => [\&m_deleteNode, \@tags]);
} elsif ( $type eq 'VNODE' ) {
print "m_B3menu: Edit Velocity node\n" if $debug;
$menuRightClick->add('command', -label => "Velocity", -state => 'disabled');
$menuRightClick->add('command', -label => 'Toggle partial derivative value',
-command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "togglePar"]);
$menuRightClick->add('command', -label => 'Edit velocity node', -command => \&m_editVNode);
$menuRightClick->add('command', -label => 'Edit velocity ALL nodes', -command => \&m_editVNodes);
$menuRightClick->add('command', -label => 'Delete current node', -command => [\&m_deleteVNode, \@tags]);
} elsif ( $type eq 'STATION' ) {
$menuRightClick->add('command', -label => "Station $tags[1]\@km $tags[2],z=$tags[3]", -state => 'disabled');
#$menuRightClick->add('command', -label => 'Edit phase',
#-command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "editPhase"]
#-command => [\&mc_editPhase, \@tags]
#);
$menuRightClick->add('command', -label => 'Toggle left shots',
-command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "leftShot"]
);
$menuRightClick->add('command', -label => 'Toggle right shots',
-command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "rightShot"]
); $menuRightClick->add('command', -label => 'Toggle station',
-command => sub {
# Toggle value of selected station (to draw or not to draw)
if ($stationlist{$tags[1]}[3]==1) {
$stationlist{$tags[1]}[3]=0
}else{
$stationlist{$tags[1]}[3]=1
};
print "Station set to $tags[1]\n ";
b_drawStation($tags[1])
});
}
# elsif ( $type eq 'PICK' ) {
#$menuRightClick->add('command', -label => 'Edit phase',
#-command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "editPhase"]
##-command => [\&mc_editPhase, \@tags]
#);
#}
$menuRightClick->Popup(qw/-popover cursor -popanchor sw/);
}
sub tc_editPhase {
=PROGhead2 tc_editPhase()
Draws the window with options for editing phase.
Choosing picks to change is done by tc_choosePicks.
"Select picks" set the flag for tc_choosePicks, so it knows
that PICK-items are to be selected.
=cut
=USERhead3 Editing phases
Editing phases only works if using ZP, 'zpdir' and 'zp2ray' are configured
in p.config.
Right click on a pick in traveltime plot and follow instructions.
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $tags = shift;
print "tags @$tags\n";
(my $st = $tags->[1]) =~ s/RAYS//;
(my $ph = $tags->[2]) =~ s/Ph//;
my ($km, $t, $unc) = split (/ /, $tags->[3]);
$km =~ s/km//;
$t =~ s/t//;
$unc =~ s/unc//;
#$ph =~ s/\.//; # Phases in Pickfile are without decimal ### TODO CHANGE THIS TO USE RIN MATCHES
my $editedStation = $st;
print "Raise, Sir\n";
# Raise current station and phase to ease picking
$lzd->raise($tags->[1]); # raise current station
$lzd->raise($tags->[2]); # raise current phase
@choosePicks = ($ph); # Flag to enable pick selection
my $phNew ;
my $mode = "change"; # Choose operating mode. Either "change" or "copy" picks to new phase
my $selection = "select"; # Choose selection of change. Either "all" picks of this phase will be changed
# of only "select"ed picks
my $start = 1; # Mark first pick to change
my $end = -1; # Mark last pick to change. -1 mean all
# Create the dialog
my $dia = $mw->Toplevel( #-popover => $mw,
-title => "$PROG: Edit picked phase",);
my $bframe = $dia->Frame (-border => 4, -background => "") -> pack(-side=>'bottom', -anchor => 'w', -fill => 'x', -expand => 'yes');
my $entryframe = $dia->Frame (-border => 4, -background => "") -> pack(-side=>'left', -anchor => 'n', -fill => 'x', -expand => 'yes');
my $modeframe = $dia->Frame (-border => 4, -background => "") -> pack(-side=>'right', -anchor => 'n', -fill => 'x', -expand => 'yes');
#$bframe->ROText(-height => 2, -relief => 'solid')-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no' )
#->insert ('end', "Change Phase");
##############
# User entries
# Stationnumber
my $stationEntry = $entryframe -> LabEntry ( -label => 'Station ',-width => '6',
-labelPack => [qw/-side left -anchor w -expand yes /],
-textvariable => \$editedStation, -state => 'disabled'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
# Phasenumber
my $phaseEntry = $entryframe -> LabEntry ( -label => 'Current phase ',-width => '6',
-labelPack => [qw/-side left -anchor w -expand yes /],
-textvariable => \$ph, -state => 'disabled'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
# new phasenumber
$entryframe -> LabEntry ( -label => 'New phase ',-width => '6',
-labelPack => [qw/-side left -anchor w -expand yes /],
-textvariable => \$phNew,
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
###############
# Chose action:
# copy, change or delete
# copy
$balloon->attach( $modeframe->Radiobutton(
-text => "copy to", -value => "copy", -variable => \$mode,
)-> pack (-side=>'top', -anchor => 'w', -fill => 'none', -expand => 'no')
, -balloonmsg => "Copy picks of phase $ph to your new phase");
# change
$balloon->attach( $modeframe->Radiobutton(
-text => "change to", -value => "change", -variable => \$mode,
)-> pack (-side=>'top', -anchor => 'w', -fill => 'none', -expand => 'no')
, -balloonmsg => "Change phasename $ph to your new phase");
# delete
$balloon->attach( $modeframe->Radiobutton(
-text => "delete", -value => "delete", -variable => \$mode,
)-> pack (-side=>'top', -anchor => 'w', -fill => 'none', -expand => 'no')
, -balloonmsg => "Delete picks");
##############
# Selector
# all picks
$balloon->attach( $bframe->Radiobutton(
-text => "All picks", -value => "all", -variable => \$selection,
-command => sub {
# Enable Station and Current Phase
$phaseEntry->configure( -state => 'normal' );
$stationEntry ->configure( -state => 'normal');
@choosePicks = (); # Disables pick selection
}, -state => "normal")-> pack (-side=>'top', -anchor => 'w', -expand => 'yes')
, -balloonmsg => "Change name for all picks of phase $ph");
# selected picks
$balloon->attach( $bframe->Radiobutton(
-text => "Select picks", -value => "select", -variable => \$selection,
-command => sub {
$phaseEntry->configure( -state => 'disabled' );
$stationEntry ->configure( -state => 'disabled' );
$lzd->raise($tags->[1]); # raise current station
$lzd->raise($tags->[2]); # raise current phase
@choosePicks = ($ph); # Resets array to a clean start
print "Select picks to change @choosePicks\n";
_printStatusMessage("\nSelect picks to change");
}
)-> pack (-side=>'top', -anchor => 'w', -expand => 'yes')
, -balloonmsg => "Select Range of picks to change name");
##############
# Help text
my $text = $bframe -> ROText(-width => '30', -height => 6, -borderwidth => 0, -wrap => 'word')
-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$text->insert('end', "Select picks to change and enter new phasenumber. Station is only used when working on 'all' picks".
" for a phase. Current phase is only used for all picks.");
$text->configure(-state => 'disabled');
##############
# Buttons
$bframe->Button(-text=>"Save Changes",
-command => sub {
# Check if new phase has been given:
unless ($phNew || $mode eq "delete") {
_printStatusMessage("\nEnter new phase");
return;
}
if ( $selection eq "select"){
# First entry is phase, second start pick, third end pick
# Check if two picks are choosen
if (@choosePicks != 3 ) {
_printStatusMessage("\nChoose two picks for range. Currently selected: Ph@choosePicks. Now resetted.");
@choosePicks = ($ph);
return;
}
_printStatusMessage("Save $ph as $phNew from @{$choosePicks[1]} to @{$choosePicks[2]}\n");
# Check if phase is the same for both picks
# Otherwise clear array and select two new picks
if ($choosePicks[1][1] ne $choosePicks[2][1] # stationnumber
|| $choosePicks[1][2] ne $choosePicks[2][2] ){ # phasenumber
_printStatusMessage("Stations and/or phases don't fit! Try again!!");
@choosePicks = ($ph);
return;
}
($editedStation = $choosePicks[1][1]) =~ s/RAYS//;
($ph = $choosePicks[1][2]) =~ s/Ph//;
$choosePicks[0] = $ph;
# Above is for "selected" picks
} else { # For changing 'all' picks you need to give the station name
@choosePicks = ($ph, $editedStation);
}
#(my $st = $tags->[1]) =~ s/RAYS//;
print "choosePicks: \n";
print Dumper(\@choosePicks);
print "Everything seems fine with the picks (@choosePicks, $mode). Do the editing ..\n";
print "Change ph $ph to $phNew for station $editedStation\n";
#print Dumper(\@choosePicks);
#die;
# How does the model now, which Station is edited?
# @choosePicks = ( $ph, @tagsPick1, @tagsPick2 ) # for selected picks
# @choosePicks = ( $ph, $station) # for all picks
$model->edit("tags" => \@choosePicks, "op" => "editPhase",
"value" => [$ph, $phNew], "mode" => $mode);
@choosePicks = ($ph); # Reset chooseen picks
_printStatusMessage("\nNew picks have been written");
# Select station and run zp2ray
$station = $editedStation;
b_zp2ray();
}
, -width => 10)->pack(qw/-side left/);
$bframe->Button(-text=>"Close", -command => sub { $dia->destroy; @choosePicks = ()}, -width => 10)->pack(qw/-side left /);
}
sub tc_choosePicks {
=PROGhead2 tc_choosePicks()
Stores tags of the clicked pick in the global array @choosePicks, if the array is not
empty. The array also operates as flag. Nothing is added if the array is empty.
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Only continue when flag for choosing picks is activated
return if (@choosePicks == 0);
print "Choosing picks enabled\n";
my $id = $lzd->find(qw/withtag current/);
my @tags = $lzd->gettags($id);
print "Include >@tags<, id @$id in selectiong\n";
push @choosePicks, \@tags;
print @choosePicks." are in array \n";
}
sub t_rms {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Initial drawing of hyperbola
# station positon is needed
# get it from pick tags
# t_rms is activated via right click menu of drawn picks
my $tags = shift; # Pick tag
my $x = shift;
my $y = shift;
#-tags => ["PICK", 'RAYS'.$station->{name}, "Ph$phase","km$km t$t unc$unc offset$off"]
(my $st = $tags->[1]) =~ s/RAYS//;
my $pos = $model->getStation($st)->{position};
print "Draw rms velocity for station $st at $pos, mouse $x, $y\n";
t_hyperbola('RMS',"$pos", "$x", "$y");
$lzd->delete('ZOOM')
}
sub t_hyperbola {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# needed arguments:
# - station position
# - mouse position
#
#######
# - (Calculate t0 depending on mouse y-position)
# - Calculate vrms depending on mouse x-positon
# - Draw hyperbola
# TODO: make text position of rms more intelligent
my ($tag, $pos, $x, $y);
if (@_ == 4 ) { # if arguments
($tag, $pos, $x, $y) = @_;
#print "Get position from arguments\n";
} else {
#print "No arguments given, look for existing RMS\n";
## if no arguments and there's already a hyperbola
if ($lzd->coords('RMS')) {
my @tags = $lzd->gettags(($lzd->find(qw/withtag RMS/))[0]);
$x = $lzd->canvasx($Tk::event->x);
$y = $lzd->canvasy($Tk::event->y);
($tag, $pos) = @tags;
#print "Found coordinates from current hyperbola\n";
}
}
my ($s, $t) = $model->screen2model([$x, $y], "time", $pos); # $s and $t are unreduced times!!
my $offset = abs ($s - $pos); # distance from station to pointer
# y-position of mouse pointer is t0
my ($x0, $t0) = $model->screen2model([$x, $y], "time"); # $s and $t are reduced times!!
# Calculate rms velocity depending on offset of mouse pointer
my $m = 6.5/150; # m = v/x, velocity v at offset x determines slope
my $v = abs ($m * $offset);
my $maxX = 250; # Line extends up to $maxX km offset from station
my $x2;
#########################################################################
# y-position of mouse pointer can be used as part of hyperbola. Calculate
# corresponding t0. BUT: pointer might cover the picks when lying
# on top.
if (abs ($offset) > 120 ) {
#print "Use mouse pointer as anchor\n";
$x0 = 0;
$x2 = $offset;
my $t2 = $t;
# Test two different ways of calculating t0. Should be the same.
my $t0test = sqrt(abs ( $t2**2 + ($x0**2 - $x2**2)/$v**2));
$t0 = sqrt ( abs ( $v**2 * $t2**2 - $x2**2 + $x0)
/ $v**2 );
#print "t0 = $t0, v = $v, unreduced pick coord are x=$x2 km, t=$t s\n";
## Check if formula is correct and input t2 can be recovered
my $t2test = sqrt(abs($t0**2 - (-$x2**2 + $x0**2)/$v**2));
#print "Put in t = $t, got out t2test = $t2test\n".
#"t0 = $t0 (commons), my t0 = $t0test\n";
}
#########################################################################
# Calculate points of hyperbola
$x0 = 0;
$x2 = 0; # Calculate t2(x2) for x2 = 0 .. $maxX
my $dx = 1; # distance between two points of hyperbola line
my @coords = ();
# Play with a simple testing model and pure formula t = sqrt(x^2+4z^2)/v
my @testcoords = ();
while ( $x2 < $maxX ) {
# Calculate hyperbola in model domain (unreduced times)
my $t2 = sqrt(abs($t0**2 - (-$x2**2 + $x0**2)/$v**2));
#print "x = $x2, t = $t2 ( x0 = $x0, t0 = $t0)\n";
# Convert model coordinates in screen coordinates
# model2screen also reduces traveltimes
# left branch
unshift @coords, $model->model2screen([$pos-$x2, $t2], "time", $pos);
# right branch
push @coords, $model->model2screen([$x2+$pos, $t2], "time", $pos);
## TESTING SIMPLE LAYERED MODEL
#my $tt = sqrt($x2**2 + 4 * 28**2)/$v;
##print "Add test model time $tt\n";
#unshift @testcoords, $model->model2screen([$pos-$x2, $tt], "time", $pos);
#push @testcoords, $model->model2screen([$x2+$pos, $tt], "time", $pos);
$x2 += $dx;
}
# Delete old hyperbola and draw new one
$lzd->delete('RMS');
$lzd->createLine(@coords,
-fill => 'blue',
-tags => ['RMS',"$pos"],
);
#$lzd->createLine(@testcoords,
#-fill => 'green',
#-tags => ['RMS',"$pos"],
#);
my $xpos = ($lzd->xview)[0] * $box->[2]+200;
my $ypos = ($lzd->yview)[0] * $box->[3]+20;
#print "Annote text to $xpos, $ypos";
#print Dumper $box;
# Annonte rms velocity
$lzd -> createText(
$xpos, $ypos, # Text position
-text => sprintf("t0 = %.2f s, v_rms = %.2f km/s", $t0, $v),
-tags => ["RMS","$pos"],
-fill=>"black", justify => "left");
}
sub m_selectNodes {
=PROGhead2 m_selectNodes()
Function enables selecting nodes for toggling of partial derivatives or snapping to upper/lower layer.
Main point is to set toggle flag and raise nodes for this layer. Flag C<$editNode> saves
information about the type of edit
Called by C<m_B3menu>
Further coding is done in m_B1node, when the second node has been selected
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $tags = shift;
my $coords = shift;
$editNode = shift; # Global variable for type of edit (toggle or snap)
#my $l = $tags->[1];
(my $l = $tags->[1]) =~ s/BOUND //;
print "Enabling choosing for layer>$l<, raising <N $l> [ @$tags ]\n";
$selectedNodes = 1;
# raising nodes to ensure clicking on the right ones if boundarys are pinched out
$cns->raise("N $l") if ($showNodes == 1);
$cns->raise("BOUND $l");
$cns->raise("V $l") if ($showVNodes == 1);
_printStatusMessage("\nSelect start and end node");
}
sub m_editModel{
}
sub i_createModel {
# Create simple model files
my $rintext =
"
&pltpar isep=0, itx=3, idata=1,
imod=1, iray=2, ibnd=0, isum=2,
xwndow=292., ywndow=175.,
ircol=1, itcol=1,
&end
&axepar xmax=300., xmm=265.,
zmax=40., zmm=60.,
tmax=10., tmm=60.,
albht=3.5, orig=15., sep=10.,
&end
&trapar imodf=1, ibsmth=1, i2pt=0,
ishot=1,-1, xshot=0.,300.,
ray=1.1,2.1,2.2,3.2,4.3,
nsmax=15,
nray=20,25,25,50,1,
space=1.,1.5,2.,2.5,1.,
aamin=0.25, aamax=75.,
&end
&invpar invr=1,
ivray=1,1,2,3,4,
&end
";
my $file = "r.in";
open(FILE, ">$file") or die "Can't open $file";
printf FILE $rintext;
close(FILE);
my $vintext =
" 1 0.00 25.00 50.00 75.00 100.00 125.0 150.00 175.00 200.00 225.00
1 0.40 0.20 -0.50 -1.50 0.20 0.60 1.50 0.30 1.00 0.70
0 0 0 0 0 0 0 0 0 0
1 250.00 275.00 300.00
0 0.00 0.50 0.50
0 0 0
1 0.00 150.00 300.00
0 4.90 4.90 4.90
1 1 1
1 0.00 150.00 300.00
0 5.40 5.40 5.40
1 1 1
2 300.00
0 10.00
0
2 300.00
0 0.00
0
2 0.00 150.00 300.00
0 5.70 5.70 5.70
1 1 1
3 0.00 100.00 200.00 300.00
0 25.00 25.00 25.00 25.00
1 1 1 1
3 300.00
0 6.40
1
3 300.00
0 6.73
-1
4 0.00 150.00 300.00
0 34.00 34.00 34.00
1 1 1
4 300.00
0 7.50
0
4 300.00
0 0.00
0
5 0.00 150.00 300.00
0 36.00 36.00 36.00
-1 -1 -1
5 300.00
0 7.70
1
5 300.00
0 0.00
0
6 300.00
0 40.00
";
$file = "v.in";
open(FILE, ">$file") or die "Can't open $file";
printf FILE $vintext;
close(FILE);
my $txtext =
" 0.000 1.000 0.000 0
5.000 0.874 0.050 1
10.000 1.771 0.050 1
15.000 2.684 0.050 1
20.000 3.472 0.050 1
25.000 4.440 0.050 1
30.000 5.375 0.050 1
35.000 6.214 0.050 1
40.000 7.193 0.050 1
45.000 7.998 0.050 1
50.000 8.961 0.050 1
55.000 9.686 0.050 1
60.000 10.700 0.050 1
65.000 11.520 0.050 1
70.000 12.496 0.050 1
75.000 13.465 0.050 1
80.000 14.177 0.050 1
85.000 15.118 0.050 1
90.000 16.022 0.050 1
95.000 16.876 0.050 1
100.000 17.729 0.050 1
105.000 18.503 0.050 1
110.000 19.377 0.050 1
115.000 20.374 0.050 1
120.000 21.206 0.050 1
125.000 22.146 0.050 1
130.000 22.958 0.050 1
135.000 23.870 0.050 1
140.000 24.675 0.050 1
145.000 25.623 0.050 1
150.000 26.519 0.050 1
155.000 27.324 0.050 1
15.000 7.413 0.050 2
20.000 7.705 0.050 2
25.000 8.185 0.050 2
30.000 8.571 0.050 2
35.000 9.032 0.050 2
40.000 9.653 0.050 2
45.000 10.169 0.050 2
50.000 10.867 0.050 2
55.000 11.424 0.050 2
60.000 12.182 0.050 2
65.000 13.038 0.050 2
70.000 13.742 0.050 2
75.000 14.405 0.050 2
80.000 15.214 0.050 2
85.000 15.819 0.050 2
90.000 16.603 0.050 2
95.000 17.368 0.050 2
100.000 18.142 0.050 2
105.000 18.965 0.050 2
110.000 19.702 0.050 2
115.000 20.617 0.050 2
120.000 21.454 0.050 2
125.000 22.316 0.050 2
130.000 23.143 0.050 2
135.000 23.932 0.050 2
140.000 24.822 0.050 2
145.000 25.619 0.050 2
150.000 26.563 0.050 2
155.000 27.359 0.050 2
20.000 9.554 0.050 3
25.000 9.884 0.050 3
30.000 10.223 0.050 3
35.000 10.741 0.050 3
40.000 11.246 0.050 3
45.000 11.728 0.050 3
50.000 12.263 0.050 3
55.000 12.877 0.050 3
60.000 13.518 0.050 3
65.000 14.215 0.050 3
70.000 14.865 0.050 3
75.000 15.417 0.050 3
80.000 16.063 0.050 3
85.000 16.698 0.050 3
90.000 17.385 0.050 3
95.000 17.983 0.050 3
100.000 18.627 0.050 3
105.000 19.292 0.050 3
110.000 20.070 0.050 3
115.000 20.757 0.050 3
120.000 21.441 0.050 3
125.000 22.166 0.050 3
130.000 22.778 0.050 3
135.000 23.581 0.050 3
140.000 24.148 0.050 3
145.000 24.871 0.050 3
150.000 25.705 0.050 3
155.000 26.433 0.050 3
160.000 27.071 0.050 3
165.000 27.955 0.050 3
170.000 28.593 0.050 3
175.000 29.288 0.050 3
180.000 30.015 0.050 3
185.000 30.708 0.050 3
190.000 31.394 0.050 3
195.000 32.076 0.050 3
200.000 32.849 0.050 3
205.000 33.511 0.050 3
90.000 17.485 0.050 4
95.000 18.074 0.050 4
100.000 18.633 0.050 4
105.000 19.286 0.050 4
110.000 20.010 0.050 4
115.000 20.601 0.050 4
120.000 21.148 0.050 4
125.000 21.807 0.050 4
130.000 22.399 0.050 4
135.000 23.057 0.050 4
140.000 23.768 0.050 4
145.000 24.320 0.050 4
150.000 24.965 0.050 4
155.000 25.703 0.050 4
160.000 26.388 0.050 4
165.000 27.068 0.050 4
170.000 27.623 0.050 4
175.000 28.319 0.050 4
180.000 28.861 0.050 4
185.000 29.577 0.050 4
190.000 30.133 0.050 4
195.000 30.799 0.050 4
200.000 31.302 0.050 4
205.000 31.873 0.050 4
210.000 32.588 0.050 4
215.000 33.221 0.050 4
220.000 33.816 0.050 4
225.000 34.497 0.050 4
230.000 35.056 0.050 4
235.000 35.690 0.050 4
240.000 36.300 0.050 4
245.000 37.027 0.050 4
250.000 37.587 0.050 4
255.000 38.203 0.050 4
260.000 38.708 0.050 4
265.000 39.381 0.050 4
270.000 40.062 0.050 4
275.000 40.663 0.050 4
280.000 41.242 0.050 4
285.000 41.814 0.050 4
290.000 42.429 0.050 4
300.000 -1.000 0.000 0
145.000 27.376 0.050 1
150.000 26.503 0.050 1
155.000 25.613 0.050 1
160.000 24.755 0.050 1
165.000 23.842 0.050 1
170.000 22.992 0.050 1
175.000 22.079 0.050 1
180.000 21.295 0.050 1
185.000 20.300 0.050 1
190.000 19.427 0.050 1
195.000 18.528 0.050 1
200.000 17.674 0.050 1
205.000 16.799 0.050 1
210.000 15.870 0.050 1
215.000 15.089 0.050 1
220.000 14.149 0.050 1
225.000 13.402 0.050 1
230.000 12.498 0.050 1
235.000 11.481 0.050 1
240.000 10.638 0.050 1
245.000 9.746 0.050 1
250.000 8.868 0.050 1
255.000 7.983 0.050 1
260.000 7.140 0.050 1
265.000 6.225 0.050 1
270.000 5.279 0.050 1
275.000 4.392 0.050 1
280.000 3.501 0.050 1
285.000 2.726 0.050 1
290.000 1.734 0.050 1
295.000 0.872 0.050 1
145.000 27.463 0.050 2
150.000 26.478 0.050 2
155.000 25.509 0.050 2
160.000 24.736 0.050 2
165.000 23.913 0.050 2
170.000 23.038 0.050 2
175.000 22.287 0.050 2
180.000 21.435 0.050 2
185.000 20.518 0.050 2
190.000 19.705 0.050 2
195.000 18.957 0.050 2
200.000 18.048 0.050 2
205.000 17.370 0.050 2
210.000 16.570 0.050 2
215.000 15.654 0.050 2
220.000 14.864 0.050 2
225.000 14.255 0.050 2
230.000 13.408 0.050 2
235.000 12.893 0.050 2
240.000 12.136 0.050 2
245.000 11.461 0.050 2
250.000 10.745 0.050 2
255.000 10.142 0.050 2
260.000 9.510 0.050 2
265.000 9.041 0.050 2
270.000 8.470 0.050 2
275.000 8.045 0.050 2
280.000 7.609 0.050 2
285.000 7.353 0.050 2
75.000 36.633 0.050 3
80.000 35.894 0.050 3
85.000 35.160 0.050 3
90.000 34.500 0.050 3
95.000 33.722 0.050 3
100.000 32.975 0.050 3
105.000 32.295 0.050 3
110.000 31.580 0.050 3
115.000 30.794 0.050 3
120.000 30.145 0.050 3
125.000 29.491 0.050 3
130.000 28.759 0.050 3
135.000 27.981 0.050 3
140.000 27.369 0.050 3
145.000 26.626 0.050 3
150.000 25.842 0.050 3
155.000 25.154 0.050 3
160.000 24.379 0.050 3
165.000 23.749 0.050 3
170.000 23.094 0.050 3
175.000 22.437 0.050 3
180.000 21.715 0.050 3
185.000 20.947 0.050 3
190.000 20.391 0.050 3
195.000 19.573 0.050 3
200.000 19.013 0.050 3
205.000 18.353 0.050 3
210.000 17.639 0.050 3
215.000 17.015 0.050 3
220.000 16.367 0.050 3
225.000 15.863 0.050 3
230.000 15.171 0.050 3
235.000 14.654 0.050 3
240.000 14.067 0.050 3
245.000 13.585 0.050 3
250.000 13.134 0.050 3
255.000 12.633 0.050 3
260.000 12.247 0.050 3
265.000 11.669 0.050 3
270.000 11.296 0.050 3
275.000 11.094 0.050 3
10.000 42.554 0.050 4
15.000 41.819 0.050 4
20.000 41.261 0.050 4
25.000 40.716 0.050 4
30.000 39.985 0.050 4
35.000 39.534 0.050 4
40.000 38.958 0.050 4
45.000 38.404 0.050 4
50.000 37.825 0.050 4
55.000 37.269 0.050 4
60.000 36.666 0.050 4
65.000 36.026 0.050 4
70.000 35.442 0.050 4
75.000 34.829 0.050 4
80.000 34.246 0.050 4
85.000 33.620 0.050 4
90.000 32.822 0.050 4
95.000 32.332 0.050 4
100.000 31.628 0.050 4
105.000 31.030 0.050 4
110.000 30.451 0.050 4
115.000 29.890 0.050 4
120.000 29.215 0.050 4
125.000 28.620 0.050 4
130.000 27.944 0.050 4
135.000 27.275 0.050 4
140.000 26.776 0.050 4
145.000 26.114 0.050 4
150.000 25.416 0.050 4
155.000 24.812 0.050 4
160.000 24.213 0.050 4
165.000 23.564 0.050 4
170.000 22.912 0.050 4
175.000 22.353 0.050 4
180.000 21.702 0.050 4
185.000 21.130 0.050 4
190.000 20.401 0.050 4
195.000 19.745 0.050 4
200.000 19.034 0.050 4
0.000 0.000 0.000 -1
";
$file = "tx.in";
open(FILE, ">$file") or die "Can't open $file";
printf FILE $txtext;
close(FILE);
}
# Called when menu items are selected.
sub m_addNode {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $tags = shift;
my $coords = shift;
print "Add Node to @$tags at km @$coords\n";
#$model->addNode($tags, $coords);
$model->edit("tags" => $tags, "value" => $coords, "op" => "add" , "type" => "d");
}
sub m_deleteNode {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $tags = shift;
print "Delete Node @$tags\n";
#$model->deleteNode($tags);
$model->edit("tags" => $tags, "op" => "del");
}
sub m_addVNode {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
#print "Adding velocity node\n";
my $tags = shift;
my $coords = shift;
print "Add Velocity Node to @$tags at km @$coords\n";
#$model->addNode($tags, $coords);
my $dia = $mw->Toplevel(-title => "$PROG: Add velocity node",
#-text => "Current values are @$tags",
#-buttons => ['Done', 'Cancel']
);
my ($v, $km) = (0, sprintf ('%d',@$coords[0]));
my ($vu, $vl, $vupar, $vlpar);
my $text = $dia -> ROText(-width => '30', -height => 4, -borderwidth => 0)
-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$text->insert('end', "Add a velocity node to @$tags");
my $fr = $dia->Frame()-> pack (-side => 'left', -expand => 'yes', -fill => 'both');
$fr -> LabEntry (
-label => 'Upper Velocity',
-labelPack => [qw/-side left -anchor w -expand yes -fill both/],
-textvariable => \$vu,
-width => '6'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$fr -> LabEntry (
-label => 'Partial derivative for upper Velocity',
-labelPack => [qw/-side left -anchor w -expand yes -fill both/],
-textvariable => \$vupar,
-width => '6'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$fr -> LabEntry (
-label => 'Lower Velocity',
-labelPack => [qw/-side left -anchor w -expand yes -fill both/],
-textvariable => \$vl,
-width => '6'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$fr -> LabEntry (
-label => 'Partial derivative for lower Velocity',
-labelPack => [qw/-side left -anchor w -expand yes -fill both/],
-textvariable => \$vlpar,
-width => '6'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$fr -> LabEntry (
-label => 'Position',
-labelPack => [qw/-side left -anchor w -expand yes -fill both/],
-textvariable => \$km,
-width => '6'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
#my $f = $dia -> Frame() -> pack (-side=>'right', -anchor => 'w', -fill => 'x', -expand => 'yes');
#my $bound = "vu";
#$f -> Radiobutton (-text => "Upper Boundary", -value =>"vu", -variable => \$bound)-> pack (-side=>'top', -anchor => 'w');
#$f -> Radiobutton (-text => "Lower Boundary", -value =>"vl", -variable => \$bound)-> pack (-side=>'top', -anchor => 'w');
#$dia -> Entry (-textvariable => "velocity", -width => '4') -> pack (-side=>'top');
#$dia -> Entry (-textvariable => "km", -width => '4') -> pack (-side=>'top');
#my $ans = $dia->Show;
#print "Dialog endet with $ans, $vu $vl, $km\n";
#if ($ans eq "Done") {
#$model->edit("tags" => $tags, "value" => [$km, $vu, $vl, $vupar, $vlpar], "op" => "addv", "type" => "v");
#}
my $bframe = $fr->Frame () -> pack(-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no');
$bframe->Button(-text=>"Save Changes",
-command => sub{
$model->edit("tags" => $tags, "value" => [$km, $vu, $vl, $vupar, $vlpar], "op" => "addv", "type" => "v");
}, -width => 10)->pack(qw/-side left/);
$bframe->Button(-text=>"Close", -command => [$dia => 'destroy'], -width => 10)->pack(qw/-side left /);
}
sub m_deleteVNode {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
print "Deleting velocity node\n";
my $tags = shift;
$model->edit("tags" => $tags, "op" => "del");
}
# EDIT ONLY ONE NODE
sub m_editVNode {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $id = $cns->find(qw/withtag current/);
my @tags = $cns->gettags($id);
#print "I'm >$tags[1]<, id @$id\n";
my $dia = $mw->Toplevel( -popover => $mw,
-title => "$PROG: Change velocity node",
#-text => "Current values are @tags",
#-buttons => ['Done', 'Cancel']
);
my ($km, $vu, $vl, $vupar, $vlpar) = $model->get("vnode", \@tags);
#my ($v, $km, $vu, $vl) = (1,2,3,4);
$dia -> LabEntry (
-label => 'Upper Velocity',
-labelPack => [qw/-side left -anchor w -expand yes -fill both/],
-textvariable => \$vu,
-width => '6'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$dia -> LabEntry (
-label => 'Partial derivative for upper Velocity',
-labelPack => [qw/-side left -anchor w -expand yes -fill both/],
-textvariable => \$vupar,
-width => '6'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$dia -> LabEntry (
-label => 'Lower Velocity',
-labelPack => [qw/-side left -anchor w -expand yes -fill both/],
-textvariable => \$vl,
-width => '6'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$dia -> LabEntry (
-label => 'Partial derivative for lower Velocity',
-labelPack => [qw/-side left -anchor w -expand yes -fill both/],
-textvariable => \$vlpar,
-width => '6'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$dia -> LabEntry (
-label => 'Position',
-labelPack => [qw/-side left -anchor w/],
-textvariable => \$km,
-width => '6'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
#my $ans = $dia->Show;
#print "Dialog endet with $ans, km $km, vu $vu, vl $vl, vupar $vupar, vlpar $vlpar\n";
#if ($ans eq "Done") {
#$model->edit("op" => "edit", "tags" => \@tags, "value" => [$km, $vu, $vl, $vupar, $vlpar]);
#}
$dia->Button(-text=>"Save Changes",
-command => sub{
$model->edit("op" => "edit", "tags" => \@tags, "value" => [$km, $vu, $vl, $vupar, $vlpar]);
$dia->destroy;
}, -width => 10)->pack(qw/-side left/);
$dia->Button(-text=>"Close", -command => [$dia => 'destroy'], -width => 10)->pack(qw/-side left /);
}
# EDIT MULTIPLE NODES
sub m_editVNodes {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $id; my @tags;
$id = $cns->find(qw/withtag current/);
@tags = $cns->gettags($id);
#print "I'm >$tags[1]<, >$tags[2]<,id @$id\n";
my $dia = $mw->Toplevel( -popover => $mw,
-title => "$PROG: Change velocity node",);
# Get references to arrays with references to each layers information
my ($km, $vu, $vl, $vupar, $vlpar) = $model->get("vnodes");
# MAKE BUTTONS
my $bframe = $dia->Frame () -> pack(-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no');
my $sc;
$bframe->Button(-text=>"Save Changes",
-command => sub{
_printStatusMessage(" Write changes to model. You have to write them to v.in");
$model->edit("op" => "edit", "tags" => ["allV"], "value" => [$km, $vu, $vl, $vupar, $vlpar])}
, -width => 10)->pack(qw/-side left/);
#$bframe->Button(-text=>"Update", -command => sub {
#($km, $vu, $vl, $vupar, $vlpar) = $model->get("vnodes");
#m_editVNodesDisplay($sc, $km, $vu, $vl, $vupar, $vlpar);
##\&m_editVNodesDisplay, \$sc
#}, -width => 10)->pack(qw/-side left /);
$bframe->Button(-text=>"Close", -command => [$dia => 'destroy'], -width => 10)->pack(qw/-side left /);
$sc = $dia -> Scrolled ('Pane', -scrollbars => 'se', -borderwidth => 1,
-relief => 'solid', #-background => "green",
-width => 600, -height => 400
) -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
#$sc->Frame;
m_editVNodesDisplay($sc, $km, $vu, $vl, $vupar, $vlpar, @tags);
sub m_editVNodesDisplay {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my ($sc, $km, $vu, $vl, $vupar, $vlpar, @tags) = @_;
# Loop through layers
for (my $i = 0; $i <= $#{$km}; $i++){
my $f = $sc -> Frame (-borderwidth => 1, -relief => 'solid', #-background => "green",
#-foreground => "blue", -label =>"Layer B ".($i+1)
) -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
#################################
my $c = 'grey';
$c = $REFRACTED[$i] if ($REFRACTED[$i]);
$f -> Label(-text => "Layer B ".($i+1), -background => $c
) -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
# Loop through nodes for each layer
for (my $j = 0; $j <= $#{$km->[$i]}; $j++){
#print "$i,$j: $km->[$i]->[$j]\n";
my $options = "lightgrey";
if ( @tags && $i == $tags[1]-1 && $j == $tags[2]){
$options = 'yellow';
}
my $fr = $f -> Frame (-borderwidth => 1, -relief => 'solid')
-> pack (-side => 'left', -fill => 'both', -expand => 'yes');
$fr -> Entry ( -width => 6, -background => $options,
-textvariable => \$km->[$i]->[$j])-> pack (-side=>'top', -anchor => 'w', -fill => 'x');
$fr -> Entry ( -width => 4, -background => $options,
-textvariable => \$vu->[$i]->[$j])-> pack (-side=>'top', -anchor => 'w', -fill => 'x');
$fr -> Entry ( -width => 4, -background => $options,
-textvariable => \$vupar->[$i]->[$j])-> pack (-side=>'top', -anchor => 'w', -fill => 'x');
$fr -> Entry ( -width => 4, -background => $options,
-textvariable => \$vl->[$i]->[$j])-> pack (-side=>'top', -anchor => 'w', -fill => 'x');
$fr -> Entry ( -width => 4, -background => $options,
-textvariable => \$vlpar->[$i]->[$j])-> pack (-side=>'top', -anchor => 'w', -fill => 'x');
#print "Added frame $fr\n";
} # Loop through nodes
} # Loop through layers
#$sc->see($fr);
#return $fr;
} # sub m_editVNodesDisplay
#print "Done\n";
#$sc->see($fr);
#print "Done, see $fr\n";
}
sub i_BindTime {
=PROGhead2 i_BindTime()
Subroutine that organizes all mouse and keyboard interactions with the
traveltime diagram: zooming and selecting of picks.
=cut
=USERhead3 Mouse operations in traveltime diagram
=USERhead4 Measure rms-values of reflection hyperbola
- Right click on a pick and choose 'Measure rms velocity'
- First hyperbola is drawn
- Click and hold the hyperbola. Mouse movement in x-direction changes
the rms velocity, y-movements change the time. Y-mouse position is used
as t0. Only for large velocities y-position is used as anchor for hyperbola
- Right click on the hyperbola to delete it.
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Make Time zoomaable
$lzd->CanvasBind('<3>' => [\&zoomCanvasInit,"t"]);
$lzd->CanvasBind('<B3-Motion>' => [\&zoomCanvasSize,"t"]);
$lzd->CanvasBind('<B3-ButtonRelease>' => \&zoomCanvasFinish);
$lzd->CanvasBind('<2>' => \&zoomOriginal);
# Editing of picks
$lzd->bind( 'PICK' => '<3>' => [\&t_Menu]);
$lzd->bind( 'PICK' => '<B3-ButtonRelease>' => sub {$lzd->delete('ZOOM')} );
$lzd->bind( 'PICK' => '<1>' => [\&tc_choosePicks]);
# Measuring velocity, print current position
$lzd->CanvasBind('<1>' => \&t_B1click);
$lzd->CanvasBind('<B1-Motion>' => \&t_B1motion);
$lzd->CanvasBind('<B1-ButtonRelease>' => \&t_B1release );
$lzd->bind('RMS' => '<B1-Motion>' => \&t_B1clickRMS);
$lzd->bind('RMS' => '<3>' => sub {$lzd->delete('RMS');});
}
sub t_B1click {
=PROGhead2 t_B1click()
Get's current coordinates, transforms them into model coordinates and displays
them in status bar
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Display current coords
my $oldx = $lzd->canvasx($Tk::event->x);
my $oldy = $lzd->canvasy($Tk::event->y);
print "(DEV) mouse screen coordinates: >$oldx,$oldy<\n" if $dev;
my ($olds, $oldt) = $model->screen2model([$oldx, $oldy], "time");
my $msg = sprintf ("\nx = %6.2fkm, t = %4.2fs",
$olds, $oldt);
_printStatusMessage($msg);
$lzd->Tk::focus;
}
sub t_B1clickRMS {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Enable global flag RMS for moving RMS-hyperbola when clicking on
# the hyperbola
$RMS = 1;
#print "Enable moving of rms hyperbola\n";
}
sub t_B1motion {
=PROGhead2 t_B1motion()
Draws a line for measuring velocity or move rms hyperbola
=cut
my $x = $lzd->canvasx($Tk::event->x);
my $y = $lzd->canvasy($Tk::event->y);
if ($RMS) {
t_hyperbola();
}
else { # Only measure velocity if no rms velocity is ongoing
# Is there already a line drawn?
if ($lzd->coords('APPARENTVELOCITY')) {
# There's already a line. Get coordinates of the line
# and update the second point to current coordinates
my @coords = $lzd->coords('APPARENTVELOCITY');
$coords[2] = $x;
$coords[3] = $y;
$lzd->coords('APPARENTVELOCITY', @coords);
} else {
# There's no line. Draw one with current coordinates
my @line = ($x, $y, $x, $y);
$lzd->createLine(@line,
-fill => 'red',
-arrow => 'last',
-tags => ['APPARENTVELOCITY'],
);
}
} # no 'RMS' found
}
sub t_B1release {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Finish. Clean up
my $id = $lzd->find(qw/withtag current/);
my @tags = $lzd->gettags($id);
#print "(DEV) tags >@tags<, id >@$id<\n" if $dev;
my $msg = " @tags";
$lzd->delete('ZOOM');
if ( $lzd->coords('APPARENTVELOCITY') ) {
# Get coordinates of the measuring arrow
my ($x1, $y1, $x2, $y2) = $lzd->coords('APPARENTVELOCITY');
my ($olds, $oldt) = $model->screen2model([$x1, $y1], "time");
$lzd->delete('APPARENTVELOCITY');
my $x = $lzd->canvasx($Tk::event->x);
my $y = $lzd->canvasy($Tk::event->y);
my ($s, $t) = $model->screen2model([$x, $y], "time");
my $ds = ($s-$olds);
my $dt = ($t-$oldt);
# Concatenate message about apparent velocity
my $v;
if ($ds == 0) {
# Measurement was vertical
$msg = sprintf ("; dt = %4.2fs",$dt) unless ($dt == 0);
$v = 0;
} elsif ($dt == 0) {
# Measurement was horizontal
$v = $CONFIG{vred};
$msg = sprintf ("; ds = %4.2fkm , v = %4.1fkm/s", $ds, $v);
} else {
# Find apparent velocity of measurement
if ($vredbutton ==1){
# Traveltime display is reduced
# abs necessary for measurements to the left
$v = abs( $ds / ($dt + abs($ds)/$CONFIG{vred}) );
} else {
$v = $ds/$dt;
}
$msg = sprintf (" to x = %6.2fkm, t = %4.2fs; ds = %6.2fkm, dt = %4.2fs,"
." v = %4.1fkm/s",
$s, $t, $ds, $dt, $v);
}
} # Velocity has been measured
if (@choosePicks > 1 ) {
$msg = $msg." -- selected ".(@choosePicks-1);
}
$RMS = 0; # Stop moving of rms hyperbola
_printStatusMessage($msg);
}
sub t_Menu {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my ($self, $x, $y) = @_;
my $cx = $lzd->canvasx($Tk::event->x);
my $cy = $lzd->canvasy($Tk::event->y);
$lzd->delete('ZOOM');
my $id = $lzd->find(qw/withtag current/);
my @tags = $lzd->gettags($id);
print "Open right click time menu tags >$tags[1]<, id @$id\n";
@tags = grep {$_ ne 'current'} @tags;
my $type = $tags[0];
my @coords = $model->screen2model([$cx, $cy], "space");
#print "Type $type, @coords\n";
# Clean menu, then adding entrys for this type of object
$menuRightClick->delete(0, 'last');
if ( $type eq 'PICK' ) {
if ( $CONFIG{zpdir} && $CONFIG{zp2ray} ){
$menuRightClick->add('command', -label => 'Edit phase',
#-command => [\&model::edit, $model, "tags", \@tags, "value", \@coords, "op" , "editPhase"]
-command => [\&tc_editPhase, \@tags]
);
}
$menuRightClick->add('command', -label => 'Measure rms velocity',
-command => [\&t_rms, \@tags, $cx, $cy]
);
}
$menuRightClick->Popup(qw/-popover cursor -popanchor sw/);
#$lzd->delete('ZOOM');
}
########################################################################
sub b_drawAll{
=PROGhead2 b_drawAll()
Extracts all enabled phases and stations from C<$RAYSTATUS> and
C<stationlist> and calls
C<< $model->drawPhaseStationList("phases" => [@DRAWNPHASES], "stations" => [@stationlist]) >>.
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# draws rays for DRAWNPHASES and stationlist
@DRAWNPHASES = ();
@DRAWNSTATIONS = ();
foreach (keys(%RAYSTATUS)){
#say "$_ is my phase, draw? <$RAYSTATUS{$_}>";
if ($RAYSTATUS{$_} == 1) {push @DRAWNPHASES, "$_";}
}
foreach my $st (keys(%stationlist)) {
if ($stationlist{$st}[3] == 1) {
#print "Station >$st< is enabled ($stationlist{$st}[3])\n";
push @DRAWNSTATIONS, $stationlist{$st}[4];
}
}
#warn "WARNING!! This function is currently disabled!!\n";
say "(DEV) b_drawAll() Draw phases @DRAWNPHASES and rays @DRAWNRAYS for @DRAWNSTATIONS" if $dev;
$model->drawPhaseStationList("rays" => [@DRAWNPHASES], "stations" => [@DRAWNSTATIONS], "phases" => \@DRAWNPHASES);
}
sub b_drawStation{
=PROGhead2 b_drawStation()
Draw all picks and rays for a single station. Is called from station button
and right click on station.
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $st = shift;
#print "p::b_drawStation $st, $stationlist{$st}[3]\n";
$model->drawSingleStationData($st, $stationlist{$st}[3]);
$station = $st if ($stationlist{$st}[3] == 1);
}
#sub b_drawPhase {
#=PROGhead2 b_drawPhase($rc, $ph)
#Called when pressing a ray button
#=cut
##print "Got @_\n";
#my $rc = $_[0];
#my $ph = $_[1];
##print "Phase @_:".
##" $RAYSTATUS{@_[0]} on/off\n";
#$RAYSTATUS{$rc} = $RAYSTATUS{$ph} if ( $rc eq '-' );
#$RAYSTATUS{$ph} = $RAYSTATUS{$rc} unless ( $RAYSTATUS{$ph} );
#print "p::b_drawPhase >$rc< >$RAYSTATUS{$rc}<, >$ph< >$RAYSTATUS{$ph}<\n";
#$model->drawPhase('ray' => [$rc, $RAYSTATUS{$rc}], 'phase' => [$ph, $RAYSTATUS{$ph}]);
#}
sub _set{
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my @args = @_;
my $var = $args[0]; # This variable shall be changed, eg, vred, picks...
my $value = $args[1];
$model->set($var => $$value);
}
sub b_export {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# This programms export currently traced phases and stations to your
# configured export-path.
# It also writes the current version number into a file to identify
# the exported data to a specific model.
# Check if outputdirectory exists
unless (-d "$CONFIG{exportpath}" ) {
print "Create output directory $CONFIG{exportpath}\n";
mkpath($CONFIG{exportpath});
}
my $file = "$CONFIG{exportpath}/version.dat";
my $version = $model->_get('version');
$model->exportRays();
print "Model is version number $version\n";
open (FILE, ">$file") or die "Can't open $file\n";
print FILE "$version\n";
print FILE "vred= $CONFIG{vred}\n";
close(FILE);
copy ("v.in", "$CONFIG{exportpath}");
$model->writeXZV();
=USERhead3 Exporting rays and picks
You can either start PRay with the command line option C<-export> (C<p.pl -export>) to just
export rays but do not display the model and
interactive GUI or you can use the File-Menu to export picks from the living GUI.
This will write rays, calculated and manual picks to your configured export-path in
C<p.config> (or default into the current directory)
ready for GMT to plot. Format was choosen to be compatible with Tobi's C<make_rays>-script.
Exported times are reduced with current reduction velocity if exported from GUI or
using C<vred> in C<p.config>.
If exporting from GUI, data for currently traced stations is exported.
If exporting from command line, another C<r.in>-formated file named C<r.export>
is used to trace data. This way you can have an extra file containing all station
and phases needed for full plotting of your profile without having to manually switch on
and off all stations and phases.
Velocity nodes are also exported
=cut
}
sub b_igmas {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# This programms converts model to igmas format and saves it to your
# configured export-path.
# Check if outputdirectory exists
unless (-d "$CONFIG{exportpath}" ) {
print "Create output directory $CONFIG{exportpath}\n";
mkpath($CONFIG{exportpath});
}
my $file = "$CONFIG{exportpath}/version.dat";
my $version = $model->_get('version');
$model->exportIgmas();
#open (FILE, ">$file") or die "Can't open $file\n";
#print FILE "$version\n";
#print FILE "vred= $CONFIG{vred}\n";
#close(FILE);
=USERhead3 Convert model to igmas format
This function is currently in development
=cut
}
sub b_AllRays {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
#say " All rays are drawn (or not)";
foreach (sort(keys(%RAYSTATUS))) {
$RAYSTATUS{$_} = $allRaysButton;
#print "PHASE $_ value $RAYSTATUS{$_}\n";
$model->drawPhase($_, $RAYSTATUS{$_});
}
}
sub b_AllRfl {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
foreach (sort(keys(%RAYSTATUS))) {
#my @t = split(/\./, $_);
#my $p = substr($_,-1);
#if ($t[1]%2 == 0 ) { # included multiples like 1.4, 1.6
#if ($t[1] == 2 ) { # No multiples
#if ($p == 2 ) { # No multiples
if ( $_ =~ m/.2/ ) {
print "Set $_ to $allRflButton\n";
$RAYSTATUS{$_} = $allRflButton;
# get phasecode and change status
#$RAYSTATUS{$CODES->get(ray => $_)} = $allRflButton;
#$model->drawPhase($_, $RAYSTATUS{$_});
}
}
b_drawAll();
}
sub b_AllRfr {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
print "Set Refractions\n";
foreach (sort(keys(%RAYSTATUS))) {
my @t = split(//, $_);
if ($t[-1] == 1 ) {
print "Set $_ to $allRfrButton\n";
$RAYSTATUS{$_} = $allRfrButton;
$model->drawPhase($_, $RAYSTATUS{$_});
}
}
}
sub b_AllMul {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
print "Switch on multiples\n";
foreach (sort(keys(%RAYSTATUS))) {
#my @t = split(/\./, $_);
#if ($t[1] >= 4 ) {
my $p = substr($_,-1);
if ($p >= 4 ) {
print "Set $_ to $allRfrButton\n";
$RAYSTATUS{$_} = $allMulButton;
$model->drawPhase($_, $RAYSTATUS{$_});
}
}
}
sub b_getPhases {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $phase = ''; # new version to go to
my $dia = $mw->Toplevel( -popover => $mw,
-title => "$PROG: Find phases",
);
$dia->LabEntry (
-label => 'Find stations with phase',
-labelPack => [qw/-side left -anchor w -expand no -fill x/],
-textvariable => \$phase,
-width => '6'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no');
my $text = $dia->ROText(-width => '30',
#-height => 8,
-borderwidth => 0)
-> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
#my $ans = $dia->Show;
#print "Dialog endet with $ans, km $km, vu $vu, vl $vl, vupar $vupar, vlpar $vlpar\n";
#if ($ans eq "Done") {
#$model->edit("op" => "edit", "tags" => \@tags, "value" => [$km, $vu, $vl, $vupar, $vlpar]);
#}
$dia->Button(-text=>"Find",
-command => sub{
print "Get phases $phase\n";
my $stations = $model->getPhase($phase);
$text->configure(-state => 'normal');
$text->delete('0.0','end');
$text->insert('end', "Found stations: \n$stations");
$text->configure(-state => 'disabled');
}, -width => 10)->pack(qw/-side left/);
$dia->Button(-text=>"Close", -command => [$dia => 'destroy'], -width => 10)->pack(qw/-side left /);
}
sub b_status {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Get model-status within a velocity range
my $dia = $mw->Toplevel( -popover => $mw,
-title => "$PROG: Get model status",
);
# Display results
my $text = $dia->ROText(-width => '50',-state => 'disabled',
-height => 36,
-borderwidth => 0)
-> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
my $stat = $model->status;
$text->configure(-state => 'normal');
$text->delete('0.0','end');
$text->insert('end', "$stat");
$text->configure(-state => 'disabled');
$dia->Button(-text=>"Close", -command => [$dia => 'destroy'], -width => 10)->pack(qw/-side left /);
}
sub b_status_range {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Get model-status within a velocity range
my @range = (150, 350); # Array with specified range
my $dia = $mw->Toplevel( -popover => $mw,
-title => "$PROG: Get model status",
);
$dia->LabEntry (
-label => 'from km',
-labelPack => [qw/-side left -anchor w -expand no -fill x/],
-textvariable => \$range[0],
-width => '6'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no');
$dia->LabEntry (
-label => 'to km',
-labelPack => [qw/-side left -anchor w -expand no -fill x/],
-textvariable => \$range[1],
-width => '6'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no');
# Display results
my $text = $dia->ROText(-width => '50',-state => 'disabled',
-height => 36,
-borderwidth => 0)
-> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
#my $ans = $dia->Show;
#print "Dialog endet with $ans, km $km, vu $vu, vl $vl, vupar $vupar, vlpar $vlpar\n";
#if ($ans eq "Done") {
#$model->edit("op" => "edit", "tags" => \@tags, "value" => [$km, $vu, $vl, $vupar, $vlpar]);
#}
$dia->Button(-text=>"Get",
-command => sub{
print "Get model statistics for range @range\n";
my $stat = $model->status('range' => \@range);
$text->configure(-state => 'normal');
$text->delete('0.0','end');
$text->insert('end', "$stat");
$text->configure(-state => 'disabled');
}, -width => 10)->pack(qw/-side left/);
$dia->Button(-text=>"Close", -command => [$dia => 'destroy'], -width => 10)->pack(qw/-side left /);
}
=USERhead3 Phases, Phasenumbering
How to get phases into Pray?
Phase numbering is based on numbering used in rayinvr. Phasecodes are
formated in L.T or LT. With L for layer number and T for type of ray
1 = refracted in layer L
2 = reflected at bottom of layer L
3 = head wave at bottom of layer L
=cut
sub b_changeStation {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
print "Current station selected is using $station\n";
##my @list=keys(%stationlist);
#foreach (keys(%stationlist)){
#print "my key $_\n";
#if ($station eq $stationlist{$_}[0]){
#print "Found my station!! $_\n";
#$station=$_;
#}
#}
#print "Station is now $station\n";
}
sub b_c2v {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
_printStatusMessage("\nConvert c.in to v.in");
system ("c2v << EOL
EOL" );
}
sub b_v2c {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
_printStatusMessage("\nConvert v.in to c.in");
system ("v2c << EOL
EOL" );
}
sub b_viewContours {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# If file does not exist, create it
if ( ! -f "contours.ps" ) {
$model->set("contours",1);
$model->set("contours",0);
}
system("gv contours.ps &");
}
sub b_modelDifferences {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
_printStatusMessage("\nCreate GMT-Difference plot between this and last version");
my $v1 = $VERSION;
my $v2 = _GetVersionNumber();
my $m = $mw->Dialog(-popover => $mw,
-title => "Compare versions",
-buttons => ['Done', 'Cancel']
);
my $text = $m->ROText(-width => '30', -height => 6, -wrap => 'word', -borderwidth => 0)
-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$text->insert('end',
"Please choose versions to compare:\n\n"
."Current version : $v1\n"
."Last version in history: $v2");
$m->LabEntry ( -label => 'compare version ',
-labelPack => [qw/-side left -anchor w -expand yes -fill both/],
-textvariable => \$v1,-width => 6,
)-> pack (-side=>'top', -anchor => 'e', -fill => 'none', -expand => 'yes');
$m->LabEntry ( -label => 'to version ',
-labelPack => [qw/-side left -anchor w -expand yes -fill both/],
-textvariable => \$v2, -width => 6,
)-> pack (-side=>'top', -anchor => 'e', -fill => 'none', -expand => 'no');
if ($m->Show eq "Done") {
_printStatusMessage("\nCompare $v1 to $v2");
#system('cd $RI/history/;'." $PRAYPATH/modeldiff.tcsh $v1 $v2 &");
system("$PRAYPATH/scripts/modeldiff.tcsh $v1 $v2 &");
}
}
sub b_resolution {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
_printStatusMessage("\nSet all partial derivatives, write model to file, run dmplsqrt and make resolution plot");
# 1. set par deriv for all layer
#$model->editAllParDerivs();
# Write model to v.in
#b_writeModel("Set all partial derivatives for resolution calculation");
## 2. run rayinvr
#b_rayinvr();
# 3. run dmplsqrt (exports resolution)
#b_dmpl("dmplsqrt to calculate resolution");
# 4. Draw resolution plot
my $cmd = $CONFIG{resolution};
print "(DEV) Run >$cmd< to plot resolution grid\n" if $dev;
system($cmd);
}
sub b_writeModel {
=PROGhead2 b_writeModel()
-_historyAdd() # Copy for undo Button
- $model->writeVin
- b_rayinvr()
_writeStatus();
- _historyAdd() # copy current v.in
- $verion--
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Asks if you want to continue. Current c.in/v.in are overwritten and
# backuped to history/v.$VERSION
my $comment = shift;
my $msg = "Do you want to write v.in and run rayinvr?\n\n"
."A backup-file called history/v.$VERSION will be created. You can read".
" it with the undo button.\n"
."\n-----------------------------------\n"
."You can add a comment for this model version. Comments get saved to "
."file $commentfile when quitting PRay via menu.\n"
."\nComment:"
;
my $win = $mw->Toplevel( -popover => $mw,
-title => "$PROG: Write v.in?",
#-text => $msg,
#-buttons => ['Yes', 'No'] #, -default_button => 'No'
);
my $dia = $win->Frame(-borderwidth => 5, -relief => 'flat')
-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
my $text = $dia->ROText(-width => '40', height => '14', -borderwidth => 3, -relief => 'flat', -wrap => 'word')
-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$text->insert('end', $msg);
$text->configure(-state => 'disabled');
my $entry = $dia -> Entry (
#-label => 'Add comment',
#-labelPack => [qw/-side top -anchor s -expand yes -fill both/],
-textvariable => \$comment,
-width => '40',
)-> pack (-side=>'top', -anchor => 'n', -fill => 'x', -expand => 'yes');
#my $ans = $dia->Show;
my $button = $dia->Button(-text=>"Yes", -command =>
sub {
$win->destroy;
_historyAdd(); # Make a copy for the undo-Button
$model->writeVin;
$model->set("version" => $VERSION); #TODO muss das nicht in historyAdd() ?
b_rayinvr();
_historyAdd(); # copy the current v.in
$VERSION--; # ???? _historyAdd increases version number.
_writeStatus();
if (defined $comment && $comment ne '') {
print "Comment for version $VERSION is >$comment<\n";
$COMMENTS{$VERSION} = $comment;
}
_setWindowTitle();
}
, -width => 10)->pack(qw/-side left -anchor e/);
$dia->Button(-text=>"No", -command => [$win => 'destroy'], -width => 10)->pack(qw/-side left -anchor e/);
$entry->focus;
# If routine was called with given comment, its from b_resolution
# and should be run at once
if ( defined $comment ){
$button->invoke();
}
}
sub b_rayinvr {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
#if (defined $pid) {
#closerayinvr();
#}
#$SIG{'CHLD'} = \&waiting;
#print "Write r.in\n";
#my $RIN = commons::readRin();
#commons::writeRin($RIN);
print("Starting $CONFIG{rayinvr} ...\n");
_printStatusMessage("\nRunning $CONFIG{rayinvr} ...");
$mw->update;
#defined( my $ripid = fork ) or die "Cannot fork: $!";
#print "Childpid:$ripid\n";
#unless( $ripid ) {
#system($CONFIG{rayinvr});
# Removing old files before running helps to recognize segmentation faults
system("rm r1.out r2.out; ".$CONFIG{rayinvr});
#my $output = `$CONFIG{rayinvr}`;
#print $output;
#open OUTPUT, "$CONFIG{rayinvr} |";
#while (<OUTPUT>){
#chomp;
#print $..": ".$_."\n";
#}
#print "\n ***** leaving rayinvr\n";
#die;
#CORE::exit(0);
#print " *** EVEN MORE ***\n";
#}
#print "RAYINVR is running\n";
#sub waiting {
#print "wait a bit until finished\n";
print "RAYINVR is done\n";
# copy r1.out to history
print "Copy r1.out to history/r1.$VERSION\n";
copy ("r1.out", "history/r1.$VERSION");
#my $tmp = `ps ax | grep -v "grep" | grep "xrayinvr"`;
#say "Grep-output $tmp ";
#my @pid = split(' ',$tmp);
#$pid = $pid[0];
# @pid= split(/ /,`ps ax | grep -v "grep" | grep "xrayinvr"` ) ;
#print "PID ARRAY: @pid \n";
#print("xrayinvr PID: ".$pid."\n");
#say "Rereading files and update plot now";
$model->read("rays", "times" );
b_drawAll();
#waitpid($ripid, 0);
#}
}
sub b_dmpl {
=PROGhead2 b_dmpl('comment')
- _historyAdd()
- dmplsq
- model->reset; b_rayinvr
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $comment = shift;
_printStatusMessage("\nRun dmplstsqr.. ");
print "dmpl: Add history\n" if $debug;
_historyAdd(); # Make a copy for the undo-Button
print "run dmplsqr\n" if $debug;
system("dmplstsqr_new2 > /dev/null");
$model->read("vin" );
# Write a resolution file
print "Reading resolution\n" if $debug;
_printStatusMessage(" reading resolution");
$model->resolution();
#print "Running rayinvr ..\n";
#_printStatusMessage("Running rayinvr ..");
$model->reset; # Deletes Contours
#$model->order; # Draws contours
#b_rayinvr;
_historyAdd(); # copy the current v.in
$VERSION--; # ???? _historyAdd increases version number.
my @t = localtime(time);
my $t = sprintf "%02d.%02d.%4d %02d:%02d",$t[3],$t[4]+1,$t[5]+1900,$t[2],$t[1],$t[0];
$COMMENTS{$VERSION} = "$t -- dmplstsqr";
$COMMENTS{$VERSION} = "$comment" if $comment;
# c.in still holds the model prior to inversion
#print "You should run c2v now, if you don't like the result\n";
#_printStatusMessage("\nYou should run v2c now, if you like the result. If not run c2v");
## syncronizing c.in and v.in
#b_v2c;
}
sub b_undo {
=PROGhead2 b_undo()
- _gotoVersion($VERSION-1)
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
print "\n\n ----------- UNDO -------------\n";
_gotoVersion($VERSION-1);
print "Leavin undo-operation with version $VERSION\n";
}
sub b_redo {
=PROGhead2 b_redo()
- _gotoVersion($VERSION+1);
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
print "\n\n +++++++++++ REDO +++++++++++++\n";
_gotoVersion($VERSION+1);
print "Leavin redo-operation with version $VERSION\n";
}
sub b_gotoVersion {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $version = ''; # new version to go to
my $m = $mw->Dialog(-popover => $mw,
-title => "$PROG: Go to version",
#-text => "Current values are @$tags",
-buttons => ['Done', 'Cancel']
);
$m->LabEntry (
-label => 'Version',
-labelPack => [qw/-side left -anchor w -expand yes -fill both/],
-textvariable => \$version,
-width => '6'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
my $text = $m->ROText(-width => '30',
#-height => 8,
-borderwidth => 0)
-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$text->insert('end', "Marked models are:\n@markedmodels\n\n".
"Last version in history: "._GetVersionNumber());
if ($m->Show eq "Done") {
_printStatusMessage("\nChange to version $version");
my $r = _gotoVersion($version);
if ( $r == 1 ) { # Error in gotoVersion! No version found
b_gotoVersion();
}
}
}
sub b_copytolast {
=PROGhead2 b_copytolast()
Function copys current model to last version + 1 found in history and
therefore enables you to edit without overwriting old models
- get last version _GetVersionNumber
- copy to last version + 1
- go to that version
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $lastVersion = _GetVersionNumber() + 1;
my $comment = "= $VERSION";
if ($COMMENTS{$VERSION} ) {
$comment .= ": $COMMENTS{$VERSION}";
}
$COMMENTS{$lastVersion} = $comment;
print "Copy current model (version $VERSION) to $lastVersion\n";
copy ("v.in", "history/v.$lastVersion");
_gotoVersion($lastVersion);
}
sub _gotoVersion {
=PROGhead2 _gotoVersion(newVersion, [runrayinvr?])
Internal routine for changing version. Checks if newVersion exists, copys
to v.in and updates Window title and global variable $VERSION.
Returns 0 for no errors, 1 for errors
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $newVersion = shift;
my $rayinvr = shift;
# if no second argument present, rayinvr will be run
my $return = 0;
if (-e "history/v.$newVersion" && $newVersion >= 0){
_printStatusMessage("\nChange to version $newVersion");
# Copy new version and run rayinvr
copy ("history/v.$newVersion", "v.in");
$mw->update;
$model->set("version" => $newVersion);
$model->reset;
print "Run rayinvr? >$rayinvr<\n" if $debug;
if ($rayinvr) {
print "Yes\n" if $debug;
_printStatusMessage(" and run rayinvr.");
b_rayinvr();
} else {
print "No\n" if $debug;
$model->read( "vin");
b_drawAll();
}
$VERSION = $newVersion;
# Update title
_setWindowTitle();
_writeStatus();
} else {
# No file found
_printStatusMessage("\nERROR: There's no file >v.$newVersion<\nChoose a different version!");
$return = 1;
}
return $return;
}
sub b_editMarkedmodels {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $m = $mw->Dialog(-popover => $mw,
-title => "Edit marked models",
#-text => "Please leave list sorted",
-buttons => ['Done', 'Cancel']
);
my $edit = "@markedmodels";
print "Edit marked models: $edit\n";
$m->LabEntry (
-label => 'marked models',
-labelPack => [qw/-side left -anchor w -expand yes -fill both/],
-textvariable => \$edit,
-width => length($edit)
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
if ($m->Show eq "Done") {
@markedmodels = sort { $a <=> $b } (split /\s+/, $edit);
_printStatusMessage("\nChanged marked models to @markedmodels");
}
}
sub b_mark {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# mark current $VERSION and ask user for a comment
print "Mark model version $VERSION\n";
unless ( grep $_ eq $VERSION, @markedmodels) {
push @markedmodels, $VERSION;
@markedmodels = sort { $a <=> $b } @markedmodels;
}
########
my $comment = $COMMENTS{$VERSION};
my $msg =
"You can add a comment for this model version. Comments get saved to "
."file $commentfile when quitting PRay via menu.\n"
."\nComment:"
;
my $win = $mw->Toplevel( -popover => $mw,
-title => "$PROG: Add a comment for this model version?",
);
# The frame gives a nicer window look with it's border. No other function
my $dia = $win->Frame(-borderwidth => 5, -relief => 'flat')
-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
my $text = $dia->ROText(-width => '40', height => '14', -borderwidth => 3, -relief => 'flat', -wrap => 'word')
-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$text->insert('end', $msg);
$text->configure(-state => 'disabled');
my $entry = $dia -> Entry (
-textvariable => \$comment,
-width => '40',
)-> pack (-side=>'top', -anchor => 'n', -fill => 'x', -expand => 'yes');
$dia->Button(-text=>"Close", -command =>
sub {
$win->destroy;
if (defined $comment && $comment ne '') {
print "Comment for version $VERSION is >$comment<\n";
$COMMENTS{$VERSION} = $comment;
} else {
# Delete commentkey if nothing is entered
delete $COMMENTS{$VERSION};
}
}
, -width => 10)->pack(qw/-side left -anchor e/);
$entry->focus;
###########
print "Models marked: @markedmodels\n";
_printStatusMessage("\nModels marked: @markedmodels");
# Make contours
$model->set( "contours", \1 );
$model->set( "contours", \$showContours );
# Save r1.out and contours.ps in history
print "Copy contours and r1 to history\n";
copy ("contours.ps", "history/contours.$VERSION.ps");
copy ("r1.out", "history/r1.$VERSION");
}
sub b_markforward {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
print "Go to next marked model in list: @markedmodels\n";
# find index for next model
for ( my $i = 0; $i <= $#markedmodels; $i++ ) {
if ( $markedmodels[$i] > $VERSION ) {
print "Load version $markedmodels[$i]\n";
_gotoVersion($markedmodels[$i]);
return;
}
}
print "No version found. Go to last model in history\n";
_gotoVersion(_GetVersionNumber());
}
sub b_markback {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
print "Go to last marked model. Current version: $VERSION\n";
# find index for previous model
for ( my $i = $#markedmodels; $i >= 0; $i-- ) {
print "Check $i: $markedmodels[$i]\n";
if ( $markedmodels[$i] < $VERSION ) {
print "Load version $markedmodels[$i]\n";
_gotoVersion($markedmodels[$i]);
return;
}
}
print "No version found. Go to end of array\n";
_gotoVersion($markedmodels[-1]);
}
sub b_reload {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
print "Reload v.in\n";
# Copied from b_rayinvr;
$model->read( "vin" );
$showBlocks=0; # Layers with block information are deleted, when
# reloading the model
$model->set( "blocks" => \$showBlocks );
b_drawAll();
}
sub b_editRin {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
#print "Pressed Editing R.in\n";
my $rin = commons::readRin();
#print Dumper($rin);
my $stat = commons::readStatxz($CONFIG{stationfile});
print "Stationfile: $CONFIG{stationfile}\n";
my $dia = $mw->Toplevel(-title => "Edit r.in");
commons::displayRin($dia,$rin, $stat);
#_printStatusMessage("\nr.in written.");
#$rin = b_displayRin($rin);
#print Dumper($rin->{ishot});
}
sub b_openfiles {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $edit = $CONFIG{editor};
if ( ! defined $edit ) {
_printStatusMessage("\nNo editor defined!! Please set up environment variable \$EDITOR ".
"or insert 'editor = youreditor' in $CONFIGFILE");
return 0;
}
defined( my $editpid = fork ) or die "Cannot fork: $!";
unless( $editpid ) {
my $command = $CONFIG{editor}." $CONFIG{files}\n";
system( $command);
print "\nStopping child $editpid '$edit'\n";
CORE::exit(0);
}
}
sub b_zp{
=PROGhead2 b_zp()
Start phase picking software. Currently ZP is used. Change this subroutine for
your own software.
=cut
=USERhead3 Connection to picking software
PRay can start a phase-picking software and provide a station file for
the currently selected station. At the moment ZP ( C< https://www.soest.hawaii.edu/users/bzelt/ > )
is used for this purpose and started with
cd $CONFIG{zpdir}; zp2 $file $par
C<$File> and C<$par> are either taken from C<statxz>-file column 4 and 5 (see L</statxz>) or
generated using C<zpFileMask> in C<p.config> (see L</Config-File>)
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $file=$stationlist{$station}[1];
my $par=$stationlist{$station}[2];
print "Open station $stationlist{$station}[0] $file in zp\n";
defined( my $zppid = fork ) or die "Cannot fork: $!";
#print "Childpid:$zppid\n";
unless( $zppid ) {
print "cd $CONFIG{zpdir}; zp2 $file $par << EOL";
system("cd $CONFIG{zpdir}; zp2 $file $par << EOL
x
EOL");
warn "\nleaving child";
CORE::exit(0);
}
print "ZP is running\n";
}
sub b_zp2ray {
=PROGhead2 b_zp2ray
- Call's $CONFIG{zp2ray}
- $model->read("times")
- b_drawAll();
=cut
=USERhead3 Update picked phases
PRay was written with ZP used for picking. ZP needs to export picked phases, which then have
to be reformatted to C<tx.in> format for rayinvr.
A program for this task can be started using the button C<zp2ray>. You can configure this button
in C<p.config> with C<zp2ray>.
TODO: describe replacements
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
$file = $stationlist{$station}[1];
$file =~ s/head$/pick/ if ($file);
if ($station eq "str") {
# Current station is the streamer
$file = "str100.4.offs.head"
} else {
unless ($CONFIG{zp2ray}) {
_printStatusMessage("\nzp2ray is NOT configured! Use your own method to export data and run rayinvr to read them");
return 1;
}
# It's a normal station for which you can use zp2ray
(my $command = $CONFIG{zp2ray}) =~ s/\$dir/$DIR/g;
$command =~ s/\$file/$file/g if ($file);
print "Export picks for station $station\n";
print "Use command: $command\n ";
#system ("/projects/nam2011/bin/zp2ray.csh $DIR $file");
system ($command);
$model->read( "times" );
b_drawAll();
}
}
sub b_reloadTx {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
print "Reload tx.in\n";
$model->read( "times" );
b_drawAll();
}
sub b_extract {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Show dialog to enter profile km for extracting 1D velocity profiles
#my $m = $mw->Dialog(-popover => $mw,
#-title => "$PROG: Extract 1D velocity profiles",
#-text => "Current values are @$tags",
#-buttons => ['Extract', 'Cancel']
#);
my $m = $mw->Toplevel( -popover => $mw,
-title => "$PROG: Extract 1D velocity profiles",
);
my $text = $m->ROText(-width => '30', -height => 3, -borderwidth => 0, -wrap => 'word')
-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$text->insert('end', "Enter profile km for extracting 1D velocity-depth profiles as comma seperated list");
$text->configure(-state => 'disabled');
$m->LabEntry (
-label => 'Profile km',
-labelPack => [qw/-side left -anchor w/],
-textvariable => \$depthvelocityprofiles,
-width => '40'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
#if ($m->Show eq "Extract") {
#_printStatusMessage("\nExtracting velocity profiles at km $depthvelocityprofiles");
#$model->get('1d', $depthvelocityprofiles);
#system("$PRAYPATH/vd_plots.csh");
#}
$m->Button(-text=>"Extract",
-command => sub{
_printStatusMessage("\nExtracting velocity profiles at km $depthvelocityprofiles");
$model->get('1d', $depthvelocityprofiles);
# As security measure, write status with correct version
# in case two programs are running
_writeStatus();
system("$PRAYPATH/scripts/vd_plots.csh");
}, -width => 10)->pack(qw/-side left/);
$m->Button(-text=>"Close", -command => [$m => 'destroy'], -width => 10)->pack(qw/-side left /);
}
sub b_quit{
=USERhead3 Quitting PRay
Use the quit button in File-menu->Quit to shut PRay down. This gives PRay the
chance to save current marked model list and version number to F<p.status> and also
gives you the chance to delete version above your current version.
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
################################
# Write current programstatus
################################
_writeStatus();
# Cleaning up history directory
my $i = _GetVersionNumber();
unless ($i == $VERSION || $VERSION !~ /[0-9]*/ ) {
my $yesno_button = $mw->messageBox( -popover => $mw, -title => "$PROG: Deleting history?",
-message => "Do you want to delete versions in history directory above"
." current version >$VERSION<?\n"
."\nLast version found is >$i<.\n",
-type => "yesnocancel", -default => "no");
if ($yesno_button eq "Yes") {
print "Deleting history-files\n";
if (-d "history") {
opendir(DIR, "history") or die $!;
my @files = grep { /^v\./ && -f "history/$_"} readdir(DIR);
closedir(DIR);
print "Delete versions above $VERSION\n";
foreach (@files){
if ($_ =~ m/(\d+)/ && $1 > $VERSION){
# $1 represents the digit selected by regex (\d+)
print "Delete history/$_, version $1\n";
unlink("history/$_"); # Potential Problem if you run it on Windows!!
(my $v = $_) =~ s/v\.//; # remove commentes for deleted modelversion
delete $COMMENTS{$v};
}
}
}
} elsif ($yesno_button eq "Cancel") {
print "Abort shutdown\n";
return;
}
}
_writeComments();
print "##############################################################\n" unless $quiet;
print "# Bye bye. Have a nice day, enjoy life without geophysics #\n" unless $quiet;
print "# and remember to PRay #\n" unless $quiet;
print "##############################################################\n" unless $quiet;
exit;
}
sub _writeStatus {
=PROGhead2 _writeStatus()
Writes current status of PRay to file p.status. This file may be manually
manipulated when PRay is not running and you have an idea what you are doing.
PRay can start without this file.
=cut
=USERhead3 Status file
PRay writes a status file C<p.status> with current program state. This file may be manually
manipulated when PRay is not running and you have an idea what you are doing.
PRay can start without this file.
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $file = "p.status";
@DRAWNRAYS = ();
@DRAWNSTATIONS = ();
foreach (sort(keys(%RAYSTATUS))){
#say "$_ is my phase, draw? <$RAYSTATUS{$_}>";
if ($RAYSTATUS{$_} == 1) {push @DRAWNRAYS, "$_";}
}
foreach (keys(%stationlist)) {
if ($stationlist{$_}[3] == 1) {push @DRAWNSTATIONS, $stationlist{$_}[4];}
}
print "Write current status to file >$file<\n" unless $quiet;
#my $s = "markedmodels = @markedmodels\n"
#."version = $VERSION\n"
#."depthvelocityprofiles = $depthvelocityprofiles\n"
#. "DRAWNSTATIONS = @DRAWNSTATIONS\n"
#. "DRAWNRAYS = @DRAWNRAYS\n";
my $s = '';
# Update STATUS variable
$STATUS{"markedmodels"} = join(' ',@markedmodels);
$STATUS{"version"} = $VERSION;
$STATUS{"depthvelocityprofiles"} = $depthvelocityprofiles;
$STATUS{ "DRAWNSTATIONS"} = join(' ',@DRAWNSTATIONS);
$STATUS{ "DRAWNRAYS"} = join(' ',@DRAWNRAYS);
#@{$STATUS{"markedmodels"}} = @markedmodels;
#@{$STATUS{"version"}} = $VERSION;
#@{$STATUS{"depthvelocityprofiles "}} = $depthvelocityprofiles;
#@{$STATUS{ "DRAWNSTATIONS"}} = @DRAWNSTATIONS;
#@{$STATUS{ "DRAWNRAYS"}} = @DRAWNRAYS;
foreach my $key ( keys(%STATUS) ) {
$s .= "$key = $STATUS{$key}\n";
}
#print Dumper(\%STATUS) if $dev;
print $s unless $quiet;
open(FILE, ">$file") or die "Can't open $file";
printf FILE $s;
#printf FILE "markedmodels = @markedmodels\n";
#printf FILE "version = $VERSION\n";
#printf FILE "depthvelocityprofiles = $depthvelocityprofiles\n";
#printf FILE "DRAWNSTATIONS = @DRAWNSTATIONS\n";
#printf FILE "DRAWNRAYS = @DRAWNRAYS\n";
close(FILE);
}
sub _writeComments {
=PROGhead2 _writeComments()
Writes content of global variable %COMMENTS to file $commentfile
=cut
################################
# Writing comments to file
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $file = $commentfile;
open(FILE, ">$file") or die "Can't open $file";
foreach (sort { $a <=> $b } (keys(%COMMENTS))) {
my $version = $_;
my $comment = $COMMENTS{$version};
#print "$version: $comment \n";
printf FILE "$version: $comment \n";
}
close(FILE);
print "Wrote comments to $file\n" unless $quiet;
}
sub b_help {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $top = $mw->Toplevel( -popover => $mw,
-title => "$PROG: User documentation",);
my $help = $top->Scrolled ("ROText", -scrollbars => 'e')
-> pack ( -side => 'bottom', -expand => 1, -fill => 'both');
# Open PRay help file
my $file = "$PRAYPATH/doc/p_readme.txt";
open (FILE, $file) or die "Cannpt open $file";
while (<FILE>) {
#chomp; # no newline
$help->insert ('end', "$_");
}
close(FILE)
#$help->insert ('end', "$file");
#$stline->configure(-height => 2);
}
sub b_helpHTML {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $file = "$PRAYPATH/p_readme.html";
system("$CONFIG{browser} $file");
}
sub b_about {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $about =
"\n".
"PRay-invr\n".
"L\n".
"O\n".
"T\n".
"\n".
"https://aforge.awi.de/gf/project/pray/\n\n".
"\n".
"Tanja Fromm\n".
"Alfred-Wegener-Institut fuer Polar- und Meeresforschung\n".
"Bremerhaven, Germany\n".
"2011-2015\n\n".
"PRay version: $STATUS{PRayVersion}\n"
;
my $m = $mw->Dialog(-popover => $mw,
-title => "$PROG: About",
-buttons => ['Close']
);
my $text = $m->Text(-width => '60', -height => 16, -borderwidth => 0)
-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
$text->insert('end', $about);
$text->configure(-state => 'disabled');
$m->Show;
}
sub b_vmodel {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $vmodelw = $mw->Toplevel(-title => "$PROG: vmodel");
my $text = $vmodelw -> Scrolled('ROText' , -scrollbars => 'e', -width => 80, -height => 60, -borderwidth => 0)
-> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
my $buttonframe = $vmodelw -> Frame ->
pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no', -before => $text);
$buttonframe -> Button (-text=>"vmodel", -command => [\&vmodel, $text])
-> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'no');
$buttonframe -> Button (-text=>"Close", -command => [$vmodelw => 'destroy'])
-> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'no');
b_vmodelFill($text);
# sub vmodel gets output of vmodel, marks border crossings and displays it
sub b_vmodelFill{
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $text = shift;
$text->tagConfigure('start'); # Create a tag named 'start'
$text->insert('end', "\n", 'start'); # Place tag to the beginning of new output
$text->insert('end', "##########################################################################\n".
"Running vmodel for version v.$VERSION\n");
my $output = `vmodel`; # Get output
$text->insert('end', $output); # Insert output
$text->see('end'); # Move whole window as far down as possible
$text->see("start.last"); # Move window back up to our mark. This ensures
# the new output is visible from start
# Mark border crossings
$text->tagConfigure('foundtag',
-foreground => "white", # Format marking
-background => "red");
$text->FindAll(-regex, -nocase, "crosses\ boundary");
if ($text->tagRanges('sel')) {
my %startfinish = $text->tagRanges('sel');
foreach(sort keys %startfinish) {
$text->tagAdd("foundtag", $_, $startfinish{$_});
}
$text->tagRemove('sel', '1.0', 'end');
}
# Mark low-velocity zones
$text->tagConfigure('lowvelo',
-foreground => "white", # Format marking
-background => "blue");
$text->FindAll(-regex, -nocase, "low-velocity\ zone");
if ($text->tagRanges('sel')) {
my %startfinish = $text->tagRanges('sel');
foreach(sort keys %startfinish) {
$text->tagAdd("lowvelo", $_, $startfinish{$_});
}
$text->tagRemove('sel', '1.0', 'end');
}
}
}
sub b_viewComments {
=PROGhead2 b_viewComments()
Creates window with buttons and text field for comments. Calls
C<< b_viewCommentsBindAndFill($text, $commentsw) >> to fill in comments.
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $commentsw = $mw->Toplevel(-title => "$PROG: View version comments");
my $text = $commentsw-> Scrolled('ROText' , -scrollbars => 'e', -width => 80, -height => 20, -borderwidth => 0)
-> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
$text->menu(undef);
my $buttonframe = $commentsw-> Frame ->
pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no', -before => $text);
$buttonframe -> Button (-text=>"Update", -command => [\&b_viewCommentsBindAndFill, $text])
-> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'no');
$buttonframe -> Button (-text=>"Close", -command => [$commentsw=> 'destroy'])
-> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'no');
# Make version number a link to go to the model
b_viewCommentsBindAndFill($text, $commentsw);
$text->tagConfigure(qw/link -foreground blue /);
#$text->tagConfigure('bold', -foreground => 'red');
$text->tagBind(qw/link <Enter>/ => [sub {
$text->configure(qw/-cursor hand2/);
#$text->tagAdd('bold',$text->index('current'));
}]
);
$text->tagBind(qw/link <Leave>/ => [sub {
#$text->tagRemove(qw/bold 1.0 end/);
$text->configure(qw/-cursor xterm/);
}]
);
}
sub b_viewCommentsBindAndFill {
=PROGhead2 b_viewCommentsBindAndFill($text, $commentsw)
Fills given window (C<< $commentsw >> with given text and creates mouse bindings.
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
#print "Display comments\n";
my $text = shift;
my $commentsw = shift;
my $textcomments = "";
$text->delete('0.0','end');
$text->tagBind('link',"<Button-1>", sub{
my $i = $text->index('current');
my @tags = $text->tagNames([ $i]);
my $version = $tags[1];
print "You pressed a link at $i with tags @tags\n"
."I'm going to this version $version\n";
_gotoVersion($version);
});
$text->tagBind('comment',"<Button-3>", sub{
my $i = $text->index('current');
my @tags = $text->tagNames([ $i]);
my $version = $tags[1];
print "You pressed a link at $i with tags @tags\n"
."Editing version $version\n";
_editComment(\$version, $text);
});
# Insert text
foreach (sort { $a <=> $b } (keys(%COMMENTS))) {
my $version = $_;
my $comment = $COMMENTS{$version};
$textcomments.="$version: $comment\n";
$text->insert('end',$version,['link',"$version"]);
$text->insert('end',": $comment\n",['comment',"$version"]);
}
$text->see('end');
}
sub _editComment {
=PROGhead2 C<_editComment($version, ($textwidget))>
Opens window to edit comment. Automatically updates C<$textwidget> if given
and writes comments to file
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
#print "_editComment: Arguments @_\n";
my $v = shift; # version to edit
my $t = shift; # textfield
my $version = $$v;
########
my $comment = $COMMENTS{$version};
my $msg =
"Edit comment for version $version"
;
my $win = $mw->Toplevel(
-title => "$PROG: Edit comment",
);
# The frame gives a nicer window look with it's border. No other function
my $dia = $win->Frame(-borderwidth => 5, -relief => 'flat')
-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes');
#my $text = $dia->ROText(-width => '40', height => '1', -borderwidth => 3, -relief => 'flat', -wrap => 'word')
#-> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'yes');
#$text->insert('end', "Edit comment for version $version");
#$text->configure(-state => 'disabled');
$dia -> LabEntry ( -width => 6,
-label => "Version ",
-labelPack => [qw/-side left -anchor w/],
-textvariable => \$version)-> pack (-side=>'left', -anchor => 'w', -fill => 'none');
my $entry = $dia -> Entry (
-textvariable => \$comment,
-width => '40',
)-> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'yes');
$dia->Button(-text=>"Close", -command =>
sub {
$win->destroy;
# Add comment to hash
if (defined $comment && $comment ne '') {
print "Comment for version $version is >$comment<\n";
$COMMENTS{$version} = $comment;
} else {
# Delete commentkey if nothing is entered
delete $COMMENTS{$version};
}
_setWindowTitle();
# Update comment list if window is open
if ( $t ) {
b_viewCommentsBindAndFill($t);
}
# Write comments to file
_writeComments();
}
, -width => 10)->pack(qw/-side bottom -anchor e/);
$entry->focus;
###########
}
sub b_viewResults {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $resultsw = $mw->Toplevel(-title => "$PROG: View tracing results");
my $text = $resultsw-> Scrolled('ROText' , -scrollbars => 'e', -width => 80, -height => 60, -borderwidth => 0)
-> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
my $buttonframe = $resultsw-> Frame ->
pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'no', -before => $text);
$buttonframe -> Button (-text=>"Update", -command => [\&b_displayResults, $text])
-> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'no');
$buttonframe -> Button (-text=>"Close", -command => [$resultsw=> 'destroy'])
-> pack (-side=>'left', -anchor => 'w', -fill => 'x', -expand => 'no');
b_displayResults($text, $resultsw);
}
sub b_displayResults {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $text = shift;
my $resultsw = shift;
my $results =("#"x80)
."\n# Model version $VERSION:\n".("#"x20)
."\n\n"
;
$results.=$model->get("results");
$text->insert('end',$results);
$text->see('end');
}
sub i_ReadStatus {
#TODO: introduce variable %STATUS for easier handling
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $file = "p.status";
open (FILE, $file) or (print "Cannot find $file. No status restored\n", return 0);
print "Reading old program status from file >$file<\n" unless $quiet;
while (<FILE>) {
chomp; # no newline
#s/#.*//; # no comments
s/^\s*#.*//; # whole line is commented
s/^#.*//; # whole line is commented
s/[0-9a-zA-Z\s]#.*//; # no comments (but keeps colors like \#A42E93
s/^\s*#//; # whole line is commented
s/^\s+//; # no leading white
s/\s+$//; # no trailing white
s/\\//g; # Remove escaping slash from hex-color codes
next unless length; # anything left?
my ($var, $value) = split(/\s*=\s*/, $_, 2);
print "$. : $_\n" if $verbose;
$STATUS{$var} = $value;
if ( $var eq 'markedmodels' ) {
@markedmodels = split /\s+/, $value;
my $msg = "Restored marked models to @markedmodels";
print "$msg\n" unless $quiet;
i_Messages("\n$msg");
}
if ( $var eq 'version' ) {
$VERSION = $value;
my $msg = "Restored version number to: $VERSION";
print "$msg\n" unless $quiet;
i_Messages("\n$msg");
}
if ( $var eq 'depthvelocityprofiles' ) {
$depthvelocityprofiles = $value;
}
if ( $var eq 'DRAWNSTATIONS' ) {
@DRAWNSTATIONS = split(/\s/, $value);
}
if ( $var eq 'DRAWNRAYS' ) {
@DRAWNRAYS = split(/\s/, $value);
}
}
close(FILE);
print "DRAWNRAYS = @DRAWNRAYS\n" if $verbose;
print "DRAWNSTATIONS = @DRAWNSTATIONS\n" if $verbose;
#print Dumper(\%STATUS) if $dev;
}
sub i_ConfigRead {
=PROGhead2 C<i_ConfigRead()>
Reads file C<<p.config>> for user specific settings into hash C<<$CONFIG{$var}>>. Values
are only set, if hashkey exists (default values).
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $file = shift;
open (FILE, $file) or do {print "WARNING!! Cannot find $CONFIGFILE. Use default values.\n"; return 0};
print "Read user configuration from file >$file<\n" unless $quiet;
while (<FILE>) {
chomp; # no newline
#s/#.*//; # no comments (be aware of hex colorcodes!)
s/^\s*#.*//; # whole line is commented
s/^#.*//; # whole line is commented
s/[0-9a-zA-Z\s]#.*//; # no comments (but keeps colors like \#A42E93
s/^\s*#//; # whole line is commented
s/^\s+//; # no leading white
s/\s+$//; # no trailing white
s/\\//g; # Remove escaping slash from hex-color codes
next unless length; # anything left?
my ($var, $value) = split(/\s*=\s*/, $_, 2);
#print "$file\[$.\]: <$var=$value>\n";
# Do not allow adding keys, which are not defined !!
if ( !exists($CONFIG{$var})) {
# Variable is not defined in $CONFIG
my @keys = sort(keys(%CONFIG));
print "\n\nERROR: Unknown configuration variable '$var' in $file $.\n\n".
"Possible variables are:\n@keys\n\n".
"Note: For consistency reasons with variable naming in rayinvr\n".
"variable maxdepth has changed to zmax\n".
"and maxheight to zmin\n\n"
."\nERROR: Unknown configuration variable '$var' in $file $.\n\n";
die;
}
# Key exists, continue
# Check if value is an environment variable
if ( $value =~ m/^\$/) {
$value =~ m/\$(.*?)\//; # find match environment variable $var up to next /
my $env = $1; # save match
#print "env = $1 - $env, value = $value\n";
# Get value of environment variable
if ( exists $ENV{$env}) {
my $envval = $ENV{$env};
# Replace variable with content
$value =~ s/\$$env/$envval/;
} else {
die "There's no environment variable named \$$value for variable $var\n";
}
#die;
}
# Some parameter require special treatment
if ($var eq 'command' || $var eq 'xz' || $var eq 'xt') {
# Several user defined commands can be added
#print "Add user defined >$var< as $value\n";
push @{$CONFIG{$var}} , $value;
} else {
$CONFIG{$var} = $value;
#print "Using $var = $value\n";
}
#elsif ($var eq 'xmax' && $value > $CONFIG{xmax}){
## If xmax is larger than xmax from r.in, model file v.in cannot
## be read
#print "ERROR: The value 'xmax = $value' in your $CONFIGFILE is larger than".
#" xmax = $CONFIG{xmax} from your r.in!!!\n".
#"Use a value smaller than the one from r.in or omit 'xmax' to use the one from r.in\n";
#die;
#} else {
#$CONFIG{$var} = $value;
#print "Using $var = $value\n";
}
close (FILE);
#print Dumper(\%CONFIG);
}
sub i_ConfigInit{
=PROGhead2 i_ConfigInit()
Define default values and pop up help for p.config parameter. To add a
config parameter, put the default value and a comment in this hash. To
allow editing also add the new parameter to b_configEdit().
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
CONFIGURATION:
###
# Programms and places
$CONFIG{rayinvr} = "xrayinvr"; $CONFIGDOC{rayinvr} =
"Default: xrayinvr
Shell command bound to button 'rayinvr'. This should normally be
'rayinvr' or 'xrayinvr'. If the \$PATH-variable is set correct, no path
is needed. It could also be a user-written script";
$CONFIG{gmt} = "GMT"; $CONFIGDOC{gmt} =
"Default: gmt
This is a switch for different GMT-versions.
If you use GMT 5, please insert GMT; if you use GMT 4, do not insert
anything.";
$CONFIG{stationfile} = "statxz"; $CONFIGDOC{stationfile} =
'File with a list of stationnames, their position and depth and optional
information for the pick program
Format:
name position depth [headfile] [parameterfile]
eg:
01 6.640 -10
02 10.660 -50
03 13.260 -60
This file is used to draw the stationpositions in the model. If it
does not exist, it is created the r.in. The additional information is
currently needed for zp, if the headfile is not named using the
\'zpfilemask\'-parameter';
$CONFIG{exportpath} = "./data"; $CONFIGDOC{exportpath} =
'Default: ./data
Outputpath for exporting rays and times in GMT format
(Menu->Export rays&picks)';
$CONFIG{deleteExported} = 1; $CONFIGDOC{deleteExported} =
"(0/1) Default: 1
1) Delete old exported rays before exporting current rays. Exportfolder
therefore contains only stations that have just been traced for the
current model
0) If set to 0 old files are kept, but may be from an old
model. Usefull if you cannot trace all stations in one go.";
#$CONFIG{outpos} = "relative"; $CONFIGDOC{outpos} =
#"(absolute/relative) Default: relative
#Defines x-positon of traveltime data.
#'absolute' for model km
#'relative' for km relative to obs";
$CONFIG{resolution} = "$PRAYPATH/scripts/resolution.gmt"; $CONFIGDOC{resolution} =
"User defined script to run for plotting the resolution file
default: scripts/resolution.gmt
";
$CONFIG{editor} = $ENV{'EDITOR'}; $CONFIGDOC{editor} =
'Default: $EDITOR
Editor for opening text files in \'Menu->Open files\'. Default is the
environment variable';
$CONFIG{files} = "v.in r.in"; $CONFIGDOC{files} =
'Default: v.in r.in
Define files for quick opening from menu (Menu->Open files)';
$CONFIG{browser} = undef; $CONFIGDOC{browser} =
'Command to open browser. This will activate the html version of
the readme file (Help->User documentation-html).
Use e.g.: \'open\' (Mac) or \'firefox\' (Unix) ';
###
# Configure picking
$CONFIG{zp2ray} = undef; $CONFIGDOC{zp2ray} =
"Shell command bound to button 'zp2ray'
You may use words \$zpdir, \$dir and \$file for substitution
\$zpdir: your 'zpdir'-configuratio value
\$dir: current working directory
\$file: file build with your 'zpFileMask'-configuration or from
4th column in 'statxz'-file";
$CONFIG{zpFileMask} = undef; $CONFIGDOC{zpFileMask} =
'Rules for naming of zp .head files used if no head-file is given in
the \'station\'-file.
$obs obsnumbers read from stationfile
e.g. : 100st$obs.h.head -> 100st130.h.head';
$CONFIG{zpdir} = undef; $CONFIGDOC{zpdir} =
'Directory containing the zp .head files.';
#$CONFIG{densityconversion} = 'barton'; $CONFIGDOC{densityconversion} =
#'Define density conversion. Default: barton. Alternative: funck
#Conversion uses values from
#Barton(1986) "The relationship between seismic velocity and density in the continental crust - a useful constraint?"
#or
#Ludwig(1970) "Seismic Refraction" in THE SEA
#';
###
# Appearance
$CONFIG{screenwidth} = 1600; $CONFIGDOC{screenwidth} =
'Default: 1600
Width of main window';
$CONFIG{screenheight} = 1000; $CONFIGDOC{screenheight} =
'Default: 1000
Height of main window';
$CONFIG{reverseTime} = 0; $CONFIGDOC{reverseTime} =
'(0/1) Default: 0
Switch direction of time axis';
$CONFIG{xmin} = undef; $CONFIGDOC{xmin} =
'Default: xmin (r.in)
Define the displayed model section. Overwrite r.in values';
$CONFIG{xmax} = undef; $CONFIGDOC{xmax} =
'Default: xmax (r.in)
Define the displayed model section. Overwrite r.in values';
$CONFIG{zmin} = 0; $CONFIGDOC{zmin} =
'Default: zmin (r.in) or 0
Define the top of the displayed model section. Overwrite r.in values.
Negative values are above the surface.';
$CONFIG{zmax} = 30; $CONFIGDOC{zmax} =
'Default: zmax (r.in) or 30
Define the bottom of the displayed model section. Overwrite r.in values.
Positive values are below the surface.';
$CONFIG{tmin} = 0; $CONFIGDOC{tmin} =
'Default: tmin (r.in) or 0
Define the top of the diplayed traveltime section. Overwrite r.in values.
Currently the y-direction of the traveltime section cannot be swapped.';
$CONFIG{tmax} = 15; $CONFIGDOC{tmax} =
'Default: tmax (r.in) or 15
Define the bottom of the diplayed traveltime section. Overwrite r.in values.
Currently the y-direction of the traveltime section cannot be swapped.';
$CONFIG{vred} = 8; $CONFIGDOC{vred} =
'Default: 8
Choose velocity reduction';
$CONFIG{stationsperline} = 30; $CONFIGDOC{stationsperline} =
"Default: 30
Number of stationbuttons in one line (currently only two lines are
supported";
$CONFIG{modelbg} = "grey"; $CONFIGDOC{modelbg} =
'Default: grey
Change background color of model section';
$CONFIG{ttbg} = "white"; $CONFIGDOC{ttbg} =
'Default: white
Change background color of traveltime display';
$CONFIG{txin} = 'dash'; $CONFIGDOC{txin} =
'(dash/circle/line) Default: dash
Set kind of drawing for traveltime arrivals (tx.in)';
$CONFIG{txinSize} = 2; $CONFIGDOC{txinSize} =
'Change size of input pick symbol (txin)';
$CONFIG{txout} = 'line'; $CONFIGDOC{txout} =
'(dash/circle/line) Default: line
Set kind of drawing for traveltime arrivals (tx.out)';
$CONFIG{txoutSize} = 1; $CONFIGDOC{txoutSize} =
'Change size of traced arrival symbol (txout)';
$CONFIG{splash} = 0; $CONFIGDOC{splash} =
'(0/1) Default: 0
Display startup-splash? The splash screen might slow down your system.';
$CONFIG{annotSize} = 80; $CONFIGDOC{annotSize} =
'Change text size for annotating velocity nodes. Default 80';
$CONFIG{stationSize} = 10; $CONFIGDOC{stationSize} =
'Change size for drawing the station triangle. Default 10';
###
# Additional data and commands
$CONFIG{additionalPhases} = undef; $CONFIGDOC{additionalPhases} =
'Define extra phases for phase button menu
e.g.:
1 2 77 100';
$CONFIG{additionalPhaseColors} = undef; $CONFIGDOC{additionalPhaseColors} =
'Define colors for the additional phases. You can use named colors
like \'red\', \'green\' or html hexcodes, e.g. A020F0)';
$CONFIG{basement} = -1; $CONFIGDOC{basement} =
'Default: -1
Give a layer number (as in v.in) for the basement and draw a thicker
line for this layer. This layer is also used as margin for extracting
the velocity structure of the igneous crust';
$CONFIG{moho} = -1; $CONFIGDOC{moho} =
'Default: -1
Give a layer number (as in v.in) for the Moho and draw a thicker
line for this layer. This layer is also used as margin for extracting
the velocity structure of the igneous crust';
$CONFIG{command} = undef; $CONFIGDOC{command} =
'Insert user defined \'commands\' to command menu.
Format:
Label = script.sh
Use one line per command and reload the config-file to get a new line
(or write directly to the file)
';
$CONFIG{xz} = undef; $CONFIGDOC{xz} =
'Overlay xz-data in model diagram. Give file name and optional color for
the line, e.g.:
filename red
file-format:
x z';
$CONFIG{xt} = undef; $CONFIGDOC{xt} =
'Overlay xt-data in traveltime diagram. Give file name and optional color for
the line, e.g.:
filename red
file-format:
x t';
###
# Non-rayinvr model data
$CONFIG{tomoPhase} = undef; $CONFIGDOC{tomoPhase} =
'Enable functions for tomo2D and associates ray data to this phase';
$CONFIG{tomoTimes} = "tt.dat"; $CONFIGDOC{tomoTimes} =
'File containing traveltimedata in tx format';
$CONFIG{tomoRays} = 'tomo.rays'; $CONFIGDOC{tomoRays} =
'raypathes in GMT-plotable multisegment format. '
.'Rays MUST start at the station (reverse file)';
$CONFIG{tomoGrid} = 'tomo.xyz'; $CONFIGDOC{tomoGrid} =
'xyz-file read in for Tomo. Should have xinc = 1, zinc = 0.5';
$CONFIG{tomoRefl} = 'tomo.refl'; $CONFIGDOC{tomoRefl} =
'reflector-file for tomo2D';
$CONFIG{tomoPhasePg} = undef; $CONFIGDOC{tomoPhasePg} = '
Phase number for Pg rays if rayfile is splitted';
$CONFIG{tomoRaysPg} = undef; $CONFIGDOC{tomoRaysPg} =
'ray file containing ONLY Pg';
$CONFIG{tomoTimesPg} = undef; $CONFIGDOC{tomoTimesPg} =
'ray file containing ONLY Pg';
$CONFIG{tomoPhasePmP} = undef; $CONFIGDOC{tomoPhasePmP} =
'Phase number for PmP rays if rayfile is splitted';
$CONFIG{tomoRaysPmP} = undef; $CONFIGDOC{tomoRaysPmP} =
'ray file containing ONLYPmP';
$CONFIG{tomoTimesPmP} = undef; $CONFIGDOC{tomoTimesPmP} =
'ray file containing ONLY PmP';
$CONFIG{txTomo} = 'line'; $CONFIGDOC{txTomo} =
'line';
############
foreach (qw(xmin xmax zmin zmax tmin tmax)) {
if (exists $RIN->{$_}) {
$CONFIG{$_}=$RIN->{$_}[0];
#print "set $_ to $RIN->{$_}[0]\n";
}
}
=USERhead3 Config-File
C<p.pl> can be configured with file C<p.config> in current working directory.
All parameter have default values, but some users might want to change some
for their own model. A config-file is not necessary. There's a graphical editor
with pop up help available at C<< Menu->Edit p.config >>.
You can comment parameter with '#'. Spaces around '=' are not needed. You can use environment
variables (e.g. zpdir=$ZP). Dont use '~'. Use '$HOME' instead. Only one variable per line is allowed.
Lists use spaces as seperator.
Under Menu-Edit p.config a graphical editor with help function aids the
program setup.
C<p.config> is read after C<r.in> and overwrites values for xmin, xmax, zmax,
zmin, tmin and tmax from r.in
=cut
}
sub b_configEdit {
=PROGhead2 b_configEdit()
Reads config and opens window for editing and saving a new C<p.config>.
New user configurables have to be inserted here.
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
#> x join(' ',sort(keys(%{$model->{config}})))
#> additionalPhaseColors additionalPhases basement browser command
# deleteExported editor exportpath files modelbg
# moho outpos rayinvr rin
# screenheight screenwidth splash stationfile tmax tmin tomoGrid
# tomoPhase tomoPhasePg tomoPhasePmP tomoRays tomoRaysPg tomoRaysPmP
# tomoRefl tomoTimes tomoTimesPg tomoTimesPmP ttbg txTomo txin txout
# vred xmax xmin xt xz zmax zmin zp2ray zpFileMask zpdir
#x join(' ',sort(map {@$_} @vars))
# Reread all values from file
i_ConfigInit();
i_ConfigRead($CONFIGFILE);
my @vars;# = sort(keys(%CONFIG));
my @labels;
my $cw = $mw->Toplevel(-title => "Edit $CONFIGFILE");
my $buttonf = $cw->Frame(-borderwidth => 1, -background => "green")->pack(qw/-side top -anchor w -expand yes -fill x/);
$buttonf->Button(-text=>"Save Changes", -command => [\&save, \@labels, \@vars], -width => 10)->pack(qw/-side left -anchor n /);
$buttonf->Button(-text=>"Close", -command => [$cw => 'destroy'], -width => 10)->pack(qw/-side left /);
my $sc = $cw -> Scrolled ('Pane', -scrollbars => 'e', -borderwidth => 1,
-relief => 'solid', #-background => "green",
#-width => 600,
-sticky=>'nwse',
-height => ($CONFIG{screenheight} - 100)
) -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
#my $sc = $cw -> Frame ( -borderwidth => 1,
#-relief => 'solid', #-background => "green",
##-width => 600, -height => 400
#) -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
# First column frame, Second column frame
my $fircolf = $sc->Frame(-borderwidth => 1, -background => "green")->pack(qw/-side left -anchor n -expand yes -fill x/);
my $seccolf = $sc->Frame(-borderwidth => 1, -background => "green")->pack(qw/-side left -anchor n -expand yes -fill x/);
# Display help text
my $rotext = $fircolf->ROText(-width => '30', -height => 10, -wrap => 'word', -borderwidth => 0)
-> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
my $text = "This is an interface to aid configuration of PRay. "
."It writes the p.config file which can also be edited with any "
."other editor. To run PRay, no special configuration is necessary, "
."information is extracted "
."from r.in, but functionality can be greatly enhanced by some simple "
." configurations. Specially the picking configuration. See popup-windows for help.\n"
."Environment variables can be used.\n"
."\nChanges are only applied after a restart of PRay!\n"
;
$rotext->insert('end', $text);
$rotext->configure(-state => 'disabled');
########################
### Create arrays with labels and config parameter
# Only parameter entered in this arrays will appear in the user interface
# Programms and places
push @vars, [qw/rayinvr gmt stationfile exportpath deleteExported editor files browser resolution densityconversion/];
push @labels,"Programms and places";
# Pick software
push @vars, [qw/zp2ray zpFileMask zpdir/];
push @labels, "Configure picking";
# Appearance
push @vars, [qw/screenwidth screenheight reverseTime xmin xmax zmin zmax tmin tmax vred stationsperline
modelbg ttbg txin txinSize txout txoutSize stationSize annotSize splash /];
push @labels, 'Appearance';
# Model definitions
push @vars, [qw/additionalPhaseColors additionalPhases basement moho
command xt xz/];
push @labels,"Additional data and commands";
# Non-rayinvr data
push @vars, [qw/tomoPhase tomoPhasePg tomoPhasePmP tomoRays tomoRaysPg
tomoRaysPmP tomoRefl tomoTimes tomoTimesPg tomoTimesPmP txTomo tomoGrid/];
push @labels, "Non-rayinvr model data (experimental)";
# Uncategorized = To be fixed
#push @vars, [];
#push @labels, "Uncategorized";
####
# Check for differences
my @v = sort(map {@$_} @vars);
my @c = sort(keys(%{$model->{config}}));
my $s = "";
for (my $i=0; $i<=$#c; $i++) {
unless ($v[$i] eq $c[$i]) {
unless ( exists $RIN->{$v[$i]}) {
print ">$v[$i]< is not to be configured any more. Programmer: remove it from sub b_configEdit\n";
} else {
print ">$c[$i]< cannot be configured in this dialog\n"
."Fix that, programmer\n";
#push @{$vars[-1]}, $c[$i];
}
last;
}
}
########################
### Fill dialog window
my $blocks = @vars;
my $frame = $fircolf;
for ( my $i = 0; $i < $blocks; $i++ ) {
$frame = $seccolf if ( $i == 3 );
makeLabel($frame, $labels[$i]);
makeLabelEntry($frame, @{$vars[$i]});
############
# Create a print out for the user docs:
#makeDoc($labels[$i], @{$vars[$i]});
}
sub makeDoc{
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my ($label, @vars) = @_;
print "$label\n";
foreach my $element (@vars) {
print $CONFIGDOC{$element};
}
}
################
sub save{
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $file = "$CONFIGFILE";
my $labels = shift;
my $vars = shift;
#print "p::b_configEdit($file)\n";
open(FILE, ">$file") or die "Can't open $file";
_printStatusMessage("\nWrite changes to >$CONFIGFILE<. You must restart to apply changes!");
#print "Write all parameter: ".sort(keys(%CONFIG));
my $blocks = @$vars;
for ( my $i = 0; $i < $blocks; $i++ ) {
my $s = "\n###################\n# $labels->[$i]\n###\n";
print $s;
printf FILE $s;
foreach my $var ( @{$vars->[$i]} ) {
if ( defined $CONFIG{$var} ) {
if ( ref($CONFIG{$var}) eq 'ARRAY' ) {
$s = "";
foreach my $element ( @{$CONFIG{$var}} ) {
$s .= "$var = $element\n" if ($element);
}
}else {
$s = "$var = $CONFIG{$var}\n";
}
#$s =~ s/#/\#/g;
$s =~ s/#//g; # Remove hash of hex codes. Otherwise they'd skipped next time as comments
# I don't know, how to replace # by \#.
print $s;
printf FILE $s;
}
}
}
close(FILE);
}
################
sub makeLabel{
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $sc = shift;
my $label = shift;
$sc -> Label(-text => "\n$label",
) -> pack (-side=>'top', -anchor => 'w', -fill => 'both', -expand => 'yes');
}
################
sub makeLabelEntry {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $sc = shift;
my @vars = @_;
foreach my $var (@vars) {
my $msg = $CONFIGDOC{$var};
if ( ref($CONFIG{$var}) eq 'ARRAY' ){
print "Found array for $var \n";
# Add empty field for new user command
push @{$CONFIG{$var}}, '';
foreach my $element ( @{$CONFIG{$var}}) {
$balloon->attach(
$sc-> LabEntry (
-label => "$var",
-justify => 'left',
-labelAnchor => 'w',
-width => '50',
-labelWidth=>20,
-labelPack => [qw/-side left -anchor e -fill x/],
-textvariable => \$element,
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes')
, -balloonmsg => $msg);
}
next;
}
# Create labeled entry with help button attached
$balloon->attach(
$sc-> LabEntry (
-label => "$var",
#-labeljustify => 'left',
-justify => 'left',
#-background => 'red',
-labelAnchor => 'w',
-width => '50',
-labelWidth=>20,
-labelPack => [qw/-side left -anchor e -fill x/],
-textvariable => \$CONFIG{$var},
#-width => '6'
)-> pack (-side=>'top', -anchor => 'w', -fill => 'x', -expand => 'yes')
, -balloonmsg => $msg);
}
}
}
#sub i_ReadRin {
#my $rin = shift; # Use hash to store r.in parameter
#print "Reading phasecode from r.in\n";
#my @txph = @{$rin->{ivray}}; # Get phasecodes for tx
#my @riph = @{$rin->{ray}}; # Get raycodes for RI
##my @phasecodes = @{$rin->{ivray}}; # Get phasecodes for tx
##my @raycodes = @{$rin->{ray}}; # Get raycodes for RI
#if (@txph != @riph) {
#print
#"###############################################################\n".
#"# ATTENTION !! ATTENTION !! ATTENTION !! #\n".
#"# Phasecode-arrays for rayinvr and zp have DIFFERENT length!! #\n".
#"# Please correct parameter >ivray< and >ray< in your r.in #\n".
#"# #\n".
#"# The array >ray< defines which phases are to be traced by #\n".
#"# rayinvr, while >ivray< defines the phasecode as in tx.in #\n".
#"###############################################################\n";
##exit;
#}
#my %phasecodes; # Store merged codes
#my %raycodes; # Store merged codes
#for (my $i=0; $i <= $#txph; $i++ ){
#$phasecodes{$txph[$i]} = $riph[$i];
## Phasecodes for in rayinvr are not unique if using multiples
## Believing, you'd define direct before multiple, value is not
## overwritten, if one exists.
#if ( exists $raycodes{$riph[$i]}) {
##print
##"###############################################################\n".
##"# ATTENTION !! ATTENTION !! ATTENTION !!\n".
##"# Rayinvr code $riph[$i] matches $txph[$i] and $raycodes{$riph[$i]}\n".
##"# Ignoring $txph[$i]\n".
##"###############################################################\n";
#i_Messages(
#"\nRayinvr code $riph[$i] matches ZP codes $txph[$i] and $raycodes{$riph[$i]}.".
#" Ignoring $txph[$i].");
#} else {
#$raycodes{$riph[$i]} = $txph[$i] unless ( exists $raycodes{$riph[$i]});
#}
#}
##return \%phasecodes, \%raycodes;
#}
sub i_Comments {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $file = $commentfile;
open (FILE, $file) or do {print "Cannot find old comment file\n"; return 0};
print "Reading comments from $commentfile\n" unless $quiet;
while (<FILE>) {
chomp; # no newline
#s/#.*//; # no comments
s/^\s*#.*//; # whole line is commented
s/^#.*//; # whole line is commented
s/[0-9a-zA-Z\s]#.*//; # no comments (but keeps colors like \#A42E93
s/^\s*#//; # whole line is commented
s/^\s+//; # no leading white
s/\s+$//; # no trailing white
s/\\//g; # Remove escaping slash from hex-color codes
next unless length; # anything left?
my ($var, $value) = split(/\s*:\s*/, $_, 2);
# Populate comment-hash with old comments
$COMMENTS{$var} = $value;
#print "Add comment >$var: $value<\n";
}
close (FILE);
}
sub i_Colors{
printf "(T) %s(@_)\n", commons::whoami() if $tree;
######################################################################
# Define Phase Colors
# 0 1 2 3 4 5 6 7 8 9 10
# 1.2 2.2 3.2 4.2 5.2 6.2 7.2 8.2 9.2 10.2 11.2
# dunkelrot rot orangerot orange hellorange gelb gruen gruener gruenblau
@REFLECTED = split(/\s+/, "#AA142B #F80500 #FF642A #FC8200 #FFB231 #FFDD31 #7EE000 #22AF00 #44BF70 #DEFF3A #AADA65");
# 1.1 2.1 3.1 4.1 5.1 6.1 7.1 8.1 9.1 10.1 11.1
# hellgruen dunkelhell gruen mint
@REFRACTED = split(/\s+/, "darkgrey #97FF4C #5BC80C #2994D0 #0033CC #27CC9C #36DDE6 #1CACB4 #1C96B4 #07CEFF #1C8DA9");
# 1.3 2.3 3.3 4.3 5.3 6.3 7.3 8.3 9.3 10.3 11.3
# blau lila pink
@HEAD = split(/\s+/, "#284AFF #011CA8 #9276FF #912EE4 #6700BD #9E00BD #DE54F9 #EF99FF #FF99F5 #FF99F5 #B077AB");
my $mult = "black"; # corrected multiple
# Define Phases
my $raycodes= $CODES->get('raycodes'); # Which phases should be visible in the Phasemenu?
#push @phases, "0.0";
# Create phaselist with number of layers
#for (my $i = 1; $i <= 11; $i++){ # For all layers. TODO Change to variable for number of layers
#push @phases, "$i.1";
#push @phases, "$i.2";
#push @phases, "$i.3";
#push @phases, "$i.4";
#push @phases, "$i.5";
#push @phases, "$i.6";
#push @phases, "$i.7";
#}
## Defines phases for phasebuttons and asigns colors to them
my $i = 0;
# Bring colors and phases together into a hash %phasecolors
foreach my $rc (@$raycodes) {
#print "Set color for phase $ph\n";
#( $j = $_) =~ s/\.\d//; # $j is the layer. It needs the array value $j-1 for colordefinition
my @rc = split /\./, $rc;
if (@rc == 2) {
my $l = $rc[0]; # Layer
my $r = $rc[1]; # raytype
my $color;
# Distinguish between raytype
if ($r =~ m/[15]/ ) {
$color = \@REFRACTED;
} elsif ($r =~ m/[24]$/ ) {
$color = \@REFLECTED;
} elsif ($r =~ m/[367]$/ ) {
$color = \@HEAD;
}
# TODO: Use a default color if there's no value in the color array
$PHASECOLORS{$rc} = $color->[$l-1];
# Color corresponding tx-code
my $ph = $CODES->get(ray => $rc);
if ( $ph ) {
# Phase is defined
$PHASECOLORS{$ph} = $color->[$l-1];
print "Raycode $rc, phase $ph: layer $l, got color $color->[$l-1]\n" if $verbose;
} else {
# Phase is not defined. What??
print "Warning! No phasecode is defined for ray $rc. I can't assign the calculated travel times"
." to traced rays.\nPlease define 'ivray' in your r.in\n";
}
} else {
# Phases other than 2 digits
print "Add $rc to additional phases\n" if $verbose;
push @ADDITIONALPHASES, $rc;
}
$i++;
}
#if (@ADDITIONALPHASES != @ADDITIONALCOLORS){
#print "Your inputs for additional Phases and Colors don't have the same amount of entrys\n".
##"Please fix that in your configfile $CONFIGFILE\n";
#print "Additional phases: @ADDITIONALPHASES\n".
#"Additional colors: @ADDITIONALCOLORS\n".
#"Use last color in array for the rest of phases\n";
##exit;
#}
# User added colors are tested and added to the %PHASECOLORS hash
my $tw = new MainWindow(-title => "Colortester");
for (my $i=0; $i <= $#ADDITIONALPHASES; $i++){
if ($ADDITIONALCOLORS[$i]) {
eval '$tw->configure(-background => $ADDITIONALCOLORS[$i])';
if ( $@ ) {
#print "BLAH $@\n";
#print "Can't find color $ADDITIONALCOLORS[$i], replace it by #$ADDITIONALCOLORS[$i]\n";
$ADDITIONALCOLORS[$i] = "#$ADDITIONALCOLORS[$i]";
}
#print "Additional color: $ADDITIONALCOLORS[$i]\n";
}
# If no more colors available, use last one
$PHASECOLORS{$ADDITIONALPHASES[$i]} = defined $ADDITIONALCOLORS[$i] ? $ADDITIONALCOLORS[$i] : $ADDITIONALCOLORS[-1];
print "Add phase $ADDITIONALPHASES[$i] with color $PHASECOLORS{$ADDITIONALPHASES[$i]}\n" if $verbose;
}
$tw->destroy;
}
sub i_DrawButtons{
=PROGhead2 i_DrawButtons()
Draws first row of command buttons and attaches balloons.
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
#######
# Create program-buttons
# If no zpFileMask is given, PRay cannot find head-files
if ( defined $CONFIG{zpdir} && defined $CONFIG{zpFileMask}) {
my $zpbutton = $mw -> Button (-text=>"zp", -command => \&b_zp)
-> pack(-side => 'left');
}
if ( defined $CONFIG{zp2ray} ) {
my $zp2rayinvrbutton = $mw -> Button (-text=>"zp2ray", -command => \&b_zp2ray)
-> pack(-side => 'left');
}
#my $cvbutton = $mw -> Button (-text=>"c2v", -command => \&b_c2v, -state => 'normal')-> pack(-side => 'left');
#my $vcbutton = $mw -> Button (-text=>"v2c", -command => \&b_v2c, -state => 'normal')-> pack(-side => 'left');
my $writebutton = $mw -> Button (-text=>"Write v.in", -command => \&b_writeModel, -state => 'normal')-> pack(-side => 'left');
my $backmark = $mw -> Button (
-command => \&b_markback, -width => '23', -height => '22',
-image => $mw->Photo(-file => "$ICONS/fastbackward.gif"), -compound => "left")-> pack(-side => 'left');
my $undo = $mw -> Button (
-command => \&b_undo, -width => '23', -height => '22',
-image => $mw->Photo(-file => "$ICONS/backward2.gif"), -compound => "left")-> pack(-side => 'left');
my $reload = $mw -> Button (
-command => \&b_reload, -width => '23', -height => '22',
-image => $mw->Photo(-file => "$ICONS/reload.gif"), -compound => "left")-> pack(-side => 'left');
my $redo = $mw -> Button (
-command => \&b_redo, -width => '23', -height => '22',
-image => $mw->Photo(-file => "$ICONS/forward2.gif"), -compound => "left")-> pack(-side => 'left');
my $forwardmark = $mw -> Button (
-command => \&b_markforward, -width => '23', -height => '22',
-image => $mw->Photo(-file => "$ICONS/fastforward.gif"), -compound => "left")-> pack(-side => 'left');
my $lastmodel = $mw -> Button (
-command => sub {
my $v = _GetVersionNumber();
print "Got to version $v";
_gotoVersion($v);}
, -width => '23', -height => '22',
-image => $mw->Photo(-file => "$ICONS/fastforward.gif"), -compound => "left")-> pack(-side => 'left');
my $mark = $mw -> Button (
-command => \&b_mark, -width => '23', -height => '22',
-image => $mw->Photo(-file => "$ICONS/flag.gif"), -compound => "left")-> pack(-side => 'left');
my $commentbutton = $mw -> Button (
-command => [\&_editComment, \$VERSION], -width => '23', -height => '22',
-image => $mw->Photo(-file => "$ICONS/comment.gif"), -compound => "left")-> pack(-side => 'left');
my $goto = $mw -> Button (
-command => \&b_gotoVersion, -width => '23', -height => '22',
-image => $mw->Photo(-file => "$ICONS/goto.gif"), -compound => "left")-> pack(-side => 'left');
my $copytolast = $mw -> Button (
-command => \&b_copytolast, -width => '23', -height => '22',
-image => $mw->Photo(-file => "$ICONS/copytolast.gif"), -compound => "left")-> pack(-side => 'left');
my $vnodesbutton
= $mw->Checkbutton( -variable =>\$showVNodes, -indicatoron => 0, -selectcolor => '', -width => '23', -height => '24',
-command => [\&model::set, $model, "vnodes", \$showVNodes],
-image => $mw->Photo(-file => "$ICONS/vnodesoff.gif"),
-selectimage => $mw->Photo(-file => "$ICONS/vnodes.gif"),
-compound => "left")-> pack(-side => 'left');
my $contoursbutton
= $mw->Checkbutton( -variable =>\$showContours, -indicatoron => 0, -selectcolor => '',
-width => '23', -height => '24',
-command => [\&model::set, $model, "contours", \$showContours],
-image => $mw->Photo(-file => "$ICONS/contoursOff.gif"),
-selectimage => $mw->Photo(-file => "$ICONS/contoursOn.gif"),
-compound => "left")-> pack(-side => 'left');
=USERhead3 Contours
Contours can be overlayn on layers in GUI. To calculate contours GMT needs to be installed. There's
also a postscript file name contours.ps created. You can open it in gv with menu Commands->View contours.ps
=cut
my $glueNodesbutton = $mw->Checkbutton ( -variable => \$glueNodes, -indicatoron => 0,
-selectcolor => '',
-width => '23', -height => '24',
#-width => 2, -height => 1,
-image => $mw->Photo(-file => "$ICONS/glueNodesOff.gif"),
-selectimage => $mw->Photo(-file => "$ICONS/glueNodes.gif"),
-compound => "left",
-command => [\&model::set, $model, "glueNodes", \$glueNodes])
->pack( -side => 'left');
#$viewmenu->checkbutton(-label => 'Show Contourlines', );
my $rayinvr = $mw -> Button (-text=>"rayinvr", -command => \&b_rayinvr)-> pack(-side => 'left');
my $dmpl = $mw -> Button (-text=>"dmplstsqr", -command => \&b_dmpl)-> pack(-side => 'left');
# Create Tomo2D button only, if this functionality is configured in $CONFIGFILE
if (defined $CONFIG{'tomoPhase'} ||
( defined $CONFIG{'tomoPhasePg'} && defined $CONFIG{'tomoPhasePmP'})){
print "Tomo2D functions enabled. \n" unless $quiet;
if (defined $CONFIG{'tomoPhase'}){
print "Phase number for tomo2D phases >$CONFIG{'tomoPhase'}<\n" unless $quiet;}
if ( defined $CONFIG{'tomoPhasePg'} && defined $CONFIG{'tomoPhasePmP'}) {
print "Phase number for tomo2D Pg phases >$CONFIG{'tomoPhasePg'}<\n".
"Phase number for tomo2D PmP phases >$CONFIG{'tomoPhasePmP'}<\n" unless $quiet;}
my $tomo = $mw -> Button (-text=>"Tomo2D",
-command => [\&model::tomo, $model, "tomorays", \"1"]);
$tomo-> pack(-side => 'left');
}
###################################
# STATION SELECTOR
# Select station used for zp or other programms with only one option
my $stationlb = $mw -> BrowseEntry(
-label => "Station:", -variable =>\$station, #-labelPack => [-side => 'right'],
-width => 10, -autolistwidth => 1, # -listwidth => 30, #-autolistwidth => 1,
-command=>\&b_changeStation)
-> pack (-side=>'left');
##########################
# Enter reduction velocity
$balloon->attach(
$mw -> Checkbutton (-text => "vred", -variable => \$vredbutton,
-indicatoron => 0,-selectcolor => '', -pady => '4',
-command => [\&_set, "vredstate", \$vredbutton], -state => 'normal') -> pack (-side=>'left')
, -balloonmsg => "Show travel times with velocity reduction");
my $entry = $mw -> Entry (-textvariable => \$CONFIG{vred}, -width => '4') -> pack (-side=>'left');
$entry -> bind ('<Return>', sub {
if ( $CONFIG{vred} =~ /^\d+\.?\d*/ ) {
_set("vred", \$CONFIG{vred});
}
});
# Attach info balloons
$balloon->attach($rayinvr, -balloonmsg => "Run rayinvr and update graphics",
-statusmsg => "Press the Button to exit the application");
$balloon->attach($backmark, -balloonmsg =>
"Go back to previous marked model version");
$balloon->attach($undo, -balloonmsg =>
"Go to previous model version");
$balloon->attach($reload, -balloonmsg =>
"Reload v.in from disk");
$balloon->attach($redo, -balloonmsg =>
"Go to next model version ");
$balloon->attach($forwardmark, -balloonmsg =>
"Go forward to next marked model version");
$balloon->attach($lastmodel, -balloonmsg =>
"Go to last model version");
$balloon->attach($mark, -balloonmsg =>
"Add mark to this version for faster navigation.\n".
"You may edit marked models using menu File->Edit marked models");
$balloon->attach($commentbutton, -balloonmsg =>
"Add or edit a comment for this model");
$balloon->attach($goto, -balloonmsg =>
"Go to version ..");
$balloon->attach($copytolast, -balloonmsg =>
"Copy this model to latest version");
$balloon->attach($glueNodesbutton, -balloonmsg =>
"Move all nodes of pinched layers together");
$balloon->attach($writebutton, -balloonmsg =>
"This writes v.in.\n".
"A backupfile with version number is created in history directory.\n".
"Use buttons to the right for navigation different versions");
$balloon->attach($dmpl, -balloonmsg =>
"Run damp least square inversion. A backup file for undo is created");
##########################
# Set type of picks to be shown (manual and/or calculated
$balloon->attach(
$mw -> Checkbutton (-text => "Obs", -variable => \$PicksManButton,
-indicatoron => 0,-selectcolor => '', -pady => '4',
-command => [\&_set, "PicksMan", \$PicksManButton], -state => 'normal') -> pack (-side=>'left')
, -balloonmsg => "Show observed arrivals");
$balloon->attach(
$mw -> Checkbutton (-text => "Calc", -variable => \$PicksCalButton,
-indicatoron => 0,-selectcolor => '', -pady => '4',
-command => [\&_set, "PicksCal", \$PicksCalButton], -state => 'normal') -> pack (-side=>'left')
, -balloonmsg => "Show calculated arrivals from RAYINVR");
$balloon->attach(
$mw -> Checkbutton (-text => "Rays", -variable => \$ShowRaysButton,
-indicatoron => 0,-selectcolor => '', -pady => '4',
-command => [\&_set, "ShowRays", \$ShowRaysButton], -state => 'normal') -> pack (-side=>'left')
, -balloonmsg => "Show calculated ray-paths from RAYINVR");
i_DrawButtonsPhases();
i_DrawButtonsStations($stationlb);
}
sub i_DrawButtonsStations{
=PROGhead2 i_DrawButtonsStations(stationlb)
Draws station buttons and station selector. Needs list as argument to
enter stations
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
###############################################################
# Buttons for selecting STATIONS for raytracing and plotting
###############################################################
my $stationlb = shift;
my $stationbuttons = $mw -> Frame(-label => "Stations:", -labelPack => [-side => "left", -anchor => 'nw'])
-> pack(-side=>'bottom', -anchor => 'w', -after => $cns);
# Frame for first line
my $f1 = $stationbuttons -> Frame->pack(-side=>'top', -anchor => 'w');
# Frame for second line
my $f2 = $stationbuttons -> Frame->pack(-side=>'top', -anchor => 'w');
my $fr = $f1; # Frame to put button to
# Station are sorted after their profile position
my @stations = sort{$a <=> $b}(keys(%{$model->{stationkm}}));
#print "(D) Draw x stations ".@stations." = km @stations\n" if $debug;
####################
# Stationbuttons
my $i = 0;
my $stationsperline = $CONFIG{stationsperline};
#print "(DEV) Draw Stationbuttons\n" if $dev;
foreach my $km ( @stations) {
$i++;
my $name = $model->{stationkm}{$km};
#print "(D) Draw $i. station button $name at km $km\n" if $debug;
# Define stationnames for second row
#if ($name =~ /^[0-9]*$/ && $name > 200) {
if ($i >= $stationsperline ) {
#print "Second frame\n";
$fr = $f2;
} else {
$fr = $f1;
}
#if ($name !~ m/[sS]tr*/){
# Attach shot number as given by rayinvr
# Find all shots at given km
my @shot = grep {$RIN->{xshot}[$_] == $km} 0 .. $#{$RIN->{xshot}};
#print "Give km $km shotnumber @shot\n";
if ( @shot > 1 ) {
print "\n\nWARNING !!\n\n You have km $km ".@shot."-times in ".
"your r.in. This leads may lead to ugly plots\n";
}
#print "(D) Create button for station >$name< with variable >$stationlist{$name}[3]< if shot[0] $shot[0]\n" if $debug;
$balloon-> attach (
$fr -> Checkbutton (-text => $name, -variable => \$stationlist{$name}[3],
-command => [\&b_drawStation, $name], -font => "Helvetica 8",
-indicatoron => 0, -selectcolor => '', -padx => '5')
-> pack (-side=>'left')
, -balloonmsg=> "km $km, shot ".($shot[0]+1)) if @shot; # Print button only, if station is in rayinvrs r.in xshot list
#} else {
#print "Do not draw button for this station. It matches a streamer name.\n"
#."Call the programmer. This is a bug \n";
#}
}
#my $stationlb = $mw-> LabOptionmenu (
#-label => 'Station',
#-labelPack => [-side => 'left'],
#-variable =>\$station, -command=>\&b_changeStation,
#-width => "8"
#)-> pack (-side=>'left');
# Add station to station selector (for ZP)
foreach (sort(keys(%stationlist))){
$stationlb -> insert('end', $_);
#$stationlb -> insert('end',$stationlist{$_}[0]);
#print "Add Option $_ $stationlist{$_}[0]\n";
#$stationlb -> addOptions([$stationlist{$_}[0] => $_]);
}
$station = (sort(keys(%stationlist)))[0];
}
sub i_DrawButtonsPhases {
=PROGhead2 Phasebuttons
Phasebuttons are drawn for each phase in the phasecolor-hash. RAYSTATUS
gets initialized
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
######################################################################
# GUI BUTTONS for PHASES to draw
# Model-Region
my $raybuttons = $mw -> Frame( #-label => "Raycodes"# \nAdditionals: "
labelPack => [-side => 'left', -anchor=>'w']) -> pack(-side=>'bottom', -anchor => 'w', -after => $cns);
my $raycodeButtons = $raybuttons-> Frame() -> pack(-side=>'top', -anchor => 'w');
my $phasecodesButtons = $raybuttons-> Frame() -> pack(-side=>'top', -anchor => 'w');
$raycodeButtons ->Label(-text => "Traced rays", -width => '13', -anchor=>'nw')->pack(-side => 'left', -anchor=>'nw');
$phasecodesButtons->Label(-text => "Picked phases", -width => '13', -anchor=>'nw')->pack(-side => 'left', -anchor=>'nw');
my $frame;
my $ph = -1;
my $rcodes = $CODES->get('raycodes');
my $phcodes = $CODES->get('phasecodes');
# Check if number of phasecodes in r.in is larger than traced rays
# Add excess phases to additional Phases
if ( @$rcodes < @$phcodes ) {
# More phasecodes in r.in than traced rays.
print "i_DrawButtonsPhases() Rays and phases in r.in have different length\n";
push @ADDITIONALPHASES, @{$phcodes}[$#$rcodes+1 .. $#$phcodes];
}
# Add raycodes
for ( my $i = 0; $i <= $#$rcodes; $i++ ) {
my $ray = $rcodes->[$i];
my $ph = $phcodes->[$i];
my $message = "Rays";
my ($l, $t) = split(/\./, $ray); # layer.type
#print "Button for ray >$ray<, split to >$l< and >$t<, phase >$ph<\n";
$frame = $raycodeButtons;
unless ( $ray =~ m/\./ ) {
# This should not happen. No phasecodes should be in the raycode-hash of rayinvr
print "WARNING!! The programm should never reach this point."
."Please let the programmer now and send the used r.in\n";
$message = "Additional Phase";
$frame = $phasecodesButtons;
} else {
if ($t == 1) { $message = "Refracted in layer ".($l+0);}
if ($t == 2) { $message = "Reflected in layer ".($l);}
if ($t == 3) { $message = "Headwave in layer ".($l+1);}
if ($t == 4) { $message = "Water multiple of reflection in layer ".($l);}
#print ".$model->getCode( 'phase' => $c)".$model->getCode( 'phase' => $c);
# No phasecode defined for this ray??
$ph = " not defined (set 'ivray' in r.in )" unless ( $ph );
$message .= ". raycode = $ray, phasecode = $ph";
}
#print "@t: Layer: $t[0], Type $t\n";
my $label;
#print "Color for ray >$ray< $PHASECOLORS{$ray}\n";
$balloon->attach(
$frame -> Checkbutton (-text => $ray, -variable => \$RAYSTATUS{$ray}, -indicatoron => 0, -padx => '5',
#-command => \&b_drawAll, -selectcolor=>$PHASECOLORS{$_})
-font => "Helvetica 8", -width => 2,
#-command => [\&b_drawPhase, $ray, $ph],
-command => sub {
$RAYSTATUS{$ph} = $RAYSTATUS{$ray};
$model->drawPhase("ray", [$ray, $RAYSTATUS{$ray}], "phase", [$ph, $RAYSTATUS{$ray}]);
},
-selectcolor=>$PHASECOLORS{$ray}
)
-> pack (-side=> 'left')
, -balloonmsg=> "$message" )
;
# Reset old status for buttons read from p.status (saved in DRAWNPHASES)
#my $phase = $_;
my $switch = (grep {$_ eq "$ray"} @DRAWNRAYS)? 1 : 0;
#print "grep $_ in DRAWNPHASES = @DRAWNPHASES, switch = $switch\n";
$RAYSTATUS{$ray} = $switch; # Initialize this buttonvariable
$RAYSTATUS{$ph} = $RAYSTATUS{$ray};
} # Add raycodes
# Add additional phasecodes without corresponding raycodes
foreach my $ph ( @ADDITIONALPHASES ) {
my $message = "Phasecode without traced rays";
my $ray = '-';
$frame = $phasecodesButtons;
$balloon->attach(
$frame -> Checkbutton (-text => $ph, -variable => \$RAYSTATUS{$ph}, -indicatoron => 0, -padx => '5',
#-command => \&b_drawAll, -selectcolor=>$PHASECOLORS{$_})
-font => "Helvetica 8", -width => 2,
#-command => [\&b_drawPhase, $ray, $ph],
#-command => [\&b_drawPhase, $ph],
-command => sub {
$model->drawPhase("phase", [$ph, $RAYSTATUS{$ph}]);
},
-selectcolor=>$PHASECOLORS{$ph}
)
-> pack (-side=> 'left')
, -balloonmsg=> "$message" )
;
#TODO: RAYSTATUS initialization can be moved to its own sub and
# just used here. Best init is right after reading status file
# Reset old status for buttons read from p.status (saved in DRAWNPHASES)
my $switch = (grep {$_ eq "$ph"} @DRAWNRAYS)? 1 : 0;
#print "(DEV) grep $ph in DRAWNPHASES = @DRAWNPHASES, switch = $switch\n" if $dev;
$RAYSTATUS{$ph} = $switch; # Initialize this buttonvariable
} # foreach ADDITIONALPHASES
$RAYSTATUS{'-'} = 0;
#print Dumper \%RAYSTATUS;
}
sub i_MenuBar {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Make MENUs
# Make menubar
my $menubar = $mw->Menu(-type => 'menubar', -borderwidth => 1);#->pack(-side => 'top', -fill => 'x');
$mw->configure(-menu => $menubar);
#####################################3
# FILE MENU
my $f = $menubar->cascade(-label => '~File', -tearoff => 0);
$f->command(-label => 'Open files ..', -command=> \&b_openfiles,
-image => $mw->Getimage("openfile"), -compound => "left");
$f->command(-label => 'Edit r.in', -command=> \&b_editRin);
#$f->command(-label => 'Edit ALL velocity nodes', -command=> \&m_editVNodes);
#$f->command(-label => 'Edit marked models', -command=> \&b_editMarkedmodels);
$f->command(-label => 'Reload v.in', -command=> \&b_reload);
$f->command(-label => 'Reload tx.in', -command=> \&b_reloadTx);
#$f->command(-label => 'Go to version ..', -command=> \&b_gotoVersion);
$f->command(-label => 'Export rays&picks', -command=> \&b_export);
$f->command(-label => 'Export velocity nodes', -command=> [\&model::writeXZV, $model]);
$f->command(-label => 'Export layer polygons', -command=> [\&model::exportPolygons, $model]);
$f->command(-label => 'Extract 1D velocity profiles', -command=> \&b_extract);
$f->command(-label => 'Export resolution', -command=> [\&model::resolution, $model]);
$f->command(-label => 'Export igmas model', -command=> \&b_igmas);
$f->command(-label => 'Export density model', -command=> [\&model::writeVin, $model,'file',"rho.in"]);
$f->separator;
$f->command(-label => 'Edit PRay configuration', -command=> \&b_configEdit);
$f->command(-label => 'Quit', -command=> \&b_quit);
#####################################3
# MODEL MENU
my $edit = $menubar->cascade(-label => '~Edit model', -tearoff => 0);
$edit->command(-label => 'Edit model setup', -command=>
# sub {print "Hello World\n" });
\&m_editModel);
$edit->command(-label => 'Edit ALL velocity nodes', -command=> \&m_editVNodes);
$edit->command(-label => 'Set partial derivatives for all v nodes', -command => [\&model::editAllParDerivs, $model, 1]);
$edit->command(-label => 'Unset partial derivatives for all v nodes', -command => [\&model::editAllParDerivs, $model, 0]);
$edit->command(-label => 'Edit marked models', -command=> \&b_editMarkedmodels);
$edit->command(-label => 'Go to version ..', -command=> \&b_gotoVersion);
#####################################3
# COMMAND MENU
my $commandmenu = $menubar->cascade(-label => '~Commands', -tearoff => 0);
$commandmenu->command(-label=>'vmodel', -command=> \&b_vmodel);
$commandmenu->command(-label=>"c2v", -command=> \&b_c2v, -state => 'normal');
$commandmenu->command(-label=>"v2c", -command=> \&b_v2c, -state => 'normal');
$commandmenu->command(-label=>"View contours.ps ", -command=> \&b_viewContours,-state => 'normal');
$commandmenu->command(-label=>'View model differences', -command=> \&b_modelDifferences);
$commandmenu->command(-label=>'Make resolution plot', -command=> \&b_resolution);
=USERhead3 User defined commands
User defined commands/scripts can be added to 'Commands'-menu with p.conig
e.g. add script plotMyModel.csh with
command = Plot Model = $BIN/plotMymodel.csh
C<$BIN> can be an environment variable.
=cut
# Add user defined commands from $CONFIGFILE
if(defined $CONFIG{command} && $CONFIG{command} > 0 ){
$commandmenu->separator;
print "User defined commands added to menu\n" unless $quiet;
foreach my $command (@{$CONFIG{command}}){
my ($label, $cmd) = split (/=/, $command);
print "Add '$label' and command >$cmd<\n" unless $quiet;
$commandmenu -> command (-label=>"$label", -state => 'normal',
-command => sub {
defined( my $pid = fork ) or die "Cannot fork: $!";
unless( $pid ) {
system("$cmd");
warn "\nleaving child";
CORE::exit(0);
}
print ">$cmd< is running\n";
});
}
}
#####################################3
# PHASE MENU
my $phasesmenu = $menubar->cascade(-label => '~Phases', -tearoff => 0);
$phasesmenu->checkbutton(-label => "All", -command =>\&b_AllRays, -variable => \$allRaysButton);
$phasesmenu->checkbutton(-label => "Reflections", -command => \&b_AllRfl, -variable => \$allRflButton, -selectcolor=> "white");
$phasesmenu->checkbutton(-label => "Refractions", -command => \&b_AllRfr, -variable => \$allRfrButton, -selectcolor=> "white");
$phasesmenu->checkbutton(-label => "Multiples", -command => \&b_AllMul, -variable => \$allMulButton, -selectcolor=> "white");
$phasesmenu->separator;
$phasesmenu->command(-label => "Find phases", -command => \&b_getPhases,);
#####################################3
# VIEW MENU
my $viewmenu = $menubar->cascade(-label => '~View', -tearoff => 0);
$viewmenu->command (-label => "Show comments", -command => \&b_viewComments);
$viewmenu->command (-label => "Show results", -command => \&b_viewResults);
$viewmenu->checkbutton(-label => "Show nodes", -command => [\&model::set, $model, "nodes", \$showNodes], -variable =>\$showNodes);
$viewmenu->command (-label => "Show model status",-command => [\&b_status]) ;
$viewmenu->command (-label => "Show model status in range",-command => \&b_status_range) ;
$viewmenu->checkbutton(-label => 'Show blocks', -command => [\&model::set, $model, "blocks", \$showBlocks], -variable =>\$showBlocks);
$viewmenu->checkbutton(-label => 'Show v-nodes', -command => [\&model::set, $model, "vnodes", \$showVNodes], -variable =>\$showVNodes);
$viewmenu->checkbutton(-label => 'Annotate v-nodes',-command => [\&model::set, $model, "annotvnodes",\$annotVNodes], -variable =>\$annotVNodes);
$viewmenu->checkbutton(-label => 'Show gradients', -command => [\&model::set, $model, "vgrid", \$showGrid], -variable =>\$showGrid);
$viewmenu->checkbutton(-label => 'Show contourlines', -command => [\&model::set, $model, "contours", \$showContours],-variable =>\$showContours);
$viewmenu->checkbutton(-label => 'Colored contours?', -command => [\&model::set, $model, "contourcolor", \$contourcolor],-variable =>\$contourcolor);
# Tomo2D related commands
if (defined $CONFIG{tomoGrid} && (defined $CONFIG{tomoPhase} || defined $CONFIG{tomoPhasePg})){
$viewmenu->checkbutton(-label => 'Show Tomo grid',
-command => [\&model::tomo, $model, "tomoGrid", \$showTomoGrid],
-variable =>\$showTomoGrid);
$viewmenu->checkbutton(-label => 'Show tomo contours',
-command => [\&model::tomo, $model, "tomoContours", \$showTomoContours],
-variable =>\$showTomoContours);
}
# Show densities
my $showDensities = 0;
$viewmenu->checkbutton(-label => 'Annotate densities', -command => [\&model::set, $model, "densities", \$showDensities], -variable =>\$showDensities);
# Show resolution
my $showResolution = 0;
$viewmenu->checkbutton(-label => 'Annotate resolution', -command => [\&model::set, $model, "resolution", \$showResolution], -variable =>\$showResolution);
# Are xz-files to be overlayn in modelspace?
if (defined $CONFIG{xz}) {
my $showXZButton = 1;
$viewmenu->checkbutton(-label => 'Show xz overlay', -command => [\&model::set, $model, "xz", \$showXZButton], -variable =>\$showXZButton);
}
# Are xt-files to be overlayn in modelspace?
if (defined $CONFIG{xt}) {
my $showXTButton = 1;
$viewmenu->checkbutton(-label => 'Show xt overlay', -command => [\&model::set, $model, "xt", \$showXTButton], -variable =>\$showXTButton);
}
$menubar->separator;
#####################################3
# HELP MENU
my $help = $menubar->cascade(-label => ' ~Help', -tearoff => 0,
-image => $mw->Photo(-file => "$ICONS/pray2.gif", -width => 18, -height => 14)
, -compound => "left",
);
$help->command(-label => "User documentation", -command => \&b_help);
$help->command(-label => "User documentation - html", -command => \&b_helpHTML) if ( $CONFIG{browser} );
$help->command(-label => "About", -command => \&b_about);
}
sub i_Messages {
=PROGhead2 i_Messages()
Collects messages during initialization
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $msg = shift;
$INITMSG = $INITMSG.$msg;
}
sub i_checkPRayVersion {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
#return unless ( $STATUS{PRayVersion} );
my ($PRayVersion, $msg) = version::check($STATUS{PRayVersion});
# If PRayVersion is not set, do not display update news. A not set
# PRayVersion variable means, that not p.status is present (e.g. for
# a brand new rayinvr directory.
if (-f "p.status" && $msg) {
$mw->withdraw();
my $m = $mw->Dialog( #-popover => $mw,
-title => "Update news",
-text => $msg,
#-width => 75,
-wraplength => '6i',
-buttons => ['Ok']
);
$m->Show;
}
$STATUS{PRayVersion} = $PRayVersion;
}
###################################
# GUI subroutines
####
sub zoomCanvasInit {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Clean up measure stuff (if present)
$cns->delete('MEASURE');
my $type = $_[1];
my $x = $cns->canvasx($Tk::event->x);
my $y = $cns->canvasy($Tk::event->y);
my $xt = $lzd->canvasx($Tk::event->x);
my $yt = $lzd->canvasy($Tk::event->y);
#print "zoomCanvasInit()\n";
@zoomRectCoords = ( $x, $y, $x, $y) if ($type eq 'm');
@zoomRectCoords = ($xt, $yt, $xt, $yt) if ($type eq 't');
print "(DEV) Zoom rectangle called from >$type< ".
"model >@zoomRectCoords< lzd xt $xt yt $yt\n" if $dev;
$zoomRect = $cns->createRectangle(
zoomReverseT(@zoomRectCoords, $type, "m"),
-outline => 'red',
-tags => ['ZOOM'],);
$zoomRectzeit = $lzd->createRectangle(
zoomReverseT(@zoomRectCoords, $type, "t"),
-outline => 'red',
-tags => ['ZOOM'],);
}
sub zoomReverseT {
#
# Reverses y-coordinate for time scale, if set
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Function requires input type and output type
# eg model or time depending on the canvas where the mouse pointer is
my ($x, $y, $x2, $y2, $type, $out) = @_;
my @coords = ($x, $y, $x2, $y2);
unless ($out) {
print "BUG!! The output is missing. Do something!!!\n";
return @coords; };
#print "(DEV) zoomReverseT Got coordinates >@coords< and type >$type<, out $out " if $dev;
# Reverse output y if input type and output type are not equal
if ( $type ne $out) {
$coords[1] = $box->[3] - $coords[1] if $CONFIG{reverseTime};
$coords[3] = $box->[3] - $coords[3] if $CONFIG{reverseTime};
}
#print "(DEV) zoomReverseT return >@coords<\n" if $dev;
#print " $coords[3] -= -$box->[3] " if $CONFIG{reverseTime};
return @coords;
}
sub zoomCanvasSize {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $type = $_[1];
# Clean up measure stuff (if present)
$cns->delete('MEASURE');
@zoomRectCoords[2,3] = ($cns->canvasx($Tk::event->x),
$cns->canvasy($Tk::event->y)) if ($type eq 'm');
@zoomRectCoords[2,3] = ($lzd->canvasx($Tk::event->x),
$lzd->canvasy($Tk::event->y)) if ($type eq 't');
$cns->coords($zoomRect => zoomReverseT(@zoomRectCoords,$type, "m"));
$lzd->coords($zoomRectzeit => zoomReverseT(@zoomRectCoords,$type, "t"));
}
sub zoomCanvasFinish {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $type = $_[1];
# Get rectangle coordinats for model and time (respects reversed
# time axis
my @mcoords = $cns->coords($zoomRect);
my @tcoords = $lzd->coords($zoomRectzeit);
# Delete the rectangles.
$cns->delete($zoomRect);
$lzd->delete($zoomRectzeit);
$lzd->delete('ZOOM');
$cns->delete('ZOOM');
$cns->delete('MEASURE');
# Get rectangle size
my $pxl = abs($zoomRectCoords[0] - $zoomRectCoords[2]);
my $pyl = abs($zoomRectCoords[1] - $zoomRectCoords[3]);
# Was the rectangle big enough?
return if ( $pxl < 10 || $pyl < 10);
# Let's find the zooming factor.
my $dx = $cns->width / $pxl;
my $dy = $cns->height / $pyl;
print "(DEV) zoom with dx $dx dy $dy\n" if $dev;
# Make newx smaller value of both
my $newx1 = $zoomRectCoords[0] < $zoomRectCoords[2] ? $zoomRectCoords[0] : $zoomRectCoords[2];
my $newx2 = $zoomRectCoords[0] > $zoomRectCoords[2] ? $zoomRectCoords[0] : $zoomRectCoords[2];
my $newy1 = $zoomRectCoords[1] < $zoomRectCoords[3] ? $zoomRectCoords[1] : $zoomRectCoords[3];
my $newy2 = $zoomRectCoords[1] > $zoomRectCoords[3] ? $zoomRectCoords[1] : $zoomRectCoords[3];
# Sort coords
if ($mcoords[0] > $mcoords[2]){
@mcoords = ($mcoords[2], $mcoords[1], $mcoords[0], $mcoords[3]);
}
if ($mcoords[1] > $mcoords[3]){
@mcoords = ($mcoords[0], $mcoords[3], $mcoords[2], $mcoords[1]);
}
if ($tcoords[0] > $tcoords[2]){
@tcoords = ($tcoords[2], $tcoords[1], $tcoords[0], $tcoords[3]);
}
if ($tcoords[1] > $tcoords[3]){
@tcoords = ($tcoords[0], $tcoords[3], $tcoords[2], $tcoords[1]);
}
# Find new limits for visible canvas (real coordinates)
#my $kmx = $newx1 / $xscale + $CONFIG{xmin};
#my $kmx2 = $newx2 / $xscale + $CONFIG{xmin};
#my $d1m = $newy1 / $yscale + $CONFIG{zmin};
#my $d2m = $newy2 / $yscale + $CONFIG{zmin};
#my $t1 = $newy1 / $ytscale;
#my $t2 = $newy2 / $ytscale;
my ( $km1, $z1, $km2, $z2) = $model->screen2model(\@mcoords,"space");
my ($kmt1, $t1, $kmt2, $t2) = $model->screen2model(\@tcoords,"time");
if ( $t1 > $t2 ) {
my $tmp = $t1;
$t1 = $t2;
$t2 = $tmp;
}
print "(DEV) new limits will be from km $km1 to $km2, depth $z1 to $z2 and time $t1 to $t2\n" if $dev;
#print "(DEV) new limits will be from km $kmx to $kmx2 and".
#"tiefe +mx: $d1m bis $d2m \n".
#"TIME: $t1, $t2\n" if $dev;
# Scale with different scale factors
$cns->scale('all' => 0, 0, $dx, $dy);
$lzd->scale('all' => 0, 0, $dx, $dy);
# Change/scale bounding box
$box->[2]*=$dx;
$box->[3]*=$dy;
#print "Spezial $_ for @{$box}\n";
# Resize the canvas (scrollregion).
$cns->configure(-scrollregion => $box);
$lzd->configure(-scrollregion => $box);
# Now we change the view to center on correct area.
my $xmove = $mcoords[0] * $dx / $box->[2];
my $ymove = $mcoords[1] * $dy / $box->[3];
my $ytmove = $tcoords[1] * $dy / $box->[3];
# my $dx = $cns->width / $pxl;
# $xmove = $mcoords[0] * $dx / $box->[2];
# $xmove = $mcoords[0] * ($cns->width / $pxl) / $box->[2]
# $pxl = abs($zoomRectCoords[0] - $zoomRectCoords[2]);
# $xmove = $mcoords[0] / $pxl)
print "(DEV) move view to xmove $xmove ymove $ymove ytmove $ytmove\n" if $dev;
$cns->xviewMoveto($xmove);
$cns->yviewMoveto($ymove);
$lzd->xviewMoveto($xmove);
$lzd->yviewMoveto($ytmove);
print "(DEV) yscales $yscale\n" if $dev;
# Calculate new scale factors
$yscale *= $dy;
$ytscale *= $dy;
$xscale *= $dx;
print "(DEV) Updated yscales $yscale\n" if $dev;
$yscale = $box->[3]/($totaldepth);
$ytscale = $box->[3]/($CONFIG{tmax} - $CONFIG{tmin}); # Scalefacto
$xscale = $box->[2]/$profilelength;
print "(DEV) Updated yscales $yscale\n" if $dev;
$model->updateScale("yscale" => $yscale, "ytscale" => $ytscale, "xscale" => $xscale,
"km1" => $km1, "km2" => $km2, "d1" => $z1, "d2" => $z2, "t1" => $t1, "t2" => $t2);
push @$zoomhistory, \@zoomRectCoords;
#print "Dump zoomhistory\n";
#print Dumper $zoomhistory;
}
sub zoomOriginal {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
$xscale = $canvaswidth/$box->[2];
$yscale = $canvasheigth/$box->[3];
$cns->scale('all' => 0, 0, $xscale, $yscale);
$lzd->scale('all' => 0, 0, $xscale, $yscale);
$box = [0, 0, $canvaswidth, $canvasheigth];
$cns->configure(-scrollregion => $box);
$lzd->configure(-scrollregion => $box);
# Update scalefactors (or reset to original)
$yscale = $box->[3]/($totaldepth);
$ytscale = $box->[3]/($CONFIG{tmax} - $CONFIG{tmin});
$xscale = $box->[2]/$profilelength;
#print "Updated yscales in ZoomOriginal: $yscale\n";
# Remove additional axes
#for (my $i=0; $i <= $#drawnAxes; $i++){
#$lzd->delete($drawnAxes[$i]);
#undef $drawnAxes[$i];
#}
#print "In axes array: @drawnAxes\n";
#$model->updateScale("yscale" => $yscale, "ytscale" => $ytscale, "xscale" => $xscale);
$model->updateScale("yscale" => $yscale, "ytscale" => $ytscale, "xscale" => $xscale,
"km1" => $CONFIG{xmin}, "km2" => $CONFIG{xmax}, "d1" => $CONFIG{zmin}, "d2" => $CONFIG{zmax},
"t1" => $CONFIG{tmin}, "t2" => $CONFIG{tmax});
}
sub zoomIn {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
print "Zooming in\n";
}
sub zoomOut {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
print "Dump zoomhistory\n";
print Dumper $zoomhistory;
my @zoomHist = @{shift @$zoomhistory};
print "Zoom out to @zoomHist\n";
#return;
#COPIED PART FROM ZOOMCANVASFINISH:
# Was the rectangle big enough?
return if abs($zoomHist[0] - $zoomHist[2]) < 10 ||
abs($zoomHist[1] - $zoomHist[3]) < 10;
# Let's find the zooming factor.
my $dx = $cns->width /abs($zoomHist[0] - $zoomHist[2]);
my $dy = $cns->height /abs($zoomHist[1] - $zoomHist[3]);
my $pyl = abs($zoomHist[1] - $zoomHist[3]);
my $pxl = abs($zoomHist[0] - $zoomHist[2]);
#print "------------------\nZooomrec: @zoomRectCoords\n";
#print "Neue laenge: y? $pyl x? $pxl dx $dx box @$box cns ".$cns->width." \n";
#print "Using xscales: $xscale\n";
#print "km start: \n";
# Make newx smaller value of both
my $newy = $zoomHist[1] < $zoomHist[3] ? $zoomHist[1] : $zoomHist[3];
my $newx = $zoomHist[0] < $zoomHist[2] ? $zoomHist[0] : $zoomHist[2];
my $newy2 = $zoomHist[1] > $zoomHist[3] ? $zoomHist[1] : $zoomHist[3];
my $newx2 = $zoomHist[0] > $zoomHist[2] ? $zoomHist[0] : $zoomHist[2];
my $kmx = $newx/$xscale;
my $kmx2 = $newx2/$xscale;
my $d1m = $newy /$yscale+$CONFIG{zmin};
my $d2m = $newy2/$yscale+$CONFIG{zmin};
my $t1 = $newy /$ytscale;
my $t2 = $newy2 /$ytscale;
#print "Von $kmx bis $kmx2 laenge,\n".
#"tiefe +mx: $d1m bis $d2m \n".
#"TIME: $t1, $t2\n";
# Scale with different scale factors
$cns->scale('all' => 0, 0, $dx, $dy);
$lzd->scale('all' => 0, 0, $dx, $dy);
# Change bounding box
$box->[2]*=$dx;
$box->[3]*=$dy;
#print "Spezial $_ for @{$box}\n";
# Resize the scrollregion.
$cns->configure(-scrollregion => $box);
$lzd->configure(-scrollregion => $box);
# Now we change the view to center on correct area.
my $xmove = $zoomHist[0] < $zoomHist[2] ? $zoomHist[0] : $zoomHist[2];
my $ymove = $zoomHist[1] < $zoomHist[3] ? $zoomHist[1] : $zoomHist[3];
$xmove *= $dx / $box->[2];
$ymove *= $dy / $box->[3];
$cns->xviewMoveto($xmove);
$cns->yviewMoveto($ymove);
$lzd->xviewMoveto($xmove);
$lzd->yviewMoveto($ymove);
$yscale = $box->[3]/($totaldepth);
$ytscale = $box->[3]/($CONFIG{tmax} - $CONFIG{tmin}); # Scalefacto
$xscale = $box->[2]/$profilelength;
#print "Updated yscales in zoomFinish: $yscale\n";
$model->updateScale("yscale" => $yscale, "ytscale" => $ytscale, "xscale" => $xscale,
"km1" => $kmx, "km2" => $kmx2, "d1" => $d1m, "d2" => $d2m, "t1" => $t1, "t2" => $t2);
}
sub _printStatusMessage {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $msg = shift;
$stline->insert ('end', "$msg");
$stline->see('end');
}
sub _setWindowTitle {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
my $title = "$PROG: Model: $DIR - version: $VERSION";
$title .= " $COMMENTS{$VERSION}" if ($COMMENTS{$VERSION});
$mw->title($title) if ($mw );
}
sub _historyAdd {
printf "(T) %s(@_)\n", commons::whoami() if $tree;
# Copys v.in with $VERSION-number into history-folder for undo-button
# and increases $VERSION-number
print "Add <$VERSION> version\n";
_setWindowTitle();
# Check for folder existence
unless (-d "history") {
# create subdirectory for history if it's not already there.
print "Creating directory for history-files\n";
mkdir 'history' or die $!;
}
# Copy v.in with $VERSION as versionnumber/historyindex into "history"-folder
copy ("v.in", "history/v.$VERSION");
$VERSION++;
=PROGhead2 _historyAdd()
- Update title $VERSION
- copy v.in v.$VERSION
- $VERSION++
=cut
=USERhead3 Version control
PRay keeps track of model versions you've written with PRay (using button "C<Write v.in>").
C<v.in>-Files are stored in the subdirectory C<history>, which can be deleted if you want to restart
from version 0.
To navigate through your versions use arrow buttons diplayed in the toolbar or go to a special
model version using 'C<< File->Go to version .. >>'
Versions above current (which is shown in windowtitle) can be deleted when exiting with
PRay's File-Menu->Quit (user is asked). During start up the last
version is compared with current C<v.in> in your working directory and differences are reported.
You can mark special version with the 'Mark'-button and navigate between them with the fastforward
and fastbackward buttons. This list is stored in file F<p.status> so PRay can read it back at next startup.
To remove marked models either edit this file when PRay is not running or via File-menu->Edit marked models.
=cut
}
sub _GetVersionNumber {
=PROGhead3 C<_GetVersionNumber>
Returns last version in history directory
=cut
printf "(T) %s(@_)\n", commons::whoami() if $tree;
opendir(DIR, "$DIR/history") or return 0; # $DIR is global and your `cwd`
my @dots = grep { /^v\.\d+/ && -f "$DIR/history/$_"} readdir(DIR); # find all v.X-files
closedir(DIR);
my $i = 0;
# Find highest backup-number
foreach my $file (@dots) {
my @a = split(/\./ , $file);
if ($a[1] > $i) { $i = $a[1];}
#print "F $file, $a[1]\n";
}
print "Last version found in history is $i\n";
print "Current version is $VERSION\n";
# Check if v.in and v.$VERSION are different:
if (compare("v.in","history/v.$i") == 0) {
print "v.in is equal to history/v.$i\n";
} else {
print "####################################################\n".
"# WARNING !! \n".
"# Your v.in is not the same like your last version \n".
"# in history/v.$i \n".
"####################################################\n";
i_Messages("\nYour v.in is not the same like your last version in history/v.$i");
#$i = "-1";
#print "v.in is not equal to your last file in history v.$i\n";
#print "What shall I do?\n";
#print "[1]: Copy v.$i to v.in and start with that version\n";
#print "[2]: Start with this v.in and copy it to history v.$i+1\n";
#print "[3]: Die\n";
#print "Any other answer will just continue the programm\n";
#my $answer = <>; # Get answer
#if ($answer == 1) {
#print "[1]: Get last version file and overwrite v.in\n";
#copy ("history/v.$i", "v.in");
#} elsif ($answer == 2 ) {
#$i++;
#copy ("v.in", "history/v.$i");
#print "[2]: Copied v.in to v$i\n";
#} elsif ($answer == 3 ) {
#print "Leaving you now. I haven't touched anything\n";
#die;
#} else {
#print "I'm doing nothing. Just continue with v.in and don't copy anything anywhere\n";
#}
}
return $i;
}
my $logfile = "history/edits.log";
=USERhead3 Overlay xz lines in model space
Users can define xz files in C<<p.config>> ( C<< xz = xzfilename [color] >>, which are read and overlayn in
model space. File format is plain text with x and z columns. Several file can be configured by repeating the whole
option.
Lines can be switched in C<View>-menu. Same procedure for xt.
=USERhead3 Links to gravity modelling
PRay can annote velocity nodes with correspondig density values. Conversion table is taken from
I<Barton(1986) "The relationship between seismic velocity and density in the continental crust - a useful constraint?">
It has also a limited function in C<< Menu->File >> to create a starting model in IGMAS structure format. !! This function is still under development
and some stuff is hardwired for the authors model !! If you want to use it, contact the author, please.
=USERhead2 What else to say?
=head3 HOW TO ..
a. .. add stations to your model
Include them in you statxz-file. See L</statxz>
=head3 Error Messages
No r2.out? Check your rayinvr-Settings in r.in
Unfortunately, the programm is a bit picky about the numbers of digits used as position for xshot and obs positions in statxz. If
they don't have three digits behind the comma, it can't recognize that it's the same (sorry about that). This problem solves itself
once you have read and saved r.in via the file-menu. It read's in your complete r.in and writes it in the format it likes the numbers.
You'll probably have your own kind of formatting for r.in. This will be lost. But if everything goes right, you have a nice GUI for editing
and don't need to count lines any more.
None of your setting will be lost though. The type of variables is not changed. None are added or disgarted.
If you need more switches in the GUI let me know. I didn't want to stuff the window with things I don't need.
=head4 r.in - Errors
Following error
tfromm@gsysm194:20110100/rayinvr/b> rayinvr
> namelist read: read unexpected character
> apparent state: unit 10 named r.in
> last format: list io
> lately reading direct formatted external IO
> Abort
occours then arrays like (ray, ivray,..) are too long. The allowed size seems to vary with your OS and type of programm. xrayinvr can handle
more elements on a Mac than rayinvr. It doesn't make a difference on Solaris.
=head4 No or not all phases in tx.out?
check your setting for itxout in r.in. It has to be either 2 or 3. 3 should interpolate
to receiver position and can cause failure to write out
a phase to tx.out. Try itxout=2 in that case.
Also check the rayinvr manual
=cut
=head2 Changes
25.01.13
- new config option r2out for format of first column of r2.out file
- new config option ttbg for color of traveltime background
- allowing PRay to start, even without the existence of r2.out
- returning status message, if no r2.out can be opened
- taking out config option for profilelength
They were overridden by r.in anyway.
26.01.13
- config options maxheight and maxdepth are replaced with zmin and zmax
if those are defined, they overwrite values from r.in
31.01.13
- PRay writes v.in directly
11.02.13
- Model versions can be marked for faster navigation
15.02.13
- Linien und Achsen ueber das Komplette Model beim Zoomen zeichnen
17.02.13
- Pinch layers
20.02.13
- Pinched nodes can be moved together
22.02.13
- New config value in p.config for files to open:
files = c.in v.in p.config ..
- tx-files may have no phasenumber in the lines starting stations
06.03.13
- Marked models are saved in p.status and list is read at startup
- version is saved in p.status so PRay knows which version is used if
it's not equal to last version in history-directory
- Contour plot is also written to file contours.ps
- Fixed bug: contours were not updated when writing v.in
- If no version in marked models is found, taking first or last model in
array. -> Circular list
07.03.13
- Marking a model writes contourplot and r1.out into history folder
08.03.13
- New button for copying current model to last version found in
history-dir plus 1.
14.03.13
- Added splash screen for startup. Enable with splash = 1 in p.config
15.03.13
- 'Edit phases' is indepentend from station now. One window can be kept
for changing phases of different stations.
- Enable 'Edit phases' only if zpdir and zp2ray are configured in p.config
26.03.13
- Add function for extracting 1D velocity profiles to File-Menu->Extract ..
31.03.13
- User can add self defined commands and script to 'Commands'-Menu
via p.config: command your Label is bla = /path/to/your/script/script.sh
21.06.13
- No p.config necesseray
12.07.13
- Remember status of station and phase button when quitting
17.07.13
- drawing of arrivals is configurable (eg: txin = dash, line)
- Add comments to model versions (Written to file comments.txt which may
be edited by the user when PRay is not running. Keep format!!)
View comments via Menu->View->Show comments
- Edit several depth nodes at once
- Switch all stations and phases in rin-editor
18.07.13
- Edit comments when clicking them in overview
25.07.13
- View-Show Results can display rayinvrs tracing results
- Dash width for picks reduced
26.07.13
- BugFix: Reduction time wasn't applied, when starting PRay
- Manual picks can be drawn as crosses
31.07.13
- Resolution from d.out can be read and exported in v.in-format
- Added switch for overwriting exported rays
01.08.13
- Resolution file is automatically written after running dmplsqr
- Quitting PRay can be canceled now
02.08.13
- PRay writes comments when running dmpl
- Add export of velocity nodes to resolution
07.08.13
- PRay exports reflection points
- Resulution values are checked (between 0 and 1?)
13.08.13
- Added comment button
01.09.13
- Added File->Reload tx.in
02.09.13
- Model can start at negative km
12.09.13
- Added export function for xzv file with velocity information
15.09.13
- Change snap function. Now new nodes are added to the other layer at
the position of start and end node
21.09.13
- Velocity nodes can get a label
06.10.13
- Measure rms velocity of reflections
11.10.13
- Overlay xz file in model diagram
21.10.13
- Change default export directory to data. Creates dir if necessary
24.10.13
- Overlay xt file in traveltime diagram
08.11.13
- Export model in IGMAS structure format (still under development!)
- Annotate velocity nodes with densities
09.05.14
- Add option for html-help of p_readme in help menu
16.06.14
- Switch picks for left and right shots
17.05.14
- Better error messages for overflown r2.out
- xz/xt can handle comments with #
18.06.14
- Config r2out not necessary any more
- Bugfix: Don't add two velocity nodes at the same position
- Bugfix: Deal with vnodes at only one boundary
24.06.14
- Bugfix: deal with negative xmin and tmin
28.06.14
- Bugfix: Write v.in with vnodes on only one boundary
- Remove r2out from p.config
- Bugfix: Axes ticks corrected for negative xvalues
- Buxfix: Take xmax from r.in to read v.in
07.07.14
- Graphically edit p.config
08.07.14
- Bug fix: Changed shebang
09.07.14
- Added phase-search to Menu Phases
- Bugfix: comments in title
10.07.14
- Added 'stationsperline' to p.config
11.07.14
- Density and resolution models are also exported into export-directory (p.config)
- Fixed bug in exporting densities (!! big bug )
22.07.14
- Bugfix: Deleting old 1D velocity profiles
- Bugfix: Name vd-files with km013.. for correct sorting
- Report statistics about velocity nodes in a special km range
- Installation of Statistics::Basics module necessary
23.07.14
- Extract velocities become non-blocking
24.07.14
- Bugfix: 1D-vd export can handle zeros in velocities
- Add rayinvr shotnumber in popup help for stations
25.07.14
- Add button for going to last model
27.07.14
- Added a bit buggy button for grey contourlines. +Fixed contourline labe
28.07.14
- Bugfix: Edit phases with three digits
09.08.14
- Clean up station drawing routines. Delete calculated picks, when changing
the model, but keeping data, when rayinvr is run on the same model with
less stations
29.09.14
- Added r.in check function if no p.status is present
- Fixed resolution write bug
30.09.14
- Added complete resolution plotting routine
22.12.14
- Working on compatibility with rayinvr examples
(removed zshot, add start nodes to model xmin)
- TODO: ishot = -1
04.01.15
- Fixed ishot = -1 issue. Automatically replace it with 2. No single
left and right selection possible
- stationname in statxz file remains the same as in file (before, some
digits and letters were suppressed, e.g. 100st137 -> 137)
- statxz is not needed or created automatically andy more
05.01.15
- Added variable for PRay version and displays messages if action is
required after an update
- Added red color for nodes with fixed gradient/thickness
06.01.15
- BugFix: Exported tt data gets not reduces if button is not enabled
09.01.15
- Several bugfixes related to resolution
- Added menu item for editing model
- Changed behaviour of rayinvr and dmplstsqr button (do not do so much
automatically)
- Added commands for (un)setting all partial derivatives for v nodes
15.01.15
- Exporting absolute and relative position, no matter what is configured
16.01.15
- Add configuration for resolution script
03.02.15
- Sort picks before drawing line (prevents some strange look for traced
arrivals
- Add config for changing pick size
21.02.15
- Moved first and last vnodes more into the screen
23.02.15
- Added user config for reversed time axis
04.03.15
- Several bugs fixed
16.03.15
- Added export-function for layer polygons (gmt readable xz-format)
25.03.15
- BugFix: Picks had not been exported if no ray was traced. Export all
picks now.
26.03.15
- Shortened text buttons
13.04.15
- Removed spaces from unit names for igmas models
- (not updated) added coordinates for p150
14.04.15
- Fixed Bug in Exporting igmas model
- Reduced number of nodes for igmas model
16.04.15
- Added config value for the text size of node annotations
- Updated documentation
22.04.15
- Change velocity density conversion from Barton to Ludwig
02.09.15
- Added basic functions for floating reflectors
27.05.16
- Added routine to create a model if no rayinvr files are present
=cut
CHANGES:
=head2 Known bugs
There are some known bugs I am aware of, but had no time to fix them. If you
find bugs not listed here, please notify me.
=over
=item *
RMS measure on the left side of a station has problems for large offsets
=item *
Environment variables entered in the graphical p.config editor are not
accepted.
=for comment
Don't run rayinvr after changin model version
=back
=cut
=head2 Requested features (TODO-List)
=over
=item *
Add user config for number of digits of measured apparent velocity and
node annotions
=item *
Add user config for annotated text size
=back
=cut
# TODO
# Document, how to get phasebuttons in the programm and also change the way it works!! Make it take the
# rays >ray< array of r.in
#
# NAMING of layers?

Add Comment

Please, Sign In to add comment

Public Pastes

✅ Make $2500 in 20 minutes⭐ 0
JavaScript | 1 sec ago | 0.25 KB
⭐⭐⭐MAKE $900 INSTANTLY⭐⭐
Java | 2 sec ago | 0.15 KB
🔥 Exchange profit method
JavaScript | 4 sec ago | 0.24 KB
📌 Swapzone +37% glitch ⭐ A
JavaScript | 9 sec ago | 0.25 KB
⭐⭐⭐Make $15OO in 2O minutesV E⭐⭐
Java | 13 sec ago | 0.15 KB
✅⭐ Make huge profits on trading ⭐⭐ T
JavaScript | 17 sec ago | 0.25 KB
💵 Make 3000$ in 20 minutes 💵
JavaScript | 18 sec ago | 0.24 KB
⭐⭐⭐Instant Profit Method⭐⭐
Java | 23 sec ago | 0.15 KB

create new paste / syntax languages / archive / faq / tools / night mode / api / scraping api / news / pro
privacy statement / cookies policy / terms of service / security disclosure / dmca / report abuse / contact

By using Pastebin.com you agree to our cookies policy to enhance your experience.
Site design & logo © 2025 Pastebin

We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand

Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!

HOME
ABOUT
AUCTIONS
SHIPPING
FEES
TOOLS
HOW
FAQ
CONTACT

Original Source | Taken Source