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.
This commit is contained in:
stuebinm 2024-01-16 01:41:34 +01:00
parent df9319f8a0
commit 0c05c14574

View file

@ -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
@ -67,6 +68,9 @@ data Platform = Platform
, 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 -> "<a href=\"https://osm.org/"<>osmType<>"/"<>osmId<>"\">"<>ref<>"</a><br>"
renderPlatform others p = case getRef (ref p) (localRef p) of
Just ref -> mkAnchor p ref<>"</a>"<>renderedSections<>"<br>"
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 =
"<a href=\"https://osm.org/"<>osmType p<>"/"<>osmId p<>"\">"<>inner<>"</a>"
_ -> pure Notfound
queriedRil100 :: Text -> MatchResult Ril100 Text
queriedRil100 query = if