#! /usr/local/bin/perl
#!/usr/bin/env perl
# -*- perl -*-
#
# $Id: bbbike,v 3.214 2005/12/09 21:48:14 eserte Exp $
# Author: Slaven Rezic
#
# Copyright (c) 1995-2005 Slaven Rezic. All rights reserved.
# This is free software; you can redistribute it and/or modify it under the
# terms of the GNU General Public License, see the file COPYING.
#
# Mail: slaven@rezic.de
# WWW: http://bbbike.sourceforge.net
#
package main;
## This is list is not maintained anymore:
#perl2exe_include Tk/Checkbutton.pm
#BEGIN { $Devel::Trace::TRACE = 0 }
use FindBin;
use lib ("$FindBin::RealBin",
"$FindBin::RealBin/images",
"$FindBin::RealBin/lib",
);
# To create the Devel::Size output, start bbbike with:
# env BBBIKE_DEBUG=Devel::Size ./bbbike | & grep size
BEGIN {
if ($ENV{BBBIKE_DEBUG}) {
eval 'use BBBikeDebug';
die $@ if $@;
}
}
BEGIN {
my $nosplash = grep { $_ eq '-nosplash' } @ARGV;
if ($] >= 5.005 && !$^C && !$^P && !$nosplash) {
# XXX don't know whether this is a Tk400 or an old perl problem
eval {
require Tk::ProgressSplash;
my $splashtype = 'fast';
if ($^O eq 'MSWin32') {
$splashtype = 'normal';
}
$splash_screen = Tk::ProgressSplash->Show
(-splashtype => $splashtype,
"$FindBin::RealBin/images/bbbike_splash.xpm",
240, 90, "BBBike", 1);
}; warn $@ if $@;
}
if ($nosplash) { $use_logo = 0 }
eval 'use sigtrap qw(stack-trace USR1)'; warn $@ if $@;
$booting = 1;
}
use Config;
## DEBUG_BEGIN
#BEGIN{mymstat("before autouse BBBikeMail, Text::Wrap, File::Copy");}
## DEBUG_END
# Call "autouse" as early as possible. Otherwise there will be errors,
# if any other module requires theses modules.
# "autouse" cannot be used on modules with non-standard import functions
use autouse 'BBBikeMail' => qw(enter_send_mail enter_send_fax);
use autouse 'Text::Wrap' => qw(wrap);
use autouse 'File::Copy' => qw(copy mv);
use autouse 'BBBikeGPS'
=> qw(gps_interface draw_gpsman_data do_draw_gpsman_data);
use autouse 'BBBikeWeather'
=> qw(wetter_dir_exists ignore_weather reset_wind update_weather
show_weather_db parse_wetterline analyze_wind);
use autouse 'BBBikeHeavy'
=> qw(start_followmouse stop_followmouse
string_eval_die load_plugin layer_editor
getmap get_file_or_url get_user_agent delete_map
pdf_export svg_export perlmod_install_advice
show_register save_register_routes load_register_routes
show_calories check_available_memory
reload_all);
#XXX problems with autouse! -> what problems?
use autouse 'BBBikeEdit'
=> qw(insert_point_from_canvas create_relation_from_canvas
ampeln_on_route radweg_open radweg_draw_canvas
);
use autouse 'BBBikeLazy'
=> qw(bbbikelazy_setup bbbikelazy_init bbbikelazy_clear
bbbikelazy_reload bbbikelazy_reload_all bbbikelazy_redraw_current_view
bbbikelazy_add_data bbbikelazy_remove_data plotstr_on_demand);
use autouse 'BBBikePrint'
=> qw(create_postscript print_postscript toggle_legend
print_text_postscript print_text_pdflatex print_route_pdf view_pdf);
## This is only for the Autoloader-Hack (see "make autoload")
#use AutoLoader 'AUTOLOAD';
## DEBUG_BEGIN
#BEGIN{mymstat("before Tk");}
## DEBUG_END
use Tk;
#XXX for now disabled ... still too many bugs floating around -> what bugs?
#use Tk::ErrorDialog; # XXX is this OK?
use Tk::Canvas;
use Tk::CanvasUtil;
use File::Basename;
## DEBUG_BEGIN
#BEGIN{mymstat("before BBBikeUtil");}
## DEBUG_END
use BBBikeUtil;
use BBBikeUtil qw(min max);
use BBBikeVar;
use BBBikeCalc;
use BBBikeTrans;
## DEBUG_BEGIN
#BEGIN{mymstat("before Strassen");}
## DEBUG_END
use Strassen;
use Strassen::Dataset;
## DEBUG_BEGIN
#BEGIN{mymstat("before Route");}
## DEBUG_END
use Route;
## DEBUG_BEGIN
#BEGIN{mymstat("before Karte");}
## DEBUG_END
use Karte;
use Hooks;
use VectorUtil qw(get_polygon_center point_in_polygon point_in_grid);
## DEBUG_BEGIN
#BEGIN{mymstat("before locale");}
## DEBUG_END
use strict;
## DEBUG_BEGIN
#BEGIN{mymstat("before use vars");}
## DEBUG_END
# i18n functions M and Mfmt
BEGIN {
if (!eval '
use Msg; # This call has to be in bbbike!
1;
') {
warn $@ if $@;
eval 'sub M ($) { $_[0] }';
eval 'sub Mfmt { sprintf(shift, @_) }';
}
}
use BBBikeGlobalVars 1.012;
## DEBUG_BEGIN
#BEGIN{mymstat("before use your");}
## DEBUG_END
use your qw($Karte::Standard::obj $Karte::Standard::init_scrollregion
$Karte::GISmap::obj $Karte::Polar::obj
$Tk::Getopt::x11_pass_through
$wettermeldung2::proxy $wettermeldung2::module
$wettermeldung2::FIELD_TEMP $wettermeldung2::tk_widget
$Http::tk_widget
%GfxConvert::tmpfiles
$BikePower::has_xs
$Radwege::bez @Radwege::bbbike_category_order
%Radwege::category_plural
$FURadar::use_map $FURadar::progress
$PLZ::VERBOSE $Devel::Trace::TRACE
);
*transpose_ls = \&transpose_ls_slow;
# If you don't have a FPU, maybe \&old_create_transpose_subs should be
# used instead.
*create_transpose_subs = \&old_create_transpose_subs_no_int;
## DEBUG_BEGIN
#BEGIN{mymstat("before use BBBikeXS");}
## DEBUG_END
eval 'use BBBikeXS 0.09';
## DEBUG_BEGIN
#BEGIN{mymstat("after use BBBikeXS");}
## DEBUG_END
$^W = 1;
# $VERSION is the version of the BBBike distribution
# $PROG_REVISION is the version of the main program
$VERSION = $BBBike::VERSION;
$PROG_REVISION = sprintf("%d.%03d", q$Revision: 3.214 $ =~ /(\d+)\.(\d+)/);
# since version 3.40 => 3.040
# OS related
$progname = basename($0);
$devel_host = ($ENV{HOST} && $ENV{HOST} =~ /^(vran|cabulja|cvrsnica|spiff|devpc01)/i);
$os = $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'dos' ? 'win'
: $^O eq 'MacOS' ? 'mac'
: 'unix';
$os_bsd = $^O =~ /bsd/i;
if (!defined $is_handheld) {
$is_handheld = $Config{"archname"} =~ /^arm-linux$/i;
}
$use_clipboard = 1 if $os eq 'win';
# include after setting $os!
require TkChange;
# compatibility includes
if ($Tk::VERSION < 402) {
warn Mfmt("Die Tk-Version ist veraltet (%s). Möglicherweise ist
BBBike trotzdem benutzbar. Empfohlen wird ein Upgrade auf Version 800.012 oder
besser.\n", $Tk::VERSION);
}
if ($Tk::VERSION <= 402.004) {
require TkCompat;
}
if ($os eq 'win') {
require WinCompat;
}
# enable DnD
use Tk::DropSite;
$tmpdir = $ENV{TMPDIR} || $ENV{TEMP} || "/tmp";
if (! -d $tmpdir) {
$tmpdir = "/temp";
if (! -d $tmpdir) {
$tmpdir = catfile($FindBin::RealBin, "tmp");
warn Mfmt("Verwende Unterverzeichnis 'tmp' des Programmverzeichnisses (%s) als temporäres Verzeichnis", $tmpdir);
}
}
# Var section: map scales and orientation
set_landscape();
$scale_coeff = 1;
$small_scale = 0.0625; # map scale for overview window (region mode)
$medium_scale = 0.13; # map scale for overview window (city/Berlin mode)
$small_scale_edit = 0.01; # dasselbe für den Edit-Mode XXX remove?
$medium_scale_edit = 0.02;
set_canvas_scale(DEFAULT_SCALE);
Karte::preload('Standard');
my $init_scale_massstab; # in 1:x form
$init_scrollregion = $Karte::Standard::init_scrollregion;
$normal_scrollregion = $init_scrollregion*$scale;
@scrollregion = ((-$normal_scrollregion) x 2,
($normal_scrollregion) x 2);
$bbbike_route_ext = 'bbr';
$map_bg = 'grey85';
# Var section: street and point attributes
@comments_types = @Strassen::Dataset::comments_types;
$str_draw{'s'} = 1; # draw streets by default
$p_draw{'pp'} = 0; # do not draw crossings by default
$p_draw{"pp-all"} = 0; # pp drawing only for the tag types below:
for (qw(s l r b u w f v e z fz)) { $p_draw{"pp-$_"} = 1} # this list should cover most keys of %str_file (but not the dependent ones like "comm" or "qs")
$p_draw{'lsa'} = 1;
$p_far_away{'o'} = 0;
$str_restrict{'s'} = {qw(BAB 0 B 1 HH 1 H 1 N 1 NN 1 Pl 0 Br 0)}; # Pl = places, Br = bridges
$str_restrict{'r'} = {qw(RA 1 RB 1 RC 1 R 1 R0 0)};
$str_restrict{'b'} = {qw(S 1 SA 1 SB 1 SC 1 S0 0)};
$str_restrict{'u'} = {qw(U 1 UA 1 UB 1 U0 0)};
$str_restrict{'qs'} = {qw(Q0 0 Q1 1 Q2 1 Q3 1)};
$str_restrict{'ql'} = {qw(Q0 0 Q1 1 Q2 1 Q3 1)};
$str_restrict{'hs'} = {qw(q0 0 q1 1 q2 1 q3 1 q4 1)};
$str_restrict{'hl'} = {qw(q0 0 q1 1 q2 1 q3 1 q4 1)};
$str_ignore{'temp_sperre_s'} = {0 => 1, 1 => 1, 2 => 1, 3 => 1}; # XXX BNP auch?
# do not draw Steigung and Gefälle at the same time:
$str_ignore{'comm'} = {'Gf' => 1}; # XXX with ";"???
require Radwege;
foreach (@Radwege::category_order) {
$str_restrict{'rw'}->{$Radwege::category_code{$_}} = 1
if defined $Radwege::category_code{$_};
}
$str_nr_draw{'comm-route'} = 1;
%tag_group = # group related tags (for stacking)
('str_s' => ['s-out', 'gr', 'rw',
's-NN', 's-N', 's-H', 's-HH', 's-B', 's-BAB', 'sBAB-BAB',
'comm', (map { "comm-$_" } @comments_types),
'nl', 'qs', 'hs', 'mount',
's-label-bg', 's-label', 'hoehe', 'vf-bg',
'sperre', 'temp_sperre_s', 'temp_sperre',
'delnet', 'pl-fg', 'lsa-bg', 'vf-fg', 'lsa-fg'],
'str_l' => ['l-out', 'l', 'comm',
(map { "comm-$_" } @comments_types),
'ql', 'hl', 'l-label-bg', 'l-label'], # XXX mount?
'p_o' => ['o', 'O'],
'p_p' => ['p'],
'str_u' => ['u', 'sperre_u', 'u-bg', 'u-fg', 'u_bg-img', 'u-label'],
'str_b' => ['b', 'sperre_b', 'b-bg', 'b-fg', 'b_bg-img', 'b-label'],
'str_r' => ['r', 'sperre_r', 'r-bg', 'r-fg', 'r_bg-img', 'r-label'],
'str_w' => ['w-out', 'w', 'i-out', 'i', 'w-label-bg', 'w-label'],
'str_f' => ['f', 'f-label-bg', 'f-label', 'f-Pabove'],
'str_g' => ['z', 'g', 'gP', 'gD'],
'p_kn' => ['kn', 'ki', 'rest'],
'map' => ['map'],
'route' => ['route'],
'v' => ['v', 'v-fg'],
'e' => ['e', 'e-img'],
);
$do_iconframe = 1;
$do_route_strnames = 0 if !defined $do_route_strnames;
$do_route_strnames_km = 0 if !defined $do_route_strnames_km;
$do_route_strnames_compact = 0 if !defined $do_route_strnames_compact;
$do_route_strnames_comments = 1 if !defined $do_route_strnames_comments;
$net_type = "s";
$no_make_net = 0;
$str_far_away{'w'} = 0;
$orte_label_size = 1;
use constant MIN_ORT_CAT => 0;
use constant MAX_ORT_CAT => 6;
$str_far_away{'l'} = 0;
$show_overview_mode = "b";
$show_overview = $show_strlist = 0;
$show_calories = 0;
$use_hoehe = 1; # XXX kann im Programm nicht gesetzt werden
$steigung_optimierung = 0;
$green_optimization = 0;
$grade_minimum_short_length = 100; # 100m gilt als kurz für grademinimumshort
$use_legend = $use_legend_right = 0;
$use_faehre = 0;
$sperre{'einbahn'} = 1;
$sperre{'einbahn-strict'} = 0;
$sperre{'sperre'} = 1;
$sperre{'wegfuehrung'} = 1;
$sperre{'Q3'} = 0;
$p_draw{'sperre'} = 0;
$sperre_file = "gesperrt";
# immediate_replot: 0 = none, 1 = immediate, 2 = deferred
my($immediate_replot, $immediate_recalc) = (1, 1);
$auto_visible = 1;
%tag_visibility =
('p-hoehe' => 1,
'str-s-NN' => 0.5,
'str-s-N' => 0.5,
'p-lsa' => 0.5,
'p-o-0' => 0.375,
'p-o-1' => 0.25,
'str-s-H' => 0.125,
'p-o-2' => 0.125,
);
$map_draw = 0;
$map_default_type = 'berlinmap';
$use_map_fallback = 1;
$map_surround = 0;
$dont_delete_map = 1;
$use_current_coord_prefix = 0;
$coord_prefix = undef;
$coordlist_lbox_nl = "";
$min_cache_decider_time = 0.500; # 500ms, dann wird gecached
$steady_mark = 0;
$lowmem = 0;
$use_logo = 1 if !defined $use_logo;
$center_loaded_route = 0;
$zoom_loaded_route = 1;
$zoom_new_route = 0;
$zoom_new_route_chooseort = 1;
$special_edit = '';
$map_mode = MM_SEARCH;
%b2_mode_desc = (B2M_NONE, M"Nichts",
B2M_SCAN, M"Scanning",
B2M_FASTSCAN, M"Fast Scanning",
B2M_AUTOSCROLL, M"Autoscrolling",
B2M_DELLAST, M"Letzten Punkt löschen",
);
# Default ist rot, weil das Orange von power oder wind schlecht zu erkennen ist
$mark_color = 'red'; # Farbe der Markierung in mark_street et al.
$gps_waypoints = 50;
define_item_attribs();
generate_plot_functions();
###################################################################
$really_no_www = $os eq 'win'; # Trumpet und Win32Sock hängen zu lange, wenn es keine Verbindung gibt
$no_map = !$devel_host && (!defined $ENV{USER} || $ENV{USER} !~ /^(eserte|rezic|srezic)$/);
$abbiege_optimierung = 0;
# Verlust in Metern beim Linksabbiegen ohne Ampel
# XXXXX und beim Geradeausfahren??????
$abbiege_penalty = { 'H' => 70, # entspricht ca. 10s bei 25km/h
'HH' => 140, # entspricht ca. 20s bei 25km/h
'BAB' => 140, # häh? für Radfahrer?
'B' => 140,
};
$lost_strecke_per_ampel = 50; # verlorene Strecke pro Ampel in m # XXX F ...?
%lost_time_per_ampel = ('X' => 15,
'F' => 5,
); # verlorene Zeit pro Ampel in s
$average_v = 0;
$radwege_optimierung = 0;
for(0..$#Radwege::category_order, "") {
$radwege_speed{"RW$_"} = 100;
}
%strcat_bez =
(
B => M"Bundesstraßen",
HH => M"wichtige Hauptstraßen",
H => M"Hauptstraßen",
N => M"Nebenstraßen",
NN => M"für Kfz gesperrte Straßen",
);
@strcat_order = qw(B HH H N NN);
if (0) { # not enabled by default
unshift @strcat_order, "BAB";
$strcat_bez{BAB} = M"Autobahnen";
}
$steigung_penalty = {};
$strecke = 0;
$dim_color = '#999999';
$unit_km = 'km';
$next_is_undo = 0;
# kontrolliert das Zeichnen der Start/Zielflagge:
@do_flag{qw(start via ziel)} = (1, 1, 1);
# $in_search: wahr, wenn gerade gesucht wird
use enum qw(:SRP_ COORD TYPE);
$aufschlag = 1; # XXX ???
# Weather variables section
$wetter_force_update = 1 if !defined $wetter_force_update;
$wetter_route_update = 0 if !defined $wetter_route_update;
$wetter_station = 'uptodate' if !defined $wetter_station;
@wetter_dir = ("$ENV{HOME}/doc/met", "/home/e/eserte/doc/met");
%wetter_zuordnung =
('dahlem1' => 'wetter-full',
'dahlem2' => 'wetter',
#'tempelhof' => 'wetter-tempelhof',
);
%wetter_name =
('dahlem1' => M"Dahlem (FU, lang)",
'dahlem2' => M"Dahlem (FU, kurz)",
#'tempelhof' => M"Tempelhof (DWD)",
);
%wetter_full = ('dahlem1' => 1);
$temperature = 20; # degrees Celsius
BBBikeCalc::init_wind();
use enum qw(:WIND_COLOR_ RED GREEN BLUE NAME);
%wind_colors = (-2 => [qw(255 0 0 red)],
-1 => [qw(255 165 0 orange)],
0 => [qw(255 215 0 gold)],
1 => [qw(154 205 50 YellowGreen)],
2 => [qw(105 139 105 DarkSeaGreen4)],
);
### Fonts
$standard_height = 12;
## DEBUG_BEGIN
#BEGIN{mymstat("use vars für postscript...");}
## DEBUG_END
### Postscript
$ps_color = 'color';
$ps_rotate = 1;
$ps_scale_a4 = 1;
$ps_fixed_font = "Courier7";
$nr = -1; # number of points in route (XXX correct???)
{
my $cachedir = catfile($FindBin::RealBin, "cache");
$cache_root = (-d $cachedir && -w $cachedir
? catfile($FindBin::RealBin, "cache")
: $tmpdir);
$Karte::cache_root = $cache_root;
}
Karte::preload('Berlinmap2000');
$do_wwwmap = (! $Karte::Berlinmap2000::obj ||
! -e $Karte::Berlinmap2000::obj->fs_dir);
if ($devel_host) {
$Karte::cache_root = "/usr/www/berlin";
}
if (!$ENV{HOME} || !-d $ENV{HOME}) { # z.B. unter Win32
$ENV{HOME} = $FindBin::RealBin;
}
if ($os eq 'win') {
require Win32Util;
my $home = Win32Util::get_user_folder();
if (-d $home) {
$bbbike_configdir = catfile($home, "BBBike");
}
}
if (!defined $bbbike_configdir) {
$bbbike_configdir = defined $ENV{HOME} ? catfile($ENV{HOME}, ".bbbike")
: "/bbbike.cfg";
}
if (!-d $bbbike_configdir) {
mkdir $bbbike_configdir, 0700;
}
if (-d $bbbike_configdir) {
$bbbike_routedir = catfile($bbbike_configdir, "route");
if (!-d $bbbike_routedir) {
mkdir $bbbike_routedir, 0700;
}
}
$oldpath = $bbbike_routedir;
$save2_path = $ENV{HOME};
# Hook init
foreach (qw(before_plot after_plot new_route del_route after_resize
after_new_layer after_delete_layer
after_change_visibility after_change_stacking)) {
new Hooks $_;
}
eval { local $SIG{'__DIE__'};
do "$FindBin::RealBin/$progname" . "_0.config" };
## DEBUG_BEGIN
#BEGIN{mymstat("before getopt BEGIN");} mymstat("before getopt");
## DEBUG_END
handle_options();
## DEBUG_BEGIN
#mymstat("after getopt processing");
## DEBUG_END
my $city_obj;
if (!defined $city) {
$city = "Berlin";
$country = "DE";
}
if (defined $city) {
require Geography;
$city_obj = Geography->new($city, $country);
if ($city_obj) {
set_datadir($city_obj->datadir, -clearold => 1);
%global_search_args = $city_obj->search_args
if $city_obj->can("search_args");
$no_original_datadir = $city ne "Berlin"; # XXX Was bedeutet das genau?
} else {
die Mfmt("Kann keine passende Datei für Stadt=%s und Land=%s finden",
$city, (defined $country ? $country : M("(unbestimmt)")));
}
} elsif ($datadir) {
set_datadir($datadir, -clearold => 1);
$no_original_datadir = 1;
} else {
warn "XXX Should never happen anymore";
# default (Berlin)
set_datadir("$FindBin::RealBin/data");
}
if ($environment ne "normal") {
eval { local $SIG{'__DIE__'};
require $progname . "_" . $environment . ".config" };
}
## DEBUG_BEGIN
#mymstat("before advanced");
## DEBUG_END
if ($advanced) {
Karte::preload(':all');
require BBBikeAdvanced;
}
$coord_system_obj = $Karte::Standard::obj;
$coord_system = $coord_system_obj->token;
if ($verbose) {
set_verbose();
}
if ($proxy) {
$wettermeldung2::proxy = $proxy;
}
if ($do_www) {
$wetter_source{'www'} = 1;
}
if (wetter_dir_exists() and !$public) {
$wetter_source{'db'} = 1;
}
if ($devel_host and !$public) {
$wetter_source{'local'} = 1;
}
# XXX ja?
# überprüfen ... auf win32 wird trotz do_www=0 trotzdem geladen?!
if (!grep($_, values %wetter_source) and $do_www and !$really_no_www) {
$wetter_source{'www'} = 1;
}
if ($net_type ne 's' && $coloring eq 'wind') {
$coloring = 'black';
}
reset_wind();
## DEBUG_BEGIN
#mymstat("before update_weather");
## DEBUG_END
update_weather(1) if $want_wind;
$wetter_route_update = 1;
if ($bikepwr) {
eval {
require BikePower;
};
if ($@) {
status_message(Mfmt("Kann BikePower nicht laden: %s", $@), 'err');
$bikepwr = 0;
} else {
if ($verbose && $BikePower::has_xs) {
warn M"Verwende die XS version von BikePower\n";
}
$bp_obj = new BikePower;
$bp_obj->given('P');
$bp_obj->temperature($temperature);
set_corresponding_power();
}
}
if (!@power) {
@power = (50, 100);
}
TRY_SPEED_POWER_REFERENCE_STRING: {
$active_speed_power{Type} = 'speed';
$active_speed_power{Index} = 0;
if (defined $speed_power_reference_string) {
my($type, $val) = split /:/, $speed_power_reference_string;
if ($type =~ /^(speed|power)$/) {
my $i = 0;
for ($type eq 'speed' ? @speed : @power) {
if ($val eq $_) {
$active_speed_power{Index} = $i;
$active_speed_power{Type} = $type;
last TRY_SPEED_POWER_REFERENCE_STRING;
}
$i++;
}
warn "Ignore reference $type $val"; # XXX german
} else {
warn "-reference should be in the form type:value, where type is either speed or power"; # XXX german
}
}
}
mk_speed_txt();
for(my $i = 0; $i <= $#speed; $i++) {
$ampel_count->{"speed"}[$i] = 1;
$kopfstein_count->{"speed"}[$i] = 1;
}
for(my $i = 0; $i <= $#power; $i++) {
$ampel_count->{"power"}[$i] = 1;
$kopfstein_count->{"power"}[$i] = 1;
}
eval {
set_coord_output_sub();
}; warn __LINE__ . ": $@" if $@;
change_net_type();
if ($do_wwwmap && $devel_host) {
$map_default_type = 'b2004';
}
if ($all_outline) {
$str_outline{'s'} =
$str_outline{'l'} =
$str_outline{'w'} =
$str_outline{'i'} = 1;
}
if (defined $init_scope) {
if ($init_scope eq 'city') { city_settings() }
elsif ($init_scope eq 'region') { region_settings() }
elsif ($init_scope eq 'jwd') { jwd_settings() }
}
if ($visual) {
push(@extra_args, -visual => $visual);
}
if (defined $Plugin::brinfo{'xwindow_id'}) {
push(@extra_args, "-use" => $Plugin::brinfo{'xwindow_id'});
}
if ($Tk::VERSION < 803 || $Tk::VERSION >= 804.025) {
eval { require Tk::UnderlineAll };
warn __LINE__ . ": $@" if $@ && $verbose;
}
eval { local $SIG{'__DIE__'};
do "FindBin::RealBin/$progname" . "_1.config" };
## DEBUG_BEGIN
#BEGIN{mymstat("irgendwo in der mitte BEGIN");} mymstat("irgendwo in der mitte");
## DEBUG_END
if (!defined $top) {
$top = MainWindow->new(@extra_args);
$top->{initial_iconic} = $top->state eq 'iconic';
$top->scaling($scaling) if defined $scaling && $scaling ne "";
# Es gibt gute Gründe, für CloseMainWin kein Escape zu nehmen
# (damit können Vorgänge abgebrochen werden). Verwendung von C-q,
# weil das mittlerweile quasi-Standard ist.
$top->eventAdd(qw[<<CloseMainWin>> <Control-c> <Control-q>]);
$top->eventAdd(qw[<<CloseWin>> <Control-c> <Escape>]);
if ($os eq 'win') { # vorerst, Windows kann keine tearoffs
$top->optionAdd("*tearOff", "false", "startupFile");
}
if ($os ne 'win') { # use standard bg color on Windows
for (qw(background highlightBackground)) {
$top->optionAdd("*$_", 'grey80', 'startupFile');
}
# Workaround for a KDE 3.x problem: KDE sets background, but not
# highlightBackground options which looks quite ugly.
my $bg = $top->optionGet("background", "Background");
if ($top->optionGet("highlightBackground", "HighlightBackground") ne $bg) {
$top->optionAdd("*highlightBackground", $bg, 'interactive');
}
# Unter Windows sollten Balloons eigentlich -bg => white sein XXX
for (qw(Balloon CanvasBalloon)) {
$top->optionAdd("*$_.background", '#C0C080', 'startupFile');
}
for (qw(Scale Scrollbar)) {
$top->optionAdd("*$_.troughcolor", "grey95", "startupFile");
}
}
# Browse is for Tk::HistEntry::Browse
for (qw(Browse Entry NumEntry Date*NumEntryPlain PathEntry
Listbox KListbox K2Listbox
TixHList HList Text ROText BrowseEntry.Entry SimpleHistEntry
ListboxSearchAnything
)) {
if ($os eq 'win') {
$top->optionAdd("*$_.background", "SystemWindow", "startupFile");
} else {
$top->optionAdd("*$_.background", "grey95", "startupFile");
}
}
for (qw(Button Checkbutton Radiobutton Menubutton
FlatCheckbox FlatRadiobutton FireButton)) {
$top->optionAdd("*$_.cursor", "hand2", "startupFile");
}
if (0) { # ... naja, müsste ein Designer ran ... außerdem with -tile nicht mehr unterstützt (?)
my $bg = $top->Photo(-file => Tk::findINC("images/bg.gif"));
for (qw(Toplevel Label Button Checkbutton Radiobutton FlatBut
FlatCheckbox FlatRadiobutton FireButton Menubutton Frame Pane),
"Bbbike Chooser", "Bbbike Copyright", "Bbbike Window",
"Bbbike Extended Chooser", "Bbbike Overview",
"Bbbike Routeinfo") {
$top->optionAdd("*$_.tile" => $bg) if $bg;
}
$top->optionAdd("*highlightBackground" => "white");
}
}
# KDE initialisation
if ($run_under_kde) {
eval {
require KDEUtil;
if ($kde = new KDEUtil -top => $top, -checkrunning => 1) {
my $kde_focus_policy =
KDEUtil::WM::get_config($kde, 'General', 'FocusPolicy');
local $^W = 0;
$focus_policy = ($kde_focus_policy eq 'ClickToFocus'
? 'click'
: 'follow');
$kde->kde_config_for_tk;
}
};
warn __LINE__ . ": $@" if $@; # XXX and $verbose
}
# Are we running exceed?
$exceed = ($top->server =~ /Hummingbird/);
$focus_policy = 'click' if $exceed;
if (!defined $focus_policy) {
if ($os eq 'unix') {
## XXX Problem: Fenster erscheinen manchmal abgeschnitten wegen
## XXX still in 804?
## -popover => 'cursor'
#XXX $focus_policy = 'follow';
$focus_policy = 'click';
} else {
$focus_policy = 'click';
}
}
if ($focus_policy eq 'follow') {
@popup_style = ('-popover', 'cursor');
} else {
@popup_style = ();
}
# erst *nach* new MainWindow aufrufen (wegen Tk::CmdLine)
if (@ARGV) {
$preload_file = $ARGV[0];
}
# Die folgende Reihenfolge ist wichtig einzuhalten:
# * Geometry ermitteln und in @want_extends ablegen, aber noch nicht setzen
# (set_default_geometry, geometry_dependent_settings)
# * Zeichensätze ermitteln und Default einstellen (set_fonts)
# * EmptyMenubar zeichnen
# * Geometry setzen
use enum qw(:GEOMETRY_ X Y WIDTH HEIGHT);
# Geometry
set_default_geometry();
geometry_dependent_settings();
# Zeichensätze
set_fonts();
## DEBUG_BEGIN
#BEGIN{mymstat("after setfonts BEGIN");} mymstat("after setfonts");
## DEBUG_END
if ($Tk::VERSION < 800) {
$standard_menubar = 0;
}
if ($standard_menubar && !$top->cget(-menu)) {
require BBBikeMenubar;
BBBike::Menubar::EmptyMenubar(); # Platz reservieren ...
# Tk feature: menu bar is not counted to geometry
my $menu_height;
if ($os eq 'unix') {
$top->withdraw;
$top->update;
$menu_height = ($top->wrapper)[1];
} else {
# wrapper[1] is not implemented on Windows ... guess menu height
$menu_height = 20;
}
if ($want_extends[GEOMETRY_HEIGHT] =~ /^-/) {
$want_extends[GEOMETRY_HEIGHT] += $menu_height;
} else {
$want_extends[GEOMETRY_HEIGHT] -= $menu_height;
}
}
if (@want_extends) {
if (($want_extends[GEOMETRY_WIDTH] < 30 && $want_extends[GEOMETRY_WIDTH] !~ /^-/) ||
($want_extends[GEOMETRY_HEIGHT] < 20 && $want_extends[GEOMETRY_HEIGHT] !~ /^-/) ||
$want_extends[GEOMETRY_X] < 0 ||
$want_extends[GEOMETRY_Y] < 0) {
warn M("Die Fenstergröße wird wegen ungültiger Werte nicht gesetzt: ")
. join(", ", @want_extends), "\n";
} else {
geometry($top, @want_extends);
@want_extends = ();
}
}
# dots per inch und mm
$top_dpmm = $top->screenwidth/$top->screenmmwidth;
$top_dpi = $top_dpmm*25.4;
$ps_image_res = int($top_dpi) . "x" . int($top_dpi);
if (defined $init_scale_massstab) {
if ($init_scale_massstab =~ m{^1:(\d+)$}) {
my $nenner = $1;
my $nenner_now = calc_mapscale_nenner();
# to the old $scale form:
$init_scale_massstab = ($scale*$nenner_now)/$nenner;
}
if ($init_scale_massstab > 0) {
my $oldscale = $scale;
set_canvas_scale($init_scale_massstab);
my $change_scale_factor = $scale/$oldscale;
foreach (@scrollregion) {
$_ *= $change_scale_factor;
}
} else {
warn "Ungültiger Skalierungswert <$init_scale_massstab> wird ignoriert\n";
}
}
$srtbike_photo = load_photo($top, 'srtbike_solid.' . $default_img_fmt);
if ($os eq 'win' || $^O eq 'cygwin') {
# XXX should I use 16 too?
$srtbike_icon = load_photo($top, 'srtbike32.' . $default_img_fmt);
if ($srtbike_icon) {
#XXX Produces funny colors --- Tk problem?!
# $top->iconmask('@' . $FindBin::RealBin . '/images/srtbike32_mask.xbm');
}
} else {
# 16x16 is the preferred size for mini-icons in KDE
# works also for twm (however, a little bit tiny)
$srtbike_icon = load_photo($top, 'srtbike16.' . $default_img_fmt);
if ($srtbike_icon) {
$top->iconmask('@' . $FindBin::RealBin . '/images/srtbike16_mask.xbm');
}
}
$top->title("$progname $VERSION");
# In ->Icon wird auch ein ->update durchgeführt:
# XXX Unter Unix vielleicht darauf verzichten und iconimage stattdessen verwenden?
$top->Icon(-image => $srtbike_icon) if defined $srtbike_icon;
if ($splash_screen) {
$splash_screen->Raise; # raise after the first ->update on $top, otherwise on Windows the splash screen will stay obscured by the main window
$splash_screen->Update(0.0);
}
# Exceed-Bug
$capstyle_round = ($exceed ? "projecting" : "round");
#XXX
# for(my $i=0; $i <= $#speed; $++) {
# $bikepwr_cal_spd[$i] = 0;
# }
# erst hier ist die @power-Zuweisung abgeschlossen
for(my $i=0; $i <= $#power; $i++) {
$bikepwr_time[$i] = 0;
$bikepwr_cal[$i] = 0;
}
mk_power_txt();
## DEBUG_BEGIN
#BEGIN{mymstat("after mk_power_txt BEGIN");} mymstat("after mk_power_txt");
## DEBUG_END
# Zeichensätze für Straßennamen
# Normal
if (defined $font_family && $font_family =~ /nimbus/) {
# XXX nimbus is a rather obscure font found in
# /usr/ports/x11-fonts/freefonts --- maybe use another?
#
# somewhere called "nimbus sans" without "l"
$rot_font_sub = sub { "-*-nimbus sans l-medium-r-condensed--0-" . $_[0]
. "-0-0-p-0-iso8859-1"};
} elsif (defined $font_family && $font_family =~ /luxi/) {
# a Type 1 font --- slower and nicer
$rot_font_sub = sub { '-b&h-Luxi Sans-medium-r-normal--0-' . $_[0] . '-0-0-p-0-iso8859-1'};
}
if (defined $rot_font_sub && !check_font($rot_font_sub->(120))) {
warn "Cannot get normal font in $font_family, use fallback...\n";
undef $rot_font_sub;
}
# Fallback to helvetica
if (!$rot_font_sub) {
my $font_family = "helvetica";
$rot_font_sub = sub { "-*-$font_family-medium-r-normal--0-" . $_[0]
. "-0-0-p-0-iso8859-1"};
}
# Bold
if (defined $font_family && $font_family =~ /nimbus/) {
$rot_bold_font_sub = sub { "-*-nimbus sans l-bold-r-condensed--0-" . $_[0]
. "-0-0-p-0-iso8859-1"};
} elsif (defined $font_family && $font_family =~ /luxi/) {
$rot_bold_font_sub = sub { '-b&h-Luxi Sans-bold-r-normal--0-' . $_[0] . '-0-0-p-0-iso8859-1'};
}
if (defined $rot_bold_font_sub && !check_font($rot_bold_font_sub->(120))) {
warn "Cannot get bold font in $font_family, use fallback...\n";
undef $rot_bold_font_sub;
}
# Fallback to helvetica bold
if (!$rot_bold_font_sub) {
my $font_family = "helvetica";
$rot_bold_font_sub = sub { "-*-$font_family-bold-r-normal--0-" . $_[0]
. "-0-0-p-0-iso8859-1"};
}
%category_rot_font =
('N' => $rot_font_sub,
'NN' => $rot_font_sub,
'H' => $rot_bold_font_sub,
'HH' => $rot_bold_font_sub,
'B' => $rot_bold_font_sub,
'BAB' => $rot_bold_font_sub,
'W' => $rot_bold_font_sub);
# According to
# http://web.archive.org/web/20020124125029/www.iarchitect.com/color.htm
# using colors for dialog buttons is not advised. Well, anyway...
$top->optionAdd("*ok*foreground" => 'green4');
$top->optionAdd("*ok*text" => M"OK");
if ($Tk::VERSION >= 800) {
$top->optionAdd("*ok*default" => 'active');
}
$top->optionAdd("*apply*foreground" => 'yellow4');
$top->optionAdd("*apply*text" => M"Übernehmen");
$top->optionAdd("*search*foreground" => 'yellow4');
$top->optionAdd("*search*text" => M"Suchen");
$top->optionAdd("*show*foreground" => 'yellow4');
$top->optionAdd("*show*text" => M"Zeigen");
$top->optionAdd("*default*foreground" => 'yellow4');
$top->optionAdd("*default*text" => M"Voreinstellung");
$top->optionAdd("*cancel*foreground" => 'red');
$top->optionAdd("*cancel*text" => M"Abbrechen");
#XXX Experiment for Tk804: {my $p=load_photo($top, "cross.".$default_img_fmt, -name => "cross");for(qw(close cancel)) { $top->optionAdd("*$_*compound","left"); $top->optionAdd("*$_*image","cross")}}
$top->optionAdd("*close*foreground" => 'red');
$top->optionAdd("*close*text" => M"Schließen");
$top->optionAdd("*end*foreground" => 'green4');
$top->optionAdd("*end*text" => M"Schließen");
if ($small_icons) {
$top->optionAdd("*Button*borderWidth" => 1);
$top->optionAdd("*Checkbutton*borderWidth" => 1);
}
$top->optionAdd("*FlatBut*borderWidth" => 0);
$top->optionAdd("*FlatBut*padX" => 1);
$top->optionAdd("*FlatBut*padY" => 0);
if ($use_logo and (!$splash_screen or !$splash_screen->{Exists})) {
show_logo();
}
if ($use_balloon) {
eval {
require Tk::Balloon;
# -balloonposition: Ansonsten kann es bei Buttons vorkommen, dass
# der Balloon Teile der Klickfläche überdeckt.
$balloon = $top->Balloon(-balloonposition => "mouse");
};
}
if (!defined $balloon) {
eval '
package Tk::Balloon; # AUTOLOAD: ignore
sub attach {}
sub configure {}
package main;
$balloon = bless {}, "Tk::Balloon";
'; # '
}
## DEBUG_BEGIN
#BEGIN{mymstat("after balloon BEGIN");} mymstat("after balloon");
## DEBUG_END
# XXX if !perl2exe
if (!$lowmem) {
if (eval { require Tk::CanvasBalloon; 1 }) {
$c_balloon = $top->CanvasBalloon(-initwait => $c_balloon_wait,
-show => $use_c_balloon);
}
}
## DEBUG_BEGIN
#BEGIN{mymstat("after canvasballoon BEGIN");} mymstat("after canvasballoon");
## DEBUG_END
TRY: {
last TRY unless $use_contexthelp;
if (!eval {
require Tk::ContextHelp;
Tk::ContextHelp->VERSION(0.05); # Win32 check
}) {
$use_contexthelp = 0;
last TRY;
}
$ch = $top->ContextHelp('-podfile' => "$FindBin::RealBin/$FindBin::Script" . ".pod");
}
if (!defined $ch) {
eval q{
package Tk::ContextHelp; # AUTOLOAD: ignore
sub attach {}
sub activate {}
sub HelpButton { shift; shift->Label(-padx => 0, -pady => 0) }
package main;
$ch = bless {}, "Tk::ContextHelp";
};
}
## DEBUG_BEGIN
#BEGIN{mymstat("after contexthelp BEGIN");} mymstat("after contexthelp");
## DEBUG_END
$frame = $top->Frame;
$frame->pack(-side => "top", -expand => "yes", -fill => "both");
$ctrl_frame = $frame->Frame->pack(-anchor => 'w', -fill => 'x');
## DEBUG_BEGIN
#BEGIN{mymstat("before topframe BEGIN");} mymstat("before topframe");
## DEBUG_END
##### Topframe #######################################################
$splash_screen->Update(0.1) if $splash_screen;
$menuarrow_photo = load_photo($top, 'menupfeil.' . $default_img_fmt);
my $col = 0;
my $top_frame = $ctrl_frame->Frame->pack(-side => 'top', -anchor => 'w',
-fill => 'x');
my($hslabel_frame, $km_frame, @speed_frame, $wind_frame,
@power_frame, $percent_frame, $temp_frame);
$top_frame->gridColumnconfigure(0, -weight => 1, -minsize => 50);
for(1..10) {
$top_frame->gridColumnconfigure($_, -weight => 0);
}
$hslabel_frame = $top_frame->Frame
(-relief => 'raised', -bd => 1);
if (!$small_icons) {
$hslabel_frame->Button
(-text => M('Ort/Bahnhof').':',
-class => 'FlatBut',
-highlightthickness => 0, -takefocus => 0,
-command => sub { choose_ort(qw(p o)) },
)->grid(-row => 0,
-column => 0,
-sticky => 'w');
$hslabel_frame->Button
(-text => M('Straße/Strecke').':',
-class => 'FlatBut',
-highlightthickness => 0, -takefocus => 0,
-command => \&choose_streets,
)->grid(-column => 0,
-row => 1,
-sticky => 'w');
}
#XXXXXXXXXXXXXXXXX Ab hier POD attaches Msg-tauglich machen
$hslabel_frame->gridColumnconfigure(1, -weight => 1, -minsize => 10);
$hs_label = $hslabel_frame->Label
(-textvariable => \$act_value{Haltestelle},
-fg => $dim_color,
-font => $font{'bold'},
-anchor => 'w',
)->grid(-column => 1, -row => 0, -sticky => 'w');
$ch->attach($hs_label, -pod => "^\\s*Ort/Haltestelle");
$str_label = $hslabel_frame->Label
(-textvariable => \$act_value{Strasse},
-fg => $dim_color,
-font => $font{'bold'},
-anchor => 'nw',
)->grid(-column => 1, -row => 1, -sticky => 'w');
$ch->attach($str_label, -pod => "^Straße/Strecke");
$km_frame = $top_frame->Frame(-relief => 'raised',
-bd => 1);
my $kmcb = $km_frame->Button
(-textvariable => \$unit_km,
-class => 'FlatBut',
-command => \&change_unit,
)->pack;
if ($km_frame->can('UnderlineAll')) { $km_frame->UnderlineAll }
$km_frame->Label(-width => 5,
-textvariable => \$act_value{Km},
-font => $font{'bold'})->pack;
$balloon->attach($km_frame, -msg => M"Streckenlänge");
$ch->attach($km_frame, -pod => "^\\s*km");
$percent_frame = $top_frame->Frame
(-relief => 'raised', -bd => 1);
$percent_frame->Label(-text => "%")->pack;
$percent_frame->Label(-width => 4,
-textvariable => \$act_value{Percent},
-font => $font{'bold'})->pack;
$balloon->attach($percent_frame, -msg => M"% über Luftlinie");
$ch->attach($percent_frame, -pod => "^\\s*%");
$ampel_klein_photo = load_photo($top, 'ampel_klein.' . $default_img_fmt);
$ampel_klein_grey_photo = load_photo($top, 'ampel_klein_grey.' . $default_img_fmt);
$kopfstein_klein_photo = load_photo($top, 'kopfstein_klein.' . $default_img_fmt);
$kopfstein_klein_grey_photo = load_photo($top, 'kopfstein_klein_grey.' . $default_img_fmt);
$star_photo = load_photo($top, 'star.' . $default_img_fmt);
$newlayer_photo = load_photo($top, 'newlayer.' . $default_img_fmt);
for(my $i = 0; $i <= $#speed; $i++) {
my $ii = $i; # für das sub
$speed_frame[$i] = $top_frame->Frame
(-relief => 'raised', -bd => 1);
$ch->attach($speed_frame[$i], -pod => "^\\s*km/h");
my $b = $speed_frame[$i]->Button
(-textvariable => \$speed_txt[$i],
-class => 'FlatBut',
-command => sub { enter_speed($ii) },
)->grid(-row => 0, -column => 0);
{
my $f = $speed_frame[$i]->Frame->grid(-row => 0, -column => 1);;
$ampel_count_button->{"speed"}[$i] =
$f->Button
(-image => ($ampel_count->{"speed"}[$i]
? $ampel_klein_photo
: $ampel_klein_grey_photo),
-class => 'FlatBut',
-padx => 1,
-command => sub { change_ampel_count("speed", $ii) },
)->pack;
$balloon->attach($ampel_count_button->{"speed"}[$i],
-msg => M"Ampeln in Zeitberechnung aufnehmen");
$kopfstein_count_button->{"speed"}[$i] =
$f->Button
(-image => ($kopfstein_count->{"speed"}[$i]
? $kopfstein_klein_photo
: $kopfstein_klein_grey_photo),
-class => 'FlatBut',
-padx => 1,
-command => sub { change_kopfstein_count("speed", $ii) },
)->pack;
$balloon->attach($kopfstein_count_button->{"speed"}[$i],
-msg => M"Langsamfahrstrecken in Zeitberechnung aufnehmen");
}
my $l = $speed_frame[$i]->Button
(-width => 7,
-class => 'FlatBut',
-command => sub {
require BBBikeAlarm;
BBBikeAlarm::enter_alarm($top, \$act_value{Time}->[$ii],
-location => get_polar_location_of_route_end());
},
-textvariable => \$act_value{Time}->[$i],
-font => $font{'bold'},
)->grid(-row => 1, -column => 0, -columnspan => 2, -sticky => "ew");
foreach (qw(2 3)) {
$speed_frame[$i]->bind
("<ButtonPress-$_>" =>
sub { change_active_speed_power("speed", $ii) });
$b->bind("<ButtonPress-$_>" =>
sub { change_active_speed_power("speed", $ii) });
$l->bind("<ButtonPress-$_>" =>
sub { change_active_speed_power("speed", $ii) });
}
enter_leave_bind_for_help($speed_frame[$i],
[M"Geschwindigkeit eingeben",
M"Geschwindigkeit als Voreinstellung festlegen",
M"Geschwindigkeit als Voreinstellung festlegen",
]);
enter_leave_bind_for_help($l,
[M"Alarm setzen", undef, undef]);
enter_leave_bind_for_help($ampel_count_button->{"speed"}[$i],
[M"Ampeln in Zeitberechnung aufnehmen", "", ""]);
enter_leave_bind_for_help($kopfstein_count_button->{"speed"}[$i],
[M"Langsamfahrstrecken in Zeitberechnung aufnehmen", "", ""]);
}
if ($bikepwr) {
for(my $i = 0; $i <= $#power; $i++) {
my $ii = $i;
$power_frame[$i] = $top_frame->Frame
(-relief => 'raised', -bd => 1);
$ch->attach($power_frame[$i], -pod => "^\\s*W\$");
my $b = $power_frame[$i]->Button
(-textvariable => \$power_txt[$i],
-class => 'FlatBut',
-command => sub { enter_power($ii) },
)->grid(-row => 0, -column => 0);
{
my $f = $power_frame[$i]->Frame->grid(-row => 0, -column => 1);;
$ampel_count_button->{"power"}[$i] =
$f->Button
(-image => ($ampel_count->{"power"}[$i]
? $ampel_klein_photo
: $ampel_klein_grey_photo),
-class => 'FlatBut',
-padx => 1,
-command => sub { change_ampel_count("power", $ii) },
)->pack;
$balloon->attach($ampel_count_button->{"power"}[$i],
-msg => M"Ampeln in Zeitberechnung aufnehmen");
if (0) { # XXX activate if implemented in updatekm()
$kopfstein_count_button->{"power"}[$i] =
$f->Button
(-image => ($kopfstein_count->{"power"}[$i]
? $kopfstein_klein_photo
: $kopfstein_klein_grey_photo),
-class => 'FlatBut',
-padx => 1,
-command => sub { change_kopfstein_count("power", $ii) },
)->pack;
$balloon->attach($kopfstein_count_button->{"power"}[$i],
-msg => M"Langsamfahrstrecken in Zeitberechnung aufnehmen");
}
}
my $l = $power_frame[$i]->Button
(-width => 7,
-class => 'FlatBut',
-command => sub {
require BBBikeAlarm;
BBBikeAlarm::enter_alarm($top, \$act_value{PowerTime}->[$ii],
-location => get_polar_location_of_route_end());
},
-textvariable => \$act_value{PowerTime}->[$i],
-font => $font{'bold'},
)->grid(-row => 1, -column => 0, -columnspan => 2, -sticky => "ew");
foreach (qw(2 3)) {
$power_frame[$i]->bind
("<ButtonPress-$_>" =>
sub { change_active_speed_power("power", $ii) });
$b->bind("<ButtonPress-$_>" =>
sub { change_active_speed_power("power", $ii) });
$l->bind("<ButtonPress-$_>" =>
sub { change_active_speed_power("power", $ii) });
}
enter_leave_bind_for_help($power_frame[$i],
[M"Leistung eingeben",
M"Leistung als Voreinstellung festlegen",
M"Leistung als Voreinstellung festlegen",
]);
enter_leave_bind_for_help($l,
[M"Alarm setzen", undef, undef]);
# XXX not yet activated
#enter_leave_bind_for_help($ampel_count_button->{"speed"}[$i],
#[M"Ampeln in Zeitberechnung aufnehmen", "", ""]);
#enter_leave_bind_for_help($kopfstein_count_button->{"speed"}[$i],
#[M"Langsamfahrstrecken in Zeitberechnung aufnehmen", "", ""]);
}
}
change_active_speed_power($active_speed_power{Type}, $active_speed_power{Index});
##### Wind & Wetter #####
$wind_frame = $top_frame->Frame
(-relief => 'raised', -bd => 1);
my $wb = $wind_frame->Button
(-textvariable => \$act_value{Windlabel},
-class => 'FlatBut',
-command => sub { update_weather(1) },
-width => 22)->pack;
$ch->attach($wb, -pod => "^\\s*Datum der Winddaten");
my $wff = $wind_frame->Frame->pack(-fill => 'x');
my $wfewb = $wff->Button
(-font => $font{'bold'},
-textvariable => \$act_value{Wind},
-class => 'FlatBut',
-command => \&enter_wind,
)->pack(-fill => 'x', -expand => 1, -side => 'left');
$ch->attach($wfewb, -pod => "^\\s*Winddaten");
my $wfemb = $wff->Menubutton;
# Hack: Verwendung von -disabledforeground, weil es kein "label"-Kommando gibt.
my $wbm = $wfemb->Menu(-title => M("Wetterdaten"),
-disabledforeground => $wb->cget(-foreground));
$wbm->command(-label => M("Wetterstation").":",
-state => 'disabled',
-font => $font{'bold'},
);
foreach (['uptodate' => M"aktuellste"],
['dahlem2'],
['dahlem1'],
#['tempelhof'],
($advanced
? map { ["synop_$_" => "$_ (Synop)"] }
qw(potsdam berlin_dahlem berlin_tegel
berlin_tempelhof berlin_schoenefeld berlin_alexanderplatz)
: ()
),
($devel_host && $advanced
? (['wetterkarte' => 'Wetterkarte Berlin-Dahlem'])
: ()
),
) {
my $name = $_->[1];
if (!defined $name) {
$name = $wetter_name{$_->[0]}
}
$wbm->radiobutton
(-label => $name,
-variable => \$wetter_station,
-value => $_->[0],
-command => sub { update_weather($wetter_force_update) },
);
}
$wbm->separator;
$wbm->command(-label => M('Quelle').':',
-state => 'disabled',
-font => $font{'bold'},
);
foreach ([M"WWW", 'www'],
[M"lokaler Cache", 'local'],
[M"Datenbank", 'db'],
) {
next if $_->[1] eq 'db' && !wetter_dir_exists();
next if $_->[1] eq 'local' && !$devel_host;
$wbm->checkbutton
(-label => $_->[0],
-variable => \$wetter_source{$_->[1]},
-command => sub { update_weather($wetter_force_update) },
);
}
if (wetter_dir_exists()) {
$wbm->separator;
$wbm->command(-label => M('Auswahl aus Datenbank').':',
-state => 'disabled',
-font => $font{'bold'},
);
$wbm->command(-label => M"Dahlem (kurz)",
-command => sub { show_weather_db('dahlem2') });
$wbm->command(-label => M"Dahlem (lang)",
-command => sub { show_weather_db('dahlem1') });
# $wbm->command(-label => M"Tempelhof",
# -command => sub { show_weather_db('tempelhof') });
}
$wbm->separator;
$wbm->command(-label => M"Wind ignorieren",
-command => sub { ignore_weather() },
);
{
my $index = $wbm->index('last');
push @edit_mode_cmd, sub { $wbm->invoke($index) };
}
$wbm->command(-label => M"Aktualisierung",
-command => sub { update_weather(1) },
);
$wbm->checkbutton(-label => M"automatische Aktualisierung",
-variable => \$wetter_force_update,
-command => sub { update_weather($wetter_force_update) },
);
$wbm->checkbutton(-label => M"automatische Routenaktualisierung",
-variable => \$wetter_route_update,
);
menuright($wb, $wbm);
menuright($wfewb, $wbm);
menuarrow($wfemb, $wbm, undef, '-pack' => [-side => 'bottom']);
if ($wind_frame->can('UnderlineAll')) { $wind_frame->UnderlineAll }
$temp_frame = $top_frame->Frame
(-relief => 'raised', -bd => 1);
$ch->attach($temp_frame, -pod => "^\\s*Temp\$");
$temp_frame->Button
(-text => 'Temp',
-width => 7,
-class => 'FlatBut',
-command => sub {
require WWWBrowser;
WWWBrowser::start_browser('http://www.met.fu-berlin.de/deutsch/Wetter/beobachtung.html');
}
)->pack;
$temp_frame->Label(-textvariable => \$act_value{Temp},
)->pack;
arrange_topframe();
##### Iconframe #######################################################
$check_sub{'s'} = sub {
plot("str",'s');
};
$check_sub{'l'} = sub {
plot("str",'l');
};
$check_sub{'u'} = sub {
$p_draw{'u'} = $p_draw{'sperre_u'} = $str_draw{'u'};
$progress->InitGroup;
plot("str",'u');
plot("p",'u');
plot_sperre($p_file{"sperre_u"}, -abk => "sperre_u");
$progress->FinishGroup;
};
$check_sub{'b'} = sub {
$p_draw{'b'} = $p_draw{'sperre_b'} = $str_draw{'b'};
$progress->InitGroup;
plot('str','b');
plot('p','b');
plot_sperre($p_file{"sperre_b"}, -abk => "sperre_b");
$progress->FinishGroup;
};
$check_sub{'r'} = sub {
$p_draw{'r'} = $str_draw{'r'};
$progress->InitGroup;
plot('str','r');
plot('p','r');
$progress->FinishGroup;
};
$check_sub{'w'} = sub {
plot('str','w');
};
$check_sub{'f'} = sub {
plot('str','f');
};
$check_sub{'o'} = sub { plot('p','o',Shortname => 1) };
$check_sub{'p'} = sub { plot('p','p') };
## DEBUG_BEGIN
#BEGIN{mymstat("before do_iconframe BEGIN");} mymstat("before do_iconframe");
## DEBUG_END
$DockFrame = 'Frame';
# use FlatCheckbox or not?
# flat relief relies on Tie::Watch installed
if ($flat_relief and !eval 'require Tie::Watch; 1') {
$flat_relief = 0;
}
$Checkbutton = 'Checkbutton';
$Radiobutton = 'Radiobutton';
if ($flat_relief) {
eval { require Tk::FlatCheckbox };
if (!$@) {
$Checkbutton = 'FlatCheckbox';
if ($os ne 'win') {
$top->optionAdd('*FlatCheckbox*background' => 'grey80',
"startupFile");
}
}
eval { require Tk::FlatRadiobutton };
if (!$@) {
$Radiobutton = 'FlatRadiobutton';
if ($os ne 'win') {
$top->optionAdd('*FlatRadiobutton*background' => 'grey80',
"startupFile");
}
}
}
$splash_screen->Update(0.2) if $splash_screen;
do_iconframe() if $do_iconframe;
if ($standard_menubar) {
## DEBUG_BEGIN
#mymstat("set menubar");
## DEBUG_END
BBBike::Menubar::Set();
}
## DEBUG_BEGIN
#BEGIN{mymstat("after do_iconframe BEGIN");}
## DEBUG_END
# Erzeugt das Frame mit den Icons und den dazugehörigen Menüs
sub do_iconframe {
my $sym_frame = $ctrl_frame->Frame
(Name => 'symframe')->pack(-side => 'top', -anchor => 'w');
my $def_selectcolor;
{
# get default selectcolor
my $cb = $top->Checkbutton;
$def_selectcolor = $cb->cget(-selectcolor);
$cb->destroy;
}
$top->optionAdd('*symframe*padX' => 0, 'startupFile');
$top->optionAdd('*symframe*padY' => 0, 'startupFile');
# XXX ja?
$top->optionAdd('*symframe*indicatorOn' => $flat_relief, 'startupFile');
$top->optionAdd('*symframe*selectColor' => 'white', 'startupFile')
unless $flat_relief;
$top->optionAdd('*symframe*Menu*selectColor' => $def_selectcolor,
'startupFile');
if ($flat_relief) {
$top->optionAdd('*symframe*relief' => 'flat');
$top->optionAdd('*symframe*Menu*relief' => 'raised');
}
if ($small_icons) {
foreach (qw(Button Checkbutton Radiobutton Menubutton
FlatCheckbox FlatRadiobutton FireButton)) {
$top->optionAdd('*symframe*$_*padY' => 0, 'startupFile');
}
}
my($dock_port, $dock_port2);
eval {
die; # XXX not ready....
require Tk::DockFrame;
$DockFrame = 'DockFrame';
$dock_port = $sym_frame->DockPort->grid(-row => 0,
-column => 0,
-sticky => 'nw');
$dock_port2 = $sym_frame->DockPort->grid(-row => 0,
-column => 1,
-sticky => 'nw');
};
use vars qw($curr_row);
local $curr_row = 0;
$misc_frame = $sym_frame->$DockFrame
(-bd => 1, -relief => 'raised',
($DockFrame eq 'DockFrame' ? ('-dock' => $dock_port) : ()));
if ($DockFrame ne 'DockFrame') {
$misc_frame->grid(-row => 0,
-column => 0,
-sticky => 'nsew');
}
$misc_frame->gridColumnconfigure(999, -weight => 1); # force buttons to the left
$col = 0;
##### Straßen #####
$strasse_photo = load_photo($misc_frame, 'strasse.' . $default_img_fmt);
my $strasse_check = $misc_frame->$Checkbutton
(image_or_text($strasse_photo, 'Str'),
-variable => \$str_draw{'s'},
-command => $check_sub{'s'},
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($strasse_check, -msg => M"Straßen");
$ch->attach($strasse_check, -pod => "^\\s*Straßen-Symbol");
my $strcmb = $misc_frame->Menubutton;
$strcmb->focus;
my $strcm = $strcmb->Menu(-title => M("Straßen"));
menu_entry_choose_ort
($strcm, 's',
-accelerator => 'S',
-strchooseortargs =>
{'-markstartifactive' => 1,
-completelistbutton => sub { choose_from_plz(-interactive => 1) },
-completelistbuttonlabel => M"Alle Straßen",
},
-strextrachoosemenuaction =>
sub {
$strcm->cascade(-label => M('Erweiterte Auswahl').' ...');
my $ausm = $strcm->Menu(-title => M("Erweiterte Auswahl").' ...');
$strcm->entryconfigure('last', -menu => $ausm);
$plzmcmd = $ausm->command
(-label => M"Komplette Straßenliste",
-command => sub { choose_from_plz(-interactive => 1) });
$ausm->command
(-label => M"Telefonbuch-Datenbank (Straße)",
-command => sub {
telefonbuch_dialog("str");
});
$ausm->command
(-label => M"Telefonbuch-Datenbank (Name)",
-command => sub {
telefonbuch_dialog("tel");
});
if ($advanced) {
$ausm->command(-label => M"MySQL-DB",
-command => sub {
push @INC, "$FindBin::RealBin/miscsrc";
eval {
require TelbuchDBApprox;
TelbuchDBApprox::tk_choose($top);
};
if ($@) {
status_message($@, "die");
}
});
}
$ausm->command(-label => M"Volltextsuche",
-accelerator => "Ctrl-F",
-command => sub {
require BBBikeAdvanced;
search_anything();
});
},
);
$strcm->separator;
$strcm->cascade(-label => M"Straßenkategorien");
{
my $skm = $strcm->Menu(-title => M"Straßenkategorien");
$strcm->entryconfigure('last', -menu => $skm);
my @l = ([M"wichtige Hauptstraßen", 'HH'],
[M"Hauptstraßen", 'H'],
[M"Nebenstraßen", 'N'],
[M"für Kfz gesperrte Straßen", 'NN']);
foreach (@l) {
$skm->checkbutton
(-label => $_->[0],
-variable => \$str_restrict{'s'}->{$_->[1]},
-command => sub {
pending(1, 'replot-str-s');
},
);
}
if ($advanced) {
$skm->separator;
$skm->checkbutton
(-label => M"Autobahnen/Kfz-Straßen",
-variable => \$str_draw{'sBAB'},
-command => sub {
plot("str", "sBAB",
-filename => get_strassen_file("strassen_bab"));
},
);
}
}
$strcm->checkbutton(-label => M"Höhenangaben",
-variable => \$p_draw{'hoehe'},
-command => sub { plot('p','hoehe') });
$strcm->checkbutton(-label => M"Radwege",
-variable => \$str_draw{'rw'},
-command => sub { plot('str','rw')},
-accelerator => 'Shift-R',
);
my $radwege_check_index = $strcm->index('last');
$strcm->cascade(-label => M"Radwegekategorien");
{
my $rkm = $strcm->Menu(-title => M"Radwegekategorien");
$strcm->entryconfigure('last', -menu => $rkm);
foreach my $t (@Radwege::category_order) {
my $cat_code = $Radwege::category_code{$t} || '';
next if $cat_code eq 'RW0';
$rkm->checkbutton
(-label => $Radwege::category_name{$t},
-variable => \$str_restrict{'rw'}->{$cat_code},
-command => sub {
pending(1, 'replot-str-rw');
},
);
}
}
$strcm->checkbutton(-label => M"Einbahn-/gesperrte Straßen",
-variable => \$p_draw{'sperre'},
-command => sub { plot_sperre() },
-accelerator => 'G',
);
my $sperre_check_index = $strcm->index('last');
$strcm->checkbutton(-label => M"Fähren",
-variable => \$str_draw{'e'},
-command => sub { plot('str','e') });
$strcm->checkbutton(-label => M"Ampeln",
-variable => \$p_draw{'lsa'},
-command => sub { plot('p','lsa') },
-accelerator => 'A',
);
my $ampeln_check_index = $strcm->index('last');
$strcm->checkbutton(-label => M"Outline zeichnen",
-variable => \$str_outline{'s'},
-command => sub {
pending(1, 'replot-str-s');
},
);
if ($os ne 'win' || $advanced) {
# No rotation on win possible.
$strcm->checkbutton(-label => M"Straßennamen",
-variable => \$str_name_draw{'s'},
-command => sub {
pending(1, 'replot-str-s');
},
);
}
$strcm->checkbutton(-label => M"Straßenqualität",
-variable => \$str_draw{'qs'},
-command => sub { plot('str','qs') },
-accelerator => 'Shift-Q',
);
my $qualitaet_check_index = $strcm->index('last');
$strcm->cascade(-label => M"Qualitätskategorien");
{
my $qm = $strcm->Menu(-title => M"Qualitätskategorien");
$strcm->entryconfigure('last', -menu => $qm);
foreach (0 .. 3) {
my $cat = "Q$_";
my $label = $category_attrib{$cat}->[ATTRIB_SINGULAR];
$qm->checkbutton
(-label => $label,
-variable => \$str_restrict{'qs'}->{$cat},
-command => sub {
$str_restrict{'ql'}->{$cat} =
$str_restrict{'qs'}->{$cat};
pending(1, 'replot-str-qs');
pending(1, 'replot-str-ql');
},
);
}
}
$strcm->checkbutton(-label => M"Sonstige Beeinträchtigungen",
-variable => \$str_draw{'hs'},
-command => sub { plot('str','hs') },
);
my $handicap_check_index = $strcm->index('last');
$strcm->checkbutton(-label => M"Unbeleuchtete Straßen",
-variable => \$str_draw{'nl'},
-command => sub { plot('str','nl') },
);
$strcm->checkbutton(-label => M"Grüne Wege",
-variable => \$str_draw{'gr'},
-command => sub { plot('str','gr') },
);
$strcm->checkbutton(-label => M"Vorfahrt",
-variable => \$p_draw{'vf'},
-command => sub { plot('p','vf') },
);
my $fragezeichen_check_index;
if ($advanced) {
$strcm->checkbutton(-label => M"Fragezeichen",
-variable => \$str_draw{'fz'},
-command => sub { plot('str','fz') },
-accelerator => '?',
);
$fragezeichen_check_index = $strcm->index('last');
}
if ($advanced) {
#XXXXXXXXXXXXXXXXX del?
if (0) {
$strcm->checkbutton(-label => M"Kommentare",
-variable => \$str_draw{'comm'},
-command => sub { plot('str','comm') },
);
}
#XXXXXXXXXXXXXXXXX do it nicer, maybe using an "all" category?
$strcm->cascade(-label => M"Kommentarkategorien");
{
my $c_bpcm = $strcm->Menu(-title => M"Kommentarkategorien");
$strcm->entryconfigure("last", -menu => $c_bpcm);
foreach my $_type (@comments_types) {
next if $_type =~ /^(cyclepath|mount)$/; # handled elsewhere
my $type = my $label = $_type;
my $def = 'comm-' . $type;
$c_bpcm->checkbutton
(-label => $label,
-variable => \$str_draw{$def},
-command => sub {
my $file = get_strassen_file("comments_" . $type);
plot('str', $def, Filename => $file);
},
);
}
}
}
$strcm->command(-label => M"Radroute auswählen",
-command => sub {
choose_ort(qw(s comm-route),
-markstartifactive => 1);
});
if ($advanced) {
$strcm->checkbutton
(-label => M"Steigungen",
-variable => \$str_draw{'mount'},
-command => \&plot_mount,
);
}
menu_entry_up_down($strcm, $tag_group{'str_s'});
menuright($strasse_check, $strcm);
menuarrow($strcmb, $strcm, $col++, -special => 'LAYER');
##### Landstraßen #####
$landstrasse_photo =
load_photo($misc_frame, 'landstrasse.' . $default_img_fmt);
my $landstrasse_check = $misc_frame->$Checkbutton
(image_or_text($landstrasse_photo, 'LStr'),
-variable => \$str_draw{'l'},
-command => $check_sub{'l'},
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($landstrasse_check, -msg => M"Landstraßen");
$ch->attach($landstrasse_check, -pod => "^\\s*Landstraßen-Symbol");
my $lstrcmb = $misc_frame->Menubutton;
my $lstrcm = $lstrcmb->Menu(-title => M"Landstraßen");
menu_entry_choose_ort($lstrcm, 'l',
-accelerator => 'L',
-strchooseortargs => {'-markstartifactive' => 1});
$lstrcm->separator;
$lstrcm->checkbutton(-label => M"Outline zeichnen",
-variable => \$str_outline{'l'},
-command => sub {
pending(1, 'replot-str-l');
},
);
$lstrcm->checkbutton(-label => M"Landstraßen jwd zeichnen",
-variable => \$str_far_away{'l'},
-command => sub {
pending(1, 'replot-str-l');
},
-accelerator => 'Shift-L',
);
my $land_jwd_check_index = $lstrcm->index('last');
$lstrcm->checkbutton(-label => M"Straßennamen",
-variable => \$str_name_draw{'l'},
-command => sub {
pending(1, 'replot-str-l');
},
);
$lstrcm->checkbutton(-label => M"Straßennummern",
-variable => \$str_nr_draw{'l'},
-command => sub {
pending(1, 'replot-str-l');
},
);
$lstrcm->checkbutton(-label => M"Straßenqualität",
-variable => \$str_draw{'ql'},
-command => sub { plot('str','ql') },
-accelerator => 'Shift-Q',
);
my $qualitaet_l_check_index = $lstrcm->index('last');
$lstrcm->checkbutton(-label => M"Sonstige Beeinträchtigungen",
-variable => \$str_draw{'hl'},
-command => sub { plot('str','hl') },
);
my $handicap_l_check_index = $lstrcm->index('last');
$lstrcm->checkbutton(-label => M"Radwege im Umland",
-variable => \$str_draw{'comm-cyclepath'},
-command => sub {
my $file = get_strassen_file("comments_cyclepath");
plot('str', 'comm-cyclepath', Filename => $file);
},
-accelerator => 'Shift-R',
);
my $radwege_l_check_index = $strcm->index('last');
menu_entry_up_down($lstrcm, $tag_group{'str_l'});
menuright($landstrasse_check, $lstrcm);
menuarrow($lstrcmb, $lstrcm, $col++, -special => 'LAYER');
##### Orte #####
$ort_photo = load_photo($misc_frame, 'ort.' . $default_img_fmt);
my $ort_check = $misc_frame->$Checkbutton
(image_or_text($ort_photo, 'Ort'),
-variable => \$p_draw{'o'},
-command => $check_sub{'o'},
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($ort_check, -msg => M"Orte im Umland");
$ch->attach($ort_check, -pod => "^\\s*Ort-Symbol");
my $ocmb = $misc_frame->Menubutton;
my $ocm = $ocmb->Menu(-title => M"Orte");
menu_entry_choose_ort($ocm, 'o', -accelerator_p => 'O',
-pchooseortargs => {'-markstartifactive' => 1});
$ocm->separator;
$ocm->checkbutton(-label => M"Ortsnamen",
-variable => \$p_name_draw{'o'},
-command => sub {
pending(1, 'replot-p-o');
},
);
$ocm->cascade(-label => M"Kategorie");
{
my $m = $ocm->Menu(-title => M"Ortkategorie");
$ocm->entryconfigure('last', -menu => $m);
for my $cat ('auto', 0 .. 5) {
$m->radiobutton(-label => ($cat eq 'auto' ? M"Auto" :
$cat == 0 ? M"Alle" : $cat),
-variable => \$place_category,
-value => $cat,
-command => sub {
pending(1, 'replot-p-o');
},
);
}
}
$ocm->checkbutton(-label => M"Orte jwd zeichnen",
-variable => \$p_far_away{'o'},
-command => sub {
pending(1, 'replot-p-o');
},
-accelerator => 'Shift-O',
);
my $ort_jwd_check_index = $ocm->index('last');
$ocm->separator;
$ocm->cascade(-label => M"Schriftgröße");
{
my $m = $ocm->Menu(-title => M"Ort-Schriftgröße");
$ocm->entryconfigure('last', -menu => $m);
foreach my $fontsize ([M"klein", 0],
[M"normal", 1],
[M"groß", 2],
[M"sehr groß", 3],
) {
$m->radiobutton(-label => $fontsize->[0],
-variable => \$orte_label_size,
-value => $fontsize->[1],
-command => sub {
pending(1, 'replot-p-o');
},
);
}
}
$ocm->checkbutton(-label => M"Überlappungen vermeiden",
-variable => \$no_overlap_label{'o'},
-command => sub {
pending(1, 'replot-p-o');
},
);
if ($advanced) { # XXX funktioniert noch nicht mit no_verlap zusammen
$ocm->checkbutton(-label => M"Umrandung um Labels",
-variable => \$do_outline_text{'o'},
-command => sub {
pending(1, 'replot-p-o');
},
);
}
menu_entry_up_down($ocm, $tag_group{'p_o'});
menuright($ort_check, $ocm);
menuarrow($ocmb, $ocm, $col++, -special => 'LAYER');
##### U-Bahn #####
$ubahn_photo = load_photo($misc_frame, 'ubahn.' . $default_img_fmt);
my $ubahn_check = $misc_frame->$Checkbutton
(image_or_text($ubahn_photo, 'U'),
-variable => \$str_draw{'u'},
-command => $check_sub{'u'},
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($ubahn_check, -msg => M"U-Bahn");
$ch->attach($ubahn_check, -pod => "^\\s*U-Bahn-Symbol");
my $ubcmb = $misc_frame->Menubutton;
my $ubcm = $ubcmb->Menu(-title => M"U-Bahn");
menu_entry_choose_ort($ubcm, 'u', -accelerator => 'U',
-pchooseortargs => {'-markstartifactive' => 1},
-strblockings => 1,
);
$ubcm->checkbutton(-label => M"U-Bhf-Namen",
-variable => \$p_name_draw{'u'},
-command => sub {
pending(1, 'replot-p-u');
},
);
$ubcm->checkbutton(-label => M"Überlappungen vermeiden",
-variable => \$no_overlap_label{'u'},
-command => sub {
pending(1, 'replot-p-u');
},
);
$ubcm->checkbutton(-label => M"Fahrradfreundliche Zugänge",
-variable => \$p_draw{'u_bg'},
-command => sub {
plot('p', 'u_bg');
},
);
$ubcm->separator;
foreach ([M"VBB-Zone Berlin A", 'UA'],
[M"VBB-Zone Berlin B", 'UB'],
[M"in Bau", 'U0'],
) {
$ubcm->checkbutton(-label => $_->[0],
-variable => \$str_restrict{'u'}->{$_->[ATTRIB_PLURAL]},
-command => sub {
$progress->InitGroup;
pending(1, 'replot-str-u');
pending(1, 'replot-p-u');
$progress->FinishGroup;
},
);
}
menu_entry_up_down($ubcm, $tag_group{'str_u'});
menuright($ubahn_check, $ubcm);
menuarrow($ubcmb, $ubcm, $col++,
-menulabel => M"U-Bahn", -special => 'LAYER');
##### S-Bahn #####
$sbahn_photo = load_photo($misc_frame, 'sbahn.' . $default_img_fmt);
my $sbahn_check = $misc_frame->$Checkbutton
(image_or_text($sbahn_photo, 'S'),
-variable => \$str_draw{'b'},
-command => $check_sub{'b'},
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($sbahn_check, -msg => M"S-Bahn");
$ch->attach($sbahn_check, -pod => "^\\s*S-Bahn-Symbol");
my $sbcmb = $misc_frame->Menubutton;
my $sbcm = $sbcmb->Menu(-title => M"S-Bahn");
menu_entry_choose_ort($sbcm, 'b', -accelerator => 'B',
-pchooseortargs => {'-markstartifactive' => 1},
-strblockings => 1,
);
$sbcm->checkbutton(-label => M"S-Bhf-Namen",
-variable => \$p_name_draw{'b'},
-command => sub {
pending(1, 'replot-p-b');
},
);
$sbcm->checkbutton(-label => M"Überlappungen vermeiden",
-variable => \$no_overlap_label{'b'},
-command => sub {
pending(1, 'replot-p-b');
},
);
$sbcm->checkbutton(-label => M"Fahrradfreundliche Zugänge",
-variable => \$p_draw{'b_bg'},
-command => sub {
plot('p', 'b_bg');
},
);
$sbcm->separator;
foreach ([M"VBB-Zone Berlin A", 'SA'],
[M"VBB-Zone Berlin B", 'SB'],
[M"VBB-Zone Berlin C", 'SC'],
[M"in Bau/stillgelegt", 'S0'],
) {
$sbcm->checkbutton(-label => $_->[0],
-variable => \$str_restrict{'b'}->{$_->[ATTRIB_PLURAL]},
-command => sub {
$progress->InitGroup;
pending(1, 'replot-str-b');
pending(1, 'replot-p-b');
$progress->FinishGroup;
},
);
}
menu_entry_up_down($sbcm, $tag_group{'str_b'});
menuright($sbahn_check, $sbcm);
menuarrow($sbcmb, $sbcm, $col++,
-menulabel => M"S-Bahn", -special => 'LAYER');
##### RB #####
$rbahn_photo = load_photo($misc_frame, 'rbahn.' . $default_img_fmt);
my $rbahn_check = $misc_frame->$Checkbutton
(image_or_text($rbahn_photo, 'RB'),
-variable => \$str_draw{'r'},
-command => $check_sub{'r'},
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($rbahn_check, -msg => M"Regionalbahn");
$ch->attach($rbahn_check, -pod => "^\\s*RB-Symbol");
my $rbcmb = $misc_frame->Menubutton;
my $rbcm = $rbcmb->Menu(-title => M"Regionalbahn");
menu_entry_choose_ort($rbcm, 'r', -accelerator => 'R',
-pchooseortargs => {'-markstartifactive' => 1},
-strblockings => 1,
);
$rbcm->checkbutton(-label => M"R-Bhf-Namen",
-variable => \$p_name_draw{'r'},
-command => sub {
pending(1, 'replot-p-r');
},
);
$rbcm->checkbutton(-label => M"Überlappungen vermeiden",
-variable => \$no_overlap_label{'r'},
-command => sub {
pending(1, 'replot-p-r');
},
);
$rbcm->separator;
foreach ([M"VBB-Zonen Berlin A und B", 'RB'],
[M"VBB-Zone Berlin C", 'RC'],
[M"außerhalb Berlin ABC", 'R'],
[M"in Bau/stillgelegt", 'R0'],
) {
$rbcm->checkbutton(-label => $_->[0],
-variable => \$str_restrict{'r'}->{$_->[ATTRIB_PLURAL]},
-command => sub {
$progress->InitGroup;
pending(1, 'replot-str-r');
pending(1, 'replot-p-r');
$progress->FinishGroup;
},
);
}
menu_entry_up_down($rbcm, $tag_group{'str_r'});
menuright($rbahn_check, $rbcm);
menuarrow($rbcmb, $rbcm, $col++,
-menulabel => M"R-Bahn", -special => 'LAYER');
##### Gewässer #####
$wasser_photo = load_photo($misc_frame, 'wasser.' . $default_img_fmt);
my $wasser_check = $misc_frame->$Checkbutton
(image_or_text($wasser_photo, 'H20'),
-variable => \$str_draw{'w'},
-command => $check_sub{'w'},
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($wasser_check, -msg => M"Gewässer");
$ch->attach($wasser_check, -pod => "^\\s*Gewässer-Symbol");
my $wcmb = $misc_frame->Menubutton;
my $wcm = $wcmb->Menu(-title => M"Gewässer");
menu_entry_choose_ort($wcm, 'w', -accelerator => 'W');
$wcm->separator;
$wcm->checkbutton(-label => M"Outline zeichnen",
-variable => \$str_outline{'w'},
-command => sub {
$str_outline{'i'} = $str_outline{'w'};
pending(1, 'replot-str-w');
},
);
$wcm->checkbutton(-label => M"Namen der Gewässer",
-variable => \$str_name_draw{'w'},
-command => sub {
pending(1, 'replot-str-w');
},
);
$wcm->checkbutton(-label => M"Gewässer in der Stadt zeichnen",
-variable => \$wasserstadt,
-command => sub {
pending(1, 'replot-str-w');
},
);
$wcm->checkbutton(-label => M"Gewässer im Umland zeichnen",
-variable => \$wasserumland,
-command => sub {
pending(1, 'replot-str-w');
},
-accelerator => 'Shift-W',
);
my $wasserumland_check_index = $wcm->index('last');
$wcm->checkbutton(-label => M"Gewässer jwd zeichnen",
-variable => \$str_far_away{'w'},
-command => sub {
pending(1, 'replot-str-w');
},
);
menu_entry_up_down($wcm, $tag_group{'str_w'});
menuright($wasser_check, $wcm);
menuarrow($wcmb, $wcm, $col++, -special => 'LAYER');
##### Flächen #####
$flaechen_photo = load_photo($misc_frame, 'flaechen.' . $default_img_fmt);
my $flaechen_check = $misc_frame->$Checkbutton
(image_or_text($flaechen_photo, 'Fl'),
-variable => \$str_draw{'f'},
-command => $check_sub{'f'},
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($flaechen_check, -msg => M"sonstige Flächen");
$ch->attach($flaechen_check, -pod => "^\\s*Flächen-Symbol");
my $fcmb = $misc_frame->Menubutton;
my $fcm = $fcmb->Menu(-title => M"sonstige Flächen");
menu_entry_choose_ort($fcm, 'f', -accelerator => 'F');
$fcm->checkbutton(-label => M"Namen der Flächen",
-variable => \$str_name_draw{'f'},
-command => sub {
pending(1, 'replot-str-f');
},
);
$fcm->separator;
if ($advanced) {
menu_entry_choose_ort($fcm, 'z');
$fcm->separator;
}
$fcm->checkbutton(-label => M"Grenzen von Berlin",
-variable => \$str_draw{'g'},
-command => sub { plot('str','g') });
$fcm->checkbutton(-label => M"Grenzen von Potsdam",
-variable => \$str_draw{'gP'},
-command => sub { plot('str','gP') });
$fcm->checkbutton(-label => M"Staatsgrenzen", # Deutschland
-variable => \$str_draw{'gD'},
-command => sub { plot('str','gD') });
menu_entry_up_down($fcm, $tag_group{'str_f'});
menuright($flaechen_check, $fcm);
menuarrow($fcmb, $fcm, $col++, -special => 'LAYER');
##### Sehenswürdigkeiten, Kneipen etc. #####
my $sehenswuerdigkeiten_check = $misc_frame->$Checkbutton
(image_or_text($star_photo, '*'),
-variable => \$str_draw{'v'},
-command => sub { plot('str','v') },
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($sehenswuerdigkeiten_check, -msg => M"Sehenswürdigkeiten etc.");
$ch->attach($sehenswuerdigkeiten_check, -pod => "^\\s*Sehenswürdigkeiten-Symbol");
my $knmb = $misc_frame->Menubutton;
my $knm = $knmb->Menu(-title => M"Sehenswürdigkeiten etc.");
$knm->checkbutton(-label => M"Sehenswürdigkeiten",
-variable => \$str_draw{'v'},
-command => sub { plot('str','v') });
$knm->command(-label => M"Sehenswürdigkeit auswählen",
-command => sub { choose_ort(qw(s v),
-markstartifactive => 1) });
$knm->checkbutton(-label => M"Namen der Sehenswürdigkeiten",
-variable => \$str_name_draw{'v'},
-command => sub {
pending(1, 'replot-str-v');
},
);
$knm->checkbutton(-label => M"Überlappungen vermeiden",
-variable => \$no_overlap_label{'v'},
-command => sub {
pending(1, 'replot-str-v');
},
);
$knm->separator;
my @kneipen_list = ('kn');
if ($advanced) {
push @kneipen_list, qw(rest ki);
}
foreach my $f (@kneipen_list) {
if (-f "$FindBin::RealBin/data/$p_file{$f}") {
$knm->checkbutton(-label => $p_attrib{$f}->[ATTRIB_PLURAL],
-variable => \$p_draw{$f},
-command => sub { plot('p',$f) });
$knm->command(-label => Mfmt("%s auswählen", $p_attrib{$f}->[ATTRIB_SINGULAR]),
-command => sub { choose_ort('p', $f) });
}
}
if (0 && $advanced) { # XXX Wird nicht mehr gepflegt...
$knm->command(-label => M"Film auswählen",
-command => sub {
require BBBikeAdvanced;
search_movie();
});
}
$knm->command(-label => M"Persönliche Orte",
-command => sub {
require BBBikePersonal;
BBBikePersonal::dialog();
});
$knm->separator;
$knm->checkbutton(-label => M"Obst",
-variable => \$p_draw{'obst'},
-command => sub { plot('p','obst') });
#XXXX menu_entry_up_down($knm, $tag_group{'str_f'});
menuright($sehenswuerdigkeiten_check, $knm);
menuarrow($knmb, $knm, $col++, -special => 'LAYER');
##### Zusätzliche Kartenebenen #####
my $newlayer_label = $misc_frame->Label
(image_or_text($newlayer_photo, '*'),
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($newlayer_label, -msg => M"Zusätzliche Kartenebenen");
$ch->attach($newlayer_label, -pod => "^\\s*Zusätzliche Kartenebenen");
my $nlmb = $misc_frame->Menubutton;
my $nlm = $nlmb->Menu(-title => M"Zusätzliche Kartenebenen");
{
# XXX this used to be LazyMenu to postpone loading of layers
# XXX maybe re-enable this one day if I find a possibility to
# update the cascade menu without showing the menu first.
my $cusm = $nlm;
#XXX del:
# $BBBike::Menubar::additional_layer_menu = $cusm;
# $BBBike::Menubar::additional_layer_menu = $BBBike::Menubar::additional_layer_menu; # peacify -w
$cusm->{BBBike_Menulabel} = M"Zusätzliche Kartenebenen";
# $opbm->entryconfigure('last', -menu => $cusm);
# $cusm->command(-label => M"Zusätzliche Layer",
# -state => 'disabled',
# -font => $font{'bold'});
$cusm->command(-label => M"Straßen-Layer zeichnen",
-command => sub {
require BBBikeAdvanced;
tk_plot_additional_layer('str') });
if ($advanced) {
$cusm->command(-label => M"Sperrungen-Layer zeichnen", # XXX label? in advanced mode because there is no way to delete the blockings from net!
-command => sub {
require BBBikeAdvanced;
plot_additional_sperre_layer() });
}
$cusm->command(-label => M"Punkte-Layer zeichnen",
-command => sub {
require BBBikeAdvanced;
tk_plot_additional_layer('p') });
$cusm->command(-label => M"Straßen/Punkte auswählen",
-command => sub {
require BBBikeAdvanced;
choose_from_additional_layer() });
$cusm->cascade(-label => M("Letzte geöffnete Layer")."...");
{
my $m = $cusm->Menu(-title => M("Letzte geöffnete Layer")."...");
$cusm->entryconfigure("last", -menu => $m);
$main::last_loaded_layers_obj =
{
List => [],
File => "$main::bbbike_configdir/last_layers",
Menu => $m,
Title => M("Letzte Layer").":",
Cb => sub {
my($file, %args) = @_;
my $linetype = delete $args{-linetype};
require BBBikeAdvanced;
plot_additional_layer($linetype, $file, %args);
},
Max => 12,
};
load_last_loaded($last_loaded_layers_obj);
}
if ($Tk::platform ne 'MSWin32') {
$cusm->command(-label => M"Umordnen",
-accelerator => 'Shift-X',
-command => sub {
require BBBikeAdvanced;
layer_editor() });
}
$cusm->command(-label => M"Layer löschen",
-command => sub {
require BBBikeAdvanced;
delete_additional_layer() });
$cusm->command(-label => M"Ausschnitt an Layer anpassen",
-command => sub {
require BBBikeAdvanced;
tk_zoom_view_for_layer() });
$cusm->command(-label => M"Scrollregion an Layer anpassen",
-command => sub {
require BBBikeAdvanced;
tk_set_scrollregion_for_layer() });
$cusm->command(-label => M"Scrollregion für Layer vergrößern",
-command => sub {
require BBBikeAdvanced;
tk_enlarge_scrollregion_for_layer() });
if ($advanced) {
$cusm->checkbutton(-label => M"Linienbreite 1 Punkt",
-variable => \$default_line_width,
-offvalue => undef, # XXX don't work,
# set to 0... ???
-onvalue => 1,
);
}
$cusm->radiobutton(-label => M"WWW-Klickmodus", # XXX bessere Bezeichnung
-variable => \$map_mode,
-value => MM_URL_SELECT,
-command => \&set_map_mode,
);
$cusm->separator;
$cusm->command(-label => M"Gpsman-Daten zeichnen",
-command => sub {
draw_gpsman_data($top);
});
$cusm->command(-label => M"GPS-Track-Animation",
-command => sub {
require BBBikeAdvanced;
gps_animation($top);
});
}
menuright($newlayer_label, $nlm);
menuarrow($nlmb, $nlm, $col++, -special => 'LAYER');
# room for plugin buttons
my $mode_layer_plugin_frame = $misc_frame->Frame->grid
(-row => $curr_row, -column => $col, -sticky => 's');
$top->Advertise(ModeLayerPluginFrame => $mode_layer_plugin_frame);
my $mode_layer_menu_plugin_frame = $misc_frame->Frame->grid
(-row => $curr_row+1, -column => $col, -sticky => 'news');
$top->Advertise(ModeLayerMenuPluginFrame => $mode_layer_menu_plugin_frame);
$col++;
$misc_frame->Label(-text => ' ')->grid(-row => $curr_row,
-column => $col++);
if (0 && !$no_map) { # no map anymore...
require BBBikeAdvanced;
map_button($misc_frame, $curr_row, \$col);
}
###### Vergrößern #####
my $mapscale_plus_photo = load_photo($misc_frame,
'viewmag+.' . $default_img_fmt);
my $mapscale_plus_button = $misc_frame->Button
(image_or_text($mapscale_plus_photo, '+'),
-command => sub { scalecanvas($c, 2) },
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($mapscale_plus_button, -msg => M"Vergrößern");
$ch->attach($mapscale_plus_button, -pod => "^\\s*Vergrößern-Symbol");
$col++;
###### Verkleinern #####
my $mapscale_minus_photo = load_photo($misc_frame,
'viewmag-.' . $default_img_fmt);
my $mapscale_minus_button = $misc_frame->Button
(image_or_text($mapscale_minus_photo, '-'),
-command => sub { scalecanvas($c, 0.5) },
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($mapscale_minus_button, -msg => M"Verkleinern");
$ch->attach($mapscale_minus_button, -pod => "^\\s*Verkleinern-Symbol");
$col++;
##### Scale of the map #####
my $scale_button = $misc_frame->Button
(-textvariable => \$mapscale,
-width => 9,
-relief => 'ridge',
-bd => ($small_icons ? 0 : 2),
-command => sub { enter_scale() },
-font => $font{'fix15'},
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($scale_button, -msg => M"Maßstab");
$ch->attach($scale_button, -pod => "^\\s*Maßstab-Feld");
$default_mapscale = calc_mapscale();
$col++;
##### Übersichtskarte
my $berlin_overview_small_photo
= load_photo($top, 'berlin_overview_small.' . $default_img_fmt);
my $overview_check = $misc_frame->$Checkbutton
(image_or_text($berlin_overview_small_photo, 'Ovw'),
-variable => \$show_overview,
-command => sub { show_overview() },
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$overview_check->bind('<Button-3>' => sub { $show_overview = 1;
show_overview(1) });
enter_leave_bind_for_help($overview_check,
[M"Übersichtskarte zeigen",
"",
M"Übersichtskarte neu laden",
]);
$balloon->attach($overview_check, -msg => M"Übersichtskarte");
$ch->attach($overview_check, -pod => "^\\s*Übersichtskarten-Symbol");
$col++;
$misc_frame->Label(-text => ' ')->grid(-row => $curr_row,
-column => $col++);
##### Windrose #####
my $windrose_photo = load_photo($misc_frame,
'windrose.' . $default_img_fmt);
eval {
die "Low memory" if $lowmem;
require Tk::FireButton;
Tk::FireButton->VERSION(0.04);
};
my $err = $@;
warn $err if $verbose and $err;
my $firebutton = (!$err ? 'FireButton' : 'Button');
$windrose_button = $misc_frame->$firebutton
(image_or_text($windrose_photo, "Wind\nrose"),
-command => \&windrose,
-takefocus => 0,
);
if ($windrose_button->isa('Tk::FireButton')) {
$windrose_button->configure(-repeatinterval => 300);
}
$windrose_button->grid(-row => $curr_row, -column => $col, -rowspan => 2);
$windrose_button->bind("<ButtonPress-2>" => sub { windrose(5) });
$windrose_button->bind("<ButtonPress-3>" => sub { center_best() });
enter_leave_bind_for_help($windrose_button,
[M"Karte scrollen",
M"Karte schneller scrollen",
M"Karte zentrieren"]);
$balloon->attach($windrose_button, -msg => M"Kartenausschnitt bewegen");
$ch->attach($windrose_button, -pod => "^\\s*Windrosen-Symbol");
$col++;
$misc_frame->Label(-text => ' ')->grid(-row => $curr_row,
-column => $col++);
$top->Advertise(MapFrame => $misc_frame);
##### misc_frame2 ... #####
$misc_frame2 = $sym_frame->$DockFrame
(-bd => 1, -relief => 'raised',
($DockFrame eq 'DockFrame' ? ('-dock' => $dock_port2) : ()));
$col = 0;
##### Komplex: Suche/Route ... #####
$search_photo = load_photo($misc_frame2, 'search.' . $default_img_fmt);
my $search_button = $misc_frame2->$Radiobutton
(image_or_text($search_photo, 'Route'),
-variable => \$map_mode,
-value => MM_SEARCH,
-command => \&set_map_mode,
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($search_button, -msg => M"Route suchen");
$ch->attach($search_button, -pod => "^\\s*Route suchen");
my $sbmb = $misc_frame2->Menubutton;
my $sbm = $sbmb->Menu(-title => M"Route suchen");
$sbm->radiobutton(-label => M"Suchmodus",
-variable => \$map_mode,
-value => MM_SEARCH,
-command => \&set_map_mode,
);
$sbm->cascade(-label => M('Route löschen'));
my $sbm_reset_menu_index = $sbm->index("last");
$sbm->command(-label => M"Route wiederherstellen (Undo)",
-command =>\&get_undo_route,
-accelerator => 'Ctrl-Z');
# XXX Brauche ich diesen Menüpunkt?
$sbm->command(-label => M"Route aktualisieren",
-command => \&redraw_path);
$sbm->command(-label => M"Suche wiederholen",
-command => \&re_search_gui);
$sbm->command(-label => M"Rückweg",
-command => \&way_back_gui);
$sbm->command(-label => M"Register",
-command => \&show_register,
-accelerator => '*',
);
$sbm->command(-label => M"Ausschnitt an Route anpassen",
-command => sub { zoom_view() });
$sbm->cascade(-label => M"Automatische Anpassung");
{
my $aasm = $sbm->Menu(-title => M"Automatische Anpassung");
$sbm->entryconfigure('last', -menu => $aasm);
$aasm->checkbutton(-label => M"nach dem Laden anpassen",
-variable => \$zoom_loaded_route,
-onvalue => 1,
-offvalue => 0);
$aasm->checkbutton(-label => M"nach dem Laden zentrieren",
-variable => \$center_loaded_route);
$aasm->checkbutton(-label => M"nach der Berechnung anpassen",
-variable => \$zoom_new_route,
-onvalue => 1,
-offvalue => 0);
$aasm->checkbutton(-label => M"nach der Berechnung aus der Straßenliste anpassen",
-variable => \$zoom_new_route_chooseort,
-onvalue => 1,
-offvalue => 0);
}
$sbm->separator;
if ($advanced) {
add_search_menu_entries($sbm);
}
if ($advanced || $lowmem) {
$sbm->command(-label => M"Straßennetz neu berechnen",
-command => \&make_net);
$sbm->command(-label => M"undef netz",
-command => sub {
undef $net;
undef $comments_net;
undef $comments_pos_net
});
}
if ($advanced) {
add_search_net_menu_entries($sbm);
$sbm->separator;
}
$sbm->checkbutton(-label => M"Steigungen/Gefälle zeigen",
-variable => \$show_grade);
$sbm->cascade(-label => M('Einfärben der Route').' ...');
{
my $fbm = $sbm->Menu(-title => M('Einfärben der Route').' ...');
$sbm->entryconfigure('last', -menu => $fbm);
foreach my $d ([M"Wind", 'wind'],
[M"Leistung", 'power'],
[M"schwarz", 'black'],
[M"rot", 'red'],
[M"blau", 'blue'],
) {
my $val = $d->[1];
$fbm->radiobutton(-label => $d->[0],
-variable => \$coloring,
-value => $val,
-command => \&redraw_path,
);
}
$fbm->checkbutton(-label => M"gestrichelt",
-variable => \$route_dashed,
-command => \&redraw_path,
);
$fbm->checkbutton(-label => M"mit Richtungspfeil",
-variable => \$route_arrowed,
-command => \&redraw_path,
);
if ($advanced && $devel_host) {
$fbm->command(-label => "spezial gestrichelt",
-command => sub {
# XXX this functionality should probably go into addpoint_xy
for ($c->find("withtag"=>"route")) { $c->createLine($c->coords($_),-fill=>"black",-dash=>[1,3],-tags=>["route"],-width=>$c->itemcget($_,-width)) if $c->type($_) eq "line"}
});
}
}
$sbm->command
(-label => M"Streckenprofil",
-command => sub {
require BBBikeProfil;
@{$bbbike_context}{qw/Profil Coords Hoehe Transient Canvas/} =
(new BBBikeProfil,
\@realcoords,
\%hoehe,
$transient,
$c);
$bbbike_context->{Profil}->Show($top, $bbbike_context);
});
require BBBikeVia;
{
$sbm->cascade(-label => M('Start/Via/Ziel').' ...');
my $viam = $sbm->Menu(-title => M('Start/Via/Ziel').' ...');
$sbm->entryconfigure('last', -menu => $viam);
BBBikeVia::menu_entries($viam);
}
$sbm->separator;
$sbm->checkbutton(-label => M"Kalorienverbrauch anzeigen",
-variable => \$show_calories,
-command => sub { show_calories() },
);
menuright($search_button, $sbm);
menuarrow($sbmb, $sbm, $col++, -menulabel => M"R~oute");
#####
$search_pref_photo = load_photo($misc_frame2, 'search_pref.' . $default_img_fmt);
my $search_pref_button = $misc_frame2->$Checkbutton
(image_or_text($search_pref_photo, 'Sucheinst.'),
-variable => \$show_enter_opt_preferences,
-command => \&toggle_enter_opt_preferences,
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($search_pref_button, -msg => M"Sucheinstellungen");
$ch->attach($search_pref_button,
-pod => "^\\s*Sucheinstellungen");
my $sb2mb = $misc_frame2->Menubutton;
my $sb2m = $sb2mb->Menu(-title => M"Sucheinstellungen");
# Note interplay between these two checkbuttons:
$sb2m->checkbutton(-label => M"Einbahn-/gesperrte Straßen beachten",
-variable => \$sperre{'sperre'},
-command => sub {
$sperre{'einbahn'} = $sperre{'wegfuehrung'} = $sperre{'sperre'};
if (!$sperre{'sperre'}) {
$sperre{'einbahn-strict'} = 0;
}
pending(1, 'recalc-net');
},
);
$sb2m->checkbutton(-label => M"Einbahn-/gesperrte Straßen *strikt* beachten",
-variable => \$sperre{'einbahn-strict'},
-command => sub {
if ($sperre{'einbahn-strict'}) {
$sperre{'einbahn'} = $sperre{'wegfuehrung'} = $sperre{'sperre'} = 1;
}
pending(1, 'recalc-net');
},
);
$sb2m->cascade(-label => M"Benutzerdefinierte Sperrungen");
{
my $bdm = $sb2m->Menu(-title => M"Benutzerdefinierte Sperrungen");
$sb2m->entryconfigure('last', -menu => $bdm);
$bdm->radiobutton(-label => M"Definieren",
-variable => \$map_mode,
-value => MM_USEREDIT,
-accelerator => "Shift-U",
-command => sub { # XXX don't duplicate code, see <U>
set_cursor('delnet');
});
$bdm->command(-label => M"Standard laden",
-command => sub { load_user_dels() });
$bdm->command(-label => M"Standard speichern",
-command => sub { save_user_dels() });
$bdm->command(-label => M"Laden",
-command => sub {
my $file = $top->getOpenFile;
if (defined $file) {
load_user_dels($file);
}
});
$bdm->command(-label => M"Speichern",
-command => sub {
my $file = $top->getSaveFile;
if (defined $file) {
save_user_dels($file);
}
});
if ($advanced) {
$bdm->checkbutton
(-label => M"Aktive Sperrungen zeichnen und beachten",
-variable => \$show_active_temp_blockings,
-command => sub {
activate_temp_blockings($show_active_temp_blockings);
},
);
$bdm->command
(-label => M"Aktive Sperrungen zeichnen für Datum",
-command => \&active_temp_blockings_for_date_dialog,
);
$bdm->command
(-label => M"Aktive und zukünftige Sperrungen zeichnen",
-command => sub {
$show_active_temp_blockings = 1;
activate_temp_blockings($show_active_temp_blockings, -from => time);
},
);
$bdm->command
(-label => M"Frühere und zukünftige Sperrungen zeichnen",
-command => sub {
$show_active_temp_blockings = 1;
activate_temp_blockings($show_active_temp_blockings, -from => 0);
},
);
$bdm->command
(-label => M"Speichern für temp_blockings",
-command => sub {
require BBBikeEdit;
BBBikeEdit::temp_blockings_editor();
}
);
}
$bdm->command(-label => M"Alle löschen",
-command => sub { delete_user_dels() });
if ($advanced) {
$bdm->command(-label => M"In die Zwischenablage kopieren",
-command => sub {
my $s = $net->create_user_deletions_object;
# XXX usage of @inslauf_selection is a hack!
$c->SelectionOwn;
@inslauf_selection = $s->as_string;
},
);
}
}
$sb2m->checkbutton(-label => M"Tragen strikt vermeiden",
-variable => \$sperre{'tragen'},
-command => sub {
pending(1, 'recalc-net');
},
);
$sb2m->checkbutton(-label => M"Schlechte Wege vermeiden",
-variable => \$sperre{'Q3'},
-command => sub {
pending(1, 'recalc-net');
},);
$sb2m->checkbutton(-label => M"Fähren verwenden",
-variable => \$use_faehre,
-command => sub {
pending(1, 'recalc-net');
},
);
$sb2m->separator;
$sb2m->checkbutton(-label => M"Straßenqualität-Optimierung",
-variable => \$qualitaet_s_optimierung,
);
$sb2m->checkbutton(-label => M"Straßenkategorie-Optimierung",
-variable => \$strcat_optimierung,
-command => sub {
if ($strcat_optimierung) {
$N_RW_optimization = 0;
}
},
);
$sb2m->checkbutton(-label => M"Optimierung der sonstigen Beeinträchtigungen",
-variable => \$handicap_s_optimierung,
);
$sb2m->checkbutton(-label => M"Ampel-Optimierung",
-variable => \$ampel_optimierung,
-command => \&calc_ampel_optimierung,
);
$sb2m->checkbutton(-label => M"Radwege-Optimierung",
-variable => \$radwege_optimierung,
-command => sub {
if ($radwege_optimierung) {
$N_RW_optimization = 0;
}
}
);
$sb2m->checkbutton(-label => M"Hauptstraßen ohne Radwege/Busspuren meiden",
-variable => \$N_RW_optimization,
-command => sub {
if ($N_RW_optimization) {
$radwege_optimierung = 0;
$strcat_optimierung = 0;
}
}
);
{
$sb2m->cascade(-label => M("Grüne Wege")."...");
my $gwm = $sb2m->Menu(-title => M"Grüne Wege");
$sb2m->entryconfigure('last', -menu => $gwm);
$gwm->radiobutton(-label => M"egal",
-variable => \$green_optimization,
-value => 0,
);
$gwm->radiobutton(-label => M"bevorzugen",
-variable => \$green_optimization,
-value => 1,
);
$gwm->radiobutton(-label => M"stark bevorzugen",
-variable => \$green_optimization,
-value => 2,
);
}
$sb2m->checkbutton(-label => M"Unbeleuchtete Straßen meiden",
-variable => \$unlit_streets_optimization,
);
$sb2m->checkbutton(-label => M"Steigungsoptimierung",
-variable => \$steigung_optimierung,
);
if ($advanced && $devel_host) {
# sowieso vorerst sinnlos...
$sb2m->checkbutton(-label => M"Abbiege-Optimierung",
-variable => \$abbiege_optimierung,
);
}
$sb2m->separator;
$sb2m->command(-label => M"Optimierungsparameter einstellen",
-command => \&enter_opt_preferences,
);
if ($advanced) {
# experimenteller Code
$sb2m->command(-label => M"Optimierungsparameter einstellen Nr.2",
-command => \&enter_opt_preferences2,
);
require BBBikeAdvanced;
penalty_menu($sb2m);
}
menuright($search_pref_button, $sb2m);
menuarrow($sb2mb, $sb2m, $col++, -menulabel => M"Sucheinstellungen");
#####
my $strlist_photo = load_photo($misc_frame2,
'strlist.' . $default_img_fmt);
my $strlist_button = $misc_frame2->$Checkbutton
(image_or_text($strlist_photo, 'StrL'),
-variable => \$show_strlist,
-command => \&show_route_strname,
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($strlist_button,
-msg => M"Beschreibung der aktuellen Route");
$ch->attach($strlist_button,
-pod => "^\\s*Beschreibung der aktuellen Route");
my $slbmb = $misc_frame2->Menubutton;
my $slbm = $slbmb->Menu(-title => M"Beschreibung der aktuellen Route");
$slbm->checkbutton
(-label => M"Routenliste",
-accelerator => "Shift-B",
-variable => \$show_strlist,
-command => \&show_route_strname);
$slbm->checkbutton
(-label => M"Automatisches Anzeigen",
-variable => \$auto_show_list,
);
$slbm->command
(-label => M"Statistik",
-command => \&show_statistics,
);
if ($advanced) {
$slbm->command(-label => M"Ampeln an der aktuellen Route",
-command => sub { ampeln_on_route(@realcoords) });
$slbm->command(-label => M"GPS-Upload mit Ampelschaltungen",
-command => sub {
require "$FindBin::RealBin/GpsmanDataAmpeln.pm";
make_ampel_route();
});
}
menuright($strlist_button, $slbm);
menuarrow($slbmb, $slbm, $col, -menulabel => M"Routen~liste");
$col++;
my $reset_photo = load_photo($misc_frame2, 'cross.' . $default_img_fmt);
my $reset_button = $misc_frame2->Button
(image_or_text($reset_photo, 'X'),
-command => \&delete_route,
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($reset_button, -msg => M"Route löschen");
$ch->attach($reset_button, -pod => "^\\s*Route löschen");
my $resetmb = $misc_frame2->Menubutton;
my $resetm = $resetmb->Menu(-title => M"Route löschen");
$resetm->command(-label => M"Gesamte Route löschen",
-command => \&delete_route,
);
$resetm->command(-label => M"Letzten Punkt der Route löschen",
-command => \&mouse_dellast,
-accelerator => '<-',
);
$resetm->command(-label => M"Bis zum letzten Via löschen",
-command => \&deltovia,
-accelerator => 'Del',
);
menuright($reset_button, $resetm);
menuarrow($resetmb, $resetm, $col, -menulabel => M"Route löschen");
$col++;
# XXX Check this on Windows! XXX The Tk::Menu manual says: do not
# use "clone" outside of the Tk library!
$sbm->entryconfigure($sbm_reset_menu_index, -menu => $resetm->clone($sbmb, "normal"));
my $reverse_photo = load_photo($misc_frame2,
'rueckweg.' . $default_img_fmt);
my $reverse_button = $misc_frame2->Button
(image_or_text($reverse_photo, 'Rev'),
-command => \&way_back_gui,
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$reverse_button->bind("<ButtonPress-3>" => sub {
IncBusy($top);
eval {
reverse_route();
};
DecBusy($top);
});
$balloon->attach($reverse_button, -msg => M"Rückweg");
$ch->attach($reverse_button, -pod => "^\\s*Rückweg-Symbol");
$col++;
my $koord_photo = load_photo($misc_frame2, 'koord.' . $default_img_fmt);
my $buttonpoint_check = $misc_frame2->$Radiobutton
(image_or_text($koord_photo, 'Koord'),
-variable => \$map_mode,
-value => MM_BUTTONPOINT,
-command => \&set_map_mode,
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($buttonpoint_check, -msg => M"Koordinaten in Zwischenablage");
$ch->attach($buttonpoint_check, -pod => "^\\s*Koordinaten-Symbol");
my($bpcm);
if (!$advanced) {
$buttonpoint_check->configure(-state => 'disabled');
} else {
my $bpcmb = $misc_frame2->Menubutton;
$bpcm = $bpcmb->Menu(-title => M"Bearbeiten");
advanced_coord_menu($bpcm);
menuright($buttonpoint_check, $bpcm);
menuarrow($bpcmb, $bpcm, $col, -menulabel => M"~Bearbeiten");
}
$col++;
my $info_photo = load_photo($misc_frame2, 'info.' . $default_img_fmt);
my $info_check = $misc_frame2->$Radiobutton
(image_or_text($info_photo, 'Info'),
-variable => \$map_mode,
-value => MM_INFO,
-command => \&set_map_mode,
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($info_check, -msg => M"Information");
$ch->attach($info_check, -pod => "^\\s*Info-Symbol");
$col++;
my $drag_photo = load_photo($misc_frame2, 'movehand.' . $default_img_fmt);
my $drag_check = $misc_frame2->$Radiobutton
(image_or_text($drag_photo, 'Drag'),
-variable => \$map_mode,
-value => MM_DRAG,
-command => \&set_map_mode,
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($drag_check, -msg => M"Karte verschieben");
# XXX $ch->attach($drag_check, -pod => "^\\s*Karte verschieben");
$col++;
# room for plugin buttons
my $mode_plugin_frame = $misc_frame2->Frame->grid
(-row => $curr_row, -column => $col, -sticky => 's');
$top->Advertise(ModePluginFrame => $mode_plugin_frame);
my $mode_menu_plugin_frame = $misc_frame2->Frame->grid
(-row => $curr_row+1, -column => $col, -sticky => 'news');
$top->Advertise(ModeMenuPluginFrame => $mode_menu_plugin_frame);
$col++;
$misc_frame2->Label(-text => ' ')->grid(-row => $curr_row,
-column => $col++);
## DEBUG_BEGIN
#mymstat("iconframe: load/save/print buttons");
## DEBUG_END
##### Komplex: Laden/Speichern/Drucken #####
my $load_photo = load_photo($misc_frame2, 'open.' . $default_img_fmt);
my $load_button = $misc_frame2->Button
(image_or_text($load_photo, 'Load'),
-command => sub { load_save_route(0) }
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($load_button, -msg => M"Laden einer Route");
$ch->attach($load_button, -pod => "^\\s*Öffnen-Symbol");
my $last_loaded_mb = $misc_frame2->Menubutton;
$last_loaded_menu = $last_loaded_mb->Menu
(-title => M"letzte geöffnete Routen",
-disabledforeground => $wb->cget(-foreground));
menuright($load_button, $last_loaded_menu);
menuarrow($last_loaded_mb, $last_loaded_menu, $col,
-menulabel => M"letzte geöffnete Routen",
-special => "OPEN");
$col++;
my $save_photo = load_photo($misc_frame2, 'save.' . $default_img_fmt);
my $save_button = $misc_frame2->Button
(image_or_text($save_photo, 'Save'),
-command => sub { load_save_route(1) }
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($save_button, -msg => M"Sichern einer Route");
$ch->attach($save_button, -pod => "^\\s*Speichern-Symbol");
my $svmb = $misc_frame2->Menubutton;
my $svm = $svmb->Menu(-title => M"Exportieren",
-disabledforeground => $save_button->cget(-foreground));
$svm->command(-label => M('Karte speichern als').' ...',
-state => "disabled",
-font => $font{"bold"});
foreach my $fmt (['Postscript', 'ps'],
['PDF', 'pdf'],
['PNG', 'png'],
['GIF', 'gif'],
['JPEG', 'jpeg'],
['PPM', 'ppm'],
) {
$svm->command(-label => "$fmt->[0]",
-command => sub {
$svm->after(50, sub { export_visible_map($fmt->[1]) });
});
if ($fmt->[1] eq 'ps') {
$svm->cascade(-label => M("Postscript-Auflösung").' ...');
my $psm = $svm->Menu(-title => M("Postscript-Auflösung").' ...');
$svm->entryconfigure("last", -menu => $psm);
my(%sizes) = (36 => 0, 72 => 0, 100 => 0, 150 => 0);
$sizes{int($top_dpi)}++;
foreach my $size (sort { $a <=> $b } keys %sizes) {
$psm->radiobutton(-label => $size . " dpi"
. ($size == int($top_dpi) ? " ".M"(normal)" : ""),
-variable => \$ps_image_res,
-value => $size . "x" . $size,
);
}
}
}
$svm->separator;
$svm->command(-label => M('Route speichern als').' ...',
-state => "disabled",
-font => $font{"bold"});
foreach my $fmt (
# vector oriented
'PDF',
'XFig',
($advanced ? ('SVG') : ()),
# map/gis
'bbd (BBBike data)',
($advanced ? ('ESRI') : ()),
# XXX not yet ready: ($devel_host ? ('OVL (TOP50)') : ()),
# GPS
($advanced ?
(
# XXX not yet --- bbd2gpx only supports wpt based routes: 'GPX-Route',
'GPX-Track',
) : ()),
['G7toWin (ASCII)', 'G7toWin_ASCII'],
['GPSMAN (Tracklog)', 'GpsmanData'],
['Waypoint+ (Track)', 'WaypointPlus'],
'-',
'GPS direkt',
[M('Route zu einem Garmin senden'), 'DirectGarmin'],
[M('Senden der Route zu einem Garmin simulieren'), 'DirectGarmin_Test'],
) {
if ($fmt eq '-') {
$svm->separator;
} elsif ($fmt eq 'GPS direkt') {
$svm->command(-label => M($fmt),
-state => "disabled",
-font => $font{"bold"});
} elsif ($fmt eq 'PDF') {
$svm->command
(-label => $fmt,
-command => \&pdf_export,
);
} elsif ($fmt eq 'SVG') {
$svm->command
(-label => $fmt,
-command => \&svg_export,
);
} elsif ($fmt eq 'XFig') {
$svm->command
(-label => $fmt,
-command => sub {
my $file = $top->getSaveFile
(-defaultextension => '.fig',
-filetypes => [[M"FIG-Dateien" => '.fig'],
[M"Alle Dateien" => '*']],
);
return unless defined $file;
require Tk::CanvasFig;
IncBusy($top);
eval {
mkdir $file."-images", 0755;
$c->fig(-file => $file,
-imagetype => (is_in_path("ppmtopcx") ? 'pcx' : 'xpm'),
-imagedir => $file."-images");
};
warn __LINE__ . ": $@" if $@;
DecBusy($top);
});
} elsif ($fmt =~ /^ovl/i) {
$svm->command
(-label => $fmt,
-command => sub {
require GPS::Ovl;
GPS::Ovl->new->tk_export(coords => \@realcoords);
}
);
} elsif ($fmt =~ /^bbd/) {
if (-x "$FindBin::RealBin/miscsrc/bbr2bbd") {
$svm->command
(-label => $fmt,
-command => \&save_route_as_bbd
);
}
} elsif ($fmt =~ /^esri/i) {
if (-x "$FindBin::RealBin/miscsrc/bbd2esri" &&
-x "$FindBin::RealBin/miscsrc/bbr2bbd"
) {
$svm->command
(-label => $fmt,
-command => \&save_route_as_esri
);
}
} elsif ($fmt eq 'GPX-Route') {
$svm->command
(-label => $fmt,
-command => sub { save_route_as_gpx(-as => "route") },
);
} elsif ($fmt eq 'GPX-Track') {
$svm->command
(-label => $fmt,
-command => sub { save_route_as_gpx(-as => "track") },
);
} elsif (ref $fmt eq 'ARRAY') {
$svm->command
(-label => "$fmt->[0]",
-command => sub { gps_interface(@$fmt) },
);
}
}
menuright($save_button, $svm);
menuarrow($svmb, $svm, $col++, -menulabel => M"Speichern",
-special => 'SAVE');
my $print_photo = load_photo($misc_frame2, 'printer.' . $default_img_fmt);
my $print_button = $misc_frame2->Button
(image_or_text($print_photo, 'Print'),
-command => sub { print_function() },
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($print_button, -msg => M"Drucken der Karte");
$ch->attach($print_button, -pod => "^\\s*Drucken-Symbol");
my $prmb = $misc_frame2->Menubutton;
my $prm = $prmb->Menu(-title => M"Druckeinstellungen");
foreach my $color ([M"Farbe", 'color'],
[M"Graustufen", 'gray'],
[M"Schwarz/Weiß", 'mono'],
) {
$prm->radiobutton(-label => $color->[0],
-value => $color->[1],
-variable => \$ps_color,
);
}
$prm->separator;
$prm->radiobutton(-label => M"Landscape",
-value => 1,
-variable => \$ps_rotate,
);
$prm->radiobutton(-label => M"Portrait",
-value => 0,
-variable => \$ps_rotate,
);
$prm->separator;
$prm->checkbutton(-label => M"auf A4 skalieren",
-variable => \$ps_scale_a4,
);
$prm->checkbutton(-label => M"Legende",
-variable => \$use_legend,
);
$prm->checkbutton(-label => M"Legende rechts statt links",
-variable => \$use_legend_right,
);
menuright($print_button, $prm);
menuarrow($prmb, $prm, $col++, -menulabel => M"Drucken",
-special => 'PRINT');
$misc_frame2->Label(-text => ' ')->grid(-row => $curr_row,
-column => $col++);
##### Bikepower #####
my $bike_photo = load_photo($misc_frame2, 'bicycle.' . $default_img_fmt);
my $bike_button = $misc_frame2->Button
(image_or_text($bike_photo, 'Bike'),
-command => sub { my %args;
unless (defined $ENV{LANG} && $ENV{LANG} !~ /^de/) {
$args{-lang} = 'de';
}
$args{-applyhook} = $args{-savedefaultshook} = sub {
# XXX
};
eval {
my $bp = $bp_obj->tk_interface($top, %args);
set_as_toolwindow($bp);
};
if ($@) { status_message($@, 'err') }
}
)->grid(-row => $curr_row, -column => $col, -rowspan => 2);
$bike_button->configure(-state => 'disabled') if !$bikepwr;
$balloon->attach
($bike_button,
-balloonmsg => M"Bikepower",
-statusmsg => M"Bikepower: Eingeben von fahrradspezifischen Daten");
$ch->attach($bike_button, -pod => "^\\s*Fahrrad-Symbol");
$col++;
$misc_frame2->Label(-text => ' ')->grid(-row => $curr_row,
-column => $col++);
##### Komplex: sonstige Optionen #####
my $opt_photo = load_photo($misc_frame2, 'opt.' . $default_img_fmt);
my $opt_button = $misc_frame2->Button
(image_or_text($opt_photo, 'Opt'),
-command => \&optedit,
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
if (!$opt) {
$opt_button->configure(-state => 'disabled');
}
$balloon->attach($opt_button, -msg => M"Optionen");
$ch->attach($opt_button, -pod => "^\\s*Options-Symbol");
my $opbmb = $misc_frame2->Menubutton;
my $opbm = $BBBike::Menubar::option_menu = $opbmb->Menu(-title => M"Einstellungen");
$BBBike::Menubar::option_menu = $BBBike::Menubar::option_menu; # peacify -w
# XXX wenn die Save-Funktion funktioniert, folgendes immer ausführen:
if ($advanced && $devel_host) {
$opbm->command(-label => M("Konfigurations-Wizard"),
-command => sub { require Wizards;
config_wizard($top);
});
$opbm->separator;
}
if ($advanced) {
$opbm->radiobutton(-label => M"Landscape",
-variable => \$orientation,
-value => 'landscape',
-command => sub {
my $replotsub = get_plotted();
set_landscape();
$replotsub->();
});
$opbm->radiobutton(-label => M"Portrait",
-variable => \$orientation,
-value => 'portrait',
-command => sub {
my $replotsub = get_plotted();
set_portrait();
$replotsub->();
});
}
$opbm->cascade(-label => M('Scope').' ...');
{
my $sbm = $opbm->Menu(-title => M('Scope').' ...');
$opbm->entryconfigure('last', -menu => $sbm);
$sbm->command(-label => M"Stadt",
-command => \&city_settings);
$sbm->command(-label => M"näheres Umland",
-command => \®ion_settings);
$sbm->command(-label => M"jwd",
-command => \&jwd_settings);
}
$opbm->separator;
if (defined $c_balloon) {
$opbm->cascade(-label => M('Canvas balloon').' ...');
{
my $cbm = $opbm->Menu(-title => M('Canvas balloon').' ...');
$opbm->entryconfigure('last', -menu => $cbm);
foreach my $d ([M('kein'), 0],
[M('nur Route'), 1],
[M('überall'), 2]) {
my $val = $d->[1];
$cbm->radiobutton(-label => $d->[0],
-variable => \$use_c_balloon,
-value => $val,
-command => sub { $c_balloon->configure
(-show => $val);
},
);
}
}
}
$opbm->command
(-label => M"Farben ändern",
-command => sub {
require Tk::ColorEditor;
my $cedit = $top->ColorEditor;
$cedit->Show;
},
);
$opbm->command
(-label => M"Schriftart ändern",
-command => sub {
eval {
require Tk::FontDialog;
Tk::FontDialog->VERSION(0.05);
};
if ($@) {
return if !perlmod_install_advice('Tk::FontDialog');
}
my $fedit = $top->FontDialog;
my $f = $fedit->Show;
if (defined $f) {
$font{'normal'} = $f;
$top->optionAdd("*font" => $font{'normal'}, 'userDefault');
# XXX RefontTree ändert auch $font{'standard'}
$top->RefontTree(-font => $font{'normal'}); # -canvas nicht
set_fonts($font{'normal'});
}
},
);
$opbm->checkbutton(-label => M"gedrehte Zeichensätze",
-variable => \$use_font_rot);
$opbm->checkbutton(-label => M"Ständige Markierung",
-variable => \$steady_mark,
);
$opbm->command(-label => M"Markierung löschen",
-command => sub {
$c->delete('show');
if ($showmark_after) {
$showmark_after->cancel;
undef $showmark_after;
}
},
);
$opbm->cascade(-label => M"Mittlere Maustaste");
{
my $sopbm = $opbm->Menu(-title => M"Mittlere Maustaste");
$opbm->entryconfigure('last', -menu => $sopbm);
foreach my $val (B2M_NONE, B2M_SCAN, B2M_FASTSCAN,
B2M_AUTOSCROLL, B2M_DELLAST,
) {
my $label = $b2_mode_desc{$val};
$label = "???" if (!defined $label);
$sopbm->radiobutton(-label => $label,
-variable => \$b2_mode,
-value => $val,
-command => \&set_b2,
);
}
}
{
$opbm->cascade(-label => M('Aktualisieren').' ...');
my $am = $opbm->Menu(-title => M('Aktualisieren').' ...');
$opbm->entryconfigure("last", -menu => $am);
my $set_immediate_sub = sub {
my($val) = @_;
foreach (qw(replot-str-s replot-str-l
replot-str-qs replot-str-ql
replot-str-hs replot-str-hl
replot-str-r replot-str-b
replot-str-u replot-str-rw
replot-str-v replot-str-f
replot-p-r replot-p-b
replot-p-u
replot-p-o replot-str-w
)) { # XXX weitere replots???
$immediate{$_} = $val;
}
};
my $rp; # XXX ein bißchen hacky (weiter unten)
foreach my $def ([M"Auf Anfrage aktualisieren", 0],
[M"Ausgabe sofort aktualisieren", 1],
[M"Ausgabe verzögert aktualisieren", 2],
) {
my $val = $def->[1];
my $button = $am->radiobutton
(-label => $def->[0],
-variable => \$immediate_replot,
-value => $val,
-command => sub { $set_immediate_sub->($val) });
$rp = $button if ($val == $immediate_replot);
}
# XXX hier müßten eigentlich auch die drei Alternativen stehen
my $rc = $am->checkbutton
(-label => M"Netz sofort aktualisieren",
-variable => \$immediate_recalc,
-command => sub {
$immediate{'recalc-net'} = $immediate_recalc;
},
);
if ($Tk::VERSION < 803 || $Tk::VERSION >= 804.025) {
$rp->cget(-command)->Call if $rp;
$rc->cget(-command)->Call;
} else {
$rp->cget(-command)->() if $rp;
$rc->cget(-command)->();
}
$am->command(-label => M"Alles aktualisieren",
-command => sub { update() });
}
### not yet..., see start_followmouse()
# $opbm->checkbutton(-label => M"Followmouse",
# -variable => \$followmouse,
# -command => sub {
# if ($followmouse) {
# start_followmouse();
# } else {
# stop_followmouse();
# }
# },
# );
if ($advanced) {
stderr_menu($opbm);
}
$opbm->checkbutton(-label => M"Wortreich (verbose)",
-variable => \$verbose,
-command => \&set_verbose);
$opbm->command
(-label => M"Daten-Update über das Internet",
-command => sub {
if ($devel_host && $ENV{HOST} !~ /^devpc01/) {
status_message("Kein Update auf cabulja/vran/cvrsnica/spiff möglich!", "die");
die;
}
require Tk::Dialog;
if ($top->Dialog
(-title => M"Update",
-text => M("Soll das Update gestartet werden?\nJe nach Internet-Verbindung und Stand der Daten kann das Update 5 bis 10 Minuten dauern. Alternativ können die Dateien als ZIP-Datei von\n$BBBike::BBBIKE_UPDATE_DATA_CGI\ngeholt und in das Verzeichnis\n$FindBin::RealBin/data\nausgepackt werden.\n"),
-bitmap => 'question',
-buttons => [M"Ja", M"Nein"])->Show eq M"Ja") {
require Update;
Update::bbbike_data_update();
}
},
);
$opbm->command(-label => M"Alarmliste",
-command => sub {
require BBBikeAlarm;
BBBikeAlarm::tk_show_all();
},
);
if ($advanced && $os ne "win") {
$opbm->command(-label => M"Start BBBike-Server",
-command => sub {
require BBBikeServer;
if (!BBBikeServer::running()) {
BBBikeServer::create_server($top);
}
},
);
}
if (!$standard_menubar) {
plugin_menu($opbm);
}
if ($advanced) {
advanced_option_menu($opbm);
}
menuright($opt_button, $opbm);
menuarrow($opbmb, $opbm, $col++,
-menulabel => M"Einstellungen", -special => 'OPTIONS');
my $help_photo = load_photo($misc_frame2, 'help.' . $default_img_fmt);
my $help_button = $misc_frame2->Button
(image_or_text($help_photo, '?'),
-command => sub {
eval {
require Tk::Pod;
Tk::Pod->Dir($FindBin::Bin);
$top->Pod(-file => $FindBin::Script . ".pod",
-title => M"Dokumentation zu BBBike");
};
if ($@) {
my $r;
my $bbbike_html = Tk::findINC("bbbike.html");
my $url;
if (defined $bbbike_html && -r $bbbike_html) {
$url = "file:$bbbike_html";
require WWWBrowser;
$r = WWWBrowser::start_browser($url);
}
if (!$r) {
return if !perlmod_install_advice('Tk::Pod');
}
}
},
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($help_button, -msg => M"Hilfe");
$ch->attach($help_button, -pod => "^\\s*Hilfe-Symbol");
my $hpbmb = $misc_frame2->Menubutton;
my $hpbm = $hpbmb->Menu(-title => M"Hilfe");
$hpbm->checkbutton(-label => M"Legende",
-command => sub {
toggle_legend($top, -realcanvas => $c);
},
-variable => \$show_legend,
-accelerator => 'F1');
my $this_index = $hpbm->index("last");
$top->bind("<F1>" => sub { $hpbm->invoke($this_index) });
$hpbm->checkbutton(-label => M"Maushilfe",
-command => \&toggle_mouse_help,
-variable => \$show_mouse_help,
);
if ($use_contexthelp) {
$hpbm->command(-label => M"Kontexthilfe",
-command => sub { $ch->activate });
}
my $bbbike_html = Tk::findINC("bbbike.html");
my $url;
if (defined $bbbike_html && -r $bbbike_html) {
$url = "file:$bbbike_html";
$hpbm->command
(-label => M"Dokumentation (lokal)",
-command => sub {
require WWWBrowser;
WWWBrowser::start_browser($url);
});
}
$hpbm->command
(-label => M"Dokumentation (WWW)",
-command => sub {
my $url = "$BBBike::BBBIKE_SF_WWW/bbbike/bbbike.html";
require WWWBrowser;
WWWBrowser::start_browser($url);
});
$hpbm->command(-label => M('Über').' ...',
-command => sub { show_logo('as_about') });
$hpbm->command(-label => M"Copyright",
-command => sub { copying_viewer($top) });
$hpbm->command(-label => M"Changes",
-command => sub { simple_file_viewer
($top, "$FindBin::RealBin/CHANGES",
-title => M"Changes",
-class => "BBBike Changes",
);
});
## XXX del: Ist schon seit Aenon nicht mehr notwendig
# $hpbm->command(-label => M"Busy-Zeiger zurücksetzen",
# -command => sub { ResetBusy($top) });
menuright($help_button, $hpbm);
menuarrow($hpbmb, $hpbm, $col++, -menulabel => M"~Hilfe");
my $context_help_button;
if (!$small_icons) {
# The only reason for the restriction: the image on the button
# is too large.
$context_help_button =
$ch->HelpButton($misc_frame2)->grid
(-row => $curr_row, -column => $col,
-rowspan => 2);
$balloon->attach($context_help_button, -msg => M"Kontexthilfe");
$col++;
}
if (!$standard_menubar) {
# No need for yet another close button if there's already a
# standard menu:
$misc_frame2->Label(-text => ' ')->grid(-row => $curr_row,
-column => $col++);
my $exit_photo = load_photo($misc_frame2, 'exit.' . $default_img_fmt);
my $exit_button = $misc_frame2->Button
(image_or_text($exit_photo, 'Exit'),
-command => \&exit_app,
)->grid(-row => $curr_row, -column => $col, -sticky => 's');
$balloon->attach($exit_button, -msg => M"BBBike beenden");
$ch->attach($exit_button, -pod => "^\\s*Ende-Symbol");
$col++;
}
## DEBUG_BEGIN
#mymstat("iconframe: underline all");
## DEBUG_END
if ($misc_frame->can('UnderlineAll')) { $misc_frame->UnderlineAll }
if ($misc_frame2->can('UnderlineAll')) { $misc_frame2->UnderlineAll }
arrange_symframe();
#XXX del: (now in "Aktuelle Route")
# $ampelstatus_label = $sym_frame->Label(-justify => "left")->grid
# (-row => 0, -column => 2, -sticky => 'n');
## DEBUG_BEGIN
#mymstat("iconframe: bindings");
## DEBUG_END
bind_nomod($top, "<s>" => sub { $strasse_check->invoke });
bind_nomod($top, "<l>" => sub { $landstrasse_check->invoke });
bind_nomod($top, "<o>" => sub { $ort_check->invoke });
bind_nomod($top, "<u>" => sub { $ubahn_check->invoke });
bind_nomod($top, "<b>" => sub { $sbahn_check->invoke });
bind_nomod($top, "<r>" => sub { $rbahn_check->invoke });
bind_nomod($top, "<w>" => sub { $wasser_check->invoke });
bind_nomod($top, "<f>" => sub { $flaechen_check->invoke });
bind_nomod($top, "<p>" => sub { $hs_check->invoke }) if $hs_check;
bind_nomod($top, "<R>" => sub {
# Same problems as in <Q>, see below.
if ($str_draw{'l'} || $str_draw{'comm-cyclepath'}) {
$lstrcm->invoke($radwege_l_check_index);
}
if ($str_draw{'s'} || $str_draw{'rw'} || !$str_draw{'l'}) {
$strcm->invoke($radwege_check_index);
}
});
bind_nomod($top, "<a>" => sub { $strcm->invoke($ampeln_check_index) });
bind_nomod($top, "<g>" => sub { $strcm->invoke($sperre_check_index) });
bind_nomod($top, "<Q>" => sub {
# XXX hmmm... nicht gerade ideal. Beispiel: Landstraßen
# sind aktiv, Q, Straßen werden aktiv gemacht, Q
# togglet jetzt genau entgegengesetzt...
if ($str_draw{'l'} || $str_draw{'ql'}) {
$lstrcm->invoke($qualitaet_l_check_index);
}
if ($str_draw{'s'} || $str_draw{'qs'} || !$str_draw{'l'}) {
$strcm->invoke($qualitaet_check_index);
}
});
bind_nomod($top, "<H>" => sub {
# XXX hmmm... nicht gerade ideal. Beispiel: Landstraßen
# sind aktiv, H, Straßen werden aktiv gemacht, H
# togglet jetzt genau entgegengesetzt...
if ($str_draw{'l'} || $str_draw{'hl'}) {
$lstrcm->invoke($handicap_l_check_index);
}
if ($str_draw{'s'} || $str_draw{'hs'} || !$str_draw{'l'}) {
$strcm->invoke($handicap_check_index);
}
});
bind_nomod($top, "<question>" => sub {
$strcm->invoke($fragezeichen_check_index) })
if defined $fragezeichen_check_index;
bind_nomod($top, "<L>" => sub { $lstrcm->invoke($land_jwd_check_index) });
bind_nomod($top, "<O>" => sub { $ocm->invoke($ort_jwd_check_index) });
bind_nomod($top, "<W>" => sub { $wcm->invoke($wasserumland_check_index) });
bind_nomod($top, "<B>" => sub { $strlist_button->invoke });
# XXX restliche Widgets fehlen noch
for my $w ($strasse_check, $landstrasse_check, $ort_check,
$ubahn_check, $sbahn_check, $rbahn_check, $wasser_check,
$flaechen_check) {
enter_leave_bind_for_help($w, [M"Option umschalten", '', M"Menü"]);
}
} # do_iconframe
sub telefonbuch_dialog {
my $type = shift;
require Telefonbuch;
my $get_coord = sub {
my($x, $y) = @_;
transpose($x, $y);
};
my $mark = sub {
my($x, $y, %args) = @_;
my $tcoords = [[]];
$tcoords->[0][0] = [ transpose($x, $y) ];
mark_point(-coords => $tcoords, %args,
-clever_center => 1);
};
if ($type eq 'str') {
Telefonbuch::tk_str_dialog($top, $mark, $get_coord);
} else {
Telefonbuch::tk_tel_dialog($top, $mark, $get_coord);
}
}
# Berechnet das Layout des obersten Frames neu (z.B. bei einem Resize)
sub arrange_topframe {
my(@order) = ($hslabel_frame, $km_frame, $speed_frame[0],
$power_frame[0], $wind_frame, $percent_frame, $temp_frame,
@speed_frame[1..$#speed_frame],
@power_frame[1..$#power_frame],
);
my(@col) = (0, 1, 3, 4+$#speed_frame, 5+$#speed_frame+$#power_frame,
2, 6+$#speed_frame+$#power_frame,
4..3+$#speed_frame,
5+$#speed_frame..4+$#speed_frame+$#power_frame);
$top->idletasks;
my $width = 0;
my(%gridslaves) = map {($_, 1)} $top_frame->gridSlaves;
for(my $i = 0; $i <= $#order; $i++) {
my $w = $order[$i];
next unless Tk::Exists($w);
my $col = $col[$i] || 0;
$width += $w->reqwidth;
if ($gridslaves{$w}) {
$w->gridForget;
}
if ($width <= $top->width) {
$w->grid(-row => 0,
-column => $col,
-sticky => 'nsew'); # XXX
}
}
}
# Berechnet das Layout des Symbol-Frames (das die Icons enthält) neu
sub arrange_symframe {
my($old_row, $new_row);
return unless $misc_frame2 || $DockFrame eq 'DockFrame';
my $p = $misc_frame2->parent;
if (grep($_ eq $misc_frame2, $p->gridSlaves)) {
# already gridded
my %a = $misc_frame2->gridInfo;
$old_row = $a{-row};
} else {
# force computation of reqwidth
$misc_frame2->idletasks;
}
my $new_col;
my $is_two_row;
if ($misc_frame->reqwidth + $misc_frame2->reqwidth + 10
> $top->width) {
$new_row = 1;
$new_col = 0;
$is_two_row = 1;
} else {
$new_row = 0;
$new_col = 1;
$is_two_row = 0;
}
if (!defined $old_row || $old_row != $new_row) {
if (defined $old_row) {
$misc_frame2->gridForget;
}
$misc_frame2->grid(-row => $new_row,
-column => $new_col,
-sticky => 'nsw');
}
# Maybe remove borders between two frames
if ($os eq 'unix' && $devel_host) { # not tested yet on Windows XXX
my $lf = $p->Subwidget("HideLeftBorder");
my $lc = $p->Subwidget("HideLeftCorner");
my $rf = $p->Subwidget("HideRightBorder");
if (!$is_two_row) {
if (!Tk::Exists($rf)) {
$rf = $misc_frame->Frame(-bg => $misc_frame->cget(-bg));
$p->Advertise("HideRightBorder" => $rf);
}
if (!Tk::Exists($lf)) {
$lf = $misc_frame2->Frame(-bg => $misc_frame->cget(-bg));
$p->Advertise("HideLeftBorder" => $lf);
}
if (!Tk::Exists($lc)) {
$lc = $misc_frame2->Frame
(-bd => 0, -bg => $misc_frame->Darken($misc_frame->cget(-bg), 60));
$p->Advertise("HideLeftCorner" => $lc);
}
$lf->place(-rely => 0, -relx => 0, -x => -1,
-width => 1, -relheight => 1);
$lc->place(-rely => 1, -relx => 0, -x => -1,
-width => 1, -height => 1);
$rf->place(-rely => 0, -relx => 1,
-width => 1, -relheight => 1);
} else {
for my $w ($rf, $lf, $lc) {
$w->placeForget if Tk::Exists($w) && $w->manager eq 'place';
}
}
}
}
$splash_screen->Update(0.3) if $splash_screen;
##### sonstige Bilder #####
## DEBUG_BEGIN
#mymstat("load photos");
## DEBUG_END
load_photos();
my $linestip = eval { Tk::findINC('images/stip.xbm') };
##### configure Canvas/Scrollbars #####
## DEBUG_BEGIN
#mymstat("create/config canvas");
## DEBUG_END
my $canvas_frame = $frame->Frame->pack(-fill => 'both', -expand => 1);
$canvas_frame->gridColumnconfigure(0, -weight => 1);
$canvas_frame->gridRowconfigure(0, -weight => 1);
$c = $canvas_frame->Canvas
(Name => 'karte',
-bg => $map_bg,
-closeenough => 3, # XXX hmmm ... manchmal gut, manchmal schlect
-scrollregion => \@scrollregion,
#-xscrollincrement => 4, -yscrollincrement => 4,
)->grid(-row => 0, -column => 0, -sticky => 'eswn');
$top->Advertise(Map => $c);
$c->{Configure}{-seeview} = \&Tk::Canvas::smooth_scroll;
#XXX$c->BindMouseWheel if defined &Tk::Widget::BindMouseWheel;
$sy = $canvas_frame->Scrollbar(-command => ["yview", $c],
-takefocus => 0,
-highlightthickness => 0,
);
$sx = $canvas_frame->Scrollbar(-orient => "horiz",
-command => ["xview", $c],
-takefocus => 0,
-highlightthickness => 0,
);
$c->configure(-yscrollcommand =>
sub { $sy->set(@_);
overview_update();
if (defined &plotstr_on_demand
and $BBBikeLazy::mode) {
my($x1,$y1,$x2,$y2) = $c->get_corners;
plotstr_on_demand(anti_transpose($x1,$y1),
anti_transpose($x2,$y2));
}
$c_balloon->Deactivate(1) if defined $c_balloon;
},
-xscrollcommand =>
sub { $sx->set(@_);
overview_update();
if (defined &plotstr_on_demand
and $BBBikeLazy::mode) {
my($x1,$y1,$x2,$y2) = $c->get_corners;
plotstr_on_demand(anti_transpose($x1,$y1),
anti_transpose($x2,$y2));
}
$c_balloon->Deactivate(1) if defined $c_balloon;
},
);
## XXX Enable after some rethaught...
## XXX and remove the scrollregion code from scalecanvas
# for my $hook (qw(after_plot after_resize)) {
# Hooks::get_hooks($hook)->add
# (sub {
# # XXX Is this fast enough?
# $c->configure(-scrollregion => [ $c->bbox("all") ]);
# }, "bbbike-scrollregion");
# $c->OnDestroy
# (sub {
# Hooks::get_hooks($hook)->del("bbbike-scrollregion");
# });
# }
# Additional MouseWheel bindings
$c->Tk::bind("<4>" => [sub { return if $_[1] ne "" && $_[1] ne "B4-";
$c->yviewScroll(-1,"units") },
Tk::Ev('s')]);
$c->Tk::bind("<5>" => [sub { return if $_[1] ne "" && $_[1] ne "B5-";
$c->yviewScroll(+1,"units") },
Tk::Ev('s')]);
for ("<Control-5>", "<Shift-5>", "<B1-5>") {
$c->Tk::bind($_ => sub { $c->xviewScroll(+1,"units") });
}
for ("<Control-4>", "<Shift-4>", "<B1-4>") {
$c->Tk::bind($_ => sub { $c->xviewScroll(-1,"units") });
}
if ($c->can('DropSite')) {
eval {
$c->DropSite
(-dropcommand => [\&accept_drop, $c],
-droptypes => ($os eq 'win' ?
'Win32' :
# KDE is removed from Tk804.02x
[($Tk::VERSION >= 804 ? () : 'KDE'), 'XDND', 'Sun']
)
);
warn M("Datei-DND wird akzeptiert") . "\n" if $verbose;
};
warn __LINE__ . ": $@" if $@ && $verbose;
}
# erst hier setzen, weil die Hintergrundfarbe von -xrm und dem Window-System
# abhängt
$category_color{'I'} = $c->cget(-background);
standard_selection_handle();
$sy->grid(-row => 0, -column => 1, -sticky => 'ns');
$sx->grid(-row => 1, -column => 0, -sticky => 'ew');
##### Statuszeile/Progress Bar #####
{
my $status_frame = $frame->Frame(-height => 16)->pack(-fill => 'x');
# XXX hmmm, das kriege ich nicht so gut hin....
$status_frame->gridColumnconfigure(0, -weight => 1);
$status_frame->gridColumnconfigure(1, -weight => 5);
$status_frame->gridColumnconfigure(2, -weight => 0);
$status_frame->gridColumnconfigure(3, -weight => 0);
my $gridx = 0;
require Tk::SRTProgress;
Tk::SRTProgress->VERSION(0.06);
$progress = $status_frame->SRTProgress
(-relief => 'sunken',
-borderwidth => 2,
-visible => 0,
-width => $top->width/10,
)->grid(-row => 0,
-column => $gridx++,
-sticky => 'ew');
$status_label = $status_frame->Label(-justify => 'left', -anchor => 'w')
->grid(-row => 0, -column => $gridx++, -sticky => 'ew');
$status_button_column = $gridx;
$status_button = $status_frame->Button(-padx => 0, -pady => 0); $gridx++; # do not map
$indicator_frame = $status_frame->Frame
->grid(-row => 0, -column => $gridx++, -sticky => "ew");
if ($advanced) {
$edit_mode_indicator = $indicator_frame->$Checkbutton
(-text => 'EDIT',
-variable => \$edit_mode_flag,
-command => sub {
set_edit_mode();
})->pack(-side => "left");
$edit_mode_type = $indicator_frame->Label
(-text => '', -relief => 'sunken')
->pack(-side => "left");
gui_set_edit_mode($edit_mode);
}
$balloon->configure(-statusbar => $status_label);
}
$splash_screen->Update(0.4) if $splash_screen;
##### initiales Zeichnen ######################################
## DEBUG_BEGIN
#BEGIN{mymstat("before init draw BEGIN");} mymstat("before init draw");
## DEBUG_END
$progress->InitGroup;
if (defined $set_mode && $set_mode eq 'edit') {
require BBBikeAdvanced;
set_edit_mode(1);
# #XXX inefficient!
# switch_edit_standard_mode();
# $lazy_plot = 1;
}
# special case 'pp':
if ($init_p_draw{'pp'} && !defined $set_mode) {
$p_draw{'pp'} = 1;
}
foreach (keys %init_str_draw) {
$str_draw{$_} = $init_str_draw{$_};
eval {
plot('str',$_) if $str_draw{$_}; # Strecken plotten
};
if ($@ && !$no_original_datadir) {
die $@;
}
}
foreach (keys %init_p_draw) {
if ($_ eq 'pp' && defined $set_mode) {
# XXX already set
} else {
$p_draw{$_} = $init_p_draw{$_};
}
eval {
plot('p',$_) if $p_draw{$_}; # Punkte (z.B. Ampeln) zeichnen
};
if ($@ && !$no_original_datadir) {
die $@;
}
}
# Höhen einlesen
read_hoehe() if $show_grade || $steigung_optimierung || $use_hoehe;
read_ampeln() unless $lowmem;
read_sperre_tragen() unless $lowmem;
plot_sperre() if $p_draw{'sperre'};
activate_temp_blockings(1) if $do_activate_temp_blockings;
if ($net_type =~ /^(us|r|rus|wr)$/) {
make_net();
}
if (!$search_route_flag) {
search_route_mouse(1);
}
## DEBUG_BEGIN
#BEGIN{mymstat("after init draw BEGIN");} mymstat("after init draw");
## DEBUG_END
$progress->FinishGroup;
$splash_screen->Update(0.7) if $splash_screen;
set_bindings();
foreach my $def (qw(start watch ziel addnet delnet info salesman xy
movehand www)) {
load_cursor($def);
}
if ($cursor{"watch"}) {
$busy_watch_args{-cursor} = ['@' . $cursor{"watch"}, $cursor_mask{"watch"},
'black', 'white'];
}
$splash_screen->Update(0.8) if $splash_screen;
$last_loaded_obj =
{
List => [],
File => "$bbbike_configdir/last",
Menu => $last_loaded_menu,
Title => M('Letzte Routen-Dateien').':',
Cb => sub { load_save_route(0, $_[0]) },
Max => 12,
};
load_last_loaded($last_loaded_obj);
hide_logo();
$top->deiconify unless $top->{initial_iconic};
# XXX should be after deiconify, otherwise center does not work (?)
choose_from_plz(-str => $center_on_str) if defined $center_on_str;
choose_from_plz(-coord => $center_on_coord) if defined $center_on_coord;
$splash_screen->Update(0.9) if $splash_screen;
set_mouse_desc();
if ($map_mode eq MM_SEARCH) {
set_cursor("start");
}
if ($preload_file) {
load_save_route(0, $preload_file);
}
if ($init_from) {
set_route_start_street($init_from);
}
if ($init_to) {
set_route_ziel_street($init_to);
}
eval { local $SIG{'__DIE__'};
require $progname . "_2.config" };
if ($advanced) {
# Besser wäre es, wenn mit "use" die aktuelle Zeit des Moduls
# aufgezeichnet werden könnte. So beschränke ich mich auf
# minutenweise überprüfen, ob neue Module geladen wurden.
check_new_modules();
$top->repeat(60*1000, \&check_new_modules);
}
if ($stderr_window) {
require BBBikeAdvanced;
stderr_window_command();
}
## DEBUG_BEGIN
#BEGIN{mymstat("before mainloop BEGIN");} mymstat("before mainloop");
## DEBUG_END
#use Devel::Symdump;
#my $symdump = rnew Devel::Symdump;
#print $symdump->as_string;
if ($use_server and $os ne 'win') { # Win32 unterstützt kein fork etc.
require BBBikeServer;
BBBikeServer::create_server($top);
}
if ($turbo) {
bbbikelazy_init();
}
if (defined $initial_plugins && $initial_plugins ne "") {
foreach my $plugin (split /,/, $initial_plugins) {
load_plugin($plugin);
}
}
if (defined $initial_layers && $initial_layers ne "") {
require BBBikeAdvanced;
foreach my $layer_def (split /,/, $initial_layers) {
plot_additional_layer_cmdline($layer_def);
}
}
$splash_screen->Destroy if $splash_screen; undef $splash_screen;
choose_streets() if $init_choose_street;
if ($ENV{BBBIKE_GUI_TEST}) {
eval qq{
require $ENV{BBBIKE_GUI_TEST};
\$top->afterIdle(\\&$ENV{BBBIKE_GUI_TEST}::start_guitest);
};
warn $@ if $@;
}
# XXX workaround for BBBikeLazy bug
if (defined $set_mode && $set_mode eq 'edit' && $lazy_plot) {
$lazy_plot = 0;
}
$booting = 0;
MainLoop unless $ENV{BBBIKE_TEST_PERFORMANCE};
##### Subs ### RELOADER_START ############################################
sub handle_options {
@opttable =
(M"Strecken/Punkte",
['','',M"Strecken und Punkte, die beim Start von BBBike\ngezeichnet werden sollen."],
['str','!',1, alias=>[qw(strasse strassen)],
label => M"Straßen", var => \$init_str_draw{'s'}],
['landstr','!',0, alias=>[qw(landstrasse landstrassen)],
label => M"Landstraßen", var => \$init_str_draw{'l'}],
['landstrjwd','!',0,
label => M"Landstraßen jwd", var => \$str_far_away{'l'}], # XXX init_str_far_away?
['sbahn','!',1,
label => M"S-Bahnlinien", var => \$init_str_draw{'b'}],
['sbahnhof','!',1,
label => M"S-Bahnhöfe", var => \$init_p_draw{'b'}],
['ubahn','!',1,
label => M"U-Bahnlinien", var => \$init_str_draw{'u'}],
['ubahnhof','!',1,
label => M"U-Bahnhöfe", var => \$init_p_draw{'u'}],
['rbahn','!',0,
label => M"R-Bahnlinien", var => \$init_str_draw{'r'}],
['rbahnhof','!',0,
label => M"R-Bahnhöfe", var => \$init_p_draw{'r'}],
['wasser','!',0, alias=>[qw(gewaesser)],
label => M"Gewässer", var =>\$init_str_draw{'w'}],
['wasserstadt','!',1,
label => M"Gewässer in der Stadt", var => \$wasserstadt],
['wasserumland','!',0,
label => M"Gewässer im Umland", var => \$wasserumland], # XXX auch init!
['wasserjwd','!',0,
label => M"Gewässer jwd", var => \$str_far_away{'w'}],
['faehre','!',0, alias=>[qw(faehren)],
label => M"Fähren", var => \$init_str_draw{'e'}],
['flaeche','!',0, alias=>[qw(flaechen)],
label => M"Flächen", var => \$init_str_draw{'f'}],
['ort','!',0, alias=>[qw(orte)],
label => M"Orte", var => \$init_p_draw{'o'}],
['ortjwd','!',0,
label => M"Orte jwd", var => \$p_far_away{'o'}],
['sehenswuerdigkeiten','!',0,
label => M"Sehenswürdigkeiten", var => \$init_str_draw{'v'}],
['fragezeichen','!',0,
label => M"Fragezeichen", var => \$init_str_draw{'fz'}],
M"Plot-Attribute",
['outline','!',0,
label => M"Outline zeichnen", var => \$all_outline],
['ampel','!',1, alias=>[qw(ampeln|lsa)],
label => M"Ampeln zeichnen", var => \$init_p_draw{'lsa'}],
['lsamaybe','!',undef, nogui => 1,
label => M"unsichere Ampeln", var => sub { $str_restrict{'lsa'} = {qw(? 1 X 0 B 0 F 0)} }],
['plothoehe','!',0,
label => M"Höhenangaben zeichnen", var => \$init_p_draw{'hoehe'}],
['showgrade','!',1,
label => M"Anzeige der Steigungen/Gefälle", var => \$show_grade],
['grademinimum','=f',0.01, # ab 1% Steigungen/Gefälle zeigen
label => M"minimal angezeigte Steigung", var => \$grade_minimum],
['grademinimumshort','=f',0.02, # kurze Stücke erst ab 2% zeigen
label => Mfmt("minimale Steigung (kurze Strecken bis %dm)", $grade_minimum_short_length), var => \$grade_minimum_short],
['strname','!',0,
label => M"Straßennamen plotten", var => \$str_name_draw{'s'}],
['ubahnname','!',1,
label => M"Namen von U-Bahnhöfen anzeigen", var => \$p_name_draw{'u'}],
['sbahnname','!',1,
label => M"Namen von S-Bahnhöfen anzeigen", var => \$p_name_draw{'b'}],
['ortname','!',1,
label => M"Ortsnamen plotten", var => \$p_name_draw{'o'}],
['ortkategorie','=s','auto',
label => M"Ortskategorie",
longhelp => M"Minimale Ortskategorie, die gezeichnet werden soll",
choices => [qw(auto), MIN_ORT_CAT .. MAX_ORT_CAT],
var => \$place_category],
['wassername','!',1, alias => [qw(gewaessername)],
label => M"Gewässernamen plotten", var => \$str_name_draw{'w'}],
['rbahnnetz','!',undef, nogui => 1,
label => M"R-Bahnnetz", var => sub { $net_type = "r" }],
['usbahnetz','!',undef, nogui => 1,
label => M"U/S-Bahnnetz", var => sub { $net_type = "us" }],
['bahnnetz','!',undef, nogui => 1,
label => M"Gesamtes Bahnnetz", var => sub { $net_type = "rus" }],
['scope','=s',undef,
label => M"Scope", var => \$init_scope,
choices => ["", qw/city region jwd/]],
['fast','!',undef, nogui => 1, var => \&fast_settings],
['turbo','!',undef, nogui => 1, var => sub { fast_settings();
$turbo = 1;
},
],
#XXX -nolazy geht nicht!
['lazy','!',undef, nogui => 1, var => sub {
$lazy_plot = 1;
# $p_far_away{'o'} = 1;
# $str_far_away{'w'} = 1;
# $str_far_away{'l'} = 1;
# $wasserumland = 1;
# $str_draw{'l'} = $str_draw{'s'};
# $p_draw{'o'} = 1;
}],
['lowmem','!',undef, nogui => 1, var => sub {
fast_settings();
$lowmem = 1;
$use_contexthelp = 0;
$use_balloon = 0;
$use_c_balloon = 0;
$want_wind = 0;
$bikepwr = 0;
@speed = (20);
$init_p_draw{'lsa'} = 0;
$map_color = 'pixmap';
$show_grade = 0;
$use_hoehe = 0;
}],
['slowcpu','!',undef, nogui => 1, var => sub {
$slowcpu = 1;
# XXX more
}],
['center','=s',undef,
label => M"Beim Starten auf Straße zentrieren", var => \$center_on_str],
['centerc','=s',undef,
label => M"Beim Starten auf Koordinaten zentrieren",
var => \$center_on_coord],
['choosestreet','!',1,
label => M"Beim Starten Straßenauswahl zeigen",
var => \$init_choose_street],
['autoshowlist','!',1,
label => M"Automatisches Anzeigen der Beschreibung",
var => \$auto_show_list],
['city','=s',undef,
label => M"Stadt", var => \$city, nosave => 1],
['country','=s',undef,
label => M"Land", var => \$country, nosave => 1],
['datadir','=s',undef,
label => M"Verzeichnis mit Straßendaten",
subtype => 'dir', nosave => 1, var => \$datadir],
M"Anzeige",
['','',M"Bei den meisten Optionen muss BBBike neu gestartet werden,\num die Änderungen sichtbar zu machen."],
['fontrot','!',1,
label => M"Rotierte Zeichensätze", var => \$use_font_rot],
['fontfamily','=s',undef, #'helvetica',#XXX no defaults!
label => M"Zeichensatz (Proportional)", var => \$font_family],
['fixedfontfamily','=s','courier',
label => M"Zeichensatz (Fixed)", var => \$fixed_font_family],
['fontheight','=i',undef, #12,#XXX no defaults!
alias => [qw(fontsize)],
label => M"Zeichensatzgröße", var => \$font_size],
['labelfontheight','=i',10,
alias => [qw(labelfontsize)],
label => M"Zeichensatzgröße für Labels", var => \$label_font_size],
['fontweight','=s',undef,
label => M"Zeichensatzform", var => \$font_weight],
['geometry','=s',undef,
subtype => "geometry", # XXX use fix_geometry for tk::getopt editor
label => M"Geometry", var => \$geometry],
['maximized','!',0,
label => M"immer maximiert öffnen", var => \$open_maximized],
['scaling','=f',undef,
label => M"Skalierung", var => \$scaling],
['visual','=s',undef,
label => M"Visual", var => \$visual],
['scale','=s',undef,
label => M"Skalierung", nogui => 1,
var => \$init_scale_massstab,
],
['overviewwasser','!',1,
label => M"Übersichtskarte mit Gewässern", var => \$overview_draw{'w'}],
['overviewsbahn','!',0,
label => M"Übersichtskarte mit S-Bahnen", var => \$overview_draw{'b'}],
['overviewsbahn','!',0,
label => M"Übersichtskarte mit Hauptstraßen", var => \$overview_draw{'s'}],
['coloring','=s','red',
label => M"Einfärben der Route", var => \$coloring,
choices => [qw(red blue black power wind)]],
['handheld','!',undef,
label => M"Handheld", var => \$is_handheld],
M"GUI",
['menu','!',1, # XXX hier stand mal "menu|stdmenu|standardmenu" => aber Aliase werden anscheinend von Tk::GetOpt nicht unterstützt?!
label => M"Standard-Menü", var => \$standard_menubar],
['balloon','!',1,
label => M"Balloons", var => \$use_balloon],
['cballoon','!',2, # 0 = nie, 1 = auf der Route, 2 = immer
label => M"Canvas balloons", var => \$use_c_balloon],
['cballoonwait','=i',350,
label => M"Wartezeit für Canvas balloons", var => \$c_balloon_wait],
['flat','!',1,
label => M"Flaches Relief", var => \$flat_relief],
['contexthelp','!',1,
label => M"Kontextsensitive Hilfe", var => \$use_contexthelp],
['rightispopup','!',1,
label => M"Popup-Menü rechts", var => \$right_is_popup],
['smoothscroll','!',0,
label => M"Weiches Scrollen", var => \$use_smooth_scroll],
['followmouse','!',0,
label => M"Kartenausschnitt folgt Cursor", var => \$followmouse],
['dialog','!',1,
label => M"Verwendung von Dialog-Fenstern", var => \$use_dialog],
['transient','!',1,
label => M"Transiente Fenster", var => \$transient,
longhelp => M('Verwendung von transienten Fenster oder "Toolwindows"')],
($os eq 'unix' ?
['pathentrydialog','!',undef, nogui => 1,
label => M"Alternative Dateiauswahl verwenden",
var => sub {
if (1) { # XXX determine current value --- Tk::GetOpt update necessary
eval 'use Tk::PathEntry::Dialog qw(as_default)';
} else {
eval 'use Tk::FBox qw(as_default)';
}
warn $@ if $@;
},
] : ()), # do not change dialog on Windows
['askquit','!',1,
label => M"vor Beenden fragen", var => \$ask_quit],
['b2mode','=i',B2M_FASTSCAN, nogui => 1,
var => \$b2_mode],
['autoscroll','!',undef, # XXX make nogui => 0, choices!
label => M"Autoscrolling", nogui => 1, var => sub { $b2_mode = B2M_AUTOSCROLL }],
['autoscrollspeed','=s','normal',
choices => [qw(slow normal fast)],
label => M"Autoscrolling-Geschwindigkeit", var => \$autoscroll_speed],
['autoscrollmiddle','!',undef,
label => M"Autoscrollpunkt in der Mitte", var => \$autoscroll_middle],
['focuspolicy','=s',undef,
label => M"Focus-Policy",
longhelp => 'click:'.M("Click-to-focus")."\n".
'follow:'.M("Focus-follows-mouse")."\n",
var => \$focus_policy,
choices => [qw(click follow)],
],
M"Suchoptionen",
['qualitaetoptimierung','!',0,
label => M"Straßenqualität beachten", var => \$qualitaet_s_optimierung],
['qualitaetwerte','!',{Q0 => 100,
Q1 => 25,
Q2 => 18,
Q3 => 13},
label => M"Straßenqualität konfigurieren", var => \%qualitaet_s_speed,
nogui => 1], # XXX Tk::Getopt can't handle this yet
['kategorieoptimierung','!',0,
label => M"Straßenkategorien beachten", var => \$strcat_optimierung],
['kategoriewerte','!',{B => 100,
HH => 100,
#BAB => 100,
H => 100,
N => 100,
NN => 100},
label => M"Straßenkategorien konfigurieren", var => \%strcat_speed,
nogui => 1], # XXX Tk::Getopt can't handle this yet
['radwegeoptimierung','!',0, var => \$radwege_optimierung,
label => M"Radwege-Optimierung"],
['N_RW_optimization', '!', 0, var => \$N_RW_optimization, nogui => 1],
['greenoptimierung', '=i', 0, choices => [0,1,2],
longhelp => "0: ".M("egal")."\n".
"1: ".M("bevorzugen")."\n".
"2: ".M("stark bevorzugen")."\n",
label => M"Grüne Wege bevorzugen", var => \$green_optimization,
],
['unbeleuchtetoptimierung', '!', 0, var => \$unlit_streets_optimization,
label => M"Unbeleuchtete Straßen meiden"],
['steigungoptimierung', '!', 0, var => \$steigung_optimierung,
label => M"Steigungsoptimierung"],
['handicapoptimierung','!',0,
label => M"Sonstige Beeinträchtigungen beachten", var => \$handicap_s_optimierung],
['handicapwerte','!',{q0 => 100,
q1 => 25,
q2 => 18,
q3 => 13,
q4 => 5, # z.B. Fußgängerzonen
},
label => M"Sonstige Beeinträchtigungen konfigurieren", var => \%handicap_s_speed,
nogui => 1], # XXX Tk::Getopt can't handle this yet
['sperre','!',undef, alias => [qw(gesperrt)],
label => M"Gesperrte Straßen beachten", nogui => 1,
var => sub {
$sperre{'einbahn'} = $sperre{'sperre'} = $sperre{'wegfuehrung'} = 1;
},
savevar => \$sperre{'einbahn'},
],
['einbahn-strict','!',undef,
label => M"Alle Einbahnstraßen *strikt* beachten", nogui => 1,
var => sub {
$sperre{'einbahn-strict'} = 1;
},
savevar => \$sperre{'einbahn-strict'},
],
['nichttragen','!',0,
label => M"Tragen strikt vermeiden", var => \$sperre{'tragen'}],
['tempblockings','!',0,
label => M"Temporäre Sperrungen verwenden", var => \$do_activate_temp_blockings],
['ampeloptimierung','!',0,
label => M"Ampeloptimierung verwenden", var => \$ampel_optimierung],
['beschleunigung','=f',1,
label => M"Beschleunigung (m/s^2)", var => \$beschleunigung],
['wind','!',1,
label => M"Windgeschwindigkeit beachten", var => \$want_wind],
['faehre','!',0,
label => M"Fähren verwenden", var => \$use_faehre],
['bikepwr','!',1, alias => [qw(bikepower)],
label => M"Bikepower verwenden", var => \$bikepwr],
['resetpower','!',undef, nogui => 1, var => sub { @power = () }],
['power','=i@',undef, nogui => 1, var => \@power], # XXX gui => 1
['resetspeed','!',undef, nogui => 1, var => sub { @speed = () }],
['speed','=i@',[qw(15 20)], nogui => 1, var => => \@speed], # XXX gui => 1
['speedpowerreference','=s',undef, nogui => 1, var => \$speed_power_reference_string],
['from','=s',undef, nogui => 1, -var => \$init_from],
['to','=s',undef, nogui => 1, -var => \$init_to],
M"WWW",
['www','!',0, # 1, wenn Wetterdaten vom Web geholt werden sollen
label => M"WWW verwenden", var => \$do_www],
['wwwmap','!',undef,
label => M"Karten übers WWW holen", var => \$do_wwwmap],
['wwwcache','!',0,
label => M"Cache für WWW-Karten verwenden", var => \$use_wwwcache],
['cachedir','=s',undef,
label => M"Cacheverzeichnis", subtype => 'dir',
var => \$cache_root],
['wwwslow','!',1,
label => M"WWW ist langsam", var => \$www_is_slow],
['proxy','=s',undef,
label => M"HTTP-Proxy (Format: http://host:port/)", var => \$proxy],
M"GPS",
['exporttxtmode','=i',EXPORT_TXT_SIMPLIFY_AUTO,
label => M"Vereinfachung von Routen",
longhelp => M"GPS-Geräte können nur eine begrenzte Anzahl von Waypoints pro Route verwenden.
Eine von BBBike berechnete Route erzeugt meist mehr Waypoints.
Mit dieser Option kann eingestellt werden, welche Strategie
dazu verwendet wird",
choices => [[M("Komplette Route"), EXPORT_TXT_FULL],
[M("Unterschiedliche Straßennamen"), EXPORT_TXT_SIMPLIFY_NAME],
[M("Abbiegevorgänge"), EXPORT_TXT_SIMPLIFY_ANGLE],
[M("Abbiegevorgänge/unterschiedliche Straßennamen"), EXPORT_TXT_SIMPLIFY_NAME_OR_ANGLE],
[M("automatisch"), EXPORT_TXT_SIMPLIFY_AUTO],
],
strict => 1,
var => \$export_txt_mode],
['exporttxtminangle','=s',30,
choices => [5,15,30,45,60],
label => M"Minimalwinkel bei Route-Vereinfachung",
longhelp => M"Minimalwinkel in Grad bei der Vereinfachung von Routen\n",
var => \$export_txt_min_angle],
['gpswaypoints','=i',50,
choices => [20,50],
label => M"Maximale Anzahl der GPS-Waypoints",
longhelp => M"Moderne Garmin-Geräte können 50 Waypoints pro Route verwenden,\nwährend ältere nur 20 Waypoints laden können\n",
var => \$gps_waypoints,
],
['gpsdevice','=s',($os eq 'win' ? "COM1" : ($os_bsd ? '/dev/cuaa0' : '/dev/ttyS0')),
choices => ( $os eq 'win' ? [map { "COM$_" } (1..4) ]
: $os_bsd ? [map { "/dev/cuaa$_" } (0..3) ]
: [map { ("/dev/ttyS$_", "/dev/ttyUSB$_") } (0..3) ]
),
label => M"GPS-Device", var => \$gps_device],
M"Sonstiges",
['kde','!',undef,
label => M"Für KDE optimieren", var => \$run_under_kde],
['coordout','=s','standard',
label => M"Koordinatenausgabe", var => \$coord_output],
['printcmd','=s',undef,
label => M"Druckerkommando", var => \$print_cmd],
['printbackend','=s',undef,
label => M"Druck-Backend", var => \$print_backend,
choices => ["", qw(ps pdf)],
],
['ps_fixed_font','=s',"Courier7",
label => M"Druckerzeichensatz (fixed)", var => \$ps_fixed_font],
['mapcolor','=s','color',
choices => [qw(mono pixmap gray color)],
label => M"Farbeinstellung beim Drucken", var => \$map_color],
['gvreuse','!',0, # 1: alten gv-Prozess wiederverwenden
label => M"GV-Fenster wiederverwenden", var => \$gv_reuse],
['server','!',undef,
label => M"Server-Modus", var => \$use_server],
['autosave','!',1,
label => M"Speichern beim Beenden", var => \$autosave_opts],
['environment','=s','normal',
# "novacom" (für GDF-Daten als Standard)
# "onlineoffice" (für Onlineoffice-Präsentationen)
nogui => 1, var => \$environment],
['mldbm','!',0,
label => M"Verwendung von MLDBM",
longhelp => M"Die interne Straßennetz-Struktur wird als MLDBM-Hash
auf der Festplatte statt im RAM gehalten. Langsamer, aber
speicherplatzsparender.",
var => \$use_mldbm],
['palmdocfmt','=s','isilo',
choices => [qw(isilo pdbdoc)],
label => M"Palm-Doc-Format", var => \$palm_doc_format],
['usexwd','!',undef,
label => M"xwd als Screengrabber", var => \$use_xwd_if_possible],
M"Advanced",
['edit','!',undef,
label => M"Editmodus beim Starten",
nogui => 1, # XXX remove some day?
var => sub {
$set_mode = "edit";
}
],
['stderr','!',0,
label => M"Fehlerausgabe auf stderr", var => \$stderr],
['stderrwindow','!',undef,
label => M"STDERR in ein Fenster", var => \$stderr_window],
['autoinstall','!',0,
label => M"Auto-Installation vom CPAN (experimentell!)", var => \$auto_install_cpan],
['pp','!',0,
label => M"Kurvenpunkte und Kreuzungen zeichnen", var => \$init_p_draw{'pp'}],
['advanced','!',undef, var => \$advanced,
label => M"Advanced mode"],
['public','!',undef, nogui => 1,
var => sub { $public_test = 1;
$advanced = 0;
$devel_host = 0;
$do_www = 0;
$no_map = 1;
$public = 1;
$autosave_opts = 0;
$lazy_plot = 0;
undef $proxy;
}],
['v','!',0, alias => [qw(verbose)],
label => M"Verbose", var => \$verbose],
['version','!',undef,
nogui => 1, var => sub {
print
"$progname $VERSION\n(file revision $PROG_REVISION)\n",
"perl $]\nTk $Tk::VERSION\n";
exit 0;
}],
['plugins','=s',undef,
label => M"Plugins beim Starten laden", var => \$initial_plugins,
longhelp => M"Kommaseparierte Liste von Plugins, z.B. BBBikeThunder,BBBikeSalesman,BBBikeRuler"],
['layers','=s',undef,
label => M"Zusätzliche Layer zeichnen", var => \$initial_layers],
['algorithm','=s','A*', var => \$global_search_args{Algorithm},
longhelp => M"Nur A* (Perl-Implementation) und C-A* (C-Implementation) sind von Interesse",
choices => ['A*', 'C-A*', ($devel_host||$advanced ? ("C-A*-2", 'srt') : ())],
label => M"Suchalgorithmus",
strict => 1],
['h','!',undef, nogui => 1, alias => [qw(help)],
var => sub {
if ($opt) {
print STDERR $opt->usage;
} else {
die M"Usage?";
}
exit(0);
}],
['nosplash','!',undef, nogui => 1], # pseudo option, handled at BEGIN
);
eval {
require Tk::Getopt;
Tk::Getopt->VERSION(0.50);
};
if ($@) { # XXX
die "Please report to author: use opttable_to_getopt!!!! XXX";
warn __LINE__ . ": $@" if $verbose;
my @getopt_list;
foreach (@getopt) {
push @getopt_list, $_ unless /^=/;
}
# XXX '@' geht nur mit Getopt::Long
push @getopt_list, 'power=i@' => \@power, 'speed=i@' => \@speed;
require Getopt::Long;
#XXX X11-Optionen durchschleifen...
# if (!Getopt::Long::GetOptions(@getopt_list)) { usage('', \@getopt_list) }
Getopt::Long::config('pass_through');
Getopt::Long::GetOptions(@getopt_list);
#XXX if (!GetOptions(@getopt_list)) { usage('', \@getopt_list) }
} else {
$Tk::Getopt::x11_pass_through = 1;
$opt = new Tk::Getopt(-opttable => \@opttable,
-filename => catfile($bbbike_configdir, "config"),
);
$opt->set_defaults;
pre_check_arguments();
$opt->load_options unless $public; # force defaults
if (!$opt->get_options) {
print $opt->usage;
exit 1;
}
$opt->process_options;
}
Tk::CmdLine::SetArguments(); # XXX here correct position?
if (@ARGV) {
require Getopt::Long;
Getopt::Long::config('nopass_through');
Getopt::Long::GetOptions() or die;
}
}
# Check for -public option --- in this case do not load the config file.
sub pre_check_arguments {
foreach my $arg (@ARGV) {
if ($arg eq '-public') {
$public = 1;
last;
}
}
}
# For binding plain keybindings without modifiers
sub bind_nomod {
my($top, $ev, $cb) = @_;
$top->bind
($ev, sub {
my $w = shift;
my $e = $w->XEvent;
# auf Alt, Control und CapsLock checken
# bei Win95/NT ist 8 nicht CapsLock, sondern NumLock
if ($Tk::VERSION < 800) {
return if $e->s & (1+($os eq 'win' ? 0 : 8)); # XXX control is missing ... 4? 2 ist Shift?
} else {
return if $e->s =~ /\b(Alt|Lock|Control)-/;
}
$cb->($w, @_);
});
}
# km <=> m
sub change_unit {
$unit_km = ($unit_km eq 'km' ? 'm' : 'km');
updatekm();
}
sub standard_selection_handle {
$c->SelectionHandle
(sub {
my($offset, $maxbytes) = @_;
my($inslauf) = join(" ", @inslauf_selection);
substr($inslauf, $offset, $maxbytes);
});
}
sub load_photos {
$flag_photo{'start'} = load_photo($top, 'flag2_bl_centered.' . $default_img_fmt);
$flag_photo{'via'} = load_photo($top, 'flag_via_centered.' . $default_img_fmt);
$flag_photo{'ziel'} = load_photo($top, 'flag_ziel_centered.' . $default_img_fmt);
$ampel_photo = load_photo($top, 'ampel.' . $default_img_fmt);
$ampel_klein2_photo = load_photo($top, 'ampel_klein2.' . $default_img_fmt);
$ampelf_photo = load_photo($top, 'ampelf.' . $default_img_fmt);
$ampelf_klein_photo = load_photo($top, 'ampelf_klein.' . $default_img_fmt);
$ampelf_klein2_photo = load_photo($top, 'ampelf_klein2.' . $default_img_fmt);
$andreaskr_klein_photo = load_photo($top,
'andreaskr_klein.' . $default_img_fmt);
$andreaskr_klein2_photo= load_photo($top,
'andreaskr_klein2.' . $default_img_fmt);
$andreaskr_photo = load_photo($top, 'andreaskr.' . $default_img_fmt);
$vorfahrt_photo = load_photo($top, 'vorfahrt.' . $default_img_fmt);
$vorfahrt_klein_photo= load_photo($top, 'vorfahrt_klein.' . $default_img_fmt);
$windrose2_photo = load_photo($top, 'windrose2.' . $default_img_fmt);
$kneipen_photo = load_photo($top, 'glas.' . $default_img_fmt);
$kneipen_klein_photo = load_photo($top, 'glas_klein.' . $default_img_fmt);
$essen_photo = load_photo($top, 'essen.' . $default_img_fmt);
$essen_klein_photo = load_photo($top, 'essen_klein.' . $default_img_fmt);
$kino_klein_photo = load_photo($top, 'kino_klein.' . $default_img_fmt);
$steigung_photo = load_photo($top, 'steigung.' . $default_img_fmt);
$gefaelle_photo = load_photo($top, 'gefaelle.' . $default_img_fmt);
$inwork_photo = load_photo($top, 'inwork.' . $default_img_fmt);
$ferry_photo = load_photo($top, 'ferry.' . $default_img_fmt);
$ferry_klein_photo = load_photo($top, 'ferry_klein.' . $default_img_fmt);
$zugbruecke_photo = load_photo($top, 'zugbruecke.' . $default_img_fmt);
$zugbruecke_klein_photo
= load_photo($top, 'zugbruecke_klein.' . $default_img_fmt);
#XXX not yet necessary:
# $blocked_photo = load_photo($top, 'redcross.' . $default_img_fmt);
}
sub set_default_geometry {
if (defined $Plugin::brinfo{x_len} and
defined $Plugin::brinfo{y_len}) {
$top->geometry($Plugin::brinfo{x_len} . "x" . $Plugin::brinfo{y_len});
} else {
if ($geometry && !$open_maximized) {
@want_extends = parse_geometry_string($geometry);
if (!$want_extends[GEOMETRY_WIDTH] || !$want_extends[GEOMETRY_HEIGHT]) { # test on 0 or undef
($want_extends[GEOMETRY_WIDTH], $want_extends[GEOMETRY_HEIGHT]) =
($top->screenwidth, $top->screenheight);
}
if (!defined $want_extends[GEOMETRY_X] || !defined $want_extends[GEOMETRY_Y]) {
($want_extends[GEOMETRY_X], $want_extends[GEOMETRY_Y]) = (0, 0);
}
} else {
@want_extends = (0, 0, $top->screenwidth, $top->screenheight);
}
if ($kde) {
@max_extends = $kde->client_window_region();
} elsif ($os eq 'win') {
@max_extends = Win32Util::client_window_region($top);
} else {
if ($top->property("exists", "_NET_CURRENT_DESKTOP", "root") &&
$top->property("exists", "_NET_WORKAREA", "root")) {
(undef, my $desktop) = $top->property("get", "_NET_CURRENT_DESKTOP", "root");
if (defined $desktop) {
my @vals = ($top->property("get", "_NET_WORKAREA", "root"))[$desktop*4+1 .. $desktop*4+4];
if (@vals && defined $vals[0]) {
@max_extends = @vals;
}
}
$max_extends[2]-=10; # XXX
$max_extends[3]-=24;
}
}
if (!@max_extends) {
# XXX guess width/height of wm borders and title bar
@max_extends = (0, 0, $top->screenwidth-10, $top->screenheight-24);
}
if ($exceed) {
$max_extends[GEOMETRY_HEIGHT] -= 35; # possible task bar --- but what to do if the taskbar is not at the standard location or has more than one row?
}
crop_geometry(\@want_extends, \@max_extends);
}
}
# after geometry processing
sub geometry_dependent_settings {
my $win_width = @want_extends ? $want_extends[GEOMETRY_WIDTH] : $top->width;
my $win_height = @want_extends ? $want_extends[GEOMETRY_HEIGHT] : $top->height;
if ($win_width <= 320 || $win_height <= 320 || $is_handheld) {
$small_icons = 1;
$standard_menubar = 0;
set_canvas_scale(DEFAULT_SMALL_SCALE);
}
if ($is_handheld) {
$use_balloon = 0;
$use_c_balloon = 0;
$use_contexthelp = 0;
$right_is_popup = 0;
$followmouse = 0;
$b2_mode = B2M_NONE;
}
}
sub define_item_attribs {
# grey99 wird als Weiß-Ersatz verwendet (damit die Postscript-Umwandlung
# besser funktioniert)
# grey98 ebenfalls, aber wenn Outlines eingeschaltet sind, dann wird
# diese Farbe nach Weiß umgewandelt.
# white wird überall dort verwendet, wo eine andere Hintergrundfarbe an der
# Stelle definiert ist, z.B. beim U-Bahn-Symbol oder in der Legende
%category_color =
('N' => 'grey98',
'NN' => '#bdffbd',
'H' => '#ffffa0', # blassgelb
'HH' => '#fff800', # kräftiges gelb
'BAB' => 'DarkBlue',
'B' => 'red3',
# zweiter (pragmatischer) Versuch einer Qualitätskategorisierung
# sehr guter Asphalt = guter Asphalt (genauere Kategorisierung nicht
# erforderlich)
# sehr gutes Kopfsteinpflaster = guter Asphalt Q0
# gutes Kopfsteinpflaster = mäßiger Asphalt Q1
# mäßiges Kopfsteinpflaster = schlechter Asphalt Q2
# schlechtes Kopfsteinpflaster Q3
'Q0' => 'DarkSeaGreen4',
'Q1' => 'YellowGreen',
'Q2' => 'gold',
'Q3' => 'red',
# sonstige Beeinträchtigungen, die nicht auf schlechte Qualität zurückzuführen
# sind und nur die Geschwindigkeit reduzieren. Geschwindigkeitsreduktion
# wie bei Q.
'q0' => 'DarkSeaGreen4',
'q1' => 'YellowGreen',
'q2' => 'gold',
'q3' => 'red',
'q4' => '#c00000',
# sonstiges
'SA' => 'green3', # S-Bahn, Zone A
'SB' => 'green3', # S-Bahn, Zone B
'SC' => '#008000', # S-Bahn, Zone C
'S0' => '#a0b0a0', # stillgelegte S-Bahn bzw. in Bau
## neues Farbschema an DB-Farben orientiert
## nicht gut, da nicht gut von Bundesstraßen unterscheidbar
# 'RA' => '#bb171d', # R-Bahn, Zone A
# 'RB' => '#bb171d', # R-Bahn, Zone B
# 'RC' => '#bb171d', # R-Bahn, Zone C
# 'R' => '#bb171d', # R-Bahn, außerhalb
# 'R0' => '#d0c0c0', # stillgelegte R-Bahn bzw. in Bau
## altes Farbschema
'RA' => 'green3', # R-Bahn, Zone A
'RB' => 'green3', # R-Bahn, Zone B
'RC' => '#008000', # R-Bahn, Zone C
'R' => '#006400', # R-Bahn, außerhalb
'R0' => '#a0b0a0', # stillgelegte R-Bahn bzw. in Bau
'U' => '#000080', # U-Bahn
'UA' => '#000080', # U-Bahn, Zone A
'UB' => '#000080', # U-Bahn, Zone B
'U0' => '#a0a0b0', # U-Bahn in Bau
'W' => '#bad5f7', # Gewässer
'WR' => '#404080', # Wasserrouten
'P' => '#76c48b', # Parks
'Pabove' => '#76c48b', # same, but for higher stacking
'Forest' => '#66b47b', # Wälder
'Forestabove' => '#66b47b', # same, but for higher stacking
'Cemetery' => '#70c085', # Friedhöfe
'Green' => '#76c48b', # sonstige Grünanlagen
'Orchard' => '#e8f8c8', # Kleingärten (was #80ca94)
'Sport' => '#c8d898', # Sportanlagen (was #86d49b)
'Industrial' => '#d7b8c8', # Industriegebiete
'Ae' => 'white', # Flughäfen
'F' => 'grey99', # sonstige Flächen
'SW' => 'red', # Sehenswürdigkeit
'Q' => 'grey99', # Fähre
'I' => 'grey85', # Inseln (wird später überschrieben)
'Z' => 'black', # PLZ-Grenzen
'RW1' => 'SlateBlue', # siehe Radwege.pm
'RW2' => '#00008b', # DarkBlue ist in der Win-Version undefiniert
'RW3' => 'LightBlue',
'RW4' => 'green',
'RW5' => 'orange',
'RW6' => 'yellow3',
'RW7' => 'green',
'RW8' => '#000060',
'RW9' => 'SlateBlue',
'RW10' => 'green',
'RW' => 'SlateBlue',
'sperre0' => 'red', # Tragen
'sperre1' => 'blue', # Einbahnstraßen
'sperre1s' => '#b0b0ff', # Einbahnstraßen (nur mit "einbahn-strict")
'sperre2' => 'red', # voll gesperrt
'sperre3' => 'red', # Wegführung gesperrt
'IN' => 'violet', # Industrieanlagen
'HB' => 'DarkViolet', # Hafenanlagen
'BU' => '#c08080', # Built-up areas
'FO' => '#46b47b', # Wälder
'MO' => '#008080', # Moor
'?' => '#9f0000',
'??' => '#8b0000', # DarkRed, bei Win undefiniert
'?p' => '#af0000',
'GPS' => 'red', # GPS Relation
'GPSs' => "#c000c0", # GPS street
'GPSs~' => "#f4c0f4", # inaccurate
'GPSs~~' => "#e4c8e4", # even more inaccurate
'GPSs?' => "#303030", # unsure
'GPSp' => "#0000a0", # GPS point
'GPSp~' => "#c0c0b0", # GPS point
'GPSp~~' => "#c8c8c0", # GPS point
'GPSp?' => "#303030", # unsure
'CP' => '#a000a0',
'CP2'=> '#a000a0',
'CS' => '#a000a0',
'St' => '#b00080',
'Gf' => '#c00080',
'PI' => '#a000a0',
'P0' => '#a000a0',
'-2' => '#008000', # (relativ) verkehrsarme Straße
'-1' => '#00c000',
'+1' => '#c00000',
'+2' => '#800000', # (relativ) verkehrsreiche Straße
'green1' => '#7fbb7f',
'green2' => '#008b00',
'X' => "red", # fallback color
);
%category_font_color =
(
'W' => '#2a45b7',
'U' => '#000060',
'S' => '#006000',
'R' => '#006000', # altes Farbschema
# 'R' => '#a00000',# neues Farbschema
);
for (qw(UA UB U0)) { $category_font_color{$_} = $category_font_color{"U"} }
for (qw(SA SB SC S0)) { $category_font_color{$_} = $category_font_color{"S"} }
for (qw(RA RB RC R0)) { $category_font_color{$_} = $category_font_color{"R"} }
%category_font =
(
'W' => 'helvetica %d italic',
'P' => 'helvetica %d',
'Ae' => 'helvetica %d',
);
for (qw(Forest Forestabove Pabove Cemetery Orchard Green Sport Industrial)) {
$category_font{$_} = $category_font{'P'};
}
$pp_color = '#008000';
for my $nr (0, 1, 2) {
$category_color{'W' . $nr} = $category_color{'W'};
$category_font_color{'W' . $nr} = $category_font_color{'W'};
$category_font{'W' . $nr} = $category_font{'W'};
}
# fallback, falls kein %category_color definiert ist
%str_color =
('s' => 'yellow',
'L' => 'red',
'qs' => 'red',
'ql' => 'red',
'hs' => 'red',
'hl' => 'red',
'nl' => 'black',
'gr' => 'green',
);
%p_color =
();
%category_image =
('bg' => "behindertengerecht.gif",
'bf' => "behindertenfreundlich.gif",
);
%category_stipple =
('Cemetery' => 'crosses.xbm');
%line_width =
('s-H' => [1, 2, 3, 4, 6, 10],
's-HH' => [1, 2, 3, 4, 6, 10],
's-B' => [1, 2, 3, 4, 6, 10],
's-BAB' => [1, 2, 3, 4, 6, 10],
'sBAB-BAB' => [1, 2, 3, 4, 6, 10],
's-N' => [1, 1, 2, 2, 4, 7],
's-NN' => [1, 1, 2, 2, 4, 7],
'comm' => [1, 2, 3, 4, 6, 10],
'mount' => [1, 2, 3, 4, 6, 10],
'qs' => [3, 4, 5, 6, 8, 12],
'hs' => [3, 4, 5, 6, 8, 12],
'temp_sperre_s' => [5, 6, 7, 8, 10, 14],
'rw' => [1, 2, 3, 4, 6, 10],
'l' => [2, 2, 3, 4, 6, 10],
'gr' => [5, 7, 8, 9, 10, 14], # s-H + 4 pixels
'ql' => [3, 4, 5, 6, 8, 12],
'hl' => [3, 4, 5, 6, 8, 12],
'z' => [1, 1, 2, 3, 5, 8],
'g' => [1, 2, 3, 4, 6, 10],
'e' => [1, 2, 3, 4, 6, 10],
# 'sperre0' => [3, 5, 7, 9, 11,15],
'sperre0' => [1, 2, 2, 2, 3, 3],
'sperre1' => [0, 0, 2, 3, 4, 6],
'sperre2' => [0, 0, 2, 3, 5, 8],
'sperre3' => [0, 0, 1, 2, 4, 6],
'w' => [1, 1, 2, 2, 4, 7],
'w-W0' => [0, 1, 1, 1, 3, 5],
'w-W1' => [2, 2, 3, 5, 7, 11],
'w-W2' => [3, 4, 6, 8, 10,13],
'default' => [1, 2, 3, 4, 6, 10],
);
foreach (qw/H HH B BAB N NN/) {
$line_width{"l-$_"} = [@{ $line_width{"s-$_"}}];
}
foreach (qw/sperre1s/) {
$line_width{$_} = [@{ $line_width{"sperre1"}}];
}
foreach (qw/gP gD/) {
$line_width{$_} = [@{ $line_width{"g"}}];
}
foreach (@comments_types) {
$line_width{"comm-".$_} = [@{ $line_width{"comm"}}];
}
%line_dash =
('qs' => [5,2],
'ql' => [5,2],
'hs' => [2,5],
'hl' => [2,5],
'temp_sperre_s' => [2,5],
'nl' => [2,4],
'comm' => [5,2],
'mount'=> [5,2],
'e' => [5,2], # Fähren
'g' => [8,5,2,5], # Grenzen
'z' => [8,5,2,5], # PLZ-Grenzen
'sperre3' => [6,2],
'fz' => [8,5],
'Tu' => [2,5], # Tunnel (addinfo)
);
foreach (qw/gP gD/) {
$line_dash{$_} = [@{ $line_dash{"g"}}];
}
foreach (@comments_types) {
$line_dash{"comm-".$_} = [@{ $line_dash{"comm"}}];
}
%line_length =
('sperre1' => [0, 0, 4, 5, 7, 10],
'sperre2' => [0, 0, 3, 4, 6, 8],
'default' => [2, 3, 4, 5, 7, 10],
);
foreach (qw/sperre1s/) {
$line_length{$_} = [@{ $line_length{"sperre1"}}];
}
%line_arrow =
('PI' => 'last',
'P0' => 'last',
);
%line_shorten =
('CP' => 1,
'CP2' => 1,
'P0' => 1,
'PI' => 1,
);
# Label size per category
%category_size =
('N' => 8,
'NN' => 7,
'H' => 10,
'HH' => 10,
'B' => 10,
'BAB'=> 10,
'W' => 12);
%outline_color =
('s' => 'grey70',
'l' => 'grey70',
'w' => 'blue4',
'i' => 'blue4',
);
%str_file =
('s' => 'strassen',
'l' => 'landstrassen', # this is really scoped
'u' => 'ubahn',
'b' => 'sbahn',
'r' => 'rbahn',
'w' => 'wasserstrassen', # this is really scoped
'f' => 'flaechen',
'v' => 'sehenswuerdigkeit',
'z' => 'plz',
'g' => 'berlin',
'gP' => "potsdam",
'gD' => "deutschland",
'e' => 'faehren',
'rw' => 'radwege',
'qs' => 'qualitaet_s',
'ql' => 'qualitaet_l',
'hs' => 'handicap_s',
'hl' => 'handicap_l',
'nl' => 'nolighting',
'gr' => 'green',
'comm' => 'comments', # this is splitted into multiple files
'mount' => 'mount',
'fz' => "fragezeichen",
'wr' => "wasserrouten",
);
foreach my $type (@comments_types) {
$str_file{"comm-$type"} = "comments_$type";
}
if ($devel_host) {
$str_file{"is"} = "$FindBin::RealBin/projects/infrasystem/data/landstrassen-corrected";
}
%p_file =
('lsa' => 'ampeln',
'u' => 'ubahnhof',
'u_bg' => 'ubahnhof_bg',
'b' => 'sbahnhof',
'b_bg' => 'sbahnhof_bg',
'r' => 'rbahnhof',
'o' => 'orte', # XXX scoped
'sperre' => $sperre_file,
'sperre_u' => 'gesperrt_u',
'sperre_b' => 'gesperrt_s',
'sperre_r' => 'gesperrt_r',
'obst' => 'obst',
'pl' => 'plaetze',
'vf' => 'vorfahrt',
'kn' => 'kneipen',
'ki' => 'kinos',
'rest' => 'restaurants',
);
# Feld-Elemente
# 0: Bezeichnung, Singular
# 1: Bezeichnung, Plural
# 2: Linien (bool)
# 3: (falls vorhanden) lange Bezeichnung
%str_attrib =
('s' => [M"Straße", M"Straßen", 0],
'l' => [M"Landstraße", M"Landstraßen", 0],
'u' => [M"U-Bahnlinie", M"U-Bahnlinien", 1],
'b' => [M"S-Bahnlinie", M"S-Bahnlinien", 1],
'r' => [M"R-Bahnlinie", M"R-Bahnlinien", 1],
'w' => [M"Gewässer", M"Gewässer", 0],
'f' => [M"Fläche", M"Flächen", 0],
'v' => [M"Sehenswürdigkeit", M"Sehenswürdigkeiten", 0],
'z' => [M"PLZ-Gebiet", M"PLZ-Gebiete", 0],
'g' => [M"Grenze von Berlin", M"Grenze von Berlin", 0],
'gP' => [M"Grenze von Potsdam", M"Grenze von Potsdam", 0],
'gD' => [M"Staatsgrenze", M"Staatsgrenze", 0],
'e' => [M"Fähre", M"Fähren", 0],
'rw' => [M"Radweg", M"Radwege", 0],
'qs' => [M"Straßenqualität", M"Straßenqualität", 0],
'ql' => [M"Straßenqualität (Landstraße)", M"Straßenqualität (Landstraße)", 0],
'hs' => [M"Sonst. Beeinträchtigungen", M"Sonst. Beeinträchtigungen", 0],
'hl' => [M"Sonst. Beeinträchtigungen (Landstraße)", M"Sonst. Beeinträchtigungen (Landstraße)", 0],
'nl' => [M"Unbeleuchtete Straße", M"Unbeleuchtete Straßen", 0],
'gr' => [M"Grüner Weg", M"Grüne Wege", 0],
'comm' => [M"Kommentare", M"Kommentare", 0],
# XXX specific comm types?
'mount' => [M"Steigung", M"Steigungen", 0],
'wr' => [M"Wasserroute", M"Wasserrouten", undef],
);
%p_attrib =
('lsa' => [M"Ampel", M"Ampeln", undef],
'u' => [M"U-Bahnhof", M"U-Bahnhöfe", undef],
'u_bg' => [M"Fahrradfreundlicher Zugang (U-Bahn)", M"Fahrradfreundliche Zugänge (U-Bahn)", undef],
'b' => [M"S-Bahnhof", M"S-Bahnhöfe", undef],
'u_bg' => [M"Fahrradfreundlicher Zugang (S-Bahn)", M"Fahrradfreundliche Zugänge (S-Bahn)", undef],
'r' => [M"R-Bahnhof", M"R-Bahnhöfe", undef],
'r_bg' => [M"Fahrradfreundlicher Zugang (Regionalbahn)", M"Fahrradfreundliche Zugänge (Regionalbahn)", undef],
'o' => [M"Ort", M"Orte", undef],
'p' => [M"Haltestelle", M"Haltestellen", undef],
'obst' => [M"Obst", M"Obst", undef],
'pl' => [M"Platz/Brücke",M"Plätze/Brücken",undef],
'vf' => [M"Vorfahrt", M"Vorfahrt", undef],
'pp' => [M"Kreuzung", M"Kreuzungen", undef],
'kn' => [M"Kneipe", M"Kneipen", undef],
'ki' => [M"Kino", M"Kinos", undef],
'rest' => [M"Restaurant", M"Restaurants", undef],
'hoehe' => [M"Höhenangabe", M"Höhenangaben", undef],
'personal' => [M"Persönlicher Ort", M"Persönliche Orte", undef],
);
%category_attrib =
('UA' => [M"U-Bahn Zone A", undef, undef],
'UB' => [M"U-Bahn Zone B", undef, undef],
'SA' => [M"S-Bahn Zone A", undef, undef],
'SB' => [M"S-Bahn Zone B", undef, undef],
'SC' => [M"S-Bahn Zone C", undef, undef],
'RA' => [M"R-Bahn Zone A", undef, undef],
'RB' => [M"R-Bahn Zone B", undef, undef],
'RC' => [M"R-Bahn Zone C", undef, undef],
'R' => [M"R-Bahn außerhalb Berlin ABC", undef, undef],
'HH' => [M"wichtige Hauptstraße", M"wichtige Hauptstraßen", undef],
'B' => [M"Bundesstraße", M"Bundesstraßen", undef],
'H' => [M"Hauptstraße", M"Hauptstraßen", undef],
'N' => [M"Nebenstraße", M"Nebenstraßen", undef],
'NN' => [M"für Kfz gesperrte Straße", M"für Kfz gesperrte Straßen", undef],
'BAB'=> [M"Autobahn", M"Autobahnen", undef],
'P' => [M"Park", M"Parks", undef],
'Pabove' => [M"Park", M"Parks", undef],
'Forest' => [M"Wald", M"Wälder", undef],
'Forestabove' => [M"Wald", M"Wälder", undef],
'Cemetery' => [M"Friedhof", M"Friedhöfe", undef],
'Green' => [M"Grünanlage", M"Grünanlagen", undef],
'Orchard' => [M"Kleingärten", M"Kleingärten", undef],
'Sport' => [M"Sportanlage", M"Sportanlagen", undef],
'Industrial' => [M"Industriegebiet", M"Industriegebiete", undef],
'Ae' => [M"Flughafen", M"Flughäfen", undef],
'F' => [M"Flughafen", M"Flughäfen", undef],
'Q0' => [M"sehr guter Belag", undef, undef,
M"sehr guter Belag (Asphalt)"],
'Q1' => [M"guter Belag", undef, undef,
M"guter Belag (Asphalt oder gutes Kopfsteinpflaster)"],
'Q2' => [M"mäßiger Belag", undef, undef,
M"mäßiger Belag (schlechter Asphalt oder mäßiges Kopfsteinpflaster)"],
'Q3' => [M"schlechter Belag", undef, undef,
M"schlechter Belag (Katzenkopfsteinpflaster oder unbefestigte Wege)"],
'q0' => [M"keine", undef, undef,
M"keine Beeinträchtigungen"],
'q1' => [M"auf ca. 25 km/h", undef, undef,
M"Beeinträchtigungen auf ca. 25 km/h"],
'q2' => [M"auf ca. 18 km/h", undef, undef,
M"Beeinträchtigungen auf ca. 18 km/h"],
'q3' => [M"auf ca. 13 km/h", undef, undef,
M"Beeinträchtigungen auf ca. 13 km/h"],
'q4' => [M"auf Schrittgeschwidigkeit", undef, undef,
M"Beeinträchtigungen auf Schrittgeschwidigkeit"],
'6' => [M"Groß- oder Millionenstadt", M"Groß- oder Millionenstädte", undef],
'5' => [M"Großstadt", M"Großstädte", undef],
'4' => [M"Ortskategorie 4", M"Ortskategorie 4", undef],
'3' => [M"Ortskategorie 3", M"Ortskategorie 3", undef],
'2' => [M"Ortskategorie 2", M"Ortskategorie 2", undef],
'1' => [M"kleiner Ort", M"kleine Orte", undef],
'0' => [M"Ortsteil", M"Ortsteile", undef],
'WR' => [M"Wasserroute", M"Wasserrouten", undef],
);
foreach (@Radwege::category_order) {
if (defined $Radwege::category_code{$_}) {
$category_attrib{$Radwege::category_code{$_}} =
[$Radwege::category_name{$_}, $Radwege::category_plural{$_}, undef];
}
}
$default_img_fmt = 'xpm';
%obst_file =
('apfel' => 'apfel.' . $default_img_fmt,
'kirsche' => 'kirsche.' . $default_img_fmt,
'birne' => 'birne.' . $default_img_fmt,
'pflaume' => 'pflaume.' . $default_img_fmt,
);
# für Orte und Sonstiges
$xadd_anchor_type->{'o'} = {'w' => 4, 'n' => 0, 'e' => -4, 's' => 0,
'nw' => 2, 'sw' => 2};
$yadd_anchor_type->{'o'} = {'w' => 0, 'n' => 1, 'e' => 0, 's' => -1,
'nw' => 1, 'sw' => -1};
$label_spaceadd{'o'} = " ";
# für Routen
$xadd_anchor_type->{'route'} = {'w' => 10, 'n' => 0, 'e' => -10, 's' => 0,
'nw' => 5, 'sw' => 5};
$yadd_anchor_type->{'route'} = {'w' => 0, 'n' => 10, 'e' => 0, 's' => -10,
'nw' => 5, 'sw' => -5};
# $label_spaceadd not needed here
# U-Bahnsymbole
$xadd_anchor_type->{'u'} = {'w' => 8, 'n' => 0, 'e' => -8, 's' => 0,
'nw' => 5, 'sw' => 5};
$yadd_anchor_type->{'u'} = {'w' => 0, 'n' => 8, 'e' => 0, 's' => -8,
'nw' => 5, 'sw' => -5};
$label_spaceadd{'u'} = " ";
# Sehenswürdigkeiten (star)
$xadd_anchor_type->{'v'} = {'w' => 8, 'n' => 0, 'e' => -8, 's' => 0,
'nw' => 5, 'sw' => 5};
$yadd_anchor_type->{'v'} = {'w' => 0, 'n' => 8, 'e' => 0, 's' => -8,
'nw' => 5, 'sw' => -5};
$label_spaceadd{'v'} = " ";
# normale Reihenfolge für das Übereinanderlegen bei restack()
#XXX labels sollten grundsätzlich immer oben sein. Problematisch bei tag_groups
@normal_stack_order =
(qw(map f w-out w i-out i f-Pabove crosshairs e e-img
gP gD z g gP gD
s-out l-out show gr rw s-NN s-N s-H s-HH s-B s-BAB sBAB sBAB-BAB l v
f-label-bg wr w-label-bg f-label w-label
u sperre_u u-bg u-fg u_bg-img r sperre_r b sperre_b
r-bg r-fg r_bg-img b-bg b-fg b_bg-img
u-label r-label b-label
hoehe vf-bg sperre temp_sperre_s temp_sperre v-fg obst
fz route comm),
(map { "comm-$_" } @comments_types),
qw(comm-route-label-bg comm-route-label qs hs ql hl mount nl delnet
O o p pl-fg lsas lsa-bg lsa-fg lsas-t
vf-fg pp kn-bg kn-fg ki-bg ki-fg rest-bg rest-fg
s-label-bg s-label l-label-bg l-label
personal-fg personal-label ovl
gpsanimrect zoomrect),
);
# XXX remove these? (was between rest-fg and personal-fg) L pp-L L-img L-fg
}
sub generate_plot_functions {
$plotstr_draw_sub = <<'EOF';
sub {
my $ret = shift;
my $strname = $ret->[Strassen::NAME];
my @kreuzungen = @{$ret->[Strassen::COORDS]};
@kreuzungen = map { $conv->($_) } @kreuzungen
if $conv;
my $cat_hin = $ret->[Strassen::CAT];
my $cat_rueck;
my(@addinfo_hin, @addinfo_rueck);
if ($cat_hin =~ /^(.*);(.*)$/) {
($cat_hin, $cat_rueck) = ($1, $2);
}
if ($cat_hin =~ /^(.+?)::(.*)$/) { # XXX will change
$cat_hin = $1;
@addinfo_hin = split ':', $2;
}
if (defined $cat_rueck && $cat_rueck =~ /^(.+?)::(.*)$/) { # XXX this will change!
$cat_rueck = $1;
@addinfo_rueck = split ':', $2;
}
# XXX Problems with cat = ";anything": $cat_hin is empty and thus always
# restricted. Workaround: always use "anything;" with the reversed
# coord list. But nevertheless $ignore and $restrict won't work correctly.
return if defined $ignore and $cat_hin =~ /$ignore/;
return if defined $restrict and $cat_hin !~ /$restrict/;
my $this_color_hin = $cat_hin =~ /^\#/ ? $cat_hin :
$category_color{$cat_hin} || $str_color{$abk} || 'white';
my $this_color_rueck = defined $cat_rueck ?
($cat_rueck =~ /^\#/ ? $cat_rueck :
$category_color{$cat_rueck} || $str_color{$abk} || 'white') :
'white';
my $this_width_hin = $category_width{$cat_hin} || $default_width || 1;
my $this_width_rueck = defined $cat_rueck ?
($category_width{$cat_hin} || $default_width || 1) :
1;
my @coordlist;
CROSSINGS_LOOP:
foreach (@kreuzungen) {
TRY: {
my($xx, $yy);
if (!$edit_mode && !$edit_mode_flag) {
($xx, $yy) = split /,/, $_;
if (!defined $yy) { # ignore invalid coords like "*"
next CROSSINGS_LOOP;
}
} elsif ($edit_mode_flag) {
/^(?::.*:)?(-?[\d\.]+),(-?[\d\.]+)$/;
($xx, $yy) = ($1, $2);
next CROSSINGS_LOOP if !defined $yy;
} elsif ($edit_mode &&
/([A-Za-z]+)?(-?[\d\.]+),(-?[\d\.]+)$/) {
# XXX Verwendung von data/BASE (hier und überall)
my $this_coordsys = (defined $1 ? $1 : '');
if ($this_coordsys eq $coordsys ||
(!($this_coordsys ne '' || $coordsys ne 'B'))) {
($xx, $yy) = ($2, $3);
} else {
# the hard way: convert it
$this_coordsys = 'B' if $this_coordsys eq '';
($xx,$yy) = $Karte::map_by_coordsys{$this_coordsys}->map2map($coord_system_obj, $2, $3);
#warn "($xx,$yy)";
}
} else {
last TRY;
}
push @coordlist, $transpose->($xx, $yy);
if ($p_draw{'pp'} && ($p_draw{"pp-$abk"}||$p_draw{"pp-all"})) {
my($x, $y) = @coordlist[$#coordlist-1 .. $#coordlist];
# keine Verwendung von _coord_as_string
$c->createLine
($x, $y, $x, $y,
-tags => ['pp', "$xx,$yy", undef, "pp-$abk"],
);
}
}
}
if (@coordlist > 0) {
my $abk = $abk;
my($mx,$my);
my $image;
my $anchor = "c";
if (exists $line_shorten{$cat_hin}) { # XXX no $cat_rueck handling
line_shorten(\@coordlist);
}
my $sight_draw = sub {
# speciality for sights: draw a star
if (!defined $mx) {
if (@coordlist > 2) {
($mx,$my) = get_polygon_center(@coordlist);
}
if (!defined $mx) {
($mx,$my) = @coordlist[0,1];
}
}
if ($image) {
if (!$photo{$image}) {
my $f = file_name_is_absolute($image) ? $image : Tk::findINC("images/$image");
if ($f) {
$photo{$image} = image_from_file($top, $f);
} else {
warn "Can't find photo $image (1)";
}
}
if ($photo{$image}) {
$c->createImage($mx,$my,-image => $photo{$image},
-anchor => $anchor,
-tags => ["$abk-fg", $strname]);
} else {
warn "No image for $image";
}
} else {
$c->createImage($mx,$my,-image => $star_photo,
-tags => ["$abk-fg", $strname]);
}
};
if ($cat_hin =~ /^F:(.*)$/) { # Fläche, no $cat_rueck handling here
my $item;
my $category = $1;
my($color, $rest) = split(/\|/, $category);
my $stipple = $category_stipple{$category};
if (defined $rest && $rest ne "") {
if ($rest =~ /^IMG:([^|]+)(?:\|ANCHOR:([^|]+))?$/) {
$image = $1;
$anchor = $2 if $2;
} else {
$stipple = $rest;
}
}
if ($color eq 'I') { $abk = 'i' } # Inseln
$color = $category_color{$color} || $color;
$stipple = Tk::findINC($stipple) if $stipple;
$stipple = '@' . $stipple if $stipple;
if ($str_outline{$abk} && @coordlist > 2) {
$item = $c->createPolygon
(@coordlist,
-fill => $outline_color{$abk},
-outline => $outline_color{$abk},
-width => 2,
-tags => ["$abk-out", "$abk-$category-out"],
);
}
if (@coordlist == 2) {
# dicken Punkt zeichnen
$item = $c->createLine
(@coordlist, @coordlist,
-fill => $color,
-width => 5, # XXX skalieren
-capstyle => 'round',
-tags => [$abk, $strname, $kreuzungen[0],
$abk."-".$i
],
);
} else {
$item = $c->createPolygon
(@coordlist,
-fill => $color,
($stipple ? (-stipple => $stipple) : ()),
-tags => [$abk, $strname,
"$abk-$category",$abk."-".$i],
);
}
if ($str_name_draw{$abk}) {
my($name, $add) = split(/\|/, $strname);
$name = "" if !defined $name;
if ($add) {
$name .= " $add";
}
$name =~ s/\cK/\n/g; # vert tab -> newline
($mx,$my) = get_polygon_center(@coordlist);
if (!defined $mx || ! do {
my @zipped_coordlist;
for(my $i = 0; $i < $#coordlist; $i+=2) {
push @zipped_coordlist, [$coordlist[$i], $coordlist[$i+1]];
}
point_in_polygon([$mx,$my], \@zipped_coordlist);
}) {
my $middle = int $#coordlist/2;
if ($middle%2 != 0) {
$middle--;
}
($mx,$my) = @coordlist[$middle,$middle+1];
}
my $abk_fg = $abk;
if ($abk eq 'v') {
$abk_fg = 'v-fg';
} elsif ($abk =~ /^[fw]$/) {
$abk_fg = $abk."-label";
}
my $tags = [$abk_fg, $strname];
my %args = (-text => $name,
-tags => $tags,
-outlinewidth => 2,
(exists $category_font_color{$category} ? (-fill => $category_font_color{$category}) : ()),
(exists $category_font{$category} ? (-font => $category_font{$category}) : ()),
);
if (exists $category_font{$category} &&
$category_font{$category} =~ /%d/) {
my $bbox_area = get_bbox_area($item);
# XXX bessere Abstufungen
if ($bbox_area < 1500) {
$args{-font} = sprintf $category_font{$category}, 7;
} elsif ($bbox_area > 5000) {
$args{-font} = sprintf $category_font{$category}, 12;
} else {
$args{-font} = sprintf $category_font{$category}, 10;
}
}
if (!$no_overlap_label{$abk} ||
!draw_text_intelligent
($c, $mx, $my,
%args,
-abk => $abk_fg,
-xadd => $xadd_anchor,
-yadd => $yadd_anchor,
-outline => 1,
)) {
my($mx,$my) = ($mx,$my);
if (defined $label_spaceadd) {
$args{-text} = $label_spaceadd . $args{-text};
$args{-anchor} = "w";
} elsif (# shift to right for points,
# center for polygons
@coordlist == 2 || $abk eq 'v') {
$mx += $xadd_anchor->{'w'};
$my += $yadd_anchor->{'w'};
$args{-anchor} = "w";
}
outline_text($c, $mx, $my, %args);
}
}
if (($abk eq 'v' && $star_photo) || $image) {
$sight_draw->();
}
} elsif ($cat_hin =~ /^IMG:([^|]+)(?:\|ANCHOR:([^|]+))?$/) { # Bild, no $cat_rueck handling here
my $img = $1;
my $anchor = ($2 ? $2 : "c");
$img = file_name_is_absolute($img) ? $img : Tk::findINC("data/$img");
my $p = image_from_file($top, $img);
# XXX this is leaking (photo never deleted...)
# XXX $abk-XXX => $abk-fg or $abk-img ?
# XXX use $abk-fg for now (scaling works!)
if ($p) {
$c->createImage(@coordlist[0..1], -image => $p,
-anchor => $anchor,
-tags => [$abk, $strname,
"$abk-fg", "$abk-" . $i],
);
} else {
warn "Can't find photo $img (2)";
}
} elsif ($use_stippleline == 1) { # old stipple code
# XXX no $cat_rueck handling here (this code branch is anyway obsolete)
# min. 4 Koordinaten erzwingen
@coordlist == 2 && push(@coordlist, @coordlist);
Tk::StippleLine::create
($c, @coordlist,
-fill => $this_color_hin,
-width => $this_width_hin,
-joinstyle => 'bevel',
-tags => [$abk, $strname,
"$abk-$cat_hin", "$abk-" . $i],
);
} else {
if (@coordlist == 2) {
# Points do not have $cat_rueck
if ($abk eq 'v') {
TRY_IMAGE: {
if ($cat_hin =~ /\|IMG:([^|]+)/) {
$image = $1;
} elsif ($star_photo) {
$image = undef; # default to $star_photo
} else {
last TRY_IMAGE;
}
$sight_draw->();
return; # next loop
}
}
# dicken Punkt zeichnen
$c->createLine(@coordlist, @coordlist,
-fill => $this_color_hin,
-width => 5, # XXX skalieren
-capstyle => 'round',
-tags => [$abk, $strname,
"$abk-$cat_hin", "$abk-" . $i,
@extra_tags],
);
} else {
my @std_tags = ($abk, $strname,"$abk-$cat_hin","$abk-" . $i);
my $line_dash = $line_dash{$abk};
if (@addinfo_hin) { # ignore @addinfo_rueck for now
for my $addinfo_hin (@addinfo_hin) {
if ($addinfo_hin eq 'Tu') {
$line_dash = $line_dash{"Tu"};
draw_tunnel_entrance(\@coordlist, width => $this_width_hin+4, tags => \@std_tags);
} elsif ($addinfo_hin eq 'Br') {
draw_bridge(\@coordlist, width => $this_width_hin+4, tags => \@std_tags);
}
}
}
if (!$use_stippleline) {
undef $line_dash;
}
if ($str_outline{$abk}) {
# XXX no $cat_rueck support yet for outlines
$c->createLine
(@coordlist,
-fill => $outline_color{$abk},
-width => $this_width_hin+2,
-joinstyle => 'bevel',
-tags => ["$abk-out",
"$abk-$cat_hin-out"],
($line_dash ? (-dash => $line_dash) : ()),
(exists $line_arrow{$cat_hin} ? (-arrow => $line_arrow{$cat_hin}) : ()),
);
}
if (defined $cat_rueck) {
my %side_coordlist;
for my $dir (1, -1) {
my($cl, $this_color, $this_width, $cat);
if ($dir == 1 && $cat_hin ne '') {
$this_color = $this_color_hin;
$this_width = $this_width_hin/2;
$cat = $cat_hin;
$cl = [@coordlist],
} elsif ($dir == -1 && $cat_rueck ne '') {
$this_color = $this_color_rueck;
$this_width = $this_width_rueck/2;
$cat = $cat_rueck;
$cl = [];
for(my $cl_i = $#coordlist-1; $cl_i >= 0; $cl_i-=2) {
push @$cl, @coordlist[$cl_i, $cl_i+1];
}
} else {
next;
}
my $delta = -$this_width;
for(my $ii = 2; $ii < $#$cl; $ii+=2) {
# atan2(y2-y1, x2-x1)
my $alpha = atan2($cl->[$ii+1]-$cl->[$ii-1], $cl->[$ii]-$cl->[$ii-2]);
my $beta = $alpha - pi()/2;
my($dx, $dy) = ($delta*cos($beta), $delta*sin($beta));
$cl->[$ii] += $dx;
$cl->[$ii+1] += $dy;
if ($ii == 2) {
$cl->[0] += $dx;
$cl->[1] += $dy;
}
}
$c->createLine
(@$cl,
-fill => $this_color,
-width => $this_width,
-joinstyle => 'bevel',
-tags => [@std_tags,
@extra_tags],
($line_dash ? (-dash => $line_dash) : ()),
#(exists $line_arrow{$cat} ? (-arrow => $line_arrow{$cat}) : ()),
-arrow => "last",
);
}
} elsif ($cat_hin eq 'Br') {
draw_bridge(\@coordlist, width => $this_width_hin+4, tags => \@std_tags);
} elsif ($cat_hin eq 'Tu') {
draw_tunnel_entrance(\@coordlist, width => $this_width_hin+4, tags => \@std_tags);
} else {
$c->createLine
(@coordlist,
-fill => $this_color_hin,
-width => $this_width_hin,
-joinstyle => 'bevel',
-tags => [@std_tags,
@extra_tags],
($line_dash ? (-dash => $line_dash) : ()),
(exists $line_arrow{$cat_hin} ? (-arrow => $line_arrow{$cat_hin}) : ()),
);
}
# no $cat_rueck support for names
if ($str_name_draw{$abk}
&& (($abk =~ /^[ls]/ &&
($cat_hin =~ /^[BH]/ ||
($lazy_str{$abk} && $scale >= 10)
)) || 0) # nur Hauptstraßen zeichnen (wg. Performance
# und Übersichtlichkeit), oder auch Nebenstraßen,
# falls lazy_plot und kleiner Maßstab
) {
my $strname = Strassen::strip_bezirk($strname);
Tk::RotFont::canvas
($c, $abk, \@coordlist,
$category_rot_font{$cat_hin} || $rot_font_sub,
$category_size{$cat_hin} || 10,
$strname,
(defined $category_font_color{$cat_hin} ? (-fill => $category_font_color{$cat_hin}) : ()),
);
}
if ($str_nr_draw{$abk}) {
draw_street_numbers($c,$strname,$abk,\@coordlist);
}
my $street_photo;
# XXX Generalize
if ($abk eq 'e') {
my $p = get_symbol_scale($abk);
$street_photo = $p if $p;
} elsif ($cat_hin eq 'St') {
$street_photo = $steigung_photo if $steigung_photo;
} elsif (@addinfo_hin # ignore @addinfo_rueck for now
) {
for my $addinfo_hin (@addinfo_hin) {
if ($addinfo_hin eq 'inwork' && $inwork_photo) {
$street_photo = $inwork_photo;
}
}
}
if ($street_photo) {
my($mx,$my) = get_polyline_center(@coordlist);
my $anchor = $street_photo eq $steigung_photo ? "s" : "nw";
$c->createImage($mx,$my,
-anchor => $anchor,
-image => $street_photo,
# $abk-img or $abk-fg ?
-tags => [$abk,$strname,"$abk-img",
"$abk-" . $i]);
if ($street_photo eq $steigung_photo) {
if ($strname =~ /([\d\.]+)\s*%/) {
outline_text
($c,
$mx, $my,
-anchor => "n",
-text => "$1%",
-font => $font{'small'},
-tags => [$abk,$strname,"$abk-fg",
"$abk-" . $i],
-outlinewidth => 2,
);
}
}
}
}
}
}
};
EOF
# XXX maybe combine this code with parsing coords code in $plotstr_draw_sub
my $parse_coords_code = <<'EOF';
TRY: {
#XXX my($xx, $yy);
if (!$edit_mode) {
($xx, $yy) = split /,/, $_;
} elsif ($edit_mode &&
/([A-Za-z]+)?(-?[\d\.]+),(-?[\d\.]+)$/) {
# XXX Verwendung von data/BASE (hier und überall)
my $this_coordsys = (defined $1 ? $1 : '');
if ($this_coordsys eq $coordsys ||
(!($this_coordsys ne '' || $coordsys ne 'B'))) {
($xx, $yy) = ($2, $3);
} else {
# the hard way: convert it
$this_coordsys = 'B' if $this_coordsys eq '';
($xx,$yy) = $Karte::map_by_coordsys{$this_coordsys}->map2map($coord_system_obj, $2, $3);
#warn "($xx,$yy)";
}
} else {
last TRY;
}
}
EOF
$plotpoint_draw_sub = <<'EOF'
sub {
my $ret = shift;
my $category = $ret->[Strassen::CAT];
return if defined $restrict and $category !~ /$restrict/;
my $pointname = $ret->[Strassen::NAME];
my $koord = $ret->[Strassen::COORDS][0]; # erste Koordinate
$koord = $conv->($koord) if $conv;
my($xx,$yy);
$_ = $koord;
EOF
. $parse_coords_code . <<'EOF';
my($x, $y) = transpose($xx, $yy);
if (defined $category_image{$category}) {
$category = "IMG:$category_image{$category}";
}
if ($category =~ /^IMG:([^|]+)(?:\|ANCHOR:([^|]+))?$/) {
my $photo = $1;
my $anchor = ($2 ? $2 : "c");
my($base) = ($photo =~ m|/| ? $photo =~ /([^\/]+)$/ : $photo);
$base = "p_$base";
my $images = ($top->{'MapImages'} ||= {});
my $p = $images->{$base};
if (!$p) {
eval {
#warn "Try $photo...\n";
$p = $c->Photo(-file => $photo);
};
if (!$p) {
eval {
my $photo = Tk::findINC($photo);
#warn "Try $photo...\n";
$p = $c->Photo(-file => $photo)
if defined $photo;
};
if (!$p) {
eval {
my $dir = dirname($p_file{$abk});
#warn "Try $dir/$photo...\n";
$p = $c->Photo(-file => "$dir/$photo");
};
}
}
if ($p) {
$images->{$base} = $p;
}
}
if ($p) {
$c->createImage($x, $y, -image => $p,
-anchor => $anchor,
-tags => ["$abk-img", "$xx,$yy", $pointname, ($abk =~ /^L\d+$/ ? ("L-fg") : ())],
);
return;
}
warn "Can't find image $photo (3)";
}
if ($abk =~ /^[ubr]$/) {
$c->createLine($x-$ubahn_length, $y, $x+$ubahn_length, $y,
-tags => ["$abk-bg", "$xx,$yy", $pointname]);
$c->createText($x, $y,
-tags => ["$abk-fg", "$xx,$yy", $pointname]);
} elsif ($abk eq 'lsa') {
# keine Verwendung von _coord_as_string
$c->createImage
($x, $y,
-image => ($category eq 'B'
? $andreaskr_photo
: $category eq 'Zbr'
? $zugbruecke_photo
: $category eq 'F'
? $ampelf_photo
: $ampel_photo
),
-tags => ["$abk-fg", "$xx,$yy", $pointname,
"$abk-" . $category . "-fg",
$abk."-".$i],
);
$ampeln{"$xx,$yy"} = $category;
} elsif ($abk eq 'pl') {
$c->createLine($x, $y, $x, $y,
-tags => ["$abk-fg", "$xx,$yy", $pointname],
);
} elsif ($abk eq 'vf') {
$c->createImage(transpose(@{Strassen::to_koord1($ret->[Strassen::COORDS][1])}),
-tags => "$abk-fg");
my($x1,$y1,$x2,$y2,$x3,$y3) =
(transpose(@{Strassen::to_koord1($ret->[Strassen::COORDS][0])}),
transpose(@{Strassen::to_koord1($ret->[Strassen::COORDS][1])}),
transpose(@{Strassen::to_koord1($ret->[Strassen::COORDS][2])}));
my $len1 = Strassen::Util::strecke([$x1,$y1], [$x2,$y2]);
my $whole_len1 = $len1 > 20 ? 20 : $len1;
my $len2 = Strassen::Util::strecke([$x2,$y2], [$x3,$y3]);
my $whole_len2 = $len2 > 20 ? 20 : $len2;
my($cx1,$cy1,$cx2,$cy2,$cx3,$cy3)
= (($x1-$x2)/$len1*$whole_len1+$x2,
($y1-$y2)/$len1*$whole_len1+$y2,
$x2,$y2,
($x3-$x2)/$len2*$whole_len2+$x2,
($y3-$y2)/$len2*$whole_len2+$y2,
);
$c->createLine($cx1,$cy1,$cx2,$cy2,$cx3,$cy3,
-tags => "$abk-bg");
} elsif ($abk =~ /^L(\d+)/) {
my $color = $category =~ /^\#/ ? $category : exists $category_color{$category} ? $category_color{$category} : undef;
my $width = $category_width{$category} || $p_width{$abk} || $default_width || 6;
$c->createLine($x, $y, $x, $y,
(defined $color ? (-fill => $color) : ()),
-width => $width,
-tags => ["$abk-fg", "$xx,$yy", $pointname, "p-" . $i, "L-fg"]);
} elsif ($abk =~ /^(kn|ki|rest)$/) {
$c->createImage($x, $y,
-tags => ["$abk-fg", "$xx,$yy", $pointname, "$abk-" . $i]);
} elsif ($abk =~ /^label/) {
# $category should contain font, anchor etc.
$c->createText($x, $y, -text => $pointname,
-font => $font{'large'}, # XXX
-anchor => "w", # XXX
-tags => ["$abk-fg", "$xx,$yy", $pointname, "$abk-" . $i]);
} else {
# Else draw a generic point (broad, color from cat)
my $color = $category_color{$category} || ($category =~ /^\#/ ? $category : 'red');
my $width = $category_width{$category} || $p_width{$abk} || $default_width || 6;
$c->createLine($x, $y, $x, $y,
-fill => $color, -capstyle => 'round',
-width => $width,
-tags => ["$abk-fg", "$xx,$yy", $pointname, "$abk-" . $i]);
}
if ($name_draw) {
my %args = ((exists $category_font_color{$category} ? (-fill => $category_font_color{$category}) : ()),
(exists $category_font{$category} ? (-font => $category_font{$category}) : ()),
-outlinewidth => 2,
-text => $pointname,
-tags => $name_draw_tag,
);
if ($orientation eq 'portrait' && $Tk::VERSION >= 800) {
require Tk::RotFont;
# XXX geht nicht...
Tk::RotFont::createRotText
($c, $x, $y,
-text => $pointname,
-rot => 3.141592653/2,
#-font => get_orte_label_font($cat),
-font => $rot_font_sub->(100), # no $cat...
-tags => $name_draw_tag,
);
} elsif (!$no_overlap_label ||
!draw_text_intelligent
($c, $x, $y,
-abk => $name_draw_other,
-xadd => $xadd_anchor,
-yadd => $yadd_anchor,
-outline => 1,
%args,
)) {
my($x,$y) = ($x,$y);
if (defined $label_spaceadd) {
$args{-text} = $label_spaceadd . $args{-text};
} else {
$x += $xadd_anchor->{'w'};
$y += $yadd_anchor->{'w'};
}
outline_text($c, $x, $y, -anchor => 'w', %args);
}
}
};
EOF
$plotorte_draw_sub = <<'EOF'
sub {
my $ret = shift;
my $cat = $ret->[Strassen::CAT];
my($name, $add) = split(/\|/, $ret->[Strassen::NAME]);
my($xx,$yy);
$_ = $ret->[Strassen::COORDS][0];
$_ = $conv->($_) if $conv;
EOF
. $parse_coords_code . <<'EOF';
# if ($ret->[Strassen::COORDS][0] =~ /(-?\d+),(-?\d+)/) {
if (defined $xx) {
# my($x, $y) = ($1, $2);
# my($tx, $ty) = $transpose->($x, $y);
my($tx, $ty) = $transpose->($xx, $yy);
my $fullname = ($add ? $name . " " . $add : $name);
return if ($place_category && $place_category ne "auto" && $cat < $place_category);
my $point_item;
if (!$municipality) {
$point_item = $c->createLine
($tx, $ty, $tx, $ty,
-tags => [$type, "$xx,$yy", $fullname, $label_tag."P$cat", $type."-".($i-1)],
);
}
if ($name_o) {
my $text = ($args{Shortname}
? $name
: $fullname);
my(@tags) = ($label_tag, "$label_tag$cat", $label_tag."-".($i-1));
if ($orientation eq 'portrait' && $Tk::VERSION >= 800) {
require Tk::RotFont;
# XXX geht nicht...
Tk::RotFont::createRotText
($c, $tx, $ty-4,
-text => $text,
-rot => 3.141592653/2,
#-font => get_orte_label_font($cat),
-font => $rot_font_sub->(100+$cat*12),
-tags => \@tags,
);
} elsif ($no_overlap_label && !$municipality) {
push(@orte_coords_labeling,
[$text, $tx, $ty, $cat, $point_item]);
} else {
if ($do_outline_text) {
outline_text
($c,
$tx+4,
$ty,
-text => $text,
-tags => \@tags,
-anchor => 'w',
-justify => 'left',
-fill => '#000080',
-font => get_orte_label_font($cat),
);
} else {
$c->createText($tx, $ty,
-text => $label_spaceadd{'o'} . $text,
-tags => \@tags,
);
}
}
}
}
};
EOF
}
sub set_bindings {
foreach (qw(p pp o
u-bg u-fg u_bg-img b-bg b-fg b_bg-img r-bg r-fg r_bg-img
sperre sperre_u sperre_b sperre_r temp_sperre
lsa-fg lsa-bg show pl-fg
L-img L-fg kn-fg ki-fg rest-fg)) {
std_p_binding($_);
}
foreach (qw(s sBAB S l L u b r f v v-fg w W i e comm mount),
(map { "comm-$_" } @comments_types),
qw(gr qs hs ql hl fz nl ovl temp_sperre_s rw wr)) {
std_str_binding($_);
}
# XXX Some bindings are here and in std_p_binding, which cause
# problems as both function set the <Leave> binding
# XXX route: no!
foreach (qw(lsa-bg lsa-fg vf-bg vf-fg
s-label-bg s-label sBAB-label-bg sBAB-label
w-label-bg w-label f-label-bg f-label
l-label-bg l-label
u-label b-label r-label show O)) {
std_transparent_binding($_);
}
# spezielle Bindings für Routen
$c->bind('route', '<Any-Enter>' => sub { enterroute($_[0]) });
$c->bind('route', '<Any-Motion>' => sub { enterroute($_[0]) });
$c->bind('route', '<Any-Leave>' => \&leaveroute);
# Cursor bei delnet-Kreuzen:
$c->bind("delnet", "<Any-Enter>" => sub {
if ($map_mode eq MM_USEREDIT) {
$c->{SavedCursor} = $c->get_cursor;
set_cursor("addnet");
}
});
$c->bind("delnet", "<Any-Leave>" => \&_restore_cursor);
foreach (qw(all)) {
# XXX TODO should be ButtonRelease-1 some day, if using
# B1-Motion for rubberbanding a zoom region
$c->bind($_, "<ButtonPress-1>" => \&set_route_point);
}
# Stack in tkstadtware für dragging angucken! XXX
$c->CanvasBind("<1>" => sub {
if ($map_mode =~ /^BBBike/) {
my $button_callback = $map_mode . '::button';
if (defined &$button_callback) {
my $e = $c->XEvent;
eval $button_callback.'($_[0], $e)';
die $@ if $@;
return;
}
} elsif ($map_mode eq MM_CUSTOMCHOOSE) {
set_route_point($c);
} elsif ($map_mode eq MM_SCRIBBLE) {
# XXX not Tk::Babybike!
Tk::Babybike::handle_button1_scribble($c,$c->XEvent);
} elsif ($map_mode eq MM_URL_SELECT) {
my($url) = grep { $_ } map {
my($url) = $_ =~ m{(http://\S+)};
defined $url ? $url : undef;
} $c->gettags("current");
if ($url) {
require WWWBrowser;
main::status_message("URL: $url", "info");
WWWBrowser::start_browser($url);
} else {
warn "Cannot get URL from " . join(", ", $c->gettags("current"));
}
}
return unless $map_mode eq MM_DRAG;
my $e = $c->XEvent;
$c->scan('mark', $e->x, $e->y);
});
$c->CanvasBind('<B1-Motion>' => sub {
if ($map_mode eq MM_SCRIBBLE) {
# XXX not Tk::Babybike!
return Tk::Babybike::handle_button1_motion_scribble($c,$c->XEvent);
}
return unless $map_mode eq MM_DRAG;
my $e = $c->XEvent;
$c->scan('dragto', $e->x, $e->y, 1);
});
set_b2();
# Canvas menu
my $popup_menu;
if ($right_is_popup) {
$popup_menu = $c->Menu(-title => M"Kartenmenü",
-tearoff => $Tk::platform eq 'unix');
$popup_menu->command(-label => M"Gesamte Route löschen",
-command => sub { delete_route() },
);
$popup_menu->command(-label => M"Suche wiederholen",
-command => \&re_search_gui,
);
$popup_menu->command(-label => M"Rückweg",
-command => \&way_back,
);
}
if ($c->can("menu") and $c->can("PostPopupMenu") and $Tk::VERSION >= 800) {
$c->menu($popup_menu);
$c->Tk::bind('<3>' => sub {
if ($right_is_popup) {
my $e = $_[0]->XEvent;
$_[0]->PostPopupMenu($e->X, $e->Y);
} else {
delete_route();
}
});
} else {
# legacy code
$frame->bind($c, "<ButtonPress-3>" => sub {
if ($right_is_popup) {
my $e = $_[0]->XEvent;
$popup_menu->Post($e->X, $e->Y);
} else {
delete_route();
}
});
}
$top->Advertise(PopupMenu => $popup_menu)
if $popup_menu;
my $alt_mouse1 = sub {
## DEBUG_BEGIN
#benchbegin("Alt Mouse1");
## DEBUG_END
if ($alt_set_route_point{$map_mode}) {
return $alt_set_route_point{$map_mode}->(@_);
}
if ($map_mode eq MM_BUTTONPOINT) {
freerec_sub(@_);
}
freedraw_sub(@_);
## DEBUG_BEGIN
#benchend();
## DEBUG_END
};
foreach (qw(Alt Shift Lock)) {
$frame->bind($c, "<$_-ButtonPress-1>" => $alt_mouse1);
}
if ($followmouse) {
start_followmouse();
}
# Zoom
for my $kp ('plus', 'KP_Add') {
$top->bind("<$kp>" => sub { my $e = $c->XEvent;
return unless $e;
my($x, $y) = ($c->canvasx($e->x),
$c->canvasy($e->y));
scalecanvas($c, 2, $x, $y);
});
}
for my $kp ('minus', 'KP_Subtract') {
$top->bind("<$kp>" => sub { my $e = $c->XEvent;
return unless $e;
my($x, $y) = ($c->canvasx($e->x),
$c->canvasy($e->y));
scalecanvas($c, 0.5, $x, $y);
});
}
$top->protocol('WM_DELETE_WINDOW', \&exit_app_noninteractive);
my($old_width, $old_height);
my $in_configure_event;
$top->bind('<Configure>' => sub {
my $e = $top->XEvent;
return if !$e || $in_configure_event;
$in_configure_event++;
eval {
if (!defined $old_width || $old_width != $e->w ||
!defined $old_height || $old_height != $e->h) {
arrange_symframe();
arrange_topframe();
$old_width = $e->w;
$old_height = $e->h;
}
};
my $err = $@;
$in_configure_event--;
die $err if $err;
});
$top->bind("<<CloseMainWin>>" => \&exit_app);
for my $mod (qw(Alt Control)) {
$top->bind("<$mod-r>" => sub { reload_all() });
}
$top->bind('<Control-o>' => sub { load_save_route(0) });
$top->bind('<Control-s>' => sub { load_save_route(1) });
$top->bind('<Control-underscore>' => \&get_undo_route);
$top->bind('<Control-z>' => \&get_undo_route);
$top->bind($_ => sub {
require BBBikeAdvanced;
search_anything();
})
for ('<Control-Key-f>', '<Key-slash>');
$top->bind("<Escape>" => sub { $escape = 1 });
$top->bind('Busy', '<Escape>' => sub { $escape = 1; });
$top->bind('Busy', '<KeyRelease-Escape>' => sub { });
bind_nomod($top, '<asterisk>' => \&show_register);
for my $i (0 .. 9) {
my $ii = $i;
$top->bind("<Key-$ii>" => sub { get_route_from_register($ii) });
}
bind_nomod($top, "<P>" => sub {
require BBBikeAdvanced;
start_ptksh();
});
$top->bind("<Control-R>" => sub {
require BBBikeAdvanced;
reload_new_modules();
});
bind_nomod($top, "<S>" => sub {
#XXX del?
# if ($BBBikeLazy::mode) {
# bbbikelazy_clear();
# } else {
# bbbikelazy_init();
# }
set_map_mode(MM_SEARCH);
});
bind_nomod($top, "<U>" => sub {
$map_mode = MM_USEREDIT;
set_cursor('delnet');
});
if ($Tk::platform ne 'MSWin32') { # XXX aber auf der Win98-Maschine von Monika laeuft es gut?!
bind_nomod($top, "<X>" => \&layer_editor);
}
bind_nomod($top, "<i>" => sub { show_info() });
if (!$no_map) {
bind_nomod($top, '<Key-M>' => sub { $map_draw = 1; getmap() });
$top->bind('<Control-Key-M>' => sub { delete_map() });
}
$top->bind("<BackSpace>" => \&mouse_dellast);
$top->bind("<Shift-BackSpace>" => \&delete_route);
$top->bind("<Delete>" => \&deltovia);
if ($advanced) {
advanced_bindings();
}
for my $kp ('', 'KP_') {
eval { # perl/Tk+win definiert keine KP_-Keysyms
$top->bind("<${kp}Down>" => sub { $c->yview(scroll => 1, 'units') });
$top->bind("<${kp}Up>" => sub { $c->yview(scroll => -1, 'units') });
$top->bind("<${kp}Left>" => sub { $c->xview(scroll => -1, 'units') });
$top->bind("<${kp}Right>" => sub { $c->xview(scroll => 1, 'units') });
$top->bind("<${kp}Begin>" => sub { center_best() });
};
}
$top->bind("<Next>" => sub { $c->yview(scroll => 5, 'units') });
$top->bind("<Prior>" => sub { $c->yview(scroll => -5, 'units') });
$top->bind("<Home>" => sub { $c->xview(scroll => -5, 'units') });
$top->bind("<End>" => sub { $c->xview(scroll => 5, 'units') });
eval {
$top->bind("<KP_Next>" => sub { $c->xview(scroll => 1, 'units');
$c->yview(scroll => 1, 'units') });
$top->bind("<KP_Prior>" => sub { $c->xview(scroll => 1, 'units');
$c->yview(scroll => -1, 'units') });
$top->bind("<KP_Home>" => sub { $c->xview(scroll => -1, 'units');
$c->yview(scroll => -1, 'units') });
$top->bind("<KP_End>" => sub { $c->xview(scroll => -1, 'units');
$c->yview(scroll => 1, 'units') });
};
$top->bind("<Shift-KP_2>" => sub { $c->yview(scroll => 5, 'units') });
$top->bind("<Shift-KP_8>" => sub { $c->yview(scroll => -5, 'units') });
$top->bind("<Shift-KP_4>" => sub { $c->xview(scroll => -5, 'units') });
$top->bind("<Shift-KP_6>" => sub { $c->xview(scroll => 5, 'units') });
$top->bind("<Shift-KP_3>" => sub { $c->xview(scroll => 5, 'units');
$c->yview(scroll => 5, 'units') });
$top->bind("<Shift-KP_9>" => sub { $c->xview(scroll => 5, 'units');
$c->yview(scroll => -5, 'units') });
$top->bind("<Shift-KP_7>" => sub { $c->xview(scroll => -5, 'units');
$c->yview(scroll => -5, 'units') });
$top->bind("<Shift-KP_1>" => sub { $c->xview(scroll => -5, 'units');
$c->yview(scroll => 5, 'units') });
}
sub set_map_mode {
if (@_) {
$map_mode = $_[0];
}
execute_and_set_map_mode_deactivate(undef);
if ($map_mode eq MM_SEARCH) {
if (defined $search_route_flag && $search_route_flag =~ /^ziel/) {
set_cursor('ziel');
} else {
set_cursor('start');
}
} elsif ($map_mode eq MM_BUTTONPOINT) {
set_cursor('xy');
} elsif ($map_mode eq MM_INFO) {
#XXX $map_mode_deactivate->() if $map_mode_deactivate;
set_cursor('info');
#XXX undef $map_mode_deactivate;
} elsif ($map_mode eq MM_DRAG) {
set_cursor('movehand');
} elsif (exists $map_mode_callback{$map_mode} &&
ref $map_mode_callback{$map_mode} eq 'CODE') {
$map_mode_callback{$map_mode}->();
} elsif ($map_mode eq MM_URL_SELECT) {
set_cursor('www');
}
}
sub execute_and_set_map_mode_deactivate {
my($new_sub) = @_;
if ($map_mode_deactivate) {
$map_mode_deactivate->();
undef $map_mode_deactivate;
}
if ($new_sub) {
$map_mode_deactivate = $new_sub;
}
}
# Bindings
# ... unter Mauszeiger anzeigen
# Punkte
sub std_p_binding {
my $tag = $_[0];
$c->bind($tag, '<Any-Enter>' => sub {
$layer_pre_enter_command{$tag}->()
if exists $layer_pre_enter_command{$tag};
enterpoint($_[0]);
$layer_post_enter_command{$tag}->()
if exists $layer_post_enter_command{$tag};
});
unless (/^lsa-/) { # lsa-fg/bg: leavepoint wird unten gesetzt
$c->bind($tag, '<Any-Leave>' => sub {
$layer_pre_leave_command{$tag}->()
if exists $layer_pre_leave_command{$tag};
leavepoint(@_);
$layer_post_leave_command{$tag}->()
if exists $layer_post_leave_command{$tag};
});
}
}
# Strecken, Flächen
sub std_str_binding {
my $tag = $_[0];
$c->bind($tag, '<Any-Enter>' => sub {
$layer_pre_enter_command{$tag}->()
if exists $layer_pre_enter_command{$tag};
enterstr($_[0]);
$layer_post_enter_command{$tag}->()
if exists $layer_post_enter_command{$tag};
});
$c->bind($tag, '<Any-Leave>' => sub {
$layer_pre_leave_command{$tag}->()
if exists $layer_pre_leave_command{$tag};
leavestr($_[0]);
$layer_post_leave_command{$tag}->()
if exists $layer_post_leave_command{$tag};
});
if (defined $c_balloon) {
$c->bind($tag, '<Any-Motion>' => sub { $c_balloon->Track });
}
}
# unter den Tags nachgucken, ob es eine Straße zum Anzeigen gibt
# ("durchsichtige" Tags)
sub std_transparent_binding {
# Motion statt Enter, da sich die Straße unter einer Route
# ändern kann.
$c->bind($_[0], '<Any-Motion>' => sub {
my $str = show_below_route_str($_[0]);
if (defined $str && $str ne ''
&& defined $c_balloon
&& $use_c_balloon > 1) {
# XXX before each $c_ballon->Popup should be this line (maybe move into sub?):
if ($leave_after) { $leave_after->cancel; undef $leave_after }
$c_balloon->Popup($str);
}
});
if ($_[0] =~ /^(show$|lsa-)/) { # XXX this special handling should go away
$c->bind($_[0], '<Any-Leave>' => sub { &leavepoint;
&leavestr; } );
} else {
$c->bind($_[0], '<Any-Leave>' => \&leavestr);
}
}
# Aufzeichnen eines Punktes
sub freerec_sub {
my $e = $_[0]->XEvent;
my($xx, $yy) = ($c->canvasx($e->x), $c->canvasy($e->y));
require BBBikeAdvanced;
buttonpoint(anti_transpose($xx, $yy));
}
# freies Zeichnen von Punkten
sub freedraw_sub {
my $e = $_[0]->XEvent;
my($xx, $yy) = ($c->canvasx($e->x), $c->canvasy($e->y));
my($ax, $ay) = anti_transpose($xx, $yy);
return if !defined(addpoint_xy($ax, $ay, $xx, $yy));
push @search_route_points, [join(",",@{ $realcoords[-1] }), POINT_MANUELL];
if ($net && $map_mode ne MM_BUTTONPOINT) {
push @act_search_route,
$net->route_to_name([$realcoords[-2], $realcoords[-1]],
-startindex => $#realcoords+1);
add_new_point($net, join(",",@{ $realcoords[-1] }), -quiet => 1);
}
if ($map_mode ne MM_BUTTONPOINT) {
set_flag('via');
set_flag('ziel');
set_cursor('ziel');
$search_route_flag = 'ziel_cont';
}
updatekm();
if (!$edit_mode && !$edit_normal_mode) {
update_route_strname();
}
}
# Letzten Punkt löschen
sub mouse_dellast {
if ($special_edit ne '') {
eval $special_edit . '_edit_mouse3(@_)';
die $@ if $@;
} else {
if ($map_mode eq MM_BUTTONPOINT) {
dellast_selection();
}
dellast()
}
}
# delete_route light. Allerdings nicht ganz klar, wo das hier warum
# verwendet wird.
sub reset_button_command {
reset_undo_route();
undef $search_route_flag;
if ($map_mode eq MM_SEARCH) {
search_route_mouse(1);
}
}
sub change_net_type {
undef $handicap_s_net;
if ($net_type eq "r") {
*set_coords = \&set_coords_rbahn;
} elsif ($net_type eq "us") {
*set_coords = \&set_coords_usbahn;
} elsif ($net_type eq "rus") {
*set_coords = \&set_coords_bahn;
} elsif ($net_type eq 'wr') {
*set_coords = \&set_coords_wasserrouten;
if (!$str_draw{wr}) {
plot("str", "wr", -draw => 1);
}
} elsif ($net_type eq 'custom') {
if (!keys %custom_net_str) {
require BBBikeAdvanced;
select_layers_for_net_dialog();
}
*set_coords = \&set_coords_custom;
} else {
*set_coords = \&set_coords_str;
}
if (defined $net) {
make_net();
}
}
# Routenpunkt festlegen
sub set_route_point {
my $e = $_[0]->XEvent;
# auf Alt, Shift und CapsLock checken
# bei Win95/NT ist 8 nicht CapsLock, sondern NumLock
if ($Tk::VERSION < 800) {
return if $e->s & (1+2+($os eq 'win' ? 0 : 8));
} else {
return if $e->s =~ /\b(Shift|Alt|Lock)-/;
}
if ($map_mode eq MM_EDITPOINT) {
my(@tags) = $c->gettags('current');
if ($tags[0] eq 'pp' || $tags[0] =~ /^vf/ || $tags[0] =~ /^lsa/) {
$point_editor->set($tags[1]);
}
} elsif ($map_mode eq MM_INSERTPOINT) {
insert_point_from_canvas($c);
} elsif ($map_mode eq MM_CREATERELATION) {
create_relation_from_canvas($c);
} elsif ($map_mode eq MM_DRAG) {
$c->scan('mark', $e->x, $e->y);
} elsif ($special_edit ne '') {
eval $special_edit . '_edit_mouse1(@_)';
die $@ if $@;
} elsif ($map_mode eq MM_CUSTOMCHOOSE_TAG || $map_mode eq MM_CUSTOMCHOOSE) {
$customchoosecmd->($c, $e);
} elsif ($map_mode eq MM_SEARCH) { # XXX doppelt
#XXX defined $search_route_flag && ????
if (defined $search_route_flag && $search_route_flag eq 'ziel_cont') {
search_route_mouse_cont();
} elsif ($search_route_flag) {
search_route_mouse();
} else {
warn "XXX activating....";
$search_route_flag = "start";
search_route_mouse();
}
Tk->break; # XXX insert more Tk->break in this subroutine?
} elsif ($map_mode eq MM_BUTTONPOINT) {
my $item = 'current';
my(@tags) = $c->gettags($item);
if ($tags[0] !~ /^(pp|o)$/) {
($item) = find_below($c, "pp", "o");
if (!defined $item) {
warn "Not over a <pp> or <o> point, got @tags";
return;
}
}
require BBBikeAdvanced;
buttonpoint(undef,undef,$item);
freedraw_sub($_[0]);
} elsif ($map_mode eq MM_INFO) {
show_info();
} elsif ($map_mode =~ /^BBBike/) {
my $itembutton_callback = $map_mode . '::itembutton';
if (defined &$itembutton_callback) {
eval $itembutton_callback.'($c,$e)';
die $@ if $@;
}
} elsif ($map_mode eq MM_USEREDIT) {
user_edit_street();
Tk->break; # XXX insert more Tk->break in this subroutine?
} elsif ($set_route_point{$map_mode}) {
$set_route_point{$map_mode}->($e);
} elsif ($map_mode ne MM_SEARCH) {
addpoint_inter();
}
}
sub draw_street_numbers {
# the coloring is german specific
my($c,$strname,$abk,$coordlist_ref) = @_;
my $do_round = 0;
# XXX handling of multiple street numbers? e.g. "F1, R1" or "B2/B5"?
my($type,$nr) = Strasse::parse_street_type_nr($strname);
# Extra routes in and outer Berlin:
if (!defined $type && $city_obj && $city_obj->can("parse_street_type_nr")) {
($type, $nr, $do_round) = $city_obj->parse_street_type_nr($strname);
}
if (defined $type) {
my $dist = 0;
my $drawn = 0;
my $draw_sub = sub {
my $coord_i = shift;
my($midx,$midy) = Strassen::Util::middle(@{$coordlist_ref}[$coord_i..$coord_i+3]);
my $item = $c->createText
($midx,$midy,-text => ($type =~ /^(B|BAB)$/ ? "" : $type) . $nr,
-fill => ($do_round ? 'white' :
$type eq 'BAB' ? 'white' :
$type =~ /^(F|R)$/ ? 'green4' :
'black'),
-tags => "$abk-label");
my(@bbox) = $c->bbox($item);
my $r_item;
if ($do_round) {
$r_item = $c->createOval
($bbox[0]-2,$bbox[1]-2,$bbox[2]+2,$bbox[3]+2,
-fill => '#90d090',
-outline => 'black',
-width => 1,
-tags => ["$abk-label-bg", "strnr", "strnr-$item"],
);
} else {
$r_item = $c->createRectangle
($bbox[0]-2,$bbox[1]-2,$bbox[2]+2,$bbox[3]+2,
-fill => ($type eq 'B' ? 'yellow' :
($type eq 'BAB' ? 'blue' :
'white')),
-outline => ($type eq 'BAB' ? 'white' :
($type =~ /^(F|R)$/ ? 'green4' : 'black')),
-width => 2,
-tags => ["$abk-label-bg", "strnr", "strnr-$item"],
);
}
$c->raise($item,$r_item);
$dist = 0;
$drawn++;
};
for(my $ci=2; $ci<$#$coordlist_ref; $ci+=2) {
$dist += Strassen::Util::strecke([@{$coordlist_ref}[$ci-2,$ci-1]], [@{$coordlist_ref}[$ci,$ci+1]]);
if ($dist >= 400) { # should be in the magnitude of canvas height
$draw_sub->($ci-2);
}
}
if (!$drawn) {
$draw_sub->(int($#$coordlist_ref/4)*2); # XXX ueberdenken
}
}
}
# middle mouse button bindings
sub set_b2 {
# first delete all canvas b2 bindings
foreach my $bind (qw(ButtonPress-2 2 B2-Motion)) {
$c->CanvasBind("<$bind>" => '');
}
if ($b2_mode == B2M_DELLAST) {
$c->CanvasBind("<ButtonPress-2>" => \&mouse_dellast);
} elsif ($b2_mode == B2M_AUTOSCROLL) {
require Tk::Autoscroll;
my %extra_args;
$extra_args{'-speed'} = $autoscroll_speed if ($autoscroll_speed);
$extra_args{'-middle'} = !!$autoscroll_middle;
Tk::Autoscroll::Init($c, %extra_args);
} elsif ($b2_mode == B2M_SCAN || $b2_mode == B2M_FASTSCAN) {
my $gain = $b2_mode == B2M_SCAN ? 1 : 10;
$c->CanvasBind('<2>',
[sub {
my($w,$x,$y) = @_;
$w->scan('mark',$x,$y);
},Tk::Ev('x'),Tk::Ev('y')]);
$c->CanvasBind('<B2-Motion>',
[sub {
my($w,$x,$y) = @_;
$w->scan('dragto',$x,$y,$gain);
},Tk::Ev('x'),Tk::Ev('y')]);
} elsif ($b2_mode == B2M_CUSTOM && $b2m_customcmd) {
$c->CanvasBind('<2>', [$b2m_customcmd, $c]);
$c->CanvasBind('<B2-Motion>', '');
} else {
# no bindings
}
set_mouse_desc();
}
# Setzen der Hilfstexte für die Maustastenbelegung
sub enter_leave_bind_for_help {
my($w, $textref) = @_;
my(@save_mouse_text);
$w->bind
('<Enter>' => sub {
for my $i (1..3) {
if (defined $textref->[$i-1]) {
$save_mouse_text[$i] = $mouse_text[$i] || '';
$mouse_text[$i] = $textref->[$i-1];
}
}
});
$w->bind
('<Leave>' => sub {
for my $i (1..3) {
if (defined $save_mouse_text[$i]) {
$mouse_text[$i] = $save_mouse_text[$i];
undef $save_mouse_text[$i];
}
}
});
}
sub set_datadir {
my($newdir, %args) = @_;
if ($args{-clearold}) {
@Strassen::datadirs = ();
}
if (defined $newdir && -d $newdir) {
unshift @Strassen::datadirs, $newdir;
$datadir = $newdir;
} else {
$datadir = $Strassen::datadirs[0];
}
if ($verbose) {
warn Mfmt("Aktuelles Datenverzeichnis ist %s\n", $datadir);
}
}
# Beendet die Anwendung. Bei Bedarf werden Konfigurationsdateien gesichert.
# Temporäre Dateien werden gelöscht.
sub exit_app {
if (Tk::Exists($top) && $ask_quit && $Tk::VERSION >= 800) {
# deiconify seems to be required on Solaris CDE
$top->deiconify;
# XXX and raise makes the thing slow on KDE :-(
$top->raise;
return if ($top->messageBox
(-icon => "question",
-title => M"BBBike beenden",
-message => M"Soll BBBike beendet werden?",
-type => "YesNo") =~ /no/i); # XXX Sprache?
}
exit_app_noninteractive();
}
sub exit_app_noninteractive {
save_last_loaded($last_loaded_obj);
save_last_loaded($last_loaded_layers_obj) if $last_loaded_layers_obj;
if ($autosave_opts && defined $opt) {
# get actual geometry
$geometry = fix_geometry();
# get actual font parameters
if ($top->can("fontActual")) {
my %f_attr = $top->fontActual($font{'normal'});
$font_family = $f_attr{-family};
$font_size = $f_attr{-size};
$font_weight = $f_attr{-weight};
}
# Reference power/speed
my $speed_or_power = ($active_speed_power{Type} eq 'speed'
? \@speed
: \@power
);
$speed_power_reference_string = $active_speed_power{Type} . ":" . $speed_or_power->[$active_speed_power{Index}];
# save options
eval {
$opt->save_options;
};
if ($@) {
status_message($@, "warn");
}
}
if (defined &BBBikeServer::server_cleanup) {
BBBikeServer::server_cleanup();
}
my @todel;
if (keys %tmpfiles) {
push @todel, keys %tmpfiles;
if ($INC{'GfxConvert.pm'}) {
push @todel, keys %GfxConvert::tmpfiles;
}
}
unlink @todel if (@todel);
$top->destroy if Tk::Exists($top);
exit;
}
######################################################################
# Verändern der aktuellen Default-Geschwindigkeit oder Default-Leistung.
# $type ist entweder "speed" oder "power"
# $index ist der zu änderne Eintrag
sub change_active_speed_power {
my($type, $index) = @_;
my $has_old = 0;
if (defined %active_speed_power) {
# delete old
my $frame = ($active_speed_power{Type} eq 'speed'
? \@speed_frame
: \@power_frame
);
my $inx = $active_speed_power{Index};
if (defined $frame->[$inx]) {
$frame->[$inx]->configure(-relief => "raised",
-borderwidth => 1);
}
$has_old = 1;
}
%active_speed_power = (Type => $type,
Index => $index);
# set new
my $frame = ($active_speed_power{Type} eq 'speed'
? \@speed_frame
: \@power_frame
);
my $inx = $active_speed_power{Index};
if (defined $frame->[$inx]) {
$frame->[$inx]->configure(-relief => "raised",
-borderwidth => 2);
}
calc_ampel_optimierung() if $ampel_optimierung;
redraw_path() if $has_old;
}
sub change_ampel_count {
my($type, $index) = @_;
$ampel_count->{$type}[$index] = !$ampel_count->{$type}[$index];
if ($ampel_count->{$type}[$index]) {
$ampel_count_button->{$type}[$index]->configure
(-image => $ampel_klein_photo);
updatekm();
} else {
$ampel_count_button->{$type}[$index]->configure
(-image => $ampel_klein_grey_photo);
updatekm();
}
}
sub change_kopfstein_count {
my($type, $index) = @_;
$kopfstein_count->{$type}[$index] = !$kopfstein_count->{$type}[$index];
if ($kopfstein_count->{$type}[$index]) {
$kopfstein_count_button->{$type}[$index]->configure
(-image => $kopfstein_klein_photo);
updatekm();
} else {
$kopfstein_count_button->{$type}[$index]->configure
(-image => $kopfstein_klein_grey_photo);
updatekm();
}
}
# Erzeugt den String für den Label der Leistung
sub mk_power_txt {
my($i) = @_;
if (defined $i) {
$power_txt[$i] = "$power[$i] W";
} else {
for($i = 0; $i <= $#power; $i++) {
$power_txt[$i] = "$power[$i] W";
}
}
}
# Dialog zum Eingeben der Leistung
### AutoLoad Sub
sub enter_power {
my($i) = @_;
my $t = redisplay_top($top, "power-$i", -title => M"Leistung");
return if !defined $t;
my $var = $power[$i];
my $scale_var = $var;
my $row = 0;
$t->Label(-text => M('Leistung (in W)').':'
)->grid(-row => $row, -column => 0);
my $e = $t->Entry(-textvariable => \$var,
-width => 4)->grid(-row => $row, -column => 1);
$e->tabFocus;
$row++;
$t->Scale(-from => 10,
-to => 500,
-bigincrement => 50,
-resolution => 5,
-orient => 'horiz',
-showvalue => 0,
-variable => \$scale_var,
-command => sub { $var = $scale_var },
)->grid(-row => $row, -column => 1, -sticky => 'we');
$row++;
my $ref_row = $row;
my $create_reference_label = sub {
$t->Label(-text => M"Referenzleistung",
)->grid(-row => $ref_row, -column => 0, -columnspan => 2);
};
my $is_reference = ($active_speed_power{Type} eq 'power' &&
$active_speed_power{Index} eq $i);
if (!$is_reference) {
my $rb;
$rb = $t->Button
(-text => M"Als Referenzleistung verwenden",
-command => sub {
change_active_speed_power("power", $i);
$create_reference_label->();
$rb->gridForget;
},
)->grid(-row => $row, -column => 0, -columnspan => 2);
$row++;
} else {
$create_reference_label->();
$row++;
}
my $close_window = sub { $t->destroy; };
my $apply_window = sub { IncBusy($t);
eval {
$power[$i] = $var;
after_changed_power($i);
};
DecBusy($t);
};
my $ok_window = sub { &$close_window;
&$apply_window };
my $bf = $t->Frame->grid(-row => $row, -column => 0,
-columnspan => 2);
my $okb = $bf->Button
(Name => 'ok',
-command => $ok_window)->grid(-row => 0, -column => 0,
-sticky => 'ew');
$bf->Button(Name => 'apply',
-command => $apply_window)->grid(-row => 0, -column => 1,
-sticky => 'ew');
my $cb = $bf->Button
(Name => 'close',
-command => $close_window)->grid(-row => 0, -column => 2,
-sticky => 'ew');
$t->bind('<Return>' => sub { $okb->invoke });
$t->bind('<<CloseWin>>' => sub { $cb->invoke });
my_popup($t);
}
sub after_changed_power {
my($i) = @_; # index
my $is_reference = ($active_speed_power{Type} eq 'power' &&
$active_speed_power{Index} eq $i);
mk_power_txt($i);
calc_ampel_optimierung()
if $ampel_optimierung && $is_reference;
recalc_bikepwr();
updatekm();
}
# Erzeugt den String für den Label der Geschwindigkeit
sub mk_speed_txt {
my($i) = @_;
if (defined $i) {
$speed_txt[$i] = "$speed[$i] km/h";
} else {
for($i = 0; $i <= $#speed; $i++) {
$speed_txt[$i] = "$speed[$i] km/h";
}
}
}
# Dialog zum Eingeben der Geschwindigkeit
### AutoLoad Sub
sub enter_speed {
my($i) = @_;
my $t = redisplay_top($top, "speed-$i", -title => M"Geschwindigkeit");
return if !defined $t;
my $var = $speed[$i];
my $scale_var = $var;
my $row = 0;
$t->Label(-text => M('Geschwindigkeit (in km/h)').':'
)->grid(-row => $row, -column => 0);
my $e = $t->Entry(-textvariable => \$var,
-width => 3)->grid(-row => $row, -column => 1);
$e->tabFocus;
$row++;
$t->Scale(-from => 5,
-to => 60,
-bigincrement => 5,
-resolution => 1,
-orient => 'horiz',
-showvalue => 0,
-variable => \$scale_var,
-command => sub { $var = $scale_var },
)->grid(-row => $row, -column => 1, -sticky => 'we');
$row++;
my $ref_row = $row;
my $create_reference_label = sub {
$t->Label(-text => M"Referenzgeschwindigkeit",
)->grid(-row => $ref_row, -column => 0, -columnspan => 2);
};
my $is_reference = ($active_speed_power{Type} eq 'speed' &&
$active_speed_power{Index} eq $i);
if (!$is_reference) {
my $rb;
$rb = $t->Button
(-text => M"Als Referenzgeschwindigkeit verwenden",
-command => sub {
change_active_speed_power("speed", $i);
$create_reference_label->();
$rb->gridForget;
},
)->grid(-row => $row, -column => 0, -columnspan => 2);
$row++;
} else {
$create_reference_label->();
$row++;
}
my $close_window = sub { $t->destroy; };
my $apply_window = sub { IncBusy($t);
eval {
$speed[$i] = $var;
mk_speed_txt($i);
calc_ampel_optimierung()
if $ampel_optimierung && $is_reference;
updatekm();
};
DecBusy($t);
};
my $ok_window = sub { &$close_window;
&$apply_window };
my $bf = $t->Frame->grid(-row => $row, -column => 0,
-columnspan => 2);
my $okb = $bf->Button
(Name => 'ok',
-command => $ok_window)->grid(-row => 0, -column => 0,
-sticky => 'ew');
$bf->Button(Name => 'apply',
-command => $apply_window)->grid(-row => 0, -column => 1,
-sticky => 'ew');
my $cb = $bf->Button
(Name => 'close',
-command => $close_window)->grid(-row => 0, -column => 2,
-sticky => 'ew');
$t->bind('<Return>' => sub { $okb->invoke });
$t->bind('<<CloseWin>>' => sub { $cb->invoke });
my_popup($t);
}
# Dialog zum Eingeben der Windgeschwindigkeit und -richtung
### AutoLoad Sub
sub enter_wind {
require Tk::Optionmenu;
require Met::Wind;
import Met::Wind;
my $t = redisplay_top($top, "wind", -title => M"Wind");
return if !defined $t;
my @var = ($winddir, $wind_v_max, $wind_v);
my @scale_var = @var;
my(@e, @om, @sc);
my %wind_range =
('Beaufort' => [0, 16],
'm/s' => [0, 56],
'km/h' => [0, 200],
'mi/h' => [0, 125],
'kn' => [0, 100]);
my @wind_unit = (undef, 'm/s', 'm/s');
my @last_wind_unit = @wind_unit;
$t->Label(-text => M("Windrichtung").":")->grid(-row => 0, -column => 0);
$t->Label(-text => M("max. Windgeschwindigkeit").":"
)->grid(-row => 1, -column => 0);
$t->Label(-text => M("mitt. Windgeschwindigkeit").":"
)->grid(-row => 2, -column => 0);
my $rbf = $t->Frame->grid(-row => 0, -column => 1, -columnspan => 10);
foreach my $spec ([qw(sw 0 2)],
[qw(w 0 1)],
[qw(nw 0 0)],
[qw(n 1 0)],
[qw(ne 2 0)],
[qw(e 2 1)],
[qw(se 2 2)],
[qw(s 1 2)]) {
my($windri, $col, $row) = @$spec;
$col*=2;
$rbf->Label(-text => uc($windri))->grid(-row => $row,
-column => $col);
$rbf->Radiobutton(-variable => \$var[0], -value => $windri,
)->grid(-row => $row, -column => $col+1);
}
if (defined $windrose2_photo) {
$rbf->Label(-image => $windrose2_photo)->grid(-row => 1,
-column => 1*2,
-columnspan => 2);
}
for(my $i = 1; $i <= $#var; $i++) {
$e[$i] = $t->Entry(-textvariable => \$var[$i],
-width => 5)->grid(-row => $i, -column => 1);
}
for(my $i = 1; $i <= $#var; $i++) {
my $ii = $i;
$om[$i] = $t->Optionmenu
(-takefocus => 1,
-highlightthickness => 2,
-variable => \$wind_unit[$i],
-command => sub {
if ($last_wind_unit[$ii] ne $wind_unit[$ii]) {
my $old_var = $var[$ii];
$sc[$ii]->configure
(-from => $wind_range{$wind_unit[$ii]}->[0],
-to => $wind_range{$wind_unit[$ii]}->[1],
);
$var[$ii] = wind_velocity([$old_var,
$last_wind_unit[$ii]],
$wind_unit[$ii]);
$last_wind_unit[$ii] = $wind_unit[$ii];
}
})->grid(-row => $i, -column => 2);
$om[$i]->addOptions('m/s', 'km/h', 'Beaufort', 'mi/h', 'kn');
$sc[$i] = $t->Scale(-from => $wind_range{$wind_unit[$i]}->[0],
-to => $wind_range{$wind_unit[$i]}->[1],
-orient => 'horiz',
-showvalue => 0,
-variable => \$scale_var[$i],
-command => sub { $var[$ii] = $scale_var[$ii] },
)->grid(-row => $i, -column => 3, -sticky => 'we');
}
$rbf->focus;
for(my $i = 1; $i < $#var; $i++) {
my $ii = $i;
$e[$i]->bind('<Return>' => sub { $e[$ii+1]->tabFocus });
}
my $apply_window = sub {
for(my $i = 1; $i <= $#var; $i++) {
if ($wind_unit[$i] ne 'm/s') {
$om[$i]->setOption('m/s');
# Der Rest wird automatisch im -command vom Optionmenu
# erledigt.
}
}
if (defined $var[0] and $var[0] =~ /^([ns][ew]?|[ew])$/i) {
analyze_wind(undef, undef, @var);
$wind = 1; # XXX ?
if ($coloring eq 'wind') {
redraw_path();
updatekm();
}
} else {
status_message(Mfmt("Unerlaubte Windrichtung: <%s>", $var[0]),
'warn');
}
};
my $close_window = sub { $t->destroy };
my $ok_window = sub { &$close_window;
&$apply_window; };
my $bf = $t->Frame->grid(-row => 3, -column => 0,
-columnspan => 10, -sticky => 'we');
my $okb = $bf->Button(Name => 'ok',
-command => $ok_window,
)->pack(-side => 'left', -fill => 'x', -expand => 1);
$bf->Button(Name => 'apply',
-command => $apply_window,
)->pack(-side => 'left', -fill => 'x', -expand => 1);
my $cb = $bf->Button(Name => 'close',
-command => $close_window,
)->pack(-side => 'left', -fill => 'x', -expand => 1);
$bf->Label->pack(-side => 'left', -fill => 'x', -expand => 1);
$bf->Button(-text => M"Beaufort-Tabelle",
-command => sub {
Met::Wind::beaufort_table
($t,
-command => sub {
my($num, $unit, $toplevel) = @_;
$var[2] = Met::Wind::wind_velocity([$num, $unit],
$wind_unit[2]);
$toplevel->destroy;
},
)
},
)->pack(-side => 'left', -fill => 'x', -expand => 1);
$e[-1]->bind('<Return>' => sub { $okb->invoke });
$t->bind('<<CloseWin>>' => sub { $cb->invoke });
#XXX del: $t->idletasks; # XXX help popup to display on the right location
my_popup($t);
}
# Dialog zum Eingeben des Mapscales
### AutoLoad Sub
sub enter_scale {
return unless $mapscale =~ /:\s*(\d+)/;
my($old_mapscale, $new_mapscale, $new_mapscale_scale);
$old_mapscale = $new_mapscale = $new_mapscale_scale = $1;
my $t = redisplay_top($top, "scale", -title => M"Maßstab");
return if !defined $t;
$t->Label(-text => M"Maßstab 1:"
)->grid(-row => 0, -column => 0, -sticky => 'e');
my $e = $t->Entry(-textvariable => \$new_mapscale,
-width => 8)->grid(-row => 0, -column => 1,
-sticky => 'ew');
$e->tabFocus;
my $sc;
if (defined $default_mapscale && $default_mapscale != 0) {
$t->Button(Name => 'default',
-command => sub {
$new_mapscale = $new_mapscale_scale = $default_mapscale;
},
)->grid(-row => 0, -column => 2);
}
my $Scale = 'Scale';
my %scaleargs = (-bigincrement => 5000,
-resolution => 1000,
-showvalue => 0,
);
eval {
require Tk::LogScale;
require Tie::Watch;
$Scale = 'LogScale';
%scaleargs = (-resolution => 0.01,
-showvalue => 0);
};
my $scale = $t->$Scale
(-from => 1000,
-to => 3_000_000,
%scaleargs,
-orient => 'horiz',
-variable => \$new_mapscale_scale,
-command => sub { $new_mapscale = int($new_mapscale_scale); },
)->grid(-row => 1, -column => 1,
-columnspan => 2,
-sticky => 'we');
my $close_window = sub { $t->destroy; };
my $apply_window = sub {
IncBusy($t);
eval {
if ($old_mapscale != $new_mapscale and $new_mapscale != 0) {
scalecanvas($c, $old_mapscale/$new_mapscale);
if ($mapscale =~ /:\s*(\d+)/) {
$old_mapscale = $new_mapscale = $1;
if (Tk::Exists($scale)) {
# Die Abfrage ist ein Workaround, ansonsten
# gibt es einen Perl-Panic, wenn Tk::LogScale
# verwendet wird. Möglicher Grund: es wird auf
# eine Tie-Variable zugegriffen, die
# anscheinend schon zerstört ist (?), bzw.
# deren Tie-Objekt zerstört ist.
$new_mapscale_scale = $1;
}
} else {
die Mfmt("Fehler beim Parsen des Massstabs: %s",
$mapscale);
}
}
};
DecBusy($t);
};
my $ok_window = sub { &$close_window;
&$apply_window };
my $bf = $t->Frame->grid(-row => 2, -column => 0,
-columnspan => 2);
my $okb = $bf->Button
(Name => 'ok',
-command => $ok_window)->grid(-row => 0, -column => 0,
-sticky => 'ew');
$bf->Button(Name => 'apply',
-command => $apply_window)->grid(-row => 0, -column => 1,
-sticky => 'ew');
my $cb = $bf->Button
(Name => 'close',
-command => $close_window)->grid(-row => 0, -column => 2,
-sticky => 'ew');
$t->bind('<Return>' => sub { $okb->invoke });
$t->bind('<<CloseWin>>' => sub { $cb->invoke });
my_popup($t);
}
# Ändert den -state einer gesamten Widgethierarchie unter $frame
# $enable gibt an, ob die Widgets de/aktiviert werden sollen
# $exceptions ist ein Hash, wobei die Keys die Ausnahmen unter den Widgets
# angeben
### AutoLoad Sub
sub change_state_all {
my($frame, $enable, $exceptions) = @_;
foreach ($frame->children) {
next if exists $exceptions->{$_};
if ($enable) {
eval { $_->configure(-state => 'normal') };
} else {
eval { $_->configure(-state => 'disabled') };
}
if ($_->can('children')) {
change_state_all($_, $enable, $exceptions);
}
}
}
sub toggle_enter_opt_preferences {
if ($show_enter_opt_preferences) {
enter_opt_preferences();
} else {
$toplevel{"optparam"}->withdraw
if Tk::Exists($toplevel{"optparam"});
}
}
# Dialog zum Einstellen der Optimierungseinstellungen
### AutoLoad Sub
sub enter_opt_preferences {
my($i) = @_;
$show_enter_opt_preferences = 1;
my $t = redisplay_top($top, "optparam", -title => M"Optimierungsparameter");
return if !defined $t;
my $withdraw = sub { $show_enter_opt_preferences = 0;
$t->withdraw;
};
$t->protocol('WM_DELETE_WINDOW', $withdraw);
require Tk::NoteBook;
my $nb = $t->NoteBook->grid(-row => 0, -column => 0,
-columnspan => 3);
my %var = %qualitaet_s_speed;
my %var4 = %handicap_s_speed;
my %var2 = %strcat_speed;
my %var3 = %radwege_speed;
my $Entry = 'Entry';
eval {
require Tk::NumEntry;
$Entry = 'NumEntry';
};
my @act_page;
$act_page[0] = $nb->add("q", -label => M"Straßenqualität");
my $gridy = 0;
$act_page[0]->Label(-text => M"Straßenqualität",
-font => $font{'bold'})->grid(-row => $gridy,
-column => 0);
$act_page[0]->Label(-text => M"max. Geschwindigkeit",
-font => $font{'bold'})->grid(-row => $gridy,
-column => 1,
-columnspan => 2,
);
$gridy++;
#XXX geht nicht...warum ???
# $t->bind('<Return>' => sub {
# warn $t->focusCurrent;
# if ($t->focusCurrent->isa('Tk::Entry')) {
# $t->focusNext->tabFocus;
# }
# });
my @e;
for (0 .. 3) {
my $i = $_;
$act_page[0]->Label(-text => "Q$i: " .
$category_attrib{"Q$i"}->[ATTRIB_LONG],
)->grid(-row => $gridy, -column => 0, -sticky => 'w');
my $w;
$w = $e[$i] = $act_page[0]->$Entry(-textvariable => \$var{"Q$i"},
-width => 3);
$w->grid(-row => $gridy, -column => 1, -sticky => 'e');
$act_page[0]->Label(-text => 'km/h')->grid(-row => $gridy, -column => 2,
-sticky => 'w');
$gridy++;
}
$e[0]->tabFocus;
my $cb1;
$cb1 = $act_page[0]->Checkbutton
(-text => M"Verwenden",
-variable => \$qualitaet_s_optimierung,
-command => sub { change_state_all($act_page[0], $qualitaet_s_optimierung,
{$cb1=>1}); },
)->grid(-row => $gridy++,
-column => 2,
-sticky => 'e');
change_state_all($act_page[0], $qualitaet_s_optimierung, {$cb1=>1});
#######
$act_page[1] = $nb->add("cat", -label => M"Straßenkategorien",
-createcmd => sub {
$gridy = 0;
$act_page[1]->Label(-text => M"Straßenkategorien",
-font => $font{'bold'})->grid(-row => $gridy,
-column => 0);
$act_page[1]->Label(-text => M"max. Geschwindigkeit",
-font => $font{'bold'})->grid(-row => $gridy,
-column => 1,
-columnspan => 2,
);
$gridy++;
# XXX BAB
for (qw(HH H N NN)) {
my $i = $_;
$act_page[1]->Label(-text => $category_attrib{$i}->[ATTRIB_PLURAL] . ": "
)->grid(-row => $gridy, -column => 0,
-sticky => 'w');
my $w = $act_page[1]->$Entry(-textvariable => \$var2{$i},
-width => 3);
# bind return XXX
$w->grid(-row => $gridy, -column => 1, -sticky => 'e');
$act_page[1]->Label(-text => 'km/h')->grid(-row => $gridy, -column => 2,
-sticky => 'w');
$gridy++;
}
{
require Tk::Optionmenu;
# Die Verwendung von $name2inx ist nur ein Workaround...
# Eigentlich würde ich die [Name => Wert]-Notation von Optionmenu
# verwenden wollen, aber das geht nicht :-(
my $name2inx =
{M"Nur Hauptstraßen" => 0,
M"Hauptstraßen bevorzugen" => 1,
M"Alle Straßen berücksichtigen" => 2,
M"Nebenstraßen bevorzugen" => 3,
M"Nur Nebenstraßen" => 4,
};
my $default = M"Alle Straßen berücksichtigen";
my $o = $act_page[1]->Optionmenu
(-options => [sort { $name2inx->{$a} <=> $name2inx->{$b} } keys %$name2inx],
-variable => \$default,
-command => sub {
my $i = 0;
# XXX BAB
for (qw(HH H N NN)) {
$var2{$_} = [[100,100,1,1],
[100,100,12,12],
[100,100,100,100],
[12,12,100,100],
[1,1,100,100],
]->[$name2inx->{$default}][$i];
$i++;
}
})->grid(-row => $gridy,
-column => 0,
-sticky => 'w');
}
my $cb2;
$cb2 = $act_page[1]->Checkbutton
(-text => M"Verwenden",
-variable => \$strcat_optimierung,
-command => sub { change_state_all($act_page[1], $strcat_optimierung,
{$cb2=>2}); },
)->grid(-row => $gridy++,
-column => 2,
-sticky => 'e');
change_state_all($act_page[1], $strcat_optimierung, {$cb2=>2});
});
#######
$act_page[2] = $nb->add("rw", -label => M"Radwege",
-createcmd => sub {
$gridy = 0;
$act_page[2]->Label(-text => M"Radwege",
-font => $font{'bold'})->grid(-row => $gridy,
-column => 0);
$act_page[2]->Label(-text => M"max. Geschwindigkeit",
-font => $font{'bold'})->grid(-row => $gridy,
-column => 1,
-columnspan => 2,
);
$gridy++;
require Radwege;
for (@Radwege::bbbike_category_order) {
my $i = $_;
$act_page[2]->Label(-text => $Radwege::bez{$i} .": "
)->grid(-row => $gridy, -column => 0,
-sticky => 'w');
my $w = $act_page[2]->$Entry(-textvariable => \$var3{$i},
-width => 3);
# bind return XXX
$w->grid(-row => $gridy, -column => 1, -sticky => 'e');
$act_page[2]->Label(-text => 'km/h')->grid(-row => $gridy, -column => 2,
-sticky => 'w');
$gridy++;
}
my $N_RW_cb;
my $cb3;
$cb3 = $act_page[2]->Checkbutton
(-text => M"Verwenden",
-variable => \$radwege_optimierung,
-command => sub { change_state_all($act_page[2], $radwege_optimierung,
{$cb3=>3,$N_RW_cb=>1}); },
)->grid(-row => $gridy++,
-column => 2,
-sticky => 'e');
change_state_all($act_page[2], $radwege_optimierung, {$cb3=>3});
$N_RW_cb = $act_page[2]->Checkbutton
(-text => M"Hauptstraßen ohne Radwege/Busspuren meiden",
-variable => \$N_RW_optimization,
-command => sub {
if ($N_RW_optimization) {
$radwege_optimierung = 0;
$strcat_optimierung = 0;
change_state_all($act_page[2], $radwege_optimierung,
{$cb3=>1,$N_RW_cb=>1});
}
},
)->grid(-row => $gridy++,
-column => 0,
-sticky => "w");
});
#######
$act_page[3] = $nb->add("lsa", -label => M"Ampel-Optimierung",
-createcmd => sub {
$gridy = 0;
$act_page[3]->Label(-text => M"Ampel-Optimierung",
-font => $font{'bold'})->grid(-row => $gridy,
-column => 0);
# $act_page[3]->Label(-text => M"max. Geschwindigkeit",
# -font => $font{'bold'})->grid(-row => $gridy,
# -column => 1,
# -columnspan => 2,
# );
$gridy++;
my $dgf = $act_page[3]->Frame->grid(-row => $gridy++, -column => 0,
-sticky => 'w', -columnspan => 3);
my $gridyy = 0;
$dgf->Label(-text => M("Durchschnittsgeschwindigkeit (km/h)").":"
)->grid(-row => $gridyy, -column => 0,
-sticky => 'w');
my $gridxx = 1;
for (qw(10 15 20 25 30)) {
$dgf->Radiobutton(-text => $_,
-variable => \$average_v,
-value => $_,
-command => \&calc_ampel_optimierung,
)->grid(-row => $gridyy, -column => $gridxx++,
-sticky => 'w');
}
$gridyy++;
my $am_frame = $dgf->Frame->grid(-row => $gridyy,
-column => 1,
-columnspan => 5,
-sticky => "nw");
$am_frame->Radiobutton(-text => M"Automatisch",
-variable => \$average_v,
-value => 0,
-command => \&calc_ampel_optimierung,
)->pack(-side => 'left');
$am_frame->Radiobutton(-text => M"Manuell über Strecke",
-variable => \$average_v,
-value => -1,
-command => \&calc_ampel_optimierung,
)->pack(-side => 'left');
$dgf->Label(-text => M("Beschleunigung (m/s^2)").":"
)->grid(-row => ++$gridyy, -column => 0,
-sticky => 'w');
$gridxx = 1;
my $found_beschleunigung;
for (qw(0.5 1 1.5 2)) {
$dgf->Radiobutton(-text => $_,
-variable => \$beschleunigung,
-value => $_,
-command => \&calc_ampel_optimierung,
)->grid(-row => $gridyy, -column => $gridxx++,
-sticky => 'w');
if ($beschleunigung == $_) {
$found_beschleunigung++;
}
}
if (!$beschleunigung) { $beschleunigung = 1 }
if (!$found_beschleunigung) {
if ($beschleunigung > 2) { $beschleunigung = 2 }
elsif ($beschleunigung < 0.5) { $beschleunigung = 0.5 }
$beschleunigung = int($beschleunigung*2)/2;
}
$gridyy++;
$dgf->Label(-text => M("Verlorene Strecke (m)").":"
)->grid(-row => $gridyy, -column => 0, -sticky => "w");
$dgf->Entry(-textvariable => \$lost_strecke_per_ampel,
-width => 5
)->grid(-row => $gridyy, -column => 1,
-columnspan => 5, -sticky => "w");
my $cb4;
$cb4 = $act_page[3]->Checkbutton
(-text => M"Verwenden",
-variable => \$ampel_optimierung,
-command => sub { change_state_all($act_page[3], $ampel_optimierung,
{$cb4=>4}); },
)->grid(-row => $gridy++,
-column => 2,
-sticky => 'e');
change_state_all($act_page[3], $ampel_optimierung, {$cb4=>4});
});
####
$act_page[4] = $nb->add("h", -label => M"Sonst. Beeinträchtigungen");
$gridy = 0;
$act_page[4]->Label(-text => M"Sonst. Beeinträchtigungen",
-font => $font{'bold'})->grid(-row => $gridy,
-column => 0);
$act_page[4]->Label(-text => M"max. Geschwindigkeit",
-font => $font{'bold'})->grid(-row => $gridy,
-column => 1,
-columnspan => 2,
);
$gridy++;
#XXX geht nicht...warum ???
# $t->bind('<Return>' => sub {
# warn $t->focusCurrent;
# if ($t->focusCurrent->isa('Tk::Entry')) {
# $t->focusNext->tabFocus;
# }
# });
@e = ();
for (0 .. 4) {
my $i = $_;
$act_page[4]->Label(-text => "q$i: " .
$category_attrib{"q$i"}->[ATTRIB_LONG],
)->grid(-row => $gridy, -column => 0, -sticky => 'w');
my $w;
$w = $e[$i] = $act_page[4]->$Entry(-textvariable => \$var4{"q$i"},
-width => 3);
$w->grid(-row => $gridy, -column => 1, -sticky => 'e');
$act_page[4]->Label(-text => 'km/h')->grid(-row => $gridy, -column => 2,
-sticky => 'w');
$gridy++;
}
$e[0]->tabFocus;
my $cb5;
$cb5 = $act_page[4]->Checkbutton
(-text => M"Verwenden",
-variable => \$handicap_s_optimierung,
-command => sub { change_state_all($act_page[4], $handicap_s_optimierung,
{$cb5=>5}); },
)->grid(-row => $gridy++,
-column => 2,
-sticky => 'e');
change_state_all($act_page[4], $handicap_s_optimierung, {$cb5=>5});
#######
$gridy = 1;
#XXX my $close_window = sub { $t->destroy; };
my $close_window = $withdraw;
my $apply_window = sub { eval {
while(my($k,$v) = each %var) {
if ($qualitaet_s_speed{$k} != $v) {
undef $qualitaet_s_net;
}
$qualitaet_s_speed{$k} = $v;
}
while(my($k,$v) = each %var2) {
if ($strcat_speed{$k} != $v) {
undef $strcat_net;
}
$strcat_speed{$k} = $v;
}
while(my($k,$v) = each %var3) {
if ($radwege_speed{$k} != $v) {
undef $radwege_net;
}
$radwege_speed{$k} = $v;
}
while(my($k,$v) = each %var4) {
if ($handicap_s_speed{$k} != $v) {
undef $handicap_s_net;
}
$handicap_s_speed{$k} = $v;
}
};
};
my $ok_window = sub { &$close_window;
&$apply_window };
my $bf = $t->Frame->grid(-row => $gridy++, -column => 0,
-columnspan => 3);
my $okb = $bf->Button
(Name => 'ok',
-command => $ok_window)->grid(-row => 0, -column => 0,
-sticky => 'ew');
$bf->Button(Name => 'apply',
-command => $apply_window)->grid(-row => 0, -column => 1,
-sticky => 'ew');
my $clb = $bf->Button
(Name => 'close',
-command => $close_window)->grid(-row => 0, -column => 2,
-sticky => 'ew');
$t->bind('<Return>' => sub { $okb->invoke });
$t->bind('<<CloseWin>>' => sub { $clb->invoke });
$t->Popup(@popup_style);
}
# Macht aus den negativen Werten positive und aus den positiven reziproke
# Werte für die Penalty-Berechnung.
### AutoLoad Sub
sub optprefs2penalty {
my $val = shift;
if ($val < 0 ) {
$val = -$val;
} elsif ($val > 0) {
$val = 1/$val;
}
}
# Alternativer Dialog zum Einstellen der Optimierung. Noch nicht
# fertig.
### AutoLoad Sub
sub enter_opt_preferences2 {
my $t = redisplay_top($top, "optprefs", -title => M"Optimierungsvorlieben");
#XXX handicap XXX
return if !defined $t;
my @l = ([M"Ampeln", M"Ampeln vermeiden", M"Ampeln bevorzugen"],
[M"Abbiegen", M"Abbiegen vermeiden", M"Abbiegen bevorzugen"],
[M"Qualität", M"schlechte Qualität vermeiden", M"schlechte Qualität bevorzugen"],
[M"Kategorie", M"Hauptstraßen vermeiden", M"Nebenstraßen vermeiden"],
[M"Radwege", M"Radwege vermeiden", M"Radwege bevorzugen"],
[M"Steigung", M"Steigungen vermeiden", M"Steigungen bevorzugen"]);
# Kategorie: B/HH: 3, H: 2, N: 1, NN: 0
# Kat Scale Res
# 0 -5 -5
# 1 -5 -2
# 2 -5 +2
# 3 -5 +5
# 0 -3 -3
# 1 -3 -1
# 2 -3 +1
# 3 -3 +3
# 0 0 0
# 1 0 0
# 2 0 0
# 3 0 0
# 0 +3 +3
# 1 +3 +1
# 2 +3 -1
# 3 +3 -3
# 0 +5 +5
# 1 +5 +2
# 2 +5 -2
# 3 +5 -5
my @scale;
my $y = 0;
for my $l_def (@l) {
my($l, $minus, $plus) = @$l_def;
$optprefs{$l} = 0 unless defined $optprefs{$l};
$t->Label(-text => $minus)->grid(-row => $y, -column => 0,
-sticky => 'e',
);
$scale[$y] = $t->Scale(-showvalue => 0,
-from => -5,
-to => 5,
-variable => \$optprefs{$l},
-orient => 'h')->grid(-row => $y, -column => 1);
$t->Label(-text => $plus)->grid(-row => $y, -column => 2,
-sticky => 'w',
);
$y++;
}
my $close_window = sub { $t->destroy; };
# XXX Überhaupt mit apply und so arbeiten? Wie war das gedacht gewesen?
my $apply_window = sub {
eval {
# Ampeloptimierung
#XXX $lost_time_per_ampel = -$optprefs{"Ampeln"}*?;
# XXX what about F ...?
$lost_strecke_per_ampel = -$optprefs{"Ampeln"}*40;
$ampel_optimierung = ($optprefs{Ampeln} != 0);
# Abbiegeoptimierung
$abbiege_penalty = -$optprefs{"Abbiegen"}*30;
$abbiege_optimierung = ($optprefs{Abbiegen} != 0);
# Qualitätsoptimierung
# foreach (0 .. 3) {
# $qualitaet_s_speed{"Q
# $qualitaet_s_optimierung = ($optprefs{Qualität} != 0);
};
};
my $ok_window = sub { &$close_window;
&$apply_window };
my $bf = $t->Frame->grid(-row => $y++, -column => 0,
-columnspan => 3,
-sticky => "ew");
my $gridx = 0;
my $okb = $bf->Button
(Name => 'ok',
-command => $ok_window)->grid(-row => 0, -column => $gridx++,
-sticky => 'ew');
$bf->Button(-text => M"Zurücksetzen",
-command => sub {
for my $l_def (@l) {
$optprefs{$l_def->[0]} = 0;
}
})->grid(-row => 0,
-column => $gridx++,
-sticky => 'ew');
$bf->Button(Name => 'apply',
-command => $apply_window)->grid(-row => 0,
-column => $gridx++,
-sticky => 'ew');
my $clb = $bf->Button
(Name => 'close',
-command => $close_window)->grid(-row => 0, -column => $gridx++,
-sticky => 'ew');
$t->bind('<Return>' => sub { $okb->invoke });
$t->bind('<<CloseWin>>' => sub { $clb->invoke });
$t->idletasks;
my $bar = $t->Frame(-bg => 'red'
)->place('-y' => $scale[0]->y,
'-x' => $scale[0]->x + $scale[0]->width/2-1,
-width => 2,
-height => ($scale[-1]->y-$scale[0]->y+
$scale[-1]->height),
);
# fast ein Hack: Events im senkrechten Strich werden auf die
# daruterliegenden Scales weitergeleitet
if ($bar->can('eventGenerate')) {
foreach my $evt (qw(Motion
B1-Motion 1 ButtonRelease-1
B2-Motion 2 ButtonRelease-2
)) {
my $evt2 = $evt;
$bar->bind("<$evt2>" => sub {
my $e = shift->XEvent;
my($X,$Y) = ($e->X, $e->Y);
# feststellen, welches Scale-Widget sich
# darunter befindet
my $wid = $bar->containing($X+5,$Y);
if (defined $wid && $wid->isa('Tk::Scale')) {
$wid->eventGenerate("<$evt2>",
'-x' => $X-$wid->rootx,
'-y' => $Y-$wid->rooty,
);
}
});
}
}
my_popup($t);
}
# Berechnet für die Watt-Zahl die entsprechende Geschwindigkeit
### AutoLoad Sub
sub power2speed {
my($power, %args) = @_;
return if !$bp_obj;
my $new_bp_obj = clone BikePower $bp_obj;
$new_bp_obj->given('P');
$new_bp_obj->headwind(0);
my $grade = $args{-grade} || 0;
$new_bp_obj->grade($grade);
$new_bp_obj->power($power);
$new_bp_obj->calc;
$new_bp_obj->velocity*3.6;
}
# Berechnet für die angegebene Geschwindigkeit die Watt-Zahl
### AutoLoad Sub
sub speed2power {
my($speed, %args) = @_;
return if !$bp_obj;
my $new_bp_obj = clone BikePower $bp_obj;
$new_bp_obj->given('v');
$new_bp_obj->headwind(0);
my $grade = $args{-grade} || 0;
$new_bp_obj->grade($grade);
$new_bp_obj->velocity($speed/3.6);
$new_bp_obj->calc;
$new_bp_obj->power;
}
# Berechnet den Faktor für die max. Geschwindigkeit, die auf der
# jeweiligen Straße (wegen Belag, Kategorie ...) gefahren werden kann.
### AutoLoad Sub
sub max_speed {
my($speed_belag) = @_;
my $speed_radler = get_active_speed();
($speed_belag >= $speed_radler
? 1
: $speed_radler/$speed_belag);
}
# Return active speed in km/h.
### AutoLoad Sub
sub get_active_speed {
my $speed;
if ($active_speed_power{Type} eq 'power') {
$speed = power2speed($power[$active_speed_power{Index}]);
} else {
$speed = $speed[$active_speed_power{Index}];
}
if (!$speed) {
$speed = 20; # für alle Fälle
}
$speed;
}
sub toggle_mouse_help {
if (defined $toplevel{"help"} and
Tk::Exists($toplevel{"help"})) {
$toplevel{"help"}->destroy;
} else {
mouse_help();
}
}
# Gibt ein Hilfsfenster mit der derzeitigen Maustastenbelegung aus
### AutoLoad Sub
sub mouse_help {
my $bgcolor = 'grey80';
my $help_t = redisplay_top($top, 'help',
-title => M"Maushilfe",
@popup_style,
-bg => $bgcolor);
return if !defined $help_t;
$help_t->protocol('WM_DELETE_WINDOW' => sub {
$show_mouse_help = 0;
$help_t->destroy;
});
my $row = 0;
$help_t->gridColumnconfigure($_, -minsize => "1.6i") for (0..2);
$help_t->gridRowconfigure($row, -minsize => "0.7i");
$help_t->Message(-textvariable => \$mouse_text[1],
-width => "1.5i",
-bg => $bgcolor,
)->grid(-row => $row+1, -column => 0, -sticky => 'ne');
$help_t->Message(-textvariable => \$mouse_text[2],
-width => "1.5i",
-bg => $bgcolor,
)->grid(-row => $row, -column => 1, -sticky => 's');
$help_t->Message(-textvariable => \$mouse_text[3],
-width => "1.5i",
-bg => $bgcolor,
)->grid(-row => $row+1, -column => 2, -sticky => 'nw');
$row++;
# Maus zeichnen
my $c = $help_t->Canvas(-width => "1.13i", -height => "1.38i",
-bg => $bgcolor,
-borderwidth => 0,
-highlightthickness => 0,
-takefocus => 0,
)->grid(-row => $row, -column => 1);
$c->create('rectangle',"0.070866i","0.070866i","1.062992i","1.311024i",
-fill => 'white',
-outline => undef);
$c->create('line',"1.062992i","1.311024i","1.062992i","0.070866i","0.070866i","0.070866i","0.070866i","1.311024i","1.062992i","1.311024i");
$c->create('line',"0.744094i","0.122047i","1.027559i","0.122047i","1.027559i","0.531496i","0.744094i","0.531496i","0.744094i","0.122047i");
$c->create('line',"0.425197i","0.122047i","0.708661i","0.122047i","0.708661i","0.531496i","0.425197i","0.531496i","0.425197i","0.122047i");
$c->create('line',"0.106299i","0.122047i","0.389764i","0.122047i","0.389764i","0.531496i","0.106299i","0.531496i","0.106299i","0.122047i");
$c->create('line', "0.106299i", "0.318898i", "0.000000i", "0.318898i");
$c->create('line', "1.133858i", "0.318898i", "1.027559i", "0.318898i");
$c->create('line', "0.562992i", "0.007874i", "0.562992i", "0.114173i");
}
## DEBUG_BEGIN
#BEGIN{mymstat("50% BEGIN");}
## DEBUG_END
# Lädt bzw. speichert eine Route
### AutoLoad Sub
sub load_save_route {
my($save, $file, %args) = @_;
status_message("");
my $path;
my $ext = $bbbike_route_ext;
if (!defined $file) {
my $method = $save ? "getSaveFile" : "getOpenFile";
$file = $top->$method
(-title => ($save ? M"Route speichern" : M"Route laden"),
-initialdir => $oldpath,
($save ?
(-defaultextension => ".$ext") :
(-filetypes => [[M"Route-Dateien", '.' . $bbbike_route_ext],
[M"GPS-Tracks", ['.tracks','.trk']],
[M"G7toWin", ['.g7t', '.G7T']],
[M"MPS-Tracks", ['.mps', '.MPS']],
[M"Alle Dateien", '*']]),
));
return if !defined $file;
$oldpath = dirname $file;
}
if (!-f $file && !file_name_is_absolute($file)) { # unvollständiger Dateiname
$file = catfile($bbbike_routedir, "$file.$ext");
}
if (!$save) { # load
IncBusy($top) if $top;
eval {
my $res = Route::load($file,
{ ResetRoute => \&reset_undo_route },
-fuzzy => 0);
if ($res->{IsStrFile}) {
# eine Strassen-Datei
plot_layer('str', $file);
return;
}
@realcoords = @{ $res->{RealCoords} };
@search_route_points = @{ $res->{SearchRoutePoints} };
if (!@realcoords) {
die M"Leere Routendatei";
}
add_last_loaded($file, $last_loaded_obj);
@coords = ();
my $i;
my($minx, $miny, $maxx, $maxy);
my $std = ($coord_system eq 'standard');
foreach (@realcoords) {
my($x, $y);
if ($std) {
($x, $y) = transpose($_->[0], $_->[1]);
} else {
($x, $y) = transpose
($coord_system_obj->standard2map($_->[0], $_->[1]));
require BBBikeAdvanced;
buttonpoint($x, $y);
};
push(@coords, [$x, $y]);
if (!defined $minx || $x < $minx) { $minx = $x }
if (!defined $maxx || $x > $maxx) { $maxx = $x }
if (!defined $miny || $y < $miny) { $miny = $y }
if (!defined $maxy || $y > $maxy) { $maxy = $y }
}
if ($zoom_loaded_route) {
zoom_view($minx, $miny, $maxx, $maxy);
} elsif ($center_loaded_route) {
my $x2 =
(abs($coords[0]->[0]-$minx) > abs($coords[0]->[0]-$maxx)
? $minx : $maxx);
my $y2 =
(abs($coords[0]->[1]-$miny) > abs($coords[0]->[1]-$maxy)
? $miny : $maxy);
$c->center_view2($coords[0]->[0], $coords[0]->[1], $x2, $y2);
}
restore_search_route_points();
redraw_path();
updatekm();
update_route_strname();
undef $search_route_flag;
search_route_mouse_cont();
status_message(Mfmt("Typ der Routendatei: %s, Punkte: %s", $res->{Type}, scalar(@realcoords)), "info");
};
if ($@) {
status_message($@, 'err');
}
DecBusy($top) if $top;
} else { # Save
my $case = ($os eq 'win' ? '(?i)' : '');
if ($file !~ /$case\.$ext$/i) {
$file .= ".$ext";
}
make_backup($file);
eval {
Route::save(-file => $file,
-realcoords => \@realcoords,
-searchroutepoints => \@search_route_points);
};
if ($@) {
status_message($@, 'err');
} else {
add_last_loaded($file, $last_loaded_obj);
}
}
}
### AutoLoad Sub
sub save_route_as_bbd {
my $file = $top->getSaveFile(-defaultextension => '.bbd');
return unless defined $file;
my $tmpfile = "$tmpdir/bbbike-$$.bbr";
load_save_route(1, $tmpfile);
system("$FindBin::RealBin/miscsrc/bbr2bbd", $tmpfile, $file);
unlink $tmpfile;
}
### AutoLoad Sub
sub save_route_as_esri {
my $file = $top->getSaveFile(-defaultextension => '.shp');
return unless defined $file;
$file =~ s/\.shp$//;
my $tmpfile1 = "$tmpdir/bbbike-$$.bbr";
my $tmpfile2 = "$tmpdir/bbbike-$$.bbd";
load_save_route(1, $tmpfile1);
eval {
# XXX Better diagnostics. bbr2bbd and bbd2esri should be
# callable as modules.
system("$FindBin::RealBin/miscsrc/bbr2bbd", $tmpfile1, $tmpfile2);
status_message(Mfmt("Das Ausführen von %s ist mit dem Code %s fehlgeschlagen", "bbr2bbd", $?), "die") if $? != 0;
system("$FindBin::RealBin/miscsrc/bbd2esri", $tmpfile2, "-o", $file);
status_message(Mfmt("Das Ausführen von %s ist mit dem Code %s fehlgeschlagen", "bbd2esri", $?), "die") if $? != 0;
}; warn $@ if $@;
unlink $tmpfile2;
unlink $tmpfile1;
}
### AutoLoad Sub
sub save_route_as_gpx {
my(%args) = @_;
if (!eval { require Strassen::GPX; 1 }) {
guess_perlmod_install_advice($@);
} else {
my $file = $top->getSaveFile(-defaultextension => '.gpx');
return unless defined $file;
my $tmpfile = "$tmpdir/bbbike-$$.bbr";
my $tmp2file = "$tmpdir/bbbike-$$.bbd";
load_save_route(1, $tmpfile);
system("$FindBin::RealBin/miscsrc/bbr2bbd", $tmpfile, $tmp2file);
my $s = Strassen->new($tmp2file);
my $out = $s->Strassen::GPX::bbd2gpx(%args);
open(FH, "> $file") or status_message("Can't write to $file: $!", "die");
binmode FH;
print FH $out;
close FH;
unlink $tmpfile;
unlink $tmp2file;
}
}
# weiter zur Druckfunktion...
### AutoLoad Sub
sub print_function {
my $print_backend = $print_backend;
if (!defined $print_backend || $print_backend eq "") {
if ($os eq 'win') {
my $available = print_postscript(undef, -checkavailability => 1);
if (!$available) {
# a PDF viewer should be available everywhere nowadays on Win32
$print_backend = "pdf";
} else {
$print_backend = "ps";
}
} else {
$print_backend = "ps";
}
}
if ($print_backend eq 'pdf') {
require File::Temp;
my($fh, $tmpfile) = File::Temp::tempfile(UNLINK => 1,
SUFFIX => ".pdf");
$tmpfiles{$tmpfile}++;
pdf_export(-visiblemap => 1, -file => $tmpfile);
close($fh);
if (-e $tmpfile) {
view_pdf($tmpfile);
}
return;
}
return if slow_postscript_generation();
my $tmpfile = create_postscript
($c,
-legend => ($use_legend ?
($use_legend_right ? 'right' : 'left') : 0),
-colormode => $ps_color,
-rotate => $ps_rotate,
-scale_a4 => $ps_scale_a4,
);
my @print_args;
if ($ps_scale_a4) {
push @print_args, -media => 'A4';
}
print_postscript($tmpfile, @print_args);
}
# Berechnet die Canvas-Koordinaten der Route aus den Standard-Koordinaten
### AutoLoad Sub
sub realcoords2coords {
@coords = ();
my $i;
my $std = ($coord_system eq 'standard');
foreach (@realcoords) {
my($x, $y);
if ($std) {
($x, $y) = transpose($_->[0], $_->[1]);
} else {
($x, $y) = transpose
($coord_system_obj->standard2map($_->[0], $_->[1]));
}
push @coords, [$x, $y];
}
}
######################################################################
#
# Funktionen zum Zeichnen der Kartenelemente (Strecken und Punkte)
#
# Allegemeine Plot-Funktion
sub plot {
my($type, $abk, %args) = @_;
Hooks::get_hooks("before_plot")->execute;
if (exists $args{'-draw'}) {
if ($type eq 'str') {
$str_draw{$abk} = $args{'-draw'};
} else {
$p_draw{$abk} = $args{'-draw'};
}
delete $args{'-draw'};
}
if ($type eq 'str') {
plotstr($abk, %args);
} elsif ($type eq 'p') {
if ($abk =~ /sperre/) {
my $object_or_file = $args{-object} || $args{-filename} || $p_obj{$abk};
$args{-abk} = $abk;
plot_sperre($object_or_file, %args);
} else {
plotp($abk, %args);
}
} else {
die "Unknown type $type";
}
###XXX Häh?
# if ($BBBikeLazy::mode && defined &bbbikelazy_remove_data) {
# bbbikelazy_remove_data($type, $abk);
# }
Hooks::get_hooks("after_plot")->execute;
}
sub plot_layer {
my($type, $file, %args) = @_;
my $abk = next_free_layer();
if (!defined $abk) {
status_message("Kein freier Layer mehr vorhanden", "err");
return;
}
fix_stack_order($abk);
if ($type eq 'p') {
$p_draw{$abk} = 1;
$p_file{$abk} = $file if defined $file;
} else {
$str_draw{$abk} = 1;
$str_file{$abk} = $file if defined $file;
}
plot($type, $abk, %args);
$abk;
}
# XXX
# höheres Canvas-Objekt
# - derzeitige Transpose-Funktion
# - Scale
# - Koordinatensystem
#
# Zeichnet Strecken auf dem Canvas
sub plotstr {
my($abk, %args) = @_;
my $c = $c;
return if !$c;
my $std = 1;
my $transpose = \&transpose;
if (exists $args{Canvas}) {
$c = $args{Canvas};
$std = 0;
$transpose = ($show_overview_mode eq 'brb'
? \&transpose_small
: \&transpose_medium);
}
status_message("");
$abk = 's' if !defined $abk;
# alte Tags löschen
if (!$std || !$args{FastUpdate} || !$str_draw{$abk}) {
$c->delete($abk); # evtl. alte Koordinaten löschen
$c->delete("pp-$abk");
}
$c->delete("$abk-out");
$c->delete("$abk-label");
$c->delete("$abk-label-bg");
$c->delete("$abk-fg") if $abk eq 'v'; # XXX do not use for "b", "r" or "u"!
if ($abk eq 'w') { # Wasser *und* Inseln löschen
$c->delete("i");
$c->delete("i-out");
}
if ($std && !$str_draw{$abk}) {
if ($lazy_str{$abk}) {
bbbikelazy_remove_data("str", $abk);
}
return;
}
# Get source from filename or street object
my($filename, $filename_maybe, $str, $has_filename);
if (!defined $args{-object}) {
$filename = $args{-filename} || $args{Filename};
if (defined $filename) {
$str_file{$abk} = $filename;
} else {
$filename = get_strassen_file($str_file{$abk});
$filename_maybe = $str_file{$abk} if $edit_mode_flag; # as fallback if no -orig version available
}
$has_filename = 1;
delete $pending{"replot-str-$abk"};
if (!defined $filename) {
status_message(Mfmt("Dateiname für <%s> ist nicht definiert.", $abk),
'err');
return;
}
} else {
$str = delete $args{-object};
}
# Radwege werden im Edit-Modus besser mit radweg_draw_canvas() gezeichnet
# XXX ups? stimmt das noch immer???
if ($abk eq 'rw' and $coord_system ne 'standard') {
radweg_open();
radweg_draw_canvas();
return;
}
my $dont_use_cache;
my $dont_set_cache = 1;
if (!$str) {
$dont_use_cache = ($coord_system ne 'standard' ||
$args{FastUpdate} ||
$abk =~ /^L\d+/);
$dont_set_cache = ($coord_system ne 'standard' ||
$abk =~ /^L\d+/);
TRYCACHE: {
if (defined $str_obj{$abk} && !$dont_use_cache) {
last TRYCACHE if ($abk eq 'l' and
(defined $str_cache_attr{'l'} and
$str_cache_attr{'l'} ne "$str_far_away{'l'}"));
last TRYCACHE if ($str_regions{'l'} && @{$str_regions{'l'}});
last TRYCACHE if !$str_obj{$abk}->is_current;
$str = $str_obj{$abk};
}
}
}
if (!defined $str) {
cache_decider_init();
# XXX use get_any_strassen_obj?
if ($abk eq 'w') {
$str = _get_wasser_obj($filename);
} elsif ($abk eq 'l') {
$str = _get_landstr_obj();
} elsif ($abk eq 'comm') {
$str = _get_comments_obj();
} else {
eval { $str = Strassen->new($filename); };
if ($@ && $filename_maybe) {
eval { $str = Strassen->new($filename_maybe); };
}
if ($@) {
if ($edit_mode || $edit_normal_mode) {
status_message(Mfmt("Beim Laden der Datei %s: %s", $filename, $@), "info");
return;
}
# Do not "die", may be in Progress mode
if (!$no_original_datadir) {
$str_draw{$abk} = 0;
status_message($@, "err");
}
return;
}
}
if ($abk ne 'w') { # XXX get_cache_identifier benutzen
if ((!$dont_set_cache && cache_decider()) ||
$abk =~ /^[sl]$/ ||
$edit_normal_mode # Always cache in edit mode to make "reload all" work
) {
# für nearest_line_points Caching erzwingen
$str_obj{$abk} = $str;
if ($abk eq 'l') {
$str_cache_attr{'l'} = "$str_far_away{'l'}";
# XXX str_regions?
}
}
}
}
if (!defined $str) {
status_message(M"Kein Objekt definiert!", "err");
return;
}
handle_global_directives($str, $abk);
# XXX obsolete:
if (defined $filename && -e "$filename.desc") {
require BBBikeAdvanced;
read_desc_file("$filename.desc", $abk);
}
if ($str_name_draw{$abk}) {
require Tk::RotFont;
}
my $lazy = defined $args{-lazy} ? $args{-lazy} : $lazy_plot;
if ($std && $lazy && $has_filename) {
return bbbikelazy_add_data("str", $abk, $str);
}
my $complete_str = $str;
my $diffed_str = 0;
my $indexmap;
if ($args{FastUpdate}) {
my($new_str, $todelref);
($new_str, $todelref, $indexmap) = $str->diff_orig(-clonefile => 1);
if (!defined $new_str) {
warn M("Diff-Ausgabe wird nicht verwendet"), "\n" if $verbose;
$c->delete($abk); # evtl. alte Koordinaten löschen
$c->delete("pp-$abk");
} else {
if ($verbose) {
warn M("Diff-Ausgabe wird verwendet"), "\n";
warn Mfmt("Anzahl der neu zu zeichnenden Straßen: %d", scalar @{$new_str->data}), "\n";
warn Mfmt("Anzahl der zu löschenden Straßen: %d", scalar @$todelref), "\n";
}
for my $id (@$todelref) {
for my $strdeladd ("", "-label") {
$c->delete("$abk$strdeladd-$id");
}
}
$str = $new_str;
$diffed_str = 1;
}
}
my($restrict, @restrict, $ignore, @ignore);
if (exists $str_restrict{$abk} ||
exists $str_ignore{$abk}) {
my $all_set = 1;
my($k,$v);
if (exists $str_restrict{$abk}) {
while(($k,$v) = each %{$str_restrict{$abk}}) {
if (!$v) {
$all_set = 0;
} else {
push @restrict, $k;
}
}
}
if (exists $str_ignore{$abk}) {
while(($k,$v) = each %{$str_ignore{$abk}}) {
if ($v) {
$all_set = 0;
push @ignore, $k;
}
}
}
if (exists $str_restrict{$abk}) {
if ($all_set || !@restrict) {
undef $restrict;
} else {
$restrict = '^(' . join('|', map { quotemeta $_ } @restrict) . ")\$";
}
}
if (exists $str_ignore{$abk}) {
$ignore = '^(' . join('|', map { quotemeta $_ } @ignore) . ")\$";
}
if ($] >= 5.005) {
eval q{
$restrict = qr/$restrict/
if defined $restrict;
$ignore = qr/$ignore/
if defined $ignore;
}; die $@ if $@;
}
}
my %category_color = %category_color;
if ($abk eq 'l') {
my($k,$v);
while(($k,$v) = each %category_color) {
if ($k =~ /^\d+$/ && $k != 0) {
$category_color{$k} = $category_color{0};
}
}
}
if ($abk =~ /^g(|[PD])$/ && !$std) {
$category_color{Z} = '#9e9e9e';
}
my %category_width; # XXX the global category_width is ignored!!! should be changed
my $default_width = get_line_width($abk) || 4;
if (defined $args{Width}) { $default_width = $args{Width} }
{
my $scale = (exists $args{Canvas}
? ($show_overview_mode eq 'brb'
? $small_scale
: $medium_scale)
: $scale);
foreach (keys %line_width) {
if (/^$abk-(.*)/) {
my $cat = $1;
$category_width{$cat} = get_line_width($_, $scale);
}
}
}
# current category size
my %category_size = map {
($_, $category_size{$_}* $label_font_size/10)
} keys %category_size;
my $no_overlap_label = (exists $args{NoOverlapLabel}
? $args{NoOverlapLabel} : $no_overlap_label{$abk});
my $coordsys = $coord_system_obj->coordsys;
my $use_stippleline = 0; # XXX Duplikat in BBBikeLazy
if (exists $line_dash{$abk}) {
if ($Tk::VERSION >= 800.016) {
$use_stippleline = 2; # new dash code
} else {
$use_stippleline = 1;
require Tk::StippleLine;
}
} else {
if ($Tk::VERSION >= 800.016) {
$use_stippleline = 3; # signal that -dash exists
}
}
destroy_delayed_restack();
IncBusy($top);
$progress->Init(-dependents => $c,
(defined $filename ? (-label => $filename) : ()),
);
eval {
# XXX Experiment
if ($orientation eq 'landscape' &&
!$edit_mode &&
#XXX? !$edit_normal_mode &&
!$str_name_draw{$abk} &&
!$str_nr_draw{$abk} &&
!exists $args{Canvas} &&
!$p_draw{'pp'} &&
($abk eq 'l' || $abk eq 's') &&
defined &BBBike::fast_plot_str) {
eval {
die if $str->isa("Strassen::Storable");
# Wenn outline nicht definiert ist, dann wird es
# eigenmächtig gesetzt. Die XS-Routine ist dafür schnell
# genug.
if (!defined $str_outline{$abk}) {
$str_outline{$abk} = 1;
}
my(@files) = $str->file;
if (grep { /\.gz$/ } @files) {
die "fast_plot_str can't handle gzipped files yet";
}
my(@args) = ($c, $abk,
(@files > 1 ? \@files : @files),
$progress);
if (@restrict) {
push @args, \@restrict;
} else {
push @args, undef;
}
push @args, \%category_width;
if (@ignore) {
push @args, \@restrict;
} else {
push @args, undef;
}
BBBike::fast_plot_str(@args);
};
my $err = $@;
if (!$err) {
goto PLOTSTR_CONT;
} else {
warn $err if $^W;
}
}
my $xadd_anchor = $xadd_anchor_type->{$abk};
my $yadd_anchor = $yadd_anchor_type->{$abk};
my $label_spaceadd = $label_spaceadd{$abk};
my $real_i = 0;
my $i;
my $anzahl_eindeutig = $str->count;
$str->init;
$escape = 0;
my @extra_tags = ($abk =~ /^L\d+/ ? ("$abk-s") : ());
my %conv_args;
if ($args{-map}) {
$conv_args{Map} = $args{-map};
}
my $conv = $str->get_conversion(%conv_args);
my $draw_sub = eval $plotstr_draw_sub;
string_eval_die($@, $plotstr_draw_sub) if $@; #die $@ if $@;
my $bench = Tk::Time_So_Far();
while (1) {
my $ret = $str->next;
last if !@{$ret->[Strassen::COORDS]};
if (!$diffed_str) {
if ($real_i % 80 == 0) {
$progress->Update($real_i/$anzahl_eindeutig);
# XXX Probleme mit diesem $top->update, falls
# ein anderer plot-Vorgang damit gestartet wird
#if ($progress) {
#$top->update; # für Escape
#if ($escape) {
# status_message("Zeichnen von <$filename> abgebrochen",
# "warn");
# last;
# }
#}
}
}
#last if $i > 100; # for Debugging XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
$i = $indexmap && exists $indexmap->{$real_i} ? $indexmap->{$real_i} : $real_i;
$draw_sub->($ret); # XXX evtl. den Code mit eval erzeugen
$real_i++;
}
# XXXXXX can this ever happen? XXXXXXXXXXXXXXXXXXXXXXXXXXX
# XXX Yes: If a bbd file contains a half-valid line (with name and cat, but without coords)
if ($str->pos != scalar @{$str->{Data}}) { status_message("warning: " . $str->pos . " != " . scalar(@{$str->{Data}}) . "!", "dialog", "err") }
#XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
warn sprintf "Plotting streets took %.3fs\n", Tk::Time_So_Far()-$bench
if $verbose;
PLOTSTR_CONT:
$c->itemconfigure('pp',
-capstyle => $capstyle_round,
-width => 5,
-fill => $pp_color,
);
if ($layer_active_color{$abk}) {
$c->itemconfigure($abk, -activefill => $layer_active_color{$abk});
}
if ($abk eq 'e' && defined $linestip) {
# XXX hacky: make sure that e-img do not get configured,
# so use 'e-Q' instead of just 'e'
$c->itemconfigure('e-Q', -stipple => '@' . $linestip);
}
if (!exists $args{Canvas} && !$no_make_net && !$edit_mode && !$edit_normal_mode) {
if (defined $net && !$net->is_source($str) && $abk =~ /^[sl]$/) {
make_net();
} elsif (!defined $net && $abk =~ /^[sl]$/) {
make_net();
}
}
if (($edit_mode || $edit_normal_mode || $abk eq 'relgps' || $args{FastUpdate})) { # XXX? and !$diffed_str) {
warn "Try to copy original data" if $verbose;
my $r = $complete_str->copy_orig;
warn "Returned $r" if $verbose;
}
if ($std) {
restack_delayed(); # XXX check!
}
if ($abk =~ /^L\d+/) {
std_str_binding($abk);
}
};
warn __LINE__ . ": $@" if ($@);
$progress->Finish;
DecBusy($top);
}
# Arguments:
# $c: canvas to draw onto
# $x, $y: canvas coordinates
# %args: options for createText, special options are:
# -outlinecolor: color of the outline, by default canvas background
# -outlinewidth: width of the outline, by default 1
### AutoLoad Sub
sub outline_text {
my($c, $x, $y, %args) = @_;
my $outline_color = delete $args{'-outlinecolor'} || $c->cget(-background);
my $fg = delete $args{'-fill'} || "black";
my $outline_width = delete $args{'-outlinewidth'} || 1;
my $tags = delete $args{'-tags'};
$tags = [$tags] if ref $tags ne 'ARRAY';
$outline_i++;
if (defined $outline_color && defined $outline_width) {
my @outlines;
foreach (1 .. $outline_width) {
push(@outlines, [-$_, 0], [$_, 0], [0, $_], [0, -$_]);
}
foreach (@outlines) {
$c->createText($x + $_->[0], $y + $_->[1],
-fill => $outline_color,
-tags => [@$tags, 'outlslave-'.$outline_i,
'outldata_'.join("_",@$_)],
%args);
}
}
$c->createText($x, $y,
-fill => $fg,
-tags => [@$tags, 'outlmaster', 'outlmaster-'.$outline_i,
"outlmaster-width-$outline_width"],
%args);
}
### AutoLoad Sub
sub plot_mount {
my $mount;
if ($str_draw{'mount'}) {
my $comm = Strassen->new(get_strassen_file("comments_mount"));
my $comm_mount = Strassen->new_copy_restricted($comm, -grep => ["St;"]);
$mount = MultiStrassen->new($str_file{"mount"},
$comm_mount);
}
plot('str','mount', -object => $mount);
}
# Zeichnet gesperrte Straßen und Einbahnstraßen.
# XXX gesperrte Wegführungen werden noch nicht gezeichnet
### AutoLoad Sub
sub plot_sperre {
my $file_or_object = shift;
my %args = @_;
my $abk = $args{-abk} || 'sperre';
Hooks::get_hooks("before_plot")->execute;
if (!$args{FastUpdate}) {
$c->delete($abk);
}
if (!$p_draw{$abk}) {
Hooks::get_hooks("after_plot")->execute; # XXX should not be here
return;
}
IncBusy($top);
eval {
my $gesperrt;
if (UNIVERSAL::isa($file_or_object, "Strassen")) {
$gesperrt = $file_or_object;
} else {
$gesperrt = new Strassen (defined $file_or_object
? $file_or_object
: get_strassen_file($sperre_file)
);
}
$p_obj{$abk} = $gesperrt;
my $is_car = $gesperrt->file =~ /gesperrt_car/;
my $car_photo;
if ($is_car) {
$car_photo = load_photo($top, 'car.' . $default_img_fmt, -persistent => 1);
}
my $width0 = get_line_width('sperre0');
my $width1 = get_line_width('sperre1');
my $width2 = get_line_width('sperre2');
my $width3 = get_line_width('sperre3');
my $length1 = get_line_length('sperre1');
my $length2 = get_line_length('sperre2');
my %type2cat =
(StrassenNetz::BLOCKED_ONEWAY() => "sperre1",
StrassenNetz::BLOCKED_ONEWAY_STRICT() => "sperre1s",
StrassenNetz::BLOCKED_COMPLETE() => "sperre2",
StrassenNetz::BLOCKED_CARRY() => "sperre0",
);
my %type2fill =
(StrassenNetz::BLOCKED_ONEWAY() =>
($width1 && $length1 ? $category_color{'sperre1'} : undef),
StrassenNetz::BLOCKED_ONEWAY_STRICT() =>
($width1 && $length1 ? $category_color{'sperre1s'} : undef),
);
my $fill2 = ($width2 && $length2 ? $category_color{'sperre2'} : undef);
# korrigieren, damit beim Vergrößern etwas erscheint
$length1 = ($length1 ? $length1 : 1);
$length2 = ($length2 ? $length2 : 1);
# XXX don't duplicate code from plotstr!
my $diffed_str = 0;
my $str = $gesperrt;
my $complete_str = $str;
my $indexmap;
#XXX Abfrage auf $edit_mode notwendig?
if (#XXX del: ($edit_mode || $edit_normal_mode) &&
$args{FastUpdate}) {
my($new_str, $todelref);
($new_str, $todelref, $indexmap) = $str->diff_orig(-clonefile => 1);
if (!defined $new_str) {
warn M("Diff-Ausgabe wird nicht verwendet") if $verbose;
$c->delete($abk); # evtl. alte Koordinaten löschen
$c->delete("pp-$abk");
} else {
if ($verbose) {
warn M("Diff-Ausgabe wird verwendet"), "\n";
warn Mfmt("Anzahl der neu zu zeichnenden Objekte: %d", scalar @{$new_str->data}), "\n";
warn Mfmt("Anzahl der zu löschenden Objekte: %d", scalar @$todelref), "\n";
}
foreach (@$todelref) {
$c->delete("$abk-$_");
}
$str = $new_str;
$diffed_str = 1;
$gesperrt = $str;
}
}
$gesperrt->init;
my $real_pos = -1;
while (1) {
$real_pos++;
my $pos = $indexmap && exists $indexmap->{$real_pos} ? $indexmap->{$real_pos} : $real_pos;
my $ret = $gesperrt->next;
my @kreuzungen = @{$ret->[Strassen::COORDS]};
last if !@kreuzungen;
my($icon_x, $icon_y, $icon_anchor);
my $sub_cat;
my($cat,@addinfo) = split ':', $ret->[Strassen::CAT];
if ($cat eq StrassenNetz::BLOCKED_CARRY) {
if ($width0) { # größer 0
$sub_cat = 'sperre0';
my($x,$y) =
transpose(@{Strassen::to_koord1($kreuzungen[0])});
my $rad = deg2rad($addinfo[1] || 0); # addinfo[1] is angle
my $cos4 = cos($rad)*4;
my $sin4 = sin($rad)*4;
for my $add ([-$cos4,$sin4], [0,0], [$cos4,-$sin4]) {
my($yadd,$xadd) = @$add;
$c->createLine
($x-$cos4+$xadd, ($y+$yadd)-$sin4, $x+$cos4+$xadd, ($y+$yadd)+$sin4,
-width => $width0, # XXX $width0 verwenden und in get_line_width anpassen
-tags => [$abk, $sub_cat,
$ret->[Strassen::NAME], $abk.'-'.$pos],
);
}
($icon_x, $icon_y, $icon_anchor) = ($x, $y, 'n');
}
} elsif ($cat eq StrassenNetz::BLOCKED_NARROWPASSAGE) {
#XXX works, but write nicer...
# if ($widthBNP) XXX
$sub_cat = 'sperreBNP';
my($x,$y) =
transpose(@{Strassen::to_koord1($kreuzungen[0])});
my $rad = deg2rad($addinfo[1] || 0); # addinfo[1] is angle
my $cos1 = cos($rad);
my $sin1 = sin($rad);
my $cos4 = cos($rad)*4;
my $sin4 = sin($rad)*4;
for my $add ([-$cos1,$sin1]) {
my($yadd,$xadd) = @$add;
$c->createLine
($x-$cos1+$xadd, ($y+$yadd)-$sin1, $x+$cos4+$xadd, ($y+$yadd)+$sin4,
-width => $width0, # XXX $widthBNP verwenden und in get_line_width anpassen
-tags => [$abk, $sub_cat,
$ret->[Strassen::NAME], $abk.'-'.$pos],
);
}
for my $add ([$cos1,-$sin1]) {
my($yadd,$xadd) = @$add;
$c->createLine
($x-$cos4+$xadd, ($y+$yadd)-$sin4, $x+$cos1+$xadd, ($y+$yadd)+$sin1,
-width => $width0, # XXX $widthBNP verwenden und in get_line_width anpassen
-tags => [$abk, $sub_cat,
$ret->[Strassen::NAME], $abk.'-'.$pos],
);
}
($icon_x, $icon_y, $icon_anchor) = ($x, $y, 'n');
} elsif ($cat =~ /^@{[ StrassenNetz::BLOCKED_ROUTE ]}(nocross)?/) {
my $is_nocross = defined $1;
$sub_cat = 'sperre3';
my @c;
for(my $i = 0; $i <= $#kreuzungen; $i++) {
push @c, map { transpose(@$_) } Strassen::to_koord1($kreuzungen[$i]);
}
line_shorten(\@c);
if (!$is_nocross) {
# move to the right
my $delta = -3;
for(my $i = 2; $i < $#c; $i+=2) {
# atan2(y2-y1, x2-x1)
my $alpha = atan2($c[$i+1]-$c[$i-1], $c[$i]-$c[$i-2]);
my $beta = $alpha - pi()/2;
my($dx, $dy) = ($delta*cos($beta), $delta*sin($beta));
$c[$i] += $dx;
$c[$i+1] += $dy;
if ($i == 2) {
$c[0] += $dx;
$c[1] += $dy;
}
}
}
$c->createLine
(@c,
-width => $width3,
(!$is_nocross ? (-arrow => 'last',
-arrowshape => [4,6,3],
-smooth => 1,
-fill => 'red',
)
: (-fill => 'orange',
)
),
($Tk::VERSION >= 800.016 ? (-dash => $line_dash{sperre3}) : ()),
-tags => [$abk, $sub_cat,
$ret->[Strassen::NAME], $abk.'-'.$pos],
);
($icon_x, $icon_y, $icon_anchor) = ($c[0], $c[1], 'n');
} else {
$sub_cat = $type2cat{$cat};
if ($cat eq StrassenNetz::BLOCKED_COMPLETE && $#kreuzungen == 0) {
# ein bisschen schummeln ...
push @kreuzungen, $kreuzungen[0];
}
for my $i (0 .. $#kreuzungen - 1) {
my($x1,$y1) =
transpose(@{Strassen::to_koord1($kreuzungen[$i])});
my($x2,$y2) =
transpose(@{Strassen::to_koord1($kreuzungen[$i+1])});
my($xm,$ym) = (int(($x2-$x1)/2+$x1), int(($y2-$y1)/2+$y1));
if ($cat eq StrassenNetz::BLOCKED_ONEWAY ||
$cat eq StrassenNetz::BLOCKED_ONEWAY_STRICT) {
my $alpha = atan2($y2-$y1, $x2-$x1);
my($xd,$yd) = ($length1*cos($alpha),
$length1*sin($alpha));
$c->createLine($xm+$xd, $ym+$yd, $xm-$xd, $ym-$yd,
-fill => $type2fill{$cat},
-width => $width1,
-arrow => 'last',
-arrowshape => [4,6,3],
-tags => [$abk, $sub_cat,
$ret->[Strassen::NAME], $abk.'-'.$pos],
);
} elsif ($cat eq StrassenNetz::BLOCKED_COMPLETE) {
# $c->createImage($xm,$ym,
# -image => $blocked_photo,
# -tags => [$abk, 'sperre2',
# $ret->[Strassen::NAME], $abk.'-'.$pos]);
$c->createLine($xm-$length2, $ym-$length2,
$xm+$length2, $ym+$length2,
-fill => $fill2,
-width => $width2,
-tags => [$abk, $sub_cat,
$ret->[Strassen::NAME], $abk.'-'.$pos]);
$c->createLine($xm-$length2, $ym+$length2,
$xm+$length2, $ym-$length2,
-fill => $fill2,
-width => $width2,
-tags => [$abk, $sub_cat,
$ret->[Strassen::NAME], $abk.'-'.$pos]);
}
if (defined $addinfo[0] && $addinfo[0] =~ /\binwork\b/ && $inwork_photo) {
$c->createImage($xm,$ym,
-anchor => "nw",
-image => $inwork_photo,
-tags => [$abk,$sub_cat,$ret->[Strassen::NAME], $abk.'-'.$pos]);
}
if ($is_car && $car_photo) {
$c->createImage($xm, $ym,
-image => $car_photo,
-anchor => "sw",
-tags => [$abk, $sub_cat,$ret->[Strassen::NAME], $abk.'-'.$pos]);
}
}
}
if ($is_car && $car_photo && defined $icon_x) {
$c->createImage($icon_x, $icon_y,
-image => $car_photo,
-anchor => $icon_anchor,
-tags => [$abk, $sub_cat,$ret->[Strassen::NAME], $abk.'-'.$pos]);
}
}
if (($edit_mode || $edit_normal_mode || $args{FastUpdate}) and !$diffed_str) {
warn "Try to copy original data" if $verbose;
my $r = $complete_str->copy_orig;
warn "Returned $r" if $verbose;
}
};
warn $@ if $@;
DecBusy($top);
Hooks::get_hooks("after_plot")->execute;
}
sub line_shorten {
my($cref) = @_;
if (@$cref > 4) { # else should never happen
my $len1 = Strassen::Util::strecke([@{$cref}[0,1]], [@{$cref}[2,3]]);
my $whole_len1 = $len1 > 20 ? 20 : $len1;
my $len2 = Strassen::Util::strecke([@{$cref}[-4,-3]], [@{$cref}[-2,-1]]);
my $whole_len2 = $len2 > 20 ? 20 : $len2;
@{$cref}[0,1, -2,-1] =
(($cref->[0]-$cref->[2])/$len1*$whole_len1+$cref->[2],
($cref->[1]-$cref->[3])/$len1*$whole_len1+$cref->[3],
($cref->[-2]-$cref->[-4])/$len2*$whole_len2+$cref->[-4],
($cref->[-1]-$cref->[-3])/$len2*$whole_len2+$cref->[-3],
);
}
}
sub activate_temp_blockings {
my $do_show_active_temp_blockings = shift;
my(%args) = @_;
my $now = $args{-now} || time;
my $from = $args{-from};
# XXX these should come from a file as constants
my $temp_blockings_dir = "$FindBin::RealBin/data/temp_blockings"; # XXX was misc
my $file = "$temp_blockings_dir/bbbike-temp-blockings.pl";
if (!-r $file) {
status_message(M("Kein Support fuer temporaere Sperrungen, das Verzeichnis $temp_blockings_dir fehlt. Dieses Verzeichnis ist aus dem CVS erhältlich, siehe README."), "warn");
return;
}
if (!$do_show_active_temp_blockings) {
$show_active_temp_blockings = 0;
plot("p", "temp_sperre", -draw => 0);
plot("str", "temp_sperre_s", -draw => 0);
make_net(); # XXX find more performant solution
undef $temporary_handicap_s;
if ($handicap_s_net) {
undef $handicap_s_net;
make_handicap_net();
}
return;
}
eval {
use vars qw(@temp_blocking); # XXX do not use a global such as this
@temp_blocking = ();
do $file; # XXX Safe?
my @s;
for my $o (@temp_blocking) {
next if !$o; # undefined entry
my $do_it = 0;
if (defined $from && (!defined $o->{until} || $o->{until} > $from)) {
$do_it = 1;
}
if (!$do_it && ((!defined $o->{from} || $o->{from} < $now) &&
(!defined $o->{until} || $o->{until} > $now))) {
$do_it = 1;
}
if ($do_it) {
require POSIX;
my $datefmt = "%d.%m.%Y %H:%M:%S";
my $from_date_readable = defined $o->{from} ? POSIX::strftime($datefmt, localtime($o->{from})) : "...";
my $to_date_readable = defined $o->{until} ? POSIX::strftime($datefmt, localtime($o->{until})) : "...";
my $text = $o->{text} . " [" . $from_date_readable . " - " . $to_date_readable . "]";
my $s;
my $f;
if ($o->{file}) {
$f = "$temp_blockings_dir/$o->{file}";
$s = Strassen->new($f);
} else {
$s = Strassen->new_from_data_string($o->{data});
}
my $new_s = Strassen->new;
push @{$new_s->{DependentFiles}}, $f if $f;
$s->init;
while(1) {
my $ret = $s->next;
last if !@{ $ret->[Strassen::COORDS()] };
$ret->[Strassen::NAME] = $text;
$new_s->push($ret);
}
push @s, $new_s;
}
}
if (!@s) {
if ($verbose) {
if (defined $args{-now}) {
warn "Keine temporären Sperrungen am " . scalar(localtime($now)) . "\n";
} else {
warn "Keine aktiven temporären Sperrungen\n";
}
}
return;
}
my $ms = MultiStrassen->new(@s);
warn "Aktive temporäre Sperrungen: " . join(", ", $ms->dependent_files) . "\n" if $verbose;
make_net() if !$net;
$net->make_sperre($ms, Type => "all");
$temporary_handicap_s = Strassen->new_copy_restricted($ms, -callback => sub { $_[0]->[Strassen::CAT] =~ /^q\d/ });
require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$temporary_handicap_s],[])->Indent(1)->Useqq(1)->Dump; # XXX
if ($handicap_s_net) {
undef $handicap_s_net;
make_handicap_net();
}
plot("p", "temp_sperre", -object => $ms, -draw => 1);
plot("str", "temp_sperre_s", -object => $ms, -draw => 1);
};
if ($@) {
$show_active_temp_blockings = 0;
status_message($@, "warn"); # do not die, may be called before mainloop
} else {
$show_active_temp_blockings = 1;
}
}
### AutoLoad Sub
sub read_sperre_tragen {
my($force) = @_;
return if (!$force && keys %sperre_tragen != 0);
%sperre_tragen = ();
if (!eval {
my $s = new Strassen get_strassen_file($sperre_file);
$s->init;
while(1) {
my $r = $s->next;
last if !@{ $r->[Strassen::COORDS] };
my($cat,@addinfo) = split /:/, $r->[Strassen::CAT];
if ($cat eq StrassenNetz::BLOCKED_CARRY &&
defined $addinfo[0] && $addinfo[0] ne '') {
$sperre_tragen{$r->[Strassen::COORDS][0]} = $addinfo[0];
} elsif ($cat eq StrassenNetz::BLOCKED_NARROWPASSAGE &&
defined $addinfo[0] && $addinfo[0] ne '') {
$sperre_narrowpassage{$r->[Strassen::COORDS][0]} = $addinfo[0];
}
}
1;
}) {
warn $@;
}
}
# Liest aus der Datenbasis die Ampelinformation ein.
### AutoLoad Sub
sub read_ampeln {
my($force) = @_;
return if (!$force && keys %ampeln != 0);
if (!eval {
$p_obj{'lsa'} = new Strassen get_strassen_file($p_file{'lsa'});
%ampeln = %{ $p_obj{'lsa'}->get_hashref_by_cat };
1;
}) {
warn $@;
%ampeln = ();
}
}
# Liest aus der Datenbasis die Höheninformation ein.
### AutoLoad Sub
sub read_hoehe {
my(%args) = @_;
return if (!$args{-force} && keys %hoehe != 0 &&
$p_obj{"hoehe"} && $p_obj{"hoehe"}->is_current);
if (!eval {
my $h = new Strassen ($args{-file}
? $args{-file}
: get_strassen_file("hoehe")
);
%hoehe = %{ $h->get_hashref };
$p_obj{"hoehe"} = $h;
1;
}) {
warn $@;
%hoehe = ();
}
}
# Zeichnet die Höhendaten.
### AutoLoad Sub
sub plot_hoehe {
my(%args) = @_;
Hooks::get_hooks("before_plot")->execute;
$c->delete('hoehe');
if ($p_draw{'hoehe'}) {
my $coordsys = $coord_system_obj->coordsys;
IncBusy($top);
eval {
read_hoehe(%args);
while(my($koord,$hoehe) = each %hoehe) {
my($xx,$yy) = split(/,/, $koord);
if ($edit_mode && $xx =~ /([A-Za-z])?(-?\d+)$/) {
my $this_coordsys = (defined $1 ? $1 : '');
if ($this_coordsys eq $coordsys ||
!($this_coordsys ne '' || $coordsys ne 'B')) {
$xx = $2;
} else {
next; # while
}
}
my($x, $y) = transpose($xx, $yy);
$c->createLine($x, $y, $x+1, $y+1,
-fill => 'red',
-tags => 'hoehe',
);
$c->createText($x+1, $y+1, -anchor => 'nw',
-font => $font{'small'},
-text => $hoehe,
-tags => 'hoehe',
);
}
};
warn __LINE__ . ": $@" if $@;
DecBusy($top);
}
Hooks::get_hooks("after_plot")->execute;
}
# XXX Folgende drei Funktionen zusammenfassen
# Gibt ein Gewässer-Objekt zurück.
### AutoLoad Sub
sub _get_wasser_obj {
my $filename = shift;
my @obj;
if ($wasserstadt) {
push @obj, Strassen->new($filename);
}
if ($wasserumland) {
push @obj, Strassen->new(get_strassen_file("wasserumland"));
}
if ($str_far_away{'w'}) {
push @obj, Strassen->new(get_strassen_file("wasserumland2"));
}
return if !@obj;
return $obj[0] if (@obj == 1);
new MultiStrassen @obj;
}
# Gibt ein Orte-Objekt zurück.
### AutoLoad Sub
sub _get_orte_obj {
my $type = shift || "o";
my $fname = ($type eq 'oo' ? 'orte_city' : 'orte');
my @obj;
push @obj, new Strassen get_strassen_file($fname);
if ($p_far_away{$type}) {
push @obj, new Strassen get_strassen_file($fname . "2");
}
return $obj[0] if (@obj == 1);
new MultiStrassen @obj;
}
# Gibt ein Landstraßen-Objekt zurück.
### AutoLoad Sub
sub _get_landstr_obj {
my @obj;
push @obj, new Strassen get_strassen_file($str_file{'l'});
if ($str_far_away{'l'}) {
my $file = "landstrassen2";
push @obj, new Strassen get_strassen_file($file);
}
if ($str_regions{'l'}) {
foreach my $file (@{ $str_regions{'l'} }) {
push @obj, new Strassen get_strassen_file($file);
}
}
return $obj[0] if (@obj == 1);
new MultiStrassen @obj;
}
# Gibt ein Kommentar-Objekt zurück.
### AutoLoad Sub
sub _get_comments_obj {
my @objs;
for my $type (@comments_types) {
next if $type eq "mount";
eval {
my $f = get_strassen_file("comments_$type");
push @objs, Strassen->new($f);
}; warn $@ if $@;
}
MultiStrassen->new(@objs);
}
# Zeichnet Punkte auf dem Canvas.
# plotp ist nur ein Dispatcher.
### AutoLoad Sub
sub plotp {
my($abk, %args) = @_;
return if $abk =~ /^pp/; # wird in plotstr gezeichnet
return if !$c;
if ($abk eq 'p') {
require BBBikeAdvanced;
ploths();
} elsif ($abk eq 'o') {
plotorte(Shortname => 1, %args);
} elsif ($abk eq 'obst') {
plotobst();
} elsif ($abk eq 'hoehe') {
plot_hoehe();
} else {
plot_point($abk, %args);
}
}
# Zeichent ein Punktsymbol, z.B. ein U-Bahn-Zeichen
### AutoLoad Sub
sub plot_symbol {
my($c, $abk, %args) = @_;
my $tag_bg = $args{'-tag_bg'} || "$abk-bg";
my $tag_fg = $args{'-tag_fg'} || "$abk-fg";
if ($abk eq 'b' || $abk eq 'r') {
my %arg = get_symbol_scale('b');
$c->itemconfigure
($tag_bg, -fill => ($abk eq 'b' ? $category_color{"SC"} : $category_color{"R"}), -capstyle => $capstyle_round,
-width => $arg{-width});
$c->itemconfigure
($tag_fg, -anchor => 'c', -fill => 'white',
-text => (defined $arg{-font}
? ($abk eq 'b' ? 'S' : 'R') : ''),
(defined $arg{-font} ? (-font => $arg{-font}) : ()),
);
} elsif ($abk eq 'u') {
my %arg = get_symbol_scale('u');
$c->itemconfigure($tag_bg, -fill => $category_color{'U'},
-width => $arg{-width});
$c->itemconfigure
($tag_fg, -anchor => 'c', -fill => 'white',
-text => (defined $arg{-font} ? 'U' : ''),
(defined $arg{-font} ? (-font => $arg{-font}) : ()),
);
} elsif ($abk =~ /^L\d+/) {
eval {
$c->itemconfigure($tag_fg,
-capstyle => $capstyle_round,
);
}; warn $@ if $@;
} elsif ($abk eq 'pl') {
$c->itemconfigure($tag_fg, -fill => 'red', -capstyle => 'projecting',
-width => 8);
} elsif ($abk eq 'vf') {
$c->itemconfigure($tag_fg, -image => get_symbol_scale($abk));
$c->itemconfigure($tag_bg, -fill => 'black',
-width => 3); # XXX width skalierbar machen
} elsif ($abk =~ /^(kn|rest)$/) {
$c->itemconfigure($tag_fg, -image => get_symbol_scale($abk));
} elsif ($abk eq 'ki') {
$c->itemconfigure($tag_fg, -image => $kino_klein_photo);
}
}
# Zeichnen von Punkten. Hiermit werden U-/S-/R-Bahnhöfe, Ampeln und alle
# sonstigen Punkte gezeichnet.
# Arguments:
# $abk: layer token
# -filename => $filename (Alias: Filename => $filename)
# NameDraw => $boolean
### AutoLoad Sub
sub plot_point {
my($abk, %args) = @_;
status_message("");
# Tags löschen
my @del_tags = ("$abk-bg", "$abk-img", "$abk-fg", "$abk-label");
if (!$args{FastUpdate}) {
$c->delete($_) for (@del_tags);
}
my($ampel_photo, $ampelf_photo, $andreaskr_photo);
if ($abk eq 'lsa') {
undef %ampeln;
$ampel_photo = get_symbol_scale('lsa-X');
$ampelf_photo = get_symbol_scale('lsa-F');
$andreaskr_photo = get_symbol_scale('lsa-B');
$zugbruecke_photo = get_symbol_scale('lsa-Zbr');
$c->delete('lsas'); # Ampelschaltung-Symbole löschen
$c->delete('lsas-t'); # Ampelschaltung-Symbole löschen
}
if (!$p_draw{$abk}) {
if ($main::lazy_p{$abk}) {
bbbikelazy_remove_data("p", $abk);
}
return;
}
my $filename = $args{-filename} || $args{Filename};
my $filename_maybe;
if (!defined $filename) {
$filename = get_strassen_file($p_file{$abk});
$filename_maybe = $p_file{$abk} if $edit_mode_flag;
}
if (!defined $filename) {
status_message("Filename is not defined", 'err');
return;
}
my $lazy = defined $args{-lazy} ? $args{-lazy} : $lazy_plot;
if ($lazy && !$args{FastUpdate}) {
return bbbikelazy_add_data("p", $abk, $filename);
}
# XXX $ignore code fehlt noch...
my $restrict;
if (exists $str_restrict{$abk}) {
my $all_set = 1;
my($k,$v);
my @restrict;
while(($k,$v) = each %{$str_restrict{$abk}}) {
if (!$v) {
$all_set = 0;
} else {
$k =~ s/([?*])/\\$1/g; # quote special, XXX mehr davon bei Bedarf
push @restrict, $k;
}
}
if ($all_set || !@restrict) {
undef $restrict;
} else {
$restrict = '^(' . join('|', @restrict) . ")\$";
}
}
my $default_width;
if (defined $args{Width}) { $default_width = $args{Width} }
my $coordsys = $coord_system_obj->coordsys;
destroy_delayed_restack();
IncBusy($top);
$progress->Init(-dependents => $c,
(defined $filename ? (-label => $filename) : ()),
);
eval {
my $bhf;
if ($args{FastUpdate} ||
(defined $p_obj{$abk} &&
$p_obj{$abk}->is_current &&
$coord_system eq 'standard' &&
$abk !~ /^L\d+/)
) {
$bhf = $p_obj{$abk};
} else {
cache_decider_init();
eval {
$bhf = new Strassen $filename;
};
if ($@ && $filename_maybe) {
eval {
$bhf = Strassen->new($filename_maybe);
};
}
if ($@) {
$p_draw{$abk} = 0;
die "OK" if ($abk eq 'r' && $coord_system ne 'standard');
die "no-original-datadir" if $no_original_datadir;
die $@;
}
if (($coord_system eq 'standard' &&
(cache_decider() || $abk =~ /^L\d+/ || $abk eq 'kn') # 'L...' und 'kn' wegen Info
) ||
$edit_normal_mode # Always cache in edit mode to make "reload all" work
) {
$p_obj{$abk} = $bhf;
}
}
handle_global_directives($bhf, $abk);
# XXX obsolete:
if (-e "$filename.desc") {
require BBBikeAdvanced;
read_desc_file("$filename.desc", $abk);
}
my $complete_str = $bhf;
my $diffed_str = 0;
my $indexmap;
if ($args{FastUpdate}) {
my($new_str, $todelref);
($new_str, $todelref, $indexmap) = $bhf->diff_orig(-clonefile => 1);
if (!defined $new_str) {
warn M("Diff-Ausgabe wird nicht verwendet") if $verbose;
$c->delete($_) for (@del_tags);
} else {
if ($verbose) {
warn M("Diff-Ausgabe wird verwendet"), "\n";
warn Mfmt("Anzahl der neu zu zeichnenden Punkte: %d", scalar @{$new_str->data}), "\n";
warn Mfmt("Anzahl der zu löschenden Punkte: %d", scalar @$todelref), "\n";
}
foreach my $id (@$todelref) {
for my $ptagadd ("") { # XXX what's necessary of the following?, "-fg", "-bg", "-img", "-label") {
$c->delete("$abk$ptagadd-$id");
}
}
$bhf = $new_str;
$diffed_str = 1;
}
}
# XXX Experiment!!!
if ($orientation eq 'landscape' &&
!$edit_mode &&
#XXX? !$edit_normal_mode &&
$abk eq 'lsa' &&
!$diffed_str &&
defined &BBBike::fast_plot_point) {
eval {
die if $bhf->isa("Strassen::Storable");
my(@files) = $bhf->file;
if (grep { /\.gz$/ } @files) {
die "fast_plot_point can't handle gzipped files yet";
}
my(@args) = ($c, $abk,
(@files > 1 ? \@files : @files),
$progress);
BBBike::fast_plot_point(@args);
};
my $err = $@;
if (!$err) {
%ampeln = %{ $bhf->get_hashref_by_cat };
goto PLOTPOINT_CONT;
} else {
warn $err if $^W;
}
}
my $real_i = 0;
my $i;
my $anzahl_eindeutig = $bhf->count;
$bhf->init;
# XXX Duplikat in BBBikeLazy:
my $ubahn_length = ($abk eq 'u'
? do { my(%a) = get_symbol_scale('u');
$a{-width}/2 }
: 0);
my $name_draw = (exists $args{NameDraw}
? $args{NameDraw} : $p_name_draw{$abk});
my $name_draw_tag = "$abk-label";
my $name_draw_other = ($name_draw_tag =~ /^[ubr]-label$/
? [qw(u-label b-label r-label)]
: $name_draw_tag);
my $no_overlap_label = (exists $args{NoOverlapLabel}
? $args{NoOverlapLabel} : $no_overlap_label{$abk});
my $xadd_anchor = $xadd_anchor_type->{'u'};
my $yadd_anchor = $yadd_anchor_type->{'u'};
my $label_spaceadd = $label_spaceadd{'u'};
my %conv_args;
if ($args{-map}) {
$conv_args{Map} = $args{-map};
}
my $conv = $bhf->get_conversion(%conv_args);
my $draw_sub = eval $plotpoint_draw_sub;
string_eval_die($@, $plotpoint_draw_sub) if $@; #die $@ if $@;
while(1) {
my $ret = $bhf->next;
last if !@{$ret->[Strassen::COORDS]};
$progress->Update($real_i/$anzahl_eindeutig) if $real_i % 80 == 0;
$i = $indexmap && exists $indexmap->{$real_i} ? $indexmap->{$real_i} : $real_i;
$draw_sub->($ret);
$real_i++;
}
plot_symbol($c, $abk);
PLOTPOINT_CONT:
if (($edit_mode || $edit_normal_mode || $abk eq 'relgps' || $args{FastUpdate})) { # XXX? and !$diffed_str) {
warn "Try to copy original data" if $verbose;
my $r = $complete_str->copy_orig;
warn "Returned $r" if $verbose;
}
restack_delayed(); # XXX check!
};
if ($@) {
if ($@ =~ /^no-original-datadir/) {
# silently ignore
} elsif ($@ !~ /^OK/) {
status_message($@, ($edit_mode || $edit_normal_mode ? 'info-stack-trace' : 'err'));
}
}
$progress->Finish;
DecBusy($top);
}
# Gibt einen eindeutigen Bezeichner für das Caching der Orts/Straßenlisten
# zurück.
### AutoLoad Sub
sub get_cache_identifier {
my($linetype, $type) = @_;
if ($linetype eq 'p') {
my $fa = $p_far_away{$type} || '';
$fa;
} elsif ($linetype eq 's' || $linetype eq 'str') { # XXX 'str' is probably wrong...
my $fa = $str_far_away{$type} || '';
# XXX str_regions?
my $ret = $fa;
if ($type eq 'w') {
$ret .= "-$wasserstadt-$wasserumland";
}
$ret;
} else {
die "Unknown linetype: $linetype";
}
}
# Dialog zum Auswählen einer Straße oder eines Ortes.
### AutoLoad Sub
sub choose_ort {
my($linetype, $type, %args) = @_;
my $data = $args{-data};
my $nodraw = $args{-nodraw};
my $ondestroy = $args{-ondestroy};
my $additionalframe = $args{-additionalframe};
my $sorted = exists $args{-unsorted} ? !$args{-unsorted} : 1;
my $splitter = $args{-splitter};
my $container = $args{-container};
my $do_popup = exists $args{-popup} ? $args{-popup} : 1;
unless ($nodraw) {
if ($linetype =~ /^s/) {
if (!$str_draw{$type}) {
$str_draw{$type} = 1;
plot('str',$type);
}
} elsif ($linetype =~ /^p/) {
if (!$p_draw{$type}) {
$p_draw{$type} = 1;
plot('p',$type);
}
} else {
die "Unknown linetype: $linetype";
}
}
my $action = (exists $args{'-action'}
? $args{'-action'}
: ($linetype =~ /^s/
? \&mark_street
: ($linetype =~ /^p/
? \&mark_point
: die "Unknown linetype: $linetype"
)
)
);
if (!$args{-rebuild}) {
if (!defined $choose_ort_cache{"$linetype-$type"} or
get_cache_identifier($linetype, $type)
ne $choose_ort_cache{"$linetype-$type"}) {
$args{-rebuild} = 1;
}
}
if (!$toplevel{"chooseort-$type-$linetype"} or
!Tk::Exists($toplevel{"chooseort-$type-$linetype"}) or
$args{'-rebuild'} or
$container) {
if (defined $toplevel{"chooseort-$type-$linetype"} and
Tk::Exists($toplevel{"chooseort-$type-$linetype"})) {
$toplevel{"chooseort-$type-$linetype"}->destroy;
delete $toplevel{"chooseort-$type-$linetype"};
}
my $Listbox = "Listbox";
if ($splitter) {
$Listbox = "HList";
} else {
if ($sorted) {
if (!defined $K2Listbox) {
TRYLISTBOX: {
foreach my $try (qw(K2Listbox KListbox WListbox)) {
if (eval q{ require Tk::} . $try . q{; 1;} && !$@) {
$K2Listbox = $Listbox = $try;
last TRYLISTBOX;
} else {
warn "Can't use module Tk::$try: $@";
}
}
}
} else {
$Listbox = $K2Listbox;
}
}
}
my $attrib = ($linetype eq 's'
? $str_attrib{$type}
: $p_attrib{$type});
IncBusy($top);
my $t;
eval {
if ($container) {
$t = $container;
} else {
$t = $top->Toplevel(-title => $attrib->[ATTRIB_PLURAL],
-class => "Bbbike Chooser");
set_as_toolwindow($t);
if ($coord_system eq 'standard') {
if ($ondestroy) {
$t->protocol('WM_DELETE_WINDOW', [$ondestroy, $t]);
} else {
$t->protocol('WM_DELETE_WINDOW', sub { $t->withdraw });
}
$toplevel{"chooseort-$type-$linetype"} = $t;
}
}
my($showb, $closeb);
my $f = $t->Frame->pack(-side => "bottom"); # Button-Frame
if ($args{'-completelistbutton'}) {
my $ff = $t->Frame->pack(-side => "bottom");
my $label = $args{'completelistbuttonlabel'} || M"Komplette Liste";
$ff->Button(-text => $label,
-command => $args{'-completelistbutton'},
)->pack;
}
if ($additionalframe) {
my $ff = $f->Frame->pack(-fill => "both");
$additionalframe->($t, $ff);
}
my $markf;
if ($args{'-markstartifactive'}) {
if (($linetype eq 's' && $type =~ /^[sl]$/ &&
$net_type eq 's') ||
($linetype eq 'p' && $type =~ /^[ub]$/ &&
$net_type eq 'us') ||
($linetype eq 'p' && $type =~ /^[ubr]$/ &&
$net_type eq 'rus') ||
($linetype eq 'p' && $type eq 'r' &&
$net_type eq 'r') ||
($linetype eq 's' && $type =~ /^wr/ &&
$net_type eq 'wr')
) {
$args{-markstart} = 1;
}
}
if ($args{'-markstart'}) {
$markf = $t->Frame->pack(-side => "bottom");
}
my $lb;
my $max_cols;
if ($Listbox =~ /K.*Listbox/ && $Tk::VERSION >= 800) {
my $c = $t->Canvas(-takefocus => 0)->pack;
my $x = 1;
for ('A'..'Z') {
$c->createText($x, 1,
-text => $_,
-font => $font{'small'},
-anchor => 'nw',
-tags => $_,
-fill => 'black',
);
$x += $t->fontMeasure($font{'small'}, $_);
}
my $asc = $t->fontMetrics($font{'small'}, '-ascent');
my $des = $t->fontMetrics($font{'small'}, '-descent');
$c->GeometryRequest($x, $asc+$des+2);
$c->bind('all', '<ButtonPress-1>' => sub {
my(@c) = $c->gettags('current');
$lb->Goto($c[0]);
});
$c->bind('all', '<Enter>' => sub {
$c->itemconfigure('current', -fill => 'red');
});
$c->bind('all', '<Leave>' => sub {
$c->itemconfigure('current', -fill => 'black');
});
}
my %orte;
my @orte;
my $object;
if ($type eq 'p') {
my @haltestellen;
require Fahrinfo;
my $hs = tie @haltestellen, 'Fahrinfo::Haltestellen';
for my $i (0 .. $hs->{'anzahl_namen'}-1) {
$orte{$hs->FETCH($i)} = $hs->get_eind_index($i);
}
} elsif ($linetype =~ /^p/) {
if ($data) {
$object = $data;
} elsif (defined $p_obj{$type} && $coord_system eq 'standard') {
$object = $p_obj{$type};
} else {
cache_decider_init();
if ($type eq 'o') {
$object = _get_orte_obj("o");
} else {
$object = get_strassen_obj($p_file{$type});
}
if ($coord_system eq 'standard' && cache_decider()) {
$p_obj{$type} = $object;
}
}
my $i = 0;
$object->init;
while(1) {
my $ret = $object->next;
last if @{$ret->[Strassen::COORDS]} == 0;
my $strname = $ret->[Strassen::NAME];
$orte{$strname} = $i;
$i++;
}
} elsif ($linetype =~ /^s/) {
if ($data) {
$object = $data;
} elsif (defined $str_obj{$type} && $coord_system eq 'standard') {
$object = $str_obj{$type};
} else {
cache_decider_init();
$object = get_any_strassen_obj("str", $type);
if ($coord_system eq 'standard' && cache_decider()) {
$str_obj{$type} = $object;
}
}
my $i = 0;
$object->init;
while(1) {
my $ret = $object->next;
last if @{$ret->[Strassen::COORDS]} == 0;
my $strname = $ret->[Strassen::NAME];
$strname =~ s/\|/ /g; # Bla|Foo: Pipe-Zeichen entfernen
my @strname;
if ($attrib->[ATTRIB_LINES]) { # Linien?
@strname = split(/,/, $strname);
} else {
@strname = ($strname);
}
foreach $strname (@strname) {
if (exists $orte{$strname}) {
$orte{$strname} .= ",$i";
} else {
$orte{$strname} = $i;
}
}
$i++;
}
}
if ($splitter) {
my(@cols) = $splitter->((keys %orte)[0]);
$max_cols = scalar @cols;
}
$lb = $t->Scrolled($Listbox,
-scrollbars => 'osoe',
-selectmode => 'single',
($splitter
? (-columns => $max_cols,
-exportselection => 1,
)
: ()
),
)->pack(-expand => 1, -fill => 'both');
$t->Advertise(Listbox => $lb->Subwidget("scrolled"));
if ($splitter) {
my $wraplength = $max_cols > 1 ? int(800/($max_cols-1)) : 800; # XXX don't hardcode 800px
my $text_style = $lb->ItemStyle('text', -wraplength => $wraplength);
my $inx = 0;
for my $ort (sort keys %orte) {
my(@cols) = $splitter->($ort);
$lb->add($inx, -text => shift @cols, -data => $ort);
for my $col (1 .. @cols) {
next if $col >= $max_cols; # XXX off by one?
$lb->itemCreate($inx, $col, -text => $cols[$col-1],
-style => $text_style,
);
}
$inx++;
}
} else {
if (!$sorted) {
$lb->insert('end',
map { $_->[1] }
sort { $a->[0] <=> $b->[0] }
map { [lc $orte{$_}, $_] }
keys %orte);
} else {
# XXX maybe use Sort::Naturally? speed issues?
my $tf_sub = (defined &Win32Util::sort_cmp_hack_transform &&
$os eq 'win'
? sub { Win32Util::sort_cmp_hack_transform($_[0]) }
: sub { lc $_[0] });
$lb->insert('end',
map { $_->[1] }
sort { $a->[0] cmp $b->[0] }
map { [ do { /^\(?(.*)/; $tf_sub->($1) }, $_] }
keys %orte);
}
}
eval {
$lb->Cache(1);
};
my $show_sub = sub {
my %args = @_;
my $lb_index = ($splitter
? $lb->info('anchor')
: $lb->index('active')
);
return if !defined $lb_index;
my $ort = ($splitter
? $lb->info("data", $lb_index)
: $lb->get($lb_index)
);
my $index = $orte{$ort};
my $tcoords = [];
$args{'-type'} = $type;
if ($type eq 'o') {
my($x,$y) = split /,/, _get_orte_obj()->get($index)->[Strassen::COORDS]->[0];
$tcoords->[0][0] = [ transpose($x, $y) ];
} elsif ($type eq 'p') {
$tcoords->[0][0] = [ transpose($koord->get($index)) ];
} else {
my @i = split(/,/, $index);
my $i;
foreach $i (@i) {
my $r = $object->get($i);
push @{$tcoords},
[ transpose_all(@{Strassen::to_koord($r->[Strassen::COORDS])}) ];
}
if ($linetype =~ /^p/) {
$args{'-width'} = 20;
$args{'-type'} = "$type-bg";
}
}
$action->(-coords => $tcoords,
'-index' => $index,
-showbutton => $showb,
-cancelbutton => $closeb,
-clever_center => 1,
%args,
);
};
if ($args{'-markstart'}) {
my $markstart_sub = sub {
my($type) = @_;
my $lb_index = $lb->index('active');
return if !defined $lb_index;
my $index = $orte{$lb->get($lb_index)};
my @i = split(/,/, $index);
my $r = $object->get($i[0]);
my $coord = $r->[Strassen::COORDS][0];
if ($type eq 'start') {
set_route_start($coord);
} else {
set_route_ziel($coord, -caller => "chooseort");
}
if ($type eq 'start' || $zoom_new_route_chooseort == 0) {
$show_sub->();
}
};
$markf->Label(-text => M('Markieren als').' ...',
-font => $font{'small'},
)->pack(-side => 'left');
$markf->Button(-text => M"Start",
-command => sub { $markstart_sub->('start') },
)->pack(-side => 'left');
$markf->Button(-text => M"Ziel",
-command => sub { $markstart_sub->('ziel') },
)->pack(-side => 'left');
}
$showb = $f->Button(Name => 'show',
-command => sub { $show_sub->() },
)->pack(-side => 'left');
$showb->bind("<2>" => sub { $show_sub->(-zoom_view => 1) });
$showb->bind("<3>" => sub { $show_sub->(-dont_center => 1) });
$closeb = $f->Button(Name => 'close',
-command => sub {
if ($ondestroy) {
$ondestroy->($t);
} else {
if ($t->can("withdraw")) {
$t->withdraw;
} else {
$t->destroy;
}
}
},
)->pack(-side => 'left');
$t->bind('<<CloseWin>>' => sub { $closeb->invoke });
for (qw(Return Double-1 2)) {
$lb->bind("<$_>", sub { $showb->invoke });
}
my $find_and_select_nearest = sub {
my($w, $y) = @_;
my $inx = $w->nearest($y);
$w->selectionClear(0, "end");
$w->selectionSet($inx);
$w->activate($inx);
};
$lb->bind("<2>" =>
[sub {
$find_and_select_nearest->(@_);
$show_sub->(-zoom_view => 1);
}, Ev('y')]);
$lb->bind("<3>" =>
[sub {
$find_and_select_nearest->(@_);
$show_sub->(-dont_center => 1);
}, Ev('y')]);
$lb->focus;
};
warn __LINE__ . ": $@" if $@;
DecBusy($top);
$choose_ort_cache{"$linetype-$type"} =
get_cache_identifier($linetype, $type);
if ($t->isa("Tk::Wm") && $do_popup) {
if (@popup_style == 0) {
if (eval {require Tk::Placement; 1; }) {
# XXX use placer also for other toplevels --- replace
# all Popup(@popup_style) calls?
Tk::Placement::placer($t, -screen => $c,
-addx => 20, -addy => 25, # XXX for fvwm
);
} else {
$t->Popup(-overanchor => "nw", -popanchor => "nw", -popover => $c);
}
} else {
my_popup($t);
}
}
} else {
$toplevel{"chooseort-$type-$linetype"}->deiconify;
# win32 benötigt zusätzliches raise
$toplevel{"chooseort-$type-$linetype"}->raise;
}
}
# Spezialisierung von choose_ort für Stadtstraßen
### AutoLoad Sub
sub choose_streets {
choose_ort(qw(s s),
-markstartifactive => 1,
-completelistbutton => sub { choose_from_plz(-interactive => 1) },
-completelistbuttonlabel => "Alle Straßen",
);
}
# Markiert einen Punkt und/oder zentriert darauf Als Argumente werden
# Canvas-Koordinaten erwartet (Ergebnis von transpose), entweder als
# -x/-y, als -point oder als -coords-Argument (komplizierter, siehe
# Source)
### AutoLoad Sub
sub mark_point {
my(%args) = @_;
my($tx, $ty);
if (exists $args{'-x'} && exists $args{'-y'}) {
($tx, $ty) = ($args{'-x'}, $args{'-y'});
} elsif (exists $args{'-point'}) {
($tx, $ty) = split /,/, $args{'-point'};
} else {
($tx, $ty) = ($args{'-coords'}->[0][0][0], $args{'-coords'}->[0][0][1]);
}
my $width = $args{'-width'} || 9;
$c->delete('show') unless $args{'-dont_delete_old'};
my @show_mark_args;
if ($args{-endlessmark}) {
push @show_mark_args, -endlessmark => 1;
}
unless ($args{'-dont_mark'}) {
my(@tags) = ('show');
if (exists $args{'-addtag'}) {
if (ref $args{'-addtag'} eq 'ARRAY') {
push @tags, @{$args{'-addtag'}};
} else {
push @tags, $args{'-addtag'};
}
}
$c->createLine($tx, $ty, $tx, $ty,
-capstyle => $capstyle_round,
-width => $width,
-fill => $mark_color,
-tags => \@tags);
show_mark(undef, @show_mark_args);
}
if (!$args{'-dont_center'}) {
if ($args{'-clever_center'} && clever_center($tx, $ty)) {
# NOP
} else {
$c->center_view($tx, $ty);
}
}
eval { local $SIG{__DIE__}; $c->lower('show', $args{'-type'}) };
}
sub clever_center {
my($tx,$ty,$tx2,$ty2) = @_;
# For now, $tx2 and $ty2 are not used, but should be used to move
# the region towards this point. See Tk::CanvasUtil::center_view2.
return 0 if (!eval { require Tk::Placement; 1 });
# Is ($tx/$ty) already visible? Then do nothing
my($rx, $ry) = ($c->rootx+$c->widgetx($tx), $c->rooty+$c->widgety($ty));
my $curr_w = $top->containing($rx, $ry);
return 1 if $curr_w eq $c;
my @win = Tk::Placement::get_toplevel_regions($top);
if (!@win) { # no clever placement needed --- fallback to normal center
return 0;
}
for (@win) {
# adjust to canvas frame
$_->{"x"} -= $c->rootx;
$_->{"y"} -= $c->rooty;
}
my $box_w = $top->width/3;
my $box_h = $top->height/3;
my $dim = {width=>$box_w,height=>$box_h};
my $scr = {x=>0,y=>0,width=>$c->width,height=>$c->height};
my($px,$py) = Tk::Placement::Clever::placement
($dim, $scr, \@win, 0, 0, 0);
$px += $box_w/2; # move to center of box
$py += $box_h/2;
$c->scroll_canvasxy_to_rootxy($tx,$ty,
$c->rootx+$px,$c->rooty+$py);
1;
}
# Markiert und/oder zentriert auf die Linie
# Important arguments:
# -coords => [[[x,y],[x2,y2]], # first line
# [[x3,y3],[x4,y4]], # second line
# ]
### AutoLoad Sub
sub mark_street {
my(%args) = @_;
$c->delete('show') unless $args{'-dont_delete_old'};
my @res_coords;
# adapt width of mark
my $line_width = $args{'-linewidth'} || get_line_width("s-H")+6; # outline takes 2 pixels...
my $point_width = $args{'-pointwidth'} || $line_width+6;
my @labels = $args{'-labels'} ? @{ $args{'-labels'} } : ();
my($minx, $miny, $maxx, $maxy);
my @all_coords = ();
foreach (@{$args{'-coords'}}) {
my @coords = @$_;
@res_coords = ();
foreach (@coords) {
if (ref $_ eq 'ARRAY') {
if (!defined $minx || $_->[0] < $minx) { $minx = $_->[0] }
if (!defined $maxx || $_->[0] > $maxx) { $maxx = $_->[0] }
if (!defined $miny || $_->[1] < $miny) { $miny = $_->[1] }
if (!defined $maxy || $_->[1] > $maxy) { $maxy = $_->[1] }
}
push @res_coords, (ref $_ eq 'ARRAY'
? ($_->[0], $_->[1])
: $_);
}
push @all_coords, @res_coords;
unless ($args{'-dont_mark'}) {
my $label = shift @labels;
if ($args{'-polygon'}) {
if (@res_coords == 2) {
push @res_coords, (@res_coords) x 2;
}
$c->createPolygon(@res_coords,
-width => 5,
-fill => $mark_color,
-tags => ['show', $label]);
} else {
my @add_args;
if (@res_coords == 2) {
push @res_coords, @res_coords;
push @add_args, -capstyle => $capstyle_round,
-width => $point_width;
} else {
push @add_args, -width => $line_width,
}
$c->createLine(@res_coords,
@add_args,
-fill => $mark_color,
-tags => ['show', $label]);
}
}
}
show_mark() unless $args{'-dont_mark'};
if ($args{'-zoom_view'} && defined $minx) {
zoom_view($minx, $miny, $maxx, $maxy);
} else {
# Prefer an already visible point to scroll to
my($vx,$vy) = find_visible_point(\@all_coords);
if (!defined $vx) {
($vx,$vy) = @all_coords[0,1];
}
if (!$args{'-dont_center'}) {
if ($args{'-clever_center'} && clever_center($vx,$vy,@all_coords[$#all_coords-1,$#all_coords])) {
# NOP
} else {
$c->center_view2($vx,$vy,@all_coords[$#all_coords-1,$#all_coords]);
}
}
}
eval { local $SIG{__DIE__}; $c->lower('show', $args{'-type'}) };
}
sub find_visible_point {
my($c_ref) = @_;
my($x1,$y1,$x2,$y2) = $c->get_corners;
for(my $i = 0; $i < $#$c_ref; $i+=2) {
my($cx,$cy) = @{$c_ref}[$i,$i+1];
if (point_in_grid($cx,$cy,$x1,$y1,$x2,$y2)) {
return($cx,$cy);
}
}
();
}
# Dialog zum Auswahl eines Straße aus der Postleitzahl-Datenbank
### AutoLoad Sub
sub choose_from_plz {
my(%args) = @_;
return if $city ne "Berlin";
my $batch = (defined $args{'-str'} || defined $args{'-coord'});
if (!$batch) {
if ($toplevel{"chooseplz"} && Tk::Exists($toplevel{"chooseplz"})) {
$toplevel{"chooseplz"}->deiconify;
$toplevel{"chooseplz"}->raise;
return;
}
}
require PLZ;
my $plz;
if ($city eq 'Berlin') {
require PLZ::Multi;
my @objs = ("Berlin.coords.data",
"Potsdam.coords.data",
);
eval {
# XXX why?
my $plaetze = Strassen->new("plaetze");
push @objs, $plaetze if $plaetze;
}; warn $@ if $@;
$plz = PLZ::Multi->new(@objs, -cache => 1);
} else {
$plz = new PLZ;
}
if (!$plz) {
$plzmcmd->configure(-state => 'disabled');
status_message(M"Keine PLZ-Datenbank vorhanden!", 'err');
return;
}
my $show_sub = sub {
my($street_obj, $dont_mark) = @_;
IncBusy($top);
eval {
if (!defined $str_obj{'s'}) {
$str_obj{'s'} = new Strassen $str_file{'s'};
}
my $s = $str_obj{'s'};
if (!defined $str_obj{'z'}) {
$str_obj{'z'} = new Strassen $str_file{'z'};
}
my $z = $str_obj{'z'};
die "Str ($s)/PLZ ($z)-Objekt?" if !$s || !$z;
my($street, $bezirk, $plz_nr, $xy) = @$street_obj;
if (defined $xy) {
mark_point(-coords => [[[ transpose(split /,/, $xy) ]]],
-clever_center => $args{-interactive});
} else {
my(@pos) = $s->choose_street($street, $bezirk);
if (!@pos || !defined $pos[0]) {
# PLZ-Gebiet markieren
$z->init;
while(1) {
my $ret = $z->next;
last if !@{$ret->[Strassen::COORDS]};
if ($ret->[Strassen::NAME] eq $plz_nr) {
mark_street
(-coords =>
[[ transpose_all(@{Strassen::to_koord($ret->[Strassen::COORDS])}) ]],
-type => 's',
-dont_mark => $dont_mark,
-polygon => 1,
);
return;
}
}
my $plz_re = $plz->make_plz_re($plz_nr);
my @streets = $plz->look($plz_re, Noquote => 1);
@pos = $s->union(\@streets, Nouniq => 1);
if (!@pos) {
die Mfmt("Keine Straßen im PLZ-Gebiet %s.\n", $plz_nr);
}
}
# Straßen im PLZ-Gebiet markieren
my $i;
for($i = 0; $i <= $#pos; $i++) {
my $o = $pos[$i];
mark_street
(-coords =>
[[ transpose_all(@{Strassen::to_koord($s->get($o)->[Strassen::COORDS])}) ]],
-type => 's',
-dont_delete_old => ($i != 0),
-dont_center => ($i != $#pos),
-dont_mark => $dont_mark,
);
}
if (@pos > 1 && !$dont_mark) {
status_message(Mfmt("%s liegt im markierten Gebiet",
$street), 'info');
}
}
};
if ($@) {
status_message($@, 'err');
}
DecBusy($top);
};
my $str;
if (defined $args{'-str'}) { # auf Straße zentrieren
return if ($args{'-str'} eq "");
$str = $args{'-str'};
my($matchref) = $plz->look_loop($str, Agrep => 3, Max => 20);
my(@match) = @$matchref;
return if !@match;
$show_sub->($match[0], 1) if !$args{-noshow};
return $match[0]->[PLZ::LOOK_COORD()]; # return coords
} elsif (defined $args{'-coord'}) { # auf Koordinaten zentrieren
return if ($args{'-coord'} eq "");
eval {
mark_point(-coords => [[[ transpose(split(/,/, $args{'-coord'})) ]]],
-dont_mark => 1);
};
warn $@ if $@;
} else { # interaktiv
my $t = $top->Toplevel(-title => M"Auswahl aus kompletter Straßenliste",
-class => "Bbbike Extended Chooser");
set_as_toolwindow($t);
$toplevel{"chooseplz"} = $t;
my $bf = $t->Frame->pack(-fill => 'x', -side => "bottom");
my $strf = $t->Frame->pack(-fill => 'x', -side => "top");
$strf->Label(-text => M('Straße').':'
)->pack(-side => "left");
my $Entry = 'Entry';
my @extra_args;
my $this_history_file;
eval {
require Tk::HistEntry;
Tk::HistEntry->VERSION(0.37);
@extra_args = (-match => 1, -dup => 0, #-case => 0
);
$Entry = 'HistEntry';
$this_history_file = "$bbbike_configdir/bbbike_street_hist";
};
my $e = $strf->$Entry(-textvariable => \$str,
@extra_args,
-width => 30)->pack(-side => "left");
$e->historyMergeFromFile($this_history_file)
if $e->can('historyMergeFromFile');
$e->focus;
my $srchb =
$strf->Button(Name => 'search',
-padx => 0,
-pady => 0,
)->pack(-side => "left");
my $showb;
my $lb = $t->Scrolled('Listbox',
-scrollbars => 'osoe',
)->pack(-fill => "x");
my @match;
my $show_sub_lb = sub {
$show_sub->($match[$lb->index('active')], 0);
};
for (qw(Double-1 2)) {
$lb->bind("<$_>" => sub {
$show_sub->($match
[$lb->nearest
($lb->Subwidget('scrolled'
)->XEvent->y)], 0);
});
}
$t->OnDestroy(sub { delete $toplevel{"chooseplz"} });
my $close_window = sub { $t->destroy; };
my $search_window = sub {
if ($e->can('historyAdd') &&
$e->can('historySave')) {
$e->historyAdd;
$e->historySave($this_history_file);
}
IncBusy($t);
eval {
my($matchref) = $plz->look_loop($str, Agrep => 3, Max => 20);
@match = @$matchref;
if (!@match) {
$showb->configure(-state => 'disabled');
die M"Keine Straßen gefunden.\n";
} else {
$lb->delete(0, 'end');
foreach (@match) {
$lb->insert('end', join("/", @{$_}[0..2]));
}
$lb->selection('set', 0);
$showb->configure(-state => 'normal');
$lb->focus;
}
};
if ($@) {
status_message($@, 'err');
}
DecBusy($t);
};
$e->bind('<Return>' => $search_window);
$srchb->configure(-command => $search_window);
$t->bind('<<CloseWin>>' => $close_window);
$showb = $bf->Button
(Name => 'show',
-state => 'disabled',
-command => $show_sub_lb)->grid(-row => 0, -column => 1,
-sticky => 'ew');
$lb->bind('<Return>' => $show_sub_lb);
$bf->Button(Name => 'close',
-command => $close_window)->grid(-row => 0, -column => 2,
-sticky => 'ew');
#$t->Popup(@popup_style);
my($x,$y) = ($c->rootx+10, $c->rooty+10);
$t->geometry("+$x+$y");
}
}
# Gibt die aktuelle Fontgröße für die übergebene Ortskategorie zurück.
### AutoLoad Sub
sub get_orte_label_font {
my($category, $is_overview_canvas) = @_;
my $base_index = 0;
if (!$is_overview_canvas) {
if ($scale >= 6) {
$base_index = 2;
} elsif ($scale >= 3) {
$base_index = 1;
}
}
my $font;
# This should handle the range MIN_ORT_CAT .. MAX_ORT_CAT:
if ($category <= 2) {
$font = $font{$font[$base_index + $orte_label_size]};
} elsif ($category == 3) {
$font = $font{$font[$base_index + $orte_label_size+1]};
} elsif ($category == 4) {
$font = $font{$font[$base_index + $orte_label_size+2]};
} elsif ($category == 5) {
$font = $font{$font[$base_index + $orte_label_size+3]};
} elsif ($category > 5) {
$font = $font{$font[$base_index + $orte_label_size+4]};
} else {
die "Unknown category $category";
}
if (!defined $font) {
$font = $font{'veryhuge'};
}
$font;
}
# Zeichnet Orte.
# XXX Modus zum Zeichnen von Bezirken
### AutoLoad Sub
sub plotorte {
my(%args) = @_;
my $std;
my $c = $c;
my $transpose;
my $municipality = $args{-municipality};
my $type = $args{-type} || 'o';
my $label_tag = uc($type);
my $is_overview_canvas;
if (exists $args{Canvas}) {
$c = $args{Canvas};
$std = 0;
$transpose = ($show_overview_mode eq 'brb'
? \&transpose_small
: \&transpose_medium);
$is_overview_canvas = 1;
} else {
$std = 1;
$transpose = \&transpose;
}
# evtl. alte Koordinaten löschen
if (!$args{FastUpdate}) {
$c->delete($type);
$c->delete($label_tag);
}
delete $pending{"replot-p-$type"};
if ($std && !$p_draw{$type}) {
undef $p_obj{$type};
if ($main::lazy_p{$type}) {
bbbikelazy_remove_data("p", $type);
}
return;
}
my $orte = _get_orte_obj($type);
my $lazy = defined $args{-lazy} ? $args{-lazy} : $lazy_plot;
if ($std && $lazy) {
return bbbikelazy_add_data("p", $type, $orte);
}
my $coordsys = $coord_system_obj->coordsys;
destroy_delayed_restack();
IncBusy($top);
$progress->Init(-dependents => $c,
-label => 'orte');
eval {
my $place_category = (exists $args{PlaceCategory}
? $args{PlaceCategory} : $place_category);
my $name_o = (exists $args{NameDraw}
? $args{NameDraw} : $p_name_draw{$type});
my $no_overlap_label = (exists $args{NoOverlapLabel}
? $args{NoOverlapLabel} : $no_overlap_label{$type});
my $progress_hack = $name_o && $no_overlap_label;
my $complete_str = $orte;
my $diffed_orte = 0;
if (#XXX del? ($edit_mode || $edit_normal_mode) &&
$args{FastUpdate}) {
my($new_orte, $todelref) = $orte->diff_orig(-clonefile => 1);
if (!defined $new_orte) {
warn "Not using diff output" if $verbose;
$c->delete($type); # evtl. alte Koordinaten löschen
$c->delete($label_tag);
} else {
warn "Using diff output" if $verbose;
# XXX not used due to lack of tag $type-$i
#foreach (@$todelref) {
# $c->delete("$type-$_");
#}
$orte = $new_orte;
$diffed_orte = 1;
}
}
my @orte_coords_labeling;
#XXX del:
# foreach ($orte->file) {
# $old_mtime{$_} = (stat($_))[STAT_MODTIME];
# $mtime_file_type{$_} = ['p', $type];
# }
my $next_meth;
my $i;
my $i_inc;
if ($no_overlap_label) {
$orte->init;
$next_meth = 'next';
$i = 0;
$i_inc = +1;
} else {
# in diesem Fall sollten die größeren Orte _später_ d.h. über
# den kleineren gezeichnet werden
$orte->set_last;
$next_meth = 'prev';
$i = $orte->count; # XXX off by one???
$i_inc = -1;
}
my $anzahl_eindeutig = $orte->count;
my $do_outline_text = $do_outline_text{$type};
my %conv_args;
if ($args{-map}) {
$conv_args{Map} = $args{-map};
}
my $conv = $orte->get_conversion(%conv_args);
my $draw_sub = eval $plotorte_draw_sub;
die $@ if $@;
my $prog_i = 0;
while(1) {
my $ret = $orte->$next_meth();
last if !@{$ret->[Strassen::COORDS]};
$progress->Update($prog_i/$anzahl_eindeutig*($progress_hack ? 0.5 : 1))
if $prog_i % 80 == 0;
$prog_i++;
$i += $i_inc;
$draw_sub->($ret);
}
$c->itemconfigure($type,
-capstyle => $capstyle_round,
-width => 5,
-fill => '#000080',
);
if ($name_o) {
if ($no_overlap_label) {
# nach Kategorie sortieren
@orte_coords_labeling
= sort { $b->[3] <=> $a->[3] } @orte_coords_labeling;
my $i = 0;
foreach my $ort_def (@orte_coords_labeling) {
$progress->Update($i/$anzahl_eindeutig*.5+0.5)
if $i % 80 == 0;
$i++;
my($text, $tx, $ty, $cat, $point_item) = @$ort_def;
my $font = get_orte_label_font($cat, $is_overview_canvas);
my(@tags) = ($label_tag, "$label_tag$cat");
if (!draw_text_intelligent($c, $tx, $ty,
-text => $text,
-font => $font,
-tags => \@tags,
-abk => $label_tag,
)) {
if ($cat <= $place_category+1) {
$c->delete($point_item);
} else {
my $anchor = 'w';
$c->createText
($tx+$xadd_anchor_type->{'o'}{$anchor},
$ty+$yadd_anchor_type->{'o'}{$anchor},
-text => $text,
-font => $font,
-tags => \@tags,
-anchor => $anchor,
-justify => 'left',
);
}
}
}
}
if (!$no_overlap_label && !$municipality &&
!$do_outline_text) {
$c->itemconfigure($label_tag,
-anchor => 'w', -justify => 'left');
}
if ($orientation eq 'landscape' &&
!$do_outline_text) {
$c->itemconfigure($label_tag,
-font => get_orte_label_font(2, $is_overview_canvas));
}
if ($municipality) {
$c->itemconfigure($label_tag, -fill => '#7e7e7e');
} elsif (!$do_outline_text) {
$c->itemconfigure($label_tag, -fill => '#000080');
}
if ($orientation eq 'landscape' &&
!$do_outline_text) {
unless ($args{'AllSmall'}) {
# wichtigere Orte bekommen eine größere Schrift
foreach my $category (3 .. MAX_ORT_CAT) {
$c->itemconfigure
("$label_tag$category",
-font => get_orte_label_font($category, $is_overview_canvas));
}
}
}
}
if (!($edit_mode || $edit_normal_mode) && !$municipality) {
change_place_visibility($c);
}
if (($edit_mode || $edit_normal_mode) and !$diffed_orte) {
warn "Try to copy original data" if $verbose;
my $r = $complete_str->copy_orig;
warn "Returned $r" if $verbose;
}
if ($std) {
restack_delayed();
}
};
if ($@) {
status_message($@, 'err');
}
$progress->Finish;
DecBusy($top);
}
# Zeichnet Labels, wobei versucht wird, Überlappungen zu vermeiden.
# Auf $canvas wird gezeichnet, die Koordinaten sind $tx/$ty
### AutoLoad Sub
sub draw_text_intelligent {
my($canvas, $tx, $ty, %args) = @_;
my @ct_args;
foreach my $arg (qw(-text -font -tags -fill -font)) {
push @ct_args, $arg => $args{$arg} if exists $args{$arg};
}
# mit welchen Tags Überlappungen vermeiden
my $abkrx = (ref $args{-abk} eq 'ARRAY'
? '^(' . join('|', @{$args{-abk}}) . ")\$"
: "^$args{-abk}\$");
# Anchor => X/Y-Versetzung
my $xadd = (exists $args{-xadd} ? $args{-xadd} : $xadd_anchor_type->{'o'});
my $yadd = (exists $args{-yadd} ? $args{-yadd} : $yadd_anchor_type->{'o'});
my $check_tag_index = (exists $args{-checktagindex}
? $args{-checktagindex}
: 0);
LOOP:
foreach my $anchor (qw(w e nw n sw s)) {
my $item = $canvas->createText
($tx+$xadd->{$anchor}, $ty+$yadd->{$anchor},
@ct_args,
-anchor => $anchor,
-justify => 'left',
);
my(@bbox) = $canvas->bbox($item);
if (@bbox) {
my(@overlap) = $canvas->find('overlapping', @bbox);
foreach my $i (@overlap) {
next if $i == $item;
my(@tags) = $canvas->gettags($i);
next if !@tags;
if ($check_tag_index eq 'all') {
foreach my $tag (@tags) {
if ($tag =~ /$abkrx/) {
$canvas->delete($item);
next LOOP;
}
}
} else {
next if !defined $tags[$check_tag_index];
if ($tags[$check_tag_index] =~ /$abkrx/) {
$canvas->delete($item);
next LOOP;
}
}
}
}
$ {$args{-returnanchor}} = $anchor
if ref $args{-returnanchor} eq 'SCALAR';
if ($args{-outline}) {
$c->delete($item);
outline_text($c, $tx+$xadd->{$anchor}, $ty+$yadd->{$anchor},
@ct_args, -anchor => $anchor,
-outlinewidth => $args{-outlinewidth});
}
return 1;
}
0;
}
# Zeichnen von Stellen mit Obstvorkommen
### AutoLoad Sub
sub plotobst {
my(%args) = @_;
my $canvas = $c;
my $transpose = \&transpose;
# evtl. alte Koordinaten löschen
$canvas->delete('obst');
delete $pending{'replot-p-obst'};
if (!$p_draw{'obst'}) {
return;
}
destroy_delayed_restack();
IncBusy($top);
$progress->Init(-dependents => $canvas,
-label => $p_file{'obst'});
eval {
my $i = 0;
my $obst = get_strassen_obj($p_file{'obst'});
$obst->init;
my $anzahl_eindeutig = $obst->count;
while(1) {
my $ret = $obst->next;
last if !@{$ret->[Strassen::COORDS]};
$progress->Update($i/$anzahl_eindeutig) if $i % 80 == 0;
$i++;
my $type = lc($ret->[Strassen::NAME]);
next if !exists $obst_file{$type}; # XXX warning
if ($ret->[Strassen::COORDS][0] =~ /(-?\d+),(-?\d+)/) {
my($x, $y) = ($1, $2);
my($tx, $ty) = $transpose->($x, $y);
if (!exists $obst_photo{$type}) {
$obst_photo{$type} =
$canvas->Photo(-file => Tk::findINC($obst_file{$type}));
}
next if (!defined $obst_photo{$type});
my $img = $obst_photo{$type};
$canvas->createImage($tx, $ty,
-image => $img,
-tags => 'obst');
}
}
restack_delayed();
};
if ($@) {
status_message($@, 'err');
}
$progress->Finish;
DecBusy($top);
}
### AutoLoad Sub
sub draw_bridge {
my($cl,%args) = @_;
my $width = $args{width}||10;
my $color = '#808080';
my $thickness = 2; # make configurable XXX
#XXX complicated code, make nicer!
#XXX an den Enden etwas verkürzen
for(my $i = 0; $i < $#$cl/2-1; $i++) {
my($x1,$y1,$x2,$y2) = @{$cl}[$i*2..$i*2+3];
my $alpha = atan2($y2-$y1,$x2-$x1);
my $beta = $alpha - pi()/2;
my $delta = $width/2;
my($dx,$dy) = ($delta*cos($beta), $delta*sin($beta));
$c->createLine($x1+$dx,$y1+$dy,$x2+$dx,$y2+$dy,
-width => $thickness,
-tags => $args{tags},
-fill => $color,
);
$c->createLine($x1-$dx,$y1-$dy,$x2-$dx,$y2-$dy,
-width => $thickness,
-tags => $args{tags},
-fill => $color,
);
}
{
my $alpha = atan2($cl->[3]-$cl->[1],$cl->[2]-$cl->[0]);
my $beta = $alpha - pi()/2;
my $knick = $alpha - pi()/4;
my $knick2 = $alpha + pi()/4;
my $delta = $width/2;
my $knick_length = $width/2;
my($dx, $dy) = ($delta*cos($beta), $delta*sin($beta));
my($kx, $ky) = ($knick_length*cos($knick), $knick_length*sin($knick));
my($k2x, $k2y) = ($knick_length*cos($knick2), $knick_length*sin($knick2));
$c->createLine($cl->[0]+$dx-$k2x, $cl->[1]+$dy-$k2y,
$cl->[0]+$dx, $cl->[1]+$dy,
-width => $thickness,
-tags => $args{tags},
-fill => $color,
);
$c->createLine(
$cl->[0]-$dx, $cl->[1]-$dy,
$cl->[0]-$dx-$kx, $cl->[1]-$dy-$ky,
-width => $thickness,
-tags => $args{tags},
-fill => $color,
);
}
{
my $alpha = atan2($cl->[-1]-$cl->[-3],$cl->[-2]-$cl->[-4]);
my $beta = $alpha - pi()/2;
my $knick = $alpha - pi()/4;
my $knick2 = $alpha + pi()/4;
my $delta = $width/2;
my $knick_length = $width/2;
my($dx, $dy) = ($delta*cos($beta), $delta*sin($beta));
my($kx, $ky) = ($knick_length*cos($knick), $knick_length*sin($knick));
my($k2x, $k2y) = ($knick_length*cos($knick2), $knick_length*sin($knick2));
$c->createLine($cl->[-2]+$dx+$kx, $cl->[-1]+$dy+$ky,
$cl->[-2]+$dx, $cl->[-1]+$dy,
-width => $thickness,
-tags => $args{tags},
-fill => $color,
);
$c->createLine(
$cl->[-2]-$dx, $cl->[-1]-$dy,
$cl->[-2]-$dx+$k2x, $cl->[-1]-$dy+$k2y,
-width => $thickness,
-tags => $args{tags},
-fill => $color,
);
}
}
### AutoLoad Sub
sub draw_tunnel_entrance {
my($cl,%args) = @_;
my $width = $args{width}||20;
my $color = '#505050';
my $thickness = 3;
#XXX complicated code, make nicer!
{
my $alpha = atan2($cl->[3]-$cl->[1],$cl->[2]-$cl->[0]);
my $beta = $alpha - pi()/2;
my $knick = $alpha - pi()/4;
my $knick2 = $alpha + pi()/4;
my $delta = $width/2;
my $knick_length = $width/3;
my($dx, $dy) = ($delta*cos($beta), $delta*sin($beta));
my($kx, $ky) = ($knick_length*cos($knick), $knick_length*sin($knick));
my($k2x, $k2y) = ($knick_length*cos($knick2), $knick_length*sin($knick2));
$c->createLine($cl->[0]+$dx-$k2x, $cl->[1]+$dy-$k2y,
$cl->[0]+$dx, $cl->[1]+$dy,
$cl->[0]-$dx, $cl->[1]-$dy,
$cl->[0]-$dx-$kx, $cl->[1]-$dy-$ky,
-width => $thickness,
-tags => $args{tags},
-fill => $color,
);
}
{
my $alpha = atan2($cl->[-1]-$cl->[-3],$cl->[-2]-$cl->[-4]);
my $beta = $alpha - pi()/2;
my $knick = $alpha - pi()/4;
my $knick2 = $alpha + pi()/4;
my $delta = $width/2;
my $knick_length = $width/3;
my($dx, $dy) = ($delta*cos($beta), $delta*sin($beta));
my($kx, $ky) = ($knick_length*cos($knick), $knick_length*sin($knick));
my($k2x, $k2y) = ($knick_length*cos($knick2), $knick_length*sin($knick2));
$c->createLine($cl->[-2]+$dx+$kx, $cl->[-1]+$dy+$ky,
$cl->[-2]+$dx, $cl->[-1]+$dy,
$cl->[-2]-$dx, $cl->[-1]-$dy,
$cl->[-2]-$dx+$k2x, $cl->[-1]-$dy+$k2y,
-width => $thickness,
-tags => $args{tags},
-fill => $color,
);
}
}
# Löscht alle derzeitig gezeichneten Straßen und Punkte und liefert
# eine Subroutine zurück, mit der die gelöschten Objekte wieder
# gezeichnet werden können.
### AutoLoad Sub
sub get_plotted {
my(@plotted_p, @plotted_str);
while(my($k,$v) = each %str_draw) {
push @plotted_str, $k if ($v);
}
while(my($k,$v) = each %p_draw) {
push @plotted_p, $k if ($v);
}
sub {
$progress->InitGroup;
foreach (@plotted_p) {
plot('p',$_);
}
foreach (@plotted_str) {
plot('str',$_);
}
$progress->FinishGroup;
}
}
# Setzt den Canvas in den Landscape-Modus (Default).
sub set_landscape {
local($^W) = 0; # wegen sub-Redefinition
$orientation = 'landscape';
*transpose = \&transpose_ls;
*anti_transpose = \&anti_transpose_ls;
*transpose_small = \&transpose_ls_small;
*transpose_medium = \&transpose_ls_medium;
*anti_transpose_small = \&anti_transpose_ls_small;
*anti_transpose_medium = \&anti_transpose_ls_medium;
delete_overview();
}
# Setzt den Canvas in den Portraint-Modus.
### AutoLoad Sub
sub set_portrait {
local($^W) = 0; # wegen sub-Redefinition
$orientation = 'portrait';
*transpose = \&transpose_pt;
*anti_transpose = \&anti_transpose_pt;
*transpose_small = \&transpose_pt_small;
*transpose_medium = \&transpose_pt_medium;
*anti_transpose_small = \&anti_transpose_pt_small;
*anti_transpose_medium = \&anti_transpose_pt_medium;
delete_overview();
}
# Ändert das aktuelle Koordinatensystem.
# XXX verbessern...
### AutoLoad Sub
sub set_coord_system {
my($o) = @_;
if (!defined $o) {
$o = $Karte::map{'standard'};
}
my $old_coord_system = $coord_system_obj ? $coord_system_obj->token : "";
if ($old_coord_system eq $o->token) {
# No change
return;
}
if ($o->token eq 'standard') {
set_landscape(); # XXX set scrollregion
$coord_system = 'standard';
$scale_coeff = 1;
set_canvas_scale(DEFAULT_SCALE);
} else {
{
local($^W) = 0;
*transpose = sub { ($_[0]*$scale, $_[1]*$scale) };
*anti_transpose = sub { ($_[0]/$scale, $_[1]/$scale) };
*transpose_small = sub { ($_[0]*$small_scale_edit, $_[1]*$small_scale_edit) };
*anti_transpose_small = sub { ($_[0]/$small_scale_edit, $_[1]/$small_scale_edit) };
*transpose_medium = sub { ($_[0]*$medium_scale_edit, $_[1]*$medium_scale_edit) };
*anti_transpose_medium = sub { ($_[0]/$medium_scale_edit, $_[1]/$medium_scale_edit) };
}
$scale_coeff = $o->scale_coeff;
set_canvas_scale(1);
}
@scrollregion = $o->scrollregion;
if ($o->token eq 'standard') { # XXX hack
foreach (@scrollregion) {
$_ *= DEFAULT_SCALE;
}
}
scalecanvas($c, 1);
$coord_system_obj = $o;
undef %hoehe;
}
# Setzt die GUI für den Edit-Mode
sub gui_set_edit_mode {
my($onoff) = @_;
if ($onoff) {
$edit_mode_indicator->configure(-fg => 'black'); # XXX don't hardcode
$edit_mode_type->configure(-text => uc($onoff));
if ($onoff eq 'std-no-orig') {
undef $edit_mode;
$edit_normal_mode = 1;
} else {
$edit_mode = $onoff;
}
$edit_mode_flag = 1;
} else {
$edit_mode_indicator->configure(-fg => $dim_color);
$edit_mode_type->configure(-text => '');
undef $edit_mode;
undef $edit_normal_mode;
$edit_mode_flag = 0;
}
}
# Zeigt Namen der aktuellen Haltestelle oder des aktuellen Ortes
# (unterhalb des Cursors).
sub enterpoint {
my $c = shift;
my(@tags) = $c->gettags('current');
if ($tags[0] eq 'p') {
$act_value{Haltestelle} = $names[$tags[1]];
$hs_label->configure(-fg => 'black');
} elsif ($tags[0] eq 'o' || $tags[0] =~ /^[ubr](?:-|_bg)/) {
my $prefix = '';
my $name = $tags[2];
if ($tags[0] =~ /^u(?:-|_bg)/) {
$prefix = 'U ';
} elsif ($tags[0] =~ /^b(?:-|_bg)/) {
$prefix = 'S ';
} elsif ($tags[0] =~ /^r(?:-|_bg)/) {
$prefix = 'Bhf. '; # XXX language?
}
$act_value{Haltestelle} = $prefix . $name;
$hs_label->configure(-fg => 'black');
} elsif ($tags[0] eq 'pp' || $tags[0] =~ /^(L\d+|kn|ki|rest)/) {
if (defined $tags[2] && $tags[2] ne 'current') {
$act_value{Haltestelle} = $tags[2];
} else {
$act_value{Haltestelle} = '';
}
if (exists $hoehe{$tags[1]}) {
$act_value{Haltestelle} .= " ($hoehe{$tags[1]}m)";
}
$hs_label->configure(-fg => 'black');
} elsif ($tags[0] =~ /sperre/) {
if ($tags[1] eq 'sperre0') {
$act_value{Haltestelle} = $tags[2] || M"tragen notwendig";
} elsif ($tags[1] =~ /^sperre1/) {
$act_value{Haltestelle} = M("Einbahnstraße") .
(defined $tags[2] and $tags[2] ne "" ? " - " . $tags[2] : "");
} elsif ($tags[1] eq 'sperre2') {
if (defined $tags[2] and $tags[2] ne "") {
$act_value{Haltestelle} = $tags[2];
} else {
$act_value{Haltestelle} = M("gesperrte Straße");
}
} else {
$act_value{Haltestelle} = $tags[2] || '';
}
$hs_label->configure(-fg => 'black');
} elsif ($tags[0] =~ /^lsa-/) {
my $exact_cat = $tags[3];
if ($exact_cat !~ /^lsa-X/) {
$act_value{Haltestelle} = ($exact_cat =~ /^lsa-F/
? M"Fußgängerampel"
: ($exact_cat =~ /^lsa-B/
? M"Bahnübergang"
: ($exact_cat =~ /^lsa-Zbr/
? M"Zugbrücke (" . $tags[2] . ")"
: substr($exact_cat, 4, 1)
)
)
);
$hs_label->configure(-fg => 'black');
} else {
$act_value{Haltestelle} = "";
}
} elsif ($tags[0] =~ /^show/) {
if (defined $tags[1] && $tags[1] ne 'current') {
$act_value{Haltestelle} = $tags[1];
$hs_label->configure(-fg => 'black');
}
if (defined $tags[2] && $tags[1] ne 'current' && $tags[2] ne 'current') {
$act_value{Strasse} = $tags[2];
$str_label->configure(-fg => 'black');
} else {
$str_label->configure(-fg => $dim_color);
}
} elsif ($tags[0] =~ /^pl/) {
$act_value{Haltestelle} = $tags[2];
$hs_label->configure(-fg => 'black');
}
my @l;
my $str = show_below_str($c);
if (defined $act_value{Haltestelle}
&& $act_value{Haltestelle} ne '') {
push @l, $act_value{Haltestelle};
}
if (defined $str && $str ne '') {
push @l, $str;
}
if (defined $c_balloon) {
if (@l && $use_c_balloon > 1) {
if ($leave_after) { $leave_after->cancel; undef $leave_after }
$c_balloon->Popup(join(" / ", @l));
} else {
$c_balloon->Deactivate;
}
}
}
# Wird beim Verlassen eines Punktes aufgerufen.
sub leavepoint {
$hs_label->configure(-fg => $dim_color);
$c_balloon->Deactivate(undef, -from => "event") if defined $c_balloon;
leavestr();
}
# Zeigt aktuellen Straßenzugnamen.
sub enterstr {
my $c = shift;
my(@tags) = $c->gettags('current');
my @l;
if (grep { $_ eq 'rw' } @tags) {
# Special handling for cyclepaths
(my $rw_code) = $tags[2] =~ /^rw-(RW\d+)/;
my $name = Radwege::code2name($rw_code);
if (defined $name) {
push @l, $name;
}
} else {
$act_value{Strasse} = $tags[1];
$act_value{Strasse} =~ s/\|.*$//; # Teil hinter "|" abschneiden
if (($edit_mode || $edit_normal_mode) and defined $tags[3] and $tags[3] =~ /-(\d+)$/) {
$act_value{Strasse} .= " [" . ($1+1) . "]"; # Zeilennummer
}
$str_label->configure(-fg => 'black');
if ($hs_label->cget(-fg) eq 'black') {
push @l, $act_value{Haltestelle};
}
if (defined $act_value{Strasse} && $act_value{Strasse} ne '') {
push @l, $act_value{Strasse};
}
}
if (defined $c_balloon) {
if (@l && $use_c_balloon > 1) {
if ($leave_after) { $leave_after->cancel; undef $leave_after }
$c_balloon->Popup(join(" / ", @l));
} else {
$c_balloon->Deactivate;
}
}
}
# Wird beim Verlassen einer Strecke aufgerufen.
sub leavestr {
$str_label->configure(-fg => $dim_color);
$c_balloon->Deactivate(undef, -from => "event") if defined $c_balloon;
}
# Zeigt den Strecken- und/oder Punktnamen unterhalb der Route.
sub enterroute {
my($c, $item) = @_;
return if !defined $c_balloon;
$item = 'current' unless defined $item;
my(@tags) = $c->gettags($item);
my $routenr;
if (defined $tags[2] && $tags[2] eq 'viaflag') {
my($item2,@tags2) = find_below_rx($c, ['^route-'],[1]);
if (defined $item2) {
($item, @tags) = ($item2, @tags2);
}
}
if (defined $tags[1] && $tags[1] =~ /^route-(.*)/) {
$routenr = $1;
if ($routenr eq "") { warn "@tags" } # XXXXX
} else {
if (!grep { $_ eq "viaflag" } @tags) {
warn "Unexpected: no route number in <@tags>";
}
return;
}
my @l;
my $str = show_below_str($c);
if (!defined $str) {
# next try with bigger tolerance
my $old_closeenough = $c->cget(-closeenough);
$c->configure(-closeenough => 5);
$str = show_below_str($c);
# restore old tolerance value
$c->configure(-closeenough => $old_closeenough);
}
push @l, Strassen::strip_bezirk($str) if (defined $str);
if (defined $routenr && $routenr >= 0) { # wenn mehr als nur der Startpunkt angewählt ist
push @l, s2hm($route_time[$routenr]) . "h" if ($route_time[$routenr]);
push @l, m2km($route_distance[$routenr]) if ($route_distance[$routenr]);
}
if (@l) {
if ($leave_after) { $leave_after->cancel; undef $leave_after }
$c_balloon->Popup(join(" / ", @l));
} else {
$c_balloon->Deactivate;
}
}
# Wird beim Verlassen einer Route aufgerufen.
sub leaveroute {
if (!$leave_after) { # XXX not well tested yet!
$leave_after =
$c->after(100, sub {
$str_label->configure(-fg => $dim_color);
$c_balloon->Deactivate(1) if defined $c_balloon;
undef $leave_after;
});
}
}
# Gibt den ersten Tag aus @allowed_tags aus, der sich unter dem jetzigen
# Tag befindet.
sub find_below {
my($c, @allowed_tags) = @_;
my $e = $c->XEvent;
my($xx, $yy) = ($c->canvasx($e->x), $c->canvasy($e->y));
my(@items) = $c->find(overlapping => $xx-1, $yy-1, $xx+1, $yy+1);
my %allowed_tags;
foreach (@allowed_tags) { $allowed_tags{$_} = 1 }
my %res;
# Now using "reverse", so top-most items are preferred
# XXX Hopefully this change does not break anything.
foreach my $item (reverse @items) {
my(@tags) = $c->gettags($item);
if ($allowed_tags{$tags[0]} && !exists $res{$tags[0]}) {
$res{$tags[0]} = $item;
}
}
foreach (@allowed_tags) {
if (exists $res{$_}) {
return ($res{$_}, $c->gettags($res{$_}));
}
}
undef;
}
# Similar to find_below, but use a list of regexes and restrict to
# a list of tag positions.
sub find_below_rx {
my($c, $allowed_rx_tags, $tag_pos, $forbidden_rx_tags) = @_;
my $e = $c->XEvent;
my($xx, $yy) = ($c->canvasx($e->x), $c->canvasy($e->y));
my(@items) = $c->find(overlapping => $xx-1, $yy-1, $xx+1, $yy+1);
# Now using "reverse", so top-most items are preferred
# XXX Hopefully this change does not break anything.
ITEM:
foreach my $item (reverse @items) {
my(@tags) = $c->gettags($item);
my @restricted_tags = $tag_pos ? @tags[@$tag_pos] : @tags;
my $ok = 0;
for my $tag (@restricted_tags) {
for my $rx (@$allowed_rx_tags) {
if ($tag =~ /$rx/) {
if ($forbidden_rx_tags) {
for my $frx (@$forbidden_rx_tags) {
if ($tag =~ /$frx/) {
next ITEM;
}
}
}
$ok = 1;
}
}
}
if ($ok) {
return ($item, @tags);
}
}
undef;
}
# Doc pending XXX
sub show_below_str {
my($c) = @_;
my($item, @tags) = find_below($c, qw/s l u b r f w/);
return if !defined $item;
$act_value{Strasse} = $tags[1];
$str_label->configure(-fg => 'black');
$act_value{Strasse};
}
# Guckt zunächst nach, ob sich darunter eine Route befindet und leitet
# bei Erfolg die Bearbeitung an enterroute() weiter, ansonsten wird
# show_below_str() verwendet.
sub show_below_route_str {
my $c = shift;
my($item, @tags) = find_below($c, qw/route/);
if (!defined $item) {
show_below_str($c); # Rückgabe: String
} else {
enterroute($c, $item);
undef; # Rückgabe: undef
}
}
# Zeigt Informationen zum aktuellen Tag.
### AutoLoad Sub
sub show_info {
my($x, $y) = @_;
my(@tags) = $c->gettags('current');
return if !@tags || !defined $tags[0];
my($base_tag, $is_p);
my $recursion_breaker=0;#XXX
while (1) {
if($recursion_breaker++>10){die}#XXX
$base_tag = $tags[0];
@tags = grep { $_ ne "current" } @tags;
$is_p = ($base_tag =~ /-(?:[fb]g|img)$/);
$base_tag =~ s/-(?:[fb]g|img)$//;
last unless !exists $p_file{$base_tag} and !$str_file{$base_tag};
my($below_item, @below_tags) = find_below($c, qw/s l u b r f w o v/);
if (!defined $below_item) {
main::status_message("Es wurde kein Kartenelement an dieser Position gefunden.", "err");
return;
}
@tags = @below_tags;
}
my $index;
if ($#tags >= 3) {
($index = $tags[3]) =~ s/^$base_tag-//;
#warn $index;
}
my $strname = $tags[1];
my(@coords) = $c->coords('current');
my $current_is_label = $c->type('current') eq 'text';
if (!@coords || @coords > 2 || $current_is_label) {
my($px,$py) = $c->pointerxy;
$px -= $c->rootx;
$py -= $c->rooty;
@coords = ($c->canvasx($px), $c->canvasy($py));
}
require Karte::Polar;
require Karte::UTM;
require Karte::ETRS89;
my($sx,$sy) = $Karte::Standard::obj->trim_accuracy(anti_transpose($coords[0], $coords[1]));
my($px,$py) = $Karte::Polar::obj->trim_accuracy($coord_system_obj->map2map($Karte::Polar::obj, $sx, $sy));
my @polarcoord = (Karte::Polar::dms_human_readable("lat", Karte::Polar::ddd2dms($py)),
Karte::Polar::dms_human_readable("long", Karte::Polar::ddd2dms($px)));
my @polarcoord2 = (Karte::Polar::dmm_human_readable("lat", Karte::Polar::ddd2dmm($py)),
Karte::Polar::dmm_human_readable("long", Karte::Polar::ddd2dmm($px)));
my($gkk_zone_potsdam, $gkk_easting_potsdam, $gkk_northing_potsdam) = Karte::UTM::DegreesToGKK($py, $px, "Potsdam");
my($gkk_zone_wgs84, $gkk_easting_wgs84, $gkk_northing_wgs84) = Karte::UTM::DegreesToGKK($py, $px, "WGS 84");
my($utm_ze, $utm_zn, $utm_x, $utm_y) = Karte::UTM::DegreesToUTM($py, $px, "WGS 84");
my($etrs_east, $etrs_north) = Karte::ETRS89::UTMToETRS89($utm_ze, $utm_zn, $utm_x, $utm_y);
my @comments;
if (!$str_obj{"comm"}) {
$str_obj{'comm'} = _get_comments_obj();
}
if (!$comments_pos_net) {
eval {
$comments_pos_net = $str_obj{"comm"}->make_coord_to_pos
(sub {
my $cat = $_[0]->[Strassen::CAT];
$cat =~ /^(?:CS|[-+][12])/ ? 2 : 0;
});
}; warn $@ if $@;
}
if ($comments_pos_net && $str_obj{"comm"}) {
eval {
my($first, $second);
(undef,undef,$first,$second) = nearest_line_points_mouse($c);
$first = join(",",@$first);
$second = join(",",@$second);
if (defined $first && defined $second &&
$comments_pos_net->{"${first}_${second}"}) {
foreach my $pos (@{$comments_pos_net->{"${first}_${second}"}}) {
my $r = $str_obj{"comm"}->get($pos);
push @comments, $r->[Strassen::NAME];
}
}
}; warn $@ if $@;
}
my($area, $total_len);
if (defined $index && $index =~ /^\d+/) {
my $s = eval { get_any_strassen_obj("str", $base_tag) };
if (!$s) {
$s = get_any_strassen_obj("p", $base_tag);
}
if ($s) {
require Strassen::Stat;
my $r = $s->get($index);
# XXX bei weitem noch nicht perfekt: statt des Indexes sollte der
# NAME verwendet werden, um alle gleichnamigen Objekte zusammenzufassen
# Außerdem sind manche Gewässer gleichzeitig Seen und Flüsse (Havel), bei
# diesen sollten aus der Fläche eine vernünftige Länge berechnet werden
# und diese zu der normalen Länge dazuaddiert werden.
if ($r) {
if ($r->[Strassen::CAT()] =~ /^F:/) {
$area = Strassen::area($r) / 1_000_000;
#XXX Noch nicht --- siehe Kommentare in wasserstrassen-orig und data/Makefile
# # Inseln abziehen
# $s->set_index($index + 1);
# while(1) {
# my $r = $s->next;
# last if !@{ $r->[Strassen::COORDS] };
# last if $r->[Strassen::CAT] ne 'F:I';
# $area - Strassen::area($r) / 1_000_000;
# }
} else {
$total_len = Strassen::total_len($r) / 1_000;
}
}
}
}
my $show_info_sub = sub {
my(@txt_and_tag) = @_;
#my $tl_tag = "info-$base_tag"; # one window per canvas type
my $tl_tag = "info"; # one window for all
my $info_top = redisplay_top($top, $tl_tag,
-title => M"Information",
-class => "BbbikePassive",
);
if (defined $info_top) {
require Tk::ROText;
$info_text = $info_top->Scrolled('ROText',
-wrap => 'word',
-scrollbars => 'osoe',
-highlightthickness => 0,
-borderwidth => 0,
-width => 40,
-height => 10,
)->pack(-expand => 1, -fill => "both");
$info_text->tagConfigure("bold", -font => $font{'bold'});
$info_text->tagConfigure("fixed", -font => $font{'fixed'});
$info_top->Button(Name => 'close',
-command => sub { $info_top->destroy },
)->pack(-fill => "x");
toplevel_checker($info_top);
}
my $show_url = sub {
my($linkcount, $url) = @_;
$info_text->tagBind("link$linkcount", "<ButtonRelease-1>" => sub {
if (ref $url eq 'CODE') {
$url = $url->();
}
require WWWBrowser;
main::status_message("URL: $url", "info");
WWWBrowser::start_browser($url);
}
);
};
# Longest text for first column:
$info_text->configure(-tabs => [$info_text->fontMeasure($font{normal}, "Sonnenuntergang: ")]);
$info_text->delete("1.0", "end");
my $linkcount = 1;
for(my $i=0; $i<=$#txt_and_tag; $i+=2) {
my($txt, $tag) = @txt_and_tag[$i, $i+1];
for my $txtline (split /\n/, $txt) {
my $pos = 0;
while ($txtline =~ m{^(.*?)((?:ftp|https?)://\S+)}g) {
my($pre_text, $link_text) = ($1, $2);
$info_text->insert("end", $pre_text, $tag);
$info_text->insert("end", $link_text, "link$linkcount");
$show_url->($linkcount, $link_text);
$linkcount++;
$pos = pos($txtline);
}
$info_text->insert("end", substr($txtline, $pos), $tag);
$info_text->insert("end", "\n");
}
}
my $comment_label_end_index;
if (@comments) {
$info_text->insert("end", "\n\n" . M("Kommentare").": ", "bold");
$comment_label_end_index = $info_text->index("end - 1c");
$info_text->insert("end", "\t" . join("\n\t", @comments), "comments_text");
}
if (defined $area) {
$info_text->insert("end",
"\n\n" . M("Fläche") . ":", "bold",
sprintf("\t%.2f km²", $area) . M(" (ungefähr)"), undef); # XXX Msg
}
if (defined $total_len) {
$info_text->insert("end",
"\n\n" . M("Länge") . ":", "bold",
sprintf("\t%.2f km", $total_len) . M(" (ungefähr)"), undef); # XXX Msg
}
$info_text->insert("end", "\n\n" . M("Koordinaten") . "\n", "bold");
if (@polarcoord) {
$info_text->insert("end", M("Polar (DMS)") . ":\t$polarcoord[0]\n\t$polarcoord[1]\n");
}
if (@polarcoord2) {
$info_text->insert("end", M("Polar (DMM)") . ":\t$polarcoord2[0]\n\t$polarcoord2[1]\n");
}
if (defined $px && defined $py) {
$info_text->insert("end", M("Polar (DDD)") . ":\t$py\n\t$px\n");
}
if (defined $gkk_zone_potsdam) {
$info_text->insert("end", "GKK (Potsdam):\t[$gkk_zone_potsdam] $gkk_easting_potsdam/$gkk_northing_potsdam\n");
}
if (defined $gkk_zone_wgs84) {
$info_text->insert("end", "GKK (WGS 84):\t[$gkk_zone_wgs84] $gkk_easting_wgs84/$gkk_northing_wgs84\n");
}
if (defined $utm_ze) {
$info_text->insert("end", "UTM (WGS 84):\t[$utm_ze/$utm_zn] $utm_x/$utm_y\n");
}
if (defined $etrs_east) {
$info_text->insert("end", "ETRS 89:\t$etrs_east/$etrs_north\n");
}
$info_text->insert("end", "BBBike:\t$sx,$sy\n");
$info_text->insert("end", "\n");
$info_text->insert("end", "Links\n", "bold");
# Mapserver XXX move to function for creating URL
my @mapserver_def = ([$BBBike::BBBIKE_MAPSERVER_ADDRESS_URL,
"Mapserver"]);
if ($devel_host) {
push @mapserver_def, [defined $ENV{BBBIKE_TEST_CGIDIR} ? "$ENV{BBBIKE_TEST_CGIDIR}/mapserver_address.cgi" : "http://www/~eserte/bbbike/cgi/mapserver_address.cgi", "Lokaler Mapserver"];
}
my @mapext = $c->get_corners;
@mapext[0,1] = map { int } anti_transpose(@mapext[0,1]);
@mapext[2,3] = map { int } anti_transpose(@mapext[2,3]);
my @layers;
# XXX move mapping or this function to a config-like module
my @str_draw_mapping = ([w => "gewaesser"],
[f => "flaechen"],
[[qw(g gP gD)] => "grenzen"],
[[qw(u b r)] => "bahn"],
[[qw(qs ql)] => "qualitaet"],
[[qw(hs hl)] => "handicap"],
[rw => "radwege"],
[e => "faehren"],
[fz => "fragezeichen"],
[v => "sehenswuerdigkeit"],
);
my @p_draw_mapping = ([o => "orte"],
[lsa => "ampeln"],
[obst => "obst"],
[sperre => "blocked"],
);
for my $type (qw(str p)) {
my $mapping = $type eq 'str' ? \@str_draw_mapping : \@p_draw_mapping;
my $draw = $type eq 'str' ? \%str_draw : \%p_draw;
for my $check (@$mapping) {
my($abk, $ms_layer) = @$check;
my $doit;
if (ref $abk eq 'ARRAY') {
for (@$abk) {
if ($draw->{$_}) {
$doit = 1;
last;
}
}
} elsif ($draw->{$abk}) {
$doit = 1;
}
if ($doit) {
push @layers, $ms_layer;
}
}
}
# XXX maybe use Karte::trim_accuracy instead of int?
my $real_coords = join(",", map { int } anti_transpose($coords[0], $coords[1]));
for my $def (@mapserver_def) {
my $mapserver_url = $def->[0];
my $url = "$mapserver_url?coords=" . $real_coords;
$url .= ";mapext=" . join("+",@mapext);
if (@layers) {
$url .= ";" . join(";", map { "layer=$_" } @layers);
}
$info_text->insert("end", $def->[1], "link$linkcount");
warn "Mapserver URL: $url\n";
$show_url->($linkcount, $url);
$info_text->insert("end", "\n");
$linkcount++;
}
my @bbbike_cgi_def = ([$BBBike::BBBIKE_DIRECT_WWW,
"BBBike im WWW"]);
if ($devel_host) {
push @bbbike_cgi_def, [defined $ENV{BBBIKE_TEST_CGIDIR} ? "$ENV{BBBIKE_TEST_CGIDIR}/bbbike.cgi" : "http://www/~eserte/bbbike/cgi/bbbike.cgi", "BBBike im WWW, lokal"];
}
my $zielname = "";
{
my $is_first = 1;
for my $def (@bbbike_cgi_def) {
my $bbbike_cgi_url = $def->[0];
$info_text->insert("end", $def->[1], "link$linkcount");
$info_text->insert("end", " ");
if ($is_first) {
my $zielname_e = $info_text->Entry(-textvariable => \$zielname,
-width => 10);
$info_text->insert("end", " Zielname:");
$info_text->windowCreate("end", -window => $zielname_e);
$is_first = 0;
}
$show_url->($linkcount, sub {
require CGI;
# sigh, ";" still makes problems...
CGI->import('-oldstyle_urls');
my $q = CGI->new({zielc => $real_coords,
zielname => $zielname,
});
my $url = "$bbbike_cgi_url?" . $q->query_string;
$url;
});
$info_text->insert("end", "\n");
$linkcount++;
}
}
my($mapscale_scale) = $mapscale =~ /:\s*(\d+)/;
{
$info_text->insert("end", "Google Maps",
"link$linkcount");
$show_url->($linkcount, sub {
require CGI;
my $wpt = "$zielname!$sx,$sy";
my $zoom;
if ($mapscale_scale < 4000) {
$zoom = 0;
} elsif ($mapscale_scale < 8000) {
$zoom = 1;
} elsif ($mapscale_scale < 16000) {
$zoom = 2;
} else {
$zoom = 3;
}
my $q2 = CGI->new({ wpt => $wpt,
zoom => $zoom,
});
my $url = "http://www.radzeit.de/cgi-bin/bbbikegooglemap.cgi?" . $q2->query_string;
$url;
});
$info_text->insert("end", "\n");
$linkcount++;
}
{
my $y_wgs = (Karte::Polar::ddd2dmm($py))[1];
my $x_wgs = (Karte::Polar::ddd2dmm($px))[1];
my $zoom = "100";
if ($mapscale_scale) {
if ($mapscale_scale < 13000) {
$zoom = 100;
} elsif ($mapscale_scale < 18000) {
$zoom = 75;
} elsif ($mapscale_scale < 26000) {
$zoom = 50;
} else {
$zoom = 27;
}
}
my $url = "http://www.berliner-stadtplan.com/?y_wgs=${y_wgs}%27&x_wgs=${x_wgs}%27&zoom=$zoom&size=500x400&sub.x=15&sub.y=7";
$info_text->insert("end", "www.berliner-stadtplan.com",
"link$linkcount");
$show_url->($linkcount, $url);
$info_text->insert("end", "\n");
$linkcount++;
}
while(my($key, $plugin) = each %info_plugins) {
$info_text->insert("end", $plugin->{name} . "\n",
"link$linkcount");
$info_text->tagBind
("link$linkcount", "<ButtonRelease-1>" => sub {
$plugin->{callback}->(coords => $real_coords,
street => $strname);
});
$linkcount++;
}
# Das war der letzte Link
for (1 .. $linkcount) {
$info_text->tagConfigure("link$_", -underline => 1,
-foreground => "blue3");
$info_text->tagBind("link$_", "<Enter>" => sub {
$info_text->configure(-cursor => "hand2");
});
$info_text->tagBind("link$_", "<Leave>" => sub {
$info_text->configure(-cursor => undef);
});
}
eval {
require Astro::Sunrise;
Astro::Sunrise->VERSION(0.85);
my $get_sun_rise = sub {
my $alt = shift;
Astro::Sunrise::sun_rise($px,$py, $alt);
};
my $get_sun_set = sub {
my $alt = shift;
Astro::Sunrise::sun_set($px,$py, $alt);
};
my $sunrise_real = $get_sun_rise->();
my $sunrise_civil = $get_sun_rise->(-6);
my $sunrise_nautical = $get_sun_rise->(-12);
my $sunrise_astro = $get_sun_rise->(-15);
my $sunset_real = $get_sun_set->();
my $sunset_civil = $get_sun_set->(-6);
my $sunset_nautical = $get_sun_set->(-12);
my $sunset_astro = $get_sun_set->(-15);
$info_text->insert("end", "\nSonnenaufgang/-untergang\n", "bold");
$info_text->insert("end", <<EOF, "fixed");
Sonnenaufgang: $sunrise_real
Dämmerung ab:
bürgerliche: $sunrise_civil
nautische: $sunrise_nautical
astronomische: $sunrise_astro
Sonnenuntergang: $sunset_real
Dämmerung bis:
bürgerliche: $sunset_civil
nautische: $sunset_nautical
astronomische: $sunset_astro
EOF
};
warn $@ if $@;
if (defined &show_info_ext) {
eval {
my $txt = show_info_ext($c, @tags);
if (defined $txt) {
$info_text->insert("end", "$txt\n");
}
};
warn $@ if $@;
}
if (defined $comment_label_end_index) {
$info_text->update;
my @bbox = $info_text->bbox($comment_label_end_index);
$info_text->tagConfigure
("comments_text",
-lmargin2 => $bbox[0]-1-$info_text->cget(-bd)-$info_text->cget(-highlightthickness),
);
}
};
# XXX zu viel Code dupliziert!
my(%info, $info_file);
if (defined $str_file{$base_tag} && $str_file{$base_tag} =~ /\.shp$/) {
(my $dbf_file = $str_file{$base_tag}) =~ s/\.shp$/.dbf/;
require BBBikeAdvanced;
my $index;
for (@tags) {
if (/^$base_tag-(\d+)/) {
$index = $1;
last;
}
}
if (defined $index) {
my $dbf_info = get_dbf_info($dbf_file, $index);
if (defined $dbf_info) {
if (@tags > 3) {
my $text = splice @tags, 2, 1;
unshift @tags, $text, "";
}
$show_info_sub->("$dbf_info\n", undef,
"\nInterne Canvas-Tags:\n", "bold",
join("\n", @tags), undef);
return;
}
}
}
eval {
require DB_File;
require Fcntl;
if (!$is_p) {
if ($str_file{$base_tag} !~ m|^/|) {
$str_file{$base_tag} = "$datadir/$str_file{$base_tag}";
}
$info_file = $str_file{$base_tag} . "-info";
} else {
if ($p_file{$base_tag} !~ m|^/|) {
$p_file{$base_tag} = "$datadir/$p_file{$base_tag}";
}
$info_file = $p_file{$base_tag} . "-info";
}
};warn $@ if $@;
if ($info_file && tie %info, 'DB_File', $info_file, &Fcntl::O_RDONLY) {
warn "Use $info_file ...\n";
TRY:
{
foreach my $i (1 .. 4) {
if (defined $tags[$i]) {
if (defined $info{$tags[$i]}) {
$show_info_sub->("Info:\n", "bold",
$info{$tags[$i]});
last TRY;
}
if ($tags[$i] =~ /^L\d+-(\d+)/) {
my $id = $1;
foreach my $type (qw(s p)) {
if (defined $info{"$type-$id"}) {
$show_info_sub->("Info:\n", "bold",
$info{"$type-$id"});
last TRY;
}
}
}
}
}
$show_info_sub->("Interne Canvas-Tags:\n", "bold",
join("\n", @tags), undef);
}
untie %info;
} else {
if ($advanced) {
if (@tags > 3) {
my $text = splice @tags, 2, 1;
unshift @tags, $text, "";
}
$show_info_sub->("Interne Canvas-Tags:\n", "bold",
join("\n", @tags), undef);
} else {
if ($tags[0] =~ /^L\d+-(fg|img)$/) {
$show_info_sub->($tags[2]); # show name
} else { # maybe more special cases?
$show_info_sub->($tags[1]); # show name
}
}
}
}
### AutoLoad Sub
sub show_statistics {
my $update_statistics;
$update_statistics = sub {
# XXX some day $dataset should replace all of %str_obj etc.
$dataset = Strassen::Dataset->new if !$dataset;
my $res = BBBikeStats::calculate
(Route->new_from_realcoords(\@realcoords), $dataset);
BBBikeStats::tk_display_result
($top,$res,-markcommand => sub {
my($realcoordsref) = @_;
my @coordsref;
for (@$realcoordsref) {
push @coordsref, [ map { [transpose(split/,/,$_)] } @$_];
}
mark_street(-coords => \@coordsref,
-dont_center => 1);
},
-updatecommand => $update_statistics,
-reusewindow => 1,
);
};
IncBusy($top);
eval {
require BBBikeStats;
require Strassen::Dataset;
$update_statistics->();
};
my $err = $@;
DecBusy($top);
if ($err) {
return status_message(Mfmt("Fehler: %s", $err), "error");
}
}
### AutoLoad Sub
sub next_free_layer {
my $max_i = 1;
while($occupied_layer{"L$max_i"}) {
$max_i++;
}
for my $type (\%str_draw, \%p_draw) {
while(my($abk, $val) = each %$type) {
if ($val && $abk =~ /^L(\d+)/ && $1 >= $max_i) {
$max_i = $1+1;
while($occupied_layer{"L$max_i"}) {
$max_i++;
}
}
}
}
my $abk = "L$max_i";
reset_free_layer($abk);
$abk;
}
### AutoLoad Sub
sub reset_free_layer {
my $abk = shift;
delete $no_overlap_label{$abk};
remove_from_stack($abk);
}
### AutoLoad Sub
sub set_coord_output_sub {
my $_coord_output = shift;
if (defined $_coord_output) {
$coord_output = $_coord_output;
}
# XXX warum geht es mit keys, aber nicht mit each!!?!?!?!
foreach my $k (keys %Karte::map) {
#while(my($k,$v) = each %Karte::map) {
my $v = $Karte::map{$k};
#warn "$k => $v";
if ($coord_output eq $k) {
my $o = $Karte::map{$k};
if ($edit_mode) { # XXX find better conditional
my $from_o = $Karte::map{'berlinmap'}; # XXX don't hardcode, each edit_mode has its own map-token
if ($k eq 'polar') {
$coord_output_sub = sub {
my(@c) = map { $_ / $scale } transpose(@_);
@c = map { sprintf "%d°%02d'%05.2f\"", Karte::Polar::ddd2dms($_) } $from_o->can('map2map')->($from_o, $o, @c);
@c;
};
} else {
$coord_output_sub = sub {
my(@c) = map { $_ / $scale } transpose(@_);
@c = map { int } $from_o->can('map2map')->($from_o, $o, @c);
@c;
};
}
} else {
if ($k eq 'polar') {
$coord_output_sub = sub {
my(@c) = map { sprintf "%d°%02d'%05.2f\"", Karte::Polar::ddd2dms($_) } $o->can('standard2map')->($o, @_);
@c;
};
} else {
$coord_output_sub = sub {
# XXX int oder nicht int?
my(@c) = map { int } $o->can('standard2map')->($o, @_);
@c;
};
}
}
return;
}
}
if ($coord_output eq 'canvas') {
$coord_output_sub = sub {
my(@c) = transpose(@_);
map {
my $x = $_;
if ($without_zoom_factor) {
$x = $x / $scale;
}
if ($coord_output_int) {
$x = int $x;
}
$x;
} @c;
};
} elsif ($coord_output ne '') {
die "Unknown value for coordout: $coord_output";
}
}
# Fügt interaktiv die angeklickte Stelle in die Route (über die
# Funktion addpoint_xy) ein, erneuert die Kilometerangaben.
sub addpoint_inter {
## DEBUG_BEGIN
#benchbegin();
## DEBUG_END
my(@tags) = $c->gettags('current');
return if !@tags;
my $res;
if ($tags[0] eq 'pp' or $tags[0] =~ /^lsa/) {
$res = addpoint_xy(@{Strassen::to_koord1($tags[1])},
$c->coords('current'));
} elsif ($tags[0] eq 'o') {
$res = addpoint_xy(anti_transpose($c->coords('current')),
$c->coords('current'));
}
return if !defined $res;
updatekm();
set_flag('via');
set_flag('ziel');
# XXX only for slowcpu?
if (!($edit_mode || $edit_normal_mode)) {
# restack_delayed is very slow for many points, so disabled here...
restack_delayed();
update_route_strname();
}
## DEBUG_BEGIN
#benchend();
## DEBUG_END
}
# Eingaben: $x und $y als realcoords, $xx und $yy als Canvas-Koords
sub addpoint_xy {
my($x, $y, $xx, $yy) = @_;
## DEBUG_BEGIN
#benchbegin();
## DEBUG_END
if (!defined $xx) {
if ($coord_system ne 'standard') {
warn "NYI: non-standard map mode and not supplied $xx and $yy to addpoint_xy";
} else {
($xx, $yy) = transpose($x, $y);
}
}
my($deltax, $deltay, $etappe);
if (@realcoords != 0) {
($deltax, $deltay) = ($x - $realcoords[-1]->[0],
$y - $realcoords[-1]->[1]);
$etappe = sqrt(sqr($deltax) + sqr($deltay));
return undef if $etappe == 0; # keine leeren Etappen
# Fährstrecken von der Gesamtstrecke ausschließen:
CHECK_NO_FERRY: {
if ($net) {
my $xy0 = join(",", @{$realcoords[-1]});
my $xy1 = "$x,$y";
my $name = ((exists $net->{Net2Name}{$xy0} && $net->{Net2Name}{$xy0}{$xy1}) ||
(exists $net->{Net2Name}{$xy1} && $net->{Net2Name}{$xy1}{$xy0}));
if (defined $name && $name =~ /^Fähre /) {
last CHECK_NO_FERRY;
}
}
$strecke += $etappe;
}
}
my($prex, $prey);
push(@coords, [$xx, $yy]);
$nr++;
push(@realcoords, [$x, $y]);
if ($nr == 0) {
($prex, $prey) = ($xx, $yy);
} else {
($prex, $prey) = @{$coords[-2]};
}
my $hw;
$hw = BBBikeCalc::head_wind($deltax, $deltay) if $wind;
my $curr_line = $c->createLine
($prex, $prey, $xx, $yy,
-width => 5,
($route_arrowed ? (-arrow => "last") : ()),
# -dash and -capstyle don't work well together
($route_dashed ? (-dash => [4,5]) : (-capstyle => $capstyle_round)),
-tags => ['route', "route-$nr"]);
if ($nr == 0) {
set_flag('start');
}
# XXX auch hier müssten Fährstrecken ausgeschlossen werden... wie?
my $v_rel;
if ($bikepwr && $etappe) {
my $wind; # Berechnung des Gegenwindes
{
local $^W = 0;
if ($hw >= 2) {
$wind = -$wind_v;
} elsif ($hw > 0) { # unsicher beim Crosswind
$wind = -$wind_v*0.7;
} elsif ($hw > -2) {
$wind = $wind_v*0.7;
} else {
$wind = $wind_v;
}
}
# Verhältnis zwischen der möglichen Geschwindigkeit, die ohne
# Gegenwind und Steigung erreicht werden kann, und der tatsächlich
# erreichten
for(my $i = 0; $i <= $#power; $i++) {
# In diesem Abschnitt wird versucht, eine Steigung zu finden.
# Wenn %hoehe nicht eingelesen wurde, passiert nichts.
# Wenn die Höhen von beiden Etappenpunkten definiert ist, kann
# die Steigung trivial errechnet werden. Wenn nur die Höhe des
# Etappenzielpunktes bekannt ist, wird nachgeguckt, ob in den
# bisherigen Etappenstartpunkten die Höhe bekannt ist, und
# bei Erfolg eine Durchschnittssteigung errechnet.
my($prev_x, $prev_y) = @{$realcoords[-2]};
my $grade;
my @grade_symbol_pos;
my $prev_hoehe = $hoehe{"$prev_x,$prev_y"};
my $this_hoehe = $hoehe{"$x,$y"};
my $grade_length = $etappe;
if ($use_hoehe && defined $this_hoehe) {
if (defined $prev_hoehe) {
$grade = ($this_hoehe-$prev_hoehe)/$grade_length;
@grade_symbol_pos = (int(($xx-$prex)/2+$prex)+1,
int(($yy-$prey)/2+$prey)+1);
} else {
for(my $j = $#{$bikepwr_all_time[$i]}; $j >= 0; $j--) {
if (defined $bikepwr_all_time[$i]->[$j][3]) {
my @grade_line;
for(my $k = $j;
$k <= $#{$bikepwr_all_time[$i]}; $k++) {
$grade_length +=
$bikepwr_all_time[$i]->[$k][2];
push @grade_line, @{$coords[$k]};
}
push @grade_line, $prex, $prey, $xx, $yy;
@grade_symbol_pos = get_polyline_center(@grade_line);
# XXX ist $etappe (und damit $grade_length)
# immer != 0?
$grade =
($this_hoehe-$bikepwr_all_time[$i]->[$j][3])
/ $grade_length;
for(my $k = $j;
$k <= $#{$bikepwr_all_time[$i]}; $k++) {
$bikepwr_all_time[$i]->[$k][4] = $grade;
}
last;
}
}
}
}
# XXX möglicherweise Performance-Killer bei reverse_route()?
# Caching verwenden?
my($current_v, $current_C) = bikepwr_get_v($wind, $i, $grade);
if ($coloring eq 'power' && $i == 0) {
$v_rel = (bikepwr_get_v(0, $i, 0))[0] / $current_v;
}
my $bikepwr_time_etappe = $etappe / $current_v;
$bikepwr_time[$i] += $bikepwr_time_etappe;
my $bikepwr_cal_etappe = ($bikepwr_time_etappe
? $current_C*($bikepwr_time_etappe/3600)
: 0);
$bikepwr_cal[$i] += $bikepwr_cal_etappe;
if (defined %active_speed_power &&
$active_speed_power{Type} eq "power" &&
$i == $active_speed_power{Index}) {
if (!$nr) {
$route_time[0] = 0;
} else {
$route_time[$nr-1] = 0 if !defined $route_time[$nr-1];
$route_time[$nr]
= $route_time[$nr-1] + $bikepwr_time_etappe;
}
if (%ampeln && $ampeln{"$x,$y"}) {
$route_time[$nr] += $lost_time_per_ampel{X}; # XXX F...
}
}
my $grade_direction;
if ($show_grade && $i == 0) {
if (!defined $grade) {
make_comments_net() if !$comments_net;
if ($comments_net) {
for my $cat (@{ $comments_net->{Net}{"$prev_x,$prev_y"}{"$x,$y"} }) {
if ($cat =~ /^(St|Gf)/) {
$grade_direction = $1 eq 'St' ? +1 : -1;
last;
}
}
if ($grade_direction) {
@grade_symbol_pos = get_polyline_center($prex, $prey, $xx, $yy);
my $r = $comments_net->get_street_record("$prev_x,$prev_y",
"$x,$y");
if ($r && $r->[Strassen::NAME] =~ /(\d+)%/) {
$grade = $1 * $grade_direction;
}
$grade_length = Strassen::Util::strecke
([$prev_x,$prev_y],[$x,$y]);
}
}
}
if ((defined $grade &&
(($grade_length >= $grade_minimum_short_length && abs($grade) >= $grade_minimum) ||
($grade_length < $grade_minimum_short_length && abs($grade) >= $grade_minimum_short))) ||
(!defined $grade && defined $grade_direction)) {
$c->createImage
(@grade_symbol_pos,
-image => ((defined $grade_direction && $grade_direction > 0) || (defined $grade && $grade > 0) ? $steigung_photo : $gefaelle_photo),
-anchor => 's',
-tags => ['route', "route-$nr"],
);
if (defined $grade) {
outline_text($c,
@grade_symbol_pos,
-font => $font{'small'},
-text => float_prec($grade*100, 1) . '%',
-tags => ['route', "route-$nr"],
-outlinewidth => 1,
-anchor => 'nw');
}
}
}
# Format einer Etappe von @bikepower_all_time
# 0: Zeit für die jeweilige Etappe
# 1: Gegenwindgeschwindigkeit (crosswind mit eingerechnet)
# 2: Länge der Etappe
# 3: Höhe des Etappenstartpunktes
# 4: Steigung der Etappe
# 5: Kalorienverbrauch
my @etappe_def = ($bikepwr_time_etappe, $wind, $etappe,
$prev_hoehe, $grade, $bikepwr_cal_etappe);
push(@{$bikepwr_all_time[$i]}, \@etappe_def);
# XXX bikepwr_all_time in dieser Form
# ist eigentlich ineffizient, da nur
# die Zeit für die verschiedenen "Power"s unterschiedlich ist,
# die anderen Daten aber alle gleich.
}
}
if (defined %active_speed_power &&
$active_speed_power{Type} eq "speed") {
my $i = $active_speed_power{Index};
if (!$nr) {
$route_time[$nr] = 0;
} else {
$route_time[$nr-1] = 0 if !defined $route_time[$nr-1];
$route_time[$nr]
= $route_time[$nr-1] + ($etappe / 1000) / $speed[$i] * 3600;
}
if (%ampeln && $ampeln{"$x,$y"}) {
$route_time[$nr] += $lost_time_per_ampel{X}; # XXX F ...
}
}
my $col;
if ($coloring eq 'power' && defined $v_rel) {
if ($v_rel >= 2) { $col = $wind_colors{-2}->[WIND_COLOR_NAME] }
elsif ($v_rel >= 1.3) { $col = $wind_colors{-1}->[WIND_COLOR_NAME] }
elsif ($v_rel >= 0.77) { $col = $wind_colors{0}->[WIND_COLOR_NAME] }
elsif ($v_rel >= 0.5) { $col = $wind_colors{1}->[WIND_COLOR_NAME] }
else { $col = $wind_colors{2}->[WIND_COLOR_NAME] }
} elsif ($wind && $coloring eq 'wind') {
$col = $wind_colors{$hw}->[WIND_COLOR_NAME];
} elsif ($coloring =~ /^(wind|power)$/) {
$col = 'red';
} else {
$col = $coloring; # red oder blue
}
$c->itemconfigure($curr_line, -fill => $col) if defined $col;
if (!$nr) {
$route_distance[0] = 0;
} else {
$route_distance[$nr-1] = 0 if !defined $route_distance[$nr-1];
$route_distance[$nr] = $route_distance[$nr-1] + $etappe;
}
## DEBUG_BEGIN
#benchend();
## DEBUG_END
1;
}
### AutoLoad Sub
sub get_route_color {
my($value, $min_value, $max_value, $min_index, $max_index) = @_;
# my $r = $wind_color{$min_value}
}
### AutoLoad Sub
sub set_flag {
my($type, $x, $y, $leaveold) = @_;
$c->delete($type . 'flag') unless $leaveold;
if ($do_flag{$type} && $flag_photo{$type}) {
if ($type eq 'start' && !defined $x) {
($x, $y) = @{$coords[0]};
} elsif ($type eq 'ziel') {
return if (@coords < 2);
($x, $y) = @{$coords[-1]};
} elsif ($type eq 'via') {
require BBBikeVia; # XXX should not be necessary
BBBikeVia::show_via_flags();
return;
}
# XXX $nr may or may not be meaningful here
$c->createImage($x, $y, -image => $flag_photo{$type},
-tags => ['route', "route-$nr", $type . 'flag']);
}
}
sub skalarprodukt {
my($a1, $a2, $b1, $b2) = @_;
$a1*$b1 + $a2*$b2;
}
# Eingabe: Gerade mit zwei Endpunkten (Q und R) und Punkt P
# Ausgabe: Fußpunkt des Lotes vom Punkt auf die Gerade
sub fusspunkt {
my($q1, $q2, $r1, $r2, $p1, $p2) = @_;
my($a1, $a2) = ($r1-$q1, $r2-$q2); # Richtungsvektor berechnen
my $a_sqr = skalarprodukt($a1, $a2, $a1, $a2);
return undef if $a_sqr == 0;
my $zaehler = skalarprodukt($p1-$q1, $p2-$q2, $a1, $a2);
my $t_f = $zaehler / $a_sqr;
($q1 + $t_f * $a1, $q2 + $t_f * $a2);
}
### AutoLoad Sub
sub recalc_bikepwr {
$power_cache = {};
for(my $i = 0; $i <= $#power; $i++) {
$bikepwr_time[$i] = 0;
$bikepwr_cal[$i] = 0;
foreach (@{$bikepwr_all_time[$i]}) {
my $wind = $_->[1];
my $grade = $_->[4];
my($v, $C) = bikepwr_get_v($wind, $i, $grade, $power_cache);
my $bikepwr_time_etappe = ($_->[2] / $v);
$bikepwr_time[$i] += $bikepwr_time_etappe;
my $bikepwr_cal_etappe = ($bikepwr_time_etappe
? $C*($bikepwr_time_etappe/3600)
: 0);
$bikepwr_cal[$i] += $bikepwr_cal_etappe;
$_->[0] = $bikepwr_time_etappe;
$_->[5] = $bikepwr_cal_etappe;
}
}
undef $power_cache;
}
### AutoLoad Sub
sub set_corresponding_power {
@power = ();
for(my $i = 0; $i<=$#speed; $i++) {
my $bp_speed = new BikePower;
$bp_speed->given('v');
$bp_speed->velocity($speed[$i]/3.6);
$bp_speed->calc;
push @power, int($bp_speed->power);
}
if (!@power) {
@power = (50, 100);
}
}
### AutoLoad Sub
sub redraw_path {
destroy_delayed_restack();
IncBusy($top);
eval {
my @oldcoords = @coords;
my @oldrealcoords = @realcoords;
my @oldsearchroutepoints = @search_route_points; # hack
resetroute();
$power_cache = {};
my $i;
for($i = 0; $i <= $#oldcoords; $i++) {
addpoint_xy(@{$oldrealcoords[$i]}, @{$oldcoords[$i]});
}
@search_route_points = @oldsearchroutepoints;
undef $power_cache;
set_flag('via');
set_flag('ziel');
updatekm();
restack_delayed();
};
DecBusy($top);
}
# Einfaches Umdrehen der Route (kein echter Rückweg!)
### AutoLoad Sub
sub reverse_route {
destroy_delayed_restack();
IncBusy($top);
eval {
my @newcoords = reverse @coords;
my @newrealcoords = reverse @realcoords;
@search_route_points = reverse @search_route_points;
resetroute();
$power_cache = {};
my $i;
for($i = 0; $i <= $#newcoords; $i++) {
addpoint_xy(@{$newrealcoords[$i]}, @{$newcoords[$i]});
}
undef $power_cache;
set_flag('via');
set_flag('ziel');
updatekm();
if ($show_strlist) {
show_route_strname();
}
restack_delayed();
};
warn __LINE__ . ": $@" if $@;
DecBusy($top);
}
# Echte Berechnung des Rückwegs
### AutoLoad Sub
sub way_back {
return if @search_route_points < 2;
@search_route_points = reverse @search_route_points;
for(my $i=$#search_route_points-1; $i >= 0; $i--) {
$search_route_points[$i+1]->[SRP_TYPE] = $search_route_points[$i]->[SRP_TYPE];
}
$search_route_points[0]->[SRP_TYPE] = POINT_MANUELL;
re_search(-undo => 0);
update_route_strname();
}
### AutoLoad Sub
sub way_back_gui {
IncBusy($top);
eval { way_back() };
warn $@ if $@;
DecBusy($top);
}
sub delete_route {
reset_button_command();
if (@inslauf_selection || @ext_selection) {
require BBBikeAdvanced;
reset_selection();
}
update_route_strname(); # XXX => hook
if ($map_mode =~ m{^(MM_VIA_MOVE
|MM_GOAL_MOVE
|MM_VIA_ADD
|MM_VIA_ADD_THEN_MOVE
|MM_VIA_DEL
)$}x) {
set_map_mode(MM_SEARCH);
}
Hooks::get_hooks("del_route")->execute;
}
### XXX problems, see above
# sub delete_route_gui_toggle {
# my $menu_index = shift;
# delete_route();
# $top->Subwidget(PopupMenu)->entryconfigure
# ($menu_index,
# -label => M"Route wiederherstellen (Undo)",
# -command => sub { get_undo_route_gui_toggle($menu_index) }
# );
# }
# sub get_undo_route_gui_toggle {
# my $menu_index = shift;
# get_undo_route();
# $top->Subwidget(PopupMenu)->entryconfigure
# ($menu_index,
# -label => M"Route löschen",
# -command => sub { delete_route_gui_toggle($menu_index) }
# );
# }
# Hierfür nicht Autoload verwenden, weil es sonst *langsam* wird!
sub bikepwr_get_v { # Resultat in m/s
my($wind, $i, $grade) = @_;
if (!defined $bp_obj) {
die "bp_obj ist nicht definiert";
}
$grade = 0 if !defined $grade;
if (defined $power_cache and
exists $power_cache->{$wind}{$i}{$grade}) {
return @{ $power_cache->{$wind}{$i}{$grade} };
}
$bp_obj->grade($grade);
$bp_obj->headwind($wind);
$bp_obj->power($power[$i]);
$bp_obj->calc();
my $v = $bp_obj->velocity;
my $C = $bp_obj->consumption;
if (defined $power_cache) {
$power_cache->{$wind}{$i}{$grade} = [$v, $C];
}
($v, $C);
}
# löscht den letzten Punkt der Route aus @coords und Routenlinie
### AutoLoad Sub
sub dellast {
my $no_update = shift;
if (@realcoords) {
if ($bikepwr) {
for(my $i=0; $i <= $#power; $i++) {
my $etappe_def = pop(@{$bikepwr_all_time[$i]});
if (ref $etappe_def eq 'ARRAY') {
$bikepwr_time[$i] -= $etappe_def->[0];
$bikepwr_cal[$i] -= $etappe_def->[5];
}
}
#for(my $i=0; $i <= $#speed; $i++) {
#XXX $bikepwr_cal_spd[$i] -= $etappe_def->[6];
#}
}
@act_search_route = (); # XXX performance hit bei langen Strecken
pop @coords;
my $ref = pop @realcoords;
my $x = $ref->[0];
my $y = $ref->[1];
my $xy = "$x,$y";
if (@realcoords) {
# Fährstrecken ausschließen
CHECK_NO_FERRY: {
if ($net) {
my $xy0 = join(",", @{$realcoords[-1]});
my $name = $net->{Net2Name}{$xy0}{$xy} ||
$net->{Net2Name}{$xy}{$xy0};
if (defined $name && $name =~ /^Fähre /) {
last CHECK_NO_FERRY;
}
}
$strecke -= sqrt(sqr($realcoords[-1]->[0] - $x) +
sqr($realcoords[-1]->[1] - $y));
}
}
# Via löschen, und zwar im aktuellen und im vorherigen Punkt ???
if (@search_route_points) {
my $last_via = $search_route_points[-1]->[SRP_COORD];
if ($xy eq $last_via) {
pop @search_route_points;
}
}
$c->delete("route-$nr");
$nr--;
unless ($no_update) {
update_flags_and_route();
}
}
}
sub update_flags_and_route {
set_flag('via');
set_flag('ziel');
updatekm();
if (!@coords) {
undef $search_route_flag;
search_route_mouse(1);
}
update_route_strname();
}
### AutoLoad Sub
sub dellast_selection {
if (@inslauf_selection) {
pop @inslauf_selection;
if ($use_clipboard) {
$c->clipboardClear;
$c->clipboardAppend(" " . join(" ", @inslauf_selection));
}
}
}
# bis zum letzten Via löschen
### AutoLoad Sub
sub deltovia {
return if !@realcoords || !@search_route_points;
# Zuerst wird überprüft, ob der letzte Punkt ein Via-Punkt ist. In
# diesem Fall wird diese Tatsache ignoriert und der Punkt wird
# gelöscht.
my $via = $search_route_points[-1]->[SRP_COORD];
my($x, $y) = @{ $realcoords[-1] };
my $xy = "$x,$y";
if ($xy eq $via) {
dellast();
}
return if !@realcoords;
return if (!@search_route_points);
$via = $search_route_points[-1]->[SRP_COORD];
for(my $i = $#realcoords; $i >= 0; $i--) {
my($x, $y) = @{ $realcoords[$i] };
my $xy = "$x,$y";
if ($xy eq $via) {
update_flags_and_route();
return;
} else {
dellast(1);
}
}
}
# Ausgabe der aktuellen Routenlänge
sub updatekm {
return if !@realcoords;
my $lost_time_s;
if (%ampeln) {
my $ampel_count = 0;
foreach (@realcoords) {
if ($ampeln{$_->[0].",".$_->[1]}) {
$ampel_count++;
}
}
if ($ampel_count == 0) {
$ampelstatus_label_text = M"Keine Ampeln";
} else {
$lost_time_s = $ampel_count*$lost_time_per_ampel{X}; # XXX F ...
$ampelstatus_label_text =
"$ampel_count " .
($ampel_count > 1 ? M"Ampeln" : M"Ampel") .
" (-" . s2ms($lost_time_s) . " min)";
}
} else {
$ampelstatus_label_text = "";
}
my $lost_time_tragen_s = 0;
my $lost_time_narrowpassage_s = 0;
if (%sperre_tragen || %sperre_narrowpassage) {
my $tragen_count = 0;
foreach (@realcoords) {
my $c = $_->[0].",".$_->[1];
if (exists $sperre_tragen{$c}) {
$lost_time_tragen_s += $sperre_tragen{$c};
$tragen_count++;
} elsif (exists $sperre_narrowpassage{$c}) {
$lost_time_narrowpassage_s += $sperre_narrowpassage{$c};
# XXX don't count
}
}
if ($lost_time_tragen_s) {
$ampelstatus_label_text .=
"\n" .
Mfmt("%dx tragen", $tragen_count) .
" (-" . s2ms($lost_time_tragen_s) . " min)";
}
}
my @time;
for(my $i = 0; $i <= $#speed; $i++) {
# XXX implement something similar for "power", too!
if ($kopfstein_count->{"speed"}[$i]) {
make_handicap_net();
make_qualitaet_net();
$time[$i] = 0;
if ($#realcoords > 0) {
for(my $ii=0; $ii<$#realcoords; $ii++) {
my $s = Strassen::Util::strecke($realcoords[$ii],$realcoords[$ii+1]);
my @etappe_speeds = $speed[$i];
if ($qualitaet_s_net && (my $cat = $qualitaet_s_net->{Net}{join(",",@{$realcoords[$ii]})}{join(",",@{$realcoords[$ii+1]})})) {
push @etappe_speeds, $qualitaet_s_speed{$cat}
if defined $qualitaet_s_speed{$cat};
}
if ($handicap_s_net && (my $cat = $handicap_s_net->{Net}{join(",",@{$realcoords[$ii]})}{join(",",@{$realcoords[$ii+1]})})) {
push @etappe_speeds, $handicap_s_speed{$cat}
if defined $handicap_s_speed{$cat};
}
$time[$i] += ($s/1000)/min(@etappe_speeds);
}
}
} else {
$time[$i] = ($strecke / 1000) / $speed[$i];
}
}
my $dir_strecke =
sqrt(sqr($realcoords[0]->[0] - $realcoords[-1]->[0]) +
sqr($realcoords[0]->[1] - $realcoords[-1]->[1]));
if ($unit_km eq 'm') {
$act_value{Km} = sprintf "%d", $scale_coeff * $strecke;
} else {
$act_value{Km} = float_prec($scale_coeff * $strecke/1000, 1);
}
$act_value{Percent} = ($dir_strecke != 0
? do {
my $p = int(($strecke/$dir_strecke)*100)-100;
# wenn 1000% erreicht sind, ist es sicher
# eine Rundfahrt, und da ist eine Prozent-
# angabe unsinnig
$p < 1000 ? $p : "";
}
: "");
for(my $i = 0; $i <= $#speed; $i++) {
my $time = $time[$i] +
(defined $lost_time_s && $ampel_count->{"speed"}[$i]
? $lost_time_s/3600 : 0);
$time += ($lost_time_tragen_s+$lost_time_narrowpassage_s)/3600;
$act_value{Time}->[$i] = h2hm($time) . " h";
}
if ($bikepwr) {
for(my $i = 0; $i <= $#power; $i++) {
my $h = int($bikepwr_time[$i]/3600);
my $m = int(($bikepwr_time[$i] - $h*3600) / 60);
my $time = $bikepwr_time[$i] +
(defined $lost_time_s && $ampel_count->{"power"}[$i]
? $lost_time_s : 0);
$time += ($lost_time_tragen_s+$lost_time_narrowpassage_s)/3600;
$act_value{PowerTime}->[$i] = s2hm($time) . " h";
if (!$edit_mode && !$edit_normal_mode) {
$calories_power[$i] = float_prec($bikepwr_cal[$i], 1);
} else {
$calories_power[$i] = undef;
}
}
#XXX
# for(my $i = 0; $i <= $#speed; $i++) {
# if (!$edit_mode && !$edit_normal_mode) {
# $calories_speed[$i] = float_prec($bikepwr_cal_spd[$i], 1);
# } else {
# $calories_speed[$i] = undef;
# }
# }
}
# XXX hier?
Hooks::get_hooks("new_route")->execute;
}
# löscht die Route (Liste und Linie)
sub resetroute {
$strecke = 0;
$act_value{Km} = "";
$act_value{Percent} = "";
for(my $i = 0; $i <= $#speed; $i++) {
$act_value{Time}->[$i] = "";
#XXX $bikepwr_cal_spd[$i] = 0;
}
@realcoords = @coords = @search_route_points = ();
if ($bikepwr) {
for(my $i = 0; $i <= $#power; $i++) {
@{$bikepwr_all_time[$i]} = ();
$bikepwr_time[$i] = 0;
$bikepwr_cal[$i] = 0;
$act_value{PowerTime}->[$i] = "";
}
}
$ampelstatus_label_text = "";
$c->delete('route');
$nr = -1;
$next_is_undo = 0;
@act_search_route = ();
update_route_strname();
if (@inslauf_selection || @ext_selection) {
require BBBikeAdvanced;
reset_selection();
}
}
sub reset_undo_route {
if (@realcoords) {
save_route_to_register(0);
}
resetroute();
}
### AutoLoad Sub
sub get_undo_route {
get_route_from_register(0);
}
### AutoLoad Sub
sub save_route_to_register {
my($register) = @_;
my $r = {};
$r->{RealCoords} = [@realcoords];
$r->{SearchRoutePoints} = [@search_route_points];
if ($bikepwr) {
for(my $i = 0; $i <= $#power; $i++) {
if (defined $bikepwr_all_time[$i]) {
@{ $r->{BikepwrAllTime}[$i] } = @{ $bikepwr_all_time[$i] }
}
$r->{BikepwrTime}[$i] = $bikepwr_time[$i];
$r->{BikepwrCal}[$i] = $bikepwr_cal[$i];
}
# for(my $i = 0; $i <= $#speed; $i++) {
# $r->{BikepwrCalSpd}[$i] = $bikepwr_cal_spd[$i];
# }
}
$r->{Nr} = $nr;
$save_route{$register} = $r;
}
# Return false if there is no route in this register.
### AutoLoad Sub
sub get_route_from_register {
my($register) = @_;
if (!$save_route{$register}) {
return 0;
}
my $r = $save_route{$register};
@realcoords = @{ $r->{RealCoords} };
realcoords2coords();
@search_route_points = @{ $r->{SearchRoutePoints} };
restore_search_route_points();
if ($bikepwr) {
for(my $i = 0; $i <= $#power; $i++) {
if (defined $r->{BikepwrAllTime}[$i]) {
@{ $bikepwr_all_time[$i] } = @{ $r->{BikepwrAllTime}[$i] }
}
$bikepwr_time[$i] = $r->{BikepwrTime}[$i];
$bikepwr_cal[$i] = $r->{BikepwrCal}[$i];
}
# for(my $i = 0; $i <= $#speed; $i++) {
# $bikepwr_cal_spd[$i] = $r->{BikepwrCalSpd}[$i];
# }
}
$nr = $r->{Nr};
redraw_path();
update_route_strname();
1;
}
sub restore_search_route_points {
if ($net) {
for (@search_route_points) {
add_new_point($net, $_->[SRP_COORD], -quiet => 1);
}
}
}
sub set_canvas_scale {
my $s = shift;
$scale = $s;
eval { set_canvas_scale_XS($s) };
create_transpose_subs();
}
### AutoLoad Sub
sub scalecanvas {
my($c, $scalefactor, $x, $y, %args) = @_;
my(@oldx) = $c->xview;
my(@oldy) = $c->yview;
my($xwidth) = $oldx[1]-$oldx[0];
my($ywidth) = $oldy[1]-$oldy[0];
my($sr_x0, $sr_y0, $sr_x1, $sr_y1) = ($Tk::VERSION == 800.017
? $c->cget(-scrollregion)
: @{$c->cget(-scrollregion)});
my($rx,$ry);
if (defined $x && defined $y) {
($rx, $ry) = ($c->rootx + $c->widgetx($x),
$c->rooty + $c->widgety($y));
}
# Initialisieren (muss als erstes kommen)
show_zoomrect() if $scalefactor < 1 and not $args{-fast};
IncBusy($top);
eval {
my $old_scale = $scale;
set_canvas_scale($scale * $scalefactor);
$c->scale('all', 0, 0, $scalefactor, $scalefactor);
calc_mapscale();
scale_width($c, $scale, $old_scale);
change_category_visibility($c, $scale, $old_scale);
foreach (@scrollregion) { $_ *= $scalefactor }
$c->configure(-scrollregion => \@scrollregion);
foreach (@coords) {
$_->[0] *= $scalefactor;
$_->[1] *= $scalefactor;
}
foreach (@route_strnames) {
$_->[1] *= $scalefactor;
$_->[2] *= $scalefactor;
}
scale_maps($scalefactor);
if (defined $x && defined $y) {
# preserve position under cursor
$c->scroll_canvasxy_to_rootxy($x*$scalefactor,$y*$scalefactor,$rx,$ry);
} else {
# in die Mitte des vorherigen Ausschnitts positionieren
$c->xview('moveto' => $oldx[0]+($xwidth-$xwidth/$scalefactor)/2);
$c->yview('moveto' => $oldy[0]+($ywidth-$ywidth/$scalefactor)/2);
}
overview_update();
};
warn $@ if $@;
DecBusy($top);
# Zoomrect starten
show_zoomrect(1) if $scalefactor < 1 and not $args{-fast};
Hooks::get_hooks("after_resize")->execute($scalefactor);
}
### AutoLoad Sub
sub scale_width {
my($c, $scale, $old_scale) = @_;
# XXX scale obst (mehrere Icon-Größen)
foreach my $type
(qw(s-BAB sBAB-BAB s-HH s-B s-H s-N s-NN
SBAB-BAB-out s-HH-out s-B-out s-H-out s-N-out s-NN-out
rw
w-W w-W0 w-W1 w-W2 w-W-out w-W0-out w-W1-out w-W2-out wr
l l-out u b r pp p z g gP gD fz
sperre0 sperre1 sperre1s sperre2)) {
eval {
CHANGE: {
my $new_width = get_line_width($type, $scale);
if (defined $old_scale) {
my $old_width = get_line_width($type, $old_scale);
last CHANGE if ($new_width == $old_width);
}
if ($type =~ /^(sperre|fz)/) {
# special handling to filter out images:
foreach my $item ($c->find("withtag", $type)) {
$c->itemconfigure($item, -width => $new_width)
unless $c->type($item) eq 'image';
}
} elsif ($type =~ /^w-.*-out$/) {
foreach my $item ($c->find("withtag", $type)) {
$c->itemconfigure($item, -width => $new_width)
unless $c->type($item) eq 'polygon';
}
} else {
$c->itemconfigure($type, -width => $new_width);
}
}
};
if ($@) {
warn "Error while configuring $type in scale_width: $@";
}
}
foreach my $sperre_type (qw(sperre1 sperre1s sperre2)) {
my $new_width = get_line_width($sperre_type);
my $old_width = get_line_width($sperre_type, $old_scale);
if ($new_width != $old_width) {
foreach my $item ($c->find("withtag", $sperre_type)) {
if ($c->type($item) ne 'image') {
$c->itemconfigure
($item,
-fill => ($new_width == 0
? undef : $category_color{$sperre_type}));
}
}
}
##XXX Works, but maybe it's better to put the code snippets of
##plot_sperre into strings to be evaled, used in plot_sperre
##and re-used here.
if ($sperre_type =~ /^sperre[12]/) {
my $new_length = get_line_length($sperre_type);
my $old_length = get_line_length($sperre_type, $old_scale) * $scale/$old_scale;
if ($old_length) { # XXX when may $old_length be 0?
my $f = $new_length / $old_length;
foreach my $item ($c->find("withtag", $sperre_type)) {
if ($c->type($item) ne 'image') {
my($x1,$y1,$x2,$y2) = $c->coords($item);
my($xm,$ym) = (($x2+$x1)/2, ($y2+$y1)/2);
my $xd1 = $x1-$xm;
my $xd2 = $x2-$xm;
my $yd1 = $y1-$ym;
my $yd2 = $y2-$ym;
$c->coords($item,
$xm+$xd1*$f, $ym+$yd1*$f,
$xm+$xd2*$f, $ym+$yd2*$f,
);
}
}
}
}
}
foreach (qw(lsa-X lsa-B lsa-F lsa-Zbr rest kn vf)) {
$c->itemconfigure($_ . '-fg', -image => get_symbol_scale($_, $scale));
}
foreach (qw(e)) {
$c->itemconfigure($_ . '-img', -image => get_symbol_scale($_, $scale));
}
# XXX ... nur ändern, falls sich die Skalierung ändert... (wie oben)
# XXX arrowshape von sperre1 ändern
my %arg = get_symbol_scale('b');
$c->itemconfigure('b-bg', -width => $arg{-width});
$c->itemconfigure('r-bg', -width => $arg{-width});
$c->itemconfigure("b-fg",
-text => (defined $arg{-font} ? 'S' : ''),
(defined $arg{-font} ? (-font => $arg{-font}) : ()),
);
$c->itemconfigure("r-fg",
-text => (defined $arg{-font} ? 'R' : ''),
(defined $arg{-font} ? (-font => $arg{-font}) : ()),
);
%arg = get_symbol_scale('u');
$c->itemconfigure('u-bg', -width => $arg{-width});
$c->itemconfigure("u-fg",
-text => (defined $arg{-font} ? 'U' : ''),
(defined $arg{-font} ? (-font => $arg{-font}) : ()),
);
foreach my $tag ($c->find('withtag', 'u-bg')) {
my($x1,$y1,$x2,$y2) = $c->coords($tag);
# work around 800.0_16-to-be bug
if (ref $x1 eq 'ARRAY') { ($x1,$y1,$x2,$y2) = @{ $c->coords($tag) } }
my $xm = ($x2-$x1)/2+$x1;
$c->coords($tag, $xm-$arg{-width}/2, $y1, $xm+$arg{-width}/2, $y2);
}
# rearrange outline_text
# XXX performance is quite bad (about 0.6s for all U+S-Bahnhöfe)
## DEBUG_BEGIN
#benchbegin("Repositioning labels");
## DEBUG_END
foreach my $item ($c->find(withtag => 'outlmaster')) {
my($x,$y) = $c->coords($item);
my $outline_width = 1;
my $outl_i;
for ($c->gettags($item)) {
if (/^outlmaster-width-(\d+)/) {
$outline_width = $1;
} elsif (/^outlmaster-(\d+)/) {
$outl_i = $1;
}
}
if (defined $outl_i) {
# XXX the second version is a hack, but faster
# foreach my $slave ($c->find(withtag => "outlslave-$outl_i")) {
foreach my $slave ($item-(4*$outline_width)..$item-1) {
# assuming last tag is outldata_$x_$y tag
my @outldata = split /_/, (($c->gettags($slave))[-1]);
$c->coords($slave, $x+$outldata[1],$y+$outldata[2]);
}
}
}
## DEBUG_BEGIN
#benchend();
## DEBUG_END
foreach my $item ($c->find(withtag => 'strnr')) {
my $master = ($c->gettags($item))[2];
$master =~ s/^strnr-//;
my(@bbox) = $c->bbox($master);
$c->coords($item, $bbox[0]-2,$bbox[1]-2,$bbox[2]+2,$bbox[3]+2);
}
for my $o_cat (MIN_ORT_CAT .. MAX_ORT_CAT) {
my $font = get_orte_label_font($o_cat);
$c->itemconfigure("O$o_cat", -font => $font);
}
while(my($name,$scalecommand) = each %scalecommand) {
warn "Scale for $name...\n";
$scalecommand->($name, $c, $scale, $old_scale);
}
}
### AutoLoad Sub
sub change_place_visibility {
my($c, $new_scale) = @_;
# XXX genaue Version für dash patches rauskriegen
return if $Tk::VERSION < 800.021;
$new_scale = $scale unless defined $new_scale;
if ($place_category eq 'auto') {
my $eff_place_category;
if ($new_scale > 0.5) {
$eff_place_category = 0;
} elsif ($new_scale > 0.25) {
$eff_place_category = 1;
} elsif ($new_scale > 0.18) {
$eff_place_category = 2;
} elsif ($new_scale > 0.125) {
$eff_place_category = 3;
} elsif ($new_scale > 0.03125) {
$eff_place_category = 4;
} else {
$eff_place_category = 5;
}
if ($eff_place_category > 0) {
for my $cat (0 .. $eff_place_category-1) {
$c->itemconfigure("O$cat", -state => "hidden");
$c->itemconfigure("OP$cat", -state => "hidden");
}
}
for my $cat ($eff_place_category .. 5) {
$c->itemconfigure("O$cat", -state => "normal");
$c->itemconfigure("OP$cat", -state => "normal");
}
}
}
### AutoLoad Sub
sub change_label_visibility {
my($c, $new_scale, $old_scale) = @_;
# XXX genaue Version für dash patches rauskriegen
return if $Tk::VERSION < 800.021;
$new_scale = $scale unless defined $new_scale;
my @tags = qw(b-label u-label v-fg);
if ($old_scale >= 1.5 && $new_scale <= 1.5) {
# make hidden
for (@tags) { $c->itemconfigure($_, -state => "hidden") }
} elsif ($old_scale < 1.5 && $new_scale >= 1.5) {
# make visible
for (@tags) { $c->itemconfigure($_, -state => "normal") }
}
}
### AutoLoad Sub
sub change_category_visibility {
my($c, $scale, $old_scale) = @_;
change_place_visibility($c, $scale);
change_label_visibility($c, $scale, $old_scale);
return 1;
#XXXXXXXXXXXX enable
# use tag_invisible for plotstr/plotp
# insert a checkbutton fot auto_visible
# str_restrict: don't set restriction on StrassenNetz
for my $tag (keys %tag_visibility) {
my $old_def = $tag_invisible{$tag};
if ($scale <= $tag_visibility{$tag}) {
$tag_invisible{$tag} = 1;
} else {
$tag_invisible{$tag} = 0;
}
if (defined $old_def && $old_def != $tag_invisible{$tag}
&& $auto_visible) {
if ($tag =~ /^([^-]+-[^-]+)/) {
pending(1, "replot-$1");
}
}
}
}
sub get_index_by_scale {
my $myscale = shift;
if ($myscale < 0.5) {
0;
} elsif ($myscale < 1) {
1;
} elsif ($myscale < 2) {
2;
} elsif ($myscale < 5) {
3;
} elsif ($myscale < 10) {
4;
} else {
5;
}
}
sub get_line_width {
my($tag, $myscale) = @_;
$myscale = $scale if !defined $myscale;
my $is_outline = ($tag =~ /-out$/);
my $add_outline = ($is_outline
? 2 : ($tag eq 'pp' || $tag eq 'p' ? 1 : 0));
my $index = get_index_by_scale($myscale);
if ($is_outline && !exists $line_width{$tag}) {
$tag =~ s/-out$//;
}
$line_width{(exists $line_width{$tag} ? $tag : 'default')}->[$index]
+ $add_outline;
}
sub get_line_length {
my($tag, $myscale) = @_;
$myscale = $scale if !defined $myscale;
my $index = get_index_by_scale($myscale);
$line_length{(exists $line_length{$tag} ? $tag : 'default')}->[$index];
}
sub get_symbol_scale {
my($tag, $myscale) = @_;
$myscale = $scale if !defined $myscale;
my $mod = $small_icons ? 2 : 1;
if ($tag eq 'lsa-X') {
if ($myscale > 4*$mod) {
return $ampel_photo;
} elsif ($scale >= 2*$mod) {
return $ampel_klein_photo;
} elsif ($scale >= 0.5*$mod) {
return $ampel_klein2_photo;
} else {
return undef;
}
} elsif ($tag eq 'lsa-F') {
if ($myscale > 4*$mod) {
return $ampelf_photo;
} elsif ($scale >= 2*$mod) {
return $ampelf_klein_photo;
} elsif ($scale >= 0.5*$mod) {
return $ampelf_klein2_photo;
} else {
return undef;
}
} elsif ($tag eq 'lsa-B') {
if ($myscale > 4*$mod) {
return $andreaskr_photo;
} elsif ($scale >= 2*$mod) {
return $andreaskr_klein_photo;
} elsif ($scale >= 0.5*$mod) {
return $andreaskr_klein2_photo;
} else {
return undef;
}
} elsif ($tag eq 'lsa-Zbr') {
if ($myscale >= 4*$mod) {
return $zugbruecke_photo;
} elsif ($scale >= 1*$mod) {
return $zugbruecke_klein_photo;
} else {
return undef;
}
} elsif ($tag eq 'kn') {
if ($myscale > 4*$mod) {
return $kneipen_photo;
} elsif ($scale >= 1*$mod) {
return $kneipen_klein_photo;
} else {
return undef;
}
} elsif ($tag eq 'e') {
if ($myscale > 1*$mod) {
return $ferry_photo;
} elsif ($scale >= 0.25*$mod) {
return $ferry_klein_photo;
} else {
return undef;
}
} elsif ($tag eq 'rest') {
if ($myscale > 4*$mod) {
return $essen_photo;
} elsif ($scale >= 1*$mod) {
return $essen_klein_photo;
} else {
return undef;
}
} elsif ($tag eq 'b') {
if ($myscale > 4*$mod) {
return (-width => 20, -font => "Helvetica -18");
} elsif ($myscale >= 1*$mod) {
return (-width => 14, -font => ($os eq 'win' ? "Helvetica -14 bold" : "6x13bold"));
} elsif ($scale >= 0.5*$mod) {
return (-width => 10, -font => ($os eq 'win' ? "Helvetica -10 bold" : "5x7"));
} elsif ($scale >= 0.2*$mod) {
return (-width => 6, -font => undef);
} else {
return (-width => 3, -font => undef);
}
} elsif ($tag eq 'u') {
if ($myscale > 4*$mod) {
return (-width => 18, -font => "Helvetica -18");
} elsif ($myscale >= 1*$mod) {
return (-width => 13, -font => ($os eq 'win' ? "Helvetica -14 bold" : "6x13bold"));
} elsif ($scale >= 0.5*$mod) {
return (-width => 9, -font => ($os eq 'win' ? "Helvetica -10 bold" : "5x7"));
} elsif ($scale >= 0.2*$mod) {
return (-width => 6, -font => undef);
} else {
return (-width => 3, -font => undef);
}
} elsif ($tag eq 'vf') {
if ($myscale > 2*$mod) {
return $vorfahrt_photo;
} elsif ($scale >= 0.5*$mod) {
return $vorfahrt_klein_photo;
} else {
return undef;
}
}
}
sub scale_maps {
my $scalefactor = shift;
if (defined $map_img || @map_surround_img) {
my($width, $height);
for my $img ($map_img, @map_surround_img) {
if (defined $img) {
($width, $height) = ($img->width, $img->height);
last;
}
}
if (defined $width) {
my @maps = $c->find(withtag => 'map');
for my $map_i (@maps) {
my @map_coords = $c->coords($map_i);
if ($c->type($map_i) eq 'image') {
eval {
my $p = $c->itemcget($map_i, "-image");
$p->delete;
}; warn $@ if $@;
}
$c->delete($map_i);
@map_coords = ($map_coords[0]+$width*$scalefactor/2,
$map_coords[1]+$height*$scalefactor/2);
# @map_coords zeigt jetzt auf die Mitte der Karte ...
eval {
local $map_surround = 0;
getmap(@map_coords); # Karte neu zeichnen (richtig skaliert)
}; warn $@ if $@;
}
}
}
}
# Zentriert entweder auf eine Straße oder Koordinaten oder auf die Mitte
# Berlins.
### AutoLoad Sub
sub center_best {
if (defined $center_on_str && $center_on_str !~ /^\s*$/) {
choose_from_plz(-str => $center_on_str);
} elsif (defined $center_on_coord && $center_on_coord !~ /^\s*$/) {
choose_from_plz(-coord => $center_on_coord);
} elsif ($city_obj && $city_obj->can("center")) {
$c->center_view(transpose(split /,/, $city_obj->center));
} else {
$c->center_view;
}
}
# Zentriert auf den Anfang der aktuellen Route
### AutoLoad Sub
sub center_begin_of_route {
$c->center_view($coords[0]->[0], $coords[0]->[1]);
}
# Zentriert auf den Anfang der aktuellen Route und verschiebt zum
# letzten Punkt der Route hin,
### AutoLoad Sub
sub center_whole_route {
$c->see($coords[0]->[0], $coords[0]->[1],
$coords[-1]->[0], $coords[-1]->[1],
);
}
# Zoomt den Ausschnitt so, daß minx/miny und maxx/maxy in den Ecken stehen.
# Wenn keine Argumente angegeben sind, werden die Minimal/Maximalwerte der
# aktuellen Route genommen.
### AutoLoad Sub
sub zoom_view {
my($minx, $miny, $maxx, $maxy);
if (@_) {
($minx, $miny, $maxx, $maxy) = @_;
} elsif (!@coords) {
return;
} else {
foreach (@coords) {
if (!defined $minx || $_->[0] < $minx) { $minx = $_->[0] }
if (!defined $maxx || $_->[0] > $maxx) { $maxx = $_->[0] }
if (!defined $miny || $_->[1] < $miny) { $miny = $_->[1] }
if (!defined $maxy || $_->[1] > $maxy) { $maxy = $_->[1] }
}
}
my(@corner) = $c->get_corners;
my $c_w = ($corner[2]-$corner[0]);
my $c_h = ($corner[3]-$corner[1]);
my($r_w, $r_h) = ($maxx-$minx, $maxy-$miny);
$c->center_view($r_w/2+$minx, $r_h/2+$miny);
# XXX ls/pt-Version
if ($r_w > 0 and $r_h > 0) {
my $asp_x = $c_w/$r_w;
my $asp_y = $c_h/$r_h;
if ($asp_x < $asp_y) {
scalecanvas($c, $asp_x/1.1); # 10% Luft lassen
} else {
scalecanvas($c, $asp_y/1.1);
}
}
}
# XXX move to CanvasUtil.pm ???
sub Tk::Canvas::smooth_scroll {
my($c, $tox, $toy, %args) = @_;
if ($use_smooth_scroll && !$args{NoSmoothScroll}) {
my($fromx, $fromy) = (($c->xview)[0], ($c->yview)[0]);
my $step = 10;
my($deltax, $deltay) = (($tox-$fromx)/$step,
($toy-$fromy)/$step);
for (1 .. $step) {
$c->xview('moveto' => $fromx + $deltax * $_);
$c->yview('moveto' => $fromy + $deltay * $_);
$c->idletasks;
}
} else {
$c->xview('moveto' => $tox);
$c->yview('moveto' => $toy);
}
}
# Diese Funktion geht von einer korrekten dpi-Einstellung für den
# Bildschirm und quadratischen Dots aus.
# Rückgabewert: Der Teil hinter dem Doppelpunkt.
sub calc_mapscale_nenner {
my($mx1) = transpose(0, 0);
my($mx2) = transpose(1000, 1000);
my $nenner = (($mx2-$mx1)/$top_dpmm/$scale_coeff);
if ($nenner == 0) { $nenner = 0.00000001 }
$nenner = abs(int(1_000_000 / $nenner));
$nenner;
}
# side-effect: this also sets $mapscale
sub calc_mapscale {
my $nenner = calc_mapscale_nenner();
$mapscale = "1:$nenner";
$nenner;
}
### AutoLoad Sub
sub show_zoomrect {
my($i) = @_;
if (!defined $i) {
$c->delete('zoomrect');
if (defined $zoomrect_after) {
$zoomrect_after->cancel;
}
my @c = $c->get_corners;
$c->createLine(@c[0,1, 0,3, 2,3, 2,1, 0,1],
-tags => 'zoomrect',
);
} elsif ($i > 3*2) {
$c->delete('zoomrect');
undef $zoomrect_after;
} else {
$c->itemconfigure('zoomrect',
-fill => ($i % 2 == 1 ? 'blue' : 'red'));
$zoomrect_after = $c->after(300, sub { show_zoomrect($i+1) });
}
}
### AutoLoad Sub
sub show_mark {
my($i, %args) = @_;
$i = 0 if !defined $i;
if ($i == 0 and $showmark_after) {
$showmark_after->cancel;
undef $showmark_after;
}
my @stipple = ('gray12', 'gray25', 'gray50', 'gray75');
my $col = $i/8; # color ...
my $j = $i%8; # stage ...
if ($col > 5 && !$args{'-endlessmark'}) {
$c->delete('show');
undef $showmark_after;
} else {
$c->itemconfigure('show',
-fill => ($col % 2 == 1 ? 'blue' : 'red'));
if ($j < 4) {
$c->itemconfigure('show',
-stipple => $stipple[$j]);
} elsif ($j == 4) {
$c->itemconfigure('show',
-stipple => undef);
} else {
$c->itemconfigure('show',
-stipple => $stipple[8-$j]);
}
unless ($steady_mark) {
$showmark_after = $c->after(150, sub { show_mark($i+1, %args) });
} else {
$c->itemconfigure('show',
-stipple => undef);
}
}
}
## DEBUG_BEGIN
#BEGIN{mymstat("75% BEGIN");}
## DEBUG_END
### AutoLoad Sub
sub show_overview {
my $new = shift;
my $overview_top = $toplevel{"overview"};
if ($overview_top && $overview_top->{CoordSystem} ne $coord_system) {
$new = 1;
}
if (defined $overview_top and Tk::Exists($overview_top)) {
if ($new) {
$overview_top->destroy;
delete $toplevel{"overview"};
}
}
if (defined $overview_top && Tk::Exists($overview_top)) {
if (!$show_overview) {
$overview_top->withdraw;
} else {
$overview_top->deiconify;
$overview_top->raise;
}
return;
}
$overview_top = $top->Toplevel(-title => M"Übersicht",
-class => "Bbbike Overview",
);
$overview_top->OnDestroy(sub { $show_overview = 0; });
$toplevel{"overview"} = $overview_top;
set_as_toolwindow($overview_top);
$overview_top->{CoordSystem} = $coord_system;
# Try to set the overview to the right bottom corner of the main
# window:
my($w,$h) = (int($top->width/3), int($top->height/3));
if (1) {
my($x,$y) = ($sy->rootx - $w - 4*2, $sx->rooty - $h - 20 - 4);
geometry($overview_top,$x,$y,$w,$h);
} else { # XXX del
if (!@max_extends) {
warn "Should not happen: no defined max_extends";
$overview_top->geometry("${w}x$h-0-0");
} else {
my(@want_extends) = ($top->x+$top->width, $top->y+$top->height,
$w, $h);
crop_geometry(\@want_extends, \@max_extends);
if ($want_extends[GEOMETRY_HEIGHT] < $h) {
$want_extends[GEOMETRY_HEIGHT] = $h;
$want_extends[GEOMETRY_Y] = "-0";
} else {
$want_extends[GEOMETRY_Y] =~ s/^/+/;
}
if ($want_extends[GEOMETRY_WIDTH] < $w) {
$want_extends[GEOMETRY_WIDTH] = $w;
$want_extends[GEOMETRY_X] = "-0";
} else {
$want_extends[GEOMETRY_X] =~ s/^/+/;
}
my $geom = "$want_extends[GEOMETRY_WIDTH]x$want_extends[GEOMETRY_HEIGHT]" . "$want_extends[GEOMETRY_X]$want_extends[GEOMETRY_Y]";
$overview_top->geometry($geom);
}
} ##XXX <--- delete until here
show_overview_populate($overview_top);
}
sub show_overview_clean_and_populate {
my $overview_top = shift;
for ($overview_top->children) {
$_->destroy;
}
show_overview_populate($overview_top);
}
sub show_overview_populate {
my $overview_top = shift;
my $withdraw_sub = sub { $overview_top->withdraw;
$show_overview = 0 };
$overview_top->protocol('WM_DELETE_WINDOW', $withdraw_sub);
# Canvas. Create scrollbars manually, so arrow_update can be called
$overview_canvas = $overview_top->Canvas
(-xscrollincrement => 15, # XXX check values
-yscrollincrement => 15,
-bg => $map_bg,
);
my($overview_width, $overview_height);
if ($coord_system eq 'standard') {
$overview_width = $normal_scrollregion/DEFAULT_SCALE*
($show_overview_mode eq 'brb' ? $small_scale : $medium_scale);
$overview_height = $overview_width;
$overview_canvas->configure
(-scrollregion => [-$overview_width, -$overview_width,
$overview_width, $overview_width]
);
} else {
my @s = $coord_system_obj->scrollregion;
# XXX show_overview_mode beachten
@s = (transpose_medium(@s[0, 1]),
transpose_medium(@s[2, 3]));
$overview_width = ($s[2]-$s[0])/2;
$overview_height = ($s[3]-$s[1])/2;
$overview_canvas->configure(-scrollregion => [@s]);
}
$overview_canvas->createLine(0,0,0,0,-tags => 'zoomrect');
$overview_top->gridColumnconfigure(0, -weight => 1);
$overview_top->gridRowconfigure(0, -weight => 1);
$overview_canvas->grid(-row => 0, -column => 0, -sticky => 'eswn');
my $sy = $overview_top->Scrollbar(-command => ["yview", $overview_canvas]);
$sy->grid(-row => 0, -column => 1, -sticky => 'ns');
my $sx = $overview_top->Scrollbar(-orient => 'horiz',
-command => ["xview", $overview_canvas]);
$sx->grid(-row => 1, -column => 0, -sticky => 'ew');
my $center_coords;
if ($city_obj && $city_obj->can("center")) {
$center_coords = [ split /,/, $city_obj->center ];
} else {
$center_coords = [8581,12243]; # Fallback: Brandenburger Tor
}
my $arrow_update = sub {
$overview_canvas->delete('berlinarrow');
require Geometry;
my($cx1,$cy1,$cx2,$cy2) = $overview_canvas->get_corners;
# Ersten Schnittpunkt (inneres Rechteck) ermitteln
# Die Mitte ist (0,0) (ca. Berlin-Moabit).
my($ix1,$iy1) = Geometry::get_intersection
($cx1+($cx2-$cx1)/2, $cy1+($cy2-$cy1)/2, 0,0,
$cx1+15,$cy1+15,$cx2-15,$cy2-15);
if (defined $ix1 and defined $iy1) {
# zweiten Schnittpunkt ermitteln (aktuelle Canvasgrenze)
my($ix2,$iy2) = Geometry::get_intersection($ix1,$iy1,0,0,
$cx1,$cy1,$cx2,$cy2);
if (defined $ix2 and defined $iy2) {
my $anti_transpose = ($show_overview_mode eq 'brb'
? \&anti_transpose_small
: \&anti_transpose_medium);
# Distance to center (in Berlin: Brandenburger Tor)
my $entf = Strassen::Util::strecke
([$anti_transpose->($ix1,$iy1)],
$center_coords);
$overview_canvas->createLine
($ix1,$iy1,$ix2,$iy2,
-arrow => "last",
-width => 2,
-fill => "red",
-tags => 'berlinarrow');
$overview_canvas->createText
($ix1, $iy1,
-anchor => BBBikeCalc::opposite_direction(BBBikeCalc::line_to_canvas_direction
($ix1,$iy1,$ix2,$iy2)),
-text => "Berlin\n".sprintf("%d km", $entf/1000),
-fill => "red",
-font => $font{'small'},
-tags => ['berlinarrow','berlinarrowlabel']);
}
}
};
$overview_canvas->configure(-yscrollcommand =>
sub {
$sy->set(@_);
$arrow_update->();
},
-xscrollcommand =>
sub {
$sx->set(@_);
$arrow_update->();
},
);
# Mode button
my $mode_button = $overview_top->Button
(-font => $font{'small'},
-padx => 0, -pady => 0,
-highlightthickness => 0,
-takefocus => 0,
-command => sub {
$show_overview_mode =
($show_overview_mode eq 'b' ? 'brb' : 'b');
# $overview_top->after(10, sub { show_overview(1) });
$overview_top->after(10, sub { show_overview_clean_and_populate($overview_top) });
});
$mode_button->place("-x" => 2, "-y" => 2);
if ($show_overview_mode eq 'brb') {
$mode_button->configure(-text => "=> Berlin");
} else {
$mode_button->configure(-text => "=> Brandenburg");
}
my $ts = ($show_overview_mode eq 'brb'
? \&transpose_small
: \&transpose_medium);
my($km100_pixel) = ($ts->(100000,0))[0] - ($ts->(0,0))[0];
# Radar button
if ($advanced) {
my $radar_onoff = 0;
my $radar_button;
my $show_radar_image;
$radar_button = $overview_top->Checkbutton
(-font => $font{'small'},
-indicatoron => 0,
-padx => 0,
-pady => ($os eq 'win' ? 0 : 1), # for Checkbuttons 1, for Buttons 0 (why?)
-highlightthickness => 0,
-takefocus => 0,
-text => 'Radar',
-variable => \$radar_onoff,
-command => sub {
$radar_button->after(50, $show_radar_image);
}
);
$show_radar_image = sub {
if ($radar_image) {
eval q{ $radar_image->delete };
}
$overview_canvas->delete('radarimage');
return if !$radar_onoff;
IncBusy($top);
$progress->Init(-label => M"Radarschirm");
eval {
require FURadar;
$FURadar::progress = $progress;
$FURadar::VERBOSE = $verbose;
# $FURadar::use_map = ($show_overview_mode eq 'brb'
# ? 'FURadar2' : 'FURadar');
$FURadar::use_map = 'FURadar2'; # the only left...
# XXXX use fetch and cache routine
my $origimgfile = FURadar::fetch();
#XXX my $origimgfile = FURadar::latest_dwd();
if ($origimgfile) {
my $time = (stat($origimgfile))[STAT_MODTIME];
my $imgfile = FURadar::interesting_parts
($origimgfile,
-km100pixel => $km100_pixel);
if (-r $imgfile) {
$radar_image = $overview_canvas->Photo(-file => $imgfile);
my($xoff,$yoff) = ($show_overview_mode eq 'brb'
? (3,20)
: $ts->(0,0));
$overview_canvas->createImage
($xoff, $yoff,
-image => $radar_image,
-tags => 'radarimage');
foreach my $raise (qw(g gP gD O o)) { # XXX evtl. andere Tags auch raisen
$overview_canvas->raise($raise);
}
}
if ($time) {
$balloon->attach($radar_button,
-msg => scalar localtime $time);
}
}
};
warn __LINE__ . ": $@" if $@;
$progress->Finish;
DecBusy($top);
};
$radar_button->configure(-selectcolor => $radar_button->cget(-background));
$radar_button->place("-x" => 2+2+$mode_button->reqwidth, "-y" => 2);
}
# Zeichnen von Gewässern, S-Bahnen, Straßen in der
# Übersichtskarte
foreach my $abk (qw(w b s)) {
local(%str_outline, %str_name_draw, $wasserumland, $wasserstadt,
%str_far_away, %str_restrict, %p_draw);
if ($overview_draw{$abk}) {
$str_outline{$abk} = 0;
$p_draw{'pp'} = 0;
my %args;
if ($abk eq 'w') {
my $ws_low = eval { Strassen->new("wasserstrassen-lowres") };
if ($ws_low) {
$args{-object} = $ws_low;
} else {
for my $cat (qw(W1 W2 F:W)) {
$str_restrict{$abk}->{$cat} = 1;
}
for my $cat (qw(W0 W)) {
$str_restrict{$abk}->{$cat} = 0;
}
$wasserumland = $wasserstadt = 1;
$str_far_away{$abk} = 1;
}
$str_name_draw{$abk} = 0;
} elsif ($abk eq 's') {
$str_restrict{$abk}->{'HH'} = 1;
}
plot('str',$abk,
Canvas => $overview_canvas,
Width => 1,
%args,
);
}
}
$progress->InitGroup;
for my $abk (qw(g gD)) {
plot('str',$abk,
Canvas => $overview_canvas,
($abk eq 'g' && $coord_system ne 'standard' ? (Filename => "plz-orig") : ()),
);
}
{
# schöner wär's mit local(), aber geht nicht so ohne weiteres
my $orte_far_away_orig = $p_far_away{'o'};
#XXX del: my $overlap_label_orig = $no_overlap_label{'o'};
$p_far_away{'o'} = 1;
#XXX del: $no_overlap_label{'o'} = 0; # XXX leider langsam
plotorte(Canvas => $overview_canvas,
PlaceCategory => 4,
AllSmall => 1,
Shortname => 1,
NoOverlapLabel => 0,
);
$p_far_away{'o'} = $orte_far_away_orig;
#XXX del: $no_overlap_label{'o'} = $overlap_label_orig;
if ($show_overview_mode eq 'b') {
plotorte(Canvas => $overview_canvas,
PlaceCategory => 0,
AllSmall => 1,
Shortname => 1,
NameDraw => 1,
-municipality => 1,
-type => 'oo'
);
}
}
$progress->FinishGroup;
$overview_canvas->raise("zoomrect");
$overview_top->bind('<q>' => $withdraw_sub);
$overview_top->bind('<Q>' => sub { &$withdraw_sub;
$overview_top->destroy
});
my $real_canvas = $overview_canvas;
my $scroll_lock;
my $set_scroll_lock = sub {
$scroll_lock = $overview_canvas->after(100,
sub { undef $scroll_lock });
};
my $button_pressed;
my $refresh_sub;
my($delta_x_fraction, $delta_y_fraction) = (0.5, 0.5);
$refresh_sub =
sub {
my($w, $initial) = @_;
my $e = $w->XEvent;
if (!defined $button_pressed) {
$button_pressed = $overview_canvas->repeat
(100, sub { $refresh_sub->($w, 0); });
}
return if $scroll_lock;
my($x, $y) = ($e->x, $e->y);
my($xx, $yy) = ($overview_canvas->canvasx($x),
$overview_canvas->canvasy($y));
if ($initial) {
my(@c) = $overview_canvas->bbox('zoomrect');
if ($xx >= $c[0] && $xx <= $c[2] &&
$yy >= $c[1] && $yy <= $c[3]) {
# Click in rect, record initial position.
# This code is necessary to avoid jumps on initial click.
$delta_x_fraction = ($xx-$c[0])/($c[2]-$c[0]);
$delta_y_fraction = ($yy-$c[1])/($c[3]-$c[1]);
}
}
my $real_canvas_width = $real_canvas->width;
my $real_canvas_height = $real_canvas->height;
# XXX ist noch etwas ruckartig ... kleinere units,
# intelligenteres Handling!
my $pad = 10;
if ($x < $pad) {
$overview_canvas->xview(scroll => -1, 'units');
$set_scroll_lock->();
}
if ($y < $pad) {
$overview_canvas->yview(scroll => -1, 'units');
$set_scroll_lock->();
}
if ($x > $real_canvas_width-$pad) {
$overview_canvas->xview(scroll => +1, 'units');
$set_scroll_lock->();
}
if ($y > $real_canvas_height-$pad) {
$overview_canvas->yview(scroll => +1, 'units');
$set_scroll_lock->();
}
my(@oldx) = $c->xview;
my(@oldy) = $c->yview;
my($xwidth) = $oldx[1]-$oldx[0];
my($ywidth) = $oldy[1]-$oldy[0];
if ($coord_system ne 'standard') {
($xx, $yy) = anti_transpose_medium($xx, $yy); # XXX brb mode!!!
$c->center_view($xx, $yy);
} else {
$c->xview(moveto => (($xx+$overview_width)/($overview_width*2)
- $xwidth*$delta_x_fraction)
);
$c->yview(moveto => (($yy+$overview_height)/($overview_height*2)
- $ywidth*$delta_y_fraction)
);
}
};
$real_canvas->Tk::bind('<ButtonPress-1>' => sub {
my $w = shift;
$refresh_sub->($w, 1, @_)
});
$real_canvas->Tk::bind('<B1-Motion>' => sub {
my $w = shift;
$refresh_sub->($w, 0, @_)
});
$real_canvas->Tk::bind
('<ButtonRelease-1>'
=> sub {
if (defined $button_pressed) {
$button_pressed->cancel();
undef $button_pressed;
}
($delta_x_fraction, $delta_y_fraction) = (0.5, 0.5);
});
{
my $gain = 1;
$real_canvas->CanvasBind('<2>',
[sub {
my($w,$x,$y) = @_;
$w->scan('mark',$x,$y);
},Tk::Ev('x'),Tk::Ev('y')]);
$real_canvas->CanvasBind('<B2-Motion>',
[sub {
my($w,$x,$y) = @_;
$w->scan('dragto',$x,$y,$gain);
},Tk::Ev('x'),Tk::Ev('y')]);
}
# Scrolling korrigieren (auf Mitte setzen)
my(@oldx) = $overview_canvas->xview;
my(@oldy) = $overview_canvas->yview;
my($xwidth) = $oldx[1]-$oldx[0];
my($ywidth) = $oldy[1]-$oldy[0];
$overview_canvas->xview('moveto' => (1-$xwidth)/2);
$overview_canvas->yview('moveto' => (1-$ywidth)/2);
overview_update();
# Scrollbar-Navigation per Cursortasten
$overview_top->bind
('<Up>' => sub { $real_canvas->yview(scroll => -1, 'units') });
$overview_top->bind
('<Down>' => sub { $real_canvas->yview(scroll => 1, 'units') });
$overview_top->bind
('<Left>' => sub { $real_canvas->xview(scroll => -1, 'units') });
$overview_top->bind
('<Right>' => sub { $real_canvas->xview(scroll => 1, 'units') });
}
### AutoLoad Sub
sub delete_overview {
my $overview_top = $toplevel{"overview"};
if (defined $overview_top && Tk::Exists($overview_top)) {
$overview_top->destroy;
}
eval q{ $radar_image->delete };
delete $toplevel{"overview"};
# Done already in OnDestroy: $show_overview = 0;
}
### AutoLoad Sub
sub overview_update {
return if !$overview_canvas || !Tk::Exists($overview_canvas);
my @a = $c->get_corners;
my @c;
my $i;
my $ts = ($show_overview_mode eq 'brb'
? \&transpose_small
: \&transpose_medium);
for($i = 0; $i < $#a; $i+=2) {
push @c, $ts->(anti_transpose($a[$i], $a[$i+1]));
}
$overview_canvas->coords('zoomrect', @c[0,1, 0,3, 2,3, 2,1, 0,1]);
my($midx, $midy) = (($c[2]-$c[0])/2+$c[0],
($c[3]-$c[1])/2+$c[1]);
if (!$overview_canvas->is_visible($midx, $midy)) {
$overview_canvas->center_view($midx, $midy);
}
}
##### Suche #####################################################
sub search_route {
my($start, $ziel, $via_arr, $continue, %args) = @_;
return if $in_search;
$in_search++;
my(@via) = @$via_arr if defined $via_arr;
destroy_delayed_restack();
IncBusy($top, %busy_watch_args);
eval {
status_message("");
# XXX $str_draw{'r'} ueberprfen, wenn im RB-Mode
if (!$net and ($str_draw{'s'} || $str_draw{'l'})) { make_net() }
warn "Suche von <$start> bis <$ziel>" . (@via ? " via <@via>" : "")
if $verbose;
my %extra_args;
if (keys %ampeln) {
if ($ampel_optimierung) {
$extra_args{Ampeln} =
{Net => \%ampeln,
Penalty => $lost_strecke_per_ampel};
} elsif ($optprefs{'Ampeln'}) {
$extra_args{Ampeln} =
{Net => \%ampeln,
Penalty => optprefs2penalty($optprefs{'Ampeln'})*100};
} # XXX
if ($abbiege_optimierung) {
$extra_args{Abbiegen} = {Penalty => $abbiege_penalty,
Order => {'NN' => 0,
'N' => 1,
'H' => 2,
'HH' => 3,
'BAB' => 3, # XXX
'B' => 4}};
}
# XXX optprefs
}
# Qualität, Handicap und temporäre Handicaps
foreach my $def ({OptSwitch => \$qualitaet_s_optimierung,
OptName => 'Qualität',
Speed => \%qualitaet_s_speed,
MakeNet => \&make_qualitaet_net,
CatPrefix => 'Q',
ExtraArgsName => 'Qualitaet',
},
{OptSwitch => \$handicap_s_optimierung,
OptName => 'Sonstige Beeinträchtigungen',
Speed => \%handicap_s_speed,
MakeNet => \&make_handicap_net,
CatPrefix => 'q',
ExtraArgsName => 'Handicap',
},
) {
my $opt = $ {$def->{OptSwitch}};
my $optname = $def->{OptName};
if ($opt || (defined $optname && $optprefs{$optname})) {
my $speed = $def->{Speed};
my $makenet = $def->{MakeNet};
my $catprefix = $def->{CatPrefix};
my $net = $makenet->();
my $penalty;
if ($opt) {
foreach (0 .. 4) {
next if !defined $speed->{$catprefix . "$_"};
$penalty->{$catprefix . "$_"} =
max_speed($speed->{$catprefix . "$_"});
}
} else {
foreach (0 .. 4) {
next if !defined $penalty->{$catprefix . "$_"};
# XXX
$penalty->{$catprefix . "$_"} =
optprefs2penalty($optprefs{$def->{OptName}}) * $_;
}
}
$extra_args{$def->{ExtraArgsName}} =
{Net => $net,
Penalty => $penalty,
};
}
}
if ($strcat_optimierung || $optprefs{'Kategorie'}) {
# XXX wenn L zugeschaltet wird, muß strcat_net aktualisiert werden
if (!$strcat_net) {
if ($multistrassen) {
$strcat_net = new StrassenNetz $multistrassen;
} elsif ($str_obj{'s'}) {
$strcat_net = new StrassenNetz $str_obj{'s'};
}
if ($strcat_net) {
$strcat_net->make_net_cat;
}
}
if ($strcat_net) {
my $penalty;
if ($strcat_optimierung) {
foreach (keys %strcat_speed) {
$penalty->{$_} = max_speed($strcat_speed{$_});
}
} else {
# my %strcat_def = (B => HH => 100,
# H => 100,
# N => 100,
# NN => 100);
# foreach (keys %strcat_speed) {
# # XXX
# $penalty->{"Q$_"} = optprefs2penalty($optprefs{'Kategorie'})* $_;
# }
}
$extra_args{Strcat} =
{Net => $strcat_net,
Penalty => $penalty,
};
}
}
if ($radwege_optimierung) {
if (!$radwege_net) {
my $radwege_exact = new Strassen "radwege_exact";
$radwege_net = new StrassenNetz $radwege_exact;
$radwege_net->make_net_cat(-obeydir => 1);
# add all other streets do not have cycle paths ...
while(my($p1,$hash) = each %{ $net->{Net} }) {
while(my($p2,$entf) = each %$hash) {
if (!exists $radwege_net->{Net}{$p1}{$p2}) {
$radwege_net->{Net}{$p1}{$p2} = "RW0";
$radwege_net->{Net}{$p2}{$p1} = "RW0";
}
}
}
}
my $penalty;
foreach (keys %radwege_speed) {
$penalty->{$_} = max_speed($radwege_speed{$_});
}
$extra_args{Radwege} =
{Net => $radwege_net,
Penalty => $penalty,
};
}
if ($N_RW_optimization) {
# XXX check if $N_RW_net is up-to-date with respect to its
# sources, or whether a new $N_RW_net should be build
if (!$N_RW_net) {
my $s = $multistrassen ? $multistrassen : $str_obj{'s'};
if (!$s) {
warn "Can't get streets object, ignore N_RW optimization";
} else {
$N_RW_net = new StrassenNetz $s;
$N_RW_net->make_net_cyclepath(Strassen->new("radwege_exact"), 'N_RW');
}
}
if ($N_RW_net) {
my $penalty = { "H" => 4,
"H_RW" => 1,
"N" => 1,
"N_RW" => 1 };
$extra_args{RadwegeStrcat} =
{Net => $N_RW_net,
Penalty => $penalty,
};
}
}
if ($green_optimization) {
# XXX check if $green_net is up-to-date with respect to its
# sources, or whether a new $green_net should be build
if (!$green_net) {
$green_net = new StrassenNetz(Strassen->new("green"));
$green_net->make_net_cat;
}
my $penalty = ($green_optimization == 2
? { "green0" => 3,
"green1" => 2,
"green2" => 1,
}
: { "green0" => 2,
"green1" => 1.5,
"green2" => 1,
}
);
$extra_args{Green} =
{Net => $green_net,
Penalty => $penalty,
};
}
if ($unlit_streets_optimization) {
if (!$unlit_streets_net) {
$unlit_streets_net = new StrassenNetz(Strassen->new("nolighting"));
$unlit_streets_net->make_net_cat;
}
my $penalty = { "NL" => 4,
};
$extra_args{UnlitStreets} =
{Net => $unlit_streets_net,
Penalty => $penalty,
};
}
if ($steigung_optimierung) {
if (!$steigung_net) {
$steigung_net = new StrassenNetz Strassen->new;
$steigung_net->make_net_steigung($net, \%hoehe);
}
my $penalty;
my $act_power;
if ($active_speed_power{Type} eq 'power') {
$act_power = $power[$active_speed_power{Index}];
} else {
$act_power = speed2power($speed[$active_speed_power{Index}]);
}
if (!defined $steigung_penalty_env{ActPower} ||
$steigung_penalty_env{ActPower} != $act_power) {
$steigung_penalty = {};
}
$steigung_penalty_env{ActPower} = $act_power;
$extra_args{Steigung} =
{Net => $steigung_net,
Penalty => $steigung_penalty,
PenaltySub => sub { steigung_penalty($_[0], $act_power) },
};
}
if (!$sperre{'tragen'}) {
$extra_args{Tragen} = 1;
}
$extra_args{Velocity} = get_active_speed()/3.6; # should be m/s
# XXX Bislang noch keine Möglichkeit außer /tmp/add.pl, um
# $aufschlag zu setzen.
# Der Alternativ-Strecken-Code braucht noch viel Arbeit. Als
# erstes sollte ein Start/Ziel-Punkt, der zwischen zwei
# Kreuzungen/Kurvenpunkten liegt, höchstens einmal! durchfahren
# werden.
if ($aufschlag != 0 && $aufschlag != 1) {
$extra_args{Aufschlag} = $aufschlag;
$extra_args{All} = 1;
}
# XXX weitere mögliche Optimierungen:
# (benutzungspflichtige) Radwege
# verkehrsberuhigte Zonen => 6 .. 20 km/h
# Fußgängerampeln: Abbremsen auf 10 km/h und gleich wieder hoch
# Kreuzungen (Neben/Haupt, Haupt/Haupt ohne Ampel)
# Berufsverkehr (Stau auf großen Straßen => 15 .. 20 km/h)
if ($search_stat) {
$extra_args{Stat} = 1;
}
if ($search_visual) {
$extra_args{'VisualSearch'} = {'Canvas' => $c,
'Transpose' => \&transpose,
'Delay' => 0.1,
};
}
if (%global_search_args) {
while(my($k,$v) = each %global_search_args) {
$extra_args{$k} = $v;
}
}
if (keys %penalty_subs) {
# Note: the %penalty_subs should only multiply $p, not add to
# if there are more than one penalty sub!
$extra_args{UserDefPenaltySub} = sub {
my($p, $next_node, $last_node) = @_;
while(my($k,$v) = each %penalty_subs) {
$p = $v->($p, $next_node, $last_node);
}
$p;
};
}
make_net() if (!$net);
foreach my $ref (\$start, \$ziel) {
if (!$net->reachable($$ref)) {
add_new_point($net, $$ref); # XXX ja?
}
}
my(@res) = $net->search($start, $ziel, %extra_args);
if (!@res) {
die M"Keine Strecke gefunden.\n";
}
my @path = @{ $res[StrassenNetz::RES_PATH] };
my $old_nr;
if ($continue) {
save_route_to_register('cont'); # if $max_list > 0;
$old_nr = $#coords;
} else {
# XXX shouldn't be necessary!!!
my($save_start) = $search_route_points[0]; # XXX used to be [SRP_COORD]?!
if (!exists $args{-undo} || $args{-undo}) {
reset_undo_route();
} else {
resetroute();
}
push @search_route_points, $save_start;
}
# my(@res);
# $power_cache = {};
# for(my $i=$max_list; $i>=0; $i--) {
# my $res_ref = $res_list[$i];
# next if (!ref $res_ref or !@$res_ref);
# @res = @$res_ref;
foreach my $p (@path) {
my($x, $y) = @$p;
addpoint_xy($x, $y, transpose($x, $y));
}
undef $power_cache;
updatekm();
# if ($max_list > 0) {
# save_route_to_register($i+1);
# resetroute();
# get_route_from_register('cont');
# }
# }
# get_route_from_register(1) if $max_list > 0;
# continue with best route (but do not continue if the route was deleted before and @act_search_route is empty)
if ($continue && @act_search_route) {
push @act_search_route,
$net->route_to_name([@path], -startindex => $old_nr); # XXX is wrong (?): +1);
} else {
# Use @realcoords instead of @path, in case it is continued,
# but with an empty @act_search_route before
@act_search_route = $net->route_to_name([@realcoords], -startindex=>0);
}
if (@path) {
push @search_route_points, [join(",", @{ $path[-1] }),
POINT_SEARCH];
}
print "Route: ", join(", ", map { $_->[0] } @act_search_route), "\n"
if $verbose;
if (exists $args{-caller} && $args{-caller} eq 'chooseort') {
zoom_view() if ($zoom_new_route_chooseort);
} else {
zoom_view() if ($zoom_new_route);
}
if ($auto_show_list) {
$show_strlist = 1;
show_route_strname();
}
set_flag('via');
set_flag('ziel');
restack_delayed();
};
my $err = $@;
$in_search = 0;
DecBusy($top);
status_message($err, 'err') if ($err);
}
# Wiederholung der Suche (evtl. mit neuen Parametern)
### AutoLoad Sub
sub re_search {
my(%args) = @_;
return if @search_route_points < 2;
IncBusy($top, %busy_watch_args);
eval {
my(@old_search_route_points) = @search_route_points;
@search_route_points = $old_search_route_points[SRP_COORD];
for(my $i=0; $i<$#old_search_route_points; $i++) {
my $p1 = $old_search_route_points[$i];
my $p2 = $old_search_route_points[$i+1];
if ($p2->[SRP_TYPE] eq POINT_MANUELL) {
addpoint_xy(split(/,/, $p2->[SRP_COORD]));
push @search_route_points, [@$p2];
} else {
search_route
($p1->[SRP_COORD], $p2->[SRP_COORD],
undef, ($i == 0 ? '' : 'cont'),
(exists $args{-undo} ? (-undo => $args{-undo}) : ()),
);
}
}
};
my $err = $@;
DecBusy($top);
die $err if $err;
}
sub re_search_gui {
re_search(@_);
update_route_strname();
}
# Steigung muß als Tausendfaches angegeben werden.
### AutoLoad Sub
sub steigung_penalty {
my($steigung, $act_power) = @_;
my $frac = ($steigung/1000+0.08)/(0.08*2);
max_speed(power2speed($act_power, -grade => $steigung/1000));
}
### AutoLoad Sub
sub route_strname_on_map {
my $xadd_anchor = $xadd_anchor_type->{'route'};
my $yadd_anchor = $yadd_anchor_type->{'route'};
require Tk::StippleLine;
foreach my $def (@route_strnames) {
my($str, $x, $y, $inx, $entf) = @$def;
$str = $str .= " ($entf)" if defined $entf and $do_route_strnames_km;
my(@tags) = ('route',
"route-" . $inx,
'routename');
my $returnanchor;
if (draw_text_intelligent
($c, $x, $y,
-text => $str,
-tags => [@tags],
-abk => ['route','routename'],
-checktagindex => 'all',
-xadd => $xadd_anchor,
-yadd => $yadd_anchor,
-returnanchor => \$returnanchor,
)) {
Tk::StippleLine::create
($c, $x, $y,
$x+$xadd_anchor->{$returnanchor},
$y+$yadd_anchor->{$returnanchor},
-fill => 'black',
-width => 2,
-tags => [@tags]);
} else {
$c->createText($x, $y, -text => $str,
-anchor => 'w',
-tags => [@tags]);
}
}
}
### AutoLoad Sub
sub get_act_search_route {
my @search_route;
if (!@act_search_route) {
if (@realcoords) {
make_net() if !$net;
@search_route = $net->route_to_name([@realcoords],-startindex=>0);
}
} else {
@search_route = @act_search_route;
}
\@search_route;
}
### AutoLoad Sub
sub show_route_strname {
require Tk::HList;
my $t;
my $withdraw_sub;
if (defined $toplevel{strlist} && Tk::Exists($toplevel{strlist})) {
if (!$show_strlist) {
$toplevel{strlist}->withdraw;
} else {
my $was_withdrawn = $toplevel{strlist}->state ne "normal";
$toplevel{strlist}->deiconify;
# raise nur ausführen, wenn es wirklich was zu sehen gibt
#$toplevel{strlist}->raise;
#XXX maybe combine with code below
if ($was_withdrawn && eval {require Tk::Placement; 1; }) {
# XXX use placer also for other toplevels --- replace
# all Popup(@popup_style) calls?
warn "Use Tk::Placement, yet experimental..." if $devel_host;
Tk::Placement::placer($toplevel{strlist}, -screen => $c,
-addx => 20, -addy => 25, # XXX for fvwm
);
}
}
} else {
$toplevel{strlist} = $top->Toplevel(-title => M"Aktuelle Route",
-class => "Bbbike Routeinfo");
set_as_toolwindow($toplevel{strlist});
$withdraw_sub = sub { $toplevel{strlist}->withdraw;
$show_strlist = 0 };
$toplevel{strlist}->protocol('WM_DELETE_WINDOW', $withdraw_sub);
$t = $toplevel{strlist};
}
undef @route_info;
if (defined $t) {
$t->SelectionOwn;
# XXX maxbytes beachten
$t->SelectionHandle(sub { route_info_to_text() });
}
my($bf, $f1);
if (defined $t) {
$bf = $t->Frame->pack(-fill => 'x', -side => "bottom");
$f1 = $t->Frame->pack(-fill => 'x', -side => "bottom");
$t->Label(-textvariable => \$ampelstatus_label_text,
-anchor => 'w',
-justify => "left")->pack(-fill => 'x', -side => 'bottom');
}
if (!Tk::Exists($route_strname_lbox)) {
if (!defined $t) {
die "No route_strname_lbox?!";
}
$route_strname_lbox = $t->Scrolled
('HList',
-header => 1,
-columns => 5,
-selectmode => 'extended',
-scrollbars => 'osoe',
-width => 68, # XXX
)->pack(-expand => 1, -fill => 'both');
$route_strname_lbox->header('create', 0, -text => M"Länge");
$route_strname_lbox->header('create', 1, -text => M"Gesamt");
$route_strname_lbox->header('create', 2, -text => M"Richtung");
$route_strname_lbox->header('create', 3, -text => M"Straße");
$route_strname_lbox->header('create', 4, -text => "");
# $route_strname_lbox->header('create', 5, -text => M"Zeit");
} else {
$route_strname_lbox->delete('all');
}
if ($do_route_strnames_comments && !$do_route_strnames_compact) {
$route_strname_lbox->header('configure', 4, -text => M"Kommentar");
} else {
$route_strname_lbox->header('configure', 4, -text => M"");
}
undef $show_route_start;
undef $show_route_ziel;
undef @route_strnames;
my(@search_route) = @{ get_act_search_route() };
if (@search_route) {
if ($do_route_strnames_orte) {
if (!$nearest_orte) {
$nearest_orte = new_from_strassen Kreuzungen
Strassen => _get_orte_obj();
$nearest_orte->make_grid;
}
}
if ($do_route_strnames_comments) {
if (!$comments_net) {
make_comments_net();
}
}
$route_strname_lbox->configure
(-command => sub {
my $i = shift;
if (defined $search_route[$i][4] and
ref $search_route[$i][4] eq 'ARRAY') {
my @line_coords;
foreach my $nr ($search_route[$i][4][0]+1 ..
$search_route[$i][4][1]+1) {
my @coords = $c->coords("route-$nr");
push @line_coords, [ @coords ] if @coords;
}
mark_street(-coords => \@line_coords,
-clever_center => 1,
) if @line_coords;
}
});
# max angle meaning straight forward
use constant ROUTE_STRAIGHT_ANGLE => 30;
if ($do_route_strnames_compact) {
@search_route = $net->compact_route(\@search_route,
-routestraightangle => ROUTE_STRAIGHT_ANGLE,
);
}
my $ges_entf = 0;
my($next_entf, $ges_entf_s, $next_winkel, $next_richtung)
= ("", "", undef, "");
my($aggr_begin_dist, $aggr_streets) = (0, "");
my $aggr_dir = undef;
my $last_str;
my ($out_dist, $out_total_dist, $out_dir, $out_str);
my $out_dist_add;
my %seen_comments;
for(my $i = 0; $i <= $#search_route; $i++) {
my($str, $index_arr);
my($entf, $winkel, $richtung)
= ($next_entf, $next_winkel, $next_richtung);
my $entf_s;
($str, $next_entf, $next_winkel, $next_richtung, $index_arr)
= @{$search_route[$i]};
my $route_strnames_index;
if ($str ne '...' &&
(!defined $last_str || $last_str ne $str)) {
$last_str = $str;
$str = Strassen::strip_bezirk($str);
if (!defined $show_route_start) {
$show_route_start = $str;
}
$show_route_ziel = $str;
if (ref $index_arr eq 'ARRAY' &&
defined $index_arr->[0] &&
defined $coords[$index_arr->[0]] &&
defined $coords[$index_arr->[0]+1]) {
my($x, $y) = ($coords[$index_arr->[0]]->[0],
$coords[$index_arr->[0]]->[1]);
push @route_strnames, [$str, $x, $y, $index_arr->[0]];
$route_strnames_index = $#route_strnames;
}
}
if ($i > 0) {
if (!$winkel) { $winkel = 0 }
$winkel = int($winkel/10)*10;
if ($winkel < ROUTE_STRAIGHT_ANGLE) {
$richtung = "";
} else {
my $artikel = (!defined $Msg::lang || $Msg::lang =~ /^(|de)$/
? Strasse::de_artikel($str)
: "=>");
$richtung =
($winkel <= 45 ? M"halb" : '') .
($richtung eq 'l' ? M"links" : M"rechts") . " " .
"($winkel°) " . $artikel;
}
if ($do_route_strnames_orte) {
my($nearest_ort_xy) =
$nearest_orte->nearest_loop
($realcoords[$index_arr->[0]]->[0],
$realcoords[$index_arr->[0]]->[1],
IncludeDistance => 1);
if ($nearest_ort_xy) {
my $ort = $nearest_orte->get_first($nearest_ort_xy->[0]);
# XXX evtl. Ort-Kat für 1000 beachten
my $in_bei = ($nearest_ort_xy->[1] <= 1000
? M"in" : M"bei");
$richtung = "$in_bei " .
(Strassen::split_ort($ort))[0] .
": $richtung";
}
}
$ges_entf += $entf;
$ges_entf_s = "(" . m2km($ges_entf) . ")";
$entf_s = M("nach")." ".m2km($entf, 3, 2);
if (defined $route_strnames_index) {
$route_strnames[$route_strnames_index]->[4]
= m2km($ges_entf);
}
} elsif (@coords > 1) {
my $compass = uc(BBBikeCalc::canvas_translation(BBBikeCalc::line_to_canvas_direction
(@{ $coords[0] }, @{ $coords[1] })));
if (defined $Msg::lang && $Msg::lang =~ /^en/) {
$compass =~ s/([NESW])/{N => 'north',
E => 'east',
S => 'south',
W => 'west'}->{$1}/gei;
$richtung = $compass . "ward";
} else {
$richtung = M("nach")." ".$compass;
}
}
##XXX del:
# if ($do_route_strnames_compact) {
# # $aggr_dist += $entf if defined $entf;
# if (!defined $aggr_dir) {
# $aggr_dir = $richtung;
# }
# if (!defined $aggr_begin_dist) {
# $aggr_begin_dist = $entf;
# $out_dist_add = 0;
# } else {
# $out_dist_add += $entf;
# }
# if ($aggr_streets ne '') {
# $aggr_streets .= ", ";
# }
# $aggr_streets .= $str;
# if (!defined $next_winkel ||
# $next_winkel < ROUTE_STRAIGHT_ANGLE) {
# next;
# }
# ($out_dist, $out_dir, $out_str)
# = ($aggr_begin_dist > 0 ? M("nach")." ".m2km($aggr_begin_dist, 3, 2) : "",
# $aggr_dir,
# $aggr_streets);
# ($aggr_begin_dist, $aggr_streets) = (undef,"");
# undef $aggr_dir;
# } else {
($out_dist, $out_dir, $out_str)
= ($entf_s, $richtung, $str);
if (defined $out_dist_add) {
$out_dist += $out_dist_add;
undef $out_dist_add;
}
#XXX del: }
$out_total_dist = $ges_entf_s;
$route_strname_lbox->add($i, -text => $out_dist);
$route_strname_lbox->itemCreate($i, 1, -text => $out_total_dist);
$route_strname_lbox->itemCreate($i, 2, -text => $out_dir);
$route_strname_lbox->itemCreate($i, 3, -text => $out_str);
my $etappe_comment = "";
if ($do_route_strnames_comments && $comments_net &&
!$do_route_strnames_compact) {
my @comments;
for my $i ($index_arr->[0] .. $index_arr->[1]) {
my($etappe_comment) = $comments_net->get_point_comment([@realcoords], $i, \%seen_comments);
push @comments, $etappe_comment if defined $etappe_comment;
}
$etappe_comment = join("; ", @comments) if @comments;
}
$route_strname_lbox->itemCreate($i, 4, -text => $etappe_comment);
push @route_info, [($out_dist||""), ($out_total_dist||""),
$out_dir || "", $out_str || ""];
}
$ges_entf_s = "(" . m2km($ges_entf+$next_entf) . ")";
my $i = $#search_route + 1;
$route_strname_lbox->add($i, -text => M("nach")." ".m2km($next_entf, 3, 2));
$route_strname_lbox->itemCreate($i, 1, -text => "$ges_entf_s");
$route_strname_lbox->itemCreate($i, 2, -text => M"angekommen!");
push @route_info, [M("nach")." ".m2km($next_entf, 3, 2),
$ges_entf_s, M"angekommen!", ""];
my(@children) = $route_strname_lbox->info('children');
my $last_i = $children[-1];
for(my $j = $i+1; $j<=$last_i; $j++) {
$route_strname_lbox->delete($j);
}
if ($do_route_strnames) {
$c->delete("routename");
route_strname_on_map(\@route_strnames);
}
$toplevel{strlist}->raise;
} else {
$route_strname_lbox->add(0, -text => M"Keine Route");
}
return if !defined $t;
my $do_route_strnames_sub = sub {
$c->delete("routename");
if ($do_route_strnames) {
route_strname_on_map(\@route_strnames);
}
};
my $cb1 = $f1->Checkbutton(-text => M"Straßennamen an der Route",
-variable => \$do_route_strnames,
-font => $font{'small'},
)->pack(-side => 'left');
my $cb2 = $f1->Checkbutton(-text => M"km-Angaben",
-variable => \$do_route_strnames_km,
-command => $do_route_strnames_sub,
-font => $font{'small'},
)->pack(-side => 'left');
my $cb2_enabler = sub {
$cb2->configure(-state => $do_route_strnames ? "normal" : "disabled");
};
$cb2_enabler->();
$cb1->configure(-command => sub {
$cb2_enabler->();
$do_route_strnames_sub->();
});
$f1->Checkbutton(-text => M"Kompakt",
-variable => \$do_route_strnames_compact,
-command => \&show_route_strname,
-font => $font{'small'},
)->pack(-side => 'left');
if ($advanced) { # XXX funktioniert noch nicht so schoen intuitiv...
$f1->Checkbutton(-text => M"Orte einbinden",
-variable => \$do_route_strnames_orte,
-command => \&show_route_strname,
-font => $font{'small'},
)->pack(-side => 'left');
}
$f1->Checkbutton(-text => M"Kommentare",
-variable => \$do_route_strnames_comments,
-command => \&show_route_strname,
-font => $font{'small'},
)->pack(-side => 'left');
my $endb = $bf->Button(Name => 'end',
-command => $withdraw_sub,
)->pack(-side => 'left');
$bf->Button
(-text => M"Sichern",
-command => sub {
my($file) = $bf->getSaveFile
(($os eq 'win' ? (-defaultextension => '.TXT') : ()),
-title => M"Route sichern",
-initialdir => $tmpdir,
);
return if !defined $file;
if ($os eq 'win' and $file !~ /\.txt$/i) {
$file .= '.TXT';
}
make_backup($file);
if (open(ROUTE, ">$file")) {
print ROUTE route_info_to_text();
close ROUTE;
} else {
status_message
(Mfmt("Schreiben auf <%s> nicht möglich: %s", $file, $!),
'err');
}
},
)->pack(-side => 'left');
# If there is a txt => palm converter and a palm transfer program,
# then show this button:
require BBBikePalm;
if (can_create_and_transfer_palm_docs()) {
create_palm_button($bf)->pack(-side => 'left');
}
my $print_text_sub = sub {
my $font = shift;
if (!$show_route_start) { $show_route_start = "???" }
if (!$show_route_ziel) { $show_route_ziel = "???" }
if ($^O eq 'MSWin32' && defined &Win32Util::start_txt_print) {
require POSIX;
my $temp = POSIX::tmpnam(); # XXX it never gets deleted
$temp =~ tr{/}{\\};
$temp =~ s/\.$//;
$verbose and warn "Using $temp as the temp file for hardcopying\n";
open(TMP, ">$temp") or status_message("Can't write to $temp: $!", "die");
print TMP Mfmt("Route von %s bis %s",
$show_route_start, $show_route_ziel), "\n";
print TMP route_info_to_text();
close TMP;
Win32Util::start_txt_print($temp);
$tmpfiles{$temp}++;
} else { # try pdflatex, then postscript, on Windows first Route::PDF
my @try_order = qw(pdflatex postscript routepdf);
if ($os eq 'win') {
@try_order = qw(routepdf pdflatex postscript);
}
TRY: {
for my $try (@try_order) {
if ($try eq 'pdflatex') {
last TRY if print_text_pdflatex(route_info_to_latex());
} elsif ($try eq 'postscript') {
print_text_postscript
(route_info_to_text(),
-columns => 1,
-header => Mfmt("Route von %s bis %s",
$show_route_start, $show_route_ziel),
-font => $font,
);
} elsif ($try eq 'routepdf') {
print_route_pdf();
}
}
}
}
};
my $db;
$db = $bf->Button
(-text => M"Drucken",
-command => sub { $print_text_sub->($ps_fixed_font||"Courier7") },
)->pack(-side => 'left');
$bf->Button
(-text => M"Mail",
-command => sub {
if (@route_info) {
$show_route_start = "???" unless $show_route_start;
$show_route_ziel = "???" unless $show_route_ziel;
enter_send_mail
(Mfmt("BBBike-Route von %s bis %s",
$show_route_start, $show_route_ziel),
-data => route_info_to_text());
}
})->pack(-side => 'left');
if ($advanced && $devel_host) {
# Fax::Send is only a private unsupported module...
$bf->Button
(-text => M"Fax",
-command => sub {
if (@route_info) {
$show_route_start = "???" unless $show_route_start;
$show_route_ziel = "???" unless $show_route_ziel;
enter_send_fax
(Mfmt("BBBike-Route von %s bis %s",
$show_route_start, $show_route_ziel),
-data => route_info_to_text());
}
})->pack(-side => 'left');
}
$t->bind('<Up>' => sub { $route_strname_lbox->yview(scroll => -1,
'units') });
$t->bind("<Down>" => sub { $route_strname_lbox->yview(scroll => 1,
'units') });
$endb->focus;
#$t->Popup(@popup_style);
my $was_withdrawn = $t->state ne "normal";
if ($was_withdrawn) {
if (eval {require Tk::Placement; 1; }) {
# XXX use placer also for other toplevels --- replace
# all Popup(@popup_style) calls?
warn "Use Tk::Placement, yet experimental...";
Tk::Placement::placer($t, -screen => $c,
-addx => 20, -addy => 25, # XXX for fvwm
);
} else {
$t->withdraw;
my($x,$y) = ($top->rootx+$top->width-10, $top->rooty+$top->height-30);
$t->idletasks;
$x -= $t->reqwidth;
$y -= $t->reqheight;
$x = 0 if ($x < 0);
$y = 0 if ($y < 0);
$t->geometry("+$x+$y");
$t->deiconify;
}
}
}
sub route_info_to_text {
my $text = sprintf("%-14s %-10s %-26s %s\n",
M"Länge", M"Gesamt", M"Richtung", M"Straße");
$text .= "-" x 70 . "\n";
$text .= join "", map { sprintf("%-14s %-10s %-26s %s\n", @$_) } @route_info;
$text;
}
sub _get_route_title {
my $route_name = "BBBike-Route";
if (defined $show_route_start and
defined $show_route_ziel) {
my $start = Strasse::short(Strassen::strip_bezirk($show_route_start), 3); # Start besser abkürzen --- ist meist immer der Gleiche
my $ziel = Strasse::short(Strassen::strip_bezirk($show_route_ziel), 2);
$route_name = "BBBike: $start-$ziel";
}
$route_name;
}
sub route_info_to_html {
my $html_route_name = _get_route_title();
eval {
require HTML::Entities;
HTML::Entities::encode_entities($html_route_name);
};
warn $@ if $@;
my $html = "<html><head><title>$html_route_name</title></head><body>";
$html .= join "", map { sprintf(" %s %s<br>\n%s <b>%s</b><br><br>\n", @$_) } @route_info;
$html .= "</body></html>";
$html;
}
# More tweaking could be done (other font face/size, real wide margins...)
sub route_info_to_latex {
my $route_title = _get_route_title();
# escape for latex missing XXX
my $latex = <<'EOF';
\documentclass[10pt]{article}
\usepackage[latin1]{inputenc}
\usepackage[widemargins]{a4}
\usepackage{german}
\usepackage{supertabular}
\pagestyle{empty}
% Tip from http://www.mackichan.com/index.html?techtalk/579.htm~mainFrame
% and http://www.faqs.org/faqs/de-tex-faq/part10/ (10.2.2)
\usepackage{helvet}
\renewcommand{\familydefault}{\sfdefault}
\sloppy
\begin{document}
EOF
$latex .= "\\section*{$route_title}\n";
$latex .= <<'EOF';
\begin{supertabular}{lllp{8cm}}
EOF
$latex .= join(" & ", M"Länge", M"Gesamt", M"Richtung", M"Straße") . "\\\\\n";
$latex .= "\\hline \\\\\n";
$latex .= join "", map {
join(" & ", map { s/=>/\$\\rightarrow{}\$/g; $_ } @$_) . "\\\\\n"
} @route_info;
$latex .= <<'EOF';
\end{tabular}
\end{document}
EOF
$latex;
}
sub update_route_strname {
if (defined $toplevel{strlist} && Tk::Exists($toplevel{strlist})) {
show_route_strname();
}
}
sub add_custom_layers_to_net {
my($net_source, $net_source_abk) = @_;
while(my($abk,$val) = each %custom_net_str) {
if ($val) { # XXX del? && $abk =~ /^L\d/) {
eval {
if (!$str_obj{$abk}) {
$str_obj{$abk} = new Strassen $str_file{$abk};
}
push @$net_source, $str_obj{$abk};
push @$net_source_abk, $abk;
};
warn "Cannot get Strassen for $abk: $@" if $@;
}
}
}
sub make_net {
my(%args) = @_;
IncBusy($top);
$progress->Init(-label => M("Berechnen des Straßennetzes")."...",
-dependents => $c,
-visible => 1,
);
my $user_dels;
if ($net && $net->{_Deleted}) { # remember user dels
require Data::Dumper;
# clone:
$user_dels = eval substr(Data::Dumper::Dumper($net->{_Deleted}), 7);
}
undef $qualitaet_s_net;
undef $handicap_s_net;
undef $strcat_net;
undef $radwege_net;
undef $N_RW_net;
undef $green_net;
undef $unlit_streets_net;
undef $steigung_net;
eval {
my(@net_source, @net_source_abk);
if ($net_type eq "r") {
if (!$str_obj{'r'}) {
$str_obj{'r'} = new Strassen $str_file{'r'};
}
push @net_source, $str_obj{'r'};
push @net_source_abk, 'r';
} elsif ($net_type eq "us" || $net_type eq 'rus') {
my @abk = ($net_type eq 'us' ? qw(u b) : qw(u b r));
foreach (@abk) {
if (!$str_obj{$_}) {
$str_obj{$_} = new Strassen $str_file{$_};
}
push @net_source, $str_obj{$_};
push @net_source_abk, $_;
}
} elsif ($net_type eq 'wr') {
if (!$str_obj{'wr'}) {
$str_obj{'wr'} = Strassen->new($str_file{'wr'});
}
push @net_source, $str_obj{'wr'};
push @net_source_abk, 'wr';
} elsif ($net_type eq 'custom') {
add_custom_layers_to_net(\@net_source, \@net_source_abk);
} else {
if ($str_obj{'l'}) {
push @net_source, $str_obj{'l'};
push @net_source_abk, 'l';
}
if ($str_obj{'s'}) {
my $is_restricted = 0;
#XXX use new_copy_restricted
foreach (keys %{$str_restrict{'s'}}) {
if ($str_restrict{'s'}->{$_} == 0 &&
$str_restrict{'s'} ne 'P') { # Plätze
$is_restricted = 1;
last;
}
}
if ($is_restricted) {
my $restr_str = new Strassen;
$str_obj{'s'}->init;
while(1) {
my $ret = $str_obj{'s'}->next;
last if !@{$ret->[Strassen::COORDS]};
next if !$str_restrict{'s'}->{$ret->[Strassen::CAT]};
$restr_str->push($ret);
}
$restr_str->{File} = $str_obj{'s'}->file;
$restr_str->{Id} = $str_obj{'s'}->id . "_restr_" . join("_", keys %{$str_restrict{'s'}});
push @net_source, $restr_str;
push @net_source_abk, 's';
} else {
if ($str_obj{'s'}) {
push @net_source, $str_obj{'s'};
push @net_source_abk, 's';
}
}
}
while(my($token, $bool) = each %add_net) {
next if !$bool;
if ($token eq 'custom') {
add_custom_layers_to_net(\@net_source, \@net_source_abk);
} else {
$str_obj{$token} = Strassen->new($str_file{$token})
if !$str_obj{$token};
push @net_source, $str_obj{$token};
push @net_source_abk, $token;
}
}
if (!@net_source) { # XXX nö
my(@str_types) = ('s');
if ($args{'-l_add'}) {
push @str_types, 'l';
}
foreach my $str_type (@str_types) {
cache_decider_init();
my $str = new Strassen $str_file{$str_type};
if (cache_decider() && $coord_system eq 'standard') {
$str_obj{$str_type} = $str;
}
push @net_source, $str;
push @net_source_abk, $str_type;
}
}
}
if (@net_source == 0) {
die "Netz kann nicht berechnet werden, keine Sourcen";
} elsif (@net_source == 1) {
$net = new StrassenNetz $net_source[0];
} else {
$multistrassen = new MultiStrassen @net_source;
$net = new StrassenNetz $multistrassen;
}
$net->source(@net_source);
$net->source_abk(@net_source_abk);
my $make_net_all = sub {
if (defined $global_search_args{Algorithm} &&
$global_search_args{Algorithm} =~ /^C-A\*-2/) {
$net->use_data_format($StrassenNetz::FMT_MMAP);
} else {
$net->use_data_format($StrassenNetz::FMT_HASH);
}
$net->make_net(Progress => $progress,
UseCache => 0,
);
if ($net_type eq "s") {
my @sperre_type;
foreach ('einbahn', 'einbahn-strict', 'sperre', 'tragen', 'wegfuehrung') {
push @sperre_type, $_ if $sperre{$_};
}
if (@sperre_type) {
eval {
$net->make_sperre($sperre_file,
Type => \@sperre_type);
}; warn $@ if $@;
}
if ($sperre{'Q3'}) {
eval {
$net->make_sperre("qualitaet_s", Type => ['Q3']);
if ($str_obj{'l'}) {
$net->make_sperre("qualitaet_l", Type => ['Q3']);
}
}; warn $@ if $@;
}
if ($use_faehre) {
$net->add_faehre($str_file{'e'});
}
} elsif ($net_type eq 'us' || $net_type eq 'rus') {
my @abk = ($net_type eq 'us' ? qw(u b) : qw(u b r));
my $sperre_s = MultiStrassen->new(map { $p_file{"sperre_$_"} } @abk);
$net->make_sperre($sperre_s, Type => "sperre");
my @bhf_source;
foreach (@abk) {
if (!$p_obj{$_}) {
$p_obj{$_} = new Strassen $p_file{$_};
}
push @bhf_source, $p_obj{$_};
}
my $bhf_obj = new MultiStrassen @bhf_source;
$handicap_s_net = StrassenNetz->new(Strassen->new);
my $h_net = $handicap_s_net->{Net} = {};
$net->add_umsteigebahnhoefe
($bhf_obj, -addmapfile => 'umsteigebhf',
-cb => sub {
my($self, $p1, $p2, $entf, $name) = @_;
$h_net->{$p1}{$p2} = "q4"; # XXX just a hack to see some results... A best solution is to use the forthcoming penalty solution for the Marathon
});
} elsif ($net_type eq 'wr') {
# nothing special here...
}
};
if ($use_mldbm) {
eval {
warn "Trying MLDBM cache...\n";
$net->load_net_mldbm;
warn "OK!\n";
};
if ($@) {
$make_net_all->();
eval {
warn "Saving MLDBM cache...\n";
$net->save_net_mldbm;
warn "OK!\n";
};
warn __LINE__ . ": $@" if $@;
}
} else {
$make_net_all->();
}
if ($verbose) {
warn $net->statistics;
}
status_message("");
delete $pending{'recalc-net'};
};
status_message($@, 'err') if ($@);
if ($user_dels) {
restore_user_dels($net, $user_dels);
}
$progress->Finish;
DecBusy($top);
}
sub make_qualitaet_net {
if (!$qualitaet_s_net) {
eval {
$qualitaet_s_net = StrassenNetz->new
(MultiStrassen->new(Strassen->new("qualitaet_s"),
Strassen->new("qualitaet_l")));
$qualitaet_s_net->make_net_cat;
};
if ($@ && !$no_original_datadir) {
status_message($@, "info");
}
}
$qualitaet_s_net;
}
sub make_handicap_net {
if (!$handicap_s_net) {
eval {
my @s = (Strassen->new("handicap_s"),
Strassen->new("handicap_l"),
);
if ($temporary_handicap_s) {
push @s, $temporary_handicap_s;
}
$handicap_s_net = StrassenNetz->new(MultiStrassen->new(@s));
$handicap_s_net->make_net_cat;
};
if ($@ && !$no_original_datadir) {
status_message($@, "info");
}
}
$handicap_s_net;
}
sub make_comments_net {
if (!$str_obj{"comm"}) {
$str_obj{'comm'} = _get_comments_obj();
#XXX del: $str_obj{"comm"} = Strassen->new("comments");
}
if ($str_obj{"comm"}) {
$comments_net = new StrassenNetz $str_obj{"comm"};
$comments_net->make_net_cat(-net2name => 1,
-multiple => 1,
-obeydir => 1);
}
}
# User definable blockings
sub load_user_dels {
my $file = shift || "$bbbike_configdir/userdels.bbd";
$net->load_user_deletions
($file,
-oncallback => sub { set_usercross_image(@_) }, #XXX do not duplicate
-offcallback => sub { # XXX do not duplicate
my($xy1,$xy2) = @_;
$c->delete("delnet-$xy1-$xy2");
$c->delete("delnet-$xy2-$xy1");
},
);
_restore_cursor();
}
sub _save_umask (&) {
my $code = shift;
my $old_umask;
eval {
$old_umask = umask;
};
eval {
$code->();
};
my $err = $@;
if (defined $old_umask) {
umask $old_umask;
}
die $err if $err;
}
sub save_user_dels {
my $file = shift || "$bbbike_configdir/userdels.bbd";
my(%args) = @_;
_save_umask {
umask 022;
$net->save_user_deletions($file, %args);
};
}
sub restore_user_dels {
my($net, $user_dels) = @_;
# restore user deletions
while(my($k1,$v1) = each %$user_dels) {
while(my($k2,$v2) = each %$v1) {
my $ok;
if (exists $net->{Net}{$k1}{$k2}) {
$net->{_Deleted}{$k1}{$k2} = $net->{Net}{$k1}{$k2};
$ok++;
}
if (exists $net->{_Deleted}{$k1}{$k2}) {
$ok++;
}
if (exists $net->{Net}{$k2}{$k1}) {
$net->{_Deleted}{$k2}{$k1} = $net->{Net}{$k2}{$k1};
$ok++;
}
if (exists $net->{_Deleted}{$k2}{$k1}) {
$ok++;
}
if ($ok) {
$net->del_net($k1, $k2, 2);
# image still exists (well it should)
} else {
$c->delete("delnet-$k1-$k2");
$c->delete("delnet-$k2-$k1");
}
}
}
}
sub delete_user_dels {
my(%args) = @_;
if ($args{-force} ||
$top->messageBox(-message => M"Alle benutzerdefinierten Sperrungen löschen?",
-type => "YesNo",
-icon => "question") =~ /^yes/i) {
$net->remove_all_from_deleted(sub {
my($xy1,$xy2) = @_;
$c->delete("delnet-$xy1-$xy2");
$c->delete("delnet-$xy2-$xy1");
});
_restore_cursor();
}
}
# Return "x,y"
sub set_coords_str {
my($c, @tags) = @_;
@tags = $c->gettags('current') if !@tags;
return if !@tags;
if ($tags[0] eq 'p' or $tags[0] eq 'pp' or $tags[0] =~ /^lsa/) {
$tags[1];
} elsif ($tags[0] =~ /^[sSlL]$/ ||
$add_net{fz} && $tags[0] eq 'fz'
# XXX weitere Ausnahmen für $add_net{is} etc. definieren
) {
my($pos, @points) = nearest_line_points_mouse($c, @tags);
make_net() if !$net;
if ($net->can("adjust_to_nearest")) {
$points[0] = [ split /,/,
$net->adjust_to_nearest(join ",", @{$points[0]})
];
} else {
$net->add_net($pos, @points);
}
my($x, $y) = @{$points[0]};
Route::_coord_as_string([$x,$y]);
} else {
my($item, @tags) = find_below($c, qw/s l p pp lsa/);
return if !defined $item;
set_coords($c, @tags); # hoffentlich keine Endlosrekursion...
#die "Tag [@tags] ist weder p, pp, s noch l sollte nicht vorkommen!";
}
}
### AutoLoad Sub
sub set_coords_rbahn {
my($c, @tags) = @_;
@tags = $c->gettags('current') if !@tags;
return if !@tags;
if ($tags[0] =~ /^r-[bf]g/) {
$tags[1];
} else {
my($item, @tags) = find_below($c, qw/r-bg r-fg/);
return if !defined $item;
set_coords($c, @tags); # hoffentlich keine Endlosrekursion...
#die "Tag [@tags] ist weder p, pp, o, s noch l sollte nicht vorkommen!";
}
}
### AutoLoad Sub
sub set_coords_usbahn {
my($c, @tags) = @_;
@tags = $c->gettags('current') if !@tags;
return if !@tags;
if ($tags[0] =~ /^[ub]-[bf]g/) {
$tags[1];
} else {
my($item, @tags) = find_below($c, qw/u-bg b-bg u-fg u-bg/);
return if !defined $item;
set_coords($c, @tags); # hoffentlich keine Endlosrekursion...
#die "Tag [@tags] ist weder p, pp, o, s noch l sollte nicht vorkommen!";
}
}
### AutoLoad Sub
sub set_coords_bahn {
my($c, @tags) = @_;
@tags = $c->gettags('current') if !@tags;
return if !@tags;
if ($tags[0] =~ /^[ubr]-[bf]g/) {
$tags[1];
} else {
my($item, @tags) = find_below($c, qw/u-bg b-bg u-fg u-bg r-bg r-fg/);
return if !defined $item;
set_coords($c, @tags); # hoffentlich keine Endlosrekursion...
#die "Tag [@tags] ist weder p, pp, o, s noch l sollte nicht vorkommen!";
}
}
### AutoLoad Sub
sub set_coords_wasserrouten {
my($c, @tags) = @_;
if ($tags[0] eq 'wr') {
my($pos, @points) = nearest_line_points_mouse($c, @tags);
make_net() if !$net;
if ($net->can("adjust_to_nearest")) {
$points[0] = [ split /,/,
$net->adjust_to_nearest(join ",", @{$points[0]})
];
} else {
$net->add_net($pos, @points);
}
my($x, $y) = @{$points[0]};
Route::_coord_as_string([$x,$y]);
} else {
my($item, @tags) = find_below($c, qw/wr/);
return if !defined $item;
set_coords($c, @tags); # hoffentlich keine Endlosrekursion...
#die "Tag [@tags] ist weder p, pp, s noch l sollte nicht vorkommen!";
}
}
# Return "x,y"
### AutoLoad Sub
sub set_coords_custom {
my($c, @tags) = @_;
@tags = $c->gettags('current') if !@tags;
return if !@tags;
if ($tags[0] =~ /^L\d$/) {
my($pos, @points) = nearest_line_points_mouse($c, @tags);
make_net() if !$net;
if ($net->can("adjust_to_nearest")) {
$points[0] = [ split /,/,
$net->adjust_to_nearest(join ",", @{$points[0]})
];
} else {
$net->add_net($pos, @points);
}
my($x, $y) = @{$points[0]};
Route::_coord_as_string([$x,$y]);
} else {
my($item, @tags) = find_below_rx($c, ['^L\d'], [0]);
return if !defined $item;
set_coords($c, @tags); # hoffentlich keine Endlosrekursion...
}
}
### AutoLoad Sub
sub user_edit_street {
if (!$net) {
make_net();
}
status_message("Can't make net", "die") if !$net;
my(@click_items) = ($net_type eq 's'
? qw(s l)
: ($net_type =~ /^(r|us|rus)$/
? map { $_ eq 's' ? 'b' : $_ } split //, $net_type
: ($net_type eq 'wr'
? qw(wr)
: warn "Unhandled net type $net_type"
)
)
);
if ($net_type eq 's' && $use_faehre) {
push @click_items, "e";
}
my($item, @tags) = find_below($c, @click_items);
if (defined $item) {
my($pos, @points) = nearest_line_points_mouse($c, @tags);
my($xy1,$xy2) = (join(",",@{$points[1]}), join(",",@{$points[2]}));
$net->toggle_deleted_line
($xy1,$xy2,
sub {
my($xy1,$xy2) = @_;
set_usercross_image($xy1,$xy2)
},
sub {
my($xy1,$xy2) = @_;
$c->delete("delnet-$xy1-$xy2");
$c->delete("delnet-$xy2-$xy1");
_restore_cursor();
});
}
}
### AutoLoad Sub
sub set_usercross_image {
my($xy1,$xy2) = @_;
if (!$usercross_photo) {
$usercross_photo =
load_photo($top, 'usercross.' . $default_img_fmt);
}
my($x1,$y1,$x2,$y2) = (split(/,/,$xy1), split(/,/,$xy2));
my($midx,$midy) = (int(($x2-$x1)/2+$x1), int(($y2-$y1)/2+$y1));
($midx,$midy) = transpose($midx, $midy);
$c->createImage($midx+2,$midy-1,
-image => $usercross_photo,
-tags => ["delnet", "delnet-$xy1-$xy2"]);
}
### AutoLoad Sub
sub _restore_cursor {
if ($c->{SavedCursor}) {
$c->set_cursor($c->{SavedCursor});
undef $c->{SavedCursor};
}
}
sub set_cursor {
my $type = shift;
if (!defined $type) {
#$c->configure(-cursor => undef);
$c->set_cursor(undef);
status_message('');
} elsif (exists $cursor{$type}) {
if (exists $cursor_mask{$type}) {
#$c->configure(-cursor =>
$c->set_cursor(['@' . $cursor{$type},
$cursor_mask{$type},
'black', 'white']);
} else {
#$c->configure(-cursor =>
$c->set_cursor(['@' . $cursor{$type}, 'black']);
}
} else {
#$c->configure(-cursor => undef);
$c->set_cursor(undef);
}
if (defined $type && $type eq 'start') {
status_message(M"Start auswählen");
} elsif (defined $type && $type eq 'ziel') {
status_message(M"Ziel auswählen");
}
}
### AutoLoad Sub
sub set_cursor_data {
my $data = shift;
my $tmpfile = "$tmpdir/cursor.$$.xbm";
if (open(C, ">$tmpfile")) {
print C $data;
close C;
#$c->configure(-cursor => ['@' . $tmpfile, 'black']);
$c->set_cursor(['@' . $tmpfile, 'black']);
unlink $tmpfile;
} else {
warn "Can't set cursor data with file $tmpfile: $!";
#$c->configure(-cursor => undef);
$c->set_cursor(undef);
}
}
### AutoLoad Sub
sub set_route_start_street {
my $street = shift;
my $coord = choose_from_plz(-str => $street,
-noshow => 0);
set_route_start($coord) if $coord;
}
### AutoLoad Sub
sub set_route_ziel_street {
my $street = shift;
my $coord = choose_from_plz(-str => $street,
-noshow => 1);
set_route_ziel($coord) if $coord;
}
# Setzt den Start-Punkt der Route
# Eingabe ist "$x,$y" (realcoords)
# XXX viel Redundanz mit search_route_mouse!
### AutoLoad Sub
sub set_route_start {
my $xy = shift;
return if !defined $xy;
my $search_route_start = $xy;
if (!$net) { make_net() }
if (!$net->reachable($search_route_start)) {
my $new_search_route_start = $net->fix_coords($search_route_start);
if (!$new_search_route_start) {
$top->bell;
status_message(M"Der Startort ist nicht erreichbar", 'warn');
undef $search_route_start;
return; #goto CLEANUP;
} else {
$search_route_start = $new_search_route_start;
}
}
resetroute();
# XXX vielleicht sollte man das unabhängige Setzen von Start/Ziel
# ermöglichen (z.B. zuerst Ziel, dann Start auswählen). Z.Zt.
# muß $search_route_ziel undefiniert werden.
#XXXundef $search_route_ziel;
$search_route_flag = 'ziel';
my($x, $y) = transpose(split(/,/, $search_route_start));
set_flag('start', $x, $y);
set_cursor('ziel');
@search_route_points = [$search_route_start, POINT_MANUELL];
return;
}
# Setzt den Ziel-Punkt der Route
# Eingabe ist "$x,$y"
# XXX viel Redundanz mit search_route_mouse_cont!
### AutoLoad Sub
sub set_route_ziel {
my $xy = shift;
my(%args) = @_;
return if !defined $xy;
#XXX dieser Teil ist halbnotwendig, falls der Startpunkt manuell
# gesetzt wurde und nearest_line_points aufgerufen werden muss.
# Allerdings funktioniert nearest_line_points anscheinend nicht ohne
# gemaltes Straßennetz, wohingegen die Telefonbuch-Straßen-Auswahl
# ganz gut ohne gemaltes Straßennetz funktioniert.
# Deshalb vorerst disabled.
#
# if (@realcoords) {
# if ($net->reachable
# (Route::_coord_as_string($realcoords[$#realcoords]))) {
# $search_route_start
# = Route::_coord_as_string($realcoords[$#realcoords]);
# }
# my($tx, $ty) = transpose(@{$realcoords[$#realcoords]});
# my($pos, @points) = nearest_line_points_xy($tx, $ty);
# if (@points) { # XXX wirklich?
# $net->add_net($pos, @points);
# $search_route_start = Route::_coord_as_string($points[0]);
# } else {
# addpoint_inter();
# return;
# # $search_route_start = $search_route_ziel;
# }
# }
# my $this_search_route_start = $search_route_ziel;
# if (!defined $this_search_route_start) {
# $this_search_route_start = $search_route_start;
# if (!defined $this_search_route_start) {
# return;
# }
# }
my $this_search_route_start = $search_route_points[-1]->[SRP_COORD];
return if (!defined $this_search_route_start);
my $search_route_ziel = $xy;
if (!$net) { make_net() }
if (!$net->reachable($search_route_ziel)) {
my $new_search_route_ziel = $net->fix_coords($search_route_ziel);
if (!$new_search_route_ziel) {
$top->bell;
status_message(M"Der Zielort ist nicht erreichbar", 'warn');
undef $search_route_ziel;
return; #goto CLEANUP;
} else {
$search_route_ziel = $new_search_route_ziel;
}
}
# XXX nicht nötig? my($x, $y) = transpose(split(/,/, $search_route_ziel));
search_route($this_search_route_start, $search_route_ziel,
undef, 'cont', %args);
update_route_strname();
}
sub search_route_mouse {
my $by_button = shift;
$map_mode = MM_SEARCH;
if (!$search_route_flag) {
$search_route_flag = 'start';
if (!$lowmem) {
if ($net_type eq "s") {
if (!$net and ($str_draw{'s'} || $str_draw{'l'})) {
make_net();
}
}
# XXX $str_draw{'r'} ueberprfen, wenn im RB-Mode
$net->reset if ($net);
} else {
warn M"`Straßennetz neu berechnen' vor Suche anklicken!\n";
}
set_cursor('start');
return;
} elsif ($search_route_flag eq 'start') {
if ($by_button) {
undef $search_route_flag;
goto CLEANUP;
}
my $search_route_start = set_coords($c);
return if !defined $search_route_start;
if (!$net->reachable($search_route_start)) {
$top->bell;
status_message(M"Der Startort ist nicht erreichbar", 'warn');
undef $search_route_start;
return; #goto CLEANUP;
}
$search_route_flag = 'ziel';
my($x, $y) = transpose(split(/,/, $search_route_start));
set_flag('start', $x, $y);
set_cursor('ziel');
@search_route_points = [$search_route_start, POINT_MANUELL];
return;
} else { # ziel
if ($by_button) {
undef $search_route_flag;
goto CLEANUP;
}
my $search_route_ziel = set_coords($c);
return if !defined $search_route_ziel;
if (!$net->reachable($search_route_ziel)) {
$top->bell;
status_message(M"Der Zielort ist nicht erreichbar", 'warn');
undef $search_route_ziel;
return; #goto CLEANUP;
}
status_message('');
my $this_search_route_start = $search_route_points[-1]->[SRP_COORD];
return if !defined $this_search_route_start;
search_route($this_search_route_start, $search_route_ziel);
# XXX duplicate code (see above)
undef $search_route_flag;
update_route_strname();
search_route_mouse_cont();
return;
}
CLEANUP:
undef $search_route_flag;
set_cursor(undef);
}
# Setzt das Suchen einer Route vom bisherigen Endpunkt fort.
# Der neue Zielpunkt wurde gerade per Maus angeklickt.
sub search_route_mouse_cont {
if (!$search_route_flag) {
# ??? Es existiert noch kein Startpunkt.
$search_route_flag = 'ziel_cont';
set_cursor('ziel');
return;
} else {
my $this_search_route_start;
if (!$net) { make_net() } # Netz wird neu berechnet
if (@realcoords) { # Es existieren bereits Punkte in der Route.
if ($net->reachable
(Route::_coord_as_string($realcoords[-1]))) {
# Der vorherige Zielpunkt ist direkt erreichbar (Punkt
# existiert in der Datenbank)
$this_search_route_start
= Route::_coord_as_string($realcoords[-1]);
} else {
# Wann tritt dieser Fall auf?
warn "In search_route_mouse_cont, 2nd case";
my($tx, $ty) = transpose(@{$realcoords[-1]});
my($pos, @points) = nearest_line_points_xy($tx, $ty);
if (@points) { # XXX wirklich?
$net->add_net($pos, @points);
$this_search_route_start = Route::_coord_as_string($points[0]);
@{$realcoords[-1]} = @{$points[0]}; # XXXX workaround
# der aber nicht stimmt, wenn der letzte Punkt über
# freehand eingegeben wurde ...
# sigh, der ganze search_route_mouse_cont-Kram braucht eine
# kräftige Überarbeitung ... :-(
} else {
addpoint_inter();
return;
}
}
}
my $search_route_ziel = set_coords($c);
return if !defined $search_route_ziel;
if (!$net->reachable($search_route_ziel)) {
$top->bell;
status_message(M"Der Zielort ist nicht erreichbar", 'warn');
#$search_route_ziel = $this_search_route_start;
#undef $search_route_start;
return; #goto CLEANUP;
}
status_message('');
search_route($this_search_route_start, $search_route_ziel,
undef, 'cont');
update_route_strname();
}
CLEANUP:
}
sub plugin_menu {
my $opbm = shift;
$opbm->command(-label => M"Plugin laden",
-command => sub {
my($file) = $top->getOpenFile
(-title => M("Plugin laden"),
-filetypes => [[M"Perl-Module" => '.pm'],
[M"Alle Dateien" => '*']],
);
if (defined $file) {
load_plugin($file);
}
});
$opbm->command(-label => M"Alle Plugins zeigen",
-command => sub {
require BBBikePlugin;
BBBikePlugin::find_all_plugins($FindBin::RealBin, $top);
});
}
sub menu_entry_up_down {
my($menu, $tag_group) = @_;
my(@tags) = @$tag_group;
$menu->separator;
my $x; # dummy
$menu->radiobutton(-label => M"oben zeichnen",
-variable => \$x,
-command => sub {
foreach (@tags) { special_raise($_, 0) }
restack();
});
$menu->radiobutton(-label => M"normal",
-variable => \$x,
-command => sub {
foreach (@tags) { special_normal($_, 0) }
restack();
});
$menu->radiobutton(-label => M"unten zeichnen",
-variable => \$x,
-command => sub {
foreach (reverse @tags) { special_lower($_, 0) }
restack();
});
}
sub menu_entry_choose_ort {
my($menu, $abk, %args) = @_;
if (exists $str_attrib{$abk}) {
$menu->checkbutton(-label => $str_attrib{$abk}->[ATTRIB_PLURAL],
-variable => \$str_draw{$abk},
-command => sub { plot('str',$abk); },
(defined $args{'-accelerator'} ?
(-accelerator => $args{'-accelerator'}) :
(),
),
);
my %str_args;
if (exists $args{'-strchooseortargs'}) {
%str_args = %{$args{'-strchooseortargs'}};
}
$menu->command(-label => Mfmt("%s auswählen", $str_attrib{$abk}->[ATTRIB_SINGULAR]),
-command => sub { choose_ort('s', $abk, %str_args) });
if ($args{'-strextrachoosemenuaction'}) {
$args{'-strextrachoosemenuaction'}->();
}
if (0) { # XXX Habe ich schon seit Jahren nicht genutzt!
$menu->command
(-label => Mfmt("Liste der %s neu erstellen",
$str_attrib{$abk}->[ATTRIB_PLURAL]),
-command => sub { choose_ort('s', $abk, -rebuild => 1,
%str_args) });
$menu->command
(-label => Mfmt("Update der %s", $str_attrib{$abk}->[ATTRIB_PLURAL]),
-command => sub { undef $str_obj{$abk};
plot('str',$abk);
});
$menu->command
(-label => Mfmt("Schnelles Update der %s",
$str_attrib{$abk}->[ATTRIB_PLURAL]),
-command => sub { plot('str',$abk, FastUpdate => 1); });
}
if ($advanced) {
$menu->command
(-label => "Lazy drawing",
-command => sub {
$str_draw{$abk} = 1 - $str_draw{$abk};
plot('str',$abk, -lazy => 1);
});
}
if ($args{'-strblockings'}) {
my $sperre_abk = 'sperre_'.$abk;
$menu->checkbutton
(-label => M"gesperrte Strecken",
-variable => \$p_draw{$sperre_abk},
-command => sub {
plot_sperre($p_file{$sperre_abk},
-abk => $sperre_abk);
},
);
}
}
if (exists $p_attrib{$abk} && exists $str_attrib{$abk}) {
$menu->separator;
}
if (exists $p_attrib{$abk}) {
$menu->checkbutton(-label => $p_attrib{$abk}->[ATTRIB_PLURAL],
-variable => \$p_draw{$abk},
-command => sub { plot('p',$abk) },
(defined $args{'-accelerator_p'} ?
(-accelerator => $args{'-accelerator_p'}) :
(),
),
);
my %p_args;
if (exists $args{'-pchooseortargs'}) {
%p_args = %{$args{'-pchooseortargs'}};
}
$menu->command(-label => Mfmt("%s auswählen", $p_attrib{$abk}->[ATTRIB_SINGULAR]),
-command => sub { choose_ort('p', $abk, %p_args) });
if ($args{'-pextrachoosemenuaction'}) {
$args{'-pextrachoosemenuaction'}->();
}
if (0) { # XXX Habe ich schon seit Jahren nicht genutzt!
$menu->command
(-label => Mfmt("Liste der %s neu erstellen", $p_attrib{$abk}->[ATTRIB_PLURAL]),
-command => sub { choose_ort('p', $abk, -rebuild => 1) });
$menu->command
(-label => Mfmt("Update der %s", $p_attrib{$abk}->[ATTRIB_PLURAL]),
-command => sub { undef $p_obj{$abk};
plot_point($abk);
});
$menu->command
(-label => Mfmt("Schnelles Update der %s",
$p_attrib{$abk}->[ATTRIB_PLURAL]),
-command => sub { plot('p',$abk, FastUpdate => 1); });
}
if ($advanced) {
$menu->command
(-label => "Lazy drawing",
-command => sub {
$p_draw{$abk} = 1 - $p_draw{$abk};
plot('p',$abk, -lazy => 1);
});
}
}
}
# bindet ein Menü an die rechte Taste
sub menuright {
my($b, $menu) = @_;
$b->bind('<ButtonPress-3>' => sub {
if (0) { # old code XXX
$menu->Popup(-popover => $b,
-popanchor => 'n',
-overanchor => 's',
);
} else {
my $e = $b->XEvent;
my $X = $e->X;
my $Y = $e->Y;
$menu->Post($X,$Y);
}
}
);
}
sub menuarrow {
my($b, $menu, $col, %args) = @_;
return if !menuarrow_unmanaged($b, $menu, %args);
if (defined $col) {
$b->grid(-row => $curr_row+1, -column => $col, -sticky => 'nesw');
} else {
my(@packargs) = (exists $args{'-pack'} ? @{$args{'-pack'}} : ());
$b->pack(@packargs);
}
}
sub menuarrow_unmanaged {
my($b, $menu, %args) = @_;
return 0 if !$menuarrow_photo;
$b->configure(-menu => $menu);
$b->configure
(-image => $menuarrow_photo,
-takefocus => 1,
-highlightthickness => 1,
-indicatoron => 0,
-bd => ($small_icons ? 0 : 2),
-padx => 0,
-pady => 0,
);
my $menulabel;
if (defined $args{'-menulabel'}) {
$menulabel = $args{'-menulabel'};
} else {
for my $inx (0 .. $menu->index('last')) {
if ($menu->type($inx) !~ /^(separator|tearoff)$/) {
$menulabel = eval q{$menu->entrycget($inx, -label)};
last if defined $menulabel;
}
}
}
if (defined $menulabel and $menulabel ne '') {
(my $balloonlabel = $menulabel) =~ s/~//;
$balloon->attach($b, -msg => M("Menü")." $balloonlabel...");
}
$menu->{BBBike_Menulabel} = $menulabel if !defined $menu->{BBBike_Menulabel};
$menu->{BBBike_Special} = $args{-special};
$b->bind('<ButtonPress-3>' => sub { $b->ButtonDown });
1;
}
# error categories:
# info: never pops up a dialog: either writes to stderr or to the
# status bar if available
# warn: warn with a dialog
# err: error with a dialog
# die: error with a dialog and die afterwards
sub status_message {
my($msg, $err) = @_;
if (!defined $err || $err =~ /^info/ || !$use_dialog) {
if (!defined $progress) {
if (defined $err && $err eq 'info-stack-trace') {
require Carp;
Carp::cluck($msg);
} else {
warn "$msg\n";
}
} else {
$msg =~ s/\n+\z//;
$status_label->configure(-text => $msg);
if ($msg =~ /\n/) {
set_status_button
(-text => "OK",
-command => sub {
status_message("", "info");
});
} else {
remove_status_button();
}
}
} else {
# warn or error
if (!$top) {
warn "$msg\n";
} else {
my %args = (-title => ($err eq 'warn' ? 'Warnung' : 'Fehler'),
-text => $msg,
-bitmap => ($err eq 'warn' ? 'warning' : 'error'),
-background => Tk::NORMAL_BG,
-highlightbackground => Tk::NORMAL_BG,
);
$splash_screen->Destroy if $splash_screen; undef $splash_screen;
if ($status_message_dialog && Tk::Exists($status_message_dialog)) {
## Do not reconfigure existing dialog because of the
## (still!) two-seconds hang
#$status_message_dialog->configure(%args);
$status_message_dialog->destroy;
}# else {
my $Dialog = "Dialog";
if (eval { require Tk::LongDialog; 1 }) {
$Dialog = "LongDialog";
} else {
require Tk::Dialog;
}
$status_message_dialog = $top->$Dialog(%args);
#}
$status_message_dialog->Show;
}
}
if (defined $err && $err eq 'die') { # also die
require Carp;
Carp::confess($msg);
}
}
sub set_status_button {
my(%args) = @_;
$status_button->grid(-column => $status_button_column,
-row => 0);
if (!$args{-command}) {
die "-command missing";
}
my $cmd = $args{-command};
$args{-command} = sub {
$cmd->();
remove_status_button();
};
$status_button->configure(%args);
}
sub remove_status_button {
if ($status_button->manager) {
$status_button->configure(-text => "", -command => \&Tk::NoOp);
$status_button->gridForget;
}
}
sub add_new_point {
my $net = shift;
my $point = shift;
my(%args) = @_;
my($rx, $ry) = split(/,/, $point);
my($tx, $ty) = transpose($rx, $ry);
my($pos, @points) = nearest_line_points_xy($tx, $ty);
# Korrektur des mittleren Punktes
$points[1] = [$rx, $ry];
if (@points) {
$net->add_net($pos, @points);
}
unless ($args{'-quiet'}) {
if (!$net->reachable($point)) {
status_message(Mfmt("Der Punkt <%s> existiert im Netz nicht und kann auch nicht erzeugt werden", $point), "die");
}
}
join(",", @{ $points[1] });
}
sub nearest_line_points_xy {
my($x, $y) = @_;
my $start;
my %seen;
my $stage = 'closest';
my @find;
my $find_i;
my $safe_loop = 0; #XXX
while (1) {
die "too many loops, please report, line " . __LINE__ if ($safe_loop++ > 100);
my $find;
if ($stage eq 'closest') {
$find = $c->find('closest', $x, $y, 0, $start);
if (defined $find and $find ne '') {
if (exists $seen{$find}) {
$stage = 'overlapping';
next;
}
}
} elsif ($stage eq 'overlapping') {
if (!@find) {
@find = $c->find('overlapping', $x-2, $y-2, $x+2, $y+2);
$find_i = 0;
}
return undef if $find_i > $#find;
$find = $find[$find_i];
$find_i++;
}
my @tags = $c->gettags($find);
if ($net_type eq "r") {
if ($tags[0] eq 'r') {
return nearest_line_points($x, $y, @tags); # XXX
}
} elsif ($net_type eq "us") {
if ($tags[0] =~ /^[ub]$/) {
return nearest_line_points($x, $y, @tags); # XXX
}
} elsif ($net_type eq "rus") {
if ($tags[0] =~ /^[ubr]$/) {
return nearest_line_points($x, $y, @tags); # XXX
}
} elsif ($net_type eq 'wr') {
if ($tags[0] eq 'wr') {
return nearest_line_points($x, $y, @tags); # XXX
}
} else {
if ($tags[0] =~ /^[sSlL]$/ && !grep { /^[sSlL]-label/ } @tags) {
return nearest_line_points($x, $y, @tags); # XXX
}
}
if ($stage eq 'closest') {
$start = $find;
$seen{$find}++;
}
}
}
sub nearest_line_points_mouse {
my($c, @tags) = @_;
my $e = $c->XEvent;
my($x, $y) = ($c->canvasx($e->x), $c->canvasy($e->y));
@tags = $c->gettags('current') if !@tags;
if (grep { /-label/ } @tags) { # ignore labels
(undef, @tags) = find_below_rx($c, [q{.}], undef, [q{current}, q{-label}]);
}
nearest_line_points($x, $y, @tags);
}
# Input arguments:
# x/y: current canvas coordinates
# tags: tags of the current canvas item
# Output:
# ($index, middlepoint(new), firstpoint, secondpoint)
# points are real coordinates
sub nearest_line_points {
my($x, $y, @tags) = @_;
my(@realcoords, @coords);
if (defined $tags[3] && $tags[3] =~ /^(.+)-(\d+)$/) {
my($type, $index) = ($1, $2);
my $s;
$s = $str_obj{$type};
if (!defined $s) {
if (exists $str_file{$type}) {
# XXX better: create a function type_to_filename
my $filename = get_strassen_file($str_file{$type});
$str_obj{$type} = new Strassen $filename;
$s = $str_obj{$type};
}
if (!defined $s) {
die "Streets not defined for type $type, Filename is $str_file{$type} XXX";
}
} else {
$s->reload;
}
my $ret = $s->get($index);
if ($ret and @{$ret->[Strassen::COORDS]}) {
# Erste Methode. $str_width wird von 2 bis 4 inkrementiert
# (hängt von der Breite der Straßen ab).
for my $str_width (2 .. 4) {
my $i;
my($lastxx, $lastyy, $lastrx, $lastry);
for($i = 0; $i <= $#{$ret->[Strassen::COORDS]}; $i++) {
if ($ret->[Strassen::COORDS][$i] =~ /^(?:[A-Z])?(-?\d+(?:\.\d*)?),(-?\d+(?:\.\d*)?)$/) {
my($rx, $ry) = ($1, $2);
my($xx, $yy) = transpose($rx, $ry);
push @realcoords, $rx, $ry;
push @coords, transpose($xx, $yy);
if (defined $lastxx &&
(($x >= $lastxx-$str_width &&
$x <= $xx+$str_width) ||
($x >= $xx-$str_width &&
$x <= $lastxx+$str_width)) &&
(($y >= $lastyy-$str_width &&
$y <= $yy+$str_width) ||
($y >= $yy-$str_width &&
$y <= $lastyy+$str_width))) {
my($p1, $p2) = anti_transpose($x, $y);
my($fp1, $fp2) = fusspunkt($lastrx, $lastry,
$rx, $ry,
$p1, $p2);
# XXX Achtung! $index kann nicht gebraucht werden, wenn
# mit Multistrassen gearbeitet wird. Lösung?
# Zuordnung von Strassen-Indices auf Multistrassen-Indices?
#XXX return ((defined $multistrassen ? undef : $index),
# XXX test it:
my(@points) = ([int_round($fp1), int_round($fp2)],
[$lastrx, $lastry],
[$rx, $ry]);
if ($net and
$net->{Strassen}->isa('MultiStrassen')) {
SEARCH: {
for my $i (0 .. $#{$net->{SourceAbk}}) {
if ($net->{SourceAbk}[$i] eq $type) {
$index +=
$net->{Strassen}{FirstIndex}[$i];
last SEARCH;
}
}
warn "Can't find index for MultiStrassen...";
undef $index;
}
}
return ($index, @points);
} else {
($lastxx, $lastyy) = ($xx, $yy);
($lastrx, $lastry) = ($rx, $ry);
}
} else {
die "Can't parse coord: $ret->[Strassen::COORDS][$i]";
}
}
}
}
warn "nearest_line_points: failed 1st method
Tags are @tags
Type is $type
Index is $index
Try 2nd method...";
} else {
die "Can't find index from tags: @tags";
}
# 2. Methode. Die nächsten zwei Punkte in @coords werden einfach als
# Nachbarn deklariert. Funktioniert ganz gut, es sei denn, die Straße
# hat einen *sehr* kurvigen Verlauf (90°-Kurven etc.).
my(@coords_dist, $nearest_i);
my $i;
if ($#coords > 0) {
for($i = 0; $i < $#coords; $i+=2) {
my($lx, $ly) = ($coords[$i], $coords[$i+1]);
push(@coords_dist,
Strassen::Util::strecke([$x, $y],
[$coords[$i], $coords[$i+1]]));
if (!defined $nearest_i or
$coords_dist[$nearest_i] > $coords_dist[-1]) {
$nearest_i = $#coords_dist;
}
}
}
my @res = ([anti_transpose($x, $y)]);
if (!defined $nearest_i) {
die "No nearest point???";
} elsif ($nearest_i == 0) {
push(@res, [@realcoords[0..1]], [@realcoords[2..3]]);
} elsif ($nearest_i == $#coords_dist) {
my $last = $#coords_dist;
push(@res,
[@realcoords[$last*2-2 .. $last*2-1]],
[@realcoords[$last*2 .. $last*2+1]]);
} elsif ($coords_dist[$nearest_i-1] < $coords_dist[$nearest_i+1]) {
push(@res,
[@realcoords[$nearest_i*2-2 .. $nearest_i*2-1]],
[@realcoords[$nearest_i*2 .. $nearest_i*2+1]]);
} else {
push(@res,
[@realcoords[$nearest_i*2 .. $nearest_i*2+1]],
[@realcoords[$nearest_i*2+2 .. $nearest_i*2+3]]);
}
(undef, @res);
}
sub city_settings {
$str_draw{'l'} = 0;
$p_draw{'o'} = 0;
$p_far_away{'o'} = 0;
$str_far_away{'w'} = 0;
$str_far_away{'l'} = 0;
$str_regions{'l'} = [];
$wasserumland = 0;
pending(1, map { "replot-$_" } ("str-l", "p-o", "str-w", "str-l"));
}
sub region_settings {
$str_draw{'l'} = 1; # XXX set to str_draw{'s'}?
$p_draw{'o'} = 1;
$p_far_away{'o'} = 0;
$str_far_away{'w'} = 0;
$str_far_away{'l'} = 0;
$str_regions{'l'} = [];
$wasserumland = 1;
pending(1, map { "replot-$_" } ("str-l", "p-o", "str-w", "str-l"));
}
sub jwd_settings {
$str_draw{'l'} = 1; # XXX set to str_draw{'s'}?
$p_draw{'o'} = 1;
$p_far_away{'o'} = 1;
$str_far_away{'w'} = 1;
$str_far_away{'l'} = 1;
$str_regions{'l'} = []; # XXX Sachsen-Anhalt?
$wasserumland = 1;
pending(1, map { "replot-$_" } ("str-l", "p-o", "str-w", "str-l"));
}
# Definiert, wie die grafischen Objekte "gestapelt" werden sollen.
# Also ganz unten Gewässer und Flächen, dann Straßen etc. und ganz oben
# Punkte wie Haltestellen, Orte und Kreuzungen.
# Allgemeine Flächen kommen unter Gewässer, damit man z.B. bei in
# Wäldern gelegenen Seen nicht aufwendig ausschneiden muss.
# Ganz oben sind die mit "Custom draw" gezeichneten Strecken.
# Weitere Regeln: Labels von Orten sind unter anderen Ortspunkten (damit
# die Ortspunkte anwählbar bleiben), dagegen sind Labels von Bahnhöfen
# über den Bahnhofspunkten und Bahnstrecken (müssen nicht anwählbar sein).
# Development-Hilfen (fz) ganz oben anzeigen.
sub restack {
my @real_order;
@real_order = real_stack_order();
foreach (@real_order) {
$c->raise($_);
}
Hooks::get_hooks("after_change_stacking")->execute();
}
# gibt das aktuelle Stacking aus
sub real_stack_order {
my @real_order;
if (defined @set_stack_order) {
return @set_stack_order;
}
push @real_order, @special_lower;
foreach (@normal_stack_order) {
if (!$special_lower{$_} && !$special_raise{$_}) {
push @real_order, $_;
}
}
push @real_order, @special_raise;
@real_order;
}
### AutoLoad Sub
sub real_type_stack_order {
my @real_order = real_stack_order();
my @res;
my %seen;
foreach my $type (@real_order) {
$type =~ s/^([^-]*)-.*/$1/;
if (!$seen{$type}) {
push @res, $type;
$seen{$type}++;
}
}
@res;
}
### AutoLoad Sub
sub set_normal_stack_order {
@set_stack_order = @normal_stack_order;
%special_lower = ();
%special_raise = ();
restack();
}
### AutoLoad Sub
sub special_normal {
my($abk, $delay) = @_;
if (exists $special_lower{$abk}) {
delete $special_lower{$abk};
remove_from_array(\@special_lower, $abk);
}
if (exists $special_raise{$abk}) {
delete $special_raise{$abk};
remove_from_array(\@special_raise, $abk);
}
restack() unless $delay;
}
### AutoLoad Sub
sub special_raise {
my($abk, $delay) = @_;
if (exists $special_lower{$abk}) {
delete $special_lower{$abk};
remove_from_array(\@special_lower, $abk);
}
$special_raise{$abk}++;
remove_from_array(\@special_raise, $abk);
push @special_raise, $abk;
restack() unless $delay;
}
### AutoLoad Sub
sub special_lower {
my($abk, $delay) = @_;
if (exists $special_raise{$abk}) {
delete $special_raise{$abk};
remove_from_array(\@special_raise, $abk);
}
$special_lower{$abk}++;
remove_from_array(\@special_lower, $abk);
unshift @special_lower, $abk;
restack() unless $delay;
}
sub remove_from_array {
my($a_ref, $val) = @_;
for(my $i = 0; $i <= $#{$a_ref}; $i++) {
if ($a_ref->[$i] eq $val) {
splice @$a_ref, $i, 1;
$i--;
}
}
}
sub destroy_delayed_restack {
destroy_delayed_sub('restack');
}
sub fix_stack_order {
my($abk) = @_;
if (!grep { $_ eq $abk } @normal_stack_order) {
push @normal_stack_order, $abk, "$abk-fg";
}
}
### AutoLoad Sub
sub add_to_stack {
my($abk, $how, $other_abk) = @_;
return if (grep { $_ eq $abk } @normal_stack_order);
my $i = 0;
for (@normal_stack_order) {
if ($_ eq $other_abk) {
if ($how eq 'after') {
splice @normal_stack_order, $i+1, 0, $abk, "$abk-fg";
return;
} elsif ($how eq 'before') {
splice @normal_stack_order, $i, 0, $abk, "$abk-fg";
return;
} else {
die "Cannot handle $how in add_to_stack";
}
}
$i++;
}
push @normal_stack_order, $abk, "$abk-fg";
}
### AutoLoad Sub
sub remove_from_stack {
my($abk) = @_;
@normal_stack_order = grep { $_ ne $abk } @normal_stack_order;
}
sub restack_delayed {
# Use the delaying only on slow systems. For fast systems,
# delaying is disturbing for the interactivity.
delayed_sub(\&restack, -busy => $slowcpu ? !$edit_mode && !$edit_normal_mode : 0,
-delay => $slowcpu ? 1000 : 300,
-name => 'restack');
}
sub destroy_delayed_sub {
my $name = shift;
if ($delayed_sub_timer{$name}) {
$delayed_sub_timer{$name}->cancel;
delete $delayed_sub_timer{$name};
}
}
sub delayed_sub {
my($sub, %args) = @_;
my $ms = $args{'-delay'} || 1000;
my $name = $args{'-name'} || "";
my $busy = (defined $args{'-busy'} ? $args{'-busy'} : 1);
destroy_delayed_sub($name);
$delayed_sub_timer{$name} = $top->after
($ms, sub {
## DEBUG_BEGIN
#benchbegin("Delayed sub $name");
## DEBUG_END
IncBusy($top) if $busy;
eval {
$sub->();
};
warn __LINE__ . ": $@" if $@;
DecBusy($top) if $busy;
## DEBUG_BEGIN
#benchend();
## DEBUG_END
});
}
### AutoLoad Sub
sub show_logo { # und About
my $as_about = shift || '';
return unless $use_logo || $as_about;
my $logotop = redisplay_top($top, "about-$as_about",
-title => ($as_about ? M('Über').' ' : '')
. 'BBBike',
-background => 'white');
return if !defined $logotop;
$logotop->optionAdd("*" . substr($logotop->PathName, 1)
. "*background" => 'white', 'startupFile');
$logotop->optionAdd("*" . substr($logotop->PathName, 1)
. "*foreground" => 'blue3', 'startupFile');
$logotop->transient($top) unless $as_about;
my $ff = $logotop->Frame(-relief => ($as_about ? 'ridge' : 'flat'),
-bd => ($as_about ? 2 : 0),
)->pack(-fill => 'both', -expand => 1);
my $f = $ff->Frame->pack(-side => 'left',
-fill => 'both', -expand => 1,
-padx => 4, -pady => 4,
);
my $Button_or_Label = ($as_about ? "Button" : "Label");
my $www_b =
$f->$Button_or_Label
(-text =>
"$progname $VERSION\n" .
"(File Rev $PROG_REVISION)\n\n" .
M("Ein Informationssystem für Radfahrer in Berlin") .
"\n\n© 1995-2005 Slaven Rezic",
-wraplength => 230,
-font => $font{'bold'},
-padx => 5,
-pady => 0,
-highlightthickness => 0,
-relief => 'flat',
-borderwidth => 0,
($as_about ?
(-command => sub {
require WWWBrowser;
WWWBrowser::start_browser($BBBike::BBBIKE_WWW);
},
) : ())
)->pack(-fill => 'x');
$balloon->attach($www_b, -msg => M"WWW-Version aufrufen")
if $balloon;
my $copying_b =
$f->$Button_or_Label
(-text => M"Siehe auch die Datei COPYING",
-padx => 5,
-highlightthickness => 0,
-relief => "flat",
-borderwidth => 0,
($as_about ?
(-command => sub { copying_viewer($logotop) }) : ()),
)->pack(-fill => "x");
if ($as_about) {
my $os_info = "OS: $^O";
if ($os eq 'win') {
$os_info .= " (" . ($Config{'cc'} =~ /^gcc/
? 'gcc' :
($Config{'cc'} eq 'cl.exe'
? 'Visual C'
: $Config{'cc'})) . ")";
}
# Are we running an emulation?
if (is_in_path("uname")) {
chomp(my $real_os = `uname`);
if ($^O !~ /^$real_os$/i) {
$os_info .= " (Real OS: $real_os)";
}
}
$f->Label(-text => "perl $]\nTk $Tk::VERSION\n$os_info",
-font => $font{'small'},
-justify => 'left',
)->pack(-anchor => 'w', -expand => 1,
-fill => 'x');
}
my $mail_b =
$f->$Button_or_Label
(-text => $BBBike::EMAIL,
-padx => 5,
-pady => 0,
-relief => 'flat',
-borderwidth => 0,
-highlightthickness => 0,
($as_about ?
(-command => sub {
if ($^O eq 'MSWin32') {
require Win32Util;
Win32Util::start_mail_composer($BBBike::EMAIL);
} else {
enter_send_mail(M"BBBike perl/Tk",
-to => $BBBike::EMAIL,
);
}
}) : ()),
-font => $font{'normal'})->pack(-fill => 'x');
$balloon->attach($mail_b, -msg => M"Mail an den Autor schicken")
if $balloon;
$ff->Label(-image => $srtbike_photo
)->pack(-side => 'left', -anchor => "ne");
if ($as_about) {
my $okb = $logotop->Button(Name => 'ok',
-command => sub { hide_logo($as_about) },
)->pack(-anchor => 'c', -pady => 4);
$logotop->bind('<Return>' => sub { $okb->invoke });
} else {
$logotop->transient($top);
}
$logotop->withdraw;
$logotop->Popup(-popover => ($as_about ? 'cursor' : $top));
$logotop->update; # damit der Inhalt sofort erscheint
}
### AutoLoad Sub
sub hide_logo {
my $as_about = shift || '';
my $t = $toplevel{"about-$as_about"};
if (defined $t && Tk::Exists($t)) {
$t->destroy;
undef $toplevel{"about-$as_about"};
}
}
### AutoLoad Sub
sub copying_viewer {
my $top = shift;
simple_file_viewer($top, "$FindBin::RealBin/COPYING",
-title => M"COPYING",
-class => "Bbbike Copyright",
);
}
### AutoLoad Sub
sub simple_file_viewer {
my($top, $file, %args) = @_;
my $title = $args{-title};
my $class = $args{-class};
if (open(C, $file)) {
binmode C;
my $t = $top->Toplevel
((defined $title ? (-title => $title) : ()),
(defined $class ? (-class => $class) : ()),
);
my $txt = $t->Scrolled("ROText", -scrollbars => "osoe")->pack(-fill => "both", -expand => 1);
while(<C>) {
$txt->insert("end", $_);
}
close C;
$t->Button(Name => 'close',
-command => sub { $t->destroy },
)->pack(-fill => "x", -expand => 1);
} else {
status_message(Mfmt("Die Datei %s kann nicht geöffnet werden: %s",
$file, $!), "error");
}
}
######################################################################
# Utilities ...
### AutoLoad Sub
sub usage {
my($msg, $getopt_listref) = @_;
my(@getopt_list) = @$getopt_listref;
if (defined $msg) {
$msg .= "\n";
} else {
$msg = '';
}
my @opt;
my $i;
for($i = 0; $i <= $#getopt_list; $i+=2) {
if ($getopt_list[$i] =~ /([^!=]+)(!|=.)?$/) {
my $mod = $2 || '';
if ($mod eq '!') {
push @opt, map { "[-[no]$_]" } split(/\|/, $1);
} else {
push @opt, map { "[-$_$mod]" } split(/\|/, $1);
}
} else {
push @opt, "[-$getopt_list[$i]]";
}
}
die $msg . wrap("usage: $progname ", "\t", join(" ", @opt))
. "\n";
}
### AutoLoad Sub
sub windrose { # funktioniert nur mit quadratischen Buttons
my($senkrecht) = @_; # "Geschwindigkeit" des Scrollens
my $e = $windrose_button->XEvent;
my($x, $y) = ($e->x, $e->y);
my($w, $h) = ($windrose_button->width, $windrose_button->height);
$senkrecht = 1 unless defined $senkrecht;
my $is_center = sub {
my($x, $y) = @_;
($x > $w*0.4 && $x < $w*0.6 &&
$y > $h*0.4 && $y < $h*0.6)
};
my $center_delay;
if ($is_center->($x, $y) && !$center_delay) {
$center_delay = $c->after
(1000, sub {
undef $center_delay;
my $e = $windrose_button->XEvent;
my($x, $y) = ($e->x, $e->y);
if ($is_center->($x, $y)) {
$c->center_view;
}
});
} elsif ($x-0.25*$w < 0.5*$y) {
if ($x-0.75*$w > -0.5*$y) {
my($y) = $c->yview;
$c->yview(scroll => $senkrecht, 'units'); # S
} elsif ($x+0.5*$w > 2*$y) {
$c->yview(scroll => -$senkrecht, 'units'); # N
$c->xview(scroll => -$senkrecht, 'units'); # W
} elsif ($x-1.5*$w > -2*$y) {
$c->yview(scroll => $senkrecht, 'units'); # S
$c->xview(scroll => -$senkrecht, 'units'); # W
} else {
$c->xview(scroll => -$senkrecht, 'units'); # W
}
} else {
if ($x-0.75*$w < -0.5*$y) {
$c->yview(scroll => -$senkrecht, 'units'); # N
} elsif ($x+0.5*$w < 2*$y) {
$c->yview(scroll => $senkrecht, 'units'); # S
$c->xview(scroll => $senkrecht, 'units'); # E
} elsif ($x-1.5*$w < -2*$y) {
$c->yview(scroll => -$senkrecht, 'units'); # N
$c->xview(scroll => $senkrecht, 'units'); # E
} else {
$c->xview(scroll => $senkrecht, 'units'); # E
}
}
}
### AutoLoad Sub
sub check_font {
my $font = shift;
eval { $top->Label(-font => $font)->destroy };
$@ eq '';
}
sub IncBusy {
my($top, %args) = @_;
return if !Tk::Exists($top);
if (!$top->{'Busy'}) {
if (eval q{ require Tk::InputO; 1 }) {
for my $t ($top, values(%toplevel)) {
next if !Tk::Exists($t);
next if $args{-except} && $args{-except}{$t};
my $io = (Tk::Exists($t->{'BusyIO'})
? $t->{'BusyIO'}
: $t->InputO);
$io->configure(-cursor => (defined $args{-cursor} ? $args{-cursor} : 'watch'));
$io->place('-x' => 0, '-y' => 0, -relwidth => 1, -relheight => 1);
$io->idletasks;
$t->{'Busy'} = 1;
$t->{'BusyIO'} = $io;
}
} else {
# see changes in TkChange.pm
$top->Busy(-recurse => 1, %args);
}
}
$top->{'BusyCount'}++;
}
sub DecBusy {
my($top) = @_;
return if !Tk::Exists($top);
$top->{'BusyCount'}-- if $top->{'BusyCount'} > 0;
if ($top->{'BusyCount'} < 1) {
if ($top->{'BusyIO'}) {
for my $t ($top, values(%toplevel)) {
next if !Tk::Exists($t) ||
!Tk::Exists($t->{'BusyIO'});
$t->{'BusyIO'}->placeForget;
}
delete $top->{'Busy'};
} else {
$top->Unbusy;
}
}
}
#XXXX del: ist nicht mehr noetig
#### AutoLoad Sub
#sub ResetBusy {
# my $top = shift;
# return if !Tk::Exists($top);
# $top->Unbusy;
# $top->{'BusyCount'} = 0;
#}
### AutoLoad Sub
sub redisplay_top {
my($top, $name, %args) = @_;
my $force = delete $args{-force};
my $deiconify = (exists $args{-deiconify} ? delete $args{-deiconify} : 1);
my $raise = (exists $args{-raise} ? delete $args{-raise} : 1);
if (!exists $args{-class}) {
$args{-class} = "Bbbike Window";
}
my $t = $toplevel{$name};
my $exists = 0;
if (defined $t && Tk::Exists($t)) {
if ($force) {
$t->destroy;
delete $toplevel{$name};
} else {
$exists = 1;
}
}
if ($exists) {
$t->deiconify if $deiconify;
# win32 benötigt zusätzliches raise
$t->raise if $raise;
undef;
} else {
$toplevel{$name} = $top->Toplevel(%args);
set_as_toolwindow($toplevel{$name});
$toplevel{$name}->OnDestroy(sub { delete $toplevel{$name} });
$toplevel{$name};
}
}
sub pending {
my($bool, @types) = @_;
if ($bool) {
foreach (@types) {
if (defined $immediate{$_}) {
if ($immediate{$_} == 1) {
update($_);
} elsif ($immediate{$_} == 2) {
$pending{$_}++;
delayed_sub(sub { update() }, -name => 'pending');
}
} else {
$pending{$_}++;
}
}
}
}
sub update {
my $type = shift;
my @types;
if (defined $type) {
@types = ($type);
} else {
@types = keys %pending;
}
foreach $type (@types) {
if ($type =~ /^replot-(.*)-(.*)$/) {
my($str_p, $elem) = ($1, $2);
plot($str_p,$elem);
} elsif ($type eq 'recalc-net') {
make_net();
} else {
die "Unknown update type: $type";
}
}
}
### AutoLoad Sub
sub calc_ampel_optimierung {
return if !$ampel_optimierung;
if ($average_v == -1) {
# manuelle Eingabe, keine Berechnung notwendig...
status_message(Mfmt("Einstellungen: verlorene Strecke pro Ampel: %d m", $lost_strecke_per_ampel), "info");
} else {
require Ampelschaltung;
my $speed = 20;
if ($average_v != 0) {
$speed = $average_v;
} else {
if ($active_speed_power{Type} eq 'speed') {
$speed = $speed[$active_speed_power{Index}];
} elsif ($active_speed_power{Type} eq 'power' and $bikepwr) {
my $bp_obj = new BikePower;
$bp_obj->given('P');
$bp_obj->power($power[$active_speed_power{Index}]);
$bp_obj->calc;
$speed = float_prec($bp_obj->velocity*3.6, 1);
}
}
my %res = Ampelschaltung::get_lost($speed, $beschleunigung);
$lost_time_per_ampel{X} = $res{-zeit}; # XXX F
$lost_strecke_per_ampel = $res{-strecke};
status_message(Mfmt("Einstellungen für %s km/h: verlorene Zeit pro Ampel: %s s, verlorene Strecke pro Ampel: %d m", $speed, float_prec($lost_time_per_ampel{X}, 1), $lost_strecke_per_ampel), "info"); # XXX F
}
}
sub now_time_hires { Tk::timeofday() }
# evtl. utimes benutzen
sub cache_decider_init { $cache_decider_time = now_time_hires() }
sub cache_decider {
die "cache_decider on empty cache_decider_time scalar"
if !defined $cache_decider_time;
my $now = now_time_hires();
my $r = ($now - $cache_decider_time > $min_cache_decider_time);
if ($verbose && $r) {
warn "Using cache (" . ($now - $cache_decider_time) . " s)!\n";
}
undef $cache_decider_time;
$r;
}
### AutoLoad Sub
sub add_last_loaded {
my($file, $last_loaded_obj, $add_def) = @_;
$add_def = "" if !defined $add_def;
eval {
require File::Spec;
$file = File::Spec->canonpath($file);
$file = File::Spec->rel2abs($file);
};
my $max = $last_loaded_obj->{Max} || 4; # maximale Anzahl in @last_loaded
my $i;
for($i = 0; $i <= $#{ $last_loaded_obj->{List} }; $i++) {
my($file_part) = $last_loaded_obj->{List}->[$i] =~ /^([^\t]*)/;
if ($file_part eq $file) {
splice @{ $last_loaded_obj->{List} }, $i, 1;
$i--;
}
}
unshift @{ $last_loaded_obj->{List} }, $file . $add_def;
splice @{ $last_loaded_obj->{List} }, $max
if @{ $last_loaded_obj->{List} } > $max;
update_last_loaded_menu($last_loaded_obj);
if ($os eq 'win') {
require Win32Util;
Win32Util::add_recent_doc($file);
}
}
sub load_last_loaded {
my $last_loaded_obj = shift;
undef @{ $last_loaded_obj->{List} };
if (open(LAST, $last_loaded_obj->{File})) {
while(<LAST>) {
chomp;
s/\r//g; # DOS-Newlines entfernen (kann passieren!)
push @{ $last_loaded_obj->{List} }, $_;
}
close LAST;
update_last_loaded_menu($last_loaded_obj);
}
}
sub save_last_loaded {
my $last_loaded_obj = shift;
if (@{ $last_loaded_obj->{List} } && open(LAST, ">$last_loaded_obj->{File}")) {
print LAST join("\n", @{ $last_loaded_obj->{List} }), "\n";
close LAST;
}
}
sub update_last_loaded_menu {
my $last_loaded_obj = shift;
my $last_loaded_menu = $last_loaded_obj->{Menu};
return unless $last_loaded_menu;
if (!Tk::Exists($last_loaded_menu)) {
die "XXX Can't update last loaded menu $last_loaded_menu";
}
$last_loaded_menu->delete(0, 'end');
if (!@{ $last_loaded_obj->{List} }) {
$last_loaded_menu->command(-label => "Flaschen leer",# kein M
-state => 'disabled',
-font => $font{'bold'});
} else {
$last_loaded_menu->command(-label => $last_loaded_obj->{Title},
-state => 'disabled',
-font => $font{'bold'});
foreach my $_file (@{ $last_loaded_obj->{List} }) {
my($file, @args) = split /\t/, $_file;
$last_loaded_menu->command(-label => $file,
-command => [$last_loaded_obj->{Cb}, $file, @args],
);
}
}
}
### AutoLoad Sub
sub fast_settings {
foreach (keys %init_str_draw) {
$init_str_draw{$_} = 0;
$str_outline{$_} = 0;
}
foreach (keys %init_p_draw) {
$init_p_draw{$_} = 0;
}
$show_grade = 0;
$use_logo = 0;
undef $center_on_str;
undef $center_on_coord;
$init_choose_street = 0;
$autosave_opts = 0; # besser ist's
$do_activate_temp_blockings = 0;
}
sub set_mouse_desc {
if ($special_edit eq 'radweg') {
$mouse_text[1] = M"Radweg editieren";
$mouse_text[2] = M"Letzte Aktion wiederholen";
$mouse_text[3] = '';
} elsif ($special_edit eq 'ampel') {
$mouse_text[1] = M"Ampel editieren";
$mouse_text[2] = $mouse_text[3] = '';
} else {
$mouse_text[1] = M"Punkt zur Route hinzufügen\nmit Alt oder Shift: Mauscursor muss sich nicht über einer Straße befinden";
my $label = $b2_mode_desc{$b2_mode};
if (defined $label) {
$mouse_text[2] = $label;
} else {
$mouse_text[2] = "???";
}
if ($right_is_popup) {
$mouse_text[3] = M"Popup-Menü";
} else {
$mouse_text[3] = M"Gesamte Route löschen";
}
}
}
# Create the fontset for bbbike. Use $std_font as default normal font,
# or, if not defined, use the system default (e.g. from the option
# database). The fontset is stored to the global hash %font.
# $top is the main window.
sub set_fonts {
my $std_font = shift;
# backward compatibility with Tk 402:
if ($Tk::VERSION <= 402.004) {
set_fonts_402();
} else {
# XXX check it under all platforms!
my $get_std_font = sub {
my $std_font = $top->optionGet('font', 'Font');
if (!defined $std_font || $std_font eq '') {
my $l = $top->Label;
$std_font = $l->cget(-font);
if ($^O eq 'MSWin32') {
# XXX Force usage of Arial, otherwise "MS Sans
# Serif" is used on my system which is not nicely
# scalable.
my(%std_font) = $l->fontActual($std_font);
$std_font = $top->fontCreate(-family => 'Arial',
-size => $std_font{-size});
}
$l->destroy;
}
$std_font;
};
my $font_from_user = 0; # true, if from options or set interactively
my $font_size_from_user = 0;
if (!defined $std_font || $std_font eq '') {
# $font_family, $font_size, $font_weight from cmdline
if (defined $font_family && $font_family ne "" && !$kde) {
if (!defined $font_size) {
my $std_font = $get_std_font->();
$font_size = $top->fontActual($std_font, '-size');
} else {
$font_size_from_user = 1;
}
$font_from_user = 1;
my(%a) = (-family => $font_family);
if (defined $font_size && $font_size =~ /^-?\d+$/) {
$a{-size} = $font_size;
}
if (defined $font_weight && $font_weight ne '') {
$a{-weight} = $font_weight;
}
eval {
$std_font = $top->fontCreate(%a);
};
if ($@) {
my $err = $@;
$std_font = "helvetica 10";
warn Mfmt("Fehler beim Definieren des Zeichensatzes:\n" .
"%s\n" .
"Fallback auf den Zeichensatz <%s>.\n",
$err, $std_font) .
wrap("", "",
Mfmt("Dieser Fehler kann möglicherweise durch Korrigieren der Einträge <fontfamily> und <fontheight> in <%s> oder <*font> in <~/.Xdefaults> behoben werden.",
catfile($bbbike_configdir, "config"))) .
"\n";
}
$top->optionAdd('*font' => $std_font, 'userDefault');
} else {
$std_font = $get_std_font->();
}
} else {
$font_from_user = $font_size_from_user = 1;
}
if ($std_font) {
$font{'normal'} = $top->fontCreate($top->fontActual($std_font));
} else {
$font{'normal'} = $top->fontCreate;
}
my %normal_attr = $top->fontActual($font{'normal'});
my $pt = $normal_attr{'-size'}; # points or pixels depending on Tk ver
my $win_width = @want_extends ? $want_extends[GEOMETRY_WIDTH] : $top->width;
if ($win_width <= 800 && abs($pt) >= 10 && !$font_size_from_user) {
## XXX This is evil: because the fontsize will be from time to time smaller
## if the use resizes below the limits and then above the limits.
## On the other side, this will result in too big fonts on small
## displays. Solution?
if ($win_width <= 320) {
$pt = $pt*8/14;
} elsif ($win_width <= 640) {
$pt = $pt*10/14;
} else {
$pt = $pt*12/14;
}
$top->fontConfigure($font{'normal'}, -size => sprintf("%.f", $pt));
$top->optionAdd('*font' => $font{'normal'}, 'userDefault');
}
if ($os eq 'win') {
$top->optionAdd('*font' => $font{'normal'}, 'userDefault');
}
foreach (qw(veryhuge huge verylarge large bold
reduced small tiny fixed standard fix15)) {
$font{$_} = $top->fontCreate($top->fontActual($font{'normal'}));
}
my $minfs = sub {
my $fs = shift;
$fs = 6 if (abs($fs) < 6);
$fs;
};
$top->fontConfigure($font{'bold'},
-size => sprintf("%.f", $minfs->($pt)),
-weight => 'bold');
$top->fontConfigure($font{'fix15'},
-size => ($small_icons ? -8 : -15));
$top->fontConfigure($font{'tiny'},
-size => sprintf("%.f", $minfs->($pt*8/14)));
$top->fontConfigure($font{'small'},
-size => sprintf("%.f", $minfs->($pt*10/14)));
$top->fontConfigure($font{'reduced'},
-size => sprintf("%.f", $minfs->($pt*12/14)));
$top->fontConfigure($font{'large'},
-size => sprintf("%.f", $minfs->($pt*18/14)));
$top->fontConfigure($font{'verylarge'},
-size => sprintf("%.f", $minfs->($pt*24/14)));
$top->fontConfigure($font{'huge'},
-size => sprintf("%.f", $minfs->($pt*28/14)));
$top->fontConfigure($font{'veryhuge'},
-size => sprintf("%.f", $minfs->($pt*36/14)));
$top->fontConfigure($font{'standard'},
-size => $standard_height,
-slant => 'roman',
-underline => 0,
-overstrike => 0);
if (abs($pt) >= 8) {
$font{'fixed'}
= sprintf("-*-$fixed_font_family-medium-r-normal--*-%d-*-*-m-*-iso8859-1", $pt*10);
} else {
$font{'fixed'} = "5x7"; # XXX really necessary?
}
my %min_sizes =
('helvetica' => [10,8],
'times' => [12,10],
'lucida' => [9,8],
'new century schoolbook' => [9,8],
'fixed' => [7,7],
);
# Resize if necessary, to prevent fonts from being too small.
# This is from looking at readable fonts under the iPAQ. I found
# that Lucida can produce the smallest readable fonts.
while(my($k,$v) = each %font) {
next if $k eq 'fixed'; # This is not a named font, so ignore this.
my $family = $top->fontActual($v, '-family');
my $minsize = $min_sizes{$family};
$minsize = [10,8] if !defined $minsize;
if ($top->fontMetrics($v, "-linespace") < $minsize->[0]) {
$top->fontConfigure($v, -size => -$minsize->[1]);
}
}
}
@font = ();
foreach (qw(tiny small reduced normal large verylarge huge veryhuge)) {
push @font, $_;
}
}
# Setzt Bild, falls vorhanden, andernfalls ein Label
sub image_or_text {
my($image, $text) = @_;
if (defined $image) {
(-image => $image);
} else {
(-text => $text);
}
}
# Doc?
### AutoLoad Sub
sub image_from_file {
my($top, $file, %args) = @_;
my $mimetype = $args{'-mimetype'};
my $colormode = $args{'-colormode'} || 'color';
if ($file =~ /\.jpe?g$/i ||
(defined $args{-mimetype} and $args{-mimetype} eq 'image/jpeg')) {
eval { require Tk::JPEG };
if ($@) {
return if !perlmod_install_advice('Tk::JPEG');
}
} elsif ($file =~ /\.png$/i ||
(defined $args{-mimetype} and $args{-mimetype} eq 'image/png')) {
eval { require Tk::PNG };
if ($@) {
return if !perlmod_install_advice('Tk::PNG');
}
}
if ($colormode eq 'mono') {
$top->Bitmap(-file => $file);
} elsif ($colormode eq 'pixmap') {
$top->Pixmap(-file => $file);
} elsif ($colormode eq 'gray') {
$top->Photo(-file => $file, -palette => 8);
} else {
$top->Photo(-file => $file);
}
}
# Lädt ein Bild.
sub load_photo {
my($top, $file, %args) = @_;
return $photo{$file} if exists $photo{$file};
my $photo;
unless ($lowmem) {
eval {
my @name = exists $args{-name} ? ($args{-name}) : ();
if ($file =~ /.xpm$/ && !$small_icons) {
$photo = $top->Pixmap(@name, -file => Tk::findINC($file));
} else {
$photo = $top->Photo(@name, -file => Tk::findINC($file));
}
if ($small_icons && $photo) {
# XXX setting of @name missing
my $small_photo = $top->Photo(-width => $photo->width/2,
-height => $photo->height/2);
$small_photo->copy($photo, -subsample => 2, 2);
$photo->delete;
$photo = $small_photo;
}
};warn $@ if $@;
}
if ($args{-persistent}) {
$photo{$file} = $photo;
}
$photo;
}
sub load_cursor {
my($def) = @_;
return if $Tk::platform eq 'MSWin32'; # no support for custom cursors yet
my $key = my $lang_def = $def;
if ($def eq 'ziel') {
$lang_def = M($def);
}
my $base = $lang_def . '_ptr.xbm';
my $xbm = Tk::findINC($base);
if (!defined $xbm) {
warn Mfmt("Die Datei <%s> existiert nicht.", $base);
} elsif (-r $xbm) {
my $mask = Tk::findINC($lang_def . '_ptr_mask.xbm');
if (-r $mask) {
$cursor{$key} = $xbm;
$cursor_mask{$key} = $mask;
}
}
}
# do a correct isa call on scrolled widgets
sub subw_isa {
my($w, $isa) = @_;
if ($w->Subwidget('scrolled')) {
$w = $w->Subwidget('scrolled');
}
$w->isa($isa);
}
# Callback bei einem Drop-Vorgang.
# Die Datei wird per load_save_route() geladen.
### AutoLoad Sub
sub accept_drop {
my($c, $seln) = @_;
my $filename;
my @targ = $c->SelectionGet('-selection'=>$seln,'TARGETS');
foreach (@targ) {
if (/FILE_NAME/) {
$filename = $c->SelectionGet('-selection'=>$seln,'FILE_NAME');
last;
}
if ($os eq 'win' && /STRING/) {
$filename = $c->SelectionGet('-selection'=>$seln,$_);
last;
}
}
if (defined $filename) {
if ($filename =~ /\.bbd/i) {
plot_layer('str', $filename);
} else {
load_save_route(0, $filename);
}
}
}
# Return the start and goal streets of the current route
### AutoLoad Sub
sub get_route_description {
my $text = "";
my @search_route = @{ get_act_search_route() };
if (@search_route) {
$text = $search_route[0][StrassenNetz::ROUTE_NAME] . " - " . $search_route[-1][StrassenNetz::ROUTE_NAME];
}
$text;
}
# Return the approximated center of the polyline.
# Coordinates of the polygon are supplied in @koord (flat list of x and y
# values).
### AutoLoad Sub
sub get_polyline_center {
my(@koord) = @_;
my $len = 0;
for(my $i=2; $i<$#koord; $i+=2) {
$len += Strassen::Util::strecke([@koord[$i-2,$i-1]],
[@koord[$i, $i+1]]);
}
my $len0 = 0;
for(my $i=2; $i<$#koord; $i+=2) {
$len0 += Strassen::Util::strecke([@koord[$i-2,$i-1]],
[@koord[$i, $i+1]]);
if ($len0 > $len/2) {
# XXX ungenau, besser machen!
return (($koord[$i-2]-$koord[$i])/2+$koord[$i],
($koord[$i-1]-$koord[$i+1])/2+$koord[$i+1]);
}
}
warn "Fallback for get_polyline_center, should not happen. Coords are @koord";
(($koord[2]-$koord[0])/2+$koord[0],
($koord[3]-$koord[1])/2+$koord[1]);
}
### AutoLoad Sub
sub get_bbox_area {
my($item) = @_;
my(@bbox) = $c->bbox($item);
abs(($bbox[2]-$bbox[0]) * ($bbox[3]-$bbox[1]));
}
# Erzeugt eine Backupdatei
### AutoLoad Sub
sub make_backup {
my $file = shift;
if (-e $file) {
if (-f $file) {
my $backup = "$file~";
rename $file, $backup;
} else {
status_message(Mfmt("%s ist keine gültige Datei, kein Backup.",
$file),
'err');
}
}
}
use your qw($StrassenNetz::VERBOSE $Strassen::VERBOSE $wettermeldung2::VERBOSE
$Tk::SRTProgress::VERBOSE $Fahrinfo::VERBOSE
$Telefonbuch::VERBOSE $GfxConvert::VERBOSE $Hooks::VERBOSE
$FURadar::VERBOSE);
# Setzt die VERBOSE-Variable in den geladenen Modulen
### AutoLoad Sub
sub set_verbose {
Strassen::set_verbose($verbose);
$wettermeldung2::VERBOSE = $verbose;
$Tk::SRTProgress::VERBOSE = $verbose;
$Fahrinfo::VERBOSE = $verbose;
$Telefonbuch::VERBOSE = $verbose;
$GfxConvert::VERBOSE = $verbose;
$Hooks::VERBOSE = $verbose;
$FURadar::VERBOSE = $verbose;
$PLZ::VERBOSE = $verbose;
}
# crops the array in $want_extends to the limits in $extends
sub crop_geometry {
my($want_extends, $extends) = @_;
# right/bottom limits
my $x = $want_extends->[GEOMETRY_X] =~ /^-/ ?
$top->screenwidth - $want_extends->[GEOMETRY_WIDTH] + $want_extends->[GEOMETRY_X] :
$want_extends->[GEOMETRY_X];
my $y = $want_extends->[GEOMETRY_Y] =~ /^-/ ?
$top->screenheight - $want_extends->[GEOMETRY_HEIGHT] + $want_extends->[GEOMETRY_Y] :
$want_extends->[GEOMETRY_Y];
my($maxx) = $want_extends->[GEOMETRY_WIDTH] + $x;
my($maxy) = $want_extends->[GEOMETRY_HEIGHT] + $y;
if ($x < $extends->[GEOMETRY_X]) {
$want_extends->[GEOMETRY_X] = $extends->[GEOMETRY_X];
}
if ($y < $extends->[GEOMETRY_Y]) {
$want_extends->[GEOMETRY_Y] = $extends->[GEOMETRY_Y];
}
if ($x + $want_extends->[GEOMETRY_WIDTH] > $extends->[GEOMETRY_WIDTH]) {
$want_extends->[GEOMETRY_WIDTH] = $extends->[GEOMETRY_WIDTH] - $x;
}
if ($y + $want_extends->[GEOMETRY_HEIGHT] > $extends->[GEOMETRY_HEIGHT]) {
$want_extends->[GEOMETRY_HEIGHT] = $extends->[GEOMETRY_HEIGHT] - $y;
}
}
sub parse_geometry_string {
my $geometry = shift;
my @extends = (0, 0, 0, 0);
if ($geometry =~ /([-+]?\d+)x([-+]?\d+)/) {
$extends[GEOMETRY_WIDTH] = $1;
$extends[GEOMETRY_HEIGHT] = $2;
}
if ($geometry =~ /([-+]\d+)([-+]\d+)/) {
$extends[GEOMETRY_X] = $1;
$extends[GEOMETRY_Y] = $2;
}
@extends;
}
# Alternative way to set geometry.
sub geometry {
my($t, @extends) = @_;
my $geometry = "$extends[GEOMETRY_WIDTH]x$extends[GEOMETRY_HEIGHT]";
$extends[GEOMETRY_X] = "+$extends[GEOMETRY_X]" if $extends[GEOMETRY_X] !~ /^[+-]/;
$extends[GEOMETRY_Y] = "+$extends[GEOMETRY_Y]" if $extends[GEOMETRY_Y] !~ /^[+-]/;
$geometry .= $extends[GEOMETRY_X] . $extends[GEOMETRY_Y];
$t->geometry($geometry);
}
sub fix_geometry {
my $geom_string = shift || $top->geometry;
my(@extends) = parse_geometry_string($geom_string);
$extends[GEOMETRY_HEIGHT] += ($top->wrapper)[1];
if ($^O eq 'MSWin32') {
# This seems to be necessary at least on a Win98 machine
# or maybe only on systems where wrapper[1] returns 0?
# 20 should probably be replaced by the value of $SM_CYCAPTION, see Win32Util (19 on this system)
$extends[GEOMETRY_HEIGHT] += 20; # get titlebar height (?) by API functions XXX
}
"$extends[GEOMETRY_WIDTH]x$extends[GEOMETRY_HEIGHT]" .
"+$extends[GEOMETRY_X]+$extends[GEOMETRY_Y]"
}
# check if the toplevel is too large and resize, if appropriate
sub toplevel_checker {
my($t) = @_;
$t->update;
my($sw,$sh) = ($t->screenwidth, $t->screenheight);
my($x,$y,$w,$h) = ($t->x, $t->y, $t->width, $t->height);
$w = $sw if ($w > $sw);
$h = $sh if ($h > $sh);
$x = 0 if ($x+$w > $sw || $x < 0);
$y = 0 if ($y+$h > $sh || $y < 0);
$t->geometry($w."x".$h."+$x+$y");
}
sub get_polar_location_of_route_end {
return undef if !@realcoords;
require Karte::Polar;
my($px,$py) = $Karte::Polar::obj->standard2map(@{ $realcoords[-1] });
"$px,$py";
}
sub my_popup {
my $t = shift;
$t->withdraw;
$t->Popup(@popup_style);
}
sub optedit {
my(%args) = @_;
my $opt_edit = $top->{GetoptEditor};
if (Tk::Exists($opt_edit)) {
$opt_edit->raise;
if ($args{-page}) {
$opt->raise_page($args{-page});
}
return;
}
$opt_edit = $opt->option_editor
($top,
($transient ? (-transient => $top) : ()),
(!defined $ENV{LANG} || $ENV{LANG} =~ /^de/ ?
(-string => {optedit => "Optionseditor",
undo => "Undo",
lastsaved => "Zuletzt gespeichert",
save => "Speichern",
defaults => "Voreinstellungen",
ok => "Ok",
oksave => "Ok",
apply => "Anwenden",
cancel => "Abbrechen",
helpfor => "Hilfe für",
}
) : ()),
-buttons => ['oksave',
#'defaults', # XXX defaults or not defaults???
#could be misleading, users might think that the
#defaults just apply to the displayed page
'cancel'],
%args, # e.g. -page
);
$top->{GetoptEditor} = $opt_edit;
}
sub export_visible_map {
my($fmt, $outfile) = @_;
if (!defined $outfile) {
$outfile = $top->getSaveFile
(-defaultextension => ".$fmt",
-title => Mfmt('%s-Datei sichern', uc($fmt)),
-initialdir => $save2_path);
}
return if !defined $outfile;
$save2_path = dirname $outfile;
$top->raise;
$top->update;
IncBusy($top);
eval {
my $in_fmt;
my $tmpfile;
my $bgcolor = sprintf('#%02x%02x%02x', map { $_/256 } $c->rgb($c->cget(-background)));
my $NNcolor = sprintf('#%02x%02x%02x', map { $_/256 } $c->rgb($category_color{N}));
my %args =
(-mapcolor =>
{# Swap colors to avoid non-white background
$bgcolor => '#ffffff',
$NNcolor => $bgcolor,
},
-res => $ps_image_res,
-autocrop => 1,
);
my $post_processing_needed = 1;
require BBBikePrint; # for using_rotated_fonts
if ((using_rotated_fonts() ||
$use_xwd_if_possible
) and
$Tk::platform eq 'unix'
and
is_in_path("xwd")
) {
$args{-rotate} = -90 if $orientation eq 'portrait';
$in_fmt = "xwd";
if ($fmt ne 'xwd') {
require GfxConvert;
GfxConvert::check($in_fmt, $fmt, $tmpfile, $outfile, %args);
} else {
$post_processing_needed = 0;
}
$tmpfile = "/tmp/bbbike.$$.xwd";
$tmpfiles{$tmpfile}++;
my $deiconify_subs = withdraw_toplevels();
$top->raise;
$top->update;
system("xwd", "-out", "$tmpfile", "-id", $c->id);
$_->() for (@$deiconify_subs);
$top->bell;
} else {
$args{-rotate} = -90 if $orientation eq 'landscape';
$in_fmt = "ps";
if ($fmt ne 'ps') {
require GfxConvert;
GfxConvert::check($in_fmt, $fmt, $tmpfile, $outfile, %args);
} else {
$post_processing_needed = 0;
}
die M"Der Export wurde unterbrochen."
if slow_postscript_generation();
$tmpfile = create_postscript($c,
-colormode => 'color',
-rotate => 1,
-scale_a4 => 0,
);
if (!defined $tmpfile) {
die M"Temporäre Postscript-Datei kann nicht erstellt werden.";
}
}
if (!$post_processing_needed) {
mv($tmpfile, $outfile);
} else {
require GfxConvert;
# -mapcolor wandelt die Farbe der Nebenstraßen
# (tk: grey99/ps: 0.9 0.9 0.9) nach weiß um und setzt die
# Hintergrundfarbe von weiß auf die Hintergrundfarbe des
# Canvases
GfxConvert::convert
($in_fmt, $fmt, $tmpfile, $outfile,
%args,
);
$tmpfiles{$tmpfile}++;
}
};
my $err = $@;
DecBusy($top);
if ($err) {
status_message($err, 'err');
}
}
sub slow_postscript_generation {
return $os eq 'win' &&
$top->messageBox(-icon => "question",
-message => M"Die PostScript-Erzeugung ist unter Windows langsam. Soll trotzdem fortgesetzt werden?",
-type => "YesNo") !~ /yes/i;
}
sub start_process {
my($token, $gather_command, $action_command) = @_;
if (defined $processes{$token}) {
status_message(M("Der Prozess $token läuft noch (PID $processes{$token}) XXX"), "die");
# XXX Abschiessen blabla
}
if (!$Config{d_fork}) {
status_message(M("fork ist nicht verfuegbar XXX"), "die");
}
require Symbol;
my $rdr = Symbol::gensym();
my $wtr = Symbol::gensym();
pipe($rdr, $wtr);
my $pid = fork;
if (!defined $pid) {
status_message(M("Der Process konnte nicht gestartet werden."), "die");
}
if ($pid == 0) {
# child
close $rdr;
warn "gather command";
my $result = $gather_command->();
warn "print result $result to $wtr";
# select $wtr; $| = 1;
print $wtr $result;
warn "printed";
close $wtr;
warn "closed";
sleep 99999;
CORE::exit(0);
}
close $wtr;
$processes{$token} = $pid;
$top->fileevent($rdr, "readable", sub {
warn "readable";
local $/ = undef;
my $result = <$rdr>;
warn "got $result";
close $rdr;
$processes{$token} = undef;
warn "do action";
$action_command->($result)
if $action_command;
});
}
sub get_strassen_file {
my $file = shift;
$file . ($edit_mode_flag ? "-orig" : "");
}
sub get_strassen_obj {
my $file = shift;
my $object;
if ($edit_mode_flag) {
$object = eval { Strassen->new(get_strassen_file($file)) };
}
if (!$object) {
$object = Strassen->new($file); # fallback to non-orig file, if necessary
}
$object;
}
sub get_any_strassen_obj {
my($linetype, $type) = @_;
my $object;
if ($linetype =~ /^s/) {
if ($type eq 'w') {
$object = _get_wasser_obj(get_strassen_file($str_file{$type}));
} elsif ($type eq 'l') {
$object = _get_landstr_obj();
} elsif ($type eq 'comm') {
$object = _get_comments_obj();
} else {
$object = get_strassen_obj($str_file{$type});
}
} else {
$object = get_strassen_obj($p_file{$type});
}
$object;
}
sub handle_global_directives {
my($s_or_file, $abk) = @_;
my $glob_dir;
if (!ref $s_or_file) {
$glob_dir = Strassen->get_global_directives($s_or_file);
} else {
$glob_dir = $s_or_file->get_global_directives;
}
return if !$glob_dir;
my %accept_global_hash_directives = map{($_,1)}
qw(line_width line_length line_arrow
str_color outline_color
category_size category_color category_width category_image
category_stipple);
my %accept_global_hashref_directives = map{($_,1)}
qw(str_attrib p_attrib);
# XXX scrollregion
while(my($directive, $vals) = each %$glob_dir) {
my($key, $val) = $directive =~ /^([^\.]+)\.([^\.]+)/;
next if !defined $key;
if ($accept_global_hash_directives{$key}) {
no strict 'refs';
${$key}{$val} = $vals->[0];
} elsif ($accept_global_hashref_directives{$key}) {
no strict 'refs';
${$key}->{$val} = $vals->[0];
}
}
}
sub withdraw_tearoff_menus {
my($toplevel) = @_;
my @deiconify_subs;
for my $w ($toplevel->children) {
if (Tk::Exists($w) && $w->isa("Tk::Menu") && $w->state eq 'normal') {
$w->withdraw;
push @deiconify_subs, sub { $w->deiconify if Tk::Exists($w) };
}
}
@deiconify_subs;
}
sub withdraw_toplevels {
my $deiconify_subs = [ withdraw_tearoff_menus($top) ];
$top->Walk
(sub {
my($w) = @_;
if (Tk::Exists($w) && $w->isa("Tk::Toplevel") &&
$w->state eq 'normal') {
$w->withdraw;
push @$deiconify_subs, sub { $w->deiconify if Tk::Exists($w) };
push @$deiconify_subs, withdraw_tearoff_menus($w);
}
});
$deiconify_subs;
}
sub set_as_toolwindow {
my($win, $parent) = @_;
if ($transient) {
if (0 && $Tk::platform eq 'MSWin32' && $Tk::VERSION >= 804) {
# XXX using -topmost seems to be mandatory, but is ugly,
# because the window is also topmost to other apps
$win->attributes(-toolwindow => 1, -topmost => 1);
} else {
$parent = $top if !$parent;
$win->transient($parent);
}
}
}
## DEBUG_BEGIN
#BEGIN{mymstat("100% BEGIN");}
## DEBUG_END
package bbbike; # HACK for autosplit