1# -*- perl -*-
2
3#
4# Author: Slaven Rezic
5#
6# Copyright (C) 1998,2000,2001,2012 Slaven Rezic. All rights reserved.
7# This package is free software; you can redistribute it and/or
8# modify it under the same terms as Perl itself.
9#
10# Mail: slaven@rezic.de
11# WWW:  http://bbbike.sourceforge.net/
12#
13
14package Route;
15
16use strict;
17#use AutoLoader 'AUTOLOAD';
18
19use vars qw($coords_ref $realcoords_ref $search_route_points_ref
20	    @EXPORT @ISA $VERSION);
21
22$VERSION = sprintf("%d.%02d", q$Revision: 1.27 $ =~ /(\d+)\.(\d+)/);
23
24require Exporter;
25@ISA    = qw(Exporter);
26@EXPORT = qw(POINT_SEARCH POINT_MANUELL);
27
28use constant POINT_SEARCH  => 'a';
29use constant POINT_MANUELL => 'm';
30
31use BBBikeUtil qw(sqr);
32
33sub new {
34    my $class = shift;
35    if (@_ == 1 && $_[0]->isa('Route')) {
36	my $new;
37	require Data::Dumper;
38	eval Data::Dumper->Dumpxs([$_[0]], ['new']);
39	die $@ if $@;
40	return $new;
41    } else {
42	my %args = @_;
43	bless \%args, $class;
44    }
45}
46
47# $realcoords_ref is [[x,y], [x,y], ...]
48sub new_from_realcoords {
49    my $class = shift;
50    my $realcoords_ref = shift;
51    my $obj = $class->new;
52    $obj->{Path} = [ @$realcoords_ref ];
53    $obj->{From} = join ",", @{$obj->{Path}[0]};
54    $obj->{To}   = join ",", @{$obj->{Path}[-1]};
55
56    require Strassen::Util;
57    my $len = 0;
58    for my $i (0 .. $#$realcoords_ref-1) {
59	$len += Strassen::Util::strecke($realcoords_ref->[$i],
60					$realcoords_ref->[$i+1]);
61    }
62    $obj->{Len} = $len;
63
64    $obj;
65}
66
67sub concat {
68    my(@r) = @_;
69    my %args;
70    while (@r && !$r[0]) {
71	shift @r;
72    }
73    while (@r && !$r[$#r]) {
74	pop @r;
75    }
76    if (!@r) {
77	return Route->new;
78    }
79
80    $args{From}       = $r[0]->from;
81    $args{To}         = $r[$#r]->to;
82    $args{Via}        = [];
83    $args{Len}        = 0;
84    $args{Penalty}    = 0;
85    $args{Path}       = [];
86    $args{PathCanvas} = [];
87    $args{Ampeln}     = undef;
88    $args{Transpose}  = $r[0]->transpose;
89    for(my $i = 0; $i <= $#r; $i++) {
90	my @p = $r[$i]->path_list;
91	if ($i > 0) {
92	    my $first = shift @p;
93	    push @{$args{Via}}, $first; # XXX check on correctness
94	}
95	$args{Len}     += $r[$i]->len;
96	$args{Penalty} += $r[$i]->penalty;
97	push @{$args{Path}}, @p;
98	my $ampeln = $r[$i]->ampeln;
99	if (defined $ampeln) {
100	    $args{Ampeln} += $ampeln;
101	}
102	if (defined $r[$i]->path_canvas) {
103	    push @{$args{PathCanvas}}, $r[$i]->path_canvas_list;
104	}
105    }
106    Route->new(%args);
107}
108
109sub from             { $_[0]->{From} }
110sub to               { $_[0]->{To}   }
111sub via              { $_[0]->{Via}  }
112sub via_list         { @{$_[0]->{Via}}  }
113sub len              { $_[0]->{Len}  }
114sub penalty          { $_[0]->{Penalty}  }
115# Path in der Form: [[x1,y1], [x2,y2], ...]
116sub path             { $_[0]->{Path} }
117sub path_list        { $_[0]->{Path} ? @{$_[0]->{Path}} : () }
118# Path in der Form: ["x1,y1", "x2,y2", ...]
119sub path_s           { [ map { _coord_as_string($_) } @{$_[0]->{Path}} ] }
120sub path_s_list      { $_[0]->{Path} ? map { _coord_as_string($_) } @{$_[0]->{Path}} : () }
121# Path in Canvas-Koordinaten
122sub path_canvas      { $_[0]->{PathCanvas} }
123sub path_canvas_list { @{$_[0]->{PathCanvas}} }
124sub is_empty         { !defined $_[0]->{Path} || scalar $_[0]->{Path} == 0 }
125sub ampeln           { $_[0]->{Ampeln} } # XXX deprecated...
126sub trafficlights    { $_[0]->{Ampeln} }
127sub coord_system     { $_[0]->{CoordSystem} || 'Standard' }
128sub transpose        { $_[0]->{Transpose} }
129sub nearest_node     { $_[0]->{NearestNode} }
130sub set_nearest_node { $_[0]->{NearestNode} = $_[1] }
131sub set_to           { $_[0]->{To} = $_[1] }
132
133# erstellt eine String-Repr�sentation der Route: x1,y1;x2,y2;...
134sub as_string        { $_[0]->_as_string(";") }
135sub as_cgi_string    { $_[0]->_as_string("!") } # ; ist schlecht bei CGI.pm
136
137sub new_from_cgi_string {
138    my($class, $cgi_string) = @_;
139    $class->new_from_realcoords([ map { [ split /,/ ] } split(/!/, $cgi_string) ]);
140}
141
142sub _as_string {
143    my($self, $sep) = @_;
144    my $route_ref = $self->path;
145    my @res;
146    for(my $i = 0; $i <= $#{$route_ref}; $i++) {
147	push(@res, "$route_ref->[$i][0],$route_ref->[$i][1]");
148    }
149    join($sep, @res);
150}
151
152# einfacher R�ckweg (ohne neue Suche)
153sub rueckweg {
154    my $self = shift;
155    @{$self->{Path}}       = reverse @{$self->{Path}};
156    @{$self->{PathCanvas}} = reverse @{$self->{PathCanvas}};
157    @{$self->{Via}}        = reverse @{$self->{Via}};
158    my $swap      = $self->{From};
159    $self->{From} = $self->{To};
160    $self->{To}   = $swap;
161}
162
163sub add {
164    my($self, $x, $y, $cx, $cy, $as_via) = @_;
165    my $xy = [$x, $y];
166    push @{$self->{Path}}, $xy;
167    push @{$self->{PathCanvas}}, [$cx, $cy]
168	if defined $cx;
169    if ($as_via) {
170	push @{$self->{Via}}, $xy;
171    }
172    $self->{Ampeln} += 0; # XXX
173    if (!defined $self->{From}) {
174	$self->{From} = _coord_as_string($xy);
175    } else {
176	$self->{Len} += _strecke($self->{Path}[$#{$self->{Path}}-1], $xy);
177	# XXX penalty fehlt
178    }
179    $self->{To} = _coord_as_string($xy);
180}
181
182sub dellast {
183    my $self = shift;
184    my $popped = pop @{$self->{Path}};
185    pop @{$self->{PathCanvas}};
186    if ($popped eq $self->{Via}[$#{$self->{Via}}]) { # XXX?
187	pop @{$self->{Via}};
188    }
189    $self->{To} = _coord_as_string($self->{Path}[$#{$self->{Path}}]);
190    if (!@{$self->{Path}}) {
191	$self->{From} = undef;
192	# XXX check on empty Via and PathCanvas
193    }
194    if (@{$self->{Path}}) {
195	$self->{Len} -= _strecke($self->{Path}[$#{$self->{Path}}], $popped);
196	# XXX penalty fehlt
197    }
198    $self->{Ampeln} -= 0; # XXX
199}
200
201sub reset {
202    my $self = shift;
203    $self->{Path}       = [];
204    $self->{PathCanvas} = [];
205    $self->{Via}        = [];
206    $self->{From}       = undef;
207    $self->{To}         = undef;
208    $self->{Len}        = 0;
209    $self->{Penalty}    = 0;
210    $self->{Ampeln}     = 0;
211}
212
213# Simplify the given $route, with the help of a StrassenNetz object
214# to level
215#     0: just copy
216#     1: return Route only with points with different street names
217#     2: return Route only with points with different angles
218sub simplify {
219    my($orig_route, $net, $level) = @_;
220    if ($level == 0) { # just copy
221	new Route $orig_route;
222    } else {
223	require Strassen;
224	my $route = new Route;
225	my @route_list = $net->route_to_name($orig_route->path);
226	if ($level == 1) {
227	    my $last_name;
228	    my $n = 0;
229	    foreach my $e (@route_list) {
230		if (defined $last_name &&
231		    $last_name eq $e->[&StrassenNetz::ROUTE_NAME]) {
232		    if ($n == $#route_list) {
233			$route->add(@{$orig_route->path->[$e->[&StrassenNetz::ROUTE_ARRAYINX][1]]})
234		    } else {
235			next;
236		    }
237		}
238		$route->add(@{$orig_route->path->[$e->[&StrassenNetz::ROUTE_ARRAYINX][0]]})
239	    } continue {
240		$n++;
241	    }
242	} else { # level == 2
243	    my $n = 0;
244	    foreach my $e (@route_list) {
245		if ($e->[&StrassenNetz::ROUTE_ANGLE] >= 30 || $n == $#route_list) {
246		    $route->add(@{$orig_route->path->[$e->[&StrassenNetz::ROUTE_ARRAYINX][0]]})
247		}
248	    } continue {
249		$n++;
250	    }
251	}
252
253	$route;
254    }
255}
256
257# Simplify the route to contain max. $max points.
258# Return a path list (like the path_list method).
259sub path_list_max {
260    my($self, $net, $max) = @_;
261    my $best_route;
262    foreach my $level (1 .. 2) {
263	my $new_route = $self->simplify($net, $level);
264	if ($new_route->path_list <= $max) {
265	    return $new_route->path_list;
266	} elsif (!defined $best_route ||
267		 $new_route->path_list < $best_route->path_list) {
268	    $best_route = $new_route;
269	}
270    }
271    return $best_route->path_list;
272}
273
274sub add_trafficlights {
275    my $self = shift;
276    my $net  = shift; # ampel-Net
277    return unless defined $net;
278    my $ampeln = 0;
279    foreach my $xy (@{ $self->path_s }) {
280	$ampeln++ if (exists $net->{$xy});
281    }
282    $self->{Ampeln} = $ampeln;
283}
284
285sub scale {
286    my($self, $scalefactor) = @_;
287    foreach (@{$self->{PathCanvas}}) {
288	$_->[0] *= $scalefactor;
289	$_->[1] *= $scalefactor;
290    }
291}
292
293# Argument: [x1,y1], [x2, y2]
294sub _strecke {
295    CORE::sqrt(sqr($_[0]->[0] - $_[1]->[0]) +
296	       sqr($_[0]->[1] - $_[1]->[1]));
297}
298
299# Return "x,y"
300sub _coord_as_string {
301    my $coord = shift;
302    "$coord->[0],$coord->[1]";
303}
304
305# $new_coord_system ist der Modulnamen-Teil nach Karte::
306sub change_coord_system {
307    my($self, $new_coord_system) = @_;
308    require Karte;
309    eval q{require Karte::} . $self->coord_system;
310    eval q{require Karte::} . $new_coord_system;
311    my $from_obj = eval q{$Karte::} . $self->coord_system . q{::obj};
312    my $to_obj   = eval q{$Karte::} . $new_coord_system . q{::obj};
313    foreach (@{$self->{PathCanvas}}) {
314	($_->[0], $_->[1]) = $from_obj->map2map($to_obj, @$_);
315    }
316    $self->{CoordSystem} = $new_coord_system;
317    # XXX transpose �ndern?!
318}
319
320sub make_path_canvas {
321    my $self = shift;
322    die if !defined $self->transpose;
323    $self->{PathCanvas} = [];
324    foreach ($self->path_list) {
325	push @{$self->{PathCanvas}}, [$self->transpose(@$_)];
326    }
327}
328
329sub make_new {
330    my $self = shift;
331    if (@{$self->{Path}}) {
332	$self->{From} = _coord_as_string($self->{Path}[0]);
333	$self->{To}   = _coord_as_string($self->{Path}{$#{$self->{Path}}});
334    }
335    $self->make_path_canvas;
336    $self->{Len} = 0;
337    $self->{Penalty} = 0;
338    my $i;
339    for($i = 1; $i <= $#{$self->{Path}}; $i++) {
340	$self->{Len} += _strecke($self->{Path}[$i-1],
341				 $self->{Path}[$i]);
342	# XXX Penalty fehlt!
343	$self->{Ampeln}+=0; #  XXX, auch ab 0 anfangen!
344    }
345}
346
347# L�dt eine Route ein und gibt @realcoords heraus.
348sub load {
349    my $file    = shift;
350    my $context = shift;
351    my(%args)   = @_;
352
353    my @realcoords;
354    my @search_route_points;
355
356    my $ret;
357
358    my $matching_type;
359
360    TRY: {
361	my %gps_args = (-fuzzy => $args{-fuzzy});
362	require GPS;
363	foreach my $gps (GPS->all()) {
364	    my $check = 0;
365	    eval {
366		warn "Magic check for $gps...\n" if ($main::verbose && $main::verbose >= 2);
367		my $mod = GPS->preload($gps);
368		if ($mod->check($file, %gps_args)) {
369		    warn "Trying $mod...\n" if ($main::verbose);
370		    $context->{ResetRoute}->() if $context->{ResetRoute};
371		    @realcoords = $mod->convert_to_route($file, %gps_args);
372		    $check = 1;
373		}
374	    }; warn $@ if $@;
375	    if ($check) {
376		$matching_type = $gps;
377		last TRY;
378	    }
379	}
380
381	open my $F, $file
382	    or die "Die Datei $file kann nicht ge�ffnet werden: $!";
383	my $line = <$F>;
384
385	my $check_sub = sub {
386	    my $no_do = shift;
387
388	    if ($line =~ /^[^\t]*\t\S+ .*\d,[-+]?\d/) { # prefixe werden nicht erkannt
389		# eine Strassen-Datei
390		$ret = {
391			IsStrFile => 1,
392			Type => "bbd",
393		       };
394		return;
395	    } elsif (!$no_do) {
396		undef $coords_ref;
397		undef $realcoords_ref;
398		undef $search_route_points_ref;
399
400		require Safe;
401		my $compartment = new Safe;
402		$compartment->share(qw($realcoords_ref
403				       $coords_ref
404				       $search_route_points_ref
405				      ));
406		# XXX Ugly hack following: somehow Devel::Cover and
407		# Safe don't play well together. So I simply turn off
408		# Safe.pm if Devel::Cover usage is detected...
409		if ($Devel::Cover::VERSION) {
410		    do $file;
411		} else {
412		    $compartment->rdo($file);
413		}
414
415		die "Die Datei <$file> enth�lt keine Route."
416		    if (!defined $realcoords_ref);
417
418		$context->{ResetRoute}->() if $context->{ResetRoute};
419		@realcoords = @$realcoords_ref;
420		if (defined $coords_ref) {
421		    warn "Achtung: <$file> enth�lt altes Routen-Format.\n".
422			"Koordinaten k�nnen verschoben sein!\n";
423		}
424		if (defined $search_route_points_ref) {
425		    @search_route_points = @$search_route_points_ref;
426		} else {
427		    @search_route_points =
428			([join(",",@{ $realcoords[0] }), POINT_MANUELL],
429			 [join(",",@{ $realcoords[-1] }), POINT_MANUELL]);
430		}
431
432		$matching_type = "bbr";
433	    } elsif ($no_do) {
434		die;
435	    }
436	};
437
438	if ($args{'-fuzzy'}) {
439	    eval {
440		$check_sub->();
441	    };
442	    if ($@) {
443		while(<$F>) {
444		    $line = $_;
445		    eval {
446			$check_sub->('nodo');
447		    };
448		    last if (!$@ || $ret);
449		}
450	    }
451	} else {
452	    $check_sub->();
453	}
454
455	close $F;
456    }
457
458    if ($ret) {
459	return $ret;
460    }
461
462    +{
463      RealCoords        => \@realcoords,
464      SearchRoutePoints => \@search_route_points,
465      Type              => $matching_type,
466     };
467}
468
469sub save {
470    my(%args) = @_;
471    my $obj = delete $args{-object}; # the same as the return value of load
472    if ($obj) {
473	$args{-realcoords} = $obj->{RealCoords};
474	$args{-searchroutepoints} = $obj->{SearchRoutePoints};
475    }
476    die "-file?"       if !$args{-file};
477    die "-realcoords?" if !$args{-realcoords};
478    $args{-searchroutepoints} = [] if !$args{-searchroutepoints};
479
480    my $SAVE;
481    if (!open($SAVE, ">$args{-file}")) {
482	die "Die Datei <$args{-file}> kann nicht geschrieben werden ($!)\n";
483    }
484    print $SAVE "#BBBike route\n";
485    eval {
486	require Data::Dumper;
487	$Data::Dumper::Indent = 0;
488	print $SAVE Data::Dumper->Dump([$args{-realcoords},
489				       $args{-searchroutepoints},
490				      ],
491				      ['realcoords_ref',
492				       'search_route_points_ref',
493				      ]);
494    };
495    if ($@) {
496	print $SAVE
497	    "$realcoords_ref = [",
498		join(",", map { "[".join(",", @$_)."]" }
499		          @{ $args{-realcoords} }),
500	     "];\n",
501	     "$search_route_points_ref = [",
502		 join(",", map { "[".join(",", @$_)."]" }
503		          @{ $args{-searchroutepoints} }),
504	     "];\n";
505    }
506    close $SAVE;
507}
508
5091;
510