1#!/usr/local/bin/perl 2 3## 4## osm2mp.pl - OpenStreetMap to 'polish' format converter 5## 6 7# $Id: osm2mp.pl 475 2011-06-22 13:02:43Z xliosha@gmail.com $ 8 9## 10## Required packages: 11## * Template-toolkit 12## * Getopt::Long 13## * YAML 14## * Encode::Locale 15## * List::MoreUtils 16## * Math::Polygon 17## * Math::Polygon::Tree 18## * Math::Geometry::Planar::GPC::PolygonXS 19## * Tree::R 20## 21## See http://search.cpan.org/ or use PPM (Perl package manager) or CPAN module 22## 23 24## 25## Licenced under GPL v2 26## 27 28 29use 5.010; 30use strict; 31use warnings; 32use autodie; 33 34use FindBin qw{ $Bin }; 35use lib $Bin; 36 37use POSIX; 38use YAML 0.72; 39use Getopt::Long qw{ :config pass_through }; 40use File::Spec; 41 42use Encode; 43use Encode::Locale; 44 45use Template::Context; 46use Template::Provider; 47 48use Math::Polygon; 49use Math::Geometry::Planar::GPC::PolygonXS 'new_gpc'; 50use Math::Polygon::Tree 0.041 qw{ polygon_centroid }; 51use Tree::R; 52 53use List::Util qw{ first reduce sum min max }; 54use List::MoreUtils qw{ all none any first_index last_index uniq }; 55 56 57 58our $VERSION = '0.91_2'; 59 60 61 62#### Settings 63 64my $config = [ '/usr/local/share/osm2mp/garmin.yml' ]; 65 66my $output_fn; 67my $multiout; 68my $codepage = '1251'; 69my $mp_opts = {}; 70 71my $upcase = 0; 72my $ttable = q{}; 73my $text_filter = q{}; 74 75my $oneway = 1; 76my $routing = 1; 77my $mergeroads = 1; 78my $mergecos = 0.2; 79my $splitroads = 1; 80my $fixclosenodes = 1; 81my $fixclosedist = 3.0; # set 5.5 for cgpsmapper 0097 and earlier 82my $maxroadnodes = 60; 83my $restrictions = 1; 84my $barriers = 1; 85my $disableuturns = 0; 86my $destsigns = 1; 87my $detectdupes = 0; 88 89my $roadshields = 1; 90my $transportstops = 1; 91my $streetrelations = 1; 92my $interchange3d = 1; 93 94my $bbox; 95my $bpolyfile; 96my $osmbbox = 0; 97my $background = 1; 98my $lessgpc = 1; 99 100my $shorelines = 0; 101my $hugesea = 0; 102my $waterback = 0; 103my $marine = 1; 104 105my $addressing = 1; 106my $full_karlsruhe = 0; 107my $navitel = 0; 108my $addrfrompoly = 1; 109my $addrinterpolation = 1; 110my $makepoi = 1; 111my $country_list; 112 113my $default_city; 114my $default_region; 115my $default_country; 116 117my $poiregion = 1; 118my $poicontacts = 1; 119 120my $transport_mode; 121 122 123#### Global vars 124 125my %yesno; 126my %taglist; 127 128my %node; 129my %waychain; 130 131my %city; 132my $city_rtree = Tree::R->new(); 133my %suburb; 134 135my %interpolation_node; 136 137my %poi; 138my $poi_rtree = Tree::R->new(); 139 140 141 142 143print STDERR "\n ---| OSM -> MP converter $VERSION (c) 2008-2011 liosha, xliosha\@gmail.com\n\n"; 144 145 146 147#### Reading configs 148 149for ( @ARGV ) { $_ = decode 'locale', $_ } 150 151GetOptions ( 152 'config=s@' => \$config, 153); 154 155my %config; 156print STDERR "Loading configuration... "; 157 158while ( my $cfgfile = shift @$config ) { 159 my ( $cfgvol, $cfgdir, undef ) = File::Spec->splitpath( $cfgfile ); 160 my %cfgpart = YAML::LoadFile $cfgfile; 161 while ( my ( $key, $item ) = each %cfgpart ) { 162 if ( $key eq 'load' && ref $item ) { 163 for my $addcfg ( @$item ) { 164 $addcfg = File::Spec->catpath( $cfgvol, $cfgdir, $addcfg ) 165 unless File::Spec->file_name_is_absolute( $addcfg ); 166 push @$config, $addcfg; 167 } 168 } 169 elsif ( $key eq 'command-line' ) { 170 my @args = grep {defined} ( $item =~ m{ (?: '([^']*)' | "([^"]*)" | (\S+) ) }gxms ); 171 for my $i ( 0 .. $#args ) { 172 next if $args[$i] !~ / --? (?: countrylist|ttable|bpoly ) /xms; 173 next if !length($args[$i+1]); 174 next if File::Spec->file_name_is_absolute( $args[$i+1] ); 175 $args[$i+1] = File::Spec->catpath( $cfgvol, $cfgdir, $args[$i+1] ); 176 } 177 unshift @ARGV, @args; 178 } 179 elsif ( $key eq 'yesno' ) { 180 %yesno = %{ $item }; 181 } 182 elsif ( $key eq 'taglist' ) { 183 while ( my ( $key, $val ) = each %$item ) { 184 next if exists $taglist{$key}; 185 $taglist{$key} = $val; 186 } 187 } 188 elsif ( $key eq 'nodes' || $key eq 'ways' ) { 189 for my $rule ( @$item ) { 190 if ( exists $rule->{id} 191 && (my $index = first_index { exists $_->{id} && $_->{id} eq $rule->{id} } @{$config{$key}}) >= 0 ) { 192 $config{$key}->[$index] = $rule; 193 } 194 else { 195 push @{$config{$key}}, $rule; 196 } 197 } 198 } 199 else { 200 %config = ( %config, $key => $item ); 201 } 202 } 203} 204 205 206GetOptions ( 207 'countrylist=s' => \$country_list, 208); 209 210my %country_code; 211if ( $country_list ) { 212 open my $cl, '<:encoding(utf8)', $country_list; 213 while ( my $line = <$cl> ) { 214 next if $line =~ / ^ \# /xms; 215 chomp $line; 216 my ($code, $name) = split /\s+/xms, $line, 2; 217 next unless $code; 218 $country_code{uc $code} = $name; 219 } 220 close $cl; 221} 222 223 224print STDERR "Ok\n\n"; 225 226 227 228# cl-options second pass: tuning 229GetOptions ( 230 'output|o=s' => \$output_fn, 231 'multiout=s' => \$multiout, 232 233 'mp-header=s%' => sub { $mp_opts->{$_[1]} = $_[2] }, 234 'codepage=s' => \$codepage, 235 'nocodepage' => sub { undef $codepage }, 236 'upcase!' => \$upcase, 237 'ttable=s' => \$ttable, 238 'textfilter=s' => sub { eval "require $_[1]" or eval "require PerlIO::via::$_[1]" or die $@; $text_filter .= ":via($_[1])"; }, 239 240 'oneway!' => \$oneway, 241 'routing!' => \$routing, 242 'mergeroads!' => \$mergeroads, 243 'mergecos=f' => \$mergecos, 244 'detectdupes!' => \$detectdupes, 245 'splitroads!' => \$splitroads, 246 'maxroadnodes=f' => \$maxroadnodes, 247 'fixclosenodes!' => \$fixclosenodes, 248 'fixclosedist=f' => \$fixclosedist, 249 'restrictions!' => \$restrictions, 250 'barriers!' => \$barriers, 251 'disableuturns!' => \$disableuturns, 252 'destsigns!' => \$destsigns, 253 'roadshields!' => \$roadshields, 254 'transportstops!' => \$transportstops, 255 'streetrelations!' => \$streetrelations, 256 'interchange3d!' => \$interchange3d, 257 'transport=s' => \$transport_mode, 258 'notransport' => sub { undef $transport_mode }, 259 260 'defaultcity=s' => \$default_city, 261 'defaultregion=s' => \$default_region, 262 'defaultcountry=s' => \$default_country, 263 264 'bbox=s' => \$bbox, 265 'bpoly=s' => \$bpolyfile, 266 'osmbbox!' => \$osmbbox, 267 'background!' => \$background, 268 'lessgpc!' => \$lessgpc, 269 'shorelines!' => \$shorelines, 270 'hugesea=i' => \$hugesea, 271 'waterback!' => \$waterback, 272 'marine!' => \$marine, 273 274 'addressing!' => \$addressing, 275 'full-karlsruhe!' => \$full_karlsruhe, 276 'navitel!' => \$navitel, 277 'addrfrompoly!' => \$addrfrompoly, 278 'addrinterpolation!'=> \$addrinterpolation, 279 'makepoi!' => \$makepoi, 280 'poiregion!' => \$poiregion, 281 'poicontacts!' => \$poicontacts, 282 283 'namelist=s%' => sub { $taglist{$_[1]} = [ split /[ ,]+/, $_[2] ] }, 284 285 # obsolete, for backward compatibility 286 'nametaglist=s' => sub { push @ARGV, '--namelist', "label=$_[1]" }, 287 'translit!' => sub { push @ARGV, '--textfilter', 'Unidecode', '--codepage', '1252' }, 288 'mapid=s' => sub { push @ARGV, '--mp-header', "ID=$_[1]" }, 289 'mapname=s' => sub { push @ARGV, '--mp-header', "Name=$_[1]" }, 290); 291 292$default_country = $country_code{uc $default_country} 293 if $default_country && $country_code{uc $default_country}; 294 295 296usage() unless (@ARGV); 297 298 299$codepage ||= 'utf8'; 300if ( $codepage =~ / ^ (?: cp | win (?: dows )? )? -? ( \d{3,} ) $ /ixms ) { 301 $mp_opts->{CodePage} = $1; 302 $codepage = "cp$1"; 303} 304 305my $binmode = "encoding($codepage)$text_filter:utf8"; 306 307 308my $cmap; 309if ( $ttable ) { 310 $cmap = do $ttable; 311 die unless $cmap; 312} 313 314my %transport_code = ( 315 emergency => 0, 316 police => 0, 317 delivery => 1, 318 car => 2, 319 motorcar => 2, 320 bus => 3, 321 taxi => 4, 322 foot => 5, 323 pedestrian => 5, 324 bike => 6, 325 bicycle => 6, 326 truck => 7, 327); 328$transport_mode = $transport_code{ $transport_mode } 329 if defined $transport_mode && exists $transport_code{ $transport_mode }; 330 331 332 333#### Precompiling templates 334 335 336my $ttc = Template::Context->new(); 337my $ttp = $ttc->{LOAD_TEMPLATES}->[0]; 338$ttp->{STAT_TTL} = 2**31; 339 340for my $template ( keys %{ $config{output} } ) { 341 $ttp->store( $template, $ttc->template( \$config{output}->{$template} ) ); 342} 343 344$mp_opts->{DefaultCityCountry} = $country_code{uc $mp_opts->{DefaultCityCountry}} 345 if $mp_opts->{DefaultCityCountry} && $country_code{uc $mp_opts->{DefaultCityCountry}}; 346 347 348 349#### Creating simple multiwriter output 350 351my $out = {}; 352if ( !$output_fn ) { 353 $out->{q{}} = *STDOUT{IO}; 354 binmode $out->{q{}}, $binmode; 355 print {$out->{q{}}} $ttc->process( header => { opts => $mp_opts, version => $VERSION } ); 356} 357 358 359#### Opening input 360 361my $infile = shift @ARGV; 362print STDERR "Processing file $infile\n\n"; 363open my $in, '<', $infile; 364 365 366 367 368#### Bounds 369 370my $bounds = 0; 371my @bound; 372my $boundtree; 373 374 375if ($bbox) { 376 $bounds = 1 ; 377 my ($minlon, $minlat, $maxlon, $maxlat) = split q{,}, $bbox; 378 @bound = ( [$minlon,$minlat], [$maxlon,$minlat], [$maxlon,$maxlat], [$minlon,$maxlat], [$minlon,$minlat] ); 379 $boundtree = Math::Polygon::Tree->new( \@bound ); 380} 381 382if ($bpolyfile) { 383 $bounds = 1; 384 print STDERR "Initialising bounds... "; 385 386 # $boundtree = Math::Polygon::Tree->new( $bpolyfile ); 387 388 open my $pf, '<', $bpolyfile; 389 390 ## ??? need advanced polygon? 391 while (<$pf>) { 392 if (/^\d/) { 393 @bound = (); 394 } 395 elsif (/^\s+([0-9.E+-]+)\s+([0-9.E+-]+)/) { 396 push @bound, [ $1+0, $2+0 ]; 397 } 398 elsif (/^END/) { 399 @bound = reverse @bound if Math::Polygon->new( @bound )->isClockwise(); 400 $boundtree = Math::Polygon::Tree->new( \@bound ); 401 last; 402 } 403 } 404 close $pf; 405 printf STDERR "%d segments\n", scalar @bound; 406} 407 408 409#### 1st pass 410### loading nodes 411 412my ( $waypos, $relpos ) = ( 0, 0 ); 413 414print STDERR "Loading nodes... "; 415 416while ( my $line = <$in> ) { 417 418 if ( $line =~ /<node.* id=["']([^"']+)["'].* lat=["']([^"']+)["'].* lon=["']([^"']+)["']/ ) { 419 $node{$1} = "$2,$3"; 420 next; 421 } 422 423 if ( $osmbbox && $line =~ /<bounds?/ ) { 424 my ($minlat, $minlon, $maxlat, $maxlon); 425 if ( $line =~ /<bounds/ ) { 426 ($minlat, $minlon, $maxlat, $maxlon) 427 = ( $line =~ /minlat=["']([^"']+)["'] minlon=["']([^"']+)["'] maxlat=["']([^"']+)["'] maxlon=["']([^"']+)["']/ ); 428 } 429 else { 430 ($minlat, $minlon, $maxlat, $maxlon) 431 = ( $line =~ /box=["']([^"',]+),([^"',]+),([^"',]+),([^"']+)["']/ ); 432 } 433 $bbox = join q{,}, ($minlon, $minlat, $maxlon, $maxlat); 434 $bounds = 1 if $bbox; 435 @bound = ( [$minlon,$minlat], [$maxlon,$minlat], [$maxlon,$maxlat], [$minlon,$maxlat], [$minlon,$minlat] ); 436 $boundtree = Math::Polygon::Tree->new( \@bound ); 437 } 438 439 last if $line =~ /<way/; 440} 441continue { $waypos = tell $in } 442 443 444printf STDERR "%d loaded\n", scalar keys %node; 445 446 447my $boundgpc = new_gpc(); 448$boundgpc->add_polygon ( \@bound, 0 ) if $bounds; 449 450 451 452 453 454### loading relations 455 456# multipolygons 457my %mpoly; 458my %ampoly; #advanced 459 460# turn restrictions 461my $counttrest = 0; 462my $countsigns = 0; 463my %trest; 464my %nodetr; 465 466# transport 467my $countroutes = 0; 468my %trstop; 469 470# streets 471my %street; 472my $count_streets = 0; 473 474# roads numbers 475my %road_ref; 476my $count_ref_roads = 0; 477 478 479print STDERR "Loading relations... "; 480 481my $relid; 482my %reltag; 483my %relmember; 484 485 486while ( <$in> ) { 487 last if /<relation/; 488} 489continue { $relpos = tell $in } 490seek $in, $relpos, 0; 491 492 493while ( my $line = decode 'utf8', <$in> ) { 494 495 if ( $line =~ /<relation/ ) { 496 ($relid) = $line =~ / id=["']([^"']+)["']/; 497 %reltag = (); 498 %relmember = (); 499 next; 500 } 501 502 if ( $line =~ /<member/ ) { 503 my ($mtype, $mid, $mrole) = 504 $line =~ / type=["']([^"']+)["'].* ref=["']([^"']+)["'].* role=["']([^"']*)["']/; 505 push @{ $relmember{"$mtype:$mrole"} }, $mid if $mtype; 506 next; 507 } 508 509 if ( $line =~ /<tag/ ) { 510 my ($key, undef, $val) = $line =~ / k=["']([^"']+)["'].* v=(["'])(.+)\2/; 511 $reltag{$key} = $val if $key && !exists $config{skip_tags}->{$key}; 512 next; 513 } 514 515 if ( $line =~ /<\/relation/ ) { 516 517 if ( !exists $reltag{'type'} ) { 518 report( "No type defined for RelID=$relid" ); 519 next; 520 } 521 522 # multipolygon 523 if ( $reltag{'type'} eq 'multipolygon' || $reltag{'type'} eq 'boundary' ) { 524 525 push @{$relmember{'way:outer'}}, @{$relmember{'way:'}} 526 if exists $relmember{'way:'}; 527 push @{$relmember{'way:outer'}}, @{$relmember{'way:exclave'}} 528 if exists $relmember{'way:exclave'}; 529 push @{$relmember{'way:inner'}}, @{$relmember{'way:enclave'}} 530 if exists $relmember{'way:enclave'}; 531 532 unless ( exists $relmember{'way:outer'} ) { 533 report( "Multipolygon RelID=$relid doesn't have OUTER way" ); 534 next; 535 } 536 537 $ampoly{$relid} = { 538 outer => $relmember{'way:outer'}, 539 inner => $relmember{'way:inner'}, 540 tags => { %reltag }, 541 }; 542 543 next unless exists $relmember{'way:inner'} && @{$relmember{'way:outer'}}==1; 544 545 # old simple multipolygon 546 my $outer = $relmember{'way:outer'}->[0]; 547 my @inner = @{ $relmember{'way:inner'} }; 548 549 $mpoly{$outer} = [ @inner ]; 550 } 551 552 # turn restrictions 553 if ( $routing && $restrictions && $reltag{'type'} eq 'restriction' ) { 554 unless ( exists $reltag{'restriction'} ) { 555 report( "Restriction RelID=$relid type not specified" ); 556 $reltag{'restriction'} = 'no_'; 557 } 558 unless ( $relmember{'way:from'} ) { 559 report( "Turn restriction RelID=$relid doesn't have FROM way" ); 560 next; 561 } 562 if ( $relmember{'way:via'} ) { 563 report( "VIA ways is still not supported (RelID=$relid)", 'WARNING' ); 564 next; 565 } 566 unless ( $relmember{'node:via'} ) { 567 report( "Turn restriction RelID=$relid doesn't have VIA node" ); 568 next; 569 } 570 if ( $reltag{'restriction'} eq 'no_u_turn' && !$relmember{'way:to'} ) { 571 $relmember{'way:to'} = $relmember{'way:from'}; 572 } 573 unless ( $relmember{'way:to'} ) { 574 report( "Turn restriction RelID=$relid doesn't have TO way" ); 575 next; 576 } 577 578 my @acc = ( 0,0,0,0,0,1,0,0 ); # foot 579 @acc = CalcAccessRules( { map { $_ => 'no' } split( /\s*[,;]\s*/, $reltag{'except'} ) }, \@acc ) 580 if exists $reltag{'except'}; 581 582 if ( any { !$_ } @acc ) { 583 584 $counttrest ++; 585 $trest{$relid} = { 586 node => $relmember{'node:via'}->[0], 587 type => ($reltag{'restriction'} =~ /^only_/) ? 'only' : 'no', 588 fr_way => $relmember{'way:from'}->[0], 589 fr_dir => 0, 590 fr_pos => -1, 591 to_way => $relmember{'way:to'}->[0], 592 to_dir => 0, 593 to_pos => -1, 594 }; 595 596 $trest{$relid}->{param} = join q{,}, @acc 597 if any { $_ } @acc; 598 } 599 600 push @{$nodetr{ $relmember{'node:via'}->[0] }}, $relid; 601 } 602 603 # destination signs 604 if ( $routing && $destsigns && $reltag{'type'} eq 'destination_sign' ) { 605 unless ( $relmember{'way:from'} ) { 606 report( "Destination sign RelID=$relid has no FROM ways" ); 607 next; 608 } 609 unless ( $relmember{'way:to'} ) { 610 report( "Destination sign RelID=$relid doesn't have TO way" ); 611 next; 612 } 613 614 my $node; 615 $node = $relmember{'node:sign'}->[0] if $relmember{'node:sign'}; 616 $node = $relmember{'node:intersection'}->[0] if $relmember{'node:intersection'}; 617 unless ( $node ) { 618 report( "Destination sign RelID=$relid doesn't have SIGN or INTERSECTION node" ); 619 next; 620 } 621 622 my $name = name_from_list( 'destination', \%reltag ); 623 unless ( $name ) { 624 report( "Destination sign RelID=$relid doesn't have label tag" ); 625 next; 626 } 627 628 $countsigns ++; 629 for my $from ( @{ $relmember{'way:from'} } ) { 630 $trest{$relid} = { 631 name => $name, 632 node => $node, 633 type => 'sign', 634 fr_way => $from, 635 fr_dir => 0, 636 fr_pos => -1, 637 to_way => $relmember{'way:to'}->[0], 638 to_dir => 0, 639 to_pos => -1, 640 }; 641 } 642 643 push @{$nodetr{ $node }}, $relid; 644 } 645 646 # transport stops 647 if ( $transportstops 648 && $reltag{'type'} eq 'route' 649 && $reltag{'route'} ~~ [ qw{ bus } ] 650 && exists $reltag{'ref'} ) { 651 $countroutes ++; 652 for my $role ( keys %relmember ) { 653 next unless $role =~ /^node:.*stop/; 654 for my $stop ( @{ $relmember{$role} } ) { 655 push @{ $trstop{$stop} }, $reltag{'ref'}; 656 } 657 } 658 } 659 660 # road refs 661 if ( $roadshields 662 && $reltag{'type'} eq 'route' 663 && $reltag{'route'} && $reltag{'route'} eq 'road' 664 && ( exists $reltag{'ref'} || exists $reltag{'int_ref'} ) ) { 665 $count_ref_roads ++; 666 for my $role ( keys %relmember ) { 667 next unless $role =~ /^way:/; 668 for my $way ( @{ $relmember{$role} } ) { 669 push @{ $road_ref{$way} }, $reltag{'ref'} if exists $reltag{'ref'}; 670 push @{ $road_ref{$way} }, $reltag{'int_ref'} if exists $reltag{'int_ref'}; 671 } 672 } 673 } 674 675 # streets 676 if ( $streetrelations 677 && $reltag{'type'} ~~ [ qw{ street associatedStreet } ] 678 && name_from_list( 'street', \%reltag ) ) { 679 $count_streets ++; 680 my $street_name = name_from_list( 'street', \%reltag ); 681 for my $role ( keys %relmember ) { 682 next unless $role =~ /:(house|address)/; 683 my ($obj) = $role =~ /(.+):/; 684 for my $member ( @{ $relmember{$role} } ) { 685 $street{ "$obj:$member" } = $street_name; 686 } 687 } 688 } 689 690 } 691} 692 693printf STDERR "%d multipolygons\n", scalar keys %ampoly; 694print STDERR " $counttrest turn restrictions\n" if $restrictions; 695print STDERR " $countsigns destination signs\n" if $destsigns; 696print STDERR " $countroutes transport routes\n" if $transportstops; 697print STDERR " $count_ref_roads numbered roads\n" if $roadshields; 698print STDERR " $count_streets streets\n" if $streetrelations; 699 700 701 702 703#### 2nd pass 704### loading cities, multipolygon parts and checking node dupes 705 706 707my %ways_to_load; 708for my $mp ( values %ampoly ) { 709 if ( $mp->{outer} ) { 710 for my $id ( @{ $mp->{outer} } ) { 711 $ways_to_load{$id} ++; 712 } 713 } 714 if ( $mp->{inner} ) { 715 for my $id ( @{ $mp->{inner} } ) { 716 $ways_to_load{$id} ++; 717 } 718 } 719} 720 721 722print STDERR "Loading necessary ways... "; 723 724my $wayid; 725my %waytag; 726my @chain; 727my $dupcount; 728 729seek $in, $waypos, 0; 730 731while ( my $line = decode 'utf8', <$in> ) { 732 733 if ( $line =~/<way / ) { 734 ($wayid) = $line =~ / id=["']([^"']+)["']/; 735 @chain = (); 736 %waytag = (); 737 $dupcount = 0; 738 next; 739 } 740 741 if ( $line =~ /<nd / ) { 742 my ($ref) = $line =~ / ref=["']([^"']+)["']/; 743 if ( $node{$ref} ) { 744 unless ( scalar @chain && $ref eq $chain[-1] ) { 745 push @chain, $ref; 746 } 747 else { 748 report( "WayID=$wayid has dupes at ($node{$ref})" ); 749 $dupcount ++; 750 } 751 } 752 next; 753 } 754 755 if ( $line =~ /<tag.* k=["']([^"']+)["'].* v=["']([^"']+)["']/ ) { 756 $waytag{$1} = $2 unless exists $config{skip_tags}->{$1}; 757 next; 758 } 759 760 761 if ( $line =~ /<\/way/ ) { 762 763 ## part of multipolygon 764 if ( $ways_to_load{$wayid} ) { 765 $waychain{$wayid} = [ @chain ]; 766 } 767 768 ## address bound 769 process_config( $config{address}, { 770 type => 'Way', 771 id => $wayid, 772 tag => { %waytag }, 773 outer => [ [ @chain ] ], 774 } ) 775 if $addressing && exists $config{address}; 776 777 next; 778 } 779 780 last if $line =~ /<relation/; 781} 782 783printf STDERR "%d loaded\n", scalar keys %waychain; 784 785undef %ways_to_load; 786 787 788 789 790print STDERR "Processing multipolygons "; 791print_section( 'Multipolygons' ); 792 793# load addressing polygons 794if ( $addressing && exists $config{address} ) { 795 while ( my ( $mpid, $mp ) = each %ampoly ) { 796 my $ampoly = merge_ampoly( $mpid ); 797 next unless exists $ampoly->{outer} && @{ $ampoly->{outer} }; 798 process_config( $config{address}, { 799 type => 'Rel', 800 id => $mpid, 801 tag => $mp->{tags}, 802 outer => $ampoly->{outer}, 803 } ); 804 } 805} 806 807# draw that should be drawn 808my $countpolygons = 0; 809while ( my ( $mpid, $mp ) = each %ampoly ) { 810 811 my $ampoly = merge_ampoly( $mpid ); 812 next unless exists $ampoly->{outer} && @{ $ampoly->{outer} }; 813 814 ## POI 815 if ( $makepoi ) { 816 process_config( $config{nodes}, { 817 type => "Rel", 818 id => $mpid, 819 tag => $mp->{tags}, 820 latlon => ( join q{,}, polygon_centroid( map { [ split q{,}, $node{$_} ] } @{ $ampoly->{outer}->[0] } ) ), 821 } ); 822 } 823 824 ## Polygon 825 my @alist; 826 for my $area ( @{ $ampoly->{outer} } ) { 827 push @alist, [ map { [reverse split q{,}, $node{$_}] } @$area ]; 828 } 829 my @hlist; 830 for my $area ( @{ $ampoly->{inner} } ) { 831 push @hlist, [ map { [reverse split q{,}, $node{$_}] } @$area ]; 832 } 833 834 process_config( $config{ways}, { 835 type => "Rel", 836 id => $mpid, 837 tag => $mp->{tags}, 838 areas => \@alist, 839 holes => \@hlist, 840 } ); 841} 842 843printf STDERR "%d polygons written\n", $countpolygons; 844printf STDERR " %d cities and %d suburbs loaded\n", scalar keys %city, scalar keys %suburb 845 if $addressing; 846 847 848 849 850 851#### 3rd pass 852### loading and writing points 853 854my %barrier; 855my %xnode; 856my %entrance; 857 858 859print STDERR "Processing nodes... "; 860print_section( 'Points' ); 861 862my $countpoi = 0; 863my $nodeid; 864my %nodetag; 865 866seek $in, 0, 0; 867 868while ( my $line = decode 'utf8', <$in> ) { 869 870 if ( $line =~ /<node/ ) { 871 ($nodeid) = $line =~ / id=["']([^"']+)["']/; 872 %nodetag = (); 873 next; 874 } 875 876 if ( $line =~ /<tag/ ) { 877 my ($key, undef, $val) = $line =~ / k=["']([^"']+)["'].* v=(["'])(.+)\2/; 878 next unless $key; #bug! 879 $nodetag{$key} = $val unless exists $config{skip_tags}->{$key}; 880 next; 881 } 882 883 if ( $line =~ /<\/node/ ) { 884 885 next unless scalar %nodetag; 886 887 ## Barriers 888 if ( $routing && $barriers && $nodetag{'barrier'} ) { 889 AddBarrier({ nodeid => $nodeid, tags => \%nodetag }); 890 } 891 892 ## Forced external nodes 893 if ( $routing && exists $nodetag{'garmin:extnode'} && $yesno{$nodetag{'garmin:extnode'}} ) { 894 $xnode{$nodeid} = 1; 895 } 896 897 ## Building entrances 898 if ( $navitel && exists $nodetag{'building'} && $nodetag{'building'} eq 'entrance' ) { 899 $entrance{$nodeid} = name_from_list( 'entrance', \%nodetag); 900 } 901 902 ## Interpolation nodes 903 if ( $addrinterpolation && exists $interpolation_node{$nodeid} ) { 904 if ( exists $nodetag{'addr:housenumber'} ) { 905 if ( extract_number( $nodetag{'addr:housenumber'} ) ) { 906 $interpolation_node{$nodeid} = { %nodetag }; 907 } 908 else { 909 report( "Wrong house number on NodeID=$nodeid" ); 910 } 911 } 912 } 913 914 ## POI 915 process_config( $config{nodes}, { 916 type => 'Node', 917 id => $nodeid, 918 tag => \%nodetag, 919 } ); 920 921 } 922 923 last if $line =~ /<way/; 924} 925 926printf STDERR "%d POIs written\n", $countpoi; 927printf STDERR " %d POIs loaded\n", (sum map { scalar @$_ } values %poi) // 0 928 if $addrfrompoly; 929printf STDERR " %d barriers loaded\n", scalar keys %barrier 930 if $barriers; 931 932 933 934#### Loading roads and coastlines, and writing other ways 935 936my %road; 937my %coast; 938my %hlevel; 939 940print STDERR "Processing ways... "; 941print_section( 'Lines and polygons' ); 942 943my $countlines = 0; 944$countpolygons = 0; 945 946my $city; 947my @chainlist; 948my $inbounds; 949 950seek $in, $waypos, 0; 951 952while ( my $line = decode 'utf8', <$in> ) { 953 954 if ( $line =~ /<way/ ) { 955 ($wayid) = $line =~ / id=["']([^"']+)["']/; 956 957 %waytag = (); 958 @chain = (); 959 @chainlist = (); 960 $inbounds = 0; 961 $city = 0; 962 963 next; 964 } 965 966 if ( $line =~ /<nd/ ) { 967 my ($ref) = $line =~ / ref=["']([^"']*)["']/; 968 if ( $node{$ref} && ( !@chain || $ref ne $chain[-1] ) ) { 969 push @chain, $ref; 970 if ($bounds) { 971 my $in = is_inside_bounds( $node{$ref} ); 972 if ( !$inbounds && $in ) { push @chainlist, ($#chain ? $#chain-1 : 0); } 973 if ( $inbounds && !$in ) { push @chainlist, $#chain; } 974 $inbounds = $in; 975 } 976 } 977 next; 978 } 979 980 if ( $line =~ /<tag/ ) { 981 my ($key, undef, $val) = $line =~ / k=["']([^"']+)["'].* v=(["'])(.+)\2/; 982 $waytag{$key} = $val if $key && !exists $config{skip_tags}->{$key}; 983 next; 984 } 985 986 if ( $line =~ /<\/way/ ) { 987 988 my $name = name_from_list( 'label', \%waytag); 989 990 @chainlist = (0) unless $bounds; 991 push @chainlist, $#chain unless ($#chainlist % 2); 992 993 if ( scalar @chain < 2 ) { 994 report( "WayID=$wayid has too few nodes at ($node{$chain[0]})" ); 995 next; 996 } 997 998 next unless scalar keys %waytag; 999 next unless scalar @chainlist; 1000 1001 my @list = @chainlist; 1002 my @clist = (); 1003 push @clist, [ (shift @list), (shift @list) ] while @list; 1004 1005 ## Way config 1006 process_config( $config{ways}, { 1007 type => "Way", 1008 id => $wayid, 1009 chain => \@chain, 1010 clist => \@clist, 1011 tag => \%waytag, 1012 } ); 1013 1014 ## POI config 1015 if ( $makepoi ) { 1016 process_config( $config{nodes}, { 1017 type => "Way", 1018 id => $wayid, 1019 latlon => ( join q{,}, polygon_centroid( map { [ split q{,}, $node{$_} ] } @chain ) ), 1020 tag => \%waytag, 1021 } ); 1022 } 1023 } # </way> 1024 1025 last if $line =~ /<relation/; 1026} 1027 1028print STDERR "$countlines lines and $countpolygons polygons dumped\n"; 1029printf STDERR " %d roads loaded\n", scalar keys %road if $routing; 1030printf STDERR " %d coastlines loaded\n", scalar keys %coast if $shorelines; 1031 1032undef %waychain; 1033 1034 1035#### Writing non-addressed POIs 1036 1037if ( %poi ) { 1038 print_section( 'Non-addressed POIs' ); 1039 while ( my ($id,$list) = each %poi ) { 1040 for my $poi ( @$list ) { 1041 WritePOI( $poi ); 1042 } 1043 } 1044 undef %poi; 1045} 1046 1047 1048 1049#### Processing coastlines 1050 1051if ( $shorelines ) { 1052 1053 my $boundcross = 0; 1054 1055 print STDERR "Processing shorelines... "; 1056 print_section( 'Sea areas generated from coastlines' ); 1057 1058 1059 ## merging 1060 my @keys = keys %coast; 1061 for my $line_start ( @keys ) { 1062 next unless $coast{ $line_start }; 1063 1064 my $line_end = $coast{ $line_start }->[-1]; 1065 next if $line_end eq $line_start; 1066 next unless $coast{ $line_end }; 1067 next unless ( !$bounds || is_inside_bounds( $node{$line_end} ) ); 1068 1069 pop @{$coast{$line_start}}; 1070 push @{$coast{$line_start}}, @{$coast{$line_end}}; 1071 delete $coast{$line_end}; 1072 redo; 1073 } 1074 1075 1076 ## tracing bounds 1077 if ( $bounds ) { 1078 1079 my @tbound; 1080 my $pos = 0; 1081 1082 for my $i ( 0 .. $#bound-1 ) { 1083 1084 push @tbound, { 1085 type => 'bound', 1086 point => $bound[$i], 1087 pos => $pos, 1088 }; 1089 1090 for my $sline ( keys %coast ) { 1091 1092 # check start of coastline 1093 my $p1 = [ reverse split q{,}, $node{$coast{$sline}->[0]} ]; 1094 my $p2 = [ reverse split q{,}, $node{$coast{$sline}->[1]} ]; 1095 my $ipoint = segment_intersection( $bound[$i], $bound[$i+1], $p1, $p2 ); 1096 1097 if ( $ipoint ) { 1098 if ( any { $_->{type} eq 'end' && $_->{point} ~~ $ipoint } @tbound ) { 1099 @tbound = grep { !( $_->{type} eq 'end' && $_->{point} ~~ $ipoint ) } @tbound; 1100 } 1101 else { 1102 $boundcross ++; 1103 push @tbound, { 1104 type => 'start', 1105 point => $ipoint, 1106 pos => $pos + segment_length( $bound[$i], $ipoint ), 1107 line => $sline, 1108 }; 1109 } 1110 } 1111 1112 # check end of coastline 1113 $p1 = [ reverse split q{,}, $node{$coast{$sline}->[-1]} ]; 1114 $p2 = [ reverse split q{,}, $node{$coast{$sline}->[-2]} ]; 1115 $ipoint = segment_intersection( $bound[$i], $bound[$i+1], $p1, $p2 ); 1116 1117 if ( $ipoint ) { 1118 if ( any { $_->{type} eq 'start' && $_->{point} ~~ $ipoint } @tbound ) { 1119 @tbound = grep { !( $_->{type} eq 'start' && $_->{point} ~~ $ipoint ) } @tbound; 1120 } 1121 else { 1122 $boundcross ++; 1123 push @tbound, { 1124 type => 'end', 1125 point => $ipoint, 1126 pos => $pos + segment_length( $bound[$i], $ipoint ), 1127 line => $sline, 1128 }; 1129 } 1130 } 1131 } 1132 1133 $pos += segment_length( $bound[$i], $bound[$i+1] ); 1134 } 1135 1136 # rotate if sea at $tbound[0] 1137 my $tmp = reduce { $a->{pos} < $b->{pos} ? $a : $b } grep { $_->{type} ne 'bound' } @tbound; 1138 if ( $tmp->{type} && $tmp->{type} eq 'end' ) { 1139 for ( grep { $_->{pos} <= $tmp->{pos} } @tbound ) { 1140 $_->{pos} += $pos; 1141 } 1142 } 1143 1144 # merge lines 1145 $tmp = 0; 1146 for my $node ( sort { $a->{pos}<=>$b->{pos} } @tbound ) { 1147 my $latlon = join q{,}, reverse @{$node->{point}}; 1148 $node{$latlon} = $latlon; 1149 1150 if ( $node->{type} eq 'start' ) { 1151 $tmp = $node; 1152 $coast{$tmp->{line}}->[0] = $latlon; 1153 } 1154 if ( $node->{type} eq 'bound' && $tmp ) { 1155 unshift @{$coast{$tmp->{line}}}, ($latlon); 1156 } 1157 if ( $node->{type} eq 'end' && $tmp ) { 1158 $coast{$node->{line}}->[-1] = $latlon; 1159 if ( $node->{line} eq $tmp->{line} ) { 1160 push @{$coast{$node->{line}}}, $coast{$node->{line}}->[0]; 1161 } else { 1162 push @{$coast{$node->{line}}}, @{$coast{$tmp->{line}}}; 1163 delete $coast{$tmp->{line}}; 1164 for ( grep { $_->{line} && $tmp->{line} && $_->{line} eq $tmp->{line} } @tbound ) { 1165 $_->{line} = $node->{line}; 1166 } 1167 } 1168 $tmp = 0; 1169 } 1170 } 1171 } 1172 1173 1174 ## detecting lakes and islands 1175 my %lake; 1176 my %island; 1177 1178 while ( my ($loop,$chain_ref) = each %coast ) { 1179 1180 if ( $chain_ref->[0] ne $chain_ref->[-1] ) { 1181 1182 report( sprintf( "Possible coastline break at (%s) or (%s)", @node{ @$chain_ref[0,-1] } ), 1183 ( $bounds ? 'ERROR' : 'WARNING' ) ) 1184 unless $#$chain_ref < 3; 1185 1186 next; 1187 } 1188 1189 # filter huge polygons to avoid cgpsmapper's crash 1190 if ( $hugesea && scalar @$chain_ref > $hugesea ) { 1191 report( sprintf( "Skipped too big coastline $loop (%d nodes)", scalar @$chain_ref ), 'WARNING' ); 1192 next; 1193 } 1194 1195 if ( Math::Polygon->new( map { [ split q{,}, $node{$_} ] } @$chain_ref )->isClockwise() ) { 1196 $island{$loop} = 1; 1197 } 1198 else { 1199 $lake{$loop} = Math::Polygon::Tree->new( [ map { [ reverse split q{,}, $node{$_} ] } @$chain_ref ] ); 1200 } 1201 } 1202 1203 my @lakesort = sort { scalar @{$coast{$b}} <=> scalar @{$coast{$a}} } keys %lake; 1204 1205 ## adding sea background 1206 if ( $waterback && $bounds && !$boundcross ) { 1207 $lake{'background'} = $boundtree; 1208 splice @lakesort, 0, 0, 'background'; 1209 } 1210 1211 ## writing 1212 my $countislands = 0; 1213 1214 for my $sea ( @lakesort ) { 1215 my %objinfo = ( 1216 type => $config{types}->{sea}->{type}, 1217 level_h => $config{types}->{sea}->{endlevel}, 1218 comment => "sea $sea", 1219 areas => $sea eq 'background' 1220 ? [ \@bound ] 1221 : [[ map { [ reverse split q{,} ] } @node{@{$coast{$sea}}} ]], 1222 ); 1223 1224 for my $island ( keys %island ) { 1225 if ( $lake{$sea}->contains( [ reverse split q{,}, $node{$island} ] ) ) { 1226 $countislands ++; 1227 push @{$objinfo{holes}}, [ map { [ reverse split q{,} ] } @node{@{$coast{$island}}} ]; 1228 delete $island{$island}; 1229 } 1230 } 1231 1232 WritePolygon( \%objinfo ); 1233 } 1234 1235 printf STDERR "%d lakes, %d islands\n", scalar keys %lake, $countislands; 1236 1237 undef %lake; 1238 undef %island; 1239} 1240 1241 1242 1243 1244#### Process roads 1245 1246my %nodid; 1247my %roadid; 1248my %nodeways; 1249 1250if ( $routing ) { 1251 1252 print_section( 'Roads' ); 1253 1254 ### detecting end nodes 1255 1256 my %enode; 1257 my %rstart; 1258 1259 while ( my ($roadid, $road) = each %road ) { 1260 $enode{$road->{chain}->[0]} ++; 1261 $enode{$road->{chain}->[-1]} ++; 1262 $rstart{$road->{chain}->[0]}->{$roadid} = 1; 1263 } 1264 1265 1266 1267 ### merging roads 1268 1269 if ( $mergeroads ) { 1270 print STDERR "Merging roads... "; 1271 1272 my $countmerg = 0; 1273 my @keys = keys %road; 1274 1275 my $i = 0; 1276 while ($i < scalar @keys) { 1277 1278 my $r1 = $keys[$i]; 1279 1280 if ( !exists $road{$r1} ) { 1281 $i++; 1282 next; 1283 } 1284 1285 my $p1 = $road{$r1}->{chain}; 1286 1287 my @list = (); 1288 for my $r2 ( keys %{$rstart{$p1->[-1]}} ) { 1289 my @plist = qw{ type name city rp level_l level_h }; 1290 push @plist, grep { /^_*[A-Z]/ } ( keys %{$road{$r1}}, keys %{$road{$r2}} ); 1291 1292 if ( $r1 ne $r2 1293 && ( all { 1294 ( !exists $road{$r1}->{$_} && !exists $road{$r2}->{$_} ) || 1295 ( defined $road{$r1}->{$_} && defined $road{$r2}->{$_} && $road{$r1}->{$_} eq $road{$r2}->{$_} ) 1296 } @plist ) 1297 && lcos( $p1->[-2], $p1->[-1], $road{$r2}->{chain}->[1] ) > $mergecos ) { 1298 push @list, $r2; 1299 } 1300 } 1301 1302 # merging 1303 if ( @list ) { 1304 $countmerg ++; 1305 @list = sort { lcos( $p1->[-2], $p1->[-1], $road{$b}->{chain}->[1] ) 1306 <=> lcos( $p1->[-2], $p1->[-1], $road{$a}->{chain}->[1] ) } @list; 1307 1308 report( sprintf( "Road WayID=$r1 may be merged with %s at (%s)", join( q{, }, @list ), $node{$p1->[-1]} ), 'FIX' ); 1309 1310 my $r2 = $list[0]; 1311 1312 # process associated restrictions 1313 if ( $restrictions || $destsigns ) { 1314 while ( my ($relid, $tr) = each %trest ) { 1315 if ( $tr->{fr_way} eq $r2 ) { 1316 my $msg = "RelID=$relid FROM moved from WayID=$r2($tr->{fr_pos})"; 1317 $tr->{fr_way} = $r1; 1318 $tr->{fr_pos} += $#{$road{$r1}->{chain}}; 1319 report( "$msg to WayID=$r1($tr->{fr_pos})", 'FIX' ); 1320 } 1321 if ( $tr->{to_way} eq $r2 ) { 1322 my $msg = "RelID=$relid TO moved from WayID=$r2($tr->{to_pos})"; 1323 $tr->{to_way} = $r1; 1324 $tr->{to_pos} += $#{$road{$r1}->{chain}}; 1325 report( "$msg to WayID=$r1($tr->{to_pos})", 'FIX' ); 1326 } 1327 } 1328 } 1329 1330 $enode{$road{$r2}->{chain}->[0]} -= 2; 1331 pop @{$road{$r1}->{chain}}; 1332 push @{$road{$r1}->{chain}}, @{$road{$r2}->{chain}}; 1333 1334 delete $rstart{ $road{$r2}->{chain}->[0] }->{$r2}; 1335 delete $road{$r2}; 1336 1337 } else { 1338 $i ++; 1339 } 1340 } 1341 1342 print STDERR "$countmerg merged\n"; 1343 } 1344 1345 1346 1347 1348 ### generating routing graph 1349 1350 my %rnode; 1351 1352 print STDERR "Detecting road nodes... "; 1353 1354 while (my ($roadid, $road) = each %road) { 1355 for my $node (@{$road->{chain}}) { 1356 $rnode{$node} ++; 1357 } 1358 } 1359 1360 my $nodcount = 1; 1361 1362 for my $node ( keys %rnode ) { 1363 $nodid{$node} = $nodcount++ 1364 if $rnode{$node} > 1 1365 || $enode{$node} 1366 || $xnode{$node} 1367 || $barrier{$node} 1368 || ( exists $nodetr{$node} && scalar @{$nodetr{$node}} ); 1369 } 1370 1371 1372 while (my ($roadid, $road) = each %road) { 1373 for my $node (@{$road->{chain}}) { 1374 push @{$nodeways{$node}}, $roadid if $nodid{$node}; 1375 } 1376 } 1377 1378 1379 undef %rnode; 1380 1381 printf STDERR "%d found\n", scalar keys %nodid; 1382 1383 1384 1385 1386 1387 ### detecting duplicate road segments 1388 1389 1390 if ( $detectdupes ) { 1391 1392 my %segway; 1393 1394 print STDERR "Detecting duplicates... "; 1395 1396 while ( my ($roadid, $road) = each %road ) { 1397 for my $i ( 0 .. $#{$road->{chain}} - 1 ) { 1398 if ( $nodid{ $road->{chain}->[$i] } 1399 && $nodid{ $road->{chain}->[$i+1] } ) { 1400 my $seg = join q{:}, sort {$a cmp $b} ($road->{chain}->[$i], $road->{chain}->[$i+1]); 1401 push @{$segway{$seg}}, $roadid; 1402 } 1403 } 1404 } 1405 1406 my $countdupsegs = 0; 1407 1408 my %roadseg; 1409 my %roadpos; 1410 1411 for my $seg ( grep { $#{$segway{$_}} > 0 } keys %segway ) { 1412 $countdupsegs ++; 1413 my $roads = join q{, }, sort {$a cmp $b} @{$segway{$seg}}; 1414 my ($point) = split q{:}, $seg; 1415 $roadseg{$roads} ++; 1416 $roadpos{$roads} = $node{$point}; 1417 } 1418 1419 for my $road ( keys %roadseg ) { 1420 report( "Roads $road have $roadseg{$road} duplicate segments near ($roadpos{$road})" ); 1421 } 1422 1423 printf STDERR "$countdupsegs segments, %d roads\n", scalar keys %roadseg; 1424 } 1425 1426 1427 1428 1429 #### fixing self-intersections and long roads 1430 1431 if ( $splitroads ) { 1432 1433 print STDERR "Splitting roads... "; 1434 1435 my $countself = 0; 1436 my $countlong = 0; 1437 my $countrest = 0; 1438 1439 while ( my ($roadid, $road) = each %road ) { 1440 my $break = 0; 1441 my @breaks = (); 1442 my $rnod = 1; 1443 my $prev = 0; 1444 1445 # test for split conditions 1446 for my $i ( 1 .. $#{$road->{chain}} ) { 1447 my $cnode = $road->{chain}->[$i]; 1448 $rnod ++ if $nodid{ $cnode }; 1449 1450 if ( any { $_ eq $cnode } @{$road->{chain}}[$break..$i-1] ) { 1451 $countself ++; 1452 if ( $cnode ne $road->{chain}->[$prev] ) { 1453 $break = $prev; 1454 push @breaks, $break; 1455 } else { 1456 $break = ($i + $prev) >> 1; 1457 push @breaks, $break; 1458 1459 my $bnode = $road->{chain}->[$break]; 1460 $nodid{ $bnode } = $nodcount++; 1461 $nodeways{ $bnode } = [ $roadid ]; 1462 report( sprintf( "Added NodID=%d for NodeID=%s at (%s)", $nodid{$bnode}, $bnode, $node{$bnode} ), 'FIX' ); 1463 } 1464 $rnod = 2; 1465 } 1466 1467 elsif ( $rnod == $maxroadnodes ) { 1468 $countlong ++; 1469 $break = $prev; 1470 push @breaks, $break; 1471 $rnod = 2; 1472 } 1473 1474 elsif ( $i < $#{$road->{chain}} && exists $barrier{ $cnode } ) { 1475 # || (exists $nodetr{ $cnode } && @{ $nodetr{ $cnode } } ) ) { 1476 $countrest ++; 1477 $break = $i; 1478 push @breaks, $break; 1479 $rnod = 1; 1480 } 1481 1482 $prev = $i if $nodid{ $cnode }; 1483 } 1484 1485 1486 1487 # split 1488 if ( @breaks ) { 1489 report( sprintf( "WayID=$roadid is splitted at %s", join( q{, }, @breaks ) ), 'FIX' ); 1490 push @breaks, $#{$road->{chain}}; 1491 1492 for my $i ( 0 .. $#breaks - 1 ) { 1493 my $id = $roadid.'/'.($i+1); 1494 report( sprintf( "Added road %s, nodes from %d to %d\n", $id, $breaks[$i], $breaks[$i+1] ), 'FIX' ); 1495 1496 $road{$id} = { %{$road{$roadid}} }; 1497 $road{$id}->{chain} = [ @{$road->{chain}}[$breaks[$i] .. $breaks[$i+1]] ]; 1498 1499 # update nod->road list 1500 for my $nod ( grep { exists $nodeways{$_} } @{$road{$id}->{chain}} ) { 1501 push @{$nodeways{$nod}}, $id; 1502 } 1503 1504 # move restrictions 1505 if ( $restrictions || $destsigns ) { 1506 while ( my ($relid, $tr) = each %trest ) { 1507 if ( $tr->{to_way} eq $roadid 1508 && $tr->{to_pos} > $breaks[$i] - (1 + $tr->{to_dir}) / 2 1509 && $tr->{to_pos} <= $breaks[$i+1] - (1 + $tr->{to_dir}) / 2 ) { 1510 my $msg = "Turn restriction RelID=$relid TO moved from $roadid($tr->{to_pos})"; 1511 $tr->{to_way} = $id; 1512 $tr->{to_pos} -= $breaks[$i]; 1513 report( "$msg to $id($tr->{to_pos})", 'FIX' ); 1514 } 1515 if ( $tr->{fr_way} eq $roadid 1516 && $tr->{fr_pos} > $breaks[$i] + ($tr->{fr_dir} - 1) / 2 1517 && $tr->{fr_pos} <= $breaks[$i+1] + ($tr->{fr_dir} - 1) / 2 ) { 1518 my $msg = "Turn restriction RelID=$relid FROM moved from $roadid($tr->{fr_pos})"; 1519 $tr->{fr_way} = $id; 1520 $tr->{fr_pos} -= $breaks[$i]; 1521 report( "$msg to $id($tr->{fr_pos})", 'FIX' ); 1522 } 1523 } 1524 } 1525 } 1526 1527 # update nod->road list 1528 for my $nod ( @{ $road->{chain} } ) { 1529 next unless exists $nodeways{$nod}; 1530 $nodeways{$nod} = [ grep { $_ ne $roadid } @{$nodeways{$nod}} ]; 1531 } 1532 for my $nod ( @{ $road->{chain} }[ 0 .. $breaks[0] ] ) { 1533 next unless exists $nodeways{$nod}; 1534 push @{ $nodeways{$nod} }, $roadid; 1535 } 1536 1537 $#{$road->{chain}} = $breaks[0]; 1538 } 1539 } 1540 print STDERR "$countself self-intersections, $countlong long roads, $countrest barriers\n"; 1541 } 1542 1543 1544 #### disable U-turns 1545 if ( $disableuturns ) { 1546 1547 print STDERR "Removing U-turns... "; 1548 1549 my $utcount = 0; 1550 1551 for my $node ( keys %nodid ) { 1552 next if $barrier{$node}; 1553 1554 # RouteParams=speed,class,oneway,toll,emergency,delivery,car,bus,taxi,foot,bike,truck 1555 my @auto_links = 1556 map { $node eq $road{$_}->{chain}->[0] || $node eq $road{$_}->{chain}->[-1] ? ($_) : ($_,$_) } 1557 grep { $road{$_}->{rp} =~ /^.,.,.,.,.,.,0/ } @{ $nodeways{$node} }; 1558 1559 next unless scalar @auto_links == 2; 1560 next unless scalar( grep { $road{$_}->{rp} =~ /^.,.,0/ } @auto_links ) == 2; 1561 1562 my $pos = first_index { $_ eq $node } @{ $road{$auto_links[0]}->{chain} }; 1563 $trest{ 'ut'.$utcount++ } = { 1564 node => $node, 1565 type => 'no', 1566 fr_way => $auto_links[0], 1567 fr_dir => $pos > 0 ? 1 : -1, 1568 fr_pos => $pos, 1569 to_way => $auto_links[0], 1570 to_dir => $pos > 0 ? -1 : 1, 1571 to_pos => $pos, 1572 param => '0,0,0,0,0,1,0,0', 1573 }; 1574 1575 $pos = first_index { $_ eq $node } @{ $road{$auto_links[1]}->{chain} }; 1576 $trest{ 'ut'.$utcount++ } = { 1577 node => $node, 1578 type => 'no', 1579 fr_way => $auto_links[1], 1580 fr_dir => $pos < $#{ $road{$auto_links[1]}->{chain} } ? -1 : 1, 1581 fr_pos => $pos, 1582 to_way => $auto_links[1], 1583 to_dir => $pos < $#{ $road{$auto_links[1]}->{chain} } ? 1 : -1, 1584 to_pos => $pos, 1585 param => '0,0,0,0,0,1,0,0', 1586 }; 1587 1588 } 1589 print STDERR "$utcount restrictions added\n"; 1590 } 1591 1592 1593 1594 1595 1596 ### fixing too close nodes 1597 1598 if ( $fixclosenodes ) { 1599 1600 print STDERR "Fixing close nodes... "; 1601 1602 my $countclose = 0; 1603 1604 while ( my ($roadid, $road) = each %road ) { 1605 my $cnode = $road->{chain}->[0]; 1606 for my $node ( grep { $_ ne $cnode && $nodid{$_} } @{$road->{chain}}[1..$#{$road->{chain}}] ) { 1607 if ( fix_close_nodes( $cnode, $node ) ) { 1608 $countclose ++; 1609 report( "Too close nodes $cnode and $node, WayID=$roadid near (${node{$node}})" ); 1610 } 1611 $cnode = $node; 1612 } 1613 } 1614 print STDERR "$countclose pairs fixed\n"; 1615 } 1616 1617 1618 1619 1620 ### dumping roads 1621 1622 1623 print STDERR "Writing roads... "; 1624 1625 my $roadcount = 1; 1626 1627 while ( my ($roadid, $road) = each %road ) { 1628 1629 my ($name, $rp) = ( $road->{name}, $road->{rp} ); 1630 my ($type, $llev, $hlev) = ( $road->{type}, $road->{level_l}, $road->{level_h} ); 1631 1632 $roadid{$roadid} = $roadcount++; 1633 1634 $rp =~ s/^(.,.),./$1,0/ unless $oneway; 1635 1636 my %objinfo = ( 1637 comment => "WayID = $roadid" . ( $road->{comment} // q{} ), 1638 type => $type, 1639 name => $name, 1640 chain => [ @{$road->{chain}} ], 1641 roadid => $roadid{$roadid}, 1642 routeparams => $rp, 1643 ); 1644 1645 $objinfo{level_l} = $llev if $llev > 0; 1646 $objinfo{level_h} = $hlev if $hlev > $llev; 1647 1648 $objinfo{StreetDesc} = $name if $name && $navitel; 1649 $objinfo{DirIndicator} = 1 if $rp =~ /^.,.,1/; 1650 1651 if ( $road->{city} ) { 1652 my $city = ref $road->{city} eq 'HASH' ? $road->{city} : $city{ $road->{city} }; 1653 my $region = $city->{region} || $default_region; 1654 my $country = $city->{country} || $default_country; 1655 1656 $objinfo{CityName} = convert_string( $city->{name} ); 1657 $objinfo{RegionName} = convert_string( $region ) if $region; 1658 $objinfo{CountryName} = convert_string( $country ) if $country; 1659 } 1660 elsif ( $default_city ) { 1661 $objinfo{CityName} = $default_city; 1662 $objinfo{RegionName} = convert_string( $default_region ) if $default_region; 1663 $objinfo{CountryName} = convert_string( $default_country ) if $default_country; 1664 } 1665 1666 my @levelchain = (); 1667 my $prevlevel = 0; 1668 for my $i ( 0 .. $#{$road->{chain}} ) { 1669 my $node = $road->{chain}->[$i]; 1670 1671 if ( $interchange3d ) { 1672 if ( exists $hlevel{ $node } ) { 1673 push @levelchain, [ $i-1, 0 ] if $i > 0 && $prevlevel == 0; 1674 push @levelchain, [ $i, $hlevel{$node} ]; 1675 $prevlevel = $hlevel{$node}; 1676 } 1677 else { 1678 push @levelchain, [ $i, 0 ] if $i > 0 && $prevlevel != 0; 1679 $prevlevel = 0; 1680 } 1681 } 1682 1683 next unless $nodid{$node}; 1684 push @{$objinfo{nod}}, [ $i, $nodid{$node}, $xnode{$node} ]; 1685 } 1686 1687 $objinfo{HLevel0} = join( q{,}, map { "($_->[0],$_->[1])" } @levelchain) if @levelchain; 1688 1689 # the rest object parameters (capitals!) 1690 for my $key ( keys %$road ) { 1691 next unless $key =~ /^_*[A-Z]/; 1692 $objinfo{$key} = $road->{$key}; 1693 } 1694 1695 WriteLine( \%objinfo ); 1696 } 1697 1698 printf STDERR "%d written\n", $roadcount-1; 1699 1700} # if $routing 1701 1702#### Background object (?) 1703 1704 1705if ( $bounds && $background && exists $config{types}->{background} ) { 1706 1707 print_section( 'Background' ); 1708 1709 WritePolygon({ 1710 type => $config{types}->{background}->{type}, 1711 level_h => $config{types}->{background}->{endlevel}, 1712 areas => [ \@bound ], 1713 }); 1714} 1715 1716 1717 1718 1719#### Writing turn restrictions 1720 1721 1722if ( $routing && ( $restrictions || $destsigns || $barriers ) ) { 1723 1724 print STDERR "Writing crossroads... "; 1725 print_section( 'Turn restrictions and signs' ); 1726 1727 my $counttrest = 0; 1728 my $countsigns = 0; 1729 1730 while ( my ($relid, $tr) = each %trest ) { 1731 1732 unless ( $tr->{fr_dir} ) { 1733 report( "RelID=$relid FROM road does'n have VIA end node" ); 1734 next; 1735 } 1736 unless ( $tr->{to_dir} ) { 1737 report( "RelID=$relid TO road does'n have VIA end node" ); 1738 next; 1739 } 1740 1741 $tr->{comment} = "RelID = $relid: from $tr->{fr_way} $tr->{type} $tr->{to_way}"; 1742 1743 if ( $tr->{type} eq 'sign' ) { 1744 $countsigns ++; 1745 write_turn_restriction ($tr); 1746 } 1747 1748 1749 if ( $tr->{type} eq 'no' ) { 1750 $counttrest ++; 1751 write_turn_restriction ($tr); 1752 } 1753 1754 if ( $tr->{type} eq 'only') { 1755 1756 my %newtr = ( 1757 type => 'no', 1758 ); 1759 for my $key ( qw{ node fr_way fr_dir fr_pos param } ) { 1760 next unless exists $tr->{$key}; 1761 $newtr{$key} = $tr->{$key}; 1762 } 1763 1764 for my $roadid ( @{$nodeways{ $trest{$relid}->{node} }} ) { 1765 $newtr{to_way} = $roadid; 1766 $newtr{to_pos} = first_index { $_ eq $tr->{node} } @{$road{$roadid}->{chain}}; 1767 1768 if ( $newtr{to_pos} < $#{$road{$roadid}->{chain}} 1769 && !( $tr->{to_way} eq $roadid && $tr->{to_dir} eq 1 ) ) { 1770 $newtr{comment} = "$tr->{comment}\nSo restrict to $roadid forward"; 1771 $newtr{to_dir} = 1; 1772 $counttrest ++; 1773 write_turn_restriction (\%newtr); 1774 } 1775 1776 if ( $newtr{to_pos} > 0 1777 && !( $tr->{to_way} eq $roadid && $tr->{to_dir} eq -1 ) 1778 && $road{$roadid}->{rp} !~ /^.,.,1/ ) { 1779 $newtr{comment} = "$tr->{comment}\nSo restrict to $roadid backward"; 1780 $newtr{to_dir} = -1; 1781 $counttrest ++; 1782 write_turn_restriction (\%newtr); 1783 } 1784 } 1785 } 1786 } 1787 1788 ## Barriers 1789 1790 print_section( 'Barriers' ); 1791 1792 for my $node ( keys %barrier ) { 1793 my %newtr = ( 1794 node => $node, 1795 type => 'no', 1796 param => $barrier{$node}->{param}, 1797 comment => "NodeID = $node\nbarrier = $barrier{$node}->{type}", 1798 ); 1799 for my $way_from ( @{$nodeways{$node}} ) { 1800 $newtr{fr_way} = $way_from; 1801 $newtr{fr_pos} = first_index { $_ eq $node } @{$road{ $way_from }->{chain}}; 1802 1803 for my $dir_from ( -1, 1 ) { 1804 1805 next if $dir_from == -1 && $newtr{fr_pos} == $#{$road{ $way_from }->{chain}}; 1806 next if $dir_from == 1 && $newtr{fr_pos} == 0; 1807 1808 $newtr{fr_dir} = $dir_from; 1809 for my $way_to ( @{$nodeways{$node}} ) { 1810 $newtr{to_way} = $way_to; 1811 $newtr{to_pos} = first_index { $_ eq $node } @{$road{ $way_to }->{chain}}; 1812 1813 for my $dir_to ( -1, 1 ) { 1814 next if $dir_to == -1 && $newtr{to_pos} == 0; 1815 next if $dir_to == 1 && $newtr{to_pos} == $#{$road{ $way_to }->{chain}}; 1816 next if $way_from eq $way_to && $dir_from == -$dir_to; 1817 1818 $newtr{to_dir} = $dir_to; 1819 $counttrest ++; 1820 write_turn_restriction (\%newtr); 1821 } 1822 } 1823 } 1824 } 1825 } 1826 1827 print STDERR "$counttrest restrictions, $countsigns signs\n"; 1828} 1829 1830 1831 1832 1833for my $file ( keys %$out ) { 1834 print {$out->{$file}} $ttc->process( 'footer' ); 1835} 1836 1837print STDERR "All done!!\n\n"; 1838 1839 1840#### The end 1841 1842 1843 1844 1845 1846 1847 1848#### Functions 1849 1850sub convert_string { 1851 1852 my ($str) = @_; 1853 return q{} unless $str; 1854 1855 if ( $cmap ) { 1856 $cmap->( $str ); 1857 } 1858 1859 $str = uc($str) if $upcase; 1860 1861 $str =~ s/\&#(\d+)\;/chr($1)/ge; 1862 $str =~ s/\&\;/\&/gi; 1863 $str =~ s/\&apos\;/\'/gi; 1864 $str =~ s/\"\;/\"/gi; 1865 $str =~ s/\&[\d\w]+\;//gi; 1866 1867 $str =~ s/[\?\"\<\>\*]/ /g; 1868 $str =~ s/[\x00-\x1F]//g; 1869 1870 $str =~ s/^[ \`\'\;\.\,\!\-\+\_]+//; 1871 $str =~ s/ +/ /g; 1872 $str =~ s/\s+$//; 1873 1874 $str =~ s/~\[0X(\w+)\]/~[0x$1]/; 1875 1876 return $str; 1877} 1878 1879sub name_from_list { 1880 my ($list_name, $tag_ref) = @_; 1881 1882 my $key = first { exists $tag_ref->{$_} } @{$taglist{$list_name}}; 1883 1884 return unless $key; 1885 1886 my $name; 1887 $name = $tag_ref->{$key} if $key; 1888 $name = $country_code{uc $name} if $list_name eq 'country' && exists $country_code{uc $name}; 1889 return $name; 1890} 1891 1892 1893 1894sub fix_close_nodes { # NodeID1, NodeID2 1895 1896 my ($id0, $id1) = @_; 1897 1898 my ($lat1, $lon1) = split q{,}, $node{$id0}; 1899 my ($lat2, $lon2) = split q{,}, $node{$id1}; 1900 1901 my ($clat, $clon) = ( ($lat1+$lat2)/2, ($lon1+$lon2)/2 ); 1902 my ($dlat, $dlon) = ( ($lat2-$lat1), ($lon2-$lon1) ); 1903 my $klon = cos( $clat * 3.14159 / 180 ); 1904 1905 my $ldist = $fixclosedist * 180 / 20_000_000; 1906 1907 my $res = ($dlat**2 + ($dlon*$klon)**2) < $ldist**2; 1908 1909 # fixing 1910 if ( $res ) { 1911 if ( $dlon == 0 ) { 1912 $node{$id0} = ($clat - $ldist/2 * ($dlat==0 ? 1 : ($dlat <=> 0) )) . q{,} . $clon; 1913 $node{$id1} = ($clat + $ldist/2 * ($dlat==0 ? 1 : ($dlat <=> 0) )) . q{,} . $clon; 1914 } 1915 else { 1916 my $azim = $dlat / $dlon; 1917 my $ndlon = sqrt( $ldist**2 / ($klon**2 + $azim**2) ) / 2; 1918 my $ndlat = $ndlon * abs($azim); 1919 1920 $node{$id0} = ($clat - $ndlat * ($dlat <=> 0)) . q{,} . ($clon - $ndlon * ($dlon <=> 0)); 1921 $node{$id1} = ($clat + $ndlat * ($dlat <=> 0)) . q{,} . ($clon + $ndlon * ($dlon <=> 0)); 1922 } 1923 } 1924 return $res; 1925} 1926 1927 1928 1929sub lcos { # NodeID1, NodeID2, NodeID3 1930 1931 my ($id0, $id1, $id2) = @_; 1932 1933 my ($lat1, $lon1) = split q{,}, $node{$id0}; 1934 my ($lat2, $lon2) = split q{,}, $node{$id1}; 1935 my ($lat3, $lon3) = split q{,}, $node{$id2}; 1936 1937 my $klon = cos( ($lat1+$lat2+$lat3) / 3 * 3.14159 / 180 ); 1938 1939 my $xx = (($lat2-$lat1)**2+($lon2-$lon1)**2*$klon**2) * (($lat3-$lat2)**2+($lon3-$lon2)**2*$klon**2); 1940 1941 return -1 if ( $xx == 0); 1942 return (($lat2-$lat1)*($lat3-$lat2)+($lon2-$lon1)*($lon3-$lon2)*$klon**2) / sqrt($xx); 1943} 1944 1945 1946 1947sub speed_code { 1948 my ($spd) = @_; 1949 return 7 if $spd > 120; # no limit 1950 return 6 if $spd > 100; # 110 1951 return 5 if $spd > 85; # 90 1952 return 4 if $spd > 70; # 80 1953 return 3 if $spd > 50; # 60 1954 return 2 if $spd > 30; # 40 1955 return 1 if $spd > 10; # 20 1956 return 0; # 5 1957} 1958 1959 1960 1961sub is_inside_bounds { # $latlon 1962 my ($node) = @_; 1963 return $boundtree->contains( [ reverse split q{,}, $node ] ); 1964} 1965 1966 1967 1968sub write_turn_restriction { # \%trest 1969 1970 my ($tr) = @_; 1971 1972 my $i = $tr->{fr_pos} - $tr->{fr_dir}; 1973 while ( !$nodid{ $road{$tr->{fr_way}}->{chain}->[$i] } && $i >= 0 && $i < $#{$road{$tr->{fr_way}}->{chain}} ) { 1974 $i -= $tr->{fr_dir}; 1975 } 1976 1977 my $j = $tr->{to_pos} + $tr->{to_dir}; 1978 while ( !$nodid{ $road{$tr->{to_way}}->{chain}->[$j] } && $j >= 0 && $j < $#{$road{$tr->{to_way}}->{chain}} ) { 1979 $j += $tr->{to_dir}; 1980 } 1981 1982 unless ( ${nodid{$tr->{node}}} ) { 1983 output( comment => { text => "$tr->{comment}\nOutside boundaries" } ); 1984 return; 1985 } 1986 1987 my %opts = ( 1988 node_from => $nodid{ $road{$tr->{fr_way}}->{chain}->[$i] }, 1989 node_via => $nodid{ $tr->{node} }, 1990 node_to => $nodid{ $road{$tr->{to_way}}->{chain}->[$j] }, 1991 road_from => $roadid{ $tr->{fr_way} }, 1992 road_to => $roadid{$tr->{to_way}}, 1993 ); 1994 1995 if ( $tr->{type} eq 'sign' ) { 1996 $opts{param} = "T,$tr->{name}"; 1997 output( destination_sign => { comment => $tr->{comment}, opts => \%opts } ); 1998 } 1999 else { 2000 $opts{param} = $tr->{param} if $tr->{param}; 2001 output( turn_restriction => { comment => $tr->{comment}, opts => \%opts } ); 2002 } 2003 2004 return; 2005} 2006 2007 2008 2009 2010sub usage { 2011 2012 my @onoff = ( "off", "on"); 2013 2014 my $usage = <<"END_USAGE"; 2015Usage: osm2mp.pl [options] file.osm 2016 2017Available options [defaults]: 2018 2019 --config <file> configuration file [/usr/local/share/osm2mp/garmin.yml] 2020 2021 --output <file> output to file [${\( $output_fn || 'stdout' )}] 2022 --multiout <key> write output to multiple files [${\( $multiout || 'off' )}] 2023 --mp-header <key>=<value> MP header values 2024 2025 --codepage <num> codepage number [$codepage] 2026 --upcase convert all labels to upper case [$onoff[$upcase]] 2027 --textfilter <layer> use extra output filter PerlIO::via::<layer> 2028 --translit same as --textfilter Unidecode 2029 --ttable <file> character conversion table 2030 --roadshields shields with road numbers [$onoff[$roadshields]] 2031 --namelist <key>=<list> comma-separated list of tags to select names 2032 2033 --addressing use city polygons for addressing [$onoff[$addressing]] 2034 --full-karlsruhe use addr:* tags if no city found [$onoff[$full_karlsruhe]] 2035 --navitel write addresses for polygons [$onoff[$navitel]] 2036 --addrfrompoly get POI address from buildings [$onoff[$addrfrompoly]] 2037 --makepoi create POIs for polygons [$onoff[$makepoi]] 2038 --poiregion write region info for settlements [$onoff[$poiregion]] 2039 --poicontacts write contact info for POIs [$onoff[$poicontacts]] 2040 --defaultcity <name> default city for addresses [${ \($default_city // '') }] 2041 --defaultregion <name> default region [${ \($default_region // '') }] 2042 --defaultcountry <name> default country [${ \($default_country // '') }] 2043 --countrylist <file> replace country code by name 2044 2045 --routing produce routable map [$onoff[$routing]] 2046 --oneway enable oneway attribute for roads [$onoff[$oneway]] 2047 --mergeroads merge same ways [$onoff[$mergeroads]] 2048 --mergecos <cosine> max allowed angle between roads to merge [$mergecos] 2049 --splitroads split long and self-intersecting roads [$onoff[$splitroads]] 2050 --maxroadnodes <dist> maximum number of nodes in road segment [$maxroadnodes] 2051 --fixclosenodes enlarge distance between too close nodes [$onoff[$fixclosenodes]] 2052 --fixclosedist <dist> minimum allowed distance [$fixclosedist m] 2053 --restrictions process turn restrictions [$onoff[$restrictions]] 2054 --barriers process barriers [$onoff[$barriers]] 2055 --disableuturns disable u-turns on nodes with 2 links [$onoff[$disableuturns]] 2056 --destsigns process destination signs [$onoff[$destsigns]] 2057 --detectdupes detect road duplicates [$onoff[$detectdupes]] 2058 --interchange3d navitel-style 3D interchanges [$onoff[$interchange3d]] 2059 --transport <mode> single transport mode 2060 2061 --bbox <bbox> comma-separated minlon,minlat,maxlon,maxlat 2062 --osmbbox use bounds from .osm [$onoff[$osmbbox]] 2063 --bpoly <poly-file> use bounding polygon from .poly-file 2064 --background create background object [$onoff[$background]] 2065 2066 --shorelines process shorelines [$onoff[$shorelines]] 2067 --waterback water background (for island maps) [$onoff[$waterback]] 2068 --marine process marine data (buoys etc) [$onoff[$marine]] 2069 2070You can use no<option> to disable features (i.e --norouting) 2071END_USAGE 2072 2073 printf $usage; 2074 exit; 2075} 2076 2077 2078 2079### geometry functions 2080 2081sub segment_length { 2082 my ($p1,$p2) = @_; 2083 return sqrt( ($p2->[0] - $p1->[0])**2 + ($p2->[1] - $p1->[1])**2 ); 2084} 2085 2086 2087sub segment_intersection { 2088 my ($p11, $p12, $p21, $p22) = @_; 2089 2090 my $Z = ($p12->[1]-$p11->[1]) * ($p21->[0]-$p22->[0]) - ($p21->[1]-$p22->[1]) * ($p12->[0]-$p11->[0]); 2091 my $Ca = ($p12->[1]-$p11->[1]) * ($p21->[0]-$p11->[0]) - ($p21->[1]-$p11->[1]) * ($p12->[0]-$p11->[0]); 2092 my $Cb = ($p21->[1]-$p11->[1]) * ($p21->[0]-$p22->[0]) - ($p21->[1]-$p22->[1]) * ($p21->[0]-$p11->[0]); 2093 2094 return if $Z == 0; 2095 2096 my $Ua = $Ca / $Z; 2097 my $Ub = $Cb / $Z; 2098 2099 return if $Ua < 0 || $Ua > 1 || $Ub < 0 || $Ub > 1; 2100 2101 return [ $p11->[0] + ( $p12->[0] - $p11->[0] ) * $Ub, 2102 $p11->[1] + ( $p12->[1] - $p11->[1] ) * $Ub ]; 2103} 2104 2105 2106sub FindCity { 2107 return unless keys %city; 2108 my @nodes = map { ref( $_ ) ? [ reverse @$_ ] : [ split q{,}, ( exists $node{$_} ? $node{$_} : $_ ) ] } @_; 2109 2110 my @cities = (); 2111 for my $node ( @nodes ) { 2112 my @res; 2113 $city_rtree->query_point( @$node, \@res ); 2114 @cities = ( @cities, @res ); 2115 } 2116 2117 return first { 2118 my $cbound = $city{$_}->{bound}; 2119 all { $cbound->contains( $_ ) } @nodes; 2120 } uniq @cities; 2121} 2122 2123sub FindSuburb { 2124 return unless keys %suburb; 2125 my @nodes = map { ref( $_ ) ? [ reverse @$_ ] : [ split q{,}, ( exists $node{$_} ? $node{$_} : $_ ) ] } @_; 2126 return first { 2127 my $cbound = $suburb{$_}->{bound}; 2128 all { $cbound->contains( $_ ) } @nodes; 2129 } keys %suburb; 2130} 2131 2132 2133sub AddPOI { 2134 my ($obj) = @_; 2135 if ( $addrfrompoly && exists $obj->{nodeid} && exists $obj->{add_contacts} ) { 2136 my $id = $obj->{nodeid}; 2137 my @bbox = ( reverse split q{,}, $node{$id} ) x 2; 2138 push @{$poi{$id}}, $obj; 2139 $poi_rtree->insert( $id, @bbox ); 2140 } 2141 else { 2142 return WritePOI( @_ ); 2143 } 2144 return; 2145} 2146 2147 2148sub WritePOI { 2149 my %param = %{$_[0]}; 2150 2151 my %tag = exists $param{tags} ? %{$param{tags}} : (); 2152 2153 return unless exists $param{nodeid} || exists $param{latlon}; 2154 2155 my $comment = $param{comment} || q{}; 2156 2157 while ( my ( $key, $val ) = each %tag ) { 2158 next unless exists $config{comment}->{$key} && $yesno{$config{comment}->{$key}}; 2159 $comment .= "\n$key = $val"; 2160 } 2161 2162 my $data = $param{latlon} || $node{$param{nodeid}}; 2163 return unless $data; 2164 2165 my %opts = ( 2166 coords => [ split /\s*,\s*/xms, $data ], 2167 lzoom => $param{level_l} || '0', 2168 hzoom => $param{level_h} || '0', 2169 Type => $param{type}, 2170 ); 2171 2172 my $label = defined $param{name} ? $param{name} : q{}; 2173 2174 if ( exists $param{add_elevation} && exists $tag{'ele'} ) { 2175 $label .= '~[0x1f]' . $tag{'ele'}; 2176 } 2177 if ( $transportstops && exists $param{add_stops} ) { 2178 my @stops; 2179 @stops = ( @{ $trstop{$param{nodeid}} } ) 2180 if exists $param{nodeid} && exists $trstop{$param{nodeid}}; 2181 push @stops, split( /\s*[,;]\s*/, $tag{'route_ref'} ) if exists $tag{'route_ref'}; 2182 @stops = uniq @stops; 2183 $label .= q{ (} . join( q{,}, sort { 2184 my $aa = extract_number($a); 2185 my $bb = extract_number($b); 2186 $aa && $bb ? $aa <=> $bb : $a cmp $b; 2187 } @stops ) . q{)} if @stops; 2188 } 2189 2190 $opts{Label} = convert_string( $label ) if $label; 2191 2192 # region and country - for cities 2193 if ( $poiregion && $label && $param{add_region} && !$param{add_contacts} ) { 2194 my $country = name_from_list( 'country', $param{tags} ); 2195 my $region = name_from_list( 'region', $param{tags} ); 2196 $region .= " $tag{'addr:district'}" if $tag{'addr:district'}; 2197 $region .= " $tag{'addr:subdistrict'}" if $tag{'addr:subdistrict'}; 2198 2199 $region ||= $default_region; 2200 $country ||= $default_country; 2201 2202 $opts{RegionName} = convert_string( $region ) if $region; 2203 $opts{CountryName} = convert_string( $country ) if $country; 2204 } 2205 2206 # contact information: address, phone 2207 if ( $poicontacts && $param{add_contacts} ) { 2208 my $cityid = FindCity( $param{nodeid} || $param{latlon} ); 2209 2210 my $city; 2211 if ( $cityid ) { 2212 $city = $city{ $cityid }; 2213 } 2214 elsif ( $full_karlsruhe && $tag{'addr:city'} ) { 2215 $city = { 2216 name => $tag{'addr:city'}, 2217 region => name_from_list( 'region', \%tag ) || $default_region, 2218 country => name_from_list( 'country', \%tag ) || $default_country, 2219 }; 2220 } 2221 2222 if ( $city ) { 2223 my $region = $city->{region} || $default_region; 2224 my $country = $city->{country} || $default_country; 2225 2226 $opts{CityName} = convert_string( $city->{name} ); 2227 $opts{RegionName} = convert_string( $region ) if $region; 2228 $opts{CountryName} = convert_string( $country ) if $country; 2229 } 2230 elsif ( $default_city ) { 2231 $opts{CityName} = $default_city; 2232 $opts{RegionName} = convert_string( $default_region ) if $default_region; 2233 $opts{CountryName} = convert_string( $default_country ) if $default_country; 2234 } 2235 2236 my $housenumber = $param{housenumber} || name_from_list( 'house', \%tag ); 2237 $opts{HouseNumber} = convert_string( $housenumber ) if $housenumber; 2238 2239 my $street = $param{street} || $tag{'addr:street'} || ( $city ? $city->{name} : $default_city ); 2240 if ( $street ) { 2241 my $suburb = FindSuburb( $param{nodeid} || $param{latlon} ); 2242 $street .= qq{ ($suburb{$suburb}->{name})} if $suburb; 2243 $opts{StreetDesc} = convert_string( $street ); 2244 } 2245 2246 $opts{Zip} = convert_string($tag{'addr:postcode'}) if $tag{'addr:postcode'}; 2247 $opts{Phone} = convert_string($tag{'phone'}) if $tag{'phone'}; 2248 $opts{WebPage} = convert_string($tag{'website'}) if $tag{'website'}; 2249 } 2250 2251 # marine data 2252 my %buoy_color = ( 2253 # Region A 2254 lateral_port => '0x01', 2255 lateral_starboard => '0x02', 2256 lateral_preferred_channel_port => '0x12', 2257 lateral_preferred_channel_starboard => '0x11', 2258 safe_water => '0x10', 2259 cardinal_north => '0x06', 2260 cardinal_south => '0x0D', 2261 cardinal_east => '0x0E', 2262 cardinal_west => '0x0F', 2263 isolated_danger => '0x08', 2264 special_purpose => '0x03', 2265 lateral_port_preferred => '0x12', 2266 lateral_starboad_preferred => '0x11', 2267 ); 2268 my %light_color = ( 2269 unlit => 0, 2270 red => 1, 2271 green => 2, 2272 white => 3, 2273 blue => 4, 2274 yellow => 5, 2275 violet => 6, 2276 amber => 7, 2277 ); 2278 my %light_type = ( 2279 fixed => '0x01', 2280 F => '0x01', 2281 isophase => '0x02', 2282 flashing => '0x03', 2283 Fl => '0x03', 2284 occulting => '0x03', 2285 Occ => '0x03', 2286 Oc => '0x03', 2287 quick => '0x0C', 2288 Q => '0x0C', 2289 # fill 2290 ); 2291 2292 ## Buoys 2293 if ( $marine && $param{add_buoy} ) { 2294 if ( my $buoy_type = ( $tag{'buoy'} or $tag{'beacon'} ) ) { 2295 $opts{FoundationColor} = $buoy_color{$buoy_type}; 2296 } 2297 if ( my $buoy_light = ( $tag{'light:colour'} or $tag{'seamark:light:colour'} ) ) { 2298 $opts{Light} = $light_color{$buoy_light}; 2299 } 2300 if ( my $light_type = ( $tag{'light:character'} or $tag{'seamark:light:character'} ) ) { 2301 ( $light_type ) = split /[\(\. ]/, $light_type; 2302 $opts{LightType} = $light_type{$light_type}; 2303 } 2304 } 2305 2306 ## Lights 2307 if ( $marine && $param{add_light} ) { 2308 my @sectors = 2309 sort { $a->[1] <=> $b->[1] } 2310 grep { $_->[3] } 2311 map { [ split q{:}, $tag{$_} ] } 2312 grep { /seamark:light:\d/ } keys %tag; 2313 my $scount = scalar @sectors; 2314 for my $i ( 0 .. $scount-1 ) { 2315 if ( $sectors[$i]->[2] != $sectors[($i+1) % $scount]->[1] ) { 2316 push @sectors, [ 'unlit', $sectors[$i]->[2], $sectors[($i+1) % $scount]->[1], 0 ]; 2317 } 2318 } 2319 2320 $opts{Light} = join( q{,}, 2321 map { sprintf "(%s,%d,$_->[1])", ($light_color{$_->[0]} or '0'), $_->[3]/10 } 2322 sort { $a->[1] <=> $b->[1] } @sectors 2323 ); 2324 2325 my $light_type = ( $tag{'light:character'} or $tag{'seamark:light:character'} or 'isophase' ); 2326 ( $light_type ) = split /[\(\. ]/, $light_type; 2327 $opts{LightType} = $light_type{$light_type} if $light_type{$light_type}; 2328 2329 for my $sector ( grep { /seamark:light:\d/ } keys %tag ) { 2330 $comment .= "\n$sector -> $tag{$sector}"; 2331 } 2332 } 2333 2334 # other parameters - capital first letter! 2335 for my $key ( keys %param ) { 2336 next unless $key =~ / ^ _* [A-Z] /xms; 2337 delete $opts{$key} and next if !defined $param{$key} || $param{$key} eq q{}; 2338 $opts{$key} = convert_string($param{$key}); 2339 } 2340 2341 output( point => { comment => $comment, opts => \%opts } ); 2342 2343 return; 2344} 2345 2346 2347sub AddBarrier { 2348 my %param = %{$_[0]}; 2349 2350 return unless exists $param{nodeid}; 2351 return unless exists $param{tags}; 2352 2353 my $acc = [ 1,1,1,1,1,1,1,1 ]; 2354 2355 $acc = [ split q{,}, $config{barrier}->{$param{tags}->{'barrier'}} ] 2356 if exists $config{barrier} 2357 && exists $config{barrier}->{$param{tags}->{'barrier'}}; 2358 2359 my @acc = map { 1-$_ } CalcAccessRules( $param{tags}, $acc ); 2360 return if all { $_ } @acc; 2361 2362 $barrier{$param{nodeid}}->{type} = $param{tags}->{'barrier'}; 2363 $barrier{$param{nodeid}}->{param} = join q{,}, @acc 2364 if any { $_ } @acc; 2365 2366 return; 2367} 2368 2369 2370sub CalcAccessRules { 2371 my %tag = %{ $_[0] }; 2372 my @acc = @{ $_[1] }; 2373 2374 return @acc unless exists $config{transport}; 2375 2376 for my $rule ( @{$config{transport}} ) { 2377 next unless exists $tag{$rule->{key}}; 2378 next unless exists $yesno{$tag{$rule->{key}}}; 2379 2380 my $val = 1-$yesno{$tag{$rule->{key}}}; 2381 $val = 1-$val if $rule->{mode} && $rule->{mode} == -1; 2382 2383 my @rule = split q{,}, $rule->{val}; 2384 for my $i ( 0 .. 7 ) { 2385 next unless $rule[$i]; 2386 $acc[$i] = $val; 2387 } 2388 } 2389 2390 return @acc; 2391} 2392 2393 2394sub WriteLine { 2395 2396 my %param = %{$_[0]}; 2397 my %tag = ref $param{tags} ? %{$param{tags}} : (); 2398 2399 return unless $param{chain}; 2400 2401 my %opts = ( 2402 lzoom => $param{level_l} || '0', 2403 hzoom => $param{level_h} || '0', 2404 Type => $param{type}, 2405 ); 2406 2407 my $comment = $param{comment} || q{}; 2408 2409 while ( my ( $key, $val ) = each %tag ) { 2410 next unless exists $config{comment}->{$key} && $yesno{$config{comment}->{$key}}; 2411 $comment .= "\n$key = $val"; 2412 } 2413 2414 $opts{chain} = [ map { [ split /\s*,\s*/xms ] } @node{ @{ $param{chain} } } ]; 2415 2416 $opts{Label} = convert_string( $param{name} ) if defined $param{name} && $param{name} ne q{}; 2417 $opts{RoadID} = $param{roadid} if exists $param{roadid}; 2418 $opts{RouteParams} = $param{routeparams} if exists $param{routeparams}; 2419 2420 for my $nod ( @{$param{nod}} ) { 2421 push @{ $opts{nods} }, [ @$nod[0,1], $$nod[2] || '0' ]; 2422 } 2423 2424 # the rest tags (capitals!) 2425 for my $key ( sort keys %param ) { 2426 next unless $key =~ / ^ _* [A-Z] /xms; 2427 delete $opts{$key} and next if !defined $param{$key} || $param{$key} eq q{}; 2428 $opts{$key} = convert_string( $param{$key} ); 2429 } 2430 2431 output( polyline => { comment => $comment, opts => \%opts } ); 2432 return; 2433} 2434 2435 2436sub AddRoad { 2437 2438 my %param = %{$_[0]}; 2439 my %tag = exists $param{tags} ? %{$param{tags}} : (); 2440 2441 return unless exists $param{chain}; 2442 return unless exists $param{type}; 2443 2444 my ($orig_id) = $param{id} =~ /^([^:]+)/; 2445 2446 my $llev = exists $param{level_l} ? $param{level_l} : 0; 2447 my $hlev = exists $param{level_h} ? $param{level_h} : 0; 2448 2449 my @rp = split q{,}, $param{routeparams}; 2450 @rp[4..11] = CalcAccessRules( \%tag, [ @rp[4..11] ] ); 2451 2452 # determine city 2453 my $city = FindCity( 2454 $param{chain}->[ floor $#{$param{chain}}/3 ], 2455 $param{chain}->[ ceil $#{$param{chain}}*2/3 ] ); 2456 2457 # calculate speed class 2458 my %speed_coef = ( 2459 maxspeed => 0.9, 2460 'maxspeed:practical' => 0.9, 2461 avgspeed => 1, 2462 ); 2463 for my $speed_key ( keys %speed_coef ) { 2464 next unless $tag{$speed_key}; 2465 my $speed = extract_number( $tag{$speed_key} ); 2466 next unless $speed; 2467 $speed *= 1.61 if $tag{$speed_key} =~ /mph$/ixms; 2468 $rp[0] = speed_code( $speed * $speed_coef{$speed_key} ); 2469 } 2470 2471 # navitel-style 3d interchanges 2472 if ( my $layer = $interchange3d && extract_number($waytag{'layer'}) ) { 2473 $layer *= 2 if $layer > 0; 2474 for my $node ( @{$param{chain}} ) { 2475 $hlevel{ $node } = $layer; 2476 } 2477 $layer-- if $layer > 0; 2478 $hlevel{ $param{chain}->[0] } = $layer; 2479 $hlevel{ $param{chain}->[-1] } = $layer; 2480 } 2481 2482 # determine suburb 2483 if ( $city && $param{name} ) { 2484 my $suburb; 2485 if ( exists $tag{'addr:suburb'}) { 2486 $suburb = $tag{'addr:suburb'}; 2487 } 2488 else { 2489 my $sub_ref = FindSuburb( 2490 $param{chain}->[ floor $#{$param{chain}}/3 ], 2491 $param{chain}->[ ceil $#{$param{chain}}*2/3 ] 2492 ); 2493 $suburb = $suburb{$sub_ref}->{name} if $sub_ref; 2494 } 2495 2496 $param{name} .= qq{ ($suburb)} if $suburb; 2497 } 2498 2499 # road shield 2500 if ( $roadshields && !$city ) { 2501 my @ref; 2502 @ref = @{ $road_ref{$orig_id} } if exists $road_ref{$orig_id}; 2503 push @ref, $tag{'ref'} if exists $tag{'ref'}; 2504 push @ref, $tag{'int_ref'} if exists $tag{'int_ref'}; 2505 2506 if ( @ref ) { 2507 my $ref = join q{-}, sort( uniq( map { my $s=$_; $s =~ s/[\s\-]//gx; split /[,;]/, $s } @ref ) ); 2508 $param{name} = '~[0x06]' . $ref . ( $param{name} ? q{ } . $param{name} : q{} ); 2509 } 2510 } 2511 2512 if ( $full_karlsruhe && !$city && $tag{'addr:city'} ) { 2513 $city = { 2514 name => $tag{'addr:city'}, 2515 region => name_from_list( 'region', \%tag ) || $default_region, 2516 country => name_from_list( 'country', \%tag ) || $default_country, 2517 }; 2518 } 2519 2520 # load road 2521 $road{$param{id}} = { 2522 #comment => $param{comment}, 2523 type => $param{type}, 2524 name => $param{name}, 2525 chain => $param{chain}, 2526 level_l => $llev, 2527 level_h => $hlev, 2528 city => $city, 2529 rp => join( q{,}, @rp ), 2530 }; 2531 2532 # FIXME: buggy object comment 2533 while ( my ( $key, $val ) = each %tag ) { 2534 next unless exists $config{comment}->{$key} && $yesno{$config{comment}->{$key}}; 2535 $road{$param{id}}->{comment} .= "\n$key = $tag{$key}"; 2536 } 2537 2538 # the rest object parameters (capitals!) 2539 for my $key ( keys %param ) { 2540 next unless $key =~ /^_*[A-Z]/; 2541 $road{$param{id}}->{$key} = $param{$key}; 2542 } 2543 2544 # external nodes 2545 if ( $bounds ) { 2546 if ( !is_inside_bounds( $node{ $param{chain}->[0] } ) ) { 2547 $xnode{ $param{chain}->[0] } = 1; 2548 $xnode{ $param{chain}->[1] } = 1; 2549 } 2550 if ( !is_inside_bounds( $node{ $param{chain}->[-1] } ) ) { 2551 $xnode{ $param{chain}->[-1] } = 1; 2552 $xnode{ $param{chain}->[-2] } = 1; 2553 } 2554 } 2555 2556 # process associated turn restrictions 2557 if ( $restrictions || $destsigns ) { 2558 2559 for my $relid ( @{$nodetr{$param{chain}->[0]}} ) { 2560 next unless exists $trest{$relid}; 2561 if ( $trest{$relid}->{fr_way} eq $orig_id ) { 2562 $trest{$relid}->{fr_way} = $param{id}; 2563 $trest{$relid}->{fr_dir} = -1; 2564 $trest{$relid}->{fr_pos} = 0; 2565 } 2566 if ( $trest{$relid}->{to_way} eq $orig_id ) { 2567 $trest{$relid}->{to_way} = $param{id}; 2568 $trest{$relid}->{to_dir} = 1; 2569 $trest{$relid}->{to_pos} = 0; 2570 } 2571 } 2572 2573 for my $relid ( @{$nodetr{$param{chain}->[-1]}} ) { 2574 next unless exists $trest{$relid}; 2575 if ( $trest{$relid}->{fr_way} eq $orig_id ) { 2576 $trest{$relid}->{fr_way} = $param{id}; 2577 $trest{$relid}->{fr_dir} = 1; 2578 $trest{$relid}->{fr_pos} = $#{ $param{chain} }; 2579 } 2580 if ( $trest{$relid}->{to_way} eq $orig_id ) { 2581 $trest{$relid}->{to_way} = $param{id}; 2582 $trest{$relid}->{to_dir} = -1; 2583 $trest{$relid}->{to_pos} = $#{ $param{chain} }; 2584 } 2585 } 2586 } 2587 return; 2588} 2589 2590 2591sub WritePolygon { 2592 2593 my %param = %{$_[0]}; 2594 2595 my %tag = $param{tags} ? %{$param{tags}} : (); 2596 2597 return unless $param{areas}; 2598 return unless @{$param{areas}}; 2599 2600 my $comment = $param{comment} || q{}; 2601 my $lzoom = $param{level_l} || '0'; 2602 my $hzoom = $param{level_h} || '0'; 2603 2604 # area-dependent zoomlevel 2605 if ( ref $hzoom ) { 2606 my $square = sum map { Math::Polygon::Calc::polygon_area( @$_ ) 2607 * cos( [polygon_centroid( @{$param{areas}->[0]} )]->[1] / 180 * 3.14159 ) 2608 * (40000/360)**2 } @{$param{areas}}; 2609 $hzoom = $lzoom + last_index { $square >= $_ } @$hzoom; 2610 return if $hzoom < $lzoom; 2611 $param{comment} .= "\narea: $square km2 -> $hzoom"; 2612 } 2613 2614 # test if inside bounds 2615 my @inside = map { $bounds ? $boundtree->contains_polygon_rough( $_ ) : 1 } @{$param{areas}}; 2616 return if all { defined && $_==0 } @inside; 2617 2618 if ( $bounds && $lessgpc && any { !defined } @inside ) { 2619 @inside = map { $boundtree->contains_points( @$_ ) } @{$param{areas}}; 2620 return if all { defined && $_ == 0 } @inside; 2621 } 2622 2623 2624 $param{holes} = [] unless $param{holes}; 2625 my @plist = grep { scalar @$_ > 3 } ( @{$param{areas}}, @{$param{holes}} ); 2626 2627 # TODO: filter bad holes 2628 2629 # clip 2630 if ( $bounds && any { !defined } @inside ) { 2631 my $gpc = new_gpc(); 2632 2633 for my $area ( @{$param{areas}} ) { 2634 $gpc->add_polygon( $area, 0 ); 2635 } 2636 for my $hole ( @{$param{holes}} ) { 2637 $gpc->add_polygon( $hole, 1 ); 2638 } 2639 2640 $gpc = $gpc->clip_to( $boundgpc, 'INTERSECT' ); 2641 @plist = sort { $#{$b} <=> $#{$a} } $gpc->get_polygons(); 2642 } 2643 2644 return unless @plist; 2645 2646 while ( my ( $key, $val ) = each %tag ) { 2647 next unless exists $config{comment}->{$key} && $yesno{$config{comment}->{$key}}; 2648 $comment .= "\n$key = $val"; 2649 } 2650 2651 $countpolygons ++; 2652 2653 my %opts = ( 2654 lzoom => $lzoom || '0', 2655 hzoom => $hzoom || '0', 2656 Type => $param{type}, 2657 ); 2658 2659 $opts{Label} = convert_string( $param{name} ) if defined $param{name} && $param{name} ne q{}; 2660 2661 ## Navitel 2662 if ( $navitel ) { 2663 my $housenumber = name_from_list( 'house', \%tag ); 2664 2665 if ( $housenumber ) { 2666 2667 my $cityid = FindCity( $plist[0]->[0] ); 2668 my $city = $cityid ? $city{$cityid} : undef; 2669 2670 if ( $full_karlsruhe && !$city && $tag{'addr:city'} ) { 2671 $city = { 2672 name => $tag{'addr:city'}, 2673 region => name_from_list( 'region', \%tag ) || $default_region, 2674 country => name_from_list( 'country', \%tag ) || $default_country, 2675 }; 2676 } 2677 2678 my $street = $tag{'addr:street'}; 2679 $street = $street{"way:$wayid"} if exists $street{"way:$wayid"}; 2680 $street //= ( $city ? $city->{name} : $default_city ); 2681 2682 my $suburb = FindSuburb( $plist[0]->[0] ); 2683 $street .= qq{ ($suburb{$suburb}->{name})} if $suburb; 2684 2685 $opts{HouseNumber} = convert_string( $housenumber ); 2686 $opts{StreetDesc} = convert_string( $street ) if defined $street && $street ne q{}; 2687 2688 if ( $city ) { 2689 my $region = $city->{region} || $default_region; 2690 my $country = $city->{country} || $default_country; 2691 2692 $opts{CityName} = convert_string( $city->{name} ); 2693 $opts{RegionName} = convert_string( $region ) if $region; 2694 $opts{CountryName} = convert_string( $country ) if $country; 2695 } 2696 elsif ( $default_city ) { 2697 $opts{CityName} = $default_city; 2698 $opts{RegionName} = convert_string( $default_region ) if $default_region; 2699 $opts{CountryName} = convert_string( $default_country ) if $default_country; 2700 } 2701 } 2702 2703 # entrances 2704 for my $entr ( @{ $param{entrance} } ) { 2705 next unless !$bounds || is_inside_bounds( $entr->[0] ); 2706 push @{$opts{EntryPoint}}, { coords => [ split /\s*,\s*/xms, $entr->[0] ], name => convert_string( $entr->[1] ) }; 2707 } 2708 } 2709 2710 for my $polygon ( @plist ) { 2711 next if @$polygon < 3; 2712 push @{ $opts{contours} }, [ map { [ reverse @{$_} ] } @$polygon ]; 2713 } 2714 2715 ## Rusa - floors 2716 if ( my $levels = $tag{'building:levels'} ) { 2717 $levels =~ s/\D.*//x; 2718 $opts{Floors} = 0 + $levels; 2719 } 2720 if ( my $height = $tag{'building:height'} // $tag{'height'} ) { 2721 $height =~ s/\D.*//x; 2722 $opts{Floors} = 3 * $height; 2723 } 2724 2725 for my $key ( keys %param ) { 2726 next unless $key =~ /^_*[A-Z]/; 2727 delete $opts{$key} and next if !defined $param{$key} || $param{$key} eq q{}; 2728 $opts{$key} = convert_string( $param{$key} ); 2729 } 2730 2731 output( polygon => { comment => $comment, opts => \%opts } ); 2732 2733 return; 2734} 2735 2736 2737 2738 2739#### Config processing 2740 2741sub condition_matches { 2742 2743 my ($condition, $obj) = @_; 2744 2745 2746 # hash-based 2747 if ( ref $condition ) { 2748 # precompiled tag match 2749 if ( exists $condition->{tag} ) { 2750 my $result = exists $obj->{tag}->{ $condition->{tag} } 2751 && ( !$condition->{re} 2752 || any { $_ =~ $condition->{re} } split( /\s*;\s*/xms, $obj->{tag}->{ $condition->{tag} } ) ); 2753 return( $result xor $condition->{neg} ); 2754 } 2755 # or 2756 elsif ( exists $condition->{or} ) { 2757 return any { condition_matches( $_, $obj ) } @{ $condition->{or} }; 2758 } 2759 # and 2760 elsif ( exists $condition->{and} ) { 2761 return all { condition_matches( $_, $obj ) } @{ $condition->{and} }; 2762 } 2763 } 2764 2765 # tag =/!= value or * 2766 if ( my ($key, $neg, $val) = $condition =~ m/ (\S+) \s* (!?) = \s* (.+) /xms ) { 2767 $_[0] = { 2768 tag => $key, 2769 neg => $neg, 2770 re => ( $val eq q{*} ? q{} : qr/^(?:$val)$/xms ), 2771 }; 2772 return &condition_matches; 2773 } 2774 2775 2776 # inside_city (smart) 2777 if ( my ($neg) = $condition =~ /(~?)\s*inside_city/ ) { 2778 my $res; 2779 if ( $obj->{type} eq 'Node' ) { 2780 $res = FindCity( $obj->{id} ); 2781 } 2782 elsif ( exists $obj->{latlon} ) { 2783 $res = FindCity( $obj->{latlon} ); 2784 } 2785 elsif ( $obj->{type} eq 'Way' && exists $obj->{chain} ) { 2786 $res = FindCity( $obj->{chain}->[ floor $#{$obj->{chain}}/3 ] ) 2787 && FindCity( $obj->{chain}->[ ceil $#{$obj->{chain}}*2/3 ] ); 2788 } 2789 return( $neg xor $res ); 2790 } 2791 2792 # named 2793 if ( my ($neg) = $condition =~ /(~?)\s*named/ ) { 2794 return( $neg xor name_from_list( 'label', $obj->{tag} )); 2795 } 2796 2797 # only_way etc 2798 if ( my ( $type ) = $condition =~ 'only_(\w+)' ) { 2799 return (uc $obj->{type}) eq (uc $type); 2800 } 2801 2802 # no_way etc 2803 if ( my ( $type ) = $condition =~ 'no_(\w+)' ) { 2804 return (uc $obj->{type}) ne (uc $type); 2805 } 2806 return; 2807} 2808 2809 2810sub execute_action { 2811 2812 my ($action, $obj, $condition) = @_; 2813 2814 my %param = %{ $action }; 2815 2816 $param{name} //= '%label'; 2817 for my $key ( keys %param ) { 2818 next unless defined $param{$key}; 2819 $param{$key} =~ s[%(\w+)][ name_from_list( $1, $obj->{tag} ) // q{} ]ge; 2820 } 2821 2822 $param{region} .= q{ }. $obj->{tag}->{'addr:district'} 2823 if exists $param{region} && exists $obj->{tag}->{'addr:district'}; 2824 2825 my %objinfo = map { $_ => $param{$_} } grep { /^_*[A-Z]/ } keys %param; 2826 2827 ## Load area as city 2828 if ( $param{action} eq 'load_city' ) { 2829 2830 if ( !$param{name} ) { 2831 report( "City without name $obj->{type}ID=$obj->{id}" ); 2832 } 2833 elsif ( $obj->{outer}->[0]->[0] ne $obj->{outer}->[0]->[-1] ) { 2834 report( "City polygon $obj->{type}ID=$obj->{id} is not closed" ); 2835 } 2836 else { 2837 report( sprintf( "Found city: $obj->{type}ID=$obj->{id} - %s [ %s, %s ]", 2838 convert_string( $param{name}), 2839 convert_string( $param{country} ), 2840 convert_string( $param{region} ) ), 'INFO' ); 2841 my $cityid = $obj->{type} . $obj->{id}; 2842 $city{ $cityid } = { 2843 name => $param{name}, 2844 region => $param{region}, 2845 country => $param{country}, 2846 bound => Math::Polygon::Tree->new( 2847 map { [ map { [ split q{,}, $node{$_} ] } @$_ ] } @{ $obj->{outer} } 2848 ), 2849 }; 2850 $city_rtree->insert( $cityid, ( Math::Polygon::Tree::polygon_bbox( 2851 map { map { [ split q{,}, $node{$_} ] } @$_ } @{ $obj->{outer} } 2852 ) ) ); 2853 } 2854 } 2855 2856 ## Load area as suburb 2857 if ( $param{action} eq 'load_suburb' ) { 2858 2859 if ( !$param{name} ) { 2860 report( "Suburb without name $obj->{type}ID=$obj->{id}" ); 2861 } 2862 elsif ( $obj->{outer}->[0]->[0] ne $obj->{outer}->[0]->[-1] ) { 2863 report( "Suburb polygon $obj->{type}ID=$obj->{id} is not closed" ); 2864 } 2865 else { 2866 report( sprintf( "Found suburb: $obj->{type}ID=$obj->{id} - %s", convert_string( $param{name} ) ), 'INFO' ); 2867 $suburb{ $obj->{type} . $obj->{id} } = { 2868 name => $param{name}, 2869 bound => Math::Polygon::Tree->new( 2870 map { [ map { [ split q{,}, $node{$_} ] } @$_ ] } @{ $obj->{outer} } 2871 ), 2872 }; 2873 2874 } 2875 } 2876 2877 ## Load interpolation nodes 2878 if ( $addrinterpolation && $param{action} eq 'load_interpolation' ) { 2879 @interpolation_node{ @{ $obj->{outer}->[0] } } = undef; 2880 } 2881 2882 ## Create interpolated objects 2883 if ( $addrinterpolation && $param{action} eq 'process_interpolation' ) { 2884 2885 my @chain = grep { defined $interpolation_node{$_} && exists $interpolation_node{$_}->{'addr:housenumber'} } @{ $obj->{chain} }; 2886 2887 if ( @chain >= 2 ) { 2888 2889 my $new_action = { %$action, action => 'write_poi' }; 2890 2891 for my $i ( 0 .. $#chain-1 ) { 2892 my ( $node1, $node2 ) = @chain[ $i, $i+1 ]; 2893 my ( $house1, $house2 ) = map { my $x = $interpolation_node{$_}->{'addr:housenumber'}; $x =~ s/^(\d+).*/$1/x; $x } ( $node1, $node2 ); 2894 2895 next if $house1 == $house2; 2896 2897 my %tag = ( %{$interpolation_node{$node2}}, %{$interpolation_node{$node1}}, %{$obj->{tag}} ); 2898 2899 my $step = ( $tag{'addr:interpolation'} eq 'all' ? 1 : 2 ); 2900 if ( $house1 > $house2 ) { $step *= -1 } 2901 2902 my ($lat1, $lon1) = split q{,}, $node{$node1}; 2903 my ($lat2, $lon2) = split q{,}, $node{$node2}; 2904 2905 my $steplat = ($lat2-$lat1) / ($house2-$house1); 2906 my $steplon = ($lon2-$lon1) / ($house2-$house1); 2907 2908 for my $j ( 0 .. ($house2-$house1)/$step ) { 2909 2910 next if $i > 0 && $j == 0; 2911 2912 my $chouse = $house1 + $step * $j; 2913 my $clat = $lat1 + $steplat * $j * $step; 2914 my $clon = $lon1 + $steplon * $j * $step; 2915 2916 my $new_obj = { 2917 id => $obj->{id}, 2918 type => 'Way', 2919 latlon => join( q{,}, $clat, $clon ), 2920 tag => { %tag, 'addr:housenumber' => $chouse, }, 2921 }; 2922 2923 execute_action( $new_action, $new_obj, $condition ); 2924 } 2925 } 2926 } 2927 else { 2928 report( "Wrong interpolation on WayID=$obj->{id}" ); 2929 } 2930 } 2931 2932 ## Write POI 2933 if ( $param{action} eq 'write_poi' ) { 2934 my %tag = %{ $obj->{tag} }; 2935 2936 return unless !$bounds 2937 || $obj->{type} eq 'Node' && is_inside_bounds( $node{$obj->{id}} ) 2938 || exists $obj->{latlon} && is_inside_bounds( $obj->{latlon} ); 2939 #return if exists $tag{'layer'} && $tag{'layer'} < -1; 2940 2941 $countpoi ++; 2942 2943 %objinfo = ( %objinfo, ( 2944 type => $action->{type}, 2945 name => $param{name}, 2946 tags => \%tag, 2947 comment => "$obj->{type}ID = $obj->{id}", 2948 )); 2949 2950 $objinfo{nodeid} = $obj->{id} if $obj->{type} eq 'Node'; 2951 $objinfo{latlon} = $obj->{latlon} if exists $obj->{latlon}; 2952 $objinfo{level_l} = $action->{level_l} if exists $action->{level_l}; 2953 $objinfo{level_h} = $action->{level_h} if exists $action->{level_h}; 2954 2955 if ( exists $action->{'city'} ) { 2956 $objinfo{City} = 'Y'; 2957 $objinfo{add_region} = 1; 2958 } 2959 if ( exists $action->{'transport'} ) { 2960 $objinfo{add_stops} = 1; 2961 } 2962 if ( exists $action->{'contacts'} ) { 2963 $objinfo{add_contacts} = 1; 2964 } 2965 if ( exists $action->{'marine_buoy'} ) { 2966 $objinfo{add_buoy} = 1; 2967 } 2968 if ( exists $action->{'marine_light'} ) { 2969 $objinfo{add_light} = 1; 2970 } 2971 if ( exists $action->{'ele'} ) { 2972 $objinfo{add_elevation} = 1; 2973 } 2974 2975 AddPOI ( \%objinfo ); 2976 } 2977 2978 ## Load coastline 2979 if ( $param{action} eq 'load_coastline' && $shorelines ) { 2980 for my $part ( @{ $obj->{clist} } ) { 2981 my ($start, $finish) = @$part; 2982 $coast{$obj->{chain}->[$start]} = [ @{$obj->{chain}}[ $start .. $finish ] ]; 2983 } 2984 } 2985 2986 ## Write line or load road 2987 if ( $param{action} ~~ [ qw{ write_line load_road modify_road } ] ) { 2988 2989 %objinfo = ( %objinfo, ( 2990 type => $action->{type}, 2991 name => $param{name}, 2992 tags => $obj->{tag}, 2993 comment => "$obj->{type}ID = $obj->{id}", 2994 )); 2995 2996 for my $option ( qw{ level_l level_h routeparams } ) { 2997 next unless exists $action->{$option}; 2998 $objinfo{$option} = $action->{$option}; 2999 } 3000 3001 my $part_no = 0; 3002 for my $part ( @{ $obj->{clist} } ) { 3003 my ($start, $finish) = @$part; 3004 3005 $objinfo{chain} = [ @{$obj->{chain}}[ $start .. $finish ] ]; 3006 $objinfo{id} = "$obj->{id}:$part_no"; 3007 $part_no ++; 3008 3009 if ( $routing && $param{action} eq 'load_road' ) { 3010 AddRoad( \%objinfo ); 3011 } 3012 elsif ( $routing && $param{action} eq 'modify_road' && exists $road{ $objinfo{id} } ) { 3013 # reverse 3014 if ( exists $action->{reverse} ) { 3015 $road{ $objinfo{id} }->{chain} = [ reverse @{ $road{ $objinfo{id} }->{chain} } ]; 3016 } 3017 # routeparams 3018 if ( exists $action->{routeparams} ) { 3019 my @rp = split q{,}, $road{ $objinfo{id} }->{rp}; 3020 my @mrp = split q{,}, $action->{routeparams}; 3021 for my $p ( @rp ) { 3022 my $mp = shift @mrp; 3023 $p = $mp if $mp =~ /^\d$/; 3024 $p = 1-$p if $mp eq q{~}; 3025 $p = $p+$1 if $p < 4 && $mp =~ /^\+(\d)$/; 3026 $p = $p-$1 if $p > 0 && $mp =~ /^\-(\d)$/; 3027 } 3028 $road{ $objinfo{id} }->{rp} = join q{,}, @rp; 3029 } 3030 # the rest - just copy 3031 for my $key ( keys %objinfo ) { 3032 next unless $key =~ /^_*[A-Z]/ or any { $key eq $_ } qw{ type level_l level_h }; 3033 next unless defined $objinfo{$key}; 3034 $road{ $objinfo{id} }->{$key} = $objinfo{$key}; 3035 } 3036 } 3037 elsif ( $param{action} ne 'modify_road' ) { 3038 $countlines ++; 3039 WriteLine( \%objinfo ); 3040 } 3041 } 3042 } 3043 3044 ## Write polygon 3045 if ( $param{action} eq 'write_polygon' ) { 3046 3047 %objinfo = ( %objinfo, ( 3048 type => $action->{type}, 3049 name => $param{name}, 3050 tags => $obj->{tag}, 3051 comment => "$obj->{type}ID = $obj->{id}", 3052 )); 3053 3054 $objinfo{level_l} = $action->{level_l} if exists $action->{level_l}; 3055 $objinfo{level_h} = $action->{level_h} if exists $action->{level_h}; 3056 3057 $objinfo{areas} = $obj->{areas} if exists $obj->{areas}; 3058 $objinfo{holes} = $obj->{holes} if exists $obj->{holes}; 3059 3060 if ( $obj->{type} eq 'Way' ) { 3061 if ( $obj->{chain}->[0] ne $obj->{chain}->[-1] ) { 3062 report( "Area WayID=$obj->{id} is not closed at ($node{$obj->{chain}->[0]})" ); 3063 return; 3064 } 3065 3066 $objinfo{areas} = [ [ map { [reverse split q{,}, $node{$_}] } @{$obj->{chain}} ] ]; 3067 if ( $mpoly{$obj->{id}} ) { 3068 $objinfo{comment} .= sprintf "\nmultipolygon with %d holes", scalar @{$mpoly{$obj->{id}}}; 3069 for my $hole ( grep { exists $waychain{$_} } @{$mpoly{$obj->{id}}} ) { 3070 push @{$objinfo{holes}}, [ map { [reverse split q{,}, $node{$_}] } @{$waychain{$hole}} ]; 3071 } 3072 } 3073 3074 $objinfo{entrance} = [ map { [ $node{$_}, $entrance{$_} ] } grep { exists $entrance{$_} } @{$obj->{chain}} ]; 3075 } 3076 3077 WritePolygon( \%objinfo ); 3078 } 3079 3080 ## Address loaded POI 3081 if ( $param{action} eq 'address_poi' && exists $obj->{chain} && $obj->{chain}->[0] eq $obj->{chain}->[-1] && exists $poi_rtree->{root} ) { 3082 3083 my @bbox = Math::Polygon::Calc::polygon_bbox( map {[ reverse split q{,}, $node{$_} ]} @{$obj->{chain}} ); 3084 my @poilist; 3085 3086 $poi_rtree->query_completely_within_rect( @bbox, \@poilist ); 3087 3088 for my $id ( @poilist ) { 3089 next unless exists $poi{$id}; 3090 next unless Math::Polygon::Tree::polygon_contains_point( 3091 [ reverse split q{,}, $node{$id} ], 3092 map {[ reverse split q{,}, $node{$_} ]} @{$obj->{chain}} 3093 ); 3094 3095 my %tag = %{ $obj->{tag} }; 3096 my $housenumber = name_from_list( 'house', \%tag ); 3097 my $street = $tag{'addr:street'}; 3098 $street = $street{"way:$wayid"} if exists $street{"way:$wayid"}; 3099 3100 for my $poiobj ( @{ $poi{$id} } ) { 3101 $poiobj->{street} = $street; 3102 $poiobj->{housenumber} = $housenumber; 3103 WritePOI( $poiobj ); 3104 } 3105 3106 delete $poi{$id}; 3107 } 3108 } 3109 return; 3110} 3111 3112 3113sub process_config { 3114 3115 my ($cfg, $obj) = @_; 3116 3117 CFG: 3118 for my $cfg_item ( @$cfg ) { 3119 3120 CONDITION: 3121 for my $cfg_condition ( @{ $cfg_item->{condition} } ) { 3122 next CFG unless condition_matches( $cfg_condition, $obj ); 3123 } 3124 3125 ACTION: 3126 for my $cfg_action ( @{ $cfg_item->{action} } ) { 3127 execute_action( $cfg_action, $obj, $cfg_item->{condition} ); 3128 } 3129 } 3130 return; 3131} 3132 3133 3134sub merge_ampoly { 3135 my ($mpid) = @_; 3136 my $mp = $ampoly{$mpid}; 3137 3138 my %res; 3139 3140 for my $contour_type ( 'outer', 'inner' ) { 3141 3142 my $list_ref = $mp->{$contour_type}; 3143 my @list = grep { exists $waychain{$_} } @$list_ref; 3144 3145 LIST: 3146 while ( @list ) { 3147 3148 my $id = shift @list; 3149 my @contour = @{$waychain{$id}}; 3150 3151 CONTOUR: 3152 while ( 1 ) { 3153 # closed way 3154 if ( $contour[0] eq $contour[-1] ) { 3155 push @{$res{$contour_type}}, [ @contour ]; 3156 next LIST; 3157 } 3158 3159 my $add = first_index { $contour[-1] eq $waychain{$_}->[0] } @list; 3160 if ( $add > -1 ) { 3161 $id .= ":$list[$add]"; 3162 pop @contour; 3163 push @contour, @{$waychain{$list[$add]}}; 3164 3165 splice @list, $add, 1; 3166 next CONTOUR; 3167 } 3168 3169 $add = first_index { $contour[-1] eq $waychain{$_}->[-1] } @list; 3170 if ( $add > -1 ) { 3171 $id .= ":r$list[$add]"; 3172 pop @contour; 3173 push @contour, reverse @{$waychain{$list[$add]}}; 3174 3175 splice @list, $add, 1; 3176 next CONTOUR; 3177 } 3178 3179 report( "Multipolygon's RelID=$mpid part WayID=$id is not closed", 3180 ( all { exists $waychain{$_} } @$list_ref ) ? 'ERROR' : 'WARNING' ); 3181 last CONTOUR; 3182 } 3183 } 3184 } 3185 3186 return \%res; 3187} 3188 3189 3190sub report { 3191 my ( $msg, $type ) = @_; 3192 $type ||= 'ERROR'; 3193 output( info => { text => "$type: $msg" } ); 3194 return; 3195} 3196 3197 3198sub print_section { 3199 my ($title) = @_; 3200 output( section => { text => "### $title" } ); 3201 return; 3202} 3203 3204 3205sub output { 3206 my ( $template, $data ) = @_; 3207 my $group = $multiout && $output_fn ? $data->{$multiout} || $data->{opts}->{$multiout} || q{} : q{}; 3208 unless( $out->{$group} ) { 3209 my $fn = $output_fn; 3210 $fn =~ s/ (?<= . ) ( \. .* $ | $ ) /.$group$1/xms if $group; 3211 open $out->{$group}, ">:$binmode", $fn; 3212 print {$out->{$group}} $ttc->process( header => { opts => $mp_opts, ($multiout // q{}) => $group, version => $VERSION } ); 3213 } 3214 3215 print {$out->{$group}} $ttc->process( $template => $data ); 3216} 3217 3218 3219sub extract_number { 3220 my $str = shift; 3221 return unless defined $str; 3222 my ($number) = $str =~ /^ ( [-+]? \d+ ) /x; 3223 return $number; 3224} 3225 3226__END__ 3227 3228sub merge_polygon_chains { 3229 3230 my @c1 = @{$_[0]}; 3231 my @c2 = @{$_[1]}; 3232 3233 my %seg = map { join( q{:}, sort ( $c1[$_], $c1[$_+1] ) ) => $_ } ( 0 .. $#c1 - 1 ); 3234 3235 for my $j ( 0 .. scalar $#c2 - 1 ) { 3236 my $seg = join( q{:}, sort ( $c2[$j], $c2[$j+1] ) ); 3237 if ( exists $seg{$seg} ) { 3238 my $i = $seg{$seg}; 3239 3240 pop @c1; 3241 @c1 = @c1[ $i+1 .. $#c1, 0 .. $i ] if $i < $#c1; 3242 @c1 = reverse @c1 if $c1[0] ne $c2[$j]; 3243 3244 # merge 3245 splice @c2, $j, 2, @c1; 3246 pop @c2; 3247 3248 # remove jitters 3249 $i = 0; 3250 JITTER: 3251 while ( $i <= $#c2 ) { 3252 if ( $c2[$i] eq $c2[($i+1) % scalar @c2] ) { 3253 splice @c2, $i, 1; 3254 $i-- if $i > 0; 3255 redo JITTER; 3256 } 3257 if ( $c2[$i] eq $c2[($i+2) % scalar @c2] ) { 3258 splice @c2, ($i+1) % scalar @c2, 1; 3259 $i-- if $i > $#c2; 3260 splice @c2, $i, 1; 3261 $i-- if $i > 0; 3262 redo JITTER; 3263 } 3264 $i++; 3265 } 3266 push @c2, $c2[0]; 3267 return \@c2; 3268 } 3269 } 3270 return; 3271} 3272 3273 3274