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/\&amp\;/\&/gi;
1863    $str =~ s/\&apos\;/\'/gi;
1864    $str =~ s/\&quot\;/\"/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