From 0c05c14574ed301c1f80ceeb5edabc34e47feffb Mon Sep 17 00:00:00 2001 From: stuebinm Date: Tue, 16 Jan 2024 01:41:34 +0100 Subject: [PATCH] support for platform sections well this blew the query up .. it attempts to do two things: - find platform sections grouped under platform_edges (important if platform sections of adjacent tracks don't line up) - if that fails, find any platforms somewhere under the whole platform object This should (hopefully) cover most cases where platform sections are actually mapped at all. --- app/Main.hs | 74 +++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 60 insertions(+), 14 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 6712c62..3ec2cac 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -10,13 +11,13 @@ import qualified Data.ByteString.Lazy as LB import Data.Char import Data.Csv hiding (lookup) import Data.Either -import Data.Function ((&)) +import Data.Function (on, (&)) import Data.Functor ((<&>)) import Data.FuzzySet.Simple import Data.List hiding (find) import Data.Map (Map) import qualified Data.Map as M -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Ord import Data.Text (Text) import qualified Data.Text as T @@ -62,11 +63,14 @@ findStationName query set = case sorted of maybeHbf = filter (T.isInfixOf "Hbf" . snd) sorted data Platform = Platform - { osmType :: Text - , osmId :: Text - , ref :: Maybe Text - , localRef :: Maybe Text - , osmLevel :: Maybe Text + { osmType :: Text + , osmId :: Text + , ref :: Maybe Text + , localRef :: Maybe Text + , osmLevel :: Maybe Text + , osmPlatform :: Maybe Text + , osmSection :: Maybe Text + , osmPlatformEdge :: Maybe Text } deriving Show instance FromRecord Platform where @@ -76,7 +80,10 @@ instance FromRecord Platform where v .! 1 <*> v .! 2 <*> v .! 3 <*> - (v .! 4 <|> v .! 5) + (v .! 4 <|> v .! 5) <*> + v .! 6 <*> + v .! 7 <*> + v .! 8 data Answer = Redirect Text @@ -150,13 +157,37 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse) | now `diffUTCTime` age < cacheTime && segment /= "fetch" -> pure answer _ -> do let overpassQuery = " \ - \[out:csv(::type, ::id, ref, local_ref, level, layer;false)][timeout:25];\n\ + \[out:csv(::type, ::id, ref, local_ref, level, layer, platform, section, track;false)][timeout:25];\n\ \nwr[~\"railway:ref|railway:ref:parent\"~\"^"<>encodeUtf8 (unRil100 ril100)<>"$\"][operator~\"^(DB|Deutsch)\"];\n\ \(._;rel[public_transport~\"stop_area|stop_area_group\"](bn);) -> .a;\n\ \rel[public_transport~\"stop_area|stop_area_group\"](br.a) -> .b;\n\ \(.a;.b;);\n\ \nwr[railway=platform](>>);\n\ - \out;\n" + \foreach {\n\ + \ ._ -> .a;\n\ + \ out tags;\n\ + \ >> -> .p;\n\ + \ nwr.p[\"railway\"=\"platform_edge\"][\"ref\"] -> .edges;\n\ + \ if (edges.count(nwr) == 0) {\n\ + \ >>;\n\ + \ node._[\"railway:platform:section\"] -> ._;\n\ + \ convert node platform = a.u(id()),\n\ + \ section = t[\"railway:platform:section\"],\n\ + \ ::id = id();\n\ + \ out tags;\n\ + \ } else { \n\ + \ foreach.edges {\n\ + \ ._ -> .b;\n\ + \ >>;\n\ + \ node._[\"railway:platform:section\"] -> ._;\n\ + \ convert node platform = a.u(id()),\n\ + \ section = t[\"railway:platform:section\"],\n\ + \ track = b.u(t[\"ref\"]),\n\ + \ ::id = id();\n\ + \ out tags;\n\ + \ }\n\ + \ }\n\ + \}\n" let req = "https://overpass-api.de/api/interpreter" { Client.requestBody = Client.RequestBodyBS overpassQuery , Client.method = "POST"} @@ -167,9 +198,8 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse) Right (platforms :: Vector Platform) -> do let answer = V.toList platforms & sortOn (maybe (0::Int) (fromRight 0 . fmap fst . T.signed T.decimal) . osmLevel) - <&> renderPlatform + <&> renderPlatform platforms & (Html . T.concat) - now <- getCurrentTime atomically $ do cache <- readTVar platformCache writeTVar platformCache (M.insert ril100 (now, answer) cache) @@ -178,9 +208,25 @@ app AppData{..} request respond = mkAnswer >>= (respond . toResponse) getRef (Just ref) _ = Just ref getRef Nothing (Just ref) = Just ref getRef _ _ = Nothing - renderPlatform Platform{..} = case getRef ref localRef of - Just ref -> "osmType<>"/"<>osmId<>"\">"<>ref<>"
" + renderPlatform others p = case getRef (ref p) (localRef p) of + Just ref -> mkAnchor p ref<>""<>renderedSections<>"
" Nothing -> "" + where sectionGroups = others + & V.filter ((== Just (osmId p)) . osmPlatform) + & V.toList + & groupBy ((==) `on` osmPlatformEdge) + renderSectionGroup sections = if null sections then "" else sections + & sortOn osmSection + & mapMaybe (\p -> case osmSection p of Just s -> Just (mkAnchor p s) ; _ -> Nothing) + & intersperse "," + & ((osmPlatformEdge (head sections) & \case {Nothing -> ""; Just a -> a<>": "}) :) + & T.concat + renderedSections = if null sectionGroups then "" else sectionGroups + <&> renderSectionGroup + & (": " :) + & T.intercalate " " + mkAnchor p inner = + "osmType p<>"/"<>osmId p<>"\">"<>inner<>"" _ -> pure Notfound queriedRil100 :: Text -> MatchResult Ril100 Text queriedRil100 query = if