diff options
| -rw-r--r-- | Build.PL | 1 | ||||
| -rw-r--r-- | README | 1 | ||||
| -rw-r--r-- | lib/Travel/Status/DE/IRIS/Stations.pm | 25 |
3 files changed, 27 insertions, 0 deletions
@@ -25,6 +25,7 @@ Module::Build->new( 'DateTime' => 0, 'DateTime::Format::Strptime' => 0, 'Encode' => 0, + 'Geo::Distance' => 0, 'Getopt::Long' => 0, 'List::Compare' => '0.29', 'List::MoreUtils' => 0, @@ -11,6 +11,7 @@ Dependencies * Class::Accessor * DateTime * DateTime::Format::Strptime +* Geo::Distance * List::Compare * List::MoreUtils * List::UtilsBy diff --git a/lib/Travel/Status/DE/IRIS/Stations.pm b/lib/Travel/Status/DE/IRIS/Stations.pm index c9863ac..54245ca 100644 --- a/lib/Travel/Status/DE/IRIS/Stations.pm +++ b/lib/Travel/Status/DE/IRIS/Stations.pm @@ -5,11 +5,16 @@ use warnings; use 5.014; use utf8; +use Geo::Distance; use List::Util qw(min); use List::UtilsBy qw(uniq_by); use List::MoreUtils qw(firstval pairwise); use Text::LevenshteinXS qw(distance); +# TODO Geo::Distance is kinda deprecated, it is recommended to use GIS::Distance +# instead. However, since GIS::Distance is not packaged for Debian, I'll stick +# with Geo::Distance for now (which works fine enough here) + # TODO switch to Text::Levenshtein::XS once AUR/Debian packages become available our $VERSION = '1.05'; @@ -8487,6 +8492,26 @@ sub get_station { return get_station_by_name($name); } +sub get_stations_by_location { + my ($lon, $lat, $num_matches) = @_; + + $num_matches //= 10; + + my $geo = Geo::Distance->new(); + + # we only use geolocations inside germany. + # For these, this fast preprocessing step will let through all + # coordinates inside a 60km radius (and a bunch which are farther out) + my @candidates = grep { $#{$_} >= 4 and abs($_->[3] - $lon) < 1 and abs($_->[4] - $lat) < 1 } @stations; + my @distances = map { $geo->distance('kilometer', $lon, $lat, $_->[3], $_->[4]) } @candidates; + my @station_map = pairwise { [ $a, $b ] } @candidates, @distances; + + @station_map = sort { $a->[1] <=> $b->[1] } @station_map; + splice(@station_map, 10); + + return @station_map; +} + sub get_station_by_name { my ($name) = @_; |