add experimental (and unreferenced) train intersection calculation

2 files changed, 393 insertions, 35 deletions

diff --git a/lib/DBInfoscreen.pm b/lib/DBInfoscreen.pm
index e49ce70..83b7103 100644
--- a/lib/DBInfoscreen.pm
+++ b/lib/DBInfoscreen.pm
@@ -317,6 +317,7 @@ sub startup {
 
 	$r->get('/_ajax_mapinfo/:tripid/:lineno')->to('map#ajax_route');
 	$r->get('/map/:tripid/:lineno')->to('map#route');
+	$r->get('/intersection/:trips')->to('map#intersection');
 
 	$self->defaults( layout => 'app' );
 
diff --git a/lib/DBInfoscreen/Controller/Map.pm b/lib/DBInfoscreen/Controller/Map.pm
index 91aefe6..4497a4a 100644
--- a/lib/DBInfoscreen/Controller/Map.pm
+++ b/lib/DBInfoscreen/Controller/Map.pm
@@ -7,6 +7,7 @@ use Mojo::Promise;
 use DateTime;
 use DateTime::Format::Strptime;
 use Geo::Distance;
+use List::Util qw();
 
 my $dbf_version = qx{git describe --dirty} || 'experimental';
 
@@ -75,6 +76,110 @@ sub get_hafas_polyline_p {
 	return $promise;
 }
 
+sub get_route_indexes {
+	my ( $features, $from_name, $to_name ) = @_;
+	my ( $from_index, $to_index );
+
+	for my $i ( 0 .. $#{$features} ) {
+		my $this_point = $features->[$i];
+		if (    not defined $from_index
+			and $this_point->{properties}{type}
+			and $this_point->{properties}{type} eq 'stop'
+			and $this_point->{properties}{name} eq $from_name )
+		{
+			$from_index = $i;
+		}
+		elsif ( $this_point->{properties}{type}
+			and $this_point->{properties}{type} eq 'stop'
+			and $this_point->{properties}{name} eq $to_name )
+		{
+			$to_index = $i;
+			last;
+		}
+	}
+	return ( $from_index, $to_index );
+}
+
+# Returns timestamped train positions between stop1 and stop2 (must not have
+# intermittent stops) in 10-second steps.
+sub estimate_timestamped_positions {
+	my (%opt) = @_;
+
+	my $from_dt   = $opt{from}{dep};
+	my $to_dt     = $opt{to}{arr};
+	my $from_name = $opt{from}{name};
+	my $to_name   = $opt{to}{name};
+	my $features  = $opt{features};
+
+	my $duration = $to_dt->epoch - $from_dt->epoch;
+
+	my @train_positions;
+
+	my @completion_ratios
+	  = map { ( $_ * 10 / $duration ) } ( 0 .. $duration / 10 );
+
+	my ( $from_index, $to_index )
+	  = get_route_indexes( $features, $from_name, $to_name );
+
+	my $location_epoch = $from_dt->epoch;
+	my $geo            = Geo::Distance->new;
+
+	if ( defined $from_index and defined $to_index ) {
+		my $total_distance = 0;
+		for my $j ( $from_index + 1 .. $to_index ) {
+			my $prev = $features->[ $j - 1 ]{geometry}{coordinates};
+			my $this = $features->[$j]{geometry}{coordinates};
+			if ( $prev and $this ) {
+				$total_distance += $geo->distance(
+					'kilometer', $prev->[0], $prev->[1],
+					$this->[0],  $this->[1]
+				);
+			}
+		}
+		my @marker_distances = map { $total_distance * $_ } @completion_ratios;
+		$total_distance = 0;
+		for my $j ( $from_index + 1 .. $to_index ) {
+			my $prev = $features->[ $j - 1 ]{geometry}{coordinates};
+			my $this = $features->[$j]{geometry}{coordinates};
+			if ( $prev and $this ) {
+				my $prev_distance = $total_distance;
+				$total_distance += $geo->distance(
+					'kilometer', $prev->[0], $prev->[1],
+					$this->[0],  $this->[1]
+				);
+				for my $i ( @train_positions .. $#marker_distances ) {
+					my $marker_distance = $marker_distances[$i];
+					if ( $total_distance > $marker_distance ) {
+
+						# completion ratio for the line between (prev, this)
+						my $sub_ratio = 1;
+						if ( $total_distance != $prev_distance ) {
+							$sub_ratio = ( $marker_distance - $prev_distance )
+							  / ( $total_distance - $prev_distance );
+						}
+
+						my $lat = $prev->[1]
+						  + ( $this->[1] - $prev->[1] ) * $sub_ratio;
+						my $lon = $prev->[0]
+						  + ( $this->[0] - $prev->[0] ) * $sub_ratio;
+
+						push( @train_positions,
+							[ $location_epoch, $lat, $lon ] );
+						$location_epoch += 10;
+					}
+				}
+				if ( @train_positions == @completion_ratios ) {
+					return @train_positions;
+				}
+			}
+		}
+		if (@train_positions) {
+			return @train_positions;
+		}
+	}
+	return;
+}
+
 # Input:
 #   now: DateTime
 #   from: current/previous stop
@@ -107,25 +212,10 @@ sub estimate_train_positions {
 	  = map { ( $time_complete + ( $_ * 2 ) ) / $time_total } ( 0 .. 45 );
 
 	my $geo = Geo::Distance->new;
-	my ( $from_index, $to_index );
 
-	for my $j ( 0 .. $#{$features} ) {
-		my $this_point = $features->[$j];
-		if (    not defined $from_index
-			and $this_point->{properties}{type}
-			and $this_point->{properties}{type} eq 'stop'
-			and $this_point->{properties}{name} eq $from_name )
-		{
-			$from_index = $j;
-		}
-		elsif ( $this_point->{properties}{type}
-			and $this_point->{properties}{type} eq 'stop'
-			and $this_point->{properties}{name} eq $to_name )
-		{
-			$to_index = $j;
-			last;
-		}
-	}
+	my ( $from_index, $to_index )
+	  = get_route_indexes( $features, $from_name, $to_name );
+
 	if ( defined $from_index and defined $to_index ) {
 		my $total_distance = 0;
 		for my $j ( $from_index + 1 .. $to_index ) {
@@ -259,6 +349,145 @@ sub estimate_train_positions2 {
 	};
 }
 
+sub estimate_train_intersection {
+	my (%opt) = @_;
+	my @route1 = @{ $opt{routes}[0] // [] };
+	my @route2 = @{ $opt{routes}[1] // [] };
+
+	my $ret;
+
+	my $i1 = 0;
+	my $i2 = 0;
+
+	my @pairs;
+	my @meeting_points;
+	my $geo = Geo::Distance->new;
+
+	# skip last route element as we compare route[i] with route[i+1]
+	while ( $i1 < $#route1 and $i2 < $#route2 ) {
+		my $dep1 = $route1[$i1]{dep};
+		my $arr1 = $route1[ $i1 + 1 ]{arr};
+		my $dep2 = $route2[$i2]{dep};
+		my $arr2 = $route2[ $i2 + 1 ]{arr};
+
+		if ( not( $dep1 and $arr1 ) ) {
+			say "skip 1 $route1[$i1]{name}";
+			$i1++;
+			next;
+		}
+
+		if ( not( $dep2 and $arr2 ) ) {
+			say "skip 2 $route2[$i2]{name}";
+			$i2++;
+			next;
+		}
+
+		if ( $arr1 <= $dep2 ) {
+			$i1++;
+		}
+		elsif ( $arr2 <= $dep1 ) {
+			$i2++;
+		}
+		elsif ( $arr2 <= $arr1 ) {
+			push( @pairs, [ $i1, $i2 ] );
+			if (    $route1[$i1]{name} eq $route2[ $i2 + 1 ]{name}
+				and $route2[$i2]{name} eq $route1[ $i1 + 1 ]{name} )
+			{
+              # both i1 name == i2+1 name and i1 name == i2 name are valid cases
+              # (trains don't just intersect when they travel in opposing
+              # directions -- they may also travel in the same direction
+              # with different speed and overtake each other).
+              # We need both stop pairs later on, so we save both.
+				$ret->{stop_pair} = [
+					[ $route1[$i1]{name}, $route1[ $i1 + 1 ]{name} ],
+					[ $route2[$i2]{name}, $route2[ $i2 + 1 ]{name} ]
+				];
+			}
+			$i2++;
+		}
+		elsif ( $arr1 <= $arr2 ) {
+			push( @pairs, [ $i1, $i2 ] );
+			if (    $route1[$i1]{name} eq $route2[ $i2 + 1 ]{name}
+				and $route2[$i2]{name} eq $route1[ $i1 + 1 ]{name} )
+			{
+				$ret->{stop_pair} = [
+					[ $route1[$i1]{name}, $route1[ $i1 + 1 ]{name} ],
+					[ $route2[$i2]{name}, $route2[ $i2 + 1 ]{name} ]
+				];
+			}
+			$i1++;
+		}
+		else {
+			$i1++;
+		}
+	}
+
+	for my $pair (@pairs) {
+		my ( $i1, $i2 ) = @{$pair};
+		my @train1_positions = estimate_timestamped_positions(
+			from     => $route1[$i1],
+			to       => $route1[ $i1 + 1 ],
+			features => $opt{features}[0],
+		);
+		my @train2_positions = estimate_timestamped_positions(
+			from     => $route2[$i2],
+			to       => $route2[ $i2 + 1 ],
+			features => $opt{features}[1],
+		);
+		$i1 = 0;
+		$i2 = 0;
+		while ( $i1 <= $#train1_positions and $i2 <= $#train2_positions ) {
+			if ( $train1_positions[$i1][0] < $train2_positions[$i2][0] ) {
+				$i1++;
+			}
+			elsif ( $train1_positions[$i2][0] < $train2_positions[$i2][0] ) {
+				$i2++;
+			}
+			else {
+				if (
+					(
+						my $distance = $geo->distance(
+							'kilometer',
+							$train1_positions[$i1][2],
+							$train1_positions[$i1][1],
+							$train2_positions[$i2][2],
+							$train2_positions[$i2][1]
+						)
+					) < 1
+				  )
+				{
+					my $ts = DateTime->from_epoch(
+						epoch     => $train1_positions[$i1][0],
+						time_zone => 'Europe/Berlin'
+					);
+					$ret->{first_meeting_time} //= $ts;
+					push(
+						@meeting_points,
+						{
+							timestamp => $ts,
+							lat       => (
+								    $train1_positions[$i1][1]
+								  + $train2_positions[$i2][1]
+							) / 2,
+							lon => (
+								    $train1_positions[$i1][2]
+								  + $train2_positions[$i2][2]
+							) / 2,
+							distance => $distance,
+						}
+					);
+				}
+				$i1++;
+				$i2++;
+			}
+		}
+	}
+
+	$ret->{meeting_points} = \@meeting_points;
+
+	return $ret;
+}
+
 sub route_to_ajax {
 	my (@stopovers) = @_;
 
@@ -348,6 +577,145 @@ sub stopovers_to_route {
 	return @route;
 }
 
+sub polyline_to_line_pairs {
+	my (@polyline) = @_;
+	my @line_pairs;
+	for my $i ( 1 .. $#polyline ) {
+		push(
+			@line_pairs,
+			[
+				[ $polyline[ $i - 1 ][1], $polyline[ $i - 1 ][0] ],
+				[ $polyline[$i][1],       $polyline[$i][0] ]
+			]
+		);
+	}
+	return @line_pairs;
+}
+
+sub intersection {
+	my ($self) = @_;
+
+	my @trips    = split( qr{;}, $self->stash('trips') );
+	my @trip_ids = map { [ split( qr{,}, $_ ) ] } @trips;
+
+	$self->render_later;
+
+	my @polyline_requests
+	  = map { $self->get_hafas_polyline_p( @{$_} ) } @trip_ids;
+	Mojo::Promise->all(@polyline_requests)->then(
+		sub {
+			my ( $pl1, $pl2 ) = map { $_->[0] } @_;
+			my @polyline1 = @{ $pl1->{polyline} };
+			my @polyline2 = @{ $pl2->{polyline} };
+			my @station_coordinates;
+
+			my @markers;
+			my $next_stop;
+
+			my $now = DateTime->now( time_zone => 'Europe/Berlin' );
+
+			my @line1_pairs = polyline_to_line_pairs(@polyline1);
+			my @line2_pairs = polyline_to_line_pairs(@polyline2);
+
+			my @route1
+			  = stopovers_to_route( @{ $pl1->{raw}{stopovers} // [] } );
+			my @route2
+			  = stopovers_to_route( @{ $pl2->{raw}{stopovers} // [] } );
+
+			my $train1_pos = estimate_train_positions2(
+				now      => $now,
+				route    => \@route1,
+				features => $pl1->{raw}{polyline}{features},
+			);
+
+			my $train2_pos = estimate_train_positions2(
+				now      => $now,
+				route    => \@route2,
+				features => $pl2->{raw}{polyline}{features},
+			);
+
+			my $intersection = estimate_train_intersection(
+				routes   => [ \@route1, \@route2 ],
+				features => [
+					$pl1->{raw}{polyline}{features},
+					$pl2->{raw}{polyline}{features}
+				],
+			);
+
+			for my $meeting_point ( @{ $intersection->{meeting_points} } ) {
+				push(
+					@station_coordinates,
+					[
+						[ $meeting_point->{lat}, $meeting_point->{lon} ],
+						[ $meeting_point->{timestamp}->strftime('%H:%M') ]
+					]
+				);
+			}
+
+			push(
+				@markers,
+				{
+					lat   => $train1_pos->{position_now}[0],
+					lon   => $train1_pos->{position_now}[1],
+					title => $pl1->{name}
+				},
+				{
+					lat   => $train2_pos->{position_now}[0],
+					lon   => $train2_pos->{position_now}[1],
+					title => $pl2->{name}
+				},
+			);
+
+			$self->render(
+				'route_map',
+				title        => "DBF",
+				hide_opts    => 1,
+				with_map     => 1,
+				intersection => 1,
+				train1_no =>
+				  scalar( $pl1->{raw}{line}{additionalName} // $pl1->{name} ),
+				train2_no =>
+				  scalar( $pl2->{raw}{line}{additionalName} // $pl2->{name} ),
+				likely_pair => $intersection->{stop_pair}
+				? $intersection->{stop_pair}[0]
+				: undef,
+				time            => scalar $intersection->{first_meeting_time},
+				polyline_groups => [
+					{
+						polylines  => [ @line1_pairs, @line2_pairs ],
+						color      => '#ffffff',
+						opacity    => 0,
+						fit_bounds => 1,
+					},
+					{
+						polylines => [@line1_pairs],
+						color     => '#005080',
+						opacity   => 0.6,
+					},
+					{
+						polylines => [@line2_pairs],
+						color     => '#800050',
+						opacity   => 0.6,
+					}
+				],
+				markers             => [@markers],
+				station_coordinates => [@station_coordinates],
+			);
+		}
+	)->catch(
+		sub {
+			my ($err) = @_;
+			$self->render(
+				'route_map',
+				title     => "DBF",
+				hide_opts => 1,
+				with_map  => 1,
+				error     => $err,
+			);
+		}
+	)->wait;
+}
+
 sub route {
 	my ($self)  = @_;
 	my $trip_id = $self->stash('tripid');
@@ -363,7 +731,6 @@ sub route {
 			my ($pl) = @_;
 
 			my @polyline = @{ $pl->{polyline} };
-			my @line_pairs;
 			my @station_coordinates;
 
 			my @markers;
@@ -371,16 +738,8 @@ sub route {
 
 			my $now = DateTime->now( time_zone => 'Europe/Berlin' );
 
-			# @line_pairs are used to draw the train's journey on the map
-			for my $i ( 1 .. $#polyline ) {
-				push(
-					@line_pairs,
-					[
-						[ $polyline[ $i - 1 ][1], $polyline[ $i - 1 ][0] ],
-						[ $polyline[$i][1],       $polyline[$i][0] ]
-					]
-				);
-			}
+			# used to draw the train's journey on the map
+			my @line_pairs = polyline_to_line_pairs(@polyline);
 
 			my @route = stopovers_to_route( @{ $pl->{raw}{stopovers} // [] } );
 
@@ -490,12 +849,10 @@ sub route {
 			my ($err) = @_;
 			$self->render(
 				'route_map',
-				title       => "DBF",
-				hide_opts   => 1,
-				with_map    => 1,
-				error       => $err,
-				origin      => undef,
-				destination => undef,
+				title     => "DBF",
+				hide_opts => 1,
+				with_map  => 1,
+				error     => $err,
 			);
 
 		}