From 1e04f049b101d8250b8964dd0b465e703d03a4c2 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Fri, 10 May 2024 17:13:53 +0200 Subject: space time diagrams: real time & time zones --- lib/Server/Frontend.hs | 2 +- lib/Server/Frontend/SpaceTime.hs | 197 ++++++++++++++++++++++++++++----------- lib/Server/Frontend/Tickets.hs | 65 +++++++------ 3 files changed, 178 insertions(+), 86 deletions(-) (limited to 'lib') diff --git a/lib/Server/Frontend.hs b/lib/Server/Frontend.hs index 3beb9e0..cec4fa7 100644 --- a/lib/Server/Frontend.hs +++ b/lib/Server/Frontend.hs @@ -5,8 +5,8 @@ module Server.Frontend (Frontend(..), Handler) where import Server.Frontend.Gtfs import Server.Frontend.OnboardUnit import Server.Frontend.Routes -import Server.Frontend.Tickets import Server.Frontend.SpaceTime +import Server.Frontend.Tickets import Yesod import Yesod.Auth diff --git a/lib/Server/Frontend/SpaceTime.hs b/lib/Server/Frontend/SpaceTime.hs index 307e795..878a627 100644 --- a/lib/Server/Frontend/SpaceTime.hs +++ b/lib/Server/Frontend/SpaceTime.hs @@ -1,104 +1,189 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -module Server.Frontend.SpaceTime (getSpaceTimeDiagramR) where +module Server.Frontend.SpaceTime (getSpaceTimeDiagramR, mkSpaceTimeDiagram, mkSpaceTimeDiagramHandler) where -import Server.Frontend.Routes +import Server.Frontend.Routes +import Control.Monad (forM, when) +import Data.Coerce (coerce) +import Data.Function (on, (&)) import Data.Functor ((<&>)) +import Data.Graph (path) +import Data.List import qualified Data.Map as M +import Data.Maybe (catMaybes, mapMaybe) import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (Day, UTCTime (..), getCurrentTime) import qualified Data.Vector as V +import Debug.Trace (trace) +import Fmt ((+|), (|+)) +import GHC.Float (double2Int, int2Double) +import GTFS (Seconds (unSeconds)) import qualified GTFS +import Persist +import Server.Util (getTzseries) import Text.Blaze.Html (Html) -import qualified Data.Text as T +import Text.Read (readMaybe) import Yesod -import Text.Read (readMaybe) -import Data.Time (getCurrentTime, UTCTime (..)) -import Persist -import Data.Function ((&), on) -import Data.List -import Data.Coerce (coerce) -import Control.Monad (when, forM) -import GHC.Float (int2Double) -import Fmt ((|+), (+|)) -import Data.Maybe (catMaybes, mapMaybe) -import GTFS (Seconds(unSeconds)) getSpaceTimeDiagramR :: Handler Html getSpaceTimeDiagramR = do - req <- getRequest - day <- case lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) of - Just day -> pure day + Just day -> pure day Nothing -> liftIO $ getCurrentTime <&> utctDay - tickets <- runDB $ selectList [ TicketDay ==. day ] [] >>= mapM (\ticket -> do - stops <- selectList [StopTicket ==. entityKey ticket] [] - pure (ticket, stops)) - - - -- TODO: this should be a nicer error message - when (null tickets) - notFound + mkSpaceTimeDiagramHandler day >>= \case + Nothing -> notFound + Just widget -> defaultLayout [whamlet| +

_{MsgSpaceTimeDiagram} +
+ ^{widget} + |] +mkSpaceTimeDiagramHandler :: Day -> Handler (Maybe Widget) +mkSpaceTimeDiagramHandler day = do + tickets <- runDB $ selectList [ TicketDay ==. day ] [] >>= mapM (\ticket -> do + stops <- selectList [StopTicket ==. entityKey ticket] [] >>= mapM (\(Entity _ stop@Stop{..}) -> do + arrival <- lift $ timeToPos day stopArrival + departure <- lift $ timeToPos day stopDeparture + pure (stop, arrival, departure)) + anchors <- selectList [TrainAnchorTicket ==. entityKey ticket] [Desc TrainAnchorSequence] + pure (ticket, stops, anchors)) + + case tickets of + [] -> + pure Nothing + _ -> + mkSpaceTimeDiagram day tickets + <&> Just + +-- | Safety: tickets may not be empty +mkSpaceTimeDiagram + :: Day + -> [(a, [(Stop, Double, Double)], [Entity TrainAnchor])] + -> Handler Widget +mkSpaceTimeDiagram day tickets = do -- we take the longest trip of the day. This will lead to unreasonable results -- if there's more than one shape (this whole route should probably take a shape id tbh) - stations <- runDB $ fmap snd tickets - & maximumBy (compare `on` length) - & fmap entityVal - & sortOn stopSequence - & mapM (\stop -> do - s <- getJust (stopStation stop) - pure (stopStation stop, s, stop)) + stations <- runDB $ fmap (\(_,stops,_) -> stops) tickets + & maximumBy (compare `on` length) + & fmap (\(stop, _, _) -> stop) + & sortOn stopSequence + & zip [0..] + & mapM (\(idx, stop) -> do + s <- getJust (stopStation stop) + pure (stopStation stop, s, stop { stopSequence = idx })) let maxSequence = stopSequence ((\(_,_,stop) -> stop) (last stations)) - let scaleSequence a = int2Double a * 100 / int2Double maxSequence + let scaleSequence a = a * 100 / int2Double maxSequence - let (minY, maxY) = tickets - <&> snd + + (minY, maxY) <- tickets + <&> (\(_,stops,_) -> stops) & concat - <&> (timeToPos . stopDeparture . entityVal) - & (\ys -> (minimum ys - 20, maximum ys + 20)) + & mapM (timeToPos day . stopDeparture . (\(stop, _, _) -> stop)) + <&> (\ys -> (minimum ys - 10, maximum ys + 30)) + + let timezone = head stations + & (\(_,_,stop) -> stop) + & stopArrival + & GTFS.tzname - defaultLayout $ do - [whamlet| -

_{MsgSpaceTimeDiagram} + timeLines <- ([0,3600..(24*3600)] + & mapM ((\a -> timeToPos day a <&> (,a)) . \seconds -> GTFS.Time seconds timezone)) + <&> takeWhile ((< maxY - 20) . fst) . filter ((> minY) . fst) -
+ pure [whamlet| + + + -- horizontal lines per hour + $forall (y, time) <- timeLines + + + #{time} + + -- vertical lines per station $forall (_, station, Stop{..}) <- stations - + #{stationName station} - $forall (ticket, stops) <- tickets + + -- static (scheduled) trip routes + $forall (ticket, stops, anchors) <- tickets + + |] - |] - -mkStopsline :: (Int -> Double) -> [(StationId, Station, Stop)] -> [Entity Stop] -> Text +mkStopsline :: (Double -> Double) -> [(StationId, Station, Stop)] -> [(Stop, Double, Double)] -> Text mkStopsline scaleSequence stations stops = stops - <&> (mkStop . entityVal) + <&> mkStop & T.concat - where mkStop stop = " "+|scaleSequence s|+","+|timeToPos (stopArrival stop)|+" " - +|scaleSequence s|+","+|timeToPos (stopDeparture stop)|+"" + where mkStop (stop, arrival, departure) = + " "+|scaleSequence s|+","+|arrival|+" " + +|scaleSequence s|+","+|departure|+"" where s = mapMaybe (\(stationId, _, res) -> if stationId == stopStation stop then Just res else Nothing) stations & head & stopSequence + & int2Double + +mkAnchorline :: (Double -> Double) -> [(StationId, Station, Stop)] -> [Entity TrainAnchor] -> Text +mkAnchorline scaleSequence stations anchors = anchors + <&> (mkAnchor . entityVal) + & T.concat + where mkAnchor anchor = + " "+|scaleSequence (transSequence (trainAnchorSequence anchor))|+"," + -- this use of secondsToPos is correct; when saves in the correct timezone already + +|secondsToPos (trainAnchorWhen anchor)|+"" + where transSequence :: Double -> Double + transSequence a = int2Double (mapSequence lastStop) + percent + where percent = abs (a - int2Double (stopSequence lastStop)) + / abs (int2Double (stopSequence lastStop - stopSequence nextStop)) + + mapSequence :: Stop -> Int + mapSequence stop = mapMaybe + (\(stationId, _, res) -> + if stationId == stopStation stop then Just res else Nothing) stations + & head + & stopSequence + lastStop = (\(_,_,stop) -> stop) (stations !! lastIndex) + nextStop = (\(_,_,stop) -> stop) (stations !! (lastIndex + 1)) + lastIndex = if + | rounded < 0 -> 0 + | rounded > length stations - 1 -> length stations - 2 + | otherwise -> rounded + where rounded = floor (trainAnchorSequence anchor) + + +-- TODO: these ignore time zones! +secondsToPos :: Seconds -> Double +secondsToPos = (/ 600) . int2Double . GTFS.unSeconds + --- TODO: ignores time zones! -timeToPos = (\a -> a / 500) . int2Double . GTFS.timeSeconds --- timeToPos time = unSeconds $ GTFS.toSeconds time _ _ +timeToPos :: Day -> GTFS.Time -> Handler Double +timeToPos day time = do + settings <- getYesod <&> getSettings + tzseries <- liftIO $ getTzseries settings (GTFS.tzname time) + pure $ secondsToPos (GTFS.toSeconds time tzseries day) diff --git a/lib/Server/Frontend/Tickets.hs b/lib/Server/Frontend/Tickets.hs index 43f24aa..ef80d42 100644 --- a/lib/Server/Frontend/Tickets.hs +++ b/lib/Server/Frontend/Tickets.hs @@ -15,39 +15,41 @@ module Server.Frontend.Tickets import Server.Frontend.Routes -import Config (ServerConfig (..), UffdConfig (..)) -import Control.Monad (forM, forM_, join) -import Control.Monad.Extra (maybeM) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Data.Coerce (coerce) -import Data.Function (on, (&)) -import Data.Functor ((<&>)) -import Data.List (lookup, nubBy) -import Data.List.NonEmpty (nonEmpty) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (catMaybes, fromJust, isJust) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time (UTCTime (..), addDays, - getCurrentTime, utctDay) -import Data.Time.Calendar (Day) -import Data.Time.Format.ISO8601 (iso8601Show) -import Data.UUID (UUID) -import qualified Data.UUID as UUID -import qualified Data.Vector as V -import Extrapolation (Extrapolator (..), - LinearExtrapolator (..)) -import Fmt ((+|), (|+)) -import GHC.Float (int2Double) +import Config (ServerConfig (..), UffdConfig (..)) +import Control.Monad (forM, forM_, join) +import Control.Monad.Extra (maybeM) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Coerce (coerce) +import Data.Function (on, (&)) +import Data.Functor ((<&>)) +import Data.List (lookup, nubBy) +import Data.List.NonEmpty (nonEmpty) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (catMaybes, fromJust, isJust) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time (UTCTime (..), addDays, + getCurrentTime, utctDay) +import Data.Time.Calendar (Day) +import Data.Time.Format.ISO8601 (iso8601Show) +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import qualified Data.Vector as V +import Extrapolation (Extrapolator (..), + LinearExtrapolator (..)) +import Fmt ((+|), (|+)) +import GHC.Float (int2Double) import qualified GTFS -import Numeric (showFFloat) +import Numeric (showFFloat) import Persist -import Server.Util (Service, secondsNow) -import Text.Read (readMaybe) +import Server.Frontend.SpaceTime (mkSpaceTimeDiagram, + mkSpaceTimeDiagramHandler) +import Server.Util (Service, secondsNow) +import Text.Read (readMaybe) import Yesod import Yesod.Auth -import Yesod.Auth.Uffd (UffdUser (..), uffdClient) +import Yesod.Auth.Uffd (UffdUser (..), uffdClient) getTicketsR :: Handler Html @@ -61,6 +63,8 @@ getTicketsR = do Just day -> (day, day == today) Nothing -> (today, True) + maybeSpaceTime <- mkSpaceTimeDiagramHandler day + let prevday = (T.pack . iso8601Show . addDays (-1)) day let nextday = (T.pack . iso8601Show . addDays 1) day gtfs <- getYesod <&> getGtfs @@ -94,6 +98,9 @@ $maybe name <- mdisplayname : _{Msgdep} #{stopDeparture (head stops)} #{stationName startStation} → #{ticketHeadsign} $if null tickets
  • (_{MsgNone}) +$maybe spaceTime <- maybeSpaceTime +
    + ^{spaceTime}

    _{MsgAccordingToGtfs}
    -- cgit v1.2.3