1# -*- perl -*- 2 3# 4# $Id: BBBikeEdit.pm,v 1.128 2009/02/14 13:39:57 eserte Exp eserte $ 5# Author: Slaven Rezic 6# 7# Copyright (C) 1998,2002,2003,2004,2009 Slaven Rezic. All rights reserved. 8# This package is free software; you can redistribute it and/or 9# modify it under the same terms as Perl itself. 10# 11# Mail: slaven@rezic.de 12# WWW: http://bbbike.sourceforge.net 13# 14 15# better: use auto-loading 16 17package BBBikeEdit; 18 19package main; 20use strict; 21use vars qw($top $c $scale %font 22 $special_edit $edit_mode $edit_normal_mode 23 %str_draw %str_obj %str_file %p_file %p_draw %p_obj %ampeln 24 $os $verbose %category_color @realcoords $progress 25 $tmpdir $progname %tmpfiles); 26my($c1, $c2, $f1, $f2); 27my(%crossing, $net); 28my $radweg_file; 29my $ampelschaltung_file; 30my $autosave = 1; 31my($lastrw1, $lastrw2); 32my $radweg_last_b2_mode; 33 34my(@radweg_data, %radweg); 35my(@ampel_data, %ampel_schaltung, $ampelschaltung_obj); 36my @lastampeldate; 37my $rel_time_begin = ""; 38my($ampel_hlist, $ampel2_hlist, 39 $ampel_current_crossing, $ampel_current_coord, 40 $ampel_red_itemstyle, $ampel_green_itemstyle, $ampel_blue_itemstyle, 41 @ampel_entry, $ampel_add, $ampel_extra, 42 $ampel_time_photo, 43 $ampelschaltung2, 44 %ampel_all_cycle, $ampel_draw_restrict 45 ); 46my $ampel_show_all = 0; 47my(%label_index, $label_anchor, $label_text, $label_coord, $label_rotated, 48 $label_i, $label_entry); 49my(%vorfahrt_index, $vorfahrt_anchor, $vorfahrt_text, $vorfahrt_coord, 50 @vorfahrt_build); 51 52###################################################################### 53# Allgemein 54# 55sub edit_mode_toggle { 56 my $type = shift; 57 eval $type . '_edit_toggle()'; 58 warn $@ if $@; 59} 60 61sub edit_mode_undef { 62 my $type = shift; 63 eval $type . '_undef_all()'; 64 warn $@ if $@; 65} 66 67sub edit_mode_save_as { 68 main::status_message("Using edit mode is deprecated!", "die"); 69 my $type = shift; 70 eval $type . '_save_as()'; 71 warn $@ if $@; 72} 73 74###################################################################### 75# Radwege 76# 77sub radweg_edit_toggle { 78 main::status_message("Using radweg edit mode is deprecated!", "die"); 79 if ($special_edit eq 'radweg') { 80 radweg_edit_modus(); 81 } else { 82 radweg_edit_off(); 83 } 84} 85 86sub radweg_edit_activate { 87 $special_edit = 'radweg'; 88 set_mouse_desc(); 89} 90 91sub radweg_edit_modus { 92 require Radwege; 93 $special_edit = 'radweg'; 94#XXX utilize $edit_normal_mode? 95#XXX switch_edit_berlin_mode() if (!defined $edit_mode or $edit_mode ne 'b'); 96 radweg_open(); 97 unless ($str_draw{'s'}) { 98 plot('str','s', -draw => 1); 99 } 100 unless ($c->find("withtag", "rw-edit")) { 101 radweg_draw_canvas(); 102 } 103 if (keys %crossing == 0) { 104 my $s = new Strassen $str_file{'s'} . "-orig"; 105 %crossing = %{ $s->all_crossings(RetType => 'hash', 106 UseCache => 1, 107 Kurvenpunkte => 1) }; 108 } 109 set_mouse_desc(); 110 my $cursorfile = defined &main::build_text_cursor ? main::build_text_cursor("RW") : undef; 111 $main::c->configure(-cursor => $cursorfile); 112 113 $radweg_last_b2_mode = $main::b2_mode; 114 $main::b2_mode = main::B2M_CUSTOM(); 115 $main::b2m_customcmd = \&radweg_edit_mouse3; 116 main::set_b2(); 117} 118 119sub radweg_undef_all { 120 undef %crossing; 121} 122 123sub radweg_edit_off { 124 $special_edit = ''; 125 set_mouse_desc(); 126## efficiency: 127# $c->delete("rw"); 128 if (defined $radweg_last_b2_mode) { 129 $main::c->configure(-cursor => undef); 130 $main::b2_mode = $radweg_last_b2_mode; 131 undef $radweg_last_b2_mode; 132 undef $main::b2m_customcmd; 133 main::set_b2(); 134 } 135} 136 137sub radweg_edit_mouse1 { 138 return unless grep($_ =~ /^[sl]$/, $c->gettags('current')); 139 my($i,$pm,$p1a,$p2a) = nearest_line_points_mouse($c); 140 return if (!defined $i); 141 my $p1 = Route::_coord_as_string($p1a); 142 my $p2 = Route::_coord_as_string($p2a); 143 my $index; 144 if (exists $radweg{$p1}->{$p2}) { 145 $index = $radweg{$p1}->{$p2}; 146 } elsif (exists $radweg{$p2}->{$p1}) { 147 $index = $radweg{$p2}->{$p1}; 148 } else { 149 $index = radweg_new_point($p1, $p2); 150 } 151 radweg_display_index($index); 152} 153 154sub radweg_edit_mouse3 { 155 return if !defined $lastrw1 or !defined $lastrw2; 156 my($i,$pm,$p1a,$p2a) = nearest_line_points_mouse($c); 157 return if (!defined $i); 158 my $p1 = Route::_coord_as_string($p1a); 159 my $p2 = Route::_coord_as_string($p2a); 160 my $index; 161 if (exists $radweg{$p1}->{$p2}) { 162 $index = $radweg{$p1}->{$p2}; 163 } elsif (exists $radweg{$p2}->{$p1}) { 164 $index = $radweg{$p2}->{$p1}; 165 } else { 166 $index = radweg_new_point($p1, $p2); 167 } 168 $radweg_data[$index]->[2] = $lastrw1; 169 $radweg_data[$index]->[3] = $lastrw2; 170 radweg_save() if $autosave; 171 radweg_draw_canvas($index); 172 radweg_display_index($index); 173} 174 175sub radweg_display_index { 176 my($index) = @_; 177 my $t = redisplay_top($top, "radweg", -title => 'Radwege'); 178 if (defined $t) { 179 my $mainf = $t->Frame->pack(-fill => 'both', -expand => 1); 180 $f1 = $mainf->Frame(-relief => 'ridge', 181 -bd => 2, 182 )->pack(-side => 'left', -fill => 'both', 183 -expand => 1); 184 $f2 = $mainf->Frame(-relief => 'ridge', 185 -bd => 2, 186 )->pack(-side => 'left', -fill => 'both', 187 -expand => 1); 188 189 foreach my $dir ('1', '2') { 190 eval 191 "\$c$dir = \$f$dir" . 192 '->Canvas(-bg => "white", -width => 30, -height => 30)->pack;'; 193 die $@ if $@; 194 foreach my $type (@Radwege::category_order) { 195 my $name = $Radwege::category_name{$type}; 196 eval "\$f$dir->Radiobutton(-text => '$name', -value => '$type')->pack(-anchor => 'w');"; 197 die $@ if $@; 198 } 199 } 200 201 my $redisplay_sub = sub { 202 radweg_draw_canvas(); 203 }; 204 my $close_sub = sub { 205 $t->destroy; 206 }; 207 my $save_sub = sub { 208 radweg_save(); 209 }; 210 211 my $butf = $t->Frame->pack(-fill => 'x', -expand => 1); 212 my $redisplayb = $butf->Button(-text => 'Neu zeichnen', 213 -command => $redisplay_sub, 214 )->pack(-side => 'left'); 215 $redisplayb->focus; 216 $butf->Button(-text => 'Sichern', 217 -command => $save_sub, 218 )->pack(-side => 'left'); 219 $butf->Checkbutton(-text => 'Auto-Sichern', 220 -variable => \$autosave, 221 )->pack(-side => 'left'); 222 my $closeb = $butf->Button 223 (Name => 'close', 224 -command => $close_sub)->pack(-side => 'left'); 225 $t->bind('<Escape>' => $close_sub); 226 } 227 228 foreach my $dir ('1', '2') { 229 my $idx1 = ($dir eq '1' ? 2 : 3); 230 my $reverse = ($dir eq '1' ? 0 : 1); 231 eval 232 "radweg_draw_arrow(\$c$dir, $index, $reverse);" . 233 ""; 234 die $@ if $@; 235 } 236 foreach my $w ($f1->children) { 237 if ($w->isa('Tk::Radiobutton')) { 238 $w->configure 239 (-variable => \$radweg_data[$index]->[2], 240 -command => sub { radweg_draw_canvas($index); 241 radweg_save() if $autosave; 242 $lastrw1 = $radweg_data[$index]->[2]; 243 $lastrw2 = $radweg_data[$index]->[3]; 244 }, 245 ); 246 247 } 248 } 249 foreach my $w ($f2->children) { 250 if ($w->isa('Tk::Radiobutton')) { 251 $w->configure 252 (-variable => \$radweg_data[$index]->[3], 253 -command => sub { radweg_draw_canvas($index); 254 radweg_save() if $autosave; 255 $lastrw1 = $radweg_data[$index]->[2]; 256 $lastrw2 = $radweg_data[$index]->[3]; 257 }, 258 ); 259 } 260 } 261} 262 263# XXX still using internally the old format and not a Strassen object 264sub BBBikeEdit::radweg_open { 265 require Strassen::Core; 266 my $s = Strassen->new("$str_file{rw}-orig"); 267 if (!$s) { 268 status_message("Can't find $str_file{rw}-orig", "err"); 269 return; 270 } 271 $radweg_file = $s->file; 272 $s->init; 273 my %rev_category_code = reverse %Radwege::category_code; 274 @radweg_data = (); 275 %radweg = (); 276 while(1) { 277 my $r = $s->next; 278 last if !@{ $r->[Strassen::COORDS()] }; 279 # same as in miscsrc/convert_radwege: 280 my @l = @{$r->[Strassen::COORDS()]}[0,1]; 281 my($hin,$rueck) = split /;/, $r->[Strassen::CAT()]; 282 $l[2] = $rev_category_code{$hin} || "kein"; 283 $l[3] = $rev_category_code{$rueck} || "kein"; 284 radweg_new_point(@l); 285 } 286 BBBikeEdit::ask_for_co($top, $radweg_file); 287} 288 289sub radweg_old_open { 290 require MyFile; 291 $radweg_file = MyFile::openlist(*RW, map { "$_/$str_file{rw}-orig" } 292 @Strassen::datadirs); 293 warn "radweg_file=$radweg_file" if $verbose; 294 if ($radweg_file) { 295 @radweg_data = (); 296 %radweg = (); 297 while(<RW>) { 298 next if (/^\s*\#/); 299 chomp; 300 my(@l) = split(/\s+/); 301 radweg_new_point(@l); 302 } 303 close RW; 304 BBBikeEdit::ask_for_co($top, $radweg_file); 305 } 306} 307 308sub radweg_save { 309 main::status_message("Using radwege edit mode is deprecated!", "die"); 310 if ($radweg_file) { 311 BBBikeEdit::ask_for_co($main::top, $radweg_file); 312 open(RW, ">$radweg_file") or main::status_message($!, "die"); 313 binmode RW; # XXX check on NT 314 print RW _auto_rcs_header(); 315 for my $F (@radweg_data) { 316 my(@F) = @$F; 317 print RW "\t$Radwege::category_code{$F[2]};$Radwege::category_code{$F[3]} $F[0] $F[1]\n"; 318 } 319 close RW; 320 } 321} 322 323sub radweg_old_save { 324 main::status_message("Using edit mode is deprecated!", "die"); 325 if ($radweg_file) { 326 BBBikeEdit::ask_for_co($main::top, $radweg_file); 327 open(RW, ">$radweg_file") or main::status_message($!, "die"); 328 binmode RW; # XXX check on NT 329 print RW _auto_rcs_header(); 330 print RW join("\n", map { join("\t", @$_) } @radweg_data), "\n"; 331 close RW; 332 } 333} 334 335sub radweg_save_as { 336 main::status_message("Using edit mode is deprecated!", "die"); 337 my $file = $top->getSaveFile; 338 if ($file) { 339 $radweg_file = $file; 340 radweg_save(); 341 } 342} 343 344sub radweg_new_point { 345 my($p1, $p2, $dir1, $dir2) = @_; 346 $dir1 = 'kein' if (!defined $dir1); 347 $dir2 = 'kein' if (!defined $dir2); 348 push @radweg_data, [$p1, $p2, $dir1, $dir2]; 349 if (exists $radweg{$p1}->{$p2} or 350 exists $radweg{$p2}->{$p1}) { 351 warn "Die Strecke $p1 -> $p2 existiert bereits!"; 352 } 353 $radweg{$p1}->{$p2} = $#radweg_data; 354 $radweg{$p2}->{$p1} = $#radweg_data; 355 return $#radweg_data; 356} 357 358sub radweg_draw_arrow { 359 my($c, $index, $reverse) = @_; 360 $c->delete('all'); 361 $c->idletasks; 362 my($c_w, $c_h) = ($c->width, $c->height); 363 my($x1,$y1,$x2,$y2) = (split(/,/, $radweg_data[$index]->[0]), 364 split(/,/, $radweg_data[$index]->[1]), 365 ); 366 my $len = Strassen::Util::strecke_s($radweg_data[$index]->[0], 367 $radweg_data[$index]->[1]); 368 my($cx1, $cy1, $cx2, $cy2) = ($c_w/2, $c_h/2, 369 ($x2-$x1)/$len*15+$c_w/2, 370 ($y1-$y2)/$len*15+$c_h/2); 371 $c->createLine($cx1, $cy1, $cx2, $cy2, 372 -arrow => ($reverse ? 'first' : 'last'), 373 -width => 4, 374 ); 375} 376 377sub BBBikeEdit::radweg_draw_canvas { 378 my $index = shift; 379 my @data; 380 my %color; 381 require Radwege; 382 while(my($k,$v) = each %Radwege::category_code) { 383 $color{$k} = $category_color{$v}; 384 } 385 if (defined $index) { 386 $c->delete("rw-$index"); 387 @data = $radweg_data[$index]; 388 } else { 389 $c->delete("rw"); 390 $index = 0; 391 @data = @radweg_data; 392 } 393 if (@data > 1) { 394 IncBusy($top); 395 require File::Basename; 396 $progress->Init(-dependents => $c, 397 -label => File::Basename::basename($radweg_file)); 398 } 399local $scale = 1;#XXX remove $scale 400 eval { 401 my $i = 0; 402 foreach my $l (@data) { 403 $progress->Update($i/($#data+1)) if @data > 1 && $i++ % 80 == 0; 404 my($x1, $y1, $x2, $y2) = (split(/,/, $l->[0]), 405 split(/,/, $l->[1]), 406 ); 407 ($x1,$y1) = main::transpose($x1,$y1); 408 ($x2,$y2) = main::transpose($x2,$y2); 409 my $alpha = atan2($y2-$y1, $x2-$x1); 410 my $beta = $alpha-3.141592653/2; 411 my($dx, $dy) = (3*cos($beta), 3*sin($beta)); 412 if ($l->[2] ne 'kein') { 413 $c->createLine($scale*($x1-$dx), $scale*($y1-$dy), 414 $scale*($x2-$dx), $scale*($y2-$dy), 415 -fill => $color{$l->[2]}, 416 -width => 3, 417 -tags => ['rw', "rw-$index", 'rw-edit']); 418 } 419 if ($l->[3] ne 'kein') { 420 $c->createLine($scale*($x1+$dx), $scale*($y1+$dy), 421 $scale*($x2+$dx), $scale*($y2+$dy), 422 -fill => $color{$l->[3]}, 423 -width => 3, 424 -tags => ['rw', "rw-$index", 'rw-edit']); 425 } 426 $index++; 427 } 428 restack(); 429 }; 430 warn $@ if $@; 431 if (@data > 1) { 432 $progress->Finish; 433 DecBusy($top); 434 } 435} 436 437###################################################################### 438# Ampelschaltungen 439# 440sub ampel_edit_toggle { 441 if ($special_edit eq 'ampel') { 442 ampel_edit_modus(); 443 } else { 444 ampel_edit_off(); 445 } 446} 447 448sub ampel_edit_modus { 449 $progress->InitGroup; 450 require Ampelschaltung; 451 $special_edit = 'ampel'; 452#XXX utilize $edit_normal_mode? 453#XXX switch_edit_berlin_mode() if (!defined $edit_mode or $edit_mode ne 'b'); 454 455 IncBusy($top); 456 $progress->Init(-dependents => $c, 457 -label => "Berechnen des Stra�ennetzes..."); 458 eval { 459 my $s; 460 if (keys %crossing == 0) { 461 $s = new Strassen $str_file{'s'} . "-orig"; 462 %crossing = %{ $s->all_crossings(RetType => 'hash', 463 UseCache => 1, 464 Kurvenpunkte => 1) }; 465 } 466 if (!defined $net) { 467 $s = new Strassen $str_file{'s'} . "-orig" if !$s; 468 $net = new StrassenNetz $s; 469 $net->make_net(Progress => $progress); 470 } 471 }; 472 status_message($@, 'err') if ($@); 473 $progress->Finish; 474 DecBusy($top); 475 476 ampel_open(); 477 478 unless ($ampelschaltung2) { 479 $ampelschaltung2 = new Ampelschaltung2; 480 if (!$ampelschaltung2->open) { 481 warn "Ampelschaltung2 konnte nicht geladen werden."; 482 undef $ampelschaltung2; 483 } 484 } 485 486 unless ($p_draw{'lsa'}) { 487 plot('p','lsa', -draw => 1); 488 } 489 special_raise("lsa-fg"); 490#XXX 491# if (!defined $ampel_time_photo) { 492# $ampel_time_photo = $top->Photo 493# XXX gif => xpm 494# (-file => Tk::findINC("ampel_time.gif")); 495# } 496# if (defined $ampel_time_photo) { 497# foreach (@ampel_data) { 498 499# } 500# } 501 502 $ampel_draw_restrict = ""; 503 ampel_meta_draw_canvas(); 504 505 set_mouse_desc(); 506 507 $progress->FinishGroup; 508} 509 510sub ampel_edit_off { 511 $special_edit = ''; 512 set_mouse_desc(); 513} 514 515sub ampel_undef_all { 516 undef $ampelschaltung2; 517 undef %crossing; 518 undef $net; 519} 520 521sub ampel_edit_mouse1 { 522 my @tags = $c->gettags('current'); 523 unless (grep { $_ =~ /^lsa/ && $_ !~ /^lsas-t/ } @tags) { 524 (my($item), @tags) = find_below($c, "lsa-fg"); 525 if (!defined $item) { 526 warn "lsa tag not found at current point"; 527 return; 528 } 529 } 530 my $p1 = $tags[1]; # XXX oder 2 531 if (!exists $ampel_schaltung{$p1}) { 532 ampel_new_point($p1); 533 } 534 ampel_display($p1); 535} 536 537sub ampel_edit_mouse3 { } 538 539# XXX Statt Indices Konstanten verwenden! 540sub ampel_display { 541 my($p1) = @_; 542 if (exists $crossing{$p1}) { 543 $ampel_current_crossing = join("/", @{$crossing{$p1}}); 544 $ampel_current_crossing = substr($ampel_current_crossing, 0, 42) 545 . "..." 546 if length($ampel_current_crossing) > 45; 547 $ampel_current_coord = $p1; 548 } 549 my $index = $ampel_schaltung{$p1}; 550 my $t = redisplay_top($top, "ampelschaltung", 551 -title => 'Ampelschaltung', 552 ); 553 my(@header_list) = 554 qw(Wochentag Zeit von nach gr�n rot Zyklus Comment Date lost); 555 my(@entry_desc) = 556 (qw(Wochentag Zeit), "von (Himmelsrichtung)", 557 "nach (Himmelsrichtung)", "Gr�nphase", "Rotphase", 558 "Zyklus", "Kommentar", "Datum"); 559 my $hlist_cols = scalar @entry_desc; 560 my $hlist_out_cols = scalar @header_list; 561 if (defined $t) { 562 require Tk::HList; 563 require Tk::Adjuster; 564 require Tk::Balloon; 565 my $mainf = $t->Frame->pack(-fill => 'both', -expand => 1); 566 my $lf = $mainf->Frame->pack; 567 $lf->Label(-textvariable => \$ampel_current_crossing, 568 -anchor => 'w', 569 )->pack(-side => 'left'); 570 $lf->Label(-textvariable => \$ampel_current_coord, 571 -anchor => 'w', 572 )->pack(-side => 'left'); 573 $ampel_hlist = $mainf->Scrolled 574 ('HList', 575 -header => 1, 576 -columns => $hlist_out_cols, 577 -selectmode => 'single', 578 -scrollbars => 'osoe', 579 -width => 50, 580 -height => 5, 581 )->packAdjust(-expand => 1, -fill => 'both'); 582 $ampel2_hlist = $mainf->Scrolled 583 ('HList', 584 -header => 1, 585 -columns => $hlist_out_cols, 586 -selectmode => 'single', 587 -scrollbars => 'osoe', 588 -width => 50, 589 -height => 6, 590 )->pack(-expand => 1, -fill => 'both'); 591 eval { 592 require Tk::ItemStyle; 593 require Tk::ResizeButton; 594 require BBBikeTkUtil; 595 my $headerstyle = $ampel_hlist->ItemStyle('window', -padx => 0, 596 -pady => 0); 597 my(@header, @header2); 598 my $i = 0; 599 my $scr_hlist = $ampel_hlist->Subwidget('scrolled');#XXX 600 my $scr2_hlist = $ampel2_hlist->Subwidget('scrolled');#XXX 601 for (@header_list) { 602 my $ii = $i; 603 $header[$i] = $ampel_hlist->ResizeButton 604 (-text => $_, 605 -relief => 'flat', -pady => 0, 606 -widget => \$scr_hlist, 607 -command => sub { BBBikeTkUtil::sort_hlist($scr_hlist, $ii) }, 608 -column => $i, 609 -padx => 0, -pady => 0, 610 ); 611 $header2[$i] = $ampel2_hlist->ResizeButton 612 (-text => $_, 613 -relief => 'flat', -pady => 0, 614 -widget => \$scr2_hlist, 615 -command => sub { BBBikeTkUtil::sort_hlist($scr2_hlist, $ii) }, 616 -column => $i, 617 -padx => 0, -pady => 0, 618 ); 619 $i++; 620 } 621 $i = 0; 622 for $i (0 .. $#header) { 623 $ampel_hlist->header('create', $i, -itemtype => 'window', 624 -widget => $header[$i], 625 -style => $headerstyle); 626 $ampel2_hlist->header('create', $i, -itemtype => 'window', 627 -widget => $header2[$i], 628 -style => $headerstyle); 629 } 630 }; 631 if ($@) { 632 warn $@ if $verbose; 633 foreach ($ampel_hlist, $ampel2_hlist) { 634 my $i = 0; 635 foreach my $h (@header_list) { 636 $_->header('create', $i, -text => $h); 637 $i++; 638 } 639 } 640 } 641 642 eval { 643 require Tk::ItemStyle; 644 $ampel_red_itemstyle = 645 $mainf->ItemStyle('text', -foreground => 'red', 646 -background => $mainf->cget(-background)); 647 $ampel_green_itemstyle = 648 $mainf->ItemStyle('text', -foreground => 'DarkGreen', 649 -background => $mainf->cget(-background)); 650 $ampel_blue_itemstyle = 651 $mainf->ItemStyle('text', -foreground => 'blue', 652 -background => $mainf->cget(-background)); 653 }; 654 655 my @entry_width = (3,5,2,2,3,3,3,10,8); 656 657 my $entry_f = $mainf->Frame->pack(-fill => "x"); 658 659 my $current_field = ""; 660 { 661 my $status_f = $mainf->Frame->pack(-fill => "x"); 662 $status_f->Label(-relief => "sunken", 663 -width => 20, 664 -bd => 2, 665 -anchor => "w", 666 -textvariable => \$current_field, 667 )->pack(-side => "left"); 668 my $rel_time_begin_e = $status_f->Entry 669 (-textvariable => \$rel_time_begin, 670 -width => 8, 671 )->pack(-side => "left"); 672 $rel_time_begin_e->bind 673 ("<FocusIn>" => sub { 674 $current_field = "Anfangszeit f�r relative Zeiteingabe"; 675 }); 676 } 677 678 for my $j (0 .. $hlist_cols-1) { 679 my $j = $j; 680 $ampel_entry[$j] = $entry_f->Entry(-width => $entry_width[$j] 681 )->pack(-side => 'left'); 682 $ampel_entry[$j]->bind("<FocusIn>" => sub { 683 $current_field = $entry_desc[$j]; 684 }); 685 $entry_f->Label(-text => '->')->pack(-side => 'left') 686 if ($j == 2); # zwischen "von" und "nach" 687 } 688 for my $j (0 .. $hlist_cols-2) { 689 $ampel_entry[$j]->bind('<Return>' => sub { 690 $ampel_entry[$j+1]->tabFocus; 691 }); 692 } 693 $ampel_entry[1]->bind 694 ("<FocusOut>" => sub { 695 my $time = $ampel_entry[1]->get; 696 if ($rel_time_begin !~ /^\s*$/ && $time !~ /^\s*$/) { 697 if (my($h0,$m0,$s0) = $rel_time_begin =~ /^(\d{1,2}):(\d{2}):(\d{2})$/) { 698 if (my($m,$s) = $time =~ /^(\d{1,2}):(\d{2})$/) { 699 my $h = 0; 700 $s += $s0; 701 if ($s >= 60) { $m++; $s %= 60 } 702 $m += $m0; 703 if ($m >= 60) { $h++; $s %= 60 } 704 $h += $h0; 705 if ($h >= 24) { 706 status_message("Wrap date!", "warn"); 707 } 708 $ampel_entry[1]->delete("0", "end"); 709 $ampel_entry[1]->insert 710 ("end", sprintf "%d:%02d:%02d", $h, $m, $s); 711 } 712 } else { 713 status_message("Falsches Format f�r Startwert der relativen Zeitangabe", "error"); 714 } 715 } 716 }); 717 718 $ampel_entry[4]->configure(-fg => 'DarkGreen'); 719 $ampel_entry[5]->configure(-fg => 'red'); 720 $ampel_entry[6]->configure(-fg => 'blue'); 721 $ampel_add = $entry_f->Button(-text => 'Add')->pack; 722 $ampel_entry[$hlist_cols-1]->bind('<Return>' => sub { 723 $ampel_add->invoke 724 }); 725 726 my $close_sub = sub { 727 $t->destroy; 728 }; 729 my $save_sub = sub { 730 ampel_save(); 731 }; 732 733 my $butf = $t->Frame->pack(-fill => 'x'); 734 $butf->Button(-text => 'Sichern', 735 -command => $save_sub, 736 )->pack(-side => 'left'); 737 $butf->Checkbutton(-text => 'Auto-Sichern', 738 -variable => \$autosave, 739 )->pack(-side => 'left'); 740 $butf->Checkbutton(-text => 'Alle zeigen', 741 -variable => \$ampel_show_all, 742 )->pack(-side => 'left'); 743 $butf->Button(-text => 'Dump', 744 -command => sub { 745 if ($ampelschaltung2) { 746 my $dump = $ampelschaltung2->dump; 747 my $dump_file = "/tmp/ampelschaltung.dump"; 748 open(DUMP, "> $dump_file") 749 or main::status_message("Kann nicht nach $dump_file schreiben: $!", "die"); 750 print DUMP $dump; 751 close DUMP; 752 main::status_message("Erfolgreich nach $dump_file geschrieben", "info"); 753 } else { 754 main::status_message("Kein Ampelschaltung-Objekt vorhanden?!", "err"); 755 } 756 })->pack(-side => "left"); 757 my $closeb = $butf->Button 758 (Name => 'close', 759 -command => $close_sub)->pack(-side => 'left'); 760 761 my $butf2 = $t->Frame->pack(-fill => 'x'); 762 $butf2->Button(-text => 'Canvas neu zeichnen', 763 -command => \&el_meta_draw_canvas 764 )->pack(-side => 'left'); 765 $butf2->Radiobutton(-text => 'Alle', 766 -variable => \$ampel_draw_restrict, 767 -value => '', 768 -command => \&el_meta_draw_canvas 769 )->pack(-side => 'left'); 770 $butf2->Radiobutton(-text => 'Tages-', 771 -variable => \$ampel_draw_restrict, 772 -value => 'tagesverkehr', 773 -command => \&el_meta_draw_canvas 774 )->pack(-side => 'left'); 775 $butf2->Radiobutton(-text => 'Berufs-', 776 -variable => \$ampel_draw_restrict, 777 -value => 'berufsverkehr', 778 -command => \&el_meta_draw_canvas 779 )->pack(-side => 'left'); 780 $butf2->Radiobutton(-text => 'Nacht-', 781 -variable => \$ampel_draw_restrict, 782 -value => 'nachtverkehr', 783 -command => \&el_meta_draw_canvas 784 )->pack(-side => 'left'); 785 $butf2->Label(-text => 'Verkehr')->pack(-side => 'left'); 786 787 $t->bind('<Escape>' => $close_sub); 788 } 789 790 my $add_hlist_entry = sub { 791 my($i) = shift; 792 my(@data) = split(/,/, $ampel_data[$index]->[$i]); 793 if ((!defined $data[6] or $data[6] eq '') and 794 (defined $data[4] and $data[4] ne '') and 795 (defined $data[5] and $data[5] ne '') 796 ) { 797 # Zyklus berechnen, falls m�glich 798 $data[6] = $data[4]+$data[5]; 799 } 800 if ((defined $data[4] and $data[4] ne '') and 801 (defined $data[5] and $data[5] ne '') 802 ) { 803 # verlorene Zeit 804 my %res = Ampelschaltung::lost(-rot => $data[5], 805 -gruen => $data[4], 806 ); 807 $data[9] = sprintf "%.1f", $res{-zeit}; 808 } 809 $ampel_hlist->add($i, -text => $data[0], -data => $i); 810 for my $j (1 .. $hlist_out_cols-1) { 811 $ampel_hlist->itemCreate($i, $j, -text => $data[$j]); 812 } 813 $ampel_hlist->itemConfigure($i, 4, -style => $ampel_green_itemstyle) 814 if ($ampel_green_itemstyle); 815 $ampel_hlist->itemConfigure($i, 5, -style => $ampel_red_itemstyle) 816 if ($ampel_red_itemstyle); 817 $ampel_hlist->itemConfigure($i, 6, -style => $ampel_blue_itemstyle) 818 if ($ampel_blue_itemstyle); 819 $ampel_hlist->see($i); 820 }; 821 822 my $add_hlist_entry2 = sub { 823 my($e, $i) = @_; 824 if ((!defined $e->{Cycle} or $e->{Cycle} eq '') and 825 (defined $e->{Red} and $e->{Red} ne '') and 826 (defined $e->{Green} and $e->{Green} ne '') 827 ) { 828 # Zyklus berechnen, falls m�glich 829 $e->{Cycle} = $e->{Red}+$e->{Green}; 830 } 831 if ((defined $e->{Red} and $e->{Red} ne '') and 832 (defined $e->{Green} and $e->{Green} ne '') 833 ) { 834 # verlorene Zeit 835 my %res = Ampelschaltung::lost(-rot => $e->{Red}, 836 -gruen => $e->{Green}, 837 ); 838 $e->{Lost} = sprintf "%.1f", $res{-zeit}; 839 } 840 $ampel2_hlist->add($i, -text => $e->{Day}, -data => $i); 841 my $j = 1; 842 foreach (qw(Time DirFrom DirTo Green Red Cycle Comment Date Lost)) { 843 $ampel2_hlist->itemCreate($i, $j, -text => $e->{$_}); 844 $j++; 845 } 846 $ampel2_hlist->itemConfigure($i, 4, -style => $ampel_green_itemstyle) 847 if ($ampel_green_itemstyle); 848 $ampel2_hlist->itemConfigure($i, 5, -style => $ampel_red_itemstyle) 849 if ($ampel_red_itemstyle); 850 $ampel2_hlist->itemConfigure($i, 6, -style => $ampel_blue_itemstyle) 851 if ($ampel_blue_itemstyle); 852 $ampel2_hlist->see($i); 853 }; 854 855 $ampel_hlist->delete('all'); 856 my $last = $#{$ampel_data[$index]}; 857 for(my $i=2; $i<=$last; $i++) { 858 $add_hlist_entry->($i); 859 } 860 861 { 862 my $i = 0; 863 $ampel2_hlist->delete('all'); 864 foreach my $e ($ampelschaltung2->find_by_point($p1)) { 865 if ($ampel_show_all || 866 (!((!defined $e->{Green} || $e->{Green} eq '') and 867 (!defined $e->{Red} || $e->{Red} eq ''))) 868 ) { 869 $add_hlist_entry2->($e, $i); 870 } 871 $i++; 872 } 873 } 874 875 for my $j (0 .. $hlist_cols-1) { 876 $ampel_entry[$j]->delete(0, 'end'); 877 } 878 for my $lastampeldate_i (0, 1, 8) { # wo-tag, zeit, datum 879 next if ($lastampeldate_i == 1 && $rel_time_begin !~ /^\s*$/); 880 $ampel_entry[$_]->insert(0, $lastampeldate[$_]) 881 if defined $lastampeldate[$_]; 882 } 883 $ampel_entry[0]->tabFocus; 884 885 my @neighbors = keys %{$net->{Net}{$p1}}; 886 887 my $draw_arrow = sub { 888 my $path = shift; 889 if ($path ne '') { 890 $c->delete('lsas-dir'); 891 my(@data) = split(/,/, $ampel_data[$index]->[$path]); 892 my $from = Strassen::Util::best_from_direction 893 ($p1, \@neighbors, $data[2]); 894 die unless $from; 895 my $to = Strassen::Util::best_from_direction 896 ($p1, \@neighbors, $data[3]); 897 die unless $to; 898 my($fromx, $fromy) = split /,/, $from; 899 my($x1, $y1) = split /,/, $p1; 900 my($tox, $toy) = split /,/, $to; 901 my $len1 = _strecke($fromx, $fromy, $x1, $y1); 902 my $len2 = _strecke($tox, $toy, $x1, $y1); 903 if ($len1 != 0 && $len2 != 0) { 904 $c->createLine($x1+($fromx-$x1)/$len1*20+4, 905 $y1+($fromy-$y1)/$len1*20+4, 906 $x1+4, $y1+4, 907 $x1+($tox-$x1)/$len2*20+4, 908 $y1+($toy-$y1)/$len2*20+4, 909 -smooth => 1, 910 -arrow => 'last', 911 -tags => ['lsas', 'lsas-dir'], 912 -fill => 'blue', 913 -width => 3, 914 ); 915 eval { $c->raise('lsa-X', 'lsas-dir') }; # XXX 916 warn $@ if $@; 917 } 918 } 919 }; 920 921 my $draw_arrow2 = sub { 922 my $e = shift; 923 if ($e) { 924 $c->delete('lsas-dir'); 925 my $from = Strassen::Util::best_from_direction 926 ($p1, \@neighbors, $e->{DirFrom}); 927 die unless $from; 928 my $to = Strassen::Util::best_from_direction 929 ($p1, \@neighbors, $e->{DirTo}); 930 die unless $to; 931 my($fromx, $fromy) = split /,/, $from; 932 my($x1, $y1) = split /,/, $p1; 933 my($tox, $toy) = split /,/, $to; 934 my $len1 = _strecke($fromx, $fromy, $x1, $y1); 935 my $len2 = _strecke($tox, $toy, $x1, $y1); 936 if ($len1 != 0 && $len2 != 0) { 937 $c->createLine($x1+($fromx-$x1)/$len1*20+4, 938 $y1+($fromy-$y1)/$len1*20+4, 939 $x1+4, $y1+4, 940 $x1+($tox-$x1)/$len2*20+4, 941 $y1+($toy-$y1)/$len2*20+4, 942 -smooth => 1, 943 -arrow => 'last', 944 -tags => ['lsas', 'lsas-dir'], 945 -fill => 'blue', 946 -width => 3, 947 ); 948 eval { $c->raise('lsa-X', 'lsas-dir') }; # XXX 949 warn $@ if $@; 950 } 951 } 952 }; 953 954 $ampel_add->configure 955 (-command => sub { 956 my $e = ''; 957 my $has_data; 958 for my $j (0 .. $hlist_cols-1) { 959 my $ee = $ampel_entry[$j]->get; 960 if ($ee ne '') { 961 $has_data++; 962 } 963 if ($j == 1 and $ee =~ /^\d+$/) { 964 $ee .= ":00"; # Minuten anh�ngen 965 } 966 $e .= ($e eq '' ? $ee : ",$ee"); 967 } 968 return if !$has_data; 969 $last++; 970 push @{ $ampel_data[$index] }, $e; 971 $add_hlist_entry->($last); 972 $draw_arrow->($last); 973 ampel_save() if $autosave; 974 my(@data) = split(/,/, $ampel_data[$index]->[$last]); 975 @lastampeldate = @data; 976 }); 977 978 $ampel_hlist->bind('<Delete>' => sub { 979 my $path = $ampel_hlist->info('anchor'); 980 if ($path ne '') { 981 my $inx = $ampel_hlist->info('data', $path); 982 $ampel_hlist->delete('entry', $path); 983 splice @{$ampel_data[$index]}, $inx, 1; 984 ampel_save() if $autosave; 985 } 986 }); 987 988 $ampel_hlist->configure 989 (-browsecmd => 990 sub { 991 my $path = $ampel_hlist->info('anchor'); 992 my $inx = $ampel_hlist->info('data', $path); 993 $draw_arrow->($inx); 994 my(@data) = split(/,/, $ampel_data[$index]->[$inx]); 995 for my $j (0 .. $hlist_cols-1) { 996 $ampel_entry[$j]->delete(0, 'end'); 997 $ampel_entry[$j]->insert(0, $data[$j]); 998 } 999 }); 1000 1001 $ampel2_hlist->configure 1002 (-browsecmd => 1003 sub { 1004 my $path = $ampel2_hlist->info('anchor'); 1005 my $inx = $ampel2_hlist->info('data', $path); 1006 my @e = $ampelschaltung2->find_by_point($p1); 1007 $draw_arrow2->($e[$inx]); 1008 }); 1009} 1010 1011sub ampel_open { 1012 my $base = "ampelschaltung-orig"; 1013 require Ampelschaltung; 1014 $ampelschaltung_obj = new Ampelschaltung; 1015 $ampelschaltung_obj->open($base, UpdateCycle => 1); 1016 1017 require MyFile; 1018 $ampelschaltung_file = MyFile::openlist 1019 (*RW, map { "$_/$base" } 1020 @Strassen::datadirs); 1021 if ($ampelschaltung_file) { 1022 @ampel_data = (); 1023 %ampel_schaltung = (); 1024 while(<RW>) { 1025 next if (/^\s*\#/); 1026 chomp; 1027 my(@l) = split(/\t/); 1028 ampel_new_point(@l); 1029 } 1030 close RW; 1031 if (!-w $ampelschaltung_file) { 1032 require Tk::Dialog; 1033 $top->Dialog 1034 (-title => 'Warnung', 1035 -text => "Achtung: auf die Datei $ampelschaltung_file kann nicht geschrieben werden.", 1036 -buttons => ['OK'])->Show; 1037 } 1038 } 1039} 1040 1041sub ampel_save { 1042 if ($ampelschaltung_file) { 1043 BBBikeEdit::ask_for_co($main::top, $ampelschaltung_file); 1044 open(RW, ">$ampelschaltung_file") or main::status_message($!, "die"); 1045 binmode RW; # XXX check on NT 1046 print RW _auto_rcs_header(); 1047 print RW join("\n", map { join("\t", @$_) } @ampel_data), "\n"; 1048 close RW; 1049 } 1050} 1051 1052sub ampel_save_as { 1053 my $file = $top->getSaveFile; 1054 if ($file) { 1055 $ampelschaltung_file = $file; 1056 ampel_save(); 1057 } 1058} 1059 1060sub ampel_new_point { 1061 my($p1, $kreuzung, @schaltung) = @_; 1062 if (!$crossing{$p1}) { 1063 warn "*** No crossing for point $p1 [$kreuzung @schaltung] found ***"; 1064 return; 1065 } 1066 $kreuzung = join("/", @{ $crossing{$p1} }) 1067 if !defined $kreuzung || $kreuzung eq ''; 1068 push @ampel_data, [$p1, $kreuzung, @schaltung]; 1069 if (exists $ampel_schaltung{$p1}) { 1070 warn "Die Ampelschaltung f�r $p1 existiert bereits!"; 1071 } 1072 $ampel_schaltung{$p1} = $#ampel_data; 1073 return $#ampel_data; 1074} 1075 1076sub ampel_meta_draw_canvas { 1077 %ampel_all_cycle = (); 1078 ampel_draw_canvas(); 1079 ampel_draw_canvas(-obj => 2); 1080 ampel_draw_canvas_cycle(); 1081} 1082 1083sub ampel_draw_canvas { 1084 my(%args) = @_; 1085 my $index = $args{'-index'}; 1086 my $obj = $args{-obj} || '1'; 1087 my(@points, %points); 1088 my $file; 1089 if ($obj eq '2') { # XXX doesn't work yet 1090 return if !$ampelschaltung2; 1091 # kein delete. Der Aufruf mit -obj => 2 muss *nach* -obj => 1 folgen 1092 $file = $ampelschaltung2->{File}; 1093 %points = $ampelschaltung2->create_points; 1094 @points = keys %points; 1095 $index = 0; 1096 } else { 1097 if (defined $index) { 1098 $c->delete("lsas-$index"); 1099 @points = create Ampelschaltung::Point $ampel_data[$index]; 1100 } else { 1101 $c->delete("lsas"); 1102 $c->delete("lsas-t"); 1103 $index = 0; 1104 @points = @{ $ampelschaltung_obj->{Data} }; 1105 } 1106 } 1107 if (@points > 1) { 1108 IncBusy($top); 1109 require File::Basename; 1110 $progress->Init 1111 (-dependents => $c, 1112 -label => File::Basename::basename($ampelschaltung_file)); 1113 } 1114 eval { 1115 my $i = 0; 1116 foreach my $l (@points) { 1117 $progress->Update($i/($#points+1)) if $i++ % 80 == 0; 1118 if ($obj eq '2') { 1119 my $point = $points{$l}->[0]->{Point}; 1120 my($x1, $y1) = split /,/, $point; 1121 my $entries = $points{$l}; 1122 my(@entries); 1123 if ($ampel_draw_restrict ne "") { 1124 foreach my $e (@$entries) { 1125 if (Ampelschaltung::verkehrszeit 1126 ($e->{Day}, $e->{Time}) eq $ampel_draw_restrict) { 1127 push @entries, $e; 1128 } 1129 } 1130 } else { 1131 @entries = @$entries; 1132 } 1133 foreach my $e (@entries) { 1134 next if !defined $e->{Cycle} or $e->{Cycle} eq ''; 1135 (my $nr = $e->{Cycle}) =~ s/\D//g; 1136 $ampel_all_cycle{$point}->{$nr}++ if $nr; 1137 } 1138 $c->createLine($scale*($x1+4), $scale*($y1+5), 1139 $scale*($x1+4), $scale*($y1+5), 1140 -width => 3, 1141 -fill => 'blue', 1142 -tags => 'lsas'); 1143 $index++; 1144 } else { 1145 my $point = $l->{Point}; 1146 next if $point =~ m{^#}; # comments are not dropped in Ampelschaltung.pm 1147 my($x1, $y1) = split /,/, $point; 1148 my(@entries); 1149 if ($ampel_draw_restrict ne "") { 1150 foreach my $e ($l->entries) { 1151 if (Ampelschaltung::verkehrszeit 1152 ($e->{Day}, $e->{Time}) eq $ampel_draw_restrict) { 1153 push @entries, $e; 1154 } 1155 } 1156 } else { 1157 @entries = $l->entries; 1158 } 1159 my $entries = scalar @entries; 1160 my $width = ($entries < 3 ? 4 : 1161 ($entries > 6 ? 8 : $entries+2)); 1162 foreach my $e (@entries) { 1163 next if !defined $e->{Cycle} or $e->{Cycle} eq ''; 1164 (my $nr = $e->{Cycle}) =~ s/\D//g; 1165 $ampel_all_cycle{$point}->{$nr}++ if $nr; 1166 } 1167 $c->createLine($scale*($x1+4), $scale*($y1+5), 1168 $scale*($x1+4), $scale*($y1+5), 1169 -width => $width, 1170 -fill => 'red', 1171 -tags => ['lsas', "lsas-$index"]); 1172 $index++; 1173 } 1174 } 1175 $c->itemconfigure('lsas', 1176 -capstyle => 'round', 1177 ); 1178 restack(); 1179 }; 1180 warn $@ if $@; 1181 if (@points > 1) { 1182 $progress->Finish; 1183 DecBusy($top); 1184 } 1185} 1186 1187sub ampel_draw_canvas_cycle { 1188 while(my($k, $v) = each %ampel_all_cycle) { 1189 my($x,$y) = transpose(split /,/, $k); 1190 my $zyklus = join(",", sort { $a <=> $b } keys %$v); 1191 if ($zyklus ne "") { 1192 #$c->createText($x,$y, -text => $zyklus, -tags => ["lsas-t"]); 1193 draw_text_intelligent($c, $x, $y, -text => $zyklus, -font => $font{'tiny'}, -tags => ["lsas-t"], -abk => 'lsa'); 1194 } 1195 } 1196# $c->itemconfigure('lsas-t', 1197# -font => $font{'tiny'}, 1198# -anchor => 'nw', 1199# ); 1200} 1201 1202#XXX portabler, aber leider gibt es ab und zu X11-Fehler (X_TranslateCoords) 1203sub ampeln_on_route_canvas { 1204 my(@realcoords) = @_; 1205 1206 die "Funktioniert nur mit Tk Version > 800.000" if $Tk::VERSION < 800; 1207 1208 my $s = new Strassen $str_file{'s'};# XXX gecachte Version verwenden 1209 my %crossing = %{ $s->all_crossings(RetType => 'hash', 1210 UseCache => 1, 1211 Kurvenpunkte => 1, 1212 ) }; 1213 my $t = $top->Toplevel; 1214 my $multi = 4; 1215 my $pc = $t->Canvas(-width => 95*$multi, -height => 250*$multi)->pack; 1216 my $drittel = $pc->cget(-width)/3; 1217 my $extra_width = 8*$multi; 1218 $pc->createLine($drittel-$extra_width, 0, 1219 $drittel-$extra_width, $pc->cget(-height)); 1220 $pc->createLine($drittel, 0, 1221 $drittel, $pc->cget(-height)); 1222 $pc->createLine(2*$drittel, 0, 1223 2*$drittel, $pc->cget(-height)); 1224 my $y = 0; 1225 my $font = $pc->fontCreate(-size => 8, -family => 'helvetica');#XXX 1226 my $bold_font = $pc->fontCreate($pc->fontActual($font)); 1227 $pc->fontConfigure($bold_font, -weight => 'bold'); 1228 my $asc = $pc->fontMetrics($font, -ascent); 1229 my $des = $pc->fontMetrics($font, -descent); 1230 my $y_height = $asc + $des + 2; 1231 1232 # Header 1233 $pc->createText(3, $y, -anchor => 'nw', 1234 -text => 'Ampel', 1235 -font => $bold_font); 1236 $pc->createText($drittel+3, $y, -anchor => 'nw', 1237 -text => 'gr�n', 1238 -font => $bold_font); 1239 $pc->createText(2*$drittel+3, $y, -anchor => 'nw', 1240 -text => 'rot', 1241 -font => $bold_font); 1242 $y+=$y_height; 1243 $pc->createLine(0, $y, $pc->cget(-width), $y); 1244 1245 # XXX der postscript-Code arbeitet nicht korrekt 1246 my $y_add_bug = 4; 1247 1248 my $ampel_s_reihe = sub { 1249 my $drittel = $pc->cget(-width)/3; 1250 my $x = $drittel+1; 1251 my $xadd = 1; 1252 for(my $s = 10; ; $s+=5) { 1253 if ($x + $pc->fontMeasure($font, $s) < $drittel*2-1) { 1254 $pc->createText($x, $y+$y_add_bug, -anchor => 'nw', 1255 -text => $s, 1256 -font => $font); 1257 } else { 1258 last; 1259 } 1260 $x += $pc->fontMeasure($font, $s) + $xadd; 1261 } 1262 $x = $drittel*2+1; 1263 for(my $s = 30; ; $s+=5) { 1264 if ($x + $pc->fontMeasure($font, $s) < $drittel*3-1) { 1265 $pc->createText($x, $y+$y_add_bug, -anchor => 'nw', 1266 -text => $s, 1267 -font => $font); 1268 } else { 1269 last; 1270 } 1271 $x += $pc->fontMeasure($font, $s) + $xadd; 1272 } 1273 }; 1274 1275 my $last; 1276 foreach (@realcoords) { 1277 my $p = "$_->[0],$_->[1]"; 1278 if (exists $ampeln{$p}) { 1279 if (defined $last and $p eq $last) { 1280 next; 1281 } else { 1282 $last = $p; 1283 } 1284 if (exists $crossing{$p}) { 1285 my(@c) = @{$crossing{$p}}; 1286 if (@c > 4) { # h�chstens vier Stra�en pro Kreuzung 1287 splice @c, 4; 1288 } 1289 foreach (@c) { 1290 s/\s*\(.*\)$//; # Klammerzusatz l�schen 1291 } 1292 # Solange Stra�ennamen verk�rzen, bis der gesamte String 1293 # in die Zelle passt. Dabei wird versucht, balanciert zu 1294 # k�rzen. 1295 while(1) { 1296 my $c = join("/", @c); 1297 last if length($c) < 10; # Endlosschleife vermeiden 1298 if ($t->fontMeasure($font, $c) > $drittel-$extra_width) { 1299 my $max_length = 0; 1300 foreach (@c) { 1301 $max_length = length($_) 1302 if (length($_) > $max_length); 1303 } 1304 foreach (@c) { 1305 chop if (length($_) >= $max_length); 1306 } 1307 } else { 1308 last; 1309 } 1310 } 1311 my $c = join("/", @c); 1312 $pc->createText(1, $y+$y_add_bug, -anchor => 'nw', 1313 -text => $c, 1314 -font => $font); 1315 if ($ampeln{$_->[0].",".$_->[1]} eq '?') { 1316 $pc->createText(1+$drittel-$extra_width, $y+$y_add_bug, 1317 -anchor => 'nw', 1318 -text => '?', 1319 -font => $font); 1320 } 1321 &$ampel_s_reihe; 1322 $y+=$y_height; 1323 $pc->createLine(0, $y, $pc->cget(-width), $y); 1324 } 1325 } 1326 } 1327 while ($y < $pc->cget(-height)) { 1328 &$ampel_s_reihe; 1329 $y+=$y_height; 1330 $pc->createLine(0, $y, $pc->cget(-width), $y); 1331 } 1332 my $tmpfile = "$tmpdir/$progname" . "_$$.ps"; 1333 $tmpfiles{$tmpfile}++; 1334 $pc->update; 1335 $pc->postscript(-pagewidth => '9.5c', 1336 -pagex => "0.5c", 1337 -pagey => "0.5c", 1338 -pageanchor => 'sw', 1339 -file => $tmpfile); 1340 require BBBikePrint; 1341 print_postscript($tmpfile); 1342 $t->destroy; 1343} 1344 1345sub ampeln_on_route_enscript { 1346 my(@realcoords) = @_; 1347 1348 do { status_message("Drucken nicht m�glich. Grund: das Programm `Enscript' ist nicht vorhanden.","err"); return } if !is_in_path("enscript"); 1349 1350 my $s = (defined $str_obj{'s'} 1351 ? $str_obj{'s'} 1352 : new Strassen $str_file{'s'}); 1353 my %crossing = %{ $s->all_crossings(RetType => 'hash', 1354 UseCache => 1, 1355 Kurvenpunkte => 1, 1356 ) }; 1357 1358 my $size = "8"; 1359 my $normal_font = "Courier$size"; 1360 open(E, "| enscript -B -s 6 -e -f $normal_font -o $tmpdir/ampeln_on_route.ps"); 1361 1362 my $y_add = 14; 1363 my $x_begin = 5; 1364 my $x_end = 269; 1365 my $y_begin = 787; 1366 my $y_end = 4; 1367 my $y_second_line = $y_begin-14; 1368 my $y = $y_second_line; 1369 1370 # senkrechte Linien und waagerechte Linien 1371 { 1372 my $x_begin = $x_begin-1; 1373 print E "\000ps{ 1374$x_begin $y_begin moveto $x_end $y_begin lineto stroke 1375$x_begin $y_end moveto $x_end $y_end lineto stroke 1376$x_begin $y_begin moveto $x_begin $y_end lineto stroke 1377127 $y_begin moveto 127 $y_end lineto stroke 1378155 $y_begin moveto 155 $y_end lineto stroke 1379212 $y_begin moveto 212 $y_end lineto stroke 1380gsave [1 3] 45 setdash 1381184 $y_second_line moveto 184 $y_end lineto stroke 1382240 $y_second_line moveto 240 $y_end lineto stroke 1383grestore 1384$x_end $y_begin moveto $x_end $y_end lineto stroke 1385}"; 1386 } 1387 1388 my $last; 1389 1390 print E "\000font{CourierBold$size}"; 1391 printf E 1392 "%-21s %-3s %-6s %-13s %-13s", "Ampel", "Dir", "Zykl", "gr�n", "rot"; 1393 print E "\000ps{$x_begin $y moveto $x_end $y lineto stroke}\n"; 1394 $y -= $y_add; 1395 print E "\000font{$normal_font}"; 1396 1397 foreach (@realcoords) { 1398 my $p = "$_->[0],$_->[1]"; 1399 if (exists $ampeln{$p}) { 1400 if (defined $last and $p eq $last) { 1401 next; 1402 } else { 1403 $last = $p; 1404 } 1405 if (exists $crossing{$p}) { 1406 my(@c) = @{$crossing{$p}}; 1407 if (@c > 4) { # h�chstens vier Stra�en pro Kreuzung 1408 splice @c, 4; 1409 } 1410 foreach (@c) { 1411 s/\s*\(.*\)$//; # Klammerzusatz l�schen 1412 } 1413 # Solange Stra�ennamen verk�rzen, bis der gesamte String 1414 # in die Zelle passt. Dabei wird versucht, balanciert zu 1415 # k�rzen. 1416 while(1) { 1417 my $c = join("/", @c); 1418 last if length($c) <= 25; 1419 my $max_length = 0; 1420 foreach (@c) { 1421 $max_length = length($_) 1422 if (length($_) > $max_length); 1423 } 1424 foreach (@c) { 1425 chop if (length($_) >= $max_length); 1426 } 1427 } 1428 my $c = join("/", @c); 1429 printf E 1430 "%-25s %-4s", $c, 1431 ($ampeln{$_->[0].",".$_->[1]} eq '?' ? '?' : '') 1432 ; 1433 print E "\000ps{$x_begin $y moveto $x_end $y lineto stroke}\n"; 1434 $y -= $y_add; 1435 } 1436 } 1437 } 1438 while ($y > 0) { 1439 printf E "%-25s %-4s", "", ""; 1440 print E "\000ps{$x_begin $y moveto $x_end $y lineto stroke}\n"; 1441 $y -= $y_add; 1442 } 1443 close E; 1444 1445 require BBBikePrint; 1446 print_postscript("$tmpdir/ampeln_on_route.ps"); 1447} 1448 1449# Alte Version f�r Ampelschaltung1 (mit vorgegebenen Rot/Gr�nphasen-Dauern) 1450sub old_ampeln_on_route_enscript { 1451 my(@realcoords) = @_; 1452 1453 do { status_message("Drucken nicht m�glich. Grund: das Programm `Enscript' ist nicht vorhanden.","err"); return } if !is_in_path("enscript"); 1454 1455 my $s = (defined $str_obj{'s'} 1456 ? $str_obj{'s'} 1457 : new Strassen $str_file{'s'}); 1458 my %crossing = %{ $s->all_crossings(RetType => 'hash', 1459 UseCache => 1, 1460 Kurvenpunkte => 1, 1461 ) }; 1462 1463 my $normal_font = "Courier5"; 1464 open(E, "| enscript -B -s 2 -e -f $normal_font -o $tmpdir/ampeln_on_route.ps"); 1465 1466 my $y = 783; 1467 my $y_add = 7; 1468 my $x_begin = 5; 1469 my $x_end = 269; 1470 my $y_begin = 791; 1471 my $y_end = 4; 1472 1473 # senkrechte Linien und waagerechte Linien 1474 { 1475 my $x_begin = $x_begin-1; 1476 print E "\000ps{ 1477$x_begin $y_begin moveto $x_end $y_begin lineto stroke 1478$x_begin $y_end moveto $x_end $y_end lineto stroke 1479$x_begin $y_begin moveto $x_begin $y_end lineto stroke 148081 $y_begin moveto 81 $y_end lineto stroke 148196 $y_begin moveto 96 $y_end lineto stroke 1482177 $y_begin moveto 177 $y_end lineto stroke 1483$x_end $y_begin moveto $x_end $y_end lineto stroke 1484}"; 1485 } 1486 1487 my $last; 1488 my $reihe = ''; 1489 for(my $s = 10; $s <= 50; $s+=5) { 1490 $reihe .= sprintf "%2d ", $s; 1491 } 1492 for(my $s = 30; $s <= 75; $s+=5) { 1493 $reihe .= sprintf "%2d ", $s; 1494 } 1495 1496 print E "\000font{CourierBold5}"; 1497 printf E 1498 "%-25s %-4s %-26s %s", "Ampel", "", "gr�n", "rot"; 1499 print E "\000ps{$x_begin $y moveto $x_end $y lineto stroke}\n"; 1500 $y -= $y_add; 1501 print E "\000font{$normal_font}"; 1502 1503 foreach (@realcoords) { 1504 my $p = "$_->[0],$_->[1]"; 1505 if (exists $ampeln{$p}) { 1506 if (defined $last and $p eq $last) { 1507 next; 1508 } else { 1509 $last = $p; 1510 } 1511 if (exists $crossing{$p}) { 1512 my(@c) = @{$crossing{$p}}; 1513 if (@c > 4) { # h�chstens vier Stra�en pro Kreuzung 1514 splice @c, 4; 1515 } 1516 foreach (@c) { 1517 s/\s*\(.*\)$//; # Klammerzusatz l�schen 1518 } 1519 # Solange Stra�ennamen verk�rzen, bis der gesamte String 1520 # in die Zelle passt. Dabei wird versucht, balanciert zu 1521 # k�rzen. 1522 while(1) { 1523 my $c = join("/", @c); 1524 last if length($c) <= 25; 1525 my $max_length = 0; 1526 foreach (@c) { 1527 $max_length = length($_) 1528 if (length($_) > $max_length); 1529 } 1530 foreach (@c) { 1531 chop if (length($_) >= $max_length); 1532 } 1533 } 1534 my $c = join("/", @c); 1535 printf E 1536 "%-25s %-4s %s", $c, 1537 ($ampeln{$_->[0].",".$_->[1]} eq '?' ? '?' : ''), 1538 $reihe; 1539 print E "\000ps{$x_begin $y moveto $x_end $y lineto stroke}\n"; 1540 $y -= $y_add; 1541 } 1542 } 1543 } 1544 while ($y > 0) { 1545 printf E "%-25s %-4s %s", "", "", $reihe; 1546 print E "\000ps{$x_begin $y moveto $x_end $y lineto stroke}\n"; 1547 $y -= $y_add; 1548 } 1549 close E; 1550 1551 require BBBikePrint; 1552 print_postscript("$tmpdir/ampeln_on_route.ps"); 1553} 1554 1555if (defined $os && $os eq 'win') { 1556 *BBBikeEdit::ampeln_on_route = \&eln_on_route_canvas; 1557} else { 1558 *BBBikeEdit::ampeln_on_route = \&eln_on_route_enscript; 1559} 1560 1561###################################################################### 1562# Labels 1563# 1564sub label_edit_toggle { 1565 if ($special_edit eq 'label') { 1566 label_edit_modus(); 1567 } else { 1568 label_edit_off(); 1569 } 1570} 1571 1572sub label_edit_modus { 1573 $special_edit = 'label'; 1574#XXX utilize $edit_normal_mode? 1575 switch_edit_berlin_mode() if (!defined $edit_mode or $edit_mode ne 'b'); 1576 unless ($str_draw{'s'}) { 1577 plot('str','s', -draw => 1); 1578 } 1579 label_undef_all(); 1580 plot('p',"lb", -draw => 1); 1581 1582 $p_obj{'lb'}->init; 1583 my $i = 0; 1584 while(1) { 1585 my $ret = $p_obj{'lb'}->next; 1586 last if !@{$ret->[1]}; 1587 $label_index{$ret->[1][0]} = $i; 1588 $i++; 1589 } 1590 1591 if (keys %crossing == 0) { 1592 my $s = new Strassen $str_file{'s'} . "-orig"; 1593 %crossing = %{ $s->all_crossings(RetType => 'hash', 1594 UseCache => 1, 1595 Kurvenpunkte => 1) }; 1596 } 1597 set_mouse_desc(); 1598} 1599 1600sub label_undef_all { 1601 undef %crossing; 1602 undef %label_index; 1603} 1604 1605sub label_edit_off { 1606 $special_edit = ''; 1607 set_mouse_desc(); 1608 plot('p',"lb", -draw => 0); 1609} 1610 1611sub label_edit_mouse1 { 1612 my(@tags) = $c->gettags('current'); 1613 return unless grep($_ =~ /^pp$/, @tags); 1614 $label_coord = $tags[1]; 1615 $label_i = (exists $label_index{$label_coord} 1616 ? $label_index{$label_coord} 1617 : undef); 1618 if (defined $label_i) { 1619 my $ret = $p_obj{'lb'}->get($label_i); 1620 $label_text = $ret->[0]; 1621 if ($ret->[2] =~ /^(90)?(.*)/) { 1622 $label_anchor = $2; 1623 $label_rotated = $1; 1624 } 1625 } else { 1626 $label_text = ""; 1627 $label_anchor = 's'; 1628 $label_rotated = ''; 1629 } 1630 my $t = redisplay_top($top, "labels", -title => 'Labels'); 1631 if (defined $t) { 1632 $label_entry = $t->Entry(-textvariable => \$label_text)->pack; 1633 my $rf = $t->Frame->pack; 1634 foreach my $anchor (qw(n nw w sw s se e ne c)) { 1635 $rf->Radiobutton(-text => $anchor, 1636 -variable => \$label_anchor, 1637 -value => $anchor)->pack(-side => 'left'); 1638 } 1639 $t->Checkbutton(-text => 'Senkrecht', 1640 -variable => \$label_rotated, 1641 -onvalue => '90', 1642 -offvalue => '')->pack; 1643 $t->Button(-text => 'OK', 1644 -command => sub { &label_set_i; 1645 $t->withdraw; }, 1646 )->pack; 1647 } 1648 $label_entry->focus; 1649} 1650 1651sub label_set_i { 1652 if (!defined $label_i) { 1653 $label_i = $p_obj{'lb'}->count; 1654 } 1655 $p_obj{'lb'}->set($label_i, [$label_text, $label_coord, 1656 "$label_rotated$label_anchor"]); 1657 $label_index{$label_coord} = $label_i; 1658 $p_obj{'lb'}->write; 1659 plot('p','lb'); 1660} 1661 1662sub label_save_as { 1663 main::status_message("Using edit mode is deprecated!", "die"); 1664 return unless $p_obj{'lb'}; 1665 my $file = $top->getSaveFile; 1666 if ($file) { 1667 $p_obj{'lb'}->write($file); 1668 } 1669} 1670 1671###################################################################### 1672# 1673# Vorfahrt 1674# 1675 1676sub vorfahrt_edit_toggle { 1677 if ($special_edit eq 'vorfahrt') { 1678 vorfahrt_edit_modus(); 1679 } else { 1680 vorfahrt_edit_off(); 1681 } 1682} 1683 1684use vars qw($p_obj_vf); 1685sub vorfahrt_edit_modus { 1686 $special_edit = 'vorfahrt'; 1687#XXX utilize $edit_normal_mode? 1688#XXX switch_edit_berlin_mode() if (!defined $edit_mode or $edit_mode ne 'b'); 1689 unless ($str_draw{'s'}) { 1690 plot('str','s', -draw => 1); 1691 } 1692 vorfahrt_undef_all(); 1693 plot('p',"vf", -draw => 1); 1694 1695 $p_obj_vf = new Strassen $p_file{'vf'} . "-orig" unless $p_obj_vf; 1696 $p_obj_vf->init; 1697 my $i = 0; 1698 while(1) { 1699 my $ret = $p_obj_vf->next; 1700 last if !@{$ret->[1]}; 1701 $vorfahrt_index{$ret->[1][0]} = $i; 1702 $i++; 1703 } 1704 1705 if (keys %crossing == 0) { 1706 my $s = new Strassen $str_file{'s'} . "-orig"; 1707 %crossing = %{ $s->all_crossings(RetType => 'hash', 1708 UseCache => 1, 1709 Kurvenpunkte => 1) }; 1710 } 1711 1712 set_mouse_desc(); 1713} 1714 1715sub vorfahrt_undef_all { 1716 undef %crossing; 1717} 1718 1719sub vorfahrt_edit_off { 1720 $special_edit = ''; 1721 set_mouse_desc(); 1722 plot('p',"vf", -draw => 0); 1723} 1724 1725# XXXX 1726# XXX 3 Punkte aufzeichnen und dann fragen, ob Vorfahrtsregelung 1727# gespeichert werden soll 1728# oder: Punkt anklicken, Grafiken f�r alle m�glichen Vorfahrtsregelungen 1729# als Button ausgeben. Nach Anklicken autosave. 1730# Delete sollte auch m�glich sein. Falls bereits Vorfahrtsregelung 1731# vorhanden, sollte diese gehighlited werden. (Vielleicht dann lieber 1732# Checkbuttons als Buttons). 1733sub vorfahrt_edit_mouse1 { 1734 my(@tags) = $c->gettags('current'); 1735 return unless grep($_ =~ /^(pp|vf.*|lsa.*)$/, @tags); 1736 1737=begin comment 1738 1739 $vorfahrt_coord = $tags[1]; 1740 $vorfahrt_i = (exists $vorfahrt_index{$vorfahrt_coord} 1741 ? $vorfahrt_index{$vorfahrt_coord} 1742 : undef); 1743 if (defined $vorfahrt_i) { 1744 my $ret = $p_obj_vf->get($vorfahrt_i); 1745 $vorfahrt_text = $ret->[0]; 1746 if ($ret->[2] =~ /^(90)?(.*)/) { 1747 $vorfahrt_anchor = $2; 1748 $vorfahrt_rotated = $1; 1749 } 1750 } else { 1751 $vorfahrt_text = ""; 1752 $vorfahrt_anchor = 's'; 1753 $vorfahrt_rotated = ''; 1754 } 1755 my $t = redisplay_top($top, "vorfahrts", -title => 'Vorfahrts'); 1756 if (defined $t) { 1757 $vorfahrt_entry = $t->Entry(-textvariable => \$vorfahrt_text)->pack; 1758 my $rf = $t->Frame->pack; 1759 foreach my $anchor (qw(n nw w sw s se e ne c)) { 1760 $rf->Radiobutton(-text => $anchor, 1761 -variable => \$vorfahrt_anchor, 1762 -value => $anchor)->pack(-side => 'left'); 1763 } 1764 $t->Checkbutton(-text => 'Senkrecht', 1765 -variable => \$vorfahrt_rotated, 1766 -onvalue => '90', 1767 -offvalue => '')->pack; 1768 $t->Button(-text => 'OK', 1769 -command => sub { &vorfahrt_set_i; 1770 $t->withdraw; }, 1771 )->pack; 1772 } 1773 $vorfahrt_entry->focus; 1774 1775=end comment 1776 1777=cut 1778 1779} 1780 1781=begin comment 1782 1783# XXXX 1784sub vorfahrt_set_i { 1785 if (!defined $vorfahrt_i) { 1786 $vorfahrt_i = $p_obj_vf->count; 1787 } 1788 $p_obj_vf->set($vorfahrt_i, [$vorfahrt_text, $vorfahrt_coord, 1789 "$vorfahrt_rotated$vorfahrt_anchor"]); 1790 $vorfahrt_index{$vorfahrt_coord} = $vorfahrt_i; 1791 $p_obj_vf->write; 1792 plot('p','vf'); 1793} 1794 1795=end comment 1796 1797=cut 1798 1799sub vorfahrt_save { 1800 main::status_message("Using edit mode is deprecated!", "die"); 1801 return unless $p_obj_vf; 1802 $p_obj_vf->write; 1803} 1804 1805sub vorfahrt_save_as { 1806 main::status_message("Using edit mode is deprecated!", "die"); 1807 return unless $p_obj_vf; 1808 my $file = $top->getSaveFile; 1809 if ($file) { 1810 $p_obj_vf->write($file); 1811 } 1812} 1813 1814sub _strecke { 1815 my($x1,$y1,$x2,$y2) = @_; 1816 my $dx = $x2-$x1; 1817 my $dy = $y2-$y1; 1818 sqrt($dx*$dx+$dy*$dy); 1819} 1820 1821sub _auto_rcs_header { 1822 "# DO NOT EDIT!\n" . 1823 "# ". "\$" . "Id: " . "\$\n"; 1824} 1825 1826# here starts the real future clean cool package 1827package BBBikeEdit; 1828use Fcntl; # f�r DB_File; 1829use Strassen; 1830use BBBikeEditUtil; 1831use BBBikeGPS; 1832use File::Basename; 1833 1834BEGIN { 1835 if (!eval ' 1836use Msg qw(frommain); 18371; 1838') { 1839 warn $@ if $@; 1840 eval 'sub M ($) { $_[0] }'; 1841 eval 'sub Mfmt { sprintf(shift, @_) }'; 1842 } 1843} 1844 1845use myclassstruct qw(top 1846 toplevel 1847 datadir 1848 canvas 1849 str_file 1850 p_file 1851 coord_system 1852 file2base 1853 ); 1854 1855{ 1856 package LinePartInfo; 1857 use myclassstruct qw(basefile line filetype name); 1858} 1859 1860use constant BBBIKEEDIT_TOPLEVEL => "bbbikeedit"; 1861 1862use vars qw($sel_file $tmpdir); 1863if (!defined $tmpdir) { 1864 $tmpdir = $main::tmpdir || "/tmp"; 1865} 1866 1867use vars qw($auto_reload); 1868$auto_reload = 1 if !defined $auto_reload; 1869 1870use vars qw($crosshairs_activated); 1871 1872# Return true if the file is writable (eventually after checking out). 1873sub ask_for_co { 1874 my($top, $file) = @_; 1875 if (!-e $file) { 1876 if (!open(TOUCH, "> $file")) { 1877 main::status_message("Die Datei $file kann nicht angelegt werden: $!", "warn"); 1878 } else { 1879 close TOUCH; 1880 } 1881 } 1882 if (!-e $file) { 1883 $top->messageBox(-title => "Warnung", 1884 -message => "Achtung: die Datei $file kann nicht erzeugt werden. Bitte Berechtigungen �berpr�fen", 1885 ); 1886 return 0; 1887 } 1888 if (!-w $file) { 1889 if (!(-e dirname($file)."/RCS/".basename($file.",v") || 1890 -e $file.",v")) { 1891 $top->messageBox(-title => "Warnung", 1892 -message => "Die Datei $file kann nicht geschrieben werden. Bitte Berechtigungen �berpr�fen", 1893 ); 1894 return 0; 1895 } 1896 require Tk::Dialog; 1897 my $ans = $top->Dialog 1898 (-title => 'Warnung', 1899 -text => "Achtung: auf die Datei $file kann nicht geschrieben werden.\nSoll ein \"co -l\" ausgef�hrt werden?", 1900 -buttons => ['Ja', 'Nein'])->Show; 1901 if ($ans eq 'Ja') { 1902 require BBBikeUtil; 1903 my $ok = BBBikeUtil::rcs_co($file); 1904 if (!$ok) { 1905 $top->Dialog 1906 (-title => 'Warnung', 1907 -text => 1908 "\"co -l $file\" hat einen Fehler gemeldet. " . 1909 "Bitte stderr �berpr�fen.", 1910 -buttons => ['OK'])->Show; 1911 return 0; 1912 } 1913 } else { 1914 return 0; 1915 } 1916 } 1917 1; 1918} 1919 1920sub create { 1921 my($pkg) = @_; 1922 my $o = $pkg->new(); 1923 $o->top($main::top); 1924 $o->toplevel(\%main::toplevel); 1925 $o->datadir($main::datadir); 1926 $o->canvas($main::c); 1927 $o->str_file(\%main::str_file); 1928 $o->p_file(\%main::p_file); 1929 $o->coord_system($main::coord_system_obj); 1930 eval { 1931 BBBikeEditUtil::base(); 1932 $o->file2base(\%BBBikeEditUtil::file2base); 1933 }; 1934 if ($@) { 1935 # BASE is not really used these days, so just warn... 1936 warn $@; 1937 } 1938 $o; 1939} 1940 1941# Return information about clicked line as a LinePartInfo struct 1942sub click_info { 1943 my $o = shift; 1944 my(@tags) = $o->canvas->gettags("current"); 1945 if (@tags) { 1946 my $abk = $tags[0]; 1947 my $pos = $tags[3]; 1948 # XXX p_file is not supported (yet) 1949 my $str_filename; 1950 my $filetype = "str"; 1951 my $name; 1952 if ($abk =~ /^[wi]$/) { # exception because of 1953 # _get_wasser_obj, include also _i_slands 1954 if ($main::wasserstadt) { 1955 $str_filename = $o->str_file->{"w"}; 1956 } 1957 if ($main::wasserumland) { 1958 if ($str_filename) { 1959 main::status_message("Ambigous. Please select only *one* Gew�sser region", "die"); 1960 } 1961 $str_filename = "wasserumland"; 1962 } 1963 if ($main::str_far_away{"w"}) { 1964 if ($str_filename) { 1965 main::status_message("Ambigous. Please select only *one* Gew�sser region", "die"); 1966 } 1967 $str_filename = "wasserumland2"; 1968 } 1969 } elsif ($abk eq 'l' && 0) { # exception because of _get_landstr_obj 1970 # XXX NYI 1971 } elsif (exists $o->str_file->{$abk}) { 1972 $str_filename = $o->str_file->{$abk}; 1973 } elsif ($abk =~ /^v-SW/ && exists $o->str_file->{"v"}) { 1974 $str_filename = $o->str_file->{$abk}; 1975 } elsif ($abk =~ m{^temp_sperre(?:_s)?$}) { 1976 my $info = main::get_temp_blockings_files(); 1977 $str_filename = $info->{file}; 1978 $filetype = "temp_blockings"; 1979 $name = $tags[2]; 1980 } 1981 if ($str_filename) { 1982 my $ret = LinePartInfo->new; 1983 $ret->basefile($str_filename); 1984 $pos =~ s/^.*-//; 1985 $ret->line($pos); 1986 $ret->filetype($filetype); 1987 $ret->name($name) if defined $name; 1988 return $ret; 1989 } 1990 1991 if (exists $o->p_file->{$abk} && defined $pos) { 1992#XXX _get_orte_obj exception not handled 1993 my $ret = LinePartInfo->new; 1994 $ret->basefile($o->p_file->{$abk}); 1995 $pos =~ s/^.*-//; 1996 $ret->line($pos); 1997 $ret->filetype("p"); 1998 return $ret; 1999 } 2000 warn "Tags not recognized: @tags\n"; 2001 } 2002 undef; 2003} 2004 2005# this is a per file-hash: 2006use vars qw(%click_readonly_warning_seen); 2007 2008sub click { 2009 my $o = shift; 2010 my $click_info = $o->click_info; 2011 die "No (str or p) line recognised" if !$click_info; 2012 2013#XXX del (no more extra handling here): 2014# if ($click_info->filetype eq "temp_blockings") { 2015# $o->edit_temp_blockings; 2016# return; 2017# } 2018 2019 my $ev = $o->canvas->XEvent; 2020 my($cx,$cy) = ($o->canvas->canvasx($ev->x), 2021 $o->canvas->canvasy($ev->y)); 2022 my($tx,$ty) = map { int } main::anti_transpose($cx,$cy); 2023 2024 # Get file name 2025 my $file; 2026 if ($click_info->basefile =~ m|^/|) { # XXX better use file_name_is_absolute 2027 $file = $click_info->basefile . "-orig"; 2028 } else { 2029 $file = $o->datadir . "/" . $click_info->basefile . "-orig"; 2030 } 2031 if (!$main::edit_mode_flag || !-e $file) { 2032 warn "Fallback to non-orig file"; 2033 $file =~ s{-orig$}{}; 2034 } 2035 if (!-r $file) { 2036 main::status_message("Can't read file $file", "die"); 2037 } 2038 2039 # Read-only vs. read-write 2040 my $readonly = 0; 2041 my @entry_args = (); 2042 my @button_args = (); 2043 if (!$main::edit_mode_flag) { 2044 $readonly = 1; 2045 } elsif (!-w $file) { 2046 if (!$click_readonly_warning_seen{$file}) { 2047 main::status_message(Mfmt("Kann die Datei %s nicht �ffnen. Wenn notwendig, ein RCS-Checkout durchf�hren. Dialog wird nun im Nur-Lese-Modus ge�ffnet.", $file), "warn"); 2048 $click_readonly_warning_seen{$file}++; 2049 } 2050 $readonly = 1; 2051 } elsif ($click_info->filetype eq "temp_blockings") { 2052 $readonly = 1; 2053 } 2054 2055 if ($readonly) { 2056 if ($Tk::VERSION >= 804) { 2057 @entry_args = (-state => "readonly"); 2058 } else { 2059 @entry_args = (-state => "disabled"); 2060 } 2061 @button_args = (-state => "disabled"); 2062 } 2063 2064 my @rec; 2065 if (eval { require DB_File; 1 }) { 2066 if (!tie @rec, 'DB_File', $file, ($readonly ? O_RDONLY : O_RDWR), 0644, $DB_File::DB_RECNO) { 2067 main::status_message(Mfmt("Die Datei %s kann mit DB_File nicht ge�ffnet werden: %s", $file, $!), "die"); 2068 } 2069 } elsif (eval { require Tie::File; 1 }) { 2070 # note that record separator is probably always Unix-styled 2071 if (!tie @rec, "Tie::File", $file, mode => ($readonly ? O_RDONLY : O_RDWR), recsep => "\n") { 2072 main::status_message(Mfmt("Die Datei %s kann mit Tie::File nicht ge�ffnet werden: %s", $file, $!), "die"); 2073 } 2074 } else { 2075 # XXX vielleicht sollte es einen fallback mit open und read geben 2076 main::status_message("Kann die Funktion nicht durchf�hren: entweder Tie::File oder DB_File fehlt", "die"); 2077 } 2078 2079 require Tk::Ruler; 2080 require Tk::LabEntry; 2081 2082 my $top = $o->top; 2083 my $t = $top->Toplevel(-title => M("BBBike-Editor") . ": " . $click_info->basefile); 2084 2085 if (tied @rec) { 2086 $t->OnDestroy(sub { untie @rec }); 2087 } 2088 2089 $t->transient($top) unless defined $main::transient && !$main::transient; 2090 my($name, $cat, $coords); 2091 2092 my $e1 = $t->LabEntry(-label => M("Name"), 2093 -labelPack => [-side => "left"], 2094 -textvariable => \$name, 2095 @entry_args, 2096 )->pack(-fill=>"x"); 2097 $e1->focus; 2098 $t->LabEntry(-label => M("Kategorie"), 2099 -labelPack => [-side => "left"], 2100 -textvariable => \$cat, 2101 @entry_args, 2102 )->pack(-fill=>"x"); 2103 { 2104 my $f = $t->Frame->pack(-fill=>"x"); 2105 $f->LabEntry(-label => M("Koordinaten"), 2106 -labelPack => [-side => "left"], 2107 -textvariable => \$coords, 2108 @entry_args, 2109 )->pack(-side => "left", -fill=>"x"); 2110 $f->Button(-text => M"Umdrehen", 2111 -command => sub { 2112 my(@coords) = split /\s+/, $coords; 2113 @coords = reverse @coords; 2114 $coords = join(" ", @coords); 2115 }, 2116 @button_args, 2117 )->pack(-side => "left"); 2118 $f->Button(-text => $main::texteditor || "Editor", 2119 -command => sub { 2120 if ($click_info->filetype eq "temp_blockings") { 2121 $o->edit_temp_blockings($click_info); 2122 } else { 2123 # XXX don't duplicate code, see below 2124 # XXX ufff... this is also in BBBikeAdvanced::find_canvas_item_file for the F9 key :-( 2125 my $count = 0; 2126 my $rec_count = 0; 2127 foreach (@rec) { 2128 if (!/^\#/) { 2129 if ($count == $click_info->line) { 2130 start_editor($file, $rec_count+1); 2131 return; 2132 } 2133 $count++; 2134 } 2135 $rec_count++; 2136 } 2137 main::status_message("Cannot find line " . $click_info->line, "die"); 2138 } 2139 })->pack(-side => "left"); 2140 } 2141 2142 { 2143 $t->Ruler->rulerPack(-pady => 2, -padx => 2); 2144 my $f = $t->Frame->pack(-anchor => "w", -fill => "x"); 2145 $f->Button(-text => M("Kommentar senden"), 2146 -command => sub { 2147 send_comment(-w => $t, 2148 -file => $file, 2149 -name => $name, 2150 -cat => $cat, 2151 -coords => $coords, 2152 -clickcoords => [$tx,$ty], 2153 ); 2154 })->pack(-anchor => "w"); 2155 } 2156 2157 my $okb; 2158 { 2159 $t->Ruler->rulerPack(-pady => 2, -padx => 2); 2160 my $f = $t->Frame->pack; 2161 if (!$readonly) { 2162 $okb = $f->Button(Name => 'ok')->pack(-side => "left"); 2163 } 2164 $f->Button(Name => 'cancel', 2165 -command => sub { 2166 $t->destroy; 2167 })->pack(-side => "left"); 2168 } 2169 2170 my $count = 0; 2171 my $rec_count = 0; 2172 #use Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->Dumpxs([$click_info],[]); # XXX 2173 2174 TRY: { 2175 if ($click_info->filetype eq "temp_blockings") { 2176 $name = $click_info->name; 2177 last TRY; 2178 } 2179 2180 foreach (@rec) { 2181 if (!/^\#/) { 2182 if ($count == $click_info->line) { 2183 my $l = Strassen::parse($_); 2184 $name = $l->[Strassen::NAME]; 2185 $cat = $l->[Strassen::CAT]; 2186 $coords = join(" ", @{$l->[Strassen::COORDS]}); 2187 2188 my $coordsys = $o->coord_system->coordsys; 2189 my $base = $o->file2base->{basename $file}; 2190 ## XXX $base is not really used today, so do not warn... 2191 #main::status_message("Can't get base from $file", "error") if !defined $base; 2192 2193 # use only coordinates in coordsys and strip coordsys 2194 my @coords; 2195 foreach my $coord (@{$l->[Strassen::COORDS]}) { 2196 my($x,$y,$this_base) = @{Strassen::to_koord1_slow($coord)}; 2197 if (!defined $this_base) { 2198 $this_base = $base; 2199 } 2200 local $^W = 0; 2201 if ($this_base eq $coordsys) { 2202 push @coords, [$x,$y]; 2203 } 2204 } 2205 2206 main::mark_street 2207 (-coords => 2208 [[ main::transpose_all(@coords) ]], 2209 -type => 's', 2210 -dont_center => 1, 2211 ); 2212 2213 last TRY; 2214 } 2215 $count++; 2216 } 2217 $rec_count++; 2218 } 2219 die "Can't find line <" . $click_info->line . "> in file <$file> which contains <$rec_count> lines and <$count> non-comment lines"; 2220 } 2221 2222 my $modtime_file = (stat($file))[9]; 2223 2224 if ($okb) { 2225 $okb->configure(-command => sub { 2226 if ($modtime_file != (stat($file))[9]) { 2227 die "File modified in the meantime!"; 2228 } else { 2229 my @l; 2230 $l[Strassen::NAME] = $name; 2231 $l[Strassen::CAT] = $cat; 2232 $l[Strassen::COORDS] = $coords; 2233 my $l = Strassen::_arr2line(\@l); 2234 $rec[$rec_count] = $l; 2235 } 2236 if (eval { require "$FindBin::RealBin/miscsrc/insert_points" }) { 2237 $BBBikeModify::datadir = $main::datadir; 2238 BBBikeModify::do_log($t, "changerec", "$rec_count $name\t$cat $coords", $file); 2239 } else { 2240 warn $@ if $@; 2241 } 2242 if ($auto_reload) { 2243 main::reload_all(); 2244 } 2245 $t->destroy; 2246 }); 2247 } 2248 2249} 2250 2251sub edit_temp_blockings { 2252 my($o, $click_info) = @_; 2253 if (!$click_info) { 2254 $click_info = $o->click_info; 2255 } 2256 2257 open TEMP_BLOCKINGS, $click_info->basefile 2258 or main::status_message("Can't open " . $click_info->basefile . ": $!", "die"); 2259 my $line = $main::temp_blocking_inx_mapping{ $click_info->line }; 2260 my $record = 0; 2261 my $linenumber = 1; 2262 while(<TEMP_BLOCKINGS>) { 2263 if (m<^\s*\{>) { 2264 if ($record == $line) { 2265 close TEMP_BLOCKINGS; 2266 start_editor($click_info->basefile, $linenumber); 2267 return; 2268 } 2269 $record++; 2270 } 2271 $linenumber++; 2272 } 2273 close TEMP_BLOCKINGS; 2274 main::status_message("Can't find record number " . $click_info->line . " in " . $click_info->basefile, "die"); 2275} 2276 2277sub start_editor { 2278 my($file, $line) = @_; 2279 require BBBikeUtil; 2280 my @try = ((defined $main::texteditor && $main::texteditor !~ m{^\s*$} ? $main::texteditor : ()), 2281 "gnuclient", 2282 "emacsclient", 2283 "emacsclient-snapshot", 2284 "vi", 2285 ); 2286 for my $try (@try) { 2287 if ($try =~ m{gnuclient} && BBBikeUtil::is_in_path($try)) { 2288 system($try, '-q', '+'.$line, $file); 2289 if ($?/256 != 0) { 2290 main::status_message("Error while starting $try", "die"); 2291 } 2292 return; 2293 } elsif ($try =~ m{emacsclient} && BBBikeUtil::is_in_path($try)) { 2294 system($try, '-n', '+'.$line, $file); 2295 if ($?/256 != 0) { 2296 main::status_message("Error while starting $try", "die"); 2297 } 2298 return; 2299 } elsif ($try eq 'vi' && BBBikeUtil::is_in_path($try) && BBBikeUtil::is_in_path("xterm")) { 2300 system("xterm", "-e", "vi", "+".$line, $file); 2301 if ($?/256 != 0) { 2302 main::status_message("Error while starting $try in an xterm", "die"); 2303 } 2304 return; 2305 } elsif (BBBikeUtil::is_in_path($try)) { 2306 system($try, "+".$line, $file); 2307 if ($?/256 != 0) { 2308 main::status_message("Error while starting $try", "die"); 2309 } 2310 return; 2311 } 2312 } 2313 main::status_message("Cannot find any text editor, tried @try", "die"); 2314} 2315 2316sub send_comment { 2317 my(%args) = @_; 2318 my($top, $file, $name, $cat, $coords, $clickcoords) = @args{qw(-w -file -name -cat -coords -clickcoords)}; 2319 my $t = $top->Toplevel(-title => M("Kommentar senden")); 2320 $t->transient($top) unless defined $main::transient && !$main::transient; 2321 $t->Label(-text => M("Kartenobjekt").":")->pack(-anchor => "w"); 2322 my $fixed_text = "File: $file\nName: $name\nCategory: $cat\nCoords: $coords\nCoords at mouse: " . join(",", @$clickcoords) . "\n\n"; 2323 my $fixed_w = $t->Scrolled("ROText", 2324 -scrollbars => "os", 2325 -wrap => "none", 2326 -bg => $t->cget('-bg'), 2327 -borderwidth => 0, 2328 -height => 5, -width => 50)->pack(-fill => "both", -expand => 1); 2329 $fixed_w->insert("end", $fixed_text); 2330 $t->Label(-text => M("Kommentar").":")->pack(-anchor => "w"); 2331 my $var_w = $t->Scrolled("Text", 2332 -scrollbars => "ose", 2333 -height => 5, -width => 50)->pack(-fill => "both", -expand => 1); 2334 $var_w->focus; 2335 2336 { 2337 $t->Ruler->rulerPack(-pady => 2, -padx => 2); 2338 my $f = $t->Frame->pack; 2339 $f->Button(Name => 'ok', 2340 -text => M"Mail senden", 2341 -command => sub { 2342 my $var_text = $var_w->Contents; 2343 if ($var_text =~ m{\A\s*\z}) { 2344 main::status_message(M("Leere Nachricht. Es wird keine Mail versandt."), "error"); 2345 } else { 2346 require BBBikeMail; 2347 require BBBikeVar; 2348 my $full_msg = $fixed_text . "\nComment:\n" . $var_text . "\n"; 2349 my $backup_file = "$main::tmpdir/bbbike_send_comments_backup.txt"; 2350 if (open(BACKUP, ">> $backup_file")) { 2351 print BACKUP $full_msg . "-------------------------------------------\n"; 2352 close BACKUP; 2353 warn "Written mail contents to backup file $backup_file.\n"; 2354 } else { 2355 warn "Cannot write to $backup_file: $!\n"; 2356 } 2357 # Send mail to software maintainer 2358 # and CC to data maintainers 2359 BBBikeMail::send_mail($BBBike::EMAIL, "BBBike comment (Perl/Tk $main::VERSION)", 2360 $full_msg, 2361 CC => $BBBike::EMAIL_NEWSTREET, 2362 ); 2363 main::status_message(M("Mail wurde eventuell versandt."), "infodlg"); 2364 } 2365 $t->destroy; 2366 })->pack(-side => "left"); 2367 $f->Button(Name => 'cancel', 2368 -command => sub { $t->destroy })->pack(-side => "left"); 2369 } 2370} 2371 2372sub init_with_edittools { 2373 my $wm_border = 5; # XXX needed for fvwm2 2374 require BBBikeAdvanced; 2375 main::set_line_coord_interactive(-geometry => "-$wm_border+0"); 2376 ## I don't use this anymore: 2377 #main::coord_to_markers_dialog(-geometry => "-$wm_border+120"); 2378 editmenu($main::top, -geometry => "-$wm_border-0"); 2379 if (eval { require SRTShortcuts; 1 }) { 2380 SRTShortcuts::show_bbbike_suggest_toplevel(-geometry => "-$wm_border+200"); 2381 } else { 2382 warn "SRTShortcuts cannot be loaded, cannot show suggest window"; 2383 } 2384} 2385 2386sub editmenu { 2387 my($top, %args) = @_; 2388 my $geometry = delete $args{-geometry}; 2389 my $t = main::redisplay_top($main::top, "edit_menu", 2390 -title => M"Editier-Men�", 2391 -geometry => $geometry, 2392 ); 2393 return if !defined $t; 2394 2395 require BBBikeAdvanced; 2396 my $sample_b; 2397 { 2398 my $f0 = $t->Frame->pack(-fill => 'x'); 2399 $sample_b = $f0->Button(-text => M("Neu laden"), 2400 -command => sub { main::reload_all() }, 2401 -anchor => "w", 2402 )->pack(-side => "left", -fill => "x", -expand => 1); 2403 my $auto = $f0->Checkbutton(-text => "Auto", 2404 -variable => \$auto_reload, 2405 -anchor => "w", 2406 )->pack(-side => "left"); 2407 my $chb = $f0->Checkbutton(-text => "Crosshairs", # XXX translation? 2408 -variable => \$crosshairs_activated, 2409 -command => sub { 2410 require BBBikeCrosshairs; 2411 if ($crosshairs_activated) { 2412 BBBikeCrosshairs::activate(); 2413 } else { 2414 BBBikeCrosshairs::deactivate(); 2415 } 2416 }, 2417 -anchor => "w", 2418 )->pack(-side => "left"); 2419 if (Tk::Exists($main::balloon)) { 2420 $main::balloon->attach($auto, -msg => M('Automatisches Neuladen nach jeder �nderung')); 2421 $main::balloon->attach($chb, -msg => M(<<EOF)); # XXX translation 2422F4: rotate crosshairs to left 2423F5: rotate crosshairs to right 2424Shift-F4: make crosshairs right-angled 2425Shift-F5: align with street under 2426F6: enlarge additional rectangle 2427F7: shrink additional rectangle 2428Shift-F7: turn off additional rectangle 2429EOF 2430 } 2431 } 2432 my $insert_point_mode = 0; 2433 my $old_mode; 2434 my $cb = $t->Checkbutton 2435 (-text => M("Punkt einf�gen"), 2436 -indicatoron => 0, 2437 -variable => \$insert_point_mode, 2438 -command => sub { 2439 if ($insert_point_mode) { 2440 $old_mode = $main::map_mode; 2441 $main::map_mode = main::MM_INSERTPOINT(); 2442 my $cursorfile = main::build_text_cursor("Insert"); 2443 $main::c->configure(-cursor => defined $cursorfile ? $cursorfile : "hand2"); 2444 } else { 2445 if (defined $old_mode) { 2446 $main::map_mode = $old_mode; 2447 undef $old_mode; 2448 } 2449 $main::c->configure(-cursor => undef); 2450 } 2451 }, 2452 -padx => 12, # XXX X11 only? Font dependent? (was 14 once (for helvetica?)) 2453 -anchor => "w", 2454 )->pack(-fill => "x"); 2455 $cb->configure(-pady => ($sample_b->reqheight-$cb->reqheight)/2); 2456 $t->Button(-text => M("Mehrere Punkte einf�gen"), 2457 -command => sub { 2458 if (main::insert_multi_points() && $auto_reload) { 2459 main::reload_all(); 2460 } 2461 }, 2462 -anchor => "w", 2463 )->pack(-fill => "x"); 2464 { 2465 my $f = $t->Frame->pack(-fill => "x", -anchor => "w"); 2466 $f->gridColumnconfigure($_, -weight => 29) for (0, 1); 2467 2468 my $row = 0; 2469 $f->Button(-text => M("Punkt bewegen (F3)"), 2470 -command => sub { 2471 if (main::change_points() && $auto_reload) { 2472 main::reload_all(); 2473 } 2474 }, 2475 -anchor => "w", 2476 )->grid(-column => 0, -row => $row, -sticky => "nesw"); 2477 $f->Button(-text => M("Linie bewegen"), 2478 -command => sub { 2479 if (main::change_line() && $auto_reload) { 2480 main::reload_all(); 2481 } 2482 }, 2483 -anchor => "w", 2484 )->grid(-column => 1, -row => $row, -sticky => "nesw"); 2485 2486 $row++; 2487 2488 $f->Button(-text => M("Punkt suchen"), 2489 -command => \&main::grep_point, # never reload necessary 2490 -anchor => "w", 2491 )->grid(-column => 0, -row => $row, -sticky => "nesw"); 2492 $f->Button(-text => M("Linie suchen"), 2493 -command => \&main::grep_line, # never reload necessary 2494 -anchor => "w", 2495 )->grid(-column => 1, -row => $row, -sticky => "nesw"); 2496 2497 $row++; 2498 2499 { 2500 my @files = ((!defined $main::edit_mode || $main::edit_mode eq '') 2501 && !$main::edit_normal_mode 2502 ? BBBikeEditUtil::get_generated_files() 2503 : BBBikeEditUtil::get_orig_files() 2504 ); 2505 if (!@files) { 2506 main::status_message(Mfmt("Keine Dateien in %s gefunden", $main::datadir), "err"); 2507 return; 2508 } 2509 my $ff = $f->Frame->grid(-column => 0, -row => $row, -columnspan => 2, -sticky => 'nesw'); 2510 $ff->Button(-text => M("Neu hinzuf�gen zu: "), 2511 -command => sub { 2512 my $file = $sel_file; 2513 if ($file !~ m|^/|) { # XXX use file_name_is_absolute 2514 $file = "$main::datadir/$file"; 2515 } 2516 addnew($t, $file) 2517 }, 2518 )->pack(-side => "left"); 2519 require Tk::BrowseEntry; 2520 my $be = $ff->BrowseEntry(#-state => "readonly", 2521 -textvariable => \$sel_file, 2522 ($Tk::VERSION >= 804 2523 ? (-autolistwidth => 1) 2524 : () 2525 ) 2526 )->pack(-side => "left"); 2527 $be->Subwidget("slistbox")->configure(-exportselection => 0); 2528 $be->insert("end", @files); 2529 } 2530 2531 $row++; 2532 2533 $f->Button(-text => M("Punkt l�schen"), 2534 -command => sub { 2535 if (main::delete_point() && $auto_reload) { 2536 main::reload_all(); 2537 } 2538 }, 2539 -anchor => "w", 2540 )->grid(-column => 0, -row => $row, -sticky => 'nesw'); 2541 2542 $f->Button(-text => M("Linie gl�tten"), 2543 -command => sub { 2544 if (main::smooth_line() && $auto_reload) { 2545 main::reload_all(); 2546 } 2547 }, 2548 -anchor => 'w', 2549 )->grid(-column => 1, -row => $row, -sticky => 'nesw'); 2550 2551 $row++; 2552 } 2553##XXX not yet: 2554# $t->Button(-text => M("Linien l�schen"), 2555# -command => \&main::delete_lines, 2556# -anchor => "w", 2557# )->pack(-fill => "x"); 2558 $t->Label(-justify => "left", 2559 -text => M("F8 zum Editieren des Elements unter dem Mauszeiger.\nF2 zum Einf�gen eines Punktes."), 2560 )->pack(-anchor => "w"); 2561 # XXX Sometimes it happens that the mouse is over the mainwindow, 2562 # but the edit window still has the focus. For this case I have 2563 # the Escape binding to fix things. 2564 $t->bind("<Escape>" => sub { 2565 $main::top->focus; 2566 }); 2567 2568 $t->update; 2569 if (!$geometry) { 2570 $t->Popup(-popover => $top, 2571 -popanchor => 'e', 2572 -overanchor => 'e', 2573 ); 2574 } 2575} 2576 2577sub addnew { 2578 my($top, $file) = @_; 2579 if (!@main::inslauf_selection) { 2580 main::status_message(M("Keine Punkte zum Einf�gen"), "err"); 2581 return; 2582 } 2583 return if !BBBikeEdit::ask_for_co($top, $file); 2584 my $std_prefix = { BBBikeEditUtil::base() }->{basename($file)}; 2585 my $prefix = ""; 2586 if ($main::coord_system_obj->coordsys ne $std_prefix) { 2587 $prefix = $main::coord_system_obj->coordsys; 2588 } 2589 my $t = $top->Toplevel(-title => M("Neu hinzuf�gen")); 2590 $t->transient($top) unless defined $main::transient && !$main::transient; 2591 $t->Popup(@main::popup_style); 2592 my($name, $cat, $coords); 2593 $coords = join(" ", @main::inslauf_selection); 2594 my($e, $be); 2595 Tk::grid($t->Label(-text => M("Name")), 2596 $e = $t->Entry(-textvariable => \$name), 2597 -sticky => "w"); 2598 $e->focus; 2599 Tk::grid($t->Label(-text => M("Kategorie")), 2600 $be = $t->BrowseEntry(-textvariable => \$cat, 2601 ($Tk::VERSION >= 804 2602 ? (-autolistwidth => 1, 2603 -listheight => 20, 2604 -autolimitheight => 1, 2605 ) 2606 : () 2607 ), 2608 ), 2609 -sticky => "w"); 2610 Tk::grid($t->Label(-text => M("Koordinaten")), 2611 $t->Entry(-textvariable => \$coords), 2612 -sticky => "w"); 2613 my $row = 3; 2614 { 2615 my $f = $t->Frame->grid(-row => $row++, -column => 0, 2616 -columnspan => 2, -sticky => "ew"); 2617 $f->Button(Name => "ok", 2618 -command => sub { 2619 # Trim all: 2620 for my $ref (\$name, \$cat, \$coords) { 2621 $$ref =~ s{^\s+}{}; 2622 $$ref =~ s{\s+$}{}; 2623 } 2624 if ($name eq "") { 2625 main::status_message(M"Kein Name eingetragen","err"); 2626 return; 2627 } 2628 if ($cat eq "") { 2629 main::status_message(M"Keine Kategorie eingetragen","err"); 2630 return; 2631 } 2632 if ($coords eq "") { 2633 main::status_message(M"Keine Kategorie eingetragen","err"); 2634 return; 2635 } 2636 $cat =~ s/\s.*//; # remove comment 2637 my $line = Strassen::arr2line([$name,$coords,$cat]); 2638 ask_for_co($t, $file); 2639 if (!open(ADD, ">>$file")) { 2640 main::status_message(Mfmt("Kann auf %s nicht schreiben: %s", $file, $!),"err"); 2641 return; 2642 } 2643 binmode ADD; 2644 print ADD $line; 2645 close ADD; 2646 2647 if (eval { require "$FindBin::RealBin/miscsrc/insert_points" }) { 2648 $BBBikeModify::datadir = $main::datadir; 2649 BBBikeModify::do_log($t, "add", "$name\t$cat $coords", $file); 2650 } else { 2651 warn $@ if $@; 2652 } 2653 2654 if ($auto_reload) { 2655 main::reload_all(); 2656 } 2657 2658 # XXX delete_route light 2659 main::reset_button_command(); 2660 main::reset_selection(); 2661 2662 $t->destroy; 2663 }, 2664 )->pack(-side => "left"); 2665 $f->Button(Name => "cancel", 2666 -command => sub { $t->destroy } 2667 )->pack(-side => "left"); 2668 } 2669 2670 require Strassen::Cat; 2671 require BBBikeUtil; 2672 my @cat = Strassen::Cat::get_static_categories($file); 2673 if (!@cat) { 2674 @cat = sort keys %main::category_attrib; 2675 } 2676 # We have some conflicting categories like 1 (Einbahnstra�e OR Ort), 2677 # B (Bahn�bergang OR Bundesstra�e). Therefore disable category label 2678 # expansion for some files: 2679 if ($file !~ m{\b(ampeln|gesperrt|gesperrt_car)(-orig)?$}) { 2680 @cat = map { 2681 my $cat = $_; 2682 (my $cat_label = $cat) =~ s{^F:}{}; 2683 if (exists $main::category_attrib{$cat_label}) { 2684 $cat_label = $main::category_attrib{$cat_label}->[0]; 2685 } else { 2686 $cat_label = ""; 2687 } 2688 [$cat, $cat_label]; 2689 } @cat; 2690 my $max_cat_length = BBBikeUtil::max(map { length $_->[0] } @cat); 2691 $max_cat_length = 4 if $max_cat_length < 4; 2692 @cat = map { sprintf "%-${max_cat_length}s %s", @$_ } @cat; 2693 } 2694 2695 $be->insert("end", @cat); 2696} 2697 2698sub insert_point_from_canvas { 2699 my $c = shift; 2700 my($point, @neighbors) = main::nearest_line_points_mouse($c); 2701 if (@neighbors) { 2702 $main::c->SelectionOwn(-command => sub { 2703 @main::inslauf_selection = (); 2704 @main::ext_selection = (); 2705 }); 2706 my($middle, $first, $last) = map { join(",", @$_) } @neighbors; 2707 if ($SRTShortcuts::force_edit_mode) { 2708 for ($first, $last) { 2709 $_ = find_corresponding_orig_point($c, $_); 2710 } 2711 $middle = $main::coord_prefix . join(",", $main::coord_output_sub->(split /,/, $middle)); 2712 } 2713 @main::inslauf_selection = ($first, $middle, $last); 2714 warn "insert coords=@main::inslauf_selection\n"; 2715 if (main::insert_points() && $auto_reload) { 2716 main::reload_all(); 2717 } 2718 } 2719} 2720 2721sub find_corresponding_orig_point { 2722 my($c, $point) = @_; 2723 my($cx,$cy) = main::transpose(split /,/, $point); 2724 for my $delta (1 .. 3) { 2725 my(@items) = $c->find("overlapping", 2726 $cx-$delta, $cy-$delta, 2727 $cx+$delta, $cy+$delta); 2728 my @items2; 2729 my %seen; 2730 for my $item (@items) { 2731 my @tags = $c->gettags($item); 2732 if (grep { $_ eq 'pp' } @tags) { 2733 if (!$seen{$tags[2]}) { 2734 push @items2, $item; 2735 $seen{$tags[2]} = 1; 2736 } 2737 } 2738 } 2739 2740 if (@items2 == 1) { 2741 my $orig = ($c->gettags($items2[0]))[2]; 2742 my $coord = ($c->gettags($items2[0]))[1]; 2743 if ($orig =~ /^ORIG:(.*)/) { # This is obsolete XXX 2744 return $1; 2745 } elsif ($coord =~ /-?\d+,-?\d+/) { 2746 return $coord; 2747 } 2748 } elsif (@items2 > 1) { 2749require Data::Dumper; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([map { [$_, $c->gettags($_)] } @items2],[])->Indent(1)->Useqq(1)->Dump; # XXX 2750 2751 main::status_message("XXX multiple item conflict, please write code for this!", "die"); 2752 } 2753 } 2754 main::status_message("Could not found orig point for $point", "die"); 2755} 2756 2757use vars qw(@points $point_nr $auto_create); 2758 2759sub relgps_filename { "$main::datadir/relation_gps" } 2760 2761sub create_relation_menu { 2762 my($top) = @_; 2763 my $t = $top->Toplevel(-title => "Create relation menu"); 2764 $t->transient($top) unless defined $main::transient && !$main::transient; 2765 2766 main::plot("str", "relgps", -draw => 1, -filename => relgps_filename()); 2767 2768 my $old_mode = $main::map_mode; 2769 $main::map_mode = main::MM_CREATERELATION(); 2770 2771 $t->OnDestroy(sub { 2772 $main::map_mode = $old_mode; 2773 main::plot("str", "relgps", -draw => 0); 2774 }); 2775 2776 2777 @points = (undef); 2778 foreach my $pnr (1 .. 2) { 2779 push @points, {}; 2780 my $f = $t->Frame->pack(-anchor => "w"); 2781 $f->Label(-text => "Point $pnr")->pack(-side => "left"); 2782 $f->Entry(-textvariable => \$points[$pnr]->{Coord})->pack(-side => "left"); 2783 $f->Label(-textvariable => \$points[$pnr]->{Type})->pack(-side => "left"); 2784 $f->Label(-textvariable => \$points[$pnr]->{Comment})->pack(-side => "left"); 2785 } 2786 $point_nr = 1; 2787 2788 $t->Button(-text => "Reset current", 2789 -command => sub { 2790 foreach (@points) { 2791 foreach my $key (qw(Coord Type Comment)) { 2792 $_->{$key} = ""; 2793 } 2794 } 2795 $point_nr = 1; 2796 })->pack; 2797 2798 { 2799 my $f = $t->Frame->pack; 2800 my($b, $activate_create_button); 2801 $activate_create_button = sub { 2802 $b->configure(-state => ($auto_create ? "disabled" : "normal")); 2803 }; 2804 $f->Checkbutton(-text => "Auto-Create", 2805 -variable => \$auto_create, 2806 -command => $activate_create_button, 2807 )->pack(-side => "left"); 2808 $b = $f->Button(-text => "Create", 2809 -command => [\&do_create_relation], 2810 )->pack(-side => "left"); 2811 $activate_create_button->(); 2812 } 2813 { 2814 my $f = $t->Frame->pack; 2815 $f->Button(-text => "Delete from map", 2816 -command => sub { 2817 main::plot("str", "relgps", -draw => 0); 2818 $t->destroy; 2819 })->pack; 2820 $f->Button(-text => "Close", 2821 -command => sub { 2822 $t->destroy; 2823 })->pack; 2824 } 2825 2826 $t->update; 2827 $t->Popup(-popover => $top, 2828 -popanchor => 'sw', 2829 -overanchor => 'sw', 2830 ); 2831} 2832 2833# XXX this is specific for creating GPS-berlinmap relationships 2834sub create_relation_from_canvas { 2835 my $c = shift; 2836 2837 my(@tags) = $c->gettags('current'); 2838 return if !@tags || !defined $tags[0]; 2839 2840 require BBBikeAdvanced; 2841 my $inslauf_selection_count = $#main::inslauf_selection; 2842 main::buttonpoint(); 2843 if ($inslauf_selection_count == $#main::inslauf_selection) { 2844 return; # nothing was inserted 2845 } 2846 # last point in @main::inslauf_selection was just inserted 2847 my $point = $main::inslauf_selection[-1]; 2848 2849 if ($tags[0] =~ /^(xxx|L\d+)/) { 2850 # XXX special GPS point handling 2851 $points[$point_nr]->{Type} = 'GPS'; 2852 $points[$point_nr]->{Comment} = $tags[2]; 2853 } else { 2854 $points[$point_nr]->{Type} = 'bbbike'; 2855 $points[$point_nr]->{Comment} = ""; 2856 } 2857 $points[$point_nr]->{Coord} = $point; 2858 2859 if ($point_nr == 1) { 2860 $point_nr++; 2861 } else { 2862 if ($auto_create) { 2863 do_create_relation(); 2864 } 2865 $point_nr = 1; # XXX? 2866 } 2867} 2868 2869# parameters: points array reference (optional, if not given then use 2870# global @points variable) 2871sub do_create_relation { 2872 my $pointsref = shift; 2873 my @points = @points; 2874 if ($pointsref && ref $pointsref eq 'ARRAY') { 2875 @points = @$pointsref; 2876 } 2877 2878 die "Same coords!" if ($points[1]->{Coord} eq $points[2]->{Coord} && 2879 $points[1]->{Type} ne $points[2]->{Type}); 2880 die "Empty coords!" if ($points[1]->{Coord} eq '' || 2881 $points[2]->{Coord} eq ''); 2882 2883 $main::str_file{'relgps'} = relgps_filename(); 2884 my $file = "$main::str_file{'relgps'}-orig"; 2885 ask_for_co($main::top, $file); 2886 open(RELFILE, ">>$file") or main::status_message("Can't write to $file: $!", "die"); 2887 binmode RELFILE; 2888 my @order = (1,2); 2889 if ($points[2]->{Type} eq 'GPS') { 2890 @order = (2,1); 2891 } 2892 print RELFILE $points[$order[0]]->{Comment}; 2893 print RELFILE "\tGPS "; 2894 print RELFILE join(" ", map { $points[$_]->{Coord} } @order); 2895 print RELFILE "\n"; 2896 close RELFILE; 2897 2898 main::plot("str", "relgps", FastUpdate => 1, -draw => 1); 2899} 2900 2901use vars qw($gps_penalty_koeff $gps_penalty_multiply 2902 $bbd_penalty_koeff $bbd_penalty_multiply $bbd_penalty_file 2903 $bbd_penalty_invert 2904 $st_net_koeff $st_net_penalty_file 2905 ); 2906 2907sub build_gps_penalty_for_search { 2908 require Strassen::Core; 2909 my $s = new Strassen relgps_filename(); 2910 die "Can't get " . relgps_filename() if !$s; 2911 $s->init; 2912 my $penalty = {}; 2913 while(1) { 2914 my $r = $s->next; 2915 last if !@{ $r->[Strassen::COORDS()] }; 2916 $penalty->{$r->[Strassen::COORDS()]->[1]}++; 2917 } 2918#XXX evtl. weiteren Modus, der die Genauigkeit der Punkte ber�cksichtigt 2919# (falls mehrere Punkte auf den gleichen Punkt verweisen, dann die 2920# Varianz ausrechnen und ber�cksichtigen) 2921 $main::penalty_subs{gpspenalty} = sub { 2922 my($pen, $next_node) = @_; 2923 if (exists $penalty->{$next_node}) { 2924 if ($gps_penalty_multiply) { 2925 $pen *= $gps_penalty_koeff * $penalty->{$next_node}; 2926 } else { 2927 $pen *= $gps_penalty_koeff; 2928 } 2929 #warn "Hit penalty node $next_node\n";#XXX 2930 } 2931 $pen; 2932 }; 2933} 2934 2935sub choose_bbd_file_for_penalty { 2936 my $f = $main::top->getOpenFile 2937 (-filetypes => 2938 [ 2939 # XXX use Strassen->filetypes? 2940 [M"BBD-Dateien", '.bbd'], 2941 [M"Alle Dateien", '*'], 2942 ], 2943 -initialdir => $main::datadir, 2944 ); 2945 return if !defined $f; 2946 $bbd_penalty_file = $f; 2947} 2948 2949# Handles 2950# - line penalties 2951# - point penalties 2952# 2953# Line penalties are specified using $bbd_penalty_koeff. 2954# Point penalties are only used if 2955# - the user has set a reference speed (not reference power) 2956# - the points are specified with categories in the form "something:losttime" 2957# 2958# If the active reference speed is changed, then the penalty net needs 2959# to be rebuild to take into effect. 2960# 2961# The penalty net can be inverted. This is only possible for line 2962# penalties. 2963sub build_bbd_penalty_for_search { 2964 if (!defined $bbd_penalty_file) { 2965 choose_bbd_file_for_penalty(); 2966 return if (!defined $bbd_penalty_file); 2967 } 2968 2969 my $active_speed_ms; 2970 if (keys %main::active_speed_power && 2971 $main::active_speed_power{Type} eq "speed") { 2972 my $i = $main::active_speed_power{Index}; 2973 $active_speed_ms = BBBikeUtil::kmh2ms($main::speed[$i]); 2974 } 2975 2976 require Strassen::Core; 2977 my $s = new Strassen $bbd_penalty_file; 2978 die "Can't get $bbd_penalty_file" if !$s; 2979 $s->init; 2980 my $penalty = {}; 2981 my $point_penalty = {}; 2982 while(1) { 2983 my $r = $s->next; 2984 my @c = @{ $r->[Strassen::COORDS()] }; 2985 last if !@c; 2986 if (@c == 1 && $active_speed_ms) { 2987 if (my($time_lost) = $r->[Strassen::CAT()] =~ m{^.*?:(\d+)}) { 2988 $point_penalty->{$c[0]} = $time_lost * $active_speed_ms; 2989 } 2990 } else { 2991 for my $i (0 .. $#c-1) { 2992 # XXX beide Richtungen??? 2993 $penalty->{$c[$i] . "," . $c[$i+1]} = 1; 2994 $penalty->{$c[$i+1] . "," . $c[$i]} = 1; 2995 } 2996 } 2997 } 2998 2999 if ($bbd_penalty_invert) { 3000 # XXX point_penalty kann nicht invertiert werden! 3001 warn M"Die Bedeutung der Penalty-Daten invertieren...\n"; 3002 my $new_penalty = {}; 3003 if (!$main::net) { 3004 $bbd_penalty_invert = 0; 3005 main::status_message(M"Nur m�glich, wenn ein Netz existiert", "die"); 3006 } 3007 my $net = $main::net->{Net}; 3008 while(my($k1,$v) = each %$net) { 3009 while(my($k2,$v2) = each %$v) { 3010 my $k12 = "$k1,$k2"; 3011 my $k21 = "$k2,$k1"; 3012 if (!exists $penalty->{$k12}) { 3013 $new_penalty->{$k12} = 1; 3014 } 3015 if (!exists $penalty->{$k21}) { 3016 $new_penalty->{$k21} = 1; 3017 } 3018 } 3019 } 3020 $penalty = $new_penalty; 3021 } 3022 3023 $main::penalty_subs{bbdpenalty} = sub { 3024 my($pen, $next_node, $last_node) = @_; 3025 if (exists $penalty->{$last_node.",".$next_node}) { 3026 if ($bbd_penalty_multiply) { 3027 $pen *= $bbd_penalty_koeff * $penalty->{$last_node.",".$next_node}; 3028 } else { 3029 $pen *= $bbd_penalty_koeff; 3030 } 3031 #warn "Hit penalty node $next_node\n";#XXX 3032 } 3033 if (exists $point_penalty->{$next_node}) { 3034 $pen += $point_penalty->{$next_node}; 3035 } 3036 $pen; 3037 }; 3038} 3039 3040sub choose_st_net_file_for_penalty { 3041 my $f = $main::top->getOpenFile 3042 (-filetypes => 3043 [ 3044 [M"Net/Storable-Dateien", '.st'], 3045 [M"Alle Dateien", '*'], 3046 ], 3047 -initialdir => $main::datadir, 3048 ); 3049 return if !defined $f; 3050 $st_net_penalty_file = $f; 3051} 3052 3053sub build_st_net_penalty_for_search { 3054 if (!defined $st_net_penalty_file) { 3055 choose_st_net_file_for_penalty(); 3056 return if (!defined $st_net_penalty_file); 3057 } 3058 require Storable; 3059 my $penalty = Storable::retrieve($st_net_penalty_file); 3060 die "Can't retrieve $st_net_penalty_file" if !$penalty; 3061 3062 $main::penalty_subs{stnetpenalty} = sub { 3063 my($pen, $next_node, $last_node) = @_; 3064 if (exists $penalty->{$last_node.",".$next_node}) { 3065 my $this_penalty = $penalty->{$last_node.",".$next_node}; 3066 $this_penalty = $st_net_koeff * $this_penalty + (100-$st_net_koeff*100) 3067 if $st_net_koeff != 1; 3068 if ($this_penalty < 1) { $this_penalty = 1 } # avoid div by zero or negative values 3069 $pen *= (100 / $this_penalty); 3070 } 3071 $pen; 3072 }; 3073} 3074 3075###################################################################### 3076# edit GPSMAN waypoints 3077 3078use vars qw($edit_gpsman_waypoint_tl @edit_gpsman_history); 3079 3080sub set_edit_gpsman_waypoint { 3081 if ($main::map_mode eq main::MM_CUSTOMCHOOSE()) { 3082 main::status_message(M("GPS-Punkte-Editor-Modus wahrscheinlich schon gesetzt"), "warn"); 3083 return; 3084 } 3085 $main::map_mode = main::MM_CUSTOMCHOOSE(); 3086 my $cursorfile = main::build_text_cursor("Edit wpt"); 3087 $main::c->configure(-cursor => defined $cursorfile ? $cursorfile : "hand2"); 3088 main::status_message(M("Waypoints editieren"), "info"); 3089 $main::customchoosecmd = sub { 3090 my($c,$e) = @_; 3091 my(@tags) = $c->gettags("current"); 3092 return unless grep { $_ =~ /^(?:xxx|L\d+)-fg$/ } @tags; 3093 edit_gpsman_waypoint($tags[2]); 3094 }; 3095} 3096 3097sub edit_gpsman_waypoint { 3098 my($wpt_tag) = @_; 3099 require DB_File; 3100 require Fcntl; 3101 require GPS::GpsmanData; 3102 require Karte::Polar; 3103 require Karte::Berlinmap1996; 3104 my $polarmap = $Karte::Polar::obj; 3105 my $b1996map = $Karte::Berlinmap1996::obj; 3106 3107 my($basefile, $wpt, $descr) = split m|/|, $wpt_tag; 3108 if (!defined $basefile || !defined $wpt) { 3109 main::status_message(Mfmt("Der Tag <%s> kann nicht geparst werden", $wpt_tag), "err"); 3110 return; 3111 } 3112 if (!-d $main::gpsman_data_dir) { 3113 main::status_message(Mfmt("Die GPSMan-Datei muss sich im Verzeichnis <%s> befinden", $main::gpsman_data_dir), "err"); 3114 return; 3115 } 3116 my $file = find_gpsman_file($basefile); 3117 if (!defined $file) { 3118 main::status_message(Mfmt("Die Datei <%s> konnte nicht im Verzeichnis <%s> oder den Unterverzeichnissen gefunden werden", $basefile, $main::gpsman_data_dir), "err"); 3119 return; 3120 } 3121 ask_for_co($main::top, $file); 3122 tie my @gpsman_data, 'DB_File', $file, &Fcntl::O_RDWR, 0644, $DB_File::DB_RECNO 3123 or do { 3124 main::status_message(Mfmt("Die Datei <%s> kann nicht ge�ffnet werden: %s", $file, $!), "err"); 3125 return; 3126 }; 3127 3128 my $tl; 3129 my $create_tl = sub { 3130 if (Tk::Exists($edit_gpsman_waypoint_tl)) { 3131 $_->destroy for $edit_gpsman_waypoint_tl->children; 3132 $edit_gpsman_waypoint_tl->deiconify; 3133 $tl = $edit_gpsman_waypoint_tl; 3134 $tl->Walk(sub { 3135 my $w = shift; 3136 eval { 3137 $w->configure(-state => "normal"); 3138 }; 3139 }); 3140 $tl->raise; 3141 } else { 3142 $tl = $main::top->Toplevel(-title => "Waypoint"); 3143 $edit_gpsman_waypoint_tl = $tl; 3144 $tl->transient($main::top) if $main::transient; 3145 $tl->Popup(@main::popup_style); 3146 } 3147 }; 3148 3149 foreach my $inx (0 .. $#gpsman_data) { 3150 my $line = $gpsman_data[$inx]; 3151 if ($line =~ /^\Q$wpt\E\t/) { 3152 my @f = split /\t/, $line; 3153 local $_ = $line; 3154 my $wptobj = GPS::GpsmanData::parse_waypoint(); 3155 #my $descr = $f[1]; # equivalent 3156 my $descr = $wptobj->Comment; 3157 $create_tl->(); 3158 my $row = 0; 3159 $tl->Label(-text => M("+ f�r Kreuzungen benutzen")."\n"."Waypoint $wpt")->grid(-column => 0, -row => $row, -sticky => "w"); 3160 my $Entry = "Entry"; 3161 my @EntryArgs = (-width => 40); 3162 if (eval {require Tk::HistEntry; Tk::HistEntry->VERSION(0.37)}) { 3163 $Entry = 'HistEntry'; 3164 @EntryArgs = (-match => 1, -dup => 0); 3165 } 3166 my $garmin_valid_chars = sub { 3167 $_[0] =~ /^[-A-Z���a-z����.+0-9 -]*$/; # the same as in ~/.gpsman-dir/patch.tcl 3168 }; 3169 my $e = $tl->$Entry 3170 (-validate => "key", 3171 -vcmd => $garmin_valid_chars, 3172 @EntryArgs, 3173 -textvariable => \$descr)->grid(-column => 1, -row => $row, -sticky => "w"); 3174 if ($e->can('history')) { 3175 $e->history([@edit_gpsman_history]); 3176 } 3177 $e->focus; 3178 my $wait = 0; 3179 my $b = $tl->Button(-text => "OK", 3180 -command => sub { $descr ne "" and $wait = 1 }) 3181 ->grid(-column => 3, -row => $row); 3182 $e->bind("<Return>" => sub { $b->invoke }); 3183 $e->bind("<Escape>" => sub { $wait = -1 }); 3184 3185 my($px,$py) = $polarmap->map2standard 3186 (map { GPS::GpsmanData::convert_DMS_to_DDD($_) } 3187 $wptobj->Longitude, $wptobj->Latitude); 3188 my @nearest_crossings = get_nearest_crossing_obj(0,$px,$py, -uniquename => 1); 3189 my(@descr2) = map { $_->{CrossingName} } @nearest_crossings; 3190 my $descr2 = @descr2 ? $descr2[0] : ""; 3191 my $create_rel = @descr2 > 0 && $nearest_crossings[0]->{Source} eq 'BBBikeData'; 3192 $row++; 3193 $tl->Label(-text => M("N�chste Kreuzung"))->grid(-column => 0, -row => $row, -sticky => "w"); 3194 my $e2 = $tl->BrowseEntry(-width => 40, 3195 -textvariable => \$descr2, 3196 -choices => \@descr2)->grid(-column => 1, -row => $row, -sticky => "w"); 3197 $tl->Checkbutton(-text => M"Relation erzeugen", 3198 -variable => \$create_rel)->grid(-column => 2, -row => $row, -sticky => "w"); 3199 3200 my $b2 = $tl->Button(-text => "OK", 3201 -command => sub { $descr2 ne "" and $wait = 2 }) 3202 ->grid(-column => 3, -row => $row); 3203 $e2->bind("<Return>" => sub { $b2->invoke }); 3204 $e2->bind("<Escape>" => sub { $wait = -1 }); 3205 3206 $tl->OnDestroy(sub { $wait = -1 }); 3207 $tl->waitVariable(\$wait); 3208 3209 if ($wait == 2) { 3210 $descr = $descr2; 3211 if ($create_rel) { 3212 my($tx,$ty) = map { int } $b1996map->standard2map($px,$py); 3213 my($cr_obj) = get_nearest_crossing_obj(1, $tx,$ty, -onlybbbikedata => 1); 3214 if (!$cr_obj) { 3215 main::status_message("Can't create relation: no crossing for $tx/$ty", "err"); 3216 die; 3217 } 3218 my @p = (undef, 3219 {Coord => $cr_obj->{Coord}, 3220 Type => "bbbike", 3221 Comment => ""}, 3222 {Coord => "$tx,$ty", 3223 Type => "GPS", 3224 Comment => "$basefile/".$wptobj->Ident."/$descr"} 3225 ); 3226 do_create_relation(\@p); 3227 } 3228 } 3229 3230 if ($wait == 1 || $wait == 2) { 3231 if ($e->can('historyAdd')) { 3232 my @crossings = split /\+/, $descr; 3233 foreach (@crossings) { 3234 $e->historyAdd($_); 3235 } 3236 @edit_gpsman_history = $e->history; 3237 } 3238 $f[1] = $descr; 3239 $gpsman_data[$inx] = join("\t", @f); 3240 } 3241 untie @gpsman_data; 3242 $tl->withdraw if Tk::Exists($tl); 3243 return; 3244 } elsif ($line =~ /^\t\Q$wpt\E\t/) { # track waypoint 3245 $create_tl->(); 3246 my @f = split /\t/, $line; 3247 my $acc = ""; 3248 if ($f[4] =~ /^(~+|\?)/) { 3249 $acc = $1; 3250 } 3251 #my $weiter = 0; 3252 #my $close = sub { $weiter = 1 }; 3253 my $disable = sub { 3254 $tl->Walk(sub { 3255 my $w = shift; 3256 eval { 3257 $w->configure(-state => "disabled"); 3258 }; 3259 }); 3260 }; 3261 my $set_accuracy = sub { 3262 $f[4] =~ s/^(~*\|?)/$acc/; 3263 my $new_line = join("\t", @f); 3264 warn $new_line; 3265 $gpsman_data[$inx] = $new_line; 3266 $disable->(); 3267 untie @gpsman_data; 3268 #$close->(); 3269 }; 3270 my $f = $tl->Frame->pack; 3271 for my $accval ('', '?', '~', '~~') { 3272 $f->Radiobutton(-text => $accval eq '' ? '!' : $accval, 3273 -value => $accval, 3274 -variable => \$acc, 3275 -indicator => 0, 3276 -command => $set_accuracy)->pack(-side => "left"); 3277 } 3278 $tl->Button(Name => "close", 3279 #-command => $close, 3280 -command => sub { 3281 untie @gpsman_data; 3282 $tl->withdraw if Tk::Exists($tl); 3283 }, 3284 )->pack; 3285 #$tl->OnDestroy(sub { $weiter = -1 }); 3286 #$tl->waitVariable(\$weiter); 3287 #untie @gpsman_data; 3288 #$tl->withdraw if Tk::Exists($tl); 3289 return; 3290 } 3291 3292 } 3293 3294 main::status_message(Mfmt("Kann den Punkt <%s> nicht finden", $wpt), "warn"); 3295 untie @gpsman_data; 3296} 3297 3298# from bbbike.cgi (changed) 3299use vars qw(%crossings %gpspoints %gpspoints_hash %str_obj); 3300sub all_crossings { 3301 my $edit_mode = shift; 3302 my $strname = ($edit_mode ? "strassen-orig" : "strassen"); 3303 if (!$str_obj{$edit_mode}) { 3304 $str_obj{$edit_mode} = Strassen->new($strname) 3305 or die "Can't get $strname"; 3306 } 3307 if (scalar keys %{$crossings{$edit_mode}} == 0) { 3308 %{$crossings{$edit_mode}} = %{ $str_obj{$edit_mode}->all_crossings(RetType => 'hash', UseCache => 1) }; 3309 } 3310} 3311 3312# from bbbike.cgi (changed) 3313#use vars qw(%kr); 3314sub new_kreuzungen { 3315 my $edit_mode = shift; 3316# if (!$kr{$edit_mode}) { 3317 if (scalar keys %{$crossings{$edit_mode}} == 0) { 3318 all_crossings($edit_mode); 3319# $kr{$edit_mode} = new Kreuzungen Hash => $crossings{$edit_mode}; 3320# $kr{$edit_mode}->make_grid; 3321 } 3322 if (!$gpspoints{$edit_mode}) { 3323 my $gpsname = "$Strassen::Util::cachedir/" . ($edit_mode ? "points.bbd-orig" : "points.bbd"); 3324 my $gpspoints_o = Strassen->new($gpsname); 3325 if (!$gpspoints_o) { 3326 warn "Cannot get GPS points from $gpsname"; 3327 } else { 3328 $gpspoints_hash{$edit_mode} = $gpspoints_o->get_hashref; 3329 $gpspoints{$edit_mode} = Kreuzungen->new(Hash => $gpspoints_hash{$edit_mode}); 3330 $gpspoints{$edit_mode}->make_grid(Width => 100); 3331 } 3332 } 3333 3334# $kr{$edit_mode}; 3335} 3336 3337# from bbbike.cgi (changed) 3338sub get_nearest_crossing_name { 3339 my($edit_mode, $x,$y) = @_; 3340 my @ret = map { $_->{CrossingName} } get_nearest_crossing_obj($edit_mode, $x,$y); 3341 my %saw; 3342 grep(!$saw{$_}++, @ret); 3343} 3344 3345# from bbbike.cgi (changed) 3346sub get_nearest_crossing_obj { 3347 my($edit_mode, $x,$y, %args) = @_; 3348 new_kreuzungen($edit_mode); 3349 3350 my @ret; 3351 3352 my $ret = $str_obj{$edit_mode}->nearest_point("$x,$y", FullReturn => 1); 3353 $ret->{CrossingName} = ($ret && $crossings{$edit_mode}->{$ret->{Coord}} 3354 ? join("+", map { Strassen::strip_bezirk($_) } @{ $crossings{$edit_mode}->{$ret->{Coord}}}) 3355 : ""); 3356 $ret->{Source} = "BBBikeData"; 3357 push @ret, $ret; 3358 3359 my $ret2; 3360 if ($gpspoints{$edit_mode} && !$args{-onlybbbikedata}) { 3361 push @ret, map { my $cr_name = $gpspoints_hash{$edit_mode}->{$_->[0]}; 3362 $cr_name = (split '/', $cr_name)[2]; 3363 +{Coord => $_->[0], 3364 Dist => $_->[1], 3365 CrossingName => $cr_name, 3366 Source => "GPSData", 3367 } 3368 } $gpspoints{$edit_mode}->nearest($x,$y,IncludeDistance => 1); 3369 } 3370 3371 @ret = map { $_->[1] } 3372 sort { $a->[0] <=> $b->[0] } 3373 map { [$_->{Dist}, $_] } 3374 @ret; 3375 3376 if ($args{-uniquename}) { 3377 my %saw; 3378 @ret = grep(!$saw{$_->{CrossingName}}++, @ret); 3379 } 3380 3381 @ret; 3382} 3383 3384use vars qw($remember_map_mode_for_edit_gps_track); 3385sub edit_gps_track_mode { 3386 $remember_map_mode_for_edit_gps_track = $main::map_mode 3387 if $main::map_mode ne main::MM_CUSTOMCHOOSE_TAG(); 3388 $main::map_mode = main::MM_CUSTOMCHOOSE_TAG(); 3389 my $cursorfile = main::build_text_cursor("GPS trk"); 3390 $main::c->configure(-cursor => defined $cursorfile ? $cursorfile : "hand2"); 3391 main::status_message(M("Track zum Editieren ausw�hlen"), "info"); 3392 $main::customchoosecmd = sub { 3393 my($c,$e) = @_; 3394 my(@tags) = $c->gettags("current"); 3395 for (@tags) { 3396 if (/(.*\.trk)/) { 3397 edit_gps_track_by_basename($1); 3398 last; 3399 } elsif (/^(L\d+)$/ && exists $main::str_file{$1} && 3400 $main::str_file{$1} =~ /(\d+\.trk)/) { 3401 edit_gps_track_by_basename($1); 3402 last; 3403 } 3404 } 3405 }; 3406} 3407 3408sub edit_gps_track_by_basename { 3409 my $basename = shift; 3410 my $file = find_gpsman_file($basename); 3411 edit_gps_track($file); 3412} 3413 3414use vars qw($recent_gps_point_layer $recent_gps_street_layer); 3415sub edit_gps_track { 3416 my $file = shift; 3417 if (-r $file) { 3418 local $main::lazy_plot = 0; # somehow does not work 3419 main::IncBusy($main::top); 3420 eval { 3421 if ($main::edit_mode) { 3422 if ($main::edit_mode eq 'b') { 3423 require "$ENV{HOME}/src/bbbike/miscsrc/gpsman2bbd.pl"; 3424 BBBike::GpsmanConv::gpsman2bbd(qw(-deststreets streets.bbd-orig -destpoints points.bbd-orig -destmap berlinmap -destdir /tmp), $file, qw(-forcepoints)); 3425# system("$ENV{HOME}/src/bbbike/miscsrc/gpsman2bbd.pl -deststreets streets.bbd-orig -destpoints points.bbd-orig -destmap berlinmap -destdir /tmp $file -forcepoints"); 3426 } else { 3427 main::status_message("No support for edit mode $main::edit_mode", "error"); 3428 die; 3429 } 3430 } else { 3431 require "$ENV{HOME}/src/bbbike/miscsrc/gpsman2bbd.pl"; 3432 BBBike::GpsmanConv::gpsman2bbd(qw(-destdir /tmp), $file, qw(-forcepoints)); 3433# system("$ENV{HOME}/src/bbbike/miscsrc/gpsman2bbd.pl -destdir /tmp $file -forcepoints"); 3434 } 3435 3436 my $abk = main::plot_layer('p', "/tmp/points.bbd"); 3437 my $abk_s = main::plot_layer('str', "/tmp/streets.bbd"); 3438 3439 main::special_raise($abk_s); 3440 main::special_raise($abk); 3441 main::special_raise($abk."-fg"); 3442 3443 $recent_gps_street_layer = $abk_s; 3444 $recent_gps_point_layer = $abk; 3445 }; 3446 my $err = $@; 3447 main::DecBusy($main::top); 3448 warn $err if $err; 3449 3450 } else { 3451 warn "Can't find file $file"; 3452 } 3453 3454 if (defined $remember_map_mode_for_edit_gps_track) { 3455 undef $main::customchoosecmd; 3456 main::set_map_mode($remember_map_mode_for_edit_gps_track); 3457 undef $remember_map_mode_for_edit_gps_track; 3458 } 3459} 3460 3461sub show_gps_track_mode { 3462 $remember_map_mode_for_edit_gps_track = $main::map_mode 3463 if $main::map_mode ne main::MM_CUSTOMCHOOSE_TAG(); 3464 $main::map_mode = main::MM_CUSTOMCHOOSE_TAG(); 3465 my $cursorfile = main::build_text_cursor("GPS trk"); 3466 $main::c->configure(-cursor => defined $cursorfile ? $cursorfile : "hand2"); 3467 main::status_message(M("Track zum Anzeigen ausw�hlen"), "info"); 3468 $main::customchoosecmd = sub { 3469 my $file = _find_track_file(@_); 3470 if (!$file) { 3471 main::status_message(M("Keine Track-Datei gefunden")); 3472 return; 3473 } 3474 BBBikeGPS::do_draw_gpsman_data($main::top, $file, -solidcoloring => 1); 3475 3476 if (defined $remember_map_mode_for_edit_gps_track) { 3477 undef $main::customchoosecmd; 3478 main::set_map_mode($remember_map_mode_for_edit_gps_track); 3479 undef $remember_map_mode_for_edit_gps_track; 3480 } 3481 }; 3482} 3483 3484sub show_gps_data_viewer_mode { 3485 $remember_map_mode_for_edit_gps_track = $main::map_mode 3486 if $main::map_mode ne main::MM_CUSTOMCHOOSE_TAG(); 3487 $main::map_mode = main::MM_CUSTOMCHOOSE_TAG(); 3488 my $cursorfile = main::build_text_cursor("GPS trk"); 3489 $main::c->configure(-cursor => defined $cursorfile ? $cursorfile : "hand2"); 3490 main::status_message(M("Track f�r GPS Data Viewer ausw�hlen"), "info"); 3491 $main::customchoosecmd = sub { 3492 my $file = _find_track_file(@_); 3493 if ($file) { 3494 require SRTShortcuts; # XXX would require use lib miscsrc 3495 SRTShortcuts::gps_data_viewer($file); 3496 if (defined $remember_map_mode_for_edit_gps_track) { 3497 undef $main::customchoosecmd; 3498 main::set_map_mode($remember_map_mode_for_edit_gps_track); 3499 undef $remember_map_mode_for_edit_gps_track; 3500 } 3501 } 3502 }; 3503} 3504 3505sub _find_track_file { 3506 my($c,$e) = @_; 3507 my(@tags) = $c->gettags("current"); 3508 my $base; 3509 for (@tags) { 3510 if (/(.*\.trk)/) { 3511 $base = $1; 3512 last; 3513 } elsif (/^(L\d+)$/ && exists $main::str_file{$1} && 3514 $main::str_file{$1} =~ /(\d+\.trk)/) { 3515 $base = $1; 3516 last; 3517 } 3518 } 3519 if ($base) { 3520 return find_gpsman_file($base); 3521 } 3522} 3523 3524use vars qw($prefer_tracks); # "bahn" or "street" 3525 3526sub find_gpsman_file { 3527 my $basename = shift; 3528 require File::Spec; 3529 my $rootdir = $main::gpsman_data_dir; 3530 if (defined $prefer_tracks && $prefer_tracks eq 'bahn') { 3531 $rootdir .= "/bahn"; 3532 } 3533 my $file = (File::Spec->file_name_is_absolute($basename) 3534 ? $basename 3535 : "$rootdir/$basename" 3536 ); 3537 if (!-r $file) { 3538 undef $file; 3539 require File::Find; 3540 File::Find::find(sub { 3541 if ($File::Find::name =~ /\b(RCS|CVS|\.svn|\.git)\b/) { 3542 $File::Find::prune = 1; 3543 return; 3544 } 3545 if ($_ eq $basename) { 3546 $file = $File::Find::name; 3547 $File::Find::prune = 1; 3548 } 3549 }, $rootdir); 3550 if (defined $file) { 3551 warn "Datei <$file> f�r Basename <$basename> gefunden\n"; 3552 } 3553 } 3554 $file; 3555} 3556 3557sub clone { 3558 my $orig = shift; 3559 my $clone; 3560 if (eval { require Storable; 1 }) { 3561 $clone = Storable::dclone($orig); 3562 } else { 3563 require Data::Dumper; 3564 my $clone; 3565 $clone = eval Data::Dumper->new([$orig], ['clone'])->Indent(0)->Purity(1)->Dump; 3566 } 3567 $clone; 3568} 3569 3570# XXX further implementation needed: 3571# * verschiedene Typen von blockings editierbar machen, mindestens jedoch 3572# "3" und "q4". Untermen� zum Ausw�hlen des aktuellen blocking-typs. 3573# das Zeichnen der zus�tzlichen Sperrungen mit dem normalen 3574# Zeichnen m�glichst unifizieren. 3575# * beim Abspeichern sollte der Typ nicht mehr angegeben werden m�ssen 3576# * beim Laden ebenfalls nicht. Im cgi und in bbbike wird statt pauschal 3577# "make_sperre" nach Kategorien differenziert und je Strassen-Objekte 3578# f�r make_sperre und merge_handicap_net on-the-fly generiert 3579# * Teile von miscsrc/bbbike-check-temp-blockings modularisieren 3580# und nach bbbike/BBBikeTempBlockings.pm verschieben: Laden der 3581# temp-blockings.pl-Datei, Checken, was davon aktuell ist 3582# * bbbike: Einzelne blockings sollten ein/ausgeblendet werden k�nnen 3583sub temp_blockings_editor { 3584 my $t = main::redisplay_top($main::top, "temp_blockings_editor", 3585 -title => M"Tempor�re Sperrungen"); 3586 return if !defined $t; 3587 require File::Spec; 3588 require File::Basename; 3589 require File::Copy; 3590 require POSIX; 3591 3592 require Tk::PathEntry; 3593 require Tk::Date; 3594 require Tk::NumEntry; 3595 require Tk::LabFrame; 3596 require Tk::ROText; 3597 3598 $t->gridColumnconfigure($_, -weight => 1) for (1..2); 3599 $t->gridRowconfigure ($_, -weight => 1) for (1..8); 3600 3601 eval { 3602 require "$FindBin::RealBin/miscsrc/check_bbbike_temp_blockings"; 3603 }; warn $@ if $@; 3604 3605 my $initialdir = $BBBike::check_bbbike_temp_blockings::temp_blockings_dir . "/"; 3606 my $pl_file = $BBBike::check_bbbike_temp_blockings::temp_blockings_pl; 3607 my $file = $initialdir; 3608 my $as_data; # default set below with "invoke" 3609 my $prewarn_days = 1; 3610 my $blocking_type = "gesperrt"; 3611 my $edit_after = 0; 3612 my $do_delete_blockings = 1; 3613 my $auto_cross_road_blockings = 0; 3614 my $is_in_work = 1; 3615 my $meta_data_handling = "append"; 3616 my $pe; 3617 my $as_data_cb; 3618 Tk::grid($t->Label(-text => M("bbd-Datei").":"), 3619 $pe = $t->PathEntry(-textvariable => \$file), 3620 $as_data_cb = $t->Checkbutton(-text => "as data", 3621 -variable => \$as_data, 3622 -command => sub { 3623 $pe->configure(-state => $as_data ? "disabled" : "normal"), 3624 }, 3625 ), 3626 -sticky => "w", 3627 ); 3628 $pe->focus; 3629 $pe->icursor("end"); 3630 $as_data_cb->invoke; # default to "as data" 3631 3632 Tk::grid($t->Label(-text => M("Beschreibung").":"), 3633 -sticky => "w", 3634 ); 3635 my $txt; 3636 Tk::grid($txt = $t->Scrolled("Text", -scrollbars => "e", 3637 -width => 40, -height => 3, 3638 ), 3639 -sticky => "ew", 3640 -columnspan => 2); 3641 my $real_txt = $txt->Subwidget("scrolled"); 3642 3643 my $btn_f; 3644 { 3645 my %info = $txt->gridInfo; 3646 my $txt_row = $info{-row}; 3647 $btn_f = $t->Frame->grid(-row => $txt_row, -column => 2, -sticky => "nw"); 3648 } 3649 3650 my $paste_b = $btn_f->Button 3651 (-text => "Paste", -bd => 1, -padx => 0, -pady => 0 3652 )->pack(-anchor => "w"); 3653 my $act_b = $btn_f->Button 3654 (-text => "Date", -bd => 1, -padx => 0, -pady => 0 3655 )->pack(-anchor => "w"); 3656 my $fmt_b = $btn_f->Button 3657 (-text => "Fmt", -bd => 1, -padx => 0, -pady => 0 3658 )->pack(-anchor => "w"); 3659 3660 my $source_id; 3661 Tk::grid($t->Label(-text => "Source-ID"), 3662 $t->Entry(-width => 20, 3663 -textvariable => \$source_id, 3664 ), 3665 -sticky => "w", 3666 ); 3667 3668 my($start_w, $end_w); 3669 my($start_undef, $end_undef); 3670 Tk::grid($t->Label(-text => M"Start"), 3671 $start_w = $t->Date(-choices => ["now", 3672 ["begin of today" => { H => 0, M => 0, S => 0 }], 3673 ["begin of tomorrow" => sub { 3674 my @l = localtime(time()+86400); 3675 @l[0,1,2]=(0,0,0); 3676 require Time::Local; 3677 Time::Local::timelocal(@l); 3678 }, 3679 ] 3680 ]), 3681 $t->Checkbutton(-text => "undef", 3682 -variable => \$start_undef), 3683 -sticky => "w", 3684 ); 3685 3686 Tk::grid($t->Label(-text => M"Ende"), 3687 $end_w = $t->Date(-choices => ["now", 3688 ["end of today" => { H => 23, M => 59, S => 59 }], 3689 ["end of tomorrow" => sub { 3690 my @l = localtime(time()+86400); 3691 @l[0,1,2]=(59,59,23); 3692 require Time::Local; 3693 Time::Local::timelocal(@l); 3694 }, 3695 ] 3696 ]), 3697 $t->Checkbutton(-text => "undef", 3698 -variable => \$end_undef), 3699 -sticky => "w", 3700 ); 3701 3702 Tk::grid($t->Label(-text => M"Vorwarnzeit in Tagen"), 3703 $t->NumEntry(-textvariable => \$prewarn_days, 3704 -width => 3, 3705 -minvalue => 0, 3706 ), 3707 -sticky => "w", 3708 ); 3709 3710 my $cs = 3; 3711 { 3712 my $f = $t->LabFrame(-label => M"Typ", 3713 -labelside => "acrosstop"); 3714 Tk::grid($f, -sticky => "ew", -columnspan => $cs); 3715 $f->Radiobutton(-text => M"gesperrt", 3716 -value => "gesperrt", 3717 -variable => \$blocking_type, 3718 )->pack(-anchor => "w"); 3719 $f->Radiobutton(-text => M"Einbahnstra�e (Richtung manuell korrigieren!)", 3720 -value => "oneway", 3721 -variable => \$blocking_type, 3722 )->pack(-anchor => "w"); 3723 $f->Radiobutton(-text => M"handicap", 3724 -value => "handicap-q4", 3725 -variable => \$blocking_type, 3726 )->pack(-anchor => "w"); 3727 $f->Radiobutton(-text => M"handicap in einer Richtung (Richtung manuell korrigieren!)", 3728 -value => "handicap-q4-oneway", 3729 -variable => \$blocking_type, 3730 )->pack(-anchor => "w"); 3731 } 3732 3733 Tk::grid($t->Checkbutton(-text => M"�berqueren der gesperrten Stra�en nicht m�glich", 3734 -variable => \$auto_cross_road_blockings, 3735 ), 3736 -sticky => "w", 3737 -columnspan => $cs, 3738 ); 3739 3740 Tk::grid($t->Checkbutton(-text => M"Baustelle", 3741 -variable => \$is_in_work, 3742 ), 3743 -sticky => "w", 3744 -columnspan => $cs, 3745 ); 3746 3747 { 3748 my $f = $t->LabFrame(-label => M"Metadaten", 3749 -labelside => "acrosstop"); 3750 Tk::grid($f, -sticky => "ew", -columnspan => $cs); 3751 $f->Radiobutton(-text => M"Nach STDERR schreiben", 3752 -value => "", 3753 -variable => \$meta_data_handling, 3754 )->pack(-anchor => "w"); 3755 $f->Radiobutton(-text => M"An zentrale pl-Datei anh�ngen", 3756 -value => "append", 3757 -variable => \$meta_data_handling, 3758 )->pack(-anchor => "w"); 3759 $f->Radiobutton(-text => M"Existierenden Eintrag ersetzen", 3760 -value => "replace", 3761 -variable => \$meta_data_handling, 3762 )->pack(-anchor => "w"); 3763 $f->Radiobutton(-text => M"Existierenden Eintrag ersetzen, alte Strecken beibehalten", 3764 -value => "replace_preserve_data", 3765 -variable => \$meta_data_handling, 3766 )->pack(-anchor => "w"); 3767 $f->Radiobutton(-text => M"Eintrag anzeigen", 3768 -value => "show", 3769 -variable => \$meta_data_handling, 3770 )->pack(-anchor => "w"); 3771 } 3772 3773 { 3774 my $f = $t->LabFrame(-label => M"Im Anschluss...", 3775 -labelside => "acrosstop"); 3776 Tk::grid($f, -sticky => "ew", -columnspan => $cs); 3777 3778 3779 $f->Checkbutton(-text => M"Dateien editieren", 3780 -variable => \$edit_after, 3781 )->pack(-anchor => "w"); 3782 $f->Checkbutton(-text => M"Sperrungen in BBBike l�schen", 3783 -variable => \$do_delete_blockings, 3784 )->pack(-anchor => "w"); 3785 } 3786 3787 my $get_text = sub { 3788 my $btxt = $real_txt->get("1.0", "end"); 3789 $btxt =~ s/\n\Z//; 3790 $btxt =~ s/\s+/ /gs; 3791 $btxt; 3792 }; 3793 3794 $paste_b->configure 3795 (-command => sub { 3796 $real_txt->delete("1.0","end"); 3797 my($selection) = $real_txt->SelectionGet; 3798 if ($selection =~ /\t/) { 3799 # very probably from choose_ort window 3800 chomp $selection; 3801 my($action, $content, $id) = split /\t/, $selection; 3802 $real_txt->insert("end", $content); 3803 $id =~ s{[^A-Za-z0-9/_.-]}{}g; 3804 $source_id = $id; 3805 } else { 3806 $real_txt->insert("end", $selection); 3807 } 3808 }); 3809 3810 $act_b->configure 3811 (-command => sub { 3812 require BBBikeEditUtil; 3813 my $btxt = $get_text->(); 3814 $real_txt->delete("1.0","end"); 3815 $real_txt->insert("end", $btxt); 3816 my($new_start_time, $new_end_time, $new_prewarn_days) = 3817 BBBikeEditUtil::parse_dates($btxt); 3818 if (defined $new_prewarn_days) { 3819 $prewarn_days = $new_prewarn_days; 3820 } 3821 my @parse_error; 3822 if (defined $new_start_time) { 3823 $start_w->configure(-value => $new_start_time); 3824 } else { 3825 push @parse_error, "Startdatum"; 3826 } 3827 if (defined $new_end_time) { 3828 $end_w->configure (-value => $new_end_time); 3829 } else { 3830 push @parse_error, "Enddatum"; 3831 } 3832 if (@parse_error) { 3833 main::status_message("Kann " . join(" und ", @parse_error) . 3834 " nicht parsen", "warn"); 3835 } 3836 }); 3837 3838 $fmt_b->configure 3839 (-command => sub { 3840 my $btxt = $real_txt->get("1.0", "end"); 3841 $btxt =~ s/^(?:NEW|CHANGED|UNCHANGED|REMOVED)(,\s+\((coords|text)\))?\s*//; 3842 $btxt =~ s/[;,]\s+(?:eine\s+)?umleitung\s+ist\s+(?:ausgeschildert|eingerichtet)//i; 3843 $btxt =~ s/[;,]\s+umleitung\s+ausgeschildert//i; 3844 $btxt =~ s/[;,]\s+umleitung//i; 3845 $btxt =~ s/[;,]\s+hohe\s+staugefahr//i; 3846 $btxt =~ s/\s*\(\d{1,2}:\d{2}\)\s*$//; # seen in vmz records 3847 $real_txt->delete("1.0","end"); 3848 $real_txt->insert("end", $btxt); 3849 }); 3850 3851 Tk::grid($t->Button 3852 (-text => "Ok", 3853 -command => sub { 3854 if (!$as_data) { 3855 if (!defined $file || $file =~ /^\s*$/) { 3856 $t->messageBox(-message => "Dateiname fehlt oder `as data' w�hlen"); 3857 return; 3858 } 3859 if (-d $file) { 3860 $t->messageBox(-message => "Bitte neue bbd-Datei ausw�hlen oder `as data' w�hlen"); 3861 return; 3862 } 3863 if (-e $file) { 3864 my $ans = $t->messageBox(-type => "YesNo", -icon => "question", -message => "Soll die existierende Datei `$file' �berschrieben werden?"); 3865 if ($ans !~ /yes/i) { 3866 return; 3867 } 3868 } 3869 } 3870 my $blocking_text = $get_text->(); 3871 $blocking_text =~ s/\'/\\\'/g; # mask for perl sq string 3872 if ($blocking_text eq '') { 3873 $t->messageBox(-message => "Beschreibender Text fehlt"); 3874 return; 3875 } 3876 if ($blocking_text =~ m{[^\x00-\xff]}) { 3877 my $ans = $t->messageBox(-type => 'OkCancel', -icon => 'question', -message => "Unicode-Zeichen oberhalb des Codespoints 255 enthalten. Diese Zeichen k�nnen zurzeit nicht verwendet werden. Automatisch konvertieren? Achtung: Informationsverlust kann auftreten!"); 3878 if ($ans !~ /ok/i) { 3879 return; 3880 } 3881 if (eval { require Text::Unidecode; 1 }) { 3882 $blocking_text = unidecode_any($blocking_text, "iso-8859-1"); 3883 } 3884 } 3885 my $start_time = $start_undef ? undef : $start_w->get; 3886 my $end_time = $end_undef ? undef : $end_w->get; 3887 if ((!$start_undef && !defined $start_time) || 3888 (!$end_undef && !defined $end_time)) { 3889 $t->messageBox(-message => "Bitte Start/Endzeit eintragen oder `undef' w�hlen"); 3890 return; 3891 } 3892 if ($start_time) { 3893 $start_time -= $prewarn_days * 86400; 3894 } 3895 3896 if ($as_data) { 3897 require File::Temp; 3898 (my($fh), $file) = File::Temp::tempfile(SUFFIX => ".bbd", 3899 UNLINK => 1); 3900 } 3901 3902 main::save_user_dels($file, 3903 -type => $blocking_type, 3904 ($is_in_work ? (-addinfo => "inwork") : (-addinfo => "temp")), 3905 ); 3906 if ($auto_cross_road_blockings) { 3907 my $add_userdels = add_cross_road_blockings(); 3908 if ($add_userdels) { 3909 $add_userdels->append($file); 3910 } 3911 } 3912 3913 my $rel_file = $file; 3914 if (index($rel_file, $initialdir) != 0) { 3915 $rel_file = File::Spec->abs2rel($rel_file); # XXX base needed? 3916 } else { 3917 3918 $rel_file = File::Basename::basename($rel_file); # XXX handle deeper hiearchies? 3919 } 3920 3921 File::Copy::copy($pl_file, "$pl_file~"); 3922 my @old_contents; 3923 open(PL_FILE, $pl_file) 3924 or main::status_message("Can't open $pl_file: $!", "die"); 3925 @old_contents = <PL_FILE>; 3926 close PL_FILE; 3927 3928 my $blocking_type2 = $blocking_type; 3929 if ($blocking_type =~ /^handicap/) { 3930 $blocking_type = "handicap"; 3931 } elsif ($blocking_type eq 'oneway') { 3932 $blocking_type = "gesperrt"; 3933 } elsif ($blocking_type ne "gesperrt") { 3934 main::status_message("Unknown blocking type <$blocking_type>", "info"); 3935 } 3936 $start_time = "undef" if $start_undef; 3937 $end_time = "undef" if $end_undef; 3938 my $pl_entry = <<EOF; 3939 { from => $start_time, # @{[ $start_undef ? "" : POSIX::strftime("%Y-%m-%d %H:%M", localtime $start_time) ]} 3940 until => $end_time, # @{[ $end_undef ? "XXX" : POSIX::strftime("%Y-%m-%d %H:%M", localtime $end_time) ]} 3941 text => '$blocking_text', 3942 type => '$blocking_type', 3943EOF 3944 if (defined $source_id && $source_id !~ /^\s*$/) { 3945 $pl_entry .= <<EOF; 3946 source_id => '$source_id', 3947EOF 3948 } 3949 if ($meta_data_handling eq 'replace_preserve_data') { 3950 $pl_entry .= "###PRESERVE DATA\n"; 3951 } else { 3952 if ($as_data) { 3953 my $s = Strassen->new($file); 3954 if ($s->count == 0) { 3955 if ($meta_data_handling eq '' || 3956 $meta_data_handling eq 'show') { 3957 # don't warn if it's only written to STDERR or Tk widget 3958 } else { 3959 $t->messageBox(-message => "Keine Blockierungen ausgew�hlt"); 3960 return; 3961 } 3962 } 3963 $pl_entry .= " data => <<EOF,\n" . $s->as_string . "EOF\n"; 3964 } else { 3965 $pl_entry .= <<EOF; 3966 file => '$rel_file', 3967EOF 3968 } 3969 } 3970 $pl_entry .= <<EOF; 3971 }, 3972EOF 3973 3974 if ($meta_data_handling eq 'show') { 3975 my $t = $main::top->Toplevel; 3976 my $txt = $t->Scrolled('ROText')->pack(qw(-fill both -expand 1)); 3977 $txt->insert('end', $pl_entry); 3978 return; 3979 } 3980 3981 if ($old_contents[-1] =~ m{^\s*\);\s*$}) { 3982 splice @old_contents, -1, 0, $pl_entry; 3983 if ($meta_data_handling eq 'append') { 3984 ask_for_co($t, $pl_file); 3985 open(PL_OUT, "> $pl_file") 3986 or main::status_message("Kann auf $pl_file nicht schreiben: $!", "die"); 3987 binmode PL_OUT; 3988 print PL_OUT join "", @old_contents; 3989 close PL_OUT; 3990 } elsif ($meta_data_handling eq 'replace' || 3991 $meta_data_handling eq 'replace_preserve_data') { 3992 my $ret = temp_blockings_editor_replace 3993 (-string => $pl_entry, 3994 -text => $blocking_text, 3995 -preserve_data => $meta_data_handling eq 'replace_preserve_data', 3996 -source_id => $source_id, 3997 ); 3998 if (!$ret) { 3999 return; 4000 } 4001 } else { 4002 print STDERR join "", @old_contents; 4003 } 4004 } else { 4005 main::status_message("Can't parse old contents in file <$pl_file>", "err"); 4006 return; 4007 } 4008 4009 if ($do_delete_blockings) { 4010 main::delete_user_dels(-force => 1); 4011 } 4012 4013 if (Tk::Exists($t)) { 4014 $t->destroy; 4015 } 4016 4017 my $check_cmd = "$FindBin::RealBin/miscsrc/check_bbbike_temp_blockings"; 4018 if (eval { require Tk::ExecuteCommand; 1 }) { 4019 $main::top->update; 4020 my $check_tl = $main::top->Toplevel(-title => "check_bbbike_temp_blockings problems"); 4021 $check_tl->withdraw; 4022 my $exec = $check_tl->ExecuteCommand (-command => $check_cmd)->pack(qw(-fill both -expand 1)); 4023 $exec->terse_gui; 4024 $exec->execute_command; 4025 my($stat,$err) = $exec->get_status; 4026 if ($stat != 0) { 4027 $check_tl->deiconify; 4028 $check_tl->raise; 4029 } else { 4030 $check_tl->destroy; 4031 } 4032 4033 } else { 4034 my $err = `$check_cmd`; 4035 if ($? != 0) { 4036 my $t = $main::top->Toplevel(-title => "check_bbbike_temp_blockings problems"); 4037 my $txt = $t->Scrolled("ROText")->pack(-fill => "both", 4038 -expand => 1); 4039 $txt->insert("end", $err); 4040 $txt->insert("end", "\nBitte auch STDERR beachten!"); 4041 } 4042 } 4043 4044 # Im Anschluss... 4045 if ($edit_after) { 4046 if (fork == 0) { 4047 exec("emacsclient", "-n", $pl_file); 4048 CORE::exit(1); 4049 } 4050 if (!$as_data) { 4051 if (fork == 0) { 4052 exec("emacsclient", "-n", $file); 4053 CORE::exit(1); 4054 } 4055 } 4056 } 4057 }), 4058 $t->Button 4059 (-text => M"Abbruch", 4060 -command => sub { 4061 $t->destroy; 4062 }), 4063 -sticky => "ew", 4064 ); 4065 4066warn "XXX 13"; 4067 $pe->idletasks; # to fill the variable 4068warn "XXX 14"; 4069 $pe->xview(1);#XXX does not work??? 4070warn "XXX 15"; 4071} 4072 4073sub temp_blockings_editor_preserve_data { 4074 my($new, $old) = @_; 4075 my $data_or_file = ""; 4076 my $stage = ''; 4077 for my $line (split /\n/, $old) { 4078 if ($stage eq '') { 4079 if ($line =~ /^\s*data/) { 4080 $stage = 'in_data'; 4081 $data_or_file .= $line . "\n"; 4082 } elsif ($line =~ /^\s*file/) { 4083 # no stage change, just one line 4084 $data_or_file .= $line . "\n"; 4085 } 4086 } elsif ($stage eq 'in_data') { 4087 $data_or_file .= $line . "\n"; 4088 if ($line =~ /^EOF/) { 4089 $stage = ''; 4090 } 4091 } 4092 } 4093 if ($new !~ s/^###PRESERVE DATA\n/$data_or_file/m) { 4094 warn "Can't find PRESERVE DATA tag in <$new>"; 4095 main::status_message("Can't find PRESERVE DATA tag!", "die"); 4096 } 4097 $new; 4098} 4099 4100sub temp_blockings_editor_replace { 4101 my(%args) = @_; 4102 my $ret = 0; 4103 my $new_string = $args{-string}; 4104 my $new_text = $args{-text}; 4105 my $preserve_data = $args{-preserve_data}; 4106 my $source_id = $args{-source_id}; 4107 if (!eval { require String::Similarity; 1 }) { 4108 main::status_message($@, "die"); 4109 } 4110 use vars qw(@temp_blocking); 4111 my $pl_file = $BBBike::check_bbbike_temp_blockings::temp_blockings_pl; 4112 do $pl_file; 4113 if (!@temp_blocking) { 4114 main::status_message("Keine Eintr�ge in <$pl_file> gefunden", "die"); 4115 } 4116 4117 my $max_index; 4118 my $max_similarity; 4119 my $found_through_source_id; 4120 # First find exactly matching records through source_id 4121 if (defined $source_id && $source_id !~ /^\s*$/) { 4122 for(my $index = $#temp_blocking; $index >= 0; $index--) { 4123 my $record = $temp_blocking[$index]; 4124 if (defined $record->{source_id} && 4125 $record->{source_id} eq $source_id) { 4126 $found_through_source_id = 1; 4127 $max_index = $index; 4128 last; 4129 } 4130 } 4131 } 4132 4133 if (!defined $max_index) { 4134 # Nothing found? Then try the best similar record. 4135 for my $index (0 .. $#temp_blocking) { 4136 my $record = $temp_blocking[$index]; 4137 my $similarity = String::Similarity::similarity(lc $record->{text}, lc $new_text); 4138 if (!defined $max_similarity || $similarity > $max_similarity) { 4139 $max_index = $index; 4140 $max_similarity = $similarity; 4141 } 4142 } 4143 if ($max_similarity == 0) { 4144 main::status_message("Keinen �hnlichen Eintrag gefunden", "info"); 4145 return $ret; 4146 } 4147 } 4148 4149 open(PL_IN, "< $pl_file") 4150 or main::status_message("Kann $pl_file nicht lesen: $!", "die"); 4151 my $stage = "pre"; 4152 my %s; 4153 my $record_count = -1; 4154 while(<PL_IN>) { 4155 if (/^\s*\{/) { 4156 $record_count++; 4157 if ($record_count == $max_index) { 4158 $stage = "inner"; 4159 } 4160 } elsif (/^\s*\}/) { 4161 $s{$stage} .= $_; 4162 if ($record_count == $max_index) { 4163 $stage = "post"; 4164 } 4165 next; 4166 } 4167 $s{$stage} .= $_; 4168 } 4169 close PL_IN; 4170 4171 if ($preserve_data) { 4172 $new_string = temp_blockings_editor_preserve_data($new_string, $s{inner}); 4173 } 4174 4175 my $yesno; 4176 { 4177 require Tk::DialogBox; 4178 my $d = $main::top->DialogBox 4179 (-title => M"Ersetzen", 4180 -buttons => [M"Ja", M"Manuell w�hlen", M"Nein"], 4181 ); 4182 $d->add("Label", -text => "Replace the following record:")->pack(-fill => "x"); 4183 my $t1 = $d->add("Scrolled", "ROText", -width => 50, -height => 10, 4184 -scrollbars => "osoe")->pack(-fill => "x"); 4185 $d->add("Label", -text => "with:")->pack(-fill => "x"); 4186 my $t2 = $d->add("Scrolled", "ROText", -width => 50, -height => 10, 4187 -scrollbars => "osoe")->pack(-fill => "x"); 4188 my $info_label = "? (index = $max_index, "; 4189 if ($found_through_source_id) { 4190 $info_label .= "Found through same source id)"; 4191 } else { 4192 $info_label .= "similarity factor = $max_similarity)"; 4193 } 4194 $d->add("Label", -text => $info_label)->pack(-fill => "x"); 4195 4196 if (eval { require Algorithm::Diff; 1 }) { 4197 my @old = split /(\s+)/, $s{"inner"}; 4198 my @new = split /(\s+)/, $new_string; 4199 for ($t1, $t2) { 4200 $_->tagConfigure("delchunk", -foreground => "red"); 4201 $_->tagConfigure("inschunk", -foreground => "green"); 4202 $_->tagConfigure("changechunk", -foreground => "orange"); 4203 } 4204 Algorithm::Diff::traverse_balanced 4205 (\@old, \@new, 4206 { MATCH => sub { 4207 my($old,$new) = @_; 4208 $t1->insert("end", $old[$old]); 4209 $t2->insert("end", $new[$new]); 4210 }, 4211 DISCARD_A => sub { 4212 my($old,undef) = @_; 4213 $t1->insert("end", $old[$old], "delchunk"); 4214 }, 4215 DISCARD_B => sub { 4216 my(undef,$new) = @_; 4217 $t2->insert("end", $new[$new], "inschunk"); 4218 }, 4219 CHANGE => sub { 4220 my($old,$new) = @_; 4221 $t1->insert("end", $old[$old], "changechunk"); 4222 $t2->insert("end", $new[$new], "changechunk"); 4223 }, 4224 } 4225 ); 4226 } else { 4227 $t1->insert("end", $s{"inner"}); 4228 $t2->insert("end", $new_string); 4229 } 4230 4231 $yesno = $d->Show; 4232 } 4233 4234 if ($yesno eq M"Ja") { 4235 ask_for_co($main::top, $pl_file); 4236 open PL_OUT, "> $pl_file" or main::status_message($!, "die"); 4237 binmode PL_OUT; 4238 print PL_OUT $s{pre} . $new_string . $s{post}; 4239 close PL_OUT; 4240 $ret = 1; 4241 } elsif ($yesno eq M"Manuell w�hlen") { 4242 my $t = $main::top->Toplevel(-title => M"Manuell w�hlen"); 4243 $t->transient($main::top) if $main::transient; 4244 require Tk::HList; 4245 my $hl = $t->Scrolled("HList", 4246 -width => 50, 4247 -height => 10, 4248 -selectmode => "single", 4249 )->pack(-fill => "both", 4250 -expand => 1); 4251 open(PL_IN, "< $pl_file") 4252 or main::status_message("Kann $pl_file nicht lesen: $!", "die"); 4253 4254 my $stage = "pre"; 4255 my %s; 4256 my @records; 4257 while(<PL_IN>) { 4258 if (/^\s*\{/) { 4259 push @records, ""; 4260 $stage = "inner"; 4261 } elsif (/^\s*\);/) { 4262 $stage = "post"; 4263 } 4264 if ($stage eq 'inner') { 4265 $records[-1] .= $_; 4266 } else { 4267 $s{$stage} .= $_; 4268 } 4269 } 4270 close PL_IN; 4271 4272 my $rec_i = 0; 4273 for my $rec (@records) { 4274 $hl->add($rec_i, -text => $rec); 4275 $rec_i++; 4276 } 4277 4278 { 4279 my $search_term = ""; 4280 my $search_sub = sub { 4281 search_in_hlist($hl, $search_term, 4282 -nocase => 1, 4283 -match => 'substr'); 4284 }; 4285 my $search_f = $t->Frame->pack(-fill => 'x'); 4286 $search_f->Button(-text => M"Suchen", 4287 -command => $search_sub)->pack(-side => "left"); 4288 my $search_e = $search_f->Entry(-textvariable => \$search_term)->pack(-side => "left", -fill => 'x'); 4289 $search_e->bind("<Return>" => $search_sub); 4290 } 4291 4292 my $weiter; 4293 { 4294 my $f = $t->Frame->pack(-fill => "x"); 4295 Tk::grid($f->Button(Name => "ok", 4296 -command => sub { 4297 $weiter = +1; 4298 }, 4299 ), 4300 $f->Button(Name => "cancel", 4301 -command => sub { 4302 $weiter = -1; 4303 } 4304 ), 4305 ); 4306 } 4307 4308 4309 TRYAGAIN: 4310 $t->OnDestroy(sub { $weiter = -1 }); 4311 $t->waitVariable(\$weiter); 4312 4313 if ($weiter == 1) { 4314 my($sel) = $hl->selectionGet; 4315 if (!defined $sel) { 4316 goto TRYAGAIN; 4317 } 4318 4319 ask_for_co($t, $pl_file); 4320 open PL_OUT, "> $pl_file" or main::status_message($!, "die"); 4321 binmode PL_OUT; 4322 print PL_OUT $s{pre}; 4323 if ($sel > 0) { 4324 print PL_OUT join("", @records[0 .. $sel-1]); 4325 } 4326 print PL_OUT $new_string; 4327 if ($sel+1 <= $#records) { 4328 print PL_OUT join("", @records[$sel+1 .. $#records]); 4329 } 4330 print PL_OUT $s{post}; 4331 close PL_OUT; 4332 4333 $ret = 1; 4334 } else { 4335 # do nothing 4336 } 4337 4338 $t->destroy if Tk::Exists($t); 4339 4340 } else { 4341 # do nothing 4342 } 4343 4344 $ret; 4345} 4346 4347sub search_in_hlist { 4348 my($hl, $search_term, %args) = @_; 4349 my $begin_at = $args{-beginat} || 'anchor'; 4350 my $match_type = $args{-match} || 'exact'; 4351 my $no_case = $args{-nocase}; 4352 4353 if ($no_case) { 4354 $search_term = lc $search_term; 4355 } 4356 4357 my $curr_entry; 4358 if ($begin_at eq 'anchor') { 4359 $curr_entry = $hl->info('anchor'); 4360 if (!defined $curr_entry || $curr_entry eq '') { 4361 $curr_entry = ($hl->info('children'))[0]; 4362 } 4363 } else { 4364 $curr_entry = $hl->info($begin_at); 4365 } 4366 if (!defined $curr_entry || $curr_entry eq '') { 4367 return; 4368 } 4369 4370 my $wrapped = 0; 4371 my $no_next = 0; 4372 while (1) { 4373 while(1) { 4374 if (!$no_next) { 4375 $curr_entry = $hl->info('next', $curr_entry); 4376 } else { 4377 $no_next = 0; 4378 } 4379 last if !defined $curr_entry || $curr_entry eq ''; # at bottom 4380 for my $col_i (0 .. $hl->cget(-columns) - 1) { 4381 my $text = $hl->itemCget($curr_entry, $col_i, '-text'); 4382 $text = lc $text if $no_case; 4383 4384 my $found = sub { 4385 $hl->anchorSet($curr_entry); 4386 $hl->see($curr_entry); 4387 return $curr_entry; 4388 }; 4389 4390 if ($match_type eq 'exact') { 4391 if ($text eq $search_term) { 4392 return $found->(); 4393 } 4394 } elsif ($match_type =~ /^substr/) { 4395 if (index($text, $search_term) > -1) { 4396 return $found->(); 4397 } 4398 } elsif ($match_type =~ /^regex/) { 4399 if ($text =~ /$search_term/) { 4400 return $found->(); 4401 } 4402 } 4403 } 4404 } 4405 if ($wrapped) { 4406 return; 4407 } else { 4408 $wrapped = 1; 4409 $no_next = 1; 4410 $curr_entry = ($hl->info('children'))[0]; 4411 } 4412 } 4413} 4414 4415sub add_cross_road_blockings { 4416 # Do not reuse $main::net, because there are already the deletions stored! 4417 require Strassen::Core; 4418 require Strassen::StrassenNetz; 4419 my $str = Strassen->new("strassen"); 4420 my $str_net = StrassenNetz->new($str); 4421 $str_net->make_net; 4422 # XXX use del_token? 4423 my $dels_str = $main::net->create_user_deletions_object; 4424 my $dels_net = StrassenNetz->new($dels_str); 4425 $dels_net->make_net; 4426 my $str_net_Net = $str_net->{Net}; 4427 my $dels_net_Net = $dels_net->{Net}; 4428 $dels_str->init; 4429 my %cross_road_blockings; 4430 my %seen; 4431 while(1) { 4432 my $r = $dels_str->next; 4433 last if !@{ $r->[Strassen::COORDS()] }; 4434 for my $p (@{ $r->[Strassen::COORDS()] }) { 4435 next if $seen{$p}; 4436 next if keys %{ $dels_net_Net->{$p} } == 1; # Endpunkt der Sperrung 4437 my %all_neighbors = map {($_,1)} keys %{ $str_net_Net->{$p} }; 4438 for (keys %{ $dels_net_Net->{$p} }) { 4439 delete $all_neighbors{$_}; 4440 } 4441 if (keys %all_neighbors > 1) { 4442 for my $p1 (keys %all_neighbors) { 4443 for my $p2 (keys %all_neighbors) { 4444 next if $p1 eq $p2; 4445 $cross_road_blockings{$p1}{$p}{$p2}++; 4446 } 4447 } 4448 } 4449 $seen{$p}++; 4450 } 4451 } 4452 4453 my $add_userdels = Strassen->new; 4454 while(my($p1,$v) = each %cross_road_blockings) { 4455 while(my($p,$v2) = each %$v) { 4456 while(my($p2) = each %$v2) { 4457 $add_userdels->push(["userdel auto", [$p1, $p, $p2], "3"]); 4458 } 4459 } 4460 } 4461 4462 require Strassen::Combine; 4463 my $add_userdels_combined = $add_userdels->make_long_streets(-ignorecat => ["3"]); 4464 4465 $add_userdels_combined; 4466} 4467 4468{ 4469 my($map, $c, $transpose, $abk, $s); 4470 4471 sub draw_pp_draw_code { 4472 my $r = shift; 4473 for my $p (@{ $r->[Strassen::COORDS()] }) { 4474 my($ox,$oy) = split /,/, $p; 4475 my($prefix) = $ox =~ m/^([^0-9+-]+)/; # stores prefix 4476 $prefix = "" if !defined $prefix; 4477 $ox =~ s/^([^0-9+-]+)//; # removes prefix 4478 my $map = $prefix ? $Karte::map_by_coordsys{$prefix} : $map; 4479 #if (!defined $map) { warn "@$r $p $prefix" } 4480 my($x, $y) = $map->map2standard($ox,$oy); 4481 my($cx,$cy) = $transpose->($x,$y); 4482 $c->createLine($cx,$cy,$cx,$cy, 4483 -tags => ['pp', "$x,$y", 4484 "ORIG:$prefix$ox,$oy", "pp-$abk"], 4485 ); 4486 } 4487 } 4488 4489 sub draw_pp_init_code { 4490 my(undef, $file, %args) = @_; 4491 $c = $main::c; 4492 $transpose = \&main::transpose; 4493 $abk = $args{-abk} || ''; 4494 $c->delete("pp-$abk"); 4495 4496 my @orig_files; 4497 if (ref $file eq "ARRAY") { 4498 @orig_files = map { "$_-orig" } @$file; 4499 $s = MultiStrassen->new(@orig_files); 4500 } else { 4501 @orig_files = $file."-orig"; 4502 $s = Strassen->new(@orig_files); 4503 } 4504 4505 my $nonorig_s; 4506 if (ref $file eq 'ARRAY') { 4507 $nonorig_s = MultiStrassen->new(@$file); 4508 } else { 4509 $nonorig_s = Strassen->new($file); 4510 } 4511 4512 my $maptoken = $args{-map}; 4513 require Karte; 4514 Karte::preload(":all"); 4515 require BBBikeEditUtil; 4516 $map = $Karte::map{$maptoken}; 4517 my $mapprefix; $mapprefix = $map->coordsys if $map; 4518 for my $f (@orig_files) { 4519 my $baseprefix = { BBBikeEditUtil::base() }->{$f}; 4520 if (defined $mapprefix && $mapprefix ne $baseprefix) { 4521 warn "Ambigous base prefixes ($mapprefix vs $baseprefix)"; 4522 } else { 4523 $mapprefix = $baseprefix; 4524 } 4525 } 4526 $map = $Karte::map_by_coordsys{$mapprefix}; 4527 ($s, $nonorig_s); 4528 } 4529 4530 sub draw_pp_post_draw_code { 4531 $c->itemconfigure('pp', 4532 -capstyle => $main::capstyle_round, 4533 -width => 5, 4534 ); 4535 main::pp_color(); 4536 } 4537} 4538 4539sub draw_pp { 4540 my($s) = draw_pp_init_code(@_); 4541 my $top = $main::top; 4542 main::IncBusy($top); 4543 eval { 4544 $s->init; 4545 while(1) { 4546 my $r = $s->next; 4547 last if !@{ $r->[Strassen::COORDS()] }; 4548 draw_pp_draw_code($r); 4549 } 4550 draw_pp_post_draw_code(); 4551 }; 4552 my $err = $@; 4553 main::DecBusy($top); 4554 main::status_message($err, "die") if $err; 4555} 4556 4557sub move_marks_by_delta { 4558 my @coords = @main::coords; 4559 my $c = $main::c; 4560 4561 if (@coords != 2) { 4562 main::status_message(M"Genau zwei Koordinaten erwartet!", "error"); 4563 return; 4564 } 4565 my $dx = $coords[1]->[0] - $coords[0]->[0]; 4566 my $dy = $coords[1]->[1] - $coords[0]->[1]; 4567 MARKITEMS: 4568 for my $i ($c->find("withtag" => "show")) { 4569 my @t = $c->gettags($i); 4570 for (@t) { 4571 next MARKITEMS if ($_ eq 'show_adjusted'); 4572 } 4573 $c->move($i, $dx, $dy); 4574 $c->addtag("show_adjusted", withtag => $i); 4575 } 4576} 4577 4578sub reset_mark_adjusted_tag { 4579 my $c = $main::c; 4580 $c->dtag("show_adjusted"); 4581} 4582 4583# REPO BEGIN 4584# REPO NAME unidecode_any /home/e/eserte/work/srezic-repository 4585# REPO MD5 59f056efd990dc126e49f5e846eee797 4586 4587=head2 unidecode_any($text, $encoding) 4588 4589Similar to Text::Unidecode::unidecode, but convert to the given 4590$encoding. This will return an octet string in the given I<$encoding>. 4591If all you want is just to restrict the charset of the string to a 4592specific encoding charset, then it's best to C<Encode::decode> the 4593result again with I<$encoding>. 4594 4595=cut 4596 4597sub unidecode_any { 4598 my($text, $encoding) = @_; 4599 4600 require Text::Unidecode; 4601 require Encode; 4602 4603 # provide better conversions for german umlauts 4604 my %override = ("\xc4" => "Ae", 4605 "\xd6" => "Oe", 4606 "\xdc" => "Ue", 4607 "\xe4" => "ae", 4608 "\xf6" => "oe", 4609 "\xfc" => "ue", 4610 ); 4611 my $override_rx = "(" . join("|", map { quotemeta } keys %override) . ")"; 4612 $override_rx = qr{$override_rx}; 4613 4614 my $res = ""; 4615 4616 if (!eval { 4617 Encode->VERSION(2.12); # need v2.12 to support coderef 4618 $res = Encode::encode($encoding, $text, 4619 sub { 4620 my $ch = chr $_[0]; 4621 if ($ch =~ $override_rx) { 4622 return $override{$ch}; 4623 } else { 4624 my $ascii = unidecode($ch); 4625 Encode::_utf8_off($ascii); 4626 $ascii; 4627 } 4628 }); 4629 1; 4630 }) { 4631 for (split //, $text) { 4632 my $conv = eval { Encode::encode($encoding, $_, Encode::FB_CROAK()) }; 4633 if ($@) { 4634 $res .= Text::Unidecode::unidecode($_); 4635 } else { 4636 $res .= $conv; 4637 } 4638 } 4639 } 4640 4641 $res; 4642} 4643# REPO END 4644 4645 46461; 4647