source: subversion/applications/utils/gary68/mwRelations.pm @ 34621

Last change on this file since 34621 was 28786, checked in by gary68, 7 years ago

verion 0.40 - fixed some errors

File size: 9.7 KB
Line 
1#
2# PERL mapweaver module by gary68
3#
4#
5#
6#
7# Copyright (C) 2011, Gerhard Schwanz
8#
9# This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the
10# Free Software Foundation; either version 3 of the License, or (at your option) any later version.
11#
12# This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13# FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
14#
15# You should have received a copy of the GNU General Public License along with this program; if not, see <http://www.gnu.org/licenses/>
16#
17
18
19package mwRelations ; 
20
21use strict ;
22use warnings ;
23
24use mwMap ;
25use mwRules ;
26use mwFile ;
27use mwMisc ;
28use mwLabel ;
29use mwConfig ;
30
31use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
32
33require Exporter ;
34
35@ISA = qw ( Exporter AutoLoader ) ;
36
37@EXPORT = qw ( processRoutes
38
39                 ) ;
40
41my $pathNumber = 0 ;
42
43my %iconSizeX = () ;
44my %iconSizeY = () ;
45
46
47# --------------------------------------------------------------------------
48
49sub processRoutes {
50#
51# process route data
52#
53        my %routeColors = () ; # will point to arrays of colors per route type
54        my %actualColorIndex = () ; # which color is next
55        my %colorNumber = () ; # number of colors per route type
56        my %wayRouteLabels = () ; # labels to be used per way
57        my %wayRouteIcons = () ; # icons to be used per way
58        my (%iconSizeX, %iconSizeY) ;
59
60        print "processing routes...\n" ;
61
62        # init before relation processing
63        # get colors per type and set actual index
64
65        my $ref = getRouteColors() ;
66        %routeColors = %$ref ;
67        foreach my $type (keys %routeColors) {
68                $colorNumber{$type} = scalar @{$routeColors{$type}} ;
69                $actualColorIndex{$type} = 0 ;
70        }
71
72        my ($lonRef, $latRef) = getNodePointers() ;
73        my ($wayNodesRef, $wayTagsRef) = getWayPointers() ;
74        my ($relationMembersRef, $relationTagsRef) = getRelationPointers() ;
75
76        foreach my $relId (keys %$relationTagsRef) {
77                my $relationType = getValue ("type", $$relationTagsRef{$relId} ) ;
78                if ( ! defined $relationType ) { $relationType = "" ; }
79
80                if ( ( $relationType eq "route" ) and ( (cv('relid') == $relId) or (cv('relid') == 0) ) ) {
81
82                        my $ruleRef = getRouteRule( $$relationTagsRef{$relId} ) ;
83
84                        if (defined $ruleRef) {
85
86                                # new route detected
87                                if (cv('debug') eq "1" ) { print "ROUTE: rule found for $relId, $$ruleRef{'type'}.\n" ; }
88
89                                # try to get color from relation tags first
90                                #
91                                my $color = getValue ("color", $$relationTagsRef{$relId} ) ;
92                                if ( ! defined $color) {
93                                        $color = getValue ("colour", $$relationTagsRef{$relId} ) ;
94                                }
95
96                                # no color yet, then get color from rule
97                                #
98                                if ( ! defined $color) { 
99                                        if (cv('debug') eq "1" ) { print "ROUTE:   actual color index: $actualColorIndex{ $$ruleRef{'type'} }\n" ; }
100                                        $color = $routeColors{ $$ruleRef{'type'} }[$actualColorIndex{ $$ruleRef{'type'} }] ; 
101                                        $actualColorIndex{ $$ruleRef{'type'} } = ($actualColorIndex{ $$ruleRef{'type'} } + 1) % $colorNumber{ $$ruleRef{'type'} } ;
102                                }
103                                if (cv('debug') eq "1" ) { print "ROUTE:   $relId final color: $color\n" ; }
104
105                                # find icon
106                                my $iconName = getValue ("ref", $$relationTagsRef{$relId} ) ;
107                                if ( ! defined $iconName ) {
108                                        getValue ("name", $$relationTagsRef{$relId} )
109                                }
110                                if ( ! defined $iconName) { $iconName = "" ; }
111
112                                # look for route icon. svg first, then png
113
114                                my $file ;
115                                $iconName = cv('routeicondir') . $$ruleRef{'type'} . "-" . $iconName . ".svg" ;
116                                my $iconResult = open ($file, "<", $iconName) ;
117                                # print "  trying $iconName\n" ;
118                                if ($iconResult) { 
119                                        if (cv('debug') eq "1") { print "ROUTE:   icon $iconName found!\n" ; }
120                                        close ($file) ;
121                                } 
122
123                                if ( ! $iconResult) {
124                                        $iconName =~ s/.svg/.png/ ; 
125                                        # print "  trying $iconName\n" ;
126                                        $iconResult = open ($file, "<", $iconName) ;
127                                        if ($iconResult) { 
128                                                if (cv('debug') eq "1") { print "ROUTE:   icon $iconName found!\n" ; }
129                                                close ($file) ;
130                                        } 
131                                }
132
133                                if ($iconResult) {
134                                        my ($x, $y) ; undef $x ; undef $y ;
135                                        if (grep /.svg/, $iconName) {
136                                                ($x, $y) = sizeSVG ($iconName) ;
137                                                if ( ($x == 0) or ($y == 0) ) { 
138                                                        $x = 32 ; $y = 32 ; 
139                                                        print "WARNING: size of file $iconName could not be determined. Set to 32px x 32px\n" ;
140                                                } 
141                                        }
142
143                                        if (grep /.png/, $iconName) {
144                                                ($x, $y) = sizePNG ($iconName) ;
145                                        }
146
147                                        $iconSizeX{$iconName} = $x ;
148                                        $iconSizeY{$iconName} = $y ;
149                                }
150
151                                my ($label, $ref) = createLabel ( $$relationTagsRef{$relId}, $$ruleRef{'label'} ) ;
152
153                                my $printIcon = "" ; if ($iconResult) { $printIcon = $iconName ; }
154                                       
155                                if (cv('verbose') eq "1" ) { 
156                                        printf "ROUTE: route %10s %10s %10s %30s %40s\n", $relId, $$ruleRef{'type'}, $color, $label, $printIcon ; 
157                                }
158
159                                # collect ways
160
161                                my $mRef = getAllMembers ($relId, 0) ;
162                                my @tempMembers = @$mRef ;
163
164                                my @relWays = () ;
165                                foreach my $member (@tempMembers) {
166                                        if ( ( ($member->[2] eq "none") or ($member->[2] eq "route") ) and ($member->[0] eq "way") ) { push @relWays, $member->[1] ; }
167                                        if ( ( ($member->[2] eq "forward") or ($member->[2] eq "backward") ) and ($member->[0] eq "way") ) { push @relWays, $member->[1] ; }
168
169                                        # TODO diversions, shortcuts?
170
171                                        # stops
172                                        if ( (grep /stop/, $member->[2]) and ($member->[0] eq "node") ) {
173                                                if ( ( $$ruleRef{'nodesize'} > 0) and (defined $$latRef{$member->[1]}) and (defined $$lonRef{$member->[1]}) ) {
174                                                        my $svgString = "fill=\"$color\" " ;
175                                                        drawCircle ($$lonRef{$member->[1]}, $$latRef{$member->[1]}, 1, $$ruleRef{'nodesize'}, 0, $svgString, 'routes') ;
176                                                }
177                                        }
178                                }
179
180                                if (cv('debug') eq "1" ) { print "ROUTE:   ways: @relWays\n" ; }
181
182                                foreach my $w (@relWays) {
183
184                                        my $op = $$ruleRef{'opacity'} / 100 ;
185                                        my $width = $$ruleRef{'size'} ;
186                                        my $linecap = $$ruleRef{'linecap'} ;
187                                        my $dashString = "" ;
188                                        my $dash = $$ruleRef{'dash'} ;
189                                        if ( $dash ne "") { $dashString = "stroke-dasharray=\"$dash\" " ; }
190                                        my $svgString = "stroke=\"$color\" stroke-opacity=\"$op\" stroke-width=\"$width\" fill=\"none\" stroke-linejoin=\"round\" stroke-linecap=\"$linecap\" " . $dashString ;
191
192                                        drawWay ($$wayNodesRef{$w}, 1, $svgString, "routes", undef) ;
193
194                                        # collect labels and icons per way
195                                        #
196                                        $wayRouteLabels{$w}{$label} = 1 ;
197                                        if ($iconResult) {                                             
198                                                $wayRouteIcons{$w}{$iconName} = 1 ;
199                                        }
200                                }
201
202                        } # rule found
203                        if (cv('debug') eq "1") { print "\n" ; }
204                } # rel route
205        } # relation
206
207        # label route ways after all relations have been processed
208        foreach my $w (keys %wayRouteLabels) {
209                if ( (defined $$wayNodesRef{$w}) and (scalar @{$$wayNodesRef{$w}} > 1) ) {
210                        my $label = "" ;
211                        foreach my $l (keys %{$wayRouteLabels{$w}}) {
212                                $label .= $l . " " ;
213                        } 
214
215                        my @way = @{$$wayNodesRef{$w}} ;
216                        if ($$lonRef{$way[0]} > $$lonRef{$way[-1]}) {
217                                @way = reverse (@way) ;
218                        }
219
220                        if (labelFitsWay ( \@way, $label, cv('routelabelfont'), cv('routelabelsize') ) ) {
221                                my $pathName = "RoutePath" . $pathNumber ; 
222                                $pathNumber++ ;
223
224                                my @points = nodes2Coordinates( @way ) ;
225
226                                if ( ! coordsOut (@points) ) {
227
228                                        createPath ($pathName, \@points, "definitions") ;
229
230                                        my $size = cv('routelabelsize') ;
231                                        my $font = cv('routelabelfont') ;
232                                        my $fontFamily = cv('routelabelfontfamily') ;
233                                        my $color = cv('routelabelcolor') ;
234
235                                        my $svgText = createTextSVG ( $fontFamily, $font, $size, $color, undef, undef) ;
236                                        pathText ($svgText, $label, $pathName, cv('routelabeloffset'), "middle", 50, "routes") ;
237                                }
238                        }
239                }
240        }
241
242        # place icons
243        foreach my $w (keys %wayRouteIcons) {
244                my $offset = 0 ;
245                my $nodeNumber = scalar @{$$wayNodesRef{$w}} ;
246                if ($nodeNumber > 1) {
247                        my $node = $$wayNodesRef{$w}[int ($nodeNumber / 2)] ;
248                        my $num = scalar (keys %{$wayRouteIcons{$w}}) ;
249                        $offset = int (-($num-1)* cv('routeicondist') / 2) ; 
250
251                        foreach my $iconName (keys %{$wayRouteIcons{$w}}) {
252
253                                my $size = 40 ;
254                                placeLabelAndIcon ($$lonRef{$node}, $$latRef{$node}, $offset, $size, "", "", $iconName, $iconSizeX{$iconName}, $iconSizeY{$iconName}, "routes") ;
255
256                                $offset += cv('routeicondist') ;
257                        }
258                }
259        }
260}
261
262# --------------------------------------------------------------------------
263
264sub getAllMembers {
265#
266# get all members of a relation recursively
267# takes rel id and nesting level
268# retruns ref to array with all members
269#
270        my ($relId, $nestingLevel) = @_ ;
271        my @allMembers = () ;
272        my $maxNestingLevel = 20 ;
273
274        my ($relationMembersRef, $relationTagsRef) = getRelationPointers() ;
275
276        if ($nestingLevel > $maxNestingLevel) { 
277                print "ERROR/WARNING nesting level of relations too deep. recursion stopped at depth $maxNestingLevel! relId=$relId\n" ;
278        }
279        else {
280                foreach my $member ( @{$$relationMembersRef{$relId}} ) {
281                        if ( ($member->[0] eq "way") or ($member->[0] eq "node") ) {
282                                push @allMembers, $member ;
283                        }
284                        if ( $member->[0] eq "relation" ) {
285                                my $ref = getAllMembers ($member->[1], $nestingLevel+1) ;
286                                push @allMembers, @$ref ;
287                        }
288                }       
289        }
290        return \@allMembers ;
291}
292
293sub labelFitsWay {
294        my ($refWayNodes, $text, $font, $size) = @_ ;
295        my @wayNodes = @$refWayNodes ;
296
297        my ($lonRef, $latRef) = getNodePointers() ;
298
299        # calc waylen
300        my $wayLength = 0 ; # in pixels
301        for (my $i=0; $i<$#wayNodes; $i++) {
302                my ($x1, $y1) = convert ($$lonRef{$wayNodes[$i]}, $$latRef{$wayNodes[$i]}) ;
303                my ($x2, $y2) = convert ($$lonRef{$wayNodes[$i+1]}, $$latRef{$wayNodes[$i+1]}) ;
304                $wayLength += sqrt ( ($x2-$x1)**2 + ($y2-$y1)**2 ) ;
305        }
306
307
308        # calc label len
309        my $labelLength = length ($text) * cv('ppc') / 10 * $size ; # in pixels
310
311        my $fit ;
312        if ($labelLength < $wayLength) { $fit="fit" ; } else { $fit = "NOFIT" ; }
313        # print "labelFitsWay: $fit, $text, labelLen = $labelLength, wayLen = $wayLength\n" ;
314
315        if ($labelLength < $wayLength) {
316                return 1 ;
317        }
318        else {
319                return 0 ;
320        }
321}
322
323
3241 ;
325
326
Note: See TracBrowser for help on using the repository browser.