1# -*- perl -*- 2 3# 4# Copyright (c) 1995-2003,2012 Slaven Rezic. All rights reserved. 5# This is free software; you can redistribute it and/or modify it under the 6# terms of the GNU General Public License, see the file COPYING. 7# 8# Mail: slaven@rezic.de 9# WWW: http://bbbike.sourceforge.net 10# 11 12package Strassen::StrassenNetzHeavy; 13 14package StrassenNetz; 15use Strassen::StrassenNetz; 16use strict; 17use vars @StrassenNetz::EXPORT_OK; 18 19### AutoLoad Sub 20sub new_from_server { 21 my $class = shift; 22 my $server_name = shift || 'bbb'; 23 # nachgucken, ob vielleicht str_server.pl l�uft 24 25 my $net; 26 27 my $try_sharelite = sub { 28 require IPC::ShareLite; 29 local $SIG{__DIE__}; 30 require Storable; 31 my %options = ( 32 -key => '1211', # XXX get from var 33 -create => 'no', 34 -exclusive => 'no', 35 -destroy => 'no', 36 ); 37 my $share = IPC::ShareLite->new(%options) or die $!; 38 warn "Shared memory anzapfen...\n" if ($VERBOSE); 39 $net = Storable::thaw($share->fetch); 40 use_data_format($FMT_HASH) if $net; 41 }; 42 43 my $try_shareable = sub { 44 require IPC::Shareable; 45 IPC::Shareable->VERSION(0.60); # no more no/yes 46 my %options = ( 47 'key' => 'paint', 48 'create' => 0, 49 'exclusive' => 0, 50 'mode' => 0644, 51 'destroy' => 0, 52 ); 53 warn "Shared memory anzapfen...\n" if ($VERBOSE); 54 tie $net, 'IPC::Shareable', $server_name, \%options; 55 #tie $net->{Net}, 'IPC::Shareable', $server_name."1", \%options; 56 #tie $net->{Net2Name}, 'IPC::Shareable', $server_name."2", \%options; 57 use_data_format($FMT_HASH) if $net; 58 }; 59 60 eval { $try_sharelite->() }; 61 warn $@ if !$net && $VERBOSE; 62 return $net if $net; 63 64 eval { $try_shareable->() }; 65 warn $@ if !$net && $VERBOSE; 66 return $net if $net; 67 68 undef; 69} 70 71### AutoLoad Sub 72sub statistics { 73 my $self = shift; 74 my $msg = ''; 75 if ($self->{Strassen}) { 76 $msg .= "Anzahl der Stra�en: " . $self->{Strassen}->count . "\n"; 77 } 78 79 if ($self->{Net2Name}) { 80 my $count = 0; 81 while(my($k,$v) = each %{$self->{Net2Name}}) { 82 $count += scalar keys %$v; 83 } 84 $msg .= "Anzahl der Kanten: " . $count . "\n"; 85 86 my $nodes = scalar keys %{$self->{Net2Name}}; 87 $msg .= "Anzahl der Knoten: " . $nodes . "\n"; 88 89 if ($nodes) { 90 $msg .= "node branching factor: " . 91 sprintf("%.1f", $count/$nodes) . "\n"; 92 } 93 } 94 95 $msg .= "Sourcen: " . join(", ", $self->sourcefiles) . "\n"; 96 $msg .= "Abh�ngige Dateien: " . join(", ", $self->dependent_files) . "\n"; 97 $msg .= "Id: " . $self->id . "\n"; 98 99 $msg; 100} 101 102# Erzeugt ein Netz, deren Kanten nur von Kreuzung zu Kreuzung gehen. 103# Dieses Netz wird als StrassenNetz-Objekt in WideNet abgelegt. 104# Zus�tzlich enth�lt es eine Struktur WideNeighbors, dass f�r Nicht-Kreuzungs- 105# Knoten die n�chsten Kreuzungs-Knoten anzeigt: 106# Node => [Neighbor1, Distance1, Neighbor2, Distance2] 107### AutoLoad Sub 108sub make_wide_net { 109 my $orig_net_obj = shift; 110 my $orig_net = $orig_net_obj->{Net}; 111 112 my $new_net_obj = StrassenNetz->new($orig_net_obj->{Strassen}); 113 $orig_net_obj->{WideNet} = $new_net_obj; 114 my $new_net = $new_net_obj->{Net} = {}; 115 my $wide_neighbors = $new_net_obj->{WideNeighbors} = {}; 116 my $intermediates_hash = $new_net_obj->{Intermediates} = {}; 117 118#XXX was ist, wenn $new_new->{$node}{$last_node} schon existiert? => 119# Distanzvergleich machen! 120# Attribut�nderungen beachten! 121 while(my($node,$neighbors) = each %{ $orig_net }) { 122 next if keys %$neighbors == 2; 123 for my $neighbor (keys %$neighbors) { 124 my(%seen_node) = ($node => 1, 125 $neighbor => 1); 126 my $last_node = $neighbor; 127 my $distance = Strassen::Util::strecke_s($node, $last_node); 128 my @intermediates; 129 while (1) { 130 my @neighbor_neighbors = keys %{ $orig_net->{$last_node} }; 131 if (scalar @neighbor_neighbors != 2) { 132 # end node or crossing node 133 # int is sufficient, as we are dealing with meters 134# XXX $node == $last_node? 135if ($node eq $last_node) {warn "$node == $last_node\n";} 136 $new_net->{$node}{$last_node} = int($distance); 137 if (@intermediates) { 138 $intermediates_hash->{$node}{$last_node} = 139 [ map { $_->[0] } @intermediates ]; 140 foreach my $intermediate_def (@intermediates) { 141 my($intermediate, $node_dist) = @$intermediate_def; 142 $wide_neighbors->{$intermediate} = 143 [$node => $node_dist, 144 $last_node => int($distance)-$node_dist]; 145 } 146 } 147 last; 148 } else { 149 push @intermediates, [$last_node, int($distance)]; 150 my $next_node = $neighbor_neighbors[0]; 151 if ($seen_node{$next_node}) { 152 $next_node = $neighbor_neighbors[1]; 153 if ($seen_node{$next_node}) { 154 die "Should not happen: $next_node already seen"; 155 } 156 } 157 $seen_node{$next_node}++; 158 $distance += Strassen::Util::strecke_s($last_node, 159 $next_node); 160 $last_node = $next_node; 161 } 162 } 163 } 164 } 165} 166 167# Create net with the category as value (instead of distance between nodes). 168# If -obeydir is true, then make a distinction between both directions. 169# If -net2name is true, then create Net2Name member. 170# If -multiple is true, then allow multiple values per street connection. 171# In this case values are always array references. 172# Turn caching on/off with -usecache. If -usecache is not specified, the 173# global value from $Strassen::Util::cacheable is used. 174# If -onewayhack is true, then handle some directed categories (1, 1s, 3) 175# specifically. 176### AutoLoad Sub 177sub make_net_cat { 178 my($self, %args) = @_; 179 my $obey_dir = $args{-obeydir} || 0; 180 my $do_net2name = $args{-net2name} || 0; 181 my $multiple = $args{-multiple} || 0; 182 my $onewayhack = $args{-onewayhack} || 0; 183 my $cacheable = defined $args{-usecache} ? $args{-usecache} : $Strassen::Util::cacheable; 184 my $args2filename = join("_", $obey_dir, $do_net2name, $multiple); 185 186 my $cachefile; 187 if ($cacheable) { 188 #XXXmy @src = $self->sourcefiles; 189 my @src = $self->dependent_files; 190 if (!@src || grep { !defined $_ } @src) { 191 warn "Not cacheable..." if $VERBOSE; 192 $cacheable = 0; 193 } else { 194 $cachefile = $self->get_cachefile; 195 my $net2name = Strassen::Util::get_from_cache("net2name_" . $args2filename . "_$cachefile", \@src); 196 my $net = Strassen::Util::get_from_cache("net_" . $args2filename . "_$cachefile", \@src); 197 if (defined $net2name && defined $net) { 198 $self->{Net2Name} = $net2name; 199 $self->{Net} = $net; 200 warn "Using cache for $cachefile\n" if $VERBOSE; 201 return; 202 } 203 } 204 } 205 $self->{Net} = {}; 206 $self->{Net2Name} = {}; 207 my $net = $self->{Net}; 208 my $net2name = $self->{Net2Name}; 209 my $strassen = $self->{Strassen}; 210 $strassen->init; 211 local $^W = 0; 212 while(1) { 213 my $ret = $strassen->next; 214 my @kreuzungen = @{$ret->[Strassen::COORDS()]}; 215 last if @kreuzungen == 0; 216 my($cat_hin, $cat_rueck); 217 # seperate forw/back direction and strip addinfo part (new/old style) 218 if ($ret->[Strassen::CAT()] =~ /^(.*?)(?:::?.*)?;(.*?)(?:::?.*)?$/) { 219 ($cat_hin, $cat_rueck) = ($1, $2); 220 } else { 221 ($cat_hin) = ($cat_rueck) = $ret->[Strassen::CAT()] =~ /^(.*?)(?:::?.*)?$/; 222 if ($onewayhack && $cat_hin =~ m{^(1|1s|3)$}) { # this are the directed categories 223 $cat_rueck = ""; 224 } 225 } 226 my $strassen_pos = $strassen->pos; 227 my $i; 228 for($i = 0; $i < $#kreuzungen; $i++) { 229 if ($cat_hin ne "") { 230 if ($multiple) { 231 push @{$net->{$kreuzungen[$i]}{$kreuzungen[$i+1]}}, $cat_hin; 232 } else { 233 $net->{$kreuzungen[$i]}{$kreuzungen[$i+1]} = $cat_hin; 234 } 235 } 236 if (!$obey_dir && $cat_rueck ne "") { 237 if ($multiple) { 238 push @{$net->{$kreuzungen[$i+1]}{$kreuzungen[$i]}}, $cat_rueck; 239 } else { 240 $net->{$kreuzungen[$i+1]}{$kreuzungen[$i]} = $cat_rueck; 241 } 242 } 243 if ($do_net2name) { 244 if ($cat_hin ne "") { 245 if ($multiple) { 246 push @{$net2name->{$kreuzungen[$i]}{$kreuzungen[$i+1]}}, $strassen_pos; 247 } else { 248 $net2name->{$kreuzungen[$i]}{$kreuzungen[$i+1]} = $strassen_pos; 249 } 250 } 251 if (!$obey_dir && $cat_rueck ne "") { 252 if ($multiple) { 253 push @{$net2name->{$kreuzungen[$i+1]}{$kreuzungen[$i]}}, $strassen_pos; 254 } else { 255 $net2name->{$kreuzungen[$i+1]}{$kreuzungen[$i]} = $strassen_pos; 256 } 257 } 258 } 259 } 260 } 261 262 if ($cacheable) { 263 Strassen::Util::write_cache($net2name, "net2name_" . $args2filename . "_$cachefile", -modifiable => 1); 264 Strassen::Util::write_cache($net, "net_" . $args2filename . "_$cachefile", -modifiable => 1); 265 if ($VERBOSE) { 266 warn "Wrote cache ($cachefile)\n"; 267 } 268 } 269 270} 271 272# Create a special cycle path/street category net 273# Categories created are: 274# H => H, B or HH without cycle path and bus lane 275# H_RW => same with cycle path 276# H_BL => same with bus lane 277# N => NH, N or NN without cycle path and bus lane 278# N_RW => same with cycle path 279# N_BL => same with bus lane 280# %args: may be UseCache => $boolean 281# Note: former versions of this function had a "$type" argument in 282# between, which is not needed and is now removed. 283### AutoLoad Sub 284sub make_net_cyclepath { 285 my($self, $cyclepath, %args) = @_; 286 287 my $cachefile; 288 my $cacheable = defined $args{UseCache} ? $args{UseCache} : $Strassen::Util::cacheable; 289 if ($cacheable) { 290 #XXXmy @src = $self->sourcefiles; 291 my @src = $self->dependent_files; 292 push @src, $cyclepath->dependent_files; 293 $cachefile = $self->get_cachefile; 294 my $net = Strassen::Util::get_from_cache("net_cyclepath_$cachefile", \@src); 295 if (defined $net) { 296 $self->{Net} = $net; 297 if ($VERBOSE) { 298 warn "Using cache for $cachefile\n"; 299 } 300 return; 301 } 302 } 303 304 $self->{Net} = {}; 305 my $net = $self->{Net}; 306 my $strassen = $self->{Strassen}; 307 308 my $cyclepath_net = __PACKAGE__->new($cyclepath); 309 $cyclepath_net->make_net_cat(-obeydir => 1); 310 my $c_net = $cyclepath_net->{Net}; 311 312 # net2name ist (noch) nicht notwendig 313 $strassen->init; 314 while(1) { 315 my $ret = $strassen->next; 316 my @kreuzungen = @{$ret->[Strassen::COORDS()]}; 317 last if @kreuzungen == 0; 318 my $cat = $ret->[Strassen::CAT()]; 319 for my $i (0 .. $#kreuzungen-1) { 320 my $str_cat = ($cat =~ /^(H|HH|B)$/ ? 'H' : 'N'); 321 if (exists $c_net->{$kreuzungen[$i]}{$kreuzungen[$i+1]}) { 322 if ($c_net->{$kreuzungen[$i]}{$kreuzungen[$i+1]} eq 'RW5') { 323 $net->{$kreuzungen[$i]}{$kreuzungen[$i+1]} = $str_cat."_Bus"; 324 } else { 325 $net->{$kreuzungen[$i]}{$kreuzungen[$i+1]} = $str_cat."_RW"; 326 } 327 } else { 328 $net->{$kreuzungen[$i]}{$kreuzungen[$i+1]} = $str_cat; 329 } 330 if (exists $c_net->{$kreuzungen[$i+1]}{$kreuzungen[$i]}) { 331 if ($c_net->{$kreuzungen[$i+1]}{$kreuzungen[$i]} eq 'RW5') { 332 $net->{$kreuzungen[$i+1]}{$kreuzungen[$i]} = $str_cat."_Bus"; 333 } else { 334 $net->{$kreuzungen[$i+1]}{$kreuzungen[$i]} = $str_cat."_RW"; 335 } 336 } else { 337 $net->{$kreuzungen[$i+1]}{$kreuzungen[$i]} = $str_cat; 338 } 339 } 340 } 341 342 if ($cacheable) { 343 Strassen::Util::write_cache($net, "net_cyclepath_$cachefile", -modifiable => 1); 344 if ($VERBOSE) { 345 warn "Wrote cache ($cachefile)\n"; 346 } 347 } 348 349} 350 351# XXX Abspeichern der Wegfuehrung nicht getestet 352### AutoLoad Sub 353sub save_net_mldbm { 354 my($self, $dir) = @_; 355 if (!keys %{$self->{Net}}) { 356 die "Net is empty"; 357 } 358 require MLDBM; 359 MLDBM->import('DB_File', $MLDBM_SERIALIZER); 360 require Fcntl; 361 require File::Basename; 362 363 # XXX use dependent_files? 364 my(@src) = $self->sourcefiles; 365 $dir = $Strassen::Util::cachedir unless $dir; 366 my $file_net = "$dir/net_" . 367 join("_", map { File::Basename::basename($_) } @src); 368 my $file_net2name = "$dir/net2name_" . 369 join("_", map { File::Basename::basename($_) } @src); 370 my $file_wegfuehrung = "$dir/wegfuehrung_" . 371 join("_", map { File::Basename::basename($_) } @src); 372 373 my %mldbm_net; 374 tie %mldbm_net, 'MLDBM', $file_net, &Fcntl::O_CREAT|&Fcntl::O_RDWR, 0640 375 or die $!; 376 while(my($k,$v) = each %{$self->{Net}}) { 377 $mldbm_net{$k} = $v; 378 } 379 untie %mldbm_net; 380 381 my %mldbm_net2name; 382 tie 383 %mldbm_net2name, 'MLDBM', $file_net2name, 384 &Fcntl::O_CREAT|&Fcntl::O_RDWR, 0640 385 or die $!; 386 while(my($k,$v) = each %{$self->{Net2Name}}) { 387 $mldbm_net2name{$k} = $v; 388 } 389 untie %mldbm_net2name; 390 391 my %mldbm_wegfuehrung; 392 tie 393 %mldbm_wegfuehrung, 'MLDBM', $file_wegfuehrung, 394 &Fcntl::O_CREAT|&Fcntl::O_RDWR, 0640 395 or die $!; 396 while(my($k,$v) = each %{$self->{Wegfuehrung}}) { 397 $mldbm_wegfuehrung{$k} = $v; 398 } 399 untie %mldbm_wegfuehrung; 400} 401 402# Ein ernstes Problem ergibt sich bei der Verwendung von MLDBM: 403# Da add_net neue Punkte zum Stra�ennetz hinzuf�gt, wird der "Schrott" 404# dadurch immer gr��er. Von Zeit zu Zeit sollte also mit make_net und 405# save_net_mldbm ein neues, frisches Stra�ennetz erzeugt werden. 406### AutoLoad Sub 407sub load_net_mldbm { 408 my($self, $dir) = @_; 409 require MLDBM; 410 MLDBM->import('DB_File', $MLDBM_SERIALIZER); 411 require Fcntl; 412 require File::Basename; 413 414 # XXX use dependent_files? 415 my(@src) = $self->sourcefiles; 416 $dir = $Strassen::Util::cachedir unless $dir; 417 my $file_net = "$dir/net_" . 418 join("_", map { File::Basename::basename($_) } @src); 419 my $file_net2name = "$dir/net2name_" . 420 join("_", map { File::Basename::basename($_) } @src); 421 my $file_wegfuehrung = "$dir/wegfuehrung_" . 422 join("_", map { File::Basename::basename($_) } @src); 423 424 my %mldbm_net; 425 tie %mldbm_net, 'MLDBM', $file_net, &Fcntl::O_RDWR, 0640 426 or die "Can't open $file_net: $!"; 427 $self->{Net} = \%mldbm_net; 428 429 my %mldbm_net2name; 430 tie 431 %mldbm_net2name, 'MLDBM', $file_net2name, &Fcntl::O_RDWR, 0640 432 or die "Can't open $file_net2name: $!"; 433 $self->{Net2Name} = \%mldbm_net2name; 434 435 my %mldbm_wegfuehrung; 436 tie 437 %mldbm_wegfuehrung, 'MLDBM', $file_wegfuehrung, &Fcntl::O_RDWR, 0640 438 or die "Can't open $file_wegfuehrung: $!"; 439 $self->{Wegfuehrung} = \%mldbm_wegfuehrung; 440 441 $self->{UseMLDBM} = 1; 442} 443 444### AutoLoad Sub 445sub wide_search { 446 my($self, $search_sub, $self2, $from, $to) = @_; 447 448 if (!$self->{WideNet}) { 449 warn "Make wide net...\n"; 450 $self->make_wide_net; 451 } 452 453 my $wide_net = $self->{WideNet}{Net}; 454 for my $node ($from, $to) { 455 if (!exists $wide_net->{$node}) { 456 my $neighbor_def = $self->{WideNet}{WideNeighbors}{$node}; 457 if (!defined $neighbor_def) { 458 die "Can't find neighbors for node $node"; 459 } 460 # XXX r�ckw�rts??? (Einbahnstra�en) 461 $wide_net->{$node}{$neighbor_def->[WIDE_NEIGHBOR1]} = $neighbor_def->[WIDE_DISTANCE1]; 462 $wide_net->{$node}{$neighbor_def->[WIDE_NEIGHBOR2]} = $neighbor_def->[WIDE_DISTANCE2]; 463 $wide_net->{$neighbor_def->[WIDE_NEIGHBOR1]}{$node} = $neighbor_def->[WIDE_DISTANCE1]; 464 $wide_net->{$neighbor_def->[WIDE_NEIGHBOR2]}{$node} = $neighbor_def->[WIDE_DISTANCE2]; 465 } 466 } 467 468 $search_sub->($self->{WideNet}, $from, $to); 469} 470 471# Expandiert das Ergebnis einer Suche in WideNet 472### AutoLoad Sub 473sub expand_wide_path { 474 my($self, $pathref) = @_; 475 return [] if (@$pathref == 0); # keep it empty 476 477 my @new_path; 478 my $net = $self->{Net}; 479 my $widenet = $self->{WideNet}->{Net}; 480 my $intermediates_hash = $self->{WideNet}->{Intermediates}; 481 for(my $i = 0; $i<$#$pathref; $i++) { 482 my $from = join(",",@{$pathref->[$i]}); 483 my $to = join(",",@{$pathref->[$i+1]}); 484 push @new_path, $pathref->[$i]; 485 if (!exists $net->{$from}{$to}) { 486 my @intermediates; 487 if (exists $intermediates_hash->{$from}{$to}) { 488 @intermediates = @{ $intermediates_hash->{$from}{$to} }; 489 } elsif (exists $intermediates_hash->{$to}{$from}) { 490 warn "Fallback to reverse intermediates $to => $from"; 491 @intermediates = @{ $intermediates_hash->{$to}{$from} }; 492 } else { 493 warn "Can't find intermediates between $from and $to"; 494 next; 495 } 496 foreach my $node (@intermediates) { 497 push @new_path, [split /,/, $node]; 498 } 499 } 500 } 501 push @new_path, $pathref->[-1]; 502 \@new_path; 503} 504 505# Bei einer Speicherung als MLDBM mu� der in der Manpage beschriebene 506# Bug umgangen werden. Diese Funktion funktioniert f�r 507# zweistufige Hashes 508sub store_to_hash { 509 my($self, $mldbm_hash, $key1, $key2, $val) = @_; 510 if ($self->{UseMLDBM}) { 511 my $tmp = $mldbm_hash->{$key1}; 512 $tmp->{$key2} = $val; 513 $mldbm_hash->{$key1} = $tmp; 514 } else { 515 $mldbm_hash->{$key1}{$key2} = $val; 516 } 517} 518 519### AutoLoad Sub 520sub add_faehre { 521 my($self, $faehre_file, %args) = @_; 522 require Strassen::Core; 523 my $faehre_obj = new Strassen $faehre_file; 524 $faehre_obj->init; 525 while(1) { 526 my $ret = $faehre_obj->next; 527 last if !@{$ret->[Strassen::COORDS()]}; 528 my @kreuzungen = @{$ret->[Strassen::COORDS()]}; 529 my $i; 530 # XXX record to make deletion possible 531 for($i = 1; $i<=$#kreuzungen; $i++) { 532 $self->{Net}{$kreuzungen[$i-1]}{$kreuzungen[$i]} = 0; 533 $self->{Net}{$kreuzungen[$i]}{$kreuzungen[$i-1]} = 0; 534 $self->{Net2Name}{$kreuzungen[$i-1]}{$kreuzungen[$i]} = 535 "F�hre " . $ret->[Strassen::NAME()]; 536 } 537 } 538} 539 540# Self: 541# (Multi)Strassen-Objekt der Linien 542# Argument: 543# (Multi)Strassen-Objekt der Bahnh�fe 544# optional: -addmap (Mapping der Umsteigebahnh�fe) 545# -addmapfile (Datei mit Mapping) 546# -cb (Callback which will be called for each added line. 547# Callback args are: $self, $coords1, $coords2, $entf, 548# $name_of_link_point 549# The callback is called only once (should be repeated 550# for both directions) and also for zero-length 551# change situations.) 552### AutoLoad Sub 553sub add_umsteigebahnhoefe { 554 my($self, $bhf_obj, %args) = @_; 555 556 my $cb = delete $args{-cb}; 557 558 if (exists $args{-addmapfile}) { 559 TRY: { 560 foreach my $dir (@Strassen::datadirs) { 561 if (open(F, "$dir/" . $args{-addmapfile})) { 562 my %map; 563 while(<F>) { 564 next if /^\#/; 565 chomp; 566 my(@l) = split /\t/; 567 $map{$l[0]} = $l[1]; 568 } 569 close F; 570 if (keys %map) { 571 $args{-addmap} = \%map; 572 } 573 last TRY; 574 } 575 } 576 } 577 } 578 579 my %bahnhoefe; 580 $bhf_obj->init; 581 while(1) { 582 my $ret = $bhf_obj->next; 583 last if !@{ $ret->[Strassen::COORDS()] }; 584 my $name = Strassen::strip_bezirk($ret->[Strassen::NAME()]); 585 if (defined $args{-addmap} and 586 exists $args{-addmap}->{$name}) { 587 $name = $args{-addmap}->{$name}; 588 } 589 my $coords = $ret->[Strassen::COORDS()][0]; 590 if (exists $bahnhoefe{$name}) { 591 foreach my $p (@{ $bahnhoefe{$name} }) { 592 my $entf = 0; 593 if ($coords ne $p) { 594 $entf = Strassen::Util::strecke_s($coords, $p); 595 $self->store_to_hash($self->{Net}, $coords, $p, $entf); 596 $self->store_to_hash($self->{Net}, $p, $coords, $entf); 597 } 598 if ($cb) { $cb->($self, $coords, $p, $entf, $name) } 599 } 600 push @{ $bahnhoefe{$name} }, $coords; 601 } else { 602 $bahnhoefe{$name} = [$coords]; 603 } 604 } 605} 606 607###################################################################### 608# User deletions 609 610### AutoLoad Sub 611sub toggle_deleted_line { 612 my($net, $xy1, $xy2, $on_callback, $off_callback, $del_token) = @_; 613 $del_token ||= ""; 614 my $deleted_net = ($net->{"_Deleted"}{$del_token} ||= {}); 615 if (exists $deleted_net->{$xy1}{$xy2} || 616 exists $deleted_net->{$xy2}{$xy1}) { 617 $net->remove_from_deleted($xy1,$xy2,$off_callback,$del_token); 618 } else { 619 $net->add_to_deleted($xy1,$xy2,$on_callback,$del_token); 620 } 621} 622 623### AutoLoad Sub 624sub remove_from_deleted { 625 my($net, $xy1, $xy2, $off_callback, $del_token) = @_; 626 $del_token ||= ""; 627 my $deleted_net = ($net->{"_Deleted"}{$del_token} ||= {}); 628 $net->{Net}{$xy1}{$xy2} = $deleted_net->{$xy1}{$xy2} 629 if exists $deleted_net->{$xy1}{$xy2}; 630 delete $deleted_net->{$xy1}{$xy2}; 631 $net->{Net}{$xy2}{$xy1} = $deleted_net->{$xy2}{$xy1} 632 if exists $deleted_net->{$xy2}{$xy1}; 633 delete $deleted_net->{$xy2}{$xy1}; 634 $off_callback->($xy1, $xy2, $del_token) if ($off_callback); 635} 636 637### AutoLoad Sub 638sub remove_all_from_deleted { 639 my($net, $off_callback, $del_token) = @_; 640 my $deleted_net = ($net->{"_Deleted"} ||= {}); 641 my $added_wegfuehrung = ($net->{"_Added_Wegfuehrung"} ||= {}); 642 my @del_tokens; 643 if (defined $del_token) { 644 @del_tokens = $del_token; 645 } else { 646 @del_tokens = keys %{ $deleted_net }; 647 } 648 649 for my $del_token (@del_tokens) { 650 while(my($xy1,$v1) = each %{ $deleted_net->{$del_token}}) { 651 while(my($xy2,$v2) = each %$v1) { 652 $net->remove_from_deleted($xy1,$xy2,$off_callback,$del_token); 653 } 654 } 655 while(my($coord,$coords) = each %{ $added_wegfuehrung->{$del_token} }) { 656 # XXX should also be a separate method, like remove_from_deleted? 657 # XXX $off_callback handling is missing! 658 my @changed_wegf; 659 for my $wegf (@{ $net->{Wegfuehrung}{$coord} || [] }) { 660 if (!$coords->{join(" ", @$wegf)}) { 661 push @changed_wegf, $wegf; 662 } 663 } 664 if (@changed_wegf) { 665 $net->{Wegfuehrung}{$coord} = \@changed_wegf; 666 } else { 667 delete $net->{Wegfuehrung}{$coord}; 668 } 669 } 670 } 671} 672 673### AutoLoad Sub 674sub add_to_deleted { 675 my($net, $xy1, $xy2, $on_callback, $del_token) = @_; 676 $del_token = "" if !defined $del_token; 677 $net->del_net($xy1, $xy2, BLOCKED_COMPLETE(), $del_token); 678 $on_callback->($xy1, $xy2, $del_token) if $on_callback; 679} 680 681#XXX rewrite to use make_sperre instead of calls to add_to_deleted. 682# steps: 683# * delete all old {_Deleted}{$del_token} entries (with $off_callback) 684# * call make_sperre with the given file/strassen object 685# * collect all points {_Deleted}{$del_token} and call $on_callback on them 686# * $on_callback should handle all blocking types 687#XXX 688# parameters: $filename or $strassen object 689# -merge 690# -oncallback 691# -offcallback 692### AutoLoad Sub 693sub load_user_deletions { 694 my($net, $filename, %args) = @_; 695 my $do_merge = $args{-merge} || 0; 696 my $on_callback = $args{-oncallback}; 697 my $off_callback = $args{-offcallback}; 698 my $del_token = $args{-deltoken} || ""; 699 my $s = UNIVERSAL::isa($filename, 'Strassen') 700 ? $filename : Strassen->new($filename); 701 $s->init; 702 my %set; 703 while(1) { 704 my $ret = $s->next; 705 last if @{ $ret->[Strassen::COORDS()] } == 0; 706 for(my $inx=0; $inx<$#{$ret->[Strassen::COORDS()]}; $inx++) { 707 $net->add_to_deleted($ret->[Strassen::COORDS()]->[$inx], 708 $ret->[Strassen::COORDS()]->[$inx+1], 709 $on_callback, 710 $del_token); 711 $set{$ret->[Strassen::COORDS()]->[$inx]}->{$ret->[Strassen::COORDS()]->[$inx+1]}++; 712 } 713 } 714 if (!$do_merge) { 715 my $deleted_net = ($net->{_Deleted}{$del_token} ||= {}); 716 while(my($k1,$v1) = each %{ $deleted_net }) { 717 while(my($k2,$v2) = each %$v1) { 718 if (!exists $set{$k1}->{$k2} && 719 !exists $set{$k2}->{$k1}) { 720 $net->remove_from_deleted($k1,$k2, $off_callback, 721 $del_token); 722 } 723 } 724 } 725 } 726} 727 728# Args: 729# -del_token? 730# -type: handicap or oneway or gesperrt (check!) 731# -addinfo: add addinfo bit to category 732### AutoLoad Sub 733sub create_user_deletions_object { 734 my $net = shift; 735 my(%args) = @_; 736 my $del_token = $args{-del_token}; 737 my $cat = BLOCKED_COMPLETE; 738 if (defined $args{-type}) { 739 if ($args{-type} eq 'handicap-q4') { 740 $cat = "q4"; 741 } elsif ($args{-type} eq 'handicap-q4-oneway') { 742 $cat = "q4"; # direction correction follows below 743 } elsif ($args{-type} eq 'oneway') { 744 $cat = "1"; # XXX but what about the direction? 745 } 746 } 747 if (defined $args{-addinfo}) { 748 $cat .= "::" . $args{-addinfo}; # XXX maybe this will change some day to ":" 749 } 750 if (defined $args{-type} && $args{-type} eq 'handicap-q4-oneway') { 751 $cat .= ";"; # direction correction 752 } 753 754 my $s = Strassen->new; 755 my %set; 756 my $deleted_net = ($net->{_Deleted}{$del_token} ||= {}); 757 while(my($k1,$v1) = each %{ $deleted_net }) { 758 while(my($k2,$v2) = each %$v1) { 759 if (!exists $set{$k1}->{$k2} && 760 !exists $set{$k2}->{$k1}) { 761 $s->push(["userdel", [$k1,$k2], $cat]); 762 $set{$k1}->{$k2}++; 763 } 764 } 765 } 766 767 require Strassen::Combine; 768 my $s_combined = $s->make_long_streets; 769 770 $s_combined; 771} 772 773### AutoLoad Sub 774sub save_user_deletions { 775 my($net, $filename, %args) = @_; 776 $args{-del_token} ||= ""; 777 my $s = $net->create_user_deletions_object(%args); 778 $s->write($filename); 779} 780 781###################################################################### 782# Zeichnet das Stra�ennetz, z.B. zum Debuggen. 783### AutoLoad Sub 784sub draw { 785 my($self, $canvas, $transpose_sub) = @_; 786 $canvas->delete("netz"); 787 while(my($node,$neighbors) = each %{ $self->{Net} }) { 788 for my $neighbor (keys %$neighbors) { 789 $canvas->createLine($transpose_sub->(split /,/, $node), 790 $transpose_sub->(split /,/, $neighbor), 791 -tags => 'netz', 792 -fill => 'pink', 793 -arrow => 'last', 794 ); 795 } 796 } 797} 798 799# Erzeugt ein alternatives Hash f�r unerlaubte Wegf�hrungen. 800# Die einzelnen Paare sehen wie folgt aus (p sind "x,y"-Koordinaten): 801# "p0-p1" => ["p2_1", "p2_2" ...] 802### AutoLoad Sub 803sub alternative_wegfuehrung_net { 804 my($net, %args) = @_; 805 if ($net->{Alternative_Wegfuehrung} && !$args{-force}) { 806 return $net->{Alternative_Wegfuehrung}; 807 } 808 my $alt = {}; 809 while(my($k,$v) = each %{$net->{Wegfuehrung}}) { 810 my(@p) = @$v; 811 my $alt_key = "$p[0]-$p[1]"; 812 if (!exists $alt->{$alt_key}) { 813 $alt->{$alt_key} = [$p[2]]; 814 } else { 815 push @{ $alt->{$alt_key} }, $p[2]; 816 } 817 } 818 $net->{Alternative_Wegfuehrung} = $alt; 819 $alt; 820} 821 822# Merge $strassen (Strassen or Multistrassen object) to existing net in $net 823# XXX Very simple version, does not recognize make_net_cat arguments. 824# Also does not do cat =~ /.*;.*/. 825sub merge_net_cat { 826 my($self, $s, %args) = @_; 827 my $net = $self->{Net}; 828 $s->init; 829 while(1) { 830 my $ret = $s->next; 831 my $c = $ret->[Strassen::COORDS()]; 832 last if @$c == 0; 833 my($cat_hin, $cat_rueck); 834 if ($ret->[Strassen::CAT()] =~ /^(.*?)(?:::.*)?;(.*?)(?:::.*)?$/) { 835 ($cat_hin, $cat_rueck) = ($1, $2); 836 } else { 837 ($cat_hin) = ($cat_rueck) = $ret->[Strassen::CAT()] =~ /^(.*?)(?:::.*)?$/; 838 } 839 for my $i (1 .. $#$c) { 840 my($c1,$c2) = ($c->[$i-1], $c->[$i]); 841 $net->{$c1}{$c2} = $cat_hin if $cat_hin ne ""; 842 $net->{$c2}{$c1} = $cat_rueck if $cat_rueck ne ""; 843 } 844 } 845} 846 847# Merge a net from another StrassenNetz object to $self. 848sub merge { 849 my($self, $another_self, %args) = @_; 850 my $overwrite = $args{-overwrite}; 851 my $net = $self->{Net}; 852 my $another_net = $another_self->{Net}; 853 while(my($k1,$v1) = each %{ $another_net }) { 854 while(my($k2,$v2) = each %$v1) { 855 if (!exists $net->{$k1}{$k2} || $overwrite) { 856 $net->{$k1}{$k2} = $v2; 857 } 858 } 859 } 860} 861 862sub push_stack { 863 my($self, $another_self) = @_; 864 865 my @modified; 866 my @added; 867 868 my $net = $self->{Net}; 869 my $another_net = $another_self->{Net}; 870 while(my($k1,$v1) = each %{ $another_net }) { 871 while(my($k2,$v2) = each %$v1) { 872 if (exists $net->{$k1}{$k2}) { 873 push @modified, [$k1, $k2, $net->{$k1}{$k2}]; 874 } else { 875 push @added, [$k1, $k2]; 876 } 877 $net->{$k1}{$k2} = $v2; 878 } 879 } 880 881 push @{ $self->{_Stack} }, { 882 modified => \@modified, 883 added => \@added, 884 }; 885} 886 887sub pop_stack { 888 my($self) = @_; 889 my $remember = pop @{ $self->{_Stack} }; 890 die "Nothing to pop off the stack" if !$remember; 891 my $net = $self->{Net}; 892 for my $modified_entry (@{ $remember->{modified} }) { 893 my($k1,$k2,$v) = @$modified_entry; 894 $net->{$k1}{$k2} = $v; 895 } 896 for my $added_entry (@{ $remember->{added} }) { 897 my($k1,$k2) = @$added_entry; 898 delete $net->{$k1}{$k2}; 899 } 900} 901 902# For debugging only 903sub dump_search_nodes { 904 my($self, $nodes) = @_; 905 while(my($coord, $def) = each %$nodes) { 906 printf STDERR "f=%d g=%d\tX; %s %s\n", 907 $def->[StrassenNetz::DIST()], $def->[StrassenNetz::HEURISTIC_DIST()], $def->[StrassenNetz::PREDECESSOR()], $coord; 908 } 909} 910 911# $route_with_name is the result of route_to_name 912# XXX should I check ImportantAngle? 913sub compact_route { 914 my($self, $route_with_name, %args) = @_; 915 my $route_straight_angle = delete $args{-routestraightangle}; 916 if (!defined $route_straight_angle) { 917 $route_straight_angle = 30; 918 } 919 die "Unknown arguments: " . join(" ", %args) if keys %args; 920 return if !@$route_with_name; 921 require Storable; 922 my @res = Storable::dclone($route_with_name->[0]); 923 for my $i (1 .. $#$route_with_name) { 924 my $this = $route_with_name->[$i]; 925 my $last = $res[-1]; 926 if (!defined $last->[ROUTE_ANGLE] || $last->[ROUTE_ANGLE] < $route_straight_angle) { 927 $last->[ROUTE_NAME] .= ", " . $this->[ROUTE_NAME] 928 if $route_with_name->[$i-1]->[ROUTE_NAME] ne $this->[ROUTE_NAME]; 929 $last->[ROUTE_DIST] += $this->[ROUTE_DIST]; 930 $last->[ROUTE_ANGLE] = $this->[ROUTE_ANGLE]; 931 $last->[ROUTE_DIR] = $this->[ROUTE_DIR]; 932 $last->[ROUTE_ARRAYINX][1] = $this->[ROUTE_ARRAYINX][1]; 933 # combine ROUTE_EXTRA? 934 } else { 935 push @res, Storable::dclone($this); 936 } 937 } 938 @res; 939} 940 941sub neighbor_by_direction { 942 my($self, $p, $angle_or_direction, %args) = @_; 943 die "Unknown options: " . join(" ", %args) if %args; 944 945 require BBBikeUtil; 946 require BBBikeCalc; 947 948 my $angle; 949 if ($angle_or_direction !~ m{^-?\d+(?:\.\d+)?$}) { 950 $angle = _direction_to_deg($angle_or_direction); 951 if (!defined $angle) { 952 die "Invalid direction '$angle_or_direction' (please use lower case English direction abbrevs)"; 953 } 954 } else { 955 $angle = BBBikeCalc::norm_deg($angle_or_direction); 956 } 957 958 my $net = $self->{Net}; 959 if (!$net) { 960 die "Did you call make_net?"; 961 } 962 963 my($px,$py) = split /,/, $p; 964 965 my @neighbor_results; 966 while(my($neighbor,$dist) = each %{ $net->{$p} }) { 967 my($nx,$ny) = split /,/, $neighbor; 968 my $neighbor_arc = BBBikeCalc::norm_arc(BBBikeUtil::pi()/2-atan2($ny-$py,$nx-$px)); 969 my $diff = BBBikeUtil::rad2deg(_norm_arc_180(BBBikeUtil::deg2rad($angle) - $neighbor_arc)); 970 my $delta = abs($diff); 971 my $side = $diff > 0 ? 'l' : $diff < 0 ? 'r' : ''; 972 push @neighbor_results, { delta => $delta, coord => $neighbor, side => $side}; 973 } 974 975 sort { $a->{delta} <=> $b->{delta} } @neighbor_results; 976} 977 978# XXX unfortunately BBBikeCalc is not usable here :-( 979use constant _direction_to_deg_CAKE => 22.5; 980sub _direction_to_deg { 981 my $dir = shift; 982 return {'n' => _direction_to_deg_CAKE*0, 983 'nne' => _direction_to_deg_CAKE*1, 984 'ne' => _direction_to_deg_CAKE*2, 985 'ene' => _direction_to_deg_CAKE*3, 986 'e' => _direction_to_deg_CAKE*4, 987 'ese' => _direction_to_deg_CAKE*5, 988 'se' => _direction_to_deg_CAKE*6, 989 'sse' => _direction_to_deg_CAKE*7, 990 's' => _direction_to_deg_CAKE*8, 991 'ssw' => _direction_to_deg_CAKE*9, 992 'sw' => _direction_to_deg_CAKE*10, 993 'wsw' => _direction_to_deg_CAKE*11, 994 'w' => _direction_to_deg_CAKE*12, 995 'wnw' => _direction_to_deg_CAKE*13, 996 'nw' => _direction_to_deg_CAKE*14, 997 'nnw' => _direction_to_deg_CAKE*15, 998 }->{$dir}; 999} 1000 1001# Return value -pi..pi 1002sub _norm_arc_180 { 1003 my($arc) = @_; 1004 require BBBikeUtil; 1005 if ($arc < -BBBikeUtil::pi()) { 1006 $arc + 2*BBBikeUtil::pi(); 1007 } elsif ($arc > BBBikeUtil::pi()) { 1008 $arc + 2*BBBikeUtil::pi(); 1009 } else { 1010 $arc; 1011 } 1012} 1013 1014 1015sub next_neighbors { 1016 my($self, $from_p, $center_p, %args) = @_; 1017 die "Unknown options: " . join(" ", %args) if %args; 1018 1019 require BBBikeUtil; 1020 require BBBikeCalc; 1021 1022 my($from_px,$from_py) = split /,/, $from_p; 1023 my($center_px,$center_py) = split /,/, $center_p; 1024 1025 my $angle = BBBikeUtil::rad2deg(BBBikeCalc::norm_arc(BBBikeUtil::pi()/2-atan2($center_py-$from_py, $center_px-$from_px))); 1026 $self->neighbor_by_direction($center_p, $angle); 1027} 1028 10291; 1030 1031__END__ 1032